diff --git a/6.1.7/patches/01_fix_Sybase_conf.patch b/6.1.7/patches/01_fix_Sybase_conf.patch
new file mode 100644
index 0000000000000000000000000000000000000000..6e06e201adc0835b4b93fbf23a7ba55f604af092
--- /dev/null
+++ b/6.1.7/patches/01_fix_Sybase_conf.patch
@@ -0,0 +1,21 @@
+diff --git sympa-6.1.3-src/src/etc/script/create_db.Sybase sympa-6.1.4-src/src/etc/script/create_db.Sybase
+index 30f84af..7b337f6 100644
+--- sympa-6.1.3-src/src/etc/script/create_db.Sybase
++++ sympa-6.1.4-src/src/etc/script/create_db.Sybase
+@@ -216,11 +216,12 @@ CREATE TABLE bulkspool_table (
+
+ create index messagekey_bulkspool_fk on bulkspool_table (messagekey_bulkspool)
+ go
+-create table conf_tabl
+
++create table conf_table (
+ robot_conf varchar(80) not null
+ label_conf varchar(80) not null
+ value_conf varchar(300) null
+- constraint ind_conf primary key (robot_conf, label_conf
++ constraint ind_conf primary key (robot_conf, label_conf)
++)
++go
+
+-go
+\ No newline at end of file
diff --git a/6.1.7/patches/02_list_db_caching b/6.1.7/patches/02_list_db_caching
new file mode 100644
index 0000000000000000000000000000000000000000..ab9341498dbc51759a51ba7c216f396eb3566dce
--- /dev/null
+++ b/6.1.7/patches/02_list_db_caching
@@ -0,0 +1,29760 @@
+diff --git a/sympa-6.1.7-src/src/etc/script/create_db.Oracle b/sympa-6.1.7-src/src/etc/script/create_db.Oracle
+index a425718..388fd7d 100644
+--- a/sympa-6.1.7-src/src/etc/script/create_db.Oracle
++++ b/sympa-6.1.7-src/src/etc/script/create_db.Oracle
+@@ -163,4 +163,20 @@ CREATE TABLE conf_table (
+ CONSTRAINT ind_conf primary key (robot_conf,label_conf)
+ );
+
++CREATE TABLE list_table (
++ name_list varchar(100) NOT NULL,
++ path_list varchar(100) NOT NULL,
++ robot_list varchar(100) NOT NULL,
++ status_list enum('open','closed','pending','error_config','family_closed') NOT NULL,
++ creation_email_list varchar(100) NOT NULL,
++ creation_epoch_list datetime ,
++ subject_list varchar(100) NOT NULL,
++ web_archive_list tinyint(1) NOT NULL,
++ topics_list varchar(100) NOT NULL,
++ editors_list varchar(100) NOT NULL,
++ owners_list varchar(100) NOT NULL,
++ CONSTRAINT ind_list PRIMARY KEY (name_list,robot_list)
++);
++
++
+ !
+diff --git a/sympa-6.1.7-src/src/etc/script/create_db.Pg b/sympa-6.1.7-src/src/etc/script/create_db.Pg
+index 3893c6e..5c890a2 100644
+--- a/sympa-6.1.7-src/src/etc/script/create_db.Pg
++++ b/sympa-6.1.7-src/src/etc/script/create_db.Pg
+@@ -177,4 +177,22 @@ CREATE TABLE conf_table (
+ value_conf varchar(300),
+ constraint ind_conf primary key (robot_conf,label_conf)
+ );
+-CREATE INDEX robot_conf_idx ON conf_table(robot_conf,label_conf);
+\ No newline at end of file
++CREATE INDEX robot_conf_idx ON conf_table(robot_conf,label_conf);
++
++DROP TABLE list_table;
++CREATE TABLE list_table (
++ name_list varchar(100) NOT NULL,
++ path_list varchar(100) NOT NULL,
++ robot_list varchar(100) NOT NULL,
++ status_list enum('open','closed','pending','error_config','family_closed') NOT NULL,
++ creation_email_list varchar(100) NOT NULL,
++ creation_epoch_list datetime ,
++ subject_list varchar(100) NOT NULL,
++ web_archive_list tinyint(1) NOT NULL,
++ topics_list varchar(100) NOT NULL,
++ owners_list varchar(100) NOT NULL,
++ editors_list varchar(100) NOT NULL,
++ CONSTRAINT ind_list PRIMARY KEY (name_list,robot_list)
++);
++CREATE INDEX list_idx ON list_table(name_list, robot_list);
++
+diff --git a/sympa-6.1.7-src/src/etc/script/create_db.SQLite b/sympa-6.1.7-src/src/etc/script/create_db.SQLite
+index 00ed639..e3c221d 100644
+--- a/sympa-6.1.7-src/src/etc/script/create_db.SQLite
++++ b/sympa-6.1.7-src/src/etc/script/create_db.SQLite
+@@ -156,3 +156,20 @@ CREATE TABLE conf_table (
+ PRIMARY KEY (robot_conf,label_conf)
+ );
+ CREATE INDEX conf_idx ON conf_table(robot_conf,label_conf);
++
++CREATE TABLE list_table (
++ name_list varchar(100) NOT NULL,
++ path_list varchar(100) NOT NULL,
++ robot_list varchar(100) NOT NULL,
++ status_list enum('open','closed','pending','error_config','family_closed') NOT NULL,
++ creation_email_list varchar(100) NOT NULL,
++ creation_epoch_list datetime ,
++ subject_list varchar(100) NOT NULL,
++ web_archive_list tinyint(1) NOT NULL,
++ topics_list varchar(100) NOT NULL,
++ owners_list varchar(100) NOT NULL,
++ editors_list varchar(100) NOT NULL,
++ CONSTRAINT ind_list PRIMARY KEY (name_list,robot_list)
++);
++CREATE INDEX list_idx ON list_table(name_list, robot_list);
++
+diff --git a/sympa-6.1.7-src/src/etc/script/create_db.Sybase b/sympa-6.1.7-src/src/etc/script/create_db.Sybase
+index 7b337f6..615e2bc 100644
+--- a/sympa-6.1.7-src/src/etc/script/create_db.Sybase
++++ b/sympa-6.1.7-src/src/etc/script/create_db.Sybase
+@@ -225,3 +225,22 @@ create table conf_table (
+ )
+ go
+
++CREATE TABLE list_table (
++ name_list varchar(100) NOT NULL,
++ path_list varchar(100) NOT NULL,
++ robot_list varchar(100) NOT NULL,
++ status_list enum('open','closed','pending','error_config','family_closed') NOT NULL,
++ creation_email_list varchar(100) NOT NULL,
++ creation_epoch_list datetime ,
++ subject_list varchar(100) NOT NULL,
++ web_archive_list tinyint(1) NOT NULL,
++ topics_list varchar(100) NOT NULL,
++ editors_list varchar(100) NOT NULL,
++ owners_list varchar(100) NOT NULL,
++ CONSTRAINT ind_list PRIMARY KEY (name_list,robot_list)
++)
++go
++
++CREATE INDEX id_list_fk ON list_table(name_list, robot_list)
++go
++
+diff --git a/sympa-6.1.7-src/src/etc/script/create_db.mysql b/sympa-6.1.7-src/src/etc/script/create_db.mysql
+index 3a178c2..f998b65 100644
+--- a/sympa-6.1.7-src/src/etc/script/create_db.mysql
++++ b/sympa-6.1.7-src/src/etc/script/create_db.mysql
+@@ -158,3 +158,19 @@ CREATE TABLE conf_table (
+ value_conf varchar(300) default NULL,
+ PRIMARY KEY (robot_conf,label_conf)
+ );
++
++CREATE TABLE list_table (
++ name_list varchar(100) NOT NULL default '',
++ path_list varchar(100) NOT NULL default '',
++ robot_list varchar(100) NOT NULL default '',
++ status_list enum('open','closed','pending','error_config','family_closed') NOT NULL default 'closed',
++ creation_email_list varchar(100) NOT NULL default '',
++ creation_epoch_list datetime default NULL,
++ subject_list varchar(100) NOT NULL default '',
++ web_archive_list tinyint(1) NOT NULL default '0',
++ topics_list varchar(100) NOT NULL default '',
++ editors_list varchar(100) NOT NULL default '',
++ owners_list varchar(100) NOT NULL default '',
++ PRIMARY KEY (name_list,robot_list)
++);
++
+diff --git a/sympa-6.1.7-src/src/lib/Conf.pm b/sympa-6.1.7-src/src/lib/Conf.pm
+index b8f3c27..22f2b53 100644
+--- a/sympa-6.1.7-src/src/lib/Conf.pm
++++ b/sympa-6.1.7-src/src/lib/Conf.pm
+@@ -200,6 +200,10 @@ sub load {
+ unless (defined $o{'tmpdir'}) {
+ $o{'tmpdir'}[0] = "$spool/tmp";
+ }
++ unless (defined $o{'db_list_cache'}){
++ $o{'db_list_cache'}[0] = 0;
++ }
++
+
+ ## Check if we have unknown values.
+ foreach $i (sort keys %o) {
+diff --git a/sympa-6.1.7-src/src/lib/List.pm b/sympa-6.1.7-src/src/lib/List.pm
+index e59a489..0283a80 100644
+--- a/sympa-6.1.7-src/src/lib/List.pm
++++ b/sympa-6.1.7-src/src/lib/List.pm
+@@ -1914,6 +1914,12 @@ sub save_config {
+ return undef;
+ }
+
++ if ($List::use_db) {
++ unless (&_update_list_db) {
++ &do_log('err', "Unable to update list_table");
++ }
++ }
++
+ return 1;
+ }
+
+@@ -7159,6 +7165,7 @@ sub rename_list_db {
+
+ my $statement_subscriber;
+ my $statement_admin;
++ my $statement_list_cache;
+
+ ## Check database connection
+ unless ($dbh and $dbh->ping) {
+@@ -7191,6 +7198,21 @@ sub rename_list_db {
+ do_log('err','Unable to execute SQL statement "%s" : %s', $statement_admin, $dbh->errstr);
+ return undef;
+ }
++
++ if ($List::use_db) {
++ $statement_admin = sprintf "UPDATE list_table SET name_list=%s, robot_list=%s WHERE (name_list=%s AND robot_list=%s)",
++ $dbh->quote($new_listname),
++ $dbh->quote($new_robot),
++ $dbh->quote($self->{'name'}),
++ $dbh->quote($self->{'domain'}) ;
++
++ do_log('debug', 'List::rename_list_db statement : %s', $statement_admin );
++
++ unless ($dbh->do($statement_admin)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement_admin, $dbh->errstr);
++ return undef;
++ }
++ }
+
+ return 1;
+ }
+@@ -9792,6 +9814,7 @@ sub get_lists {
+ my $robot_context = shift || '*';
+ my $options = shift;
+ my $requested_lists = shift; ## Optional parameter to load only a subset of all lists
++ my $use_files = shift;
+
+ my(@lists, $l,@robots);
+ do_log('debug2', 'List::get_lists(%s)',$robot_context);
+@@ -9827,7 +9850,13 @@ sub get_lists {
+ if ( defined($requested_lists)){
+ @files = sort @{$requested_lists};
+ }else {
+- @files = sort readdir(DIR);
++ if ($use_files) {
++ @files = sort readdir(DIR);
++ }else {
++ # get list names from list config table
++ my $files = &get_lists_db('SELECT name_list FROM list_table');
++ @files = @{$files};
++ }
+ }
+
+ foreach my $l (@files) {
+@@ -12243,6 +12272,139 @@ sub get_list_id {
+ return $self->{'name'}.'@'.$self->{'domain'};
+ }
+
++## Support for list config caching in database
++
++sub get_lists_db {
++ my $statement = shift;
++ return undef unless defined($statement);
++ do_log('info', 'List::get_search_list_db(%s)', $statement);
++
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ my ($l, @lists);
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++ push @sth_stack, $sth;
++ &do_log('debug2','SQL: %s', $statement);
++ unless ($sth = $dbh->prepare($statement)) {
++ &do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++ while ($l = $sth->fetchrow_hashref) {
++ my $name = $l->{'name_list'};
++ push @lists, $name;
++ }
++ $sth->finish();
++ $sth = pop @sth_stack;
++
++ return \@lists;
++}
++
++sub _update_list_db
++{
++ my ($self) = shift;
++ my @admins;
++ my $i;
++ my $adm_txt;
++ my $ed_txt;
++ my $statement = sprintf "SELECT COUNT(*) FROM list_table WHERE name_list = %s AND robot_list = %s" , $dbh->quote($self->{'name'}), $dbh->quote($self->{'admin'}{'host'});
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++ my $ret;
++ unless ($sth->execute) {
++ do_log('err',"Unable to execute SQL statement '%s' : %s", $statement, $dbh->errstr);
++ return undef;
++ }
++
++ my $op = "UPDATE";
++ my $set = "";
++ my $ret = $sth->fetchrow_arrayref;
++ $sth->finish;
++ my $count = $ret->[0];
++ unless ($count > 0) {
++ $op = "INSERT INTO";
++ $set = "";
++ }
++ my $name = $self->{'name'};
++ my $subject = $self->{'admin'}{'subject'} || '';
++ my $status = $self->{'admin'}{'status'};
++ my $robot = $self->{'admin'}{'host'};
++ my $web_archive = &is_web_archived($self) || 0;
++ my $topics = '';
++ if ($self->{'admin'}{'topics'}) {
++ $topics = join(',',@{$self->{'admin'}{'topics'}});
++ }
++
++ foreach $i (@{$self->{'admin'}{'owner'}}) {
++ if (ref($i->{'email'})) {
++ push(@admins, @{$i->{'email'}});
++ } elsif ($i->{'email'}) {
++ push(@admins, $i->{'email'});
++ }
++ }
++ $adm_txt = join(',',@admins) || '';
++
++ undef @admins;
++ foreach $i (@{$self->{'admin'}{'editor'}}) {
++ if (ref($i->{'email'})) {
++ push(@admins, @{$i->{'email'}});
++ } elsif ($i->{'email'}) {
++ push(@admins, $i->{'email'});
++ }
++ }
++ $ed_txt = join(',',@admins) || '';
++ my $statement = sprintf "%s `list_table` %s SET status_list= %s, name_list=%s, robot_list=%s, subject_list=%s, web_archive_list=%s, topics_list=%s, owners_list=%s, editors_list=%s ",
++ $op, $set, $dbh->quote($status), $dbh->quote($name),
++ $dbh->quote($robot), $dbh->quote($subject),
++ $dbh->quote($web_archive), $dbh->quote($topics),
++ $dbh->quote($adm_txt),$dbh->quote($ed_txt);
++
++ if ($op eq "UPDATE") {
++ $statement .= sprintf " WHERE robot_list = %s AND name_list = %s ", $dbh->quote($robot), $dbh->quote($name);
++ }
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ }
++ return 1;
++}
++
++sub _flush_list_db
++{
++ my ($listname) = shift;
++ my $statement;
++ unless ($listname) {
++ $statement = "TRUNCATE list_table";
++ } else {
++ $statement = sprintf "DELETE FROM list_table WHERE name_list = %s", $dbh->quote($listname);
++ }
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++ unless ($sth->execute) {
++ do_log('err',"Unable to execute SQL statement '%s' : %s", $statement, $dbh->errstr);
++ return undef;
++ }
++}
++
+ ###### END of the List package ######
+
+ 1;
+diff --git a/sympa-6.1.7-src/src/lib/List.pm.orig b/sympa-6.1.7-src/src/lib/List.pm.orig
+new file mode 100644
+index 0000000..e59a489
+--- /dev/null
++++ b/sympa-6.1.7-src/src/lib/List.pm.orig
+@@ -0,0 +1,12248 @@
++# list.pm - This module includes all list processing functions
++# RCS Identication ; $Revision: 7009 $ ; $Date: 2011-02-02 15:28:39 +0100 (mer 02 fév 2011) $
++#
++# Sympa - SYsteme de Multi-Postage Automatique
++# Copyrigh (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
++# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
++#
++# This program is free software; you can redistribute it and/or modify
++# it under the terms of the GNU General Public License as published by
++# the Free Software Foundation; either version 2 of the License, or
++# (at your option) any later version.
++#
++# This program is distributed in the hope that it will be useful,
++# but WITHOUT ANY WARRANTY; without even the implied warranty of
++# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++# GNU General Public License for more details.
++#
++# You should have received a copy of the GNU General Public License# along with this program; if not, write to the Free Software
++# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
++
++package List;
++
++use strict;
++
++use POSIX qw(strftime);
++use Fcntl qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN);
++use Encode;
++
++use Datasource;
++use SQLSource qw(create_db %date_format);
++use Upgrade;
++use Lock;
++use Task;
++use Scenario;
++use Fetch;
++use WebAgent;
++use Exporter;
++use tt2;
++use Sympa::Constants;
++use tools;
++
++our @ISA = qw(Exporter);
++our @EXPORT = qw(%list_of_lists);
++
++
++=head1 CONSTRUCTOR
++
++=item new( [PHRASE] )
++
++ List->new();
++
++Creates a new object which will be used for a list and
++eventually loads the list if a name is given. Returns
++a List object.
++
++=back
++
++=head1 METHODS
++
++=over 4
++
++=item load ( LIST )
++
++Loads the indicated list into the object.
++
++=item save ( LIST )
++
++Saves the indicated list object to the disk files.
++
++=item savestats ()
++
++Saves updates the statistics file on disk.
++
++=item update_stats( BYTES )
++
++Updates the stats, argument is number of bytes, returns the next
++sequence number. Does nothing if no stats.
++
++=item send_sub_to_owner ( WHO, COMMENT )
++Send a message to the list owners telling that someone
++wanted to subscribe to the list.
++
++=item send_to_editor ( MSG )
++
++Send a Mail::Internet type object to the editor (for approval).
++
++=item send_msg ( MSG )
++
++Sends the Mail::Internet message to the list.
++
++=item send_file ( FILE, USER, GECOS )
++
++Sends the file to the USER. FILE may only be welcome for now.
++
++=item delete_user ( ARRAY )
++
++Delete the indicated users from the list.
++
++=item delete_admin_user ( ROLE, ARRAY )
++
++Delete the indicated admin user with the predefined role from the list.
++
++=item get_cookie ()
++
++Returns the cookie for a list, if available.
++
++=item get_max_size ()
++
++Returns the maximum allowed size for a message.
++
++=item get_reply_to ()
++
++Returns an array with the Reply-To values.
++
++=item get_default_user_options ()
++
++Returns a default option of the list for subscription.
++
++=item get_total ()
++
++Returns the number of subscribers to the list.
++
++=item get_user_db ( USER )
++
++Returns a hash with the information regarding the indicated
++user.
++
++=item get_subscriber ( USER )
++
++Returns a subscriber of the list.
++
++=item get_admin_user ( ROLE, USER)
++
++Return an admin user of the list with predefined role
++
++=item get_first_user ()
++
++Returns a hash to the first user on the list.
++
++=item get_first_admin_user ( ROLE )
++
++Returns a hash to the first admin user with predefined role on the list.
++
++=item get_next_user ()
++
++Returns a hash to the next users, until we reach the end of
++the list.
++
++=item get_next_admin_user ()
++
++Returns a hash to the next admin users, until we reach the end of
++the list.
++
++=item update_user ( USER, HASHPTR )
++
++Sets the new values given in the hash for the user.
++
++=item update_admin_user ( USER, ROLE, HASHPTR )
++
++Sets the new values given in the hash for the admin user.
++
++=item add_user ( USER, HASHPTR )
++
++Adds a new user to the list. May overwrite existing
++entries.
++
++=item add_admin_user ( USER, ROLE, HASHPTR )
++
++Adds a new admin user to the list. May overwrite existing
++entries.
++
++=item is_user ( USER )
++
++Returns true if the indicated user is member of the list.
++
++=item am_i ( FUNCTION, USER )
++
++Returns true is USER has FUNCTION (owner, editor) on the
++list.
++
++=item get_state ( FLAG )
++
++Returns the value for a flag : sig or sub.
++
++=item may_do ( ACTION, USER )
++
++Chcks is USER may do the ACTION for the list. ACTION can be
++one of following : send, review, index, getm add, del,
++reconfirm, purge.
++
++=item is_moderated ()
++
++Returns true if the list is moderated.
++
++=item archive_exist ( FILE )
++
++Returns true if the indicated file exists.
++
++=item archive_send ( WHO, FILE )
++
++Send the indicated archive file to the user, if it exists.
++
++=item archive_ls ()
++
++Returns the list of available files, if any.
++
++=item archive_msg ( MSG )
++
++Archives the Mail::Internet message given as argument.
++
++=item is_archived ()
++
++Returns true is the list is configured to keep archives of
++its messages.
++
++=item get_stats ( OPTION )
++
++Returns either a formatted printable strings or an array whith
++the statistics. OPTION can be 'text' or 'array'.
++
++=item print_info ( FDNAME )
++
++Print the list information to the given file descriptor, or the
++currently selected descriptor.
++
++=cut
++
++use Carp;
++
++use IO::Scalar;
++use Storable;
++use Mail::Header;
++use Archive;
++use Language;
++use Log;
++use Conf;
++use mail;
++use Ldap;
++use Time::Local;
++use MIME::Entity;
++use MIME::EncWords;
++use MIME::Parser;
++use Message;
++use Family;
++use PlainDigest;
++
++
++## Database and SQL statement handlers
++my ($dbh, $sth, $db_connected, @sth_stack, $use_db);
++
++my %list_cache;
++
++## DB fields with numeric type
++## We should not do quote() for these while inserting data
++my %numeric_field = ('cookie_delay_user' => 1,
++ 'bounce_score_subscriber' => 1,
++ 'subscribed_subscriber' => 1,
++ 'included_subscriber' => 1,
++ 'subscribed_admin' => 1,
++ 'included_admin' => 1,
++ 'wrong_login_count' => 1,
++ );
++
++## List parameters defaults
++my %default = ('occurrence' => '0-1',
++ 'length' => 25
++ );
++
++my @param_order = qw (subject visibility info subscribe add unsubscribe del owner owner_include
++ send editor editor_include delivery_time account topics
++ host lang web_archive archive digest digest_max_size available_user_options
++ default_user_options msg_topic msg_topic_keywords_apply_on msg_topic_tagging reply_to_header reply_to forced_reply_to *
++ verp_rate welcome_return_path remind_return_path merge_feature user_data_source include_file include_remote_file
++ include_list include_remote_sympa_list include_ldap_query
++ include_ldap_2level_query include_sql_query include_admin ttl distribution_ttl creation update
++ status serial custom_attribute);
++
++## List parameters aliases
++my %alias = ('reply-to' => 'reply_to',
++ 'replyto' => 'reply_to',
++ 'forced_replyto' => 'forced_reply_to',
++ 'forced_reply-to' => 'forced_reply_to',
++ 'custom-subject' => 'custom_subject',
++ 'custom-header' => 'custom_header',
++ 'subscription' => 'subscribe',
++ 'unsubscription' => 'unsubscribe',
++ 'max-size' => 'max_size');
++
++##############################################################
++## This hash COMPLETELY defines ALL list parameters
++## It is then used to load, save, view, edit list config files
++##############################################################
++## List parameters format accepts the following keywords :
++## format : Regexp aplied to the configuration file entry;
++## some common regexps are defined in %regexp
++## file_format : Config file format of the parameter might not be
++## the same in memory
++## split_char: Character used to separate multiple parameters
++## length : Length of a scalar variable ; used in web forms
++## scenario : tells that the parameter is a scenario, providing its name
++## default : Default value for the param ; may be a configuration parameter (conf)
++## synonym : Defines synonyms for parameter values (for compatibility reasons)
++## gettext_unit :Unit of the parameter ; this is used in web forms and refers to translated
++## strings in PO catalogs
++## occurrence : Occurerence of the parameter in the config file
++## possible values: 0-1 | 1 | 0-n | 1-n
++## example : a list may have multiple owner
++## gettext_id : Title reference in NLS catalogues
++## description : deescription text of a parameter
++## group : Group of parameters
++## obsolete : Obsolete parameter ; should not be displayed
++## nor saved
++## obsolete_values : defined obsolete values for a parameter
++## these values should not get proposed on the web interface edition form
++## order : Order of parameters within paragraph
++## internal : Indicates that the parameter is an internal parameter
++## that should always be saved in the config file
++## field_type : used to select passwords web input type
++###############################################################
++%::pinfo = ('account' => {'format' => '\S+',
++ 'length' => 10,
++ 'gettext_id' => "Account",
++ 'group' => 'other'
++ },
++ 'add' => {'scenario' => 'add',
++ 'gettext_id' => "Who can add subscribers",
++ 'group' => 'command'
++ },
++ 'anonymous_sender' => {'format' => '.+',
++ 'gettext_id' => "Anonymous sender",
++ 'group' => 'sending'
++ },
++ 'archive' => {'format' => {'period' => {'format' => ['day','week','month','quarter','year'],
++ 'synonym' => {'weekly' => 'week'},
++ 'gettext_id' => "frequency",
++ 'order' => 1
++ },
++ 'access' => {'format' => ['open','private','public','owner','closed'],
++ 'synonym' => {'open' => 'public'},
++ 'gettext_id' => "access right",
++ 'order' => 2
++ }
++ },
++ 'gettext_id' => "Text archives",
++ 'group' => 'archives'
++ },
++ 'archive_crypted_msg' => {'format' => ['original','decrypted'],
++ 'default' => 'original',
++ 'gettext_id' => "Archive encrypted mails as cleartext",
++ 'group' => 'archives'
++ },
++ 'available_user_options' => {'format' => {'reception' => {'format' => ['mail','notice','digest','digestplain','summary','nomail','txt','html','urlize','not_me'],
++ 'occurrence' => '1-n',
++ 'split_char' => ',',
++ 'default' => 'mail,notice,digest,digestplain,summary,nomail,txt,html,urlize,not_me',
++ 'gettext_id' => "reception mode"
++ },
++ },
++ 'gettext_id' => "Available subscription options",
++ 'group' => 'sending'
++ },
++
++ 'bounce' => {'format' => {'warn_rate' => {'format' => '\d+',
++ 'length' => 3,
++ 'gettext_unit' => '%',
++ 'default' => {'conf' => 'bounce_warn_rate'},
++ 'gettext_id' => "warn rate",
++ 'order' => 1
++ },
++ 'halt_rate' => {'format' => '\d+',
++ 'length' => 3,
++ 'gettext_unit' => '%',
++ 'default' => {'conf' => 'bounce_halt_rate'},
++ 'gettext_id' => "halt rate",
++ 'order' => 2
++ }
++ },
++ 'gettext_id' => "Bounces management",
++ 'group' => 'bounces'
++ },
++ 'bouncers_level1' => {'format' => {'rate' => {'format' => '\d+',
++ 'length' => 2,
++ 'gettext_unit' => 'points',
++ 'default' => {'conf' => 'default_bounce_level1_rate'},
++ 'gettext_id' => "threshold",
++ 'order' => 1
++ },
++ 'action' => {'format' => ['remove_bouncers','notify_bouncers','none'],
++ 'default' => 'notify_bouncers',
++ 'gettext_id' => "action for this population",
++ 'order' => 2
++ },
++ 'notification' => {'format' => ['none','owner','listmaster'],
++ 'default' => 'owner',
++ 'gettext_id' => "notification",
++ 'order' => 3
++ }
++ },
++ 'gettext_id' => "Management of bouncers, 1st level",
++ 'group' => 'bounces'
++ },
++ 'bouncers_level2' => {'format' => {'rate' => {'format' => '\d+',
++ 'length' => 2,
++ 'gettext_unit' => 'points',
++ 'default' => {'conf' => 'default_bounce_level2_rate'},
++ 'gettext_id' => "threshold",
++ 'order' => 1
++ },
++ 'action' => {'format' => ['remove_bouncers','notify_bouncers','none'],
++ 'default' => 'remove_bouncers',
++ 'gettext_id' => "action for this population",
++ 'order' => 2
++ },
++ 'notification' => {'format' => ['none','owner','listmaster'],
++ 'default' => 'owner',
++ 'gettext_id' => "notification",
++ 'order' => 3
++ }
++ },
++ 'gettext_id' => "Management of bouncers, 2nd level",
++ 'group' => 'bounces'
++ },
++ 'clean_delay_queuemod' => {'format' => '\d+',
++ 'length' => 3,
++ 'gettext_unit' => 'days',
++ 'default' => {'conf' => 'clean_delay_queuemod'},
++ 'gettext_id' => "Expiration of unmoderated messages",
++ 'group' => 'other'
++ },
++ 'cookie' => {'format' => '\S+',
++ 'length' => 15,
++ 'default' => {'conf' => 'cookie'},
++ 'gettext_id' => "Secret string for generating unique keys",
++ 'group' => 'other'
++ },
++ 'creation' => {'format' => {'date_epoch' => {'format' => '\d+',
++ 'occurrence' => '1',
++ 'gettext_id' => "epoch date",
++ 'order' => 3
++ },
++ 'date' => {'format' => '.+',
++ 'gettext_id' => "human readable",
++ 'order' => 2
++ },
++ 'email' => {'format' => 'listmaster|'.&tools::get_regexp('email'),
++ 'occurrence' => '1',
++ 'gettext_id' => "who created the list",
++ 'order' => 1
++ }
++ },
++ 'gettext_id' => "Creation of the list",
++ 'occurrence' => '0-1',
++ 'internal' => 1,
++ 'group' => 'other'
++
++ },
++ 'custom_attribute' => {
++ 'format' => {
++ 'id' => {
++ 'format' => '\w+',
++ 'length' => 20,
++ 'gettext_id' => "internal identifier",
++ 'occurrence' => '1',
++ 'order' =>1
++ },
++ 'name' => {
++ 'format' => '.+',
++ 'length' =>30,
++ 'occurrence' => '1',
++ 'gettext_id' => "label",
++ 'order' => 2
++ },
++ 'comment' => {
++ 'format' => '.+',
++ 'length' => 100,
++ 'gettext_id' => "additional comment",
++ 'order' => 3
++ },
++ 'type' => {
++ 'format' => ['string','text','integer','enum'],
++ 'default' => 'string',
++ 'occurence' => 1,
++ 'gettext_id' => "type",
++ 'order' => 4
++ },
++ 'enum_values' => {
++ 'format' => '.+',
++ 'length' => 100,
++ 'gettext_id' => "possible attribute values (if enum is used)",
++ 'order' => 5
++ },
++ 'optional' => {
++ 'format' => ['required','optional'],
++ 'gettext_id' => "is the attribute optional?",
++ 'order' => 6
++ }
++
++ },
++ 'occurrence' => '0-n',
++ 'gettext_id' => "Custom user attributes",
++ 'group' => 'other'
++ },
++ 'custom_header' => {'format' => '\S+:\s+.*',
++ 'length' => 30,
++ 'occurrence' => '0-n',
++ 'gettext_id' => "Custom header field",
++ 'group' => 'sending'
++ },
++ 'custom_subject' => {'format' => '.+',
++ 'length' => 15,
++ 'gettext_id' => "Subject tagging",
++ 'group' => 'sending'
++ },
++ 'custom_vars' => {'format' => {'name' => {'format' => '\S+',
++ 'occurrence' => '1',
++ 'gettext_id' => 'var name',
++ 'order' => 1
++ },
++ 'value' => {'format' => '\S+',
++ 'occurrence' => '1',
++ 'gettext_id' => 'var value',
++ 'order' => 2
++ }
++ },
++ 'gettext_id' => "custom parameters",
++ 'occurrence' => '0-n',
++ 'group' => 'other'
++ },
++
++ 'default_user_options' => {'format' => {'reception' => {'format' => ['digest','digestplain','mail','nomail','summary','notice','txt','html','urlize','not_me'],
++ 'default' => 'mail',
++ 'gettext_id' => "reception mode",
++ 'order' => 1
++ },
++ 'visibility' => {'format' => ['conceal','noconceal'],
++ 'default' => 'noconceal',
++ 'gettext_id' => "visibility",
++ 'order' => 2
++ }
++ },
++ 'gettext_id' => "Subscription profile",
++ 'group' => 'sending'
++ },
++ 'del' => {'scenario' => 'del',
++ 'gettext_id' => "Who can delete subscribers",
++ 'group' => 'command'
++ },
++ 'delivery_time' => {'format' => '[0-2]?\d\:[0-6]\d',
++ 'length' => 5,
++ 'gettext_id' => "Delivery time (hh:mm)",
++ 'occurrence' => '0-1',
++ 'group' => 'sending'
++ },
++ 'digest' => {'file_format' => '\d+(\s*,\s*\d+)*\s+\d+:\d+',
++ 'format' => {'days' => {'format' => [0..6],
++ 'file_format' => '1|2|3|4|5|6|7',
++ 'occurrence' => '1-n',
++ 'gettext_id' => "days",
++ 'order' => 1
++ },
++ 'hour' => {'format' => '\d+',
++ 'length' => 2,
++ 'occurrence' => '1',
++ 'gettext_id' => "hour",
++ 'order' => 2
++ },
++ 'minute' => {'format' => '\d+',
++ 'length' => 2,
++ 'occurrence' => '1',
++ 'gettext_id' => "minute",
++ 'order' => 3
++ }
++ },
++ 'gettext_id' => "Digest frequency",
++ 'group' => 'sending'
++ },
++
++ 'digest_max_size' => {'format' => '\d+',
++ 'length' => 2,
++ 'gettext_unit' => 'messages',
++ 'default' => 25,
++ 'gettext_id' => "Digest maximum number of messages",
++ 'group' => 'sending'
++ },
++
++ 'distribution_ttl' => {'format' => '\d+',
++ 'length' => 6,
++ 'gettext_unit' => 'seconds',
++ 'default' => {'conf' => 'default_distribution_ttl'},
++ 'gettext_id' => "Inclusions timeout for message distribution",
++ 'group' => 'data_source'
++ },
++
++ 'dkim_feature' => {'format' => ['on','off'],
++ 'occurence' => '0-1',
++ 'default' => {'conf' => 'dkim_feature'},
++ 'gettext_id' => "Insert DKIM signature to messages sent to the list",
++ 'comment' => "Enable/Disable DKIM. This feature require Mail::DKIM to installed and may be some custom scenario to be updated",
++ 'group' => 'dkim',
++ },
++ 'dkim_signature_apply_on'=> {'format' => ['md5_authenticated_messages','smime_authenticated_messages','dkim_authenticated_messages','editor_validated_messages','none','any'],
++ 'occurrence' => '0-n',
++ 'split_char' => ',',
++ 'default' => {'conf' => 'dkim_signature_apply_on'},
++ 'gettext_id' => "The categories of messages sent to the list that will be signed using DKIM.",
++ 'comment' => "This parameter controls in which case messages must be signed using DKIM, you may sign every message choosing 'any' or a subset. The parameter value is a comma separated list of keywords",
++ 'group' => 'dkim',
++ },
++ 'dkim_parameters'=> {'format' => {'private_key_path'=> {'format' => '\S+',
++ 'occurence' => '0-1',
++ 'default' => {'conf' => 'dkim_private_key_path'},
++ 'gettext_id' => "File path for list DKIM private key",
++ 'comment' => "The file must contain a RSA pem encoded private key",
++ 'order' => 1
++ },
++ 'selector' => { 'format' => '\S+',
++ 'occurence' => '0-1',
++ 'default' => {'conf' => 'dkim_selector'},
++ 'comment' => "The selector is used in order to build the DNS query for public key. It is up to you to choose the value you want but verify that you can query the public DKIM key for <selector>._domainkey.your_domain",
++ 'gettext_id' => "Selector for DNS lookup of DKIM public key",
++ 'order' => 2
++ },
++
++ 'header_list'=> { 'format' => '\S+',
++ 'occurence' => '0-1',
++ 'default' => {'conf' => 'dkim_header_list'},
++ 'gettext_id' => 'List of headers to be included ito the message for signature',
++ 'comment' => 'You should probably use teh default value which is the value recommended by RFC4871',
++ 'order' => 4
++ },
++ 'signer_domain' => {'format' => '\S+',
++ 'occurence' => '0-1',
++ 'default' => {'conf' => 'dkim_signer_domain'},
++ 'gettext_id' => 'DKIM "d=" tag, you should probably use the default value',
++ 'omment' => ' The DKIM "d=" tag, is the domain of the signing entity. the list domain MUST must be included in the "d=" domain',
++ 'order' => 5
++ },
++ 'signer_identity'=> {'format' => '\S+',
++ 'occurence' => '0-1',
++ 'comment' => 'DKIM "i=" tag, you should probably not use this parameter, as recommended by RFC 4871, default for list brodcasted messages is i=<listname>-request@<domain>',
++ 'gettext_id' => 'DKIM "i=" tag, you should probably leave this parameter empty',
++ 'order' => 6
++ },
++ },
++ 'group' => 'dkim',
++ 'comment' => 'A set of parameters in order to define outgoing DKIM signature',
++ 'occurrence' => '0-1',
++ 'gettext_id' => "DKIM configuration",
++ },
++
++ 'editor' => {'format' => {'email' => {'format' => &tools::get_regexp('email'),
++ 'length' => 30,
++ 'occurrence' => '1',
++ 'gettext_id' => "email address",
++ 'order' => 1
++ },
++ 'reception' => {'format' => ['mail','nomail'],
++ 'default' => 'mail',
++ 'gettext_id' => "reception mode",
++ 'order' => 4
++ },
++ 'visibility' => {'format' => ['conceal','noconceal'],
++ 'default' => 'noconceal',
++ 'gettext_id' => "visibility",
++ 'order' => 5
++ },
++ 'gecos' => {'format' => '.+',
++ 'length' => 30,
++ 'gettext_id' => "name",
++ 'order' => 2
++ },
++ 'info' => {'format' => '.+',
++ 'length' => 30,
++ 'gettext_id' => "private information",
++ 'order' => 3
++ }
++ },
++ 'occurrence' => '0-n',
++ 'gettext_id' => "Moderators",
++ 'group' => 'description'
++ },
++ 'editor_include' => {'format' => {'source' => {'datasource' => 1,
++ 'occurrence' => '1',
++ 'gettext_id' => 'the data source',
++ 'order' => 1
++ },
++ 'source_parameters' => {'format' => '.*',
++ 'occurrence' => '0-1',
++ 'gettext_id' => 'data source parameters',
++ 'order' => 2
++ },
++ 'reception' => {'format' => ['mail','nomail'],
++ 'default' => 'mail',
++ 'gettext_id' => 'reception mode',
++ 'order' => 3
++ },
++ 'visibility' => {'format' => ['conceal','noconceal'],
++ 'default' => 'noconceal',
++ 'gettext_id' => "visibility",
++ 'order' => 5
++ }
++
++ },
++ 'occurrence' => '0-n',
++ 'gettext_id' => 'Moderators defined in an external data source',
++ 'group' => 'description',
++ },
++ 'expire_task' => {'task' => 'expire',
++ 'gettext_id' => "Periodical subscription expiration task",
++ 'group' => 'other'
++ },
++ 'family_name' => {'format' => &tools::get_regexp('family_name'),
++ 'occurrence' => '0-1',
++ 'gettext_id' => 'Family name',
++ 'internal' => 1,
++ 'group' => 'description'
++ },
++ 'footer_type' => {'format' => ['mime','append'],
++ 'default' => 'mime',
++ 'gettext_id' => "Attachment type",
++ 'group' => 'sending'
++ },
++ 'forced_reply_to' => {'format' => '\S+',
++ 'gettext_id' => "Forced reply address",
++ 'obsolete' => 1
++ },
++ 'host' => {'format' => &tools::get_regexp('host'),
++ 'length' => 20,
++ 'default' => {'conf' => 'host'},
++ 'gettext_id' => "Internet domain",
++ 'group' => 'description'
++ },
++ 'include_file' => {'format' => '\S+',
++ 'length' => 20,
++ 'occurrence' => '0-n',
++ 'gettext_id' => "File inclusion",
++ 'group' => 'data_source'
++ },
++ 'include_remote_file' => {'format' => {'url' => {'format' => '.+',
++ 'gettext_id' => "data location URL",
++ 'occurrence' => '1',
++ 'length' => 50,
++ 'order' => 2
++ },
++ 'user' => {'format' => '.+',
++ 'gettext_id' => "remote user",
++ 'order' => 3,
++ 'occurrence' => '0-1'
++ },
++ 'passwd' => {'format' => '.+',
++ 'length' => 10,
++ 'field_type' => 'password',
++ 'gettext_id' => "remote password",
++ 'order' => 4,
++ 'occurrence' => '0-1'
++ },
++ 'name' => {'format' => '.+',
++ 'gettext_id' => "short name for this source",
++ 'length' => 15,
++ 'order' => 1
++ }
++ },
++ 'gettext_id' => "Remote file inclusion",
++ 'occurrence' => '0-n',
++ 'group' => 'data_source'
++ },
++ 'include_ldap_query' => {'format' => {'host' => {'format' => &tools::get_regexp('multiple_host_with_port'),
++ 'occurrence' => '1',
++ 'gettext_id' => "remote host",
++ 'order' => 2
++ },
++ 'port' => {'format' => '\d+',
++ 'length' => 4,
++ 'gettext_id' => "remote port",
++ 'obsolete' => 1,
++ 'order' => 2
++ },
++ 'user' => {'format' => '.+',
++ 'gettext_id' => "remote user",
++ 'order' => 3
++ },
++ 'passwd' => {'format' => '.+',
++ 'length' => 10,
++ 'field_type' => 'password',
++ 'gettext_id' => "remote password",
++ 'order' => 3
++ },
++ 'suffix' => {'format' => '.+',
++ 'gettext_id' => "suffix",
++ 'order' => 4
++ },
++ 'filter' => {'format' => '.+',
++ 'length' => 50,
++ 'occurrence' => '1',
++ 'gettext_id' => "filter",
++ 'order' => 7
++ },
++ 'attrs' => {'format' => '\w+',
++ 'length' => 15,
++ 'default' => 'mail',
++ 'gettext_id' => "extracted attribute",
++ 'order' => 8
++ },
++ 'select' => {'format' => ['all','first'],
++ 'default' => 'first',
++ 'gettext_id' => "selection (if multiple)",
++ 'order' => 9
++ },
++ 'scope' => {'format' => ['base','one','sub'],
++ 'default' => 'sub',
++ 'gettext_id' => "search scope",
++ 'order' => 5
++ },
++ 'timeout' => {'format' => '\w+',
++ 'default' => 30,
++ 'gettext_unit' => 'seconds',
++ 'gettext_id' => "connection timeout",
++ 'order' => 6
++ },
++ 'name' => {'format' => '.+',
++ 'gettext_id' => "short name for this source",
++ 'length' => 15,
++ 'order' => 1
++ },
++ 'use_ssl' => {'format' => ['yes','no'],
++ 'default' => 'no',
++ 'gettext_id' => 'use SSL (LDAPS)',
++ 'order' => 2.5,
++ },
++ 'ssl_version' => {'format' => ['sslv2','sslv3','tls'],
++ 'default' => 'sslv3',
++ 'gettext_id' => 'SSL version',
++ 'order' => 2.5,
++ },
++ 'ssl_ciphers' => {'format' => '.+',
++ 'default' => 'ALL',
++ 'gettext_id' => 'SSL ciphers used',
++ 'order' => 2.5,
++ },
++
++
++
++ },
++ 'occurrence' => '0-n',
++ 'gettext_id' => "LDAP query inclusion",
++ 'group' => 'data_source'
++ },
++ 'include_ldap_2level_query' => {'format' => {'host' => {'format' => &tools::get_regexp('multiple_host_with_port'),
++ 'occurrence' => '1',
++ 'gettext_id' => "remote host",
++ 'order' => 1
++ },
++ 'port' => {'format' => '\d+',
++ 'length' => 4,
++ 'gettext_id' => "remote port",
++ 'obsolete' => 1,
++ 'order' => 2
++ },
++ 'user' => {'format' => '.+',
++ 'gettext_id' => "remote user",
++ 'order' => 3
++ },
++ 'passwd' => {'format' => '.+',
++ 'length' => 10,
++ 'field_type' => 'password',
++ 'gettext_id' => "remote password",
++ 'order' => 3
++ },
++ 'suffix1' => {'format' => '.+',
++ 'gettext_id' => "first-level suffix",
++ 'order' => 4
++ },
++ 'filter1' => {'format' => '.+',
++ 'length' => 50,
++ 'occurrence' => '1',
++ 'gettext_id' => "first-level filter",
++ 'order' => 7
++ },
++ 'attrs1' => {'format' => '\w+',
++ 'length' => 15,
++ 'gettext_id' => "first-level extracted attribute",
++ 'order' => 8
++ },
++ 'select1' => {'format' => ['all','first','regex'],
++ 'default' => 'first',
++ 'gettext_id' => "first-level selection",
++ 'order' => 9
++ },
++ 'scope1' => {'format' => ['base','one','sub'],
++ 'default' => 'sub',
++ 'gettext_id' => "first-level search scope",
++ 'order' => 5
++ },
++ 'timeout1' => {'format' => '\w+',
++ 'default' => 30,
++ 'gettext_unit' => 'seconds',
++ 'gettext_id' => "first-level connection timeout",
++ 'order' => 6
++ },
++ 'regex1' => {'format' => '.+',
++ 'length' => 50,
++ 'default' => '',
++ 'gettext_id' => "first-level regular expression",
++ 'order' => 10
++ },
++ 'suffix2' => {'format' => '.+',
++ 'gettext_id' => "second-level suffix template",
++ 'order' => 11
++ },
++ 'filter2' => {'format' => '.+',
++ 'length' => 50,
++ 'occurrence' => '1',
++ 'gettext_id' => "second-level filter template",
++ 'order' => 14
++ },
++ 'attrs2' => {'format' => '\w+',
++ 'length' => 15,
++ 'default' => 'mail',
++ 'gettext_id' => "second-level extracted attribute",
++ 'order' => 15
++ },
++ 'select2' => {'format' => ['all','first','regex'],
++ 'default' => 'first',
++ 'gettext_id' => "second-level selection",
++ 'order' => 16
++ },
++ 'scope2' => {'format' => ['base','one','sub'],
++ 'default' => 'sub',
++ 'gettext_id' => "second-level search scope",
++ 'order' => 12
++ },
++ 'timeout2' => {'format' => '\w+',
++ 'default' => 30,
++ 'gettext_unit' => 'seconds',
++ 'gettext_id' => "second-level connection timeout",
++ 'order' => 13
++ },
++ 'regex2' => {'format' => '.+',
++ 'length' => 50,
++ 'default' => '',
++ 'gettext_id' => "second-level regular expression",
++ 'order' => 17
++ },
++ 'name' => {'format' => '.+',
++ 'gettext_id' => "short name for this source",
++ 'length' => 15,
++ 'order' => 1
++ },
++ 'use_ssl' => {'format' => ['yes','no'],
++ 'default' => 'no',
++ 'gettext_id' => 'use SSL (LDAPS)',
++ 'order' => 2.5,
++ },
++ 'ssl_version' => {'format' => ['sslv2','sslv3','tls'],
++ 'default' => '',
++ 'gettext_id' => 'SSL version',
++ 'order' => 2.5,
++ },
++ 'ssl_ciphers' => {'format' => '.+',
++ 'default' => 'ALL',
++ 'gettext_id' => 'SSL ciphers used',
++ 'order' => 2.5,
++ },
++
++ },
++ 'occurrence' => '0-n',
++ 'gettext_id' => "LDAP 2-level query inclusion",
++ 'group' => 'data_source'
++ },
++ 'include_list' => {'format' => &tools::get_regexp('listname').'(\@'.&tools::get_regexp('host').')?',
++ 'occurrence' => '0-n',
++ 'gettext_id' => "List inclusion",
++ 'group' => 'data_source'
++ },
++ 'include_remote_sympa_list' => {'format' => {'host' => {'format' => &tools::get_regexp('host'),
++ 'occurrence' => '1',
++ 'gettext_id' => "remote host",
++ 'order' => 1
++ },
++ 'port' => {'format' => '\d+',
++ 'default' => 443,
++ 'length' => 4,
++ 'gettext_id' => "remote port",
++ 'order' => 2
++ },
++ 'path' => {'format' => '\S+',
++ 'length' => 20,
++ 'occurrence' => '1',
++ 'gettext_id' => "remote path of sympa list dump",
++ 'order' => 3
++
++ },
++ 'cert' => {'format' => ['robot','list'],
++ 'gettext_id' => "certificate for authentication by remote Sympa",
++ 'default' => 'list',
++ 'order' => 4
++ },
++ 'name' => {'format' => '.+',
++ 'gettext_id' => "short name for this source",
++ 'length' => 15,
++ 'order' => 1
++ }
++ },
++
++ 'occurrence' => '0-n',
++ 'gettext_id' => "remote list inclusion",
++ 'group' => 'data_source'
++ },
++ 'include_sql_query' => {'format' => {'db_type' => {'format' => '\S+',
++ 'occurrence' => '1',
++ 'gettext_id' => "database type",
++ 'order' => 1
++ },
++ 'host' => {'format' => &tools::get_regexp('host'),
++ 'occurrence' => '1',
++ 'gettext_id' => "remote host",
++ 'order' => 2
++ },
++ 'db_port' => {'format' => '\d+',
++ 'gettext_id' => "database port",
++ 'order' => 3
++ },
++ 'db_name' => {'format' => '\S+',
++ 'occurrence' => '1',
++ 'gettext_id' => "database name",
++ 'order' => 4
++ },
++ 'connect_options' => {'format' => '.+',
++ 'gettext_id' => "connection options",
++ 'order' => 4
++ },
++ 'db_env' => {'format' => '\w+\=\S+(;\w+\=\S+)*',
++ 'order' => 5,
++ 'gettext_id' => "environment variables for database connection"
++ },
++ 'user' => {'format' => '\S+',
++ 'occurrence' => '1',
++ 'gettext_id' => "remote user",
++ 'order' => 6
++ },
++ 'passwd' => {'format' => '.+',
++ 'field_type' => 'password',
++ 'gettext_id' => "remote password",
++ 'order' => 7
++ },
++ 'sql_query' => {'format' => &tools::get_regexp('sql_query'),
++ 'length' => 50,
++ 'occurrence' => '1',
++ 'gettext_id' => "SQL query",
++ 'order' => 8
++ },
++ 'f_dir' => {'format' => '.+',
++ 'gettext_id' => "Directory where the database is stored (used for DBD::CSV only)",
++ 'order' => 9
++ },
++ 'name' => {'format' => '.+',
++ 'gettext_id' => "short name for this source",
++ 'length' => 15,
++ 'order' => 1
++ }
++
++ },
++ 'occurrence' => '0-n',
++ 'gettext_id' => "SQL query inclusion",
++ 'group' => 'data_source'
++ },
++ 'inclusion_notification_feature' => {'format' => ['on','off'],
++ 'occurence' => '0-1',
++ 'default' => 'off',
++ 'gettext_id' => "Notify subscribers when they are included from a data source?",
++ 'group' => 'data_source',
++ },
++ 'info' => {'scenario' => 'info',
++ 'gettext_id' => "Who can view list information",
++ 'group' => 'command'
++ },
++ 'invite' => {'scenario' => 'invite',
++ 'gettext_id' => "Who can invite people",
++ 'group' => 'command'
++ },
++ 'lang' => {'format' => [], ## &Language::GetSupportedLanguages() called later
++ 'file_format' => '\w+',
++ 'default' => {'conf' => 'lang'},
++ 'gettext_id' => "Language of the list",
++ 'group' => 'description'
++ },
++ 'latest_instantiation' => {'format' => {'date_epoch' => {'format' => '\d+',
++ 'occurrence' => '1',
++ 'gettext_id' => 'epoch date',
++ 'order' => 3
++ },
++ 'date' => {'format' => '.+',
++ 'gettext_id' => 'date',
++ 'order' => 2
++ },
++ 'email' => {'format' => 'listmaster|'.&tools::get_regexp('email'),
++ 'occurrence' => '0-1',
++ 'gettext_id' => 'who ran the instantiation',
++ 'order' => 1
++ }
++ },
++ 'gettext_id' => 'Latest family instantiation',
++ 'internal' => 1,
++ 'group' => 'other'
++ },
++ 'loop_prevention_regex' => {'format' => '\S*',
++ 'length' => 70,
++ 'default' => {'conf' => 'loop_prevention_regex'},
++ 'gettext_id' => "Regular expression applied to prevent loops with robots",
++ 'group' => 'other'
++ },
++ 'max_size' => {'format' => '\d+',
++ 'length' => 8,
++ 'gettext_unit' => 'bytes',
++ 'default' => {'conf' => 'max_size'},
++ 'gettext_id' => "Maximum message size",
++ 'group' => 'sending'
++ },
++ 'msg_topic' => {'format' => {'name' => {'format' => '[\-\w]+',
++ 'length' => 15,
++ 'occurrence' => '1',
++ 'gettext_id' => "Message topic name",
++ 'order' => 1
++ },
++ 'keywords' => {'format' => '[^,\n]+(,[^,\n]+)*',
++ 'occurrence' => '0-1',
++ 'gettext_id' => "Message topic keywords",
++ 'order' => 2
++ },
++ 'title' => {'format' => '.+',
++ 'length' => 35,
++ 'occurrence' => '1',
++ 'gettext_id' => "Message topic title",
++ 'order' => 3
++ }
++ },
++ 'occurrence' => '0-n',
++ 'gettext_id' => "Topics for message categorization",
++ 'group' => 'sending'
++ },
++ 'msg_topic_keywords_apply_on' => { 'format' => ['subject','body','subject_and_body'],
++ 'occurrence' => '0-1',
++ 'default' => 'subject',
++ 'gettext_id' => "Defines to which part of messages topic keywords are applied",
++ 'group' => 'sending'
++ },
++
++ 'msg_topic_tagging' => { 'format' => ['required_sender','required_moderator','optional'],
++ 'occurrence' => '0-1',
++ 'default' => 'optional',
++ 'gettext_id' => "Message tagging",
++ 'group' => 'sending'
++ },
++ 'owner' => {'format' => {'email' => {'format' => &tools::get_regexp('email'),
++ 'length' =>30,
++ 'occurrence' => '1',
++ 'gettext_id' => "email address",
++ 'order' => 1
++ },
++ 'reception' => {'format' => ['mail','nomail'],
++ 'default' => 'mail',
++ 'gettext_id' => "reception mode",
++ 'order' =>5
++ },
++ 'visibility' => {'format' => ['conceal','noconceal'],
++ 'default' => 'noconceal',
++ 'gettext_id' => "visibility",
++ 'order' => 6
++ },
++ 'gecos' => {'format' => '.+',
++ 'length' => 30,
++ 'gettext_id' => "name",
++ 'order' => 2
++ },
++ 'info' => {'format' => '.+',
++ 'length' => 30,
++ 'gettext_id' => "private information",
++ 'order' => 3
++ },
++ 'profile' => {'format' => ['privileged','normal'],
++ 'default' => 'normal',
++ 'gettext_id' => "profile",
++ 'order' => 4
++ }
++ },
++ 'occurrence' => '1-n',
++ 'gettext_id' => "Owner",
++ 'group' => 'description'
++ },
++ 'owner_include' => {'format' => {'source' => {'datasource' => 1,
++ 'occurrence' => '1',
++ 'gettext_id' => 'the datasource',
++ 'order' => 1
++ },
++ 'source_parameters' => {'format' => '.*',
++ 'occurrence' => '0-1',
++ 'gettext_id' => 'datasource parameters',
++ 'order' => 2
++ },
++ 'reception' => {'format' => ['mail','nomail'],
++ 'default' => 'mail',
++ 'gettext_id' => 'reception mode',
++ 'order' => 4
++ },
++ 'visibility' => {'format' => ['conceal','noconceal'],
++ 'default' => 'noconceal',
++ 'gettext_id' => "visibility",
++ 'order' => 5
++ },
++ 'profile' => {'format' => ['privileged','normal'],
++ 'default' => 'normal',
++ 'gettext_id' => 'profile',
++ 'order' => 3
++ }
++ },
++ 'occurrence' => '0-n',
++ 'gettext_id' => 'Owners defined in an external data source',
++ 'group' => 'description',
++ },
++ 'priority' => {'format' => [0..9,'z'],
++ 'length' => 1,
++ 'default' => {'conf' => 'default_list_priority'},
++ 'gettext_id' => "Priority",
++ 'group' => 'description'
++ },
++ 'reject_mail_from_automates_feature' => {'format' => ['on','off'],
++ 'occurence' => '0-1',
++ 'default' => {'conf' => 'reject_mail_from_automates_feature'},
++ 'gettext_id' => "Reject mail from automates (crontab, etc)?",
++ 'group' => 'sending'
++ },
++ 'remind' => {'scenario' => 'remind',
++ 'gettext_id' => "Who can start a remind process",
++ 'group' => 'command'
++ },
++ 'remind_return_path' => {'format' => ['unique','owner'],
++ 'default' => {'conf' => 'remind_return_path'},
++ 'gettext_id' => "Return-path of the REMIND command",
++ 'group' => 'bounces'
++ },
++ 'remind_task' => {'task' => 'remind',
++ 'gettext_id' => 'Periodical subscription reminder task',
++ 'default' => {'conf' => 'default_remind_task'},
++ 'group' => 'other'
++ },
++ 'remove_headers' => {'format' => '\S+',
++ 'gettext_id' => 'Incoming SMTP header fields to be removed',
++ 'default' => {'conf' => 'remove_headers'},
++ 'group' => 'sending',
++ 'occurrence' => '0-n',
++ 'split_char' => ',',
++ },
++ 'remove_outgoing_headers' => {'format' => '\S+',
++ 'gettext_id' => 'Outgoing SMTP header fields to be removed',
++ 'default' => {'conf' => 'remove_outgoing_headers'},
++ 'group' => 'sending',
++ 'occurrence' => '0-n',
++ 'split_char' => ',',
++ },
++ 'reply_to' => {'format' => '\S+',
++ 'default' => 'sender',
++ 'gettext_id' => "Reply address",
++ 'group' => 'sending',
++ 'obsolete' => 1
++ },
++ 'reply_to_header' => {'format' => {'value' => {'format' => ['sender','list','all','other_email'],
++ 'default' => 'sender',
++ 'gettext_id' => "value",
++ 'occurrence' => '1',
++ 'order' => 1
++ },
++ 'other_email' => {'format' => &tools::get_regexp('email'),
++ 'gettext_id' => "other email address",
++ 'order' => 2
++ },
++ 'apply' => {'format' => ['forced','respect'],
++ 'default' => 'respect',
++ 'gettext_id' => "respect of existing header field",
++ 'order' => 3
++ }
++ },
++ 'gettext_id' => "Reply address",
++ 'group' => 'sending'
++ },
++ 'review' => {'scenario' => 'review',
++ 'synonym' => {'open' => 'public'},
++ 'gettext_id' => "Who can review subscribers",
++ 'group' => 'command'
++ },
++ 'rfc2369_header_fields' => {'format' => ['help','subscribe','unsubscribe','post','owner','archive'],
++ 'default' => {'conf' => 'rfc2369_header_fields'},
++ 'occurrence' => '0-n',
++ 'split_char' => ',',
++ 'gettext_id' => "RFC 2369 Header fields",
++ 'group' => 'sending'
++ },
++ 'send' => {'scenario' => 'send',
++ 'gettext_id' => "Who can send messages",
++ 'group' => 'sending'
++ },
++ 'serial' => {'format' => '\d+',
++ 'default' => 0,
++ 'length' => 3,
++ 'default' => 0,
++ 'gettext_id' => "Serial number of the config",
++ 'internal' => 1,
++ 'group' => 'other'
++ },
++ 'shared_doc' => {'format' => {'d_read' => {'scenario' => 'd_read',
++ 'gettext_id' => "Who can view",
++ 'order' => 1
++ },
++ 'd_edit' => {'scenario' => 'd_edit',
++ 'gettext_id' => "Who can edit",
++ 'order' => 2
++ },
++ 'quota' => {'format' => '\d+',
++ 'default' => {'conf' => 'default_shared_quota'},
++ 'length' => 8,
++ 'gettext_unit' => 'Kbytes',
++ 'gettext_id' => "quota",
++ 'order' => 3
++ }
++ },
++ 'gettext_id' => "Shared documents",
++ 'group' => 'command'
++ },
++ 'spam_protection' => {'format' => ['at','javascript','none'],
++ 'default' => 'javascript',
++ 'gettext_id' => "email address protection method",
++ 'group' => 'other'
++ },
++ 'web_archive_spam_protection' => {'format' => ['cookie','javascript','at','none'],
++ 'default' => {'conf' => 'web_archive_spam_protection'},
++ 'gettext_id' => "email address protection method",
++ 'group' => 'archives'
++ },
++
++ 'status' => {'format' => ['open','closed','pending','error_config','family_closed'],
++ 'default' => 'open',
++ 'gettext_id' => "Status of the list",
++ 'internal' => 1,
++ 'group' => 'other'
++ },
++ 'sql_fetch_timeout' => {'format' => '\d+',
++ 'length' => 6,
++ 'gettext_unit' => 'seconds',
++ 'default' => {'conf' => 'default_sql_fetch_timeout'},
++ 'gettext_id' => "Timeout for fetch of include_sql_query",
++ 'group' => 'data_source'
++ },
++ 'subject' => {'format' => '.+',
++ 'length' => 50,
++ 'occurrence' => '1',
++ 'gettext_id' => "Subject of the list",
++ 'group' => 'description'
++ },
++ 'subscribe' => {'scenario' => 'subscribe',
++ 'gettext_id' => "Who can subscribe to the list",
++ 'group' => 'command'
++ },
++ 'topics' => {'format' => '[\-\w]+(\/[\-\w]+)?',
++ 'split_char' => ',',
++ 'occurrence' => '0-n',
++ 'gettext_id' => "Topics for the list",
++ 'group' => 'description'
++ },
++ 'ttl' => {'format' => '\d+',
++ 'length' => 6,
++ 'gettext_unit' => 'seconds',
++ 'default' => {'conf' => 'default_ttl'},
++ 'gettext_id' => "Inclusions timeout",
++ 'group' => 'data_source'
++ },
++ 'unsubscribe' => {'scenario' => 'unsubscribe',
++ 'gettext_id' => "Who can unsubscribe",
++ 'group' => 'command'
++ },
++ 'update' => {'format' => {'date_epoch' => {'format' => '\d+',
++ 'length' => 8,
++ 'occurrence' => '1',
++ 'gettext_id' => 'epoch date',
++ 'order' => 3
++ },
++ 'date' => {'format' => '.+',
++ 'length' => 30,
++ 'gettext_id' => 'date',
++ 'order' => 2
++ },
++ 'email' => {'format' => '(listmaster|automatic|'.&tools::get_regexp('email').')',
++ 'length' => 30,
++ 'occurrence' => '1',
++ 'gettext_id' => 'who updated the config',
++ 'order' => 1
++ }
++ },
++ 'gettext_id' => "Last update of config",
++ 'internal' => 1,
++ 'group' => 'other'
++ },
++ 'user_data_source' => {'format' => ['database','file','include','include2'],
++ 'default' => 'include2',
++ 'obsolete_values'=> ['database','file','include'],
++ 'gettext_id' => "User data source",
++ 'group' => 'data_source'
++ },
++ 'pictures_feature' => {'format' => ['on','off'],
++ 'occurence' => '0-1',
++ 'default' => {'conf' => 'pictures_feature'},
++ 'gettext_id' => "Allow picture display? (must be enabled for the current robot)",
++ 'group' => 'other'
++ },
++ 'merge_feature' => {'format' => ['on','off'],
++ 'occurence' => '0-1',
++ 'default' => {'conf' => 'merge_feature'},
++ 'gettext_id' => "Allow message personnalization",
++ 'group' => 'sending'
++ },
++ 'visibility' => {'scenario' => 'visibility',
++ 'synonym' => {'public' => 'noconceal',
++ 'private' => 'conceal'},
++ 'gettext_id' => "Visibility of the list",
++ 'group' => 'description'
++ },
++ 'web_archive' => {'format' => {'access' => {'scenario' => 'access_web_archive',
++ 'gettext_id' => "access right",
++ 'order' => 1
++ },
++ 'quota' => {'format' => '\d+',
++ 'default' => {'conf' => 'default_archive_quota'},
++ 'length' => 8,
++ 'gettext_unit' => 'Kbytes',
++ 'gettext_id' => "quota",
++ 'order' => 2
++ },
++ 'max_month' => {'format' => '\d+',
++ 'length' => 3,
++ 'gettext_id' => "Maximum number of month archived",
++ 'order' => 3
++ }
++ },
++
++ 'gettext_id' => "Web archives",
++ 'group' => 'archives'
++
++ },
++ 'welcome_return_path' => {'format' => ['unique','owner'],
++ 'default' => {'conf' => 'welcome_return_path'},
++ 'gettext_id' => "Welcome return-path",
++ 'group' => 'bounces'
++ },
++ 'verp_rate' => {'format' => ['100%','50%','33%','25%','20%','10%','5%','2%','0%'],
++ 'default' => {'conf' => 'verp_rate'},
++ 'gettext_id' => "percentage of list members in VERP mode",
++ 'group' => 'bounces'
++ },
++
++ );
++
++## This is the generic hash which keeps all lists in memory.
++my %list_of_lists = ();
++my %list_of_robots = ();
++our %list_of_topics = ();
++my %edit_list_conf = ();
++
++## Last modification times
++my %mtime;
++
++use Fcntl;
++use DB_File;
++
++$DB_BTREE->{compare} = \&_compare_addresses;
++
++## Connect to Database
++sub db_connect {
++ my $option = shift;
++
++ do_log('debug2', 'List::db_connect');
++
++ my $connect_string;
++
++ ## Check if already connected
++ if ($dbh && $dbh->ping()) {
++ &do_log('notice', 'List::db_connect(): Db handle already available');
++ return 1;
++ }
++
++ ## We keep trying to connect if this is the first attempt
++ ## Unless in a web context, because we can't afford long response time on the web interface
++ unless ( $dbh = &SQLSource::connect(\%Conf::Conf, {'keep_trying'=>($option ne 'just_try' && ( !$db_connected && !$ENV{'HTTP_HOST'})),
++ 'warn'=>1 } )) {
++ return undef;
++ }
++ do_log('debug3','Connected to Database %s',$Conf::Conf{'db_name'});
++ $db_connected = 1;
++
++ return 1;
++}
++
++## Disconnect from Database
++sub db_disconnect {
++ do_log('debug3', 'List::db_disconnect');
++
++ unless ($dbh->disconnect()) {
++ do_log('notice','Can\'t disconnect from Database %s : %s',$Conf::Conf{'db_name'}, $dbh->errstr);
++ return undef;
++ }
++
++ return 1;
++}
++
++## Get database handler
++sub db_get_handler {
++ do_log('debug3', 'List::db_get_handler');
++
++
++ return $dbh;
++}
++
++## Creates an object.
++sub new {
++ my($pkg, $name, $robot, $options) = @_;
++ my $list={};
++ do_log('debug2', 'List::new(%s, %s, %s)', $name, $robot, join('/',keys %$options));
++
++ ## Allow robot in the name
++ if ($name =~ /\@/) {
++ my @parts = split /\@/, $name;
++ $robot ||= $parts[1];
++ $name = $parts[0];
++ }
++
++ ## Look for the list if no robot was provided
++ $robot ||= &search_list_among_robots($name);
++
++ unless ($robot) {
++ &do_log('err', 'Missing robot parameter, cannot create list object for %s', $name) unless ($options->{'just_try'});
++ return undef;
++ }
++
++ $options = {} unless (defined $options);
++
++ ## Only process the list if the name is valid.
++ my $listname_regexp = &tools::get_regexp('listname');
++ unless ($name and ($name =~ /^$listname_regexp$/io) ) {
++ &do_log('err', 'Incorrect listname "%s"', $name) unless ($options->{'just_try'});
++ return undef;
++ }
++ ## Lowercase the list name.
++ $name =~ tr/A-Z/a-z/;
++
++ ## Reject listnames with reserved list suffixes
++ my $regx = &Conf::get_robot_conf($robot,'list_check_regexp');
++ if ( $regx ) {
++ if ($name =~ /^(\S+)-($regx)$/) {
++ &do_log('err', 'Incorrect name: listname "%s" matches one of service aliases', $name) unless ($options->{'just_try'});
++ return undef;
++ }
++ }
++
++ my $status ;
++ if ($list_of_lists{$robot}{$name}){
++ # use the current list in memory and update it
++ $list=$list_of_lists{$robot}{$name};
++
++ $status = $list->load($name, $robot, $options);
++ }else{
++ # create a new object list
++ bless $list, $pkg;
++
++ $options->{'first_access'} = 1;
++ $status = $list->load($name, $robot, $options);
++ }
++ unless (defined $status) {
++ return undef;
++ }
++
++ ## Config file was loaded or reloaded
++ if (($status == 1 && ! $options->{'skip_sync_admin'}) ||
++ $options->{'force_sync_admin'}) {
++
++ ## Update admin_table
++ unless (defined $list->sync_include_admin()) {
++ &do_log('err','List::new() : sync_include_admin_failed') unless ($options->{'just_try'});
++ }
++ if ($list->get_nb_owners() < 1 &&
++ $list->{'admin'}{'status'} ne 'error_config') {
++ &do_log('err', 'The list "%s" has got no owner defined',$list->{'name'}) ;
++ $list->set_status_error_config('no_owner_defined',$list->{'name'});
++ }
++ }
++
++ return $list;
++}
++
++## When no robot is specified, look for a list among robots
++sub search_list_among_robots {
++ my $listname = shift;
++
++ unless ($listname) {
++ &do_log('err', 'List::search_list_among_robots() : Missing list parameter');
++ return undef;
++ }
++
++ ## Search in default robot
++ if (-d $Conf::Conf{'home'}.'/'.$listname) {
++ return $Conf::Conf{'host'};
++ }
++
++ foreach my $r (keys %{$Conf::Conf{'robots'}}) {
++ if (-d $Conf::Conf{'home'}.'/'.$r.'/'.$listname) {
++ return $r;
++ }
++ }
++
++ return 0;
++}
++
++## set the list in status error_config and send a notify to listmaster
++sub set_status_error_config {
++ my ($self, $message, @param) = @_;
++ &do_log('debug3', 'List::set_status_error_config');
++
++ unless ($self->{'admin'}{'status'} eq 'error_config'){
++ $self->{'admin'}{'status'} = 'error_config';
++
++ my $host = &Conf::get_robot_conf($self->{'robot'}, 'host');
++ ## No more save config in error...
++ #$self->save_config("listmaster\@$host");
++ #$self->savestats();
++ &do_log('err', 'The list "%s" is set in status error_config',$self->{'name'});
++ unless (&List::send_notify_to_listmaster($message, $self->{'domain'},\@param)) {
++ &do_log('notice',"Unable to send notify '$message' to listmaster");
++ };
++ }
++}
++
++## set the list in status family_closed and send a notify to owners
++sub set_status_family_closed {
++ my ($self, $message, @param) = @_;
++ &do_log('debug2', 'List::set_status_family_closed');
++
++ unless ($self->{'admin'}{'status'} eq 'family_closed'){
++
++ my $host = &Conf::get_robot_conf($self->{'robot'}, 'host');
++
++ unless ($self->close("listmaster\@$host",'family_closed')) {
++ &do_log('err','Impossible to set the list %s in status family_closed');
++ return undef;
++ }
++ &do_log('err', 'The list "%s" is set in status family_closed',$self->{'name'});
++ unless ($self->send_notify_to_owner($message,\@param)){
++ &do_log('err','Impossible to send notify to owner informing status family_closed for the list %s',$self->{'name'});
++ }
++# messages : close_list
++ }
++ return 1;
++}
++
++## Saves the statistics data to disk.
++sub savestats {
++ my $self = shift;
++ do_log('debug2', 'List::savestats');
++
++ ## Be sure the list has been loaded.
++ my $name = $self->{'name'};
++ my $dir = $self->{'dir'};
++ return undef unless ($list_of_lists{$self->{'domain'}}{$name});
++
++ ## Lock file
++ my $lock = new Lock ($dir.'/stats');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++ $lock->set_timeout(2);
++ unless ($lock->lock('write')) {
++ return undef;
++ }
++
++ _save_stats_file("$dir/stats", $self->{'stats'}, $self->{'total'}, $self->{'last_sync'}, $self->{'last_sync_admin_user'});
++
++ ## Release the lock
++ unless ($lock->unlock()) {
++ return undef;
++ }
++
++ ## Changed on disk
++ $self->{'mtime'}[2] = time;
++
++ return 1;
++}
++
++## msg count.
++sub increment_msg_count {
++ my $self = shift;
++ do_log('debug2', "List::increment_msg_count($self->{'name'})");
++
++ ## Be sure the list has been loaded.
++ my $name = $self->{'name'};
++ my $file = "$self->{'dir'}/msg_count";
++
++ my %count ;
++ if (open(MSG_COUNT, $file)) {
++ while (<MSG_COUNT>){
++ if ($_ =~ /^(\d+)\s(\d+)$/) {
++ $count{$1} = $2;
++ }
++ }
++ close MSG_COUNT ;
++ }
++ my $today = int(time / 86400);
++ if ($count{$today}) {
++ $count{$today}++;
++ }else{
++ $count{$today} = 1;
++ }
++
++ unless (open(MSG_COUNT, ">$file.$$")) {
++ do_log('err', "Unable to create '%s.%s' : %s", $file,$$, $!);
++ return undef;
++ }
++ foreach my $key (sort {$a <=> $b} keys %count) {
++ printf MSG_COUNT "%d\t%d\n",$key,$count{$key} ;
++ }
++ close MSG_COUNT ;
++
++ unless (rename("$file.$$", $file)) {
++ do_log('err', "Unable to write '%s' : %s", $file, $!);
++ return undef;
++ }
++ return 1;
++}
++
++# Returns the number of messages sent to the list
++sub get_msg_count {
++ my $self = shift;
++ do_log('debug3', "Getting the number of messages for list %s",$self->{'name'});
++
++ ## Be sure the list has been loaded.
++ my $name = $self->{'name'};
++ my $file = "$self->{'dir'}/stats";
++
++ my $count = 0 ;
++ if (open(MSG_COUNT, $file)) {
++ while (<MSG_COUNT>){
++ if ($_ =~ /^(\d+)\s+(.*)$/) {
++ $count=$1;
++ }
++ }
++ close MSG_COUNT ;
++ }
++
++ return $count;
++
++}
++## last date of distribution message .
++sub get_latest_distribution_date {
++ my $self = shift;
++ do_log('debug3', "List::latest_distribution_date($self->{'name'})");
++
++ ## Be sure the list has been loaded.
++ my $name = $self->{'name'};
++ my $file = "$self->{'dir'}/msg_count";
++
++ my %count ;
++ my $latest_date = 0 ;
++ unless (open(MSG_COUNT, $file)) {
++ do_log('debug2',"get_latest_distribution_date: unable to open $file");
++ return undef ;
++ }
++
++ while (<MSG_COUNT>){
++ if ($_ =~ /^(\d+)\s(\d+)$/) {
++ $latest_date = $1 if ($1 > $latest_date);
++ }
++ }
++ close MSG_COUNT ;
++
++ return undef if ($latest_date == 0);
++ return $latest_date ;
++}
++
++## Update the stats struct
++## Input : num of bytes of msg
++## Output : num of msgs sent
++sub update_stats {
++ my($self, $bytes) = @_;
++ do_log('debug2', 'List::update_stats(%d)', $bytes);
++
++ my $stats = $self->{'stats'};
++ $stats->[0]++;
++ $stats->[1] += $self->{'total'};
++ $stats->[2] += $bytes;
++ $stats->[3] += $bytes * $self->{'total'};
++
++ ## Update 'msg_count' file, used for bounces management
++ $self->increment_msg_count();
++
++ return $stats->[0];
++}
++
++## Extract a set of rcpt for which verp must be use from a rcpt_tab.
++## Input : percent : the rate of subscribers that must be threaded using verp
++## xseq : the message sequence number
++## @rcpt : a tab of emails
++## return : a tab of rcpt for which rcpt must be use depending on the message sequence number, this way every subscriber is "verped" from time to time
++## input table @rcpt is spliced : rcpt for which verp must be used are extracted from this table
++sub extract_verp_rcpt() {
++ my $percent = shift;
++ my $xseq = shift;
++ my $refrcpt = shift;
++ my $refrcptverp = shift;
++
++ &do_log('debug','&extract_verp(%s,%s,%s,%s)',$percent,$xseq,$refrcpt,$refrcptverp) ;
++
++ my @result;
++
++ if ($percent ne '0%') {
++ my $nbpart ;
++ if ( $percent =~ /^(\d+)\%/ ) {
++ $nbpart = 100/$1;
++ }
++ else {
++ &do_log ('err', 'Wrong format for parameter extract_verp: %s. Can\'t process VERP.',$percent);
++ return undef;
++ }
++
++ my $modulo = $xseq % $nbpart ;
++ my $lenght = int (($#{$refrcpt} + 1) / $nbpart) + 1;
++
++ @result = splice @$refrcpt, $lenght*$modulo, $lenght ;
++ }
++ foreach my $verprcpt (@$refrcptverp) {
++ push @result, $verprcpt;
++ }
++ return ( @result ) ;
++}
++
++
++
++## Dumps a copy of lists to disk, in text format
++sub dump {
++ my $self = shift;
++ do_log('debug2', 'List::dump(%s)', $self->{'name'});
++
++ unless (defined $self) {
++ &do_log('err','Unknown list');
++ return undef;
++ }
++
++ my $user_file_name = "$self->{'dir'}/subscribers.db.dump";
++
++ unless ($self->_save_users_file($user_file_name)) {
++ &do_log('err', 'Failed to save file %s', $user_file_name);
++ return undef;
++ }
++
++ $self->{'mtime'} = [ (stat("$self->{'dir'}/config"))[9], (stat("$self->{'dir'}/subscribers"))[9], (stat("$self->{'dir'}/stats"))[9] ];
++
++ return 1;
++}
++
++## Saves the configuration file to disk
++sub save_config {
++ my ($self, $email) = @_;
++ do_log('debug3', 'List::save_config(%s,%s)', $self->{'name'}, $email);
++
++ return undef
++ unless ($self);
++
++ my $config_file_name = "$self->{'dir'}/config";
++
++ ## Lock file
++ my $lock = new Lock ($self->{'dir'}.'/config');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++ $lock->set_timeout(5);
++ unless ($lock->lock('write')) {
++ return undef;
++ }
++
++ my $name = $self->{'name'};
++ my $old_serial = $self->{'admin'}{'serial'};
++ my $old_config_file_name = "$self->{'dir'}/config.$old_serial";
++
++ ## Update management info
++ $self->{'admin'}{'serial'}++;
++ $self->{'admin'}{'update'} = {'email' => $email,
++ 'date_epoch' => time,
++ 'date' => (gettext_strftime "%d %b %Y at %H:%M:%S", localtime(time)),
++ };
++
++ unless (&_save_admin_file($config_file_name, $old_config_file_name, $self->{'admin'})) {
++ &do_log('info', 'unable to save config file %s', $config_file_name);
++ $lock->unlock();
++ return undef;
++ }
++
++ ## Also update the binary version of the data structure
++ if (&Conf::get_robot_conf($self->{'robot'}, 'cache_list_config') eq 'binary_file') {
++ eval {&Storable::store($self->{'admin'},"$self->{'dir'}/config.bin")};
++ if ($@) {
++ &do_log('err', 'Failed to save the binary config %s. error: %s', "$self->{'dir'}/config.bin",$@);
++ }
++ }
++
++# $self->{'mtime'}[0] = (stat("$list->{'dir'}/config"))[9];
++
++ ## Release the lock
++ unless ($lock->unlock()) {
++ return undef;
++ }
++
++ return 1;
++}
++
++## Loads the administrative data for a list
++sub load {
++ my ($self, $name, $robot, $options) = @_;
++ do_log('debug2', 'List::load(%s, %s, %s)', $name, $robot, join('/',keys %$options));
++
++ my $users;
++
++ ## Set of initializations ; only performed when the config is first loaded
++ if ($options->{'first_access'}) {
++
++ ## Search robot if none was provided
++ unless ($robot) {
++ foreach my $r (keys %{$Conf::Conf{'robots'}}) {
++ if (-d "$Conf::Conf{'home'}/$r/$name") {
++ $robot=$r;
++ last;
++ }
++ }
++
++ ## Try default robot
++ unless ($robot) {
++ if (-d "$Conf::Conf{'home'}/$name") {
++ $robot = $Conf::Conf{'host'};
++ }
++ }
++ }
++
++ if ($robot && (-d "$Conf::Conf{'home'}/$robot")) {
++ $self->{'dir'} = "$Conf::Conf{'home'}/$robot/$name";
++ }elsif (lc($robot) eq lc($Conf::Conf{'host'})) {
++ $self->{'dir'} = "$Conf::Conf{'home'}/$name";
++ }else {
++ &do_log('err', 'No such robot (virtual domain) %s', $robot) unless ($options->{'just_try'});
++ return undef ;
++ }
++
++ $self->{'domain'} = $robot ;
++
++ # default list host is robot domain
++ $self->{'admin'}{'host'} ||= $self->{'domain'};
++ $self->{'name'} = $name ;
++ }
++
++ unless ((-d $self->{'dir'}) && (-f "$self->{'dir'}/config")) {
++ &do_log('debug2', 'Missing directory (%s) or config file for %s', $self->{'dir'}, $name) unless ($options->{'just_try'});
++ return undef ;
++ }
++
++ my ($m1, $m2, $m3) = (0, 0, 0);
++ ($m1, $m2, $m3) = @{$self->{'mtime'}} if (defined $self->{'mtime'});
++
++ my $time_config = (stat("$self->{'dir'}/config"))[9];
++ my $time_config_bin = (stat("$self->{'dir'}/config.bin"))[9];
++ my $time_subscribers;
++ my $time_stats = (stat("$self->{'dir'}/stats"))[9];
++ my $config_reloaded = 0;
++ my $admin;
++
++ if (&Conf::get_robot_conf($self->{'domain'}, 'cache_list_config') eq 'binary_file' &&
++ $time_config_bin > $self->{'mtime'}->[0] &&
++ $time_config <= $time_config_bin &&
++ ! $options->{'reload_config'}) {
++
++ ## Get a shared lock on config file first
++ my $lock = new Lock ($self->{'dir'}.'/config');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++ $lock->set_timeout(5);
++ unless ($lock->lock('read')) {
++ return undef;
++ }
++
++ ## Load a binary version of the data structure
++ ## unless config is more recent than config.bin
++ eval {$admin = &Storable::retrieve("$self->{'dir'}/config.bin")};
++ if ($@) {
++ &do_log('err', 'Failed to load the binary config %s, error: %s', "$self->{'dir'}/config.bin",$@);
++ $lock->unlock();
++ return undef;
++ }
++
++ $config_reloaded = 1;
++ $m1 = $time_config_bin;
++ $lock->unlock();
++
++ }elsif ($self->{'name'} ne $name || $time_config > $self->{'mtime'}->[0] ||
++ $options->{'reload_config'}) {
++ $admin = _load_admin_file($self->{'dir'}, $self->{'domain'}, 'config');
++
++ ## Get a shared lock on config file first
++ my $lock = new Lock ($self->{'dir'}.'/config');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++ $lock->set_timeout(5);
++ unless ($lock->lock('write')) {
++ return undef;
++ }
++
++ ## update the binary version of the data structure
++ if (&Conf::get_robot_conf($self->{'domain'}, 'cache_list_config') eq 'binary_file') {
++ eval {&Storable::store($admin,"$self->{'dir'}/config.bin")};
++ if ($@) {
++ &do_log('err', 'Failed to save the binary config %s. error: %s', "$self->{'dir'}/config.bin",$@);
++ }
++ }
++
++ $config_reloaded = 1;
++ unless (defined $admin) {
++ &do_log('err', 'Impossible to load list config file for list % set in status error_config',$self->{'name'});
++ $self->set_status_error_config('load_admin_file_error',$self->{'name'});
++ $lock->unlock();
++ return undef;
++ }
++
++ $m1 = $time_config;
++ $lock->unlock();
++ }
++
++ ## If config was reloaded...
++ if ($admin) {
++ $self->{'admin'} = $admin;
++
++ ## check param_constraint.conf if belongs to a family and the config has been loaded
++ if (defined $admin->{'family_name'} && ($admin->{'status'} ne 'error_config')) {
++ my $family;
++ unless ($family = $self->get_family()) {
++ &do_log('err', 'Impossible to get list %s family : %s. The list is set in status error_config',$self->{'name'},$self->{'admin'}{'family_name'});
++ $self->set_status_error_config('no_list_family',$self->{'name'}, $admin->{'family_name'});
++ return undef;
++ }
++ my $error = $family->check_param_constraint($self);
++ unless($error) {
++ &do_log('err', 'Impossible to check parameters constraint for list % set in status error_config',$self->{'name'});
++ $self->set_status_error_config('no_check_rules_family',$self->{'name'}, $family->{'name'});
++ }
++ if (ref($error) eq 'ARRAY') {
++ &do_log('err', 'The list "%s" does not respect the rules from its family %s',$self->{'name'}, $family->{'name'});
++ $self->set_status_error_config('no_respect_rules_family',$self->{'name'}, $family->{'name'});
++ }
++ }
++ }
++
++ $self->{'as_x509_cert'} = 1 if ((-r "$self->{'dir'}/cert.pem") || (-r "$self->{'dir'}/cert.pem.enc"));
++
++ if ($self->{'admin'}{'user_data_source'} eq 'database') {
++
++ }elsif($self->{'admin'}->{'user_data_source'} eq 'file') {
++
++ $time_subscribers = (stat("$self->{'dir'}/subscribers"))[9] if (-f "$self->{'dir'}/subscribers");
++
++ ## Touch subscribers file if not exists
++ unless ( -r "$self->{'dir'}/subscribers") {
++ open L, ">$self->{'dir'}/subscribers" or return undef;
++ close L;
++ do_log('info','No subscribers file, creating %s',"$self->{'dir'}/subscribers");
++ }
++
++ if ($self->{'name'} ne $name || $time_subscribers > $self->{'mtime'}[1]) {
++ $users = _load_users("$self->{'dir'}/subscribers");
++ unless (defined $users) {
++ do_log('err', 'Could not load subscribers for list %s', $self->{'name'});
++ #return undef;
++ }
++ $m2 = $time_subscribers;
++ }
++
++ }elsif ($self->{'admin'}{'user_data_source'} eq 'include2') {
++ ## currently no check
++
++ }elsif($self->{'admin'}{'user_data_source'} eq 'include') {
++
++ ## include other subscribers as defined in include directives (list|ldap|sql|file|owners|editors)
++ unless ( $self->has_include_data_sources()) {
++ &do_log('err', 'Include paragraph missing in configuration file %s', "$self->{'dir'}/config");
++# return undef;
++ }
++
++ $time_subscribers = (stat("$self->{'dir'}/subscribers.db"))[9] if (-f "$self->{'dir'}/subscribers.db");
++
++
++ ## Update 'subscriber.db'
++ if ( ## 'config' is more recent than 'subscribers.db'
++ ($time_config > $time_subscribers) ||
++ ## 'ttl'*2 is NOT over
++ (time > ($time_subscribers + $self->{'admin'}{'ttl'} * 2)) ||
++ ## 'ttl' is over AND not Web context
++ ((time > ($time_subscribers + $self->{'admin'}{'ttl'})) &&
++ !($ENV{'HTTP_HOST'} && (-f "$self->{'dir'}/subscribers.db")))) {
++
++ $users = $self->_load_users_include("$self->{'dir'}/subscribers.db", 0);
++ unless (defined $users) {
++ do_log('err', 'Could not load subscribers for list %s', $self->{'name'});
++ #return undef;
++ }
++
++ $m2 = time;
++ }elsif (## First new()
++ ! $self->{'users'} ||
++ ## 'subscribers.db' is more recent than $self->{'users'}
++ ($time_subscribers > $self->{'mtime'}->[1])) {
++
++ ## Use cache
++ $users = $self->_load_users_include("$self->{'dir'}/subscribers.db", 1);
++
++ unless (defined $users) {
++ return undef;
++ }
++
++ $m2 = $time_subscribers;
++ }
++
++ }else {
++ do_log('notice','Wrong value for user_data_source');
++ return undef;
++ }
++
++ ## Load stats file if first new() or stats file changed
++ my ($stats, $total);
++ if (! $self->{'mtime'}[2] || ($time_stats > $self->{'mtime'}[2])) {
++ ($stats, $total, $self->{'last_sync'}, $self->{'last_sync_admin_user'}) = _load_stats_file("$self->{'dir'}/stats");
++ $m3 = $time_stats;
++
++ $self->{'stats'} = $stats if (defined $stats);
++ $self->{'total'} = $total if (defined $total);
++ }
++
++ $self->{'users'} = $users->{'users'} if ($users);
++ $self->{'ref'} = $users->{'ref'} if ($users);
++
++ if ($users && defined($users->{'total'})) {
++ $self->{'total'} = $users->{'total'};
++ }
++
++ ## We have updated %users, Total may have changed
++ if ($m2 > $self->{'mtime'}[1]) {
++ $self->savestats();
++ }
++
++ $self->{'mtime'} = [ $m1, $m2, $m3];
++
++ $list_of_lists{$self->{'domain'}}{$name} = $self;
++ return $config_reloaded;
++}
++
++## Return a list of hash's owners and their param
++sub get_owners {
++ my($self) = @_;
++ &do_log('debug3', 'List::get_owners(%s)', $self->{'name'});
++
++ my $owners = ();
++
++ # owners are in the admin_table ; they might come from an include data source
++ for (my $owner = $self->get_first_admin_user('owner'); $owner; $owner = $self->get_next_admin_user()) {
++ push(@{$owners},$owner);
++ }
++
++ return $owners;
++}
++
++sub get_nb_owners {
++ my($self) = @_;
++ &do_log('debug3', 'List::get_nb_owners(%s)', $self->{'name'});
++
++ my $resul = 0;
++ my $owners = $self->get_owners;
++
++ if (defined $owners) {
++ $resul = $#{$owners} + 1;
++ }
++ return $resul;
++}
++
++## Return a hash of list's editors and their param(empty if there isn't any editor)
++sub get_editors {
++ my($self) = @_;
++ &do_log('debug3', 'List::get_editors(%s)', $self->{'name'});
++
++ my $editors = ();
++
++ # editors are in the admin_table ; they might come from an include data source
++ for (my $editor = $self->get_first_admin_user('editor'); $editor; $editor = $self->get_next_admin_user()) {
++ push(@{$editors},$editor);
++ }
++
++ return $editors;
++}
++
++
++## Returns an array of owners' email addresses
++sub get_owners_email {
++ my($self,$param) = @_;
++ do_log('debug3', 'List::get_owners_email(%s,%s)', $self->{'name'}, $param -> {'ignore_nomail'});
++
++ my @rcpt;
++ my $owners = ();
++
++ $owners = $self->get_owners();
++
++ if ($param -> {'ignore_nomail'}) {
++ foreach my $o (@{$owners}) {
++ push (@rcpt, lc($o->{'email'}));
++ }
++ }
++ else {
++ foreach my $o (@{$owners}) {
++ next if ($o->{'reception'} eq 'nomail');
++ push (@rcpt, lc($o->{'email'}));
++ }
++ }
++ unless (@rcpt) {
++ &do_log('notice','Warning : no owner found for list %s', $self->{'name'} );
++ }
++ return @rcpt;
++}
++
++## Returns an array of editors' email addresses
++# or owners if there isn't any editors'email adress
++sub get_editors_email {
++ my($self,$param) = @_;
++ do_log('debug3', 'List::get_editors_email(%s,%s)', $self->{'name'}, $param -> {'ignore_nomail'});
++
++ my @rcpt;
++ my $editors = ();
++
++ $editors = $self->get_editors();
++
++ if ($param -> {'ignore_nomail'}) {
++ foreach my $e (@{$editors}) {
++ push (@rcpt, lc($e->{'email'}));
++ }
++ }
++ else {
++ foreach my $e (@{$editors}) {
++ next if ($e->{'reception'} eq 'nomail');
++ push (@rcpt, lc($e->{'email'}));
++ }
++ }
++ unless (@rcpt) {
++ &do_log('notice','Warning : no editor found for list %s, getting owners', $self->{'name'} );
++ @rcpt = $self->get_owners_email($param);
++ }
++ return @rcpt;
++}
++
++## Returns an object Family if the list belongs to a family
++# or undef
++sub get_family {
++ my $self = shift;
++ &do_log('debug3', 'List::get_family(%s)', $self->{'name'});
++
++ if (ref($self->{'family'}) eq 'Family') {
++ return $self->{'family'};
++ }
++
++ my $family_name;
++ my $robot = $self->{'domain'};
++
++ unless (defined $self->{'admin'}{'family_name'}) {
++ &do_log('err', 'List::get_family(%s) : this list has not got any family', $self->{'name'});
++ return undef;
++ }
++
++ $family_name = $self->{'admin'}{'family_name'};
++
++ my $family;
++ unless ($family = new Family($family_name,$robot) ) {
++ &do_log('err', 'List::get_family(%s) : new Family(%s) impossible', $self->{'name'},$family_name);
++ return undef;
++ }
++
++ $self->{'family'} = $family;
++ return $family;
++}
++
++## return the config_changes hash
++## Used ONLY with lists belonging to a family.
++sub get_config_changes {
++ my $self = shift;
++ &do_log('debug3', 'List::get_config_changes(%s)', $self->{'name'});
++
++ unless ($self->{'admin'}{'family_name'}) {
++ &do_log('err', 'List::get_config_changes(%s) is called but there is no family_name for this list.',$self->{'name'});
++ return undef;
++ }
++
++ ## load config_changes
++ my $time_file = (stat("$self->{'dir'}/config_changes"))[9];
++ unless (defined $self->{'config_changes'} && ($self->{'config_changes'}{'mtime'} >= $time_file)) {
++ unless ($self->{'config_changes'} = $self->_load_config_changes_file()) {
++ &do_log('err','Impossible to load file config_changes from list %s',$self->{'name'});
++ return undef;
++ }
++ }
++ return $self->{'config_changes'};
++}
++
++
++## update file config_changes if the list belongs to a family by
++# writing the $what(file or param) name
++sub update_config_changes {
++ my $self = shift;
++ my $what = shift;
++ # one param or a ref on array of param
++ my $name = shift;
++ &do_log('debug2', 'List::update_config_changes(%s,%s)', $self->{'name'},$what);
++
++ unless ($self->{'admin'}{'family_name'}) {
++ &do_log('err', 'List::update_config_changes(%s,%s,%s) is called but there is no family_name for this list.',$self->{'name'},$what);
++ return undef;
++ }
++ unless (($what eq 'file') || ($what eq 'param')){
++ &do_log('err', 'List::update_config_changes(%s,%s) : %s is wrong : must be "file" or "param".',$self->{'name'},$what);
++ return undef;
++ }
++
++ # status parameter isn't updating set in config_changes
++ if (($what eq 'param') && ($name eq 'status')) {
++ return 1;
++ }
++
++ ## load config_changes
++ my $time_file = (stat("$self->{'dir'}/config_changes"))[9];
++ unless (defined $self->{'config_changes'} && ($self->{'config_changes'}{'mtime'} >= $time_file)) {
++ unless ($self->{'config_changes'} = $self->_load_config_changes_file()) {
++ &do_log('err','Impossible to load file config_changes from list %s',$self->{'name'});
++ return undef;
++ }
++ }
++
++ if (ref($name) eq 'ARRAY' ) {
++ foreach my $n (@{$name}) {
++ $self->{'config_changes'}{$what}{$n} = 1;
++ }
++ } else {
++ $self->{'config_changes'}{$what}{$name} = 1;
++ }
++
++ $self->_save_config_changes_file();
++
++ return 1;
++}
++
++## return a hash of config_changes file
++sub _load_config_changes_file {
++ my $self = shift;
++ &do_log('debug3', 'List::_load_config_changes_file(%s)', $self->{'name'});
++
++ my $config_changes = {};
++
++ unless (-e "$self->{'dir'}/config_changes") {
++ &do_log('err','No file %s/config_changes. Assuming no changes', $self->{'dir'});
++ return $config_changes;
++ }
++
++ unless (open (FILE,"$self->{'dir'}/config_changes")) {
++ &do_log('err','File %s/config_changes exists, but unable to open it: %s', $self->{'dir'},$_);
++ return undef;
++ }
++
++ while (<FILE>) {
++
++ next if /^\s*(\#.*|\s*)$/;
++
++ if (/^param\s+(.+)\s*$/) {
++ $config_changes->{'param'}{$1} = 1;
++
++ }elsif (/^file\s+(.+)\s*$/) {
++ $config_changes->{'file'}{$1} = 1;
++
++ }else {
++ &do_log ('err', 'List::_load_config_changes_file(%s) : bad line : %s',$self->{'name'},$_);
++ next;
++ }
++ }
++ close FILE;
++
++ $config_changes->{'mtime'} = (stat("$self->{'dir'}/config_changes"))[9];
++
++ return $config_changes;
++}
++
++## save config_changes file in the list directory
++sub _save_config_changes_file {
++ my $self = shift;
++ &do_log('debug3', 'List::_save_config_changes_file(%s)', $self->{'name'});
++
++ unless ($self->{'admin'}{'family_name'}) {
++ &do_log('err', 'List::_save_config_changes_file(%s) is called but there is no family_name for this list.',$self->{'name'});
++ return undef;
++ }
++ unless (open (FILE,">$self->{'dir'}/config_changes")) {
++ &do_log('err','List::_save_config_changes_file(%s) : unable to create file %s/config_changes : %s',$self->{'name'},$self->{'dir'},$_);
++ return undef;
++ }
++
++ foreach my $what ('param','file') {
++ foreach my $name (keys %{$self->{'config_changes'}{$what}}) {
++ print FILE "$what $name\n";
++ }
++ }
++ close FILE;
++
++ return 1;
++}
++
++
++
++
++sub _get_param_value_anywhere {
++ my $new_admin = shift;
++ my $param = shift;
++ &do_log('debug3', '_get_param_value_anywhere(%s %s)',$param);
++ my $minor_p;
++ my @values;
++
++ if ($param =~ /^([\w-]+)\.([\w-]+)$/) {
++ $param = $1;
++ $minor_p = $2;
++ }
++
++ ## Multiple parameter (owner, custom_header, ...)
++ if ((ref ($new_admin->{$param}) eq 'ARRAY') &&
++ !($::pinfo{$param}{'split_char'})) {
++ foreach my $elt (@{$new_admin->{$param}}) {
++ my $val = &List::_get_single_param_value($elt,$param,$minor_p);
++ if (defined $val) {
++ push @values,$val;
++ }
++ }
++
++ }else {
++ my $val = &List::_get_single_param_value($new_admin->{$param},$param,$minor_p);
++ if (defined $val) {
++ push @values,$val;
++ }
++ }
++ return \@values;
++}
++
++
++## Returns the list parameter value from $list->{'admin'}
++# the parameter is simple ($param) or composed ($param & $minor_param)
++# the value is a scalar or a ref on an array of scalar
++# (for parameter digest : only for days)
++sub get_param_value {
++ my $self = shift;
++ my $param = shift;
++ &do_log('debug3', 'List::get_param_value(%s,%s)', $self->{'name'},$param);
++ my $minor_param;
++ my $value;
++
++ if ($param =~ /^([\w-]+)\.([\w-]+)$/) {
++ $param = $1;
++ $minor_param = $2;
++ }
++
++ ## Multiple parameter (owner, custom_header, ...)
++ if ((ref ($self->{'admin'}{$param}) eq 'ARRAY') &&
++ ! $::pinfo{$param}{'split_char'}) {
++ my @values;
++ foreach my $elt (@{$self->{'admin'}{$param}}) {
++ push @values,&_get_single_param_value($elt,$param,$minor_param)
++ }
++ $value = \@values;
++ }else {
++ $value = &_get_single_param_value($self->{'admin'}{$param},$param,$minor_param);
++ }
++ return $value;
++}
++
++## Returns the single list parameter value from struct $p, with $key entrie,
++# $k is optionnal
++# the single value can be a ref on a list when the parameter value is a list
++sub _get_single_param_value {
++ my ($p,$key,$k) = @_;
++ &do_log('debug3', 'List::_get_single_value(%s %s)',$key,$k);
++
++ if (defined ($::pinfo{$key}{'scenario'}) ||
++ defined ($::pinfo{$key}{'task'})) {
++ return $p->{'name'};
++
++ }elsif (ref($::pinfo{$key}{'file_format'})) {
++
++ if (defined ($::pinfo{$key}{'file_format'}{$k}{'scenario'})) {
++ return $p->{$k}{'name'};
++
++ }elsif (($::pinfo{$key}{'file_format'}{$k}{'occurrence'} =~ /n$/)
++ && $::pinfo{$key}{'file_format'}{$k}{'split_char'}) {
++ return $p->{$k}; # ref on an array
++ }else {
++ return $p->{$k};
++ }
++
++ }else {
++ if (($::pinfo{$key}{'occurrence'} =~ /n$/)
++ && $::pinfo{$key}{'split_char'}) {
++ return $p; # ref on an array
++ }elsif ($key eq 'digest') {
++ return $p->{'days'}; # ref on an array
++ }else {
++ return $p;
++ }
++ }
++}
++
++
++
++########################################################################################
++# FUNCTIONS FOR MESSAGE SENDING #
++########################################################################################
++# #
++# -list distribution
++# -template sending #
++# -service messages
++# -notification sending(listmaster, owner, editor, user) #
++# #
++
++
++######################### LIST DISTRIBUTION #########################################
++
++
++####################################################
++# distribute_msg
++####################################################
++# prepares and distributes a message to a list, do
++# some of these :
++# stats, hidding sender, adding custom subject,
++# archive, changing the replyto, removing headers,
++# adding headers, storing message in digest
++#
++#
++# IN : -$self (+): ref(List)
++# -$message (+): ref(Message)
++# -$apply_dkim_signature : on | off
++# OUT : -$numsmtp : number of sendmail process
++####################################################
++sub distribute_msg {
++ my $self = shift;
++ my %param = @_;
++
++ my $message = $param{'message'};
++ my $apply_dkim_signature = $param{'apply_dkim_signature'};
++
++ do_log('debug2', 'List::distribute_msg(%s, %s, %s, %s, %s, %s, apply_dkim_signature=%s)', $self->{'name'}, $message->{'msg'}, $message->{'size'}, $message->{'filename'}, $message->{'smime_crypted'}, $apply_dkim_signature );
++
++ my $hdr = $message->{'msg'}->head;
++ my ($name, $host) = ($self->{'name'}, $self->{'admin'}{'host'});
++ my $robot = $self->{'domain'};
++
++ ## Update the stats, and returns the new X-Sequence, if any.
++ my $sequence = $self->update_stats($message->{'size'});
++
++ ## Loading info msg_topic file if exists, add X-Sympa-Topic
++ my $info_msg_topic;
++ if ($self->is_there_msg_topic()) {
++ my $msg_id = $hdr->get('Message-ID');
++ chomp($msg_id);
++ $info_msg_topic = $self->load_msg_topic_file($msg_id,$robot);
++
++ # add X-Sympa-Topic header
++ if (ref($info_msg_topic) eq "HASH") {
++ $message->add_topic($info_msg_topic->{'topic'});
++ }
++ }
++
++ ## Hide the sender if the list is anonymoused
++ if ( $self->{'admin'}{'anonymous_sender'} ) {
++
++ foreach my $field (@{$Conf::Conf{'anonymous_header_fields'}}) {
++ $hdr->delete($field);
++ }
++
++ $hdr->add('From',"$self->{'admin'}{'anonymous_sender'}");
++ my $new_id = "$self->{'name'}.$sequence\@anonymous";
++ $hdr->add('Message-id',"<$new_id>");
++
++ # rename msg_topic filename
++ if ($info_msg_topic) {
++ my $queuetopic = &Conf::get_robot_conf($robot, 'queuetopic');
++ my $listname = "$self->{'name'}\@$robot";
++ rename("$queuetopic/$info_msg_topic->{'filename'}","$queuetopic/$listname.$new_id");
++ $info_msg_topic->{'filename'} = "$listname.$new_id";
++ }
++
++ ## Virer eventuelle signature S/MIME
++ }
++
++ ## Add Custom Subject
++ if ($self->{'admin'}{'custom_subject'}) {
++ my $subject_field = $message->{'decoded_subject'};
++ $subject_field =~ s/^\s*(.*)\s*$/$1/; ## Remove leading and trailing blanks
++
++ ## Search previous subject tagging in Subject
++ my $custom_subject = $self->{'admin'}{'custom_subject'};
++
++ ## tag_regexp will be used to remove the custom subject if it is already present in the message subject.
++ ## Remember that the value of custom_subject can be "dude number [%list.sequence"%]" whereas the actual
++ ## subject will contain "dude number 42".
++ my $tag_regexp = $custom_subject;
++ $tag_regexp =~ s/([\[\]\*\-\(\)\+\{\}\?])/\\$1/g; ## cleanup, just in case dangerous chars were left
++ $tag_regexp =~ s/\\\[%\S+%\\\]/[^\]]\+/g; ## Replaces variables declarations by "[^\]]+"
++ $tag_regexp =~ s/\s+/\\s+/g; ## Takes spaces into account
++
++ ## Add subject tag
++ $message->{'msg'}->head->delete('Subject');
++ my $parsed_tag;
++ &tt2::parse_tt2({'list' => {'name' => $self->{'name'},
++ 'sequence' => $self->{'stats'}->[0]
++ }},
++ [$custom_subject], \$parsed_tag);
++
++ ## If subject is tagged, replace it with new tag
++ ## Splitting the subject in two parts :
++ ## - what is before the custom subject (probably some "Re:")
++ ## - what is after it : the orginal subject sent to the list.
++ ## The custom subject is not kept.
++ my $before_tag = '';
++ my $after_tag = $subject_field;
++ $after_tag =~ s/.*\[$tag_regexp\]\s*//;
++ $after_tag =~ s/\s*$//;
++
++ if($subject_field =~ /(.*)\s*\[$tag_regexp\].*/) {
++ $before_tag = $1;
++ }
++
++ ## Encode subject using initial charset
++
++ ## Don't try to encode the subject if it was not originaly encoded.
++ if ($message->{'subject_charset'}) {
++ $subject_field = MIME::EncWords::encode_mimewords([
++ [Encode::decode('utf8', $before_tag), $message->{'subject_charset'}],
++ [Encode::decode('utf8', '['.$parsed_tag.'] '), &Language::GetCharset()],
++ [Encode::decode('utf8', $after_tag), $message->{'subject_charset'}]
++ ], Encoding=>'A', Field=>'Subject');
++ }else {
++ $subject_field = $before_tag . ' ' . MIME::EncWords::encode_mimewords([
++ [Encode::decode('utf8', '['.$parsed_tag.']'), &Language::GetCharset()]
++ ], Encoding=>'A', Field=>'Subject') . ' ' . $after_tag;
++ }
++
++ $message->{'msg'}->head->add('Subject', $subject_field);
++ }
++
++ ## Remove unwanted headers if present.
++ if ($self->{'admin'}{'remove_headers'}) {
++ foreach my $field (@{$self->{'admin'}{'remove_headers'}}) {
++ $hdr->delete($field);
++ }
++ }
++
++ ## Archives
++ my $msgtostore = $message->{'msg'};
++ if (($message->{'smime_crypted'} eq 'smime_crypted') &&
++ ($self->{admin}{archive_crypted_msg} eq 'original')) {
++ $msgtostore = $message->{'orig_msg'};
++ }
++ $self->archive_msg($msgtostore);
++
++ ## Change the reply-to header if necessary.
++ if ($self->{'admin'}{'reply_to_header'}) {
++ unless ($hdr->get('Reply-To') && ($self->{'admin'}{'reply_to_header'}{'apply'} ne 'forced')) {
++ my $reply;
++
++ $hdr->delete('Reply-To');
++
++ if ($self->{'admin'}{'reply_to_header'}{'value'} eq 'list') {
++ $reply = "$name\@$host";
++ }elsif ($self->{'admin'}{'reply_to_header'}{'value'} eq 'sender') {
++ $reply = undef;
++ }elsif ($self->{'admin'}{'reply_to_header'}{'value'} eq 'all') {
++ $reply = "$name\@$host,".$hdr->get('From');
++ }elsif ($self->{'admin'}{'reply_to_header'}{'value'} eq 'other_email') {
++ $reply = $self->{'admin'}{'reply_to_header'}{'other_email'};
++ }
++
++ $hdr->add('Reply-To',$reply) if $reply;
++ }
++ }
++
++ ## Add useful headers
++ $hdr->add('X-Loop', "$name\@$host");
++ $hdr->add('X-Sequence', $sequence);
++ $hdr->add('Errors-to', $name.&Conf::get_robot_conf($robot, 'return_path_suffix').'@'.$host);
++ $hdr->add('Precedence', 'list');
++ $hdr->add('Precedence', 'bulk');
++ $hdr->add('Sender', "$self->{'name'}-request\@$self->{'admin'}{'host'}"); # The Sender: header should be add at least for DKIM compatibility
++ $hdr->add('X-no-archive', 'yes');
++ foreach my $i (@{$self->{'admin'}{'custom_header'}}) {
++ $hdr->add($1, $2) if ($i=~/^([\S\-\:]*)\s(.*)$/);
++ }
++
++ ## Add RFC 2919 header field
++ if ($hdr->get('List-Id')) {
++ &do_log('notice', 'Found List-Id: %s', $hdr->get('List-Id'));
++ $hdr->delete('List-ID');
++ }
++ $hdr->add('List-Id', sprintf ('<%s.%s>', $self->{'name'}, $self->{'admin'}{'host'}));
++
++ ## Add RFC 2369 header fields
++ foreach my $field (@{$self->{'admin'}{'rfc2369_header_fields'}}) {
++ if ($field eq 'help') {
++ $hdr->add('List-Help', sprintf ('<mailto:%s@%s?subject=help>', &Conf::get_robot_conf($robot, 'email'), &Conf::get_robot_conf($robot, 'host')));
++ }elsif ($field eq 'unsubscribe') {
++ $hdr->add('List-Unsubscribe', sprintf ('<mailto:%s@%s?subject=unsubscribe%%20%s>', &Conf::get_robot_conf($robot, 'email'), &Conf::get_robot_conf($robot, 'host'), $self->{'name'}));
++ }elsif ($field eq 'subscribe') {
++ $hdr->add('List-Subscribe', sprintf ('<mailto:%s@%s?subject=subscribe%%20%s>', &Conf::get_robot_conf($robot, 'email'), &Conf::get_robot_conf($robot, 'host'), $self->{'name'}));
++ }elsif ($field eq 'post') {
++ $hdr->add('List-Post', sprintf ('<mailto:%s@%s>', $self->{'name'}, $self->{'admin'}{'host'}));
++ }elsif ($field eq 'owner') {
++ $hdr->add('List-Owner', sprintf ('<mailto:%s-request@%s>', $self->{'name'}, $self->{'admin'}{'host'}));
++ }elsif ($field eq 'archive') {
++ if (&Conf::get_robot_conf($robot, 'wwsympa_url') and $self->is_web_archived()) {
++ $hdr->add('List-Archive', sprintf ('<%s/arc/%s>', &Conf::get_robot_conf($robot, 'wwsympa_url'), $self->{'name'}));
++ }
++ }
++ }
++
++ ## Remove outgoing header fileds
++ ## Useful to remove some header fields that Sympa has set
++ if ($self->{'admin'}{'remove_outgoing_headers'}) {
++ foreach my $field (@{$self->{'admin'}{'remove_outgoing_headers'}}) {
++ $hdr->delete($field);
++ }
++ }
++
++ ## store msg in digest if list accept digest mode (encrypted message can't be included in digest)
++ if (($self->is_digest()) and ($message->{'smime_crypted'} ne 'smime_crypted')) {
++ $self->archive_msg_digest($msgtostore);
++ }
++
++ ## Synchronize list members, required if list uses include sources
++ ## unless sync_include has been performed recently.
++ if ($self->has_include_data_sources()) {
++ $self->on_the_fly_sync_include('use_ttl' => 1);
++ }
++
++ ## Blindly send the message to all users.
++ my $numsmtp = $self->send_msg('message'=> $message, 'apply_dkim_signature'=>$apply_dkim_signature);
++ unless (defined ($numsmtp)) {
++ return $numsmtp;
++ }
++
++ $self->savestats();
++
++ return $numsmtp;
++}
++
++####################################################
++# send_msg_digest
++####################################################
++# Send a digest message to the subscribers with
++# reception digest, digestplain or summary
++#
++# IN : -$self(+) : ref(List)
++#
++# OUT : 1 : ok
++# | 0 if no subscriber for sending digest
++# | undef
++####################################################
++sub send_msg_digest {
++ my ($self) = @_;
++
++ my $listname = $self->{'name'};
++ my $robot = $self->{'domain'};
++ do_log('debug2', 'List:send_msg_digest(%s)', $listname);
++
++ my $filename;
++ ## Backward compatibility concern
++ if (-f "$Conf::Conf{'queuedigest'}/$listname") {
++ $filename = "$Conf::Conf{'queuedigest'}/$listname";
++ }else {
++ $filename = $Conf::Conf{'queuedigest'}.'/'.$self->get_list_id();
++ }
++
++ my $param = {'replyto' => "$self->{'name'}-request\@$self->{'admin'}{'host'}",
++ 'to' => $self->get_list_address(),
++ 'table_of_content' => sprintf(gettext("Table of contents:")),
++ 'boundary1' => '----------=_'.&tools::get_message_id($robot),
++ 'boundary2' => '----------=_'.&tools::get_message_id($robot),
++ };
++ if ($self->get_reply_to() =~ /^list$/io) {
++ $param->{'replyto'}= "$param->{'to'}";
++ }
++
++ my @tabrcpt ;
++ my @tabrcptsummary;
++ my @tabrcptplain;
++ my $i;
++
++ my (@list_of_mail);
++
++ ## Create the list of subscribers in various digest modes
++ for (my $user = $self->get_first_user(); $user; $user = $self->get_next_user()) {
++ my $options;
++ $options->{'email'} = $user->{'email'};
++ $options->{'name'} = $self->{'name'};
++ $options->{'domain'} = $self->{'domain'};
++ my $user_data = &get_subscriber_no_object($options);
++ ## test to know if the rcpt suspended her subscription for this list
++ ## if yes, don't send the message
++ if ($user_data->{'suspend'} eq '1'){
++ if(($user_data->{'startdate'} <= time) && ((time <= $user_data->{'enddate'}) || (!$user_data->{'enddate'}))){
++ next;
++ }elsif(($user_data->{'enddate'} < time) && ($user_data->{'enddate'})){
++ ## If end date is < time, update the BDD by deleting the suspending's data
++ &restore_suspended_subscription($user->{'email'},$self->{'name'},$self->{'domain'});
++ }
++ }
++ if ($user->{'reception'} eq "digest") {
++ push @tabrcpt, $user->{'email'};
++
++ }elsif ($user->{'reception'} eq "summary") {
++ ## Create the list of subscribers in summary mode
++ push @tabrcptsummary, $user->{'email'};
++
++ }elsif ($user->{'reception'} eq "digestplain") {
++ push @tabrcptplain, $user->{'email'};
++ }
++ }
++ if (($#tabrcptsummary == -1) and ($#tabrcpt == -1) and ($#tabrcptplain == -1)) {
++ &do_log('info', 'No subscriber for sending digest in list %s', $listname);
++ return 0;
++ }
++
++ my $old = $/;
++ local $/ = "\n\n" . &tools::get_separator() . "\n\n";
++
++ ## Digest split in individual messages
++ open DIGEST, $filename or return undef;
++ foreach (<DIGEST>){
++
++ my @text = split /\n/;
++ pop @text; pop @text;
++
++ ## Restore carriage returns
++ foreach $i (0 .. $#text) {
++ $text[$i] .= "\n";
++ }
++
++ my $parser = new MIME::Parser;
++ $parser->output_to_core(1);
++ $parser->extract_uuencode(1);
++ $parser->extract_nested_messages(1);
++# $parser->output_dir($Conf::Conf{'spool'} ."/tmp");
++ my $mail = $parser->parse_data(\@text);
++
++ next unless (defined $mail);
++
++ push @list_of_mail, $mail;
++ }
++ close DIGEST;
++ local $/ = $old;
++
++ ## Deletes the introduction part
++ splice @list_of_mail, 0, 1;
++
++ ## Digest index
++ my @all_msg;
++ foreach $i (0 .. $#list_of_mail){
++ my $mail = $list_of_mail[$i];
++ my $subject = &MIME::EncWords::decode_mimewords($mail->head->get('Subject'), Charset=>'utf8');
++ chomp $subject;
++ my $from = &MIME::EncWords::decode_mimewords($mail->head->get('From'), Charset=>'utf8');
++ chomp $from;
++ my $date = &MIME::EncWords::decode_mimewords($mail->head->get('Date'), Charset=>'utf8');
++ chomp $date;
++
++ my $msg = {};
++ $msg->{'id'} = $i+1;
++ $msg->{'subject'} = $subject;
++ $msg->{'from'} = $from;
++ $msg->{'date'} = $date;
++
++ #$mail->tidy_body;
++
++ ## Commented because one Spam made Sympa die (MIME::tools 5.413)
++ #$mail->remove_sig;
++
++ $msg->{'full_msg'} = $mail->as_string;
++ $msg->{'body'} = $mail->body_as_string;
++ $msg->{'plain_body'} = $mail->PlainDigest::plain_body_as_string();
++ #$msg->{'body'} = $mail->bodyhandle->as_string();
++ chomp $msg->{'from'};
++ $msg->{'month'} = strftime("%Y-%m", localtime(time)); ## Should be extracted from Date:
++ $msg->{'message_id'} = &tools::clean_msg_id($mail->head->get('Message-Id'));
++
++ ## Clean up Message-ID
++ $msg->{'message_id'} = &tools::escape_chars($msg->{'message_id'});
++
++ #push @{$param->{'msg_list'}}, $msg ;
++ push @all_msg, $msg ;
++ }
++
++ my @now = localtime(time);
++ $param->{'datetime'} = gettext_strftime "%a, %d %b %Y %H:%M:%S", @now;
++ $param->{'date'} = gettext_strftime "%a, %d %b %Y", @now;
++
++ ## Split messages into groups of digest_max_size size
++ my @group_of_msg;
++ while (@all_msg) {
++ my @group = splice @all_msg, 0, $self->{'admin'}{'digest_max_size'};
++
++ push @group_of_msg, \@group;
++ }
++
++
++ $param->{'current_group'} = 0;
++ $param->{'total_group'} = $#group_of_msg + 1;
++ ## Foreach set of digest_max_size messages...
++ foreach my $group (@group_of_msg) {
++
++ $param->{'current_group'}++;
++ $param->{'msg_list'} = $group;
++ $param->{'auto_submitted'} = 'auto-forwarded';
++
++ ## Prepare Digest
++ if (@tabrcpt) {
++ ## Send digest
++ unless ($self->send_file('digest', \@tabrcpt, $robot, $param)) {
++ &do_log('notice',"Unable to send template 'digest' to $self->{'name'} list subscribers");
++ }
++ }
++
++ ## Prepare Plain Text Digest
++ if (@tabrcptplain) {
++ ## Send digest-plain
++ unless ($self->send_file('digest_plain', \@tabrcptplain, $robot, $param)) {
++ &do_log('notice',"Unable to send template 'digest_plain' to $self->{'name'} list subscribers");
++ }
++ }
++
++
++ ## send summary
++ if (@tabrcptsummary) {
++ unless ($self->send_file('summary', \@tabrcptsummary, $robot, $param)) {
++ &do_log('notice',"Unable to send template 'summary' to $self->{'name'} list subscribers");
++ }
++ }
++ }
++
++ return 1;
++}
++
++
++######################### TEMPLATE SENDING ##########################################
++
++
++####################################################
++# send_global_file
++####################################################
++# Send a global (not relative to a list)
++# message to a user.
++# Find the tt2 file according to $tpl, set up
++# $data for the next parsing (with $context and
++# configuration )
++#
++# IN : -$tpl (+): template file name (file.tt2),
++# without tt2 extension
++# -$who (+): SCALAR |ref(ARRAY) - recipient(s)
++# -$robot (+): robot
++# -$context : ref(HASH) - for the $data set up
++# to parse file tt2, keys can be :
++# -user : ref(HASH), keys can be :
++# -email
++# -lang
++# -password
++# -auto_submitted auto-generated|auto-replied|auto-forwarded
++# -...
++# -$options : ref(HASH) - options
++# OUT : 1 | undef
++#
++####################################################
++sub send_global_file {
++ my($tpl, $who, $robot, $context, $options) = @_;
++ do_log('debug2', 'List::send_global_file(%s, %s, %s)', $tpl, $who, $robot);
++
++ my $data = &tools::dup_var($context);
++
++ unless ($data->{'user'}) {
++ $data->{'user'} = &get_user_db($who) unless ($options->{'skip_db'});
++ $data->{'user'}{'email'} = $who unless (defined $data->{'user'});;
++ }
++ unless ($data->{'user'}{'lang'}) {
++ $data->{'user'}{'lang'} = $Language::default_lang;
++ }
++
++ unless ($data->{'user'}{'password'}) {
++ $data->{'user'}{'password'} = &tools::tmp_passwd($who);
++ }
++
++ ## Lang
++ $data->{'lang'} = $data->{'lang'} || $data->{'user'}{'lang'} || &Conf::get_robot_conf($robot, 'lang');
++
++ ## What file
++ my $lang = &Language::Lang2Locale($data->{'lang'});
++ my $tt2_include_path = &tools::make_tt2_include_path($robot,'mail_tt2',$lang,'');
++
++ foreach my $d (@{$tt2_include_path}) {
++ &tt2::add_include_path($d);
++ }
++
++ my @path = &tt2::get_include_path();
++ my $filename = &tools::find_file($tpl.'.tt2',@path);
++
++ unless (defined $filename) {
++ &do_log('err','Could not find template %s.tt2 in %s', $tpl, join(':',@path));
++ return undef;
++ }
++
++ foreach my $p ('email','host','sympa','request','listmaster','wwsympa_url','title','listmaster_email') {
++ $data->{'conf'}{$p} = &Conf::get_robot_conf($robot, $p);
++ }
++
++ $data->{'sender'} = $who;
++ $data->{'conf'}{'version'} = $main::Version;
++ $data->{'from'} = "$data->{'conf'}{'email'}\@$data->{'conf'}{'host'}" unless ($data->{'from'});
++ $data->{'robot_domain'} = $robot;
++ $data->{'return_path'} = &Conf::get_robot_conf($robot, 'request');
++ $data->{'boundary'} = '----------=_'.&tools::get_message_id($robot) unless ($data->{'boundary'});
++
++ if ((&Conf::get_robot_conf($robot, 'dkim_feature') eq 'on')&&(&Conf::get_robot_conf($robot, 'dkim_add_signature_to')=~/robot/)){
++ $data->{'dkim'} = &tools::get_dkim_parameters({'robot' => $robot});
++ }
++
++ $data->{'use_bulk'} = 1 unless ($data->{'alarm'}) ; # use verp excepted for alarms. We should make this configurable in order to support Sympa server on a machine without any MTA service
++ unless (&mail::mail_file($filename, $who, $data, $robot)) {
++ &do_log('err',"List::send_global_file, could not send template $filename to $who");
++ return undef;
++ }
++
++ return 1;
++}
++
++####################################################
++# send_file
++####################################################
++# Send a message to a user, relative to a list.
++# Find the tt2 file according to $tpl, set up
++# $data for the next parsing (with $context and
++# configuration)
++# Message is signed if the list has a key and a
++# certificate
++#
++# IN : -$self (+): ref(List)
++# -$tpl (+): template file name (file.tt2),
++# without tt2 extension
++# -$who (+): SCALAR |ref(ARRAY) - recipient(s)
++# -$robot (+): robot
++# -$context : ref(HASH) - for the $data set up
++# to parse file tt2, keys can be :
++# -user : ref(HASH), keys can be :
++# -email
++# -lang
++# -password
++# -auto_submitted auto-generated|auto-replied|auto-forwarded
++# -...
++# OUT : 1 | undef
++####################################################
++sub send_file {
++ my($self, $tpl, $who, $robot, $context) = @_;
++ do_log('debug2', 'List::send_file(%s, %s, %s)', $tpl, $who, $robot);
++
++ my $name = $self->{'name'};
++ my $sign_mode;
++
++ my $data = &tools::dup_var($context);
++
++ ## Any recipients
++ if ((ref ($who) && ($#{$who} < 0)) ||
++ (!ref ($who) && ($who eq ''))) {
++ &do_log('err', 'No recipient for sending %s', $tpl);
++ return undef;
++ }
++
++ ## Unless multiple recipients
++ unless (ref ($who)) {
++ unless ($data->{'user'}) {
++ unless ($data->{'user'} = &get_user_db($who)) {
++ $data->{'user'}{'email'} = $who;
++ $data->{'user'}{'lang'} = $self->{'admin'}{'lang'};
++ }
++ }
++
++ $data->{'subscriber'} = $self->get_subscriber($who);
++
++ if ($data->{'subscriber'}) {
++ $data->{'subscriber'}{'date'} = gettext_strftime "%d %b %Y", localtime($data->{'subscriber'}{'date'});
++ $data->{'subscriber'}{'update_date'} = gettext_strftime "%d %b %Y", localtime($data->{'subscriber'}{'update_date'});
++ if ($data->{'subscriber'}{'bounce'}) {
++ $data->{'subscriber'}{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/;
++
++ $data->{'subscriber'}{'first_bounce'} = gettext_strftime "%d %b %Y", localtime($1);
++ }
++ }
++
++ unless ($data->{'user'}{'password'}) {
++ $data->{'user'}{'password'} = &tools::tmp_passwd($who);
++ }
++
++ ## Unique return-path VERP
++ if ((($self->{'admin'}{'welcome_return_path'} eq 'unique') && ($tpl eq 'welcome')) ||
++ (($self->{'admin'}{'remind_return_path'} eq 'unique') && ($tpl eq 'remind'))) {
++ my $escapercpt = $who ;
++ $escapercpt =~ s/\@/\=\=a\=\=/;
++ $data->{'return_path'} = "$Conf::Conf{'bounce_email_prefix'}+$escapercpt\=\=$name";
++ $data->{'return_path'} .= '==w' if ($tpl eq 'welcome');
++ $data->{'return_path'} .= '==r' if ($tpl eq 'remind');
++ $data->{'return_path'} .= "\@$self->{'domain'}";
++ }
++ }
++
++ $data->{'return_path'} ||= $name.&Conf::get_robot_conf($robot, 'return_path_suffix').'@'.$self->{'admin'}{'host'};
++
++ ## Lang
++ $data->{'lang'} = $data->{'user'}{'lang'} || $self->{'admin'}{'lang'} || &Conf::get_robot_conf($robot, 'lang');
++
++ ## Trying to use custom_vars
++ if (defined $self->{'admin'}{'custom_vars'}) {
++ $data->{'custom_vars'} = {};
++ foreach my $var (@{$self->{'admin'}{'custom_vars'}}) {
++ $data->{'custom_vars'}{$var->{'name'}} = $var->{'value'};
++ }
++ }
++
++ ## What file
++ my $lang = &Language::Lang2Locale($data->{'lang'});
++ my $tt2_include_path = &tools::make_tt2_include_path($robot,'mail_tt2',$lang,$self);
++
++ push @{$tt2_include_path},$self->{'dir'}; ## list directory to get the 'info' file
++ push @{$tt2_include_path},$self->{'dir'}.'/archives'; ## list archives to include the last message
++
++ foreach my $d (@{$tt2_include_path}) {
++ &tt2::add_include_path($d);
++ }
++
++ foreach my $p ('email','host','sympa','request','listmaster','wwsympa_url','title','listmaster_email') {
++ $data->{'conf'}{$p} = &Conf::get_robot_conf($robot, $p);
++ }
++
++ my @path = &tt2::get_include_path();
++ my $filename = &tools::find_file($tpl.'.tt2',@path);
++
++ unless (defined $filename) {
++ &do_log('err','Could not find template %s.tt2 in %s', $tpl, join(':',@path));
++ return undef;
++ }
++
++ $data->{'sender'} ||= $who;
++ $data->{'list'}{'lang'} = $self->{'admin'}{'lang'};
++ $data->{'list'}{'name'} = $name;
++ $data->{'list'}{'domain'} = $data->{'robot_domain'} = $robot;
++ $data->{'list'}{'host'} = $self->{'admin'}{'host'};
++ $data->{'list'}{'subject'} = $self->{'admin'}{'subject'};
++ $data->{'list'}{'owner'} = $self->get_owners();
++ $data->{'list'}{'dir'} = $self->{'dir'};
++
++ ## Sign mode
++ if ($Conf::Conf{'openssl'} &&
++ (-r $self->{'dir'}.'/cert.pem') && (-r $self->{'dir'}.'/private_key')) {
++ $sign_mode = 'smime';
++ }
++
++ # if the list have it's private_key and cert sign the message
++ # . used only for the welcome message, could be usefull in other case?
++ # . a list should have several certificats and use if possible a certificat
++ # issued by the same CA as the receipient CA if it exists
++ if ($sign_mode eq 'smime') {
++ $data->{'fromlist'} = "$name\@$data->{'list'}{'host'}";
++ $data->{'replyto'} = "$name"."-request\@$data->{'list'}{'host'}";
++ }else{
++ $data->{'fromlist'} = "$name"."-request\@$data->{'list'}{'host'}";
++ }
++
++ $data->{'from'} = $data->{'fromlist'} unless ($data->{'from'});
++ $data->{'boundary'} = '----------=_'.&tools::get_message_id($robot) unless ($data->{'boundary'});
++ $data->{'sign_mode'} = $sign_mode;
++
++ if ((&Conf::get_robot_conf($self->{'domain'}, 'dkim_feature') eq 'on')&&(&Conf::get_robot_conf($self->{'domain'}, 'dkim_add_signature_to')=~/robot/)){
++ $data->{'dkim'} = &tools::get_dkim_parameters({'robot' => $self->{'domain'}});
++ }
++ $data->{'use_bulk'} = 1 unless ($data->{'alarm'}) ; # use verp excepted for alarms. We should make this configurable in order to support Sympa server on a machine without any MTA service
++ unless (&mail::mail_file($filename, $who, $data, $self->{'domain'})) {
++ &do_log('err',"List::send_file, could not send template $filename to $who");
++ return undef;
++ }
++
++ return 1;
++}
++
++####################################################
++# send_msg
++####################################################
++# selects subscribers according to their reception
++# mode in order to distribute a message to a list
++# and sends the message to them. For subscribers in reception mode 'mail',
++# and in a msg topic context, selects only one who are subscribed to the topic
++# of the message.
++#
++#
++# IN : -$self (+): ref(List)
++# -$message (+): ref(Message)
++# OUT : -$numsmtp : number of sendmail process
++# | 0 : no subscriber for sending message in list
++# | undef
++####################################################
++sub send_msg {
++
++ my $self = shift;
++ my %param = @_;
++
++ my $message = $param{'message'};
++ my $apply_dkim_signature = $param{'apply_dkim_signature'};
++
++ do_log('debug2', 'List::send_msg(filname = %s, smime_crypted = %s,apply_dkim_signature = %s )', $message->{'filename'}, $message->{'smime_crypted'},$apply_dkim_signature);
++
++ my $hdr = $message->{'msg'}->head;
++ my $name = $self->{'name'};
++ my $robot = $self->{'domain'};
++ my $admin = $self->{'admin'};
++ my $total = $self->get_total('nocache');
++ my $sender_line = $hdr->get('From');
++ my @sender_hdr = Mail::Address->parse($sender_line);
++ my %sender_hash;
++ foreach my $email (@sender_hdr) {
++ $sender_hash{lc($email->address)} = 1;
++ }
++
++ unless ($total > 0) {
++ &do_log('info', 'No subscriber in list %s', $name);
++ return 0;
++ }
++
++ ## Bounce rate
++ my $rate = $self->get_total_bouncing() * 100 / $total;
++ if ($rate > $self->{'admin'}{'bounce'}{'warn_rate'}) {
++ unless ($self->send_notify_to_owner('bounce_rate',{'rate' => $rate})) {
++ &do_log('notice',"Unable to send notify 'bounce_rate' to $self->{'name'} listowner");
++ }
++ }
++
++ ## Who is the enveloppe sender?
++ my $host = $self->{'admin'}{'host'};
++ my $from = $name.&Conf::get_robot_conf($robot, 'return_path_suffix').'@'.$host;
++
++ # separate subscribers depending on user reception option and also if verp a dicovered some bounce for them.
++ my (@tabrcpt, @tabrcpt_notice, @tabrcpt_txt, @tabrcpt_html, @tabrcpt_url, @tabrcpt_verp, @tabrcpt_notice_verp, @tabrcpt_txt_verp, @tabrcpt_html_verp, @tabrcpt_url_verp);
++ my $mixed = ($message->{'msg'}->head->get('Content-Type') =~ /multipart\/mixed/i);
++ my $alternative = ($message->{'msg'}->head->get('Content-Type') =~ /multipart\/alternative/i);
++
++ if ( $message->{'msg'}->head->get('X-Sympa-Receipient') ) {
++
++ @tabrcpt = split /,/, $message->{'msg'}->head->get('X-Sympa-Receipient');
++ $message->{'msg'}->head->delete('X-Sympa-Receipient');
++
++ } else {
++
++ for ( my $user = $self->get_first_user(); $user; $user = $self->get_next_user() ){
++ unless ($user->{'email'}) {
++ &do_log('err','Skipping user with no email address in list %s', $name);
++ next;
++ }
++ my $options;
++ $options->{'email'} = $user->{'email'};
++ $options->{'name'} = $name;
++ $options->{'domain'} = $host;
++ my $user_data = &get_subscriber_no_object($options);
++ ## test to know if the rcpt suspended her subscription for this list
++ ## if yes, don't send the message
++ if ($user_data->{'suspend'} eq '1'){
++ if(($user_data->{'startdate'} <= time) && ((time <= $user_data->{'enddate'}) || (!$user_data->{'enddate'}))){
++ next;
++ }elsif(($user_data->{'enddate'} < time) && ($user_data->{'enddate'})){
++ ## If end date is < time, update the BDD by deleting the suspending's data
++ &restore_suspended_subscription($user->{'email'},$name,$host);
++ }
++ }
++ if ($user->{'reception'} =~ /^(digest|digestplain|summary|nomail)$/i) {
++ next;
++ } elsif ($user->{'reception'} eq 'notice') {
++ if ($user->{'bounce_address'}) {
++ push @tabrcpt_notice_verp, $user->{'email'};
++ }else{
++ push @tabrcpt_notice, $user->{'email'};
++ }
++ } elsif ($alternative and ($user->{'reception'} eq 'txt')) {
++ if ($user->{'bounce_address'}) {
++ push @tabrcpt_txt_verp, $user->{'email'};
++ }else{
++ push @tabrcpt_txt, $user->{'email'};
++ }
++ } elsif ($alternative and ($user->{'reception'} eq 'html')) {
++ if ($user->{'bounce_address'}) {
++ push @tabrcpt_html_verp, $user->{'email'};
++ }else{
++ if ($user->{'bounce_address'}) {
++ push @tabrcpt_html_verp, $user->{'email'};
++ }else{
++ push @tabrcpt_html, $user->{'email'};
++ }
++ }
++ } elsif ($mixed and ($user->{'reception'} eq 'urlize')) {
++ if ($user->{'bounce_address'}) {
++ push @tabrcpt_url_verp, $user->{'email'};
++ }else{
++ push @tabrcpt_url, $user->{'email'};
++ }
++ } elsif ($message->{'smime_crypted'} &&
++ (! -r $Conf::Conf{'ssl_cert_dir'}.'/'.&tools::escape_chars($user->{'email'}) &&
++ ! -r $Conf::Conf{'ssl_cert_dir'}.'/'.&tools::escape_chars($user->{'email'}.'@enc' ))) {
++ ## Missing User certificate
++ unless ($self->send_file('x509-user-cert-missing', $user->{'email'}, $robot, {'mail' => {'subject' => $message->{'msg'}->head->get('Subject'),
++ 'sender' => $message->{'msg'}->head->get('From')},
++ 'auto_submitted' => 'auto-generated'})) {
++ &do_log('notice',"Unable to send template 'x509-user-cert-missing' to $user->{'email'}");
++ }
++ }else{
++ if ($user->{'bounce_address'}) {
++ push @tabrcpt_verp, $user->{'email'} unless ($sender_hash{$user->{'email'}})&&($user->{'reception'} eq 'not_me');
++ }else{
++ push @tabrcpt, $user->{'email'} unless ($sender_hash{$user->{'email'}})&&($user->{'reception'} eq 'not_me');}
++ }
++ }
++ }
++
++ ## sa return 0 = Pb ?
++ unless (@tabrcpt || @tabrcpt_notice || @tabrcpt_txt || @tabrcpt_html || @tabrcpt_url || @tabrcpt_verp || @tabrcpt_notice_verp || @tabrcpt_txt_verp || @tabrcpt_html_verp || @tabrcpt_url_verp) {
++ &do_log('info', 'No subscriber for sending msg in list %s', $name);
++ return 0;
++ }
++ #save the message before modifying it
++ my $saved_msg = $message->{'msg'}->dup;
++ my $nbr_smtp = 0;
++ my $nbr_verp = 0;
++
++ # prepare verp parameter
++ my $verp_rate = $self->{'admin'}{'verp_rate'};
++ my $xsequence = $self->{'stats'}->[0] ;
++
++ my $tags_to_use;
++
++ # Define messages which can be tagged as first or last according to the verp rate.
++ # If the VERP is 100%, then all the messages are VERP. Don't try to tag not VERP
++ # messages as they won't even exist.
++ if($verp_rate eq '0%'){
++ $tags_to_use->{'tag_verp'} = 0;
++ $tags_to_use->{'tag_noverp'} = 1;
++ }else{
++ $tags_to_use->{'tag_verp'} = 1;
++ $tags_to_use->{'tag_noverp'} = 0;
++ }
++
++ my $dkim_parameters ;
++ # prepare dkim parameters
++ if ($apply_dkim_signature eq 'on') {
++ $dkim_parameters = &tools::get_dkim_parameters({'robot'=>$self->{'domain'}, 'listname'=>$self->{'name'}});
++ }
++
++ ## Storing the not empty subscribers' arrays into a hash.
++ my $available_rcpt;
++ my $available_verp_rcpt;
++
++ if (@tabrcpt) {
++ $available_rcpt->{'tabrcpt'} = \@tabrcpt;
++ $available_verp_rcpt->{'tabrcpt'} = \@tabrcpt_verp;
++ }
++ if (@tabrcpt_notice) {
++ $available_rcpt->{'tabrcpt_notice'} = \@tabrcpt_notice;
++ $available_verp_rcpt->{'tabrcpt_notice'} = \@tabrcpt_notice_verp;
++ }
++ if (@tabrcpt_txt) {
++ $available_rcpt->{'tabrcpt_txt'} = \@tabrcpt_txt;
++ $available_verp_rcpt->{'tabrcpt_txt'} = \@tabrcpt_txt_verp;
++ }
++ if (@tabrcpt_html) {
++ $available_rcpt->{'tabrcpt_html'} = \@tabrcpt_html;
++ $available_verp_rcpt->{'tabrcpt_html'} = \@tabrcpt_html_verp;
++ }
++ if (@tabrcpt_url) {
++ $available_rcpt->{'tabrcpt_url'} = \@tabrcpt_url;
++ $available_verp_rcpt->{'tabrcpt_url'} = \@tabrcpt_url_verp;
++ }
++
++ foreach my $array_name (keys %$available_rcpt) {
++ my $new_message;
++ ##Prepare message for normal reception mode
++ if ($array_name eq 'tabrcpt') {
++ ## Add a footer
++ unless ($message->{'protected'}) {
++ my $new_msg = $self->add_parts($message->{'msg'});
++ if (defined $new_msg) {
++ $message->{'msg'} = $new_msg;
++ $message->{'altered'} = '_ALTERED_';
++ }
++ }
++ $new_message = $message;
++
++ ##Prepare message for notice reception mode
++ }elsif($array_name eq 'tabrcpt_notice'){
++ my $notice_msg = $saved_msg->dup;
++ $notice_msg->bodyhandle(undef);
++ $notice_msg->parts([]);
++ $new_message = new Message($notice_msg);
++
++ ##Prepare message for txt reception mode
++ }elsif($array_name eq 'tabrcpt_txt'){
++ my $txt_msg = $saved_msg->dup;
++ if (&tools::as_singlepart($txt_msg, 'text/plain')) {
++ do_log('notice', 'Multipart message changed to singlepart');
++ }
++
++ ## Add a footer
++ my $new_msg = $self->add_parts($txt_msg);
++ if (defined $new_msg) {
++ $txt_msg = $new_msg;
++ }
++ $new_message = new Message($txt_msg);
++
++ ##Prepare message for html reception mode
++ }elsif($array_name eq 'tabrcpt_html'){
++ my $html_msg = $saved_msg->dup;
++ if (&tools::as_singlepart($html_msg, 'text/html')) {
++ do_log('notice', 'Multipart message changed to singlepart');
++ }
++ ## Add a footer
++ my $new_msg = $self->add_parts($html_msg);
++ if (defined $new_msg) {
++ $html_msg = $new_msg;
++ }
++ $new_message = new Message($html_msg);
++
++ ##Prepare message for urlize reception mode
++ }elsif($array_name eq 'tabrcpt_url'){
++ my $url_msg = $saved_msg->dup;
++
++ my $expl = $self->{'dir'}.'/urlized';
++
++ unless ((-d $expl) ||( mkdir $expl, 0775)) {
++ do_log('err', "Unable to create urlize directory $expl");
++ return undef;
++ }
++
++ my $dir1 = &tools::clean_msg_id($url_msg->head->get('Message-ID'));
++
++ ## Clean up Message-ID
++ $dir1 = &tools::escape_chars($dir1);
++ $dir1 = '/'.$dir1;
++
++ unless ( mkdir ("$expl/$dir1", 0775)) {
++ do_log('err', "Unable to create urlize directory $expl/$dir1");
++ printf "Unable to create urlized directory $expl/$dir1";
++ return 0;
++ }
++ my $mime_types = &tools::load_mime_types();
++ my @parts = $url_msg->parts();
++
++ foreach my $i (0..$#parts) {
++ my $entity = &_urlize_part ($url_msg->parts ($i), $self, $dir1, $i, $mime_types, &Conf::get_robot_conf($robot, 'wwsympa_url')) ;
++ if (defined $entity) {
++ $parts[$i] = $entity;
++ }
++ }
++
++ ## Replace message parts
++ $url_msg->parts (\@parts);
++
++ ## Add a footer
++ my $new_msg = $self->add_parts($url_msg);
++ if (defined $new_msg) {
++ $url_msg = $new_msg;
++ }
++ $new_message = new Message($url_msg);
++ }
++
++ ## TOPICS
++ my @selected_tabrcpt;
++ my @possible_verptabrcpt;
++ if ($self->is_there_msg_topic()){
++ @selected_tabrcpt = $self->select_subscribers_for_topic($new_message->get_topic(),$available_rcpt->{$array_name});
++ @possible_verptabrcpt = $self->select_subscribers_for_topic($new_message->get_topic(),$available_verp_rcpt->{$array_name});
++ } else {
++ @selected_tabrcpt = @{$available_rcpt->{$array_name}};
++ @possible_verptabrcpt = @{$available_verp_rcpt->{$array_name}};
++ }
++
++ ## Preparing VERP receipients.
++ my @verp_selected_tabrcpt = &extract_verp_rcpt($verp_rate, $xsequence,\@selected_tabrcpt, \@possible_verptabrcpt);
++
++ ## Sending non VERP.
++ my $result = &mail::mail_message('message'=>$new_message,
++ 'rcpt'=> \@selected_tabrcpt,
++ 'list'=>$self,
++ 'verp' => 'off',
++ 'dkim_parameters'=>$dkim_parameters,
++ 'tag_as_last' => $tags_to_use->{'tag_noverp'});
++ unless (defined $result) {
++ &do_log('err',"List::send_msg, could not send message to distribute from $from (verp desabled)");
++ return undef;
++ }
++ $tags_to_use->{'tag_noverp'} = 0 if ($result > 0);
++ $nbr_smtp += $result;
++
++ ## Sending VERP.
++ $result = &mail::mail_message('message'=> $new_message,
++ 'rcpt'=> \@verp_selected_tabrcpt,
++ 'list'=> $self,
++ 'verp' => 'on',
++ 'dkim_parameters'=>$dkim_parameters,
++ 'tag_as_last' => $tags_to_use->{'tag_verp'});
++ unless (defined $result) {
++ &do_log('err',"List::send_msg, could not send message to distribute from $from (verp enabled)");
++ return undef;
++ }
++ $tags_to_use->{'tag_verp'} = 0 if ($result > 0);
++ $nbr_smtp += $result;
++ $nbr_verp += $result;
++ }
++
++ return $nbr_smtp;
++}
++
++######################### SERVICE MESSAGES ##########################################
++
++###############################################################
++# send_to_editor
++###############################################################
++# Sends a message to the list editor to ask him for moderation
++# ( in moderation context : editor or editorkey). The message
++# to moderate is set in spool queuemod with name containing
++# a key (reference send to editor for moderation)
++# In context of msg_topic defined the editor must tag it
++# for the moderation (on Web interface)
++#
++# IN : -$self(+) : ref(List)
++# -$method : 'md5' - for "editorkey" | 'smtp' - for "editor"
++# -$message(+) : ref(Message) - the message to moderatte
++# OUT : $modkey : the moderation key for naming message waiting
++# for moderation in spool queuemod
++# | undef
++#################################################################
++sub send_to_editor {
++ my($self, $method, $message) = @_;
++ my ($msg, $file, $encrypt) = ($message->{'msg'}, $message->{'filename'});
++
++ $encrypt = 'smime_crypted' if ($message->{'smime_crypted'});
++ do_log('debug3', "List::send_to_editor, msg: $msg, file: $file method : $method, encrypt : $encrypt");
++
++ my($i, @rcpt);
++ my $admin = $self->{'admin'};
++ my $name = $self->{'name'};
++ my $host = $admin->{'host'};
++ my $robot = $self->{'domain'};
++ my $modqueue = $Conf::Conf{'queuemod'};
++ return unless ($name && $admin);
++
++ my @now = localtime(time);
++ my $messageid=$now[6].$now[5].$now[4].$now[3].$now[2].$now[1]."."
++ .int(rand(6)).int(rand(6)).int(rand(6)).int(rand(6)).int(rand(6)).int(rand(6))."\@".$host;
++ my $modkey=Digest::MD5::md5_hex(join('/', $self->get_cookie(),$messageid));
++ my $boundary ="__ \<$messageid\>";
++
++ ## Keeps a copy of the message
++ if ($method eq 'md5'){
++ my $mod_file = $modqueue.'/'.$self->get_list_id().'_'.$modkey;
++ unless (open(OUT, ">$mod_file")) {
++ do_log('notice', 'Could Not open %s', $mod_file);
++ return undef;
++ }
++
++ unless (open (MSG, $file)) {
++ do_log('notice', 'Could not open %s', $file);
++ return undef;
++ }
++
++ print OUT <MSG>;
++ close MSG ;
++ close(OUT);
++
++ my $tmp_dir = $modqueue.'/.'.$self->get_list_id().'_'.$modkey;
++ unless (-d $tmp_dir) {
++ unless (mkdir ($tmp_dir, 0777)) {
++ &do_log('err','Unable to create %s', $tmp_dir);
++ return undef;
++ }
++ my $mhonarc_ressources = &tools::get_filename('etc',{},'mhonarc-ressources.tt2', $robot, $self);
++
++ unless ($mhonarc_ressources) {
++ do_log('notice',"Cannot find any MhOnArc ressource file");
++ return undef;
++ }
++ ## generate HTML
++ chdir $tmp_dir;
++ my $mhonarc = &Conf::get_robot_conf($robot, 'mhonarc');
++
++ open ARCMOD, "$mhonarc -single -rcfile $mhonarc_ressources -definevars listname=$name -definevars hostname=$host $mod_file|";
++ open MSG, ">msg00000.html";
++ &do_log('debug', "$mhonarc -single -rcfile $mhonarc_ressources -definevars listname=$name -definevars hostname=$host $mod_file");
++ print MSG <ARCMOD>;
++ close MSG;
++ close ARCMOD;
++ chdir $Conf::Conf{'home'};
++ }
++ }
++
++ @rcpt = $self->get_editors_email();
++
++ my $hdr = $message->{'msg'}->head;
++
++ ## Did we find a recipient?
++ if ($#rcpt < 0) {
++ &do_log('notice', "No editor found for list %s. Trying to proceed ignoring nomail option", $self->{'name'});
++ my $messageid = $hdr->get('Message-Id');
++
++ @rcpt = $self->get_editors_email({'ignore_nomail',1});
++ &do_log('notice', 'Warning : no owner and editor defined at all in list %s', $name ) unless (@rcpt);
++
++ ## Could we find a recipient by ignoring the "nomail" option?
++ if ($#rcpt >= 0) {
++ &do_log('notice', 'All the intended recipients of message %s in list %s have set the "nomail" option. Ignoring it and sending it to all of them.', $messageid, $self->{'name'} );
++ }
++ else {
++ &do_log ('err','Impossible to send the moderation request for message %s to editors of list %s. Neither editor nor owner defined!',$messageid,$self->{'name'}) ;
++ return undef;
++ }
++ }
++
++ my $subject = MIME::EncWords::decode_mimewords($hdr->get('Subject'), Charset=>'utf8');
++ my $param = {'modkey' => $modkey,
++ 'boundary' => $boundary,
++ 'msg_from' => $message->{'sender'},
++ 'subject' => $subject,
++ 'spam_status' => $message->{'spam_status'},
++ 'mod_spool_size' => $self->get_mod_spool_size(),
++ 'method' => $method};
++
++ if ($self->is_there_msg_topic()) {
++ $param->{'request_topic'} = 1;
++ }
++
++ foreach my $recipient (@rcpt) {
++ if ($encrypt eq 'smime_crypted') {
++ ## is $msg->body_as_string respect base64 number of char per line ??
++ my $cryptedmsg = &tools::smime_encrypt($msg->head, $msg->body_as_string, $recipient);
++ unless ($cryptedmsg) {
++ &do_log('notice', 'Failed encrypted message for moderator');
++ # xxxx send a generic error message : X509 cert missing
++ return undef;
++ }
++
++ my $crypted_file = $Conf::Conf{'tmpdir'}.'/'.$self->get_list_id().'.moderate.'.$$;
++ unless (open CRYPTED, ">$crypted_file") {
++ &do_log('notice', 'Could not create file %s', $crypted_file);
++ return undef;
++ }
++ print CRYPTED $cryptedmsg;
++ close CRYPTED;
++ $param->{'msg_path'} = $crypted_file;
++
++ }else{
++ $param->{'msg_path'} = $file;
++ }
++ # create a one time ticket that will be used as un md5 URL credential
++
++ unless ($param->{'one_time_ticket'} = &Auth::create_one_time_ticket($recipient,$robot,'modindex/'.$name,'mail')){
++ &do_log('notice',"Unable to create one_time_ticket for $recipient, service modindex/$name");
++ }else{
++ &do_log('notice',"ticket : $param->{'one_time_ticket'}");
++ }
++ &tt2::allow_absolute_path();
++ $param->{'auto_submitted'} = 'auto-forwarded';
++
++ unless ($self->send_file('moderate', $recipient, $self->{'domain'}, $param)) {
++ &do_log('notice',"Unable to send template 'moderate' to $recipient");
++ return undef;
++ }
++ }
++# Old code 5.4 and before to be removed in 5.5
++# if ($encrypt eq 'smime_crypted') {
++#
++# ## Send a different crypted message to each moderator
++# foreach my $recipient (@rcpt) {
++#
++# # create a one time ticket that will be used as un md5 URL credential
++# $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'email'},$robot,'modindex/'.$name,$ip)
++#
++# ## $msg->body_as_string respecte-t-il le Base64 ??
++# my $cryptedmsg = &tools::smime_encrypt($msg->head, $msg->body_as_string, $recipient); #
++# unless ($cryptedmsg) {
++# &do_log('notice', 'Failed encrypted message for moderator');
++# # xxxx send a generic error message : X509 cert missing
++# return undef;
++# }
++#
++# my $crypted_file = $Conf::Conf{'tmpdir'}.'/'.$self->get_list_id().'.moderate.'.$$;
++# unless (open CRYPTED, ">$crypted_file") {
++# &do_log('notice', 'Could not create file %s', $crypted_file);
++# return undef;
++# }
++# print CRYPTED $cryptedmsg;
++# close CRYPTED;
++#
++#
++# $param->{'msg_path'} = $crypted_file;
++#
++# &tt2::allow_absolute_path();
++# unless ($self->send_file('moderate', $recipient, $self->{'domain'}, $param)) {
++# &do_log('notice',"Unable to send template 'moderate' to $recipient");
++# return undef;
++# }
++# }
++# }else{
++# $param->{'msg_path'} = $file;
++#
++# &tt2::allow_absolute_path();
++# unless ($self->send_file('moderate', \@rcpt, $self->{'domain'}, $param)) {
++# &do_log('notice',"Unable to send template 'moderate' to $self->{'name'} editors");
++# return undef;
++# }
++# }
++ return $modkey;
++}
++
++####################################################
++# send_auth
++####################################################
++# Sends an authentication request for a sent message to distribute.
++# The message for distribution is copied in the authqueue
++# spool in order to wait for confirmation by its sender.
++# This message is named with a key.
++# In context of msg_topic defined, the sender must tag it
++# for the confirmation
++#
++# IN : -$self (+): ref(List)
++# -$message (+): ref(Message)
++#
++# OUT : $authkey : the key for naming message waiting
++# for confirmation (or tagging) in spool queueauth
++# | undef
++####################################################
++sub send_auth {
++ my($self, $message) = @_;
++ my ($sender, $msg, $file) = ($message->{'sender'}, $message->{'msg'}, $message->{'filename'});
++ &do_log('debug3', 'List::send_auth(%s, %s)', $sender, $file);
++
++ ## Ensure 1 second elapsed since last message
++ sleep (1);
++
++ my($i, @rcpt);
++ my $admin = $self->{'admin'};
++ my $name = $self->{'name'};
++ my $host = $admin->{'host'};
++ my $robot = $self->{'domain'};
++ my $authqueue = $Conf::Conf{'queueauth'};
++ return undef unless ($name && $admin);
++
++
++ my @now = localtime(time);
++ my $messageid = $now[6].$now[5].$now[4].$now[3].$now[2].$now[1]."."
++ .int(rand(6)).int(rand(6)).int(rand(6)).int(rand(6))
++ .int(rand(6)).int(rand(6))."\@".$host;
++ my $authkey = Digest::MD5::md5_hex(join('/', $self->get_cookie(),$messageid));
++
++ my $auth_file = $authqueue.'/'.$self->get_list_id().'_'.$authkey;
++ unless (open OUT, ">$auth_file") {
++ &do_log('notice', 'Cannot create file %s', $auth_file);
++ return undef;
++ }
++
++ unless (open IN, $file) {
++ &do_log('notice', 'Cannot open file %s', $file);
++ return undef;
++ }
++
++ print OUT <IN>;
++
++ close IN; close OUT;
++
++ my $param = {'authkey' => $authkey,
++ 'boundary' => "----------------- Message-Id: \<$messageid\>",
++ 'file' => $file};
++
++ if ($self->is_there_msg_topic()) {
++ $param->{'request_topic'} = 1;
++ }
++
++ &tt2::allow_absolute_path();
++ $param->{'auto_submitted'} = 'auto-replied';
++ unless ($self->send_file('send_auth',$sender,$robot,$param)) {
++ &do_log('notice',"Unable to send template 'send_auth' to $sender");
++ return undef;
++ }
++
++ return $authkey;
++}
++
++####################################################
++# request_auth
++####################################################
++# sends an authentification request for a requested
++# command .
++#
++#
++# IN : -$self : ref(List) if is present
++# -$email(+) : recepient (the personn who asked
++# for the command)
++# -$cmd : -signoff|subscribe|add|del|remind if $self
++# -remind else
++# -$robot(+) : robot
++# -@param : 0 : used if $cmd = subscribe|add|del|invite
++# 1 : used if $cmd = add
++#
++# OUT : 1 | undef
++#
++####################################################
++sub request_auth {
++ do_log('debug2', 'List::request_auth(%s, %s, %s, %s)', @_);
++ my $first_param = shift;
++ my ($self, $email, $cmd, $robot, @param);
++
++ if (ref($first_param) eq 'List') {
++ $self = $first_param;
++ $email= shift;
++ }else {
++ $email = $first_param;
++ }
++ $cmd = shift;
++ $robot = shift;
++ @param = @_;
++ &do_log('debug3', 'List::request_auth() List : %s,$email: %s cmd : %s',$self->{'name'},$email,$cmd);
++
++
++ my $keyauth;
++ my $data = {'to' => $email};
++
++
++ if (ref($self) eq 'List') {
++ my $listname = $self->{'name'};
++ $data->{'list_context'} = 1;
++
++ if ($cmd =~ /signoff$/){
++ $keyauth = $self->compute_auth ($email, 'signoff');
++ $data->{'command'} = "auth $keyauth $cmd $listname $email";
++ $data->{'type'} = 'signoff';
++
++ }elsif ($cmd =~ /subscribe$/){
++ $keyauth = $self->compute_auth ($email, 'subscribe');
++ $data->{'command'} = "auth $keyauth $cmd $listname $param[0]";
++ $data->{'type'} = 'subscribe';
++
++ }elsif ($cmd =~ /add$/){
++ $keyauth = $self->compute_auth ($param[0],'add');
++ $data->{'command'} = "auth $keyauth $cmd $listname $param[0] $param[1]";
++ $data->{'type'} = 'add';
++
++ }elsif ($cmd =~ /del$/){
++ my $keyauth = $self->compute_auth($param[0], 'del');
++ $data->{'command'} = "auth $keyauth $cmd $listname $param[0]";
++ $data->{'type'} = 'del';
++
++ }elsif ($cmd eq 'remind'){
++ my $keyauth = $self->compute_auth('','remind');
++ $data->{'command'} = "auth $keyauth $cmd $listname";
++ $data->{'type'} = 'remind';
++
++ }elsif ($cmd eq 'invite'){
++ my $keyauth = $self->compute_auth($param[0],'invite');
++ $data->{'command'} = "auth $keyauth $cmd $listname $param[0]";
++ $data->{'type'} = 'invite';
++ }
++
++ $data->{'command_escaped'} = &tt2::escape_url($data->{'command'});
++ $data->{'auto_submitted'} = 'auto-replied';
++ unless ($self->send_file('request_auth',$email,$robot,$data)) {
++ &do_log('notice',"Unable to send template 'request_auth' to $email");
++ return undef;
++ }
++
++ }else {
++ if ($cmd eq 'remind'){
++ my $keyauth = &List::compute_auth('',$cmd);
++ $data->{'command'} = "auth $keyauth $cmd *";
++ $data->{'command_escaped'} = &tt2::escape_url($data->{'command'});
++ $data->{'type'} = 'remind';
++
++ }
++ $data->{'auto_submitted'} = 'auto-replied';
++ unless (&send_global_file('request_auth',$email,$robot,$data)) {
++ &do_log('notice',"Unable to send template 'request_auth' to $email");
++ return undef;
++ }
++ }
++
++
++ return 1;
++}
++
++
++####################################################
++# archive_send
++####################################################
++# sends an archive file to someone (text archive
++# file : independant from web archives)
++#
++# IN : -$self(+) : ref(List)
++# -$who(+) : recepient
++# -file(+) : name of the archive file to send
++# OUT : - | undef
++#
++######################################################
++sub archive_send {
++ my($self, $who, $file) = @_;
++ do_log('debug', 'List::archive_send(%s, %s)', $who, $file);
++
++ return unless ($self->is_archived());
++
++ my $dir = &Conf::get_robot_conf($self->{'domain'},'arc_path').'/'.$self->get_list_id();
++ my $msg_list = Archive::scan_dir_archive($dir, $file);
++
++ my $subject = 'File '.$self->{'name'}.' '.$file ;
++ my $param = {'to' => $who,
++ 'subject' => $subject,
++ 'msg_list' => $msg_list } ;
++
++ $param->{'boundary1'} = &tools::get_message_id($self->{'domain'});
++ $param->{'boundary2'} = &tools::get_message_id($self->{'domain'});
++ $param->{'from'} = &Conf::get_robot_conf($self->{'domain'},'sympa');
++
++# open TMP2, ">/tmp/digdump"; &tools::dump_var($param, 0, \*TMP2); close TMP2;
++$param->{'auto_submitted'} = 'auto-replied';
++ unless ($self->send_file('get_archive',$who,$self->{'domain'},$param)) {
++ &do_log('notice',"Unable to send template 'archive_send' to $who");
++ return undef;
++ }
++
++}
++
++####################################################
++# archive_send_last
++####################################################
++# sends last archive file
++#
++# IN : -$self(+) : ref(List)
++# -$who(+) : recepient
++# OUT : - | undef
++#
++######################################################
++sub archive_send_last {
++ my($self, $who) = @_;
++ do_log('debug', 'List::archive_send_last(%s, %s)',$self->{'listname'}, $who);
++
++ return unless ($self->is_archived());
++ my $dir = $self->{'dir'}.'/archives' ;
++
++ my $mail = new Message("$dir/last_message",'noxsympato');
++ unless (defined $mail) {
++ &do_log('err', 'Unable to create Message object %s', "$dir/last_message");
++ return undef;
++ }
++
++ my @msglist;
++ my $msg = {};
++ $msg->{'id'} = 1;
++
++ $msg->{'subject'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('Subject'), Charset=>'utf8');
++ chomp $msg->{'subject'};
++ $msg->{'from'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('From'), Charset=>'utf8');
++ chomp $msg->{'from'};
++ $msg->{'date'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('Date'), Charset=>'utf8');
++ chomp $msg->{'date'};
++
++ $msg->{'full_msg'} = $mail->{'msg'}->as_string;
++
++ push @msglist,$msg;
++
++ my $subject = 'File '.$self->{'name'}.'.last_message' ;
++ my $param = {'to' => $who,
++ 'subject' => $subject,
++ 'msg_list' => \@msglist } ;
++
++
++ $param->{'boundary1'} = &tools::get_message_id($self->{'domain'});
++ $param->{'boundary2'} = &tools::get_message_id($self->{'domain'});
++ $param->{'from'} = &Conf::get_robot_conf($self->{'domain'},'sympa');
++ $param->{'auto_submitted'} = 'auto-replied';
++# open TMP2, ">/tmp/digdump"; &tools::dump_var($param, 0, \*TMP2); close TMP2;
++
++ unless ($self->send_file('get_archive',$who,$self->{'domain'},$param)) {
++ &do_log('notice',"Unable to send template 'archive_send' to $who");
++ return undef;
++ }
++
++}
++
++
++######################### NOTIFICATION SENDING ######################################
++
++
++####################################################
++# send_notify_to_listmaster
++####################################################
++# Sends a notice to listmaster by parsing
++# listmaster_notification.tt2 template
++#
++# IN : -$operation (+): notification type
++# -$robot (+): robot
++# -$param(+) : ref(HASH) | ref(ARRAY)
++# values for template parsing
++#
++# OUT : 1 | undef
++#
++######################################################
++sub send_notify_to_listmaster {
++
++ my ($operation, $robot, $param) = @_;
++ unless ($operation eq 'logs_failed') {
++ &do_log('debug2', 'List::send_notify_to_listmaster(%s,%s )', $operation, $robot );
++ }
++
++ unless ($operation eq 'logs_failed') {
++ unless (defined $operation) {
++ &do_log('err','List::send_notify_to_listmaster(%s) : missing incoming parameter "$operation"');
++ return undef;
++ }
++ unless (defined $robot) {
++ &do_log('err','List::send_notify_to_listmaster(%s) : missing incoming parameter "$robot"');
++ return undef;
++ }
++ }
++ my $host = &Conf::get_robot_conf($robot, 'host');
++ my $listmaster = &Conf::get_robot_conf($robot, 'listmaster');
++ my $to = "$Conf::Conf{'listmaster_email'}\@$host";
++ my $options = {}; ## options for send_global_file()
++
++ if ($operation eq 'logs_failed') {
++ my $data = {'to' => $to,
++ 'type' => $operation,
++ 'auto_submitted' => 'auto-generated',
++ 'alarm' => 1, # bypass bulk
++ };
++
++ for my $i(0..$#{$param}) {
++ $data->{"param$i"} = $param->[$i];
++ }
++ unless (&send_global_file('listmaster_notification', $listmaster, $robot, $data, $options)) {
++ return undef;
++ }
++ return 1;
++ }
++
++ if (ref($param) eq 'HASH') {
++
++ $param->{'to'} = $to;
++ $param->{'type'} = $operation;
++ $param->{'auto_submitted'} = 'auto-generated';
++
++ ## Prepare list-related data
++ if ($param->{'list'} && ref($param->{'list'}) eq 'List') {
++ my $list = $param->{'list'};
++ $param->{'list'} = {'name' => $list->{'name'},
++ 'host' => $list->{'domain'},
++ 'subject' => $list->{'admin'}{'subject'},
++ };
++ }
++
++ ## Automatic action done on bouncing adresses
++ if ($operation eq 'automatic_bounce_management') {
++ my $list = new List ($param->{'listname'}, $robot);
++ unless (defined $list) {
++ &do_log('err','Parameter %s is not a valid list', $param->{'listname'});
++ return undef;
++ }
++ unless ($list->send_file('listmaster_notification',$listmaster, $robot, $param, $options)) {
++ &do_log('notice',"Unable to send template 'listmaster_notification' to $listmaster");
++ return undef;
++ }
++
++ }else {
++
++ ## No DataBase | DataBase restored
++ if (($operation eq 'no_db')||($operation eq 'db_restored')) {
++
++ $param->{'db_name'} = &Conf::get_robot_conf($robot, 'db_name');
++ $options->{'skip_db'} = 1; ## Skip DB access because DB is not accessible
++
++
++ ## Loop detected in Sympa
++ }elsif ($operation eq 'loop_command') {
++ $param->{'boundary'} = '----------=_'.&tools::get_message_id($robot);
++ &tt2::allow_absolute_path();
++ }
++
++
++ foreach my $email (split (/\,/, $listmaster)) {
++ if (($operation eq 'request_list_creation')or($operation eq 'request_list_renaming')) {
++ $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($email,$robot,'get_pending_lists',$param->{'ip'});
++ }
++ $param->{'alarm'} = 1;
++ unless (&send_global_file('listmaster_notification', $email, $robot, $param, $options)) {
++ &do_log('notice',"Unable to send template 'listmaster_notification' to $listmaster");
++ return undef;
++ }
++ }
++ }
++
++ }elsif(ref($param) eq 'ARRAY') {
++
++ my $data = {'to' => $to,
++ 'type' => $operation,
++ 'auto_submitted' => 'auto-generated',
++ 'alarm' => 1
++ };
++ for my $i(0..$#{$param}) {
++ $data->{"param$i"} = $param->[$i];
++ }
++ unless (&send_global_file('listmaster_notification', $listmaster, $robot, $data, $options)) {
++ &do_log('notice',"Unable to send template 'listmaster_notification' to $listmaster");
++ return undef;
++ }
++ }else {
++ &do_log('err','List::send_notify_to_listmaster(%s,%s) : error on incoming parameter "$param", it must be a ref on HASH or a ref on ARRAY', $operation, $robot );
++ return undef;
++ }
++ return 1;
++}
++
++
++####################################################
++# send_notify_to_owner
++####################################################
++# Sends a notice to list owner(s) by parsing
++# listowner_notification.tt2 template
++#
++# IN : -$self (+): ref(List)
++# -$operation (+): notification type
++# -$param(+) : ref(HASH) | ref(ARRAY)
++# values for template parsing
++#
++# OUT : 1 | undef
++#
++######################################################
++sub send_notify_to_owner {
++
++ my ($self,$operation,$param) = @_;
++ &do_log('debug2', 'List::send_notify_to_owner(%s, %s)', $self->{'name'}, $operation);
++
++ my $host = $self->{'admin'}{'host'};
++ my @to = $self->get_owners_email();
++ my $robot = $self->{'domain'};
++
++ unless (@to) {
++ do_log('notice', 'No owner defined or all of them use nomail option in list %s ; using listmasters as default', $self->{'name'} );
++ @to = split /,/, &Conf::get_robot_conf($robot, 'listmaster');
++ }
++ unless (defined $operation) {
++ &do_log('err','List::send_notify_to_owner(%s) : missing incoming parameter "$operation"', $self->{'name'});
++ return undef;
++ }
++
++ if (ref($param) eq 'HASH') {
++
++ $param->{'auto_submitted'} = 'auto-generated';
++ $param->{'to'} =join(',', @to);
++ $param->{'type'} = $operation;
++
++
++ if ($operation eq 'warn-signoff') {
++ $param->{'escaped_gecos'} = $param->{'gecos'};
++ $param->{'escaped_gecos'} =~ s/\s/\%20/g;
++ $param->{'escaped_who'} = $param->{'who'};
++ $param->{'escaped_who'} =~ s/\s/\%20/g;
++ foreach my $owner (@to) {
++ $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($owner,$robot,'search/'.$self->{'name'}.'/'.$param->{'escaped_who'},$param->{'ip'});
++ unless ($self->send_file('listowner_notification',[$owner], $robot,$param)) {
++ &do_log('notice',"Unable to send template 'listowner_notification' to $self->{'name'} list owner $owner");
++ }
++ }
++ }elsif ($operation eq 'subrequest') {
++ $param->{'escaped_gecos'} = $param->{'gecos'};
++ $param->{'escaped_gecos'} =~ s/\s/\%20/g;
++ $param->{'escaped_who'} = $param->{'who'};
++ $param->{'escaped_who'} =~ s/\s/\%20/g;
++ foreach my $owner (@to) {
++ $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($owner,$robot,'subindex/'.$self->{'name'},$param->{'ip'});
++ unless ($self->send_file('listowner_notification',[$owner], $robot,$param)) {
++ &do_log('notice',"Unable to send template 'listowner_notification' to $self->{'name'} list owner $owner");
++ }
++ }
++ }else{
++ if ($operation eq 'sigrequest') {
++ $param->{'escaped_who'} = $param->{'who'};
++ $param->{'escaped_who'} =~ s/\s/\%20/g;
++ $param->{'sympa'} = &Conf::get_robot_conf($self->{'domain'}, 'sympa');
++
++ }elsif ($operation eq 'bounce_rate') {
++ $param->{'rate'} = int ($param->{'rate'} * 10) / 10;
++ }
++ unless ($self->send_file('listowner_notification',\@to, $robot,$param)) {
++ &do_log('notice',"Unable to send template 'listowner_notification' to $self->{'name'} list owner");
++ return undef;
++ }
++ }
++
++ }elsif(ref($param) eq 'ARRAY') {
++
++ my $data = {'to' => join(',', @to),
++ 'type' => $operation};
++
++ for my $i(0..$#{$param}) {
++ $data->{"param$i"} = $param->[$i];
++ }
++ unless ($self->send_file('listowner_notification', \@to, $robot, $data)) {
++ &do_log('notice',"Unable to send template 'listowner_notification' to $self->{'name'} list owner");
++ return undef;
++ }
++
++ }else {
++
++ &do_log('err','List::send_notify_to_owner(%s,%s) : error on incoming parameter "$param", it must be a ref on HASH or a ref on ARRAY', $self->{'name'},$operation);
++ return undef;
++ }
++ return 1;
++}
++
++#########################
++## Delete a pictures file
++#########################
++# remove picture from user $2 in list $1
++#########################
++sub delete_user_picture {
++ my ($self,$email) = @_;
++ do_log('debug2', 'delete_user_picture(%s)', $email);
++
++ my $fullfilename = undef;
++ my $filename = &tools::md5_fingerprint($email);
++ my $name = $self->{'name'};
++ my $robot = $self->{'domain'};
++
++ foreach my $ext ('.gif','.jpg','.jpeg','.png') {
++ if(-f &Conf::get_robot_conf($robot,'pictures_path').'/'.$name.'@'.$robot.'/'.$filename.$ext) {
++ my $file = &Conf::get_robot_conf($robot,'pictures_path').'/'.$name.'@'.$robot.'/'.$filename.$ext;
++ $fullfilename = $file;
++ last;
++ }
++ }
++
++ if (defined $fullfilename) {
++ unless(unlink($fullfilename)) {
++ do_log('err', 'delete_user_picture() : Failed to delete '.$fullfilename);
++ return undef;
++ }
++
++ do_log('notice', 'delete_user_picture() : File deleted successfull '.$fullfilename);
++ }
++
++ return 1;
++}
++
++
++####################################################
++# send_notify_to_editor
++####################################################
++# Sends a notice to list editor(s) or owner (if no editor)
++# by parsing listeditor_notification.tt2 template
++#
++# IN : -$self (+): ref(List)
++# -$operation (+): notification type
++# -$param(+) : ref(HASH) | ref(ARRAY)
++# values for template parsing
++#
++# OUT : 1 | undef
++#
++######################################################
++sub send_notify_to_editor {
++
++ my ($self,$operation,$param) = @_;
++ &do_log('debug2', 'List::send_notify_to_editor(%s, %s)', $self->{'name'}, $operation);
++
++ my @to = $self->get_editors_email();
++ my $robot = $self->{'domain'};
++ $param->{'auto_submitted'} = 'auto-generated';
++
++ unless (@to) {
++ do_log('notice', 'Warning : no editor or owner defined or all of them use nomail option in list %s', $self->{'name'} );
++ return undef;
++ }
++ unless (defined $operation) {
++ &do_log('err','List::send_notify_to_editor(%s) : missing incoming parameter "$operation"', $self->{'name'});
++ return undef;
++ }
++ if (ref($param) eq 'HASH') {
++
++ $param->{'to'} =join(',', @to);
++ $param->{'type'} = $operation;
++
++ unless ($self->send_file('listeditor_notification',\@to, $robot,$param)) {
++ &do_log('notice',"Unable to send template 'listeditor_notification' to $self->{'name'} list editor");
++ return undef;
++ }
++
++ }elsif(ref($param) eq 'ARRAY') {
++
++ my $data = {'to' => join(',', @to),
++ 'type' => $operation};
++
++ foreach my $i(0..$#{$param}) {
++ $data->{"param$i"} = $param->[$i];
++ }
++ unless ($self->send_file('listeditor_notification', \@to, $robot, $data)) {
++ &do_log('notice',"Unable to send template 'listeditor_notification' to $self->{'name'} list editor");
++ return undef;
++ }
++
++ }else {
++ &do_log('err','List::send_notify_to_editor(%s,%s) : error on incoming parameter "$param", it must be a ref on HASH or a ref on ARRAY', $self->{'name'},$operation);
++ return undef;
++ }
++ return 1;
++}
++
++
++####################################################
++# send_notify_to_user
++####################################################
++# Send a notice to a user (sender, subscriber ...)
++# by parsing user_notification.tt2 template
++#
++# IN : -$self (+): ref(List)
++# -$operation (+): notification type
++# -$user(+): email of notified user
++# -$param(+) : ref(HASH) | ref(ARRAY)
++# values for template parsing
++#
++# OUT : 1 | undef
++#
++######################################################
++sub send_notify_to_user{
++
++ my ($self,$operation,$user,$param) = @_;
++ &do_log('debug2', 'List::send_notify_to_user(%s, %s, %s)', $self->{'name'}, $operation, $user);
++
++ my $host = $self->{'admin'}->{'host'};
++ my $robot = $self->{'domain'};
++ $param->{'auto_submitted'} = 'auto-generated';
++
++ unless (defined $operation) {
++ &do_log('err','List::send_notify_to_user(%s) : missing incoming parameter "$operation"', $self->{'name'});
++ return undef;
++ }
++ unless ($user) {
++ &do_log('err','List::send_notify_to_user(%s) : missing incoming parameter "$user"', $self->{'name'});
++ return undef;
++ }
++
++ if (ref($param) eq "HASH") {
++ $param->{'to'} = $user;
++ $param->{'type'} = $operation;
++
++ if ($operation eq 'auto_notify_bouncers') {
++ }
++
++ unless ($self->send_file('user_notification',$user,$robot,$param)) {
++ &do_log('notice',"Unable to send template 'user_notification' to $user");
++ return undef;
++ }
++
++ }elsif (ref($param) eq "ARRAY") {
++
++ my $data = {'to' => $user,
++ 'type' => $operation};
++
++ for my $i(0..$#{$param}) {
++ $data->{"param$i"} = $param->[$i];
++ }
++ unless ($self->send_file('user_notification',$user,$robot,$data)) {
++ &do_log('notice',"Unable to send template 'user_notification' to $user");
++ return undef;
++ }
++
++ }else {
++
++ &do_log('err','List::send_notify_to_user(%s,%s,%s) : error on incoming parameter "$param", it must be a ref on HASH or a ref on ARRAY',
++ $self->{'name'},$operation,$user);
++ return undef;
++ }
++ return 1;
++}
++# #
++# #
++# #
++######################### END functions for sending messages ############################
++
++
++
++## genererate a md5 checksum using private cookie and parameters
++sub compute_auth {
++ do_log('debug3', 'List::compute_auth(%s, %s, %s)', @_);
++
++ my $first_param = shift;
++ my ($self, $email, $cmd);
++
++ if (ref($first_param) eq 'List') {
++ $self = $first_param;
++ $email= shift;
++ }else {
++ $email = $email;
++ }
++ $cmd = shift;
++
++ $email =~ y/[A-Z]/[a-z]/;
++ $cmd =~ y/[A-Z]/[a-z]/;
++
++ my ($cookie, $key, $listname) ;
++
++ if ($self){
++ $listname = $self->{'name'};
++ $cookie = $self->get_cookie() || $Conf::Conf{'cookie'};
++ }else {
++ $cookie = $Conf::Conf{'cookie'};
++ }
++
++ $key = substr(Digest::MD5::md5_hex(join('/', $cookie, $listname, $email, $cmd)), -8) ;
++
++ return $key;
++}
++
++
++## Add footer/header to a message
++sub add_parts {
++ my ($self, $msg) = @_;
++ my ($listname,$type) = ($self->{'name'}, $self->{'admin'}{'footer_type'});
++ my $listdir = $self->{'dir'};
++ do_log('debug2', 'List:add_parts(%s, %s, %s)', $msg, $listname, $type);
++
++ my ($header, $headermime);
++ foreach my $file ("$listdir/message.header",
++ "$listdir/message.header.mime",
++ "$Conf::Conf{'etc'}/mail_tt2/message.header",
++ "$Conf::Conf{'etc'}/mail_tt2/message.header.mime") {
++ if (-f $file) {
++ unless (-r $file) {
++ &do_log('notice', 'Cannot read %s', $file);
++ next;
++ }
++ $header = $file;
++ last;
++ }
++ }
++
++ my ($footer, $footermime);
++ foreach my $file ("$listdir/message.footer",
++ "$listdir/message.footer.mime",
++ "$Conf::Conf{'etc'}/mail_tt2/message.footer",
++ "$Conf::Conf{'etc'}/mail_tt2/message.footer.mime") {
++ if (-f $file) {
++ unless (-r $file) {
++ &do_log('notice', 'Cannot read %s', $file);
++ next;
++ }
++ $footer = $file;
++ last;
++ }
++ }
++
++ ## No footer/header
++ unless (-f $footer or -f $header) {
++ return undef;
++ }
++
++ my $parser = new MIME::Parser;
++ $parser->output_to_core(1);
++
++ ## Msg Content-Type
++ my $content_type = $msg->head->get('Content-Type');
++
++ ## MIME footer/header
++ if ($type eq 'append'){
++
++ my (@footer_msg, @header_msg);
++ if ($header) {
++ open HEADER, $header;
++ @header_msg = <HEADER>;
++ close HEADER;
++ }
++
++ if ($footer) {
++ open FOOTER, $footer;
++ @footer_msg = <FOOTER>;
++ close FOOTER;
++ }
++
++ if (!$content_type or $content_type =~ /^text\/plain/i) {
++
++ my @body;
++ if (defined $msg->bodyhandle) {
++ @body = $msg->bodyhandle->as_lines;
++ }
++
++ $msg->bodyhandle (new MIME::Body::Scalar [@header_msg,@body,@footer_msg] );
++
++ }elsif ($content_type =~ /^multipart\/mixed/i) {
++ ## Append to first part if text/plain
++
++ if ($msg->parts(0)->head->get('Content-Type') =~ /^text\/plain/i) {
++
++ my $part = $msg->parts(0);
++ my @body;
++
++ if (defined $part->bodyhandle) {
++ @body = $part->bodyhandle->as_lines;
++ }
++ $part->bodyhandle (new MIME::Body::Scalar [@header_msg,@body,@footer_msg] );
++ }else {
++ &do_log('notice', 'First part of message not in text/plain ; ignoring footers and headers');
++ }
++
++ }elsif ($content_type =~ /^multipart\/alternative/i) {
++ ## Append to first text/plain part
++
++ foreach my $part ($msg->parts) {
++ &do_log('debug3', 'TYPE: %s', $part->head->get('Content-Type'));
++ if ($part->head->get('Content-Type') =~ /^text\/plain/i) {
++
++ my @body;
++ if (defined $part->bodyhandle) {
++ @body = $part->bodyhandle->as_lines;
++ }
++ $part->bodyhandle (new MIME::Body::Scalar [@header_msg,@body,@footer_msg] );
++ next;
++ }
++ }
++ }
++
++ }else {
++ if ($content_type =~ /^multipart\/alternative/i || $content_type =~ /^multipart\/related/i) {
++
++ &do_log('notice', 'Making $1 into multipart/mixed');
++ $msg->make_multipart("mixed",Force=>1);
++ }
++
++ if ($header) {
++ if ($header =~ /\.mime$/) {
++
++ my $header_part = $parser->parse_in($header);
++ $msg->make_multipart unless $msg->is_multipart;
++ $msg->add_part($header_part, 0); ## Add AS FIRST PART (0)
++
++ ## text/plain header
++ }else {
++
++ $msg->make_multipart unless $msg->is_multipart;
++ my $header_part = build MIME::Entity Path => $header,
++ Type => "text/plain",
++ Filename => "message-header.txt",
++ Encoding => "8bit",
++ Charset => "UTF-8";
++ $msg->add_part($header_part, 0);
++ }
++ }
++ if ($footer) {
++ if ($footer =~ /\.mime$/) {
++
++ my $footer_part = $parser->parse_in($footer);
++ $msg->make_multipart unless $msg->is_multipart;
++ $msg->add_part($footer_part);
++
++ ## text/plain footer
++ }else {
++
++ $msg->make_multipart unless $msg->is_multipart;
++ $msg->attach(Path => $footer,
++ Type => "text/plain",
++ Filename => "message-footer.txt",
++ Encoding => "8bit",
++ Charset => "UTF-8"
++ );
++ }
++ }
++ }
++
++ return $msg;
++}
++
++
++
++
++## Delete a new user to Database (in User table)
++sub delete_user_db {
++ my @users = @_;
++
++ do_log('debug2', 'List::delete_user_db');
++
++ return undef unless ($#users >= 0);
++
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ foreach my $who (@users) {
++ my $statement;
++
++ $who = &tools::clean_email($who);
++
++ ## Update field
++ $statement = sprintf "DELETE FROM user_table WHERE (email_user =%s)", $dbh->quote($who);
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ next;
++ }
++ }
++
++ return $#users + 1;
++}
++
++## Delete the indicate users from the list.
++## IN : - ref to array
++## - option exclude
++##
++## $list->delete_user('users' => \@u, 'exclude' => 1)
++## $list->delete_user('users' => [$email], 'exclude' => 1)
++sub delete_user {
++ my $self = shift;
++ my %param = @_;
++ my @u = @{$param{'users'}};
++ my $exclude = $param{'exclude'};
++ &do_log('debug2', 'List::delete_user');
++
++ my $name = $self->{'name'};
++ my $total = 0;
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ foreach my $who (@u) {
++ $who = &tools::clean_email($who);
++
++ my $statement;
++ ## Include in exclusion_table only if option is set.
++ if($exclude == 1){
++ ## Insert in exclusion_table if $user->{'included'} eq '1'
++ &insert_delete_exclusion($who, $name, $self->{'domain'}, 'insert');
++
++ }
++
++ $list_cache{'is_user'}{$self->{'domain'}}{$name}{$who} = undef;
++ $list_cache{'get_subscriber'}{$self->{'domain'}}{$name}{$who} = undef;
++
++ ## Delete record in SUBSCRIBER
++ $statement = sprintf "DELETE FROM subscriber_table WHERE (user_subscriber=%s AND list_subscriber=%s AND robot_subscriber=%s)",
++ $dbh->quote($who),
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'});
++
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement %s : %s', $statement, $dbh->errstr);
++ next;
++ }
++
++ $total--;
++ }
++
++ $self->{'total'} += $total;
++ $self->savestats();
++ &delete_user_picture($self,shift(@u));
++ return (-1 * $total);
++}
++
++
++## Delete the indicated admin users from the list.
++sub delete_admin_user {
++ my($self, $role, @u) = @_;
++ do_log('debug2', 'List::delete_admin_user(%s)', $role);
++
++ my $name = $self->{'name'};
++ my $total = 0;
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ foreach my $who (@u) {
++ $who = &tools::clean_email($who);
++ my $statement;
++
++ $list_cache{'is_admin_user'}{$self->{'domain'}}{$name}{$who} = undef;
++
++ ## Delete record in ADMIN
++ $statement = sprintf "DELETE FROM admin_table WHERE (user_admin=%s AND list_admin=%s AND robot_admin=%s AND role_admin=%s)",
++ $dbh->quote($who),
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $dbh->quote($role);
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement %s : %s', $statement, $dbh->errstr);
++ next;
++ }
++
++ $total--;
++ }
++
++ return (-1 * $total);
++}
++
++## Delete all admin_table entries
++sub delete_admin_all {
++ &do_log('debug2', 'List::delete_admin_all()');
++
++ my $total = 0;
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ my $statement;
++
++ ## Delete record in ADMIN
++ $statement = sprintf "DELETE FROM admin_table";
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement %s : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ return 1;
++}
++
++
++## Returns the cookie for a list, if any.
++sub get_cookie {
++ return shift->{'admin'}{'cookie'};
++}
++
++## Returns the maximum size allowed for a message to the list.
++sub get_max_size {
++ return shift->{'admin'}{'max_size'};
++}
++
++## Returns an array with the Reply-To data
++sub get_reply_to {
++ my $admin = shift->{'admin'};
++
++ my $value = $admin->{'reply_to_header'}{'value'};
++
++ $value = $admin->{'reply_to_header'}{'other_email'} if ($value eq 'other_email');
++
++ return $value
++}
++
++## Returns a default user option
++sub get_default_user_options {
++ my $self = shift->{'admin'};
++ my $what = shift;
++ do_log('debug3', 'List::get_default_user_options(%s)', $what);
++
++ if ($self) {
++ return $self->{'default_user_options'};
++ }
++ return undef;
++}
++
++## Returns the number of subscribers to the list
++sub get_total {
++ my $self = shift;
++ my $name = $self->{'name'};
++ my $option = shift;
++ &do_log('debug3','List::get_total(%s)', $name);
++
++ if ($option eq 'nocache') {
++ $self->{'total'} = $self->_load_total_db($option);
++ }
++
++ return $self->{'total'};
++}
++
++## Returns a hash for a given user
++sub get_user_db {
++ my $who = &tools::clean_email(shift);
++ do_log('debug2', 'List::get_user_db(%s)', $who);
++
++ my $statement;
++
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ ## Additional subscriber fields
++ my $additional;
++ if ($Conf::Conf{'db_additional_user_fields'}) {
++ $additional = ',' . $Conf::Conf{'db_additional_user_fields'};
++ }
++
++ $statement = sprintf "SELECT email_user AS email, gecos_user AS gecos, password_user AS password, cookie_delay_user AS cookie_delay, lang_user AS lang %s, attributes_user AS attributes, data_user AS data, last_login_date_user AS last_login_date, wrong_login_count_user AS wrong_login_count, last_login_host_user AS last_login_host FROM user_table WHERE email_user = %s ", $additional, $dbh->quote($who);
++
++ push @sth_stack, $sth;
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ my $user = $sth->fetchrow_hashref('NAME_lc');
++
++ $sth->finish();
++
++ $sth = pop @sth_stack;
++
++ if (defined $user) {
++ ## decrypt password
++ if ($user->{'password'}) {
++ $user->{'password'} = &tools::decrypt_password($user->{'password'});
++ }
++
++ ## Turn user_attributes into a hash
++ my $attributes = $user->{'attributes'};
++ $user->{'attributes'} = undef;
++ foreach my $attr (split (/\;/, $attributes)) {
++ my ($key, $value) = split (/\=/, $attr);
++ $user->{'attributes'}{$key} = $value;
++ }
++ ## Turn data_user into a hash
++ if ($user->{'data'}) {
++ my %prefs = &tools::string_2_hash($user->{'data'});
++ $user->{'prefs'} = \%prefs;
++ }
++ }
++
++ return $user;
++}
++
++## Returns an array of all users in User table hash for a given user
++sub get_all_user_db {
++ do_log('debug2', 'List::get_all_user_db()');
++
++ my $statement;
++ my @users;
++
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ $statement = sprintf "SELECT email_user FROM user_table";
++
++ push @sth_stack, $sth;
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ while (my $email = ($sth->fetchrow_array)[0]) {
++ push @users, $email;
++ }
++
++ $sth->finish();
++
++ $sth = pop @sth_stack;
++
++ return @users;
++}
++
++######################################################################
++### suspend_subscription #
++## Suspend an user from list(s) #
++######################################################################
++# IN: #
++# - email : the subscriber email #
++# - list : the name of the list #
++# - data : start_date and end_date #
++# - robot : domain #
++# OUT: #
++# - undef if something went wrong. #
++# - 1 if user is suspended from the list #
++######################################################################
++sub suspend_subscription {
++
++ my $email = shift;
++ my $list = shift;
++ my $data = shift;
++ my $robot = shift;
++ &do_log('debug2', 'List::suspend_subscription("%s", "%s", "%s" )', $email, $list, $data);
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ my $statement = sprintf "UPDATE subscriber_table SET suspend_subscriber='1', suspend_start_date_subscriber=%s, suspend_end_date_subscriber=%s WHERE (user_subscriber=%s AND list_subscriber=%s AND robot_subscriber = %s )",
++ $dbh->quote($data->{'startdate'}),
++ $dbh->quote($data->{'enddate'}),
++ $dbh->quote($email),
++ $dbh->quote($list),
++ $dbh->quote($robot);
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ return 1;
++}
++
++######################################################################
++### restore_suspended_subscription #
++## Restore the subscription of an user from list(s) #
++######################################################################
++# IN: #
++# - email : the subscriber email #
++# - list : the name of the list #
++# - robot : domain #
++# OUT: #
++# - undef if something went wrong. #
++# - 1 if his/her subscription is restored #
++######################################################################
++sub restore_suspended_subscription {
++
++ my $email = shift;
++ my $list = shift;
++ my $robot = shift;
++ &do_log('debug2', 'List::restore_suspended_subscription("%s", "%s", "%s")', $email, $list, $robot);
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++ ## Update field
++ my $statement = sprintf "UPDATE subscriber_table SET suspend_subscriber='0', suspend_start_date_subscriber=NULL, suspend_end_date_subscriber=NULL WHERE (user_subscriber=%s AND list_subscriber=%s AND robot_subscriber = %s )",
++ $dbh->quote($email),
++ $dbh->quote($list),
++ $dbh->quote($robot);
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ return 1;
++}
++
++######################################################################
++### insert_delete_exclusion #
++## Update the exclusion_table #
++######################################################################
++# IN: #
++# - email : the subscriber email #
++# - list : the name of the list #
++# - robot : the name of the domain #
++# - action : insert or delete #
++# OUT: #
++# - undef if something went wrong. #
++# - 1 #
++######################################################################
++sub insert_delete_exclusion {
++
++ my $email = shift;
++ my $list = shift;
++ my $robot = shift;
++ my $action = shift;
++ &do_log('info', 'List::insert_delete_exclusion("%s", "%s", "%s", "%s")', $email, $list, $robot, $action);
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++ my $statement;
++ if($action eq 'insert'){
++ ## INSERT only if $user->{'included'} eq '1'
++
++ my $options;
++ $options->{'email'} = $email;
++ $options->{'name'} = $list;
++ $options->{'domain'} = $robot;
++ my $user = &get_subscriber_no_object($options);
++ my $date = time;
++
++ if ($user->{'included'} eq '1') {
++ ## Insert : list, user and date
++ $statement = sprintf "INSERT INTO exclusion_table (list_exclusion, user_exclusion, date_exclusion) VALUES (%s, %s, %s)", $dbh->quote($list), $dbh->quote($email), $dbh->quote($date);
++
++ unless ($dbh->do($statement)) {
++ &do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++ }
++
++ }elsif($action eq 'delete') {
++ ## If $email is in exclusion_table, delete it.
++ my $data_excluded = &get_exclusion($list);
++ my @users_excluded;
++
++ my $key =0;
++ while ($data_excluded->{'emails'}->[$key]){
++ push @users_excluded, $data_excluded->{'emails'}->[$key];
++ $key = $key + 1;
++ }
++
++ foreach my $users (@users_excluded) {
++ if($email eq $users){
++ ## Delete : list, user and date
++ $statement = sprintf "DELETE FROM exclusion_table WHERE (list_exclusion = %s AND user_exclusion = %s)", $dbh->quote($list), $dbh->quote($email);
++
++ unless ($dbh->do($statement)) {
++ &do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++ }
++ }
++
++ }else{
++ &do_log('err','You must choose an action');
++ return undef;
++ }
++
++ return 1;
++}
++
++######################################################################
++### get_exclusion #
++## Returns a hash with those excluded from the list and the date. #
++## #
++# IN: - name : the name of the list #
++# OUT: - data_exclu : * %data_exclu->{'emails'}->[] #
++# * %data_exclu->{'date'}->[] #
++######################################################################
++sub get_exclusion {
++
++ my $name= shift;
++ &do_log('debug2', 'List::get_exclusion(%s)', $name);
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++ ## the query return the email and the date in a hash
++ my $statement = sprintf "SELECT user_exclusion AS email, date_exclusion AS date FROM exclusion_table WHERE list_exclusion = %s",
++ $dbh->quote($name);
++
++ push @sth_stack, $sth;
++ unless ($sth = $dbh->prepare($statement)) {
++ &do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++ unless ($sth->execute) {
++ &do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ my @users;
++ my @date;
++ my $data;
++ while ($data = $sth->fetchrow_hashref){
++ push @users, $data->{'email'};
++ push @date, $data->{'date'};
++ }
++ ## in order to use the data, we add the emails and dates in differents array
++ my $data_exclu = {"emails" => \@users,
++ "date" => \@date
++ };
++
++ $sth->finish();
++ $sth = pop @sth_stack;
++
++ unless($data_exclu){
++ &do_log('err','Unable to retrieve information from database for list %s', $name);
++ return undef;
++ }
++ return $data_exclu;
++}
++
++######################################################################
++### get_subscriber #
++## Returns a subscriber of the list. #
++######################################################################
++sub get_subscriber {
++ my $self= shift;
++ my $email = &tools::clean_email(shift);
++
++ do_log('debug2', 'List::get_subscriber(%s)', $email);
++
++ my $name = $self->{'name'};
++ my $statement;
++ my $date_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'date_subscriber', 'date_subscriber';
++ my $update_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'update_subscriber', 'update_subscriber';
++
++ ## Use session cache
++ if (defined $list_cache{'get_subscriber'}{$self->{'domain'}}{$self->{'name'}}{$email}) {
++ return $list_cache{'get_subscriber'}{$self->{'domain'}}{$self->{'name'}}{$email};
++ }
++
++ my $options;
++ $options->{'email'} = $email;
++ $options->{'name'} = $self->{'name'};
++ $options->{'domain'} = $self->{'domain'};
++
++ my $user = &get_subscriber_no_object($options);
++
++ unless($user){
++ do_log('err','Unable to retrieve information from database for user %s', $email);
++ return undef;
++ }
++ $user->{'reception'} = $self->{'admin'}{'default_user_options'}{'reception'}
++ unless ($self->is_available_reception_mode($user->{'reception'}));
++ ## In case it was not set in the database
++ $user->{'subscribed'} = 1 if ($self->{'admin'}{'user_data_source'} eq 'database');
++
++ ## Set session cache
++ $list_cache{'get_subscriber'}{$self->{'domain'}}{$self->{'name'}}{$email} = $user;
++
++ return $user;
++}
++
++#######################################################################
++# IN
++# - a single reference to a hash with the following keys: #
++# * email : the subscriber email #
++# * name: the name of the list #
++# * domain: the virtual host under which the list is installed. #
++#
++# OUT : undef if something wrong
++# a hash of tab of ressembling emails
++sub get_ressembling_subscribers_no_object {
++ my $options = shift;
++ &do_log('debug2', 'List::get_ressembling_subscribers_no_object(%s, %s, %s)', $options->{'name'}, $options->{'email'}, $options->{'domain'});
++ my $name = $options->{'name'};
++ my @output;
++
++
++
++ my $email = &tools::clean_email($options->{'email'});
++ my $robot = $options->{'domain'};
++ my $listname = $options->{'name'};
++
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++ my $date_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'date_subscriber', 'date_subscriber';
++ my $update_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'update_subscriber', 'update_subscriber';
++
++ $email =~ /^(.*)\@(.*)$/;
++ my $local_part = $1;
++ my $subscriber_domain = $2;
++ my %subscribers_email;
++
++
++
++ ##### plused
++ # is subscriber a plused email ?
++ if ($local_part =~ /^(.*)\+(.*)$/) {
++
++ foreach my $subscriber (&find_subscriber_by_pattern_no_object({'email_pattern' => $1.'@'.$subscriber_domain,'name'=>$listname,'domain'=>$robot})){
++ next if ($subscribers_email{$subscriber->{'email'}});
++ $subscribers_email{$subscriber->{'email'}} = 1;
++ push @output,$subscriber;
++ }
++ }
++ # is some subscriber ressembling with a plused email ?
++ foreach my $subscriber (&find_subscriber_by_pattern_no_object({'email_pattern' => $local_part.'+%@'.$subscriber_domain,'name'=>$listname,'domain'=>$robot})){
++ next if ($subscribers_email{$subscriber->{'email'}});
++ $subscribers_email{ $subscriber->{'email'} } = 1;
++ push @output,$subscriber;
++ }
++
++ # ressembling local part
++ # try to compare firstname.name@domain with name@domain
++ foreach my $subscriber (&find_subscriber_by_pattern_no_object({'email_pattern' => '%'.$local_part.'@'.$subscriber_domain,'name'=>$listname,'domain'=>$robot})){
++ next if ($subscribers_email{$subscriber->{'email'}});
++ $subscribers_email{ $subscriber->{'email'} } = 1;
++ push @output,$subscriber;
++ }
++
++ if ($local_part =~ /^(.*)\.(.*)$/) {
++ foreach my $subscriber (&find_subscriber_by_pattern_no_object({'email_pattern' => $2.'@'.$subscriber_domain,'name'=>$listname,'domain'=>$robot})){
++ next if ($subscribers_email{$subscriber->{'email'}});
++ $subscribers_email{ $subscriber->{'email'} } = 1;
++ push @output,$subscriber;
++ }
++ }
++
++ #### Same local_part and ressembling domain
++ #
++ # compare host.domain.tld with domain.tld
++ if ($subscriber_domain =~ /^[^\.]\.(.*)$/) {
++ my $upperdomain = $1;
++ if ($upperdomain =~ /\./) {
++ # remove first token if there is still at least 2 tokens try to find a subscriber with that domain
++ foreach my $subscriber (&find_subscriber_by_pattern_no_object({'email_pattern' => $local_part.'@'.$upperdomain,'name'=>$listname,'domain'=>$robot})){
++ next if ($subscribers_email{$subscriber->{'email'}});
++ $subscribers_email{ $subscriber->{'email'} } = 1;
++ push @output,$subscriber;
++ }
++ }
++ }
++ foreach my $subscriber (&find_subscriber_by_pattern_no_object({'email_pattern' => $local_part.'@%'.$subscriber_domain,'name'=>$listname,'domain'=>$robot})){
++ next if ($subscribers_email{$subscriber->{'email'}});
++ $subscribers_email{ $subscriber->{'email'} } = 1;
++ push @output,$subscriber;
++ }
++
++ # looking for initial
++ if ($local_part =~ /^(.*)\.(.*)$/) {
++ my $givenname = $1;
++ my $name= $2;
++ my $initial = '';
++ if ($givenname =~ /^([a-z])/){
++ $initial = $1;
++ }
++ if ($name =~ /^([a-z])/){
++ $initial = $initial.$1;
++ }
++ foreach my $subscriber (&find_subscriber_by_pattern_no_object({'email_pattern' => $initial.'@'.$subscriber_domain,'name'=>$listname,'domain'=>$robot})){
++ next if ($subscribers_email{$subscriber->{'email'}});
++ $subscribers_email{ $subscriber->{'email'} } = 1;
++ push @output,$subscriber;
++ }
++ }
++
++
++
++ #### users in the same local part in any other domain
++ #
++ foreach my $subscriber (&find_subscriber_by_pattern_no_object({'email_pattern' => $local_part.'@%','name'=>$listname,'domain'=>$robot})){
++ next if ($subscribers_email{$subscriber->{'email'}});
++ $subscribers_email{ $subscriber->{'email'} } = 1;
++ push @output,$subscriber;
++ }
++
++ return \@output;
++
++
++}
++
++
++######################################################################
++### find_subscriber_by_pattern_no_object #
++## Get details regarding a subscriber. #
++# IN: #
++# - a single reference to a hash with the following keys: #
++# * email pattern : the subscriber email patern looking for #
++# * name: the name of the list #
++# * domain: the virtual host under which the list is installed. #
++# OUT: #
++# - undef if something went wrong. #
++# - a hash containing the user details otherwise #
++######################################################################
++
++sub find_subscriber_by_pattern_no_object {
++ my $options = shift;
++
++ my $name = $options->{'name'};
++
++ my $email_pattern = &tools::clean_email($options->{'email_pattern'});
++ my $statement;
++ my $date_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'date_subscriber', 'date_subscriber';
++ my $update_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'update_subscriber', 'update_subscriber';
++
++ my @ressembling_users;
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++ ## Additional subscriber fields
++ my $additional;
++ if ($Conf::Conf{'db_additional_subscriber_fields'}) {
++ $additional = ',' . $Conf::Conf{'db_additional_subscriber_fields'};
++ }
++ $statement = sprintf "SELECT user_subscriber AS email, comment_subscriber AS gecos, bounce_subscriber AS bounce, bounce_score_subscriber AS bounce_score, bounce_address_subscriber AS bounce_address, reception_subscriber AS reception, topics_subscriber AS topics, visibility_subscriber AS visibility, %s AS \"date\", %s AS update_date, subscribed_subscriber AS subscribed, included_subscriber AS included, include_sources_subscriber AS id, custom_attribute_subscriber AS custom_attribute, suspend_subscriber AS suspend, suspend_start_date_subscriber AS startdate, suspend_end_date_subscriber AS enddate %s FROM subscriber_table WHERE (user_subscriber LIKE %s AND list_subscriber = %s AND robot_subscriber = %s)",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($email_pattern),
++ $dbh->quote($name),
++ $dbh->quote($options->{'domain'});
++# $statement = sprintf "SELECT user_subscriber AS email FROM subscriber_table WHERE (user_subscriber LIKE %s AND list_subscriber = %s AND robot_subscriber = %s)",
++# $dbh->quote($email_pattern),
++# $dbh->quote($name),
++# $dbh->quote($options->{'domain'});
++
++
++ push @sth_stack, $sth;
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ while (my $user = $sth->fetchrow_hashref('NAME_lc')){
++ if (defined $user) {
++
++ $user->{'reception'} ||= 'mail';
++ $user->{'escaped_email'} = &tools::escape_chars($user->{'email'});
++ $user->{'update_date'} ||= $user->{'date'};
++ if (defined $user->{custom_attribute}) {
++ my %custom_attr = &parseCustomAttribute($user->{'custom_attribute'});
++ $user->{'custom_attribute'} = \%custom_attr ;
++ my @k = sort keys %custom_attr ;
++ }
++ push @ressembling_users, $user;
++ }
++ }
++ $sth->finish();
++
++ $sth = pop @sth_stack;
++ ## Set session cache
++
++ return @ressembling_users;
++}
++
++######################################################################
++### get_subscriber_no_object #
++## Get details regarding a subscriber. #
++# IN: #
++# - a single reference to a hash with the following keys: #
++# * email : the subscriber email #
++# * name: the name of the list #
++# * domain: the virtual host under which the list is installed. #
++# OUT: #
++# - undef if something went wrong. #
++# - a hash containing the user details otherwise #
++######################################################################
++
++sub get_subscriber_no_object {
++ my $options = shift;
++ &do_log('debug2', 'List::get_subscriber_no_object(%s, %s, %s)', $options->{'name'}, $options->{'email'}, $options->{'domain'});
++
++ my $name = $options->{'name'};
++
++ my $email = &tools::clean_email($options->{'email'});
++ my $statement;
++ my $date_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'date_subscriber', 'date_subscriber';
++ my $update_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'update_subscriber', 'update_subscriber';
++
++ ## Use session cache
++ if (defined $list_cache{'get_subscriber'}{$options->{'domain'}}{$name}{$email}) {
++ return $list_cache{'get_subscriber'}{$options->{'domain'}}{$name}{$email};
++ }
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++ ## Additional subscriber fields
++ my $additional;
++ if ($Conf::Conf{'db_additional_subscriber_fields'}) {
++ $additional = ',' . $Conf::Conf{'db_additional_subscriber_fields'};
++ }
++ $statement = sprintf "SELECT user_subscriber AS email, comment_subscriber AS gecos, bounce_subscriber AS bounce, bounce_score_subscriber AS bounce_score, bounce_address_subscriber AS bounce_address, reception_subscriber AS reception, topics_subscriber AS topics, visibility_subscriber AS visibility, %s AS \"date\", %s AS update_date, subscribed_subscriber AS subscribed, included_subscriber AS included, include_sources_subscriber AS id, custom_attribute_subscriber AS custom_attribute, suspend_subscriber AS suspend, suspend_start_date_subscriber AS startdate, suspend_end_date_subscriber AS enddate %s FROM subscriber_table WHERE (user_subscriber = %s AND list_subscriber = %s AND robot_subscriber = %s)",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($email),
++ $dbh->quote($name),
++ $dbh->quote($options->{'domain'});
++
++ push @sth_stack, $sth;
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++ my $user = $sth->fetchrow_hashref('NAME_lc');
++ if (defined $user) {
++
++ $user->{'reception'} ||= 'mail';
++ $user->{'update_date'} ||= $user->{'date'};
++ do_log('debug2', 'custom_attribute = (%s)', $user->{custom_attribute});
++ if (defined $user->{custom_attribute}) {
++ do_log('debug2', '1. custom_attribute = (%s)', $user->{custom_attribute});
++ my %custom_attr = &parseCustomAttribute($user->{'custom_attribute'});
++ $user->{'custom_attribute'} = \%custom_attr ;
++ do_log('debug2', '2. custom_attribute = (%s)', %custom_attr);
++ do_log('debug2', '3. custom_attribute = (%s)', $user->{custom_attribute});
++ my @k = sort keys %custom_attr ;
++ do_log('debug2', "keys custom_attribute = @k");
++ }
++
++ }
++
++ $sth->finish();
++
++ $sth = pop @sth_stack;
++ ## Set session cache
++ $list_cache{'get_subscriber'}{$options->{'domain'}}{$name}{$email} = $user;
++ return $user;
++}
++
++## Returns an array of all users in User table hash for a given user
++sub get_subscriber_by_bounce_address {
++
++ my $self= shift;
++ my $bounce_address = &tools::clean_email(shift);
++
++ do_log('debug2', 'List::get_subscriber_by_bounce_address (%s)', $bounce_address);
++
++ return undef unless $bounce_address;
++
++ my $statement;
++ my @users;
++ my @subscribers;
++
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ my $listname = $self->{'name'};
++ my $robot = $self->{'domain'};
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ $statement = sprintf "SELECT user_subscriber AS email, bounce_address_subscriber AS bounce_address FROM subscriber_table WHERE (list_subscriber=%s AND robot_subscriber=%s AND bounce_address_subscriber LIKE %s",$dbh->quote($listname),$dbh->quote($robot),$dbh->quote($bounce_address);
++
++ push @sth_stack, $sth;
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++ while (my $subscriber = $sth->fetchrow_hashref('NAME_lc')) {
++ push @subscribers, $subscriber;
++ }
++ $sth->finish();
++ $sth = pop @sth_stack;
++ return @subscribers;
++}
++
++
++## Returns an admin user of the list.
++sub get_admin_user {
++ my $self= shift;
++ my $role= shift;
++ my $email = &tools::clean_email(shift);
++
++ do_log('debug2', 'List::get_admin_user(%s,%s)', $role,$email);
++
++ my $name = $self->{'name'};
++ my $statement;
++ my $date_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'date_admin', 'date_admin';
++ my $update_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'update_admin', 'update_admin';
++
++ ## Use session cache
++ if (defined $list_cache{'get_admin_user'}{$self->{'domain'}}{$name}{$role}{$email}) {
++ return $list_cache{'get_admin_user'}{$self->{'domain'}}{$name}{$role}{$email};
++ }
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ $statement = sprintf "SELECT user_admin AS email, comment_admin AS gecos, reception_admin AS reception, visibility_admin AS visibility, %s AS \"date\", %s AS update_date, info_admin AS info, profile_admin AS profile, subscribed_admin AS subscribed, included_admin AS included, include_sources_admin AS id FROM admin_table WHERE (user_admin = %s AND list_admin = %s AND robot_admin = %s AND role_admin = %s)",
++ $date_field,
++ $update_field,
++ $dbh->quote($email),
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $dbh->quote($role);
++
++ push @sth_stack, $sth;
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ my $admin_user = $sth->fetchrow_hashref('NAME_lc');
++
++ if (defined $admin_user) {
++ $admin_user->{'reception'} ||= 'mail';
++ $admin_user->{'update_date'} ||= $admin_user->{'date'};
++
++ ## In case it was not set in the database
++ $admin_user->{'subscribed'} = 1 if ($self->{'admin'}{'user_data_source'} eq 'database');
++ }
++
++ $sth->finish();
++
++ $sth = pop @sth_stack;
++
++ ## Set session cache
++ $list_cache{'get_admin_user'}{$self->{'domain'}}{$name}{$role}{$email} = $admin_user;
++
++ return $admin_user;
++
++}
++
++
++## Returns the first user for the list.
++sub get_first_user {
++ my ($self, $data) = @_;
++
++ my ($sortby, $offset, $rows, $sql_regexp);
++ $sortby = $data->{'sortby'};
++ ## Sort may be domain, email, date
++ $sortby ||= 'domain';
++ $offset = $data->{'offset'};
++ $rows = $data->{'rows'};
++ $sql_regexp = $data->{'sql_regexp'};
++
++ my $lock = new Lock ($self->{'dir'}.'/include');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++ $lock->set_timeout(10*60);
++
++ do_log('debug2', 'List::get_first_user(%s,%s,%d,%d)', $self->{'name'},$sortby, $offset, $rows);
++
++ ## Get an Shared lock
++ unless ($lock->lock('read')) {
++ return undef;
++ }
++
++ my $name = $self->{'name'};
++ my $statement;
++ my $date_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'date_subscriber', 'date_subscriber';
++ my $update_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'update_subscriber', 'update_subscriber';
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ ## SQL regexp
++ my $selection;
++ if ($sql_regexp) {
++ $selection = sprintf " AND (user_subscriber LIKE %s OR comment_subscriber LIKE %s)"
++ ,$dbh->quote($sql_regexp), $dbh->quote($sql_regexp);
++ }
++
++ ## Additional subscriber fields
++ my $additional;
++ if ($Conf::Conf{'db_additional_subscriber_fields'}) {
++ $additional = ',' . $Conf::Conf{'db_additional_subscriber_fields'};
++ }
++
++ ## Oracle
++ if ($Conf::Conf{'db_type'} eq 'Oracle') {
++
++ $statement = sprintf "SELECT user_subscriber \"email\", comment_subscriber \"gecos\", reception_subscriber \"reception\", topics_subscriber \"topics\", visibility_subscriber \"visibility\", bounce_subscriber \"bounce\", bounce_score_subscriber \"bounce_score\", bounce_address_subscriber \"bounce_address\", %s \"date\", %s \"update_date\", subscribed_subscriber \"subscribed\", included_subscriber \"included\", include_sources_subscriber \"id\", custom_attribute_subscriber \"custom_attribute\", suspend_subscriber \"suspend\", suspend_start_date_subscriber \"startdate\", suspend_end_date_subscriber AS \"enddate\" %s FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s %s)",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $selection;
++
++ ## SORT BY
++ if ($sortby eq 'domain') {
++ $statement = sprintf "SELECT user_subscriber \"email\", comment_subscriber \"gecos\", reception_subscriber \"reception\", topics_subscriber \"topics\", visibility_subscriber \"visibility\", bounce_subscriber \"bounce\", bounce_score_subscriber \"bounce_score\",bounce_address_subscriber \"bounce_address\", %s \"date\", %s \"update_date\", subscribed_subscriber \"subscribed\", included_subscriber \"included\", include_sources_subscriber \"id\", custom_attribute_subscriber \"custom_attribute\", substr(user_subscriber,instr(user_subscriber,'\@')+1) \"dom\",suspend_subscriber \"suspend\", suspend_start_date_subscriber \"startdate\", suspend_end_date_subscriber \"enddate\" %s FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s) ORDER BY \"dom\"",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'});
++
++ }elsif ($sortby eq 'email') {
++ $statement .= " ORDER BY email";
++
++ }elsif ($sortby eq 'date') {
++ $statement .= " ORDER BY date DESC";
++
++ }elsif ($sortby eq 'sources') {
++ $statement .= " ORDER BY subscribed DESC,id";
++
++ }elsif ($sortby eq 'name') {
++ $statement .= " ORDER BY gecos";
++ }
++
++ ## Sybase
++ }elsif ($Conf::Conf{'db_type'} eq 'Sybase'){
++
++ $statement = sprintf "SELECT user_subscriber \"email\", comment_subscriber \"gecos\", reception_subscriber \"reception\", topics_subscriber \"topics\", visibility_subscriber \"visibility\", bounce_subscriber \"bounce\", bounce_score_subscriber \"bounce_score\", bounce_address_subscriber \"bounce_address\", %s \"date\", %s \"update_date\", subscribed_subscriber \"subscribed\", included_subscriber \"included\", include_sources_subscriber \"id\", custom_attribute_subscriber \"custom_attribute\", suspend_subscriber \"suspend\", suspend_start_date_subscriber \"startdate\", suspend_end_date_subscriber \"enddate\" %s FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s %s)",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $selection;
++
++ ## SORT BY
++ if ($sortby eq 'domain') {
++ $statement = sprintf "SELECT user_subscriber \"email\", comment_subscriber \"gecos\", reception_subscriber \"reception\", topics_subscriber \"topics\", visibility_subscriber \"visibility\", bounce_subscriber \"bounce\", bounce_score_subscriber \"bounce_score\", bounce_address_subscriber \"bounce_address\",%s \"date\", %s \"update_date\", subscribed_subscriber \"subscribed\", included_subscriber \"included\", include_sources_subscriber \"id\", custom_attribute_subscriber \"custom_attribute\", substring(user_subscriber,charindex('\@',user_subscriber)+1,100) \"dom\",suspend_subscriber \"suspend\", suspend_start_date_subscriber \"startdate\", suspend_end_date_subscriber \"enddate\" %s FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s) ORDER BY \"dom\"",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'});
++
++ }elsif ($sortby eq 'email') {
++ $statement .= " ORDER BY email";
++
++ }elsif ($sortby eq 'date') {
++ $statement .= " ORDER BY date DESC";
++
++ }elsif ($sortby eq 'sources') {
++ $statement .= " ORDER BY subscribed DESC,id";
++
++ }elsif ($sortby eq 'name') {
++ $statement .= " ORDER BY gecos";
++ }
++
++
++ ## mysql
++ }elsif ($Conf::Conf{'db_type'} eq 'mysql') {
++
++ $statement = sprintf "SELECT user_subscriber AS email, comment_subscriber AS gecos, reception_subscriber AS reception, topics_subscriber AS topics, visibility_subscriber AS visibility, bounce_subscriber AS bounce, bounce_score_subscriber AS bounce_score, bounce_address_subscriber AS bounce_address, %s AS \"date\", %s AS update_date, subscribed_subscriber AS subscribed, included_subscriber AS included, include_sources_subscriber AS id, custom_attribute_subscriber AS custom_attribute, suspend_subscriber AS suspend, suspend_start_date_subscriber AS startdate, suspend_end_date_subscriber AS enddate %s FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s %s)",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $selection;
++
++ ## SORT BY
++ if ($sortby eq 'domain') {
++ ## Redefine query to set "dom"
++
++ $statement = sprintf "SELECT user_subscriber AS email, comment_subscriber AS gecos, reception_subscriber AS reception, topics_subscriber AS topics, visibility_subscriber AS visibility, bounce_subscriber AS bounce, bounce_score_subscriber AS bounce_score, bounce_address_subscriber AS bounce_address, %s AS \"date\", %s AS update_date, subscribed_subscriber AS subscribed, included_subscriber AS included, include_sources_subscriber AS id, custom_attribute_subscriber AS custom_attribute, REVERSE(SUBSTRING(user_subscriber FROM position('\@' IN user_subscriber) FOR 50)) AS \"dom\", suspend_subscriber AS suspend, suspend_start_date_subscriber AS startdate, suspend_end_date_subscriber AS enddate %s FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s ) ORDER BY \"dom\"",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'});
++
++ }elsif ($sortby eq 'email') {
++ ## Default SORT
++ $statement .= ' ORDER BY email';
++
++ }elsif ($sortby eq 'date') {
++ $statement .= ' ORDER BY date DESC';
++
++ }elsif ($sortby eq 'sources') {
++ $statement .= " ORDER BY subscribed DESC,id";
++
++ }elsif ($sortby eq 'name') {
++ $statement .= ' ORDER BY gecos';
++ }
++
++ ## LIMIT clause
++ if (defined($rows) and defined($offset)) {
++ $statement .= sprintf " LIMIT %d, %d", $offset, $rows;
++ }
++
++ ## SQLite
++ }elsif ($Conf::Conf{'db_type'} eq 'SQLite') {
++
++ $statement = sprintf "SELECT user_subscriber AS email, comment_subscriber AS gecos, reception_subscriber AS reception, visibility_subscriber AS visibility, bounce_subscriber AS bounce, bounce_score_subscriber AS bounce_score, bounce_address_subscriber AS bounce_address, %s AS \"date\", %s AS update_date, subscribed_subscriber AS subscribed, included_subscriber AS included, include_sources_subscriber AS id, custom_attribute_subscriber AS custom_attribute,suspend_subscriber AS suspend, suspend_start_date_subscriber AS startdate, suspend_end_date_subscriber AS enddate %s FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s %s)",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $selection;
++
++ ## SORT BY
++ if ($sortby eq 'domain') {
++ ## Redefine query to set "dom"
++
++ $statement = sprintf "SELECT user_subscriber AS email, comment_subscriber AS gecos, reception_subscriber AS reception, visibility_subscriber AS visibility, bounce_subscriber AS bounce, bounce_score_subscriber AS bounce_score, bounce_address_subscriber AS bounce_address, %s AS \"date\", %s AS update_date, subscribed_subscriber AS subscribed, included_subscriber AS included, include_sources_subscriber AS id, custom_attribute_subscriber AS custom_attribute, substr(user_subscriber,0,func_index(user_subscriber,'\@')+1) AS \"dom\", suspend_subscriber AS suspend, suspend_start_date_subscriber AS startdate, suspend_end_date_subscriber AS enddate %s FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s) ORDER BY \"dom\"",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'});
++
++ }elsif ($sortby eq 'email') {
++ ## Default SORT
++ $statement .= ' ORDER BY email';
++
++ }elsif ($sortby eq 'date') {
++ $statement .= ' ORDER BY date DESC';
++
++ }elsif ($sortby eq 'sources') {
++ $statement .= " ORDER BY subscribed DESC,id";
++
++ }elsif ($sortby eq 'name') {
++ $statement .= ' ORDER BY gecos';
++ }
++
++ ## LIMIT clause
++ if (defined($rows) and defined($offset)) {
++ $statement .= sprintf " LIMIT %d, %d", $offset, $rows;
++ }
++
++ ## Pg
++ }else {
++
++ $statement = sprintf "SELECT user_subscriber AS email, comment_subscriber AS gecos, reception_subscriber AS reception, topics_subscriber AS topics, visibility_subscriber AS visibility, bounce_subscriber AS bounce, bounce_score_subscriber AS bounce_score, bounce_address_subscriber AS bounce_address, %s AS \"date\", %s AS update_date, subscribed_subscriber AS subscribed, included_subscriber AS included, include_sources_subscriber AS id, custom_attribute_subscriber AS custom_attribute,suspend_subscriber AS suspend, suspend_start_date_subscriber AS startdate, suspend_end_date_subscriber AS enddate %s FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s %s)",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $selection;
++
++ ## SORT BY
++ if ($sortby eq 'domain') {
++ ## Redefine query to set "dom"
++
++ $statement = sprintf "SELECT user_subscriber AS email, comment_subscriber AS gecos, reception_subscriber AS reception, topics_subscriber AS topics, visibility_subscriber AS visibility, bounce_subscriber AS bounce, bounce_score_subscriber AS bounce_score, bounce_address_subscriber AS bounce_address, %s AS \"date\", %s AS update_date, subscribed_subscriber AS subscribed, included_subscriber AS included, include_sources_subscriber AS id, custom_attribute_subscriber AS custom_attribute, SUBSTRING(user_subscriber FROM position('\@' IN user_subscriber) FOR 50) AS \"dom\", suspend_subscriber AS suspend, suspend_start_date_subscriber AS startdate, suspend_end_date_subscriber AS enddate %s FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s) ORDER BY \"dom\"",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'});
++
++ }elsif ($sortby eq 'email') {
++ $statement .= ' ORDER BY email';
++
++ }elsif ($sortby eq 'date') {
++ $statement .= ' ORDER BY date DESC';
++
++ }elsif ($sortby eq 'sources') {
++ $statement .= " ORDER BY subscribed DESC,id";
++
++ }elsif ($sortby eq 'name') {
++ $statement .= ' ORDER BY gecos';
++ }
++
++ ## LIMIT clause
++ if (defined($rows) and defined($offset)) {
++ $statement .= sprintf " LIMIT %d OFFSET %d", $rows, $offset;
++ }
++ }
++ push @sth_stack, $sth;
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ my $user = $sth->fetchrow_hashref('NAME_lc');
++ if (defined $user) {
++ &do_log('err','Warning: entry with empty email address in list %s', $self->{'name'})
++ if (! $user->{'email'});
++ $user->{'reception'} ||= 'mail';
++ $user->{'reception'} = $self->{'admin'}{'default_user_options'}{'reception'}
++ unless ($self->is_available_reception_mode($user->{'reception'}));
++ $user->{'update_date'} ||= $user->{'date'};
++
++ ## In case it was not set in the database
++ $user->{'subscribed'} = 1 if (defined($user) && ($self->{'admin'}{'user_data_source'} eq 'database'));
++
++ ############################################################################
++ if (defined $user->{custom_attribute}) {
++ do_log('debug2', 'custom_attribute = (%s)', $user->{custom_attribute});
++ my %custom_attr = &parseCustomAttribute($user->{'custom_attribute'});
++ $user->{'custom_attribute'} = \%custom_attr ;
++ }
++
++
++ }
++ else {
++ $sth->finish;
++ $sth = pop @sth_stack;
++
++ if ($self->{'admin'}{'user_data_source'} eq 'include2') {
++
++ ## Release the Shared lock
++ unless ($lock->unlock()) {
++ return undef;
++ }
++ }
++ }
++
++ ## If no offset (for LIMIT) was used, update total of subscribers
++ unless ($offset) {
++ my $total = $self->_load_total_db('nocache');
++ if ($total != $self->{'total'}) {
++ $self->{'total'} = $total;
++ $self->savestats();
++ }
++ }
++
++ return $user;
++}
++
++# Create a custom attribute from an XML description
++# IN : File handle or a string, XML formed data as stored in database
++# OUT : HASH data storing custome attributes.
++sub parseCustomAttribute {
++ my $xmldoc = shift ;
++ return undef if ($xmldoc eq '') ;
++
++ my $parser = XML::LibXML->new();
++ my $tree;
++
++ ## We should use eval to parse to prevent the program to crash if it fails
++ if (ref($xmldoc) eq 'GLOB') {
++ $tree = eval {$parser->parse_fh($xmldoc)};
++ }else {
++ $tree = eval {$parser->parse_string($xmldoc)};
++ }
++
++ unless (defined $tree) {
++ &do_log('err', "Failed to parse XML data");
++ return undef;
++ }
++
++ my $doc = $tree->getDocumentElement;
++
++ my @custom_attr = $doc->getChildrenByTagName('custom_attribute') ;
++ my %ca ;
++ foreach my $ca (@custom_attr) {
++ my $id = Encode::encode_utf8($ca->getAttribute('id'));
++ my $value = Encode::encode_utf8($ca->getElementsByTagName('value'));
++ $ca{$id} = {value=>$value} ;
++ }
++ return %ca ;
++}
++
++# Create an XML Custom attribute to be stored into data base.
++# IN : HASH data storing custome attributes
++# OUT : string, XML formed data to be stored in database
++sub createXMLCustomAttribute {
++ my $custom_attr = shift ;
++ return '<?xml version="1.0" encoding="UTF-8" ?><custom_attributes></custom_attributes>' if (not defined $custom_attr) ;
++ my $XMLstr = '<?xml version="1.0" encoding="UTF-8" ?><custom_attributes>';
++ foreach my $k (sort keys %{$custom_attr} ) {
++ $XMLstr .= "<custom_attribute id=\"$k\"><value>".&tools::escape_html($custom_attr->{$k}{value})."</value></custom_attribute>";
++ }
++ $XMLstr .= "</custom_attributes>";
++
++ return $XMLstr ;
++}
++
++## Returns the first admin_user with $role for the list.
++sub get_first_admin_user {
++ my ($self, $role, $data) = @_;
++
++ my ($sortby, $offset, $rows, $sql_regexp);
++ $sortby = $data->{'sortby'};
++ ## Sort may be domain, email, date
++ $sortby ||= 'domain';
++ $offset = $data->{'offset'};
++ $rows = $data->{'rows'};
++ $sql_regexp = $data->{'sql_regexp'};
++ my $fh;
++
++ &do_log('debug2', 'List::get_first_admin_user(%s,%s,%s,%d,%d)', $self->{'name'},$role, $sortby, $offset, $rows);
++
++ my $lock = new Lock ($self->{'dir'}.'/include_admin_user');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++ $lock->set_timeout(20);
++
++ ## Get a shared lock
++ unless ($fh = $lock->lock('read')) {
++ return undef;
++ }
++
++ my $name = $self->{'name'};
++ my $statement;
++
++ my $date_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'date_admin', 'date_admin';
++ my $update_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'update_admin', 'update_admin';
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ ## SQL regexp
++ my $selection;
++ if ($sql_regexp) {
++ $selection = sprintf " AND (user_admin LIKE %s OR comment_admin LIKE %s)"
++ ,$dbh->quote($sql_regexp), $dbh->quote($sql_regexp);
++ }
++
++ ## Oracle
++# and ok?
++ if ($Conf::Conf{'db_type'} eq 'Oracle') {
++
++ $statement = sprintf "SELECT user_admin \"email\", comment_admin \"gecos\", reception_admin \"reception\", visibility_admin \"visibility\", %s \"date\", %s \"update_date\", info_admin \"info\", profile_admin \"profile\", subscribed_admin \"subscribed\", included_admin \"included\", include_sources_admin \"id\" FROM admin_table WHERE (list_admin = %s AND robot_admin = %s %s AND role_admin = %s)",
++ $date_field,
++ $update_field,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $selection,
++ $dbh->quote($role);
++
++ ## SORT BY
++ if ($sortby eq 'domain') {
++ $statement = sprintf "SELECT user_admin \"email\", comment_admin \"gecos\", reception_admin \"reception\", visibility_admin \"visibility\", %s \"date\", %s \"update_date\", info_admin \"info\", profile_admin \"profile\", subscribed_admin \"subscribed\", included_admin \"included\", include_sources_admin \"id\", substr(user_admin,instr(user_admin,'\@')+1) \"dom\" FROM admin_table WHERE (list_admin = %s AND robot_admin = %s AND role_admin = %s ) ORDER BY \"dom\"",
++ $date_field,
++ $update_field,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $dbh->quote($role);
++
++ }elsif ($sortby eq 'email') {
++ $statement .= " ORDER BY email";
++
++ }elsif ($sortby eq 'date') {
++ $statement .= " ORDER BY date DESC";
++
++ }elsif ($sortby eq 'sources') {
++ $statement .= " ORDER BY subscribed DESC,id";
++
++ }elsif ($sortby eq 'name') {
++ $statement .= " ORDER BY gecos";
++ }
++
++ ## Sybase
++ }elsif ($Conf::Conf{'db_type'} eq 'Sybase'){
++
++ $statement = sprintf "SELECT user_admin \"email\", comment_admin \"gecos\", reception_admin \"reception\", visibility_admin \"visibility\", %s \"date\", %s \"update_date\", info_admin \"info\", profile_admin \"profile\", subscribed_admin \"subscribed\", included_admin \"included\", include_sources_admin \"id\" FROM admin_table WHERE (list_admin = %s AND robot_admin = %s %s AND role_admin = %s)",
++ $date_field,
++ $update_field,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $selection,
++ $dbh->quote($role);
++ ## SORT BY
++ if ($sortby eq 'domain') {
++ $statement = sprintf "SELECT user_admin \"email\", comment_admin \"gecos\", reception_admin \"reception\", visibility_admin \"visibility\", %s \"date\", %s \"update_date\", info_admin \"info\", profile_admin \"profile\", subscribed_admin \"subscribed\", included_admin \"included\", include_sources_admin \"id\", substring(user_admin,charindex('\@',user_admin)+1,100) \"dom\" FROM admin_table WHERE (list_admin = %s AND robot_admin = %s AND role_admin = %s) ORDER BY \"dom\"",
++ $date_field,
++ $update_field,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $dbh->quote($role);
++
++ }elsif ($sortby eq 'email') {
++ $statement .= " ORDER BY email";
++
++ }elsif ($sortby eq 'date') {
++ $statement .= " ORDER BY date DESC";
++
++ }elsif ($sortby eq 'sources') {
++ $statement .= " ORDER BY subscribed DESC,id";
++
++ }elsif ($sortby eq 'name') {
++ $statement .= " ORDER BY gecos";
++ }
++
++
++ ## mysql
++ }elsif ($Conf::Conf{'db_type'} eq 'mysql') {
++
++ $statement = sprintf "SELECT user_admin AS email, comment_admin AS gecos, reception_admin AS reception, visibility_admin AS visibility, %s AS \"date\", %s AS update_date, info_admin AS info, profile_admin AS profile, subscribed_admin AS subscribed, included_admin AS included, include_sources_admin AS id FROM admin_table WHERE (list_admin = %s AND robot_admin = %s %s AND role_admin = %s)",
++ $date_field,
++ $update_field,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $selection,
++ $dbh->quote($role);
++
++ ## SORT BY
++ if ($sortby eq 'domain') {
++ ## Redefine query to set "dom"
++
++ $statement = sprintf "SELECT user_admin AS email, comment_admin AS gecos, reception_admin AS reception, visibility_admin AS visibility, %s AS \"date\", %s AS update_date, info_admin AS info, profile_admin AS profile, subscribed_admin AS subscribed, included_admin AS included, include_sources_admin AS id, REVERSE(SUBSTRING(user_admin FROM position('\@' IN user_admin) FOR 50)) AS \"dom\" FROM admin_table WHERE (list_admin = %s AND robot_admin = %s AND role_admin = %s ) ORDER BY \"dom\"",
++ $date_field,
++ $update_field,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $dbh->quote($role);
++
++ }elsif ($sortby eq 'email') {
++ ## Default SORT
++ $statement .= ' ORDER BY email';
++
++ }elsif ($sortby eq 'date') {
++ $statement .= ' ORDER BY date DESC';
++
++ }elsif ($sortby eq 'sources') {
++ $statement .= " ORDER BY subscribed DESC,id";
++
++ }elsif ($sortby eq 'name') {
++ $statement .= ' ORDER BY gecos';
++ }
++
++ ## LIMIT clause
++ if (defined($rows) and defined($offset)) {
++ $statement .= sprintf " LIMIT %d, %d", $offset, $rows;
++ }
++
++ ## SQLite
++ }elsif ($Conf::Conf{'db_type'} eq 'SQLite') {
++
++ $statement = sprintf "SELECT user_admin AS email, comment_admin AS gecos, reception_admin AS reception, visibility_admin AS visibility, %s AS \"date\", %s AS update_date, info_admin AS info, profile_admin AS profile, subscribed_admin AS subscribed, included_admin AS included, include_sources_admin AS id FROM admin_table WHERE (list_admin = %s AND robot_admin = %s %s AND role_admin = %s)",
++ $date_field,
++ $update_field,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $selection,
++ $dbh->quote($role);
++
++ ## SORT BY
++ if ($sortby eq 'domain') {
++ ## Redefine query to set "dom"
++
++ $statement = sprintf "SELECT user_admin AS email, comment_admin AS gecos, reception_admin AS reception, visibility_admin AS visibility, %s AS \"date\", %s AS update_date, info_admin AS info, profile_admin AS profile, subscribed_admin AS subscribed, included_admin AS included, include_sources_admin AS id, substr(user_admin,func_index(user_admin,'\@')+1,50) AS \"dom\" FROM admin_table WHERE (list_admin = %s AND robot_admin = %s AND role_admin = %s ) ORDER BY \"dom\"",
++ $date_field,
++ $update_field,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $dbh->quote($role);
++
++ }elsif ($sortby eq 'email') {
++ ## Default SORT
++ $statement .= ' ORDER BY email';
++
++ }elsif ($sortby eq 'date') {
++ $statement .= ' ORDER BY date DESC';
++
++ }elsif ($sortby eq 'sources') {
++ $statement .= " ORDER BY subscribed DESC,id";
++
++ }elsif ($sortby eq 'name') {
++ $statement .= ' ORDER BY gecos';
++ }
++
++ ## LIMIT clause
++ if (defined($rows) and defined($offset)) {
++ $statement .= sprintf " LIMIT %d, %d", $offset, $rows;
++ }
++
++ ## Pg
++ }else {
++
++ $statement = sprintf "SELECT user_admin AS email, comment_admin AS gecos, reception_admin AS reception, visibility_admin AS visibility, %s AS \"date\", %s AS update_date, info_admin AS info, profile_admin AS profile, subscribed_admin AS subscribed, included_admin AS included, include_sources_admin AS id FROM admin_table WHERE (list_admin = %s AND robot_admin = %s %s AND role_admin = %s)",
++ $date_field,
++ $update_field,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $selection,
++ $dbh->quote($role);
++
++ ## SORT BY
++ if ($sortby eq 'domain') {
++ ## Redefine query to set "dom"
++
++ $statement = sprintf "SELECT user_admin AS email, comment_admin AS gecos, reception_admin AS reception, visibility_admin AS visibility, %s AS \"date\", %s AS update_date, info_admin AS info, profile_admin AS profile, subscribed_admin AS subscribed, included_admin AS included, include_sources_admin AS id, SUBSTRING(user_admin FROM position('\@' IN user_admin) FOR 50) AS \"dom\" FROM admin_table WHERE (list_admin = %s AND robot_admin = %s AND role_admin = %s) ORDER BY \"dom\"",
++ $date_field,
++ $update_field,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $dbh->quote($role);
++
++ }elsif ($sortby eq 'email') {
++ $statement .= ' ORDER BY email';
++
++ }elsif ($sortby eq 'date') {
++ $statement .= ' ORDER BY date DESC';
++
++ }elsif ($sortby eq 'sources') {
++ $statement .= " ORDER BY subscribed DESC,id";
++
++ }elsif ($sortby eq 'email') {
++ $statement .= ' ORDER BY gecos';
++ }
++
++ ## LIMIT clause
++ if (defined($rows) and defined($offset)) {
++ $statement .= sprintf " LIMIT %d OFFSET %d", $rows, $offset;
++ }
++ }
++ push @sth_stack, $sth;
++
++ &do_log('debug2','SQL: %s', $statement);
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ my $admin_user = $sth->fetchrow_hashref('NAME_lc');
++ if (defined $admin_user) {
++ &do_log('err','Warning: entry with empty email address in list %s', $self->{'name'})
++ if (! $admin_user->{'email'});
++ $admin_user->{'reception'} ||= 'mail';
++ $admin_user->{'update_date'} ||= $admin_user->{'date'};
++
++ ## In case it was not set in the database
++ $admin_user->{'subscribed'} = 1 if (defined($admin_user) && ($self->{'admin'}{'user_data_source'} eq 'database'));
++
++ }else {
++ $sth->finish;
++ $sth = pop @sth_stack;
++
++ ## Release the Shared lock
++ my $lock = new Lock($self->{'dir'}.'/include_admin_user');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++
++ unless ($lock->unlock()) {
++ return undef;
++ }
++ }
++
++ return $admin_user;
++}
++
++## Loop for all subsequent users.
++sub get_next_user {
++ my $self = shift;
++ do_log('debug2', 'List::get_next_user');
++
++ unless (defined $sth) {
++ &do_log('err', 'No handle defined, get_first_user(%s) was not run', $self->{'name'});
++ return undef;
++ }
++
++ my $user = $sth->fetchrow_hashref('NAME_lc');
++
++ if (defined $user) {
++ &do_log('err','Warning: entry with empty email address in list %s', $self->{'name'})
++ if (! $user->{'email'});
++ $user->{'reception'} ||= 'mail';
++ unless ($self->is_available_reception_mode($user->{'reception'})){
++ $user->{'reception'} = $self->{'admin'}{'default_user_options'}{'reception'}
++ }
++ $user->{'update_date'} ||= $user->{'date'};
++
++ ## In case it was not set in the database
++ $user->{'subscribed'} = 1 if (defined($user) && ($self->{'admin'}{'user_data_source'} eq 'database'));
++
++ do_log('debug2', '(email = %s)', $user->{'email'});
++ if (defined $user->{custom_attribute}) {
++ do_log('debug2', '1. custom_attribute = (%s)', $user->{custom_attribute});
++ my %custom_attr = &parseCustomAttribute($user->{'custom_attribute'});
++ $user->{'custom_attribute'} = \%custom_attr ;
++ do_log('debug2', '2. custom_attribute = (%s)', %custom_attr);
++ do_log('debug2', '3. custom_attribute = (%s)', $user->{custom_attribute});
++ my @k = sort keys %custom_attr ;
++ do_log('debug2', "keys custom_attribute = @k");
++ }
++ }
++ else {
++ $sth->finish;
++ $sth = pop @sth_stack;
++
++ if ($self->{'admin'}{'user_data_source'} eq 'include2') {
++
++ ## Release lock
++ my $lock = new Lock ($self->{'dir'}.'/include');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++ unless ($lock->unlock()) {
++ return undef;
++ }
++ }
++ }
++
++# $self->{'total'}++;
++
++ return $user;
++}
++
++## Loop for all subsequent admin users with the role defined in get_first_admin_user.
++sub get_next_admin_user {
++ my $self = shift;
++ do_log('debug2', 'List::get_next_admin_user');
++
++ unless (defined $sth) {
++ &do_log('err','Statement handle not defined in get_next_admin_user for list %s', $self->{'name'});
++ return undef;
++ }
++
++ my $admin_user = $sth->fetchrow_hashref('NAME_lc');
++
++ if (defined $admin_user) {
++ &do_log('err','Warning: entry with empty email address in list %s', $self->{'name'})
++ if (! $admin_user->{'email'});
++ $admin_user->{'reception'} ||= 'mail';
++ $admin_user->{'update_date'} ||= $admin_user->{'date'};
++
++ ## In case it was not set in the database
++ $admin_user->{'subscribed'} = 1 if (defined($admin_user) && ($self->{'admin'}{'user_data_source'} eq 'database'));
++ }
++ else {
++ $sth->finish;
++ $sth = pop @sth_stack;
++
++ ## Release the Shared lock
++ my $lock = new Lock($self->{'dir'}.'/include_admin_user');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++
++ unless ($lock->unlock()) {
++ return undef;
++ }
++ }
++ return $admin_user;
++}
++
++
++
++
++## Returns the first bouncing user
++sub get_first_bouncing_user {
++ my $self = shift;
++ do_log('debug2', 'List::get_first_bouncing_user');
++
++ my $lock = new Lock ($self->{'dir'}.'/include');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++ $lock->set_timeout(10*60);
++
++ ## Get an Shared lock
++ unless ($lock->lock('read')) {
++ return undef;
++ }
++
++ my $name = $self->{'name'};
++ my $statement;
++ my $date_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'date_subscriber', 'date_subscriber';
++ my $update_field = sprintf $date_format{'read'}{$Conf::Conf{'db_type'}}, 'update_subscriber', 'update_subscriber';
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ ## Additional subscriber fields
++ my $additional;
++ if ($Conf::Conf{'db_additional_subscriber_fields'}) {
++ $additional = ',' . $Conf::Conf{'db_additional_subscriber_fields'};
++ }
++
++ $statement = sprintf "SELECT user_subscriber AS email, reception_subscriber AS reception, topics_subscriber AS topics, visibility_subscriber AS visibility, bounce_subscriber AS bounce,bounce_score_subscriber AS bounce_score, %s AS \"date\", %s AS update_date,suspend_subscriber AS suspend, suspend_start_date_subscriber AS startdate, suspend_end_date_subscriber AS enddate %s FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s AND bounce_subscriber is not NULL)",
++ $date_field,
++ $update_field,
++ $additional,
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'});
++
++ push @sth_stack, $sth;
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ my $user = $sth->fetchrow_hashref('NAME_lc');
++
++ if (defined $user) {
++ &do_log('err','Warning: entry with empty email address in list %s', $self->{'name'})
++ if (! $user->{'email'});
++
++ ## In case it was not set in the database
++ $user->{'subscribed'} = 1 if (defined ($user) && ($self->{'admin'}{'user_data_source'} eq 'database'));
++
++ }else {
++ $sth->finish;
++ $sth = pop @sth_stack;
++
++ ## Release the Shared lock
++ unless ($lock->unlock()) {
++ return undef;
++ }
++ }
++ return $user;
++}
++
++## Loop for all subsequent bouncing users.
++sub get_next_bouncing_user {
++ my $self = shift;
++ do_log('debug2', 'List::get_next_bouncing_user');
++
++ unless (defined $sth) {
++ &do_log('err', 'No handle defined, get_first_bouncing_user(%s) was not run', $self->{'name'});
++ return undef;
++ }
++
++ my $user = $sth->fetchrow_hashref('NAME_lc');
++
++ if (defined $user) {
++ &do_log('err','Warning: entry with empty email address in list %s', $self->{'name'})
++ if (! $user->{'email'});
++
++ ## In case it was not set in the database
++ $user->{'subscribed'} = 1 if (defined ($user) && ($self->{'admin'}{'user_data_source'} eq 'database'));
++ if (defined $user->{custom_attribute}) {
++ my %custom_attr = &parseCustomAttribute($user->{'custom_attribute'});
++ $user->{'custom_attribute'} = \%custom_attr ;
++ }
++
++ }else {
++ $sth->finish;
++ $sth = pop @sth_stack;
++
++ ## Release the Shared lock
++ my $lock = new Lock ($self->{'dir'}.'/include');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++ unless ($lock->unlock()) {
++ return undef;
++ }
++ }
++
++ return $user;
++}
++
++sub get_info {
++ my $self = shift;
++
++ my $info;
++
++ unless (open INFO, "$self->{'dir'}/info") {
++ &do_log('err', 'Could not open %s : %s', $self->{'dir'}.'/info', $!);
++ return undef;
++ }
++
++ while (<INFO>) {
++ $info .= $_;
++ }
++ close INFO;
++
++ return $info;
++}
++
++## Total bouncing subscribers
++sub get_total_bouncing {
++ my $self = shift;
++ do_log('debug2', 'List::get_total_boucing');
++
++ my $name = $self->{'name'};
++ my $statement;
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ ## Query the Database
++ $statement = sprintf "SELECT count(*) FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s AND bounce_subscriber is not NULL)", $dbh->quote($name), $dbh->quote($self->{'domain'});
++
++ push @sth_stack, $sth;
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ my $total = $sth->fetchrow;
++
++ $sth->finish();
++
++ $sth = pop @sth_stack;
++
++ return $total;
++}
++
++## Is the person in user table (db only)
++sub is_user_db {
++ my $who = &tools::clean_email(pop);
++ do_log('debug3', 'List::is_user_db(%s)', $who);
++
++ return undef unless ($who);
++
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ my $statement;
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ ## Query the Database
++ $statement = sprintf "SELECT count(*) FROM user_table WHERE email_user = %s", $dbh->quote($who);
++
++ push @sth_stack, $sth;
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ my $is_user = $sth->fetchrow();
++ $sth->finish();
++
++ $sth = pop @sth_stack;
++
++ return $is_user;
++}
++
++## Is the indicated person a subscriber to the list?
++sub is_user {
++ my ($self, $who) = @_;
++ $who = &tools::clean_email($who);
++ do_log('debug3', 'List::is_user(%s)', $who);
++
++ return undef unless ($self && $who);
++
++ my $statement;
++ my $name = $self->{'name'};
++
++ ## Use cache
++ if (defined $list_cache{'is_user'}{$self->{'domain'}}{$name}{$who}) {
++ # &do_log('debug3', 'Use cache(%s,%s): %s', $name, $who, $list_cache{'is_user'}{$self->{'domain'}}{$name}{$who});
++ return $list_cache{'is_user'}{$self->{'domain'}}{$name}{$who};
++ }
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ ## Query the Database
++ $statement = sprintf "SELECT count(*) FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s AND user_subscriber = %s)",$dbh->quote($name), $dbh->quote($self->{'domain'}), $dbh->quote($who);
++
++ push @sth_stack, $sth;
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ my $is_user = $sth->fetchrow;
++
++ $sth->finish();
++
++ $sth = pop @sth_stack;
++
++ ## Set cache
++ $list_cache{'is_user'}{$self->{'domain'}}{$name}{$who} = $is_user;
++
++ return $is_user;
++}
++
++## Sets new values for the given user (except gecos)
++sub update_user {
++ my($self, $who, $values) = @_;
++ do_log('debug2', 'List::update_user(%s)', $who);
++ $who = &tools::clean_email($who);
++
++ my ($field, $value);
++
++ my ($user, $statement, $table);
++ my $name = $self->{'name'};
++
++ ## mapping between var and field names
++ my %map_field = ( reception => 'reception_subscriber',
++ topics => 'topics_subscriber',
++ visibility => 'visibility_subscriber',
++ date => 'date_subscriber',
++ update_date => 'update_subscriber',
++ gecos => 'comment_subscriber',
++ password => 'password_user',
++ bounce => 'bounce_subscriber',
++ score => 'bounce_score_subscriber',
++ email => 'user_subscriber',
++ subscribed => 'subscribed_subscriber',
++ included => 'included_subscriber',
++ id => 'include_sources_subscriber',
++ bounce_address => 'bounce_address_subscriber',
++ custom_attribute => 'custom_attribute_subscriber',
++ suspend => 'suspend_subscriber',
++ startdate_subscriber => 'suspend_start_date_subscriber',
++ enddate => 'suspend_end_date_subscriber'
++ );
++
++ ## mapping between var and tables
++ my %map_table = ( reception => 'subscriber_table',
++ topics => 'subscriber_table',
++ visibility => 'subscriber_table',
++ date => 'subscriber_table',
++ update_date => 'subscriber_table',
++ gecos => 'subscriber_table',
++ password => 'user_table',
++ bounce => 'subscriber_table',
++ score => 'subscriber_table',
++ email => 'subscriber_table',
++ subscribed => 'subscriber_table',
++ included => 'subscriber_table',
++ id => 'subscriber_table',
++ bounce_address => 'subscriber_table',
++ custom_attribute => 'subscriber_table',
++ suspend => 'subscriber_table',
++ startdate => 'subscriber_table',
++ enddate => 'subscriber_table'
++ );
++
++ ## additional DB fields
++ if (defined $Conf::Conf{'db_additional_subscriber_fields'}) {
++ foreach my $f (split ',', $Conf::Conf{'db_additional_subscriber_fields'}) {
++ $map_table{$f} = 'subscriber_table';
++ $map_field{$f} = $f;
++ }
++ }
++
++ if (defined $Conf::Conf{'db_additional_user_fields'}) {
++ foreach my $f (split ',', $Conf::Conf{'db_additional_user_fields'}) {
++ $map_table{$f} = 'user_table';
++ $map_field{$f} = $f;
++ }
++ }
++
++ do_log('debug2', " custom_attribute id: $Conf::Conf{'custom_attribute'}");
++ ## custom attributes
++ if (defined $Conf::Conf{'custom_attribute'}){
++ foreach my $f (sort keys %{$Conf::Conf{'custom_attribute'}}){
++ do_log('debug2', "List::update_user custom_attribute id: $Conf::Conf{'custom_attribute'}{id} name: $Conf::Conf{'custom_attribute'}{name} type: $Conf::Conf{'custom_attribute'}{type} ");
++
++ }
++ }
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ ## Update each table
++ foreach $table ('user_table','subscriber_table') {
++
++ my @set_list;
++ while (($field, $value) = each %{$values}) {
++
++ unless ($map_field{$field} and $map_table{$field}) {
++ &do_log('err', 'Unknown database field %s', $field);
++ next;
++ }
++
++ if ($map_table{$field} eq $table) {
++ if ($field eq 'date') {
++ $value = sprintf $date_format{'write'}{$Conf::Conf{'db_type'}}, $value, $value;
++ }elsif ($field eq 'update_date') {
++ $value = sprintf $date_format{'write'}{$Conf::Conf{'db_type'}}, $value, $value;
++ }elsif ($value eq 'NULL'){
++ if ($Conf::Conf{'db_type'} eq 'mysql') {
++ $value = '\N';
++ }
++ }else {
++ if ($numeric_field{$map_field{$field}}) {
++ $value ||= 0; ## Can't have a null value
++ }else {
++ $value = $dbh->quote($value);
++ }
++ }
++ my $set = sprintf "%s=%s", $map_field{$field}, $value;
++ push @set_list, $set;
++ }
++ }
++ next unless @set_list;
++
++ ## Update field
++ if ($table eq 'user_table') {
++ $statement = sprintf "UPDATE %s SET %s WHERE (email_user=%s)", $table, join(',', @set_list), $dbh->quote($who);
++
++ }elsif ($table eq 'subscriber_table') {
++ if ($who eq '*') {
++ $statement = sprintf "UPDATE %s SET %s WHERE (list_subscriber=%s AND robot_subscriber = %s)",
++ $table,
++ join(',', @set_list),
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'});
++ }else {
++ $statement = sprintf "UPDATE %s SET %s WHERE (user_subscriber=%s AND list_subscriber=%s AND robot_subscriber = %s)",
++ $table,
++ join(',', @set_list),
++ $dbh->quote($who),
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'});
++ }
++ }
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++ }
++
++ ## Rename picture on disk if user email changed
++ if ($values->{'email'}) {
++ my $file_name = &tools::md5_fingerprint($who);
++ my $picture_file_path = &Conf::get_robot_conf($self->{'domain'},'pictures_path').'/'.$self->{'name'}.'@'.$self->{'domain'};
++
++ foreach my $extension ('gif','png','jpg','jpeg') {
++ if (-f $picture_file_path.'/'.$file_name.'.'.$extension) {
++ my $new_file_name = &tools::md5_fingerprint($values->{'email'});
++ unless (rename $picture_file_path.'/'.$file_name.'.'.$extension, $picture_file_path.'/'.$new_file_name.'.'.$extension) {
++ &do_log('err', "Failed to rename %s to %s : %s", $picture_file_path.'/'.$file_name.'.'.$extension, $picture_file_path.'/'.$new_file_name.'.'.$extension, $!);
++ }
++ }
++ }
++ }
++
++ ## Reset session cache
++ $list_cache{'get_subscriber'}{$self->{'domain'}}{$name}{$who} = undef;
++
++ return 1;
++}
++
++
++## Sets new values for the given admin user (except gecos)
++sub update_admin_user {
++ my($self, $who,$role, $values) = @_;
++ do_log('debug2', 'List::update_admin_user(%s,%s)', $role, $who);
++ $who = &tools::clean_email($who);
++
++ my ($field, $value);
++
++ my ($admin_user, $statement, $table);
++ my $name = $self->{'name'};
++
++ ## mapping between var and field names
++ my %map_field = ( reception => 'reception_admin',
++ visibility => 'visibility_admin',
++ date => 'date_admin',
++ update_date => 'update_admin',
++ gecos => 'comment_admin',
++ password => 'password_user',
++ email => 'user_admin',
++ subscribed => 'subscribed_admin',
++ included => 'included_admin',
++ id => 'include_sources_admin',
++ info => 'info_admin',
++ profile => 'profile_admin',
++ role => 'role_admin'
++ );
++
++ ## mapping between var and tables
++ my %map_table = ( reception => 'admin_table',
++ visibility => 'admin_table',
++ date => 'admin_table',
++ update_date => 'admin_table',
++ gecos => 'admin_table',
++ password => 'user_table',
++ email => 'admin_table',
++ subscribed => 'admin_table',
++ included => 'admin_table',
++ id => 'admin_table',
++ info => 'admin_table',
++ profile => 'admin_table',
++ role => 'admin_table'
++ );
++#### ??
++ ## additional DB fields
++# if (defined $Conf::Conf{'db_additional_user_fields'}) {
++# foreach my $f (split ',', $Conf::Conf{'db_additional_user_fields'}) {
++# $map_table{$f} = 'user_table';
++# $map_field{$f} = $f;
++# }
++# }
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ ## Update each table
++ foreach $table ('user_table','admin_table') {
++
++ my @set_list;
++ while (($field, $value) = each %{$values}) {
++
++ unless ($map_field{$field} and $map_table{$field}) {
++ &do_log('err', 'Unknown database field %s', $field);
++ next;
++ }
++
++ if ($map_table{$field} eq $table) {
++ if ($field eq 'date') {
++ $value = sprintf $date_format{'write'}{$Conf::Conf{'db_type'}}, $value, $value;
++ }elsif ($field eq 'update_date') {
++ $value = sprintf $date_format{'write'}{$Conf::Conf{'db_type'}}, $value, $value;
++ }elsif ($value eq 'NULL'){
++ if ($Conf::Conf{'db_type'} eq 'mysql') {
++ $value = '\N';
++ }
++ }else {
++ if ($numeric_field{$map_field{$field}}) {
++ $value ||= 0; ## Can't have a null value
++ }else {
++ $value = $dbh->quote($value);
++ }
++ }
++ my $set = sprintf "%s=%s", $map_field{$field}, $value;
++
++ push @set_list, $set;
++ }
++ }
++ next unless @set_list;
++
++ ## Update field
++ if ($table eq 'user_table') {
++ $statement = sprintf "UPDATE %s SET %s WHERE (email_user=%s)", $table, join(',', @set_list), $dbh->quote($who);
++
++ }elsif ($table eq 'admin_table') {
++ if ($who eq '*') {
++ $statement = sprintf "UPDATE %s SET %s WHERE (list_admin=%s AND robot_admin=%s AND role_admin=%s)",
++ $table,
++ join(',', @set_list),
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $dbh->quote($role);
++ }else {
++ $statement = sprintf "UPDATE %s SET %s WHERE (user_admin=%s AND list_admin=%s AND robot_admin=%s AND role_admin=%s )",
++ $table,
++ join(',', @set_list),
++ $dbh->quote($who),
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $dbh->quote($role);
++ }
++ }
++ }
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ ## Reset session cache
++ $list_cache{'get_admin_user'}{$self->{'domain'}}{$name}{$role}{$who} = undef;
++
++ return 1;
++}
++
++
++
++## Sets new values for the given user in the Database
++sub update_user_db {
++ my($who, $values) = @_;
++ do_log('debug', 'List::update_user_db(%s)', $who);
++
++ $who = &tools::clean_email($who);
++
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ ## use md5 fingerprint to store password
++ $values->{'password'} = &Auth::password_fingerprint($values->{'password'}) if ($values->{'password'});
++
++ my ($field, $value);
++
++ my ($user, $statement, $table);
++
++ ## mapping between var and field names
++ my %map_field = ( gecos => 'gecos_user',
++ password => 'password_user',
++ cookie_delay => 'cookie_delay_user',
++ lang => 'lang_user',
++ attributes => 'attributes_user',
++ email => 'email_user',
++ data => 'data_user',
++ last_login_date => 'last_login_date_user',
++ last_login_host => 'last_login_host_user',
++ wrong_login_count => 'wrong_login_count_user'
++ );
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ ## Update each table
++ my @set_list;
++
++ while (($field, $value) = each %{$values}) {
++ unless ($map_field{$field}) {
++ do_log('error',"unkown field $field in map_field internal error");
++ next;
++ };
++ my $set;
++
++ if ($numeric_field{$map_field{$field}}) {
++ $value ||= 0; ## Can't have a null value
++ $set = sprintf '%s=%s', $map_field{$field}, $value;
++ }else {
++ $set = sprintf '%s=%s', $map_field{$field}, $dbh->quote($value);
++ }
++ push @set_list, $set;
++ }
++
++ return undef unless @set_list;
++
++ ## Update field
++
++ # my $statement2 = sprintf "UPDATE user_table SET %s WHERE (email_user=%s)",$setlist,dbh->quote($who);
++
++ $statement = sprintf "UPDATE user_table SET %s WHERE (email_user=%s)"
++ , join(',', @set_list), $dbh->quote($who);
++
++ do_log('debug3', 'List::update_user_db() statement : %s', $statement);
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ return 1;
++}
++
++## Adds a new user to Database (in User table)
++sub add_user_db {
++ my($values) = @_;
++ do_log('debug2', 'List::add_user_db');
++
++ my ($field, $value);
++ my ($user, $statement, $table);
++
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ ## encrypt password
++ $values->{'password'} = &Auth::password_fingerprint($values->{'password'}) if ($values->{'password'});
++
++ return undef unless (my $who = &tools::clean_email($values->{'email'}));
++
++ return undef if (is_user_db($who));
++
++ ## mapping between var and field names
++ my %map_field = ( email => 'email_user',
++ gecos => 'gecos_user',
++ custom_attribute => 'custom_attribute',
++ password => 'password_user',
++ cookie_delay => 'cookie_delay_user',
++ lang => 'lang_user',
++ attributes => 'attributes_user'
++ );
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ ## Update each table
++ my (@insert_field, @insert_value);
++ while (($field, $value) = each %{$values}) {
++
++ next unless ($map_field{$field});
++
++ my $insert;
++ if ($numeric_field{$map_field{$field}}) {
++ $value ||= 0; ## Can't have a null value
++ $insert = $value;
++ }else {
++ $insert = sprintf "%s", $dbh->quote($value);
++ }
++ push @insert_value, $insert;
++ push @insert_field, $map_field{$field}
++ }
++
++ return undef
++ unless @insert_field;
++
++ ## Update field
++ $statement = sprintf "INSERT INTO user_table (%s) VALUES (%s)"
++ , join(',', @insert_field), join(',', @insert_value);
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ return 1;
++}
++
++## Adds a new user, no overwrite.
++sub add_user {
++ my($self, @new_users) = @_;
++ &do_log('debug2', 'List::add_user');
++
++ my $name = $self->{'name'};
++ my $total = 0;
++
++ my $subscriptions = $self->get_subscription_requests();
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ foreach my $new_user (@new_users) {
++ my $who = &tools::clean_email($new_user->{'email'});
++ next unless $who;
++
++ # Delete from exclusion_table if new_user is in.
++ &insert_delete_exclusion($who, $name, $self->{'domain'}, 'delete');
++
++ $new_user->{'date'} ||= time;
++ $new_user->{'update_date'} ||= $new_user->{'date'};
++
++ my %custom_attr = %{ $subscriptions->{$who}{'custom_attribute'} } if (defined $subscriptions->{$who}{'custom_attribute'} );
++ $new_user->{'custom_attribute'} ||= &createXMLCustomAttribute(\%custom_attr) ;
++ do_log('debug2', 'List::add_user custom_attribute = %s', $new_user->{'custom_attribute'});
++
++ my $date_field = sprintf $date_format{'write'}{$Conf::Conf{'db_type'}}, $new_user->{'date'}, $new_user->{'date'};
++ my $update_field = sprintf $date_format{'write'}{$Conf::Conf{'db_type'}}, $new_user->{'update_date'}, $new_user->{'update_date'};
++
++ ## Crypt password if it was not crypted
++ unless ($new_user->{'password'} =~ /^crypt/) {
++ $new_user->{'password'} = &tools::crypt_password($new_user->{'password'});
++ }
++
++ $list_cache{'is_user'}{$self->{'domain'}}{$name}{$who} = undef;
++
++ my $statement;
++
++ ## Either is_included or is_subscribed must be set
++ ## default is is_subscriber for backward compatibility reason
++ unless ($new_user->{'included'}) {
++ $new_user->{'subscribed'} = 1;
++ }
++
++ unless ($new_user->{'included'}) {
++ ## Is the email in user table?
++ if (! is_user_db($who)) {
++ ## Insert in User Table
++ $statement = sprintf "INSERT INTO user_table (email_user, gecos_user, lang_user, password_user) VALUES (%s,%s,%s,%s)",$dbh->quote($who), $dbh->quote($new_user->{'gecos'}), $dbh->quote($new_user->{'lang'}), $dbh->quote($new_user->{'password'});
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ next;
++ }
++ }
++ }
++
++ $new_user->{'subscribed'} ||= 0;
++ $new_user->{'included'} ||= 0;
++
++ ## Update Subscriber Table
++ $statement = sprintf "INSERT INTO subscriber_table (user_subscriber, comment_subscriber, list_subscriber, robot_subscriber, date_subscriber, update_subscriber, reception_subscriber, topics_subscriber, visibility_subscriber,subscribed_subscriber,included_subscriber,include_sources_subscriber,custom_attribute_subscriber,suspend_subscriber,suspend_start_date_subscriber,suspend_end_date_subscriber) VALUES (%s, %s, %s, %s, %s, %s, %s, %s, %s, %s, %s, %s, %s, %s, %s, %s)",
++ $dbh->quote($who),
++ $dbh->quote($new_user->{'gecos'}),
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $date_field,
++ $update_field,
++ $dbh->quote($new_user->{'reception'}),
++ $dbh->quote($new_user->{'topics'}),
++ $dbh->quote($new_user->{'visibility'}),
++ $new_user->{'subscribed'},
++ $new_user->{'included'},
++ $dbh->quote($new_user->{'id'}),
++ $dbh->quote($new_user->{'custom_attribute'}),
++ $dbh->quote($new_user->{'suspend'}),
++ $dbh->quote($new_user->{'startdate'}),
++ $dbh->quote($new_user->{'enddate'});
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ next;
++ }
++ $total++;
++ }
++
++ $self->{'total'} += $total;
++ $self->savestats();
++
++ return $total;
++}
++
++
++## Adds a new admin user, no overwrite.
++sub add_admin_user {
++ my($self, $role, @new_admin_users) = @_;
++ do_log('debug2', 'List::add_admin_user');
++
++ my $name = $self->{'name'};
++ my $total = 0;
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ foreach my $new_admin_user (@new_admin_users) {
++ my $who = &tools::clean_email($new_admin_user->{'email'});
++
++ next unless $who;
++
++ $new_admin_user->{'date'} ||= time;
++ $new_admin_user->{'update_date'} ||= $new_admin_user->{'date'};
++
++ my $date_field = sprintf $date_format{'write'}{$Conf::Conf{'db_type'}}, $new_admin_user->{'date'}, $new_admin_user->{'date'};
++ my $update_field = sprintf $date_format{'write'}{$Conf::Conf{'db_type'}}, $new_admin_user->{'update_date'}, $new_admin_user->{'update_date'};
++
++ $list_cache{'is_admin_user'}{$self->{'domain'}}{$name}{$who} = undef;
++
++ my $statement;
++
++ ## either is_included or is_subscribed must be set
++ ## default is is_subscriber for backward compatibility reason
++ unless ($new_admin_user->{'included'}) {
++ $new_admin_user->{'subscribed'} = 1;
++ }
++
++ unless ($new_admin_user->{'included'}) {
++ ## Is the email in user table?
++ if (! is_user_db($who)) {
++ ## Insert in User Table
++ $statement = sprintf "INSERT INTO user_table (email_user, gecos_user, lang_user, password_user) VALUES (%s,%s,%s,%s)",$dbh->quote($who), $dbh->quote($new_admin_user->{'gecos'}), $dbh->quote($new_admin_user->{'lang'}), $dbh->quote($new_admin_user->{'password'});
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ next;
++ }
++ }
++ }
++
++ $new_admin_user->{'subscribed'} ||= 0;
++ $new_admin_user->{'included'} ||= 0;
++
++ ## Update Admin Table
++ $statement = sprintf "INSERT INTO admin_table (user_admin, comment_admin, list_admin, robot_admin, date_admin, update_admin, reception_admin, visibility_admin, subscribed_admin,included_admin,include_sources_admin, role_admin, info_admin, profile_admin) VALUES (%s, %s, %s, %s, %s, %s, %s, %s, %s, %s, %s, %s, %s, %s)",
++ $dbh->quote($who),
++ $dbh->quote($new_admin_user->{'gecos'}),
++ $dbh->quote($name),
++ $dbh->quote($self->{'domain'}),
++ $date_field,
++ $update_field,
++ $dbh->quote($new_admin_user->{'reception'}),
++ $dbh->quote($new_admin_user->{'visibility'}),
++ $new_admin_user->{'subscribed'},
++ $new_admin_user->{'included'},
++ $dbh->quote($new_admin_user->{'id'}),
++ $dbh->quote($role),
++ $dbh->quote($new_admin_user->{'info'}),
++ $dbh->quote($new_admin_user->{'profile'});
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ next;
++ }
++ $total++;
++ }
++
++ return $total;
++}
++
++## Update subscribers and admin users (used while renaming a list)
++sub rename_list_db {
++ my($self, $new_listname, $new_robot) = @_;
++ do_log('debug', 'List::rename_list_db(%s,%s,%s)', $self->{'name'},$new_listname, $new_robot);
++
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ my $statement_subscriber;
++ my $statement_admin;
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ $statement_subscriber = sprintf "UPDATE subscriber_table SET list_subscriber=%s, robot_subscriber=%s WHERE (list_subscriber=%s AND robot_subscriber=%s)",
++ $dbh->quote($new_listname),
++ $dbh->quote($new_robot),
++ $dbh->quote($self->{'name'}),
++ $dbh->quote($self->{'domain'}) ;
++
++ do_log('debug', 'List::rename_list_db statement : %s', $statement_subscriber );
++
++ unless ($dbh->do($statement_subscriber)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement_subscriber, $dbh->errstr);
++ return undef;
++ }
++
++ # admin_table is "alive" only in case include2
++ $statement_admin = sprintf "UPDATE admin_table SET list_admin=%s, robot_admin=%s WHERE (list_admin=%s AND robot_admin=%s)",
++ $dbh->quote($new_listname),
++ $dbh->quote($new_robot),
++ $dbh->quote($self->{'name'}),
++ $dbh->quote($self->{'domain'}) ;
++
++ do_log('debug', 'List::rename_list_db statement : %s', $statement_admin );
++
++ unless ($dbh->do($statement_admin)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement_admin, $dbh->errstr);
++ return undef;
++ }
++
++ return 1;
++}
++
++
++## Is the user listmaster
++sub is_listmaster {
++ my $who = shift;
++ my $robot = shift;
++
++ $who =~ y/A-Z/a-z/;
++
++ return 0 unless ($who);
++
++ if ($robot && (defined $Conf::Conf{'robots'}{$robot}) && $Conf::Conf{'robots'}{$robot}{'listmasters'}) {
++ foreach my $listmaster (@{$Conf::Conf{'robots'}{$robot}{'listmasters'}}){
++ return 1 if (lc($listmaster) eq lc($who));
++ }
++ }
++
++ foreach my $listmaster (@{$Conf::Conf{'listmasters'}}){
++ return 1 if (lc($listmaster) eq lc($who));
++ }
++
++ return 0;
++}
++
++## Does the user have a particular function in the list?
++sub am_i {
++ my($self, $function, $who, $options) = @_;
++ do_log('debug2', 'List::am_i(%s, %s, %s)', $function, $self->{'name'}, $who);
++
++ return undef unless ($self && $who);
++ $function =~ y/A-Z/a-z/;
++ $who =~ y/A-Z/a-z/;
++ chomp($who);
++
++ ## If 'strict' option is given, then listmaster does not inherit privileged
++ unless (defined $options and $options->{'strict'}) {
++ ## Listmaster has all privileges except editor
++ # sa contestable.
++ if (($function eq 'owner' || $function eq 'privileged_owner') and &is_listmaster($who,$self->{'domain'})) {
++ $list_cache{'am_i'}{$function}{$self->{'domain'}}{$self->{'name'}}{$who} = 1;
++ return 1;
++ }
++ }
++
++ ## Use cache
++ if (defined $list_cache{'am_i'}{$function}{$self->{'domain'}}{$self->{'name'}}{$who} &&
++ $function ne 'editor') { ## Defaults for editor may be owners) {
++ # &do_log('debug3', 'Use cache(%s,%s): %s', $name, $who, $list_cache{'is_user'}{$self->{'domain'}}{$name}{$who});
++ return $list_cache{'am_i'}{$function}{$self->{'domain'}}{$self->{'name'}}{$who};
++ }
++
++ ##Check editors
++ if ($function =~ /^editor$/i){
++
++ ## Check cache first
++ if ($list_cache{'am_i'}{$function}{$self->{'domain'}}{$self->{'name'}}{$who} == 1) {
++ return 1;
++ }
++
++ my $editor = $self->get_admin_user('editor',$who);
++
++ if (defined $editor) {
++ return 1;
++ }else {
++ ## Check if any editor is defined ; if not owners are editors
++ my $editors = $self->get_editors();
++ if ($#{$editors} < 0) {
++
++ # if no editor defined, owners has editor privilege
++ $editor = $self->get_admin_user('owner',$who);
++ if (defined $editor){
++ ## Update cache
++ $list_cache{'am_i'}{'editor'}{$self->{'domain'}}{$self->{'name'}}{$who} = 1;
++
++ return 1;
++ }
++ }else {
++
++ ## Update cache
++ $list_cache{'am_i'}{'editor'}{$self->{'domain'}}{$self->{'name'}}{$who} = 0;
++
++ return undef;
++ }
++ }
++ }
++ ## Check owners
++ if ($function =~ /^owner$/i){
++ my $owner = $self->get_admin_user('owner',$who);
++ if (defined $owner) {
++ ## Update cache
++ $list_cache{'am_i'}{'owner'}{$self->{'domain'}}{$self->{'name'}}{$who} = 1;
++
++ return 1;
++ }else {
++
++ ## Update cache
++ $list_cache{'am_i'}{'owner'}{$self->{'domain'}}{$self->{'name'}}{$who} = 0;
++
++ return undef;
++ }
++ }elsif ($function =~ /^privileged_owner$/i) {
++ my $privileged = $self->get_admin_user('owner',$who);
++ if ($privileged->{'profile'} eq 'privileged') {
++
++ ## Update cache
++ $list_cache{'am_i'}{'privileged_owner'}{$self->{'domain'}}{$self->{'name'}}{$who} = 1;
++
++ return 1;
++ }else {
++
++ ## Update cache
++ $list_cache{'am_i'}{'privileged_owner'}{$self->{'domain'}}{$self->{'name'}}{$who} = 0;
++
++ return undef;
++ }
++ }
++}
++
++## Check list authorizations
++## Higher level sub for request_action
++sub check_list_authz {
++ my $self = shift;
++ my $operation = shift;
++ my $auth_method = shift;
++ my $context = shift;
++ my $debug = shift;
++ &do_log('debug', 'List::check_list_authz %s,%s',$operation,$auth_method);
++
++ $context->{'list_object'} = $self;
++
++ return &Scenario::request_action($operation, $auth_method, $self->{'domain'}, $context, $debug);
++}
++
++## Initialize internal list cache
++sub init_list_cache {
++ &do_log('debug2', 'List::init_list_cache()');
++
++ undef %list_cache;
++}
++
++## May the indicated user edit the indicated list parameter or not?
++sub may_edit {
++
++ my($self,$parameter, $who) = @_;
++ do_log('debug3', 'List::may_edit(%s, %s)', $parameter, $who);
++
++ my $role;
++
++ return undef unless ($self);
++
++ my $edit_conf;
++
++ # Load edit_list.conf: track by file, not domain (file may come from server, robot, family or list context)
++ my $edit_conf_file = &tools::get_filename('etc',{},'edit_list.conf',$self->{'domain'},$self);
++ if (! $edit_list_conf{$edit_conf_file} || ((stat($edit_conf_file))[9] > $mtime{'edit_list_conf'}{$edit_conf_file})) {
++
++ $edit_conf = $edit_list_conf{$edit_conf_file} = &tools::load_edit_list_conf($self->{'domain'}, $self);
++ $mtime{'edit_list_conf'}{$edit_conf_file} = time;
++ }else {
++ $edit_conf = $edit_list_conf{$edit_conf_file};
++ }
++
++ ## What privilege?
++ if (&is_listmaster($who,$self->{'domain'})) {
++ $role = 'listmaster';
++ }elsif ( $self->am_i('privileged_owner',$who) ) {
++ $role = 'privileged_owner';
++
++ }elsif ( $self->am_i('owner',$who) ) {
++ $role = 'owner';
++
++ }elsif ( $self->am_i('editor',$who) ) {
++ $role = 'editor';
++
++# }elsif ( $self->am_i('subscriber',$who) ) {
++# $role = 'subscriber';
++#
++ }else {
++ return ('user','hidden');
++ }
++
++ ## What privilege does he/she has?
++ my ($what, @order);
++
++ if (($parameter =~ /^(\w+)\.(\w+)$/) &&
++ ($parameter !~ /\.tt2$/)) {
++ my $main_parameter = $1;
++ @order = ($edit_conf->{$parameter}{$role},
++ $edit_conf->{$main_parameter}{$role},
++ $edit_conf->{'default'}{$role},
++ $edit_conf->{'default'}{'default'})
++ }else {
++ @order = ($edit_conf->{$parameter}{$role},
++ $edit_conf->{'default'}{$role},
++ $edit_conf->{'default'}{'default'})
++ }
++
++ foreach $what (@order) {
++ if (defined $what) {
++ return ($role,$what);
++ }
++ }
++
++ return ('user','hidden');
++}
++
++
++## May the indicated user edit a paramter while creating a new list
++# sa cette proc��dure est appel��e nul part, je lui ajoute malgr��s tout le param��tre robot
++# edit_conf devrait ��tre aussi d��pendant du robot
++sub may_create_parameter {
++
++ my($self, $parameter, $who,$robot) = @_;
++ do_log('debug3', 'List::may_create_parameter(%s, %s, %s)', $parameter, $who,$robot);
++
++ if ( &is_listmaster($who,$robot)) {
++ return 1;
++ }
++ my $edit_conf = &tools::load_edit_list_conf($robot,$self);
++ $edit_conf->{$parameter} ||= $edit_conf->{'default'};
++ if (! $edit_conf->{$parameter}) {
++ do_log('notice','tools::load_edit_list_conf privilege for parameter $parameter undefined');
++ return undef;
++ }
++ if ($edit_conf->{$parameter} =~ /^(owner|privileged_owner)$/i ) {
++ return 1;
++ }else{
++ return 0;
++ }
++
++}
++
++
++## May the indicated user do something with the list or not?
++## Action can be : send, review, index, get
++## add, del, reconfirm, purge
++sub may_do {
++ my($self, $action, $who) = @_;
++ do_log('debug3', 'List::may_do(%s, %s)', $action, $who);
++
++ my $i;
++
++ ## Just in case.
++ return undef unless ($self && $action);
++ my $admin = $self->{'admin'};
++ return undef unless ($admin);
++
++ $action =~ y/A-Z/a-z/;
++ $who =~ y/A-Z/a-z/;
++
++ if ($action =~ /^(index|get)$/io) {
++ my $arc_access = $admin->{'archive'}{'access'};
++ if ($arc_access =~ /^public$/io) {
++ return 1;
++ }elsif ($arc_access =~ /^private$/io) {
++ return 1 if ($self->is_user($who));
++ return $self->am_i('owner', $who);
++ }elsif ($arc_access =~ /^owner$/io) {
++ return $self->am_i('owner', $who);
++ }
++ return undef;
++ }
++
++ if ($action =~ /^(review)$/io) {
++ foreach $i (@{$admin->{'review'}}) {
++ if ($i =~ /^public$/io) {
++ return 1;
++ }elsif ($i =~ /^private$/io) {
++ return 1 if ($self->is_user($who));
++ return $self->am_i('owner', $who);
++ }elsif ($i =~ /^owner$/io) {
++ return $self->am_i('owner', $who);
++ }
++ return undef;
++ }
++ }
++
++ if ($action =~ /^send$/io) {
++ if ($admin->{'send'} =~/^(private|privateorpublickey|privateoreditorkey)$/i) {
++
++ return undef unless ($self->is_user($who) || $self->am_i('owner', $who));
++ }elsif ($admin->{'send'} =~ /^(editor|editorkey|privateoreditorkey)$/i) {
++ return undef unless ($self->am_i('editor', $who));
++ }elsif ($admin->{'send'} =~ /^(editorkeyonly|publickey|privatekey)$/io) {
++ return undef;
++ }
++ return 1;
++ }
++
++ if ($action =~ /^(add|del|remind|reconfirm|purge)$/io) {
++ return $self->am_i('owner', $who);
++ }
++
++ if ($action =~ /^(modindex)$/io) {
++ return undef unless ($self->am_i('editor', $who));
++ return 1;
++ }
++
++ if ($action =~ /^auth$/io) {
++ if ($admin->{'send'} =~ /^(privatekey)$/io) {
++ return 1 if ($self->is_user($who) || $self->am_i('owner', $who));
++ } elsif ($admin->{'send'} =~ /^(privateorpublickey)$/io) {
++ return 1 unless ($self->is_user($who) || $self->am_i('owner', $who));
++ }elsif ($admin->{'send'} =~ /^(publickey)$/io) {
++ return 1;
++ }
++ return undef; #authent
++ }
++ return undef;
++}
++
++## Does the list support digest mode
++sub is_digest {
++ return (shift->{'admin'}{'digest'});
++}
++
++## Does the file exist?
++sub archive_exist {
++ my($self, $file) = @_;
++ do_log('debug', 'List::archive_exist (%s)', $file);
++
++ return undef unless ($self->is_archived());
++ my $dir = &Conf::get_robot_conf($self->{'domain'},'arc_path').'/'.$self->get_list_id();
++ Archive::exist($dir, $file);
++
++}
++
++
++## List the archived files
++sub archive_ls {
++ my $self = shift;
++ do_log('debug2', 'List::archive_ls');
++
++ my $dir = &Conf::get_robot_conf($self->{'domain'},'arc_path').'/'.$self->get_list_id();
++
++ Archive::list($dir) if ($self->is_archived());
++}
++
++## Archive
++sub archive_msg {
++ my($self, $msg ) = @_;
++ do_log('debug2', 'List::archive_msg for %s',$self->{'name'});
++
++ my $is_archived = $self->is_archived();
++ Archive::store_last($self, $msg) if ($is_archived);
++
++ Archive::outgoing("$Conf::Conf{'queueoutgoing'}",$self->get_list_id(),$msg)
++ if ($self->is_web_archived());
++}
++
++sub archive_msg_digest {
++ my($self, $msg) = @_;
++ do_log('debug2', 'List::archive_msg_digest');
++
++ $self->store_digest( $msg) if ($self->{'name'});
++}
++
++## Is the list moderated?
++sub is_moderated {
++
++ return 1 if (defined shift->{'admin'}{'editor'});
++
++ return 0;
++}
++
++## Is the list archived?
++sub is_archived {
++ do_log('debug', 'List::is_archived');
++ if (shift->{'admin'}{'web_archive'}{'access'}) {do_log('debug', 'List::is_archived : 1'); return 1 ;}
++ do_log('debug', 'List::is_archived : undef');
++ return undef;
++}
++
++## Is the list web archived?
++sub is_web_archived {
++ return 1 if (shift->{'admin'}{'web_archive'}{'access'}) ;
++ return undef;
++
++}
++
++## Returns 1 if the digest must be send
++sub get_nextdigest {
++ my $self = shift;
++ do_log('debug3', 'List::get_nextdigest (%s)');
++
++ my $digest = $self->{'admin'}{'digest'};
++ my $listname = $self->{'name'};
++
++ ## Reverse compatibility concerns
++ my $filename;
++ foreach my $f ("$Conf::Conf{'queuedigest'}/$listname",
++ $Conf::Conf{'queuedigest'}.'/'.$self->get_list_id()) {
++ $filename = $f if (-f $f);
++ }
++
++ return undef unless (defined $filename);
++
++ unless ($digest) {
++ return undef;
++ }
++
++ my @days = @{$digest->{'days'}};
++ my ($hh, $mm) = ($digest->{'hour'}, $digest->{'minute'});
++
++ my @now = localtime(time);
++ my $today = $now[6]; # current day
++ my @timedigest = localtime( (stat $filename)[9]);
++
++ ## Should we send a digest today
++ my $send_digest = 0;
++ foreach my $d (@days){
++ if ($d == $today) {
++ $send_digest = 1;
++ last;
++ }
++ }
++
++ return undef
++ unless ($send_digest == 1);
++
++ if (($now[2] * 60 + $now[1]) >= ($hh * 60 + $mm) and
++ (timelocal(0, $mm, $hh, $now[3], $now[4], $now[5]) > timelocal(0, $timedigest[1], $timedigest[2], $timedigest[3], $timedigest[4], $timedigest[5]))
++ ){
++ return 1;
++ }
++
++ return undef;
++}
++
++
++## Loads all scenari for an action
++sub load_scenario_list {
++ my ($self, $action,$robot) = @_;
++ do_log('debug3', 'List::load_scenario_list(%s,%s)', $action,$robot);
++
++ my $directory = "$self->{'dir'}";
++ my %list_of_scenario;
++ my %skip_scenario;
++
++ foreach my $dir (
++ "$directory/scenari",
++ "$Conf::Conf{'etc'}/$robot/scenari",
++ "$Conf::Conf{'etc'}/scenari",
++ Sympa::Constants::DEFAULTDIR . '/scenari'
++ ) {
++ next unless (-d $dir);
++
++ my $scenario_regexp = &tools::get_regexp('scenario');
++
++ while (<$dir/$action.*:ignore>) {
++ if (/$action\.($scenario_regexp):ignore$/) {
++ my $name = $1;
++ $skip_scenario{$name} = 1;
++ }
++ }
++
++ while (<$dir/$action.*>) {
++ next unless (/$action\.($scenario_regexp)$/);
++ my $name = $1;
++
++ next if (defined $list_of_scenario{$name});
++ next if (defined $skip_scenario{$name});
++
++ my $scenario = new Scenario ('robot' => $robot,
++ 'directory' => $directory,
++ 'function' => $action,
++ 'name' => $name);
++ $list_of_scenario{$name} = $scenario;
++
++ ## Set the title in the current language
++ if (defined $scenario->{'title'}{&Language::GetLang()}) {
++ $list_of_scenario{$name}{'web_title'} = $scenario->{'title'}{&Language::GetLang()};
++ }elsif (defined $scenario->{'title'}{'gettext'}) {
++ $list_of_scenario{$name}{'web_title'} = gettext($scenario->{'title'}{'gettext'});
++ }elsif (defined $scenario->{'title'}{'us'}) {
++ $list_of_scenario{$name}{'web_title'} = gettext($scenario->{'title'}{'us'});
++ }else {
++ $list_of_scenario{$name}{'web_title'} = $name;
++ }
++ $list_of_scenario{$name}{'name'} = $name;
++ }
++ }
++
++ ## Return a copy of the data to prevent unwanted changes in the central scenario data structure
++ return &tools::dup_var(\%list_of_scenario);
++}
++
++sub load_task_list {
++ my ($self, $action,$robot) = @_;
++ do_log('debug2', 'List::load_task_list(%s,%s)', $action,$robot);
++
++ my $directory = "$self->{'dir'}";
++ my %list_of_task;
++
++ foreach my $dir (
++ "$directory/list_task_models",
++ "$Conf::Conf{'etc'}/$robot/list_task_models",
++ "$Conf::Conf{'etc'}/list_task_models",
++ Sympa::Constants::DEFAULTDIR . '/list_task_models'
++ ) {
++
++ next unless (-d $dir);
++
++ foreach my $file (<$dir/$action.*>) {
++ next unless ($file =~ /$action\.(\w+)\.task$/);
++ my $name = $1;
++
++ next if (defined $list_of_task{$name});
++
++ $list_of_task{$name}{'name'} = $name;
++
++ my $titles = &List::_load_task_title ($file);
++
++ ## Set the title in the current language
++ if (defined $titles->{&Language::GetLang()}) {
++ $list_of_task{$name}{'title'} = $titles->{&Language::GetLang()};
++ }elsif (defined $titles->{'gettext'}) {
++ $list_of_task{$name}{'title'} = gettext( $titles->{'gettext'});
++ }elsif (defined $titles->{'us'}) {
++ $list_of_task{$name}{'title'} = gettext( $titles->{'us'});
++ }else {
++ $list_of_task{$name}{'title'} = $name;
++ }
++
++ }
++ }
++
++ return \%list_of_task;
++}
++
++sub _load_task_title {
++ my $file = shift;
++ do_log('debug3', 'List::_load_task_title(%s)', $file);
++ my $title = {};
++
++ unless (open TASK, $file) {
++ do_log('err', 'Unable to open file "%s"' , $file);
++ return undef;
++ }
++
++ while (<TASK>) {
++ last if /^\s*$/;
++
++ if (/^title\.([\w-]+)\s+(.*)\s*$/) {
++ $title->{$1} = $2;
++ }
++ }
++
++ close TASK;
++
++ return $title;
++}
++
++## Loads all data sources
++sub load_data_sources_list {
++ my ($self, $robot) = @_;
++ do_log('debug3', 'List::load_data_sources_list(%s,%s)', $self->{'name'},$robot);
++
++ my $directory = "$self->{'dir'}";
++ my %list_of_data_sources;
++
++ foreach my $dir (
++ "$directory/data_sources",
++ "$Conf::Conf{'etc'}/$robot/data_sources",
++ "$Conf::Conf{'etc'}/data_sources",
++ Sympa::Constants::DEFAULTDIR . '/data_sources'
++ ) {
++
++ next unless (-d $dir);
++
++ while (my $f = <$dir/*.incl>) {
++
++ next unless ($f =~ /([\w\-]+)\.incl$/);
++
++ my $name = $1;
++
++ next if (defined $list_of_data_sources{$name});
++
++ $list_of_data_sources{$name}{'title'} = $name;
++ $list_of_data_sources{$name}{'name'} = $name;
++ }
++ }
++
++ return \%list_of_data_sources;
++}
++
++## Loads the statistics information
++sub _load_stats_file {
++ my $file = shift;
++ do_log('debug3', 'List::_load_stats_file(%s)', $file);
++
++ ## Create the initial stats array.
++ my ($stats, $total, $last_sync, $last_sync_admin_user);
++
++ if (open(L, $file)){
++ if (<L> =~ /^(\d+)\s+(\d+)\s+(\d+)\s+(\d+)(\s+(\d+))?(\s+(\d+))?(\s+(\d+))?/) {
++ $stats = [ $1, $2, $3, $4];
++ $total = $6;
++ $last_sync = $8;
++ $last_sync_admin_user = $10;
++
++ } else {
++ $stats = [ 0, 0, 0, 0];
++ $total = 0;
++ $last_sync = 0;
++ $last_sync_admin_user = 0;
++ }
++ close(L);
++ } else {
++ $stats = [ 0, 0, 0, 0];
++ $total = 0;
++ $last_sync = 0;
++ $last_sync_admin_user = 0;
++ }
++
++ ## Return the array.
++ return ($stats, $total, $last_sync, $last_sync_admin_user);
++}
++
++## Loads the list of subscribers as a tied hash
++sub _load_users {
++ my $file = shift;
++ do_log('debug2', 'List::_load_users(%s)', $file);
++
++ ## Create the in memory btree using DB_File.
++ my %users;
++ my @users_list = (&_load_users_file($file)) ;
++ my $btree = new DB_File::BTREEINFO;
++ return undef unless ($btree);
++ $btree->{'compare'} = \&_compare_addresses;
++ $btree->{'cachesize'} = 200 * ( $#users_list + 1 ) ;
++ my $ref = tie %users, 'DB_File', undef, O_CREAT|O_RDWR, 0600, $btree;
++ return undef unless ($ref);
++
++ ## Counters.
++ my $total = 0;
++
++ foreach my $user ( @users_list ) {
++ my $email = $user->{'email'};
++ unless ($users{$email}) {
++ $total++;
++ $users{$email} = join("\n", %{$user});
++ unless ( defined ( $users{$email} )) {
++ # $btree->{'cachesize'} under-sized
++ &do_log('err', '_load_users : cachesise too small : (%d users)', $total);
++ return undef;
++ }
++ }
++ }
++
++ my $l = {
++ 'ref' => $ref,
++ 'users' => \%users,
++ 'total' => $total
++ };
++
++ $l;
++}
++
++## Loads the list of subscribers.
++sub _load_users_file {
++ my $file = shift;
++ do_log('debug2', 'List::_load_users_file(%s)', $file);
++
++ ## Open the file and switch to paragraph mode.
++ open(L, $file) || return undef;
++
++ ## Process the lines
++ local $/;
++ my $data = <L>;
++
++ my @users;
++ foreach (split /\n\n/, $data) {
++ my(%user, $email);
++ $user{'email'} = $email = $1 if (/^\s*email\s+(.+)\s*$/om);
++ $user{'gecos'} = $1 if (/^\s*gecos\s+(.+)\s*$/om);
++ $user{'date'} = $1 if (/^\s*date\s+(\d+)\s*$/om);
++ $user{'update_date'} = $1 if (/^\s*update_date\s+(\d+)\s*$/om);
++ $user{'reception'} = $1 if (/^\s*reception\s+(digest|nomail|summary|notice|txt|html|urlize|not_me)\s*$/om);
++ $user{'visibility'} = $1 if (/^\s*visibility\s+(conceal|noconceal)\s*$/om);
++
++ push @users, \%user;
++ }
++ close(L);
++
++ return @users;
++}
++
++## include a remote sympa list as subscribers.
++sub _include_users_remote_sympa_list {
++ my ($self, $users, $param, $dir, $robot, $default_user_options , $tied) = @_;
++
++ my $host = $param->{'host'};
++ my $port = $param->{'port'} || '443';
++ my $path = $param->{'path'};
++ my $cert = $param->{'cert'} || 'list';
++
++ my $id = Datasource::_get_datasource_id($param);
++
++ do_log('debug', 'List::_include_users_remote_sympa_list(%s) https://%s:%s/%s using cert %s,', $self->{'name'}, $host, $port, $path, $cert);
++
++ my $total = 0;
++ my $get_total = 0;
++
++ my $cert_file ; my $key_file ;
++
++ $cert_file = $dir.'/cert.pem';
++ $key_file = $dir.'/private_key';
++ if ($cert eq 'list') {
++ $cert_file = $dir.'/cert.pem';
++ $key_file = $dir.'/private_key';
++ }elsif($cert eq 'robot') {
++ $cert_file = &tools::get_filename('etc',{},'cert.pem',$robot,$self);
++ $key_file = &tools::get_filename('etc',{},'private_key',$robot,$self);
++ }
++ unless ((-r $cert_file) && ( -r $key_file)) {
++ do_log('err', 'Include remote list https://%s:%s/%s using cert %s, unable to open %s or %s', $host, $port, $path, $cert,$cert_file,$key_file);
++ return undef;
++ }
++
++ my $getting_headers = 1;
++
++ my %user ;
++ my $email ;
++
++
++ foreach my $line ( &Fetch::get_https($host,$port,$path,$cert_file,$key_file,{'key_passwd' => $Conf::Conf{'key_passwd'},
++ 'cafile' => $Conf::Conf{'cafile'},
++ 'capath' => $Conf::Conf{'capath'}})
++ ){
++ chomp $line;
++
++ if ($getting_headers) { # ignore http headers
++ next unless ($line =~ /^(date|update_date|email|reception|visibility)/);
++ }
++ undef $getting_headers;
++
++ if ($line =~ /^\s*email\s+(.+)\s*$/o) {
++ $user{'email'} = $email = $1;
++ do_log('debug',"email found $email");
++ $get_total++;
++ }
++ $user{'gecos'} = $1 if ($line =~ /^\s*gecos\s+(.+)\s*$/o);
++
++ next unless ($line =~ /^$/) ;
++
++ unless ($user{'email'}) {
++ do_log('debug','ignoring block without email definition');
++ next;
++ }
++ my %u;
++ ## Check if user has already been included
++ if ($users->{$email}) {
++ do_log('debug3',"ignore $email because already member");
++ if ($tied) {
++ %u = split "\n",$users->{$email};
++ }else {
++ %u = %{$users->{$email}};
++ }
++ }else{
++ do_log('debug3',"add new subscriber $email");
++ %u = %{$default_user_options};
++ $total++;
++ }
++ $u{'email'} = $user{'email'};
++ $u{'id'} = join (',', split(',', $u{'id'}), $id);
++ $u{'gecos'} = $user{'gecos'};delete $user{'gecos'};
++
++ $u{'visibility'} = $default_user_options->{'visibility'} if (defined $default_user_options->{'visibility'});
++ $u{'reception'} = $default_user_options->{'reception'} if (defined $default_user_options->{'reception'});
++ $u{'profile'} = $default_user_options->{'profile'} if (defined $default_user_options->{'profile'});
++ $u{'info'} = $default_user_options->{'info'} if (defined $default_user_options->{'info'});
++
++ if ($tied) {
++ $users->{$email} = join("\n", %u);
++ }else{
++ $users->{$email} = \%u;
++ }
++ delete $user{$email};undef $email;
++
++ }
++ do_log('info','Include %d users from list (%d subscribers) https://%s:%s%s',$total,$get_total,$host,$port,$path);
++ return $total ;
++}
++
++
++
++## include a list as subscribers.
++sub _include_users_list {
++ my ($users, $includelistname, $robot, $default_user_options, $tied) = @_;
++ do_log('debug2', 'List::_include_users_list');
++
++ my $total = 0;
++
++ my $includelist;
++
++ ## The included list is local or in another local robot
++ if ($includelistname =~ /\@/) {
++ $includelist = new List ($includelistname);
++ }else {
++ $includelist = new List ($includelistname, $robot);
++ }
++
++ unless ($includelist) {
++ do_log('info', 'Included list %s unknown' , $includelistname);
++ return undef;
++ }
++
++ my $id = Datasource::_get_datasource_id($includelistname);
++
++ for (my $user = $includelist->get_first_user(); $user; $user = $includelist->get_next_user()) {
++ my %u;
++
++ ## Check if user has already been included
++ if ($users->{$user->{'email'}}) {
++ if ($tied) {
++ %u = split "\n",$users->{$user->{'email'}};
++ }else {
++ %u = %{$users->{$user->{'email'}}};
++ }
++ }else {
++ %u = %{$default_user_options};
++ $total++;
++ }
++
++ my $email = $u{'email'} = $user->{'email'};
++ $u{'gecos'} = $user->{'gecos'};
++ $u{'id'} = join (',', split(',', $u{'id'}), $id);
++
++ $u{'visibility'} = $default_user_options->{'visibility'} if (defined $default_user_options->{'visibility'});
++ $u{'reception'} = $default_user_options->{'reception'} if (defined $default_user_options->{'reception'});
++ $u{'profile'} = $default_user_options->{'profile'} if (defined $default_user_options->{'profile'});
++ $u{'info'} = $default_user_options->{'info'} if (defined $default_user_options->{'info'});
++
++ if ($tied) {
++ $users->{$email} = join("\n", %u);
++ }else {
++ $users->{$email} = \%u;
++ }
++ }
++ do_log('info',"Include %d users from list %s",$total,$includelistname);
++ return $total ;
++}
++
++## include a lists owners lists privileged_owners or lists_editors.
++sub _include_users_admin {
++ my ($users, $selection, $role, $default_user_options,$tied) = @_;
++# il faut pr��parer une liste de hash avec le nom de liste, le nom de robot, le r��pertoire de la liset pour appeler
++# load_admin_file d��commanter le include_admin
++ my $lists;
++
++ unless ($role eq 'listmaster') {
++
++ if ($selection =~ /^\*\@(\S+)$/) {
++ $lists = &get_lists($1);
++ my $robot = $1;
++ }else{
++ $selection =~ /^(\S+)@(\S+)$/ ;
++ $lists->[0] = $1;
++ }
++
++ foreach my $list (@$lists) {
++ #my $admin = _load_admin_file($dir, $domain, 'config');
++ }
++ }
++}
++
++sub _include_users_file {
++ my ($users, $filename, $default_user_options,$tied) = @_;
++ do_log('debug2', 'List::_include_users_file(%s)', $filename);
++
++ my $total = 0;
++
++ unless (open(INCLUDE, "$filename")) {
++ do_log('err', 'Unable to open file "%s"' , $filename);
++ return undef;
++ }
++ do_log('debug2','including file %s' , $filename);
++
++ my $id = Datasource::_get_datasource_id($filename);
++ my $lines = 0;
++ my $emails_found = 0;
++ my $email_regexp = &tools::get_regexp('email');
++
++ while (<INCLUDE>) {
++ if($lines > 49 && $emails_found == 0){
++ &do_log('err','Too much errors in file %s (%s lines, %s emails found). Source file probably corrupted. Cancelling.',$filename, $lines, $emails_found);
++ return undef;
++ }
++ next if /^\s*$/;
++ next if /^\s*\#/;
++
++ unless (/^\s*($email_regexp)(\s*(\S.*))?\s*$/) {
++ &do_log('err', 'Not an email address: %s', $_);
++ }
++
++ my $email = &tools::clean_email($1);
++ $lines++;
++ next unless $email;
++ my $gecos = $5;
++ $emails_found++;
++
++ my %u;
++ ## Check if user has already been included
++ if ($users->{$email}) {
++ if ($tied) {
++ %u = split "\n",$users->{$email};
++ }else {
++ %u = %{$users->{$email}};
++ }
++ }else {
++ %u = %{$default_user_options};
++ $total++;
++ }
++ $u{'email'} = $email;
++ $u{'gecos'} = $gecos;
++ $u{'id'} = join (',', split(',', $u{'id'}), $id);
++
++ $u{'visibility'} = $default_user_options->{'visibility'} if (defined $default_user_options->{'visibility'});
++ $u{'reception'} = $default_user_options->{'reception'} if (defined $default_user_options->{'reception'});
++ $u{'profile'} = $default_user_options->{'profile'} if (defined $default_user_options->{'profile'});
++ $u{'info'} = $default_user_options->{'info'} if (defined $default_user_options->{'info'});
++
++ if ($tied) {
++ $users->{$email} = join("\n", %u);
++ }else {
++ $users->{$email} = \%u;
++ }
++ }
++ close INCLUDE ;
++
++
++ do_log('info',"include %d new users from file %s",$total,$filename);
++ return $total ;
++}
++
++sub _include_users_remote_file {
++ my ($users, $param, $default_user_options,$tied) = @_;
++
++ my $url = $param->{'url'};
++
++ do_log('debug', "List::_include_users_remote_file($url)");
++
++ my $total = 0;
++ my $id = Datasource::_get_datasource_id($param);
++
++ ## WebAgent package is part of Fetch.pm and inherites from LWP::UserAgent
++
++ my $fetch = WebAgent->new (agent => 'Sympa/'. Sympa::Constants::VERSION);
++
++ my $req = HTTP::Request->new(GET => $url);
++
++ if (defined $param->{'user'} && defined $param->{'passwd'}) {
++ &WebAgent::set_basic_credentials($param->{'user'},$param->{'passwd'});
++ }
++
++ my $res = $fetch->request($req);
++
++ # check the outcome
++ if ($res->is_success) {
++ my @remote_file = split(/\n/,$res->content);
++ my $lines = 0;
++ my $emails_found = 0;
++ my $email_regexp = &tools::get_regexp('email');
++
++ # forgot headers (all line before one that contain a email
++ foreach my $line (@remote_file) {
++ if($lines > 49 && $emails_found == 0){
++ &do_log('err','Too much errors in file %s (%s lines, %s emails found). Source file probably corrupted. Cancelling.',$url, $lines, $emails_found);
++ return undef;
++ }
++ next if ($line =~ /^\s*$/);
++ next if ($line =~ /^\s*\#/);
++
++ unless ( $line =~ /^\s*($email_regexp)(\s*(\S.*))?\s*$/) {
++ &do_log('err', 'Not an email address: %s', $_);
++ }
++ my $email = &tools::clean_email($1);
++ $lines++;
++ next unless $email;
++ my $gecos = $5;
++ $emails_found++;
++
++ my %u;
++ ## Check if user has already been included
++ if ($users->{$email}) {
++ if ($tied) {
++ %u = split "\n",$users->{$email};
++ }else{
++ %u = %{$users->{$email}};
++ foreach my $k (keys %u) {
++ }
++ }
++ }else {
++ %u = %{$default_user_options};
++ $total++;
++ }
++ $u{'email'} = $email;
++ $u{'gecos'} = $gecos;
++ $u{'id'} = join (',', split(',', $u{'id'}), $id);
++
++ $u{'visibility'} = $default_user_options->{'visibility'} if (defined $default_user_options->{'visibility'});
++ $u{'reception'} = $default_user_options->{'reception'} if (defined $default_user_options->{'reception'});
++ $u{'profile'} = $default_user_options->{'profile'} if (defined $default_user_options->{'profile'});
++ $u{'info'} = $default_user_options->{'info'} if (defined $default_user_options->{'info'});
++
++ if ($tied) {
++ $users->{$email} = join("\n", %u);
++ }else {
++ $users->{$email} = \%u;
++ }
++ }
++ }
++ else {
++ do_log ('err',"List::include_users_remote_file: Unable to fetch remote file $url : %s", $res->message());
++ return undef;
++ }
++
++ ## Reset http credentials
++ &WebAgent::set_basic_credentials('','');
++
++ do_log('info',"include %d new subscribers from remote file %s",$total,$url);
++ return $total ;
++}
++
++
++## Returns a list of subscribers extracted from a remote LDAP Directory
++sub _include_users_ldap {
++ my ($users, $param, $default_user_options, $tied) = @_;
++ do_log('debug2', 'List::_include_users_ldap');
++
++ my $id = Datasource::_get_datasource_id($param);
++
++ my $user = $param->{'user'};
++ my $passwd = $param->{'passwd'};
++ my $ldap_suffix = $param->{'suffix'};
++ my $ldap_filter = $param->{'filter'};
++ my $ldap_attrs = $param->{'attrs'};
++ my $ldap_select = $param->{'select'};
++
++ ## LDAP and query handler
++ my ($ldaph, $fetch);
++
++ ## Connection timeout (default is 120)
++ #my $timeout = 30;
++
++ my $param2 = &tools::dup_var($param);
++ my $ds = new Datasource('LDAP', $param2);
++ if (defined $user) {
++ $param2->{'bind_dn'} = $user;
++ $param2->{'bind_password'} = $passwd;
++ }
++
++ unless (defined $ds && ($ldaph = $ds->connect())) {
++ &do_log('err',"Unable to connect to the LDAP server '%s'", $param2->{'host'});
++ return undef;
++ }
++
++ do_log('debug2', 'Searching on server %s ; suffix %s ; filter %s ; attrs: %s', $param->{'host'}, $ldap_suffix, $ldap_filter, $ldap_attrs);
++ $fetch = $ldaph->search ( base => "$ldap_suffix",
++ filter => "$ldap_filter",
++ attrs => [ "$ldap_attrs" ],
++ scope => "$param->{'scope'}");
++ if ($fetch->code()) {
++ do_log('err','Ldap search (single level) failed : %s (searching on server %s ; suffix %s ; filter %s ; attrs: %s)',
++ $fetch->error(), $param->{'host'}, $ldap_suffix, $ldap_filter, $ldap_attrs);
++ return undef;
++ }
++
++ ## Counters.
++ my $total = 0;
++ my $dn;
++ my @emails;
++ my %emailsViewed;
++
++ while (my $e = $fetch->shift_entry) {
++
++ my $entry = $e->get_value($ldap_attrs, asref => 1);
++
++ ## Multiple values
++ if (ref($entry) eq 'ARRAY') {
++ foreach my $email (@{$entry}) {
++ my $cleanmail = &tools::clean_email($email);
++ next if ($emailsViewed{$cleanmail});
++ push @emails, $cleanmail;
++ $emailsViewed{$cleanmail} = 1;
++ last if ($ldap_select eq 'first');
++ }
++ }else {
++ my $cleanmail = &tools::clean_email($entry);
++ unless ($emailsViewed{$cleanmail}) {
++ push @emails, $cleanmail;
++ $emailsViewed{$cleanmail} = 1;
++ }
++ }
++ }
++
++ unless ($ds->disconnect()) {
++ do_log('notice','Can\'t unbind from LDAP server %s', $param->{'host'});
++ return undef;
++ }
++
++ foreach my $email (@emails) {
++ next if ($email =~ /^\s*$/);
++
++ $email = &tools::clean_email($email);
++ my %u;
++ ## Check if user has already been included
++ if ($users->{$email}) {
++ if ($tied) {
++ %u = split "\n",$users->{$email};
++ }else {
++ %u = %{$users->{$email}};
++ }
++ }else {
++ %u = %{$default_user_options};
++ $total++;
++ }
++
++ $u{'email'} = $email;
++ $u{'date'} = time;
++ $u{'update_date'} = time;
++ $u{'id'} = join (',', split(',', $u{'id'}), $id);
++
++ $u{'visibility'} = $default_user_options->{'visibility'} if (defined $default_user_options->{'visibility'});
++ $u{'reception'} = $default_user_options->{'reception'} if (defined $default_user_options->{'reception'});
++ $u{'profile'} = $default_user_options->{'profile'} if (defined $default_user_options->{'profile'});
++ $u{'info'} = $default_user_options->{'info'} if (defined $default_user_options->{'info'});
++
++ if ($tied) {
++ $users->{$email} = join("\n", %u);
++ }else {
++ $users->{$email} = \%u;
++ }
++ }
++
++ do_log('debug2',"unbinded from LDAP server %s ", $param->{'host'});
++ do_log('info','%d new users included from LDAP query',$total);
++
++ return $total;
++}
++
++## Returns a list of subscribers extracted indirectly from a remote LDAP
++## Directory using a two-level query
++sub _include_users_ldap_2level {
++ my ($users, $param, $default_user_options,$tied) = @_;
++ do_log('debug2', 'List::_include_users_ldap_2level');
++
++ unless (eval "require Net::LDAP") {
++ do_log('err',"Unable to use LDAP library, install perl-ldap (CPAN) first");
++ return undef;
++ }
++ require Net::LDAP;
++
++ my $id = Datasource::_get_datasource_id($param);
++
++ my $user = $param->{'user'};
++ my $passwd = $param->{'passwd'};
++ my $ldap_suffix1 = $param->{'suffix1'};
++ my $ldap_filter1 = $param->{'filter1'};
++ my $ldap_attrs1 = $param->{'attrs1'};
++ my $ldap_select1 = $param->{'select1'};
++ my $ldap_scope1 = $param->{'scope1'};
++ my $ldap_regex1 = $param->{'regex1'};
++ my $ldap_suffix2 = $param->{'suffix2'};
++ my $ldap_filter2 = $param->{'filter2'};
++ my $ldap_attrs2 = $param->{'attrs2'};
++ my $ldap_select2 = $param->{'select2'};
++ my $ldap_scope2 = $param->{'scope2'};
++ my $ldap_regex2 = $param->{'regex2'};
++ my @sync_errors = ();
++
++ ## LDAP and query handler
++ my ($ldaph, $fetch);
++
++ my $param2 = &tools::dup_var($param);
++ my $ds = new Datasource('LDAP', $param2);
++ if (defined $user) {
++ $param2->{'bind_dn'} = $user;
++ $param2->{'bind_password'} = $passwd;
++ }
++
++ unless (defined $ds && ($ldaph = $ds->connect())) {
++ &do_log('err',"Unable to connect to the LDAP server '%s'", $param2->{'host'});
++ return undef;
++ }
++
++ do_log('debug2', 'Searching on server %s ; suffix %s ; filter %s ; attrs: %s', $param->{'host'}, $ldap_suffix1, $ldap_filter1, $ldap_attrs1) ;
++ $fetch = $ldaph->search ( base => "$ldap_suffix1",
++ filter => "$ldap_filter1",
++ attrs => [ "$ldap_attrs1" ],
++ scope => "$ldap_scope1");
++ if ($fetch->code()) {
++ do_log('err','LDAP search (1st level) failed : %s (searching on server %s ; suffix %s ; filter %s ; attrs: %s)',
++ $fetch->error(), $param2->{'host'}, $ldap_suffix1, $ldap_filter1, $ldap_attrs1);
++ return undef;
++ }
++
++ ## Counters.
++ my $total = 0;
++ my $dn;
++
++ ## returns a reference to a HASH where the keys are the DNs
++ ## the second level hash's hold the attributes
++
++ my (@attrs, @emails);
++
++ while (my $e = $fetch->shift_entry) {
++ my $entry = $e->get_value($ldap_attrs1, asref => 1);
++ ## Multiple values
++ if (ref($entry) eq 'ARRAY') {
++ foreach my $attr (@{$entry}) {
++ next if (($ldap_select1 eq 'regex') && ($attr !~ /$ldap_regex1/));
++ push @attrs, $attr;
++ last if ($ldap_select1 eq 'first');
++ }
++ }else {
++ push @attrs, $entry
++ unless (($ldap_select1 eq 'regex') && ($entry !~ /$ldap_regex1/));
++ }
++ }
++
++ my %emailsViewed;
++
++ my ($suffix2, $filter2);
++ foreach my $attr (@attrs) {
++ ($suffix2 = $ldap_suffix2) =~ s/\[attrs1\]/$attr/g;
++ ($filter2 = $ldap_filter2) =~ s/\[attrs1\]/$attr/g;
++
++ do_log('debug2', 'Searching on server %s ; suffix %s ; filter %s ; attrs: %s', $param->{'host'}, $suffix2, $filter2, $ldap_attrs2);
++ $fetch = $ldaph->search ( base => "$suffix2",
++ filter => "$filter2",
++ attrs => [ "$ldap_attrs2" ],
++ scope => "$ldap_scope2");
++ if ($fetch->code()) {
++ do_log('err','LDAP search (2nd level) failed : %s. Node: %s (searching on server %s ; suffix %s ; filter %s ; attrs: %s)',
++ $fetch->error(), $attr, $param->{'host'}, $suffix2, $filter2, $ldap_attrs2);
++ push @sync_errors, {'error',$fetch->error(), 'host', $param->{'host'}, 'suffix2', $suffix2, 'fliter2', $filter2,'ldap_attrs2', $ldap_attrs2};
++ }
++
++ ## returns a reference to a HASH where the keys are the DNs
++ ## the second level hash's hold the attributes
++
++ while (my $e = $fetch->shift_entry) {
++ my $entry = $e->get_value($ldap_attrs2, asref => 1);
++
++ ## Multiple values
++ if (ref($entry) eq 'ARRAY') {
++ foreach my $email (@{$entry}) {
++ my $cleanmail = &tools::clean_email($email);
++ next if (($ldap_select2 eq 'regex') && ($cleanmail !~ /$ldap_regex2/));
++ next if ($emailsViewed{$cleanmail});
++ push @emails, $cleanmail;
++ $emailsViewed{$cleanmail} = 1;
++ last if ($ldap_select2 eq 'first');
++ }
++ }else {
++ my $cleanmail = &tools::clean_email($entry);
++ unless( (($ldap_select2 eq 'regex') && ($cleanmail !~ /$ldap_regex2/))||$emailsViewed{$cleanmail}) {
++ push @emails, $cleanmail;
++ $emailsViewed{$cleanmail} = 1;
++ }
++ }
++ }
++ }
++
++ unless ($ds->disconnect()) {
++ do_log('err','Can\'t unbind from LDAP server %s', $param->{'host'});
++ return undef;
++ }
++
++ foreach my $email (@emails) {
++ next if ($email =~ /^\s*$/);
++
++ $email = &tools::clean_email($email);
++ my %u;
++ ## Check if user has already been included
++ if ($users->{$email}) {
++ if ($tied) {
++ %u = split "\n",$users->{$email};
++ }else {
++ %u = %{$users->{$email}};
++ }
++ }else {
++ %u = %{$default_user_options};
++ $total++;
++ }
++
++ $u{'email'} = $email;
++ $u{'date'} = time;
++ $u{'update_date'} = time;
++ $u{'id'} = join (',', split(',', $u{'id'}), $id);
++
++ $u{'visibility'} = $default_user_options->{'visibility'} if (defined $default_user_options->{'visibility'});
++ $u{'reception'} = $default_user_options->{'reception'} if (defined $default_user_options->{'reception'});
++ $u{'profile'} = $default_user_options->{'profile'} if (defined $default_user_options->{'profile'});
++ $u{'info'} = $default_user_options->{'info'} if (defined $default_user_options->{'info'});
++
++ if ($tied) {
++ $users->{$email} = join("\n", %u);
++ }else {
++ $users->{$email} = \%u;
++ }
++ }
++
++ do_log('debug2',"unbinded from LDAP server %s ", $param->{'host'}) ;
++ do_log('info','%d new users included from LDAP query',$total);
++
++ my $result;
++ $result->{'total'} = $total;
++ if ($#sync_errors > -1) {$result->{'errors'} = \@sync_errors;}
++ return $result;
++}
++
++## Returns a list of subscribers extracted from an remote Database
++sub _include_users_sql {
++ my ($users, $param, $default_user_options, $tied, $fetch_timeout) = @_;
++
++ &do_log('debug2','List::_include_users_sql()');
++
++ my $id = Datasource::_get_datasource_id($param);
++ my $ds = new Datasource('SQL', $param);
++ unless ($ds->connect && ($ds->query($param->{'sql_query'}))) {
++ return undef;
++ }
++ ## Counters.
++ my $total = 0;
++
++ ## Process the SQL results
++ $ds->set_fetch_timeout($fetch_timeout);
++ my $array_of_users = $ds->fetch;
++
++ unless (defined $array_of_users && ref($array_of_users) eq 'ARRAY') {
++ &do_log('err', 'Failed to include users from ',$param->{'name'});
++ return undef;
++ }
++
++ foreach my $row (@{$array_of_users}) {
++ my $email = $row->[0]; ## only get first field
++ ## Empty value
++ next if ($email =~ /^\s*$/);
++
++ $email = &tools::clean_email($email);
++ my %u;
++ ## Check if user has already been included
++ if ($users->{$email}) {
++ if ($tied eq 'tied') {
++ %u = split "\n",$users->{$email};
++ }else {
++ %u = %{$users->{$email}};
++ }
++ }else {
++ %u = %{$default_user_options};
++ $total++;
++ }
++
++ $u{'email'} = $email;
++ $u{'date'} = time;
++ $u{'update_date'} = time;
++ $u{'id'} = join (',', split(',', $u{'id'}), $id);
++
++ $u{'visibility'} = $default_user_options->{'visibility'} if (defined $default_user_options->{'visibility'});
++ $u{'reception'} = $default_user_options->{'reception'} if (defined $default_user_options->{'reception'});
++ $u{'profile'} = $default_user_options->{'profile'} if (defined $default_user_options->{'profile'});
++ $u{'info'} = $default_user_options->{'info'} if (defined $default_user_options->{'info'});
++
++ if ($tied eq 'tied') {
++ $users->{$email} = join("\n", %u);
++ }else {
++ $users->{$email} = \%u;
++ }
++ }
++ $ds->disconnect();
++
++ do_log('info','%d included users from SQL query', $total);
++ return $total;
++}
++
++## Loads the list of subscribers from an external include source
++sub _load_users_include {
++ my $self = shift;
++ my $db_file = shift;
++ my $use_cache = shift;
++ my $name = $self->{'name'};
++ my $admin = $self->{'admin'};
++ my $dir = $self->{'dir'};
++ do_log('debug2', 'List::_load_users_include for list %s ; use_cache: %d',$name, $use_cache);
++
++ my (%users, $depend_on, $ref);
++ my $total = 0;
++
++ ## Create in memory btree using DB_File.
++ my $btree = new DB_File::BTREEINFO;
++ return undef unless ($btree);
++ $btree->{'compare'} = \&_compare_addresses;
++
++ if (!$use_cache && (-f $db_file)) {
++ rename $db_file, $db_file.'old';
++ }
++
++ unless ($use_cache) {
++ unless ($ref = tie %users, 'DB_File', $db_file, O_CREAT|O_RDWR, 0600, $btree) {
++ &do_log('err', '(no cache) Could not tie to DB_File %s',$db_file);
++ return undef;
++ }
++
++ ## Lock DB_File
++ my $fd = $ref->fd;
++
++ unless (open DB_FH, "+<&$fd") {
++ &do_log('err', 'Cannot open %s: %s', $db_file, $!);
++ return undef;
++ }
++ unless (flock (DB_FH, LOCK_EX | LOCK_NB)) {
++ &do_log('notice','Waiting for writing lock on %s', $db_file);
++ unless (flock (DB_FH, LOCK_EX)) {
++ &do_log('err', 'Failed locking %s: %s', $db_file, $!);
++ return undef;
++ }
++ }
++ &do_log('debug3', 'Got lock for writing on %s', $db_file);
++
++ foreach my $type ('include_list','include_remote_sympa_list','include_file','include_ldap_query','include_ldap_2level_query','include_sql_query','include_remote_file') {
++ last unless (defined $total);
++
++ foreach my $tmp_incl (@{$admin->{$type}}) {
++ my $included;
++
++ ## Work with a copy of admin hash branch to avoid including temporary variables into the actual admin hash.[bug #3182]
++ my $incl = &tools::dup_var($tmp_incl);
++
++ ## get the list of users
++ if ($type eq 'include_sql_query') {
++ $included = _include_users_sql(\%users, $incl, $admin->{'default_user_options'}, 'tied', $admin->{'sql_fetch_timeout'});
++ }elsif ($type eq 'include_ldap_query') {
++ $included = _include_users_ldap(\%users, $incl, $admin->{'default_user_options'}, 'tied');
++ }elsif ($type eq 'include_ldap_2level_query') {
++ my $result = _include_users_ldap_2level(\%users, $incl, $admin->{'default_user_options'}, 'tied');
++ if (defined $result) {
++ $included = $result->{'total'};
++ if (defined $result->{'errors'}){
++ &do_log('error', 'Errors occurred during the second LDAP passe for list %s, source "%s"', $self->{'name'}, );
++ }
++ }else{
++ $included = undef;
++ }
++ }elsif ($type eq 'include_list') {
++ $depend_on->{$name} = 1 ;
++ if (&_inclusion_loop ($name,$incl,$depend_on)) {
++ do_log('err','loop detection in list inclusion : could not include again %s in %s',$incl,$name);
++ }else{
++ $depend_on->{$incl} = 1;
++ $included = _include_users_list (\%users, $incl, $self->{'domain'}, $admin->{'default_user_options'}, 'tied');
++
++ }
++ }elsif ($type eq 'include_remote_sympa_list') {
++ $included = $self->_include_users_remote_sympa_list(\%users, $incl, $dir,$admin->{'domain'},$admin->{'default_user_options'}, 'tied');
++ }elsif ($type eq 'include_file') {
++ $included = _include_users_file (\%users, $incl, $admin->{'default_user_options'}, 'tied');
++ }elsif ($type eq 'include_remote_file') {
++ $included = _include_users_remote_file (\%users, $incl, $admin->{'default_user_options'}, 'tied');
++ }
++ unless (defined $included) {
++ &do_log('err', 'Inclusion %s failed in list %s', $type, $name);
++ next;
++ }
++
++ $total += $included;
++ }
++ }
++
++ ## Unlock
++ $ref->sync;
++ flock(DB_FH,LOCK_UN);
++ &do_log('debug3', 'Release lock on %s', $db_file);
++ undef $ref;
++ untie %users;
++ close DB_FH;
++
++ unless (defined $total) {
++ if (-f $db_file.'old') {
++ unlink $db_file;
++ rename $db_file.'old', $db_file;
++ $total = 0;
++ }
++ }
++ }
++
++ unless ($ref = tie %users, 'DB_File', $db_file, O_CREAT|O_RDWR, 0600, $btree) {
++ &do_log('err', '(use cache) Could not tie to DB_File %s',$db_file);
++ return undef;
++ }
++
++ ## Lock DB_File
++ my $fd = $ref->fd;
++ unless (open DB_FH, "+<&$fd") {
++ &do_log('err', 'Cannot open %s: %s', $db_file, $!);
++ return undef;
++ }
++ unless (flock (DB_FH, LOCK_SH | LOCK_NB)) {
++ &do_log('notice','Waiting for reading lock on %s', $db_file);
++ unless (flock (DB_FH, LOCK_SH)) {
++ &do_log('err', 'Failed locking %s: %s', $db_file, $!);
++ return undef;
++ }
++ }
++ &do_log('debug3', 'Got lock for reading on %s', $db_file);
++
++ ## Unlock DB_file
++ flock(DB_FH,LOCK_UN);
++ &do_log('debug3', 'Release lock on %s', $db_file);
++
++ ## Inclusion failed, clear cache
++ unless (defined $total) {
++ undef $ref;
++ #untie %users;
++ close DB_FH;
++ unlink $db_file;
++ return undef;
++ }
++
++ my $l = { 'ref' => $ref,
++ 'users' => \%users
++ };
++ $l->{'total'} = $total
++ if $total;
++
++ undef $ref;
++ #untie %users;
++ close DB_FH;
++ $l;
++}
++
++## Loads the list of subscribers from an external include source
++sub _load_users_include2 {
++ my $self = shift;
++ my $name = $self->{'name'};
++ my $admin = $self->{'admin'};
++ my $dir = $self->{'dir'};
++ do_log('debug2', 'List::_load_users_include for list %s',$name);
++ my (%users, $depend_on, $ref);
++ my $total = 0;
++ my @errors;
++ my $result;
++
++ foreach my $type ('include_list','include_remote_sympa_list','include_file','include_ldap_query','include_ldap_2level_query','include_sql_query','include_remote_file') {
++ last unless (defined $total);
++
++ foreach my $tmp_incl (@{$admin->{$type}}) {
++ my $included;
++ ## Work with a copy of admin hash branch to avoid including temporary variables into the actual admin hash.[bug #3182]
++ my $incl = &tools::dup_var($tmp_incl);
++
++ ## get the list of users
++ if ($type eq 'include_sql_query') {
++ $included = _include_users_sql(\%users, $incl, $admin->{'default_user_options'}, 'untied', $admin->{'sql_fetch_timeout'});
++ unless (defined $included){
++ push @errors, {'type' => $type, 'name' => $incl->{'name'}};
++ }
++ }elsif ($type eq 'include_ldap_query') {
++ $included = _include_users_ldap(\%users, $incl, $admin->{'default_user_options'});
++ unless (defined $included){
++ push @errors, {'type' => $type, 'name' => $incl->{'name'}};
++ }
++ }elsif ($type eq 'include_ldap_2level_query') {
++ my $result = _include_users_ldap_2level(\%users, $incl, $admin->{'default_user_options'});
++ if (defined $result) {
++ $included = $result->{'total'};
++ if (defined $result->{'errors'}){
++ &do_log('err', 'Errors occurred during the second LDAP passe');
++ push @errors, {'type' => $type, 'name' => $incl->{'name'}};
++ }
++ }else{
++ $included = undef;
++ push @errors, {'type' => $type, 'name' => $incl->{'name'}};
++ }
++ }elsif ($type eq 'include_remote_sympa_list') {
++ $included = $self->_include_users_remote_sympa_list(\%users, $incl, $dir,$admin->{'domain'},$admin->{'default_user_options'});
++ unless (defined $included){
++ push @errors, {'type' => $type, 'name' => $incl->{'name'}};
++ }
++ }elsif ($type eq 'include_list') {
++ $depend_on->{$name} = 1 ;
++ if (&_inclusion_loop ($name,$incl,$depend_on)) {
++ do_log('err','loop detection in list inclusion : could not include again %s in %s',$incl,$name);
++ }else{
++ $depend_on->{$incl} = 1;
++ $included = _include_users_list (\%users, $incl, $self->{'domain'}, $admin->{'default_user_options'});
++ unless (defined $included){
++ push @errors, {'type' => $type, 'name' => $incl};
++ }
++ }
++ }elsif ($type eq 'include_file') {
++ $included = _include_users_file (\%users, $incl, $admin->{'default_user_options'});
++ unless (defined $included){
++ push @errors, {'type' => $type, 'name' => $incl};
++ }
++ }elsif ($type eq 'include_remote_file') {
++ $included = _include_users_remote_file (\%users, $incl, $admin->{'default_user_options'});
++ unless (defined $included){
++ push @errors, {'type' => $type, 'name' => $incl->{'name'}};
++ }
++ }
++ unless (defined $included) {
++ &do_log('err', 'Inclusion %s failed in list %s', $type, $name);
++ next;
++ }
++ $total += $included;
++ }
++ }
++
++ ## If an error occured, return an undef value
++ $result->{'users'} = \%users;
++ $result->{'errors'} = \@errors;
++ return $result;
++}
++
++## Loads the list of admin users from an external include source
++sub _load_admin_users_include {
++ my $self = shift;
++ my $role = shift;
++ my $name = $self->{'name'};
++
++ &do_log('debug2', 'List::_load_admin_users_include(%s) for list %s',$role, $name);
++
++ my (%admin_users, $depend_on, $ref);
++ my $total = 0;
++ my $list_admin = $self->{'admin'};
++ my $dir = $self->{'dir'};
++
++ foreach my $entry (@{$list_admin->{$role."_include"}}) {
++
++ next unless (defined $entry);
++
++ my %option;
++ $option{'reception'} = $entry->{'reception'} if (defined $entry->{'reception'});
++ $option{'visibility'} = $entry->{'visibility'} if (defined $entry->{'visibility'});
++ $option{'profile'} = $entry->{'profile'} if (defined $entry->{'profile'} && ($role eq 'owner'));
++
++
++ my $include_file = &tools::get_filename('etc',{},"data_sources/$entry->{'source'}\.incl",$self->{'domain'},$self);
++
++ unless (defined $include_file){
++ &do_log('err', '_load_admin_users_include : the file %s.incl doesn\'t exist',$entry->{'source'});
++ return undef;
++ }
++
++ my $include_admin_user;
++ ## the file has parameters
++ if (defined $entry->{'source_parameters'}) {
++ my %parsing;
++
++ $parsing{'data'} = $entry->{'source_parameters'};
++ $parsing{'template'} = "$entry->{'source'}\.incl";
++
++ my $name = "$entry->{'source'}\.incl";
++
++ my $include_path = $include_file;
++ if ($include_path =~ s/$name$//) {
++ $parsing{'include_path'} = $include_path;
++ $include_admin_user = &_load_include_admin_user_file($self->{'domain'},$include_path,\%parsing);
++ } else {
++ &do_log('err', '_load_admin_users_include : errors to get path of the the file %s.incl',$entry->{'source'});
++ return undef;
++ }
++
++
++ } else {
++ $include_admin_user = &_load_include_admin_user_file($self->{'domain'},$include_file);
++ }
++ foreach my $type ('include_list','include_remote_sympa_list','include_file','include_ldap_query','include_ldap_2level_query','include_sql_query','include_remote_file') {
++ last unless (defined $total);
++
++ foreach my $tmp_incl (@{$include_admin_user->{$type}}) {
++ my $included;
++
++ ## Work with a copy of admin hash branch to avoid including temporary variables into the actual admin hash.[bug #3182]
++ my $incl = &tools::dup_var($tmp_incl);
++
++ ## get the list of admin users
++ ## does it need to define a 'default_admin_user_option'?
++ if ($type eq 'include_sql_query') {
++ $included = _include_users_sql(\%admin_users, $incl,\%option, 'untied', $list_admin->{'sql_fetch_timeout'});
++ }elsif ($type eq 'include_ldap_query') {
++ $included = _include_users_ldap(\%admin_users, $incl,\%option);
++ }elsif ($type eq 'include_ldap_2level_query') {
++ my $result = _include_users_ldap_2level(\%admin_users, $incl,\%option);
++ if (defined $result) {
++ $included = $result->{'total'};
++ if (defined $result->{'errors'}){
++ &do_log('err', 'Errors occurred during the second LDAP passe. Please verify your LDAP query.');
++ }
++ }else{
++ $included = undef;
++ }
++ }elsif ($type eq 'include_remote_sympa_list') {
++ $included = $self->_include_users_remote_sympa_list(\%admin_users, $incl, $dir,$list_admin->{'domain'},\%option);
++ }elsif ($type eq 'include_list') {
++ $depend_on->{$name} = 1 ;
++ if (&_inclusion_loop ($name,$incl,$depend_on)) {
++ do_log('err','loop detection in list inclusion : could not include again %s in %s',$incl,$name);
++ }else{
++ $depend_on->{$incl} = 1;
++ $included = _include_users_list (\%admin_users, $incl, $self->{'domain'}, \%option);
++ }
++ }elsif ($type eq 'include_file') {
++ $included = _include_users_file (\%admin_users, $incl, \%option);
++ }elsif ($type eq 'include_remote_file') {
++ $included = _include_users_remote_file (\%admin_users, $incl, \%option);
++ }
++ unless (defined $included) {
++ &do_log('err', 'Inclusion %s %s failed in list %s', $role, $type, $name);
++ next;
++ }
++ $total += $included;
++ }
++ }
++
++ ## If an error occured, return an undef value
++ unless (defined $total) {
++ return undef;
++ }
++ }
++
++ return \%admin_users;
++}
++
++
++# Load an include admin user file (xx.incl)
++sub _load_include_admin_user_file {
++ my ($robot, $file, $parsing) = @_;
++ &do_log('debug2', 'List::_load_include_admin_user_file(%s,%s)',$robot, $file);
++
++ my %include;
++ my (@paragraphs);
++
++ # the file has parmeters
++ if (defined $parsing) {
++ my @data = split(',',$parsing->{'data'});
++ my $vars = {'param' => \@data};
++ my $output = '';
++
++ unless (&tt2::parse_tt2($vars,$parsing->{'template'},\$output,[$parsing->{'include_path'}])) {
++ &do_log('err', 'Failed to parse %s', $parsing->{'template'});
++ return undef;
++ }
++
++ my @lines = split('\n',$output);
++
++ my $i = 0;
++ foreach my $line (@lines) {
++ if ($line =~ /^\s*$/) {
++ $i++ if $paragraphs[$i];
++ }else {
++ push @{$paragraphs[$i]}, $line;
++ }
++ }
++ } else {
++ unless (open INCLUDE, $file) {
++ &do_log('info', 'Cannot open %s', $file);
++ }
++
++ ## Just in case...
++ local $/ = "\n";
++
++ ## Split in paragraphs
++ my $i = 0;
++ while (<INCLUDE>) {
++ if (/^\s*$/) {
++ $i++ if $paragraphs[$i];
++ }else {
++ push @{$paragraphs[$i]}, $_;
++ }
++ }
++ close INCLUDE;
++ }
++
++ for my $index (0..$#paragraphs) {
++ my @paragraph = @{$paragraphs[$index]};
++
++ my $pname;
++
++ ## Clean paragraph, keep comments
++ for my $i (0..$#paragraph) {
++ my $changed = undef;
++ for my $j (0..$#paragraph) {
++ if ($paragraph[$j] =~ /^\s*\#/) {
++ chomp($paragraph[$j]);
++ push @{$include{'comment'}}, $paragraph[$j];
++ splice @paragraph, $j, 1;
++ $changed = 1;
++ }elsif ($paragraph[$j] =~ /^\s*$/) {
++ splice @paragraph, $j, 1;
++ $changed = 1;
++ }
++
++ last if $changed;
++ }
++
++ last unless $changed;
++ }
++
++ ## Empty paragraph
++ next unless ($#paragraph > -1);
++
++ ## Look for first valid line
++ unless ($paragraph[0] =~ /^\s*([\w-]+)(\s+.*)?$/) {
++ &do_log('info', 'Bad paragraph "%s" in %s', @paragraph, $file);
++ next;
++ }
++
++ $pname = $1;
++
++ unless(($pname eq 'include_list')||($pname eq 'include_remote_sympa_list')||($pname eq 'include_file')||($pname eq 'include_remote_file')||
++ ($pname eq 'include_ldap_query')||($pname eq 'include_ldap_2level_query')||($pname eq 'include_sql_query')) {
++ &do_log('info', 'Unknown parameter "%s" in %s', $pname, $file);
++ next;
++ }
++
++ ## Uniqueness
++ if (defined $include{$pname}) {
++ unless (($::pinfo{$pname}{'occurrence'} eq '0-n') or
++ ($::pinfo{$pname}{'occurrence'} eq '1-n')) {
++ &do_log('info', 'Multiple parameter "%s" in %s', $pname, $file);
++ }
++ }
++
++ ## Line or Paragraph
++ if (ref $::pinfo{$pname}{'file_format'} eq 'HASH') {
++ ## This should be a paragraph
++ unless ($#paragraph > 0) {
++ &do_log('info', 'Expecting a paragraph for "%s" parameter in %s, ignore it', $pname, $file);
++ next;
++ }
++
++ ## Skipping first line
++ shift @paragraph;
++
++ my %hash;
++ for my $i (0..$#paragraph) {
++ next if ($paragraph[$i] =~ /^\s*\#/);
++
++ unless ($paragraph[$i] =~ /^\s*(\w+)\s*/) {
++ &do_log('info', 'Bad line "%s" in %s',$paragraph[$i], $file);
++ }
++
++ my $key = $1;
++
++ unless (defined $::pinfo{$pname}{'file_format'}{$key}) {
++ &do_log('info', 'Unknown key "%s" in paragraph "%s" in %s', $key, $pname, $file);
++ next;
++ }
++
++ unless ($paragraph[$i] =~ /^\s*$key\s+($::pinfo{$pname}{'file_format'}{$key}{'file_format'})\s*$/i) {
++ &do_log('info', 'Bad entry "%s" in paragraph "%s" in %s', $paragraph[$i], $key, $pname, $file);
++ next;
++ }
++
++ $hash{$key} = &_load_list_param($robot,$key, $1, $::pinfo{$pname}{'file_format'}{$key});
++ }
++
++ ## Apply defaults & Check required keys
++ my $missing_required_field;
++ foreach my $k (keys %{$::pinfo{$pname}{'file_format'}}) {
++
++ ## Default value
++ unless (defined $hash{$k}) {
++ if (defined $::pinfo{$pname}{'file_format'}{$k}{'default'}) {
++ $hash{$k} = &_load_list_param($robot,$k, 'default', $::pinfo{$pname}{'file_format'}{$k});
++ }
++ }
++ ## Required fields
++ if ($::pinfo{$pname}{'file_format'}{$k}{'occurrence'} eq '1') {
++ unless (defined $hash{$k}) {
++ &do_log('info', 'Missing key "%s" in param "%s" in %s', $k, $pname, $file);
++ $missing_required_field++;
++ }
++ }
++ }
++
++ next if $missing_required_field;
++
++ ## Should we store it in an array
++ if (($::pinfo{$pname}{'occurrence'} =~ /n$/)) {
++ push @{$include{$pname}}, \%hash;
++ }else {
++ $include{$pname} = \%hash;
++ }
++ }else {
++ ## This should be a single line
++ unless ($#paragraph == 0) {
++ &do_log('info', 'Expecting a single line for "%s" parameter in %s', $pname, $file);
++ }
++
++ unless ($paragraph[0] =~ /^\s*$pname\s+($::pinfo{$pname}{'file_format'})\s*$/i) {
++ &do_log('info', 'Bad entry "%s" in %s', $paragraph[0], $file);
++ next;
++ }
++
++ my $value = &_load_list_param($robot,$pname, $1, $::pinfo{$pname});
++
++ if (($::pinfo{$pname}{'occurrence'} =~ /n$/)
++ && ! (ref ($value) =~ /^ARRAY/)) {
++ push @{$include{$pname}}, $value;
++ }else {
++ $include{$pname} = $value;
++ }
++ }
++ }
++
++ return \%include;
++}
++
++sub sync_include {
++ my ($self) = shift;
++ my $option = shift;
++ my $name=$self->{'name'};
++ &do_log('debug', 'List:sync_include(%s)', $name);
++
++ my %old_subscribers;
++ my $total=0;
++ my $errors_occurred=0;
++
++ ## Load a hash with the old subscribers
++ for (my $user=$self->get_first_user(); $user; $user=$self->get_next_user()) {
++ $old_subscribers{lc($user->{'email'})} = $user;
++
++ ## User neither included nor subscribed = > set subscribed to 1
++ unless ($old_subscribers{lc($user->{'email'})}{'included'} || $old_subscribers{lc($user->{'email'})}{'subscribed'}) {
++ &do_log('notice','Update user %s neither included nor subscribed', $user->{'email'});
++ unless( $self->update_user(lc($user->{'email'}), {'update_date' => time,
++ 'subscribed' => 1 }) ) {
++ &do_log('err', 'List:sync_include(%s): Failed to update %s', $name, lc($user->{'email'}));
++ next;
++ }
++ $old_subscribers{lc($user->{'email'})}{'subscribed'} = 1;
++ }
++
++ $total++;
++ }
++
++ ## Load a hash with the new subscriber list
++ my $new_subscribers;
++ unless ($option eq 'purge') {
++ my $result = $self->_load_users_include2();
++ $new_subscribers = $result->{'users'};
++ my $tmp_errors = $result->{'errors'};
++ my @errors = @$tmp_errors;
++ ## If include sources were not available, do not update subscribers
++ ## Use DB cache instead and warn the listmaster.
++ if($#errors > -1) {
++ &do_log('err', 'Errors occurred while synchornizing datasources for list: %s', $name);
++ $errors_occurred = 1;
++ unless (&List::send_notify_to_listmaster('sync_include_failed', $self->{'domain'}, {'errors' => \@errors, 'listname' => $self->{'name'}})) {
++ &do_log('notice',"Unable to send notify 'sync_include_failed' to listmaster");
++ }
++ return undef;
++ }
++ }
++
++ my $data_exclu;
++ my @subscriber_exclusion;
++
++ ## R�cup�rer un array d'emails pour une liste donn�e in 'exclusion_table'
++ $data_exclu = &get_exclusion($name);
++
++ my $key =0;
++ while ($data_exclu->{'emails'}->[$key]){
++ push @subscriber_exclusion, $data_exclu->{'emails'}->[$key];
++ $key = $key + 1;
++ }
++
++
++ my $users_added = 0;
++ my $users_updated = 0;
++
++ ## Get an Exclusive lock
++ my $lock = new Lock ($self->{'dir'}.'/include');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++ $lock->set_timeout(10*60);
++ unless ($lock->lock('write')) {
++ return undef;
++ }
++
++ ## Go through new users
++ my @add_tab;
++ $users_added = 0;
++ foreach my $email (keys %{$new_subscribers}) {
++ if (defined($old_subscribers{$email}) ) {
++
++ if ($old_subscribers{$email}{'included'}) {
++
++ ## If one user attribute has changed, then we should update the user entry
++ foreach my $attribute ('id','gecos') {
++ if ($old_subscribers{$email}{$attribute} ne $new_subscribers->{$email}{$attribute}) {
++ &do_log('debug', 'List:sync_include: updating %s to list %s', $email, $name);
++ unless( $self->update_user($email, {'update_date' => time,
++ $attribute => $new_subscribers->{$email}{$attribute} }) ) {
++ &do_log('err', 'List:sync_include(%s): Failed to update %s', $name, $email);
++ next;
++ }
++ $users_updated++;
++ }
++ }
++ ## User was already subscribed, update include_sources_subscriber in DB
++ }else {
++ &do_log('debug', 'List:sync_include: updating %s to list %s', $email, $name);
++ unless( $self->update_user($email, {'update_date' => time,
++ 'included' => 1,
++ 'id' => $new_subscribers->{$email}{'id'} }) ) {
++ &do_log('err', 'List:sync_include(%s): Failed to update %s',
++ $name, $email);
++ next;
++ }
++ $users_updated++;
++ }
++
++ ## Add new included user
++ }else {
++ my $compare = 0;
++ foreach my $sub_exclu (@subscriber_exclusion){
++ unless ($compare eq '1'){
++ if ($email eq $sub_exclu){
++ $compare = 1;
++ }else{
++ next;
++ }
++ }
++ }
++ if($compare eq '1'){
++ next;
++ }
++ &do_log('debug3', 'List:sync_include: adding %s to list %s', $email, $name);
++ my $u = $new_subscribers->{$email};
++ $u->{'included'} = 1;
++ $u->{'date'} = time;
++ @add_tab = ($u);
++ my $user_added = 0;
++ unless( $user_added = $self->add_user( @add_tab ) ) {
++ &do_log('err', 'List:sync_include(%s): Failed to add new users', $name);
++ return undef;
++ }
++ if ($user_added) {
++ $users_added++;
++ ## Send notification if the list config authorizes it only.
++ if ($self->{'admin'}{'inclusion_notification_feature'} eq 'on') {
++ unless ($self->send_file('welcome', $u->{'email'}, $self->{'domain'},{})) {
++ &do_log('err',"Unable to send template 'welcome' to $u->{'email'}");
++ }
++ }
++ }
++ }
++ }
++
++ if ($users_added) {
++ &do_log('notice', 'List:sync_include(%s): %d users added', $name, $users_added);
++ }
++
++ ## Go though previous list of users
++ my $users_removed = 0;
++ my $user_removed;
++ my @deltab;
++ foreach my $email (keys %old_subscribers) {
++ unless( defined($new_subscribers->{$email}) ) {
++ ## User is also subscribed, update DB entry
++ if ($old_subscribers{$email}{'subscribed'}) {
++ &do_log('debug', 'List:sync_include: updating %s to list %s', $email, $name);
++ unless( $self->update_user($email, {'update_date' => time,
++ 'included' => 0,
++ 'id' => ''}) ) {
++ &do_log('err', 'List:sync_include(%s): Failed to update %s', $name, $email);
++ next;
++ }
++
++ $users_updated++;
++
++ ## Tag user for deletion
++ }else {
++ &do_log('debug3', 'List:sync_include: removing %s from list %s', $email, $name);
++ @deltab = ($email);
++ unless($user_removed = $self->delete_user('users' => \@deltab)) {
++ &do_log('err', 'List:sync_include(%s): Failed to delete %s', $name, $user_removed);
++ return undef;
++ }
++ if ($user_removed) {
++ $users_removed++;
++ ## Send notification if the list config authorizes it only.
++ if ($self->{'admin'}{'inclusion_notification_feature'} eq 'on') {
++ unless ($self->send_file('removed', $email, $self->{'domain'},{})) {
++ &do_log('err',"Unable to send template 'removed' to $email");
++ }
++ }
++ }
++ }
++ }
++ }
++ if ($users_removed > 0) {
++ &do_log('notice', 'List:sync_include(%s): %d users removed', $name, $users_removed);
++ }
++ &do_log('notice', 'List:sync_include(%s): %d users updated', $name, $users_updated);
++
++ ## Release lock
++ unless ($lock->unlock()) {
++ return undef;
++ }
++
++ ## Get and save total of subscribers
++ $self->{'total'} = $self->_load_total_db('nocache');
++ $self->{'last_sync'} = time;
++ $self->savestats();
++
++ return 1;
++}
++
++## The previous function (sync_include) is to be called by the task_manager.
++## This one is to be called from anywhere else. This function deletes the scheduled
++## sync_include task. If this deletion happened in sync_include(), it would disturb
++## the normal task_manager.pl functionning.
++
++sub on_the_fly_sync_include {
++ my $self = shift;
++ my %options = @_;
++
++ my $pertinent_ttl = $self->{'admin'}{'distribution_ttl'}||$self->{'admin'}{'ttl'};
++ &do_log('debug2','List::on_the_fly_sync_include(%s)',$pertinent_ttl);
++ if ( $options{'use_ttl'} != 1 || $self->{'last_sync'} < time - $pertinent_ttl) {
++ &do_log('notice', "Synchronizing list members...");
++ if ($self->sync_include()) {
++ $self->remove_task('sync_include');
++ return 1;
++ }
++ else {
++ return undef;
++ }
++ }
++ return 1;
++}
++
++sub sync_include_admin {
++ my ($self) = shift;
++ my $option = shift;
++
++ my $name=$self->{'name'};
++ &do_log('debug2', 'List:sync_include_admin(%s)', $name);
++
++ ## don't care about listmaster role
++ foreach my $role ('owner','editor'){
++ my $old_admin_users = {};
++ ## Load a hash with the old admin users
++ for (my $admin_user=$self->get_first_admin_user($role); $admin_user; $admin_user=$self->get_next_admin_user()) {
++ $old_admin_users->{lc($admin_user->{'email'})} = $admin_user;
++ }
++
++ ## Load a hash with the new admin user list from an include source(s)
++ my $new_admin_users_include;
++ ## Load a hash with the new admin user users from the list config
++ my $new_admin_users_config;
++ unless ($option eq 'purge') {
++
++ $new_admin_users_include = $self->_load_admin_users_include($role);
++
++ ## If include sources were not available, do not update admin users
++ ## Use DB cache instead
++ unless (defined $new_admin_users_include) {
++ &do_log('err', 'Could not get %ss from an include source for list %s', $role, $name);
++ unless (&List::send_notify_to_listmaster('sync_include_admin_failed', $self->{'domain'}, [$name])) {
++ &do_log('notice',"Unable to send notify 'sync_include_admmin_failed' to listmaster");
++ }
++ return undef;
++ }
++
++ $new_admin_users_config = $self->_load_admin_users_config($role);
++
++ unless (defined $new_admin_users_config) {
++ &do_log('err', 'Could not get %ss from config for list %s', $role, $name);
++ return undef;
++ }
++ }
++
++ my @add_tab;
++ my $admin_users_added = 0;
++ my $admin_users_updated = 0;
++
++ ## Get an Exclusive lock
++ my $lock = new Lock ($self->{'dir'}.'/include_admin_user');
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock');
++ return undef;
++ }
++ $lock->set_timeout(20);
++ unless ($lock->lock('write')) {
++ return undef;
++ }
++
++ ## Go through new admin_users_include
++ foreach my $email (keys %{$new_admin_users_include}) {
++
++ # included and subscribed
++ if (defined $new_admin_users_config->{$email}) {
++ my $param;
++ foreach my $p ('reception','visibility','gecos','info','profile') {
++ # config parameters have priority on include parameters in case of conflict
++ $param->{$p} = $new_admin_users_config->{$email}{$p} if (defined $new_admin_users_config->{$email}{$p});
++ $param->{$p} ||= $new_admin_users_include->{$email}{$p};
++ }
++
++ #Admin User was already in the DB
++ if (defined $old_admin_users->{$email}) {
++
++ $param->{'included'} = 1;
++ $param->{'id'} = $new_admin_users_include->{$email}{'id'};
++ $param->{'subscribed'} = 1;
++
++ my $param_update = &is_update_param($param,$old_admin_users->{$email});
++
++ # updating
++ if (defined $param_update) {
++ if (%{$param_update}) {
++ &do_log('debug', 'List:sync_include_admin : updating %s %s to list %s',$role, $email, $name);
++ $param_update->{'update_date'} = time;
++
++ unless ($self->update_admin_user($email, $role,$param_update)) {
++ &do_log('err', 'List:sync_include_admin(%s): Failed to update %s %s', $name,$role,$email);
++ next;
++ }
++ $admin_users_updated++;
++ }
++ }
++ #for the next foreach (sort of new_admin_users_config that are not included)
++ delete ($new_admin_users_config->{$email});
++
++ # add a new included and subscribed admin user
++ }else {
++ &do_log('debug2', 'List:sync_include_admin: adding %s %s to list %s',$email,$role, $name);
++
++ foreach my $key (keys %{$param}) {
++ $new_admin_users_config->{$email}{$key} = $param->{$key};
++ }
++ $new_admin_users_config->{$email}{'included'} = 1;
++ $new_admin_users_config->{$email}{'subscribed'} = 1;
++ push (@add_tab,$new_admin_users_config->{$email});
++
++ #for the next foreach (sort of new_admin_users_config that are not included)
++ delete ($new_admin_users_config->{$email});
++ }
++
++ # only included
++ }else {
++ my $param = $new_admin_users_include->{$email};
++
++ #Admin User was already in the DB
++ if (defined($old_admin_users->{$email}) ) {
++
++ $param->{'included'} = 1;
++ $param->{'id'} = $new_admin_users_include->{$email}{'id'};
++ $param->{'subscribed'} = 0;
++
++ my $param_update = &is_update_param($param,$old_admin_users->{$email});
++
++ # updating
++ if (defined $param_update) {
++ if (%{$param_update}) {
++ &do_log('debug', 'List:sync_include_admin : updating %s %s to list %s', $role, $email, $name);
++ $param_update->{'update_date'} = time;
++
++ unless ($self->update_admin_user($email, $role,$param_update)) {
++ &do_log('err', 'List:sync_include_admin(%s): Failed to update %s %s', $name, $role,$email);
++ next;
++ }
++ $admin_users_updated++;
++ }
++ }
++ # add a new included admin user
++ }else {
++ &do_log('debug2', 'List:sync_include_admin: adding %s %s to list %s', $role, $email, $name);
++
++ foreach my $key (keys %{$param}) {
++ $new_admin_users_include->{$email}{$key} = $param->{$key};
++ }
++ $new_admin_users_include->{$email}{'included'} = 1;
++ push (@add_tab,$new_admin_users_include->{$email});
++ }
++ }
++ }
++
++ ## Go through new admin_users_config (that are not included : only subscribed)
++ foreach my $email (keys %{$new_admin_users_config}) {
++
++ my $param = $new_admin_users_config->{$email};
++
++ #Admin User was already in the DB
++ if (defined($old_admin_users->{$email}) ) {
++
++ $param->{'included'} = 0;
++ $param->{'id'} = '';
++ $param->{'subscribed'} = 1;
++ my $param_update = &is_update_param($param,$old_admin_users->{$email});
++
++ # updating
++ if (defined $param_update) {
++ if (%{$param_update}) {
++ &do_log('debug', 'List:sync_include_admin : updating %s %s to list %s', $role, $email, $name);
++ $param_update->{'update_date'} = time;
++
++ unless ($self->update_admin_user($email, $role,$param_update)) {
++ &do_log('err', 'List:sync_include_admin(%s): Failed to update %s %s', $name, $role, $email);
++ next;
++ }
++ $admin_users_updated++;
++ }
++ }
++ # add a new subscribed admin user
++ }else {
++ &do_log('debug2', 'List:sync_include_admin: adding %s %s to list %s', $role, $email, $name);
++
++ foreach my $key (keys %{$param}) {
++ $new_admin_users_config->{$email}{$key} = $param->{$key};
++ }
++ $new_admin_users_config->{$email}{'subscribed'} = 1;
++ push (@add_tab,$new_admin_users_config->{$email});
++ }
++ }
++
++ if ($#add_tab >= 0) {
++ unless( $admin_users_added = $self->add_admin_user($role,@add_tab ) ) {
++ &do_log('err', 'List:sync_include_admin(%s): Failed to add new %ss', $role, $name);
++ return undef;
++ }
++ }
++
++ if ($admin_users_added) {
++ &do_log('debug', 'List:sync_include_admin(%s): %d %s(s) added',
++ $name, $admin_users_added, $role);
++ }
++
++ &do_log('debug', 'List:sync_include_admin(%s): %d %s(s) updated', $name, $admin_users_updated, $role);
++
++ ## Go though old list of admin users
++ my $admin_users_removed = 0;
++ my @deltab;
++
++ foreach my $email (keys %$old_admin_users) {
++ unless (defined($new_admin_users_include->{$email}) || defined($new_admin_users_config->{$email})) {
++ &do_log('debug2', 'List:sync_include_admin: removing %s %s to list %s', $role, $email, $name);
++ push(@deltab, $email);
++ }
++ }
++
++ if ($#deltab >= 0) {
++ unless($admin_users_removed = $self->delete_admin_user($role,@deltab)) {
++ &do_log('err', 'List:sync_include_admin(%s): Failed to delete %s %s',
++ $name, $role, $admin_users_removed);
++ return undef;
++ }
++ &do_log('debug', 'List:sync_include_admin(%s): %d %s(s) removed',
++ $name, $admin_users_removed, $role);
++ }
++
++ ## Release lock
++ unless ($lock->unlock()) {
++ return undef;
++ }
++ }
++
++ $self->{'last_sync_admin_user'} = time;
++ $self->savestats();
++
++ return $self->get_nb_owners;
++}
++
++## Load param admin users from the config of the list
++sub _load_admin_users_config {
++ my $self = shift;
++ my $role = shift;
++ my $name = $self->{'name'};
++ my %admin_users;
++
++ &do_log('debug2', 'List::_load_admin_users_config(%s) for list %s',$role, $name);
++
++ foreach my $entry (@{$self->{'admin'}{$role}}) {
++ my $email = lc($entry->{'email'});
++ my %u;
++
++ $u{'email'} = $email;
++ $u{'reception'} = $entry->{'reception'};
++ $u{'visibility'} = $entry->{'visibility'};
++ $u{'gecos'} = $entry->{'gecos'};
++ $u{'info'} = $entry->{'info'};
++ $u{'profile'} = $entry->{'profile'} if ($role eq 'owner');
++
++ $admin_users{$email} = \%u;
++ }
++ return \%admin_users;
++}
++
++## return true if new_param has changed from old_param
++# $new_param is changed to return only entries that need to
++# be updated (only deals with admin user parameters, editor or owner)
++sub is_update_param {
++ my $new_param = shift;
++ my $old_param = shift;
++ my $resul = {};
++ my $update = 0;
++
++ &do_log('debug2', 'List::is_update_param ');
++
++ foreach my $p ('reception','visibility','gecos','info','profile','id','included','subscribed') {
++ if (defined $new_param->{$p}) {
++ if ($new_param->{$p} ne $old_param->{$p}) {
++ $resul->{$p} = $new_param->{$p};
++ $update = 1;
++ }
++ }else {
++ if (defined $old_param->{$p} && ($old_param->{$p} ne '')) {
++ $resul->{$p} = '';
++ $update = 1;
++ }
++ }
++ }
++ if ($update) {
++ return $resul;
++ }else {
++ return undef;
++ }
++}
++
++
++
++sub _inclusion_loop {
++
++ my $name = shift;
++ my $incl = shift;
++ my $depend_on = shift;
++
++ return 1 if ($depend_on->{$incl}) ;
++
++ return undef;
++}
++
++sub _load_total_db {
++ my $self = shift;
++ my $option = shift;
++ do_log('debug2', 'List::_load_total_db(%s)', $self->{'name'});
++
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ ## Use session cache
++ if (($option ne 'nocache') && (defined $list_cache{'load_total_db'}{$self->{'domain'}}{$self->{'name'}})) {
++ return $list_cache{'load_total_db'}{$self->{'domain'}}{$self->{'name'}};
++ }
++
++ my ($statement);
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ ## Query the Database
++ $statement = sprintf "SELECT count(*) FROM subscriber_table WHERE (list_subscriber = %s AND robot_subscriber = %s)", $dbh->quote($self->{'name'}), $dbh->quote($self->{'domain'});
++
++ push @sth_stack, $sth;
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('debug','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('debug','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ my $total = $sth->fetchrow;
++
++ $sth->finish();
++
++ $sth = pop @sth_stack;
++
++ ## Set session cache
++ $list_cache{'load_total_db'}{$self->{'domain'}}{$self->{'name'}} = $total;
++
++ return $total;
++}
++
++## Writes to disk the stats data for a list.
++sub _save_stats_file {
++ my $file = shift;
++ my $stats = shift;
++ my $total = shift;
++ my $last_sync = shift;
++ my $last_sync_admin_user = shift;
++
++ unless (defined $stats && ref ($stats) eq 'ARRAY') {
++ &do_log('err', 'List_save_stats_file() : incorrect parameter');
++ return undef;
++ }
++
++ do_log('debug2', 'List::_save_stats_file(%s, %d, %d, %d)', $file, $total,$last_sync,$last_sync_admin_user );
++
++ open(L, "> $file") || return undef;
++ printf L "%d %.0f %.0f %.0f %d %d %d\n", @{$stats}, $total, $last_sync, $last_sync_admin_user;
++ close(L);
++}
++
++## Writes the user list to disk
++sub _save_users_file {
++ my($self, $file) = @_;
++ do_log('debug3', 'List::_save_users_file(%s)', $file);
++
++ my($k, $s);
++
++ do_log('debug2','Saving user file %s', $file);
++
++ rename("$file", "$file.old");
++ open SUB, "> $file" or return undef;
++
++ for ($s = $self->get_first_user(); $s; $s = $self->get_next_user()) {
++ foreach $k ('date','update_date','email','gecos','reception','visibility') {
++ printf SUB "%s %s\n", $k, $s->{$k} unless ($s->{$k} eq '');
++
++ }
++ print SUB "\n";
++ }
++ close SUB;
++ return 1;
++}
++
++sub _compare_addresses {
++ my ($a, $b) = @_;
++
++ my ($ra, $rb);
++
++ $a =~ tr/A-Z/a-z/;
++ $b =~ tr/A-Z/a-z/;
++
++ $ra = reverse $a;
++ $rb = reverse $b;
++
++ return ($ra cmp $rb);
++}
++
++## Does the real job : stores the message given as an argument into
++## the digest of the list.
++sub store_digest {
++ my($self,$msg) = @_;
++ do_log('debug3', 'List::store_digest');
++
++ my($filename, $newfile);
++ my $separator = &tools::get_separator();
++
++ unless ( -d "$Conf::Conf{'queuedigest'}") {
++ return;
++ }
++
++ my @now = localtime(time);
++
++ ## Reverse compatibility concern
++ if (-f "$Conf::Conf{'queuedigest'}/$self->{'name'}") {
++ $filename = "$Conf::Conf{'queuedigest'}/$self->{'name'}";
++ }else {
++ $filename = $Conf::Conf{'queuedigest'}.'/'.$self->get_list_id();
++ }
++
++ $newfile = !(-e $filename);
++ my $oldtime=(stat $filename)[9] unless($newfile);
++
++ open(OUT, ">> $filename") || return;
++ if ($newfile) {
++ ## create header
++ printf OUT "\nThis digest for list has been created on %s\n\n",
++ strftime("%a %b %e %H:%M:%S %Y", @now);
++ print OUT "------- THIS IS A RFC934 COMPLIANT DIGEST, YOU CAN BURST IT -------\n\n";
++ printf OUT "\n%s\n\n", &tools::get_separator();
++
++ # send the date of the next digest to the users
++ }
++ #$msg->head->delete('Received') if ($msg->head->get('received'));
++ $msg->print(\*OUT);
++ printf OUT "\n%s\n\n", &tools::get_separator();
++ close(OUT);
++
++ #replace the old time
++ utime $oldtime,$oldtime,$filename unless($newfile);
++}
++
++## List of lists hosted a robot
++## Returns a ref to an array of List objects
++sub get_lists {
++ my $robot_context = shift || '*';
++ my $options = shift;
++ my $requested_lists = shift; ## Optional parameter to load only a subset of all lists
++
++ my(@lists, $l,@robots);
++ do_log('debug2', 'List::get_lists(%s)',$robot_context);
++
++ if ($robot_context eq '*') {
++ @robots = &get_robots ;
++ }else{
++ push @robots, $robot_context ;
++ }
++
++ foreach my $robot (@robots) {
++
++ ## Check cache first
++ if (defined $list_cache{'get_lists'}{$robot}) {
++ push @lists, @{$list_cache{'get_lists'}{$robot}};
++ }else {
++ my $robot_dir = $Conf::Conf{'home'}.'/'.$robot ;
++ $robot_dir = $Conf::Conf{'home'} unless ((-d $robot_dir) || ($robot ne $Conf::Conf{'host'}));
++
++ unless (-d $robot_dir) {
++ do_log('err',"unknown robot $robot, Unable to open $robot_dir");
++ return undef ;
++ }
++
++ unless (opendir(DIR, $robot_dir)) {
++ do_log('err',"Unable to open $robot_dir");
++ return undef;
++ }
++
++ ## Load only requested lists if $requested_list is set
++ ## otherwise load all lists
++ my @files;
++ if ( defined($requested_lists)){
++ @files = sort @{$requested_lists};
++ }else {
++ @files = sort readdir(DIR);
++ }
++
++ foreach my $l (@files) {
++ next if (($l =~ /^\./o) || (! -d "$robot_dir/$l") || (! -f "$robot_dir/$l/config"));
++
++ my $list = new List ($l, $robot, $options);
++
++ next unless (defined $list);
++
++ push @lists, $list;
++
++ ## Also feed the cache
++ ## Unless we only loaded a subset of all lists ($requested_lists parameter used)
++ unless (defined $requested_lists) {
++ push @{$list_cache{'get_lists'}{$robot}}, $list;
++ }
++
++ }
++ closedir DIR;
++ }
++ }
++ return \@lists;
++}
++
++## List of robots hosted by Sympa
++sub get_robots {
++
++ my(@robots, $r);
++ do_log('debug2', 'List::get_robots()');
++
++ unless (opendir(DIR, $Conf::Conf{'etc'})) {
++ do_log('err',"Unable to open $Conf::Conf{'etc'}");
++ return undef;
++ }
++ my $use_default_robot = 1 ;
++ foreach $r (sort readdir(DIR)) {
++ next unless (($r !~ /^\./o) && (-d "$Conf::Conf{'home'}/$r"));
++ next unless (-r "$Conf::Conf{'etc'}/$r/robot.conf");
++ push @robots, $r;
++ undef $use_default_robot if ($r eq $Conf::Conf{'host'});
++ }
++ closedir DIR;
++
++ push @robots, $Conf::Conf{'host'} if ($use_default_robot);
++ return @robots ;
++}
++
++## List of lists in database mode which e-mail parameter is member of
++## Results concern ALL robots
++sub get_which_db {
++ my $email = shift;
++ my $function = shift;
++ do_log('debug3', 'List::get_which_db(%s,%s)', $email, $function);
++
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ my ($l, %which, $statement);
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ if ($function eq 'member') {
++ ## Get subscribers
++ $statement = sprintf "SELECT list_subscriber, robot_subscriber, bounce_subscriber, reception_subscriber, topics_subscriber, include_sources_subscriber, subscribed_subscriber, included_subscriber FROM subscriber_table WHERE user_subscriber = %s",$dbh->quote($email);
++
++ push @sth_stack, $sth;
++
++ &do_log('debug2','SQL: %s', $statement);
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ while ($l = $sth->fetchrow_hashref('NAME_lc')) {
++ my ($name, $robot) = ($l->{'list_subscriber'}, $l->{'robot_subscriber'});
++ $name =~ s/\s*$//; ## usefull for PostgreSQL
++ $which{$robot}{$name}{'member'} = 1;
++ $which{$robot}{$name}{'reception'} = $l->{'reception_subscriber'};
++ $which{$robot}{$name}{'bounce'} = $l->{'bounce_subscriber'};
++ $which{$robot}{$name}{'topic'} = $l->{'topic_subscriber'};
++ $which{$robot}{$name}{'included'} = $l->{'included_subscriber'};
++ $which{$robot}{$name}{'subscribed'} = $l->{'subscribed_subscriber'};
++ $which{$robot}{$name}{'include_sources'} = $l->{'include_sources_subscriber'};
++ }
++ $sth->finish();
++ $sth = pop @sth_stack;
++
++ }else {
++ ## Get admin
++ $statement = sprintf "SELECT list_admin, robot_admin, role_admin FROM admin_table WHERE user_admin = %s",$dbh->quote($email);
++
++ push @sth_stack, $sth;
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ &do_log('debug2','SQL: %s', $statement);
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ while ($l = $sth->fetchrow_hashref('NAME_lc')) {
++ $which{$l->{'robot_admin'}}{$l->{'list_admin'}}{$l->{'role_admin'}} = 1;
++ }
++
++ $sth->finish();
++
++ $sth = pop @sth_stack;
++ }
++
++ return \%which;
++}
++
++## get idp xref to locally validated email address
++sub get_netidtoemail_db {
++ my $robot = shift;
++ my $netid = shift;
++ my $idpname = shift;
++ do_log('debug', 'List::get_netidtoemail_db(%s, %s)', $netid, $idpname);
++
++ unless ($List::use_db) {
++ &do_log('err', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ my ($l, %which, $statement, $email);
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ $statement = sprintf "SELECT email_netidmap FROM netidmap_table WHERE netid_netidmap = %s and serviceid_netidmap = %s and robot_netidmap = %s", $dbh->quote($netid), $dbh->quote($idpname), $dbh->quote($robot);
++
++ push @sth_stack, $sth;
++
++ unless ($sth = $dbh->prepare($statement)) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ $email = $sth->fetchrow;
++
++ $sth->finish();
++
++ $sth = pop @sth_stack;
++
++ return $email;
++}
++
++## set idp xref to locally validated email address
++sub set_netidtoemail_db {
++ my $robot = shift;
++ my $netid = shift;
++ my $idpname = shift;
++ my $email = shift;
++ do_log('debug', 'List::set_netidtoemail_db(%s, %s, %s)', $netid, $idpname, $email);
++
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI');
++ return undef;
++ }
++
++ my ($l, %which, $statement);
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ $statement = sprintf "INSERT INTO netidmap_table (netid_netidmap,serviceid_netidmap,email_netidmap,robot_netidmap) VALUES (%s, %s, %s, %s)", $dbh->quote($netid), $dbh->quote($idpname), $dbh->quote($email), $dbh->quote($robot);
++
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ return 1;
++}
++
++## Update netidmap table when user email address changes
++sub update_email_netidmap_db{
++ my ($robot, $old_email, $new_email) = @_;
++ my $statement;
++
++ unless (defined $robot &&
++ defined $old_email &&
++ defined $new_email) {
++ &do_log('err', 'Missing parameter');
++ return undef;
++ }
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ $statement = sprintf "UPDATE netidmap_table SET email_netidmap = %s WHERE (email_netidmap = %s AND robot_netidmap = %s)",$dbh->quote($new_email), $dbh->quote($old_email), $dbh->quote($robot);
++
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++
++ return 1;
++}
++
++## &get_which(<email>,<robot>,<type>)
++## Get lists of lists where <email> assumes this <type> (owner, editor or member) of
++## function to any list in <robot>.
++sub get_which {
++ my $email = shift;
++ my $robot =shift;
++ my $function = shift;
++ do_log('debug2', 'List::get_which(%s, %s)', $email, $function);
++
++ my ($l, @which);
++
++ ## WHICH in Database
++ my $db_which = {};
++ my $requested_lists;
++
++ if (defined $Conf::Conf{'db_type'} && $List::use_db) {
++ $db_which = &get_which_db($email, $function);
++ @{$requested_lists} = keys %{$db_which->{$robot}};
++ }
++
++ ## This call is required too
++ my $all_lists = &get_lists($robot, {}, $requested_lists);
++
++ foreach my $list (@$all_lists){
++
++ my $l = $list->{'name'};
++ # next unless (($list->{'admin'}{'host'} eq $robot) || ($robot eq '*')) ;
++
++ ## Skip closed lists unless the user is Listmaster
++ if ($list->{'admin'}{'status'} =~ /closed/) {
++ next;
++ }
++
++ if ($function eq 'member') {
++ if ($db_which->{$robot}{$l}{'member'}) {
++ $list->{'user'}{'reception'} = $db_which->{$robot}{$l}{'reception'};
++ $list->{'user'}{'topic'} = $db_which->{$robot}{$l}{'topic'};
++ $list->{'user'}{'bounce'} = $db_which->{$robot}{$l}{'bounce'};
++ $list->{'user'}{'subscribed'} = $db_which->{$robot}{$l}{'subscribed'};
++ $list->{'user'}{'included'} = $db_which->{$robot}{$l}{'included'};
++
++ push @which, $list ;
++
++ ## Update cache
++ $list_cache{'is_user'}{$list->{'domain'}}{$l}{$email} = 1;
++ }else {
++ ## Update cache
++ $list_cache{'is_user'}{$list->{'domain'}}{$l}{$email} = 0;
++ }
++
++ }elsif ($function eq 'owner') {
++ if ($db_which->{$robot}{$l}{'owner'} == 1) {
++ push @which, $list ;
++
++ ## Update cache
++ $list_cache{'am_i'}{'owner'}{$list->{'domain'}}{$l}{$email} = 1;
++ }else {
++ ## Update cache
++ $list_cache{'am_i'}{'owner'}{$list->{'domain'}}{$l}{$email} = 0;
++ }
++ }elsif ($function eq 'editor') {
++ if ($db_which->{$robot}{$l}{'editor'} == 1) {
++ push @which, $list ;
++
++ ## Update cache
++ $list_cache{'am_i'}{'editor'}{$list->{'domain'}}{$l}{$email} = 1;
++ }else {
++ ## Update cache
++ $list_cache{'am_i'}{'editor'}{$list->{'domain'}}{$l}{$email} = 0;
++ }
++ }else {
++ do_log('err',"Internal error, unknown or undefined parameter $function in get_which");
++ return undef ;
++ }
++ }
++
++ return @which;
++}
++
++
++
++## return total of messages awaiting moderation
++sub get_mod_spool_size {
++ my $self = shift;
++ do_log('debug3', 'List::get_mod_spool_size()');
++ my @msg;
++
++ unless (opendir SPOOL, $Conf::Conf{'queuemod'}) {
++ &do_log('err', 'Unable to read spool %s', $Conf::Conf{'queuemod'});
++ return undef;
++ }
++
++ my $list_name = $self->{'name'};
++ my $list_id = $self->get_list_id();
++ @msg = sort grep(/^($list_id|$list_name)\_\w+$/, readdir SPOOL);
++
++ closedir SPOOL;
++ return ($#msg + 1);
++}
++
++### moderation for shared
++
++# return the status of the shared
++sub get_shared_status {
++ my $self = shift;
++ do_log('debug3', '(%s)', $self->{'name'});
++
++ if (-e $self->{'dir'}.'/shared') {
++ return 'exist';
++ }elsif (-e $self->{'dir'}.'/pending.shared') {
++ return 'deleted';
++ }else{
++ return 'none';
++ }
++}
++
++# return the list of documents shared waiting for moderation
++sub get_shared_moderated {
++ my $self = shift;
++ do_log('debug3', 'List::get_shared_moderated()');
++ my $shareddir = $self->{'dir'}.'/shared';
++
++ unless (-e "$shareddir") {
++ return undef;
++ }
++
++ ## sort of the shared
++ my @mod_dir = &sort_dir_to_get_mod("$shareddir");
++ return \@mod_dir;
++}
++
++# return the list of documents awaiting for moderation in a dir and its subdirs
++sub sort_dir_to_get_mod {
++ #dir to explore
++ my $dir = shift;
++ do_log('debug3', 'List::sort_dir_to_get_mod()');
++
++ # listing of all the shared documents of the directory
++ unless (opendir DIR, "$dir") {
++ do_log('err',"sort_dir_to_get_mod : cannot open $dir : $!");
++ return undef;
++ }
++
++ # array of entry of the directory DIR
++ my @tmpdir = readdir DIR;
++ closedir DIR;
++
++ # private entry with documents not yet moderated
++ my @moderate_dir = grep (/(\.moderate)$/, @tmpdir);
++ @moderate_dir = grep (!/^\.desc\./, @moderate_dir);
++
++ foreach my $d (@moderate_dir) {
++ $d = "$dir/$d";
++ }
++
++ my $path_d;
++ foreach my $d (@tmpdir) {
++ # current document
++ $path_d = "$dir/$d";
++
++ if ($d =~ /^\.+$/){
++ next;
++ }
++
++ if (-d $path_d) {
++ push(@moderate_dir,&sort_dir_to_get_mod($path_d));
++ }
++ }
++
++ return @moderate_dir;
++
++ }
++
++
++## Get the type of a DB field
++sub get_db_field_type {
++ my ($table, $field) = @_;
++
++ return undef unless ($Conf::Conf{'db_type'} eq 'mysql');
++
++ ## Is the Database defined
++ unless ($Conf::Conf{'db_name'}) {
++ &do_log('info', 'No db_name defined in configuration file');
++ return undef;
++ }
++
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ unless ($sth = $dbh->prepare("SHOW FIELDS FROM $table")) {
++ do_log('err','Unable to prepare SQL query : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL query : %s', $dbh->errstr);
++ return undef;
++ }
++
++ while (my $ref = $sth->fetchrow_hashref('NAME_lc')) {
++ next unless ($ref->{'Field'} eq $field);
++
++ return $ref->{'Type'};
++ }
++
++ return undef;
++}
++
++## Just check if DB connection is ok
++sub check_db_connect {
++
++ ## Is the Database defined
++ unless ($Conf::Conf{'db_name'}) {
++ &do_log('err', 'No db_name defined in configuration file');
++ return undef;
++ }
++
++ unless ($dbh and $dbh->ping) {
++ unless (&db_connect('just_try')) {
++ &do_log('err', 'Failed to connect to database');
++ return undef;
++ }
++ }
++
++ ## Used by List subroutines to check that the DB is available
++ $List::use_db = 1;
++
++ return 1;
++}
++
++
++
++## Lowercase field from database
++sub lowercase_field {
++ my ($table, $field) = @_;
++
++ my $total = 0;
++
++ ## Check database connection
++ unless ($dbh and $dbh->ping) {
++ return undef unless &db_connect();
++ }
++
++ unless ($sth = $dbh->prepare("SELECT $field from $table")) {
++ do_log('err','Unable to prepare SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ unless ($sth->execute) {
++ do_log('err','Unable to execute SQL statement : %s', $dbh->errstr);
++ return undef;
++ }
++
++ while (my $user = $sth->fetchrow_hashref('NAME_lc')) {
++ my $lower_cased = lc($user->{$field});
++ next if ($lower_cased eq $user->{$field});
++
++ $total++;
++
++ ## Updating Db
++ my $statement = sprintf "UPDATE $table SET $field=%s WHERE ($field=%s)", $dbh->quote($lower_cased), $dbh->quote($user->{$field});
++
++ unless ($dbh->do($statement)) {
++ do_log('err','Unable to execute SQL statement "%s" : %s', $statement, $dbh->errstr);
++ return undef;
++ }
++ }
++ $sth->finish();
++
++ return $total;
++}
++
++## Loads the list of topics if updated
++sub load_topics {
++
++ my $robot = shift ;
++ do_log('debug2', 'List::load_topics(%s)',$robot);
++
++ my $conf_file = &tools::get_filename('etc',{},'topics.conf',$robot);
++
++ unless ($conf_file) {
++ &do_log('err','No topics.conf defined');
++ return undef;
++ }
++
++ my $topics = {};
++
++ ## Load if not loaded or changed on disk
++ if (! $list_of_topics{$robot} || ((stat($conf_file))[9] > $mtime{'topics'}{$robot})) {
++
++ ## delete previous list of topics
++ %list_of_topics = undef;
++
++ unless (-r $conf_file) {
++ &do_log('err',"Unable to read $conf_file");
++ return undef;
++ }
++
++ unless (open (FILE, "<", $conf_file)) {
++ &do_log('err',"Unable to open config file $conf_file");
++ return undef;
++ }
++
++ ## Raugh parsing
++ my $index = 0;
++ my (@raugh_data, $topic);
++ while (<FILE>) {
++ Encode::from_to($_, $Conf::Conf{'filesystem_encoding'}, 'utf8');
++ if (/^([\-\w\/]+)\s*$/) {
++ $index++;
++ $topic = {'name' => $1,
++ 'order' => $index
++ };
++ }elsif (/^([\w\.]+)\s+(.+)\s*$/) {
++ next unless (defined $topic->{'name'});
++
++ $topic->{$1} = $2;
++ }elsif (/^\s*$/) {
++ if (defined $topic->{'name'}) {
++ push @raugh_data, $topic;
++ $topic = {};
++ }
++ }
++ }
++ close FILE;
++
++ ## Last topic
++ if (defined $topic->{'name'}) {
++ push @raugh_data, $topic;
++ $topic = {};
++ }
++
++ $mtime{'topics'}{$robot} = (stat($conf_file))[9];
++
++ unless ($#raugh_data > -1) {
++ &do_log('notice', 'No topic defined in %s/topics.conf', $Conf::Conf{'etc'});
++ return undef;
++ }
++
++ ## Analysis
++ foreach my $topic (@raugh_data) {
++ my @tree = split '/', $topic->{'name'};
++
++ if ($#tree == 0) {
++ my $title = _get_topic_titles($topic);
++ $list_of_topics{$robot}{$tree[0]}{'title'} = $title;
++ $list_of_topics{$robot}{$tree[0]}{'visibility'} = $topic->{'visibility'}||'default';
++ #$list_of_topics{$robot}{$tree[0]}{'visibility'} = &_load_scenario_file('topics_visibility', $robot,$topic->{'visibility'}||'default');
++ $list_of_topics{$robot}{$tree[0]}{'order'} = $topic->{'order'};
++ }else {
++ my $subtopic = join ('/', @tree[1..$#tree]);
++ my $title = _get_topic_titles($topic);
++ $list_of_topics{$robot}{$tree[0]}{'sub'}{$subtopic} = &_add_topic($subtopic,$title);
++ }
++ }
++
++ ## Set undefined Topic (defined via subtopic)
++ foreach my $t (keys %{$list_of_topics{$robot}}) {
++ unless (defined $list_of_topics{$robot}{$t}{'visibility'}) {
++ #$list_of_topics{$robot}{$t}{'visibility'} = &_load_scenario_file('topics_visibility', $robot,'default');
++ }
++
++ unless (defined $list_of_topics{$robot}{$t}{'title'}) {
++ $list_of_topics{$robot}{$t}{'title'} = {'default' => $t};
++ }
++ }
++ }
++
++ ## Set the title in the current language
++ my $lang = &Language::GetLang();
++ foreach my $top (keys %{$list_of_topics{$robot}}) {
++ my $topic = $list_of_topics{$robot}{$top};
++ $topic->{'current_title'} = $topic->{'title'}{$lang} || $topic->{'title'}{'default'} || $top;
++
++ foreach my $subtop (keys %{$topic->{'sub'}}) {
++ $topic->{'sub'}{$subtop}{'current_title'} = $topic->{'sub'}{$subtop}{'title'}{$lang} || $topic->{'sub'}{$subtop}{'title'}{'default'} || $subtop;
++ }
++ }
++
++ return %{$list_of_topics{$robot}};
++}
++
++sub _get_topic_titles {
++ my $topic = shift;
++
++ my $title;
++ foreach my $key (%{$topic}) {
++ if ($key =~ /^title(.(\w+))?$/) {
++ my $lang = $2 || 'default';
++ $title->{$lang} = $topic->{$key};
++ }
++ }
++
++ return $title;
++}
++
++## Inner sub used by load_topics()
++sub _add_topic {
++ my ($name, $title) = @_;
++ my $topic = {};
++
++ my @tree = split '/', $name;
++ if ($#tree == 0) {
++ return {'title' => $title};
++ }else {
++ $topic->{'sub'}{$name} = &_add_topic(join ('/', @tree[1..$#tree]), $title);
++ return $topic;
++ }
++}
++
++############ THIS IS RELATED TO NEW LOAD_ADMIN_FILE #############
++
++## Sort function for writing config files
++sub by_order {
++ ($::pinfo{$main::a}{'order'} <=> $::pinfo{$main::b}{'order'}) || ($main::a cmp $main::b);
++}
++
++## Apply defaults to parameters definition (%::pinfo)
++sub _apply_defaults {
++ do_log('debug3', 'List::_apply_defaults()');
++
++ ## List of available languages
++ $::pinfo{'lang'}{'format'} = &Language::GetSupportedLanguages();
++
++ ## Parameter order
++ foreach my $index (0..$#param_order) {
++ if ($param_order[$index] eq '*') {
++ $default{'order'} = $index;
++ }else {
++ $::pinfo{$param_order[$index]}{'order'} = $index;
++ }
++ }
++
++ ## Parameters
++ foreach my $p (keys %::pinfo) {
++
++ ## Apply defaults to %pinfo
++ foreach my $d (keys %default) {
++ unless (defined $::pinfo{$p}{$d}) {
++ $::pinfo{$p}{$d} = $default{$d};
++ }
++ }
++
++ ## Scenario format
++ if ($::pinfo{$p}{'scenario'}) {
++ $::pinfo{$p}{'format'} = &tools::get_regexp('scenario');
++ $::pinfo{$p}{'default'} = 'default';
++ }
++
++ ## Task format
++ if ($::pinfo{$p}{'task'}) {
++ $::pinfo{$p}{'format'} = &tools::get_regexp('task');
++ }
++
++ ## Datasource format
++ if ($::pinfo{$p}{'datasource'}) {
++ $::pinfo{$p}{'format'} = &tools::get_regexp('datasource');
++ }
++
++ ## Enumeration
++ if (ref ($::pinfo{$p}{'format'}) eq 'ARRAY') {
++ $::pinfo{$p}{'file_format'} ||= join '|', @{$::pinfo{$p}{'format'}};
++ }
++
++
++ ## Set 'format' as default for 'file_format'
++ $::pinfo{$p}{'file_format'} ||= $::pinfo{$p}{'format'};
++
++ if (($::pinfo{$p}{'occurrence'} =~ /n$/)
++ && $::pinfo{$p}{'split_char'}) {
++ my $format = $::pinfo{$p}{'file_format'};
++ my $char = $::pinfo{$p}{'split_char'};
++ $::pinfo{$p}{'file_format'} = "($format)*(\\s*$char\\s*($format))*";
++ }
++
++
++ next unless ((ref $::pinfo{$p}{'format'} eq 'HASH')
++ && (ref $::pinfo{$p}{'file_format'} eq 'HASH'));
++
++ ## Parameter is a Paragraph)
++ foreach my $k (keys %{$::pinfo{$p}{'format'}}) {
++ ## Defaults
++ foreach my $d (keys %default) {
++ unless (defined $::pinfo{$p}{'format'}{$k}{$d}) {
++ $::pinfo{$p}{'format'}{$k}{$d} = $default{$d};
++ }
++ }
++
++ ## Scenario format
++ if (ref($::pinfo{$p}{'format'}{$k}) && $::pinfo{$p}{'format'}{$k}{'scenario'}) {
++ $::pinfo{$p}{'format'}{$k}{'format'} = &tools::get_regexp('scenario');
++ $::pinfo{$p}{'format'}{$k}{'default'} = 'default' unless (($p eq 'web_archive') && ($k eq 'access'));
++ }
++
++ ## Task format
++ if (ref($::pinfo{$p}{'format'}{$k}) && $::pinfo{$p}{'format'}{$k}{'task'}) {
++ $::pinfo{$p}{'format'}{$k}{'format'} = &tools::get_regexp('task');
++ }
++
++ ## Datasource format
++ if (ref($::pinfo{$p}{'format'}{$k}) && $::pinfo{$p}{'format'}{$k}{'datasource'}) {
++ $::pinfo{$p}{'format'}{$k}{'format'} = &tools::get_regexp('datasource');
++ }
++
++ ## Enumeration
++ if (ref ($::pinfo{$p}{'format'}{$k}{'format'}) eq 'ARRAY') {
++ $::pinfo{$p}{'file_format'}{$k}{'file_format'} ||= join '|', @{$::pinfo{$p}{'format'}{$k}{'format'}};
++ }
++
++
++ if (($::pinfo{$p}{'file_format'}{$k}{'occurrence'} =~ /n$/)
++ && $::pinfo{$p}{'file_format'}{$k}{'split_char'}) {
++ my $format = $::pinfo{$p}{'file_format'}{$k}{'file_format'};
++ my $char = $::pinfo{$p}{'file_format'}{$k}{'split_char'};
++ $::pinfo{$p}{'file_format'}{$k}{'file_format'} = "($format)*(\\s*$char\\s*($format))*";
++ }
++
++ }
++
++ next unless (ref $::pinfo{$p}{'file_format'} eq 'HASH');
++
++ foreach my $k (keys %{$::pinfo{$p}{'file_format'}}) {
++ ## Set 'format' as default for 'file_format'
++ $::pinfo{$p}{'file_format'}{$k}{'file_format'} ||= $::pinfo{$p}{'file_format'}{$k}{'format'};
++ }
++ }
++
++ ## Default for user_data_source is 'file'
++ ## if not using a RDBMS
++ if ($List::use_db) {
++ $::pinfo{'user_data_source'}{'default'} = 'include2';
++ }else {
++ $::pinfo{'user_data_source'}{'default'} = 'file';
++ }
++
++ return \%::pinfo;
++}
++
++## Save a parameter
++sub _save_list_param {
++ my ($key, $p, $defaults, $fd) = @_;
++ &do_log('debug3', '_save_list_param(%s)', $key);
++
++ ## Ignore default value
++ return 1 if ($defaults == 1);
++# next if ($defaults == 1);
++
++ return 1 unless (defined ($p));
++# next unless (defined ($p));
++
++ if (defined ($::pinfo{$key}{'scenario'}) ||
++ defined ($::pinfo{$key}{'task'}) ) {
++ return 1 if ($p->{'name'} eq 'default');
++
++ $fd->print(sprintf "%s %s\n", $key, $p->{'name'});
++ $fd->print("\n");
++
++ }elsif (ref($::pinfo{$key}{'file_format'})) {
++ $fd->print(sprintf "%s\n", $key);
++ foreach my $k (keys %{$p}) {
++
++ if (defined ($::pinfo{$key}{'file_format'}{$k}{'scenario'}) ) {
++ ## Skip if empty value
++ next if ($p->{$k}{'name'} =~ /^\s*$/);
++
++ $fd->print(sprintf "%s %s\n", $k, $p->{$k}{'name'});
++
++ }elsif (($::pinfo{$key}{'file_format'}{$k}{'occurrence'} =~ /n$/)
++ && $::pinfo{$key}{'file_format'}{$k}{'split_char'}) {
++
++ $fd->print(sprintf "%s %s\n", $k, join($::pinfo{$key}{'file_format'}{$k}{'split_char'}, @{$p->{$k}}));
++ }else {
++ ## Skip if empty value
++ next if ($p->{$k} =~ /^\s*$/);
++
++ $fd->print(sprintf "%s %s\n", $k, $p->{$k});
++ }
++ }
++ $fd->print("\n");
++
++ }else {
++ if (($::pinfo{$key}{'occurrence'} =~ /n$/)
++ && $::pinfo{$key}{'split_char'}) {
++ ################" avant de debugger do_edit_list qui cr���e des nouvelles entr���es vides
++ my $string = join($::pinfo{$key}{'split_char'}, @{$p});
++ $string =~ s/\,\s*$//;
++
++ $fd->print(sprintf "%s %s\n\n", $key, $string);
++ }elsif ($key eq 'digest') {
++ my $value = sprintf '%s %d:%d', join(',', @{$p->{'days'}})
++ ,$p->{'hour'}, $p->{'minute'};
++ $fd->print(sprintf "%s %s\n\n", $key, $value);
++## }elsif (($key eq 'user_data_source') && $defaults && $List::use_db) {
++## printf $fd "%s %s\n\n", $key, 'database';
++ }else {
++ $fd->print(sprintf "%s %s\n\n", $key, $p);
++ }
++ }
++
++ return 1;
++}
++
++## Load a single line
++sub _load_list_param {
++ my ($robot,$key, $value, $p, $directory) = @_;
++ &do_log('debug3','_load_list_param(%s,\'%s\',\'%s\')', $robot,$key, $value);
++
++ ## Empty value
++ if ($value =~ /^\s*$/) {
++ return undef;
++ }
++
++ ## Default
++ if ($value eq 'default') {
++ $value = $p->{'default'};
++ }
++
++ ## Search configuration file
++ if (ref($value) && defined $value->{'conf'}) {
++ $value = &Conf::get_robot_conf($robot, $value->{'conf'});
++ }
++
++ ## Synonyms
++ if (defined $p->{'synonym'}{$value}) {
++ $value = $p->{'synonym'}{$value};
++ }
++
++ ## Include mode should not be used anymore
++ ## Change value to include2 to shift to new behavior
++ if ($key eq 'user_data_source' && $value eq 'include') {
++ $value = 'include2';
++ }
++
++ ## Scenario
++ if ($p->{'scenario'}) {
++ $value =~ y/,/_/;
++ my $scenario = new Scenario ('function' => $p->{'scenario'},
++ 'robot' => $robot,
++ 'name' => $value,
++ 'directory' => $directory);
++
++ ## We store the path of the scenario in the sstructure
++ ## Later &Scenario::request_action() will look for the scenario in %Scenario::all_scenarios through Scenario::new()
++ $value = {'file_path' => $scenario->{'file_path'},
++ 'name' => $scenario->{'name'}};
++ }elsif ($p->{'task'}) {
++ $value = {'name' => $value};
++ }
++
++ ## Do we need to split param if it is not already an array
++ if (($p->{'occurrence'} =~ /n$/)
++ && $p->{'split_char'}
++ && !(ref($value) eq 'ARRAY')) {
++ my @array = split /$p->{'split_char'}/, $value;
++ foreach my $v (@array) {
++ $v =~ s/^\s*(.+)\s*$/$1/g;
++ }
++
++ return \@array;
++ }else {
++ return $value;
++ }
++}
++
++
++
++## Load the certificat file
++sub get_cert {
++
++ my $self = shift;
++ my $format = shift;
++
++ ## Default format is PEM (can be DER)
++ $format ||= 'pem';
++
++ do_log('debug2', 'List::load_cert(%s)',$self->{'name'});
++
++ # we only send the encryption certificate: this is what the user
++ # needs to send mail to the list; if he ever gets anything signed,
++ # it will have the respective cert attached anyways.
++ # (the problem is that netscape, opera and IE can't only
++ # read the first cert in a file)
++ my($certs,$keys) = tools::smime_find_keys($self->{dir},'encrypt');
++
++ my @cert;
++ if ($format eq 'pem') {
++ unless(open(CERT, $certs)) {
++ do_log('err', "List::get_cert(): Unable to open $certs: $!");
++ return undef;
++ }
++
++ my $state;
++ while(<CERT>) {
++ chomp;
++ if($state == 1) {
++ # convert to CRLF for windows clients
++ push(@cert, "$_\r\n");
++ if(/^-+END/) {
++ pop @cert;
++ last;
++ }
++ }elsif (/^-+BEGIN/) {
++ $state = 1;
++ }
++ }
++ close CERT ;
++ }elsif ($format eq 'der') {
++ unless (open CERT, "$Conf::Conf{'openssl'} x509 -in $certs -outform DER|") {
++ do_log('err', "$Conf::Conf{'openssl'} x509 -in $certs -outform DER|");
++ do_log('err', "List::get_cert(): Unable to open get $certs in DER format: $!");
++ return undef;
++ }
++
++ @cert = <CERT>;
++ close CERT;
++ }else {
++ do_log('err', "List::get_cert(): unknown '$format' certificate format");
++ return undef;
++ }
++
++ return @cert;
++}
++
++## Load a config file of a list
++sub _load_admin_file {
++ my ($directory,$robot, $file) = @_;
++ do_log('debug3', 'List::_load_admin_file(%s, %s, %s)', $directory, $robot, $file);
++
++ my $config_file = $directory.'/'.$file;
++
++ my %admin;
++ my (@paragraphs);
++
++ ## Just in case...
++ local $/ = "\n";
++
++ ## Set defaults to 1
++ foreach my $pname (keys %::pinfo) {
++ $admin{'defaults'}{$pname} = 1 unless ($::pinfo{$pname}{'internal'});
++ }
++
++ ## Lock file
++ my $lock = new Lock ($config_file);
++ unless (defined $lock) {
++ &do_log('err','Could not create new lock on %s',$config_file);
++ return undef;
++ }
++ $lock->set_timeout(5);
++ unless ($lock->lock('read')) {
++ &do_log('err','Could not put a read lock on the config file %s',$config_file);
++ return undef;
++ }
++
++ unless (open CONFIG, "<", $config_file) {
++ &do_log('info', 'Cannot open %s', $config_file);
++ }
++
++ ## Split in paragraphs
++ my $i = 0;
++ while (<CONFIG>) {
++ if (/^\s*$/) {
++ $i++ if $paragraphs[$i];
++ }else {
++ push @{$paragraphs[$i]}, $_;
++ }
++ }
++
++ for my $index (0..$#paragraphs) {
++ my @paragraph = @{$paragraphs[$index]};
++
++ my $pname;
++
++ ## Clean paragraph, keep comments
++ for my $i (0..$#paragraph) {
++ my $changed = undef;
++ for my $j (0..$#paragraph) {
++ if ($paragraph[$j] =~ /^\s*\#/) {
++ chomp($paragraph[$j]);
++ push @{$admin{'comment'}}, $paragraph[$j];
++ splice @paragraph, $j, 1;
++ $changed = 1;
++ }elsif ($paragraph[$j] =~ /^\s*$/) {
++ splice @paragraph, $j, 1;
++ $changed = 1;
++ }
++
++ last if $changed;
++ }
++
++ last unless $changed;
++ }
++
++ ## Empty paragraph
++ next unless ($#paragraph > -1);
++
++ ## Look for first valid line
++ unless ($paragraph[0] =~ /^\s*([\w-]+)(\s+.*)?$/) {
++ &do_log('err', 'Bad paragraph "%s" in %s, ignore it', @paragraph, $config_file);
++ next;
++ }
++
++ $pname = $1;
++
++ ## Parameter aliases (compatibility concerns)
++ if (defined $alias{$pname}) {
++ $paragraph[0] =~ s/^\s*$pname/$alias{$pname}/;
++ $pname = $alias{$pname};
++ }
++
++ unless (defined $::pinfo{$pname}) {
++ &do_log('err', 'Unknown parameter "%s" in %s, ignore it', $pname, $config_file);
++ next;
++ }
++
++ ## Uniqueness
++ if (defined $admin{$pname}) {
++ unless (($::pinfo{$pname}{'occurrence'} eq '0-n') or
++ ($::pinfo{$pname}{'occurrence'} eq '1-n')) {
++ &do_log('err', 'Multiple occurences of a unique parameter "%s" in %s', $pname, $config_file);
++ }
++ }
++
++ ## Line or Paragraph
++ if (ref $::pinfo{$pname}{'file_format'} eq 'HASH') {
++ ## This should be a paragraph
++ unless ($#paragraph > 0) {
++ &do_log('err', 'Expecting a paragraph for "%s" parameter in %s, ignore it', $pname, $config_file);
++ next;
++ }
++
++ ## Skipping first line
++ shift @paragraph;
++
++ my %hash;
++ for my $i (0..$#paragraph) {
++ next if ($paragraph[$i] =~ /^\s*\#/);
++
++ unless ($paragraph[$i] =~ /^\s*(\w+)\s*/) {
++ &do_log('err', 'Bad line "%s" in %s',$paragraph[$i], $config_file);
++ }
++
++ my $key = $1;
++
++ unless (defined $::pinfo{$pname}{'file_format'}{$key}) {
++ &do_log('err', 'Unknown key "%s" in paragraph "%s" in %s', $key, $pname, $config_file);
++ next;
++ }
++
++ unless ($paragraph[$i] =~ /^\s*$key\s+($::pinfo{$pname}{'file_format'}{$key}{'file_format'})\s*$/i) {
++ &do_log('err', 'Bad entry "%s" in paragraph "%s" in %s', $paragraph[$i], $key, $pname, $config_file);
++ next;
++ }
++
++ $hash{$key} = &_load_list_param($robot,$key, $1, $::pinfo{$pname}{'file_format'}{$key}, $directory);
++ }
++
++ ## Apply defaults & Check required keys
++ my $missing_required_field;
++ foreach my $k (keys %{$::pinfo{$pname}{'file_format'}}) {
++
++ ## Default value
++ unless (defined $hash{$k}) {
++ if (defined $::pinfo{$pname}{'file_format'}{$k}{'default'}) {
++ $hash{$k} = &_load_list_param($robot,$k, 'default', $::pinfo{$pname}{'file_format'}{$k}, $directory);
++ }
++ }
++
++ ## Required fields
++ if ($::pinfo{$pname}{'file_format'}{$k}{'occurrence'} eq '1') {
++ unless (defined $hash{$k}) {
++ &do_log('info', 'Missing key "%s" in param "%s" in %s', $k, $pname, $config_file);
++ $missing_required_field++;
++ }
++ }
++ }
++
++ next if $missing_required_field;
++
++ delete $admin{'defaults'}{$pname};
++
++ ## Should we store it in an array
++ if (($::pinfo{$pname}{'occurrence'} =~ /n$/)) {
++ push @{$admin{$pname}}, \%hash;
++ }else {
++ $admin{$pname} = \%hash;
++ }
++ }else {
++ ## This should be a single line
++ unless ($#paragraph == 0) {
++ &do_log('info', 'Expecting a single line for "%s" parameter in %s', $pname, $config_file);
++ }
++
++ unless ($paragraph[0] =~ /^\s*$pname\s+($::pinfo{$pname}{'file_format'})\s*$/i) {
++ &do_log('info', 'Bad entry "%s" in %s', $paragraph[0], $config_file);
++ next;
++ }
++
++ my $value = &_load_list_param($robot,$pname, $1, $::pinfo{$pname}, $directory);
++
++ delete $admin{'defaults'}{$pname};
++
++ if (($::pinfo{$pname}{'occurrence'} =~ /n$/)
++ && ! (ref ($value) =~ /^ARRAY/)) {
++ push @{$admin{$pname}}, $value;
++ }else {
++ $admin{$pname} = $value;
++ }
++ }
++ }
++
++ close CONFIG;
++
++ ## Release the lock
++ unless ($lock->unlock()) {
++ &do_log('err', 'Could not remove the read lock on file %s',$config_file);
++ return undef;
++ }
++
++ ## Apply defaults & check required parameters
++ foreach my $p (keys %::pinfo) {
++
++ ## Defaults
++ unless (defined $admin{$p}) {
++
++ ## Simple (versus structured) parameter case
++ if (defined $::pinfo{$p}{'default'}) {
++ $admin{$p} = &_load_list_param($robot,$p, $::pinfo{$p}{'default'}, $::pinfo{$p}, $directory);
++
++ ## Sructured parameters case : the default values are defined at the next level
++ }elsif ((ref $::pinfo{$p}{'format'} eq 'HASH')
++ && ($::pinfo{$p}{'occurrence'} =~ /1$/)) {
++ ## If the paragraph is not defined, try to apply defaults
++ my $hash;
++
++ foreach my $key (keys %{$::pinfo{$p}{'format'}}) {
++
++ ## Skip keys without default value.
++ unless (defined $::pinfo{$p}{'format'}{$key}{'default'}) {
++ next;
++ }
++
++ $hash->{$key} = &_load_list_param($robot,$key, $::pinfo{$p}{'format'}{$key}{'default'}, $::pinfo{$p}{'format'}{$key}, $directory);
++ }
++
++ $admin{$p} = $hash if (defined $hash);
++
++ }
++
++# $admin{'defaults'}{$p} = 1;
++ }
++
++ ## Required fields
++ if ($::pinfo{$p}{'occurrence'} =~ /^1(-n)?$/ ) {
++ unless (defined $admin{$p}) {
++ &do_log('info','Missing parameter "%s" in %s', $p, $config_file);
++ }
++ }
++ }
++
++ ## "Original" parameters
++ if (defined ($admin{'digest'})) {
++ if ($admin{'digest'} =~ /^(.+)\s+(\d+):(\d+)$/) {
++ my $digest = {};
++ $digest->{'hour'} = $2;
++ $digest->{'minute'} = $3;
++ my $days = $1;
++ $days =~ s/\s//g;
++ @{$digest->{'days'}} = split /,/, $days;
++
++ $admin{'digest'} = $digest;
++ }
++ }
++ # The 'host' parameter is ignored if the list is stored on a
++ # virtual robot directory
++
++ # $admin{'host'} = $self{'domain'} if ($self{'dir'} ne '.');
++
++
++ if (defined ($admin{'custom_subject'})) {
++ if ($admin{'custom_subject'} =~ /^\s*\[\s*(\w+)\s*\]\s*$/) {
++ $admin{'custom_subject'} = $1;
++ }
++ }
++
++ ## Format changed for reply_to parameter
++ ## New reply_to_header parameter
++ if (($admin{'forced_reply_to'} && ! $admin{'defaults'}{'forced_reply_to'}) ||
++ ($admin{'reply_to'} && ! $admin{'defaults'}{'reply_to'})) {
++ my ($value, $apply, $other_email);
++ $value = $admin{'forced_reply_to'} || $admin{'reply_to'};
++ $apply = 'forced' if ($admin{'forced_reply_to'});
++ if ($value =~ /\@/) {
++ $other_email = $value;
++ $value = 'other_email';
++ }
++
++ $admin{'reply_to_header'} = {'value' => $value,
++ 'other_email' => $other_email,
++ 'apply' => $apply};
++
++ ## delete old entries
++ $admin{'reply_to'} = undef;
++ $admin{'forced_reply_to'} = undef;
++ }
++
++ ############################################
++ ## Bellow are constraints between parameters
++ ############################################
++
++ ## Subscription and unsubscribe add and del are closed
++ ## if subscribers are extracted via external include method
++ ## (current version external method are SQL or LDAP query
++ if ($admin{'user_data_source'} eq 'include') {
++ foreach my $p ('subscribe','add','invite','unsubscribe','del') {
++ $admin{$p} = &_load_list_param($robot,$p, 'closed', $::pinfo{$p}, 'closed', $directory);
++ }
++
++ }
++
++ ## Do we have a database config/access
++ if (($admin{'user_data_source'} eq 'database') ||
++ ($admin{'user_data_source'} eq 'include2')){
++ unless ($List::use_db) {
++ &do_log('info', 'Sympa not setup to use DBI or no database access');
++ ## We should notify the listmaster here...
++ #return undef;
++ }
++ }
++
++ ## This default setting MUST BE THE LAST ONE PERFORMED
++# if ($admin{'status'} ne 'open') {
++# ## requested and closed list are just list hidden using visibility parameter
++# ## and with send parameter set to closed.
++# $admin{'send'} = &_load_list_param('.','send', 'closed', $::pinfo{'send'}, $directory);
++# $admin{'visibility'} = &_load_list_param('.','visibility', 'conceal', $::pinfo{'visibility'}, $directory);
++# }
++
++ ## reception of default_user_options must be one of reception of
++ ## available_user_options. If none, warning and put reception of
++ ## default_user_options in reception of available_user_options
++ if (! grep (/^$admin{'default_user_options'}{'reception'}$/,
++ @{$admin{'available_user_options'}{'reception'}})) {
++ push @{$admin{'available_user_options'}{'reception'}}, $admin{'default_user_options'}{'reception'};
++ do_log('info','reception is not compatible between default_user_options and available_user_options in %s',$directory);
++ }
++
++ return \%admin;
++}
++
++## Save a config file
++sub _save_admin_file {
++ my ($config_file, $old_config_file, $admin) = @_;
++ do_log('debug3', 'List::_save_admin_file(%s, %s, %s)', $config_file,$old_config_file, $admin);
++
++ unless (rename $config_file, $old_config_file) {
++ &do_log('notice', 'Cannot rename %s to %s', $config_file, $old_config_file);
++ return undef;
++ }
++
++ unless (open CONFIG, ">", $config_file) {
++ &do_log('info', 'Cannot open %s', $config_file);
++ return undef;
++ }
++ my $config = '';
++ my $fd = new IO::Scalar \$config;
++
++ foreach my $c (@{$admin->{'comment'}}) {
++ $fd->print(sprintf "%s\n", $c);
++ }
++ $fd->print("\n");
++
++ foreach my $key (sort by_order keys %{$admin}) {
++
++ next if ($key =~ /^(comment|defaults)$/);
++ next unless (defined $admin->{$key});
++
++ ## Multiple parameter (owner, custom_header,...)
++ if ((ref ($admin->{$key}) eq 'ARRAY') &&
++ ! $::pinfo{$key}{'split_char'}) {
++ foreach my $elt (@{$admin->{$key}}) {
++ &_save_list_param($key, $elt, $admin->{'defaults'}{$key}, $fd);
++ }
++ }else {
++ &_save_list_param($key, $admin->{$key}, $admin->{'defaults'}{$key}, $fd);
++ }
++
++ }
++ print CONFIG $config;
++ close CONFIG;
++
++ return 1;
++}
++
++# Is a reception mode in the parameter reception of the available_user_options
++# section?
++sub is_available_reception_mode {
++ my ($self,$mode) = @_;
++ $mode =~ y/[A-Z]/[a-z]/;
++
++ return undef unless ($self && $mode);
++
++ my @available_mode = @{$self->{'admin'}{'available_user_options'}{'reception'}};
++
++ foreach my $m (@available_mode) {
++ if ($m eq $mode) {
++ return $mode;
++ }
++ }
++
++ return undef;
++}
++
++# List the parameter reception of the available_user_options section
++sub available_reception_mode {
++ my $self = shift;
++
++ return join (' ',@{$self->{'admin'}{'available_user_options'}{'reception'}});
++}
++
++########################################################################################
++# FUNCTIONS FOR MESSAGE TOPICS #
++########################################################################################
++# #
++# #
++
++
++####################################################
++# is_there_msg_topic
++####################################################
++# Test if some msg_topic are defined
++#
++# IN : -$self (+): ref(List)
++#
++# OUT : 1 - some are defined | 0 - not defined
++####################################################
++sub is_there_msg_topic {
++ my ($self) = shift;
++
++ if (defined $self->{'admin'}{'msg_topic'}) {
++ if (ref($self->{'admin'}{'msg_topic'}) eq "ARRAY") {
++ if ($#{$self->{'admin'}{'msg_topic'}} >= 0) {
++ return 1;
++ }
++ }
++ }
++ return 0;
++}
++
++
++####################################################
++# is_available_msg_topic
++####################################################
++# Checks for a topic if it is available in the list
++# (look foreach list parameter msg_topic.name)
++#
++# IN : -$self (+): ref(List)
++# -$topic (+): string
++# OUT : -$topic if it is available | undef
++####################################################
++sub is_available_msg_topic {
++ my ($self,$topic) = @_;
++
++ my @available_msg_topic;
++ foreach my $msg_topic (@{$self->{'admin'}{'msg_topic'}}) {
++ return $topic
++ if ($msg_topic->{'name'} eq $topic);
++ }
++
++ return undef;
++}
++
++
++####################################################
++# get_available_msg_topic
++####################################################
++# Return an array of available msg topics (msg_topic.name)
++#
++# IN : -$self (+): ref(List)
++#
++# OUT : -\@topics : ref(ARRAY)
++####################################################
++sub get_available_msg_topic {
++ my ($self) = @_;
++
++ my @topics;
++ foreach my $msg_topic (@{$self->{'admin'}{'msg_topic'}}) {
++ if ($msg_topic->{'name'}) {
++ push @topics,$msg_topic->{'name'};
++ }
++ }
++
++ return \@topics;
++}
++
++####################################################
++# is_msg_topic_tagging_required
++####################################################
++# Checks for the list parameter msg_topic_tagging
++# if it is set to 'required'
++#
++# IN : -$self (+): ref(List)
++#
++# OUT : 1 - the msg must must be tagged
++# | 0 - the msg can be no tagged
++####################################################
++sub is_msg_topic_tagging_required {
++ my ($self) = @_;
++
++ if ($self->{'admin'}{'msg_topic_tagging'} =~ /required/) {
++ return 1;
++ } else {
++ return 0;
++ }
++}
++
++####################################################
++# automatic_tag
++####################################################
++# Compute the topic(s) of the message and tag it.
++#
++# IN : -$self (+): ref(List)
++# -$msg (+): ref(MIME::Entity)
++# -$robot (+): robot
++#
++# OUT : string of tag(s), can be separated by ',', can be empty
++# | undef
++####################################################
++sub automatic_tag {
++ my ($self,$msg,$robot) = @_;
++ my $msg_id = $msg->head->get('Message-ID');
++ chomp($msg_id);
++ &do_log('debug3','automatic_tag(%s,%s)',$self->{'name'},$msg_id);
++
++
++ my $topic_list = $self->compute_topic($msg,$robot);
++
++ if ($topic_list) {
++ my $filename = $self->tag_topic($msg_id,$topic_list,'auto');
++
++ unless ($filename) {
++ &do_log('err','Unable to tag message %s with topic "%s"',$msg_id,$topic_list);
++ return undef;
++ }
++ }
++
++ return $topic_list;
++}
++
++
++####################################################
++# compute_topic
++####################################################
++# Compute the topic of the message. The topic is got
++# from applying a regexp on the message, regexp
++# based on keywords defined in list_parameter
++# msg_topic.keywords. The regexp is applied on the
++# subject and/or the body of the message according
++# to list parameter msg_topic_keywords_apply_on
++#
++# IN : -$self (+): ref(List)
++# -$msg (+): ref(MIME::Entity)
++# -$robot(+) : robot
++#
++# OUT : string of tag(s), can be separated by ',', can be empty
++####################################################
++sub compute_topic {
++ my ($self,$msg,$robot) = @_;
++ my $msg_id = $msg->head->get('Message-ID');
++ chomp($msg_id);
++ &do_log('debug3','compute_topic(%s,%s)',$self->{'name'},$msg_id);
++ my @topic_array;
++ my %topic_hash;
++ my %keywords;
++
++
++ ## TAGGING INHERITED BY THREAD
++ # getting reply-to
++ my $reply_to = $msg->head->get('In-Reply-To');
++ $reply_to = &tools::clean_msg_id($reply_to);
++ my $info_msg_reply_to = $self->load_msg_topic_file($reply_to,$robot);
++
++ # is msg reply to already tagged?
++ if (ref($info_msg_reply_to) eq "HASH") {
++ return $info_msg_reply_to->{'topic'};
++ }
++
++
++
++ ## TAGGING BY KEYWORDS
++ # getting keywords
++ foreach my $topic (@{$self->{'admin'}{'msg_topic'}}) {
++
++ my $list_keyw = &tools::get_array_from_splitted_string($topic->{'keywords'});
++
++ foreach my $keyw (@{$list_keyw}) {
++ $keywords{$keyw} = $topic->{'name'}
++ }
++ }
++
++ # getting string to parse
++ # We convert it to Unicode for case-ignore match with non-ASCII keywords.
++ my $mail_string = '';
++ if ($self->{'admin'}{'msg_topic_keywords_apply_on'} eq 'subject'){
++ $mail_string = &MIME::EncWords::decode_mimewords($msg->head->get('subject'), Charset=>'_UNICODE_')."\n";
++ }
++ unless ($self->{'admin'}{'msg_topic_keywords_apply_on'} eq 'subject') {
++ # get bodies of any text/* parts, not digging nested subparts.
++ my @parts;
++ if ($msg->effective_type =~ /^(multipart|message)\//i) {
++ @parts = $msg->parts();
++ } else {
++ @parts = ($msg);
++ }
++ foreach my $part (@parts) {
++ next unless $part->effective_type =~ /^text\//i;
++ my $charset = $part->head->mime_attr("Content-Type.Charset");
++ $charset = MIME::Charset->new($charset);
++ if (defined $part->bodyhandle) {
++ my $body = $msg->bodyhandle->as_string();
++ my $converted;
++ eval {
++ $converted = $charset->decode($body);
++ };
++ if ($@) {
++ $converted = Encode::decode('US-ASCII', $body);
++ }
++ $mail_string .= $converted."\n";
++ }
++ }
++ }
++
++ # parsing
++ foreach my $keyw (keys %keywords) {
++ my $k = $keywords{$keyw};
++ $keyw = Encode::decode_utf8($keyw);
++ $keyw = &tools::escape_regexp($keyw);
++ if ($mail_string =~ /$keyw/i){
++ $topic_hash{$k} = 1;
++ }
++ }
++
++
++
++ # for no double
++ foreach my $k (keys %topic_hash) {
++ push @topic_array,$k if ($topic_hash{$k});
++ }
++
++ if ($#topic_array <0) {
++ return '';
++
++ } else {
++ return (join(',',@topic_array));
++ }
++}
++
++####################################################
++# tag_topic
++####################################################
++# tag the message by creating the msg topic file
++#
++# IN : -$self (+): ref(List)
++# -$msg_id (+): string, msg_id of the msg to tag
++# -$topic_list (+): string (splitted by ',')
++# -$method (+) : 'auto'|'editor'|'sender'
++# the method used for tagging
++#
++# OUT : string - msg topic filename
++# | undef
++####################################################
++sub tag_topic {
++ my ($self,$msg_id,$topic_list,$method) = @_;
++ &do_log('debug3','tag_topic(%s,%s,"%s",%s)',$self->{'name'},$msg_id,$topic_list,$method);
++
++ my $robot = $self->{'domain'};
++ my $queuetopic = &Conf::get_robot_conf($robot, 'queuetopic');
++ my $list_id = $self->get_list_id();
++ $msg_id = &tools::clean_msg_id($msg_id);
++ $msg_id =~ s/>$//;
++ my $file = $list_id.'.'.$msg_id;
++
++ unless (open (FILE, ">$queuetopic/$file")) {
++ &do_log('info','Unable to create msg topic file %s/%s : %s', $queuetopic,$file, $!);
++ return undef;
++ }
++
++ print FILE "TOPIC $topic_list\n";
++ print FILE "METHOD $method\n";
++
++ close FILE;
++
++ return "$queuetopic/$file";
++}
++
++
++
++####################################################
++# load_msg_topic_file
++####################################################
++# Looks for a msg topic file from the msg_id of
++# the message, loads it and return contained information
++# in a HASH
++#
++# IN : -$self (+): ref(List)
++# -$msg_id (+): the message ID
++# -$robot (+): the robot
++#
++# OUT : ref(HASH) file contents :
++# - topic : string - list of topic name(s)
++# - method : editor|sender|auto - method used to tag
++# - msg_id : the msg_id
++# - filename : name of the file containing this information
++# | undef
++####################################################
++sub load_msg_topic_file {
++ my ($self,$msg_id,$robot) = @_;
++ $msg_id = &tools::clean_msg_id($msg_id);
++ &do_log('debug3','List::load_msg_topic_file(%s,%s)',$self->{'name'},$msg_id);
++
++ my $queuetopic = &Conf::get_robot_conf($robot, 'queuetopic');
++ my $list_id = $self->get_list_id();
++ my $file = "$list_id.$msg_id";
++
++ unless (open (FILE, "$queuetopic/$file")) {
++ &do_log('debug','No topic define ; unable to open %s/%s : %s', $queuetopic,$file, $!);
++ return undef;
++ }
++
++ my %info = ();
++
++ while (<FILE>) {
++ next if /^\s*(\#.*|\s*)$/;
++
++ if (/^(\S+)\s+(.+)$/io) {
++ my($keyword, $value) = ($1, $2);
++ $value =~ s/\s*$//;
++
++ if ($keyword eq 'TOPIC') {
++ $info{'topic'} = $value;
++
++ }elsif ($keyword eq 'METHOD') {
++ if ($value =~ /^(editor|sender|auto)$/) {
++ $info{'method'} = $value;
++ }else {
++ &do_log('err','List::load_msg_topic_file(%s,%s): syntax error in file %s/%s : %s', $queuetopic,$file, $!);
++ return undef;
++ }
++ }
++ }
++ }
++ close FILE;
++
++ if ((exists $info{'topic'}) && (exists $info{'method'})) {
++ $info{'msg_id'} = $msg_id;
++ $info{'filename'} = $file;
++
++ return \%info;
++ }
++ return undef;
++}
++
++
++####################################################
++# modifying_msg_topic_for_subscribers()
++####################################################
++# Deletes topics subscriber that does not exist anymore
++# and send a notify to concerned subscribers.
++#
++# IN : -$self (+): ref(List)
++# -$new_msg_topic (+): ref(ARRAY) - new state
++# of msg_topic parameters
++#
++# OUT : -0 if no subscriber topics have been deleted
++# -1 if some subscribers topics have been deleted
++#####################################################
++sub modifying_msg_topic_for_subscribers(){
++ my ($self,$new_msg_topic) = @_;
++ &do_log('debug3',"List::modifying_msg_topic_for_subscribers($self->{'name'}");
++ my $deleted = 0;
++
++ my @old_msg_topic_name;
++ foreach my $msg_topic (@{$self->{'admin'}{'msg_topic'}}) {
++ push @old_msg_topic_name,$msg_topic->{'name'};
++ }
++
++ my @new_msg_topic_name;
++ foreach my $msg_topic (@{$new_msg_topic}) {
++ push @new_msg_topic_name,$msg_topic->{'name'};
++ }
++
++ my $msg_topic_changes = &tools::diff_on_arrays(\@old_msg_topic_name,\@new_msg_topic_name);
++
++ if ($#{$msg_topic_changes->{'deleted'}} >= 0) {
++
++ for (my $subscriber=$self->get_first_user(); $subscriber; $subscriber=$self->get_next_user()) {
++
++ if ($subscriber->{'reception'} eq 'mail') {
++ my $topics = &tools::diff_on_arrays($msg_topic_changes->{'deleted'},&tools::get_array_from_splitted_string($subscriber->{'topics'}));
++
++ if ($#{$topics->{'intersection'}} >= 0) {
++ my $wwsympa_url = &Conf::get_robot_conf($self->{'domain'}, 'wwsympa_url');
++ unless ($self->send_notify_to_user('deleted_msg_topics',$subscriber->{'email'},
++ {'del_topics' => $topics->{'intersection'},
++ 'url' => $wwsympa_url.'/suboptions/'.$self->{'name'}})) {
++ &do_log('err',"List::modifying_msg_topic_for_subscribers($self->{'name'}) : impossible to send notify to user about 'deleted_msg_topics'");
++ }
++ unless ($self->update_user(lc($subscriber->{'email'}),
++ {'update_date' => time,
++ 'topics' => join(',',@{$topics->{'added'}})})) {
++ &do_log('err',"List::modifying_msg_topic_for_subscribers($self->{'name'} : impossible to update user '$subscriber->{'email'}'");
++ }
++ $deleted = 1;
++ }
++ }
++ }
++ }
++ return 1 if ($deleted);
++ return 0;
++}
++
++####################################################
++# select_subscribers_for_topic
++####################################################
++# Select users subscribed to a topic that is in
++# the topic list incoming when reception mode is 'mail', 'notice', 'not_me', 'txt', 'html' or 'urlize', and the other
++# subscribers (recpetion mode different from 'mail'), 'mail' and no topic subscription
++#
++# IN : -$self(+) : ref(List)
++# -$string_topic(+) : string splitted by ','
++# topic list
++# -$subscribers(+) : ref(ARRAY) - list of subscribers(emails)
++#
++# OUT : @selected_users
++#
++#
++####################################################
++sub select_subscribers_for_topic {
++ my ($self,$string_topic,$subscribers) = @_;
++ &do_log('debug3', 'List::select_subscribers_for_topic(%s, %s)', $self->{'name'},$string_topic);
++
++ my @selected_users;
++ my $msg_topics;
++
++ if ($string_topic) {
++ $msg_topics = &tools::get_array_from_splitted_string($string_topic);
++ }
++
++ foreach my $user (@$subscribers) {
++
++ # user topic
++ my $info_user = $self->get_subscriber($user);
++
++ if ($info_user->{'reception'} !~ /^(mail|notice|not_me|txt|html|urlize)$/i) {
++ push @selected_users,$user;
++ next;
++ }
++ unless ($info_user->{'topics'}) {
++ push @selected_users,$user;
++ next;
++ }
++ my $user_topics = &tools::get_array_from_splitted_string($info_user->{'topics'});
++
++ if ($string_topic) {
++ my $result = &tools::diff_on_arrays($msg_topics,$user_topics);
++ if ($#{$result->{'intersection'}} >=0 ) {
++ push @selected_users,$user;
++ }
++ }else {
++ my $result = &tools::diff_on_arrays(['other'],$user_topics);
++ if ($#{$result->{'intersection'}} >=0 ) {
++ push @selected_users,$user;
++ }
++ }
++ }
++ return @selected_users;
++}
++
++# #
++# #
++# #
++########## END - functions for message topics #############################################
++
++
++
++
++sub _urlize_part {
++ my $message = shift;
++ my $list = shift;
++ my $expl = $list->{'dir'}.'/urlized';
++ my $robot = $list->{'domain'};
++ my $dir = shift;
++ my $i = shift;
++ my $mime_types = shift;
++ my $listname = $list->{'name'};
++ my $wwsympa_url = shift;
++
++ my $head = $message->head ;
++ my $encoding = $head->mime_encoding ;
++
++ ## name of the linked file
++ my $fileExt = $mime_types->{$head->mime_type};
++ if ($fileExt) {
++ $fileExt = '.'.$fileExt;
++ }
++ my $filename;
++
++ if ($head->recommended_filename) {
++ $filename = $head->recommended_filename;
++ } else {
++ $filename ="msg.$i".$fileExt;
++ }
++
++ ##create the linked file
++ ## Store body in file
++ if (open OFILE, ">$expl/$dir/$filename") {
++ my @ct = split(/;/,$head->get('Content-type'));
++ chomp ($ct[0]);
++ printf OFILE "Content-type: %s\n\n", $ct[0];
++ } else {
++ &do_log('notice', "Unable to open $expl/$dir/$filename") ;
++ return undef ;
++ }
++
++ if ($encoding =~ /^(binary|7bit|8bit|base64|quoted-printable|x-uu|x-uuencode|x-gzip64)$/ ) {
++ open TMP, ">$expl/$dir/$filename.$encoding";
++ $message->print_body (\*TMP);
++ close TMP;
++
++ open BODY, "$expl/$dir/$filename.$encoding";
++ my $decoder = new MIME::Decoder $encoding;
++ $decoder->decode(\*BODY, \*OFILE);
++ unlink "$expl/$dir/$filename.$encoding";
++ }else {
++ $message->print_body (\*OFILE) ;
++ }
++ close (OFILE);
++ my $file = "$expl/$dir/$filename";
++ my $size = (-s $file);
++
++ ## Only URLize files with a moderate size
++ if ($size < $Conf::Conf{'urlize_min_size'}) {
++ unlink "$expl/$dir/$filename";
++ return undef;
++ }
++
++ ## Delete files created twice or more (with Content-Type.name and Content-Disposition.filename)
++ $message->purge ;
++
++ (my $file_name = $filename) =~ s/\./\_/g;
++ my $file_url = "$wwsympa_url/attach/$listname".&tools::escape_chars("$dir/$filename",'/'); # do NOT escape '/' chars
++
++ my $parser = new MIME::Parser;
++ $parser->output_to_core(1);
++ my $new_part;
++
++ my $lang = &Language::GetLang();
++ my $charset = &Language::GetCharset();
++
++ my $tt2_include_path = &tools::make_tt2_include_path($robot,'mail_tt2',$lang,$list);
++
++ &tt2::parse_tt2({'file_name' => $file_name,
++ 'file_url' => $file_url,
++ 'file_size' => $size ,
++ 'charset' => $charset},
++ 'urlized_part.tt2',
++ \$new_part,
++ $tt2_include_path);
++
++ my $entity = $parser->parse_data(\$new_part);
++
++ return $entity;
++}
++
++sub store_subscription_request {
++ my ($self, $email, $gecos, $custom_attr) = @_;
++ &do_log('debug2', '(%s, %s, %s)', $self->{'name'}, $email, $gecos, $custom_attr);
++
++ my $filename = $Conf::Conf{'queuesubscribe'}.'/'.$self->get_list_id().'.'.time.'.'.int(rand(1000));
++
++ unless (opendir SUBSPOOL, "$Conf::Conf{'queuesubscribe'}") {
++ &do_log('err', 'Could not open %s', $Conf::Conf{'queuesubscribe'});
++ return undef;
++ }
++
++ my @req_files = sort grep (!/^\.+$/,readdir(SUBSPOOL));
++ closedir SUBSPOOL;
++
++ my $listaddr = $self->{'name'}.'@'.$self->{'domain'};
++
++ foreach my $file (@req_files) {
++ next unless ($file =~ /$listaddr\..*/) ;
++ unless (open OLDREQUEST, "$Conf::Conf{'queuesubscribe'}/$file") {
++ &do_log('err', 'Could not open %s for verification', $file);
++ return undef;
++ }
++ foreach my $line (<OLDREQUEST>) {
++ if ($line =~ /^$email/i) {
++ &do_log('notice', 'Subscription already requested by %s', $email);
++ return undef;
++ }
++ }
++ close OLDREQUEST;
++ }
++
++ unless (open REQUEST, ">$filename") {
++ &do_log('notice', 'Could not open %s', $filename);
++ return undef;
++ }
++
++ ## First line of the file contains the user email address + his/her name
++ printf REQUEST "$email\t$gecos\n";
++
++ ## Following lines may contain custom attributes in an XML format
++ printf REQUEST "$custom_attr\n";
++
++ close REQUEST;
++
++ return 1;
++}
++
++sub get_subscription_requests {
++ my ($self) = shift;
++ do_log('debug2', 'List::get_subscription_requests(%s)', $self->{'name'});
++
++ my %subscriptions;
++
++ unless (opendir SPOOL, $Conf::Conf{'queuesubscribe'}) {
++ &do_log('info', 'Unable to read spool %s', $Conf::Conf{'queuesubscribe'});
++ return undef;
++ }
++
++ foreach my $filename (sort grep(/^$self->{'name'}(\@$self->{'domain'})?\.\d+\.\d+$/, readdir SPOOL)) {
++ unless (open REQUEST, "<:bytes", "$Conf::Conf{'queuesubscribe'}/$filename") {
++ do_log('err', 'Could not open %s', $filename);
++ closedir SPOOL;
++ next;
++ }
++
++ ## First line of the file contains the user email address + his/her name
++ my $line = <REQUEST>;
++ my ($email, $gecos);
++ if ($line =~ /^((\S+|\".*\")\@\S+)\s*([^\t]*)\t(.*)$/) {
++ ($email, $gecos) = ($1, $3);
++
++ }else {
++ &do_log('err', "Failed to parse subscription request %s",$filename);
++ next;
++ }
++
++ my $user_entry = $self->get_subscriber($email);
++
++ if ( defined($user_entry) && ($user_entry->{'subscribed'} == 1)) {
++ &do_log('err','User %s is subscribed to %s already. Deleting subscription request.', $email, $self->{'name'});
++ unless (unlink "$Conf::Conf{'queuesubscribe'}/$filename") {
++ &do_log('err', 'Could not delete file %s', $filename);
++ }
++ next;
++ }
++ ## Following lines may contain custom attributes in an XML format
++ my %xml = &parseCustomAttribute(\*REQUEST) ;
++ close REQUEST;
++
++ $subscriptions{$email} = {'gecos' => $gecos,
++ 'custom_attribute' => \%xml};
++ unless($subscriptions{$email}{'gecos'}) {
++ my $user = get_user_db($email);
++ if ($user->{'gecos'}) {
++ $subscriptions{$email}{'gecos'} = $user->{'gecos'};
++ }
++ }
++
++ $filename =~ /^$self->{'name'}(\@$self->{'domain'})?\.(\d+)\.\d+$/;
++ $subscriptions{$email}{'date'} = $2;
++ }
++ closedir SPOOL;
++
++ return \%subscriptions;
++}
++
++sub get_subscription_request_count {
++ my ($self) = shift;
++ do_log('debug2', 'List::get_subscription_requests_count(%s)', $self->{'name'});
++
++ my %subscriptions;
++ my $i = 0 ;
++
++ unless (opendir SPOOL, $Conf::Conf{'queuesubscribe'}) {
++ &do_log('info', 'Unable to read spool %s', $Conf::Conf{'queuesubscribe'});
++ return undef;
++ }
++
++ foreach my $filename (sort grep(/^$self->{'name'}(\@$self->{'domain'})?\.\d+\.\d+$/, readdir SPOOL)) {
++ $i++;
++ }
++ closedir SPOOL;
++
++ return $i;
++}
++
++sub delete_subscription_request {
++ my ($self, @list_of_email) = @_;
++ &do_log('debug2', 'List::delete_subscription_request(%s, %s)', $self->{'name'}, join(',',@list_of_email));
++
++ my $removed_file = 0;
++ my $email_regexp = &tools::get_regexp('email');
++
++ unless (opendir SPOOL, $Conf::Conf{'queuesubscribe'}) {
++ &do_log('info', 'Unable to read spool %s', $Conf::Conf{'queuesubscribe'});
++ return undef;
++ }
++
++ foreach my $filename (sort grep(/^$self->{'name'}(\@$self->{'domain'})?\.\d+\.\d+$/, readdir SPOOL)) {
++
++ unless (open REQUEST, "$Conf::Conf{'queuesubscribe'}/$filename") {
++ &do_log('notice', 'Could not open %s', $filename);
++ next;
++ }
++ my $line = <REQUEST>;
++ close REQUEST;
++
++ foreach my $email (@list_of_email) {
++
++ unless ($line =~ /^($email_regexp)\s*/ && ($1 eq $email)) {
++ next;
++ }
++
++ unless (unlink "$Conf::Conf{'queuesubscribe'}/$filename") {
++ &do_log('err', 'Could not delete file %s', $filename);
++ last;
++ }
++ $removed_file++;
++ }
++ }
++
++ closedir SPOOL;
++
++ unless ($removed_file > 0) {
++ &do_log('err', 'No pending subscription was found for users %s', join(',',@list_of_email));
++ return undef;
++ }
++
++ return 1;
++}
++
++
++sub get_shared_size {
++ my $self = shift;
++
++ return tools::get_dir_size("$self->{'dir'}/shared");
++}
++
++sub get_arc_size {
++ my $self = shift;
++ my $dir = shift;
++
++ return tools::get_dir_size($dir.'/'.$self->get_list_id());
++}
++
++# return the date epoch for next delivery planified for a list
++sub get_next_delivery_date {
++ my $self = shift;
++
++ my $dtime = $self->{'admin'}{'delivery_time'} ;
++ unless ($dtime =~ /(\d?\d)\:(\d\d)/ ) {
++ # if delivery _time if not defined, the delivery time right now
++ return time();
++ }
++ my $h = $1;
++ my $m = $2;
++ unless ((($h == 24)&&($m == 0))||(($h <= 23)&&($m <= 60))){
++ &do_log('err',"ignoring wrong parameter format delivery_time, delivery_tile must be smaller than 24:00");
++ return time();
++ }
++ my $date = time();
++
++ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($date);
++
++ my $plannified_time = (($h*60)+$m)*60; # plannified time in sec
++ my $now_time = ((($hour*60)+$min)*60)+$sec; # Now #sec since to day 00:00
++
++ my $result = $date - $now_time + $plannified_time;
++ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($result);
++
++ if ($now_time <= $plannified_time ) {
++ return ( $date - $now_time + $plannified_time) ;
++ }else{
++ return ( $date - $now_time + $plannified_time + (24*3600)); # plannified time is past so report to tomorrow
++ }
++}
++
++
++## Searches the include datasource corresponding to the provided ID
++sub search_datasource {
++ my ($self, $id) = @_;
++ &do_log('debug2','List::search_datasource(%s,%s)', $self->{'name'}, $id);
++
++ ## Go through list parameters
++ foreach my $p (keys %{$self->{'admin'}}) {
++ next unless ($p =~ /^include/);
++
++ ## Go through sources
++ foreach my $s (@{$self->{'admin'}{$p}}) {
++ if (&Datasource::_get_datasource_id($s) eq $id) {
++ if (ref($s)) {
++ return $s->{'name'} || $s->{'host'};
++ }else{
++ return $s;
++ }
++ }
++ }
++ }
++
++ return undef;
++}
++
++## Return the names of datasources, given a coma-separated list of source ids
++# IN : -$class
++# -$id : datasource ids (coma-separated)
++# OUT : -$name : datasources names (scalar)
++sub get_datasource_name {
++ my ($self, $id) = @_;
++ &do_log('debug2','(%s,%s)', $self->{'name'}, $id);
++ my %sources;
++
++ my @ids = split /,/,$id;
++ foreach my $id (@ids) {
++ ## User may come twice from the same datasource
++ unless (defined ($sources{$id})) {
++ $sources{$id} = $self->search_datasource($id);
++ }
++ }
++
++ return join(', ', values %sources);
++}
++
++## Remove a task in the tasks spool
++sub remove_task {
++ my $self = shift;
++ my $task = shift;
++
++ unless (opendir(DIR, $Conf::Conf{'queuetask'})) {
++ &do_log ('err', "error : can't open dir %s: %s", $Conf::Conf{'queuetask'}, $!);
++ return undef;
++ }
++ my @tasks = grep !/^\.\.?$/, readdir DIR;
++ closedir DIR;
++
++ foreach my $task_file (@tasks) {
++ if ($task_file =~ /^(\d+)\.\w*\.$task\.$self->{'name'}\@$self->{'domain'}$/) {
++ unless (unlink("$Conf::Conf{'queuetask'}/$task_file")) {
++ &do_log('err', 'Unable to remove task file %s : %s', $task_file, $!);
++ return undef;
++ }
++ &do_log('notice', 'Removing task file %s', $task_file);
++ }
++ }
++
++ return 1;
++}
++
++## Close the list (remove from DB, remove aliases, change status to 'closed' or 'family_closed')
++sub close {
++ my ($self, $email, $status) = @_;
++
++ return undef
++ unless ($self && ($list_of_lists{$self->{'domain'}}{$self->{'name'}}));
++
++ ## Dump subscribers, unless list is already closed
++ unless ($self->{'admin'}{'status'} eq 'closed') {
++ $self->_save_users_file("$self->{'dir'}/subscribers.closed.dump");
++ }
++
++ ## Delete users
++ my @users;
++ for ( my $user = $self->get_first_user(); $user; $user = $self->get_next_user() ){
++ push @users, $user->{'email'};
++ }
++ $self->delete_user('users' => \@users);
++
++ ## Remove entries from admin_table
++ foreach my $role ('owner','editor') {
++ my @admin_users;
++ for ( my $user = $self->get_first_admin_user($role); $user; $user = $self->get_next_admin_user() ){
++ push @admin_users, $user->{'email'};
++ }
++ $self->delete_admin_user($role, @admin_users);
++ }
++
++ ## Change status & save config
++ $self->{'admin'}{'status'} = 'closed';
++
++ if (defined $status) {
++ foreach my $s ('family_closed','closed') {
++ if ($status eq $s) {
++ $self->{'admin'}{'status'} = $status;
++ last;
++ }
++ }
++ }
++
++ $self->{'admin'}{'defaults'}{'status'} = 0;
++
++ $self->save_config($email);
++ $self->savestats();
++
++ $self->remove_aliases();
++
++ return 1;
++}
++
++## Remove the list
++sub purge {
++ my ($self, $email) = @_;
++
++ return undef
++ unless ($self && ($list_of_lists{$self->{'domain'}}{$self->{'name'}}));
++
++ ## Remove tasks for this list
++ &Task::list_tasks($Conf::Conf{'queuetask'});
++ foreach my $task (&Task::get_tasks_by_list($self->get_list_id())) {
++ unlink $task->{'filepath'};
++ }
++
++ ## Close the list first, just in case...
++ $self->close();
++
++ if ($self->{'name'}) {
++ my $arc_dir = &Conf::get_robot_conf($self->{'domain'},'arc_path');
++ &tools::remove_dir($arc_dir.'/'.$self->get_list_id());
++ &tools::remove_dir($self->get_bounce_dir());
++ }
++
++ &tools::remove_dir($self->{'dir'});
++
++ return 1;
++}
++
++## Remove list aliases
++sub remove_aliases {
++ my $self = shift;
++
++ return undef
++ unless ($self && ($list_of_lists{$self->{'domain'}}{$self->{'name'}})
++ && ($Conf::Conf{'sendmail_aliases'} !~ /^none$/i));
++
++ my $alias_manager = $Conf::Conf{'alias_manager'};
++
++ unless (-x $alias_manager) {
++ &do_log('err','Cannot run alias_manager %s', $alias_manager);
++ return undef;
++ }
++
++ system ("$alias_manager del $self->{'name'} $self->{'admin'}{'host'}");
++ my $status = $? / 256;
++ unless ($status == 0) {
++ do_log('err','Failed to remove aliases ; status %d : %s', $status, $!);
++ return undef;
++ }
++
++ &do_log('info','Aliases for list %s removed successfully', $self->{'name'});
++
++ return 1;
++}
++
++
++##
++## bounce management actions
++##
++
++# Sub for removing user
++#
++sub remove_bouncers {
++ my $self = shift;
++ my $reftab = shift;
++ &do_log('debug','List::remove_bouncers(%s)',$self->{'name'});
++
++ ## Log removal
++ foreach my $bouncer (@{$reftab}) {
++ &do_log('notice','Removing bouncing subsrciber of list %s : %s', $self->{'name'}, $bouncer);
++ }
++
++ unless ($self->delete_user('users' => $reftab, 'exclude' =>' 1')){
++ &do_log('info','error while calling sub delete_users');
++ return undef;
++ }
++ return 1;
++}
++
++#Sub for notifying users : "Be carefull,You're bouncing"
++#
++sub notify_bouncers{
++ my $self = shift;
++ my $reftab = shift;
++ &do_log('debug','List::notify_bouncers(%s)', $self->{'name'});
++
++ foreach my $user (@$reftab){
++ &do_log('notice','Notifying bouncing subsrciber of list %s : %s', $self->{'name'}, $user);
++ unless ($self->send_notify_to_user('auto_notify_bouncers',$user,{})) {
++ &do_log('notice',"Unable to send notify 'auto_notify_bouncers' to $user");
++ }
++ }
++ return 1;
++}
++
++## Create the document repository
++sub create_shared {
++ my $self = shift;
++
++ my $dir = $self->{'dir'}.'/shared';
++
++ if (-e $dir) {
++ &do_log('err',"List::create_shared : %s already exists", $dir);
++ return undef;
++ }
++
++ unless (mkdir ($dir, 0777)) {
++ &do_log('err',"List::create_shared : unable to create %s : %s ", $dir, $!);
++ return undef;
++ }
++
++ return 1;
++}
++
++## check if a list has include-type data sources
++sub has_include_data_sources {
++ my $self = shift;
++
++ foreach my $type ('include_file','include_list','include_remote_sympa_list','include_sql_query','include_remote_file',
++ 'include_ldap_query','include_ldap_2level_query','include_admin','owner_include','editor_include') {
++ if (ref($self->{'admin'}{$type}) eq 'ARRAY' && $#{$self->{'admin'}{$type}} >= 0) {
++ return 1;
++ }
++ }
++
++ return 0
++}
++
++# move a message to a queue or distribute spool
++sub move_message {
++ my ($self, $file, $queue) = @_;
++ &do_log('debug2', "List::move_message($file, $self->{'name'}, $queue)");
++
++ my $dir = $queue || $Conf::Conf{'queuedistribute'};
++ my $filename = $self->get_list_id().'.'.time.'.'.int(rand(999));
++
++ unless (open OUT, ">$dir/T.$filename") {
++ &do_log('err', 'Cannot create file %s', "$dir/T.$filename");
++ return undef;
++ }
++
++ unless (open IN, $file) {
++ &do_log('err', 'Cannot open file %s', $file);
++ return undef;
++ }
++
++ print OUT <IN>; close IN; close OUT;
++ unless (rename "$dir/T.$filename", "$dir/$filename") {
++ &do_log('err', 'Cannot rename file %s into %s',"$dir/T.$filename","$dir/$filename" );
++ return undef;
++ }
++ return 1;
++}
++
++## Return the path to the list bounce directory, where bounces are stored
++sub get_bounce_dir {
++ my $self = shift;
++
++ my $root_dir = &Conf::get_robot_conf($self->{'domain'}, 'bounce_path');
++
++ return $root_dir.'/'.$self->get_list_id();
++}
++
++## Return the list email address
++sub get_list_address {
++ my $self = shift;
++
++ return $self->{'name'}.'@'.$self->{'admin'}{'host'};
++}
++
++## Return the list ID, different from the list address (uses the robot name)
++sub get_list_id {
++ my $self = shift;
++
++ return $self->{'name'}.'@'.$self->{'domain'};
++}
++
++###### END of the List package ######
++
++1;
+diff --git a/sympa-6.1.7-src/src/lib/Upgrade.pm b/sympa-6.1.7-src/src/lib/Upgrade.pm
+index c56e0b1..6c828ce 100644
+--- a/sympa-6.1.7-src/src/lib/Upgrade.pm
++++ b/sympa-6.1.7-src/src/lib/Upgrade.pm
+@@ -815,8 +815,19 @@ sub probe_db {
+ },
+ 'conf_table' => {'robot_conf' => 'varchar(80)',
+ 'label_conf' => 'varchar(80)',
+- 'value_conf' => 'varchar(300)'}
+- },
++ 'value_conf' => 'varchar(300)'},
++ 'lists_table' => {'name_list'=>'varchar(100)',
++ 'path_list'=>'varchar(100)',
++ 'robot_list'=>'varchar(100)',
++ 'status_list'=>"enum('open','closed','pending','error_config','family_closed')",
++ 'creation_email_list'=>'varchar(100)',
++ 'creation_epoch_list'=>'datetime',
++ 'subject_list'=>'varchar(100)',
++ 'web_archive_list'=>'tinyint(1)',
++ 'topics_list'=>'varchar(100)',
++ 'editors_list'=>'varchar(100)',
++ 'owners_list'=>'varchar(100)'}
++ },
+ 'SQLite' => {'user_table' => {'email_user' => 'text',
+ 'gecos_user' => 'text',
+ 'password_user' => 'text',
+@@ -921,7 +932,19 @@ sub probe_db {
+ 'dkim_header_list_bulkspool' => 'varchar(500)'},
+ 'conf_table' => {'robot_conf' => 'text',
+ 'label_conf' => 'text',
+- 'value_conf' => 'text'}});
++ 'value_conf' => 'text'},
++ 'lists_table' => {'name_list'=>'varchar(100)',
++ 'path_list'=>'varchar(100)',
++ 'robot_list'=>'varchar(100)',
++ 'status_list'=>"enum('open','closed','pending','error_config','family_closed')",
++ 'creation_email_list'=>'varchar(100)',
++ 'creation_epoch_list'=>'datetime',
++ 'subject_list'=>'varchar(100)',
++ 'web_archive_list'=>'tinyint(1)',
++ 'topics_list'=>'varchar(100)',
++ 'editors_list'=>'varchar(100)',
++ 'owners_list'=>'varchar(100)'}
++ } );
+
+ my %not_null = ('email_user' => 1,
+ 'list_subscriber' => 1,
+@@ -949,6 +972,16 @@ sub probe_db {
+ 'messagekey_bulkmailer' => 1,
+ 'packetid_bulkmailer' => 1,
+ 'messagekey_bulkspool' => 1,
++ 'name_list'=>1,
++ 'path_list'=>1,
++ 'robot_list'=>1,
++ 'status_list'=>1,
++ 'creation_email_list'=>1,
++ 'subject_list'=>1,
++ 'web_archive_list'=>1,
++ 'topics_list'=>1,
++ 'owners_list'=>1,
++ 'editors_list'=>1
+ );
+
+ my %primary = ('user_table' => ['email_user'],
+@@ -961,7 +994,8 @@ sub probe_db {
+ 'one_time_ticket_table' => ['ticket_one_time_ticket'],
+ 'bulkmailer_table' => ['messagekey_bulkmailer','packetid_bulkmailer'],
+ 'bulkspool_table' => ['messagekey_bulkspool'],
+- 'conf_table' => ['robot_conf','label_conf']
++ 'conf_table' => ['robot_conf','label_conf'],
++ 'list_table'=> ['name_list','robot_list']
+ );
+
+ ## List the required INDEXES
+diff --git a/sympa-6.1.7-src/src/lib/admin.pm b/sympa-6.1.7-src/src/lib/admin.pm
+index f925869..496f795 100644
+--- a/sympa-6.1.7-src/src/lib/admin.pm
++++ b/sympa-6.1.7-src/src/lib/admin.pm
+@@ -341,6 +341,7 @@ sub create_list_old{
+ &do_log('notice', "Synchronizing list members...");
+ $list->sync_include();
+ }
++ $list->save_config;
+
+ return $return;
+ }
+diff --git a/sympa-6.1.7-src/src/lib/confdef.pm b/sympa-6.1.7-src/src/lib/confdef.pm
+index ed37441..51f96f8 100644
+--- a/sympa-6.1.7-src/src/lib/confdef.pm
++++ b/sympa-6.1.7-src/src/lib/confdef.pm
+@@ -526,6 +526,11 @@ our @params = (
+ default => 'mailer-daemon|sympa|listserv|majordomo|smartlist|mailman',
+ vhost => '1',
+ },
++ {
++ name => 'db_list_cache',
++ default => '0',
++ advice => 'Whether or not to cache lists in the database',
++ },
+ { title => 'Internationalization' },
+ {
+ name => 'lang',
+diff --git a/sympa-6.1.7-src/src/sympa.pl.in b/sympa-6.1.7-src/src/sympa.pl.in
+index 1142b50..130f7df 100644
+--- a/sympa-6.1.7-src/src/sympa.pl.in
++++ b/sympa-6.1.7-src/src/sympa.pl.in
+@@ -84,6 +84,7 @@ Options:
+ --dump=list\@dom|ALL : dumps subscribers
+ --make_alias_file : create file in /tmp with all aliases (usefull when aliases.tpl is changed)
+ --lowercase : lowercase email addresses in database
++ --sync_list_db[=listname] : syncs filesystem list configs to the database cache of list configs, optionally sync an individual list if specified.
+ --md5_encode_password : rewrite password in database using md5 fingerprint. YOU CAN'T UNDO unless you save this table first
+ --create_list --robot=robot_name --input_file=/path/to/file.xml
+ : create a list with the xml file under robot_name
+@@ -125,7 +126,7 @@ encryption.
+ ## Check --dump option
+ my %options;
+ unless (&GetOptions(\%main::options, 'dump=s', 'debug|d', ,'log_level=s','foreground', 'service=s','config|f=s',
+- 'lang|l=s', 'mail|m', 'keepcopy|k=s', 'help', 'version', 'import=s','make_alias_file','lowercase','md5_encode_password',
++ 'lang|l=s', 'mail|m', 'keepcopy|k=s', 'help', 'version', 'import=s','make_alias_file','lowercase','sync_list_db','md5_encode_password',
+ 'close_list=s','rename_list=s','new_listname=s','new_listrobot=s','purge_list=s','create_list','instantiate_family=s','robot=s','add_list=s','modify_list=s','close_family=s','md5_digest=s',
+ 'input_file=s','sync_include=s','upgrade','upgrade_shared','from=s','to=s','reload_list_config','list=s','quiet','close_unknown','test_database_message_buffer','conf_2_db')) {
+ &fatal_err("Unknown options.");
+@@ -156,7 +157,8 @@ $main::options{'batch'} = 1 if ($main::options{'dump'} ||
+ $main::options{'upgrade_shared'} ||
+ $main::options{'test_database_message_buffer'} ||
+ $main::options{'conf_2_db'} ||
+- $main::options{'reload_list_config'}
++ $main::options{'reload_list_config'} ||
++ $main::options{'sync_list_db'}
+ );
+
+ # Some option force foreground mode
+@@ -925,6 +927,32 @@ elsif ($main::options{'close_family'}) {
+ print STDOUT $string;
+ exit 0;
+ }
++##########################################
++elsif ($main::options{'sync_list_db'}) {
++ unless ($Conf{'db_list_cache'}) {
++ print STDOUT "\nSympa not configured to use database list caching \n";
++ exit 1;
++ }
++ my $listname = $main::options{'sync_list_db'};
++ if (length($listname) > 1) {
++ my ($listname, $robot) = split /\@/, $listname;
++ my $list = new List ($listname, $robot);
++ unless (defined $list) {
++ print STDOUT "\nList '$list' does not exist. \n";
++ exit 1;
++ }
++ if (&List::_flush_list_db($listname)) {
++ $list->_update_list_db;
++ }
++ } else {
++ &List::_flush_list_db();
++ my $all_lists = &List::get_lists('*', undef, undef, 1);
++ foreach my $list (@$all_lists) {
++ $list->_update_list_db;
++ }
++ }
++ exit 0;
++}
+
+
+ ## Do we have right access in the directory
+diff --git a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
+index e6f8ba6..c062cb9 100644
+--- a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
++++ b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
+@@ -7940,7 +7940,11 @@ sub do_remove_arc {
+ ## Checking families and other virtual hosts.
+ &get_server_details();
+
+- my $all_lists = &List::get_lists($robot);
++ #my $all_lists = &List::get_lists($robot);
++ # use list config db table to get lists
++ my $statement = "SELECT name_list from list_table WHERE status_list = 'pending'";
++ my @lists = &List::get_lists_db($statement);
++ my $all_lists = &List::get_lists($robot, undef, @lists);
+ foreach my $list ( @$all_lists ) {
+ if ($list->{'admin'}{'status'} eq 'pending') {
+ $param->{'pending'}{$list->{'name'}}{'subject'} = $list->{'admin'}{'subject'};
+@@ -7960,7 +7964,11 @@ sub do_remove_arc {
+ ## Checking families and other virtual hosts.
+ &get_server_details();
+
+- my $all_lists = &List::get_lists($robot);
++ #my $all_lists = &List::get_lists($robot);
++ # use list config db table to get lists
++ my $statement = "SELECT name_list from list_table WHERE status_list = 'closed'";
++ my @lists = &List::get_lists_db($statement);
++ my $all_lists = &List::get_lists($robot, undef, @lists);
+ foreach my $list ( @$all_lists ) {
+ if ($list->{'admin'}{'status'} eq 'closed' ||
+ $list->{'admin'}{'status'} eq 'family_closed') {
+@@ -8873,7 +8881,13 @@ Sends back the list creation edition form.
+
+ ## Members list
+ my $record = 0;
+- my $all_lists = &List::get_lists($robot);
++ #my $all_lists = &List::get_lists($robot);
++ # use list config db table to get lists
++ my $regexp = $param->{'regexp'};
++ my $statement = sprintf "SELECT name_list from list_table WHERE name_list RLIKE '%s' OR subject_list RLIKE '%s'", $regexp, $regexp;
++ my @lists = &List::get_lists_db($statement) || undef;
++ my $all_lists = &List::get_lists($robot, undef, @lists);
++
+ foreach my $list ( @$all_lists ) {
+ my $is_admin;
+ ## Search filter
+@@ -10280,7 +10294,7 @@ sub do_rename_list {
+ 'error_type' => 'unknown_robot'});
+ return undef;
+ }
+-
++ $list->save_config();
+ ## Were aliases installed?
+ if ($param->{'aliases'} == 1) {
+ $param->{'auto_aliases'} = 1;
+diff --git a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in.orig b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in.orig
+new file mode 100644
+index 0000000..e6f8ba6
+--- /dev/null
++++ b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in.orig
+@@ -0,0 +1,16925 @@
++#!--PERL-- -U
++# wwsympa.fcgi - This script provides the web interface to Sympa
++# RCS Identication ; $Revision: 7135 $ ; $Date: 2011-07-15 16:33:38 +0200 (ven 15 jui 2011) $
++#
++# Sympa - SYsteme de Multi-Postage Automatique
++# Copyright (c) 1997-2003 Comite Reseau des Universites
++#
++# This program is free software; you can redistribute it and/or modify
++# it under the terms of the GNU General Public License as published by
++# the Free Software Foundation; either version 2 of the License, or
++# (at your option) any later version.
++#
++# This program is distributed in the hope that it will be useful,
++# but WITHOUT ANY WARRANTY; without even the implied warranty of
++# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++# GNU General Public License for more details.
++#
++# You should have received a copy of the GNU General Public License
++# along with this program; if not, write to the Free Software
++# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
++
++## Copyright 1999 Comit� R�seaux des Universit�s
++## web interface to Sympa mailing lists manager
++## Sympa: http://www.sympa.org/
++## Authors :
++## Serge Aumont <sa AT cru.fr>
++## Olivier Sala�n <os AT cru.fr>
++=pod
++
++=head1 NAME
++
++I<wwsympa.fcgi> - Sympa web interface
++
++=head1 DESCRIPTION
++
++This fcgi script completely handles all aspects of the Sympa web interface
++
++=cut
++
++use lib '--modulesdir--';
++
++use Getopt::Long;
++use Archive::Zip;
++
++use strict 'vars';
++use Time::Local;
++use MIME::Lite::HTML;
++
++## Sympa API
++use List;
++use mail;
++use Conf;
++use confdef;
++use Commands;
++use Language;
++use Log;
++use Auth;
++use admin;
++use SharedDocument;
++use report;
++use SympaSession;
++use Log;
++use tools;
++use time_utils;
++use Sympa::Constants;
++use wwslib;
++use cookielib;
++use Robot;
++use tt2;
++#use DateTime;
++#use open ':utf8'; ## Default is to consider files utf8
++
++use Mail::Header;
++use Mail::Address;
++
++my $crypt_openssl_x509_ok;
++BEGIN {
++ if (eval "require Crypt::OpenSSL::X509") {
++ require Crypt::OpenSSL::X509;
++ $crypt_openssl_x509_ok = 1;
++ } else {
++ $crypt_openssl_x509_ok = 0;
++ }
++};
++
++## WWSympa librairies
++my %options;
++
++## Configuration
++my $wwsconf = {};
++
++## Change to your wwsympa.conf location
++my $conf_file = Sympa::Constants::WWSCONFIG;
++my $sympa_conf_file = Sympa::Constants::CONFIG;
++
++
++
++my $loop = 0;
++my $list;
++my $param = {};
++my ($robot, $robot_object);
++my $ip ;
++my $rss ;
++my $session;
++
++## Load config
++unless ($wwsconf = &wwslib::load_config($conf_file)) {
++ &fatal_err('Unable to load config file %s', $conf_file);
++}
++
++## Load sympa config
++unless (&Conf::load( $sympa_conf_file )) {
++ &fatal_err('Unable to load sympa config file %s', $sympa_conf_file);
++}
++
++&Log::set_log_level($Conf{'log_level'}) if ($Conf{'log_level'});
++
++&mail::set_send_spool($Conf{'queue'});
++
++if ($wwsconf->{'use_fast_cgi'}) {
++ require CGI::Fast;
++}else {
++ require CGI;
++}
++my $daemon_name = &Log::set_daemon($0);
++
++my $mime_types = &wwslib::load_mime_types();
++
++
++# hash of all the description files already loaded
++# format :
++# $desc_files{pathfile}{'date'} : date of the last load
++# $desc_files{pathfile}{'desc_hash'} : hash which describes
++# the description file
++
++#%desc_files_map; NOT USED ANYMORE
++
++# hash of the icons linked with a type of file
++my %icon_table;
++
++ # application file
++$icon_table{'unknown'} = $Conf{'static_content_url'}.'/icons/unknown.png';
++$icon_table{'folder'} = $Conf{'static_content_url'}.'/icons/folder.png';
++$icon_table{'current_folder'} = $Conf{'static_content_url'}.'/icons/folder.open.png';
++$icon_table{'application'} = $Conf{'static_content_url'}.'/icons/unknown.png';
++$icon_table{'octet-stream'} = $Conf{'static_content_url'}.'/icons/binary.png';
++$icon_table{'audio'} = $Conf{'static_content_url'}.'/icons/sound1.png';
++$icon_table{'image'} = $Conf{'static_content_url'}.'/icons/image2.png';
++$icon_table{'text'} = $Conf{'static_content_url'}.'/icons/text.png';
++$icon_table{'video'} = $Conf{'static_content_url'}.'/icons/movie.png';
++$icon_table{'father'} = $Conf{'static_content_url'}.'/icons/back.png';
++$icon_table{'sort'} = $Conf{'static_content_url'}.'/icons/down.png';
++$icon_table{'url'} = $Conf{'static_content_url'}.'/icons/link.png';
++$icon_table{'left'} = $Conf{'static_content_url'}.'/icons/left.png';
++$icon_table{'right'} = $Conf{'static_content_url'}.'/icons/right.png';
++## Shared directory and description file
++
++#$shared = 'shared';
++#$desc = '.desc';
++
++
++## subroutines
++my %comm = ('home' => 'do_home',
++ 'logout' => 'do_logout',
++ 'loginrequest' => 'do_loginrequest',
++ 'login' => 'do_login',
++ 'sso_login' => 'do_sso_login',
++ 'sso_login_succeeded' => 'do_sso_login_succeeded',
++ 'subscribe' => 'do_subscribe',
++ 'multiple_subscribe' => 'do_multiple_subscribe',
++ 'subrequest' => 'do_subrequest',
++ 'subindex' => 'do_subindex',
++ 'suboptions' => 'do_suboptions',
++ 'signoff' => 'do_signoff',
++ 'auto_signoff' => 'do_auto_signoff',
++ 'multiple_signoff' => 'do_multiple_sigoff',
++ 'sigrequest' => 'do_sigrequest',
++ 'ignoresub' => 'do_ignoresub',
++ 'which' => 'do_which',
++ 'lists' => 'do_lists',
++ 'latest_lists' => 'do_latest_lists',
++ 'active_lists' => 'do_active_lists',
++ 'info' => 'do_info',
++ 'subscriber_count' => 'do_subscriber_count',
++ 'review' => 'do_review',
++ 'search' => 'do_search',
++ 'pref', => 'do_pref',
++ 'setpref' => 'do_setpref',
++ 'setpasswd' => 'do_setpasswd',
++ 'renewpasswd' => 'do_renewpasswd',
++ 'firstpasswd' => 'do_firstpasswd',
++ 'requestpasswd' => 'do_requestpasswd',
++ 'choosepasswd' => 'do_choosepasswd',
++ 'viewfile' => 'do_viewfile',
++ 'set' => 'do_set',
++ 'admin' => 'do_admin',
++ 'add_request' => 'do_add_request',
++ 'add' => 'do_add',
++ 'del' => 'do_del',
++ 'modindex' => 'do_modindex',
++ 'reject' => 'do_reject',
++ 'reject_notify' => 'do_reject_notify',
++ 'reject_notify_shared' =>'admin',
++ 'distribute' => 'do_distribute',
++ 'viewmod' => 'do_viewmod',
++ 'd_reject_shared' => 'do_d_reject_shared',
++ 'reject_notify_shared' => 'do_reject_notify_shared',
++ 'd_install_shared' => 'do_d_install_shared',
++ 'editfile' => 'do_editfile',
++ 'savefile' => 'do_savefile',
++ 'arc' => 'do_arc',
++ 'latest_arc' => 'do_latest_arc',
++ 'latest_d_read' => 'do_latest_d_read',
++ 'arc_manage' => 'do_arc_manage',
++ 'remove_arc' => 'do_remove_arc',
++ 'send_me' => 'do_send_me',
++ 'view_source' => 'do_view_source',
++ 'arcsearch_form' => 'do_arcsearch_form',
++ 'arcsearch_id' => 'do_arcsearch_id',
++ 'arcsearch' => 'do_arcsearch',
++ 'rebuildarc' => 'do_rebuildarc',
++ 'rebuildallarc' => 'do_rebuildallarc',
++ 'arc_download' => 'do_arc_download',
++ 'arc_delete' => 'do_arc_delete',
++ 'serveradmin' => 'do_serveradmin',
++ 'set_loglevel' => 'do_set_loglevel',
++ 'set_dumpvars' => 'do_set_dumpvars',
++ 'show_sessions' => 'do_show_sessions',
++ 'unset_dumpvars' => 'do_unset_dumpvars',
++ 'set_session_email' => 'do_set_session_email',
++ 'restore_email' => 'do_restore_email',
++ 'skinsedit' => 'do_skinsedit',
++ 'css' => 'do_css',
++ 'help' => 'do_help',
++ 'edit_list_request' => 'do_edit_list_request',
++ 'edit_list' => 'do_edit_list',
++ 'create_list_request' => 'do_create_list_request',
++ 'create_list' => 'do_create_list',
++ 'get_pending_lists' => 'do_get_pending_lists',
++ 'get_closed_lists' => 'do_get_closed_lists',
++ 'get_latest_lists' => 'do_get_latest_lists',
++ 'get_inactive_lists' => 'do_get_inactive_lists',
++ 'set_pending_list_request' => 'do_set_pending_list_request',
++ 'install_pending_list' => 'do_install_pending_list',
++ 'edit_config' => 'do_edit_config',
++ 'submit_list' => 'do_submit_list',
++ 'editsubscriber' => 'do_editsubscriber',
++ 'viewbounce' => 'do_viewbounce',
++ 'redirect' => 'do_redirect',
++ 'rename_list_request' => 'do_rename_list_request',
++ 'rename_list' => 'do_rename_list',
++ 'copy_list' => 'do_copy_list',
++ 'reviewbouncing' => 'do_reviewbouncing',
++ 'resetbounce' => 'do_resetbounce',
++ 'scenario_test' => 'do_scenario_test',
++ 'search_list' => 'do_search_list',
++ 'show_cert' => 'show_cert',
++ 'close_list_request' => 'do_close_list_request',
++ 'close_list' => 'do_close_list',
++ 'purge_list' => 'do_purge_list',
++ 'restore_list' => 'do_restore_list',
++ 'upload_pictures' => 'do_upload_pictures',
++ 'delete_pictures' => 'do_delete_pictures',
++ 'd_read' => 'do_d_read',
++ 'd_create_dir' => 'do_d_create_dir',
++ 'd_upload' => 'do_d_upload',
++ 'd_unzip' => 'do_d_unzip',
++ 'd_editfile' => 'do_d_editfile',
++ 'd_properties' => 'do_d_properties',
++ 'd_overwrite' => 'do_d_overwrite',
++ 'd_savefile' => 'do_d_savefile',
++ 'd_describe' => 'do_d_describe',
++ 'd_delete' => 'do_d_delete',
++ 'd_rename' => 'do_d_rename',
++ 'd_control' => 'do_d_control',
++ 'd_change_access' => 'do_d_change_access',
++ 'd_set_owner' => 'do_d_set_owner',
++ 'd_admin' => 'do_d_admin',
++ 'dump_scenario' => 'do_dump_scenario',
++ 'dump' => 'do_dump',
++ 'arc_protect' => 'do_arc_protect',
++ 'remind' => 'do_remind',
++ 'change_email' => 'do_change_email',
++ 'change_email_request' => 'do_change_email_request',
++ 'load_cert' => 'do_load_cert',
++ 'compose_mail' => 'do_compose_mail',
++ 'send_mail' => 'do_send_mail',
++ 'request_topic' => 'do_request_topic',
++ 'tag_topic_by_sender' =>'do_tag_topic_by_sender',
++ 'search_user' => 'do_search_user',
++ 'set_lang' => 'do_set_lang',
++ 'attach' => 'do_attach',
++ 'stats' => 'do_stats',
++ 'viewlogs'=> 'do_viewlogs',
++ 'wsdl'=> 'do_wsdl',
++ 'sync_include' => 'do_sync_include',
++ 'review_family' => 'do_review_family',
++ 'ls_templates' => 'do_ls_templates',
++ 'remove_template' => 'do_remove_template',
++ 'copy_template' => 'do_copy_template',
++ 'view_template' => 'do_view_template',
++ 'edit_template' => 'do_edit_template',
++ 'rss_request' => 'do_rss_request',
++ 'maintenance' => 'do_maintenance',
++ 'blacklist' => 'do_blacklist',
++ 'edit_attributes' => 'do_edit_attributes',
++ 'ticket' => 'do_ticket',
++ 'manage_template' => 'do_manage_template',
++ 'send_newsletter' => 'do_send_newsletter',
++ 'suspend_request' => 'do_suspend_request',
++ 'suspend_request_action' => 'do_suspend_request_action',
++ 'show_exclude' => 'do_show_exclude',
++ 'ca' => 'do_ca', # 'ca' stands for 'custom_action'. I used a short name to make it discrete in a URL.
++ 'lca' => 'do_lca', # 'lca' stands for 'list_custom_action'. I used a short name to make it discrete in a URL.
++ );
++
++my %auth_action = ('logout' => 1,
++ 'loginrequest' => 1,
++ 'login' => 1,
++ 'sso_login' => 1,
++ 'sso_login_succeeded' => 1,
++ 'renewpasswd' => 1,
++ 'firstpasswd' => 1,
++ 'choosepasswd' => 1,
++ 'sendssopasswd' => 1,
++ 'ticket' => 1,
++ );
++
++## Arguments awaited in the PATH_INFO, depending on the action
++my %action_args = ('default' => ['list'],
++ 'editfile' => ['list','file'],
++ 'viewfile' => ['list','file'],
++ 'requestpasswd' => ['email'],
++ 'choosepasswd' => ['email','passwd'],
++ 'lists' => ['topic','subtopic'],
++ 'latest_lists' => ['topic','subtopic'],
++ 'active_lists' => ['topic','subtopic'],
++ 'login' => ['email','passwd','previous_action','previous_list'],
++ 'sso_login' => ['auth_service_name','subaction','email', 'ticket'],
++ 'sso_login_succeeded' => ['auth_service_name','previous_action','previous_list'],
++ 'loginrequest' => ['previous_action','previous_list'],
++ 'logout' => ['previous_action','previous_list'],
++ 'renewpasswd' => ['previous_action','previous_list'],
++ 'firstpasswd' => ['previous_action','previous_list'],
++ 'css' => ['file'],
++ 'pref' => ['previous_action','previous_list'],
++ 'reject' => ['list','id'],
++ 'distribute' => ['list','id'],
++ 'dump_scenario' => ['list','pname'],
++ 'd_reject_shared' => ['list','id'],
++ 'd_install_shared' => ['list','id'],
++ 'modindex' => ['list'],
++ 'viewmod' => ['list','id','@file'],
++ 'viewfile' => ['list','file'],
++ 'add' => ['list','email'],
++ 'add_request' => ['list'],
++ 'del' => ['list','email'],
++ 'editsubscriber' => ['list','email','previous_action','custom_attribute'],
++# 'editsubscriber' => ['list','email','previous_action'],
++ 'viewbounce' => ['list','email'],
++ 'resetbounce' => ['list','email'],
++ 'review' => ['list','page','size','sortby'],
++ 'reviewbouncing' => ['list','page','size'],
++ 'arc' => ['list','month','@arc_file'],
++ 'latest_arc' => ['list'],
++ 'arc_manage' => ['list'],
++ 'arcsearch_form' => ['list','archive_name'],
++ 'arcsearch_id' => ['list','archive_name','msgid'],
++ 'rebuildarc' => ['list','month'],
++ 'rebuildallarc' => [],
++ 'arc_download' => ['list'],
++ 'arc_delete' => ['list','zip'],
++ 'home' => [],
++ 'help' => ['help_topic'],
++ 'show_cert' => [],
++ 'subscribe' => ['list','email','passwd'],
++ 'subrequest' => ['list','email'],
++ 'subrequest' => ['list'],
++ 'subindex' => ['list'],
++ 'ignoresub' => ['list','@email','@gecos'],
++ 'signoff' => ['list','email','passwd'],
++ 'auto_signoff' => ['list','email'],
++ 'sigrequest' => ['list','email'],
++ 'set' => ['list','email','reception','gecos'],
++ 'serveradmin' => ['subaction'],
++ 'set_session_email' => ['email'],
++ 'skinsedit' => [],
++ 'get_pending_lists' => [],
++ 'get_closed_lists' => [],
++ 'get_latest_lists' => [],
++ 'get_inactive_lists' => [],
++ 'search_list' => ['filter'],
++ 'shared' => ['list','@path'],
++ 'd_read' => ['list','@path'],
++ 'latest_d_read' => ['list'],
++ 'd_admin' => ['list','d_admin'],
++ 'd_delete' => ['list','@path'],
++ 'd_rename' => ['list','@path'],
++ 'd_create_dir' => ['list','@path'],
++ 'd_overwrite' => ['list','@path'],
++ 'd_savefile' => ['list','@path'],
++ 'd_describe' => ['list','@path'],
++ 'd_editfile' => ['list','@path'],
++ 'd_properties' => ['list','@path'],
++ 'd_control' => ['list','@path'],
++ 'd_change_access' => ['list','@path'],
++ 'd_set_owner' => ['list','@path'],
++ 'dump' => ['list','format'],
++ 'search' => ['list','filter'],
++ 'search_user' => ['email'],
++ 'set_lang' => ['lang'],
++ 'attach' => ['list','dir','file'],
++ 'edit_list_request' => ['list','group'],
++ 'rename_list' => ['list','new_list','new_robot'],
++ 'copy_list' => ['list','new_list','new_robot'],
++ 'redirect' => [],
++ 'viewlogs' => ['list','first'],
++ 'wsdl' => [],
++ 'sync_include' => ['list'],
++ 'review_family' => ['family_name'],
++ 'ls_templates' => ['list'],
++ 'view_template' => [],
++ 'remove_template' => [],
++ 'copy_template' => ['list'],
++ 'edit_template' => ['list'],
++ 'rss_request' => ['list'],
++ 'request_topic' => ['list','authkey'],
++ 'tag_topic_by_sender' => ['list'],
++ 'multiple_subscribe' => ['lists'],
++ 'multiple_signoff' => ['lists'],
++ 'ticket' => ['ticket'],
++ 'change_email' => ['email'],
++ 'manage_template' => ['subaction','list','message_template'],
++ 'send_newsletter' => [],
++ 'compose_mail' => ['list','subaction'],
++ 'suspend_request' => ['subaction'],
++ 'show_exclude' => ['list'],
++ 'ca' => ['custom_action','@cap'],
++ 'lca' => ['custom_action','list','@cap'],
++ );
++
++## Define the required parameters for each action
++## Parameter names refer to the %in structure of to $param if mentionned as 'param.x'
++## This structure is used to determine if any parameter is missing
++## The list of parameters is not ordered
++## Some keywords are reserved: param.list and param.user.email
++## Alternate parameters can be defined with the '|' character
++## Limits of this structure: it does not define optional parameters (a or b)
++## Limit: it does not allow to have a specific error message and redirect to a given page if the parameter is missing
++my %required_args = ('active_lists' => ['for|count'],
++ 'admin' => ['param.list','param.user.email'],
++ 'add' => ['param.list','param.user.email'],
++ 'add_request' => ['param.list','param.user.email'],
++ 'arc' => ['param.list'],
++ 'arc_delete' => ['param.user.email','param.list'],
++ 'arc_download' => ['param.user.email','param.list'],
++ 'arc_manage' => ['param.list'],
++ 'arc_protect' => ['param.list'],
++ 'arcsearch' => ['param.list'],
++ 'arcsearch_form' => ['param.list'],
++ 'arcsearch_id' => ['param.list'],
++ 'attach' => ['param.list'],
++ 'blacklist' => ['param.list'],
++ 'change_email' => ['param.user.email'],
++ 'change_email_request' => ['param.user.email','new_email'],
++ 'close_list' => ['param.user.email','param.list'],
++ 'close_list_request' => ['param.user.email','param.list'],
++ 'compose_mail' => ['param.user.email','param.list'],
++ 'copy_template' => ['webormail'],
++ 'create_list' => ['param.user.email'], ## other required parameters are checked in the subroutine
++ 'create_list_request' => ['param.user.email'],
++ 'css' => [],
++ 'd_admin' => ['param.list','param.user.email'],
++ 'd_change_access' => ['param.list','param.user.email'],
++ 'd_control' => ['param.list','param.user.email'],
++ 'd_create_dir' => ['param.list','param.user.email','name_doc'],
++ 'd_delete' => ['param.list','param.user.email'],
++ 'd_describe' => ['param.list','param.user.email','content'],
++ 'd_editfile' => ['param.list','param.user.email'],
++ 'd_install_shared' => ['param.list','param.user.email','id'],
++ 'd_overwrite' => ['param.list','param.user.email'],
++ 'd_properties' => ['param.list','param.user.email'],
++ 'd_read' => ['param.list'],
++ 'd_reject_shared' => ['param.list','param.user.email','id'],
++ 'd_rename' => ['param.list','param.user.email','new_name'],
++ 'd_savefile' => ['param.list','param.user.email','content|url'],
++ 'd_set_owner' => ['param.list','param.user.email'],
++ 'd_unzip' => ['param.list','param.user.email'],
++ 'd_upload' => ['param.list','param.user.email'],
++ 'del' => ['param.list','param.user.email','email'],
++ 'delete_pictures' => ['param.list','param.user.email'],
++ 'distribute' => ['param.list','param.user.email','id|idspam'],
++ 'dump' => ['param.list'],
++ 'dump_scenario' => ['param.list','pname'],
++ 'edit_list' => ['param.user.email','param.list'],
++ 'edit_list_request' => ['param.user.email','param.list'],
++ 'edit_template' => ['webormail'],
++ 'editfile' => ['param.user.email'],
++ 'editsubscriber' => ['param.list','param.user.email','email'],
++ 'get_closed_lists' => ['param.user.email'],
++ 'get_inactive_lists' => ['param.user.email'],
++ 'get_latest_lists' => ['param.user.email'],
++ 'get_pending_lists' => ['param.user.email'],
++ 'ignoresub' => ['param.list','param.user.email'],
++ 'info' => ['param.list'],
++ 'install_pending_list' => ['param.user.email'],
++ 'edit_config' => ['param.user.email'],
++ 'latest_arc' => ['param.list','for|count'],
++ 'latest_d_read' => ['param.list','for','count'],
++ 'latest_lists' => ['for|count'],
++ 'load_cert' => ['param.list'],
++ 'logout' => ['param.user.email'],
++ 'manage_template' => ['param.list','param.user.email'],
++ 'modindex' => ['param.list','param.user.email'],
++ 'multiple_subscribe' => ['param.list'],
++ 'pref' => ['param.user.email'],
++ 'purge_list' => ['param.user.email','selected_lists'],
++ 'rebuildallarc' => ['param.user.email'],
++ 'rebuildarc' => ['param.user.email','param.list'],
++ 'reject' => ['param.list','param.user.email','id|idspam'],
++ 'remind' => ['param.list','param.user.email'],
++ 'remove_arc' => ['param.list'],
++ 'remove_templates' => ['webormail'],
++ 'rename_list' => ['param.user.email','param.list','new_listname','new_robot'],
++ 'copy_list' => ['param.user.email','param.list','new_listname','new_robot'],
++ 'rename_list_request' => ['param.user.email','param.list'],
++ 'request_topic' => ['param.list','authkey'],
++ 'resetbounce' => ['param.list','param.user.email','email'],
++ 'restore_list' => ['param.user.email','param.list'],
++ 'review' => ['param.list'],
++ 'review_family' => ['param.user.email','family_name'],
++ 'reviewbouncing' => ['param.list'],
++ 'rss_request' => [],
++ 'savefile' => ['param.user.email','file'],
++ 'search' => ['param.list','filter'],
++ 'search_user' => ['param.user.email','email'],
++ 'send_mail' => ['param.user.email'],
++ 'send_newsletter' => ['param.list','param.user.email', 'url'],
++ 'send_me' => ['param.list'],
++ 'view_source' => ['param.list'],
++ 'requestpasswd' => ['email'],
++ 'serveradmin' => ['param.user.email'],
++ 'set' => ['param.list','reception|visibility'],
++ 'set_lang' => [],
++ 'set_pending_list_request' => ['param.user.email'],
++ 'setpasswd' => ['param.user.email','newpasswd1','newpasswd2'],
++ 'setpref' => ['param.user.email'],
++ 'signoff' => ['param.list'],
++ 'sigrequest' => ['param.list'],
++ 'skinedit' => ['param.user.email'],
++ 'sso_login' => ['auth_service_name'],
++ 'stats' => ['param.user.email','param.list'],
++ 'subindex' => ['param.list','param.user.email'],
++ 'suboptions' => ['param.list','param.user.email'],
++ 'subrequest' => ['param.list'],
++ 'subscribe' => ['param.list'],
++ 'subscriber_count' => ['param.list'],
++ 'suspend_request' => [],
++ 'suspend_request_action' => [],
++ 'show_exclude' => ['param.list'],
++ 'sync_include' => ['param.list','param.user.email'],
++ 'tag_topic_by_sender' => ['param.list'],
++ 'upload_pictures' => ['param.user.email','param.list'],
++ 'view_template' => ['webormail'],
++ 'viewbounce' => ['param.list','email'],
++ 'viewfile' => ['file','param.list'],
++ 'viewlogs' => ['param.list'],
++ 'viewmod' => ['param.list','param.user.email','id|idspam'],
++ 'wsdl' => [],
++ 'which' => ['param.user.email'],
++ );
++
++## Defines the required privileges to access privileged actions
++## You can define a set ofequiivalent privileges in the ARRAYREF
++my %required_privileges = ('admin' => ['owner','editor'],
++ 'arc_download' => ['owner'],
++ 'blacklist' => ['owner','editor'],
++ 'close_list' => ['privileged_owner'],
++ 'close_list_request' => ['privileged_owner'],
++ 'copy_template' => ['listmaster'],
++ 'd_install_shared' => ['editor'],
++ 'd_reject_shared' => ['editor'],
++ 'distribute' => ['editor'],
++ 'dump_scenario' => ['listmaster'],
++ 'edit_list' => ['owner'],
++ 'edit_list_request' => ['owner'],
++ 'edit_template' => ['listmaster'],
++ 'editsubscriber' => ['owner'],
++ 'get_closed_lists' => ['listmaster'],
++ 'get_inactive_lists' => ['listmaster'],
++ 'get_latest_lists' => ['listmaster'],
++ 'get_pending_lists' => ['listmaster'],
++ 'ignoresub' => ['owner'],
++ 'install_pending_list' => ['listmaster'],
++ 'edit_config' => ['listmaster'],
++ 'ls_templates' => ['listmaster'],
++ 'manage_template' => ['owner'],
++ 'manage_template' => ['owner'],
++ 'modindex' => ['editor'],
++ 'purge_list' => ['privileged_owner','listmaster'],
++ 'rebuildallarc' => ['listmaster'],
++ 'rebuildarc' => ['listmaster'],
++ 'reject' => ['editor'],
++ 'remove_template' => ['listmaster'],
++ 'rename_list' => ['privileged_owner'],
++ 'copy_list' => ['owner'],
++ 'rename_list_request' => ['privileged_owner'],
++ 'resetbounce' => ['owner'],
++ 'restore_list' => ['listmaster'],
++ 'review_family' => ['listmaster'],
++ 'reviewbouncing' => ['owner'],
++ 'search_user' => ['listmaster'],
++ 'serveradmin' => ['listmaster'],
++ 'set_dumpvars' => ['listmaster'],
++ 'set_loglevel' => ['listmaster'],
++ 'set_pending_list_request' => ['listmaster'],
++ 'set_session_email' => ['listmaster'],
++ 'show_sessions' => ['listmaster'],
++ 'stats' => ['owner'],
++ 'subindex' => ['owner'],
++ 'sync_include' => ['owner'],
++ 'skinedit' => ['listmaster'],
++ 'view_template' => ['listmaster'],
++ 'viewbounce' => ['owner'],
++ 'viewlogs' => ['owner','editor'],
++ 'viewmod' => ['editor'],
++ );
++
++# this definition is used to choose the left side menu type (admin -> listowner admin menu | serveradmin -> server_admin menu | none list or your_list menu)
++my %action_type = ('editfile' => 'admin',
++ 'review' => 'admin',
++ 'search' => 'admin',
++ 'viewfile' => 'admin',
++ 'admin' => 'admin',
++ 'add_request' =>'admin',
++ 'add' =>'admin',
++ 'del' =>'admin',
++# 'modindex' =>'admin',
++ 'reject' =>'admin',
++ 'reject_notify' =>'admin',
++ 'add_request' =>'admin',
++ 'distribute' =>'admin',
++ 'viewmod' =>'admin',
++ 'savefile' =>'admin',
++ 'rebuildarc' =>'admin',
++ 'rebuildallarc' =>'admin',
++ 'reviewbouncing' =>'admin',
++ 'edit_list_request' =>'admin',
++ 'edit_list' =>'admin',
++ 'editsubscriber' =>'admin',
++ 'viewbounce' =>'admin',
++ 'resetbounce' =>'admin',
++ 'scenario_test' =>'admin',
++ 'close_list_request' =>'admin',
++ 'close_list' =>'admin',
++ 'restore_list' => 'admin',
++ 'd_admin' => 'admin',
++ 'd_reject_shared' =>'admin',
++ 'd_install_shared' =>'admin',
++ 'dump_scenario' => 'admin',
++ 'dump' => 'admin',
++ 'remind' => 'admin',
++# 'subindex' => 'admin',
++ 'stats' => 'admin',
++ 'ignoresub' => 'admin',
++ 'rename_list' => 'admin',
++ 'copy_list' => 'admin',
++ 'rename_list_request' => 'admin',
++ 'arc_manage' => 'admin',
++ 'sync_include' => 'admin',
++ 'ls_templates' => 'admin',
++ 'view_template' => 'admin',
++ 'remove_template' => 'admin',
++ 'copy_template' => 'admin',
++ 'edit_template' => 'admin',
++ 'blacklist' => 'admin',
++ 'viewlogs' => 'admin',
++ 'serveradmin' => 'serveradmin',
++ 'get_pending_lists' => 'serveradmin',
++ 'get_closed_lists' => 'serveradmin',
++ 'get_inactive_lists' => 'serveradmin',
++ 'get_latest_lists' => 'serveradmin',
++ 'ls_templates' => 'serveradmin',
++ 'skinedit' => 'serveradmin',
++ 'review_family' => 'serveradmin',
++ 'search_user' => 'serveradmin',
++ 'show_sessions' => 'serveradmin',
++ 'show_exclude' => 'admin',
++ 'rebuildarc' => 'serveradmin',
++ 'set_session_email' => 'serveradmin',
++ 'set_loglevel' => 'serveradmin',
++ 'editfile' => 'serveradmin',
++ 'unset_dumpvars' => 'serveradmin',
++ 'set_dumpvars' => 'serveradmin'
++);
++
++## actions tthat are not used in return of login,
++my %temporary_actions = ( 'logout' => 1,
++ 'loginrequest' => 1,
++ 'login' => 1,
++ 'sso_login' => 1,
++ 'sso_login_succeeded' => 1,
++ 'ticket' => 1,
++ 'css' => 1,
++ 'rss' => 1,
++ 'wsdl' => 1,
++ 'redirect' => 1,
++ );
++
++## Regexp applied on incoming parameters (%in)
++## The aim is not a strict definition of parameter format
++## but rather a security check
++my %in_regexp = (
++ ## Default regexp
++ '*' => '[\w\-\.]+',
++
++ ## List config parameters
++ 'single_param' => '.+',
++ 'multiple_param' => '.+',
++
++ ## Textarea content
++ 'template_content' => '.+',
++ 'content' => '.+',
++ 'body' => '.+',
++ 'info' => '.+',
++ 'new_scenario_content' => '.+',
++ 'blacklist' => '.*',
++
++ ## Integer
++ 'page' => '\d+',
++ 'size' => '\d+',
++
++ ## Free data
++ 'subject' => '.*',
++ 'gecos' => '[^<>\\\*\$\n]+',
++ 'additional_field' => '[^<>\\\*\$\n]+',
++ 'dump' => '[^<>\\\*\$]+', # contents email + gecos
++
++ ## Search
++ 'filter' => '[^<>\\\[\]\(\)\$\n]+', # search list
++ 'key_word' => '.*',
++ 'format' => '[^<>\\\$\n]+', # dump format/filter string
++
++ ## File names
++ 'file' => '[^<>\*\$\n]+',
++ 'template_path' => '[\w\-\.\/_]+',
++ 'arc_file' => '[^<>\\\*\$\n]+',
++ 'path' => '[^<>\\\*\$\n]+',
++ 'uploaded_file' => '[^<>\*\$\n]+', # Could be precised (use of "'")
++ 'unzipped_file' => '[^<>\*\$\n]+',
++ 'dir' => '[^<>\\\*\$\n]+',
++ 'name_doc' => '[^<>\\\*\$\[\]\/\n]+',
++ 'shortname' => '[^<>\\\*\$\n]+',
++ 'new_name' => '[^<>\\\*\$\n]+',
++ 'id' => '[^<>\\\*\$\n]+',
++ 'template_name' => &tools::get_regexp('template_name'),
++ 'new_template_name' => &tools::get_regexp('template_name'),
++ 'message_template' => &tools::get_regexp('template_name'),
++ 'new_default' => &tools::get_regexp('template_name'),
++
++ ## Archives
++ 'month' => '\d{2}|\d{4}\-\d{2}', ## format is yyyy-mm for 'arc' and mm for 'send_me'
++
++ ## URL
++ 'referer' => '[^\\\$\*\"\'\`\^\|\<\>\n]+',
++ 'failure_referer' => '[^\\\$\*\"\'\`\^\|\<\>\n]+',
++ 'url' => '[^\\\$\*\"\'\`\^\|\<\>\n]+',
++
++ ## Msg ID
++ 'msgid' => '[^\\\*\"\'\`\^\|\n]+',
++ 'in_reply_to' => '[^\\\*\"\'\`\^\|\n]+',
++ 'message_id' => '[^\\\*\"\'\`\^\|\n]+',
++
++ ## Password
++ 'passwd' => '.+',
++ 'password' => '.+',
++ 'newpasswd1' => '.+',
++ 'newpasswd2' => '.+',
++ 'new_password' => '.+',
++
++ ## Topics
++ 'topic' => '[\-\w\/]+',
++ 'topics' => '[\-\w\/]+',
++ 'subtopic' => '[\-\w\/]+',
++
++
++ ## List names
++ 'list' => '[\w\-\.\+]*', ## &tools::get_regexp('listname') + uppercase
++ 'previous_list' => '[\w\-\.\+]*',
++ 'new_list' => '[\w\-\.\+]*',
++ 'listname' => '[\w\-\.\+]*',
++ 'new_listname' => '[\w\-\.\+]*',
++ 'selected_lists' => '[\w\-\.\+]*',
++
++ ## Family names
++ 'family_name' => &tools::get_regexp('family_name'),
++
++ ## Email addresses
++ 'email' => &tools::get_regexp('email').'|'.&tools::get_regexp('uid'),
++ 'init_email' => &tools::get_regexp('email'),
++ 'old_email' => &tools::get_regexp('email'),
++ 'new_email' => &tools::get_regexp('email'),
++ 'pending_email' => &tools::get_regexp('email').',.*', # Email address is followed by ',' + gecos data
++ 'sender' => &tools::get_regexp('email'),
++ 'to' => '(([\w\-\_\.\/\+\=\']+|\".*\")\s[\w\-]+(\.[\w\-]+)+(,?))*',
++
++ ## Host
++ 'new_robot' => &tools::get_regexp('host'),
++ 'remote_host' => &tools::get_regexp('host'),
++ 'remote_addr' => &tools::get_regexp('host'),
++
++ ## Scenario name
++ 'scenario' => &tools::get_regexp('scenario'),
++ 'read_access' => &tools::get_regexp('scenario'),
++ 'edit_access' => &tools::get_regexp('scenario'),
++ ## RSS URL or blank
++ 'active_lists' => '.*',
++ 'latest_lists' => '.*',
++ 'latest_arc' => '.*',
++ 'latest_d_read' => '.*',
++
++ ##Logs
++ 'target_type' => '[\w\-\.\:]*',
++ 'target' => &tools::get_regexp('email'),
++ 'date_from' => '[\d\/]+',
++ 'date_to' => '[\d\/]+',
++ 'ip' => &tools::get_regexp('host'),
++
++ ## colors
++ 'subaction_test' => '.*',
++ 'subaction_reset' => '.*',
++ 'subaction_install' => '.*',
++ 'custom_color_value' => '\#.*',
++ 'custom_color_0' => '.*',
++ 'custom_color_1' => '.*',
++ 'custom_color_2' => '.*',
++ 'custom_color_3' => '.*',
++ 'custom_color_4' => '.*',
++ 'custom_color_5' => '.*',
++ 'custom_color_6' => '.*',
++ 'custom_color_7' => '.*',
++ 'custom_color_8' => '.*',
++ 'custom_color_9' => '.*',
++ 'custom_color_10' => '.*',
++ 'custom_color_11' => '.*',
++ 'custom_color_12' => '.*',
++ 'custom_color_13' => '.*',
++ 'custom_color_14' => '.*',
++ 'custom_color_15' => '.*',
++
++ ## Custom attribute
++ 'custom_attribute' => '.*',
++
++ ## Templates
++ 'scope' => 'distrib|robot|family|list|site',
++
++ ## Custom Inputs from create_list_request.tt2
++ 'custom_input' => '.*',
++
++ ## conf parameters
++ 'conf_new_value' => '.*',
++
++ ## custom actions
++ 'cap' => '.*',
++ 'lcap' => '.*',
++ );
++
++## Regexp applied on incoming parameters (%in)
++## This regular expression defines forbidden expressions applied on all incoming parameters
++## Note that you can use the ^ and $ expressions to match beginning and ending of expressions
++my %in_negative_regexp = (
++ 'arc_file' => '^(arctxt|\.)'
++ );
++
++## List some required filtering of incoming parameters, depending on current action
++## Paramater can be '*' or 'param*'
++## Like Q-encoding
++my %filtering = ('d_reject_shared' => {'id' => 'qencode'},
++ 'd_install_shared' => {'id' => 'qencode'},
++ 'd_read' => {'path' => 'qencode'},
++ 'd_create_dir' => {'name_doc' => 'qencode', 'path' => 'qencode'},
++ 'd_upload' => {'path' => 'qencode'},
++ 'd_unzip' => {'path' => 'qencode'},
++ 'd_editfile' => {'path' => 'qencode'},
++ 'd_properties' => {'path' => 'qencode'},
++ 'd_overwrite' => {'path' => 'qencode'},
++ 'd_savefile' => {'path' => 'qencode', 'name_doc' => 'qencode'},
++ 'd_describe' => {'path' => 'qencode'},
++ 'd_delete' => {'path' => 'qencode'},
++ 'd_rename' => {'path' => 'qencode','new_name' => 'qencode'},
++ 'd_control' => {'path' => 'qencode'},
++ 'd_change_access' => {'path' => 'qencode'},
++ 'd_set_owner' => {'path' => 'qencode'},
++ 'requestpasswd' => {'email' => 'fix_escape_uri'},
++ 'viewbounce' => {'email' => 'fix_escape_uri'},
++ 'editsubscriber' => {'email' => 'fix_escape_uri'},
++ 'edit_list' => {'*param*' => 'unescape_html'}, ## Required because outgoing parameters have been html-escaped in edit_list_request
++ 'change_email' => {'*email' => 'normalize'}, ## Remove leading/trailing white spaces and lowercase
++ );
++
++## Open log
++$wwsconf->{'log_facility'}||= $Conf{'syslog'};
++
++&Log::do_openlog($wwsconf->{'log_facility'}, $Conf{'log_socket_type'}, 'wwsympa');
++&do_log('info', 'WWSympa started');
++
++## Set locale configuration
++$Language::default_lang = $Conf{'lang'};
++
++## Important to leave this there because it defined defaults for user_data_source
++&List::check_db_connect();
++
++my $pinfo = &List::_apply_defaults();
++
++## Check that the data structure is uptodate
++## If not, set the web interface to maintenance mode
++my $maintenance_mode;
++unless (&Upgrade::data_structure_uptodate()) {
++ $maintenance_mode = 1;
++ &do_log('err',"Web interface set to maintenance mode ; you should run sympa.pl --upgrade");
++}
++
++&tools::ciphersaber_installed();
++
++%::changed_params;
++
++my (%in, $query);
++
++my $birthday = time ;
++
++# Now internal encoding is same as input/output.
++#XXX## Set output encoding
++#XXX## All outgoing strings will be recoded transparently using this charset
++#XXXbinmode STDOUT, ":utf8";
++
++#XXX## Incoming data is utf8-encoded
++#XXXbinmode STDIN, ":utf8";
++
++ ## Main loop
++ my $loop_count;
++ my $start_time = &POSIX::strftime("%d %b %Y at %H:%M:%S", localtime(time));
++ while ($query = &new_loop()) {
++
++ undef %::changed_params;
++
++ undef $param;
++ undef $list;
++ undef $robot;
++ undef $robot_object;
++ undef $ip;
++ undef $rss;
++ undef $session;
++
++ &Log::set_log_level($Conf{'log_level'});
++ &Language::SetLang($Language::default_lang);
++
++ ## Empty cache of the List.pm module
++ &List::init_list_cache();
++
++ ## Check effective ID
++ unless ($> eq (getpwnam(Sympa::Constants::USER))[2]) {
++ $maintenance_mode = 1;
++ &report::reject_report_web('intern_quiet','incorrect_server_config',{},'','');
++ &wwslog('err','Config error: wwsympa should run with UID %s (instead of %s). *** Switching to maintenance mode. ***', (getpwnam(Sympa::Constants::USER))[2], $>);
++ }
++
++ unless (&List::check_db_connect()) {
++ &report::reject_report_web('system_quiet','no_database',{},'','');
++ &do_log('info','WWSympa requires a RDBMS to run');
++ }
++
++ ## If in maintenance mode, check if the data structure is now uptodate
++ if ($maintenance_mode && (&Upgrade::data_structure_uptodate() && ($> eq (getpwnam(Sympa::Constants::USER))[2]))) {
++ $maintenance_mode = undef;
++ &do_log('notice',"Data structure seem updated, setting OFF maintenance mode");
++ }
++
++ ## Get params in a hash
++ # foreach ($query->param) {
++ # $in{$_} = $query->param($_);
++ # }
++ %in = $query->Vars;
++
++ foreach my $k (keys %::changed_params) {
++ &do_log('debug3', 'Changed Param: %s', $k);
++ }
++
++ ## Free terminated sendmail processes
++ # &smtp::reaper;
++
++ ## Parse CGI parameters
++ # &CGI::ReadParse();
++
++ if (defined $Conf{'robot_by_http_host'}{&get_header_field('SERVER_NAME')}) {
++ my ($selected_robot, $selected_path);
++ my ($k,$v);
++ while (($k, $v) = each %{$Conf{'robot_by_http_host'}{&get_header_field('SERVER_NAME')}}) {
++ if ($ENV{'REQUEST_URI'} =~ /^$k/) {
++ ## Longer path wins
++ if (length($k) > length($selected_path)) {
++ ($selected_robot, $selected_path) = ($v, $k);
++ }
++ }
++ }
++ $robot = $selected_robot;
++ }
++
++ $robot = $Conf{'host'} unless $robot;
++
++ ## Create Robot object
++ $robot_object = new Robot $robot;
++
++ ## Default robot
++ if ($robot eq $Conf{'host'}) {
++ $param->{'default_robot'} = 1;
++ }
++
++ $param->{'cookie_domain'} = $Conf{'robots'}{$robot}{'cookie_domain'} if $Conf{'robots'}{$robot};
++ $param->{'cookie_domain'} ||= $wwsconf->{'cookie_domain'};
++ $ip = $ENV{'REMOTE_HOST'};
++ $ip = $ENV{'REMOTE_ADDR'} unless ($ip);
++ $ip = 'undef' unless ($ip);
++ ## In case HTTP_HOST does not match cookie_domain
++ my $http_host = &get_header_field('HTTP_HOST');
++ $http_host =~ s/:\d+$//; ## suppress port
++ unless (($http_host =~ /$param->{'cookie_domain'}$/) ||
++ ($param->{'cookie_domain'} eq 'localhost')) {
++ &wwslog('notice', 'Cookie_domain(%s) does NOT match HTTP_HOST; setting cookie_domain to %s', $param->{'cookie_domain'}, $http_host);
++ $param->{'cookie_domain'} = $http_host;
++ }
++
++ &Log::set_log_level($Conf{'robots'}{$robot}{'log_level'});
++
++ ## Sympa parameters in $param->{'conf'}
++ $param->{'conf'} = {};
++ foreach my $p ('email','host','sympa','request','soap_url','wwsympa_url','listmaster_email','logo_html_definition',
++ 'main_menu_custom_button_1_url','main_menu_custom_button_1_title','main_menu_custom_button_1_target',
++ 'main_menu_custom_button_2_url','main_menu_custom_button_2_title','main_menu_custom_button_2_target',
++ 'main_menu_custom_button_3_url','main_menu_custom_button_3_title','main_menu_custom_button_3_target',
++ 'dark_color','light_color','text_color','bg_color','error_color','use_blacklist','antispam_feature','custom_robot_parameter',
++ 'selected_color','shaded_color','color_0','color_1','color_2','color_3','color_4','color_5','color_6','color_7','color_8','color_9','color_10','color_11','color_12','color_13','color_14','color_15') {
++
++ $param->{'conf'}{$p} = &Conf::get_robot_conf($robot, $p);
++ $param->{$p} = &Conf::get_robot_conf($robot, $p) if (($p =~ /_color$/)|| ($p =~ /color_/));
++ }
++
++
++ foreach my $auth (keys %{$Conf{'cas_id'}{$robot}}) {
++ &do_log('debug2', "cas authentication service $auth");
++ $param->{'sso'}{$auth} = $auth;
++ }
++
++ foreach my $auth (keys %{$Conf{'generic_sso_id'}{$robot}}) {
++ &do_log('debug', "Generic SSO authentication service $auth");
++ $param->{'sso'}{$auth} = $Conf{'auth_services'}{$robot}[$Conf{'generic_sso_id'}{$robot}{$auth}]{'service_name'};
++ }
++
++ $param->{'sso_number'} = $Conf{'cas_number'}{$robot} + $Conf{'generic_sso_number'}{$robot};
++ $param->{'use_passwd'} = $Conf{'use_passwd'}{$robot};
++ $param->{'use_sso'} = 1 if ($param->{'sso_number'});
++ $param->{'authentication_info_url'} = $Conf{'authentication_info_url'}{$robot};
++ $param->{'wwsconf'} = $wwsconf;
++
++ $param->{'path_cgi'} = $ENV{'SCRIPT_NAME'};
++ $param->{'path_cgi'} =~ s/\/\//\//g; ## Replace '//' with '/' because it would break navigation
++ $param->{'version'} = Sympa::Constants::VERSION;
++ $param->{'date'} = gettext_strftime "%d %b %Y at %H:%M:%S", localtime(time);
++ $param->{'time'} = gettext_strftime "%H:%M:%S", localtime(time);
++
++ ## Hash defining the parameters where no control is performed (because they are supposed to contain html and/or javascript).
++ $param->{'htmlAllowedParam'} = {
++ 'title' => 1,
++ 'hidden_head' => 1,
++ 'hidden_end' => 1,
++ 'hidden_at' => 1,
++ 'list_protected_email' => 1,
++ 'selected' => 1,
++ 'author_mailto' =>1,
++ 'mailto' =>1,
++ 'logo_html_definition' => 1,
++ 'template_content' => 1,
++ 'html_dumpvars' => 1,
++ };
++ ## Hash defining the parameters where HTML must be filtered.
++ $param->{'htmlToFilter'} = {
++ 'homepage_content' => 1,
++ 'info_content' => 1,
++ };
++
++ ## Change to list root
++ unless (chdir($Conf{'home'})) {
++ &report::reject_report_web('intern','chdir_error',{},'','','',$robot);
++ &wwslog('info','unable to change directory');
++ exit (-1);
++ }
++
++ ## Sets the UMASK
++ umask(oct($Conf{'umask'}));
++
++ ## Authentication
++ ## use https client certificat information if define.
++
++ ## Default auth method (for scenarios)
++ $param->{'auth_method'} = 'md5';
++
++ &report::init_report_web();
++
++ ## Get PATH_INFO parameters
++ &get_parameters();
++
++ ## CSS related
++ $param->{'css_path'} = &Conf::get_robot_conf($robot, 'css_path');
++ $param->{'css_url'} = &Conf::get_robot_conf($robot, 'css_url');
++ ## If CSS file not found, let Sympa do the job...
++ unless (-f $param->{'css_path'}.'/style.css') {
++ &wwslog('err','Could not find CSS file %s, using default CSS', $param->{'css_path'}.'/style.css') if ($param->{'css_path'}); ## Notice only if path was defined
++ $param->{'css_url'} = $param->{'base_url'}.$param->{'path_cgi'}.'/css';
++ }
++
++ &wwslog('info', "parameter css_url '%s' seems strange, it must be the url of a directory not a css file", $param->{'css_url'}) if ($param->{'css_url'} =~ /\.css$/);
++
++ $session = new SympaSession ($robot,{'cookie'=>&SympaSession::get_session_cookie($ENV{'HTTP_COOKIE'}),
++ 'action'=>$in{'action'},
++ 'rss'=>$rss});
++ undef $ENV{'HTTP_COOKIE'}; # Getting rid of the environment variable to make sure it won't be affected to another anonymous session.
++ unless (defined $session) {
++ &List::send_notify_to_listmaster('failed_to_create_web_session', $robot);
++ &wwslog('info','Failed to create session');
++ $session->{'email'}= 'nobody'; $session->{'id_session'} = &get_random();
++ }
++
++ $param->{'session'} = $session->as_hashref();
++
++ &Log::set_log_level($session->{'log_level'}) if ($session->{'log_level'});
++ $param->{'restore_email'} = $session->{'restore_email'};
++ $param->{'dumpvars'} = $session->{'dumpvars'};
++ $param->{'unauthenticated_email'} = $session->{'unauthenticated_email'};
++
++ if ($session->{'custom_color'} == 1) {
++ foreach my $i (0 .. 15){
++ $param->{'color_'.$i} = $session->{'color_'.$i} if ($session->{'color_'.$i});
++ }
++ }
++
++ ## RSS does not require user authentication
++ unless ($rss) {
++
++ if (($ENV{'SSL_CLIENT_VERIFY'} eq 'SUCCESS') &&
++ ($in{'action'} ne 'sso_login')) { ## Do not check client certificate automatically if in sso_login
++
++ &do_log('debug2', "SSL verified, S_EMAIL = %s,"." S_DN_Email = %s", $ENV{'SSL_CLIENT_S_EMAIL'}, $ENV{'SSL_CLIENT_S_DN_Email'});
++ if (($ENV{'SSL_CLIENT_S_EMAIL'})) {
++ ## this is the X509v3 SubjectAlternativeName, and requires
++ ## a patch to mod_ssl -- cm@coretec.at
++ $param->{'user'}{'email'} = lc($ENV{'SSL_CLIENT_S_EMAIL'});
++ }elsif ($ENV{SSL_CLIENT_S_DN_Email}) {
++ $param->{'user'}{'email'} = lc($ENV{'SSL_CLIENT_S_DN_Email'});
++ }elsif ($ENV{'SSL_CLIENT_S_DN'} =~ /\+MAIL=([^\+\/]+)$/) {
++ ## Compatibility issue with old a-sign.at certs
++ $param->{'user'}{'email'} = lc($1);
++ }elsif ($crypt_openssl_x509_ok and exists($ENV{SSL_CLIENT_CERT})) {
++ ## this is the X509v3 SubjectAlternativeName, and does only
++ ## require "SSLOptions +ExportCertData" without patching
++ ## mod_ssl -- massar@unix-ag.uni-kl.de
++ $param->{'user'}{'email'} = lc(Crypt::OpenSSL::X509->new_from_string($ENV{SSL_CLIENT_CERT})->email());
++ }
++
++ if($param->{user}{email}) {
++ $session->{'email'}= $param->{user}{email} ;
++ $param->{'auth_method'} = 'smime';
++ $session->{'auth'} = 'x509' ;
++ $param->{'ssl_client_s_dn'} = $ENV{'SSL_CLIENT_S_DN'};
++ $param->{'ssl_client_v_end'} = $ENV{'SSL_CLIENT_V_END'};
++ $param->{'ssl_client_i_dn'} = $ENV{'SSL_CLIENT_I_DN'};
++ $param->{'ssl_cipher_usekeysize'} = $ENV{'SSL_CIPHER_USEKEYSIZE'};
++ }
++
++ }elsif (($session->{'email'}) && ($session->{'email'} ne 'nobody')) {
++ $param->{'user'}{'email'} = $session->{'email'};
++ }elsif($in{'ticket'}=~/(S|P)T\-/){ # the request contain a CAS named ticket that use CAS ticket format
++ delete $session->{'do_not_use_cas'}; #reset do_not_use_cas because this client probably use CAS
++ # select the cas server that redirect the user to sympa and check the ticket
++ do_log ('notice',"CAS ticket is detected. in{'ticket'}=$in{'ticket'} checked_cas=$session->{'checked_cas'}");
++
++
++ my $cas_id = '';
++ if ($in{'checked_cas'} =~ /^(\d+)\,?/) {
++ $cas_id = $1;
++ } elsif ($session->{'checked_cas'} =~ /^(\d+)\,?/) {
++ $cas_id = $1;
++ }
++ if ($cas_id ne '') {
++
++ my $ticket = $in{'ticket'};
++ my $cas_server = $Conf{'auth_services'}{$robot}[$cas_id]{'cas_server'};
++
++ my $service_url = &wwslib::get_my_url();
++ $service_url =~ s/(\?|&)ticket\=.+$//;
++
++ my $net_id = $cas_server->validateST($service_url, $ticket);
++
++ if(defined $net_id) { # the ticket is valid net-id
++ do_log('notice',"login CAS OK server netid=$net_id" );
++ $param->{'user'}{'email'} = lc(&Auth::get_email_by_net_id($robot, $cas_id, {'uid' => $net_id}));
++ $session->{'auth'} = 'cas';
++ $session->{'email'}= $param->{user}{email} ;
++
++ $session->{'cas_server'} = $cas_id;
++
++
++ }else{
++ do_log('err',"CAS ticket validation failed : %s", &AuthCAS::get_errors());
++ }
++ }else{
++ do_log ('notice',"Internal error while receiving a CAS ticket $session->{'checked_cas'} ");
++ }
++ }elsif(($Conf{'cas_number'}{$robot} > 0) && ($in{'action'} !~ /^(login|sso_login|wsdl)$/)) { # some cas server are defined but no CAS ticket detected
++ unless ($session->{'do_not_use_cas'}) {
++ # user not taggued as not using cas
++ foreach my $auth_service (@{$Conf{'auth_services'}{$robot}}){
++ next unless ($auth_service->{'auth_type'} eq 'cas'); # skip auth services not related to cas
++ next unless ($auth_service->{'non_blocking_redirection'} eq 'on');
++
++ ## skip cas server where client as been already redirect to the list of cas servers already checked is stored in the session
++ ## the check below works fine as long as we don't have more then 10 CAS servers (because we don't properly split the list of values)
++ &do_log ('debug',"check_cas checker_cas : $session->{'checked_cas'} current cas_id $Conf{'cas_id'}{$robot}{$auth_service->{'auth_service_name'}}");
++ next if ($session->{'checked_cas'} =~ /$Conf{'cas_id'}{$robot}{$auth_service->{'auth_service_name'}}/) ;
++
++ # before redirect update the list of already checked cas server to prevent loop
++ my $cas_server = $auth_service->{'cas_server'};
++ my $return_url = &wwslib::get_my_url();
++
++ ## Append the current CAS server ID to the list of checked CAS servers
++ $session->{'checked_cas'} .= $Conf{'cas_id'}{$robot}{$auth_service->{'auth_service_name'}};
++
++ my $redirect_url = $cas_server->getServerLoginGatewayURL($return_url);
++
++ if ($redirect_url =~ /http(s)+\:\//i) {
++ $in{'action'} = 'redirect';
++ $param->{'redirect_to'} = $redirect_url;
++
++ last
++ }elsif($redirect_url == -1) { # CAS server auth error
++ do_log('notice',"CAS server auth error $auth_service->{'auth_service_name'}" );
++ }else{
++ do_log('notice',"Strange CAS ticket detected and validated check sympa code !" );
++ }
++ }
++ $session->{'do_not_use_cas'} = 1 unless ($param->{'redirect_to'} =~ /http(s)+\:\//i) ; #set do_not_use_cas because all cas servers have been checked without success
++ }
++ }
++
++
++ ##Cookie extern : sympa_altemails
++ ## !!
++ $param->{'alt_emails'} = &cookielib::check_cookie_extern($ENV{'HTTP_COOKIE'},$Conf{'cookie'},$param->{'user'}{'email'});
++
++ if ($param->{'user'}{'email'}) {
++# $param->{'auth'} = $param->{'alt_emails'}{$param->{'user'}{'email'}} || 'classic';
++
++ if (&List::is_user_db($param->{'user'}{'email'})) {
++ $param->{'user'} = &List::get_user_db($param->{'user'}{'email'});
++ }
++
++ ## For the parser to display an empty field instead of [xxx]
++ $param->{'user'}{'gecos'} ||= '';
++ unless (defined $param->{'user'}{'cookie_delay'}) {
++ $param->{'user'}{'cookie_delay'} = $wwsconf->{'cookie_expire'};
++ }
++
++ ## Skip get_which if either in a list context or accessing the CSS
++ unless ($in{'action'} eq 'css' || defined $in{'list'}) {
++ @{$param->{'get_which'}} = &List::get_which($param->{'user'}{'email'},$robot,'member') ;
++ @{$param->{'get_which_owner'}} = &List::get_which($param->{'user'}{'email'},$robot,'owner') ;
++ @{$param->{'get_which_editor'}} = &List::get_which($param->{'user'}{'email'},$robot,'editor') ;
++ }
++# }
++
++ }
++ } ## END if RSS
++
++ ## Action
++ my $action = $in{'action'};
++
++ ## Store current action in the session in order to redirect after a logi or other temporary actions.
++ ## We should not memorize ULRs that are transitory actions
++ ## POST is not handled
++ ## A lot of other methods where used in the past (before session was introduced in Sympa). We must clean all.
++ unless ($temporary_actions{$action} || $ENV{'REQUEST_METHOD'} ne 'GET') {
++ $session->{'redirect_url'} = $param->{'base_url'}.$param->{'path_cgi'}.$ENV{'PATH_INFO'};
++ }
++
++ $action ||= &Conf::get_robot_conf($robot, 'default_home');
++ $param->{'remote_addr'} = $ENV{'REMOTE_ADDR'} ;
++ $param->{'remote_host'} = $ENV{'REMOTE_HOST'};
++ $param->{'http_user_agent'} = $ENV{'HTTP_USER_AGENT'};
++ $param->{'htmlarea_url'} = $wwsconf->{'htmlarea_url'} ;
++ # if ($wwsconf->{'export_topics'} =~ /all/i);
++
++ if ($in{'action'} eq 'css') {
++ &do_css();
++ $param->{'action'} = 'css';
++ }elsif ($maintenance_mode) {
++ &do_maintenance();
++ $param->{'action'} = 'maintenance';
++ }else {
++
++ ## Session loop
++ while ($action) {
++ unless (&check_param_in()) {
++ &report::reject_report_web('user','wrong_param',{},$action,$list);
++ &wwslog('info','Wrong parameters');
++ last;
++ }
++
++ $param->{'host'} = $list->{'admin'}{'host'} if (ref($list) eq 'List');
++ $param->{'host'} ||= $robot;
++ $param->{'domain'} = $list->{'domain'} if (ref($list) eq 'List');
++
++ ## language ( $ENV{'HTTP_ACCEPT_LANGUAGE'} not used !)
++ $param->{'list_lang'} = $list->{'admin'}{'lang'} if (ref($list) eq 'List');
++ $param->{'user_lang'} = $param->{'user'}{'lang'} if (defined $param->{'user'});
++ $param->{'lang'} = $session->{'lang'} || $param->{'user_lang'} || $param->{'list_lang'} || &Conf::get_robot_conf($robot, 'lang');
++
++ $param->{'locale'} = &Language::SetLang($param->{'lang'});
++
++ &export_topics ($robot);
++
++ unless ($comm{$action}) {
++ if (new List ($action, $robot)){
++ &do_redirect ($param->{'base_url'}.$param->{'path_cgi'}.'/info/'.$action);
++ last;
++ }
++ &report::reject_report_web('user','unknown_action',{},$action,$list);
++ &wwslog('info','unknown action %s', $action);
++ last;
++ }
++
++ $param->{'action'} = $action;
++
++ my $old_action = $action;
++ my $old_subaction = $in{'subaction'};
++
++ ## Check required action parameters
++ my $check_output = &check_action_parameters($action);
++
++ if (! defined $check_output ) {
++ &wwslog('err', "missing required parameters for action '$action'");
++ delete($param->{'action'});
++ last;
++
++ }elsif ($check_output != 1) {
++ ## The output of the check may indicate another action to run first
++ ## Example : running loginrequest if user is not authenticated
++ $action = $param->{'action'} = $check_output;
++ }
++
++ ## Execute the action ##
++ if (defined $action) {
++ $action = &{$comm{$action}}();
++ }
++
++ unless (defined $action) {
++ delete($param->{'action'});
++ last;
++ }
++
++ last if ($action =~ /redirect/) ; # after redirect do not send anything, it will crash fcgi lib
++
++
++ if ($action eq $old_action) {
++ # if a subaction is define and change, then it is not a loop
++ if (! defined ($in{'subaction'})||($in{'subaction'} eq $old_subaction)){
++ &wwslog('info','Stopping loop with %s action', $action);
++ #undef $action;
++ $action = 'home';
++ }
++ }
++
++ undef $action if ($action == 1);
++ }
++ }
++
++ ## Prepare outgoing params
++ &check_param_out();
++
++ ## Params
++ $param->{'refparam'} = ref($param);
++ $param->{'action_type'} = $action_type{$param->{'action'}};
++
++ $param->{'action_type'} = 'none' unless (($param->{'is_priv'})||($param->{'action_type'} eq 'serveradmin'));
++ $param->{'lang'} ||= $param->{'user'}{'lang'} if (defined $param->{'user'});
++ $param->{'lang'} ||= &Conf::get_robot_conf($robot, 'lang');
++
++ if ($param->{'list'}) {
++ $param->{'list_title'} = $list->{'admin'}{'subject'};
++ $param->{'list_protected_email'} = &get_protected_email_address($param->{'list'}, $list->{'admin'}{'host'});
++ $param->{'title'} = &get_protected_email_address($param->{'list'}, $list->{'admin'}{'host'});
++ $param->{'title_clear_txt'} = "$param->{'list'}";
++
++ if ($param->{'subtitle'}) {
++ $param->{'main_title'} = "$param->{'list'} - $param->{'subtitle'}";
++ }
++
++ }else {
++ $param->{'main_title'} = $param->{'title'} = &Conf::get_robot_conf($robot,'title');
++ $param->{'title_clear_txt'} = $param->{'title'};
++ }
++ $param->{'robot_title'} = &Conf::get_robot_conf($robot,'title');
++
++ ## store in session table this session contexte
++ $session->store();
++
++ ## Do not manage cookies at this level if content was already sent
++ unless ($param->{'bypass'} eq 'extreme' ||
++ $param->{'action'} eq 'css' ||
++ $maintenance_mode ||
++ $rss) {
++
++ my $delay = $param->{'user'}{'cookie_delay'};
++ unless (defined $delay) {
++ $delay = $wwsconf->{'cookie_expire'};
++ }
++
++ if ($delay == 0) {
++ $delay = 'session';
++ }
++ $session->renew() unless($param->{'use_ssl'});
++
++ unless ($session->set_cookie($param->{'cookie_domain'},$delay,$param->{'use_ssl'})) {
++ &wwslog('notice', 'Could not set HTTP cookie');
++ }
++
++ ## Set cookies "your_subscribtions" unless in one list page
++ if ($param->{'user'}{'email'} && ref($list) ne 'List') {
++
++ ## In case get_which was not set
++ @{$param->{'get_which'}} = &List::get_which($param->{'user'}{'email'},$robot,'member') unless (defined $param->{'get_which'});
++ @{$param->{'get_which_owner'}} = &List::get_which($param->{'user'}{'email'},$robot,'owner') unless (defined $param->{'get_which_owner'});
++ @{$param->{'get_which_editor'}} = &List::get_which($param->{'user'}{'email'},$robot,'editor') unless (defined $param->{'get_which_editor'});
++
++ ## Add lists information to 'which_info'
++ foreach my $list (@{$param->{'get_which'}}) {
++ ## Evaluate AuthZ scenario first
++ my $result = $list->check_list_authz('visibility', $param->{'auth_method'},
++ {'sender' =>$param->{'user'}{'email'} ,
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ next unless (ref($result) eq 'HASH' && $result->{'action'} eq 'do_it');
++
++ my $l = $list->{'name'};
++ $param->{'which_info'}{$l}{'subject'} = $list->{'admin'}{'subject'};
++ $param->{'which_info'}{$l}{'host'} = $list->{'admin'}{'host'};
++ $param->{'which_info'}{$l}{'info'} = 1;
++ }
++ foreach my $list (@{$param->{'get_which_owner'}}) {
++ my $l = $list->{'name'};
++ $param->{'which_info'}{$l}{'subject'} = $list->{'admin'}{'subject'};
++ $param->{'which_info'}{$l}{'host'} = $list->{'admin'}{'host'};
++ $param->{'which_info'}{$l}{'info'} = 1;
++ $param->{'which_info'}{$l}{'admin'} = 1;
++ }
++ foreach my $list (@{$param->{'get_which_editor'}}) {
++ my $l = $list->{'name'};
++
++ $param->{'which_info'}{$l}{'subject'} = $list->{'admin'}{'subject'};
++ $param->{'which_info'}{$l}{'host'} = $list->{'admin'}{'host'};
++ $param->{'which_info'}{$l}{'info'} = 1;
++ $param->{'which_info'}{$l}{'admin'} = 1;
++ }
++ }
++ ## Set cookies unless client use https authentication
++ if ($param->{'user'}{'email'}) {
++ if ($param->{'user'}{'email'} ne 'x509') {
++ $session->{'auth'} ||= 'classic';
++ $param->{'cookie_set'} = 1;
++
++
++ ###Cookie extern : sympa_altemails
++ my $number = 0;
++ foreach my $element (keys %{$param->{'alt_emails'}}){
++ $number ++ if ($element);
++ }
++
++ unless ($number == 0) {
++ unless(&cookielib::set_cookie_extern($Conf{'cookie'},$param->{'cookie_domain'},%{$param->{'alt_emails'}})){
++ &wwslog('notice', 'Could not set HTTP cookie for external_auth');
++ }
++ }
++ }
++ } #elsif ($ENV{'HTTP_COOKIE'} =~ /sympauser\=/){
++ # &cookielib::set_cookie('unknown', $Conf{'cookie'}, $param->{'cookie_domain'}, 'now');
++ #}
++ }
++
++ ## Available languages
++ my $saved_lang = &Language::GetLang();
++
++
++ foreach my $l (@{&Language::GetSupportedLanguages($robot)}) {
++ &Language::SetLang($l) || next;
++
++ if (gettext("_language_")) {
++ $param->{'languages'}{$l}{'complete'} = gettext("_language_");
++ }else {
++ $param->{'languages'}{$l}{'complete'} = $l;
++ }
++
++ if ($param->{'locale'} eq $l) {
++ $param->{'languages'}{$l}{'selected'} = 'selected="selected"';
++ }else {
++ $param->{'languages'}{$l}{'selected'} = '';
++ }
++ }
++
++ &Language::SetLang($saved_lang);
++
++ $param->{'html_dumpvars'} = &tools::dump_html_var($param) if ($session->{'dumpvars'});
++
++ # if bypass is defined select the content-type from various vars
++ if ($param->{'bypass'}) {
++
++ ## if bypass = 'extreme' leave the action send the content-type and the content itself
++ unless ($param->{'bypass'} eq 'extreme') {
++
++ ## if bypass = 'asis', file content-type is in the file itself as is define by the action in $param->{'content_type'};
++ unless ($param->{'bypass'} eq 'asis') {
++ my $type = $param->{'content_type'} || $mime_types->{$param->{'file_extension'}} || 'application/octet-stream';
++ printf "Content-Type: %s\n\n", $type;
++ }
++
++ # $param->{'file'} or $param->{'error'} must be define in this case.
++
++ if (open (FILE, $param->{'file'})){
++ print <FILE>;
++ close FILE;
++ }elsif(&report::is_there_any_reject_report_web()){
++ ## for compatibility : it could be better
++ my $intern = &report::get_intern_error_web();
++ my $system = &report::get_system_error_web();
++ my $user = &report::get_user_error_web();
++ my $auth = &report::get_auth_reject_web();
++
++ if (ref($intern) eq 'ARRAY'){
++ printf "INTERNAL SERVER ERROR\n";
++ };
++ if (ref($system) eq 'ARRAY'){
++ printf "SYSTEM ERROR\n";
++ };
++ if (ref($user) eq 'ARRAY'){
++ foreach my $err (@$user){
++ printf "ERROR : $err\n";
++ }
++ };
++ if (ref($auth) eq 'ARRAY'){
++ foreach my $err (@$auth){
++ printf "AUTHORISATION FAILED : $err\n";
++ }
++ };
++
++ }else{
++ printf "Internal error content-type nor file defined\n";
++ &do_log('err', 'Internal error content-type nor file defined');
++ }
++ }
++
++ }elsif ($rss) {
++ ## Send RSS
++ print "Cache-control: no-cache\n";
++ print "Content-Type: application/rss+xml; charset=utf-8\n\n";
++
++ ## Icons
++ $param->{'icons_url'} = $Conf{'static_content_url'}.'/icons';
++
++ ## Retro compatibility concerns
++ $param->{'active'} = 1;
++
++ if (defined $list) {
++ $param->{'list_conf'} = $list->{'admin'};
++ }
++
++ my $lang = &Language::Lang2Locale($param->{'lang'});
++ my $tt2_include_path = &tools::make_tt2_include_path($robot,'web_tt2',$lang,$list);
++
++ unless (&tt2::parse_tt2($param,'rss.tt2' ,\*STDOUT, $tt2_include_path, {})) {
++ my $error = &tt2::get_error();
++ $param->{'tt2_error'} = $error;
++ unless (&List::send_notify_to_listmaster('web_tt2_error', $robot, [$error])) {
++ &wwslog('notice','Unable to send notify "web_tt2_error" to listmaster');
++ }
++ }
++
++
++# close FILE;
++ }elsif ($param->{'redirect_to'}) {
++ do_log ('notice',"Redirecting to $param->{'redirect_to'}");
++ print "Location: $param->{'redirect_to'}\n\n";
++ }else {
++ &prepare_report_user();
++ &send_html('main.tt2');
++ }
++
++ # exit if wwsympa.fcgi itself has changed
++ if ((stat($ENV{'SCRIPT_FILENAME'}))[9] > $birthday ) {
++ do_log('notice',"Exiting because $ENV{'SCRIPT_FILENAME'} has changed since fastcgi server started");
++ exit(0);
++ }
++
++ }
++
++ ##############################################################
++ #-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/
++ ##############################################################
++
++
++ ## Write to log
++ sub wwslog {
++ my $facility = shift;
++
++ # do not log if log level if too high regarding the log requested by user
++ return if ($Log::levels{$facility} > $Log::log_level);
++
++ my $msg = shift;
++
++ my $remote = $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'};
++
++ ## Determine calling function and parameters
++ my @call = caller(1);
++ $msg = $call[3].'() ' . $msg if ($call[3]);
++
++ $msg = "[list $param->{'list'}] " . $msg
++ if $param->{'list'};
++
++
++ if ($param->{'alt_emails'}) {
++ my @alts;
++ foreach my $alt (keys %{$param->{'alt_emails'}}) {
++ push @alts, $alt
++ unless ($alt eq $param->{'user'}{'email'});
++ }
++
++ if ($#alts >= 0) {
++ my $alt_list = join ',', @alts;
++ $msg = "[alt $alt_list] " . $msg;
++ }
++ }
++
++ $msg = "[user $param->{'user'}{'email'}] " . $msg
++ if $param->{'user'}{'email'};
++
++ $msg = "[rss] ".$msg
++ if $rss;
++
++ $msg = "[client $remote] ".$msg
++ if $remote;
++
++ $msg = "[session $session->{'id_session'}] ".$msg
++ if $session;
++
++ $msg = "[robot $robot] ".$msg;
++
++ return &Log::do_log($facility, $msg, @_);
++ }
++
++sub web_db_log {
++ my $data = shift;
++
++ $data->{'client'} = $param->{'remote_addr'};
++ $data->{'daemon'} = 'wwsympa';
++ $data->{'robot'} ||= $robot;
++ $data->{'list'} ||= $list->{'name'} if (defined $list);
++ $data->{'action'} ||= $param->{'action'};
++ $data->{'user_email'} ||= $param->{'user'}{'email'} if (defined $param->{'user'});
++ $data->{'target_email'} ||= $data->{'user_email'}; ## Default email is the user email
++
++ unless (&Log::db_log($data)) {
++ &wwslog('err','web_db_log: failed to log in database');
++ return undef;
++ }
++
++ return 1;
++}
++
++ sub new_loop {
++ $loop++;
++ my $query;
++
++ if ($wwsconf->{'use_fast_cgi'}) {
++ $query = new CGI::Fast;
++ $loop_count++;
++ }else {
++ return undef if ($loop > 1);
++
++ $query = new CGI;
++ }
++
++ return $query;
++ }
++
++sub get_header_field {
++ my $field = shift;
++
++ ## HTTP_X_ header fields set when using a proxy
++ if ($field eq 'SERVER_NAME') {
++ return $ENV{'HTTP_X_FORWARDED_SERVER'} || $ENV{'SERVER_NAME'};
++ }elsif ($field eq 'HTTP_HOST') {
++ return $ENV{'HTTP_X_FORWARDED_HOST'} || $ENV{'HTTP_HOST'};
++ }else {
++ return $ENV{$field};
++ }
++}
++
++
++
++# _split_params is used by get_parameters to split path info in the appropriate parameters list.
++# It is used also by action ticket to prepare the context stored in the one_time_ticket table in string like path_info
++# input ENV{'PATH_INFO'} like string, output in the global $param hash
++sub _split_params {
++ my $args_string = shift;
++
++ &do_log('debug', "PATH_INFO: %s",$ENV{'PATH_INFO'});
++
++ $args_string =~ s+^/++;
++
++ my $ending_slash = 0;
++ if ($args_string =~ /\/$/) {
++ $ending_slash = 1;
++ }
++
++ my @params = split /\//, $args_string;
++
++ if ($params[0] eq 'nomenu') {
++ $param->{'nomenu'} = 1;
++ $param->{'path_cgi'} .= '/nomenu'; ## other links should keep the nomenu attribute
++ shift @params;
++ }
++
++ ## debug mode
++ if ($params[0] =~ /debug(\d)?/) {
++ shift @params;
++ if ($1) {
++ $main::options{'debug_level'} = $1 if ($1);
++ }else{
++ $main::options{'debug_level'} = 1 ;
++ }
++ }else{
++ $main::options{'debug_level'} = 0 ;
++ }
++ do_log ('debug2', "debug level $main::options{'debug_level'}");
++
++ ## rss mode
++ if ($params[0] eq 'rss') {
++ shift @params;
++ $rss = 1;
++ }
++
++ if ($#params >= 0) {
++ $in{'action'} = $params[0];
++
++ my $args;
++ if (defined $action_args{$in{'action'}}) {
++ $args = $action_args{$in{'action'}};
++ }else {
++ $args = $action_args{'default'};
++ }
++
++ my $i = 1;
++ foreach my $p (@$args) {
++ my $pname;
++ ## More than 1 param
++ if ($p =~ /^\@(\w+)$/) {
++ $pname = $1;
++ $in{$pname} = join '/', @params[$i..$#params];
++ $in{$pname} .= '/' if $ending_slash;
++ last;
++ }
++ else {
++ $pname = $p;
++ $in{$pname} = $params[$i];
++ }
++ &wwslog('debug',"Incoming parameter: $pname=$in{$pname}");
++ $i++;
++ }
++ }
++}
++
++sub get_parameters {
++ # &wwslog('debug3', 'get_parameters');
++
++ ## CGI URL
++ if ($ENV{'HTTPS'} eq 'on') {
++ $param->{'base_url'} = sprintf 'https://%s', &get_header_field('HTTP_HOST');
++ $param->{'use_ssl'} = 1;
++ }else {
++ $param->{'base_url'} = sprintf 'http://%s', &get_header_field('HTTP_HOST');
++ $param->{'use_ssl'} = 0;
++ }
++
++ $param->{'path_info'} = $ENV{'PATH_INFO'};
++ $param->{'http_method'} = $ENV{'REQUEST_METHOD'}; ## Usefull to skip previous_action when using POST
++ $param->{'robot_domain'} = $wwsconf->{'robot_domain'}{&get_header_field('SERVER_NAME')};
++
++ if ($ENV{'REQUEST_METHOD'} eq 'GET') {
++ &_split_params ($ENV{'PATH_INFO'});
++ }elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
++ ## POST
++
++ if ($in{'javascript_action'}) {
++ ## because of incompatibility javascript
++ $in{'action'} = $in{'javascript_action'};
++ }
++ foreach my $p (keys %in) {
++ do_log('debug2',"POST key $p value $in{$p}") unless ($p =~ /passwd/);
++ if ($p =~ /^((\w*)action)_(\w+)((\.\w+)*)$/) {
++
++ $in{$1} = $3;
++ if ($4) {
++ foreach my $v (split /\./, $4) {
++ $v =~ s/^\.?(\w+)\.?/$1/;
++ $in{$v} = 1;
++ }
++ }
++ undef $in{$p};
++ }
++ }
++ $param->{'nomenu'} = $in{'nomenu'};
++ }
++
++ ## Lowercase email addresses
++ $in{'email'} = lc ($in{'email'});
++
++ ## Don't get multiple listnames
++ if ($in{'list'}) {
++ my @lists = split /\0/, $in{'list'};
++ $in{'list'} = $lists[0];
++ }
++
++ my $custom_attribute ;
++ my $custom_input;
++
++ ## Check parameters format
++ foreach my $p (keys %in) {
++
++ ## Skip empty parameters
++ next if ($in{$p} =~ /^$/);
++
++ ## Remove DOS linefeeds (^M) that cause problems with Outlook 98, AOL, and EIMS:
++ $in{$p} =~ s/\015//g;
++
++ #XXX## Convert from the web encoding to unicode string
++ #XXX$in{$p} = Encode::decode('utf8', $in{$p});
++
++ my @tokens = split (/\./, $p);
++ my $pname = $tokens[0];
++
++ ## Regular expressions applied on parameters
++
++ my $regexp;
++ if ($pname =~ /^additional_field/) {
++ $regexp = $in_regexp{'additional_field'};
++ }elsif ($pname =~ /^custom_attribute(.*)$/) {
++ my $key = $tokens[1] ;
++ $regexp = $in_regexp{'custom_attribute'};
++ do_log ('debug2', "get_parameters (custom_attribute) : ($p)($key) $pname $in{$p} $Conf{$key}{type}");
++ $custom_attribute->{$key} = {value=>$in{$p}} ;
++ undef $in{$p} ;
++ }elsif ($pname =~ /^custom_input(.*)$/) {
++ my $key = $tokens[1];
++ $regexp = $in_regexp{'custom_input'};
++ do_log ('debug2', "get_parameters (custom_input) : ($p)($key) $pname $in{$p} $Conf{$key}{type}");
++ $custom_input->{$key} = $in{$p};
++ undef $in{$p};
++ }elsif ($in_regexp{$pname}) {
++ $regexp = $in_regexp{$pname};
++ }else {
++ $regexp = $in_regexp{'*'};
++ }
++
++ my $negative_regexp;
++ if ($pname =~ /^additional_field/) {
++ $negative_regexp = $in_negative_regexp{'additional_field'};
++ }elsif ($in_negative_regexp{$pname}) {
++ $negative_regexp = $in_negative_regexp{$pname};
++ }
++
++ # If we are editing an HTML file in the shared, allow HTML but prevent XSS.
++ if ($pname eq 'content' && $in{'action'} eq 'd_savefile' && $in{'path'} =~ $list->{'dir'}.'/shared' && lc($in{'path'}) =~ /\.html?/) {
++ my $tmpparam = $in{$p};
++ $tmpparam = &tools::sanitize_html('robot' => $robot,
++ 'string' => $in{$p});
++ if (defined $tmpparam) {
++ $in{$p} = $tmpparam;
++ }
++ else {
++ &do_log('err','Unable to sanitize parameter %s',$pname);
++ }
++ }
++ foreach my $one_p (split /\0/, $in{$p}) {
++ if ($one_p !~ /^$regexp$/s ||
++ (defined $negative_regexp && $one_p =~ /$negative_regexp/s) ) {
++ ## Dump parameters in a tmp file for later analysis
++ my $dump_file = &Conf::get_robot_conf($robot, 'tmpdir').'/sympa_dump.'.time.'.'.$$;
++ unless (open DUMP, ">$dump_file") {
++ &wwslog('err','get_parameters: failed to create %s : %s', $dump_file, $!);
++ }
++ &tools::dump_var(\%in, 0, \*DUMP);
++ close DUMP;
++
++ &report::reject_report_web('user','syntax_errors',{'params' => $p},'','');
++ &wwslog('err','get_parameters: syntax error for parameter %s value \'%s\' not conform to regexp:%s ; dumped vars in %s', $pname, $one_p, $regexp, $dump_file);
++ $in{$p} = '';
++ next;
++ }
++ }
++ }
++
++ $in{custom_attribute} = $custom_attribute ;
++ $in{custom_input} = $custom_input;
++
++ ## For shared-related actions, Q-encode filenames
++ ## This required for filenames that include non ascii characters
++ if (defined $filtering{$in{'action'}}) {
++
++ my %apply_to; ## Build list of parameters filters apply to
++ foreach my $p (keys %{$filtering{$in{'action'}}}) {
++ if ($p =~ /\*/) { ## use of wildcar
++ my $p_regexp = $p; $p_regexp =~ s/\*/\.\*/g; ## Turn wildcar into a regexp
++ foreach my $in_key (keys %in) {
++ if ($in_key =~ /^$p_regexp$/) {
++ $apply_to{$in_key} = $filtering{$in{'action'}}{$p};
++ }
++ }
++ }else {
++ $apply_to{$p} = $filtering{$in{'action'}}{$p};
++ }
++ }
++
++ foreach my $p (keys %apply_to) {
++ my $filtering_action = $apply_to{$p};
++ if ($filtering_action eq 'qencode') {
++ ## Q-encode file path
++ my @tokens = split /\//, $in{$p};
++ foreach my $i (0..$#tokens) {
++ $tokens[$i] = &tools::qencode_filename($tokens[$i]);
++ }
++ $in{$p} = join '/', @tokens;
++ ## Sympa's URI escaping subroutine (tools::escape_chars()) replaces '/' with %A5 ('�' character)
++ ## This should be transformed into a '/' again
++
++ }elsif ($filtering_action eq 'unescape_html') {
++ $in{$p} = &tools::unescape_chars($in{$p});
++
++ }elsif ($filtering_action eq 'fix_escape_uri') {
++ $in{$p} =~ s/\xa5/\//g;
++
++ }elsif ($filtering_action eq 'normalize') {
++ $in{$p} =~ s/^\$+//; ## remove leading \s
++ $in{$p} =~ s/\$+$//; ## remove trailing \s
++ $in{$p} = lc($in{$p}); ## lowercase
++ }
++ }
++ }
++
++ return 1;
++ }
++
++sub get_parameters_old {
++ # &wwslog('debug3', 'get_parameters');
++
++ ## CGI URL
++ if ($ENV{'HTTPS'} eq 'on') {
++ $param->{'base_url'} = sprintf 'https://%s', &get_header_field('HTTP_HOST');
++ $param->{'use_ssl'} = 1;
++ }else {
++ $param->{'base_url'} = sprintf 'http://%s', &get_header_field('HTTP_HOST');
++ $param->{'use_ssl'} = 0;
++ }
++
++ $param->{'path_info'} = $ENV{'PATH_INFO'};
++ $param->{'robot_domain'} = $wwsconf->{'robot_domain'}{&get_header_field('SERVER_NAME')};
++
++ if ($ENV{'REQUEST_METHOD'} eq 'GET') {
++ my $path_info = $ENV{'PATH_INFO'};
++ &do_log('debug', "PATH_INFO: %s",$ENV{'PATH_INFO'});
++
++ $path_info =~ s+^/++;
++
++ my $ending_slash = 0;
++ if ($path_info =~ /\/$/) {
++ $ending_slash = 1;
++ }
++
++ my @params = split /\//, $path_info;
++
++
++ # foreach my $i(0..$#params) {
++ # $params[$i] = &tools::unescape_chars($params[$i]);
++ # }
++
++ if ($params[0] eq 'nomenu') {
++ $param->{'nomenu'} = 1;
++ $param->{'path_cgi'} .= '/nomenu'; ## other links should keep the nomenu attribute
++ shift @params;
++ }
++
++ ## debug mode
++ if ($params[0] =~ /debug(\d)?/) {
++ shift @params;
++ if ($1) {
++ $main::options{'debug_level'} = $1 if ($1);
++ }else{
++ $main::options{'debug_level'} = 1 ;
++ }
++ }else{
++ $main::options{'debug_level'} = 0 ;
++ }
++ do_log ('debug2', "debug level $main::options{'debug_level'}");
++
++
++
++ ## rss mode
++########### /^rss$/ ???
++ if ($params[0] eq 'rss') {
++ shift @params;
++ $rss = 1;
++ }
++
++ if ($#params >= 0) {
++ $in{'action'} = $params[0];
++
++ my $args;
++ if (defined $action_args{$in{'action'}}) {
++ $args = $action_args{$in{'action'}};
++ }else {
++ $args = $action_args{'default'};
++ }
++
++ my $i = 1;
++ foreach my $p (@$args) {
++ my $pname;
++ ## More than 1 param
++ if ($p =~ /^\@(\w+)$/) {
++ $pname = $1;
++ $in{$pname} = join '/', @params[$i..$#params];
++ $in{$pname} .= '/' if $ending_slash;
++ last;
++ }
++ else {
++ $pname = $p;
++ $in{$pname} = $params[$i];
++ }
++ $i++;
++ }
++ }
++ }elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
++ ## POST
++
++ if ($in{'javascript_action'}) {
++ ## because of incompatibility javascript
++ $in{'action'} = $in{'javascript_action'};
++ }
++ foreach my $p (keys %in) {
++ do_log('debug2',"POST key $p value $in{$p}");
++ if ($p =~ /^((\w*)action)_(\w+)((\.\w+)*)$/) {
++
++ $in{$1} = $3;
++ if ($4) {
++ foreach my $v (split /\./, $4) {
++ $v =~ s/^\.?(\w+)\.?/$1/;
++ $in{$v} = 1;
++ }
++ }
++
++ undef $in{$p};
++ }
++ }
++
++ $param->{'nomenu'} = $in{'nomenu'};
++ }
++
++ ## Lowercase email addresses
++ $in{'email'} = lc ($in{'email'});
++
++ ## Don't get multiple listnames
++ if ($in{'list'}) {
++ my @lists = split /\0/, $in{'list'};
++ $in{'list'} = $lists[0];
++ }
++
++
++ my $custom_attribute ;
++
++ ## Check parameters format
++ foreach my $p (keys %in) {
++
++ ## Skip empty parameters
++ next if ($in{$p} =~ /^$/);
++
++ ## Remove DOS linefeeds (^M) that cause problems with Outlook 98, AOL, and EIMS:
++ $in{$p} =~ s/\015//g;
++
++ #XXX## Convert from the web encoding to unicode string
++ #XXX$in{$p} = Encode::decode('utf8', $in{$p});
++
++ my @tokens = split (/\./, $p);
++ my $pname = $tokens[0];
++
++ ## Regular expressions applied on parameters
++
++ my $regexp;
++ if ($pname =~ /^additional_field/) {
++ $regexp = $in_regexp{'additional_field'};
++ }elsif ($pname =~ /^custom_attribute(.*)$/) {
++ my $key = $tokens[1] ;
++ $regexp = $in_regexp{'custom_attribute'};
++ do_log ('debug2', "get_parameters (custom_attribute) : ($p)($key) $pname $in{$p} $Conf{$key}{type}");
++ $custom_attribute->{$key} = {value=>$in{$p}} ;
++ undef $in{$p} ;
++
++ }elsif ($in_regexp{$pname}) {
++ $regexp = $in_regexp{$pname};
++ }else {
++ $regexp = $in_regexp{'*'};
++ }
++
++ my $negative_regexp;
++ if ($pname =~ /^additional_field/) {
++ $negative_regexp = $in_negative_regexp{'additional_field'};
++ }elsif ($in_negative_regexp{$pname}) {
++ $negative_regexp = $in_negative_regexp{$pname};
++ }
++
++ # If we are editing an HTML file in the shared, allow HTML but prevent XSS.
++ if ($pname eq 'content' && $in{'action'} eq 'd_savefile' && $in{'path'} =~ $list->{'dir'}.'/shared' && lc($in{'path'}) =~ /\.html?/) {
++ my $tmpparam = $in{$p};
++ $tmpparam = &tools::sanitize_html('robot' => $robot,
++ 'string' => $in{$p});
++ if (defined $tmpparam) {
++ $in{$p} = $tmpparam;
++ }
++ else {
++ &do_log('err','Unable to sanitize parameter %s',$pname);
++ }
++ }
++
++ foreach my $one_p (split /\0/, $in{$p}) {
++ if ($one_p !~ /^$regexp$/s ||
++ (defined $negative_regexp && $one_p =~ /$negative_regexp/s) ) {
++ ## Dump parameters in a tmp file for later analysis
++ my $dump_file = &Conf::get_robot_conf($robot, 'tmpdir').'/sympa_dump.'.time.'.'.$$;
++ unless (open DUMP, ">$dump_file") {
++ &wwslog('err','get_parameters: failed to create %s : %s', $dump_file, $!);
++ }
++ &tools::dump_var(\%in, 0, \*DUMP);
++ close DUMP;
++
++ &report::reject_report_web('user','syntax_errors',{'params' => $p},'','');
++ &wwslog('err','get_parameters: syntax error for parameter %s value \'%s\' not conform to regexp:%s ; dumped vars in %s', $pname, $one_p, $regexp, $dump_file);
++ $in{$p} = '';
++ next;
++ }
++ }
++ }
++
++ $in{custom_attribute} = $custom_attribute ;
++
++ ## For shared-related actions, Q-encode filenames
++ ## This required for filenames that include non ascii characters
++ if (defined $filtering{$in{'action'}}) {
++
++ foreach my $p (keys %{$filtering{$in{'action'}}}) {
++ if ($filtering{$in{'action'}}{$p} eq 'qencode') {
++ ## Q-encode file path
++ my @tokens = split /\//, $in{$p};
++ foreach my $i (0..$#tokens) {
++ $tokens[$i] = &tools::qencode_filename($tokens[$i]);
++ }
++ $in{$p} = join '/', @tokens;
++ ## Sympa's URI escaping subroutine (tools::escape_chars()) replaces '/' with %A5 ('�' character)
++ ## This should be transformed into a '/' again
++
++ }elsif ($filtering{$in{'action'}}{$p} eq 'fix_escape_uri') {
++ $in{$p} =~ s/\xa5/\//g;
++ }
++ }
++ }
++
++ return 1;
++ }
++
++## Check required parameters for an action
++## It compares incoming parameter to those declared as required in %required_args
++## Also check required privileges to perform each action
++sub check_action_parameters {
++ my $action = shift;
++
++ if (defined $required_args{$action}) {
++ foreach my $arg_name (@{$required_args{$action}}) {
++
++ ## Missing list parameter
++ if ($arg_name eq 'param.list') {
++ unless (defined $list) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$action);
++ &wwslog('info','missing list parameter');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'no_list'});
++
++ return undef;
++ }
++
++ ## User is not authenticated
++ }elsif ($arg_name eq 'param.user.email') {
++ unless (defined $param->{'user'} && $param->{'user'}{'email'}) {
++ &report::reject_report_web('user','no_user',{},$action);
++ &wwslog('err','user not logged in');
++ &web_db_log({'status' => 'error',
++ 'error_type' => "not_logged_in"});
++
++ ## User is redirected to the login request form
++ $param->{'previous_action'} = $action;
++ $param->{'previous_list'} = $param->{'list'} if (defined $param->{'list'});
++ return 'loginrequest';
++
++ }
++ ## Other incoming parameters
++ }else {
++ ## There may be alternate parameters
++ ## Then at least one of them MUST be set
++ my @req_parameters = split(/\|/, $arg_name);
++ my $ok = 0;
++ foreach my $req_param (@req_parameters) {
++ $ok =1 if ($in{$req_param});
++ }
++ unless ($ok) {
++ ## Replace \0 and '|' with ',' before logging
++ $in{$arg_name} =~ s/\0/,/g;
++ $in{$arg_name} =~ s/\|/,/g;
++
++ &report::reject_report_web('user','missing_arg',{'argument' => $arg_name},$action);
++ &wwslog('info',"missing parameter '$arg_name'");
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'missing_parameter'});
++ return undef;
++ }
++ }
++ }
++ }
++
++ ## Check required privileges
++ if (defined $required_privileges{$action}) {
++ ## There may be alternate privileges
++ ## Then at least one of them MUST verified
++ my $ok = 0;
++ my $missing_priv;
++ foreach my $req_priv (@{$required_privileges{$action}}) {
++ $ok =1 if ($param->{'is_'.$req_priv});
++ $missing_priv = $req_priv;
++ }
++ unless ($ok) {
++ &report::reject_report_web('auth','action_'.$missing_priv,{},$param->{'action'},$list);
++ &wwslog('info','authorization failed, insufficient privileges');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++ }
++
++ return 1;
++}
++
++## Send HTML output
++sub send_html {
++
++ my $tt2_file = shift;
++
++ ## Send HTML
++ if ($param->{'date'}) {
++ Language::PushLang("en_US");
++ printf "Date: %s\n", &POSIX::strftime('%a, %d %b %Y %R %z',localtime(time));
++ Language::PopLang();
++ }
++ ## If we set the header indicating the last time the file to send was modified, add an HTTP header (limitate web harvesting).
++ if ($param->{'header_date'}) {
++ Language::PushLang("en_US");
++ printf "Last-Modified: %s\n", &POSIX::strftime('%a, %d %b %Y %R %z',localtime($param->{'header_date'}));
++ Language::PopLang();
++ }
++ print "Cache-control: no-cache\n" unless ( $param->{'action'} eq 'arc') ;
++ print "Content-Type: text/html\n\n";
++
++ ## Icons
++ $param->{'icons_url'} = $Conf{'static_content_url'}.'/icons';
++
++
++ ## Retro compatibility concerns
++ $param->{'active'} = 1;
++
++ if (defined $list) {
++ $param->{'list_conf'} = $list->{'admin'};
++ }
++
++ ## Trying to use custom_vars
++ if (defined $list->{'admin'}{'custom_vars'}) {
++ foreach my $var (@{$list->{'admin'}{'custom_vars'}}) {
++ $param->{'custom_vars'}{$var->{'name'}} = $var->{'value'};
++ }
++ }
++
++ my $lang = &Language::Lang2Locale($param->{'lang'});
++ my $tt2_include_path = &tools::make_tt2_include_path($robot,'web_tt2',$lang,$list);
++
++ # XSS escaping applied to all outgoing parameters.
++ my $param_copy = &tools::dup_var($param); ## Escape parameters on a copy to avoid altering usefull data.
++ if(defined $param_copy) {
++ unless(&tools::sanitize_var('var' => $param_copy,
++ 'level' => 0,
++ 'robot' => $robot,
++ 'htmlAllowedParam' => $param_copy->{'htmlAllowedParam'} ,
++ 'htmlToFilter' => $param_copy->{'htmlToFilter'} ,
++ )
++ )
++ {
++ &do_log('err','Failed to sanitize $param in host %s', $robot);
++ }
++ }
++
++ unless (&tt2::parse_tt2($param_copy,$tt2_file , \*STDOUT, $tt2_include_path, {})) {
++ my $error = &tt2::get_error();
++ $param->{'tt2_error'} = $error;
++ $param_copy->{'tt2_error'} = $error;
++ &List::send_notify_to_listmaster('web_tt2_error', $robot, [$error]);
++ &tt2::parse_tt2($param_copy,'tt2_error.tt2' , \*STDOUT, $tt2_include_path);
++ }
++}
++
++sub prepare_report_user {
++
++ $param->{'intern_errors'} = &report::get_intern_error_web();
++ $param->{'system_errors'} = &report::get_system_error_web();
++ $param->{'user_errors'} = &report::get_user_error_web();
++ $param->{'auth_rejects'} = &report::get_auth_reject_web();
++ $param->{'notices'} = &report::get_notice_web();
++ $param->{'errors'} = &report::is_there_any_reject_report_web();
++}
++
++
++
++
++=pod
++
++=head2 sub check_param_in
++
++Checks parameters contained in the global variable $in. It is the process used to analyze the incoming parameters.
++Use it to create a List object and initialize output parameters.
++
++=head3 Arguments
++
++=over
++
++=item * I<None>
++
++=back
++
++=head3 Return
++
++=over
++
++=item * I<undef> if the process encounters problems.
++
++=item * I<1> if everything goes well
++
++=back
++
++=head3 Calls
++
++=over
++
++=item * d_access_control
++
++=item * make_pictures_url
++
++=item * wwslog
++
++=item * Language::SetLang
++
++=item * List::am_i
++
++=item * List::check_list_authz
++
++=item * List::get_mod_spool_size
++
++=item * List::get_shared_moderated
++
++=item * List::get_subscriber
++
++=item * List::get_subscription_request_count
++
++=item * List::get_total
++
++=item * List::get_total_bouncing
++
++=item * List::is_listmaster
++
++=item * List::is_moderated
++
++=item * List::is_user
++
++=item * List::new
++
++=item * List::request_action
++
++=item * report::reject_report_web
++
++=back
++
++=cut
++
++ ## Analysis of incoming parameters
++ sub check_param_in {
++ &wwslog('debug2', 'check_param_in');
++
++ ## Lowercase list name
++ $in{'list'} =~ tr/A-Z/a-z/;
++
++ ## In case the variable was multiple
++ if ($in{'list'} =~ /^(\S+)\0/) {
++ $in{'list'} = $1;
++
++ ## Create a new List instance.
++ unless ($list = new List ($in{'list'}, $robot)) {
++ &report::reject_report_web('user','unknown_list',{'list' => $in{'list'}},$param->{'action'},'');
++ &wwslog('info','check_param_in: unknown list %s', $in{'list'});
++ return undef;
++ }
++
++ ## Set lang to list lang
++ &Language::SetLang($list->{'admin'}{'lang'});
++ }
++
++ ## listmaster has owner and editor privileges for the list
++ if (&List::is_listmaster($param->{'user'}{'email'},$robot)) {
++ $param->{'is_listmaster'} = 1;
++ }
++
++ if ($in{'list'}) {
++ ## Create a new List instance.
++ unless ($list = new List ($in{'list'}, $robot, {})) {
++ &report::reject_report_web('user','unknown_list',{'list' => $in{'list'}},$param->{'action'},'');
++ &wwslog('info','check_param_in: unknown list %s', $in{'list'});
++ return undef;
++ }
++
++ ## Gather list configuration informations for further output.
++ $param->{'list'} = $in{'list'};
++ $param->{'subtitle'} = $list->{'admin'}{'subject'};
++ $param->{'subscribe'} = $list->{'admin'}{'subscribe'}{'name'};
++ $param->{'send'} = $list->{'admin'}{'send'}{'title'}{$param->{'lang'}};
++
++ # Pictures are not available unless it is configured for the list and the robot
++ if ($list->{'admin'}{'pictures_feature'} eq 'off') {
++ $param->{'pictures_display'} = undef;
++ }
++ else {
++ $param->{'pictures_display'} = 'on';
++ }
++
++ ## Get the total number of subscribers to the list.
++ if (defined $param->{'total'}) {
++ $param->{'total'} = $list->get_total();
++ }else {
++ $param->{'total'} = $list->get_total('nocache');
++ }
++
++ ## Check if the current list has a public key X.509 certificate.
++ $param->{'list_as_x509_cert'} = $list->{'as_x509_cert'};
++
++ ## Stores to output the whole list's admin configuration.
++ $param->{'listconf'} = $list->{'admin'};
++
++ ## If an user is logged in, checks this user's privileges.
++ if ($param->{'user'}{'email'}) {
++ $param->{'is_subscriber'} = $list->is_user($param->{'user'}{'email'});
++ $param->{'subscriber'} = $list->get_subscriber($param->{'user'}{'email'})
++ if $param->{'is_subscriber'};
++ $param->{'is_privileged_owner'} = $param->{'is_listmaster'} || $list->am_i('privileged_owner', $param->{'user'}{'email'});
++ $param->{'is_owner'} = $param->{'is_privileged_owner'} || $list->am_i('owner', $param->{'user'}{'email'});
++ $param->{'is_editor'} = $list->am_i('editor', $param->{'user'}{'email'});
++ $param->{'is_priv'} = $param->{'is_owner'} || $param->{'is_editor'};
++ $param->{'pictures_url'} = &tools::make_pictures_url('email' => $param->{'user'}{'email'}, 'list' => $list);
++
++ ## Checks if the user can post in this list.
++ my $result = $list->check_list_authz('send',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $r_action;
++ $r_action = $result->{'action'} if (ref($result) eq 'HASH');
++ $param->{'may_post'} = 1 if ($r_action !~ /reject/);
++
++ ## If no user logged in, the output can ask for authentification.
++ }else {
++ $param->{'user'}{'email'} = undef;
++ $param->{'need_login'} = 1;
++
++ }
++
++ ## Check if this list's messages must be moderated.
++ $param->{'is_moderated'} = $list->is_moderated();
++
++ ## If the user logged in is a privileged user, gather informations relative to administration tasks
++ if ($param->{'is_priv'}) {
++ $param->{'mod_message'} = $list->get_mod_spool_size();
++
++ $param->{'mod_subscription'} = $list->get_subscription_request_count();
++
++ $param->{'doc_mod_list'} = $list->get_shared_moderated();
++ $param->{'mod_total_shared'} = $#{$param->{'doc_mod_list'}} + 1;
++
++ if ($param->{'total'} > 0) {
++ $param->{'bounce_total'} = $list->get_total_bouncing();
++ $param->{'bounce_rate'} = $param->{'bounce_total'} * 100 / $param->{'total'};
++ $param->{'bounce_rate'} = int ($param->{'bounce_rate'} * 10) / 10;
++ }else {
++ $param->{'bounce_rate'} = 0;
++ }
++ $param->{'mod_total'} = $param->{'mod_total_shared'}+$param->{'mod_message'}+$param->{'mod_subscription'};
++ }
++
++
++ ## Check unsubscription authorization for the current user and list.
++ my $result = $list->check_list_authz('unsubscribe',$param->{'auth_method'},
++ {'sender' =>$param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ $main::action = $result->{'action'} if (ref($result) eq 'HASH');
++
++ if (! $param->{'user'}{'email'}) {
++ $param->{'may_signoff'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
++
++ }elsif ($param->{'is_subscriber'}) {
++ $param->{'may_signoff'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
++ $param->{'may_suboptions'} = 1;
++ }
++
++ ## Check subscription authorization for the current user and list.
++ my $result = $list->check_list_authz('subscribe',$param->{'auth_method'},
++ {'sender' =>$param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ $main::action = $result->{'action'} if (ref($result) eq 'HASH');
++
++ $param->{'may_subscribe'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
++
++
++ ## Check if the current user can read the shared documents.
++ my %mode;
++ $mode{'read'} = 1;
++ my %access = &d_access_control(\%mode,"");
++ $param->{'may_d_read'} = $access{'may'}{'read'};
++
++ ## Check the status (exists, deleted, doesn't exist) of the shared directory
++ $param->{'shared'} = $list->get_shared_status();
++ }
++
++ ## Check if the current user can create a list.
++ my $result = &Scenario::request_action ('create_list',$param->{'auth_method'},$robot,
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $r_action;
++ my $reason;
++ if (ref($result) eq 'HASH') {
++ $r_action = $result->{'action'};
++ $reason = $result->{'reason'};
++ }
++ $param->{'create_list_reason'} = $reason;
++
++ if ($param->{'user'}{'email'} &&
++ (($param->{'create_list'} = $r_action ) =~ /do_it|listmaster/)) {
++ $param->{'may_create_list'} = 1;
++ }else{
++ undef ($param->{'may_create_list'});
++ }
++
++ return 1;
++
++ }
++
++ ## Prepare outgoing params
++ sub check_param_out {
++ &wwslog('debug2', 'check_param_out');
++
++ $param->{'loop_count'} = $loop_count;
++ $param->{'start_time'} = $start_time;
++ $param->{'process_id'} = $$;
++
++ ## listmaster has owner and editor privileges for the list
++ if (&List::is_listmaster($param->{'user'}{'email'},$robot)) {
++ $param->{'is_listmaster'} = 1;
++ }else {
++ undef $param->{'is_listmaster'};
++ }
++
++ ## Reset $list variable if it is not expected for the current action
++ ## To prevent the list panel from being printed in a non list context
++ ## Only check if the corresponding entry exists in %action_args
++ if (defined $param->{'action'} && defined $action_args{$param->{'action'}}) {
++ unless (grep /^list$/, @{$action_args{$param->{'action'}}}) {
++ $param->{'list'} = undef;
++ $list = undef;
++ }
++ }
++
++ ## Email addresses protection
++
++ if (defined $list) {
++ if ($list->{'admin'}{'spam_protection'} eq 'at') {
++ $param->{'hidden_head'} = ''; $param->{'hidden_at'} = ' AT '; $param->{'hidden_end'} = '';
++ }elsif($list->{'admin'}{'spam_protection'} eq 'javascript') {
++ $param->{'protection_type'} = 'javascript';
++ $param->{'hidden_head'} = '
++ <script type="text/javascript">
++ <!--
++ document.write("';
++ $param->{'hidden_at'} ='" + "@" + "';
++ $param->{'hidden_end'} ='")
++ // -->
++ </script>';
++ }else {
++ $param->{'hidden_head'} = ''; $param->{'hidden_at'} = '@'; $param->{'hidden_end'} = '';
++ }
++ }else {
++ if (&Conf::get_robot_conf($robot,'spam_protection') eq 'at') {
++ $param->{'hidden_head'} = ''; $param->{'hidden_at'} = ' AT '; $param->{'hidden_end'} = '';
++ }elsif(&Conf::get_robot_conf($robot,'spam_protection') eq 'javascript') {
++ $param->{'protection_type'} = 'javascript';
++ $param->{'hidden_head'} = '
++ <script type="text/javascript">
++ <!--
++ document.write("';
++ $param->{'hidden_at'} ='" + "@" + "';
++ $param->{'hidden_end'} ='")
++ // -->
++ </script>';
++ }else {
++ $param->{'hidden_head'} = ''; $param->{'hidden_at'} = '@'; $param->{'hidden_end'} = '';
++ }
++ }
++
++ if ($list->{'name'}) {
++ &wwslog('debug2', "list-name $list->{'name'}");
++
++ ## Email addresses protection
++ if ($in{'action'} eq 'arc') {
++ $param->{'protection_type'} = undef;
++ if ($list->{'admin'}{'web_archive_spam_protection'} eq 'at') {
++ $param->{'hidden_head'} = ''; $param->{'hidden_at'} = ' AT '; $param->{'hidden_end'} = '';
++ }elsif($list->{'admin'}{'web_archive_spam_protection'} eq 'javascript') {
++ $param->{'protection_type'} = 'javascript';
++ $param->{'hidden_head'} = '
++ <script type="text/javascript">
++ <!--
++ document.write("';
++ $param->{'hidden_at'} ='" + "@" + "';
++ $param->{'hidden_end'} ='")
++ // -->
++ </script>';
++ }else {
++ $param->{'hidden_head'} = ''; $param->{'hidden_at'} = '@'; $param->{'hidden_end'} = '';
++ }
++ }else {
++ if ($list->{'admin'}{'spam_protection'} eq 'at') {
++ $param->{'hidden_head'} = ''; $param->{'hidden_at'} = ' AT '; $param->{'hidden_end'} = '';
++ }elsif($list->{'admin'}{'spam_protection'} eq 'javascript') {
++ $param->{'hidden_head'} = '
++ <script type="text/javascript">
++ <!--
++ document.write("';
++ $param->{'hidden_at'} ='" + "@" + "';
++ $param->{'hidden_end'} ='")
++ // -->
++ </script>';
++ }else {
++ $param->{'hidden_head'} = ''; $param->{'hidden_at'} = '@'; $param->{'hidden_end'} = '';
++ }
++ }
++
++ ## Owners
++ my $owners = $list->get_owners();
++ foreach my $o (@{$owners}) {
++ next unless $o->{'email'};
++ $param->{'owner'}{$o->{'email'}}{'gecos'} = $o->{'gecos'};
++ $param->{'owner'}{$o->{'email'}}{'visibility'} = $o->{'visibility'};
++ $param->{'owner'}{$o->{'email'}}{'mailto'} = &mailto($list,$o->{'email'},$o->{'gecos'});
++ ($param->{'owner'}{$o->{'email'}}{'local'},$param->{'owner'}{$o->{'email'}}{'domain'}) = split ('@',$o->{'email'});
++ my $masked_email = $o->{'email'};
++ $masked_email =~ s/\@/ AT /;
++ $param->{'owner'}{$o->{'email'}}{'masked_email'} = $masked_email;
++ }
++
++ ## Editors
++ if (defined $list->{'admin'}{'editor'}) {
++ my $editors = $list->get_editors();
++ foreach my $e (@{$editors}) {
++ next unless $e->{'email'};
++ $param->{'editor'}{$e->{'email'}}{'gecos'} = $e->{'gecos'};
++ $param->{'editor'}{$e->{'email'}}{'visibility'} = $e->{'visibility'};
++ $param->{'editor'}{$e->{'email'}}{'mailto'} = &mailto($list,$e->{'email'},$e->{'gecos'});
++ ($param->{'editor'}{$e->{'email'}}{'local'},$param->{'editor'}{$e->{'email'}}{'domain'}) = split ('@',$e->{'email'});
++ my $masked_email = $e->{'email'};
++ $masked_email =~ s/\@/ AT /;
++ $param->{'editor'}{$e->{'email'}}{'masked_email'} = $masked_email;
++ }
++ }
++
++ ## Environment variables
++ foreach my $k (keys %ENV) {
++ $param->{'env'}{$k} = $ENV{$k};
++ }
++ ## privileges
++ if ($param->{'user'}{'email'}) {
++ $param->{'is_subscriber'} = $list->is_user($param->{'user'}{'email'});
++ $param->{'subscriber'} = $list->get_subscriber($param->{'user'}{'email'})
++ if $param->{'is_subscriber'};
++ $param->{'is_privileged_owner'} = $param->{'is_listmaster'} || $list->am_i('privileged_owner', $param->{'user'}{'email'});
++ $param->{'is_owner'} = $param->{'is_privileged_owner'} || $list->am_i('owner', $param->{'user'}{'email'});
++ $param->{'is_editor'} = $list->am_i('editor', $param->{'user'}{'email'});
++ $param->{'is_priv'} = $param->{'is_owner'} || $param->{'is_editor'};
++
++ #May post:
++ my $result = $list->check_list_authz('send',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++
++ my $r_action;
++ my $reason;
++ if (ref($result) eq 'HASH') {
++ $r_action = $result->{'action'};
++ $reason = $result->{'reason'};
++ }
++
++ if ($r_action =~ /do_it/) {
++ $param->{'may_post'} = 1 ;
++ }else {
++ $param->{'may_post_reason'} = $reason;
++ }
++
++
++ if (($list->{'admin'}{'user_data_source'} eq 'include2') &&
++ $list->has_include_data_sources() &&
++ $param->{'is_owner'}) {
++ $param->{'may_sync'} = 1;
++ }
++ }else {
++ ## If user not logged in && GET method && not an authN-related action
++ ## Keep track of the 'referer' parameter
++ if ($ENV{'REQUEST_METHOD'} eq 'GET' &&
++ ! $auth_action{$in{'action'}} ) {
++ $param->{'referer'} = &tools::escape_chars(&wwslib::get_my_url());
++ }else {
++ ## Keep the previous value of the referer
++ $param->{'referer'} = $in{'referer'};
++ }
++ }
++
++ ## Should Not be used anymore ##
++ $param->{'may_subunsub'} = 1
++ if ($param->{'may_signoff'} || $param->{'may_subscribe'});
++
++ ## May review
++ my $result = $list->check_list_authz('review',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $r_action;
++ $r_action = $result->{'action'} if (ref($result) eq 'HASH');
++
++ $param->{'may_suboptions'} = 1 unless ($list->{'admin'}{'user_data_source'} eq 'include');
++ $param->{'total'} = $list->get_total();
++ $param->{'may_review'} = 1 if ($r_action =~ /do_it/);
++ $param->{'list_status'} = $list->{'admin'}{'status'};
++
++ ## May signoff
++ my $result = $list->check_list_authz('unsubscribe',$param->{'auth_method'},
++ {'sender' =>$param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ $main::action = $result->{'action'} if (ref($result) eq 'HASH');
++
++ if (! $param->{'user'}{'email'}) {
++ $param->{'may_signoff'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
++
++ }elsif ($param->{'is_subscriber'} &&
++ ($param->{'subscriber'}{'subscribed'} == 1)) {
++ $param->{'may_signoff'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
++ $param->{'may_suboptions'} = 1;
++ }
++
++ ## May Subscribe
++ my $result = $list->check_list_authz('subscribe',$param->{'auth_method'},
++ {'sender' =>$param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ $main::action = $result->{'action'} if (ref($result) eq 'HASH');
++
++ $param->{'may_subscribe'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
++
++
++
++ ## Archives Access control
++ if (defined $list->{'admin'}{'web_archive'}) {
++ $param->{'is_archived'} = 1;
++
++ ## Check if the current user may access web archives
++ my $result = $list->check_list_authz('web_archive.access',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $r_action;
++ $r_action = $result->{'action'} if (ref($result) eq 'HASH');
++
++ if ($r_action =~ /do_it/i) {
++ $param->{'arc_access'} = 1;
++ }else{
++ undef ($param->{'arc_access'});
++ }
++
++ ## Check if web archive is publically accessible (useful information for RSS)
++ my $result = $list->check_list_authz('web_archive.access',$param->{'auth_method'},
++ {'sender' => 'nobody'});
++ my $r_action;
++ $r_action = $result->{'action'} if (ref($result) eq 'HASH');
++
++ if ($r_action =~ /do_it/i) {
++ $param->{'arc_public_access'} = 1;
++ }
++ }
++
++ ## Shared documents access control
++ if ($list->get_shared_status() eq 'exist') {
++ ## Check if shared is publically accessible (useful information for RSS)
++ my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
++ {'sender' => 'nobody'});
++ my $r_action;
++ if (ref($result) eq 'HASH') {
++ $r_action = $result->{'action'};
++ }
++
++ if ($r_action =~ /do_it/i) {
++ $param->{'shared_public_access'} = 1;
++ }
++
++ }
++ }
++
++ $param->{'robot'} = $robot;
++
++ ## If parameter has the Unicode Perl flag, then switch to utf-8
++ ## this switch is applied recursively
++ &tools::recursive_transformation($param, \&tools::unicode_to_utf8);
++
++ }
++
++## ticket : this action is used if someone submits a one time ticket
++sub do_ticket {
++ &wwslog('info', 'do_ticket(%s)', $in{'ticket'});
++
++ $param->{'ticket_context'} = &Auth::get_one_time_ticket($in{'ticket'}, $ip );
++ $param->{'ticket_context'}{'printable_date'} = gettext_strftime "%d %b %Y at %H:%M:%S", localtime($param->{'ticket_context'}{'date'});
++
++ return 1 unless ($param->{'ticket_context'}{'result'} eq 'success' or $param->{'ticket_context'}{'result'} eq 'closed');
++
++ # if the ticket is related to someone which is not logged in, the system performs the same operation as for a login
++ my $email_regexp = &tools::get_regexp('email');
++ if ($param->{'ticket_context'}{'result'} eq 'success') {
++ $session->{'email'} = lc($param->{'ticket_context'}{'email'});
++ $param->{'user'} = &List::get_user_db($session->{'email'});
++ $param->{'user'}{'email'} = $session->{'email'} ;
++ $param->{'last_login _host'} = $param->{'user'}{'last_login_host'};
++ $param->{'last_login_date'} = &POSIX::strftime("%d %b %Y at %H:%M:%S", localtime($param->{'user'}{'last_login_date'})) if ($param->{'user'}{'last_login_date'});
++ &List::update_user_db($param->{'user'}{'email'},{last_login_date =>time(),last_login_host=>$ip }) ;
++ }elsif($param->{'ticket_context'}{'result'} eq 'closed'){
++ &wwslog('info', 'do_ticket(%s) : Refusing to perform login because the ticket has been used before', $in{'ticket'});
++ return 1;
++ }else{
++ &wwslog('err', 'do_ticket(%s) : Unable to evaluate the ticket validity (status: %s)', $in{'ticket'}, $param->{'ticket_context'}{'result'});
++ return 1;
++ }
++ &_split_params($param->{'ticket_context'}{'data'});
++ return $in{'action'} ;
++
++}
++
++
++ ## Login WWSympa
++ sub do_login {
++ &wwslog('info', 'do_login(%s)', $in{'email'});
++ my $user;
++ my $next_action;
++
++ if ($in{'referer'}) {
++ $param->{'redirect_to'} = &tools::unescape_chars($in{'referer'});
++ }elsif ($in{'previous_action'} &&
++ $in{'previous_action'} !~ /^(login|logout|loginrequest)$/) {
++ $next_action = $in{'previous_action'};
++ $in{'list'} = $in{'previous_list'};
++ }else {
++ $next_action = 'home';
++ }
++ # never return to login or logout when login.
++ $next_action = 'home' if ($in{'next_action'} eq 'login') ;
++ $next_action = 'home' if ($in{'next_action'} eq 'logout') ;
++
++ if ($param->{'user'}{'email'}) {
++ &report::reject_report_web('user','already_login',{'email' => $param->{'user'}{'email'}},$param->{'action'},'');
++ &wwslog('info','do_login: user %s already logged in', $param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'email'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'already_login'});
++ if ($param->{'nomenu'}) {
++ $param->{'back_to_mom'} = 1;
++ return 1;
++ }else {
++ return $next_action;
++ }
++ }
++
++ unless ($in{'email'}) {
++ &report::reject_report_web('user','no_email',{},$param->{'action'},'');
++ &wwslog('info','do_login: no email');
++ &web_db_log({'parameters' => $in{'email'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => "no_email"});
++ return $in{'previous_action'} || 'home';
++ }
++
++ $session->{'unauthenticated_email'} = $param->{'unauthenticated_email'} = $in{'email'};
++
++ unless ($in{'passwd'}) {
++ my $url_redirect;
++ #Does the email belongs to an ldap directory?
++ if($url_redirect = &is_ldap_user($in{'email'})){
++ $param->{'redirect_to'} = $url_redirect
++ if ($url_redirect && ($url_redirect != 1));
++ }elsif ($in{'failure_referer'}) {
++ $param->{'redirect_to'} = $in{'failure_referer'};
++ }else{
++ $in{'init_email'} = $in{'email'};
++ $param->{'init_email'} = $in{'email'};
++ $param->{'escaped_init_email'} = &tools::escape_chars($in{'email'});
++
++ &report::reject_report_web('user','missing_arg',{'argument' => 'passwd'},$param->{'action'},'');
++ &wwslog('info','do_login: missing parameter passwd');
++ &web_db_log({'parameters' => $in{'email'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => "missing_parameter"});
++ $param->{'login_error'} = 'missing_password';
++ return $in{'previous_action'} || 'renewpasswd';
++ }
++ }
++
++ my $data;
++
++ unless ($ENV{'REQUEST_METHOD'} eq 'POST') {
++ &do_log('notice', "Authentication failed, because do not use HTTP method POST but %s",$ENV{'REQUEST_METHOD'} );
++ &web_db_log({'parameters' => $in{'email'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'not_using_post'});
++ return 'loginrequest';
++ }
++
++
++ unless($data = &Auth::check_auth($robot, $in{'email'},$in{'passwd'})){
++ &do_log('notice', "Authentication failed\n");
++ &web_db_log({'parameters' => $in{'email'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'authentication'});
++ my $unauthenticated_user = &List::get_user_db($in{'email'});
++ if ($unauthenticated_user->{'wrong_login_count'} > &Conf::get_robot_conf($robot, 'max_wrong_password')){
++ $param->{'login_error'} = 'password_reset';
++ }else{
++ $param->{'login_error'} = 'wrong_password';
++ }
++ if ($in{'previous_action'}) {
++ delete $in{'passwd'};
++ $in{'list'} = $in{'previous_list'};
++ return $in{'previous_action'};
++ }elsif ($in{'failure_referer'}) {
++ $param->{'redirect_to'} = $in{'failure_referer'};
++ }else {
++ return 'renewpasswd';
++ }
++ }
++ $param->{'user'} = $data->{'user'};
++ $param->{'last_login_host'} = $data->{'user'}{'last_login_host'};
++ $param->{'last_login_date'} = &POSIX::strftime("%d %b %Y at %H:%M:%S", localtime($data->{'user'}{'last_login_date'})) if ($data->{'user'}{'last_login_date'});
++ $session->{'auth'} = $data->{'auth'};
++ my $email = lc($param->{'user'}{'email'});
++ $session->{'email'} = $email;
++ $session->{'unauthenticated_email'} = '';
++
++ &List::update_user_db($param->{'user'}{'email'},{last_login_date =>time(),last_login_host=>$ip, wrong_login_count =>0}) ;
++
++ ## Set alt_email
++ if ($data->{'alt_emails'}) {
++ foreach my $k (keys %{$data->{'alt_emails'}}) {
++ $param->{'alt_emails'}{$k} = $data->{'alt_emails'}{$k};
++ }
++ }
++
++
++ unless($param->{'alt_emails'}{$email}){
++ unless(&cookielib::set_cookie_extern($Conf{'cookie'},$param->{'cookie_domain'},%{$param->{'alt_emails'}})){
++ &wwslog('notice', 'Could not set HTTP cookie for external_auth');
++ &web_db_log({'parameters' => "$Conf{'cookie'},$param->{'cookie_domain'},%{$param->{'alt_emails'}}",
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'cookie'});
++ return undef;
++ }
++ }
++
++ ## Current authentication mode
++ #$param->{'auth'} = $param->{'alt_emails'}{$param->{'user'}{'email'}} || 'classic';
++
++
++ if ($session->{'lang'}) { # user did choose a specific language before being logged. Apply it as a user pref.
++ &List::update_user_db($param->{'user'}{'email'},{lang=>$session->{'lang'}}) ;
++ $param->{'lang'} = $session->{'lang'};
++ }else{ # user did not choose a specific language, apply user pref for this session.
++ $param->{'lang'} = $user->{'lang'} || $list->{'admin'}{'lang'} || &Conf::get_robot_conf($robot, 'lang');
++ $session->{'lang'} = $param->{'lang'} ;
++ }
++
++ if ($session->{'review_page_size'}) { # user did choose a specific page size upgrade prefs
++ &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
++ }
++
++ if ($session->{'shared_mode'}) { # user did choose a shared expert/standard mode
++ &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
++ }
++
++ if ($in{'newpasswd1'} && $in{'newpasswd2'}) {
++ my $old_action = $param->{'action'};
++ $param->{'action'} = 'setpasswd';
++ &do_setpasswd();
++ $param->{'action'} = $old_action;
++ }
++
++ if ($param->{'nomenu'}) {
++ $param->{'back_to_mom'} = 1;
++ return 1;
++ }
++ &web_db_log({'parameters' => $in{'email'},
++ 'target_email' => $in{'email'},
++ 'status' => 'success'});
++
++ &do_redirect ($session->{'redirect_url'});
++ return ;
++
++ }
++
++## Login WWSympa
++## The sso_login action is made of 4 subactions that make a complete workflow.
++## Note that this comlexe workflow is only used if the SSO server does not provide
++## the user email address or if this email address is not trusted and therefore
++## needs to be checked.
++## The workflow:
++## 1) init: determine if email address needs to be collected/checked
++## 2) requestemail: collect the user email address in a web form. Note that form may be initialized with
++## one email address provided by the SSO server
++## 3) validateemail: a challenge is sent to the email address to validate it
++## 4) confirmemail: user confirms his email address with the challenge
++sub do_sso_login {
++ &wwslog('info', 'do_sso_login(%s)', $in{'auth_service_name'});
++
++ delete $session->{'do_not_use_cas'}; #when user require CAS login, reset do_not_use_cas cookie
++ my $next_action;
++
++ if ($param->{'user'}{'email'}) {
++ &report::reject_report_web('user','already_login',{'email' => $param->{'user'}{'email'}},$param->{'action'},'');
++ &wwslog('err','do_login: user %s already logged in', $param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++ 'status' => 'error',
++ 'error_type' => "already_login"});
++ return 'home';
++ }
++
++
++ ## This is a CAS service
++ if (defined (my $cas_id = $Conf{'cas_id'}{$robot}{$in{'auth_service_name'}})) {
++ my $cas_server = $Conf{'auth_services'}{$robot}[$cas_id]{'cas_server'};
++
++ my $path = '';
++ if ($param->{'nomenu'}) {
++ $path = "/nomenu";
++ }
++ $path .= "/sso_login_succeeded/$in{'auth_service_name'}";
++
++ $session->{'checked_cas'} = $cas_id;
++ my $service = "$param->{'base_url'}$param->{'path_cgi'}".$path;
++
++ my $redirect_url = $cas_server->getServerLoginURL($service);
++ &wwslog('info', 'do_sso_login: redirect_url(%s)', $redirect_url);
++ if ($redirect_url =~ /http(s)+\:\//i) {
++ $in{'action'} = 'redirect';
++ $param->{'redirect_to'} = $redirect_url;
++ $param->{'bypass'} = 'extreme';
++ $session->set_cookie('localhost','session');
++ print "Location: $param->{'redirect_to'}\n\n";
++ }
++
++ }elsif (defined (my $sso_id = $Conf{'generic_sso_id'}{$robot}{$in{'auth_service_name'}})) {
++ ## Generic SSO
++
++ ## If contacted via POST, then redirect the user to the URL for the access control to apply
++ if ($ENV{'REQUEST_METHOD'} eq 'POST') {
++ my $path = '';
++ my $service;
++
++ if ($param->{'nomenu'}) {
++ $path = "/nomenu";
++ }
++ &wwslog('info', 'do_sso_login(): POST request processing');
++
++ if ($in{'subaction'} eq 'validateemail') {
++ $path .= "/validateemail/$in{'email'}";
++
++ }elsif ($in{'subaction'} eq 'confirmemail') {
++
++ $path .= "/confirmemail/$in{'email'}/$in{'ticket'}";
++
++ }else {
++
++ $path .= "/init";
++ }
++
++ my $service = "$param->{'base_url'}$param->{'path_cgi'}/sso_login/$in{'auth_service_name'}".$path;
++
++ &wwslog('info', 'do_sso_login: redirect user to %s', $service);
++ $in{'action'} = 'redirect';
++ $param->{'redirect_to'} = $service;
++ $param->{'bypass'} = 'extreme';
++ print "Location: $param->{'redirect_to'}\n\n";
++
++ return 1;
++ }
++
++ my $email;
++ ## We need to collect/verify the user's email address
++ if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'force_email_verify'}) {
++ my $email_is_trusted = 0;
++
++ ## the subactions order is : init, requestemail, validateemail, sendssopasswd, confirmemail
++
++ ## get email from NetiD table
++ if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'internal_email_by_netid'}) {
++ &wwslog('debug', 'do_sso_login(): lookup email internal: %s', $sso_id);
++ if ($email = &Auth::get_email_by_net_id($robot, $sso_id, \%ENV)) {
++ $email_is_trusted = 1;
++ }
++ }
++
++ ## get email from authN module
++ if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'} && ! $email_is_trusted) {
++ my @email_list = split(/$Conf{'auth_services'}{$robot}[$sso_id]{'http_header_value_separator'}/,
++ lc($ENV{$Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'}}));
++ $email = $email_list[0]; ## Only get the first occurence if multi-valued
++ }
++
++ ## Start the email validation process
++ if ($in{'subaction'} eq 'init' &&
++ ($email_is_trusted == 0 || ! $email)) {
++ &wwslog('info', 'do_sso_login(): return request email');
++ $session->{'auth'} = 'generic_sso';
++ $param->{'server'}{'key'} = $in{'auth_service_name'};
++ $param->{'subaction'} = 'requestemail';
++ $param->{'init_email'} = $email;
++ return 1;
++ }
++
++ if (defined($in{'email'}) and !($in{'subaction'} eq 'init')) {
++ $email = $in{'email'};
++ }
++
++ ## Send a confirmation email and request it on the web interface
++ if ($in{'subaction'} eq 'validateemail') {
++ $session->{'auth'} = 'generic_sso';
++ $param->{'server'}{'key'} = $in{'auth_service_name'};
++ $param->{'init_email'} = $email;
++
++ ## Replace sendpassword with one time ticket
++ $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'email'},$robot,'sso_login/confirmemail?auth_service_name='.$in{'auth_service_name'},$ip);
++
++ unless (&sendssopasswd($email)) {
++ &report::reject_report_web('user','incorrect_email',{'email' => $email},$param->{'action'});
++ $param->{'subaction'} = 'requestemail';
++ return 1;
++ }
++
++ $param->{'subaction'} = 'validateemail';
++ return 1;
++ }
++
++ if ($in{'subaction'} eq 'confirmemail') {
++ $session->{'auth'} = 'generic_sso' ;
++ $param->{'server'}{'key'} = $in{'auth_service_name'};
++ $param->{'init_email'} = $email;
++ $in{'email'} = $email;
++
++ #
++ # Check input parameters and verify ticket for email, stolen from do_login
++ #
++ unless ($in{'email'}) {
++ &report::reject_report_web('user','no_email',{},$param->{'action'});
++ &wwslog('info','confirmemail: no email');
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'no_email'});
++ $param->{'subaction'} = 'validateemail';
++ return 1;
++ }
++
++ unless ($in{'ticket'}) {
++ $in{'init_email'} = $in{'email'};
++ $param->{'init_email'} = $in{'email'};
++ $param->{'escaped_init_email'} = &tools::escape_chars($in{'email'});
++
++ &report::reject_report_web('user','missing_arg',{'argument' => 'ticket'},$param->{'action'});
++ &wwslog('info','do_sso_login: confirmemail: missing parameter ticket');
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'missing_parameter'});
++ $param->{'subaction'} = 'validateemail';
++ return 1;
++ }
++
++ ## Validate the ticket
++ my $ticket_output = &Auth::get_one_time_ticket($in{'ticket'}, $ip );
++ unless ($ticket_output->{'result'} eq 'success'){
++ &report::reject_report_web('user','auth_failed',{},$param->{'action'});
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'authentication'});
++ &wwslog('err', "Authentication failed\n");
++
++ $param->{'subaction'} = 'validateemail';
++ return 1;
++ }
++
++ &wwslog('info', 'do_sso_login: confirmemail: email validation succeeded');
++ # need to create netid to email map entry
++ $email = $in{'email'};
++
++ # everything is ok to proceed to with possible sympa account created and traddional sso login
++
++ ## TODO : netidmap_table should also be used when no confirmation is performed
++ if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'internal_email_by_netid'}) {
++
++ my $netid = $ENV{$Conf{'auth_services'}{$robot}[$sso_id]{'netid_http_header'}};
++ my $idpname = $Conf{'auth_services'}{$robot}[$sso_id]{'service_id'};
++
++ unless(&List::set_netidtoemail_db($robot, $netid, $idpname, $in{'email'})) {
++ &report::reject_report_web('intern','db_update_failed',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err', 'error update netid map');
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return 'home';
++ }
++
++ }else {
++ &wwslog('info', 'do_sso_login: confirmemail: validation failed');
++
++ $param->{'subaction'} = 'validateemail';
++ return 1;
++ }
++ }
++
++ }else {
++ ##
++ if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'}) {
++ my @email_list = split($Conf{'auth_services'}{$robot}[$sso_id]{'http_header_value_separator'},
++ lc($ENV{$Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'}}));
++ $email = $email_list[0]; ## Only get the first occurence if multi-valued
++
++ }else {
++ unless (defined $Conf{'auth_services'}{$robot}[$sso_id]{'ldap_host'} &&
++ defined $Conf{'auth_services'}{$robot}[$sso_id]{'ldap_get_email_by_uid_filter'}) {
++ &report::reject_report_web('intern','auth_conf_no_identified_user',{},$param->{'action'},'','',$robot);
++ &wwslog('err','do_sso_login: auth.conf error : either email_http_header or ldap_host/ldap_get_email_by_uid_filter entries should be defined');
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return 'home';
++ }
++
++ $email = &Auth::get_email_by_net_id($robot, $sso_id, \%ENV);
++ }
++ }
++
++ unless ($email) {
++ &report::reject_report_web('intern','no_identified_user',{},$param->{'action'},'','',$robot);
++ &wwslog('err','do_sso_login: user could not be identified, no %s HTTP header set', $Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'});
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++
++ 'status' => 'error',
++ 'error_type' => 'no_email'});
++ return 'home';
++ }
++
++ $param->{'user'}{'email'} = $email;
++ $session->{'email'} = $email;
++ $session->{'auth'} = 'generic_sso' ;
++
++ &wwslog('notice', 'User identified as %s', $email);
++
++ ## There are two ways to list the attributes that Sympa will cache for the user
++ ## Either with a defined header prefix (http_header_prefix)
++ ## Or with an explicit list of header fields (http_header_list)
++ my @sso_attr;
++ if ($Conf{'auth_services'}{$robot}[$sso_id]{'http_header_list'}) {
++ my $list_of_headers = $Conf{'auth_services'}{$robot}[$sso_id]{'http_header_list'};
++
++ foreach my $field (split(/,/, $list_of_headers)) {
++ if (defined $ENV{$field}) {
++ push @sso_attr, "$field=$ENV{$field}";
++ }
++ }
++
++ }elsif ($Conf{'auth_services'}{$robot}[$sso_id]{'http_header_list'}) {
++
++ my $prefix = $Conf{'auth_services'}{$robot}[$sso_id]{'http_header_prefix'};
++
++ foreach my $k (keys %ENV) {
++ if ($k =~ /^$prefix/) {
++ push @sso_attr, "$k=$ENV{$k}";
++ }
++ }
++ }
++
++ my $all_sso_attr = join ';', @sso_attr;
++
++ ## Create user entry if required
++ unless (&List::is_user_db($email)) {
++ unless (&List::add_user_db({'email' => $email})) {
++ &report::reject_report_web('intern','add_user_db_failed',{'user'=>$email},$param->{'action'},'',$email,$robot);
++ &wwslog('info','do_sso_login: add failed');
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++
++ unless (&List::update_user_db($email,
++ {'attributes' => $all_sso_attr })) {
++ &report::reject_report_web('intern','update_user_db_failed',{'user'=>$email},$param->{'action'},'',$email,$robot);
++ &wwslog('info','do_sso_login: update failed');
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ &report::notice_report_web('you_have_been_authenticated',{},$param->{'action'});
++
++ ## Keep track of the SSO used to login
++ ## Required to provide logout feature if available
++ $session->{'sso_id'} = $in{'auth_service_name'};
++
++ &do_redirect ($session->{'redirect_url'});
++ return ;
++ }else{
++ ## Unknown SSO service
++ &report::reject_report_web('intern','unknown_authentication_service',{'name'=> $in{'auth_service_name'}},$param->{'action'},'','',$robot);
++ &wwslog('err','do_sso_login: unknown authentication service %s', $in{'auth_service_name'});
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return 'home';
++ }
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++ 'target_email' => $in{'email'},
++ 'status' => 'success'});
++ return 1;
++}
++
++sub do_sso_login_succeeded {
++ &wwslog('info', 'do_sso_login_succeeded(%s)', $in{'auth_service_name'});
++
++ if (defined $param->{'user'} && $param->{'user'}{'email'}) {
++ &report::notice_report_web('you_have_been_authenticated',{},$param->{'action'});
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++ 'status' => 'success'});
++
++ }else{
++ &report::reject_report_web('user','auth_failed',{},$param->{'action'});
++ &web_db_log({'parameters' => $in{'auth_service_name'},
++ 'status' => 'error',
++ 'error_type' => 'authentication'});
++ }
++
++ ## We should refresh the main window
++ if ($param->{'nomenu'}) {
++ $param->{'back_to_mom'} = 1;
++ return 1;
++ }else{
++ &do_redirect ($session->{'redirect_url'});
++ return;
++ }
++}
++
++ sub is_ldap_user {
++ my $auth = shift; ## User email or UID
++ &wwslog('debug2',"is_ldap_user ($auth)");
++
++ unless (&tools::get_filename('etc',{}, 'auth.conf', $robot)) {
++ return undef;
++ }
++
++ ## List all LDAP servers first
++ my @ldap_servers;
++ foreach my $ldap (@{$Conf{'auth_services'}{$robot}}){
++ next unless ($ldap->{'auth_type'} eq 'ldap');
++
++ push @ldap_servers, $ldap;
++ }
++
++ unless ($#ldap_servers >= 0) {
++ return undef;
++ }
++
++ unless (eval "require Net::LDAP") {
++ &wwslog ('err',"Unable to use LDAP library, Net::LDAP required,install perl-ldap (CPAN) first");
++ return undef;
++ }
++ require Net::LDAP;
++
++ my ($ldap_anonymous,$filter);
++
++ foreach my $ldap (@ldap_servers){
++
++ # skip ldap auth service if the user id or email do not match regexp auth service parameter
++ next unless ($auth =~ /$ldap->{'regexp'}/i);
++
++ my $param = &tools::dup_var($ldap);
++ my $ds = new Datasource('LDAP', $param);
++
++ unless (defined $ds && ($ldap_anonymous = $ds->connect())) {
++ &do_log('err',"Unable to connect to the LDAP server '%s'", $ldap->{'ldap_host'});
++ next;
++ }
++
++ my @alternative_conf = split(/,/,$ldap->{'alternative_email_attribute'});
++ my $attrs = $ldap->{'email_attribute'};
++
++ if (&tools::valid_email($auth)){
++ $filter = $ldap->{'get_dn_by_email_filter'};
++ }else{
++ $filter = $ldap->{'get_dn_by_uid_filter'};
++ }
++ $filter =~ s/\[sender\]/$auth/ig;
++
++ ## !! une fonction get_dn_by_email/uid
++
++ my $mesg = $ldap_anonymous->search(base => $ldap->{'suffix'} ,
++ filter => "$filter",
++ scope => $ldap->{'scope'},
++ timeout => $ldap->{'timeout'} );
++
++ unless($mesg->count() != 0) {
++ &wwslog('notice','No entry in the Ldap Directory Tree of %s for %s',$ldap->{'host'},$auth);
++ $ds->disconnect();
++ last;
++ }
++
++ $ds->disconnect();
++ my $redirect = $ldap->{'authentication_info_url'};
++ return $redirect || 1;
++
++ next unless ($ldap_anonymous);
++ }
++ }
++
++ ## send back login form
++ sub do_loginrequest {
++ &wwslog('info','do_loginrequest');
++
++ if ($param->{'user'}{'email'}) {
++ &report::reject_report_web('user','already_login',{'email' => $param->{'user'}{'email'}},$param->{'action'});
++ &wwslog('info','do_loginrequest: already logged in as %s', $param->{'user'}{'email'});
++ return undef;
++ }
++
++ if ($in{'init_email'}) {
++ $param->{'init_email'} = $in{'init_email'};
++ }
++
++ if ($in{'previous_action'} eq 'referer') {
++ $param->{'referer'} = &tools::escape_chars($ENV{'HTTP_REFERER'});
++ }elsif (! $param->{'previous_action'}) {
++ $param->{'previous_action'} = 'loginrequest';
++ }
++
++ $param->{'title'} = 'Login'
++ if ($param->{'nomenu'});
++
++
++ return 1;
++ }
++
++ ## Help / about WWSympa
++ sub do_help {
++ &wwslog('info','do_help(%s)', $in{'help_topic'});
++
++ ## Contextual help
++ if ($in{'help_topic'}) {
++ if ($in{'help_topic'} eq 'editlist') {
++ foreach my $pname (sort List::by_order keys %{$pinfo}) {
++ next if ($pname =~ /^(comment|defaults)$/);
++
++ if ($pinfo->{$pname}{'gettext_id'}) {
++ $param->{'param'}{$pname}{'title'} = gettext($pinfo->{$pname}{'gettext_id'});
++ } else {
++ $param->{'param'}{$pname}{'title'} = $pinfo->{$pname}{'title'}{$param->{'lang'}};
++ }
++ $param->{'param'}{$pname}{'comment'} = $pinfo->{$pname}{'comment'}{$param->{'lang'}};
++ }
++ }
++
++ $param->{'help_topic'} = $in{'help_topic'};
++ }
++
++ return 1;
++ }
++
++# update session cookie and redirect the client to redirect_to parameter or glob var;
++sub do_redirect {
++
++ my $redirect_to = shift;
++ &wwslog('info','do_redirect(%s)', $redirect_to);
++
++ $redirect_to ||= $param->{'redirect_to'};
++ # because of some bug Sympa did redirection to un empty URL. Next line should prevent it.
++ $redirect_to ||= $param->{'base_url'}.$param->{'path_cgi'};
++
++ $session->set_cookie('localhost','session');
++ print "Location: $redirect_to\n\n";
++ $param->{'bypass'} = 'extreme';
++ return 1;
++}
++
++ ## Logout from WWSympa
++ sub do_logout {
++ &wwslog('info','do_logout(%s)', $param->{'user'}{'email'});
++
++ delete $param->{'user'};
++ $session->{'email'} = 'nobody' ;
++
++ # no reason to alter the lang because user perform logout
++ # $param->{'lang'} = $param->{'cookie_lang'} = &cookielib::check_lang_cookie($ENV{'HTTP_COOKIE'}) || $list->{'admin'}{'lang'} || &Conf::get_robot_conf($robot, 'lang');
++
++ if (defined $session->{'cas_server'} && (defined $Conf{'auth_services'}{$robot}[$session->{'cas_server'}])) {
++ # this user was logged using CAS
++ my $cas_server = $Conf{'auth_services'}{$robot}[$session->{'cas_server'}]{'cas_server'};
++
++ $in{'action'} = 'redirect';
++ my $return_url = &wwslib::get_my_url();
++ $return_url =~ s/\/logout//;
++
++ $param->{'redirect_to'} = $cas_server->getServerLogoutURL($return_url);
++
++ delete $session->{'cas_server'};
++ return 'redirect';
++ } elsif (defined $session->{'sso_id'}) {
++ # this user was logged using a generic_sso
++
++ ## Check if logout_url is known for this SSO
++ my $sso;
++ unless ($sso = &Conf::get_sso_by_id(robot => $robot, service_id => $session->{'sso_id'})) {
++
++ &wwslog('err',"unknown SSO service_id '%s'", $session->{'sso_id'});
++ return undef ;
++ }
++
++ ## Remove sso_id
++ delete $session->{'sso_id'};
++
++ if ($sso->{'logout_url'}) {
++
++ $in{'action'} = 'redirect';
++ $param->{'redirect_to'} = $sso->{'logout_url'};
++
++ return 'redirect';
++ }
++ }
++
++ &wwslog('info','do_logout: logout performed');
++ &web_db_log({'parameters' => $param->{'user'}{'email'},
++ 'target_email' => $in{'email'},
++ 'status' => 'success'});
++
++ if ($in{'previous_action'} eq 'referer') {
++ $param->{'referer'} = &tools::escape_chars($in{'previous_list'});
++ }
++
++ return 'home';
++ }
++
++sub sendssopasswd {
++ my $email = shift;
++ do_log('info', 'sendssopasswd(%s)', $email);
++
++ my ($passwd, $user);
++
++ unless ($email) {
++ &report::reject_report_web('user','no_email',{},$param->{'action'});
++ &wwslog('info','do_sendssopasswd: no email');
++ &web_db_log({'parameters' => $email,
++ 'target_email' => $email,
++ 'status' => 'error',
++ 'error_type' => "no_email"});
++ return 'requestemail';
++ }
++
++ unless (&tools::valid_email($email)) {
++ &report::reject_report_web('user','incorrect_email',{'email' => $email},$param->{'action'});
++ &wwslog('info','do_sendssopasswd: incorrect email %s', $email);
++ &web_db_log({'parameters' => $email,
++ 'target_email' => $email,
++ 'status' => 'error',
++ 'error_type' => "incorrect_email"});
++
++ return 'requestemail';
++ }
++
++ my $url_redirect;
++
++ if ($param->{'newuser'} = &List::get_user_db($email)) {
++
++ ## Create a password if none
++ unless ($param->{'newuser'}{'password'}) {
++ unless ( &List::update_user_db($email,
++ {'password' => &tools::tmp_passwd($email)
++ })) {
++ &report::reject_report_web('intern','db_update_failed',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','sendssopasswd: update failed');
++ &web_db_log({'parameters' => $email,
++ 'target_email' => $email,
++ 'status' => 'error',
++ 'error_type' => "internal"});
++ return undef;
++ }
++ $param->{'newuser'}{'password'} = &tools::tmp_passwd($email);
++ }
++
++ $param->{'newuser'}{'escaped_email'} = &tools::escape_chars($param->{'newuser'}{'email'});
++
++ }else {
++
++ $param->{'newuser'} = {'email' => $email,
++ 'escaped_email' => &tools::escape_chars($email),
++ 'password' => &tools::tmp_passwd($email)
++ };
++
++ }
++
++ $param->{'init_passwd'} = 1
++ if ($param->{'user'}{'password'} =~ /^init/);
++
++ &List::send_global_file('sendssopasswd', $email, $robot, $param);
++
++
++ $param->{'email'} = $email;
++ &web_db_log({'parameters' => $email,
++ 'target_email' => $email,
++ 'status' => 'success'});
++
++ return 'validateemail';
++}
++sub do_firstpasswd {
++ &wwslog('info', 'do_firstpasswd(%s)', $in{'email'});
++ $param->{'requestpasswd_context'} = 'firstpasswd';
++ return 'renewpasswd';
++}
++ ## send a ticket for choosing a new password
++sub do_renewpasswd {
++ &wwslog('info', 'do_renewpasswd(%s)', $in{'email'});
++
++ my $url_redirect;
++ if($in{'email'}){
++ if($url_redirect = &is_ldap_user($in{'email'})){
++ $param->{'redirect_to'} = $url_redirect
++ if ($url_redirect && ($url_redirect != 1));
++ }elsif (! &tools::valid_email($in{'email'})) {
++ &report::reject_report_web('user','incorrect_email',{'email' => $in{'email'}},$param->{'action'});
++ &wwslog('info','do_renewpasswd: incorrect email \"%s\"', $in{'email'});
++ &web_db_log({'parameters' => $in{'email'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'incorrect_email'});
++ return undef;
++ }
++ }
++
++ $param->{'email'} = $in{'email'};
++ &web_db_log({'parameters' => $in{'email'},
++ 'target_email' => $in{'email'},
++ 'status' => 'success',
++ });
++
++ if ($in{'previous_action'} eq 'referer') {
++ $param->{'referer'} = &tools::escape_chars($in{'previous_list'});
++ }
++ return 1;
++ }
++
++####################################################
++# do_requestpasswd
++####################################################
++# Sends a message to the user containing user password.
++#
++# IN : -
++#
++# OUT : 'renewpasswd' | 1 | 'loginrequest' | undef
++#
++####################################################
++ sub do_requestpasswd {
++ &wwslog('info', 'do_requestpasswd(%s)', $in{'email'});
++ my ($passwd, $user);
++
++ $param->{'account_creation'} = 1;
++
++ my $url_redirect;
++ if($url_redirect = &is_ldap_user($in{'email'})){
++ ## There might be no authentication_info_url URL defined in auth.conf
++ if ($url_redirect == 1) {
++ &report::reject_report_web('user','ldap_user',{},$param->{'action'});
++ &wwslog('info','do_requestpasswd: LDAP user %s, cannot remind password', $in{'email'});
++ &web_db_log({'parameters' => $in{'email'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return 'home';
++ }else{
++ $param->{'redirect_to'} = $url_redirect if ($url_redirect && ($url_redirect != 1));
++ return 1;
++ }
++ }
++
++ ## Check auth.conf before creating/sending a password
++ unless (&Auth::may_use_sympa_native_auth($robot, $in{'email'})) {
++ ## TODO: Error handling
++ &report::reject_report_web('user','passwd_reminder_not_allowed',{},$param->{'action'});
++ return undef
++ }
++ &wwslog('debug','do_requestpasswd: sending one tile ticket for %s', $in{'email'});
++ $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'email'},$robot,'choosepasswd',$ip);
++ $param->{'request_from_host'} = $ip;
++ $param->{'newuser'} = &List::get_user_db($in{'email'});
++ if ($param->{'one_time_ticket'}) {
++ $param->{'login_error'}='ticket_sent';
++ unless (&List::send_global_file('sendpasswd', $in{'email'}, $robot, $param)) {
++ &wwslog('notice',"Unable to send template 'sendpasswd' to $in{'email'}");
++ $param->{'login_error'}='unable_to_send_ticket';
++ }
++ }else{
++ &wwslog('notice',"Unable to create_one_time_ticket");
++ &report::reject_report_web('user','passwd_reminder_error',{},$param->{'action'});
++ $param->{'login_error'}='unable_to_create_ticket';
++ }
++
++ return 1 unless ($param->{'previous_action'}) ;
++ return $param->{'previous_action'};
++ }
++
++ ## Which list the user is subscribed to
++ ## TODO (pour listmaster, toutes les listes)
++ sub do_which {
++ my $which = {};
++
++ &wwslog('info', 'do_which');
++
++
++ $param->{'get_which'} = undef ;
++ $param->{'which'} = undef ;
++
++ foreach my $role ('member','owner','editor') {
++
++ foreach my $list ( &List::get_which($param->{'user'}{'email'}, $robot, $role) ){
++ my $l = $list->{'name'};
++
++ my $result = $list->check_list_authz('visibility', $param->{'auth_method'},
++ {'sender' =>$param->{'user'}{'email'} ,
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++
++ my $r_action;
++ $r_action = $result->{'action'} if (ref($result) eq 'HASH');
++
++ next unless ($r_action =~ /do_it/);
++
++ $param->{'which'}{$l}{'subject'} = $list->{'admin'}{'subject'};
++ $param->{'which'}{$l}{'host'} = $list->{'admin'}{'host'};
++
++ if ($role eq 'member') {
++ push @{$param->{'get_which'}}, $list;
++ }
++
++ if ($role eq 'owner' || $role eq 'editor') {
++ $param->{'which'}{$l}{'admin'} = 1;
++ }
++
++ ## For compatibility concerns (3.0)
++ ## To be deleted one of these day
++ $param->{$role}{$l}{'subject'} = $list->{'admin'}{'subject'};
++ $param->{$role}{$l}{'host'} = $list->{'admin'}{'host'};
++
++ }
++
++ }
++ # &List::db_log('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'which','',$robot,'','done');
++ return 1;
++ }
++
++ ## The list of list
++ sub do_lists {
++ my @lists;
++ &wwslog('info', 'do_lists(%s,%s)', $in{'topic'}, $in{'subtopic'});
++
++ my %topics = &List::load_topics($robot);
++
++ if ($in{'topic'}) {
++ $param->{'topic'} = $in{'topic'};
++ if ($in{'subtopic'}) {
++ $param->{'subtopic'} = $in{'subtopic'};
++ $param->{'subtitle'} = sprintf "%s / %s", $topics{$in{'topic'}}{'current_title'}, $topics{$in{'topic'}}{'sub'}{$in{'subtopic'}}{'current_title'};
++ $param->{'subtitle'} ||= "$in{'topic'} / $in{'subtopic'}";
++ }else {
++ $param->{'subtitle'} = $topics{$in{'topic'}}{'current_title'} || $in{'topic'};
++ }
++ }
++
++ my $all_lists = &List::get_lists($robot);
++ foreach my $list ( @$all_lists ) {
++
++ my $sender = $param->{'user'}{'email'} || 'nobody';
++
++ my $result = $list->check_list_authz('visibility',$param->{'auth_method'},
++ {'sender' => $sender,
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'},
++ 'options' => {'dont_reload_scenario' => 1}});
++
++ my $r_action;
++ $r_action = $result->{'action'} if (ref($result) eq 'HASH');
++
++ next unless ($r_action eq 'do_it');
++
++ my $list_info = {};
++ $list_info->{'subject'} = $list->{'admin'}{'subject'};
++ $list_info->{'host'} = $list->{'admin'}{'host'};
++ $list_info->{'date_epoch'} = $list->{'admin'}{'creation'}{'date_epoch'};
++ $list_info->{'date'} = $list->{'admin'}{'creation'}{'date'};
++ $list_info->{'topics'} = $list->{'admin'}{'topics'};
++ if ($param->{'user'}{'email'} &&
++ ($list->am_i('owner',$param->{'user'}{'email'}) ||
++ $list->am_i('editor',$param->{'user'}{'email'})) ) {
++ $list_info->{'admin'} = 1;
++ }
++ if ($param->{'user'}{'email'} &&
++ $list->is_user($param->{'user'}{'email'})) {
++ $list_info->{'is_subscriber'} = 1;
++ }
++
++ ## no topic ; List all lists
++
++ if (! $in{'topic'}) {
++ $param->{'which'}{$list->{'name'}} = $list_info;
++ }elsif ($list->{'admin'}{'topics'}) {
++ foreach my $topic (@{$list->{'admin'}{'topics'}}) {
++ my @tree = split '/', $topic;
++
++ next if (($in{'topic'}) && ($tree[0] ne $in{'topic'}));
++ next if (($in{'subtopic'}) && ($tree[1] ne $in{'subtopic'}));
++
++ $param->{'which'}{$list->{'name'}} = $list_info;
++ }
++ }elsif ($in{'topic'} eq 'topicsless') {
++ $param->{'which'}{$list->{'name'}} = $list_info;
++ }
++ }
++ foreach my $listname (sort keys %{$param->{'which'}}) {
++ if ($listname =~ /^([a-z])/){
++ push @{$param->{'orderedlist'}{$1}}, $listname ;
++ }else{
++ push @{$param->{'orderedlist'}{'others'}}, $listname ;
++ }
++ }
++ return 1;
++ }
++
++ ## The list of latest created lists
++ sub do_latest_lists {
++ &wwslog('info', "do_latest_lists($in{'for'}, $in{'count'},$in{'topic'}, $in{'subtopic'})");
++
++ unless (&do_lists()) {
++ &wwslog('err','do_latest_lists: error while calling do_lists');
++ return undef;
++ }
++
++ my $today = time;
++
++ my $oldest_day;
++ if (defined $in{'for'}) {
++ $oldest_day = $today - (3600 * 24 * ($in{'for'}));
++ $param->{'for'} = $in{'for'};
++ unless ($oldest_day >= 0){
++ &report::reject_report_web('user','nb_days_to_much',{'nb_days' => $in{'for'} },$param->{'action'});
++ &wwslog('err','do_latest_lists: parameter "for" is too big"');
++ }
++ }
++
++ my $nb_lists = 0;
++ my @date_lists;
++ foreach my $listname (keys (%{$param->{'which'}})) {
++ if ($param->{'which'}{$listname}{'date_epoch'} < $oldest_day) {
++ delete $param->{'which'}{$listname};
++ next;
++ }
++ $nb_lists++;
++ }
++
++ if (defined $in{'count'}) {
++ $param->{'count'} = $in{'count'};
++
++ unless ($in{'count'}) {
++ $param->{'which'} = undef;
++ }
++ }
++
++ my $count_lists = 0;
++ foreach my $l ( sort {$param->{'which'}{$b}{'date_epoch'} <=> $param->{'which'}{$a}{'date_epoch'}} (keys (%{$param->{'which'}}))) {
++
++ $count_lists++;
++
++ if ($in{'count'}) {
++ if ($count_lists > $in{'count'}){
++ last;
++ }
++ }
++
++ $param->{'which'}{$l}{'name'} = $l;
++ push @{$param->{'latest_lists'}} , $param->{'which'}{$l};
++ }
++
++ $param->{'which'} = undef;
++
++ return 1;
++ }
++
++
++ ## The list of the most active lists
++ sub do_active_lists {
++ &wwslog('info', "do_active_lists($in{'for'}, $in{'count'},$in{'topic'}, $in{'subtopic'})");
++
++ unless (&do_lists()) {
++ &wwslog('err','do_active_lists: error while calling do_lists');
++ return undef;
++ }
++
++ ## oldest interesting day
++ my $oldest_day = 0;
++
++ if (defined $in{'for'}) {
++ $oldest_day = int(time/86400) - $in{'for'};
++ unless ($oldest_day >= 0){
++ &report::reject_report_web('user','nb_days_to_much',{'nb_days' => $in{'for'} },$param->{'action'});
++ &wwslog('err','do_latest_lists: parameter "for" is too big"');
++ return undef;
++ }
++ }
++
++ ## get msg count for each list
++ foreach my $l (keys (%{$param->{'which'}})) {
++ my $list = new List ($l, $robot);
++ my $file = "$list->{'dir'}/msg_count";
++
++ my %count ;
++
++ if (open(MSG_COUNT, $file)) {
++ while (<MSG_COUNT>){
++ if ($_ =~ /^(\d+)\s(\d+)$/) {
++ $count{$1} = $2;
++ }
++ }
++ close MSG_COUNT ;
++
++ $param->{'which'}{$l}{'msg_count'} = &count_total_msg_since($oldest_day,\%count);
++
++ if ($in{'for'}) {
++ my $average = $param->{'which'}{$l}{'msg_count'} / $in{'for'}; ## nb msg by day
++ $average = int($average * 10);
++ $param->{'which'}{$l}{'average'} = $average /10; ## one digit
++ }
++ } else {
++ $param->{'which'}{$l}{'msg_count'} = 0;
++ }
++ }
++
++ my $nb_lists = 0;
++
++ ## get "count" lists
++ foreach my $l ( sort {$param->{'which'}{$b}{'msg_count'} <=> $param->{'which'}{$a}{'msg_count'}} (keys (%{$param->{'which'}}))) {
++ if (defined $in{'count'}) {
++ $nb_lists++;
++ if ($nb_lists > $in{'count'}) {
++ last;
++ }
++ }
++
++ $param->{'which'}{$l}{'name'} = $l;
++ push @{$param->{'active_lists'}} , $param->{'which'}{$l};
++
++ }
++
++ if (defined $in{'count'}) {
++ $param->{'count'} = $in{'count'};
++ }
++ if (defined $in{'for'}) {
++ $param->{'for'} = $in{'for'};
++ }
++
++ $param->{'which'} = undef;
++
++
++ return 1;
++ }
++
++ sub count_total_msg_since {
++ my $oldest_day = shift;
++ my $count = shift;
++
++ my $total = 0;
++ foreach my $d (sort {$b <=> $a} (keys %$count)) {
++ if ($d < $oldest_day) {
++ last;
++ }
++ $total = $total + $count->{$d};
++ }
++ return $total;
++ }
++
++ ## List information page
++ sub do_info {
++ &wwslog('info', 'do_info');
++
++ ## Access control
++ unless (defined &check_authz('do_info', 'info')) {
++ delete $param->{'list'};
++ return undef;
++ }
++
++ ## Get List Description
++ if (-r $list->{'dir'}.'/homepage') {
++ my $file_path = $list->{'dir'}.'/homepage';
++ unless (open FILE, "<", $file_path) {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $file_path},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_info: failed to open file %s: %s', $file_path,$!);
++ &web_db_log({'parameters' => $file_path,
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ while (<FILE>) {
++ Encode::from_to($_, $Conf{'filesystem_encoding'}, 'utf8');
++ $param->{'homepage_content'} .= $_;
++ }
++ close FILE;
++
++ ## Used by previous templates
++ $param->{'homepage'} = 1;
++ }elsif (-r $list->{'dir'}.'/info') {
++ my $file_path = $list->{'dir'}.'/info';
++ unless (open FILE, "<", $file_path) {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $file_path},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_info: failed to open file %s: %s', $file_path,$!);
++ &web_db_log({'parameters' => $file_path,
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ while (<FILE>) {
++ Encode::from_to($_, $Conf{'filesystem_encoding'}, 'utf8');
++ $param->{'info_content'} .= $_;
++ }
++ close FILE;
++ $param->{'info_content'} =~ s/\n/\<br\/\>/g;
++ }
++
++ &tt2::add_include_path($list->{'dir'});
++
++ return 1;
++ }
++
++
++ ## List subcriber count page
++ sub do_subscriber_count {
++ &wwslog('info', 'do_subscriber_count');
++
++ unless (&do_info()) {
++ &wwslog('info','do_subscriber_count: error while calling do_info');
++ return undef;
++ }
++
++ print "Content-type: text/plain\n\n";
++ print $list->get_total()."\n";
++
++ $param->{'bypass'} = 'extreme';
++
++ return 1;
++ }
++
++
++ ## Subscribers' list
++ sub do_review {
++ &wwslog('info', 'do_review(%d)', $in{'page'});
++ my $record;
++ my @users;
++ my $size ;
++ my $sortby = $in{'sortby'} || 'email';
++ my %sources;
++
++ ## Access control
++ return undef unless (defined &check_authz('do_review', 'review'));
++
++ if($in{'size'}){
++ $size = $in{'size'};
++ $session->{'review_page_size'} = $in{'size'} ;
++ if ($param->{'user'}{'prefs'}{'review_page_size'} ne $in{'size'}) {
++ # update user pref as soon as connected user change page size
++ $param->{'user'}{'prefs'}{'review_page_size'} = $in{'size'};
++ &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
++ }
++ }else{
++ $size = $param->{'user'}{'prefs'}{'review_page_size'} || $session->{'review_page_size'} || $wwsconf->{'review_page_size'};
++ }
++ $param->{'review_page_size'} = $size;
++
++ unless ($param->{'total'}) {
++ &report::reject_report_web('user','no_subscriber',{},$param->{'action'},$list);
++ &wwslog('info','do_review: no subscriber');
++ # &List::db_log('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'review',$param->{'list'},$robot,'','no subscriber');
++ return 1;
++ }
++
++ ## Owner
++ $param->{'page'} = $in{'page'} || 1;
++ $param->{'total_page'} = int ($param->{'total'} / $size);
++ $param->{'total_page'} ++
++ if ($param->{'total'} % $size);
++
++ if ($param->{'total_page'} > 0 and ($param->{'page'} > $param->{'total_page'})) {
++ &report::reject_report_web('user','no_page',{'page' => $param->{'page'}},$param->{'action'},$list);
++ ('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'review',$param->{'list'},$robot,'','out of pages');
++ &wwslog('info','do_review: no page %d', $param->{'page'});
++ return undef;
++ }
++
++ my $offset;
++ if ($param->{'page'} > 1) {
++ $offset = (($param->{'page'} - 1) * $size);
++ }else {
++ $offset = 0;
++ }
++
++ ## We might not use LIMIT clause
++ my ($limit_not_used, $count);
++ unless (($list->{'admin'}{'user_data_source'} =~ /^(database|include2)$/) &&
++ ($Conf{'db_type'} =~ /^(Pg|mysql$)/)) {
++ $limit_not_used = 1;
++ }
++
++ ## Additional DB fields
++ my @additional_fields = split ',', $Conf{'db_additional_subscriber_fields'};
++
++ ## Members list synchronization if list has included data sources.
++ if ($list->has_include_data_sources()) {
++ if ($list->on_the_fly_sync_include('use_ttl'=>1)) {
++ &report::notice_report_web('subscribers_updated',{},$param->{'action'});
++ }else {
++ &report::reject_report_web('intern','sync_include_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ }
++ }
++
++ ## Members list
++ $count = -1;
++ for (my $i = $list->get_first_user({'sortby' => $sortby,
++ 'offset' => $offset,
++ 'rows' => $size});
++ $i; $i = $list->get_next_user()) {
++
++ ## some review pages may be empty while viewed by subscribers
++ next if (($i->{'visibility'} eq 'conceal')
++ and (! $param->{'is_priv'}) );
++
++ if ($limit_not_used) {
++ $count++;
++ next unless (($count >= $offset) && ($count <= $offset+$size));
++ }
++
++ ## Add user
++ &_prepare_subscriber($i, \@additional_fields, \%sources);
++
++ push @{$param->{'members'}}, $i;
++ }
++
++ if ($param->{'page'} > 1) {
++ $param->{'prev_page'} = $param->{'page'} - 1;
++ }
++
++ unless (($offset + $size) >= $param->{'total'}) {
++ $param->{'next_page'} = $param->{'page'} + 1;
++ }
++
++ $param->{'size'} = $size;
++ $param->{'sortby'} = $sortby;
++
++ ######################
++ if($in{'exclude'} eq '1'){
++ $param->{'exclude_opt'} = 0;
++ }else{
++ $param->{'exclude_opt'} = 1;
++ }
++ #######################
++
++ ## additional DB fields
++ $param->{'additional_fields'} = $Conf{'db_additional_subscriber_fields'};
++ ('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'review',$param->{'list'},$robot,'','done');
++
++ ## msg_topics
++ if ($list->is_there_msg_topic()) {
++ foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
++ if (defined $top->{'name'}) {
++ push (@{$param->{'available_topics'}},$top);
++ }
++ }
++ }
++
++
++ return 1;
++ }
++
++## Show the table of exclude
++sub do_show_exclude {
++
++ &wwslog('info', 'do_exclude()');
++ # Get the emails of the exclude about a list and the date of their insertion
++ my $data_exclu = &List::get_exclusion($list->{'name'});
++
++ my $excluded;
++ my $key = 0;
++ while (($data_exclu->{emails}->[$key]) && ($data_exclu->{date}->[$key])){
++ my $email = $data_exclu->{'emails'}->[$key];
++ my $date = gettext_strftime "%d %b %Y", localtime($data_exclu->{'date'}->[$key]);
++
++ $excluded = {'email' => $email,
++ 'since' => $date};
++ push @{$param->{'exclude_users'}}, $excluded;
++ $key = $key + 1;
++ }
++ return 1;
++}
++
++## Search in subscribers and in exclude
++sub do_search {
++ &wwslog('info', 'do_search(%s)', $in{'filter'});
++
++ my %sources;
++
++ ## Additional DB fields
++ my @additional_fields = split ',', $Conf{'db_additional_subscriber_fields'};
++ ## Access control
++ return undef unless (defined &check_authz('do_search', 'review'));
++ ## Regexp
++ $param->{'filter'} = $in{'filter'};
++ my $regexp = &tools::escape_regexp($param->{'filter'});
++
++ my $sql_regexp;
++ if ($list->{'admin'}{'user_data_source'} eq 'database') {
++ $sql_regexp = $param->{'filter'};
++ $sql_regexp =~ s/\%/\\\%/g;
++ $sql_regexp =~ s/\*/\%/g;
++ #$sql_regexp = '%'.$sql_regexp.'%';
++ }
++
++ my $record = 0;
++ ## Maximum size of selection
++ my $max_select = 50;
++
++ ## Members list
++ for (my $i = $list->get_first_user({'sql_regexp' => $sql_regexp, 'sortby' => 'email'}); $i; $i = $list->get_next_user()) {
++
++ ## Search filter
++ next if ($i->{'email'} !~ /$regexp/i
++ && $i->{'gecos'} !~ /$regexp/i);
++
++ next if (($i->{'visibility'} eq 'conceal')
++ and (! $param->{'is_owner'}) );
++
++ ## Add user
++ &_prepare_subscriber($i, \@additional_fields, \%sources);
++
++ $record++;
++ push @{$param->{'members'}}, $i;
++ }
++
++ my $data_exclu = &List::get_exclusion($list->{'name'});
++ my $key = 0;
++ ## Exclude users are searched too
++ while (($data_exclu->{emails}->[$key]) && ($data_exclu->{date}->[$key])){
++ my $email = $data_exclu->{'emails'}->[$key];
++ my $date = gettext_strftime "%d %b %Y", localtime($data_exclu->{'date'}->[$key]);
++ $key = $key + 1;
++
++ ## Search filter
++ next if ($email !~ /$regexp/i);
++ next if (!$param->{'is_owner'});
++
++ my $excluded = {'email' => $email,
++ 'since' => $date};
++
++ push @{$param->{'exclude_users'}}, $excluded;
++ $record++;
++ }
++
++ if ($record > $max_select) {
++ undef $param->{'members'};
++ $param->{'too_many_select'} = 1;
++ }
++
++ $param->{'similar_subscribers'} = &List::get_ressembling_subscribers_no_object({'name'=>$list->{'name'},'domain'=>$robot,'email'=>$in{'filter'}});
++ $param->{'similar_subscribers_occurence'} =$#{$param->{'similar_subscribers'}}+1;
++
++ $param->{'occurrence'} = $record;
++ return 1;
++}
++
++## Access to user preferences
++sub do_pref {
++ &wwslog('info', 'do_pref');
++
++ ## Find nearest expiration period
++ my $selected = 0;
++ foreach my $p (sort {$b <=> $a} keys %wwslib::cookie_period) {
++ my $entry = {'value' => $p};
++
++ ## Set description from NLS
++ $entry->{'desc'} = sprintf gettext($wwslib::cookie_period{$p}{'gettext_id'});
++
++ ## Choose nearest delay
++ if ((! $selected) && $param->{'user'}{'cookie_delay'} >= $p) {
++ $entry->{'selected'} = 'selected="selected"';
++ $selected = 1;
++ }
++
++ unshift @{$param->{'cookie_periods'}}, $entry;
++ }
++
++ $param->{'previous_list'} = $in{'previous_list'};
++ $param->{'previous_action'} = $in{'previous_action'};
++
++ return 1;
++ }
++
++ ## Set the initial password
++ sub do_choosepasswd {
++ &wwslog('info', 'do_choosepasswd');
++
++ if($session->{'auth'} eq 'ldap'){
++ &report::reject_report_web('auth','',{'login'=> $param->{'need_login'}},$param->{'action'});
++ &wwslog('notice', "do_choosepasswd : user not authorized\n");
++ &web_db_log({'parameters' => $in{'email'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ }
++
++ unless ($param->{'user'}{'email'}) {
++ unless ($in{'email'} && $in{'passwd'}) {
++ &report::reject_report_web('user','no_user',{},$param->{'action'});
++ &wwslog('info','do_pref: no user');
++ &web_db_log({'parameters' => $in{'email'},
++ 'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'no_user'});
++ $param->{'previous_action'} = 'choosepasswd';
++ return 'loginrequest';
++ }
++
++ $in{'previous_action'} = 'choosepasswd';
++ return 'login';
++ }
++ &web_db_log({'parameters' => "$in{'email'}",
++ 'target_email' => $in{'email'} || $param->{'user'}{'email'},
++ 'status' => 'success',
++ });
++ $param->{'init_passwd'} = 1 if ($param->{'user'}{'password'} =~ /^INIT/i);
++
++ return 1;
++ }
++
++####################################################
++# do_set
++####################################################
++# Changes subscription parameter (reception or visibility)
++#
++# IN : -
++#
++# OUT :'loginrequest'|'info' | undef
++
++ sub do_set {
++ &wwslog('info', 'do_set(%s, %s)', $in{'reception'}, $in{'visibility'});
++
++ my ($reception, $visibility) = ($in{'reception'}, $in{'visibility'});
++ my $email;
++
++ my $xml_custom_attribute;
++ if ($in{custom_attribute}){
++ return undef if ( &check_custom_attribute() != 1) ;
++ my $xml = &List::createXMLCustomAttribute($in{custom_attribute});
++
++ $xml_custom_attribute = $xml ;
++ }
++
++ if ($in{'email'}) {
++ unless ($param->{'is_owner'}) {
++ &report::reject_report_web('auth','action_owner',{},$param->{'action'},$list);
++ &wwslog('info','do_set: not owner');
++ &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++ $email = &tools::unescape_chars($in{'email'});
++ }else {
++ unless ($param->{'user'}{'email'}) {
++ &report::reject_report_web('user','no_user',{},$param->{'action'});
++ &wwslog('info','do_set: no user');
++ &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
++ 'status' => 'error',
++ 'error_type' => 'no_user'});
++ return 'loginrequest';
++ }
++ $email = $param->{'user'}{'email'};
++ }
++
++ unless ($list->is_user($email)) {
++ &report::reject_report_web('user','not_subscriber',{'list'=> $param->{'list'}},$param->{'action'},$list);
++ &wwslog('info','do_set: %s not subscriber of list %s', $email, $param->{'list'});
++ &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
++ 'status' => 'error',
++ 'error_type' => 'not_subscriber'});
++ return undef;
++ }
++
++ # Verify that the mode is allowed
++ if (! $list->is_available_reception_mode($reception)) {
++ &report::reject_report_web('user','not_available_reception_mode',{'recpetion_mode'=> $reception},$param->{'action'},$list);
++ return undef;
++ }
++
++ $reception = '' if $reception eq 'mail';
++ $visibility = '' if $visibility eq 'noconceal';
++
++ my $update = {'reception' => $reception,
++ 'visibility' => $visibility,
++ 'update_date' => time};
++
++ ## Lower-case new email address
++ $in{'new_email'} = lc( $in{'new_email'});
++
++ if ($in{'new_email'} && ($in{'email'} ne $in{'new_email'})) {
++
++ unless ($in{'new_email'} && &tools::valid_email($in{'new_email'})) {
++ &wwslog('notice', "do_set:incorrect email %s",$in{'new_email'});
++ &report::reject_report_web('user','incorrect_email',{'email' => $in{'new_email'}},$param->{'action'});
++ &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
++ 'status' => 'error',
++ 'error_type' => 'incorrect_email'});
++ return undef;
++ }
++
++ ## Check if new email is already subscribed
++ if ($list->is_user($in{'new_email'})) {
++ &report::reject_report_web('user','already_subscriber', {'list' => $list->{'name'}},$param->{'action'},$list);
++ &wwslog('info','do_set: %s already subscriber', $in{'new_email'});
++ &web_db_log({'parameters' => $in{'new_email'},
++ 'status' => 'error',
++ 'error_type' => 'already subscriber'});
++ return undef;
++ }
++
++ ## Duplicate entry in user_table
++ unless (&List::is_user_db($in{'new_email'})) {
++
++ my $user_pref = &List::get_user_db($in{'email'});
++ $user_pref->{'email'} = $in{'new_email'};
++ &List::add_user_db($user_pref);
++ }
++
++ $update->{'email'} = $in{'new_email'};
++ }
++
++ ## message topic subscription
++ if ($list->is_there_msg_topic()) {
++ my @user_topics;
++
++ if ($in{'no_topic'}) {
++ $update->{'topics'} = undef;
++
++ } else {
++ foreach my $msg_topic (@{$list->{'admin'}{'msg_topic'}}) {
++ my $var_name = "topic_"."$msg_topic->{'name'}";
++ if ($in{"$var_name"}) {
++ push @user_topics, $msg_topic->{'name'};
++ }
++ }
++
++ if ($in{"topic_other"}) {
++ push @user_topics, 'other';
++ }
++
++ $update->{'topics'} = join(',',@user_topics);
++ }
++ }
++
++ if ($reception =~ /^(digest|digestplain|nomail|summary)$/i) {
++ $update->{'topics'} = '';
++ }
++
++ ## Get additional DB fields
++ foreach my $v (keys %in) {
++ if ($v =~ /^additional_field_(\w+)$/) {
++ $update->{$1} = $in{$v};
++ }
++ }
++
++ if ($in{'gecos'}) {
++ $update->{'gecos'} = $in{'gecos'};
++ }else{
++ $update->{'gecos'} = undef;
++ }
++ $update->{'custom_attribute'} = $xml_custom_attribute if $xml_custom_attribute;
++
++ unless ( $list->update_user($email, $update) ) {
++ &report::reject_report_web('intern','update_subscriber_db_failed',{'sub'=>$email},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info', 'do_set: set failed');
++ &web_db_log({'parameters' => "$email,$update",
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ &report::notice_report_web('performed',{},$param->{'action'});
++ &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
++ 'status' => 'success',
++ });
++
++ return $in{'previous_action'} || 'info';
++ }
++
++
++## checks if each element of the custom attribute is conform to the list's
++## definition
++sub check_custom_attribute {
++
++ my @custom_attributes = @{$list->{'admin'}{'custom_attribute'}} ;
++ my $isOK = 1 ;
++
++ foreach my $ca (@custom_attributes){
++ my $value = $in{custom_attribute}{$ca->{id}}{value} ;
++ if ($ca->{optional} eq 'required' && $value eq '') {
++ &report::reject_report_web('user','missing_arg',{'argument' => "\"$ca->{name}\" is required"},$param->{'action'});
++ &wwslog('info','do_set: missing parameter');
++ &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
++ 'status' => 'error',
++ 'error_type' => 'missing_parameter'});
++ $isOK = undef;
++ next ;
++ }
++
++ ## No further checking if attribute if empty
++ next if ($value =~ /^$/);
++
++ my @values = split(/,/ , $ca->{'enum_values'}) if (defined $ca->{'enum_values'});
++
++ ## Check that the parameter has the correct format
++ unless (($ca->{'type'} eq 'enum' && grep(/^$value$/, @values)) ||
++ ($ca->{'type'} eq 'integer' && $value =~ /^\d+$/) ||
++ ($ca->{'type'} eq 'string' && $value =~ /^.+$/) ||
++ ($ca->{'type'} eq 'text' && $value =~ /^.+$/m)
++ ) {
++ &report::reject_report_web('user','syntax_errors',{'params' => $ca->{name}},$param->{'action'});
++ &wwslog('info','do_set: syntax error');
++ &web_db_log({'parameters' => $ca->{name}, 'status' => 'error', 'error_type' => 'missing_parameter'});
++ $isOK = undef;
++ next ;
++ }
++ }
++ return $isOK ;
++}
++
++
++ ## Update of user preferences
++ sub do_setpref {
++ &wwslog('info', 'do_setpref');
++ my $changes = {};
++
++ foreach my $p ('gecos','lang','cookie_delay') {
++ $changes->{$p} = $in{$p} if (defined($in{$p}));
++ }
++
++ ## Set session language and user language to new value
++ $session->{'lang'} = $in{'lang'} ;
++ $param->{'lang'} = $in{'lang'};
++
++ if (&List::is_user_db($param->{'user'}{'email'})) {
++
++ unless (&List::update_user_db($param->{'user'}{'email'}, $changes)) {
++ &report::reject_report_web('intern','update_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_pref: update failed');
++ &web_db_log({'parameters' => "$in{'gecos'},$in{'lang'},$in{'cookie_delay'}",
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }else {
++ $changes->{'email'} = $param->{'user'}{'email'};
++ unless (&List::add_user_db($changes)) {
++ &report::reject_report_web('intern','add_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_pref: add failed');
++ &web_db_log({'parameters' => "$in{'gecos'},$in{'lang'},$in{'cookie_delay'}",
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++
++ foreach my $p ('gecos','lang','cookie_delay') {
++ $param->{'user'}{$p} = $in{$p};
++ }
++
++ &report::notice_report_web('performed',{},$param->{'action'});
++ &web_db_log({'parameters' => "$in{'gecos'},$in{'lang'},$in{'cookie_delay'}",
++ 'status' => 'success',
++ });
++ if ($in{'previous_action'}) {
++ $in{'list'} = $in{'previous_list'};
++ return $in{'previous_action'};
++ }else {
++ return 'pref';
++ }
++ }
++
++ ## Prendre en compte les d�fauts
++ sub do_viewfile {
++ &wwslog('info', 'do_viewfile');
++
++ unless (defined $wwslib::filenames{$in{'file'}}) {
++ &report::reject_report_web('user','file_not_editable',{'file' => $in{'file'}},$param->{'action'});
++ &wwslog('info','do_viewfile: file %s not editable', $in{'file'});
++ return undef;
++ }
++
++ $param->{'file'} = $in{'file'};
++
++ $param->{'filepath'} = $list->{'dir'}.'/'.$in{'file'};
++
++ if ((-e $param->{'filepath'}) and (! -r $param->{'filepath'})) {
++ &report::reject_report_web('intern','cannot_read',{'filepath' => $param->{'filepath'}},$param->{'action'},'','',$robot);
++ &wwslog('info','do_viewfile: cannot read %s', $param->{'filepath'});
++ return undef;
++ }
++
++ return 1;
++ }
++
++
++####################################################
++# do_subscribe
++####################################################
++# Subscribes a user to the list
++#
++# IN : -
++#
++# OUT :'subrequest'|'login'|'info'|$in{'previous_action'}
++# | undef
++####################################################
++## TOTO: accepter nouveaux users
++sub do_subscribe {
++ &wwslog('info', 'do_subscribe(%s)', $in{'email'});
++
++ if (defined $param->{'user'} && $param->{'user'}{'email'}) {
++ my $xml_custom_attribute;
++
++ if ($list->{'admin'}{'custom_attribute'} ) {
++
++ ## This variable is set in the subrequest form
++ ## If not set, it means that the user has not been prompted to provide custom_attributes
++ unless ($in{'via_subrequest'}) {
++ &wwslog('notice', 'Returning subrequest form');
++ return "subrequest";
++ }
++
++ if (&check_custom_attribute() != 1) {
++ &wwslog('notice', "Missing required custom attributes") ;
++ return 'subrequest';
++ }
++ my $xml = &List::createXMLCustomAttribute($in{custom_attribute});
++ $xml_custom_attribute = $xml ;
++ }
++
++ if ($param->{'is_subscriber'}) {
++ &report::reject_report_web('user','already_subscriber', {'list' => $list->{'name'}},$param->{'action'},$list);
++ &wwslog('info','do_subscribe: %s already subscriber', $param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'already_subscriber'});
++ return undef;
++ }
++ my $result = $list->check_list_authz('subscribe',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $sub_is;
++ my $reason;
++ if (ref($result) eq 'HASH') {
++ $sub_is = $result->{'action'};
++ $reason = $result->{'reason'};
++ }
++ if ($sub_is =~ /reject/) {
++ &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
++ &wwslog('info', 'do_subscribe: subscribe closed');
++ &web_db_log({'parameters' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++ $param->{'may_subscribe'} = 1;
++
++ if ($sub_is =~ /owner/) {
++
++ unless ($list->send_notify_to_owner('subrequest',{'who' => $param->{'user'}{'email'},
++ 'keyauth' => $list->compute_auth($param->{'user'}{'email'}, 'add'),
++ 'replyto' => &Conf::get_robot_conf($robot, 'sympa'),
++ 'custom_attribute' => $in{custom_attribute},
++ 'gecos' => $param->{'user'}{'gecos'},
++ 'ip'=>$ip})) {
++ &wwslog('notice',"Unable to send notify 'subrequest' to $list->{'name'} listowner");
++ }
++
++ $list->store_subscription_request($param->{'user'}{'email'}, "", $xml_custom_attribute);
++ &report::notice_report_web('sent_to_owner',{},$param->{'action'});
++ &wwslog('info', 'do_subscribe: subscribe sent to owners');
++
++ return 'info';
++ }elsif ($sub_is =~ /do_it/) {
++ if ($param->{'is_subscriber'}) {
++ unless ($list->update_user($param->{'user'}{'email'},
++ {'subscribed' => 1,
++ 'update_date' => time})) {
++ &report::reject_report_web('intern','update_subscriber_db_failed',{'sub'=>$param->{'user'}{'email'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info', 'do_subscribe: update failed');
++ &web_db_log({'parameters' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }else {
++ my $defaults = $list->get_default_user_options();
++ my $u;
++ %{$u} = %{$defaults};
++ $u->{'email'} = $param->{'user'}{'email'};
++ $u->{'gecos'} = $param->{'user'}{'gecos'} || $in{'gecos'};
++ $u->{'date'} = $u->{'update_date'} = time;
++ $u->{'password'} = $param->{'user'}{'password'};
++ $u->{'custom_attribute'} = $xml_custom_attribute if (defined $xml_custom_attribute);
++ $u->{'lang'} = $param->{'user'}{'lang'} || $param->{'lang'};
++
++ unless ($list->add_user($u)) {
++ &report::reject_report_web('intern','add_subscriber_db_failed',{'sub'=>$param->{'user'}{'email'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info', 'do_subscribe: subscribe failed');
++ &web_db_log({'parameters' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++
++ unless ($sub_is =~ /quiet/i ) {
++ unless ($list->send_file('welcome', $param->{'user'}{'email'}, $robot,{})) {
++ &wwslog('notice',"Unable to send template 'welcome' to $param->{'user'}{'email'}");
++ }
++ }
++
++ if ($sub_is =~ /notify/) {
++ unless ($list->send_notify_to_owner('notice',{'who' => $param->{'user'}{'email'},
++ 'gecos' => $param->{'user'}{'gecos'},
++ 'command' => 'subscribe'})) {
++ &wwslog('notice','Unable to send notify "notice" to listmaster');
++ }
++ }
++
++ }
++ }else{ # user is not autenticated
++
++ if ($in{'email'} && $in{'passwd'}) {
++ $in{'previous_action'} = 'subscribe';
++ $in{'previous_list'} = $param->{'list'};
++ return 'login';
++ }else{
++ return 'subrequest';
++ }
++ }
++ ## perform which to update your_subscriptions cookie ;
++ @{$param->{'get_which'}} = &List::get_which($param->{'user'}{'email'},$robot,'member') ;
++ &report::notice_report_web('performed',{},$param->{'action'});
++ &web_db_log({'parameters' => $in{'email'},'status' => 'success'});
++
++ if ($in{'previous_action'}) {
++ return $in{'previous_action'};
++ }
++
++# return 'suboptions';
++ return 'info';
++}
++
++
++####################################################
++# do_multiple_subscribe
++####################################################
++# Subscribes a user to each lists
++#
++# IN : lists a array of lists
++#
++# OUT :'subrequest'|'login'|'info'|$in{'previous_action'}
++# | undef
++####################################################
++sub do_multiple_subscribe {
++ &wwslog('info', 'do_multiple_subscribe(%s)', $in{'email'});
++
++ ## Not authenticated
++ unless (defined $param->{'user'} && $param->{'user'}{'email'}) {
++ ## no email
++ unless ($in{'email'}) {
++ return 'lists';
++ }
++ }
++
++ my @lists = split /\0/, $in{'lists'};
++ my $total;
++ my %results ;
++
++
++ foreach my $requested_list (@lists) {
++ my $param->{'list'} = new List ($requested_list, $robot);
++ $results{'requested_list'} = &do_subscribe();
++ }
++}
++
++## Subscription request (user not authenticated)
++sub do_suboptions {
++ &wwslog('info', 'do_suboptions()');
++
++ unless($param->{'is_subscriber'} ) {
++ &report::reject_report_web('user','not_subscriber',{'list'=> $list->{'name'}},$param->{'action'},$list);
++ &wwslog('info','do_suboptions: %s not subscribed to %s',$param->{'user'}{'email'}, $param->{'list'} );
++ return undef;
++ }
++
++ my ($s, $m);
++
++ unless($s = $list->get_subscriber($param->{'user'}{'email'})) {
++ &report::reject_report_web('intern','subscriber_not_found',{'email' => $param->{'user'}{'email'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info', 'do_sub_options: subscriber %s not found', $param->{'user'}{'email'});
++ return undef;
++ }
++
++ $s->{'reception'} ||= 'mail';
++ $s->{'visibility'} ||= 'noconceal';
++ $s->{'date'} = gettext_strftime "%d %b %Y", localtime($s->{'date'});
++ $s->{'update_date'} = gettext_strftime "%d %b %Y", localtime($s->{'update_date'});
++
++ foreach $m (keys %wwslib::reception_mode) {
++ if ($list->is_available_reception_mode($m)) {
++ $param->{'reception'}{$m}{'description'} = sprintf(gettext($wwslib::reception_mode{$m}->{'gettext_id'}));
++ if ($s->{'reception'} eq $m) {
++ $param->{'reception'}{$m}{'selected'} = 'selected="selected"';
++ if ($m =~ /^(mail|notice|not_me|txt|html|urlize)$/i) {
++ $param->{'possible_topic'} = 1;
++ }
++ }else {
++ $param->{'reception'}{$m}{'selected'} = '';
++ }
++ }
++ }
++
++ foreach $m (keys %wwslib::visibility_mode) {
++ $param->{'visibility'}{$m}{'description'} = sprintf(gettext($wwslib::visibility_mode{$m}->{'gettext_id'}));
++ if ($s->{'visibility'} eq $m) {
++ $param->{'visibility'}{$m}{'selected'} = 'selected="selected"';
++ }else {
++ $param->{'visibility'}{$m}{'selected'} = '';
++ }
++ }
++
++ $param->{'subscriber'} = $s;
++
++
++ #msg_topic
++ $param->{'sub_user_topic'} = 0;
++ foreach my $user_topic (split (/,/,$s->{'topics'})) {
++ $param->{'topic_checked'}{$user_topic} = 1;
++ $param->{'sub_user_topic'}++;
++ }
++
++ if ($list->is_there_msg_topic()) {
++ foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
++ if (defined $top->{'name'}) {
++ push (@{$param->{'available_topics'}},$top);
++ }
++ }
++ }
++
++ return 1;
++}
++
++## Subscription request (user not authenticated)
++sub do_subrequest {
++ &wwslog('info', 'do_subrequest(%s,%s)', $in{'email'},$in{'custom_attribute'});
++
++ if (defined $in{'custom_attribute'}) {
++ $param->{'custom_attribute'} = $in{'custom_attribute'};
++ }
++
++ ## Auth ?
++ if ($param->{'user'}{'email'}) {
++ ## Subscriber ?
++ if ($param->{'is_subscriber'}) {
++ &report::reject_report_web('user','already_subscriber', {'list' => $list->{'name'}},$param->{'action'},$list);
++ &wwslog('info','%s already subscriber', $param->{'user'}{'email'});
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'already_subscriber'});
++ return undef;
++ }
++ $param->{'status'} = 'auth';
++ }else {
++ ## Provided email parameter ?
++ unless ($in{'email'}) {
++ $param->{'status'} = 'notauth_noemail';
++ return 1;
++ }
++ ## Subscriber ?
++ if ($list->is_user($in{'email'})) {
++ $param->{'status'} = 'notauth_subscriber';
++ return 1;
++ }
++ my $user;
++ $user = &List::get_user_db($in{'email'})
++ if &List::is_user_db($in{'email'});
++
++ ## Need to send a password by email
++ $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'email'},$robot,'subscribe/'.$list->{'name'},$ip);
++ $param->{'login_error'}='ticket_sent';
++ $param->{'request_from_host'} = $ip;
++ $param->{'newuser'} = &List::get_user_db($in{'email'});
++ unless (&List::send_global_file('sendpasswd', $in{'email'}, $robot, $param)) {
++ &wwslog('notice',"Unable to send template 'sendpasswd' to $in{'email'}");
++ $param->{'login_error'}='unable_to_send_ticket';
++ }
++ # &do_requestpasswd();
++ $param->{'status'} = 'notauth_passwordsent';
++
++ return 1;
++ }
++
++ return 1;
++}
++sub do_auto_signoff {
++ &wwslog('info', 'do_signoff');
++ ## If the URL isn't valid, then go to home page. No need to guide the user: this function is supposed to be used by clicking on autocreated URL only.
++ return 'home' unless $in{'email'};
++
++ ## If unsubscribe is forbidden, reject the request. Other
++
++ my $result = $list->check_list_authz('unsubscribe',$param->{'auth_method'},
++ {'sender' => $in{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $sig_is;
++ my $reason;
++ if (ref($result) eq 'HASH') {
++ $sig_is = $result->{'action'};
++ $reason = $result->{'reason'};
++ }
++
++ if ($sig_is =~ /reject/) {
++ &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
++ &wwslog('info', 'do_signoff: %s may not signoff from %s'
++ , $in{'email'}, $param->{'list'});
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++ ## Send the confirmation email to the user.
++
++ if ($list->is_user($in{'email'})) {
++
++ my $ticket = &Auth::create_one_time_ticket($in{'email'},$robot,'signoff/'.$list->{'name'},$ip);
++
++ my $tt2_param = {
++ 'list' => $list,
++ 'type' => 'ticket_to_signoff',
++ 'one_time_ticket' => $ticket,
++ 'email' => $in{'email'},
++ 'context' => 'auto_signoff',
++ 'ip' => $ip,
++ };
++ unless (&List::send_global_file('user_notification', $in{'email'}, $robot, $tt2_param)) {
++ &do_log('notice',"Unable to send template 'user_notification' to $in{'email'}");
++ return undef;
++ }
++ }else{
++ return 'home';
++ }
++ $param->{'signing_off_email'} = $in {'email'};
++ ## If OK, return the page displaying the informations to the user.
++ return 1;
++
++}
++####################################################
++# do_signoff
++####################################################
++# Unsubcribes a user from a list
++#
++# IN : -
++#
++# OUT : 'sigrequest' | 'login' | 'info'
++#
++####################################################
++ ## Unsubscribe from list
++ sub do_signoff {
++ &wwslog('info', 'do_signoff');
++
++ my $authenticated_email_address = $param->{'user'}{'email'};
++
++ unless ($authenticated_email_address) {
++ unless ($in{'email'}) {
++ return 'sigrequest';
++ }
++
++ if ($in{'fingerprint'}) {
++
++ unless(&tools::get_fingerprint($in{'email'}, $in{'fingerprint'})){
++ &report::reject_report_web('user','cannot_do_signoff');
++ &wwslog('err','do_signoff: failed to unsubscribe user %s', $in{'email'});
++ return undef;
++ }
++
++ ## We don't set $param->{'user'}{'email'} because we don't want the user to be authenticated
++ ## to prevent the cookie from being set
++ $authenticated_email_address = $in{'email'};
++
++ }else {
++
++ ## Perform login first
++ if ($in{'passwd'}) {
++ $in{'previous_action'} = 'signoff';
++ $in{'previous_list'} = $param->{'list'};
++ return 'login';
++ }
++
++ if ( &List::is_user_db($in{'email'}) ) {
++ &report::reject_report_web('user','no_user',{},$param->{'action'});
++ &wwslog('info','do_signoff: need auth for user %s', $in{'email'});
++ &web_db_log({'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'authentication'});
++ return undef;
++ }
++
++ ## No passwd
++ &init_passwd($in{'email'}, {'lang' => $param->{'lang'} });
++
++ $param->{'user'}{'email'} = $in{'email'};
++ $authenticated_email_address = $in{'email'};
++ }
++ }
++
++ my %result = &unsubscribe($authenticated_email_address, $list);
++ if ($result{'success'} == 1) {
++ &report::notice_report_web($result{'details'},{},$param->{'action'});
++ $param->{'is_subscriber'} = 0;
++ $param->{'may_signoff'} = 0;
++ }else{
++ &report::reject_report_web($result{'category_error'},$result{'reason_error'},{%{$result{'reason_error'}},'list'=>$list->{'name'}},$param->{'action'},$list);
++ }
++ return 'home';
++ }
++
++## Unsubscribe current user from a list.
++sub unsubscribe {
++ my $authenticated_email_address = shift;
++ my $list = shift;
++ my %report = ('success',1,'details','');
++
++ unless ($list->is_user($authenticated_email_address)) {
++ &wwslog('info','do_signoff: %s not subscribed to %s',$authenticated_email_address, $param->{'list'} );
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'not_subscriber'});
++ $report{'success'} = 0;
++ $report{'category_error'} = 'user';
++ $report{'reason_error'} = 'not_subscribed';
++ $report{'details_error'} = {};
++ return %report;
++ }
++
++ my $result = $list->check_list_authz('unsubscribe',$param->{'auth_method'},
++ {'sender' => $authenticated_email_address,
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $sig_is;
++ my $reason;
++ if (ref($result) eq 'HASH') {
++ $sig_is = $result->{'action'};
++ $reason = $result->{'reason'};
++ }
++
++ $param->{'may_signoff'} = 1 if ($sig_is =~ /do_it|owner/);
++
++ if ($sig_is =~ /reject/) {
++ &wwslog('info', 'do_signoff: %s may not signoff from %s'
++ , $authenticated_email_address, $param->{'list'});
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'authorization'});
++ $report{'success'} = 0;
++ $report{'category_error'} = 'auth';
++ $report{'reason_error'} = $reason;
++ $report{'details_error'} = {};
++ return %report;
++ }elsif ($sig_is =~ /owner/) {
++ unless ($list->send_notify_to_owner('sigrequest',{'who' => $authenticated_email_address,
++ 'keyauth' => $list->compute_auth($authenticated_email_address, 'del')})) {
++ &wwslog('notice',"Unable to send notify 'sigrequest' to $list->{'name'} list owner");
++ }
++ &wwslog('info', 'do_signoff: signoff sent to owner');
++ $report{'success'} = 1;
++ $report{'details'} = 'sent_to_owner';
++ return %report;
++ }else {
++ unless ($list->delete_user('users' => [$authenticated_email_address], 'exclude' =>' 1')) {
++ &wwslog('info', 'do_signoff: signoff failed');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ $report{'success'} = 0;
++ $report{'category_error'} = 'intern';
++ $report{'reason_error'} = 'delete_subscriber_db_failed';
++ $report{'details_error'} = {'sub'=>$authenticated_email_address};
++ return %report;
++ }
++
++ if ($sig_is =~ /notify/) {
++ unless ($list->send_notify_to_owner('notice',{'who' => $authenticated_email_address,
++ 'gecos' => '',
++ 'command' => 'signoff'})) {
++ &wwslog('notice',"Unable to send notify 'notice' to $list->{'name'} list owner");
++ }
++ }
++
++ ## perform which to update your_subscribtions cookie ;
++ @{$param->{'get_which'}} = &List::get_which($authenticated_email_address,$robot,'member') ;
++
++ unless ($list->send_file('bye', $authenticated_email_address, $robot, {})) {
++ &wwslog('notice',"Unable to send template 'bye' to $authenticated_email_address");
++ }
++ }
++ &web_db_log({'status' => 'success'});
++ $report{'success'} = 1;
++ $report{'details'} = 'performed';
++ return %report;
++}
++
++ ## Unsubscription request (user not authenticated)
++ sub do_sigrequest {
++ &wwslog('info', 'do_sigrequest(%s)', $in{'email'});
++
++ ## If user is authenticated then redirect him to the signoff action but
++ ## get a confirmation (via the sigrequest web page) first
++ if ($param->{'user'}{'email'}) {
++ return 1;
++ }
++
++ ## Not auth & no email => return the sigrequest web form to get the user email
++ unless ($in{'email'}) {
++ return 1;
++ }
++
++
++ if ($list->is_user($in{'email'})) {
++
++ my $ticket = &Auth::create_one_time_ticket($in{'email'},$robot,'signoff/'.$list->{'name'},$ip);
++
++ my $tt2_param = {'type' => 'ticket_to_signoff',
++ 'list' => $list,
++ 'one_time_ticket' => $ticket,
++ 'email' => $in{'email'}};
++ unless (&List::send_global_file('user_notification', $in{'email'}, $robot, $tt2_param)) {
++ &do_log('notice',"Unable to send template 'user_notification' to $in{'email'}");
++ return undef;
++ }
++
++ }else {
++ $param->{'not_subscriber'} = 1;
++ }
++
++ $param->{'email'} = $in{'email'};
++
++ return 1;
++ }
++
++
++ ## Update of password
++ sub do_setpasswd {
++ &wwslog('info', 'do_setpasswd');
++ my $user;
++
++ if ($in{'newpasswd1'} =~ /^\s+$/ ) {
++ &report::reject_report_web('user','no_passwd',{},$param->{'action'});
++ &wwslog('info','do_setpasswd: no newpasswd1');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'missing_parameter'});
++ return undef;
++ }
++
++ unless ($in{'newpasswd1'} eq $in{'newpasswd2'}) {
++ &report::reject_report_web('user','diff_passwd',{},$param->{'action'});
++ &wwslog('info','do_setpasswd: different newpasswds');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'bad_parameter'});
++ return undef;
++ }
++
++ if (&List::is_user_db($param->{'user'}{'email'})) {
++
++ unless ( &List::update_user_db($param->{'user'}{'email'}, {'password' => $in{'newpasswd1'},'wrong_login_count' => 0} )) {
++ &report::reject_report_web('intern','update_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_setpasswd: update failed');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }else {
++
++ unless ( &List::add_user_db({'email' => $param->{'user'}{'email'},
++ 'password' => $in{'newpasswd1'},
++ 'wrong_login_count' => 0} )) {
++ &report::reject_report_web('intern','add_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_setpasswd: update failed');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++
++ $param->{'user'}{'password'} = $in{'newpasswd1'};
++
++ &report::notice_report_web('performed',{},$param->{'action'});
++ &web_db_log({'status' => 'success'});
++
++ if ($in{'previous_action'}) {
++ $in{'list'} = $in{'previous_list'};
++ return $in{'previous_action'};
++ }else {
++ return 'pref';
++ }
++ }
++
++ ## List admin page
++ sub do_admin {
++ &wwslog('info', 'do_admin');
++
++ ## Messages edition
++ foreach my $f ('info','homepage','welcome.tt2','bye.tt2','removed.tt2','message.footer','message.header','remind.tt2','invite.tt2','reject.tt2') {
++ next unless ($list->may_edit($f, $param->{'user'}{'email'}) eq 'write');
++ if ($wwslib::filenames{$f}{'gettext_id'}) {
++ $param->{'files'}{$f}{'complete'} = gettext($wwslib::filenames{$f}{'gettext_id'});
++ }else {
++ $param->{'files'}{$f}{'complete'} = $f;
++ }
++ $param->{'files'}{$f}{'selected'} = '';
++ }
++ $param->{'files'}{'info'}{'selected'} = 'selected="selected"';
++
++ # my %mode;
++ # $mode{'edit'} = 1;
++ # my %access = &d_access_control(\%mode,$path);
++
++ return 1;
++ }
++
++ ## Server admin page
++ sub do_serveradmin {
++ &wwslog('info', 'do_serveradmin');
++
++ my $f;
++
++ ## Lists Default files
++ foreach my $f ('welcome.tt2','bye.tt2','removed.tt2','message.footer','message.header','remind.tt2','invite.tt2','reject.tt2','your_infected_msg.tt2') {
++ if ($wwslib::filenames{$f}{'gettext_id'}){
++ $param->{'lists_default_files'}{$f}{'complete'} = gettext($wwslib::filenames{$f}{'gettext_id'});
++ }else {
++ $param->{'lists_default_files'}{$f}{'complete'} = $f;
++ }
++ $param->{'lists_default_files'}{$f}{'selected'} = '';
++ }
++
++ ## Checking families and other virtual hosts.
++ &get_server_details();
++
++ ## Server files
++ foreach my $f ('helpfile.tt2','lists.tt2','global_remind.tt2','summary.tt2','create_list_request.tt2','list_created.tt2','list_aliases.tt2') {
++ $param->{'server_files'}{$f}{'complete'} = gettext($wwslib::filenames{$f}{'gettext_id'});
++ $param->{'server_files'}{$f}{'selected'} = '';
++ }
++ $param->{'server_files'}{'helpfile.tt2'}{'selected'} = 'selected="selected"';
++ $param->{'log_level'} = $session->{'log_level'} ;
++ $param->{'subaction'} = $in{'subaction'} ;
++ return 1;
++ }
++
++sub do_edit_config {
++
++ my @editable_params = @confdef::params ;
++
++ &get_server_details;
++
++ unless ($param->{'main_robot'}) {
++ &report::reject_report_web('auth','super lismaster feature only','{}',$param->{'action'});
++ &wwslog('info','check_authz: access denied in edit_config for %s because not super listmaster', $param->{'user'}{'email'});
++ }
++
++ for my $i ( 0 .. $#editable_params ) {
++ if ($editable_params[$i]->{'name'}) {
++ $editable_params[$i]->{'current_value'} = &Conf::get_robot_conf($robot, $editable_params[$i]->{'name'});
++ $editable_params[$i]->{'current_value'} = join( ",", @{$editable_params[$i]->{'current_value'}}) if (ref($editable_params[$i]->{'current_value'}) eq 'ARRAY');
++ }
++ }
++
++ if ($in{'conf_new_value'}) {
++ my $editable; my $i;
++ for $i ( 0 .. $#editable_params ) {
++ # if the parameter is editable and if the is a change
++ next unless ($editable_params[$i]->{'name'} eq $in{'conf_parameter_name'});
++ if ($editable_params[$i]->{'edit'} ne '1'){
++ do_log ('err','Ignoring change of parameter %s (value %s) because not editable', $in{'conf_parameter_name'}, $in{'conf_new_value'});
++ last;
++ }
++ if ($in{'conf_new_value'} eq $editable_params[$i]->{'current_value'} ){
++ do_log ('notice','Ignoring change of parameter %s (value %s) because inchanged', $in{'conf_parameter_name'}, $in{'conf_new_value'});
++ last;
++ }else{
++ $editable_params[$i]->{'current_value'} = $in{'conf_new_value'};
++ &Conf::set_robot_conf($robot, $in{'conf_parameter_name'}, $in{'conf_new_value'});
++ do_log ('notice','setting parameter %s to value %s', $in{'conf_parameter_name'}, $in{'conf_new_value'});
++ last;
++ }
++ }
++ }
++
++ $param->{'editable_params'} = \@editable_params ;
++ return 1;
++
++}
++
++## Change log_level for the current session
++sub do_set_loglevel {
++ &wwslog('info', 'do_set_loglevel');
++
++ $session->{'log_level'} = $in{'log_level'};
++ return 'serveradmin';
++}
++
++## activate dump var feature
++sub do_set_dumpvars {
++ &wwslog('info', 'do_set_dumpvars');
++
++ $session->{'dumpvars'} = 'true' ;
++ $param->{'dumpavars'} = $session->{'dumpvars'} ;
++ $param->{'redirect_to'} = $param->{'base_url'}.$param->{'path_cgi'}.'/serveradmin';
++ return '1';
++}
++## un-activate dump var feature
++sub do_unset_dumpvars {
++ &wwslog('info', 'do_unset_dumpvars');
++
++ $session->{'dumpvars'} = '' ;
++ $param->{'dumpavars'} = '';
++ $param->{'redirect_to'} = $param->{'base_url'}.$param->{'path_cgi'}.'/serveradmin';
++ return '1';
++}
++## un-activate dump var feature
++sub do_show_sessions {
++ &wwslog('info', 'do_show_sessions');
++
++ $in{'session_delay'} = 10 unless ($in{'session_delay'});
++ my $delay = 60 * $in{'session_delay'};
++ $param->{'sessions'} = &SympaSession::list_sessions($delay,$robot,$in{'connected_only'});
++ return '1';
++}
++
++
++## Change user email
++sub do_set_session_email {
++ &wwslog('info', 'do_set_session_email');
++
++ my $email_regexp = &tools::get_regexp('email');
++ unless ($in{'email'} =~ /^\s*$email_regexp\s*$/){
++ &report::reject_report_web('user','Invalid email provided.',{},$param->{'action'},$list);
++ return 'serveradmin';
++ };
++ if ($session){
++ $session->{'restore_email'} = $param->{'user'}{'email'};
++ $session->{'email'} = $in{'email'};
++ $param->{'redirect_to'} = $param->{'base_url'}.$param->{'path_cgi'};
++ return '1';
++ }else{
++ &report::reject_report_web('user','No active session',{},$param->{'action'},$list);
++ return 'serveradmin';
++ }
++}
++
++## Change user email
++sub do_restore_email {
++ &wwslog('info', 'do_restore_email');
++ &wwslog('debug2', 'do_restore_email from %s to %s',$session->{'email'},$session->{'restore_email'} );
++
++ if ($param->{'restore_email'}){
++ $session->{'email'} = $session->{'restore_email'} ;
++ $param->{'restore_email'}= $session->{'restore_email'} = '' ;
++ $param->{'redirect_to'} = $param->{'base_url'}.$param->{'path_cgi'};
++ }else{
++ &wwslog('info','do_restore_email from %s no restore_email attached to current session', $param->{'user'}{'email'});
++ &report::reject_report_web('user','wrong_param',{},$param->{'action'},$list);
++ }
++ return 'home';
++}
++
++## list available templates
++sub do_ls_templates {
++ &wwslog('info', 'do_ls_templates');
++
++ $in{'webormail'} ||= 'web';
++
++ if (defined $list) {
++ $param->{'templates'} = &tools::get_templates_list($in{'webormail'},$robot,$list);
++ }else{
++ $param->{'templates'} = &tools::get_templates_list($in{'webormail'},$robot, undef);
++ }
++
++ ## List of lang per type
++ foreach my $level ('site','robot','list') {
++ $param->{'lang_per_level'}{$level}{'default'} = 1;
++ }
++
++ foreach my $file (keys %{$param->{'templates'}}) {
++ foreach my $level (keys %{$param->{'templates'}{$file}}) {
++ foreach my $lang (keys %{$param->{'templates'}{$file}{$level}}) {
++ $param->{'lang_per_level'}{$level}{$lang} = 1;
++ }
++ }
++ }
++
++
++ ## Colspan per level
++ foreach my $level (keys %{$param->{'lang_per_level'}}) {
++ foreach my $lang (keys %{$param->{'lang_per_level'}{$level}}) {
++ $param->{'colspan_per_level'}{$level}++;
++ foreach my $file (keys %{$param->{'templates'}}) {
++ $param->{'templates'}{$file}{$level}{$lang} ||= '';
++ }
++ }
++ }
++
++ $param->{'webormail'} = $in{'webormail'};
++
++ return 1;
++}
++
++# show a template, used by copy_template and edit_emplate
++sub do_remove_template {
++
++ &wwslog('info', 'do_remove_template');
++
++ my $template_path ;
++
++ if ($in{'scope'} eq 'list') {
++ $template_path = &tools::get_template_path($in{'webormail'},$robot,'list',$in{'template_name'},$in{'tpl_lang'},$list);
++ }else{
++ $template_path = &tools::get_template_path($in{'webormail'},$robot,$in{'scope'},$in{'template_name'},$in{'tpl_lang'});
++ }
++
++ my $template_old_path = &tools::shift_file($template_path,10);
++ unless ($template_old_path) {
++ &report::reject_report_web('intern','remove_failed',{'path'=>$template_path},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info',"remove_template: could not remove $template_path");
++ &web_db_log({'parameters' => $in{'webormail'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ &report::notice_report_web('file_renamed',{'orig_file'=>$template_path,'new_file'=>$template_old_path}, $param->{'action'});
++ &web_db_log({'parameters' => $in{'webormail'},
++ 'status' => 'status'});
++ $param->{'webormail'} = $in{'webormail'};
++ $param->{'scope'} = $in{'scope'};
++ $param->{'template_name'} = $in{'template_name'};
++ $param->{'tpl_lang'} = $in{'tpl_lang'};
++
++ return 'ls_templates';
++}
++
++# show a template, used by copy_template and edit_emplate
++sub do_view_template {
++
++ &wwslog('info', "do_view_template(type=$in{'webormail'},template-name=$in{'template_name'},listname=$in{'list'},path=$in{'template_path'},scope=$in{'scope'},lang=$in{'tpl_lang'})");
++
++ my $template_path ;
++
++ if ($in{'scope'} eq 'list') {
++ $template_path = &tools::get_template_path($in{'webormail'},$robot,'list',$in{'template_name'},$in{'tpl_lang'},$list);
++ }else{
++ $template_path = &tools::get_template_path($in{'webormail'},$robot,$in{'scope'},$in{'template_name'},$in{'tpl_lang'});
++ }
++
++ unless (open (TPL,$template_path)) {
++ &report::reject_report_web('intern','cannot_open_file',{'path' => $in{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err',"view_template: can't open file %s",$template_path);
++ return undef;
++ }
++
++ $param->{'rows'} = 5; # minimum size of 5 rows;
++ $param->{'template_content'} = ''; # init content
++ while(<TPL>) {$param->{'template_content'}.= $_; $param->{'rows'}++;}
++ $param->{'template_content'} = &tools::escape_html($param->{'template_content'});
++ close TPL;
++
++
++ $param->{'webormail'} = $in{'webormail'};
++ $param->{'template_name'} = $in{'template_name'};
++ $param->{'template_path'} = $template_path;
++ $param->{'scope'} = $in{'scope'};
++ $param->{'tpl_lang'} = $in{'tpl_lang'};
++
++ return 1;
++}
++
++## template copy
++sub do_copy_template {
++ &wwslog('info', 'do_copy_template');
++
++
++ ## Load original template
++ &do_view_template();
++
++ ## Return form
++ unless ($in{'scope_out'}) {
++ return 1;
++ }
++
++# one of theses parameters is commint from the form submission
++ if ($in{'scope_out'} eq 'list') {
++ if ($in{'list_out'}) {
++ my $list_out;
++ unless ($list_out = new List $in{'list_out'}, $robot) {
++ &report::reject_report_web('user','unknown_list',{'list' => $in{'list_out'}},$param->{'action'},'');
++ &wwslog('info','do_copy_template: unknown list %s', $in{'list_out'});
++ &web_db_log({'parameters' => $in{'list_out'},
++ 'status' => 'error',
++ 'error_type' => 'unknown_list'});
++ return undef;
++ }
++
++ $param->{'template_path_out'} = &tools::get_template_path($in{'webormail'},$robot,$in{'scope_out'},$in{'template_name_out'},$in{'tpl_lang_out'},$list_out);
++ }else{
++ &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
++ &wwslog('err','do_copy_template: missing parameter webormail');
++ &web_db_log({'parameters' => $in{'webormail'},
++ 'status' => 'error',
++ 'error_type' => 'missing_parameter'});
++ return 1;
++ }
++ }else{
++ $param->{'template_path_out'} = &tools::get_template_path($in{'webormail'},$robot,$in{'scope_out'},$in{'template_name_out'},$in{'tpl_lang_out'});
++ }
++
++ unless (&tools::mk_parent_dir($param->{'template_path_out'})) {
++ &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path_out'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err',"can't create parent directory for %s : %s", $param->{'template_path_out'}, $!);
++ &web_db_log({'parameters' => $param->{'template_name_out'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ unless (open (TPLOUT,'>'.$param->{'template_path_out'})) {
++ &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path_out'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err',"can't open file %s : %s", $param->{'template_path_out'}, $!);
++ &web_db_log({'parameters' => $param->{'template_name_out'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ print TPLOUT &tools::unescape_html($param->{'template_content'});
++ close TPLOUT;
++
++ if ($in{'list_out'}) {$param->{'list'} = $in{'list'} = $in{'list_out'} ;}
++
++ $param->{'webormail'} = $in{'webormail'};
++ $param->{'tpl_lang'} = $in{'tpl_lang'} = $in{'tpl_lang_out'};
++ $param->{'scope'} = $in{'scope'} = $in{'scope_out'} ;
++ $param->{'template_path'} = $in{'template_path'} = $param->{'template_path_out'};
++ $param->{'template_name'} = $in{'template_name'} = $in{'template_name_out'};
++ &web_db_log({'parameters' => $param->{'template_name_out'},
++ 'status' => 'success'});
++ return ('edit_template');
++}
++
++
++## manage the rejection templates
++sub do_manage_template {
++ &wwslog('info', '(%s,%s)', $in{'subaction'}, $in{'message_template'});
++
++ my $file;
++
++ $in{'message_template'} =~ s/^reject_//;
++
++ if ($in{'message_template'}) {
++ my $escaped_template_path = $in{'message_template'};
++ $escaped_template_path =~ s/\s/_/g ;
++ $param->{'template_path'} = &tools::get_template_path('mail',$robot,'list', ,'reject_'.$escaped_template_path.'.tt2','',$list);
++ }
++ my $tt2_include_path = &tools::make_tt2_include_path($robot,'mail_tt2','',$list);
++ my $default_file = &tools::find_file('reject.tt2',@{$tt2_include_path});
++
++
++ if ($in{'subaction'} eq 'save') {
++ ## create the parent directory if it doesn't already exist
++ unless (&tools::mk_parent_dir($param->{'template_path'})) {
++ &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err',"can't create parent directory for %s : %s", $param->{'template_path'}, $!);
++ &web_db_log({'parameters' => $param->{'template_name'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ ## open the template
++ unless (open (TPLOUT ,'>' ,$param->{'template_path'})) {
++ &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err',"can't open file %s : %s", $param->{'template_path'}, $!);
++ &web_db_log({'parameters' => $in{'template_name'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ ## save template contents
++ print TPLOUT $in{'template_content'};
++ close TPLOUT;
++ &report::notice_report_web('performed',{},$in{'subaction'});
++
++ }elsif($in{'subaction'} eq 'create_new') {
++
++ $in{'template_new'} = $in{'new_template_name'} ;
++
++ unless ($in{'new_template_name'}) {
++ &report::reject_report_web('user','missing template name',{'path' => ''},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ return undef;
++ }
++ my $escaped_template_path = $in{'new_template_name'};$escaped_template_path =~ s/\s/_/g ;
++ my $new_template_path = &tools::get_template_path('mail',$robot,'list', ,'reject_'.$escaped_template_path.'.tt2','',$list);
++
++ if (-f $new_template_path) {
++ &report::reject_report_web('intern','template already exist',{'path' => $new_template_path},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ return undef;
++ }
++ ## create the parent directory if it doesn't already exist
++ unless (&tools::mk_parent_dir($new_template_path)) {
++
++ &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err',"can't create parent directory for %s : %s", $param->{'template_path'}, $!);
++ &web_db_log({'parameters' => $param->{'template_name'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ my $default_file = &tools::get_template_path('mail',$robot,'robot', ,'reject.tt2','',$list);
++ $default_file = &tools::get_template_path('mail',$robot,'site', ,'reject.tt2','',$list) unless (-f $default_file);
++ $default_file = &tools::get_template_path('mail',$robot,'distrib', ,'reject.tt2','',$list)unless (-f $default_file);
++
++ unless(open (DEFAULT, $default_file)){
++ &report::reject_report_web('intern','cannot_open_file',{'path' => $default_file},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err',"can't open file %s : %s", $default_file, $!);
++ return undef;
++ }
++
++ unless(open (TPL, '> '.$new_template_path)){
++ &report::reject_report_web('intern','cannot_open_file',{'path' => $new_template_path},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err',"can't open file %s : %s", $new_template_path, $!);
++ return undef;
++ }
++
++ while (<DEFAULT>){
++ print TPL $_;
++ }
++ close DEFAULT;
++ close TPL;
++ $in{'subaction'}='modify';
++ $in{'message_template'} = $in{'new_template_name'};
++ return 'manage_template';
++
++ }elsif ($in{'subaction'} eq 'modify') {
++
++ unless(open (FILE, $param->{'template_path'})){
++ &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err',"can't open file MODIFY %s : %s", $param->{'template_path'}, $!);
++ &web_db_log({'parameters' => $param->{'template_path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ while (<FILE>){
++ $param->{'content'} .= $_;
++ }
++ $param->{'content'} = &tools::escape_html($param->{'content'});
++ close FILE;
++ $param->{'message_template'} = $in{'message_template'};
++
++ }elsif($in{'subaction'} eq 'setdefault') {
++ # replace existing reject.tt2 file by a symlink to reject_default.tt2 for compatibility with version older than 6.0
++ my $base = $list->{'dir'}.'/mail_tt2/';
++ $in{'new_default'} =~ s/\s/_/g ;
++ my $absolute_file = $base.'reject_'.$in{'new_default'}.'.tt2';
++
++ &do_log('info','Change default by linking %s 2 %s',$base.'reject.tt2',$absolute_file);
++ if (-l $base.'reject.tt2') {
++ unless (unlink ($base.'reject.tt2')){
++ &wwslog('err','Could not unlink %s',$base.'reject.tt2');
++ }
++ }
++ unless (symlink ($absolute_file,$base.'reject.tt2')){
++ &wwslog('err','Could not symlink %s,%s',$absolute_file,$base.'reject.tt2');
++ }
++
++ }elsif ($in{'subaction'} eq 'delete') {
++
++ unless(unlink $param->{'template_path'}) {
++ &report::reject_report_web('intern','cannot_delete',{'file_del' => $param->{'template_path'}},'','','',$robot);
++ &wwslog('err',"can't open file %s : %s", $param->{'template_path'}, $!);
++ &web_db_log({'parameters' => $param->{'template_path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ &report::notice_report_web('performed',{},$in{'subaction'});
++ }
++ ## Build the list of available templates
++ my $available_files = &tools::get_templates_list('mail','',$list, {'ignore_global' => 1});
++ foreach $file (keys %$available_files) {
++ if ($file eq 'reject.tt2') {
++ my $base = $list->{'dir'}.'/mail_tt2/';
++ my $absolute_file = $base.'reject.tt2';
++ if (-l $absolute_file){
++ my $default = readlink ($absolute_file);
++ if ((-f $default )||( -f $base.$default )) {
++
++ $default =~ s/^.*reject_//;
++ $default =~ s/.tt2$//;
++ $default =~ s/_/ /g;
++ $param->{'default_reject_template'} = $default;
++ }else{
++ # link to no existing file. remove link
++ &wwslog('err','Link %s point to un no existing file (%s)', $base.'reject.tt2',$default);
++ unless (unlink ($absolute_file)){
++ &wwslog('err','do_modindex: could not unlink %s',$base.'reject.tt2');
++ }
++ }
++ }elsif(-f $absolute_file){
++ # replace existing reject.tt2 file by a symlink to reject_default.tt2 for compatibility with version older than 6.0
++ unless (rename ($absolute_file,$base.'reject_default.tt2')){
++ &wwslog('err','Could not rename %,%s',$base.'reject.tt2',$base.'reject_default.tt2');
++ }
++ unless (symlink ($base.'reject_default.tt2',$absolute_file)){
++ &wwslog('err','Could not symlink %s,%s',$base.'reject_default.tt2',$absolute_file);
++ }
++
++ $param->{'default_reject_template'} = 'default';
++ push (@{$param->{'available_files'}},'default');
++ }
++ }else{
++ next unless($file =~ /^reject_/);
++ $file =~ s/^reject_//;
++ $file =~ s/.tt2$//;
++ $file =~ s/_/ /g;
++ push (@{$param->{'available_files'}},$file);
++ }
++ }
++
++ return 1;
++}
++
++## online template edition
++sub do_edit_template {
++
++ $in{'subdir'} ||= 'default';
++
++ &wwslog('info', "do_edit_template(type=$in{'webormail'},template-name=$in{'template_name'},listname=$in{'list'},path=$in{'template_path'},scope=$in{'scope'},lang=$in{'tpl_lang'})");
++
++ ## Load original template
++ &do_view_template;
++
++ unless ($in{'content'}) {
++ return 1;
++ }
++ if ($in{'scope'} eq 'list') {
++ if ($in{'list'}) {
++ $param->{'template_path'} = &tools::get_template_path($in{'webormail'},$robot,$in{'scope'},$in{'template_name'},$in{'tpl_lang'},$list);
++ }else{
++ &report::reject_report_web('user','listname_needed',{},$param->{'action'});
++ &wwslog('info',"edit_template : no output lisname while output scope is list");
++ &web_db_log({'parameters' => $in{'template_name'},
++ 'status' => 'error',
++ 'error_type' => 'no_list'});
++ return undef;
++ }
++ }else {
++ $param->{'template_path'} = &tools::get_template_path($in{'webormail'},$robot,$in{'scope'},$in{'template_name'},$in{'tpl_lang'});
++ }
++
++ unless (open (TPLOUT,'>'.$param->{'template_path'})) {
++ &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err',"edit_template: can't open file %s", $param->{'template_path'});
++ &web_db_log({'parameters' => $in{'template_name'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ print TPLOUT &tools::unescape_html($in{'content'});
++ close TPLOUT;
++
++ $param->{'saved'} = 1;
++ $param->{'template_content'} = $in{'content'};
++ $param->{'webormail'} = $in{'webormail'};
++ $param->{'template_name'} = $in{'template_name'};
++ $param->{'list'} = $in{'list'};
++ $param->{'scope'} = $in{'scope'};
++ $param->{'template_path'} = $in{'template_path'};
++ $param->{'tpl_lang'} = $in{'tpl_lang'};
++
++ &web_db_log({'parameters' => $in{'template_name'},
++ 'status' => 'success'});
++
++ return 'ls_templates';
++
++}
++
++
++ ## Server show colors, and install static css in future edit colors etc
++
++
++ ## Server show colors, and install static css in futur edit colors etc
++sub do_skinsedit {
++ &wwslog('info', 'do_skinsedit');
++ my $f;
++
++ my $dir = &Conf::get_robot_conf($robot, 'css_path');
++ my $css_url = &Conf::get_robot_conf($robot, 'css_url');
++
++ ## Checking families and other virtual hosts.
++ &get_server_details();
++
++ $param->{'css_warning'} = "parameter css_url seems strange, it must be the url of a directory not a css file" if ($css_url =~ /\.css$/);
++
++ if(($in{'editcolors'})&&($in{'subaction'} eq 'reset')){
++ delete $session->{'custom_css'};
++ delete $param ->{'session'}{'custom_css'};
++ delete $param->{'custom_css'};
++
++ foreach my $colornumber (0..15){
++ delete $session->{'color_'.$colornumber} ;
++ delete $param ->{'session'}{'color_'.$colornumber};
++ }
++ }
++
++ if(($in{'editcolors'})&&($in{'subaction'} eq 'test')){
++
++ return unless ($in{'custom_color_number'} =~ /color_/);
++ $param->{'custom_color_number'} = $in{'custom_color_number'};
++ $param->{'custom_color_value'} = $in{'custom_color_value'};
++ $param->{'custom_css'} = $css_url.'/'.$param->{'user'}{'email'}.'.style.css';
++ $session->{'custom_css'} = $param->{'custom_css'} ;
++
++ $session->{$in{'custom_color_number'}} = $in{'custom_color_value'};
++
++ $param->{$in{'custom_color_number'}} = $in{'custom_color_value'};
++ foreach my $colornumber (0..15){
++ if ($session->{'color_'.$colornumber} ) {
++ $param->{'color_'.$colornumber} = $session->{'color_'.$colornumber} ;
++ $param->{'session'}{'color_'.$colornumber} = $session->{'color_'.$colornumber} ;
++ }
++ }
++
++ }
++ if (($in{'subaction'} eq 'install')||($in{'installcss'})) {
++
++ my $lang = &Language::Lang2Locale($param->{'lang'});
++ my $tt2_include_path = &tools::make_tt2_include_path($robot,'web_tt2',$lang,'');
++
++ my $date= time;
++ my $style_file;
++
++ # update config
++ foreach my $colornumber (0..15){
++ &Conf::set_robot_conf($robot, 'color_'.$colornumber, $session->{'color_'.$colornumber}) if ($session->{'color_'.$colornumber});
++ }
++ $param->{'conf'}=$Conf::Conf;
++
++ foreach my $css ('style.css','print.css','fullPage.css','print-preview.css') {
++ $param->{'css'} = $css;
++ my $css_file;
++ # if user use editcolor form we must generate a static CSS that used custom colors.
++ if($in{'subaction_test'}){
++ $css_file = "$dir/$param->{'user'}{'email'}.$css";
++ }else{
++ $css_file = "$dir/$css";
++ }
++ unless (-d $dir) {
++ unless (mkdir $dir, 0775) {
++ &report::reject_report_web('intern',"mkdir_failed",{'path' => $dir}, $param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err','skinsedit : failed to create directory %s : %s',$dir, $!);
++ return undef;
++ }
++ chmod 0775, $dir;
++ &wwslog('notice','skinsedit : created missing directory %s',$dir);
++ }
++
++ ## Keep a copy of the previous CSS (only if this is not a custom css).
++ if ((-f "$css_file")&&!($in{'editcolors'})) {
++ unless (rename "$css_file", "$css_file.$date") {
++ &report::reject_report_web('intern','cannot_rename_file',{'path' => "$css_file.$date"},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err','skinsedit : can\'t open file %s.%s',$css_file,$date);
++ return undef;
++ }
++ }
++
++ if ($in{'subaction_install'}) {
++ foreach my $colornumber (0..15){
++ $param->{'color_'.$colornumber} = $session->{'color_'.$colornumber} if ($session->{'color_'.$colornumber});
++ }
++ }
++
++ unless (open (CSS,">$css_file")) {
++ &report::reject_report_web('intern','cannot_open_file',{'path' => "$css_file"},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err','skinsedit : can\'t open file (write) %s',$css_file);
++ return undef;
++ }
++ unless (&tt2::parse_tt2($param,'css.tt2' ,\*CSS, $tt2_include_path)) {
++ my $error = &tt2::get_error();
++ $param->{'tt2_error'} = $error;
++ &List::send_notify_to_listmaster('web_tt2_error', $robot,[$error]);
++ &wwslog('info', "do_skinsedit : error while installing $css_file");
++ }
++ close (CSS) ;
++
++ ## Make the CSS readable to anyone
++ chmod 0775, "$css_file";
++
++
++ }
++
++ $param->{'css_result'} = 1 ;
++ }
++ return 1;
++}
++
++ ## Multiple add
++ sub do_add_request {
++ &wwslog('info', 'do_add_request(%s)', $in{'email'});
++
++ ## Access control
++ return undef unless (defined &check_authz('do_add_request', 'add'));
++
++ return 1;
++ }
++
++
++####################################################
++# do_add
++####################################################
++# Adds a user to a list (requested by an other user)
++#
++# IN : -
++#
++# OUT : 'loginrequest'
++# | ($in{'previous_action'} || 'review')
++# | undef
++####################################################
++## TODO: v�rifier validit� email
++ sub do_add {
++ &wwslog('info', 'do_add(%s)', $in{'email'}||$in{'pending_email'});
++ my $subscriptions = $list->get_subscription_requests();
++
++ my %user;
++
++ ## If a list is not 'open' and allow_subscribe_if_pending has been set to 'off' returns undef.
++ unless (($list->{'admin'}{'status'} eq 'open') || (&Conf::get_robot_conf($robot, 'allow_subscribe_if_pending') eq 'on')) {
++ &report::reject_report_web('user','list_not_open',{'status' => $list->{'admin'}{'status'}},$param->{'action'});
++ &wwslog('info','list not open');
++ &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
++ 'status' => 'error',
++ 'error_type' => 'list_not_open'});
++ return undef;
++ }
++
++ my $email_regexp = &tools::get_regexp('email');
++ if ($in{'dump'}) {
++ foreach (split /\n/, $in{'dump'}) {
++ if (/^\s*($email_regexp)(\s+(.*))?\s*$/) {
++ $user{&tools::get_canonical_email($1)} = $5;
++ }
++ }
++ }elsif ($in{'email'} =~ /,/) {
++ foreach my $pair (split /\0/, $in{'email'}) {
++ if ($pair =~ /^($email_regexp)(,(.*))?\s*$/) {
++ $user{&tools::get_canonical_email($1)} = $5;
++ }
++ }
++ }elsif ($in{'email'}) {
++ $user{&tools::get_canonical_email($in{'email'})} = $in{'gecos'};
++ }elsif ($in{'pending_email'}) {
++ foreach my $pair (split /\0/, $in{'pending_email'}) {
++ my ($email, $gecos);
++ if ($pair =~ /^($email_regexp)(,(.*))?\s*$/) {
++ ($email, $gecos) = ($1,$5);
++ $user{&tools::get_canonical_email($email)} = $gecos;
++ }
++ }
++ }else {
++ &report::reject_report_web('user','no_email',{},$param->{'action'});
++ &wwslog('info','do_add: no email');
++ &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
++ 'status' => 'error',
++ 'error_type' => 'no_email'});
++ return undef;
++ }
++
++ my ($total, @new_users, @added_users );
++ my $comma_emails ;
++ foreach my $email (keys %user) {
++ &wwslog('debug', "do_add subscription \$subscriptions->{$email}{custom_attribute} = $subscriptions->{$email}{'custom_attribute'})" );
++ if (ref($subscriptions->{$email}{'custom_attribute'}) eq 'HASH') {
++ my $xml = List::createXMLCustomAttribute($subscriptions->{$email}{'custom_attribute'}) ;
++ &wwslog('debug', "do_add subscription XML \$subscriptions->{$email}{custom_attribute} = $xml;");
++ }
++
++ my $result = $list->check_list_authz('add',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'email' => $in{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $add_is;
++ my $reason;
++ if (ref($result) eq 'HASH') {
++ $add_is = $result->{'action'};
++ $reason = $result->{'reason'};
++ }
++
++ unless ($add_is =~ /do_it/) {
++ &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
++ &wwslog('info','do_add: %s may not add', $param->{'user'}{'email'});
++ &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ next;
++ }
++
++ unless (&tools::valid_email($email)) {
++ &report::reject_report_web('user','incorrect_email',{'email' => $email},$param->{'action'},$list);
++ &wwslog('info','do_add: incorrect email %s', $email);
++ &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
++ 'status' => 'error',
++ 'error_type' => 'incorrect_email'});
++ next;
++ }
++
++ my $user_entry = $list->get_subscriber($email);
++
++ if (defined($user_entry)) {
++ &report::reject_report_web('user','user_already_subscriber', {'list' => $list->{'name'},'email' => $email},$param->{'action'},$list);
++ &wwslog('info','do_add: %s already subscriber', $email);
++ &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
++ 'status' => 'error',
++ 'error_type' => 'already_subscriber'});
++ next;
++ }
++
++ my $u2 = &List::get_user_db($email);
++ my $defaults = $list->get_default_user_options();
++ my $u;
++ %{$u} = %{$defaults};
++ $u->{'email'} = $email;
++ $u->{'gecos'} = $user{$email} || $u2->{'gecos'};
++ $u->{'date'} = $u->{'update_date'} = time;
++ $u->{'password'} = $u2->{'password'} || &tools::tmp_passwd($email) ;
++ $u->{'lang'} = $u2->{'lang'} || $list->{'admin'}{'lang'};
++ if ($comma_emails) {
++ $comma_emails = $comma_emails .','. $email;
++ }else{
++ $comma_emails = $email;
++ }
++
++ ##
++ push @new_users, $u;
++ push @added_users, $email; ## List only email addresses ; used later to remove pending subrequests
++
++ unless ($in{'quiet'} || $add_is =~ /quiet/i) {
++ unless ($list->send_file('welcome', $email, $robot,{})) {
++ &wwslog('err',"Unable to send template 'welcome' to $email");
++ }
++ }
++ }
++
++ $total = $list->add_user(@new_users);
++ unless( defined $total) {
++ &report::reject_report_web('intern','add_subscriber_db_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_add: failed adding');
++ &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ ## Delete subscription request if any
++ $list->delete_subscription_request(@added_users);
++
++ &report::notice_report_web('add_performed', {'total' => $total},$param->{'action'});
++
++ foreach my $email (@added_users) {
++ &web_db_log({'target_email' => $email,
++ 'status' => 'success'});
++ }
++
++ $in{'list'} = $in{'previous_list'} if ($in{'previous_list'});
++ return $in{'previous_action'} || 'review';
++ }
++
++
++
++####################################################
++# do_del
++####################################################
++# Deletes a user from a list (requested by an other user)
++#
++# IN : -
++#
++# OUT : 'loginrequest'
++# | ($in{'previous_action'} || 'review') | undef
++#
++####################################################
++ ## TODO: v�rifier validit� email
++ sub do_del {
++ &wwslog('info', 'do_del()');
++
++ $in{'email'} = &tools::unescape_chars($in{'email'});
++
++ my $result = $list->check_list_authz('del',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'email' => $in{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $del_is;
++ my $reason;
++ if (ref($result) eq 'HASH') {
++ $del_is = $result->{'action'};
++ $reason = $result->{'reason'};
++ }
++
++ unless ( $del_is =~ /do_it/) {
++ &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
++ # &List::db_log('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'del',$param->{'list'},$robot,$in{'email'},'may not');
++ &wwslog('info','do_del: %s may not del', $param->{'user'}{'email'});
++ &web_db_log({'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ my @emails = split /\0/, $in{'email'};
++
++ my ($total, @removed_users);
++
++ foreach my $email (@emails) {
++
++ my $escaped_email = &tools::escape_chars($email);
++
++ my $user_entry = $list->get_subscriber($email);
++
++ unless (defined($user_entry)) {
++ &report::reject_report_web('user','not_subscriber',{'email' => $email},$param->{'action'},$list);
++ # &List::db_log('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'del',$param->{'list'},$robot,$email,'not subscriber');
++ &wwslog('info','do_del: %s not subscribed', $email);
++ &web_db_log({'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'not_subscriber'});
++ next;
++ }
++
++ push @removed_users, $email;
++
++
++ my $bounce_dir = $list->get_bounce_dir();
++
++ if (-f $bounce_dir.'/'.$escaped_email) {
++ unless (unlink $bounce_dir.'/'.$escaped_email) {
++ &wwslog('info','do_resetbounce: failed deleting %s', $bounce_dir.'/'.$escaped_email);
++ &web_db_log({'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ next;
++ }
++ }
++
++
++ &wwslog('info','do_del: subscriber %s deleted from list %s', $email, $param->{'list'});
++
++ unless ($in{'quiet'}) {
++ unless ($list->send_file('removed', $email, $robot,{})) {
++ &wwslog('notice',"Unable to send template 'removed' to $email");
++ }
++ }
++ }
++
++ $total = $list->delete_user('users' => \@removed_users, 'exclude' =>'1');
++
++ unless( defined $total) {
++ &report::reject_report_web('intern','delete_subscriber_db_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_del: failed');
++ &web_db_log({'target_email' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ &report::notice_report_web('del_performed',{'total' => $total},$param->{'action'});
++ &web_db_log({'target_email' => $in{'email'},
++ 'status' => 'success'});
++
++ $param->{'is_subscriber'} = 1;
++ $param->{'may_signoff'} = 1;
++
++ ## Skip search because we don't have the expression anymore
++ delete $in{'previous_action'} if ($in{'previous_action'} eq 'search');
++
++ return $in{'previous_action'} || 'review';
++ }
++
++
++####################################################
++# do_modindex
++####################################################
++# Web page for an editor to moderate documents and
++# and/or to tag message in message topic context
++#
++# IN : -
++#
++# OUT : 'loginrequest' | 'admin' | '1' | undef
++#
++#######################################################
++ sub do_modindex {
++ &wwslog('info', 'do_modindex');
++ my $msg;
++ my $doc;
++
++ ## Loads message list
++ unless (opendir SPOOL, $Conf{'queuemod'}) {
++ &report::reject_report_web('intern','cannot_open_spool',{'spool'=>$Conf{'queuemod'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_modindex: unable to read spool');
++ return 'admin';
++ }
++
++ my $list_name = $list->{'name'};
++ my $list_id = $list->get_list_id();
++ foreach $msg ( sort grep(!/^\./, readdir SPOOL )) {
++ next
++ unless ($msg =~ /^$list_id\_(\w+)$/ ||
++ $msg =~ /^$list_name\_(\w+)$/);
++
++ my $id = $1;
++
++ ## Load msg
++ my $mail = new Message("$Conf{'queuemod'}/$msg");
++
++ unless (defined $mail) {
++ &report::reject_report_web('intern','cannot_get_msg',{'msg'=>"$Conf{'queuemod'}/$msg"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_modindex: unable to parse msg %s', $msg);
++ closedir SPOOL;
++ next;
++ }
++
++
++ $param->{'spool'}{$id}{'size'} = int( (-s "$Conf{'queuemod'}/$msg") / 1024 + 0.5);
++ $param->{'spool'}{$id}{'subject'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('Subject'), Charset=>'utf8');
++ $param->{'spool'}{$id}{'subject'} ||= 'no_subject';
++ $param->{'spool'}{$id}{'date'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('Date'), Charset=>'utf8');
++ $param->{'spool'}{$id}{'from'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('From'), Charset=>'utf8');
++ $param->{'spool'}{$id}{'spam_status'} = $mail->{'spam_status'};
++ foreach my $field ('subject','date','from') {
++ $param->{'spool'}{$id}{$field} =~ s/&/&/g;
++ $param->{'spool'}{$id}{$field} =~ s/</</g;
++ $param->{'spool'}{$id}{$field} =~ s/>/>/g;
++ }
++ }
++ closedir SPOOL;
++
++ if ($list->is_there_msg_topic()) {
++
++ $param->{'request_topic'} = 1;
++
++ foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
++ if ($top->{'name'}) {
++ push (@{$param->{'available_topics'}},$top);
++ }
++ }
++ $param->{'topic_required'} = $list->is_msg_topic_tagging_required();
++ }
++
++ my $available_files = &tools::get_templates_list('mail','',$list, {'ignore_global' => 1});
++ foreach my $file (keys %$available_files) {
++
++ if ($file eq 'reject.tt2') {
++
++ my $base = $list->{'dir'}.'/mail_tt2/';
++ my $absolute_file = $base.'reject.tt2';
++ if (-l $absolute_file){
++
++ my $default = readlink ($absolute_file);
++ if ((-f $default )||( -f $base.$default )) {
++ $default =~ s/^.*reject_//;
++ $default =~ s/.tt2$//;
++ $param->{'default_reject_template'} = $default;
++ }else{
++ # link to no existing file. remove link
++ &wwslog('err','do_modindex: link %s point to un no existing file (%s)', $base.'reject.tt2',$default);
++ unless (unlink ($absolute_file)){
++ &wwslog('err','do_modindex: could not unlink %s',$base.'reject.tt2');
++ }
++ }
++ }elsif(-f $absolute_file){
++ # replace existing reject.tt2 file by a symlink to reject_default.tt2 for compatibility with version older than 6.0
++ unless (rename ($absolute_file,$base.'reject_default.tt2')){
++ &wwslog('err','do_modindex: could not rename %,%s',$base.'reject.tt2',$base.'reject_default.tt2');
++ }
++ unless (symlink ($base.'reject_default.tt2',$absolute_file)){
++ &wwslog('err','do_modindex: could not symlink %s,%s',$base.'reject_default.tt2',$absolute_file);
++ }
++
++ $param->{'default_reject_template'} = 'default';
++ push (@{$param->{'available_files'}},'default');
++ }
++ }else{
++ next unless($file =~ /^reject_/);
++ $file =~ s/^reject_//;
++ $file =~ s/.tt2$//;
++ push (@{$param->{'available_files'}},$file);
++ }
++ }
++ ## shared documents awaiting moderation
++ foreach my $d (@{$param->{'doc_mod_list'}}) {
++
++ $d =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
++
++ my $long_path = $1; # path without the filename
++ my $fname = $3; # the filename with .moderate
++ my $path = $long_path; $path =~ s/^.*\/shared//; #the path for the user, without the filename
++ my $visible_fname = &make_visible_path($fname); # the filename without .moderate
++ my $visible_path = $path;
++ $visible_path = &make_visible_path($visible_path);
++
++ my %desc_hash;
++ if ($d && (-e "$long_path.desc.$fname")){
++ %desc_hash = &get_desc_file("$long_path.desc.$fname");
++ }
++
++ my @info = stat $d;
++
++ my $doc = {};
++ $doc->{'visible_path'} = $visible_path;
++ $doc->{'visible_fname'} = $visible_fname;
++ $doc->{'escaped_fname'} = &tools::escape_docname($fname, '/');
++ $doc->{'escaped_path'} = &tools::escape_docname($path, '/');
++ $doc->{'fname'} = $fname;
++ $doc->{'size'} = (-s $d)/1000;
++ $doc->{'date'} = gettext_strftime "%d %b %Y", localtime($info[9]);
++ $doc->{'author'} = $desc_hash{'email'};
++ $doc->{'path'} = $path;
++
++ push(@{$param->{'info_doc_mod'}},$doc)
++ }
++
++ unless (($param->{'spool'}) || ($param->{'mod_total_shared'} > 0)) {
++ &report::notice_report_web('no_msg_document', {'list' => $in{'list'}},$param->{'action'});
++ &wwslog('err','do_modindex: no message and no document');
++ }
++
++ return 1;
++ }
++
++### installation of moderated documents of shared
++ sub do_d_install_shared {
++ &wwslog('info', 'do_d_install_shared(%s)', $in{'id'});
++
++ if ($in{'mode_cancel'}) {
++ return 'modindex';
++ }
++
++ my $shareddir = $list->{'dir'}.'/shared';
++ my $file;
++ my $slash_path;
++ my $fname;
++ my $visible_fname;
++ # list of file already existing
++ my @list_file_exist;
++
++ unless($in{'mode_confirm'} || $in{'mode_cancel'}) {
++
++ # file already exists ?
++ foreach my $id (split /\0/, $in{'id'}) {
++
++ $file = "$shareddir$id";
++ $id =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
++ $slash_path = $1;
++ $fname = $3;
++ $visible_fname = &make_visible_path($fname);
++
++ if (-e "$file") {
++ if (-e "$shareddir$slash_path$visible_fname") {
++ push(@list_file_exist,"$slash_path$visible_fname");
++ }
++ }
++ }
++
++ if (@list_file_exist) {
++
++ $param->{'list_file'}=\@list_file_exist;
++ my @id = split(/\0/,$in{'id'});
++ $param->{'id'} = \@id;
++
++ return 1;
++ }
++ }
++
++ # install the file(s) selected
++ foreach my $id (split /\0/, $in{'id'}) {
++
++ $file = "$shareddir$id";
++ $id =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
++ $slash_path = $1;
++ $fname = $3;
++ my $new_fname; ## new filename without the .moderate extension
++ if ($fname =~ /^\.(.+)\.moderate$/) {
++ $new_fname = $1;
++ }
++ my $visible_path = &make_visible_path($slash_path);
++ $visible_fname = &make_visible_path($fname);
++
++ if (-e "$file") {
++
++ # rename the old file in .old if exists
++ if (-e "$shareddir$slash_path$new_fname") {
++ unless (rename "$shareddir$slash_path$new_fname","$shareddir$slash_path$new_fname.old"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir$slash_path$new_fname",
++ 'new'=>"$shareddir$slash_path$new_fname.old" },
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_install_shared : Failed to rename $shareddir$slash_path$new_fname to .old : %s",$!);
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ unless (rename "$shareddir$slash_path.desc.$new_fname","$shareddir$slash_path.desc.$new_fname.old"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir$slash_path.desc.$new_fname",
++ 'new'=>"$shareddir$slash_path.desc.$new_fname.old"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_install_shared : Failed to rename shareddir$slash_path.desc.$new_fname to .old : %s",$!);
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ }
++
++ unless (rename ("$shareddir$id","$shareddir$slash_path$new_fname")){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir$id",
++ 'new'=>"$shareddir$slash_path$new_fname"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_install_shared : Failed to rename $file to $shareddir$slash_path$new_fname : $!");
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ unless (rename ("$shareddir$slash_path.desc.$fname","$shareddir$slash_path.desc.$new_fname")){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir$slash_path.desc.$fname",
++ 'new'=>"$shareddir$slash_path.desc.$new_fname"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_install_shared : Failed to rename $file to $shareddir$slash_path$new_fname : $!");
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ # send a message to the author
++ my %context;
++ $context{'installed_by'} = $param->{'user'}{'email'};
++ $context{'filename'} = "$visible_path$visible_fname";
++
++ my %desc_hash;
++ if ($id && (-e "$shareddir$slash_path.desc.$visible_fname")){
++ %desc_hash = &get_desc_file("$shareddir$slash_path.desc.$visible_fname");
++ }
++
++ my $sender = $desc_hash{'email'};
++ unless ($list->send_file('d_install_shared', $sender, $robot, \%context)) {
++ &wwslog('notice',"Unable to send template 'd_install_shared' to $sender");
++ }
++ }
++ }
++
++ &report::notice_report_web('performed',{},$param->{'action'});
++ &web_db_log({'status' => 'success'});
++ return 'modindex';
++ }
++
++### reject moderated documents of shared
++ sub do_d_reject_shared {
++ &wwslog('info', 'do_d_reject_shared(%s)', $in{'id'});
++
++ my $shareddir = $list->{'dir'}.'/shared';
++ my $file;
++ my $slash_path;
++ my $fname;
++ my $visible_fname;
++
++ foreach my $id (split /\0/, $in{'id'}) {
++
++ $file = "$shareddir$id";
++ $id =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
++ $slash_path = $1;
++ $fname = $3;
++ $visible_fname = &make_visible_path($fname);
++ my $visible_path = &make_visible_path($slash_path);
++
++ unless ($in{'quiet'}) {
++
++ my %context;
++ my $sender;
++ $context{'rejected_by'} = $param->{'user'}{'email'};
++ $context{'filename'} = "$visible_path$visible_fname";
++
++ my %desc_hash;
++ if ($id && (-e "$shareddir$slash_path.desc.$fname")){
++ %desc_hash = &get_desc_file("$shareddir$slash_path.desc.$fname");
++ }
++ $sender = $desc_hash{'email'};
++
++ unless ($list->send_file('d_reject_shared', $sender, $robot, \%context)) {
++ &wwslog('notice',"Unable to send template 'd_reject_shared' to $sender");
++ }
++ }
++
++
++ unless (unlink($file)) {
++ &report::reject_report_web('intern','erase_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_d_reject_shared: failed to erase %s', $file);
++ &web_db_log({'parameters' => $in{'id'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ unless (unlink("$shareddir$slash_path.desc.$fname")) {
++ &report::reject_report_web('intern','erase_file',{'file' => "$shareddir$slash_path.desc.$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_reject_shared: failed to erase $shareddir$slash_path.desc.$fname");
++ &web_db_log({'parameters' => $in{'id'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++
++ &report::notice_report_web('performed',{},$param->{'action'});
++ &web_db_log({'parameters' => $in{'id'},
++ 'status' => 'success'});
++ return 'modindex';
++ }
++
++
++
++####################################################
++# do_reject
++####################################################
++# Moderation of messages : rejects messages and notifies
++# their senders. If in{'blacklist'} add sender to list blacklist
++#
++# IN : -
++#
++# OUT : 'loginrequest' | 'modindex' | undef
++#
++####################################################
++ sub do_reject {
++
++ # toggle selection javascript have a distinction of spam and ham base on the checkbox name . It is not useful here so join id list and idspam list.
++ $in{'id'} .= ','.$in{'idspam'} if ($in{'idspam'});
++ $in{'id'} =~ s/^,//;
++ $in{'id'} =~ s/\0/,/g;
++ $in{'message_template'};
++
++ ## The quiet information might either be provided by the 'quiet' variable
++ ## or by the 'quiet' value of the 'message_template' variable
++ if ($in{'message_template'} eq 'quiet') {
++ $in{'quiet'} = 1;
++ delete $in{'message_template'};
++ }
++ if ($in{'blacklist'}) {
++ $in{'quiet'} = 1;
++ }
++
++ &wwslog('info', 'do_reject(%s)', $in{'id'});
++ my ($msg, $file);
++
++ $param->{'blacklist_added'} = 0;
++ $param->{'blacklist_ignored'} = 0;
++ foreach my $id (split (/,/, $in{'id'})) {
++
++ ## For compatibility concerns
++ foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
++ $file = $Conf{'queuemod'}.'/'.$list_id.'_'.$id;
++ last if (-f $file);
++ }
++
++ ## Open the file
++ unless (open(IN, $file)) {
++ &report::reject_report_web('user','already_moderated',{},$param->{'action'});
++ &wwslog('err','do_reject: Unable to open %s', $file);
++ &web_db_log({'parameters' => $in{'id'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ next;
++ }
++
++ # extract sender address is needed to report reject to sender and in case the sender is to be added to the blacklist
++ if (($in{'quiet'} ne '1')||($in{'blacklist'})) {
++ my $msg;
++ my $parser = new MIME::Parser;
++ $parser->output_to_core(1);
++ unless ($msg = $parser->read(\*IN)) {
++ &wwslog('err', 'Unable to parse message %s', $file);
++ next;
++ }
++
++ my @sender_hdr = Mail::Address->parse($msg->head->get('From'));
++ unless ($#sender_hdr == -1) {
++ my $rejected_sender = $sender_hdr[0]->address;
++ unless ($in{'quiet'}) {
++ my %context;
++ $context{'subject'} = &MIME::EncWords::decode_mimewords($msg->head->get('subject'), Charset=>'utf8');
++ chomp $context{'subject'};
++ $context{'rejected_by'} = $param->{'user'}{'email'};
++ $context{'template_used'} = $in{'message_template'};
++ unless ($list->send_file($in{'message_template'}, $rejected_sender, $robot, \%context)) {
++ &wwslog('notice',"Unable to send template $in{'message_template'} to $rejected_sender");
++ }
++ }
++ if ($in{'blacklist'}) {
++ if (&tools::add_in_blacklist($rejected_sender,$robot,$list)) {
++ $param->{'blacklist_added'} += 1;
++ &wwslog('info',"added $rejected_sender to $list->{'name'} blacklist");
++ }else{
++ &wwslog('notice',"Unable to add $rejected_sender to $list->{'name'} blacklist");
++ $param->{'blacklist_ignored'} += 0;
++ }
++ }
++ }
++ }
++ close(IN);
++
++ unless (unlink($file)) {
++ &report::reject_report_web('intern','erase_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_reject: failed to erase %s', $file);
++ &web_db_log({'parameters' => $in{'id'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ }
++ &web_db_log({'parameters' => $in{'id'},
++ 'status' => 'success'});
++ &report::notice_report_web('performed',{},$param->{'action'});
++
++ return 'modindex';
++ }
++
++####################################################
++# do_distribute
++####################################################
++# Moderation of messages : distributes moderated
++# messages and tag it in message moderation context
++#
++# IN : - id of message to distribute. This value can also be in idspam parameter
++#
++# OUT : 'loginrequest' | 'modindex' | undef
++#
++######################################################
++ sub do_distribute {
++
++ $in{'id'} .= ','.$in{'idspam'} if ( $in{'idspam'});
++ $in{'id'} =~ s/^,//;
++ $in{'id'} =~ s/\0/,/g;
++
++ &wwslog('info', 'do_distribute(%s)', $in{'id'});
++ my ($msg, $file);
++
++ my $time = time;
++ my $data = {'headers' => {'Message-ID' => &tools::get_message_id($robot),
++ 'X-Sympa-NoWrap' => 'yes'},
++ 'from'=> $param->{'user'}{'email'}};
++
++ ## msg topics
++ my @msg_topics;
++ foreach my $msg_topic (@{$list->{'admin'}{'msg_topic'}}) {
++ my $var_name = "topic_"."$msg_topic->{'name'}";
++ if ($in{"$var_name"}) {
++ push @msg_topics, $msg_topic->{'name'};
++ }
++ }
++ my $list_topics = join(',',@msg_topics);
++
++ if (!$list_topics && $list->is_msg_topic_tagging_required()) {
++ &report::reject_report_web('user','msg_topic_missing',{},$param->{'action'});
++ &wwslog('info','do_distribute: message(s) without topic but in a required list');
++ &web_db_log({'parameters' => $in{'id'},
++ 'status' => 'error',
++ 'error_type' => 'no_topic'});
++ return undef;
++ }
++
++
++ ## messages
++ foreach my $id (split (/,/, $in{'id'})) {
++ my $mail_command = sprintf ("QUIET DISTRIBUTE %s %s\n",$list->{'name'},$id);
++ $data->{'body'} .= $mail_command;
++
++ ## For compatibility concerns
++ foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
++ $file = $Conf{'queuemod'}.'/'.$list_id.'_'.$id;
++ last if (-f $file);
++ }
++
++ unless (-f $file) {
++ &report::reject_report_web('user','already_moderated',{},$param->{'action'});
++ &wwslog('err','do_distribute: Unable to open %s', $file);
++ &web_db_log({'parameters' => $in{'id'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ next;
++ }
++
++ ## TAG
++ if ($list_topics) {
++
++ my $parser = new MIME::Parser;
++ $parser->output_to_core(1);
++
++ unless (open FILE, "$file") {
++ &wwslog('notice', 'do_distribute: Cannot open file %s', $file);
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &web_db_log({'parameters' => $in{'id'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ my $msg = $parser->parse(\*FILE);
++ my $head = $msg->head();
++ my $filetopic = $list->tag_topic(&tools::clean_msg_id($head->get('Message-Id')),$list_topics,'editor');
++ }
++
++ unless (rename($file,"$file.distribute")) {
++ &report::reject_report_web('intern','rename_file',{'old'=>$file,
++ 'new'=>"$file.distribute"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_distribute: failed to rename %s', $file);
++ &web_db_log({'parameters' => $in{'id'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ }
++ }
++
++ $data->{'not_auto_submitted'} = 1;
++ unless (&mail::mail_file('',&Conf::get_robot_conf($robot, 'sympa'), $data, $robot)) {
++ &report::reject_report_web('intern','cannot_send_distribute',{'from' => $param->{'user'}{'email'},'listname'=>$list->{'name'}},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_distribute: failed to send message for file %s', $file);
++ &web_db_log({'parameters' => $in{'id'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ &web_db_log({'parameters' => $in{'id'},
++ 'status' => 'success'});
++
++ &report::notice_report_web('performed_soon',{},$param->{'action'});
++
++ return 'modindex';
++ }
++
++####################################################
++# do_viewmod
++####################################################
++# Web page for an editor to moderate a mail and/or
++# to tag it in message topic context
++#
++# IN : -
++#
++# OUT : 'login,request' | '1' | undef
++#
++####################################################
++sub do_viewmod {
++ &wwslog('info', 'do_viewmod(%s,%s)', $in{'id'},$in{'file'});
++
++ my $msg;
++ my $tmp_dir;
++
++ my $available_files = &tools::get_templates_list('mail','',$list, {'ignore_global' => 1});
++ foreach my $file (keys %$available_files) {
++ next unless($file =~ /^reject_/);
++ $file =~ s/^reject_//;
++ $file =~ s/.tt2$//;
++ push (@{$param->{'available_files'}},$file);
++ }
++
++ ## For compatibility concerns
++ foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
++ $tmp_dir = $Conf{'queuemod'}.'/.'.$list_id.'_'.$in{'id'};
++ if (-d $tmp_dir) {
++ last;
++ }
++ }
++
++ unless (-d $tmp_dir) {
++ &report::reject_report_web('intern','no_html_message_available',{'dir' => $tmp_dir},$param->{'action'});
++ &wwslog('err','do_viewmod: no HTML version of the message available in %s', $tmp_dir);
++ return undef;
++ }
++
++ if ($in{'file'}) {
++ $in{'file'} =~ /\.(\w+)$/;
++ $param->{'file_extension'} = $1;
++ $param->{'file'} = $tmp_dir.'/'.$in{'file'};
++ $param->{'bypass'} = 1;
++ }else {
++ &tt2::add_include_path($tmp_dir) ;
++ }
++
++ $param->{'base'} = sprintf "%s/viewmod/%s/%s/", &Conf::get_robot_conf($robot, 'wwsympa_url'), $param->{'list'}, $in{'id'};
++ $param->{'id'} = $in{'id'};
++
++ if ($list->is_there_msg_topic()) {
++
++ $param->{'request_topic'} = 1;
++
++ foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
++ if ($top->{'name'}) {
++ push (@{$param->{'available_topics'}},$top);
++ }
++ }
++ $param->{'topic_required'} = $list->is_msg_topic_tagging_required();
++ }
++
++ return 1;
++ }
++
++
++## Edition of list/sympa files
++## No list -> sympa files (helpfile,...)
++## TODO : upload
++## TODO : edit family file ???
++ sub do_editfile {
++ &wwslog('info', 'do_editfile(%s)', $in{'file'});
++
++ $param->{'subtitle'} = sprintf $param->{'subtitle'}, $in{'file'};
++
++ unless ($in{'file'}) {
++ ## Messages edition
++ foreach my $f ('info','homepage','welcome.tt2','bye.tt2','removed.tt2','message.footer','message.header','remind.tt2','invite.tt2','reject.tt2','your_infected_msg.tt2') {
++ next unless ($list->may_edit($f, $param->{'user'}{'email'}) eq 'write');
++ if ($wwslib::filenames{$f}{'gettext_id'}) {
++ $param->{'files'}{$f}{'complete'} = gettext($wwslib::filenames{$f}{'gettext_id'});
++ }else {
++ $param->{'files'}{$f}{'complete'} = $f;
++ }
++ $param->{'files'}{$f}{'selected'} = '';
++ }
++ return 1;
++ }
++
++ unless (defined $wwslib::filenames{$in{'file'}}) {
++ &report::reject_report_web('user','file_not_editable',{'file' => $in{'file'}},$param->{'action'});
++ &wwslog('err','do_editfile: file %s not editable', $in{'file'});
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ $param->{'file'} = $in{'file'};
++
++ my $subdir = '';
++ if ($in{'file'} =~ /\.tt2$/) {
++ $subdir = 'mail_tt2/';
++ }
++
++ if ($param->{'list'}) {
++ my ($role,$right) = $list->may_edit($in{'file'}, $param->{'user'}{'email'});
++
++ unless ($right eq 'write') {
++ &report::reject_report_web('auth','edit_right',{'role'=>$role, 'right' => $right},$param->{'action'},$list);
++ &wwslog('err','do_editfile: not allowed');
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++ ## Add list lang to tpl filename
++ my $file = $in{'file'};
++ #$file =~ s/\.tpl$/\.$list->{'admin'}{'lang'}\.tpl/;
++
++ ## Look for the template
++ $param->{'filepath'} = &tools::get_filename('etc',{},$subdir.$file,$robot, $list);
++
++ ## There might be no matching file if default template not provided with Sympa
++ if (defined $param->{'filepath'}) {
++ ## open file and provide filecontent to the parser
++ ## It allows to us the correct file encoding
++ unless (open FILE, "<", $param->{'filepath'}) {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $param->{'filepath'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_editfile: failed to open file %s: %s', $param->{'filepath'},$!);
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ while (<FILE>) {
++ Encode::from_to($_, $Conf{'filesystem_encoding'}, 'utf8');
++ $param->{'filecontent'} .= $_;
++ }
++ close FILE;
++ }else {
++ $param->{'filepath'} = $list->{'dir'}.'/'.$subdir.$file;
++ }
++
++ ## Default for 'homepage' is 'info'
++ if (($in{'file'} eq 'homepage') &&
++ ! $param->{'filepath'}) {
++ $param->{'filepath'} = &tools::get_filename('etc',{},$subdir.'info',$robot, $list);
++ }
++ }else {
++ unless (&List::is_listmaster($param->{'user'}{'email'},$robot)) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
++ &wwslog('err','do_editfile: no list');
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'error',
++ 'error_type' => 'no_list'});
++ return undef;
++ }
++
++ my $file = $in{'file'};
++
++ ## Look for the template
++ if ($file eq 'list_aliases.tt2') {
++ $param->{'filepath'} = &tools::get_filename('etc',{},$file,$robot,$list);
++ }else {
++ #my $lang = &Conf::get_robot_conf($robot, 'lang');
++ #$file =~ s/\.tpl$/\.$lang\.tpl/;
++
++ $param->{'filepath'} = &tools::get_filename('etc',{},$subdir.$file,$robot,$list);
++ }
++ }
++
++ if (-f $param->{'filepath'} && (! -r $param->{'filepath'})) {
++ &report::reject_report_web('intern','cannot_read',{'filepath' => $param->{'filepath'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_editfile: cannot read %s', $param->{'filepath'});
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'success'});
++ &tt2::allow_absolute_path();
++
++ return 1;
++ }
++
++
++
++
++
++#####################################################################################
++
++ ## Saving of list files
++ sub do_savefile {
++ &wwslog('info', 'do_savefile(%s)', $in{'file'});
++
++ $param->{'subtitle'} = sprintf $param->{'subtitle'}, $in{'file'};
++
++ if ($param->{'list'}) {
++ unless ($list->am_i('owner', $param->{'user'}{'email'})) {
++ &report::reject_report_web('auth','action_owner',{},$param->{'action'},$list);
++ &wwslog('err','do_savefile: not allowed');
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++ if ($in{'file'} =~ /\.tt2$/) {
++ $param->{'filepath'} = $list->{'dir'}.'/mail_tt2/'.$in{'file'};
++ }else {
++ $param->{'filepath'} = $list->{'dir'}.'/'.$in{'file'};
++
++ if (defined $list->{'admin'}{'family_name'}) {
++ unless ($list->update_config_changes('file',$in{'file'})) {
++ &report::reject_report_web('intern','update_config_changes',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_savefile: cannot write in config_changes for file %s', $param->{'filepath'});
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++
++ }
++ }else {
++ unless (&List::is_listmaster($param->{'user'}{'email'}),$robot) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
++ &wwslog('err','do_savefile: no list');
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'error',
++ 'error_type' => 'no_list'});
++ return undef;
++ }
++
++ if ($robot ne $Conf{'domain'}) {
++ if ($in{'file'} eq 'list_aliases.tt2') {
++ $param->{'filepath'} = "$Conf{'etc'}/$robot/$in{'file'}";
++ }else {
++ $param->{'filepath'} = "$Conf{'etc'}/$robot/mail_tt2/$in{'file'}";
++ }
++ }else {
++ if ($in{'file'} eq 'list_aliases.tt2') {
++ $param->{'filepath'} = "$Conf{'etc'}/$in{'file'}";
++ }else {
++ $param->{'filepath'} = "$Conf{'etc'}/mail_tt2/$in{'file'}";
++ }
++ }
++ }
++
++ unless ((! -e $param->{'filepath'}) or (-w $param->{'filepath'})) {
++ &report::reject_report_web('intern','cannot_write',{'filepath' => $param->{'filepath'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_savefile: cannot write %s', $param->{'filepath'});
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ ## Keep the old file
++ if (-e $param->{'filepath'}) {
++ rename($param->{'filepath'}, "$param->{'filepath'}.orig");
++ }
++
++ ## Not empty
++ if ($in{'content'} && ($in{'content'} !~ /^\s*$/)) {
++
++ ## Remove DOS linefeeds (^M) that cause problems with Outlook 98, AOL, and EIMS:
++ $in{'content'} =~ s/\015//g;
++
++ ## Create directory if required
++ my $dir = $param->{'filepath'};
++ $dir =~ s/\/[^\/]+$//;
++ unless (-d $dir) {
++ unless (mkdir $dir, 0777) {
++ &report::reject_report_web('intern','cannot_mkdir',{'dir' => $dir},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_savefile: failed to create directory %s: %s', $dir,$!);
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++
++ ## Save new file
++ unless (open FILE, ">", $param->{'filepath'}) {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $param->{'filepath'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_savefile: failed to save file %s: %s', $param->{'filepath'},$!);
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ my $e = $in{'content'};
++ Encode::from_to($e, 'utf8', $Conf{'filesystem_encoding'});
++ print FILE $e;
++ close FILE;
++ }elsif (-f $param->{'filepath'}) {
++ &wwslog('info', 'do_savefile: deleting %s', $param->{'filepath'});
++ unlink $param->{'filepath'};
++ }
++ &web_db_log({'parameters' => $in{'file'},
++ 'status' => 'success'});
++
++ &report::notice_report_web('performed',{},$param->{'action'});
++
++ # undef $in{'file'};
++ # undef $param->{'file'};
++ return 'editfile';
++ }
++
++ ## Access to web archives
++sub do_arc {
++ &wwslog('info', 'do_arc(%s, %s)', $in{'month'}, $in{'arc_file'});
++ my $latest;
++
++ my $index = $session->{'arc_mode'} ;
++ unless ($index) {$index = $wwsconf->{'archive_default_index'};}
++
++ ## Clean arc_file
++ if ($in{'arc_file'} eq '/') {
++ delete $in{'arc_file'};
++ }
++
++ ## Access control
++ unless (defined &check_authz('do_arc', 'web_archive.access')) {
++ $param->{'previous_action'} = 'arc';
++ $param->{'previous_list'} = $list->{'name'};
++ return undef;
++ }
++
++ $session->{'archive_sniffer'} = 'false' if ($param->{'user'}{'email'} or $in{'not_a_sniffer'}) ;
++
++ if ($list->{'admin'}{'web_archive_spam_protection'} eq 'cookie'){
++ return 'arc_protect' unless ($session->{'archive_sniffer'} eq 'false') ;
++ }
++
++ my $arc_path = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
++ ## Calendar
++ unless (opendir ARC, $arc_path) {
++ &report::reject_report_web('user','empty_archives',{},$param->{'action'},$list);
++ &wwslog('err','do_arc: no directory %s', $arc_path);
++ return undef;
++ }
++ foreach my $dir (sort grep(!/^\./,readdir ARC)) {
++ if ($dir =~ /^(\d{4})-(\d{2})$/ && -d $arc_path.'/'.$dir.'/arctxt') {
++ $param->{'calendar'}{$1}{$2} = '???';
++ if (open(IDX, $arc_path.'/'.$dir.'/index')) {
++ my ($msgs) = <IDX>;
++ chomp ($msgs);
++ close IDX;
++ $param->{'calendar'}{$1}{$2} = $msgs if ($msgs);
++ }
++ $latest = $dir;
++ }
++ }
++ closedir ARC;
++
++ ## Read html file
++ $in{'month'} ||= $latest;
++ my $arc_month_path = $arc_path.'/'.$in{'month'};
++
++ unless ($in{'arc_file'}) {
++ undef $latest;
++ unless (opendir ARC, $arc_month_path) {
++ &wwslog('err',"unable to readdir $arc_month_path");
++ &report::reject_report_web('user','month_not_found',{'month' => $in{'month'},
++ 'dir' => $arc_month_path,
++ 'listname' => $param->{'list'}},
++ $param->{'action'},
++ $list,$param->{'user'}{'email'},
++ $robot);
++ }
++ foreach my $file (grep(/^$index/,readdir ARC)) {
++ if ($file =~ /^$index(\d+)\.html$/) {
++ $latest = $1 if ($latest < $1);
++ }
++ }
++ closedir ARC;
++
++ $in{'arc_file'} = $index.$latest.".html";
++ }
++
++ ## File exist ?
++ my $arc_file_path = $arc_month_path.'/'.$in{'arc_file'};
++ unless (-r $arc_file_path) {
++ &wwslog('err',"unable to read $arc_file_path");
++ &report::reject_report_web('user','arc_not_found',{'arc_file' => $in{'arc_file'},
++ 'path' => $arc_file_path,
++ 'listname' => $param->{'list'}},
++ $param->{'action'},
++ $list,$param->{'user'}{'email'},
++ $robot);
++ return undef;
++ }
++
++ ## File type
++ if ($in{'arc_file'} =~ /^(mail\d+|msg\d+|thrd\d+)\.html$/) {
++
++ if ($in{'arc_file'} =~/^(thrd|mail)\d+\.html/) {
++ $session->{'arc_mode'} = $1;
++ }
++ if ($param->{'user'}{'email'}){
++ if ($param->{'user'}{'prefs'}{'arc_mode'} ne $session->{'arc_mode'}) {
++ # update user pref as soon as connected user change the way he consult archives
++ $param->{'user'}{'prefs'}{'arc_mode'} = $session->{'arc_mode'};
++ &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
++ }
++ }
++
++ if ($in{'arc_file'} =~ /^(msg\d+)\.html$/) {
++ ## If the file is a message, load the metadata to find out who is the author of the message
++ my $metadata = &Archive::load_html_message('file_path' => $arc_file_path);
++ $param->{'include_picture'} = &tools::make_pictures_url('email' => $metadata->{'X-From'}, 'list' => $list);
++
++ $param->{'subtitle'} = $metadata->{'X-Subject'};
++ }
++
++ ## Provide a filehandle to the TT2 parser (instead of a filename previously)
++ ## It allows to set the appropriate utf8 binmode on the FH
++ open $param->{'file_handle'}, "<", $arc_file_path;
++
++ &tt2::add_include_path($arc_month_path);
++ }else {
++
++ if ($in{'arc_file'} =~ /\.(\w+)$/) {
++ $param->{'file_extension'} = $1;
++ }
++
++ $param->{'bypass'} = 1;
++
++ $param->{'file'} = $arc_file_path;
++ }
++
++ my @stat = stat ($arc_file_path);
++ $param->{'date'} = $stat[9];
++ # send page as static if client is a bot. That's prevent crawling all archices every weeks by google, yahoo and others bots
++ if ($session->{'is_a_crawler'}) {
++ $param->{'header_date'} = $stat[9];
++ }
++ $param->{'base'} = sprintf "%s%s/arc/%s/%s/%s", $param->{'base_url'}, $param->{'path_cgi'}, $param->{'list'}, $in{'month'}, $in{'arc_file'};
++ $param->{'archive_name'} = $in{'month'};
++
++ return 1;
++}
++
++ ## Access to latest web archives
++ sub do_latest_arc {
++ &wwslog('info', 'do_latest_arc(%s,%s,%s)', $in{'list'}, $in{'for'}, $in{'count'});
++
++ ## Access control
++ return undef unless (defined &check_authz('do_latest_arc', 'web_archive.access'));
++
++ ## parameters of the query
++ my $today = time;
++
++ my $oldest_day;
++ if (defined $in{'for'}) {
++ $oldest_day = $today - (86400 * ($in{'for'}));
++ $param->{'for'} = $in{'for'};
++ unless ($oldest_day >= 0){
++ &report::reject_report_web('user','nb_days_to_much',{'nb_days' => $in{'for'} },$param->{'action'},$list);
++ &wwslog('err','do_latest_lists: parameter "for" is too big"');
++ }
++ }
++
++ my $nb_arc;
++ my $NB_ARC_MAX = 100;
++ if (defined $in{'count'}) {
++ if ($in{'count'} > $NB_ARC_MAX) {
++ $in{'count'} = $NB_ARC_MAX;
++ }
++ $param->{'count'} = $in{'count'};
++ $nb_arc = $in{'count'};
++ } else {
++ $nb_arc = $NB_ARC_MAX;
++ }
++
++ my $arc_path = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
++ unless (opendir ARC_DIR, $arc_path) {
++ &report::reject_report_web('user','empty_archives',{},$param->{'action'},$list);
++ &wwslog('err','do_latest_arc: no directory %s', $arc_path);
++ return undef;
++ }
++
++ my @months;
++ my $latest;
++ foreach my $dir (sort grep(!/^\./,readdir ARC_DIR)) {
++ if ($dir =~ /^(\d{4})-(\d{2})$/) {
++ push @months, $dir;
++ $latest = $dir;
++ }
++ }
++ closedir ARC_DIR;
++
++ @months = reverse @months;
++ my $stop_search;
++
++ my @archives;
++
++ ## year-month directory
++ foreach my $year_month (@months) {
++ if ($nb_arc <= 0) {
++ last;
++ }
++
++ last if $stop_search;
++
++ my $arc_month_path = $arc_path.'/'.$year_month.'/arctxt';
++ unless (opendir MONTH, $arc_month_path) {
++ &report::reject_report_web('intern','inaccessible_archive',{'path' => $arc_month_path,
++ 'listname' => $list->{'name'}},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_latest_arc: unable to open directory %s', $arc_month_path);
++ next;
++ }
++
++ ## mails in the year-month directory
++ foreach my $arc (sort {$b <=> $a} grep(!/^\./,readdir MONTH)) {
++ last if ($nb_arc <= 0);
++
++ if ($arc =~ /^(\d)+$/) {
++ my %msg_info;
++
++ use MIME::Parser;
++ my $parser = new MIME::Parser;
++ $parser->output_to_core(1);
++
++ my $arc_file = $arc_month_path.'/'.$arc;
++
++ unless (open (FILE, $arc_file)) {
++ &wwslog('err', 'Unable to open file %s', $arc_file);
++ }
++
++ my $message;
++ unless ($message = $parser->read(\*FILE)) {
++ &wwslog('err', 'Unable to parse message %s', $arc_file);
++ next;
++ }
++
++ use Mail::Header;
++ my $hdr = $message->head;
++
++ unless (defined $hdr) {
++ &wwslog('err', 'Unable to parse header of message %s', $arc_file);
++ next;
++ }
++
++ foreach my $field ('message-id','subject','from') {
++
++ my $var = $field; $var =~ s/-/_/g;
++
++ $msg_info{$var} = $hdr->get($field);
++
++ if (ref $msg_info{$var} eq 'ARRAY') {
++ $msg_info{$var} = $msg_info{$var}->[0];
++ }
++
++ ## Hide full email address
++ if ($field eq 'from') {
++ if ($msg_info{$var} =~ /(.+)\<.+\>/) {
++ $msg_info{$var} = $1;
++ }else {
++ my @email = split /\@/, $msg_info{$var};
++ $msg_info{$var} = $email[0];
++ }
++ }
++
++ if ($field eq 'message-id') {
++ $msg_info{$var} = &tools::clean_msg_id($msg_info{'message_id'});
++ $msg_info{$var} = &tools::escape_chars($msg_info{$var});
++
++ $msg_info{'year_month'} = $year_month;
++ }else {
++ $msg_info{$var} = &MIME::EncWords::decode_mimewords($msg_info{$var}, Charset=>'utf8');
++ $msg_info{$var} = &tools::escape_html($msg_info{$var});
++ }
++ }
++
++ my $date = $hdr->get('Date');
++
++ unless (defined $date) {
++ &wwslog('err', 'No date found in message %s', $arc_file);
++ next;
++ }
++
++ my @array_date = &time_utils::parse_date($date);
++
++ $msg_info{'date_smtp'} = $date;
++ $msg_info{'date_epoch'} = &get_timelocal_from_date(@array_date[1..$#array_date]);
++
++ $msg_info{'date'} = gettext_strftime "%d %b %Y", localtime($msg_info{'date_epoch'});
++ if ($msg_info{'date_epoch'} < $oldest_day) {
++ $stop_search = 1;
++ last;
++ }
++
++ foreach my $key (keys %msg_info) {
++ chomp($msg_info{$key});
++ }
++
++ push @archives,\%msg_info;
++ $nb_arc--;
++ }
++ }
++ closedir MONTH;
++
++
++ }
++
++ @{$param->{'archives'}} = sort ({$b->{'date_epoch'} <=> $a->{'date_epoch'}} @archives);
++
++ return 1;
++ }
++
++
++sub get_timelocal_from_date {
++ my($mday, $mon, $yr, $hr, $min, $sec, $zone) = @_;
++ my($time) = 0;
++
++ $yr -= 1900 if $yr >= 1900; # if given full 4 digit year
++ $yr += 100 if $yr <= 37; # in case of 2 digit years
++ if (($yr < 70) || ($yr > 137)) {
++ warn "Warning: Bad year (", $yr+1900, ") using current\n";
++ $yr = (localtime(time))[5];
++ }
++
++ $time = &timelocal($sec,$min,$hr,$mday,$mon,$yr);
++ return $time
++
++}
++
++
++
++####################################################
++# do_remove_arc
++####################################################
++#
++# request by list owner or message sender to remove message from archive
++# Create in the outgoing spool a file containing the message-id of mesage to be removed
++#
++# IN : list@host yyyy month and a tab of msgid
++#
++# OUT : 1 | undef
++#
++####################################################
++
++sub do_remove_arc {
++ &wwslog('info', 'do_remove_arc : list %s, yyyy %s, mm %s, #message %s', $in{'list'}, $in{'yyyy'}, $in{'month'});
++
++ my $arcpath = $wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$in{'yyyy'}.'-'.$in{'month'};
++
++ ## Access control
++
++# $in{'msgid'} = &tools::unescape_chars($in{'msgid'});
++ my @msgids = split /\0/, $in{'msgid'};
++
++ if ($#msgids == -1) {
++ &report::reject_report_web('user','may_not_remove_arc',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','remove_arc: no message id found');
++ &web_db_log({'parameters' => $in{'msgid'},
++ 'msg_id' => $in{'msgid'},
++ 'status' => 'error',
++ 'error_type' => 'no_msgid'});
++ $param->{'status'} = 'no_msgid';
++ return undef;
++ }
++
++ my $file = $Conf{'queueoutgoing'}.'/.remove.'.$list->get_list_id().'.'.$in{'yyyy'}.'-'.$in{'month'}.'.'.time;
++ unless (open REBUILD, ">$file") {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_remove: cannot create %s', $file);
++ &web_db_log({'parameters' => $in{'msgid'},
++ 'msg_id' => $in{'msgid'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ closedir ARC;
++ return undef;
++ }
++
++ foreach my $msgid (@msgids) {
++ chomp $msgid ;
++ printf REBUILD ('%s||%s',$msgid,$param->{'user'}{'email'}) ; printf REBUILD "\n";
++ }
++ close REBUILD;
++ &wwslog('info', 'do_remove_arc %d messages marked to be removed by archived', $#msgids+1);
++ &web_db_log({'parameters' => $in{'msgid'},
++ 'msg_id' => $in{'msgid'},
++ 'status' => 'success'});
++ $param->{'status'} = 'done';
++
++ return 1;
++}
++
++
++####################################################
++# do_send_me
++####################################################
++# Sends a web archive message to a
++# requesting user
++# It uses mail::mail_forward() to do it.
++#
++# IN : -
++#
++# OUT : 'arc' | 1 | undef
++#
++####################################################
++ sub do_send_me {
++ &wwslog('info', 'do_send_me(%s, %s, %s, %s', $in{'list'}, $in{'yyyy'}, $in{'month'}, $in{'msgid'});
++
++ if (! $in{'msgid'} ||
++ $in{'msgid'} =~ /NO-ID-FOUND\.mhonarc\.org/) {
++ &report::reject_report_web('intern','may_not_send_me',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','send_me: no message id found');
++ $param->{'status'} = 'no_msgid';
++ return undef;
++ }
++ ##
++ my $arcpath = $wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$in{'yyyy'}.'-'.$in{'month'};
++
++ opendir ARC, "$arcpath/arctxt";
++ my $msgfile;
++ foreach my $file (grep (!/\./,readdir ARC)) {
++ &wwslog('debug','send_me: scanning %s', $file);
++ next unless (open MAIL,"$arcpath/arctxt/$file") ;
++ while (<MAIL>) {
++ last if /^$/ ;
++ if (/^Message-id:\s?<?([^>\s]+)>?\s?/i ) {
++ my $id = $1;
++ if ($id eq $in{'msgid'}) {
++ $msgfile = $file ;
++ }
++ last ;
++ }
++ }
++ close MAIL ;
++ }
++ if ($msgfile) {
++ unless (open MSG, "$arcpath/arctxt/$msgfile") {
++ $param->{'status'} = 'message_err';
++ &wwslog('info', 'do_send_me : could not read file %s',"$arcpath/arctxt/$msgfile");
++ }
++ my $msg_string;
++ while (<MSG>){
++ $msg_string .= $_ ;
++ }
++ close MSG;
++
++ unless (&mail::mail_forward($msg_string,&Conf::get_robot_conf($robot, 'sympa'),\$param->{'user'}{'email'},$robot)) {
++ $param->{'status'} = 'message_err';
++ &wwslog('err',"do_send_me : impossible to send archive file to %s",$param->{'user'}{'email'});
++ return undef;
++ }
++ &wwslog('info', 'do_send_me message %s spooled for %s', "$arcpath/arctxt/$msgfile", $param->{'user'}{'email'} );
++ &report::notice_report_web('performed',{},$param->{'action'});
++ $in{'month'} = $in{'yyyy'}."-".$in{'month'};
++ return 'arc';
++
++ }else{
++ &wwslog('info', 'do_send_me : no file match msgid');
++ $param->{'status'} = 'not_found';
++ return undef;
++ }
++
++ return 1;
++ }
++
++####################################################
++# do_view_source
++####################################################
++# Display message as text/plain in archives
++#
++# IN : -
++#
++# OUT : 'arc' | 1 | undef
++#
++####################################################
++ sub do_view_source {
++ &wwslog('info', 'do_view_source(%s, %s, %s, %s', $in{'list'}, $in{'yyyy'}, $in{'month'}, $in{'msgid'});
++
++
++ ## Access control
++ unless (defined &check_authz('do_arc', 'web_archive.access')) {
++ $param->{'previous_action'} = 'arc';
++ $param->{'previous_list'} = $list->{'name'};
++ return undef;
++ }
++
++ if (! $in{'msgid'} ||
++ $in{'msgid'} =~ /NO-ID-FOUND\.mhonarc\.org/) {
++ &report::reject_report_web('intern','may_not_view_source',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','view_source: no message id found');
++ $param->{'status'} = 'no_msgid';
++ return undef;
++ }
++ ##
++ my $arcpath = $wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$in{'yyyy'}.'-'.$in{'month'};
++
++ opendir ARC, "$arcpath/arctxt";
++ my $msgfile;
++ foreach my $file (grep (!/\./,readdir ARC)) {
++ &wwslog('debug','view_source: scanning %s', $file);
++ next unless (open MAIL,"$arcpath/arctxt/$file") ;
++ while (<MAIL>) {
++ last if /^$/ ;
++ if (/^Message-id:\s?<?([^>\s]+)>?\s?/i ) {
++ my $id = $1;
++ if ($id eq $in{'msgid'}) {
++ $msgfile = $file ;
++ }
++ last ;
++ }
++ }
++ close MAIL ;
++ }
++ if ($msgfile) {
++ unless (open MSG, "$arcpath/arctxt/$msgfile") {
++ $param->{'status'} = 'message_err';
++ &wwslog('info', 'do_view_source : could not read file %s',"$arcpath/arctxt/$msgfile");
++ }
++
++ $param->{'bypass'} = 'extreme';
++ printf "Content-Type: text/plain\n\n";
++ while (<MSG>){
++ printf $_ ;
++ }
++ close MSG;
++
++
++ }else{
++ &wwslog('info', 'do_view_source : no file match msgid');
++ $param->{'status'} = 'not_found';
++ return undef;
++ }
++
++ return 1;
++ }
++
++ ## Output an initial form to search in web archives
++ sub do_arcsearch_form {
++ &wwslog('info', 'do_arcsearch_form(%s)', $param->{'list'});
++
++ ## Access control
++ return undef unless (defined &check_authz('do_arcsearch_form', 'web_archive.access'));
++
++ my $search_base = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
++ opendir ARC, "$search_base";
++ foreach my $dir (sort {$b cmp $a} grep(!/^\./,readdir ARC)) {
++ if ($dir =~ /^(\d{4})-(\d{2})$/) {
++ push @{$param->{'yyyymm'}}, $dir;
++ }
++ }
++ closedir ARC;
++
++ $param->{'key_word'} = $in{'key_word'};
++ $param->{'archive_name'} = $in{'archive_name'};
++
++ return 1;
++ }
++
++ ## Search in web archives
++ sub do_arcsearch {
++ &wwslog('info', 'do_arcsearch(%s)', $param->{'list'});
++
++ ## Access control
++ return undef unless (defined &check_authz('do_arcsearch', 'web_archive.access'));
++
++ use Marc::Search;
++
++ my $search = new Marc::Search;
++ $search->search_base ($wwsconf->{'arc_path'} . '/' . $list->get_list_id());
++ $search->base_href (&Conf::get_robot_conf($robot, 'wwsympa_url') . '/arc/' . $param->{'list'});
++ $search->archive_name ($in{'archive_name'});
++
++ unless (defined($in{'directories'})) {
++ # by default search in current month and in the previous none empty one
++ my $search_base = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
++ opendir ARC, "$search_base";
++ foreach my $dir (sort {$b cmp $a} grep(!/^\./,readdir ARC)) {
++ if ($dir =~ /^(\d{4})-(\d{2})$/) {
++ push @{$param->{'yyyymm'}}, $dir;
++ }
++ }
++ closedir ARC;
++ $in{'directories'} = join "\0",@{$param->{'yyyymm'}} ;
++ }
++
++ if (defined($in{'directories'})) {
++ $search->directories ($in{'directories'});
++ foreach my $dir (split/\0/, $in{'directories'}) {
++ push @{$param->{'directories'}}, $dir;
++ }
++ }
++
++ if (defined $in{'previous'}) {
++ $search->body_count ($in{'body_count'});
++ $search->date_count ($in{'date_count'});
++ $search->from_count ($in{'from_count'});
++ $search->subj_count ($in{'subj_count'});
++ $search->previous ($in{'previous'});
++ }
++
++ ## User didn't enter any search terms
++ if ($in{'key_word'} =~ /^\s*$/) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'key_word'},$param->{'action'});
++ &wwslog('info','do_arcsearch: no search term');
++ return undef;
++ }elsif ($in{'key_word'} =~ /[<>\\\*\$]/) {
++ &report::reject_report_web('user','syntax_errors',{'params' => 'key_word'},$param->{'action'});
++ &wwslog('info','do_arcsearch: syntax error');
++ return undef;
++ }
++
++ $param->{'key_word'} = &tools::escape_regexp($in{'key_word'});
++
++ $search->limit ($in{'limit'});
++
++ $search->age (1)
++ if ($in{'age'} eq 'new');
++
++ $search->match (1)
++ if (($in{'match'} eq 'partial') or ($in{'match'} eq '1'));
++
++ my @words = split(/\s+/,&tools::escape_regexp($in{'key_word'}));
++ $search->words (\@words);
++ $search->clean_words ($in{'key_word'});
++ my @clean_words = @words;
++
++ for my $i (0 .. $#words) {
++ $words[$i] =~ s,/,\\/,g;
++ $words[$i] = '\b' . $words[$i] . '\b' if ($in{'match'} eq 'exact');
++ }
++ $search->key_word (join('|',@words));
++
++ if ($in{'case'} eq 'off') {
++ $search->case(1);
++ $search->key_word ('(?i)' . $search->key_word);
++ }
++ if ($in{'how'} eq 'any') {
++ $search->function2 ($search->match_any(@words));
++ $search->how ('any');
++ }elsif ($in{'how'} eq 'all') {
++ $search->function1 ($search->body_match_all(@clean_words,@words));
++ $search->function2 ($search->match_all(@words));
++ $search->how ('all');
++ }else {
++ $search->function2 ($search->match_this(@words));
++ $search->how ('phrase');
++ }
++
++ $search->subj (defined($in{'subj'}));
++ $search->from (defined($in{'from'}));
++ $search->date (defined($in{'date'}));
++ $search->body (defined($in{'body'}));
++
++ $search->body (1)
++ if ( not ($search->subj)
++ and not ($search->from)
++ and not ($search->body)
++ and not ($search->date));
++
++ my $searched = $search->search;
++
++ if (defined($search->error)) {
++ &wwslog('info','do_arcsearch_search_error : %s', $search->error);
++ }
++
++ $search->searched($searched);
++
++ if ($searched < $search->file_count) {
++ $param->{'continue'} = 1;
++ }
++
++ foreach my $field ('list','archive_name','age','body','case','date','from','how','limit','match','subj') {
++ $param->{$field} = $in{$field};
++ }
++
++ $param->{'body_count'} = $search->body_count;
++ $param->{'clean_words'} = $search->clean_words;
++ $param->{'date_count'} = $search->date_count;
++ $param->{'from_count'} = $search->from_count;
++ $param->{'subj_count'} = $search->subj_count;
++
++ $param->{'num'} = $search->file_count + 1;
++ $param->{'searched'} = $search->searched;
++
++ $param->{'res'} = $search->res;
++
++ ## Decode subject header fields
++ foreach my $m (@{$param->{'res'}}) {
++ $m->{'subj'} = &MIME::EncWords::decode_mimewords($m->{'subj'}, Charset=>'utf8');
++ }
++
++ return 1;
++ }
++
++ ## Search message-id in web archives
++ sub do_arcsearch_id {
++ &wwslog('info', 'do_arcsearch_id(%s,%s,%s)', $param->{'list'},$in{'archive_name'},$in{'msgid'});
++
++ ## Access control
++ return undef unless (defined &check_authz('do_arcsearch_id', 'web_archive.access'));
++
++ use Marc::Search;
++
++ my $search = new Marc::Search;
++ $search->search_base ($wwsconf->{'arc_path'} . '/' . $list->get_list_id());
++ $search->base_href (&Conf::get_robot_conf($robot, 'wwsympa_url') . '/arc/' . $param->{'list'});
++
++ $search->archive_name ($in{'archive_name'});
++
++ # search in current month and in the previous none empty one
++ my $search_base = $search->search_base;
++ my $previous_active_dir ;
++ opendir ARC, "$search_base";
++ foreach my $dir (sort {$b cmp $a} grep(!/^\./,readdir ARC)) {
++ if (($dir =~ /^(\d{4})-(\d{2})$/) && ($dir lt $search->archive_name)) {
++ $previous_active_dir = $dir;
++ last;
++ }
++ }
++ closedir ARC;
++ $in{'archive_name'} = $search->archive_name."\0".$previous_active_dir ;
++
++ $search->directories ($in{'archive_name'});
++ # $search->directories ($search->archive_name);
++
++ ## User didn't enter any search terms
++ if ($in{'msgid'} =~ /^\s*$/) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'msgid'},$param->{'action'});
++ &wwslog('info','do_arcsearch_id: no search term');
++ return undef;
++ }
++
++ $param->{'msgid'} = &tools::unescape_chars($in{'msgid'});
++ $in{'msgid'} = &tools::escape_regexp($in{'msgid'});
++
++ ## Mhonarc escapes some characters : '-' (-) and '&' (&)
++ $in{'msgid'} =~ s/\&/\&\#38\;/g;
++ $in{'msgid'} =~ s/\-/\&\#45\;/g;
++
++ $search->limit (1);
++
++ my @words = split(/\s+/,$in{'msgid'});
++ $search->words (\@words);
++ $search->clean_words ($in{'msgid'});
++ my @clean_words = @words;
++
++ $search->key_word (join('|',@words));
++
++ $search->function2 ($search->match_this(@words));
++
++ $search->id (1);
++
++ my $searched = $search->search;
++
++ if (defined($search->error)) {
++ &wwslog('info','do_arcsearch_id_search_error : %s', $search->error);
++ }
++
++ $search->searched($searched);
++
++ $param->{'res'} = $search->res;
++
++ unless ($#{$param->{'res'}} >= 0) {
++ &report::reject_report_web('intern_quiet','archive_not_found',{'msgid'=> $in{'msgid'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','No message found in archives matching Message-ID %s', $in{'msgid'});
++ return 'arc';
++ }
++
++ $param->{'redirect_to'} = $param->{'res'}[0]{'file'};
++
++ return 1;
++ }
++
++ # get pendings lists
++ sub do_get_pending_lists {
++
++ &wwslog('info', 'get_pending_lists');
++
++ ## Checking families and other virtual hosts.
++ &get_server_details();
++
++ my $all_lists = &List::get_lists($robot);
++ foreach my $list ( @$all_lists ) {
++ if ($list->{'admin'}{'status'} eq 'pending') {
++ $param->{'pending'}{$list->{'name'}}{'subject'} = $list->{'admin'}{'subject'};
++ $param->{'pending'}{$list->{'name'}}{'by'} = $list->{'admin'}{'creation'}{'email'};
++ $param->{'pending'}{$list->{'name'}}{'date'} = gettext_strftime "%d %b %y %H:%M", localtime($list->{'admin'}{'creation'}{'date_epoch'});
++ }
++ }
++
++ return 1;
++ }
++
++ # get closed lists
++ sub do_get_closed_lists {
++
++ &wwslog('info', 'get_closed_lists');
++
++ ## Checking families and other virtual hosts.
++ &get_server_details();
++
++ my $all_lists = &List::get_lists($robot);
++ foreach my $list ( @$all_lists ) {
++ if ($list->{'admin'}{'status'} eq 'closed' ||
++ $list->{'admin'}{'status'} eq 'family_closed') {
++ $param->{'closed'}{$list->{'name'}}{'subject'} = $list->{'admin'}{'subject'};
++ $param->{'closed'}{$list->{'name'}}{'by'} = $list->{'admin'}{'creation'}{'email'};
++ }
++ }
++
++ return 1;
++ }
++
++ # get ordered latest lists
++ sub do_get_latest_lists {
++
++ &wwslog('info', 'get_latest_lists');
++
++ ## Checking families and other virtual hosts.
++ &get_server_details();
++
++ my @unordered_lists;
++ my $all_lists = &List::get_lists($robot);
++ foreach my $list ( @$all_lists ) {
++
++ push @unordered_lists, {'name' => $list->{'name'},
++ 'subject' => $list->{'admin'}{'subject'},
++ 'creation_date' => $list->{'admin'}{'creation'}{'date_epoch'}};
++ }
++
++ foreach my $l (sort {$b->{'creation_date'} <=> $a->{'creation_date'}} @unordered_lists) {
++ push @{$param->{'latest_lists'}}, $l;
++ $l->{'creation_date'} = gettext_strftime "%d %b %Y", localtime($l->{'creation_date'});
++ }
++
++ return 1;
++ }
++
++
++# get inactive lists
++sub do_get_inactive_lists {
++
++ &wwslog('info', 'get_inactive_lists');
++
++ ## Checking families and other virtual hosts.
++ &get_server_details();
++
++ my @unordered_lists;
++ my $all_lists = &List::get_lists($robot);
++ foreach my $list ( @$all_lists ) {
++
++ ## skip closed lists
++ if ($list->{'admin'}{'status'} eq 'closed') {
++ next;
++ }
++
++ my $last_message;
++
++ if (open COUNT, $list->{'dir'}.'/msg_count') {
++ while (<COUNT>) {
++ $last_message = $1 if (/^(\d+)\s/ && ($1 > $last_message));
++ }
++ close COUNT;
++
++ }else {
++ &wwslog('info', 'Could not open file %s', $list->{'dir'}.'/msg_count');
++ }
++
++
++ push @unordered_lists, {
++ 'name' => $list->{'name'},
++ 'creator' =>$list->{'admin'}{'creation'}{'email'},
++ 'send_scenario' =>$list->{'admin'}{'send'}{'name'},
++ 'owners' => join(", ", map {$_->{'email'}} @{$list->{'admin'}{'owner'}}),
++ 'editors' => join(", ", map {$_->{'email'}} @{$list->{'admin'}{'editor'}}),
++ 'subscribers_count' => $list->get_total('nocache'),
++ 'subject' => $list->{'admin'}{'subject'},
++ 'msg_count' => $list->get_msg_count(),
++ 'last_message_epoch' => $last_message,
++ 'last_message_date' => (gettext_strftime "%d %b %Y", localtime($last_message*86400)),
++ 'creation_date_epoch' => $list->{'admin'}{'creation'}{'date_epoch'},
++ 'creation_date' => (gettext_strftime "%d %b %Y", localtime($list->{'admin'}{'creation'}{'date_epoch'})),
++ };
++ }
++
++ foreach my $l (sort {$a->{'last_message_epoch'} <=> $b->{'last_message_epoch'}} @unordered_lists) {
++ push @{$param->{'inactive_lists'}}, $l;
++ }
++
++ return 1;
++ }
++
++## show a list parameters
++sub do_set_pending_list_request {
++ &wwslog('info', 'set_pending_list(%s)',$in{'list'});
++
++ my $list_dir = $list->{'dir'};
++
++ $param->{'list_config'} = $list_dir.'/config';
++ if (-f $list_dir.'/info'){
++ $param->{'list_info_file_exists'} = 1;
++ }
++ $param->{'list_info'} = $list_dir.'/info';
++ $param->{'list_subject'} = $list->{'admin'}{'subject'};
++ $param->{'list_request_by'} = $list->{'admin'}{'creation'}{'email'};
++ $param->{'list_request_date'} = $list->{'admin'}{'creation'}{'date'};
++ $param->{'list_serial'} = $list->{'admin'}{'serial'};
++ $param->{'list_status'} = $list->{'admin'}{'status'};
++
++ &tt2::add_include_path($list->{'dir'});
++
++ return 1;
++ }
++
++ ## show a list parameters
++ sub do_install_pending_list {
++ &wwslog('info', 'do_install_pending_list(%s,%s,%s)',$in{'list'},$in{'status'},$in{'notify'});
++
++ unless ($in{'status'} && (($in{'status'} eq 'open') || ($in{'status'} eq 'closed'))) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'status'},$param->{'action'});
++ &wwslog('info', 'Missing status parameter',);
++ &web_db_log({'parameters' => "$in{'status'},$in{'notify'}",
++ 'status' => 'error',
++ 'error_type' => 'missing_parameter'});
++ return undef;
++ }
++
++ if ($list->{'admin'}{'status'} eq $in{'status'}) {
++ &report::reject_report_web('user','didnt_change_anything',{},$param->{'action'});
++ &wwslog('info','view_pending_list: didn t change really the status, nothing to do');
++ &web_db_log({'parameters' => "$in{'status'},$in{'notify'}",
++ 'status' => 'error',
++ 'error_type' => 'didnt_change_anything'});
++ return undef ;
++ }
++
++ $list->{'admin'}{'status'} = $in{'status'};
++
++ # open TMP, ">/tmp/dump1";
++ # &tools::dump_var ($list->{'admin'}, 0, \*TMP);
++ # close TMP;
++
++ unless ($list->save_config($param->{'user'}{'email'})) {
++ &report::reject_report_web('intern','cannot_save_config',{'listname'=> $list->{'name'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','_create_list: Cannot save config file');
++ &web_db_log({'parameters' => "$in{'status'},$in{'notify'}",
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ # open TMP, ">/tmp/dump2";
++ # &tools::dump_var ($list->{'admin'}, 0, \*TMP);
++ # close TMP;
++
++ ## create the aliases
++ if ($in{'status'} eq 'open') {
++ my $aliases = &admin::install_aliases($list,$robot);
++ if ($aliases == 1) {
++ $param->{'auto_aliases'} = 1;
++ }else {
++ &report::reject_report_web('intern','failed_to_install_aliases',{'listname'=> $list->{'name'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','Failed to install list aliases');
++ }
++
++ }
++
++ ## Notify listmasters
++ if ($in{'status'} eq 'open') {
++ unless ($list->send_file('list_created', &Conf::get_robot_conf($robot, 'listmaster'), $robot,{})) {
++ &wwslog('notice',"Unable to send template 'list_created' to listmaster");
++ }
++ }elsif ($in{'status'} eq 'closed') {
++ unless ($list->send_file('list_rejected', &Conf::get_robot_conf($robot, 'listmaster'), $robot,{})) {
++ &wwslog('notice',"Unable to send template 'list_rejected' to listmaster");
++ }
++ }
++
++ if ($in{'notify'}) {
++ my $owners = $list->get_owners();
++ foreach my $i (@{$owners}) {
++ ## Notify all listowners, even if reception is nomail
++ next unless ($i->{'email'});
++ if ($in{'status'} eq 'open') {
++ unless ($list->send_file('list_created', $i->{'email'}, $robot,{})) {
++ &wwslog('notice',"Unable to send template 'list_created' to $i->{'email'}");
++ }
++ }elsif ($in{'status'} eq 'closed') {
++ unless ($list->send_file('list_rejected', $i->{'email'}, $robot,{})) {
++ &wwslog('notice',"Unable to send template 'list_rejected' to $i->{'email'}");
++ }
++ }
++ }
++ }
++
++ $param->{'status'} = $in{'status'};
++
++ $list = $param->{'list'} = $in{'list'} = undef;
++ return 'get_pending_lists';
++ &web_db_log({'parameters' => "$in{'status'},$in{'notify'}",
++ 'status' => 'success'});
++ return 1;
++ }
++
++ ## check if the requested list exists already using smtp 'rcpt to'
++ sub list_check_smtp {
++ my $list = shift;
++ my $conf = '';
++ my $smtp;
++ my (@suf, @addresses);
++
++ my $smtp_relay = $Conf{'robots'}{$robot}{'list_check_smtp'} || $Conf{'list_check_smtp'};
++ my $suffixes = $Conf{'robots'}{$robot}{'list_check_suffixes'} || $Conf{'list_check_suffixes'};
++ return 0
++ unless ($smtp_relay && $suffixes);
++ my $domain = &Conf::get_robot_conf($robot, 'host');
++ &wwslog('debug2', 'list_check_smtp(%s)',$in{'listname'});
++ @suf = split(/,/,$suffixes);
++ return 0 if ! @suf;
++ for(@suf) {
++ push @addresses, $list."-$_\@".$domain;
++ }
++ push @addresses,"$list\@" . $domain;
++
++ unless (eval "require Net::SMTP") {
++ wwslog ('err',"Unable to use Net library, Net::SMTP required, install it (CPAN) first");
++ return undef;
++ }
++ require Net::SMTP;
++
++ if( $smtp = Net::SMTP->new($smtp_relay,
++ Hello => $smtp_relay,
++ Timeout => 30) ) {
++ $smtp->mail('');
++ for(@addresses) {
++ $conf = $smtp->to($_);
++ last if $conf;
++ }
++ $smtp->quit();
++ return $conf;
++ }
++ return undef;
++ }
++
++=pod
++
++=head2 sub do_create_list
++
++Creates a list using a list template
++
++=head3 Arguments
++
++=over
++
++=item * I<None>
++
++=back
++
++=head3 Return
++
++=over
++
++=item * I<1>, if no problem is encountered
++
++=item * I<undef>, if anything goes wrong
++
++=item * I<'loginrequest'> if no user is logged in at the time the function is called.
++
++=back
++
++=head3 Calls
++
++=over
++
++=item * web_db_log
++
++=item * wwslog
++
++=item * admin::create_list_old
++
++=item * check_param_in
++
++=item * List::send_notify_to_listmaster
++
++=item * report::reject_report_web
++
++=back
++
++=cut
++
++## create a liste using a list template.
++ sub do_create_list {
++
++ &wwslog('info', 'do_create_list(%s,%s,%s)',$in{'listname'},$in{'subject'},$in{'template'});
++
++ ## Check that all the needed arguments are present.
++ ## This is checked here because it requires to return the incomplete form to the user
++ foreach my $arg ('listname','subject','template','info','topics') {
++ unless ($in{$arg}) {
++ &report::reject_report_web('user','missing_arg',{'argument' => $arg},$param->{'action'});
++ &wwslog('info','do_create_list: missing param %s', $arg);
++ &web_db_log({'parameters' => $in{'listname'},
++ 'list' => $in{'listname'},
++ 'status' => 'error',
++ 'error_type' => 'missing_parameter'});
++ return 'create_list_request';
++ }
++ }
++
++ ## Lowercase listname if required
++ if ($in{'listname'} =~ /[A-Z]/) {
++ $in{'listname'} = lc($in{'listname'});
++ &report::notice_report_web('listname_lowercased',{},$param->{'action'});
++ }
++
++ $param->{'create_action'} = $param->{'create_list'};
++
++ &wwslog('info',"do_create_list, get action : $param->{'create_action'} ");
++
++ ## If the action is forbidden, stop here.
++ if ($param->{'create_action'} =~ /reject/) {
++ &report::reject_report_web('auth',$param->{'reason'},{},$param->{'action'},$list);
++ &wwslog('info','do_create_list: not allowed');
++ &web_db_log({'parameters' => $in{'listname'},
++ 'list' => $in{'listname'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++
++ ## If the action is reserved to listmaster, note that it will have to be moderated
++ }elsif ($param->{'create_action'} =~ /listmaster/i) {
++ $param->{'status'} = 'pending' ;
++
++ ## If the action is plainly authorized, note that it will be executed.
++ }elsif ($param->{'create_action'} =~ /do_it/i) {
++ $param->{'status'} = 'open' ;
++
++ ## If the action hasn't an authorization status, stop here.
++ }else{
++ &report::reject_report_web('intern','internal_scenario_error_create_list',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_create_list: internal error in scenario create_list');
++ &web_db_log({'parameters' => $in{'listname'},
++ 'list' => $in{'listname'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ ## 'other' topic means no topic
++ $in{'topics'} = undef if ($in{'topics'} eq 'other');
++
++ ## Store creation parameters.
++ my %owner;
++ $owner{'email'} = $param->{'user'}{'email'};
++ $owner{'gecos'} = $param->{'user'}{'gecos'};
++
++ my $parameters;
++ push @{$parameters->{'owner'}},\%owner;
++ $parameters->{'listname'} = $in{'listname'};
++ $parameters->{'subject'} = $in{'subject'};
++ $parameters->{'creation_email'} = $param->{'user'}{'email'};
++ $parameters->{'lang'} = $param->{'lang'};
++ $parameters->{'status'} = $param->{'status'};
++ $parameters->{'topics'} = $in{'topics'};
++ $parameters->{'description'} = $in{'info'};
++ $parameters->{'custom_input'} = $in{'custom_input'};
++
++ ## create liste
++ if (my $testlist = new List($in{'listname'},$robot)){
++ &report::reject_report_web('user','list_already_exists',{'new_listname'=> $in{'listname'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_create_list: requested list %s already exist (from %s)',$in{'listname'},$param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'listname'},
++ 'list' => $in{'listname'},
++ 'status' => 'error',
++ 'error_type' => 'user'});
++ return undef
++ }
++ my $resul = &admin::create_list_old($parameters,$in{'template'},$robot,"web");
++ unless(defined $resul) {
++ &report::reject_report_web('intern','create_list',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_create_list: unable to create list %s for %s',$in{'listname'},$param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'listname'},
++ 'list' => $in{'listname'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef
++ }
++
++ ## Create list object
++ $in{'list'} = $in{'listname'};
++ &check_param_in();
++
++ if ($param->{'create_action'} =~ /do_it/i) {
++ if ($resul->{'aliases'} == 1) {
++ $param->{'auto_aliases'} = 1;
++ }else {
++ &report::reject_report_web('intern','failed_to_install_aliases',{'listname'=> $in{'listname'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','Failed to install list aliases');
++ }
++ }
++
++ ## notify listmaster
++ my $list = new List $in{'listname'};
++ unless (defined $list) {
++ &wwslog('info',"failed to create list object for list '%s'",$in{'listname'});
++ &report::reject_report_web('intern','create_list',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ return undef;
++ }
++
++ if ($param->{'create_action'} =~ /notify/) {
++ &wwslog('info','notify listmaster');
++
++ unless (&List::send_notify_to_listmaster('request_list_creation',$robot,
++ {'list' => $list,
++ 'email' => $param->{'user'}{'email'}})) {
++ &wwslog('notice',"Unable to send notify 'request_list_creation' to listmaster");
++ }
++ }
++
++ &web_db_log({'parameters' => $in{'listname'},
++ 'list' => $in{'listname'},
++ 'status' => 'success'});
++
++ $in{'list'} = $resul->{'list'}{'name'};
++ &check_param_in();
++
++ $param->{'listname'} = $resul->{'list'}{'name'};
++ return 1;
++ }
++
++=pod
++
++=head2 sub do_create_list_request
++
++Sends back the list creation edition form.
++
++=head3 Arguments
++
++=over
++
++=item * I<None>
++
++=back
++
++=head3 Return
++
++=over
++
++=item * I<1>, if no problem is encountered
++
++=item * I<undef>, if anything goes wrong
++
++=item * I<'loginrequest'> if no user is logged in at the time the function is called.
++
++=back
++
++=head3 Calls
++
++=over
++
++=item * wwslog
++
++=item * _prepare_edit_form
++
++=item * List::request_action
++
++=item * List::load_topics
++
++=item * tools::get_list_list_tpl
++
++=item * tt2::allow_absolute_path
++
++=item * report::reject_report_web
++
++=back
++
++=cut
++
++ ## Return the creation form
++ sub do_create_list_request {
++ &wwslog('info', 'do_create_list_request()');
++
++ my $result = &Scenario::request_action('create_list',$param->{'auth_method'},$robot,
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++
++ my $r_action;
++ my $reason;
++ if (ref($result) eq 'HASH') {
++ $r_action = $result->{'action'};
++ $reason = $result->{'reason'};
++ }
++
++ $param->{'create_action'} = $r_action;
++ ## Initialize the form
++ ## When returning to the form
++ foreach my $p ('listname','template','subject','topics','info') {
++ $param->{'saved'}{$p} = $in{$p};
++ }
++
++ if ($param->{'create_action'} =~ /reject/) {
++ &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
++ &wwslog('info','do_create_list: not allowed');
++ return undef;
++ }
++
++ my %topics;
++ unless (%topics = &List::load_topics($robot)) {
++ &report::reject_report_web('intern','unable_to_load_list_of_topics',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ }
++ $param->{'list_of_topics'} = \%topics;
++
++ $param->{'list_of_topics'}{$in{'topics'}}{'selected'} = 1
++ if ($in{'topics'});
++
++ unless ($param->{'list_list_tpl'} = &tools::get_list_list_tpl($robot)) {
++ &report::reject_report_web('intern','unable_to_load_create_list_templates',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ }
++
++ &tt2::allow_absolute_path();
++
++ foreach my $template (keys %{$param->{'list_list_tpl'}}){
++ $param->{'tpl_count'} ++ ;
++ }
++
++ $param->{'list_list_tpl'}{$in{'template'}}{'selected'} = 1
++ if ($in{'template'});
++
++
++ return 1 ;
++
++ }
++
++## WWSympa Home-Page
++ sub do_home {
++ &wwslog('info', 'do_home');
++
++ return 1;
++ }
++
++ sub do_editsubscriber {
++ &wwslog('info', 'do_editsubscriber(%s)', $in{'email'});
++
++ my $subscriber;
++
++ $in{'email'} = &tools::unescape_chars($in{'email'});
++
++ unless($subscriber = $list->get_subscriber($in{'email'})) {
++ &report::reject_report_web('intern','subscriber_not_found',{'email' => $in{'email'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_editsubscriber: subscriber %s not found', $in{'email'});
++ return undef;
++ }
++
++ $param->{'current_subscriber'} = $subscriber;
++ $param->{'current_subscriber'}{'escaped_email'} = &tools::escape_html($param->{'current_subscriber'}{'email'});
++ $param->{'current_subscriber'}{'escaped_bounce_address'} = &tools::escape_html($param->{'current_subscriber'}{'bounce_address'});
++ $param->{'current_subscriber'}{'date'} = gettext_strftime "%d %b %Y", localtime($subscriber->{'date'});
++ $param->{'current_subscriber'}{'update_date'} = gettext_strftime "%d %b %Y", localtime($subscriber->{'update_date'});
++ $param->{'current_subscriber'}{'pictures_url'} = &tools::make_pictures_url('email' => $subscriber->{'email'}, 'list' => $list);
++
++ ## Prefs
++ $param->{'current_subscriber'}{'reception'} ||= 'mail';
++ $param->{'current_subscriber'}{'visibility'} ||= 'noconceal';
++
++ ## Get language from user_table
++ my $user = &List::get_user_db($in{'email'});
++ $param->{'current_subscriber'}{'lang'} = &Language::GetLangName($user->{'lang'});
++
++ foreach my $m (keys %wwslib::reception_mode) {
++ if ($list->is_available_reception_mode($m)) {
++ $param->{'reception'}{$m}{'description'} = sprintf(gettext($wwslib::reception_mode{$m}->{'gettext_id'}));
++ if ($param->{'current_subscriber'}{'reception'} eq $m) {
++ $param->{'reception'}{$m}{'selected'} = 'selected="selected"';
++ }else {
++ $param->{'reception'}{$m}{'selected'} = '';
++ }
++ }
++ }
++
++ foreach my $m (keys %wwslib::visibility_mode) {
++ $param->{'visibility'}{$m}{'description'} = sprintf(gettext($wwslib::visibility_mode{$m}->{'gettext_id'}));
++ if ($param->{'current_subscriber'}{'visibility'} eq $m) {
++ $param->{'visibility'}{$m}{'selected'} = 'selected="selected"';
++ }else {
++ $param->{'visibility'}{$m}{'selected'} = '';
++ }
++ }
++
++ ## Bounces
++ if ($subscriber->{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/) {
++ my @bounce = ($1, $2, $3, $5);
++ $param->{'current_subscriber'}{'first_bounce'} = gettext_strftime "%d %b %Y", localtime($bounce[0]);
++ $param->{'current_subscriber'}{'last_bounce'} = gettext_strftime "%d %b %Y", localtime($bounce[1]);
++ $param->{'current_subscriber'}{'bounce_count'} = $bounce[2];
++ if ($bounce[3] =~ /^(\d+\.(\d+\.\d+))$/) {
++ $subscriber->{'bounce_code'} = $1;
++ $subscriber->{'bounce_status'} = $wwslib::bounce_status{$2};
++ }
++
++ $param->{'previous_action'} = $in{'previous_action'};
++ }
++
++ ## Additional DB fields
++ if ($Conf{'db_additional_subscriber_fields'}) {
++ my @additional_fields = split ',', $Conf{'db_additional_subscriber_fields'};
++
++ my %data;
++
++ foreach my $field (@additional_fields) {
++
++ ## Is the Database defined
++ unless ($Conf{'db_name'}) {
++ &wwslog('info', 'No db_name defined in configuration file');
++ return undef;
++ }
++
++ ## Check field type (enum or not) with MySQL
++ $data{$field}{'type'} = &List::get_db_field_type('subscriber_table', $field);
++ if ($data{$field}{'type'} =~ /^enum\((\S+)\)$/) {
++ my @enum = split /,/,$1;
++ foreach my $e (@enum) {
++ $e =~ s/^\'([^\']+)\'$/$1/;
++ $data{$field}{'enum'}{$e} = '';
++ }
++ $data{$field}{'type'} = 'enum';
++
++ $data{$field}{'enum'}{$subscriber->{$field}} = 'selected="selected"'
++ if (defined $subscriber->{$field});
++ }else {
++ $data{$field}{'type'} = 'string';
++ $data{$field}{'value'} = $subscriber->{$field};
++ }
++ }
++ $param->{'additional_fields'} = \%data;
++ }
++
++ $param->{'previous_action'} = $in{'previous_action'};
++
++ return 1;
++ }
++
++ sub do_viewbounce {
++ &wwslog('info', 'do_viewbounce(%s)', $in{'email'});
++
++ my $escaped_email = &tools::escape_chars($in{'email'});
++
++ $param->{'lastbounce_path'} = $list->get_bounce_dir().'/'.$escaped_email;
++
++ unless (-r $param->{'lastbounce_path'}) {
++ &report::reject_report_web('user','no_bounce_user',{'email'=>$in{'email'}},$param->{'action'},$list);
++ &wwslog('info','do_viewbounce: no bounce %s', $param->{'lastbounce_path'});
++ return undef;
++ }
++
++ &tt2::allow_absolute_path();
++
++ return 1;
++ }
++
++ ## some help for listmaster and developpers
++ sub do_scenario_test {
++ &wwslog('info', 'do_scenario_test');
++
++ ## List available scenarii
++ unless (opendir SCENARI, Sympa::Constants::DEFAULTDIR.'/scenari/'){
++ &report::reject_report_web('intern','cannot_open_dir',{'dir' => Sympa::Constants::DEFAULTDIR.'/scenari/'},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info',"do_scenario_test : unable to open %s/scenari", Sympa::Constants::DEFAULTDIR);
++ return undef;
++ }
++
++ foreach my $scfile (readdir SCENARI) {
++ if ($scfile =~ /^(\w+)\.(\w+)/ ) {
++ $param->{'scenario'}{$1}{'defined'}=1 ;
++ }
++ }
++ closedir SCENARI;
++ my $all_lists = &List::get_lists('*');
++ foreach my $list ( @$all_lists ) {
++ $param->{'listname'}{$list->{'name'}}{'defined'}=1 ;
++ }
++ foreach my $a ('smtp','md5','smime') {
++ #$param->{'auth_method'}{$a}{'define'}=1 ;
++ $param->{'authmethod'}{$a}{'defined'}=1 ;
++ }
++
++ $param->{'scenario'}{$in{'scenario'}}{'selected'} = 'selected="selected"' if $in{'scenario'};
++
++ $param->{'listname'}{$in{'listname'}}{'selected'} = 'selected="selected"' if $in{'listname'};
++
++ $param->{'authmethod'}{$in{'auth_method'}}{'selected'} = 'selected="selected"' if $in{'auth_method'};
++
++ $param->{'email'} = $in{'email'};
++
++ if ($in{'scenario'}) {
++ my $operation = $in{'scenario'};
++ &wwslog('debug3', 'do_scenario_test: perform scenario_test');
++
++ my $result = &Scenario::request_action ($operation,$in{'auth_method'},$robot,
++ {'listname' => $in{'listname'},
++ 'sender' => $in{'sender'},
++ 'email' => $in{'email'},
++ 'remote_host' => $in{'remote_host'},
++ 'remote_addr' => $in{'remote_addr'}},'debug');
++ if (ref($result) eq 'HASH'){
++ $param->{'scenario_action'} = $result->{'action'};
++ $param->{'scenario_condition'} = $result->{'condition'};
++ $param->{'scenario_auth_method'} = $result->{'auth_method'};
++ $param->{'scenario_reason'} = $result->{'reason'};
++ }
++ }
++ return 1;
++ }
++
++ ## Bouncing addresses review
++ sub do_reviewbouncing {
++ &wwslog('info', 'do_reviewbouncing(%d)', $in{'page'});
++ my $size = $in{'size'} || $wwsconf->{'review_page_size'};
++
++ ## Owner
++ $param->{'page'} = $in{'page'} || 1;
++ if ($size eq 'all') {
++ $param->{'total_page'} = $param->{'bounce_total'};
++ }else {
++ $param->{'total_page'} = int ( $param->{'bounce_total'} / $size);
++ $param->{'total_page'} ++
++ if ($param->{'bounce_total'} % $size);
++ }
++
++ if ($param->{'total_page'} > 0 and ($param->{'page'} > $param->{'total_page'})) {
++ &report::reject_report_web('user','no_page',{'page' => $param->{'page'}},$param->{'action'});
++ &wwslog('info','do_reviewbouncing: no page %d', $param->{'page'});
++ return 'admin';
++ }
++
++ my @users;
++ ## Members list
++ for (my $i = $list->get_first_bouncing_user(); $i; $i = $list->get_next_bouncing_user()) {
++ $i->{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/;
++ $i->{'first_bounce'} = $1;
++ $i->{'last_bounce'} = $2;
++ $i->{'bounce_count'} = $3;
++ if ($5 =~ /^(\d+)\.\d+\.\d+$/) {
++ $i->{'bounce_class'} = $1;
++ }
++
++ ## Define color in function of bounce_score
++ if ($i->{'bounce_score'} <= $list->{'admin'}{'bouncers_level1'}{'rate'}) {
++ $i->{'bounce_level'} = 0;
++ }elsif ($i->{'bounce_score'} <= $list->{'admin'}{'bouncers_level2'}{'rate'}){
++ $i->{'bounce_level'} = 1;
++ }else{
++ $i->{'bounce_level'} = 2;
++ }
++ push @users, $i;
++ }
++
++ my $record;
++ foreach my $i (sort
++ {($b->{'bounce_score'} <=> $a->{'bounce_score'}) ||
++ ($b->{'last_bounce'} <=> $a->{'last_bounce'}) ||
++ ($b->{'bounce_class'} <=> $a->{'bounce_class'}) }
++ @users) {
++ $record++;
++
++ if (($size ne 'all') && ($record > ( $size * ($param->{'page'} ) ) ) ) {
++ $param->{'next_page'} = $param->{'page'} + 1;
++ last;
++ }
++
++ next if (($size ne 'all') && ($record <= ( ($param->{'page'} - 1) * $size)));
++
++ $i->{'first_bounce'} = gettext_strftime "%d %b %Y", localtime($i->{'first_bounce'});
++ $i->{'last_bounce'} = gettext_strftime "%d %b %Y", localtime($i->{'last_bounce'});
++
++ ## Escape some weird chars
++ $i->{'escaped_email'} = &tools::escape_chars($i->{'email'});
++
++ push @{$param->{'members'}}, $i;
++ }
++
++ if ($param->{'page'} > 1) {
++ $param->{'prev_page'} = $param->{'page'} - 1;
++ }
++
++ $param->{'size'} = $size;
++
++ return 1;
++ }
++
++ sub do_resetbounce {
++ &wwslog('info', 'do_resetbounce()');
++
++ $in{'email'} = &tools::unescape_chars($in{'email'});
++
++ my @emails = split /\0/, $in{'email'};
++
++ foreach my $email (@emails) {
++
++ my $escaped_email = &tools::escape_chars($email);
++
++ unless ( $list->is_user($email) ) {
++ &report::reject_report_web('user','not_subscriber',{'email'=> $email},$param->{'action'},$list);
++ &wwslog('info','do_del: %s not subscribed', $email);
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'not_subscriber'});
++ return undef;
++ }
++
++ unless( $list->update_user($email, {'bounce' => 'NULL', 'update_date' => time, 'score' => 0})) {
++ &report::reject_report_web('intern','update_subscriber_db_failed',{'sub'=> $email},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_resetbounce: failed update database for %s', $email);
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ my $bounce_dir = $list->get_bounce_dir();
++
++ unless (unlink $bounce_dir.'/'.$escaped_email) {
++ &wwslog('info','do_resetbounce: failed deleting %s', $bounce_dir.'/'.$escaped_email);
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ }
++
++ &wwslog('info','do_resetbounce: bounces for %s reset ', $email);
++ &web_db_log({'status' => 'success'});
++
++ }
++
++ return $in{'previous_action'} || 'review';
++ }
++
++ ## Rebuild an archive using arctxt/
++ sub do_rebuildarc {
++ &wwslog('info', 'do_rebuildarc(%s, %s)', $param->{'list'}, $in{'month'});
++
++ my $file = $Conf{'queueoutgoing'}.'/.rebuild.'.$list->get_list_id();
++
++ unless (open REBUILD, ">$file") {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_rebuildarc: cannot create %s', $file);
++ &web_db_log({'parameters' => $in{'month'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ &wwslog('info', 'File: %s', $file);
++
++ print REBUILD ' ';
++ close REBUILD;
++
++ &report::notice_report_web('performed_soon',{},$param->{'action'});
++ &web_db_log({'parameters' => $in{'month'},
++ 'status' => 'success'});
++ return 'admin';
++ }
++
++ ## Rebuild all archives using arctxt/
++ sub do_rebuildallarc {
++ &wwslog('info', 'do_rebuildallarc');
++
++ my $all_lists = &List::get_lists($robot);
++ foreach my $list ( @$all_lists ) {
++ next unless (defined $list->{'admin'}{'web_archive'});
++ my $file = $Conf{'queueoutgoing'}.'/.rebuild.'.$list->get_list_id();
++
++ unless (open REBUILD, ">$file") {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $file},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_rebuildarc: cannot create %s', $file);
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ &wwslog('info', 'File: %s', $file);
++
++ print REBUILD ' ';
++ close REBUILD;
++
++ }
++ &report::notice_report_web('performed_soon',{},$param->{'action'});
++ &web_db_log({'status' => 'success'});
++ return 'serveradmin';
++ }
++
++ ## Search among lists
++ sub do_edit_attributes {
++ &wwslog('info', 'do_edit_attributes(%s)', $in{'filter'});
++
++ return 1;
++ }
++
++ ## Search among lists
++ sub do_search_list {
++ &wwslog('info', 'do_search_list(%s)', $in{'filter'});
++
++ unless ($in{'filter'}) {
++ &report::reject_report_web('user','no_filter',{},$param->{'action'});
++ &wwslog('info','do_search_list: no filter');
++ return undef;
++ }elsif ($in{'filter'} =~ /[<>\\\*\$]/) {
++ &report::reject_report_web('user','syntax_errors',{'params' => 'filter'},$param->{'action'});
++ &wwslog('err','do_search_list: syntax error');
++ return undef;
++ }
++
++ ## Regexp
++ $param->{'filter'} = $in{'filter'};
++ $param->{'regexp'} = &tools::escape_regexp($param->{'filter'});
++
++ ## Members list
++ my $record = 0;
++ my $all_lists = &List::get_lists($robot);
++ foreach my $list ( @$all_lists ) {
++ my $is_admin;
++ ## Search filter
++ my $regtest = eval { (($list->{'name'} !~ /$param->{'regexp'}/i)
++ && ($list->{'admin'}{'subject'} !~ /$param->{'regexp'}/i)) };
++ unless (defined($regtest)) {
++ &report::reject_report_web('user','syntax_errors',{'params' => 'filter'},$param->{'action'});
++ &wwslog('err','do_search_list: syntax error');
++ return undef;
++ }
++ next if $regtest;
++
++ my $result = $list->check_list_authz('visibility',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $r_action;
++ $r_action = $result->{'action'} if (ref($result) eq 'HASH');
++ next unless ($r_action eq 'do_it');
++
++ if ($param->{'user'}{'email'} &&
++ ($list->am_i('owner',$param->{'user'}{'email'}) ||
++ $list->am_i('editor',$param->{'user'}{'email'})) ) {
++ $is_admin = 1;
++ }
++
++ $record++;
++ $param->{'which'}{$list->{'name'}} = {'host' => $list->{'admin'}{'host'},
++ 'subject' => $list->{'admin'}{'subject'},
++ 'admin' => $is_admin,
++ 'export' => 'no'};
++ }
++ $param->{'occurrence'} = $record;
++ foreach my $listname (sort keys %{$param->{'which'}}) {
++ if ($listname =~ /^([a-z])/){
++ push @{$param->{'orderedlist'}{$1}}, $listname ;
++ }else{
++ push @{$param->{'orderedlist'}{'others'}}, $listname ;
++ }
++ }
++
++ return 1;
++ }
++
++sub do_edit_list {
++ &wwslog('info', 'do_edit_list()');
++
++ ## Check if the list belong to a family.
++ my $family;
++ if (defined $list->{'admin'}{'family_name'}) {
++ unless ($family = $list->get_family()) {
++ &report::reject_report_web('intern','unable_get_family',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_edit_list : impossible to get list %s\'s family',$list->{'name'});
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++
++ ## This hash will contain all the data gathered from the edit list form.
++ ## The keys are the parameter names.
++ ## The values are either the parameter value or an array containing this value if this is a multiple values parameter.
++ ## The value can be a scalar or a hash.
++ my $new_admin = {};
++
++ ## This hash contains the names of all the parameters sent by the form to the FCGI.
++ ## The keys are the parameters name, the value is always 1.
++ ## Used only to parse the data.
++ my $edited_param = {};
++
++ ## Parse all the data sent from the web interface to the FCGI.
++ ## Fills the $new_admin and $edited_param hashes.
++ foreach my $key (sort keys %in) {
++ next unless ($key =~ /^(single_param|multiple_param)\.(\S+)$/);
++
++ $key =~ /^(single_param|multiple_param)\.(\S+)$/;
++ my ($type, $name) = ($1, $2);
++
++ ## Tag parameter as present in the form
++ if ($name =~ /^([^\.]+)(\.)/ ||
++ $name =~ /^([^\.]+)$/) {
++ $edited_param->{$1} = 1;
++ }
++
++ ## Parameter value
++ my $value = $in{$key};
++ next if ($value =~ /^\s*$/);
++
++ ## If the parameter is a multiple values parameter, store the values into an array.
++ if ($type eq 'multiple_param') {
++ my @values = split /\0/, $value;
++ $value = \@values;
++ }
++
++ my @token = split (/\./, $name);
++
++ ## make it an entry in $new_admin
++ my $var = &_shift_var(0, $new_admin, @token);
++ $$var = $value;
++ }
++
++ ## Check that the serial number sent by the form is the same as the one we expect.
++ ## Avoid modifying a list previously modified by another way.
++ unless ($list->{'admin'}{'serial'} == $in{'serial'}) {
++ &report::reject_report_web('user','config_changed',{'email' => $list->{'admin'}{'update'}{'email'}},$param->{'action'},$list);
++ &wwslog('info','do_edit_list: Config file has been modified(%d => %d) by %s. Cannot apply changes', $in{'single_param.serial'}, $list->{'admin'}{'serial'}, $list->{'admin'}{'update'}{'email'});
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ ## Check changes & check syntax
++ ## %changed stores the names of the parameters whose values differs from the value in the config file.
++ ## %stores the name of parameter for which values have been deleted. The keys are the parameter name, the values are the index of the deleted value.
++ ## @syntax_error stores the list of parameters for which syntax errors wre founs while evaluating the data sent by the form.
++ my (%changed, %delete);
++ my @syntax_error;
++
++ ## Check family constraints.
++ ## %check_family is a hash whose keys are a parameter name and whose values are the constraints
++ ## defined for this parameter.
++ my %check_family;
++
++
++ ## Getting changes about owners or editors
++ ## If changes occured in the owner or editor definition, these scalars are set to 1.
++ my $owner_update = 0;
++ my $editor_update = 0;
++
++ ######################################################################
++ ## Start of the loop parsing the data sent by the edition form. ##
++ ######################################################################
++
++ foreach my $pname (sort List::by_order keys %{$edited_param}) {
++
++ ## $p will contain the values of the current parameter in the previous list config
++ ## $new_p will contain the values sent by the form for the current parameter.
++ my ($p, $new_p);
++
++ ## Check privileges first
++ next unless ($list->may_edit($pname,$param->{'user'}{'email'}) eq 'write');
++
++ ## If the list belongs to a family, gather all the constraints for each edited parameter.
++ if (ref($family) eq 'Family') {
++
++ if ((ref($::pinfo{$pname}{'format'}) ne 'HASH') && (!ref($pname))) { # simple parameter
++ my $constraint = $family->get_param_constraint($pname);
++
++ if (ref($constraint) eq 'HASH') { # controlled parameter
++ $check_family{$pname} = $constraint;
++
++ } elsif ($constraint ne '0') { # fixed parameter (free : no control)
++ next;
++ }
++ }
++ }
++
++ ## Skip the obsolete parameters.
++ next if $pinfo->{$pname}{'obsolete'};
++
++ ## $to_index value will correspond to the number of not empty parameters sent by the form.
++ my $to_index;
++
++ ####### Validation, step 1: remove empty entries ###########
++
++ ## If the parameter can have multiple values...
++ if ($pinfo->{$pname}{'occurrence'} =~ /n$/) {
++
++ ## They were either entries removed by the user or empty entries added by wwsympa
++ ## The loop is going backward so we can remove empty entries
++ my @all = 0..$#{$new_admin->{$pname}};
++ foreach my $i (reverse @all ) {
++ ## If the parameter has a complex structure
++ if (ref ($pinfo->{$pname}{'format'}) eq 'HASH') {
++ ## Check each component of the complex parameter.
++ foreach my $key (keys %{$pinfo->{$pname}{'format'}}) {
++ ## As soon as a required component is found missing, the whole parameter instance is removed.
++ if ($pinfo->{$pname}{'format'}{$key}{'occurrence'} =~ /^1/ &&
++ $new_admin->{$pname}[$i]{$key} =~ /^\s*$/ ) {
++ splice(@{$new_admin->{$pname}}, $i, 1);
++ last;
++ }
++ }
++ ## Else if the parameter has only a scalar value
++ }else {
++ ## Remove if empty
++ if ($new_admin->{$pname}[$i] =~ /^\s*$/) {
++ splice(@{$new_admin->{$pname}}, $i, 1);
++ next;
++ }
++ }
++ }
++
++ ## Now, %new_admin contains only entries for which all the mandatory values are accounted for.
++
++ ## $last_index corresponds to the number of remaining instances of this param sent by the form.
++ my $last_index = $#{$new_admin->{$pname}};
++
++
++ ## If a mandatory parameter is missing, issue an error and stop here.
++ if ($pinfo->{$pname}{'occurrence'} =~ /^1/ && !($last_index >= 0)){
++ delete $new_admin->{$pname};
++ &wwslog('err','Error: Parameter %s is mandatory.', $pname);
++ &report::reject_report_web('user','mandatory_parameter',{'p_name' => $pname},$param->{'action'},$list);
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'syntax_errors'});
++ next;
++ }
++
++ ## If there are less entries in the config file than were sent by the form,
++ ## $to_index must correspond to the number of entries sent.
++ if ($#{$list->{'admin'}{$pname}} < $last_index) {
++ $to_index = $last_index;
++ ## Otherwise, $to_index must correspond to the number of entries in the config file.
++ }else {
++ $to_index = $#{$list->{'admin'}{$pname}};
++ }
++
++ $p = $list->{'admin'}{$pname};
++ $new_p = $new_admin->{$pname};
++
++ ## If the parameter can't have multiple values...
++ }else {
++
++ ## If the parameter has a complex structure
++ if (ref ($pinfo->{$pname}{'format'}) eq 'HASH') {
++
++ ## Check each component of the complex parameter.
++ foreach my $key (keys %{$pinfo->{$pname}{'format'}}) {
++
++ ## Remove the full record if a component is emtpy and required
++ if ($pinfo->{$pname}{'format'}{$key}{'occurrence'} =~ /^1/ &&
++ $new_admin->{$pname}{$key} =~ /^\s*$/ ) {
++ delete $new_admin->{$pname};
++ last;
++ }
++ }
++ ## If the parameter contains a simple scalar value.
++ }else {
++
++ ## Remove if empty
++ if ($new_admin->{$pname} =~ /^\s*$/) {
++ delete $new_admin->{$pname};
++ }
++ }
++
++ $p = [$list->{'admin'}{$pname}];
++ $new_p = [$new_admin->{$pname}];
++ }
++
++ ####### Validation, step 2: - check if the parameter was modified. ###########
++ ####### - check that the new values have the right syntax. ###########
++ ####### Note: this step is performed for each occurrence of the parameter. ###########
++
++ foreach my $i (0..$to_index) {
++ unless (defined $new_p->[$i]) {
++ push @{$delete{$pname}}, $i;
++ $changed{$pname} = 1; next;
++ }
++ ## If the parameter corresponds to a scenario or a task, mark it as changed if its name was changed.
++ ## Example: 'subscribe'
++ if ($pinfo->{$pname}{'scenario'} ||
++ $pinfo->{$pname}{'task'} ) {
++ if ($p->[$i]{'name'} ne $new_p->[$i]{'name'}) {
++ $changed{$pname} = 1; next;
++ }
++ ## If the parameter has a complex structure, we need to check all its components.
++ ## Example: 'owner'
++ }elsif (ref ($pinfo->{$pname}{'format'}) eq 'HASH') {
++ ## Check each parameter component.
++ ## Example: 'owner->email'
++ foreach my $key (keys %{$pinfo->{$pname}{'format'}}) {
++
++ ## Check that the user is allowed to edit this parameter component.
++ next unless ($list->may_edit("$pname.$key",$param->{'user'}{'email'}) eq 'write');
++
++ ## If the list belongs to a family, check the possible constraints on this parameter component.
++ if (ref($family) eq 'Family') {
++ ## Test constraints only if the parameter component is not a complex structure.
++ if (!ref($key)) {
++ my $constraint = $family->get_param_constraint("$pname.$key");
++ if (ref($constraint) eq 'HASH') { # controlled parameter
++ $check_family{$pname}{$key} = $constraint;
++ } elsif ($constraint ne '0') { # fixed parameter
++ next; # Go to the next parameter component.
++ }
++ }
++ }
++
++ ## If the parameter component corresponds to a task or a scenario, mark it as changed if its name was changed.
++ if ($pinfo->{$pname}{'format'}{$key}{'scenario'} ||
++ $pinfo->{$pname}{'format'}{$key}{'task'} ) {
++ if ($p->[$i]{$key}{'name'} ne $new_p->[$i]{$key}{'name'}) {
++ $changed{$pname} = 1; next; # Mark as changed and go to the next parameter component.
++ }
++ ## If the parameter component doesn't correspond to a task or a scenario, we must check its content.
++ }else{
++ ## Parameter component check, case 1: this parameter component can have multiple occurence.
++ ## Example: 'digest->days'
++ if ($pinfo->{$pname}{'format'}{$key}{'occurrence'} =~ /n$/) {
++ ## If the new value differs from the previous value, mark as changed and go to the next parameter component.
++ if ($#{$p->[$i]{$key}} != $#{$new_p->[$i]{$key}}) {
++ $changed{$pname} = 1; next;
++ }
++
++ ## For each occurrence of this parameter component, check value
++ foreach my $index (0..$#{$p->[$i]{$key}}) {
++ my $format = $pinfo->{$pname}{'format'}{$key}{'format'};
++
++ ## If the format has a complex structure, it is the description of a file format.
++ if (ref ($format)) {
++ $format = $pinfo->{$pname}{'format'}{$key}{'file_format'};
++ }
++ ## If this occurrence of the parameter component differs from the corresponding one in the config
++ ## check the syntax and mark as changed.
++ if ($p->[$i]{$key}[$index] ne $new_p->[$i]{$key}[$index]) {
++
++ if (defined($new_p->[$i]{$key}[$index]) && $new_p->[$i]{$key}[$index] !~ /^$format$/i) {
++ &wwslog('err', "Syntax error : $pname/$i/$key/$index = $new_p->[$i]{$key}[$index]");
++ push @syntax_error, $pname;
++ }
++ $changed{$pname} = 1; next; # Mark as changed and go to the next parameter component.
++ }
++ }
++
++ ## Parameter component check, case 2: this component is limited to one occurence.
++ ## Example: 'owner->email'
++ }else {
++ ## If the parameter component value differs from the corresponding one in the config, go on.
++ if ($p->[$i]{$key} ne $new_p->[$i]{$key}) {
++ my $format = $pinfo->{$pname}{'format'}{$key}{'format'};
++
++ ## If the format has a complex structure, it is the description of a file format.
++ if (ref ($format)) {
++ $format = $pinfo->{$pname}{'format'}{$key}{'file_format'};
++ }
++
++ ## Check the syntax and mark as changed if the syntax is correct.
++ if (defined($new_p->[$i]{$key}) && $new_p->[$i]{$key} !~ /^$format$/i) {
++ &wwslog('err', "Syntax error : $pname/$i/$key = $new_p->[$i]{$key}");
++ push @syntax_error, $pname;
++ }
++
++ $changed{$pname} = 1; next; # Mark as changed and go to the next parameter component.
++ }
++ }
++ }
++ }
++ ## If the parameter has just a scalar value, just check its value.
++ ## Example: 'max_size'
++ }else {
++ ## If the value differs from the one in the config file, mark parameter as changed if the syntax is correct.
++ if ($p->[$i] ne $new_p->[$i]) {
++ unless ($new_p->[$i] =~ /^$pinfo->{$pname}{'file_format'}$/) {
++ &wwslog('err', "Syntax error : $pname/$i = $new_p->[$i]");
++ push @syntax_error, $pname;
++ }
++ $changed{$pname} = 1;
++ }
++ }
++ }
++ }
++
++ ######################################################################
++ ## Validation of the form finished. Start of valid data treatments ##
++ ######################################################################
++
++ ## Error if no parameter was edited
++ unless (keys %changed) {
++ &report::reject_report_web('user','no_parameter_edited',{},$param->{'action'},$list);
++ &wwslog('info','No parameter was edited by user');
++ return 'edit_list_request';
++ }
++
++ ## Syntax errors
++ if ($#syntax_error > -1) {
++ &report::reject_report_web('user','syntax_errors',{'params' => 'filter'},$param->{'action'},$list);
++ &wwslog('info','do_edit_list: Syntax errors for parameters %s', join(',', @syntax_error));
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'syntax_errors'});
++ return undef;
++ }
++
++ ## Checking no topic named "other"
++ foreach my $msg_topic (@{$new_admin->{'msg_topic'}}) {
++ if ($msg_topic->{'name'} =~ /^other$/i) {
++ $msg_topic->{'name'} = undef;
++ $msg_topic->{'title'} = undef;
++ &report::reject_report_web('user','topic_other',{},$param->{'action'},$list);
++ &wwslog('notice',"do_edit_list: topic other is a reserved word");
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'syntax_errors'});
++ return undef;
++ }
++ }
++
++ ## For changed msg_topic.name
++ if (defined $new_admin->{'msg_topic'} && $list->modifying_msg_topic_for_subscribers($new_admin->{'msg_topic'})) {
++ &report::notice_report_web('subscribers_noticed_deleted_topics',{},$param->{'action'});
++ }
++
++ ## Delete selected params
++ foreach my $p (keys %delete) {
++
++ if (($p eq 'owner') || ($p eq 'owner_include')) {
++ $owner_update = 1;
++ }
++
++ if (($p eq 'editor') || ($p eq 'editor_include')) {
++ $editor_update = 1;
++ }
++
++ ## Delete ALL entries
++ unless (ref ($delete{$p})) {
++ undef $new_admin->{$p};
++ next;
++ }
++
++ ## Delete selected entries
++ foreach my $k (reverse @{$delete{$p}}) {
++ splice @{$new_admin->{$p}}, $k, 1;
++ }
++
++ if (defined $check_family{$p}) { # $p is family controlled
++ if ($#{$new_admin->{$p}} < 0) {
++ &report::reject_report_web('user','p_family_controlled',{'param' => $p},$param->{'action'},$list);
++ &wwslog('info','do_edit_list : parameter %s must have values (family context)',$p);
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'missing_parameter'});
++ return undef;
++ }
++ }
++ }
++
++ # updating config_changes for deleted parameters
++ if (ref($family)) {
++ my @array_delete = keys %delete;
++ unless ($list->update_config_changes('param',\@array_delete)) {
++ &report::reject_report_web('intern','update_config_changes',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_edit_list: cannot write in config_changes for deleted parameters from list %s', $list->{'name'});
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++
++ ## Update config in memory
++ my $data_source_updated;
++ foreach my $parameter (keys %changed) {
++
++ my $pname;
++ if ($parameter =~ /^([\w-]+)\.([\w-]+)$/) {
++ $pname = $1;
++ } else{
++ $pname = $parameter;
++ }
++
++ my @users;
++
++ ## If new owners/editors have been added, then notify them
++ foreach my $admin_type ('owner','editor') {
++ my (%previous_emails, %new_emails);
++
++ ## Check previous entries
++ foreach my $entry (@{$list->{'admin'}{$admin_type}}) {
++ $previous_emails{$entry->{'email'}} = 1;
++ }
++
++ ## Compare with new entries
++ foreach my $entry (@{$new_admin->{$admin_type}}) {
++
++ unless ($previous_emails{$entry->{'email'}}) {
++
++ ## Notify the new list owner/editor
++ $list->send_notify_to_user('added_as_listadmin', $entry->{'email'},{'admin_type' => $admin_type, 'delegator' => $param->{'user'}{'email'}});
++ &report::notice_report_web('user_notified',{'notified_user' => $entry->{'email'}},$param->{'action'});
++ }
++ }
++ }
++
++ if (defined $check_family{$pname}) { # $pname is CONTROLLED
++ &_check_new_values(\%check_family,$pname,$new_admin);
++ }
++
++ ## If datasource config changed
++ if ($pname =~ /^(include_.*|user_data_source|ttl)$/) {
++ $data_source_updated = 1;
++ }
++
++ ## User Data Source
++ if ($pname eq 'user_data_source') {
++ ## Migrating to database
++ if (($list->{'admin'}{'user_data_source'} eq 'file') && ($new_admin->{'user_data_source'} eq 'database' || $new_admin->{'user_data_source'} eq 'include2')) {
++ unless (-f "$list->{'dir'}/subscribers") {
++ &wwslog('notice', 'No subscribers to load in database');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'no_subsciber'});
++ }
++ @users = &List::_load_users_file("$list->{'dir'}/subscribers");
++ }elsif (($list->{'admin'}{'user_data_source'} ne 'include2') &&
++ ($new_admin->{'user_data_source'} eq 'include2')) {
++ $list->update_user('*', {'subscribed' => 1});
++ &report::notice_report_web('subscribers_updated_soon',{},$param->{'action'});
++ }elsif (($list->{'admin'}{'user_data_source'} eq 'include2') &&
++ ($new_admin->{'user_data_source'} eq 'database')) {
++ $list->sync_include('purge');
++ }
++
++ ## Update total of subscribers
++ $list->{'total'} = $list->_load_total_db();
++ $list->savestats();
++ }
++
++ $list->{'admin'}{$pname} = $new_admin->{$pname};
++ if (defined $new_admin->{$pname} || $pinfo->{$pname}{'internal'}) {
++ delete $list->{'admin'}{'defaults'}{$pname};
++ }else {
++ $list->{'admin'}{'defaults'}{$pname} = 1;
++ }
++
++ if (($pname eq 'user_data_source') &&
++ ($#users >= 0)) {
++
++ $list->{'total'} = 0;
++
++ ## Insert users in database
++ foreach my $user (@users) {
++ $list->add_user($user);
++ }
++
++ $list->get_total();
++ $list->{'mtime'}[1] = 0;
++ }
++
++ if (($pname eq 'owner') || ($pname eq 'owner_include')){
++ $owner_update = 1;
++ }
++
++ if (($pname eq 'editor') || ($pname eq 'editor_include')){
++ $editor_update = 1;
++ }
++
++ # updating config_changes for changed parameters
++
++ if (ref($family)) {
++ my @array_changed = keys %changed;
++ unless ($list->update_config_changes('param',\@array_changed)) {
++ &report::reject_report_web('intern','update_config_changes',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_edit_file: cannot write in config_changes for changed parameters from list %s', $list->{'name'});
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++ }
++
++ ## Save config file
++ unless ($list->save_config($param->{'user'}{'email'})) {
++ &report::reject_report_web('intern','cannot_save_config',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_edit_list: Cannot save config file');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++
++ ## Reload config to clean some empty entries in $list->{'admin'}
++ $list = new List $list->{'name'}, $robot, {'reload_config' => 1};
++
++ unless (defined $list) {
++ &report::reject_report_web('intern','list_reload',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_edit_list: error in list reloading');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ ## If list has included data sources, update them and delete sync_include task.
++ if ($data_source_updated) {
++ if ($list->on_the_fly_sync_include('use_ttl'=>0)) {
++ &report::notice_report_web('subscribers_updated',{},$param->{'action'});
++ }else {
++ &report::reject_report_web('intern','sync_include_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ }
++ }
++
++ ## call sync_include_admin if there are changes about owners or editors and we're in mode include2
++ if ( ($list->{'admin'}{'user_data_source'} eq 'include2')) {
++ unless ($list->sync_include_admin()) {
++ &report::reject_report_web('intern','sync_include_admin_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_edit_list: sync_include_admin() failed');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++#($owner_update || $editor_update) &&
++ ## checking there is some owner(s) in case of sync_include_admin not called
++ if (($owner_update || $data_source_updated) && ($list->{'admin'}{'user_data_source'} ne 'include2')) {
++
++ unless ( $list->get_nb_owners()) {
++ &report::reject_report_web('intern','no_owner_defined',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_edit_list: no owner defined for list %s',$list->{'name'});
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++
++
++ ## Tag changed parameters
++ foreach my $pname (keys %changed) {
++ $::changed_params{$pname} = 1;
++ }
++
++ ## Save stats
++ $list->savestats();
++
++# print "Content-type: text/plain\n\n";
++ # &tools::dump_var($list->{'admin'}{'msg_topic'},0);
++ # &tools::dump_var($param->{'param'},0);
++
++
++ &report::notice_report_web('list_config_updated',{},$param->{'action'});
++ &web_db_log({'status' => 'success'});
++ return 'edit_list_request';
++ }
++
++ ## Shift tokens to get a reference to the desired
++ ## entry in $var (recursive)
++ sub _shift_var {
++ my ($i, $var, @tokens) = @_;
++ &wwslog('debug3','shift_var(%s,%s,%s)',$i, $var, join('.',@tokens));
++ my $newvar;
++
++ my $token = shift @tokens;
++
++ if ($token =~ /^\d+$/) {
++ return \$var->[$token]
++ if ($#tokens == -1);
++
++ if ($tokens[0] =~ /^\d+$/) {
++ unless (ref $var->[$token]) {
++ $var->[$token] = [];
++ }
++ $newvar = $var->[$token];
++ }else {
++ unless (ref $var->[$token]) {
++ $var->[$token] = {};
++ }
++ $newvar = $var->[$token];
++ }
++ }else {
++ return \$var->{$token}
++ if ($#tokens == -1);
++
++ if ($tokens[0] =~ /^\d+$/) {
++ unless (ref $var->{$token}) {
++ $var->{$token} = [];
++ }
++ $newvar = $var->{$token};
++ }else {
++ unless (ref $var->{$token}) {
++ $var->{$token} = {};
++ }
++ $newvar = $var->{$token};
++ }
++
++ }
++
++ if ($#tokens > -1) {
++ $i++;
++ return &_shift_var($i, $newvar, @tokens);
++ }
++ return $newvar;
++ }
++
++=pod
++
++=head2 sub do_edit_list_request
++
++Sends back the list config edition form.
++
++=head3 Arguments
++
++=over
++
++=item * I<None>
++
++=back
++
++=head3 Return
++
++=over
++
++=item * I<1>, if no problem is encountered
++
++=item * I<undef>, if anything goes wrong
++
++=item * I<'loginrequest'> if no user is logged in at the time the function is called.
++
++=back
++
++=head3 Calls
++
++=over
++
++=item * wwslog
++
++=item * _prepare_edit_form
++
++=item * report::reject_report_web
++
++=back
++
++=cut
++
++ ## Send back the list config edition form
++ sub do_edit_list_request {
++ &wwslog('info', 'do_edit_list_request(%s)', $in{'group'});
++
++ if ($in{'group'}) {
++ $param->{'group'} = $in{'group'};
++ &_prepare_edit_form ($list);
++ }
++
++ # print "Content-type: text/plain\n\n";
++ # &tools::dump_var(\%pinfo,0);
++ # &tools::dump_var($list->{'admin'},0);
++ # &tools::dump_var($param->{'param'},0);
++
++ $param->{'serial'} = $list->{'admin'}{'serial'};
++
++ return 1;
++ }
++
++sub _check_new_values {
++ my $check_family = shift;
++ my $pname = shift;
++ my $new_admin = shift;
++ &wwslog('debug3', '_check_new_values(%s)',$pname);
++
++ my $uncompellable_param = &Family::get_uncompellable_param();
++
++ if (ref($::pinfo{$pname}{'format'}) eq 'HASH') { #composed parameter
++
++ foreach my $key (keys %{$check_family->{$pname}}) {
++
++ my $constraint = $check_family->{$pname}{$key};
++ my $values = &List::_get_param_value_anywhere($new_admin,"$pname.$key");
++ my $nb_for = 0;
++
++ # exception for uncompellable param
++ foreach my $p (keys %{$uncompellable_param}) {
++ if (($pname eq $p) && !($uncompellable_param->{$p})) {
++ return 1;
++ }
++
++ if (($pname eq $p) && ($key eq $uncompellable_param->{$p})) {
++ return 1;
++ }
++ }
++ foreach my $p_val (@{$values}) { #each element value
++ $nb_for++;
++ if (ref($p_val) eq 'ARRAY') { # multiple values
++ foreach my $p (@{$p_val}) {
++ if (!($constraint->{$p}) && (($nb_for == 1) || ($p ne ''))) {
++ &report::reject_report_web('user','p_family_wrong',{'param' => $pname,'val'=> $p},$param->{'action'});
++ &wwslog('info','do_edit_list : parameter %s has got wrong value : %s (family context), %s, %d',$pname,$p);
++ return undef;
++ }
++ }
++ } else { # single value
++ if (!($constraint->{$p_val}) && (($nb_for == 1) || ($p_val ne ''))) {
++ &report::reject_report_web('user','p_family_wrong',{'param' => $pname,'val'=> $p_val},$param->{'action'});
++ &wwslog('info','do_edit_list : parameter %s has got wrong value : %s (family context), %s, %d',$pname,$p_val);
++ return undef;
++ }
++ }
++ }
++ }
++ } else { #simple parameter
++
++ # exception for uncompellable param
++ foreach my $p (keys %{$uncompellable_param}) {
++ if ($pname eq $p) {
++ return 1;
++ }
++ }
++
++
++ my $constraint = $check_family->{$pname};
++ my $values = &List::_get_param_value_anywhere($new_admin,$pname);
++ my $nb_for = 0;
++
++
++ foreach my $p_val (@{$values}) { #each element value
++ $nb_for++;
++ if (ref($p_val) eq 'ARRAY') { # multiple values
++ foreach my $p (@{$p_val}) {
++ if (!($constraint->{$p}) && (($nb_for == 1) || ($p ne ''))) {
++ &report::reject_report_web('user','p_family_wrong',{'param' => $pname,'val'=> $p},$param->{'action'});
++ &wwslog('info','do_edit_list : parameter %s has got wrong value : %s (family context), %s, %d',$pname,$p);
++ return undef;
++ }
++ }
++ } else { # single value
++ if (!($constraint->{$p_val}) && (($nb_for == 1) || ($p_val ne ''))) {
++ &report::reject_report_web('user','p_family_wrong',{'param' => $pname,'val'=> $p_val},$param->{'action'});
++ &wwslog('info','do_edit_list : parameter %s has got wrong value : %s (family context), %s, %d',$pname,$p_val);
++ return undef;
++ }
++ }
++ }
++ }
++}
++
++=pod
++
++=head2 sub _prepare_edit_form(LIST)
++
++Prepares config data to be sent in the edition form. Adds to the parameters array a hash for each parameter to be edited.
++
++=head3 Arguments
++
++=over
++
++=item * I<$list>, a List object
++
++=back
++
++=head3 Return
++
++=over
++
++=item * I<1>, if no problem is encountered
++
++=item * I<undef>, if anything goes wrong
++
++=back
++
++=head3 Calls
++
++=over
++
++=item * _prepare_data
++
++=item * _restrict_values
++
++=item * wwslog
++
++=item * List::by_order
++
++=item * List::get_family
++
++=item * List::load_topics
++
++=item * List::may_edit
++
++=item * Language::GetLang
++
++=item * Language::SetLang
++
++=item * report::reject_report_web
++
++=item * tools::dup_var
++
++=back
++
++=cut
++
++## Prepare config data to be sent in the
++## edition form
++sub _prepare_edit_form {
++ my $list = shift;
++ my $list_config = &tools::dup_var($list->{'admin'});
++ my $family;
++ my $is_form_editable = '0';
++
++ ## If the list belongs to a family, check if the said family can be retrieved.
++ if (defined $list_config->{'family_name'}) {
++ unless ($family = $list->get_family()) {
++ &report::reject_report_web('intern','unable_get_family',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','_prepare_edit_form : impossible to get list %s\'s family',$list->{'name'});
++ return undef;
++ }
++ }
++
++ ## For each parameter defined in List.pm, retrieve and prepare for editing
++ foreach my $pname (sort List::by_order keys %{$pinfo}) {
++
++ ## Skip comments and default values.
++ next if ($pname =~ /^(comment|defaults)$/);
++
++ ## Skip parameters belonging to another group.
++ next if ($in{'group'} && ($pinfo->{$pname}{'group'} ne $in{'group'}));
++
++ ## Skip obsolete parameters.
++ next if $pinfo->{$pname}{'obsolete'};
++
++ ## Check whether the parameter can be edited by the logged user.
++ my $may_edit = $list->may_edit($pname,$param->{'user'}{'email'});
++
++ ## Valid form global edit status as soon as at least one editable parameter is found.
++ if ($may_edit eq 'write') {
++ $is_form_editable = '1';
++ }
++
++ ## Store in $p a reference to the hash containing the informations relative to the parameter editing.
++ my $p = &_prepare_data($pname, $pinfo->{$pname}, $list_config->{$pname},$may_edit,$family);
++
++ ## Store if the parameter is still at its default value or not.
++ $p->{'default'} = $list_config->{'defaults'}{$pname};
++
++ ## Store the change state of this parameter, taken from the global variable %changed_params.
++ $p->{'changed'} = $::changed_params{$pname};
++
++ ## Exceptions...too many
++ if ($pname eq 'topics') {
++ $p->{'type'} = 'enum';
++
++ my @topics;
++ foreach my $topic(@{$p->{'value'}}) {
++ push @topics, $topic->{'value'};
++ }
++ undef $p->{'value'};
++ my %list_of_topics = &List::load_topics($robot);
++
++ if (defined $p->{'constraint'}) {
++ &_restrict_values(\%list_of_topics,$p->{'constraint'});
++ }
++
++ foreach my $topic (keys %list_of_topics) {
++ $p->{'value'}{$topic}{'selected'} = 0;
++ $p->{'value'}{$topic}{'title'} = $list_of_topics{$topic}{'current_title'};
++
++ if ($list_of_topics{$topic}{'sub'}) {
++ foreach my $subtopic (keys %{$list_of_topics{$topic}{'sub'}}) {
++ $p->{'value'}{"$topic/$subtopic"}{'selected'} = 0;
++ $p->{'value'}{"$topic/$subtopic"}{'title'} = "$list_of_topics{$topic}{'current_title'}/$list_of_topics{$topic}{'sub'}{$subtopic}{'current_title'}";
++ }
++ }
++ }
++ foreach my $selected_topic (@topics) {
++ next unless (defined $selected_topic);
++ $p->{'value'}{$selected_topic}{'selected'} = 1;
++ $p->{'value'}{$selected_topic}{'title'} = "Unknown ($selected_topic)"
++ unless (defined $p->{'value'}{$selected_topic}{'title'});
++ }
++ }elsif ($pname eq 'digest') {
++ foreach my $v (@{$p->{'value'}}) {
++ next unless ($v->{'name'} eq 'days');
++ if (ref($v->{'value'}) eq 'ARRAY'){
++ &tools::do_log('debug2','Empty digest parameter. Putting a dummy value.');
++ $v->{'value'} = undef;
++ $v->{'type'} = 'enum';
++ }else{
++ foreach my $day (keys %{$v->{'value'}}) {
++ $v->{'value'}{$day}{'title'} = gettext_strftime "%A", gmtime(0 + ($day +3) * (3600 * 24));
++ }
++ }
++ }
++ }elsif ($pname eq 'lang') {
++ my $saved_lang = &Language::GetLang();
++
++ foreach my $lang (keys %{$p->{'value'}}) {
++ #&wwslog('notice','LANG: %s', $lang);
++ &Language::SetLang($lang);
++ $p->{'value'}{$lang}{'title'} = gettext('_language_');
++ }
++ &Language::SetLang($saved_lang);
++ }
++
++ push @{$param->{'param'}}, $p;
++ }
++
++ ## If at least one param was editable, make the update button appear in the form.
++ $param->{'is_form_editable'} = $is_form_editable;
++ return 1;
++ }
++
++=pod
++
++=head2 sub _prepare_data(STRING $name, HASH_Ref $struct, SCALAR $data, STRING $may_edit, FAMILY $family, STRING $main_p)
++
++Returns a reference to a hash containing the data used to edit the parameter (of name $name, corresponding to the structure $struct in pinfo, with the $may_edit editing status) containing the data in the Sympa web interface.
++
++=head3 Arguments
++
++=over
++
++=item * I<$name> (STRING), the name of the parameter processed
++
++=item * I<$struct> (HASH_Ref), a ref to the hash describing this parameter in %List::pinfo
++
++=item * I<$data> (), the value(s) taken by this parameter in the current list. Can be a reference to a list or the value of a single parameter.
++
++=item * I<$may_edit> (STRING), the editing status of this parameter in the current context.
++
++=item * I<$family> (FAMILY), the family the list belongs to.
++
++=item * I<$main_p> (STRING), the prefix composing the complete name of the parameter.
++
++=back
++
++=head3 Return
++
++=over
++
++=item * I<$p_glob>, a reference to a hash containing the data used to edit the parameter.
++
++=back
++
++=head3 Calls
++
++=over
++
++=item * _restrict_values
++
++=item * _prepare_data
++
++=item * load_data_sources_list
++
++=item * Family::get_param_constraint
++
++=item * List::load_scenario_list
++
++=item * List::load_task_list
++
++=item * List::may_edit
++
++=item * tools::escape_html
++
++=back
++
++=cut
++
++ sub _prepare_data {
++ my ($name, $struct,$data,$may_edit,$family,$main_p) = @_;
++ # &wwslog('debug2', '_prepare_data(%s, %s)', $name, $data);
++ # $family and $main_p (recursive call) are optionnal
++ # if $main_p is needed, $family also
++ next if ($struct->{'obsolete'});
++
++ ## Prepare data structure for the parser
++ my $p_glob = {'name' => $name,
++ 'comment' => $struct->{'comment'}{$param->{'lang'}}
++ };
++
++ ## Check if some family constraint modify the editing rights.
++ my $restrict = 0;
++ my $constraint;
++ if ((ref($family) eq 'Family') && ($may_edit eq 'write')) {
++
++ if ($main_p && defined $::pinfo{$main_p}) {
++ if (ref($::pinfo{$main_p}{'format'}) eq 'HASH') { # composed parameter
++ $constraint = $family->get_param_constraint("$main_p.$p_glob->{'name'}");
++ }
++ } else { # simple parameter
++ if (ref($::pinfo{$p_glob->{'name'}}{'format'}) ne 'HASH') { # simple parameter
++ $constraint = $family->get_param_constraint($p_glob->{'name'});
++ }
++ }
++ if ($constraint eq '0') { # free parameter
++ $p_glob->{'may_edit'} = 'write';
++
++ } elsif (ref($constraint) eq 'HASH') { # controlled parameter
++ $p_glob->{'may_edit'} = 'write';
++ $restrict = 1;
++
++ } else { # fixed parameter
++ $p_glob->{'may_edit'} = 'read';
++ }
++
++ } else {
++ $p_glob->{'may_edit'} = $may_edit;
++ }
++
++ ## Naming the parameter.
++ if ($struct->{'gettext_id'}) {
++ $p_glob->{'title'} = gettext($struct->{'gettext_id'});
++ }else {
++ $p_glob->{'title'} = $name;
++ }
++
++ ## Occurrences : if the parameter can have multiple occurences,
++ ## its values are transfered into the array pointed by $data2
++ ## if they were given in arguments (if not, an empty array is created).
++ ## if it is a single occurence parameter, an array is created with
++ ## its single value.
++
++ my $data2;
++ if ($struct->{'occurrence'} =~ /n$/) {
++ $p_glob->{'occurrence'} = 'multiple';
++ if (defined($data)) {
++ $data2 = $data;
++
++ if ($may_edit eq 'write') {
++ ## Add an empty entry
++ unless (($name eq 'days') || ($name eq 'reception') || ($name eq 'rfc2369_header_fields') || ($name eq 'topics')) {
++
++ my $empty_entry;
++ ## Structured parameter
++ if (ref($struct->{'format'}) eq 'HASH') {
++ foreach my $sub_parameter (keys %{$struct->{'format'}}) {
++
++ ## Use default value if defined
++ if ($struct->{'format'}{$sub_parameter}{'default'}) {
++ $empty_entry->{$sub_parameter} = $struct->{'format'}{$sub_parameter}{'default'};
++ }
++ }
++
++ ## Simpe parameter
++ }else {
++ $empty_entry = undef;
++ }
++
++ push @{$data2}, $empty_entry;
++ ## &wwslog('debug2', 'Add 1 %s', $name);
++ }
++ }
++ }else {
++ if ($may_edit eq 'write') {
++ $data2 = [undef];
++ }
++ }
++ }else {
++ $data2 = [$data];
++ }
++
++ my @all_p;
++
++ ## Foreach occurrence of param
++ foreach my $d (@{$data2}) {
++ my $p = {};
++
++ ## Type of data
++ if ($struct->{'scenario'}) {
++ $p_glob->{'type'} = 'scenario';
++ my $list_of_scenario;
++
++ my $tmp_list_of_scenario = $list->load_scenario_list($struct->{'scenario'},$robot);
++
++ ## Only get required scenario attributes
++ foreach my $scenario (keys %{$tmp_list_of_scenario}) {
++ $list_of_scenario->{$scenario} = {'name' => $tmp_list_of_scenario->{$scenario}{'name'},
++ 'web_title' => $tmp_list_of_scenario->{$scenario}{'web_title'}};
++ }
++
++ $list_of_scenario->{$d->{'name'}}{'selected'} = 1;
++
++ $p->{'value'} = $list_of_scenario;
++
++ if ($restrict) {
++ &_restrict_values($p->{'value'},$constraint);
++ }
++
++ }elsif ($struct->{'task'}) {
++ $p_glob->{'type'} = 'task';
++ my $list_of_task = $list->load_task_list($struct->{'task'}, $robot);
++
++ $list_of_task->{$d->{'name'}}{'selected'} = 1;
++
++ $p->{'value'} = $list_of_task;
++
++ if ($restrict) {
++ &_restrict_values($p->{'value'},$constraint);
++ }
++
++ }elsif ($struct->{'datasource'}) {
++ $p_glob->{'type'} = 'datasource';
++ my $list_of_data_sources = $list->load_data_sources_list($robot);
++
++ $list_of_data_sources->{$d}{'selected'} = 1;
++
++ $p->{'value'} = $list_of_data_sources;
++
++ if ($restrict) {
++ &_restrict_values($p->{'value'},$constraint);
++ }
++
++ }elsif (ref ($struct->{'format'}) eq 'HASH') {
++ $p_glob->{'type'} = 'paragraph';
++ unless (ref($d) eq 'HASH') {
++ $d = {};
++ }
++
++ foreach my $k (sort {$struct->{'format'}{$a}{'order'} <=> $struct->{'format'}{$b}{'order'}}
++ keys %{$struct->{'format'}}) {
++ ## Prepare data recursively
++ my $m_e = $list->may_edit("$name.$k",$param->{'user'}{'email'});
++ my $v = &_prepare_data($k, $struct->{'format'}{$k}, $d->{$k},$m_e,$family,$name);
++
++ push @{$p->{'value'}}, $v;
++ }
++
++ }elsif ((ref ($struct->{'format'}) eq 'ARRAY') || ($restrict && ($main_p eq 'msg_topic' && $name eq 'keywords'))) {
++ $p_glob->{'type'} = 'enum';
++
++ unless (defined $p_glob->{'value'}) {
++ ## Initialize
++ foreach my $elt (@{$struct->{'format'}}) {
++ $p_glob->{'value'}{$elt}{'selected'} = 0;
++ }
++
++ ## Check obsolete values ; they should not be printed
++ if (defined $struct->{'obsolete_values'}) {
++ foreach my $elt (@{$struct->{'obsolete_values'}}) {
++ delete $p_glob->{'value'}{$elt};
++ }
++ }
++ }
++ if (ref ($d)) {
++ next unless (ref ($d) eq 'ARRAY');
++ foreach my $v (@{$d}) {
++ $p_glob->{'value'}{$v}{'selected'} = 1;
++ }
++ }else {
++ $p_glob->{'value'}{$d}{'selected'} = 1 if (defined $d);
++ }
++
++ if ($restrict) {
++ &_restrict_values($p_glob->{'value'},$constraint);
++ }
++
++ }else {
++ if ($restrict && ($name ne 'topics')) {
++ $p_glob->{'type'} = 'enum';
++
++ foreach my $elt (keys %{$constraint}) {
++ $p->{'value'}{&tools::escape_html($elt)}{'selected'} = 0;
++ }
++
++ $p->{'value'}{&tools::escape_html($d)}{'selected'} = 1;
++ $p->{'length'} = $struct->{'length'};
++ $p->{'unit'} = gettext($struct->{'gettext_unit'});
++
++ } else {
++
++ $p_glob->{'type'} = 'scalar';
++ $p->{'value'} = &tools::escape_html($d);
++ $p->{'length'} = $struct->{'length'};
++ $p->{'field_type'} = $struct->{'field_type'};
++ my $l = length($p->{'value'});
++ $p->{'hidden_field'} = '*' x $l;
++ $p->{'unit'} = gettext($struct->{'gettext_unit'});
++ if ($restrict) { # for topics
++ $p_glob->{'constraint'} = $constraint;
++ }
++ }
++ }
++
++ push @all_p, $p;
++ }
++
++ if (($p_glob->{'occurrence'} eq 'multiple')
++ && ($p_glob->{'type'} ne 'enum')) {
++ $p_glob->{'value'} = \@all_p;
++ }else {
++ foreach my $k (keys %{$all_p[0]}) {
++ $p_glob->{$k} = $all_p[0]->{$k};
++ }
++ }
++
++ return $p_glob;
++ }
++
++## Restrict allowed values in the hash
++sub _restrict_values {
++ my $values = shift; #ref on hash of values
++ my $allowed = shift; #ref on hash of allowed values
++ &wwslog('debug3', '_restrict_values()');
++
++ foreach my $v (keys %{$values}) {
++ unless (defined $allowed->{$v}) {
++ delete $values->{$v};
++ }
++ }
++}
++
++ ## NOT USED anymore (expect chinese)
++ sub do_close_list_request {
++ &wwslog('info', 'do_close_list_request()');
++
++ if ($list->{'admin'}{'status'} eq 'closed') {
++ &report::reject_report_web('user','already_closed',{},$param->{'action'},$list);
++ &wwslog('info','do_close_list_request: already closed');
++ return undef;
++ }
++
++ return 1;
++ }
++
++
++ # in order to rename a list you must be list owner and you must be allowed to create new list
++ sub do_rename_list_request {
++ &wwslog('info', 'do_rename_list_request()');
++
++ my $result = &Scenario::request_action ('create_list',$param->{'auth_method'},$robot,
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $r_action;
++ my $reason;
++ if (ref($result) eq 'HASH') {
++ $r_action = $result->{'action'};
++ $reason = $result->{'reason'};
++ }
++
++ unless ($r_action =~ /do_it|listmaster/) {
++ &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
++ &wwslog('info','do_rename_list_request: not owner');
++ return undef;
++ }
++
++ ## Super listmaster can move a list to another robot
++ if (&List::is_listmaster($param->{'user'}{'email'}, $robot)) {
++ foreach (keys %{$Conf{'robots'}}) {
++ if ($_ eq $robot) {
++ $param->{'robots'}{$_} = 'selected="selected"';
++ }else {
++ $param->{'robots'}{$_} = '';
++ }
++ }
++ }
++
++ return '1';
++ }
++
++sub do_copy_list {
++ &wwslog('info', 'do_copy_list(%s,%s)', $in{'new_listname'}, $in{'new_robot'});
++ &do_rename_list('copy');
++}
++
++# in order to rename a list you must be list owner and you must be allowed to create new list
++sub do_rename_list {
++ my $mode = shift;
++
++ if ($in{'new_listname'} =~ /[A-Z]/) {
++ $in{'new_listname'} = lc($in{'new_listname'});
++ &report::notice_report_web('listname_lowercased',{},$param->{'action'});
++ }
++
++ &wwslog('info', 'do_rename_list(%s,%s, mode = %s)', $in{'new_listname'}, $in{'new_robot'},$mode);
++
++ my $result = &admin::rename_list(list => $list,
++ new_listname =>$in{'new_listname'},
++ new_robot => $in{'new_robot'},
++ mode => $mode,
++ auth_method => $param->{'auth_method'},
++ user_email => $param->{'user'}{'email'},
++ remote_host => $param->{'remote_host'},
++ remote_addr => $param->{'remote_addr'},
++ aliases => $param->{'aliases'},
++ status => $param->{'status'},
++ );
++
++ if ($result eq 'incorrect_listname') {
++ &report::reject_report_web('user','incorrect_listname', {'bad_listname' => $in{'new_listname'}},$param->{'action'},$list);
++ &wwslog('info','do_rename_list: incorrect listname %s', $in{'new_listname'});
++ &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
++ 'status' => 'error',
++ 'error_type' => 'incorrect_listname'});
++ return 'rename_list_request';
++
++ }elsif ($result eq 'authorization') {
++ &report::reject_report_web('auth','authorization',{},$param->{'action'},$list);
++ &wwslog('info','do_rename_list: not owner');
++ &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++
++ }elsif ($result eq 'internal') {
++ &report::reject_report_web('intern','UUUUnable_to_rename_list',{'new_listname' => $in{'new_listname'}},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err', "can't rename list %s to %s@%s", $list->get_list_address(), $in{'new_listname'}, $in{'new_robot'});
++ &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++
++ }elsif ($result eq 'list_already_exists') {
++ &report::reject_report_web('user','list_already_exists',{'new_listname' => $in{'new_listname'}},$param->{'action'},$list);
++ &wwslog('info', 'Could not rename list %s for %s: new list %s already existing list',
++ $in{'listname'},$param->{'user'}{'email'},$in{'new_listname'});
++ &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
++ 'status' => 'error',
++ 'error_type' => 'list_already_exists'});
++ return undef;
++
++ }elsif ($result eq 'incorrect_listname') {
++ &report::reject_report_web('user','listname_matches_aliases',{'new_listname' => $in{'new_listname'}},$param->{'action'},$list);
++ &wwslog('info','do_create_list: incorrect listname %s', $in{'new_listname'});
++ &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
++ 'status' => 'error',
++ 'error_type' => 'incorrect_listname'});
++ return 'rename_list_request';
++ }elsif ($result eq 'unknown_robot') {
++ &wwslog('info',"do_rename_list : unknown robot $in{'new_robot'}");
++ &report::reject_report_web('user','unknown_robot',{'new_robot' => $in{'new_robot'}},$param->{'action'},$list);
++ &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
++ 'status' => 'error',
++ 'error_type' => 'unknown_robot'});
++ return undef;
++ }
++
++ ## Were aliases installed?
++ if ($param->{'aliases'} == 1) {
++ $param->{'auto_aliases'} = 1;
++ }else {
++ $param->{'auto_aliases'} = 0;
++ }
++
++ # set list status to pending if creation list is moderated
++ if ($param->{'status'} eq 'pending') {
++ &report::notice_report_web('pending_list',{},$param->{'action'},$list);
++ }
++
++ if ($in{'new_robot'} eq '$robot') {
++ $param->{'redirect_to'} = "$param->{'base_url'}$param->{'path_cgi'}/admin/$in{'new_listname'}";
++ }else {
++ $param->{'redirect_to'} = &Conf::get_robot_conf($in{'new_robot'}, 'wwsympa_url')."/admin/$in{'new_listname'}";
++ }
++
++ $param->{'list'} = $in{'new_listname'};
++ &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
++ 'status' => 'success'});
++
++ return 1;
++}
++
++
++sub do_purge_list {
++ &wwslog('info', 'do_purge_list()');
++
++ my @lists = split /\0/, $in{'selected_lists'};
++
++ foreach my $l (@lists) {
++ my $list = new List ($l, $robot);
++ next unless (defined $list);
++ $list->purge($param->{'user'}{'email'});
++ }
++
++ &report::notice_report_web('performed',{},$param->{'action'});
++ &web_db_log({'parameters' => $in{'selected_lists'},
++ 'status' => 'success'});
++ return 'get_closed_lists';
++ }
++
++ sub do_close_list {
++ &wwslog('info', "do_close_list($list->{'name'})");
++
++ if ($list->{'admin'}{'status'} eq 'closed') {
++ &report::reject_report_web('user','already_closed',{},$param->{'action'},$list);
++ &wwslog('info','do_close_list: already closed');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'already_closed'});
++ return undef;
++ }elsif($list->{'admin'}{'status'} eq 'pending') {
++ &wwslog('info','do_close_list: closing a pending list makes it purged');
++ $list->purge($param->{'user'}{'email'});
++ &report::notice_report_web('list_purged',{},$param->{'action'});
++ &web_db_log({'status' => 'success'});
++ return 'home';
++ }else{
++ $list->close($param->{'user'}{'email'});
++ &report::notice_report_web('list_closed',{},$param->{'action'});
++ &web_db_log({'status' => 'success'});
++ return 'admin';
++ }
++
++ }
++
++ sub do_restore_list {
++ &wwslog('info', 'do_restore_list()');
++
++
++ unless ($list->{'admin'}{'status'} eq 'closed') {
++ &report::reject_report_web('user','not_closed',{},$param->{'action'},$list);
++ &wwslog('info','do_restore_list: list not closed');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'not_closed'});
++ return undef;
++ }
++
++ ## Change status & save config
++ $list->{'admin'}{'status'} = 'open';
++ $list->save_config($param->{'user'}{'email'});
++
++ if ($list->{'admin'}{'user_data_source'} eq 'file') {
++ $list->{'users'} = &List::_load_users_file("$list->{'dir'}/subscribers.closed.dump");
++ }elsif ($list->{'admin'}{'user_data_source'} =~ /^(database|include2)$/) {
++ unless (-f "$list->{'dir'}/subscribers.closed.dump") {
++ &wwslog('notice', 'No subscribers to restore');
++ &web_db_log({'status' => 'error',
++ 'error_type' => 'no_subscribers'});
++ }
++ my @users = &List::_load_users_file("$list->{'dir'}/subscribers.closed.dump");
++
++ ## Insert users in database
++ foreach my $user (@users) {
++ $list->add_user($user);
++ }
++ }
++
++ $list->savestats();
++
++ my $aliases = &admin::install_aliases($list,$robot);
++ if ($aliases == 1) {
++ $param->{'auto_aliases'} = 1;
++ }else {
++ $param->{'aliases'} = $aliases;
++ $param->{'auto_aliases'} = 0;
++ }
++
++ &report::notice_report_web('list_restored',{},$param->{'action'});
++ &web_db_log({'status' => 'success'});
++ return 'admin';
++ }
++
++
++ sub get_desc_file {
++ my $file = shift;
++ my $ligne;
++ my %hash;
++
++ open DESC_FILE,"$file";
++
++ while ($ligne = <DESC_FILE>) {
++ if ($ligne =~ /^title\s*$/) {
++ #case title of the document
++ while (($ligne = <DESC_FILE>) and ($ligne!~/^\s*$/)) {
++ $ligne =~ /^\s*(\S.*\S)\s*/;
++ $hash{'title'} = $hash{'title'}.$1." ";
++ }
++ }
++
++
++
++ if ($ligne =~ /^creation\s*$/) {
++ #case creation of the document
++ while (($ligne = <DESC_FILE>) and ($ligne!~/^\s*$/)) {
++ if ($ligne =~ /^\s*email\s*(\S*)\s*/) {
++ $hash{'email'} = $1;
++ }
++ if ($ligne =~ /^\s*date_epoch\s*(\d*)\s*/) {
++ $hash{'date'} = $1;
++ }
++
++ }
++ }
++
++ if ($ligne =~ /^access\s*$/) {
++ #case access scenari for the document
++ while (($ligne = <DESC_FILE>) and ($ligne!~/^\s*$/)) {
++ if ($ligne =~ /^\s*read\s*(\S*)\s*/) {
++ $hash{'read'} = $1;
++ }
++ if ($ligne =~ /^\s*edit\s*(\S*)\s*/) {
++ $hash{'edit'} = $1;
++ }
++
++ }
++ }
++
++ }
++
++
++ close DESC_FILE;
++
++ return %hash;
++
++ }
++
++
++ sub show_cert {
++ return 1;
++ }
++
++ ## Function synchronize
++ ## Return true if the file in parameter can be overwrited
++ ## false if it has changes since the parameter date_epoch
++ sub synchronize {
++ # args : 'path' , 'date_epoch'
++ my $path = shift;
++ my $date_epoch = shift;
++
++ my @info = stat $path;
++
++ return ($date_epoch == $info[9]);
++ }
++
++
++ #*******************************************
++ # Function : d_access_control
++ # Description : return a hash with privileges
++ # in read, edit, control
++ # if first parameter require
++ # it
++ #******************************************
++
++ ## Regulars
++ # read(/) = default (config list)
++ # edit(/) = default (config list)
++ # control(/) = not defined
++# read(A/B)= (read(A) && read(B)) ||
++ # (author(A) || author(B))
++ # edit = idem read
++ # control (A/B) : author(A) || author(B)
++ # + (set owner A/B) if (empty directory &&
++ # control A)
++
++
++ sub d_access_control {
++ # Arguments:
++ # (\%mode,$path)
++ # if mode->{'read'} control access only for read
++ # if mode->{'edit'} control access only for edit
++ # if mode->{'control'} control access only for control
++
++ # return the hash (
++ # $result{'may'}{'read'} == $result{'may'}{'edit'} == $result{'may'}{'control'} if is_author else :
++ # $result{'may'}{'read'} = 0 or 1 (right or not)
++ # $result{'may'}{'edit'} = 0(not may edit) or 0.5(may edit with moderation) or 1(may edit ) : it is not a boolean anymore
++ # $result{'may'}{'control'} = 0 or 1 (right or not)
++ # $result{'reason'}{'read'} = string for authorization_reject.tt2 when may_read == 0
++ # $result{'reason'}{'edit'} = string for authorization_reject.tt2 when may_edit == 0
++ # $result{'scenario'}{'read'} = scenario name for the document
++ # $result{'scenario'}{'edit'} = scenario name for the document
++
++
++ # Result
++ my %result;
++ $result{'reason'} = {};
++
++ # Control
++
++ # Arguments
++ my $mode = shift;
++ my $path = shift;
++
++ &wwslog('debug', "d_access_control(%s, %s)", join('/',%$mode), $path);
++
++ my $mode_read = $mode->{'read'};
++ my $mode_edit = $mode->{'edit'};
++ my $mode_control = $mode->{'control'};
++
++ # Useful parameters
++ my $list_name = $list->{'name'};
++ my $shareddir = $list->{'dir'}.'/shared';
++
++
++ # document to read
++ my $doc;
++ if ($path) {
++ # the path must have no slash a its end
++ $path =~ /^(.*[^\/])?(\/*)$/;
++ $path = $1;
++ $doc = $shareddir.'/'.$path;
++ } else {
++ $doc = $shareddir;
++ }
++
++ # Control for editing
++ my $may_read = 1;
++ my $why_not_read = '';
++ my $may_edit = 1;
++ my $why_not_edit = '';
++ my $is_author = 0; # <=> $may_control
++
++ ## First check privileges on the root shared directory
++ $result{'scenario'}{'read'} = $list->{'admin'}{'shared_doc'}{'d_read'}{'name'};
++ $result{'scenario'}{'edit'} = $list->{'admin'}{'shared_doc'}{'d_edit'}{'name'};
++
++ ## Privileged owner has all privileges
++ if ($param->{'is_privileged_owner'}) {
++ $result{'may'}{'read'} = 1;
++ $result{'may'}{'edit'} = 1;
++ $result{'may'}{'control'} = 1;
++ return %result;
++ }
++
++ # if not privileged owner
++ if ($mode_read) {
++ my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $action;
++ if (ref($result) eq 'HASH') {
++ $action = $result->{'action'};
++ $why_not_read = $result->{'reason'};
++ }
++
++ $may_read = ($action =~ /do_it/i);
++ }
++
++ if ($mode_edit) {
++ my $result = $list->check_list_authz('shared_doc.d_edit',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $action;
++ if (ref($result) eq 'HASH') {
++ $action = $result->{'action'};
++ $why_not_edit = $result->{'reason'};
++ }
++
++ #edit = 0, 0.5 or 1
++ $may_edit = &find_edit_mode($action);
++ $why_not_edit = '' if ($may_edit);
++ }
++
++ ## Only authenticated users can edit files
++ unless ($param->{'user'}{'email'}) {
++ $may_edit = 0;
++ $why_not_edit = 'not_authenticated';
++ }
++
++# if ($mode_control) {
++# $result{'may'}{'control'} = 0;
++# }
++
++ my $current_path = $path;
++ my $current_document;
++ my %desc_hash;
++ my $user = $param->{'user'}{'email'} || 'nobody';
++
++ while ($current_path ne "" && $current_path ne '/') {
++ # no description file found yet
++ my $def_desc_file = 0;
++ my $desc_file;
++
++ $current_path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
++ $current_document = $3;
++ my $next_path = $1;
++
++ # opening of the description file appropriated
++ if (-d $shareddir.'/'.$current_path) {
++ # case directory
++
++ # unless ($slash) {
++ $current_path = $current_path.'/';
++ # }
++
++ if (-e "$shareddir/$current_path.desc"){
++ $desc_file = $shareddir.'/'.$current_path.".desc";
++ $def_desc_file = 1;
++ }
++
++ }else {
++ # case file
++ if (-e "$shareddir/$next_path.desc.$3"){
++ $desc_file = $shareddir.'/'.$next_path.".desc.".$3;
++ $def_desc_file = 1;
++ }
++ }
++
++ if ($def_desc_file) {
++ # a description file was found
++ # loading of acces information
++
++ %desc_hash = &get_desc_file($desc_file);
++
++ if ($mode_read) {
++
++ my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'},
++ 'scenario'=> $desc_hash{'read'}});
++ my $action;
++ if (ref($result) eq 'HASH') {
++ $action = $result->{'action'};
++ $why_not_read = $result->{'reason'};
++ }
++
++ $may_read = $may_read && ( $action=~ /do_it/i);
++ $why_not_read = '' if ($may_read);
++ }
++
++ if ($mode_edit) {
++ my $result = $list->check_list_authz('shared_doc.d_edit',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'},
++ 'scenario'=> $desc_hash{'edit'}});
++ my $action_edit;
++ if (ref($result) eq 'HASH') {
++ $action_edit = $result->{'action'};
++ $why_not_edit = $result->{'reason'};
++ }
++
++
++ # $may_edit = 0, 0.5 or 1
++ my $may_action_edit = &find_edit_mode($action_edit);
++ $may_edit = &merge_edit($may_edit,$may_action_edit);
++ $why_not_edit = '' if ($may_edit);
++
++
++ }
++
++ ## Only authenticated users can edit files
++ unless ($param->{'user'}{'email'}) {
++ $may_edit = 0;
++ $why_not_edit = 'not_authenticated';
++ }
++
++ $is_author = $is_author || ($user eq $desc_hash{'email'});
++
++ unless (defined $result{'scenario'}{'read'}) {
++ $result{'scenario'}{'read'} = $desc_hash{'read'};
++ $result{'scenario'}{'edit'} = $desc_hash{'edit'};
++ }
++
++ ## Author has all privileges
++ if ($is_author) {
++ $result{'may'}{'read'} = 1;
++ $result{'may'}{'edit'} = 1;
++ $result{'may'}{'control'} = 1;
++ return %result;
++ }
++
++ }
++
++ # truncate the path for the while
++ $current_path = $next_path;
++ }
++
++ if ($mode_read) {
++ $result{'may'}{'read'} = $may_read;
++ $result{'reason'}{'read'} = $why_not_read;
++ }
++
++ if ($mode_edit) {
++ $result{'may'}{'edit'} = $may_edit;
++ $result{'reason'}{'edit'} = $why_not_edit;
++ }
++
++# if ($mode_control) {
++# $result{'may'}{'control'} = 0;
++# }
++
++
++
++ return %result;
++ }
++
++## return the mode of editing included in $action : 0, 0.5 or 1
++sub find_edit_mode{
++ my $action=shift;
++
++ my $result;
++ if ($action =~ /editor/i){
++ $result = 0.5;
++ } elsif ($action =~ /do_it/i){
++ $result = 1;
++ } else {
++ $result = 0;
++ }
++ return $result;
++}
++
++## return the mode of editing : 0, 0.5 or 1 :
++# do the merging between 2 args of right access edit : "0" > "0.5" > "1"
++# instead of a "and" between two booleans : the most restrictive right is
++# imposed
++sub merge_edit{
++ my $arg1=shift;
++ my $arg2=shift;
++ my $result;
++
++ if ($arg1 == 0 || $arg2 == 0){
++ $result = 0;
++ }elsif ($arg1 == 0.5 || $arg2 == 0.5){
++ $result = 0.5;
++ }else {
++ $result = 1;
++ }
++ return $result;
++}
++
++
++
++
++ # create the root shared document
++ sub do_d_admin {
++ &wwslog('info', 'do_d_admin(%s,%s)', $in{'list'}, $in{'d_admin'});
++
++ my %mode;
++ $mode{'edit'} = 1;
++ my %access = &d_access_control(\%mode,$in{'path'});
++
++
++ my $dir = $list->{'dir'};
++
++ unless ($access{'may'}{'edit'}) {
++ &wwslog('info',"do_d_admin : permission denied for $param->{'user'}{'email'} ");
++ &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++ if ($in{'d_admin'} eq 'create') {
++
++ unless ($list->create_shared()) {
++ &wwslog('info',"do_d_admin : could not create the shared");
++ &report::reject_report_web('intern','create_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ return 'd_read';
++
++ }elsif($in{'d_admin'} eq 'restore') {
++ unless (-e "$dir/pending.shared") {
++ &wwslog('info',"do_d_admin : restore; $dir/pending.shared not found");
++ &report::reject_report_web('intern','restore_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ if (-e "$dir/shared") {
++ &wwslog('info',"do_d_admin : restore; $dir/shared already exist");
++ &report::reject_report_web('intern','restore_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ unless (rename ("$dir/pending.shared", "$dir/shared")){
++ &wwslog('info',"do_d_admin : restore; unable to rename $dir/pending.shared");
++ &report::reject_report_web('intern','restore_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'success'});
++ return 'd_read';
++ }elsif($in{'d_admin'} eq 'delete') {
++ unless (-e "$dir/shared") {
++ &wwslog('info',"do_d_admin : restore; $dir/shared not found");
++ &report::reject_report_web('intern','delete_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ if (-e "$dir/pending.shared") {
++ &wwslog('info',"do_d_admin : delete ; $dir/pending.shared already exist");
++ &report::reject_report_web('intern','delete_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ unless (rename ("$dir/shared", "$dir/pending.shared")){
++ &wwslog('info',"do_d_admin : restore; unable to rename $dir/shared");
++ &report::reject_report_web('intern','delete_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'success'});
++ return 'admin';
++ }
++
++ # Function which sorts a hash of documents
++ # Sort by various parameters
++ sub by_order {
++ my $order = shift;
++ my $hash = shift;
++ # $order = 'order_by_size'/'order_by_doc'/'order_by_author'/'order_by_date'
++
++ if ($order eq 'order_by_doc') {
++ $hash->{$a}{'doc'} cmp $hash->{$b}{'doc'}
++ or $hash->{$b}{'date_epoch'} <=> $hash->{$a}{'date_epoch'};
++ }
++ elsif ($order eq 'order_by_author') {
++ $hash->{$a}{'author'} cmp $hash->{$b}{'author'}
++ or $hash->{$b}{'date_epoch'} <=> $hash->{$a}{'date_epoch'};
++ }
++ elsif ($order eq 'order_by_size') {
++ $hash->{$a}{'size'} <=> $hash->{$b}{'size'}
++ or $hash->{$b}{'date_epoch'} <=> $hash->{$a}{'date_epoch'};
++ }
++ elsif ($order eq 'order_by_date') {
++ $hash->{$b}{'date_epoch'} <=> $hash->{$a}{'date_epoch'} or $a cmp $b;
++ }
++
++ else {
++ $a cmp $b;
++ }
++ }
++
++
++ #*******************************************
++# Function : do_d_read
++ # Description : reads a file or a directory
++ #******************************************
++##
++## Function do_d_read
++sub do_d_read {
++ &wwslog('info', 'do_d_read(%s)', $in{'path'});
++
++ ### Useful variables
++
++ # current list / current shared directory
++ my $list_name = $list->{'name'};
++
++ # relative path / directory shared of the document
++ my $path = &no_slash_end($in{'path'});
++
++ # moderation
++ my $visible_path = &make_visible_path($path);
++
++ # path of the shared directory
++ my $shareddir = $list->{'dir'}.'/shared';
++
++ # document to read
++ my $doc;
++ if ($path) {
++ $doc = $shareddir.'/'.$path;
++ } else {
++ $doc = $shareddir;
++ }
++
++ ### is list open ?
++ unless ($list->{'admin'}{'status'} eq 'open'){
++ &report::reject_report_web('user','list_not_open',{'status' => $list->{'admin'}{'status'}},$param->{'action'},$list);
++ &wwslog('err','d_read : access denied for %s because list is not open', $param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++ ### Document exists ?
++ unless (-r "$doc") {
++ &wwslog('err',"do_d_read : unable to read $shareddir/$path : no such file or directory");
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ ### Document has non-size zero?
++ unless (-s "$doc") {
++ &wwslog('err',"do_d_read : unable to read $shareddir/$path : empty document");
++ &report::reject_report_web('user','empty_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ ### Document isn't a description file
++ unless ($path !~ /\.desc/) {
++ &wwslog('err',"do_d_read : $shareddir/$path : description file");
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ ### Access control
++ my %mode;
++ $mode{'read'} = 1;
++ $mode{'edit'} = 1;
++ $mode{'control'} = 1;
++ my %access = &d_access_control(\%mode,$path);
++ my $may_read = $access{'may'}{'read'};
++ unless ($may_read) {
++ &report::reject_report_web('auth',$access{'reason'}{'read'},{},$param->{'action'},$list);
++ &wwslog('err','d_read : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++ my $may_edit = $access{'may'}{'edit'};
++ my $may_control = $access{'may'}{'control'};
++
++
++ ### File or directory ?
++
++ if (!(-d $doc)) {
++ my @tokens = split /\//,$doc;
++ my $filename = $tokens[$#tokens];
++
++ ## Jump to the URL
++ if ($filename =~ /^\..*\.(\w+)\.moderate$/) {
++ $param->{'file_extension'} = $1;
++ }elsif ($filename =~ /^.*\.(\w+)$/) {
++ $param->{'file_extension'} = $1;
++ }
++
++ if ($param->{'file_extension'} eq 'url') {
++ open DOC, $doc;
++ my $url = <DOC>;
++ close DOC;
++ chomp $url;
++ $param->{'redirect_to'} = $url;
++ return 1;
++ }else {
++ # parameters for the template file
++ # view a file
++ $param->{'file'} = $doc;
++ $param->{'bypass'} = 1;
++ return 1;
++ }
++ }else { # directory
++ # verification of the URL (the path must have a slash at its end)
++ # if ($ENV{'PATH_INFO'} !~ /\/$/) {
++ # $param->{'redirect_to'} = "$param->{'base_url'}$param->{'path_cgi'}/d_read/$list_name/";
++ # return 1;
++ # }
++
++ ## parameters of the current directory
++ if ($path && (-e "$doc/.desc")) {
++ my %desc_hash = &get_desc_file("$doc/.desc");
++ $param->{'doc_owner'} = $desc_hash{'email'};
++ $param->{'doc_title'} = $desc_hash{'title'};
++ }
++ my @info = stat $doc;
++ $param->{'doc_date'} = gettext_strftime "%d %b %Y", localtime($info[9]);
++
++
++ # listing of all the shared documents of the directory
++ unless (opendir DIR, "$doc") {
++ &report::reject_report_web('intern','cannot_open_dir',{'dir' => $doc },$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"d_read : cannot open $doc : $!");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ # array of entry of the directory DIR
++ my @tmpdir = readdir DIR;
++ closedir DIR;
++
++ my $dir = &get_directory_content(\@tmpdir,$param->{'user'}{'email'},$list,$doc);
++
++ # empty directory?
++ $param->{'empty'} = ($#{$dir} == -1);
++
++ # subdirectories hash
++ my %subdirs;
++ # file hash
++ my %files;
++
++ ## for the exception of index.html
++ # name of the file "index.html" if exists in the directory read
++ my $indexhtml;
++
++ # boolean : one of the subdirectories or files inside
++ # can be edited -> normal mode of read -> d_read.tt2;
++ my $normal_mode;
++
++
++ my $path_doc;
++ my %desc_hash;
++ my $may, my $def_desc;
++ my $user = $param->{'user'}{'email'} || 'nobody';
++
++ foreach my $d (@{$dir}) {
++
++ # current document
++ my $path_doc = "$doc/$d";
++
++ #case subdirectory
++ if (-d $path_doc) {
++
++ # last update
++ my @info = stat $path_doc;
++
++ if (-e "$path_doc/.desc") {
++
++ # check access permission for reading
++ %desc_hash = &get_desc_file("$path_doc/.desc");
++
++ my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'},
++ 'scenario' => $desc_hash{'read'}});
++ my $action;
++ $action = $result->{'action'} if (ref($result) eq 'HASH');
++
++ if (($user eq $desc_hash{'email'}) || ($may_control) ||
++ ($action =~ /do_it/i)) {
++
++ $subdirs{$d}{'date_epoch'} = $info[9];
++ $subdirs{$d}{'date'} = gettext_strftime "%d %b %Y", localtime($info[9]);
++
++ # Case read authorized : fill the hash
++ $subdirs{$d}{'icon'} = $icon_table{'folder'};
++
++ $subdirs{$d}{'doc'} = &make_visible_path($d);
++ $subdirs{$d}{'escaped_doc'} = &tools::escape_docname($d, '/');
++
++ # size of the doc
++ $subdirs{$d}{'size'} = (-s $path_doc)/1000;
++
++ # description
++ $subdirs{$d}{'title'} = $desc_hash{'title'};
++ $subdirs{$d}{'escaped_title'}=&tools::escape_html($desc_hash{'title'});
++
++ # Author
++ if ($desc_hash{'email'}) {
++ $subdirs{$d}{'author'} = $desc_hash{'email'};
++ $subdirs{$d}{'author_mailto'} = &mailto($list,$desc_hash{'email'});
++ $subdirs{$d}{'author_known'} = 1;
++ }
++
++ # if the file can be read, check for edit access & edit description files access
++ ## only authenticated users can edit a file
++
++ if ($param->{'user'}{'email'}) {
++ my $result = $list->check_list_authz('shared_doc.d_edit',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'},
++ 'scenario' => $desc_hash{'edit'}});
++ my $action_edit;
++ $action_edit = $result->{'action'} if (ref($result) eq 'HASH');
++ #may_action_edit = 0, 0.5 or 1
++ my $may_action_edit=&find_edit_mode($action_edit);
++ $may_action_edit=&merge_edit($may_action_edit,$may_edit);
++
++ if ($may_control || ($user eq $desc_hash{'email'})){
++
++ $subdirs{$d}{'edit'} = 1;# or = $may_action_edit ?
++ # if index.html, must know if something can be edit in the dir
++ $normal_mode = 1;
++ } elsif ($may_action_edit != 0) {
++ # $may_action_edit = 0.5 or 1
++ $subdirs{$d}{'edit'} = $may_action_edit;
++ # if index.html, must know if something can be edit in the dir
++ $normal_mode = 1;
++ }
++ }
++
++ if ($may_control || ($user eq $desc_hash{'email'})) {
++ $subdirs{$d}{'control'} = 1;
++ }
++
++ }
++ } else {
++ # no description file = no need to check access for read
++ # access for edit and control
++
++ if ($may_control) {
++ $subdirs{$d}{'edit'} = 1; # or = $may_action_edit ?
++ $normal_mode = 1;
++ } elsif ($may_edit !=0) {
++ # $may_action_edit = 1 or 0.5
++ $subdirs{$d}{'edit'} = $may_edit;
++ $normal_mode = 1;
++ }
++
++ if ($may_control) {$subdirs{$d}{'control'} = 1;}
++ }
++
++ }else {
++ # case file
++ $may = 1;
++ $def_desc = 0;
++
++ if (-e "$doc/.desc.$d") {
++ # a desc file was found
++ $def_desc = 1;
++
++ # check access permission
++ %desc_hash = &get_desc_file("$doc/.desc.$d");
++
++
++ my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'},
++ 'scenario' => $desc_hash{'read'}});
++ my $action;
++ $action = $result->{'action'} if (ref($result) eq 'HASH');
++ unless (($user eq $desc_hash{'email'}) || ($may_control) ||
++ ($action =~ /do_it/i)) {
++ $may = 0;
++ }
++ }
++
++ # if permission or no description file
++ if ($may) {
++ $path_doc =~ /^([^\/]*\/)*([^\/]+)\.([^\/]+)$/;
++
++ ## Bookmark
++ if (($path_doc =~ /\.url$/) || ($path_doc =~ /\.url\.moderate$/)) {
++ open DOC, $path_doc;
++ my $url = <DOC>;
++ close DOC;
++ chomp $url;
++ $files{$d}{'url'} = $url;
++ $files{$d}{'anchor'} = &make_visible_path($d);
++ $files{$d}{'icon'} = $icon_table{'url'};
++
++ ## MIME - TYPES : icons for template
++ }elsif (my $type = $mime_types->{$3}) {
++ # type of the file and apache icon
++ $type =~ /^([\w\-]+)\/([\w\-]+)$/;
++ my $mimet = $1;
++ my $subt = $2;
++ if ($subt) {
++ if ($subt =~ /^octet-stream$/) {
++ $mimet = 'octet-stream';
++ $subt = 'binary';
++ }
++ $files{$d}{'type'} = "$subt file";
++ }
++ $files{$d}{'icon'} = $icon_table{$mimet} || $icon_table{'unknown'};
++ } else {
++ # unknown file type
++ $files{$d}{'icon'} = $icon_table{'unknown'};
++ }
++
++ ## case html
++ if ($3 =~ /^html?$/i) {
++ $files{$d}{'html'} = 1;
++ $files{$d}{'type'} = 'html file';
++ $files{$d}{'icon'} = $icon_table{'text'};
++ }
++ ## exception of index.html
++ if ($d =~ /^(index\.html?)$/i) {
++ $indexhtml = $1;
++ }
++
++ ## Access control for edit and control
++ if ($def_desc) {
++ # check access for edit and control the file
++ ## Only authenticated users can edit files
++
++ if ($param->{'user'}{'email'}) {
++ my $result= $list->check_list_authz('shared_doc.d_edit',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'},
++ 'scenario' => $desc_hash{'edit'}});
++ my $action_edit;
++ $action_edit = $result->{'action'} if (ref($result) eq 'HASH');
++ #may_action_edit = 0, 0.5 or 1
++ my $may_action_edit=&find_edit_mode($action_edit);
++ $may_action_edit=&merge_edit($may_action_edit,$may_edit);
++
++ if ($may_control || ($user eq $desc_hash{'email'})){
++ $normal_mode = 1;
++ $files{$d}{'edit'} = 1; # or = $may_action_edit ?
++ } elsif ($may_action_edit != 0){
++ # $may_action_edit = 1 or 0.5
++ $normal_mode = 1;
++ $files{$d}{'edit'} = $may_action_edit;
++ }
++
++ if (($user eq $desc_hash{'email'}) || $may_control) {
++ $files{$d}{'control'} = 1;
++ }
++
++ # fill the file hash
++ # description of the file
++ $files{$d}{'title'} = $desc_hash{'title'};
++ $files{$d}{'escaped_title'}=&tools::escape_html($desc_hash{'title'});
++ # author
++ if ($desc_hash{'email'}) {
++ $files{$d}{'author'} = $desc_hash{'email'};
++ $files{$d}{'author_known'} = 1;
++ $files{$d}{'author_mailto'} = &mailto($list,$desc_hash{'email'});
++ }
++ } else {
++ if ($may_edit!=0) {
++ $files{$d}{'edit'} = $may_edit ;
++ $normal_mode = 1;
++ }
++ if ($may_control) {$files{$d}{'control'} = 1;}
++ }
++
++ # name of the file
++ if ($d =~ /^(\.).*(.moderate)$/) {
++ # file not yet moderated can be seen by its author
++ $files{$d}{'doc'} = &make_visible_path($d);
++ $files{$d}{'moderate'} = 1;
++ } else {
++ $files{$d}{'doc'} = &make_visible_path($d);
++ }
++ $files{$d}{'escaped_doc'} = &tools::escape_docname($d, '/');
++
++ # last update
++ my @info = stat $path_doc;
++ $files{$d}{'date_epoch'} = $info[9];
++ $files{$d}{'date'} = gettext_strftime "%d %b %Y", localtime($info[9]);
++ # size
++ $files{$d}{'size'} = (-s $path_doc)/1000;
++ }
++ }
++ }
++
++ }
++
++ ### Exception : index.html
++ if ($indexhtml) {
++ unless ($normal_mode) {
++ $param->{'file_extension'} = 'html';
++ $param->{'bypass'} = 1;
++ $param->{'file'} = "$doc/$indexhtml";
++ return 1;
++ }
++ }
++
++ ## to sort subdirs
++ my @sort_subdirs;
++ my $order = $in{'order'} || 'order_by_doc';
++ $param->{'order_by'} = $order;
++ foreach my $k (sort {by_order($order,\%subdirs)} keys %subdirs) {
++ push @sort_subdirs, $subdirs{$k};
++ }
++
++ ## to sort files
++ my @sort_files;
++ foreach my $k (sort {by_order($order,\%files)} keys %files) {
++ push @sort_files, $files{$k};
++ }
++
++ # parameters for the template file
++ $param->{'list'} = $list_name;
++
++ $param->{'may_edit'} = $may_edit;
++ $param->{'may_control'} = $may_control;
++
++ if ($path) {
++ # building of the parent directory path
++ if ($path =~ /^(([^\/]*\/)*)([^\/]+)$/) {
++ $param->{'father'} = $1;
++ }else {
++ $param->{'father'} = '';
++ }
++ $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
++
++
++ # Parameters for the description
++ if (-e "$doc/.desc") {
++ my @info = stat "$doc/.desc";
++ $param->{'serial_desc'} = $info[9];
++ my %desc_hash = &get_desc_file("$doc/.desc");
++ $param->{'description'} = $desc_hash{'title'};
++ }
++
++ $param->{'path'} = $path;
++ $param->{'visible_path'} = $visible_path;
++ $param->{'escaped_path'} = &tools::escape_docname($param->{'path'}, '/');
++ }
++ if (scalar keys %subdirs) {
++ $param->{'sort_subdirs'} = \@sort_subdirs;
++ }
++ if (scalar keys %files) {
++ $param->{'sort_files'} = \@sort_files;
++ }
++ }
++ $param->{'father_icon'} = $icon_table{'father'};
++ $param->{'sort_icon'} = $icon_table{'sort'};
++
++
++ ## Show expert commands / user page
++
++ # for the curent directory
++ if ($may_edit == 0 && $may_control == 0) {
++ $param->{'has_dir_rights'} = 0;
++ } else {
++ $param->{'has_dir_rights'} = 1;
++ if ($may_edit == 1) { # (is_author || ! moderated)
++ $param->{'total_edit'} = 1;
++ }
++ }
++
++ # set the page mode
++ if ($in{'show_expert_page'} && $param->{'has_dir_rights'}) {
++ $session->{'shared_mode'}='expert';
++ if ($param->{'user'}{'prefs'}{'shared_mode'} ne 'expert') {
++ # update user pref as soon as connected user change shared mode
++ $param->{'user'}{'prefs'}{'shared_mode'} = 'expert';
++ &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
++ }
++ $param->{'expert_page'} = 1;
++
++ } elsif ($in{'show_user_page'}) {
++ $session->{'shared_mode'}='basic';
++ if ($param->{'user'}{'prefs'}{'shared_mode'} ne 'basic') {
++ # update user pref as soon as connected user change shared mode
++ $param->{'user'}{'prefs'}{'shared_mode'} = 'basic';
++ &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
++ }
++ $param->{'expert_page'} = 0;
++ } else {
++ if ( $session->{'shared_mode'} eq 'expert' && $param->{'has_dir_rights'}) {
++ $param->{'expert_page'} = 1;
++ } else {
++ $param->{'expert_page'} = 0;
++ }
++ }
++
++ #open TMP, ">/tmp/dump1";
++ #&tools::dump_var($param, 0,\*TMP);
++ #close TMP;
++
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'success'});
++
++ return 1;
++}
++
++## return a ref on an array of file (or subdirecties) to show to user
++sub get_directory_content {
++ my $tmpdir = shift;
++ my $user = shift;
++ my $list = shift;
++ my $doc = shift;
++
++ # array of file not hidden
++ my @dir = grep !/^\./, @$tmpdir;
++
++ # array with documents not yet moderated
++ my @moderate_dir = grep (/(\.moderate)$/, @$tmpdir);
++ @moderate_dir = grep (!/^\.desc\./, @moderate_dir);
++
++ # the editor can see file not yet moderated
++ # a user can see file not yet moderated if he is th owner of these files
++ if ($list->am_i('editor',$user)) {
++ push(@dir,@moderate_dir);
++ }else {
++ my @privatedir = &select_my_files($user,$doc,\@moderate_dir);
++ push(@dir,@privatedir);
++ }
++
++ return \@dir;
++}
++
++
++## return an array that contains only file from @$refdir that belongs to $user
++sub select_my_files {
++ my ($user,$path,$refdir)=@_;
++ my @new_dir;
++
++ foreach my $d (@$refdir) {
++ if (-e "$path/.desc.$d") {
++ my %desc_hash = &get_desc_file("$path/.desc.$d");
++ if ($user eq $desc_hash{'email'}){
++ $new_dir[$#new_dir+1]=$d;
++ }
++ }
++ }
++ return @new_dir;
++}
++
++ ## Useful function to get off the slash at the end of the path
++ ## at its end
++ sub no_slash_end {
++ my $path = shift;
++
++ ## supress ending '/'
++ $path =~ s/\/+$//;
++
++ return $path;
++ }
++
++## return a visible path from a moderated file or not
++sub make_visible_path {
++ my $path = shift;
++
++ my $visible_path = $path;
++
++ if ($path =~ /\.url(\.moderate)?$/){
++ if ($path =~ /^([^\/]*\/)*([^\/]+)\.([^\/]+)$/) {
++ $visible_path =~ s/\.moderate$//;
++ $visible_path =~ s/^\.//;
++ $visible_path =~ s/\.url$//;
++ }
++
++ }elsif ($path =~ /\.moderate$/){
++ if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
++ my $name = $3;
++ $name =~ s/^\.//;
++ $name =~ s/\.moderate//;
++ $visible_path = "$2"."$name";
++ }
++ }
++
++ ## Qdecode the visible path
++ return &tools::qdecode_filename($visible_path);
++}
++
++
++ ## Access to latest shared documents
++sub do_latest_d_read {
++ &wwslog('info', 'do_latest_d_read(%s,%s,%s)', $in{'list'}, $in{'for'}, $in{'count'});
++
++ ### is list open ?
++ unless ($list->{'admin'}{'status'} eq 'open'){
++ &report::reject_report_web('user','list_not_open',{'status' => $list->{'admin'}{'status'}},$param->{'action'},$list);
++ &wwslog('err','d_latest_d_read : access denied for %s because list is not open', $param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++ ### shared exist ?
++ my $shareddir = $list->{'dir'}.'/shared';
++ unless (-r "$shareddir") {
++ &wwslog('err',"do_latest_d_read : unable to read $shareddir : no such file or directory");
++ &report::reject_report_web('user','no_shared',{},$param->{'action'},$list);
++ return undef;
++ }
++
++ ### Document has non-size zero?
++ unless (-s "$shareddir") {
++ &wwslog('err',"do_latest_d_read : unable to read $shareddir : empty document");
++ &report::reject_report_web('user','shared_empty',{},$param->{'action'},$list);
++ return undef;
++ }
++
++ ### Access control
++ my %mode;
++ $mode{'read'} = 1;
++ $mode{'control'} = 1;
++
++ my %access = &d_access_control(\%mode,$shareddir);
++ unless ($access{'may'}{'read'}) {
++ &report::reject_report_web('auth',$access{'reason'}{'read'},{},$param->{'action'},$list);
++ &wwslog('err','latest_d_read : access denied for %s', $param->{'user'}{'email'});
++ return undef;
++ }
++
++ ## parameters of the query
++ my $today = time;
++
++ my $oldest_day;
++ if (defined $in{'for'}) {
++ $oldest_day = $today - (86400 * ($in{'for'}));
++ $param->{'for'} = $in{'for'};
++ unless ($oldest_day >= 0){
++ &report::reject_report_web('user','nb_days_to_much',{'nb_days' => $in{'for'} },$param->{'action'},$list);
++ &wwslog('err','do_latest_d_read: parameter "for" is too big"');
++ }
++ }
++
++ my $nb_doc;
++ my $NB_DOC_MAX = 100;
++ if (defined $in{'count'}) {
++ if ($in{'count'} > $NB_DOC_MAX) {
++ $in{'count'} = $NB_DOC_MAX;
++ }
++ $param->{'count'} = $in{'count'};
++ $nb_doc = $in{'count'};
++ } else {
++ $nb_doc = $NB_DOC_MAX;
++ }
++
++ my $documents;
++ unless ($documents = &directory_browsing('',$oldest_day,$access{'may'}{'control'})) {
++ &wwslog('err',"do_d_latest_d_read($list) : impossible to browse shared");
++ &report::reject_report_web('intern','browse_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ return undef;
++ }
++
++ @$documents = sort ({$b->{'date_epoch'} <=> $a->{'date_epoch'}} @$documents);
++
++ @{$param->{'documents'}} = splice(@$documents,0,$nb_doc);
++
++ return 1;
++ }
++
++## browse a directory recursively and return documents younger than $oldest_day
++ sub directory_browsing {
++ my ($dir,$oldest_day,$may_control) = @_;
++ &wwslog('debug2',"directory_browsing($dir,$oldest_day)");
++
++ my @result;
++ my $shareddir = $list->{'dir'}.'/shared';
++ my $path_dir = "$shareddir/$dir";
++
++ ## listing of all the shared documents of the directory
++ unless (opendir DIR, "$path_dir") {
++ &wwslog('err',"directory_browsing($dir) : cannot open the directory : $!");
++ return undef;
++ }
++
++ my @tmpdir = readdir DIR;
++ closedir DIR;
++
++ # array of file not hidden
++ my @directory = grep !/^\./, @tmpdir;
++
++ my $user = $param->{'user'}{'email'} || 'nobody';
++
++ ## browsing
++ foreach my $d (@directory) {
++ my $path_d = "$path_dir/$d";
++
++ #case subdirectory
++ if (-d $path_d) {
++ if (-e "$path_d/.desc") {
++ # check access permission for reading
++ my %desc_hash = &get_desc_file("$path_d/.desc");
++
++ my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'},
++ 'scenario' => $desc_hash{'read'}});
++ my $action;
++ $action = $result->{'action'} if (ref($result) eq 'HASH');
++ if (($user eq $desc_hash{'email'}) || ($may_control) ||
++ ($action =~ /do_it/i)) {
++ my $content_d;
++ unless($content_d = &directory_browsing("$dir/$d",$oldest_day)) {
++ &wwslog('err',"directory_browsing($dir) : impossible to browse subdirectory $d");
++ next;
++ }
++ if (ref($content_d) eq "ARRAY") {
++ push @result,@$content_d;
++ }
++ }
++ }
++
++ #case file
++ } else {
++
++ my %file_info;
++
++ ## last update
++ my @info = stat $path_d;
++ $file_info{'date_epoch'} = $info[9];
++
++ if ($file_info{'date_epoch'} < $oldest_day) {
++ next;
++ }
++
++ $file_info{'last_update'} = gettext_strftime "%d %b %Y", localtime($info[9]);
++
++ ## exception of index.html
++ if ($d =~ /^(index\.html?)$/i) {
++ next;
++ }
++
++ my $may = 1;
++ my $def_desc = 0;
++ my %desc_hash;
++
++ if (-e "$path_dir/.desc.$d") {
++ # a desc file was found
++ $def_desc = 1;
++
++ # check access permission
++ %desc_hash = &get_desc_file("$path_dir/.desc.$d");
++
++ my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'},
++ 'scenario' => $desc_hash{'read'}});
++ my $action;
++ $action = $result->{'action'} if (ref($result) eq 'HASH');
++ unless (($user eq $desc_hash{'email'}) || ($may_control) ||
++ ($action =~ /do_it/i)) {
++ $may = 0;
++ }
++ }
++
++ # if permission or no description file
++ if ($may) {
++ $path_d =~ /^([^\/]*\/)*([^\/]+)\.([^\/]+)$/;
++
++ ## Bookmark
++ if ($path_d =~ /\.url$/) {
++ open DOC, $path_d;
++ my $url = <DOC>;
++ close DOC;
++ chomp $url;
++ $file_info{'url'} = $url;
++ $file_info{'anchor'} = &make_visible_path($d);
++ $file_info{'icon'} = $icon_table{'url'};
++
++ ## MIME - TYPES : icons for template
++ }elsif (my $type = $mime_types->{$3}) {
++ # type of the file and apache icon
++ $type =~ /^([\w\-]+)\/([\w\-]+)$/;
++ my $mimet = $1;
++ my $subt = $2;
++ if ($subt) {
++ if ($subt =~ /^octet-stream$/) {
++ $mimet = 'octet-stream';
++ $subt = 'binary';
++ }
++ }
++ $file_info{'icon'} = $icon_table{$mimet} || $icon_table{'unknown'};
++
++ ## UNKNOWN FILE TYPE
++ } else {
++ $file_info{'icon'} = $icon_table{'unknown'};
++ }
++
++ ## case html
++ if ($3 =~ /^html?$/i) {
++ $file_info{'html'} = 1;
++ $file_info{'icon'} = $icon_table{'text'};
++ }
++
++ ## name of the file
++ $file_info{'name'} = &make_visible_path($d);
++ $file_info{'escaped_name'} = &tools::escape_docname($d, '/');
++
++ ## content_directory
++ if ($dir) {
++ $file_info{'content_dir'} = &make_visible_path($dir);
++ } else {
++ $file_info{'content_dir'} = "/";
++ }
++ $file_info{'escaped_content_dir'} = &tools::escape_docname($dir,'/');
++
++ if ($def_desc) {
++ ## description
++ $file_info{'title'} = $desc_hash{'title'};
++ $file_info{'escaped_title'}=&tools::escape_html($desc_hash{'title'});
++
++ ## author
++ if ($desc_hash{'email'}) {
++ $file_info{'author'} = $desc_hash{'email'};
++ }
++ }
++
++ push @result,\%file_info;
++ }
++ } # else (file)
++
++ } # foreach
++
++ return \@result;
++
++ }
++
++ #*******************************************
++ # Function : do_d_editfile
++ # Description : prepares the parameters to
++ # edit a file
++ #*******************************************
++
++ sub do_d_editfile {
++ &wwslog('info', 'do_d_editfile(%s)', $in{'path'});
++
++ # Variables
++ my $path = &no_slash_end($in{'path'});
++
++ my $list_name = $list->{'name'};
++ my $shareddir = $list->{'dir'}.'/shared';
++ my $visible_path = &make_visible_path($path);
++
++ $param->{'directory'} = -d "$shareddir/$path";
++
++ # Control
++
++ unless ($path) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'file name'},$param->{'action'});
++ &wwslog('err','do_d_editfile: no file name');
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'missing_parameter'});
++ return undef;
++ }
++
++ # Existing document? File?
++ unless (-w "$shareddir/$path") {
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &wwslog('err',"d_editfile : Cannot edit $shareddir/$path : not an existing file");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'no_file'});
++ return undef;
++ }
++
++ ### Document isn't a description file?
++ unless ($path !~ /\.desc/) {
++ &wwslog('err',"do_editfile : $shareddir/$path : description file");
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ if (($path =~ /\.url$/) ||($path =~ /^\..+\.url.moderate$/)) {
++ ## Get URL of bookmark
++ open URL, "$shareddir/$path";
++ my $url = <URL>;
++ close URL;
++ chomp $url;
++
++ $param->{'url'} = $url;
++ $visible_path =~ s/\.url$//;
++ }
++
++ ### is list open ?
++ unless ($list->{'admin'}{'status'} eq 'open'){
++ &report::reject_report_web('user','list_not_open',{'status' => $list->{'admin'}{'status'}},$param->{'action'},$list);
++ &wwslog('err','d_edit : access denied for %s because list is not open', $param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++ # Access control
++ my %mode;
++ $mode{'edit'} = 1;
++ my %access = &d_access_control(\%mode,$path);
++ my $may_edit = $access{'may'}{'edit'};
++
++ unless ($may_edit > 0) {
++ &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('err','d_editfile : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'autorization'});
++ return undef;
++ }
++
++ ## End of controls
++
++ $param->{'list'} = $list_name;
++ $param->{'path'} = $path;
++ $param->{'visible_path'} = $visible_path;
++
++ # test if it's a text file
++ if (-T "$shareddir/$path") {
++ $param->{'textfile'} = 1;
++ $param->{'filepath'} = "$shareddir/$path";
++ } else {
++ $param->{'textfile'} = 0;
++ }
++ $param->{'use_htmlarea'} = '1' if (($wwsconf->{'htmlarea_url'}) and ($param->{'textfile'}) and ($path =~ /\.html?/));
++
++
++
++ #Current directory
++ if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
++ $param->{'father'} = $1;
++ }else {
++ $param->{'father'} = '';
++ }
++ $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
++
++ # Description of the file
++ my $descfile;
++ if (-d "$shareddir/$path") {
++ $descfile = "$shareddir/$1$3/.desc";
++ }else {
++ $descfile = "$shareddir/$1.desc.$3";
++ }
++
++ if (-e $descfile) {
++ my %desc_hash = &get_desc_file($descfile);
++ $param->{'desc'} = $desc_hash{'title'};
++ $param->{'doc_owner'} = $desc_hash{'email'};
++ ## Synchronization
++ my @info = stat $descfile;
++ $param->{'serial_desc'} = $info[9];
++ }
++
++ ## Synchronization
++ my @info = stat "$shareddir/$path";
++ $param->{'serial_file'} = $info[9];
++ ## parameters of the current directory
++ $param->{'doc_date'} = gettext_strftime "%d %b %y %H:%M", localtime($info[9]);
++
++ &tt2::allow_absolute_path();
++
++ $param->{'father_icon'} = $icon_table{'father'};
++
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'success'});
++
++ return 1;
++ }
++
++ #*******************************************
++ # Function : do_d_properties
++ # Description : prepares the parameters to
++ # change a file properties
++ #*******************************************
++
++ sub do_d_properties {
++ &wwslog('info', 'do_d_properties(%s)', $in{'path'});
++
++ # Variables
++ my $path = &no_slash_end($in{'path'});
++
++ my $list_name = $list->{'name'};
++ my $shareddir = $list->{'dir'}.'/shared';
++ my $visible_path = &make_visible_path($path);
++
++ $param->{'directory'} = -d "$shareddir/$path";
++
++ # Control
++
++ unless ($path) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'filename'},$param->{'action'});
++ &wwslog('err','do_d_properties: no file name');
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'no_file'});
++ return undef;
++ }
++
++ # Existing document? File?
++ unless (-w "$shareddir/$path") {
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &wwslog('err',"do_d_properties : Cannot edit $shareddir/$path : not an existing file");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'no_file'});
++ return undef;
++ }
++
++ ### Document isn't a description file?
++ unless ($path !~ /\.desc/) {
++ &wwslog('err',"do_d_properties : $shareddir/$path : description file");
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ if ($path =~ /\.url$/) {
++ ## Get URL of bookmark
++ open URL, "$shareddir/$path";
++ my $url = <URL>;
++ close URL;
++ chomp $url;
++
++ $param->{'url'} = $url;
++ }
++
++ # Access control
++ my %mode;
++ $mode{'edit'} = 1;
++ my %access = &d_access_control(\%mode,$path);
++ my $may_edit = $access{'may'}{'edit'};
++
++ unless ($may_edit > 0) {
++ &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('err','do_d_properties : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++ ## End of controls
++
++ $param->{'list'} = $list_name;
++ $param->{'path'} = $path;
++ $param->{'visible_path'} = $visible_path;
++
++ # test if it's a text file
++ if (-T "$shareddir/$path") {
++ $param->{'textfile'} = 1;
++ $param->{'filepath'} = "$shareddir/$path";
++ } else {
++ $param->{'textfile'} = 0;
++ }
++ $param->{'use_htmlarea'} = '1' if (($wwsconf->{'htmlarea_url'}) and ($param->{'textfile'}) and ($path =~ /\.html?/));
++
++
++
++ #Current directory
++ if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
++ $param->{'father'} = $1;
++ }else {
++ $param->{'father'} = '';
++ }
++ $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
++
++ $param->{'fname'} = &make_visible_path($3);
++ # Description of the file
++ my $descfile;
++ if (-d "$shareddir/$path") {
++ $descfile = "$shareddir/$1$3/.desc";
++ }else {
++ $descfile = "$shareddir/$1.desc.$3";
++ }
++
++ if (-e $descfile) {
++ my %desc_hash = &get_desc_file($descfile);
++ $param->{'desc'} = $desc_hash{'title'};
++ $param->{'doc_owner'} = $desc_hash{'email'};
++ ## Synchronization
++ my @info = stat $descfile;
++ $param->{'serial_desc'} = $info[9];
++ }
++
++ ## Synchronization
++ my @info = stat "$shareddir/$path";
++ $param->{'serial_file'} = $info[9];
++ ## parameters of the current directory
++ $param->{'doc_date'} = gettext_strftime "%d %b %y %H:%M", localtime($info[9]);
++
++ &tt2::allow_absolute_path();
++
++ $param->{'father_icon'} = $icon_table{'father'};
++
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'success'});
++
++ return 1;
++ }
++
++ #*******************************************
++ # Function : do_d_describe
++ # Description : Saves the description of
++ # the file
++ #******************************************
++
++ sub do_d_describe {
++ &wwslog('info', 'do_d_describe(%s)', $in{'path'});
++
++ # Variables
++ my $path = &no_slash_end($in{'path'});
++ my $visible_path=&make_visible_path($path);
++ my $list_name = $list->{'name'};
++ my $shareddir = $list->{'dir'}.'/shared';
++
++ #### Controls
++
++ ### Document isn't a description file?
++ unless ($path !~ /\.desc/) {
++ &wwslog('info',"do_d_describe : $shareddir/$path : description file");
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ ## the path must not be empty (the description file of the shared directory
++ # doesn't exist)
++ unless ($path) {
++ &report::reject_report_web('intern','cannot_describe_shared_directory',{'path' => $path },$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info',"d_describe : Cannot describe $shareddir : root directory");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ # the file to describe must already exist
++ unless (-e "$shareddir/$path") {
++ &report::reject_report_web('user','no_doc_to_describe',{'path'=> $visible_path},$param->{'action'},$list);
++ &wwslog('info',"d_describe : Unable to describe $shareddir/$path : not an existing document");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'no_file'});
++ return undef;in{'shortname'}
++ }
++
++ # Access control
++ # Access control
++ my %mode;
++ $mode{'edit'} = 1;
++ my %access = &d_access_control(\%mode,$path);
++
++ unless ($access{'may'}{'edit'} > 0) {
++ &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('info','d_describe : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++
++ ## End of controls
++
++ if ($in{'content'} !~ /^\s*$/) {
++
++ # Description file
++ $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
++ my $dir = $1;
++ my $file = $3;
++
++ my $desc_file;
++ if (-d "$shareddir/$path") {
++ $desc_file = "$shareddir/$dir$file/.desc";
++ } else {
++ $desc_file = "$shareddir/$dir.desc.$file";
++ }
++
++ if (-r "$desc_file"){
++ # if description file already exists : open it and modify it
++ my %desc_hash = &get_desc_file ("$desc_file");
++
++ # Synchronization
++ unless (&synchronize($desc_file,$in{'serial'})){
++ &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
++ &wwslog('info',"d_describe : Synchronization failed for $desc_file");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ # fill the description file
++ unless (open DESC,">$desc_file") {
++ &wwslog('info',"do_d_describe : cannot open $desc_file : $!");
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ # information modified
++ print DESC "title\n $in{'content'}\n\n";
++ # information not modified
++ print DESC "access\n read $desc_hash{'read'}\n edit $desc_hash{'edit'}\n\n";
++ print DESC "creation\n";
++ # time
++ print DESC " date_epoch $desc_hash{'date'}\n";
++ # author
++ print DESC " email $desc_hash{'email'}\n\n";
++
++ close DESC;
++
++ } else {
++ # Creation of a description file
++ unless (open (DESC,">$desc_file")) {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info',"d_describe : Cannot create description file $desc_file : $!");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ # fill
++ # description
++ print DESC "title\n $in{'content'}\n\n";
++ # date and author
++ my @info = stat "$shareddir/$path";
++ print DESC "creation\n date_epoch ".$info[10]."\n email\n\n";
++ # access rights
++ print DESC "access\n";
++ print DESC " read $access{'scenario'}{'read'}\n";
++ print DESC " edit $access{'scenario'}{'edit'}\n\n";
++
++ close DESC;
++
++ }
++
++ $in{'path'} = &no_slash_end($dir);
++ }
++
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'success'});
++
++ return 'd_read';
++
++ }
++
++ #*******************************************
++ # Function : do_d_savefile
++ # Description : Saves a file edited in a
++ # text area
++ #******************************************
++
++sub do_d_savefile {
++ &wwslog('info', 'do_d_savefile(%s)', $in{'path'});
++
++ # Variables
++ my $path = &no_slash_end($in{'path'});
++
++ if ($in{'url'} &&
++ $in{'previous_action'} eq 'd_read') {
++ $path .= '/'.$in{'name_doc'} . '.url';
++ }
++
++
++ my $visible_path = &make_visible_path($path);
++
++ my $moderated;
++ if ($visible_path ne $path) {
++ $moderated = 1;
++ }
++
++ #my $list_name = $in{'list'};
++ my $list_name = $list->{'name'};
++
++ my $shareddir = $list->{'dir'}.'/shared';
++
++ #### Controls
++
++ my $creation = 1 unless (-f "$shareddir/$path");
++
++ ### Document isn't a description file
++ unless ($path !~ /\.desc/) {
++ &wwslog('err',"do_d_savefile : $shareddir/$path : description file");
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ # Access control
++ my %mode;
++ $mode{'edit'} = 1;
++ my %access = &d_access_control(\%mode,$path);
++
++ unless ($access{'may'}{'edit'} > 0) {
++ &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('err','do_d_savefile : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++ #### End of controls
++
++ if (($in{'content'} =~ /^\s*$/) && ($in{'url'} =~ /^\s*$/)) {
++ &report::reject_report_web('user','no_content',{},$param->{'action'},$list);
++ &wwslog('err',"do_d_savefile : Cannot save file $shareddir/$path : no content");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'missing_parameter'});
++ return undef;
++ }
++
++ # Synchronization
++ unless ($in{'url'}) { # only for files
++ unless (&synchronize("$shareddir/$path",$in{'serial'})){
++ &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
++ &wwslog('err',"do_d_savefile : Synchronization failed for $shareddir/$path");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ }
++
++ # Renaming of the old file
++############""" pas les url ?
++ rename ("$shareddir/$path","$shareddir/$path.old")
++ unless ($creation);
++
++ my $dir;
++ my $file;
++ if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/){
++ $dir = $1;
++ $file = $3;
++ }
++
++ if ($in{'url'}) {
++##############
++# if ($access{'may'}{'edit'} == 0.5) {
++# open URL, ">$shareddir/$dir.$file.moderate";
++# }else {
++ open URL, ">$shareddir/$path";
++# }
++ print URL "$in{'url'}\n";
++ close URL;
++ }else {
++ # Creation of the shared file
++ unless (open FILE, ">$shareddir/$path") {
++ rename("$shareddir/$path.old","$shareddir/$path");
++ &report::reject_report_web('user','cannot_overwrite', {'reason' => $1,
++ 'path' => $visible_path }
++ ,$param->{'action'},$list);
++ &wwslog('err',"do_d_savefile : Cannot open for replace $shareddir/$path : $!");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ print FILE $in{'content'};
++ close FILE;
++ }
++
++ unlink "$shareddir/$path.old";
++
++ # Description file
++ if (-e "$shareddir/$dir.desc.$file"){
++
++ # if description file already exists : open it and modify it
++ my %desc_hash = &get_desc_file ("$shareddir/$dir.desc.$file");
++
++ open DESC,">$shareddir/$dir.desc.$file";
++
++ # information not modified
++ print DESC "title\n $desc_hash{'title'}\n\n";
++ print DESC "access\n read $desc_hash{'read'}\n edit $desc_hash{'edit'}\n\n";
++ print DESC "creation\n";
++ # date
++ print DESC ' date_epoch '.$desc_hash{'date'}."\n";
++
++ # information modified
++ # author
++ print DESC " email $param->{'user'}{'email'}\n\n";
++
++ close DESC;
++
++ } else {
++ # Creation of a description file if author is known
++
++ unless (open (DESC,">$shareddir/$dir.desc.$file")) {
++ &wwslog('info',"do_d_savefile: cannot create description file $shareddir/$dir.desc.$file");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ }
++ # description
++ print DESC "title\n \n\n";
++ # date of creation and author
++ my @info = stat "$shareddir/$path";
++ print DESC "creation\n date_epoch ".$info[10]."\n email $param->{'user'}{'email'}\n\n";
++ # Access
++ print DESC "access\n";
++ print DESC " read $access{'scenario'}{'read'}\n";
++ print DESC " edit $access{'scenario'}{'edit'}\n\n";
++
++ close DESC;
++ }
++
++ # shared_moderated
++#######################
++ if (($access{'may'}{'edit'} == 0.5) && ($creation)) {
++
++ unless (rename "$shareddir/$path","$shareddir/$dir.$file.moderate"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$path",
++ 'new'=>"$shareddir/$dir.$file.moderate"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_savefile : Failed to rename $path to $dir.$file.moderate : $!");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ }
++ unless (rename "$shareddir/$dir.desc.$file","$shareddir/$dir.desc..$file.moderate"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$dir.desc.$file",
++ 'new'=>"$shareddir/$dir.desc..$file.moderate"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_savefile : Failed to rename $dir.desc.$file to $dir.desc..$file.moderate : $!");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ }
++
++ if (!$in{'url'}){
++ $in{'path'}=$path;
++ $param->{'path'}=$path;
++ }else {
++ $visible_path = $file;
++ $visible_path =~ s/\.url$//
++ }
++
++ unless ($list->send_notify_to_editor('shared_moderated',{'filename' => $visible_path,
++ 'who' => $param->{'user'}{'email'}})) {
++ &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
++ }
++
++ &report::notice_report_web('to_moderate', {'path' => $visible_path},$param->{'action'});
++ }
++
++ &report::notice_report_web('save_success', {'path' => $visible_path},$param->{'action'});
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'success'});
++ if ($in{'previous_action'}) {
++ return $in{'previous_action'};
++ }else {
++ $in{'path'} =~ s/([^\/]+)$//;
++ $param->{'path'} =~ s/([^\/]+)$//;
++ return 'd_read';
++ }
++ }
++
++ #*******************************************
++ # Function : do_d_overwrite
++ # Description : Overwrites a file with a
++ # uploaded file
++ #******************************************
++
++ sub do_d_overwrite {
++ &wwslog('info', 'do_d_overwrite(%s)', $in{'path'});
++
++ # Variables
++ my $path = &no_slash_end($in{'path'});
++
++ my $visible_path = &make_visible_path($path);
++
++ #my $list_name = $in{'list'};
++ my $list_name = $list->{'name'};
++
++ # path of the shared directory
++ my $shareddir = $list->{'dir'}.'/shared';
++
++ # Parameters of the uploaded file
++ my $fh = $query->upload('uploaded_file');
++ my $fn = $query->param('uploaded_file');
++
++ # name of the file
++ my $fname;
++ if ($fn =~ /([^\/\\]+)$/) {
++ $fname = $1;
++ }
++
++ ### uploaded file must have a name
++ unless ($fname) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'file name'},$param->{'action'});
++ &wwslog('info',"do_d_overwrite : No file specified to overwrite");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'no_file'});
++ return undef;
++ }
++
++ ####### Controls
++
++ ### Document isn't a description file?
++ unless ($path !~ /\.desc/) {
++ &wwslog('err',"do_d_overwrite : $shareddir/$path : description file");
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ # the path to replace must already exist
++ unless (-e "$shareddir/$path") {
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &wwslog('err',"do_d_overwrite : Unable to overwrite $shareddir/$path : not an existing file");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'no_file'});
++ return undef;
++ }
++
++ # the path must represent a file
++ if (-d "$shareddir/$path") {
++ &report::reject_report_web('user','doc_already_a_dir',{'path'=> $visible_path},$param->{'action'},$list);
++ &wwslog('err',"do_d_overwrite : Unable to create $shareddir/$path : a directory named $path already exists");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'already_exists'});
++ return undef;
++ }
++
++
++ # Access control
++ my %mode;
++ $mode{'edit'} = 1;
++ my %access = &d_access_control(\%mode,$path);
++
++ unless ($access{'may'}{'edit'} > 0) {
++ &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('err','do_d_overwrite : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++ #### End of controls
++
++ # Synchronization
++ unless (&synchronize("$shareddir/$path",$in{'serial'})){
++ &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
++ &wwslog('err',"do_d_overwrite : Synchronization failed for $shareddir/$path");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ # Renaming of the old file
++ rename ("$shareddir/$path","$shareddir/$path.old");
++
++ # Creation of the shared file
++ unless (open FILE, ">:bytes", "$shareddir/$path") {
++ &report::reject_report_web('user','cannot_overwrite', {'reason' => $!,
++ 'path' => $visible_path }
++ ,$param->{'action'},$list);
++ &wwslog('err',"d_overwrite : Cannot open for replace $shareddir/$path : $!");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'cannot_overwrite'});
++ return undef;
++ }
++ while (<$fh>) {
++ print FILE;
++ }
++ close FILE;
++
++ # Description file
++ my ($dir, $file);
++ if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
++ $dir = $1;
++ $file = $3;
++ }
++
++ if (-e "$shareddir/$dir.desc.$file"){
++ # if description file already exists: open it and modify it
++ my %desc_hash = &get_desc_file ("$shareddir/$dir.desc.$file");
++
++ open DESC,">$shareddir/$dir.desc.$file";
++
++ # information not modified
++ print DESC "title\n $desc_hash{'title'}\n\n";
++ print DESC "access\n read $desc_hash{'read'}\n edit $desc_hash{'edit'}\n\n";
++ print DESC "creation\n";
++ # time
++ print DESC " date_epoch $desc_hash{'date'}\n";
++ # information modified
++ # author
++ print DESC " email $param->{'user'}{'email'}\n\n";
++
++ close DESC;
++ } else {
++ # Creation of a description file
++ unless (open (DESC,">$shareddir/$dir.desc.$file")) {
++ &wwslog('info',"do_d_overwrite : Cannot create description file $shareddir/$dir.desc.$file");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ # description
++ print DESC "title\n \n\n";
++ # date of creation and author
++ my @info = stat "$shareddir/$path";
++ print DESC "creation\n date_epoch ".$info[10]."\n email $param->{'user'}{'email'}\n\n";
++ # access rights
++ print DESC "access\n";
++ print DESC " read $access{'scenario'}{'read'}\n";
++ print DESC " edit $access{'scenario'}{'edit'}\n\n";
++
++ close DESC;
++
++ }
++
++ # shared_moderated
++ if (($access{'may'}{'edit'} == 0.5) && ($path eq $visible_path)) {
++ unless (rename "$shareddir/$path","$shareddir/$dir.$file.moderate"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$path",
++ 'new'=>"$shareddir/$dir.$file.moderate"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_overwrite : Failed to rename $path to $dir.$file.moderate : $!");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++ unless (rename "$shareddir/$dir.desc.$file","$shareddir/$dir.desc..$file.moderate"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$dir.desc.$file",
++ 'new'=>"$shareddir/$dir.desc..$file.moderate"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_overwrite : Failed to rename $dir.desc.$file to $dir.desc..$file.moderate : $!");
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ }
++ unless ($list->send_notify_to_editor('shared_moderated',{'filename' => $visible_path,
++ 'who' => $param->{'user'}{'email'}})) {
++ &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
++ }
++ $in{'path'}="$dir.$file.moderate";
++ &report::notice_report_web('to_moderate',{'path' => $visible_path},$param->{'action'});
++ }
++
++ # Removing of the old file
++ unlink "$shareddir/$path.old";
++
++ $in{'list'} = $list_name;
++ #$in{'path'} = $dir;
++
++ # message of success
++ &report::notice_report_web('upload_success', {'path' => $visible_path});
++ &web_db_log({'parameters' => $in{'path'},
++ 'status' => 'success'});
++ return 'd_editfile';
++ }
++
++ #*******************************************
++ # Function : do_d_upload
++ # Description : Creates a new file with a
++ # uploaded file
++#******************************************
++
++ sub do_d_upload {
++ # Parameters of the uploaded file (from d_read.tt2)
++ my $fn = $in{'uploaded_file'};
++
++ # name of the file, without path
++ my ($fname, $visible_fname);
++ if ($fn =~ /([^\/\\]+)$/) {
++ $fname = &tools::qencode_filename($1);
++ $visible_fname = &make_visible_path($fname);
++ }
++
++ # param from d_upload.tt2
++ if ($in{'shortname'}){
++ $fname = $in{'shortname'};
++ }
++ &wwslog('info', 'do_d_upload(%s/%s)', $in{'path'},$fname);
++
++ # Variables
++ my $path = &no_slash_end($in{'path'});
++ my $visible_path = &make_visible_path($path);
++
++ # path of the shared directory
++ my $shareddir = $list->{'dir'}.'/shared';
++
++ # name of the file
++ my $longname = "$shareddir/$path/$fname";
++ $longname =~ s/\/+/\//g;
++
++# ## $path must have a slash at its end
++# $path = &format_path('with_slash',$path);
++
++ #my $list_name = $in{'list'};
++ my $list_name = $list->{'name'};
++
++
++ ## Controls
++
++ # uploaded file must have a name
++ unless ($fname) {
++ &report::reject_report_web('user','no_name',{},$param->{'action'},$list);
++ &wwslog('err',"do_d_upload : No file specified to upload");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ## Check quota
++ if ($list->{'admin'}{'shared_doc'}{'quota'}) {
++ if ($list->get_shared_size() >= $list->{'admin'}{'shared_doc'}{'quota'} * 1024){
++ &report::reject_report_web('user','shared_full',{},$param->{'action'},$list);
++ &wwslog('err',"do_d_upload : Shared Quota exceeded for list $list->{'name'}");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'shared_full','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++
++ # The name of the file must be correct and musn't not be a description file
++ if ($fname =~ /^\./
++ || $fname =~ /\.desc/
++ || $fname =~ /[~\#\[\]]$/) {
++
++ # unless ($fname =~ /^\w/ and
++ # $fname =~ /\w$/ and
++ # $fname =~ /^[\w\-\.]+$/ and
++ # $fname !~ /\.desc/) {
++ &report::reject_report_web('user','incorrect_name',{'name' => $fname},$param->{'action'},$list);
++ &wwslog('err',"do_d_upload : Unable to create file $fname : incorrect name");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # the file must be uploaded in a directory existing
++ unless (-d "$shareddir/$path") {
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &wwslog('err',"do_d_upload : $shareddir/$path : not a directory");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # Access control for the directory where there is the uploading
++ my %mode;
++ $mode{'edit'} = 1;
++ $mode{'control'} = 1; # for the exception index.html
++ my %access_dir = &d_access_control(\%mode,$path);
++
++ if ($access_dir{'may'}{'edit'} == 0) {
++ &report::reject_report_web('auth',$access_dir{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('err','do_d_upload : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # Lowercase for file name
++ # $fname = $fname;
++
++ ## when the file already exists :
++
++ # the temporary name of the uploaded file : with .duplicate
++ my $tmpname="."."$fname".".duplicate";
++ my $longtmpname="$shareddir/$path/$tmpname";
++ $longtmpname =~ s/\/+/\//g;
++
++ # the temporary desc of the uploaded file : with .duplicate
++ my $tmpdesc=".desc."."$tmpname";
++ my $longtmpdesc="$shareddir/$path/$tmpdesc";
++ $longtmpdesc =~ s/\/+/\//g;
++
++ # if we aren't in mode_delete nor in mode_rename nor in mode_cancel and the file already exists
++ # then we create of a temporary file
++ if ((-e "$longname") &&
++ ($in{'mode_delete'} eq undef) &&
++ ($in{'mode_rename'} eq undef) &&
++ ($in{'mode_cancel'} eq undef)) {
++
++ #access control for the file already existing
++ my %mode;
++ $mode{'edit'} = 1;
++ my %access_file = &d_access_control(\%mode,"$path/$fname");
++
++ unless ($access_file{'may'}{'edit'} > 0) {
++ &report::reject_report_web('auth',$access_file{'reason'}{'edit'},{},$param->{'action'},$list);
++ return undef;
++ }
++
++ if (-e "$longtmpname"){
++ # if exists a temp file younger than 5 minutes that belongs to another user : upload refused
++ my @info = stat $longtmpname;
++ my $timeold = time - $info[10];
++
++ if ($timeold<=300){
++ my %desc_hash = &get_desc_file($longtmpdesc);
++
++ unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
++ &report::reject_report_web('user','cannot_upload',{'path' => "$visible_path/$visible_fname",
++ 'reason' => "file being uploaded by $desc_hash{'email'} at this time" },
++ $param->{'action'},$list);
++ &wwslog('err',"do_d_upload : Unable to upload $longtmpname : file being uploaded at this time ");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++ }
++
++ &creation_shared_file($shareddir,$path,$tmpname);
++ &creation_desc_file($shareddir,$path,$tmpname,%access_file);
++
++ my @info = stat $longname;
++ $param->{'serial_file'} = $info[9];
++ $param->{'path'} = $path;
++ $param->{'shortname'} = $fname;
++
++ return 1;
++ }
++
++
++ # for the moderation
++ my $longmodname = "$shareddir/$path/"."."."$fname".".moderate";
++ $longmodname =~ s/\/+/\//g;
++
++ my $longmoddesc="$shareddir/$path/".".desc.."."$fname".".moderate";
++ $longmoddesc =~ s/\/+/\//g;
++
++ # when a file is already waiting for moderation
++ my $file_moderated;
++
++ if (-e "$longmodname"){
++
++ my %desc_hash = &get_desc_file("$longmoddesc");
++ $file_moderated = 1;
++
++ unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
++ &report::reject_report_web('user','cannot_upload',{'path' => "$path/$fname",
++ 'reason' => "file already exists but not yet moderated"},
++ $param->{'action'},$list);
++ &wwslog('err',"do_d_upload : Unable to create $longname : file already exists but not yet moderated");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++
++
++ ## Exception index.html
++ unless ($fname !~ /^index.html?$/i) {
++ unless ($access_dir{'may'}{'control'}) {
++ &report::reject_report_web('user','index_html',{'dir' => $path,
++ 'reason' => "d_access_control"},
++ $param->{'action'},$list);
++ &wwslog('err',"do_d_upload : $param->{'user'}{'email'} not authorized to upload a INDEX.HTML file in $path");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++
++ # if we're in mode_delete or mode_rename or mode_cancel, the temp file and his desc file must exist
++ if ($in{'mode_delete'} ||
++ $in{'mode_rename'} ||
++ $in{'mode_cancel'}) {
++
++ unless(-e $longtmpname){
++ &report::reject_report_web('user','no_uploaded_file',{},$param->{'action'},$list);
++ &wwslog('err',"do_d_upload : there isn't any temp file for the uploaded file $fname");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ unless(-e $longtmpdesc){
++ &report::reject_report_web('user','no_uploaded_file',{},$param->{'action'},$list);
++ &wwslog('err',"do_d_upload : there isn't any desc temp file for the uploaded file $fname");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ }
++ ## End of controls
++
++
++ # in mode_delete the file is going to be overwritten
++ if ($in{'mode_delete'}) {
++
++ # Synchronization
++ unless (&synchronize("$longname",$in{'serial'})){
++ &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
++ &wwslog('err',"do_d_upload : Synchronization failed for $longname");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'synchro_failed','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # Renaming the tmp file and the desc file
++
++ if ($access_dir{'may'}{'edit'} == 1 ){
++
++ # Renaming of the old file
++ my $longgoodname="$shareddir/$path/$fname";
++ $longgoodname =~ s/\/+/\//g;
++ unless (rename "$longgoodname","$longgoodname.old"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$longgoodname",
++ 'new'=>"$longgoodname.old"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_upload : Failed to rename %s to .old : %s",$longgoodname, $!);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # Renaming of the old desc
++ my $longgooddesc="$shareddir/$path/".".desc."."$fname";
++ $longgooddesc =~ s/\/+/\//g;
++ unless (rename "$longgooddesc","$longgooddesc.old"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$longgooddesc",
++ 'new'=>"$longgooddesc.old"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_upload : Failed to rename %s to .old : %s", $longgooddesc, $!);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ # the tmp file
++ unless (rename "$longtmpname","$longgoodname"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpname",
++ 'new'=>"$longgoodname"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpname, $longgoodname, $!);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ # the tmp desc file
++ unless (rename "$longtmpdesc","$longgooddesc"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpdesc",
++ 'new'=>"$longgooddesc"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpdesc, $longgooddesc, $!);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ }elsif ($access_dir{'may'}{'edit'} == 0.5 ){
++
++ unless (rename "$longtmpname","$longmodname"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpname",
++ 'new'=>"$longmodname"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpname, $longmodname, $!);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ unless (rename "$longtmpdesc","$longmoddesc"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpdesc",
++ 'new'=>"$longmoddesc"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpdesc, $longmoddesc, $!);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ unless ($list->send_notify_to_editor('shared_moderated',{'filename' => "$path/$fname",
++ 'who' => $param->{'user'}{'email'}})) {
++ &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
++ }
++
++ }else {
++ &report::reject_report_web('auth',$access_dir{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('err','do_d_upload : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++# $in{'list'} = $list_name;
++
++ # message of success
++ &report::notice_report_web('upload_success', {'path' => $fname},$param->{'action'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 'd_read';
++ }
++
++ # in mode_rename the file is going to be renamed
++ if ($in{'mode_rename'}) {
++
++ my $longnewname="$shareddir/$path/$in{'new_name'}";
++ $longnewname =~ s/\/+/\//g;
++
++ # Control new document name
++ unless ($in{'new_name'}) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'new name'},$param->{'action'});
++ &wwslog('err',"do_d_upload : new name missing to rename the uploaded file");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'missing_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ if ($in{'new_name'} =~ /^\./
++ || $in{'new_name'} =~ /\.desc/
++ || $in{'new_name'} =~ /[~\#\[\]\/]$/) {
++ &report::reject_report_web('user','incorrect_name',{'name' => $in{'new_name'}},$param->{'action'},$list);
++ &wwslog('err',"do_d_upload : Unable to create file $in{'new_name'} : incorrect name");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ if (($fname =~ /\.url$/) && ($in{'new_name'} !~ /\.url$/)) {
++ &report::reject_report_web('user','incorrect_name',{'name' => $in{'new_name'}},$param->{'action'},$list);
++ &wwslog('err',"do_d_upload : New file name $in{'new_name'} does not match URL filenames");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ if (-e $longnewname){
++ &report::reject_report_web('user','doc_already_exist',{'name' => $in{'new_name'}},$param->{'action'},$list);
++ &wwslog('err',"do_d_upload : $in{'new_name'} is an existing name");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # when a file is already waiting for moderation
++ if (-e "$shareddir/$path/.$in{'new_name'}.moderate"){
++ &report::reject_report_web('user','doc_already_exist',{'name' => $in{'new_name'}},$param->{'action'},$list);
++ &wwslog('err',"do_d_upload : $in{'new_name'} is an existing name for a not yet moderated file" );
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ # when a file is being uploaded
++ if (-e "$shareddir/$path/.$in{'new_name'}.duplicate"){
++ &report::reject_report_web('user','doc_already_exist',{'name' => $in{'new_name'}},$param->{'action'},$list);
++ &wwslog('err',"do_d_upload : $in{'new_name'} is an existing name for a file being uploaded ");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ # Renaming the tmp file and the desc file
++
++ if ($access_dir{'may'}{'edit'} == 1 ){
++ unless (rename "$longtmpname","$longnewname"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpname",
++ 'new'=>"$longnewname"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpname, $longnewname, $!);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ my $longnewdesc="$shareddir/$path/.desc.$in{'new_name'}";
++ $longnewdesc =~ s/\/+/\//g;
++
++ unless (rename "$longtmpdesc","$longnewdesc"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpdesc",
++ 'new'=>"$longnewdesc"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpdesc, $longnewdesc, $!);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ }elsif ($access_dir{'may'}{'edit'} == 0.5 ){
++
++ unless (rename "$longtmpname","$shareddir/$path/.$in{'new_name'}.moderate"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpname",
++ 'new'=>"$shareddir/$path/.$in{'new_name'}.moderate"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_upload : Failed to rename $longtmpname to $shareddir/$path/.$in{'new_name'}.moderate : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ unless (rename "$longtmpdesc","$shareddir/$path/.desc..$in{'new_name'}.moderate"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpdesc",
++ 'new'=>"$shareddir/$path/.desc..$in{'new_name'}.moderate"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_upload : Failed to rename $longtmpdesc to $shareddir/$path/.desc..$in{'new_name'}.moderate: $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ unless ($list->send_notify_to_editor('shared_moderated',{'filename' => "$path/$in{'new_name'}",
++ 'who' => $param->{'user'}{'email'}})) {
++ &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
++ }
++
++ }else {
++ &report::reject_report_web('auth',$access_dir{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('err','do_d_upload : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++# $in{'list'} = $list_name;
++
++ # message of success
++ &report::notice_report_web('upload_success', {'path' => $fname},$param->{'action'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 'd_read';
++ }
++
++ # in mode_cancel, we delete the temp file and his desc
++ if ($in{'mode_cancel'}) {
++
++ # removing of the temp file
++ unless (unlink($longtmpname)) {
++ &report::reject_report_web('intern','erase_file',{'file' => $longtmpname},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_d_upload: failed to erase the temp file %s', $longtmpname);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # removing of the description temp file
++ unless (unlink($longtmpdesc)) {
++ &report::reject_report_web('intern','erase_file',{'file' => $longtmpdesc},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_d_upload: failed to erase the desc temp file %s', $longtmpdesc);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ return 'd_read';
++ }
++
++ ## usual case
++
++ # shared_moderated
++ if ($access_dir{'may'}{'edit'} == 0.5 ) {
++ my $modname="."."$fname".".moderate";
++
++ &creation_shared_file($shareddir,$path,$modname);
++ &creation_desc_file($shareddir,$path,$modname,%access_dir);
++
++ unless ($file_moderated){
++ unless ($list->send_notify_to_editor('shared_moderated',{'filename' => "$path/$fname",
++ 'who' => $param->{'user'}{'email'}})) {
++ &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
++ }
++ }
++
++ &report::notice_report_web('to_moderate', {'path' => $fname},$param->{'action'});
++
++ } else {
++ &creation_shared_file($shareddir,$path,$fname);
++ &creation_desc_file($shareddir,$path,$fname,%access_dir);
++ }
++
++ $in{'list'} = $list_name;
++
++ &report::notice_report_web('upload_success', {'path' => $visible_fname},$param->{'action'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 'd_read';
++ }
++
++## Creation of a picture file
++sub creation_picture_file {
++ my($root_dir, $path ,$fname)=@_;
++
++ unless(-d $root_dir.'/'.$path) {
++ &wwslog('notice',"creation_picture_file : Create dir $root_dir/$path/");
++
++ unless (&tools::mkdir_all($root_dir.'/'.$path, 0755)){
++ &wwslog('err',"creation_picture_file : Unable to create dir $root_dir/$path/");
++ return undef;
++ }
++
++ unless (open(FF,">$root_dir".'/'.$path.'/index.html')){
++ &wwslog('err',"creation_picture_file : Unable to create dir $root_dir/$path/index.html");
++ }
++ chmod 0755, $root_dir.'/'.$path.'/index.html';
++ close FF;
++ }
++
++ my $fh = $query->upload('uploaded_file');
++ unless (open FILE, ">:bytes", "$root_dir/$path/$fname") {
++ &report::reject_report_web('intern','cannot_upload',{'path' => "$path/$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"creation_picture_file : Cannot open file $root_dir/$path/$fname : $!");
++ return undef;
++ }
++ while (<$fh>) {
++ print FILE;
++ }
++ close FILE;
++ chmod 0755, "$root_dir/$path/$fname";
++}
++
++
++## Creation of a shared file
++sub creation_shared_file {
++ my($shareddir,$path,$fname)=@_;
++
++ unless(-d $shareddir.'/'.$path) {
++ &wwslog('notice',"creation_shared_file : Create dir $shareddir/$path/");
++
++ unless (mkdir($shareddir.'/'.$path,0755)){
++ &wwslog('err',"creation_shared_file : Unable to create dir $shareddir/$path/");
++ return undef;
++ }
++
++ }
++
++ my $fh = $query->upload('uploaded_file');
++
++ unless (open FILE, ">:bytes", "$shareddir/$path/$fname") {
++ &report::reject_report_web('intern','cannot_upload',{'path' => "$path/$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"creation_shared_file : Cannot open file $shareddir/$path/$fname : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ while (<$fh>) {
++ print FILE;
++ }
++ close FILE;
++
++ ## XSS Protection for HTML files.
++ if (lc($fname) =~ /\.html?/) {
++ my $sanitized_file = &tools::sanitize_html_file('robot' => $robot,
++ 'file' => "$shareddir/$path/$fname");
++ if (defined $sanitized_file) {
++ open HTMLFILE, ">:bytes", "$shareddir/$path/$fname";
++ print HTMLFILE $sanitized_file;
++ close HTMLFILE;
++ }
++ else {
++ &do_log('err','Unable to sanitize file %s',$fname);
++ }
++ }
++
++}
++
++## Creation of the description file
++sub creation_desc_file {
++ my($shareddir,$path,$fname,%access)=@_;
++
++ unless (open (DESC,">$shareddir/$path/.desc.$fname")) {
++ &wwslog('err',"creation_desc_file: cannot create description file $shareddir/.desc.$path/$fname");
++ }
++
++ print DESC "title\n \n\n";
++ print DESC "creation\n date_epoch ".time."\n email $param->{'user'}{'email'}\n\n";
++
++ print DESC "access\n";
++ print DESC " read $access{'scenario'}{'read'}\n";
++ print DESC " edit $access{'scenario'}{'edit'}\n";
++
++ close DESC;
++}
++
++ #*******************************************
++ # Function : do_d_unzip
++ # Description : unzip a file or a tree structure
++ # from an uploaded zip file
++ #******************************************
++
++ sub do_d_unzip {
++ # Parameters of the uploaded file (from d_read.tt2)
++ my $fn = $in{'unzipped_file'};
++
++ # name of the file, without path
++ my $fname;
++ if ($fn =~ /([^\/\\]+)$/) {
++ $fname = $1;
++ }
++
++ &wwslog('info', 'do_d_unzip(%s/%s)', $in{'path'},$fname);
++
++ # Variables
++ my $path = &no_slash_end($in{'path'});
++
++ # path of the shared directory
++ my $shareddir = $list->{'dir'}.'/shared';
++
++ # name of the file
++ my $longname = "$shareddir/$path/$fname";
++ $longname =~ s/\/+/\//g;
++
++ ## Controls
++
++ my $listname = $list->{'name'};
++
++ # uploaded file must have a name
++ unless ($fname) {
++ &report::reject_report_web('user','no_name',{},$param->{'action'},$list);
++ &wwslog('err',"do_d_unzip(%s/%s) : No file specified to upload",$path,$fname);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # must have .zip extension
++ unless ($fname =~ /^.+\.zip$/) {
++ &report::reject_report_web('user','incorrect_name',{'name' => "$fname",
++ 'reason' => "must have the '.zip' extension"},$param->{'action'},$list);
++ &wwslog('err',"do_d_unzip(%s/%s) : the file must have '.zip' extension",$path,$fname);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ## Check quota
++ if ($list->{'admin'}{'shared_doc'}{'quota'}) {
++ if ($list->get_shared_size() >= $list->{'admin'}{'shared_doc'}{'quota'} * 1024){
++ &report::reject_report_web('user','shared_full',{},$param->{'action'},$list);
++ &wwslog('err',"do_d_unzip(%s/%s) : Shared Quota exceeded for list $list->{'name'}",$path,$fname);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'shared_full','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++
++ # The name of the file must be correct and must not be a description file
++ if ($fname =~ /^\./
++ || $fname =~ /\.desc/
++ || $fname =~ /[~\#\[\]]$/) {
++ &report::reject_report_web('user','incorrect_name',{'name' => "$fname"},$param->{'action'},$list);
++ &wwslog('err',"do_d_unzip(%s/%s) : incorrect name",$path,$fname);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # the file must be uploaded in a directory existing
++ unless (-d "$shareddir/$path") {
++ &report::reject_report_web('user','no_such_document',{'path'=> $path},$param->{'action'},$list);
++ &wwslog('err',"do_d_unzip(%s/%s) : $shareddir/$path : not a directory",$path,$fname);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # Access control for the directory where there is the uploading
++ # only for (is_author || !moderated)
++ my %mode;
++ $mode{'edit'} = 1;
++ my %access_dir = &d_access_control(\%mode,$path);
++
++ if ($access_dir{'may'}{'edit'} == 0) {
++ &report::reject_report_web('auth',$access_dir{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('err','do_d_unzip(%s/%s) : access denied for %s',$path,$fname, $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ if ($access_dir{'may'}{'edit'} == 0.5) {
++ &report::reject_report_web('auth','edit_moderated',{},$param->{'action'},$list);
++ &wwslog('err','do_d_unzip(%s/%s) : access denied for %s',$path,$fname, $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ## End of control
++
++ # directory for the uploaded file
++ my $date = time;
++ my $zip_dir_name = $listname.$date.$$;
++ my $zip_abs_dir = $Conf{'tmpdir'}.'/'.$zip_dir_name;
++
++ unless (mkdir ("$zip_abs_dir",0777)) {
++ &report::reject_report_web('intern','cannot_mkdir',{'dir' => $zip_abs_dir},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_unzip($path/$fname) : Unable to create $zip_abs_dir : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ### directory for unzipped files
++ unless (mkdir ("$zip_abs_dir"."/zip",0777)) {
++ &report::reject_report_web('intern','cannot_mkdir',{'dir' => "$zip_abs_dir"."/zip"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_unzip($path/$fname) : Unable to create $zip_abs_dir/zip : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ### uploaded of the file.zip
++ my $fh = $query->upload('unzipped_file');
++ unless (open FILE, ">:bytes", "$zip_abs_dir/$fname") {
++ &report::reject_report_web('intern','cannot_upload',{'path' => "$path/$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_unzip($path/$fname) : Cannot open file $zip_abs_dir/$fname : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ while (<$fh>) {
++ print FILE;
++ }
++ close FILE;
++
++ ### unzip the file
++ my $status = &d_unzip_shared_file($zip_abs_dir,$fname,$path);
++
++ unless (defined($status)) {
++ &report::reject_report_web('intern','cannot_unzip',{'path' => "$zip_abs_dir/$fname", 'name' => $fname},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_unzip($path/$fname) : Unable to unzip the file $zip_abs_dir/$fname");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ unless ($status) {
++ &report::reject_report_web('intern','cannot_unzip',{'name' => "$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ }
++
++ ### install the file hierarchy
++
++ unless (&d_install_file_hierarchy("$zip_abs_dir/zip",$shareddir,$path,\%access_dir)) {
++ &wwslog('err',"do_d_unzip($path/$fname) : unable to install file hierarchy");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ## remove tmp directories and files
++# &tools::remove_dir($zip_abs_dir);
++
++ $in{'list'} = $listname;
++
++ &report::notice_report_web('unzip_success', {'path' => $fname},$param->{'action'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 'd_read'
++ }
++
++## unzip a shared file in the tmp directory
++sub d_unzip_shared_file {
++ my ($zip_abs_dir,$fname) = @_;
++ &wwslog('info', 'd_unzip_shared_file(%s/%s)', $zip_abs_dir,$fname);
++
++ my $status = 1;
++
++ my $zip = Archive::Zip->new();
++
++ my $az = $zip->read( "$zip_abs_dir/$fname" );
++
++ unless ($az == AZ_OK){
++ &wwslog('err',"unzip_shared_file : Unable to read the zip file $zip_abs_dir/$fname : $az");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$zip_abs_dir,$fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ my @memberNames = $zip->memberNames();
++
++ foreach my $name (@memberNames) {
++ my $az = $zip->extractMember($name, $zip_abs_dir.'/zip/'.$name);
++ unless ($az == AZ_OK) {
++ &wwslog('err',"unzip_shared_file : Unable to extract member $name of the zip file $zip_abs_dir/$fname : $az");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$zip_abs_dir,$fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ $status = 0;
++ }
++ }
++
++ ## Qencode 8bit filenames afterward
++ ## The suspected charset is the one that is associated to the user's language
++ &tools::qencode_hierarchy($zip_abs_dir.'/zip', &Language::GetCharset());
++
++ return $status;
++}
++
++## Install file hierarchy from $tmp_dir directory to $shareddir/$path directory
++sub d_install_file_hierarchy {
++ my ($tmp_dir,$shareddir,$path,$access_dir)=@_;
++ &wwslog('debug2', 'd_install_file_hierarchy(%s,%s)',$tmp_dir,$path);
++
++ $tmp_dir = &no_slash_end($tmp_dir);
++ $shareddir = &no_slash_end($shareddir);
++ $path = &no_slash_end($path);
++
++ my $fatal_error = 0;
++
++ unless (opendir DIR,"$tmp_dir") {
++ &report::reject_report_web('intern','cannot_open_dir',{'dir' => $tmp_dir},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','d_install_file_hierarchy(%s) : impossible to open %s directory',$path,$tmp_dir);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$tmp_dir,$shareddir,$path,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ my @from_dir = readdir DIR;
++ closedir DIR;
++
++ foreach my $doc (@from_dir) {
++ next
++ if($doc eq '.' || $doc eq '..');
++ if (-d "$tmp_dir/$doc") {
++ if ($fatal_error) {
++ &report::reject_report_web('user','directory_no_copied',{'name'=> "$path/$doc",
++ 'reason' => "quota exceeded"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ }else {
++ unless (&d_copy_rec_dir("$tmp_dir","$path","$shareddir/$path",$doc)){
++ $fatal_error = 1;
++ &report::reject_report_web('user','directory_no_copied',{'name'=> "$path/$doc",
++ 'reason' => "quota exceeded"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ # return undef;
++ }
++ }
++ } else {
++ if ($fatal_error) {
++ &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$doc",
++ 'reason' => "quota exceeded"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ }else {
++ unless (&d_copy_file("$tmp_dir","$path","$shareddir/$path",$doc,$access_dir)) {
++ &wwslog('err',"d_install_hierarchy($path) : fatal error from d_copy_file($doc)");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$tmp_dir,$shareddir,$path,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++
++ $fatal_error = 1;
++ &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$doc",
++ 'reason' => "quota exceeded"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ }
++ # return undef;
++ }
++ }
++ }
++
++ if ($fatal_error) {
++ return undef;
++ }else {
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$tmp_dir,$shareddir,$path,$access_dir",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++}
++
++## copy $dname from $from to $list->{shared}/$path if rights are ok
++sub d_copy_rec_dir {
++ my ($from,$path,$dest_dir,$dname) = @_;
++ &wwslog('debug3', 'd_copy_rec_dir(%s,%s,%s)',$from,$dest_dir,$dname);
++
++ $from = &no_slash_end($from);
++ $path = &no_slash_end($path);
++ $dest_dir = &no_slash_end($dest_dir);
++
++ my $fatal_error = 0;
++
++ # Access control on the directory $path where there is the copy
++ # Copy allowed only for (is_author || !moderate)
++ my %mode;
++ $mode{'edit'} = 1;
++ $mode{'control'} = 1;
++ my %access_dir = &d_access_control(\%mode,$path);
++
++ unless ($access_dir{'may'}{'edit'} == 1) {
++ &report::reject_report_web('user','directory_no_copied',{'name'=> $dname,
++ 'reason' => "no edition right on father directory"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','d_copy_rec_dir(%s): access denied for %s',$path,$param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++ my $may;
++ unless ($may = &d_test_existing_and_rights($path,$dname,$dest_dir)) {
++ &report::reject_report_web('user','directory_no_copied',{'name'=> $dname },
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','d_copy_rec_dir(%s) : error while calling "test_existing_and_rights(%s/%s)"',$dname,$dest_dir,$dname);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++ unless ($may->{'exists'}) {
++
++ # The name of the directory must be correct and musn't not be a description file
++ if ($dname =~ /^\./
++ || $dname =~ /\.desc/
++ || $dname =~ /[~\#\[\]]$/) {
++ &report::reject_report_web('user','incorrect_name',{'name' => "$dname"},$param->{'action'},$list);
++ &wwslog('err',"d_copy_rec_dir : $dname : incorrect name");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++ ## Exception index.html
++ unless ($dname !~ /^index.html?$/i) {
++ &report::reject_report_web('user','index_html',{'dir' => $path},$param->{'action'},$list);
++ &wwslog('err',"d_copy_rec_dir : the directory cannot be called INDEX.HTML ");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++ ## directory creation
++ unless (mkdir ("$dest_dir/$dname",0777)) {
++ &report::reject_report_web('user','directory_no_copied',{'name'=> "$dname"},$param->{'action'},$list);
++ &wwslog('err',"d_copy_rec_dir : Unable to create directory $dest_dir/$dname : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++ ## desc directory creation
++ unless (open (DESC,">$dest_dir/$dname/.desc")) {
++ &wwslog('err',"d_copy_rec_dir: cannot create description file $dest_dir/$dname/.desc");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ print DESC "title\n \n\n";
++ print DESC "creation\n date_epoch ".time."\n email $param->{'user'}{'email'}\n\n";
++
++ print DESC "access\n";
++ print DESC " read $access_dir{'scenario'}{'read'}\n";
++ print DESC " edit $access_dir{'scenario'}{'edit'}\n";
++
++ close DESC;
++ }
++
++ if ($may->{'rights'} || !($may->{'exists'})) {
++
++ unless (opendir DIR,"$from/$dname") {
++ &report::reject_report_web('user','directory_no_copied',{'name'=> "$dname"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','d_copy_rec_dir(%s) : impossible to open %s directory',$dname,$from);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++ my @from_dir = readdir DIR;
++ closedir DIR;
++
++
++ foreach my $doc (@from_dir) {
++
++ if ($doc eq '.' || $doc eq '..') {
++ next;
++ }
++ if (-d "$from/$dname/$doc") {
++ if ($fatal_error) {
++ &report::reject_report_web('user','directory_no_copied',{'name'=> "$dname/$doc",
++ 'reason' => "quota exceeded"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++
++ }else {
++
++ unless (&d_copy_rec_dir("$from/$dname","$path/$dname","$dest_dir/$dname",$doc)){
++ $fatal_error = 1;
++ &report::reject_report_web('user','directory_no_copied',{'name'=> "$dname/$doc",
++ 'reason' => "quota exceeded"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++# return undef;
++ }
++ }
++
++ }else {
++ if ($fatal_error) {
++ &report::reject_report_web('user','file_no_copied',{'name'=> "$dname/$doc",
++ 'reason' => "quota exceeded"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++
++ }else {
++ unless (&d_copy_file("$from/$dname","$path/$dname","$dest_dir/$dname",$doc,\%access_dir)){
++ &wwslog('err',"d_copy_rec_dir($path/$dname) : fatal error from d_copy_file($doc)");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ $fatal_error = 1;
++ &report::reject_report_web('user','file_no_copied',{'name'=> "$dname/$doc",
++ 'reason' => "quota exceeded"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ }
++# return undef;
++ }
++ }
++ }
++
++ }else{
++ &report::reject_report_web('user','directory_no_copied',{'name'=> $dname,
++ 'reason' => "no edition right on the father directory"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++
++ &wwslog('err',"d_copy_rec_file : impossible to copy content directory $dname, the user doesn't have edit rights on directory $path");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ if ($fatal_error) {
++ return undef;
++ } else {
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++}
++
++## copy $from/$fname to $list->{shared}/$path if rights are ok
++sub d_copy_file {
++ my ($from,$path,$dest_dir,$fname,$access_dir) = @_;
++ &wwslog('debug3', 'd_copy_file(%s,%s,%s',$from,$dest_dir,$fname);
++
++ $from = &no_slash_end($from);
++ $path = &no_slash_end($path);
++ $dest_dir = &no_slash_end($dest_dir);
++
++ my $may;
++ unless ($may = &d_test_existing_and_rights($path,$fname,$dest_dir)) {
++ &report::reject_report_web('user','file_no_copied',{'name'=> "$fname",
++ 'reason' => "quota exceeded"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','d_copy_file(%s) : error while calling "test_existing_and_rights(%s/%s)"',$fname,$dest_dir,$fname);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++ if ($may->{'rights'} || !($may->{'exists'})) {
++
++ # The name of the file must be correct and musn't not be a description file
++ if ($fname =~ /^\./
++ || $fname =~ /\.desc/
++ || $fname =~ /[~\#\[\]]$/) {
++ &report::reject_report_web('user','incorrect_name',{'name' => "$fname"},$param->{'action'},$list);
++ &wwslog('err',"d_copy_file : $fname : incorrect name");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++ ## Exception index.html
++ unless ($fname !~ /^index.html?$/i) {
++ unless ($access_dir->{'may'}{'control'}) {
++ &report::reject_report_web('user','index_html',{'dir' => $path},$param->{'action'},$list);
++ &wwslog('err',"d_copy_file : the user is not authorized to upload a INDEX.HTML file in $dest_dir");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++ }
++
++ ## Check quota
++ if ($list->{'admin'}{'shared_doc'}{'quota'}) {
++
++ if ($list->get_shared_size() >= $list->{'admin'}{'shared_doc'}{'quota'} * 1024){
++ &report::reject_report_web('user','shared_full',{},$param->{'action'},$list);
++ &wwslog('err',"d_copy_file : Shared Quota exceeded for list $list->{'name'} on file $path/$fname");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'shared_full','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++
++ ## if already existing :delete it
++ unlink ("$dest_dir/$fname")
++ if (-e "$dest_dir/$fname");
++ unlink ("$dest_dir/.desc.$fname")
++ if (-e "$dest_dir/.desc.$fname");
++
++ ## # if exists a temp file younger than 5 minutes that belongs to another user : file copy refused
++ if (-e "$dest_dir/.$fname.duplicate") {
++ my @info = stat "$dest_dir/.$fname.duplicate";
++ my $timeold = time - $info[10];
++ if ($timeold <= 300){
++ my %desc_hash = &get_desc_file("$dest_dir/.desc..$fname.duplicate");
++ unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
++ &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$fname",
++ 'reason' => "file being uploading by $desc_hash{'email'} at this time"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"d_copy_file : unable to copy $path/$fname : file being uploaded at this time ");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++ }
++
++ unlink ("$dest_dir/.$fname.duplicate");
++ unlink ("$dest_dir/.desc..$fname.duplicate")
++ if (-e "$dest_dir/.desc..$fname.duplicate");
++ }
++
++ if (-e "$dest_dir/.$fname.moderate") {
++ my %desc_hash = &get_desc_file("$dest_dir/.$fname.moderate");
++
++ unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
++ &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$fname",
++ 'reason' => "file awaiting for moderation, uploaded by $desc_hash{'email'}"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"d_copy_file : unable to copy $path/$fname : file awaiting for moderation");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++ unlink ("$dest_dir/.$fname.moderate");
++
++ unlink ("$dest_dir/.desc..$fname.moderate")
++ if (-e "$dest_dir/.desc..$fname.moderate");
++ }
++
++ ## file copy
++ unless (open FROM_FILE,"$from/$fname") {
++ &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$fname"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"d_copy_file : impossible to open $from/$fname");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++ my $visible_fname = &make_visible_path($fname);
++
++ unless (open DEST_FILE, ">$dest_dir/$fname") {
++ &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$visible_fname"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"d_copy_file : Cannot create file $dest_dir/$fname : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++ while (<FROM_FILE>) {
++ print DEST_FILE;
++ }
++ close FROM_FILE;
++ close DEST_FILE;
++
++ ## XSS Protection for HTML files.
++ if (lc($fname) =~ /\.html?/) {
++ my $sanitized_file = &tools::sanitize_html_file('robot' => $robot,
++ 'file' => "$dest_dir/$fname");
++ if (defined $sanitized_file) {
++ open HTMLFILE, ">:bytes", "$dest_dir/$fname";
++ print HTMLFILE $sanitized_file;
++ close HTMLFILE;
++ }
++ else {
++ &do_log('err','Unable to sanitize file %s',$fname);
++ }
++ }
++
++ ## desc file creation
++ unless (open (DESC,">$dest_dir/.desc.$fname")) {
++ &wwslog('err',"d_copy_file: cannot create description file $dest_dir/.desc.$fname");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ print DESC "title\n \n\n";
++ print DESC "creation\n date_epoch ".time."\n email $param->{'user'}{'email'}\n\n";
++
++ print DESC "access\n";
++ print DESC " read $access_dir->{'scenario'}{'read'}\n";
++ print DESC " edit $access_dir->{'scenario'}{'edit'}\n";
++
++ close DESC;
++
++ ## information
++
++ &report::notice_report_web('file_erased',{'path'=> "$path/$visible_fname"},$param->{'action'})
++ if ($may->{'exists'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }else{
++ &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$fname",
++ 'reason' => "you do not have total edit right on the file"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"d_copy_file : impossible to copy file $fname, the user doesn't have total edit rights on the file");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ return 1;
++}
++
++## return information on file or dir : existing and edit rights for the user in $param
++sub d_test_existing_and_rights {
++ my ($path,$name,$dest_dir) = @_;
++
++ $path = &no_slash_end($path);
++ $name = &no_slash_end($name);
++ $dest_dir = &no_slash_end($dest_dir);
++
++ my $return;
++
++ $return->{'exists'} = 0;
++ $return->{'rights'} = 0;
++
++ if ((-e "$dest_dir/$name") ||
++ (-e "$dest_dir/.$name.duplicate") ||
++ (-e "$dest_dir/.$name.moderate")) {
++
++ $return->{'exists'} = 1;
++
++ my %mode;
++ $mode{'edit'} = 1;
++ my %access = &d_access_control(\%mode,"$path/$name");
++ $return->{'rights'} = 1
++ if $access{'may'}{'edit'} == 1;
++ }
++
++ return $return;
++}
++
++
++ #*******************************************
++ # Function : do_d_delete
++ # Description : Delete an existing document
++ # (file or directory)
++ #******************************************
++
++ sub do_d_delete {
++ &wwslog('info', 'do_d_delete(%s)', $in{'path'});
++
++ #useful variables
++ my $path = &no_slash_end($in{'path'});
++
++ my $visible_path = &make_visible_path($path);
++
++ #Current directory and document to delete
++ $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
++ my $current_directory = &no_slash_end($1);
++ my $document = $3;
++
++ # path of the shared directory
++ #my $list_name = $in{'list'};
++ my $list_name = $list->{'name'};
++ my $shareddir = $list->{'dir'}.'/shared';
++
++ #### Controls
++
++ ## must be something to delete
++ unless ($document) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'doccument'},$param->{'action'});
++ &wwslog('err',"do_d_delete : no document to delete has been specified");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'missing_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ### Document isn't a description file?
++ unless ($document !~ /^\.desc/) {
++ &wwslog('err',"do_d_delete : $shareddir/$path : description file");
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'description_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ### Document exists?
++ unless (-e "$shareddir/$path") {
++ &wwslog('err',"do_d_delete : $shareddir/$path : no such file or directory");
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # removing of the document
++ my $doc = "$shareddir/$path";
++
++ # Access control
++ my %mode;
++ $mode{'edit'} = 1;
++ my %access = &d_access_control(\%mode,$path);
++
++ unless ($access{'may'}{'edit'} > 0) {
++ &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('err','do_d_delete : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ## Directory
++ if (-d "$shareddir/$path") {
++
++ # test of emptiness
++ opendir DIR, "$doc";
++ my @readdir = readdir DIR;
++ close DIR;
++
++ # test for "ordinary" files
++ my @test_normal = grep !/^\./, @readdir;
++ my @test_hidden = grep !(/^\.desc$/ | /^\.(\.)?$/ | /^[^\.]/), @readdir;
++ if (($#test_normal != -1) || ($#test_hidden != -1)) {
++ &report::reject_report_web('user','full_directory',{'directory'=> $path},$param->{'action'},$list);
++ &wwslog('err',"do_d_delete : Failed to erase $doc : directory not empty");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # removing of the description file if exists
++ if (-e "$doc/\.desc") {
++ unless (unlink("$doc/.desc")) {
++ &report::reject_report_web('intern','erase_file',{'file' => "$doc/.desc"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_delete : Failed to erase $doc/.desc : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++ # removing of the directory
++ rmdir $doc;
++
++ ## File
++ }else {
++
++ # removing of the document
++ unless (unlink($doc)) {
++ &report::reject_report_web('intern','erase_file',{'file' => "$doc"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_d_delete: failed to erase %s', $doc);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ # removing of the description file if exists
++ if (-e "$shareddir/$current_directory/.desc.$document") {
++ unless (unlink("$shareddir/$current_directory/.desc.$document")) {
++ &wwslog('err',"do_d_delete: failed to erase $shareddir/$current_directory/.desc.$document");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++ }
++ }
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ $in{'list'} = $list_name;
++ $in{'path'} = $current_directory;
++ return 'd_read';
++ }
++
++ #*******************************************
++ # Function : do_d_rename
++ # Description : Rename a document
++ # (file or directory)
++ #******************************************
++
++ sub do_d_rename {
++ &wwslog('info', 'do_d_rename(%s)', $in{'path'});
++
++ #useful variables
++ my $path = &no_slash_end($in{'path'});
++
++ #moderation
++ my $visible_path = &make_visible_path($path);
++ my $moderate;
++ if ($path =~ /\.moderate$/) {
++ $moderate=1;
++ }
++
++ #Current directory and document to delete
++ my $current_directory;
++ if ($path =~ /^(.*)\/([^\/]+)$/) {
++ $current_directory = &no_slash_end($1);
++ }else {
++ $current_directory = '.';
++ }
++ $path =~ /(^|\/)([^\/]+)$/;
++ my $document = $2;
++
++ # path of the shared directory
++ my $list_name = $list->{'name'};
++ my $shareddir = $list->{'dir'}.'/shared';
++
++ #### Controls
++
++ ## must be something to delete
++ unless ($document) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'document'},$param->{'action'});
++ &wwslog('err',"do_d_rename : no document to rename has been specified");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ### Document isn't a description file?
++ unless ($document !~ /^\.desc/) {
++ &wwslog('err',"do_d_rename : $shareddir/$path : description file");
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_such_document','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ### Document exists?
++ unless (-e "$shareddir/$path") {
++ &wwslog('err',"do_d_rename : $shareddir/$path : no such file or directory");
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_such_document','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ if ($in{'new_name'} =~ /^\./
++ || $in{'new_name'} =~ /\.desc/
++ || $in{'new_name'} =~ /[~\#\[\]\/]$/) {
++ &report::reject_report_web('user','incorrect_name',{'name' => $in{'new_name'}},$param->{'action'},$list);
++ &wwslog('err',"do_d_rename : Unable to create file $in{'new_name'} : incorrect name");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ if (($document =~ /\.url$/) && ($in{'new_name'} !~ /\.url$/)) {
++ &report::reject_report_web('user','incorrect_name',{'name' => $in{'new_name'}},$param->{'action'},$list);
++ &wwslog('err',"do_d_rename : New file name $in{'new_name'} does not match URL filenames");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ my $doc = "$shareddir/$path";
++
++ # Access control
++ my %mode;
++ $mode{'edit'} = 1;
++ my %access = &d_access_control(\%mode,$path);
++
++ unless ($access{'may'}{'edit'} > 0) {
++ &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('err','do_d_rename : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ if ($moderate){
++ &do_log('notice', "RENAME: $doc, $shareddir/$current_directory/$in{'new_name'}");
++ unless (rename $doc, "$shareddir/$current_directory/.$in{'new_name'}.moderate") {
++ &report::reject_report_web('intern','rename_file',{'old'=>$doc,
++ 'new'=>"$shareddir/$current_directory/.$in{'new_name'}.moderate"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_rename : Failed to rename %s to %s : %s", $doc, "$shareddir/$current_directory/$in{'new_name'}", $!);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }else {
++ &do_log('notice', "RENAME: $doc, $shareddir/$current_directory/$in{'new_name'}");
++ unless (rename $doc, "$shareddir/$current_directory/$in{'new_name'}") {
++ &report::reject_report_web('intern','rename_file',{'old'=>$doc,
++ 'new'=>"$shareddir/$current_directory/$in{'new_name'}"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_rename : Failed to rename %s to %s : %s", $doc, "$shareddir/$current_directory/$in{'new_name'}", $!);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++ ## Rename description file
++ my $desc_file = "$shareddir/$current_directory/.desc.$document";
++ my $new_desc_file = $desc_file;
++
++ if (-f $desc_file) {
++ if ($moderate){
++ $new_desc_file =~ s/\Q$document/\.$in{'new_name'}\.moderate/;
++ }else {
++ $new_desc_file =~ s/\Q$document/$in{'new_name'}/;
++ }
++ unless (rename $desc_file, $new_desc_file) {
++ &report::reject_report_web('intern','rename_file',{'old'=>$desc_file,
++ 'new'=> $new_desc_file},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_rename : Failed to rename $desc_file : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ $in{'list'} = $list_name;
++ if ($current_directory eq '.') {
++ $in{'path'} = '';
++ } else {
++ $in{'path'} = $current_directory.'';
++ }
++ return 'd_read';
++ }
++
++ #*******************************************
++ # Function : do_d_create_dir
++ # Description : Creates a new file / directory
++ #******************************************
++ sub do_d_create_dir {
++ &wwslog('info', 'do_d_create_dir(%s)', $in{'name_doc'});
++
++ #useful variables
++ my $path = &no_slash_end($in{'path'});
++
++ #my $list_name = $in{'list'};
++ my $list_name = $list->{'name'};
++ my $name_doc = $in{'name_doc'};
++
++ $param->{'list'} = $list_name;
++ $param->{'path'} = $path;
++
++ ## Q-decode file path and names
++ $param->{'decoded_path'} = &tools::qdecode_filename($param->{'path'});
++ $param->{'decoded_name_doc'} = &tools::qdecode_filename($name_doc);
++
++ my $type = $in{'type'} || 'directory';
++ my $desc_file;
++
++ ### Controls
++
++ # Must be a directory to create (directory name not empty)
++ unless ($name_doc) {
++ &report::reject_report_web('user','no_name',{},$param->{'action'},$list);
++ &wwslog('err',"do_d_create_dir : Unable to create : no name specified!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'missing_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # The name of the directory must be correct
++ if ($name_doc =~ /^\./
++ || $name_doc =~ /\.desc/
++ || $name_doc =~ /[~\#\[\]\/]$/) {
++ &report::reject_report_web('user','incorrect_name',{'name' => $name_doc},$param->{'action'},$list);
++ &wwslog('err',"do_d_create_dir : Unable to create directory $name_doc : incorrect name");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++
++ # Access control
++ my %mode;
++ $mode{'edit'} = 1;
++ my %access = &d_access_control(\%mode, $path);
++
++ if ($type eq 'directory') { ## only when (is_author || !moderated)
++ if ($access{'may'}{'edit'} == 0) {
++ &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('err','do_d_create_dir : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ if ($access{'may'}{'edit'} == 0.5) {
++ &report::reject_report_web('auth','dir_edit_moderated',{},$param->{'action'},$list);
++ &wwslog('err','do_d_create_dir : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ } else {
++ if ($access{'may'}{'edit'} == 0) {
++ &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('err','do_d_create_dir : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++
++ # path of the shared directory
++ my $shareddir = $list->{'dir'}.'/shared';
++
++ my $document = "$shareddir/$path/$name_doc";
++
++ $param->{'document'} = $document;
++
++ # the file musn't already exists
++ if (-e $document){
++ &report::reject_report_web('user','doc_already_exist',{'name' => "$path/$name_doc"},$param->{'action'},$list);
++ &wwslog('err',"do_d_create_dir : cannot create $path/$name_doc : file already exists");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # if the file .moderate exists, only its author can erase it
++
++ my $doc_moderate = "$shareddir/$path/"."."."$name_doc".".moderate";
++ my $file_moderated;
++
++ if (-e "$doc_moderate"){
++
++ $file_moderated = 1;
++ my $desc="$shareddir/$path/".".desc.."."$name_doc".".moderate";
++ $desc =~ s/\/+/\//g;
++ my %desc_hash = &get_desc_file("$desc");
++
++ unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
++ &report::reject_report_web('user','cannot_upload',{'path' => "$path/$name_doc",
++ 'reason' => "file already exists but not yet moderated"},$param->{'action'},$list);
++ &wwslog('err',"do_d_create_dir : Unable to create $doc_moderate : file already exists but not yet moderated");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++
++ ### End of controls
++
++ if ($type eq 'directory') {
++ # Creation of the new directory
++ unless (mkdir ("$document",0777)) {
++ &report::reject_report_web('intern','cannot_mkdir',{'dir' => $document},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_create_dir : Unable to create $document : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ $desc_file = "$document/.desc";
++
++ }else {
++ # Creation of the new file
++ unless (open FILE, ">$document") {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => "$path/$name_doc"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_create_dir : Unable to create $document : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ close FILE;
++
++ $desc_file = "$shareddir/$path/.desc.$name_doc";
++ }
++
++ # Creation of a default description file
++ unless (open (DESC,">$desc_file")) {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => "$desc_file"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ }
++
++ print DESC "title\n \n\n";
++ print DESC "creation\n date_epoch ".time."\n email $param->{'user'}{'email'}\n\n";
++
++ print DESC "access\n";
++ print DESC " read $access{'scenario'}{'read'}\n";
++ print DESC " edit $access{'scenario'}{'edit'}\n\n";
++
++ close DESC;
++
++ # moderation
++ if ($access{'may'}{'edit'} == 0.5 && ($type ne 'directory')) {
++ unless (rename "$shareddir/$path/$name_doc","$shareddir/$path/.$name_doc.moderate"){
++ &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$path/$name_doc",
++ 'new'=>"$shareddir/$path/.$name_doc.moderate"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_create_dir : Failed to rename $path/$name_doc to $path/.$name_doc.moderate : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ unless (rename "$desc_file","$shareddir/$path/.desc..$name_doc.moderate"){
++ &report::reject_report_web('intern','rename_file',{'old'=>$desc_file,
++ 'new'=>"$shareddir/$path/.desc..$name_doc.moderate"},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_d_create_dir : Failed to rename $desc_file to $path/.desc..$name_doc.moderate : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ unless ($file_moderated){
++ unless ($list->send_notify_to_editor('shared_moderated',{'filename' => $param->{'decoded_path'}.'/'.$param->{'decoded_name_doc'},
++ 'who' => $param->{'user'}{'email'}})) {
++ &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
++ }
++ }
++ }
++
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++
++ if ($type eq 'directory') {
++ return 'd_read';
++ }
++
++ if ($access{'may'}{'edit'} == 0.5) {
++ $in{'path'} = "$path/.$name_doc.moderate";
++ }else {
++ $in{'path'} = "$path/$name_doc";
++ }
++
++ return 'd_editfile';
++ }
++
++ ############## Control
++
++
++ #*******************************************
++ # Function : do_d_control
++ # Description : prepares the parameters
++ # to edit access for a doc
++ #*******************************************
++
++ sub do_d_control {
++ &wwslog('info', "do_d_control $in{'path'}");
++
++ # Variables
++ my $path = &no_slash_end($in{'path'});
++ #my $list_name = $in{'list'};
++ my $list_name = $list->{'name'};
++
++ # path of the shared directory
++ my $shareddir = $list->{'dir'}.'/shared';
++
++ #moderation
++ my $visible_path = &make_visible_path($path);
++
++ unless ($path) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'document'},$param->{'action'});
++ &wwslog('info','do_d_control: no document name');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'missing_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # Existing document?
++ unless (-e "$shareddir/$path") {
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &wwslog('info',"do_d_control : Cannot control $shareddir/$path : not an existing document");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_such_document','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ### Document isn't a description file?
++ unless ($path !~ /\.desc/) {
++ &wwslog('info',"do_d_control : $shareddir/$path : description file");
++ &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_such_document','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # Access control
++ my %mode;
++ $mode{'control'} = 1;
++ my %access = &d_access_control(\%mode,$path);
++ unless ($access{'may'}{'control'}) {
++ &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
++ &wwslog('info','d_control : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++
++ ## End of controls
++
++
++ #Current directory
++ if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
++ $param->{'father'} = &no_slash_end($1);
++ }else {
++ $param->{'father'} = '';
++ }
++ $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
++
++ my $desc_file;
++ # path of the description file
++ if (-d "$shareddir/$path") {
++ $desc_file = "$shareddir/$1$3/.desc";
++ } else {
++ $desc_file = "$shareddir/$1.desc.$3";
++ }
++
++ # Description of the file
++ my $read;
++ my $edit;
++
++ if (-e $desc_file) {
++
++ ## Synchronization
++ my @info = stat "$desc_file";
++ $param->{'serial_desc'} = $info[9];
++ my %desc_hash = &get_desc_file("$desc_file");
++ # rights for read and edit
++ $read = $desc_hash{'read'};
++ $edit = $desc_hash{'edit'};
++ # owner of the document
++ $param->{'owner'} = $desc_hash{'email'};
++ $param->{'doc_title'} = $desc_hash{'title'};
++ }else {
++ $read = $access{'scenario'}{'read'};
++ $edit = $access{'scenario'}{'edit'};
++ }
++
++ ## other info
++ my @info = stat "$shareddir/$path";
++ $param->{'doc_date'} = gettext_strftime "%d %b %y %H:%M", localtime($info[9]);
++
++ # template parameters
++ $param->{'list'} = $list_name;
++ $param->{'path'} = $path;
++ $param->{'visible_path'} = $visible_path;
++
++ my $lang = $param->{'lang'};
++
++ ## Scenario list for READ
++
++ my $tmp_list_of_scenario = $list->load_scenario_list('d_read',$robot);
++
++ ## Only get required scenario attributes
++ foreach my $scenario (keys %{$tmp_list_of_scenario}) {
++ $param->{'scenari_read'}{$scenario} = {'name' => $tmp_list_of_scenario->{$scenario}{'name'},
++ 'web_title' => $tmp_list_of_scenario->{$scenario}{'web_title'}};
++ }
++
++ $param->{'scenari_read'}{$read}{'selected'} = 'selected="selected"';
++
++ ## Scenario list for EDIT
++ my $tmp_list_of_scenario = $list->load_scenario_list('d_edit',$robot);
++
++ ## Only get required scenario attributes
++ foreach my $scenario (keys %{$tmp_list_of_scenario}) {
++ $param->{'scenari_edit'}{$scenario} = {'name' => $tmp_list_of_scenario->{$scenario}{'name'},
++ 'web_title' => $tmp_list_of_scenario->{$scenario}{'web_title'}};
++ }
++ $param->{'scenari_edit'}{$edit}{'selected'} = 'selected="selected"';
++
++ ## father directory
++ if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
++ $param->{'father'} = &no_slash_end($1);
++ }else {
++ $param->{'father'} = '';
++ }
++ $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
++
++ $param->{'set_owner'} = 1;
++
++ $param->{'father_icon'} = $icon_table{'father'};
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++
++ #*******************************************
++ # Function : do_d_change_access
++ # Description : Saves the description of
++ # the file
++ #******************************************
++
++ sub do_d_change_access {
++ &wwslog('info', 'do_d_change_access(%s)', $in{'path'});
++
++ # Variables
++ my $path = &no_slash_end($in{'path'});
++
++ my $list_name = $list->{'name'};
++
++ # path of the shared directory
++ my $shareddir = $list->{'dir'}.'/shared';
++
++ #### Controls
++
++ ## the path must not be empty (the description file of the shared directory
++ # doesn't exist)
++ unless ($path) {
++ &report::reject_report_web('intern','cannot_describe_shared_directory',{'path' => $path },$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info',"do_d_change_access : Cannot change access $shareddir : root directory");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # the document to describe must already exist
++ unless (-e "$shareddir/$path") {
++ &report::reject_report_web('user','no_doc_to_describe',{'path'=> $path},$param->{'action'},$list);
++ &wwslog('info',"d_change_access : Unable to change access $shareddir/$path : no such document");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++
++ # Access control
++ my %mode;
++ $mode{'control'} = 1;
++ my %access = &d_access_control(\%mode,$path);
++
++ unless ($access{'may'}{'control'}) {
++ &report::reject_report_web('auth','action_listmaster_or_privileged_owner_or_author',{},$param->{'action'},$list);
++ &wwslog('info','d_change_access : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ## End of controls
++
++ # Description file
++ $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
++ my $dir = $1;
++ my $file = $3;
++
++ my $desc_file;
++ if (-d "$shareddir/$path") {
++ $desc_file = "$shareddir/$1$3/.desc";
++ } else {
++ $desc_file = "$shareddir/$1.desc.$3";
++ }
++
++ if (-e "$desc_file"){
++ # if description file already exists : open it and modify it
++ my %desc_hash = &get_desc_file ("$desc_file");
++
++ # Synchronization
++ unless (&synchronize($desc_file,$in{'serial'})){
++ &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
++ &wwslog('info',"d_change_access : Synchronization failed for $desc_file");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'synchro_failed','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ unless (open DESC,">$desc_file") {
++ &wwslog('info',"d_change_access : cannot open $desc_file : $!");
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # information not modified
++ print DESC "title\n $desc_hash{'title'}\n\n";
++
++ # access rights
++ print DESC "access\n read $in{'read_access'}\n";
++ print DESC " edit $in{'edit_access'}\n\n";
++
++ print DESC "creation\n";
++ # time
++ print DESC " date_epoch $desc_hash{'date'}\n";
++ # author
++ print DESC " email $desc_hash{'email'}\n\n";
++
++ close DESC;
++
++ } else {
++ # Creation of a description file
++ unless (open (DESC,">$desc_file")) {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info',"d_change_access : Cannot create description file $desc_file : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ print DESC "title\n \n\n";
++
++ my @info = stat "$shareddir/$path";
++ print DESC "creation\n date_epoch ".$info[10]."\n email\n\n";
++ print DESC "access\n read $in{'read_access'}\n";
++ print DESC " edit $in{'edit_access'}\n\n";
++
++ close DESC;
++
++ }
++
++ return 'd_control';
++
++
++ }
++
++ sub do_d_set_owner {
++ &wwslog('info', 'do_d_set_owner(%s)', $in{'path'});
++
++ # Variables
++ my $desc_file;
++
++ my $path = &no_slash_end($in{'path'});
++
++ #moderation
++ my $visible_path = &make_visible_path($path);
++
++ #my $list_name = $in{'list'};
++ my $list_name = $list->{'name'};
++
++ # path of the shared directory
++ my $shareddir = $list->{'dir'}.'/shared';
++
++ #### Controls
++
++ ## the path must not be empty (the description file of the shared directory
++ # doesn't exist)
++ unless ($path) {
++ &report::reject_report_web('intern','cannot_describe_shared_directory',{'path' => $path },$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info',"do_d_set_owner : Cannot change access $shareddir : root directory");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # the email must look like an email "somebody@somewhere"
++ unless (&tools::valid_email($in{'content'})) {
++ &report::reject_report_web('user','incorrect_email',{'email' => $in{'content'}},$param->{'action'},$list);
++ &wwslog('info',"d_set_owner : $in{'content'} : incorrect email");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'incorrect_email','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # Access control
++ ## father directory
++ $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
++ my $dir = $1;
++ my $file = $3;
++ if (-d "$shareddir/$path") {
++ $desc_file = "$shareddir/$dir$file/.desc";
++ }else {
++ $desc_file = "$shareddir/$dir.desc.$file";
++ }
++
++ my %mode;
++ $mode{'control'} = 1;
++ ## must be authorized to control father directory
++ #my %access = &d_access_control(\%mode,$1);
++ my %access = &d_access_control(\%mode,$path);
++
++ unless ($access{'may'}{'control'}) {
++ &report::reject_report_web('auth','action_listmaster_or_privileged_owner_or_author',{},$param->{'action'},$list);
++ &wwslog('info','d_set_owner : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authentication','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ my $may_set = 1;
++
++ unless ($may_set) {
++ &report::reject_report_web('user','full_directory',{'directory'=> $visible_path},$param->{'action'},$list);
++ &wwslog('info',"d_set_owner : cannot set owner of a full directory");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'full_directory','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ## End of controls
++
++ my %desc_hash;
++
++ if (-e "$desc_file"){
++ # if description file already exists : open it and modify it
++ %desc_hash = &get_desc_file ("$desc_file");
++
++ # Synchronization
++ unless (&synchronize($desc_file,$in{'serial'})) {
++
++ &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
++ &wwslog('info',"d_set_owner : Synchronization failed for $desc_file");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'synchro_failed','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ unless (open DESC,">$desc_file") {
++ &wwslog('info',"d_set_owner : cannot open $desc_file : $!");
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # information not modified
++ print DESC "title\n $desc_hash{'title'}\n\n";
++
++ print DESC "access\n read $desc_hash{'read'}\n";
++ print DESC " edit $desc_hash{'edit'}\n\n";
++ print DESC "creation\n";
++ # time
++ print DESC " date_epoch $desc_hash{'date'}\n";
++
++ #information modified
++ # author
++ print DESC " email $in{'content'}\n\n";
++
++ close DESC;
++
++ } else {
++ # Creation of a description file
++ unless (open (DESC,">$desc_file")) {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info',"d_set_owner : Cannot create description file $desc_file : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ print DESC "title\n $desc_hash{'title'}\n\n";
++ my @info = stat "$shareddir/$path";
++ print DESC "creation\n date_epoch ".$info[10]."\n email $in{'content'}\n\n";
++
++ print DESC "access\n read $access{'scenario'}{'read'}\n";
++ print DESC " edit $access{'scenario'}{'edit'}\n\n";
++
++ close DESC;
++
++ }
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ ## ONLY IF SET_OWNER can be performed even if not control of the father directory
++ $mode{'control'} = 1;
++ my %access = &d_access_control(\%mode,$path);
++ unless ($access{'may'}{'control'}) {
++ ## father directory
++ $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
++ $in{'path'} = &no_slash_end($1);
++ return 'd_read';
++ }
++
++ ## ELSE
++ return 'd_control';
++ }
++
++ ## Protecting archives from Email Sniffers
++ sub do_arc_protect {
++ &wwslog('info', 'do_arc_protect()');
++
++ return 1;
++ }
++
++####################################################
++# do_remind
++####################################################
++# Sends a remind command to sympa.pl.
++#
++# IN : -
++#
++# OUT : 'loginrequest' | 'admin' | undef
++#
++#####################################################
++ sub do_remind {
++ &wwslog('info', 'do_remind()');
++
++ ## Access control
++ return undef unless (defined &check_authz('do_remind', 'remind'));
++
++ my $extention = time.".".int(rand 9999) ;
++ my $mail_command;
++
++ ## Sympa will require a confirmation
++ my $result = $list->check_list_authz('remind','smtp',
++ {'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $r_action;
++ my $reason;
++ if (ref($result) eq 'HASH') {
++ $r_action = $result->{'action'};
++ $reason = $result->{'reason'};
++ }
++
++ if ($r_action =~ /reject/i) {
++ &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
++ &wwslog('info','remind : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++
++ }else {
++ $mail_command = sprintf "REMIND %s", $param->{'list'};
++ }
++
++ my $time = time;
++ my $data = {'headers' => {'Message-ID' => '<'.$time.'@wwsympa>',
++ 'X-Sympa-NoWrap' => 'yes'},
++ 'from'=> $param->{'user'}{'email'},
++ 'body' => $mail_command};
++
++ $data->{'not_auto_submitted'} = 1;
++ unless (&mail::mail_file('',&Conf::get_robot_conf($robot, 'sympa'),$data,$robot)) {
++ &report::reject_report_web('intern','cannot_send_remind',{'from' => $param->{'user'}{'email'},'listname'=>$list->{'name'}},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_remind: failed to send message for command REMIND');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ &report::notice_report_web('performed_soon',{},$param->{'action'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 'admin';
++ }
++
++ ## Load list certificat
++ sub do_load_cert {
++ &wwslog('info','do_load_cert(%s)', $param->{'list'});
++
++ my @cert = $list->get_cert('der');
++ unless (@cert) {
++ &report::reject_report_web('user','missing_cert',{},$param->{'action'},$list);
++ &wwslog('info','do_load_cert: no cert for this list');
++ return undef;
++ }
++
++ # don't you just HATE it when every single browser seems to want a
++ # different content-type for certificates? order is important, as
++ # everybody calls themselves "mozilla", and opera identifies as
++ # IE if told so (but Opera doesn't do S/MIME anyways, it seems)
++ my ($ua, $ct) = ($ENV{HTTP_USER_AGENT}, 'application/x-x509-email-cert');
++ if ($ua =~ /MSIE/) {
++ $ct = 'application/pkix-cert';
++ }
++ $param->{'bypass'} = 'extreme';
++ printf "Content-type: $ct\n\n";
++ foreach my $l (@cert) {
++ printf "$l";
++ }
++ return 1;
++ }
++
++
++#*******************************************
++# Function : do_upload_pictures
++# Description : Creates a new pictures with a
++# uploaded file
++#******************************************
++
++sub do_upload_pictures {
++ # Parameters of the uploaded file (from suboptions.tt2)
++ my $fn = $query->param('uploaded_file');
++ &wwslog('info', 'do_upload_pictures(%s,%s)',$fn,$param->{'user'}{'email'});
++
++ # name of the file, without path
++ my $fname;
++ if ($fn =~ /([^\/\\]+)$/) {
++ $fname = $1;
++ }
++
++ # type of the file
++ my $filetype;
++ if ($fn =~ /\.(jpg|jpeg|png|gif)$/i) {
++ $filetype = $1;
++ }
++ else {$filetype = undef};
++
++ my $filename = &tools::md5_fingerprint($param->{'user'}{'email'});
++ my $fullfilename = $filename.'.'.$filetype;
++
++ #uploaded file must have a name
++ unless ($fname) {
++ &report::reject_report_web('user','no_name',{},$param->{'action'});
++ &wwslog('err',"do_upload_pictures : No file specified to upload");
++ return 'suboptions';
++ }
++
++ unless($filetype) {
++ &report::reject_report_web('user','cannot_upload',{'path' => $fullfilename,
++ 'reason' => "your file does not have an authorized format." },$param->{'action'});
++ &wwslog('err',"do_upload_pictures : unauthorized format");
++ return 'suboptions';
++ }
++
++ my $filetmp;
++
++ #check if there is not already a file for the user with a different extension
++ foreach my $ext ('.gif','.png','.jpg','.jpeg') {
++ my $file = &Conf::get_robot_conf($robot,'pictures_path').'/'.$in{'list'}.'@'.$robot.'/'.$filename;
++ if(-f $file.$ext) {
++ rename($file.$ext,$file.$ext.'.tmp');
++ $filetmp = $file.$ext;
++ last;
++ }
++ }
++
++ unless(&creation_picture_file(&Conf::get_robot_conf($robot,'pictures_path'),$param->{'list'}.'@'.$robot,$fullfilename)) {
++ &report::reject_report_web('user','upload_failed', {'path' => $fullfilename},$param->{'action'});
++ &wwslog('err','do_upload_pictures : Failed to create file %s/%s@%s%s',&Conf::get_robot_conf($robot,'pictures_path'),$param->{'list'},$robot,$filename);
++ return 'suboptions';
++ }
++ my $uploadedfile = &Conf::get_robot_conf($robot,'pictures_path').'/'.$in{'list'}.'@'.$robot.'/'.$fullfilename;
++ my @info = stat($uploadedfile);
++ my $size = $info[7];
++
++ unless($size <= $Conf{'pictures_max_size'}) {
++ unlink($uploadedfile);
++ rename($filetmp.'.tmp',$filetmp);
++ &report::reject_report_web('user','cannot_upload',{'path' => $fullfilename,
++ 'reason' => "Your file exceeds the authorized size." },$param->{'action'});
++ &wwslog('err',"do_upload_pictures : Failed to upload pictures");
++ return 'suboptions';
++ }
++
++ # message of success
++ unlink($filetmp.'.tmp');
++ &wwslog('info',"do_upload_pictures : Upload of the pictures succeeded");
++ return 'suboptions';
++
++}
++
++## Delete a picture file
++sub do_delete_pictures {
++ &wwslog('info', 'do_delete_pictures(%s,%s,%s)', $param->{'list'},$robot,$param->{'user'}{'email'});
++
++ my $email = $param->{'user'}{'email'};
++
++ #deleted file must exist
++ unless(&tools::pictures_filename('email' => $email, 'list' => $list)) {
++ &report::reject_report_web('user','no_name',{},$param->{'action'},$list);
++ &wwslog('err',"do_delete_pictures : No file exists to delete");
++ return 'suboptions';
++ }
++
++ unless($list->delete_user_picture($email)) {
++ &report::reject_report_web('intern','erase_file',{'file' => &tools::pictures_filename('email' => $email, 'list' => $list)},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"do_delete_pictures : Failed to erase ".&tools::pictures_filename('email' => $email, 'list' => $list));
++ return undef;
++ }
++ else {
++ &wwslog('notice',"do_delete_pictures : File deleted successfull");
++ return 'suboptions';
++ }
++}
++
++
++####################################################
++# do_change_email_request
++####################################################
++# Checks a user's new email address and passes it
++# to 'change_email'
++#
++# IN : -
++#
++# OUT : '1' | 'change_email'
++#
++####################################################
++## Checks a users new email address by sending a ticket to the new email address
++## and demanding that they click it to verify. Leads to 'change_email'
++sub do_change_email_request {
++ &wwslog('info','do_change_email_request(%s)', $in{'new_email'});
++
++ unless ($param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'new_email'},$robot,'change_email/'.$param->{'user'}{'email'},$ip)){
++
++ &do_log('notice',"Unable to create one_time_ticket for $in{'new_email'}, service do_change_email_request");
++ }else{
++ &do_log('notice',"ticket : $param->{'one_time_ticket'}");
++ }
++
++ $param->{'new_email'} = $in{'new_email'};
++ my $tt2_param = {'type' => 'ticket_to_send',
++ 'one_time_ticket' => $param->{'one_time_ticket'},
++ 'to' => $in{'new_email'},
++ };
++ unless (&List::send_global_file('user_notification', $in{'new_email'}, $robot, $tt2_param)) {
++ &do_log('notice',"Unable to send template 'user_notification' to $in{'new_email'}");
++ return undef;
++ }
++ return '1';
++}
++
++
++
++####################################################
++# do_change_email
++####################################################
++# Changes a user's email address in Sympa environment
++#
++# IN : -
++#
++# OUT : '1' | 'pref' | undef
++#
++####################################################
++## Change a user's email address in Sympa environment
++sub do_change_email {
++ &wwslog('info','do_change_email(%s)', $in{'email'});
++
++ my ($old_email, $new_email);
++ my $edited_by_listmaster;
++
++ unless ($in{'email'} || ($in{'old_email'} && $in{'new_email'})) {
++ &report::reject_report_web('user','Missing argument',{},$param->{'action'});
++ &wwslog('err',"Lacking parameter : $in{'email'} or $in{'old_email'} or $in{'new_email'} ");
++ &web_db_log({'parameters' => $in{'email'},$in{'old_email'},$in{'new_email'},
++ 'status' => 'error',
++ 'error_type' => 'user'});
++ }
++
++ ## There are two ways to access this function 'change_email'. One from the preferences page and one from the serveradmin page
++ ## If the process comes from server admin it needs the variables 'old_email' and 'new_email'.
++ if ($in{'old_email'} && $in{'new_email'}) {
++ ## if variables old_email and new_email are present $edited_by_listmaster is set to one
++ ## so that at the end of the function we can return to the SympaAdmin page
++ ## instead of the preferences page
++ $edited_by_listmaster = 1;
++ unless (&List::is_listmaster ($param->{'user'}{'email'}, $robot)) {
++ &report::reject_report_web('auth','User is not Listmaster',{},$param->{'action'});
++ &wwslog('err','do_change_email : not listmaster');
++ &web_db_log({'parameters' => $in{'email'},
++ 'status' => 'error',
++ 'error_type' => 'authorization'});
++ return undef;
++ }
++
++ $old_email = $in{'old_email'};
++ $new_email = $in{'new_email'};
++ }else {
++ $old_email = $in{'email'};
++ $new_email = $param->{'user'}{'email'};
++ }
++
++ my ($password, $newuser);
++
++ if ($newuser = &List::get_user_db($old_email)) {
++
++ $password = $newuser->{'password'};
++ }
++
++ ## Change email as list MEMBER
++ foreach my $list ( &List::get_which($old_email,$robot, 'member') ) {
++
++
++ my $l = $list->{'name'};
++
++ my $user_entry = $list->get_subscriber($old_email);
++ if ($user_entry->{'included'} == 1) {
++ ## Notify list owner
++ $list->send_notify_to_owner('failed_to_change_included_member',{'current_email' => $old_email,
++ 'new_email' => $new_email,
++ 'datasource' => $list->get_datasource_name($user_entry->{'id'})});
++
++ &report::reject_report_web('user','change_member_email_failed_included',{'listname'=>$list->{'name'}},
++ $param->{'action'},$list,$old_email,$robot);
++ &wwslog('err', 'could not change member email for list %s because member is included', $l);
++ next;
++ }
++
++ ## Check if user is already member of the list with his new address
++ ## then we just need to remove the old address
++ if ($list->is_user($new_email)) {
++ unless ($list->delete_user('users' => [$old_email]) ) {
++ &report::reject_report_web('intern','delete_subscriber_db_failed',{'sub'=>$new_email},
++ $param->{'action'},$list,$old_email,$robot);
++ &wwslog('info', 'do_change_email: could not remove email from list %s', $l);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$new_email",'target_email' => "$new_email",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $old_email,'client' => $ip,'daemon' => $daemon_name});
++ }
++
++ }else {
++
++ unless ($list->update_user($old_email, {'email' => $new_email, 'update_date' => time}) ) {
++ &report::reject_report_web('intern','update_subscriber_db_failed',{'sub'=>$new_email},
++ 'old_email' => $old_email,
++ $param->{'action'},$list,$old_email,$robot);
++ &wwslog('info', 'do_change_email: could not change email for list %s', $l);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$new_email",'target_email' => "$new_email",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $old_email,'client' => $ip,'daemon' => $daemon_name});
++ }
++ }
++ }
++
++ &report::notice_report_web('performed',{},$param->{'action'});
++
++ ## Change email as list OWNER/MODERATOR
++ my %updated_lists;
++ foreach my $role ('owner', 'editor') {
++ foreach my $list ( &List::get_which($old_email,$robot, $role) ) {
++
++ ## Check if admin is include via an external datasource
++ my $admin_user = $list->get_admin_user($role, $old_email);
++ if ($admin_user->{'included'}) {
++ ## Notify listmaster
++ &List::send_notify_to_listmaster('failed_to_change_included_admin',$robot,{'list' => $list,
++ 'current_email' => $old_email,
++ 'new_email' => $new_email,
++ 'datasource' => $list->get_datasource_name($admin_user->{'id'})});
++
++ &report::reject_report_web('user','change_admin_email_failed_included',{'listname'=>$list->{'name'}},
++ $param->{'action'},$list,$old_email,$robot);
++ &wwslog('err', 'could not change %s email for list %s because admin is included', $role, $list->{'name'});
++ next;
++ }
++
++ ## Go through owners/editors of the list
++ foreach my $admin (@{$list->{'admin'}{$role}}) {
++ next unless (lc($admin->{'email'}) eq lc($old_email));
++
++ ## Update entry with new email address
++ $admin->{'email'} = $new_email;
++ $updated_lists{$list->{'name'}}++;
++ }
++
++ ## Update Db cache for the list
++ $list->sync_include_admin();
++ $list->save_config();
++ }
++ }
++ ## Notify listmasters that list owners/moderators email have changed
++ if (keys %updated_lists) {
++ &List::send_notify_to_listmaster('listowner_email_changed',$robot,
++ {'list' => $list,
++ 'previous_email' => $old_email,
++ 'new_email' => $new_email,
++ 'updated_lists' => keys %updated_lists})
++ }
++
++ ## Update User_table and remove existing entry first (to avoid duplicate entries)
++ &List::delete_user_db($new_email,);
++
++ unless ( &List::update_user_db($old_email,
++ {'email' => $new_email,
++
++ })) {
++ &report::reject_report_web('intern','update_user_db_failed',{'user'=>$new_email,
++ 'old_email' => $old_email},
++ $param->{'action'},'',$old_email,$robot);
++ &wwslog('info','change_email: update failed');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$new_email",'target_email' => "$new_email",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $old_email,'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ## Update netidmap_table
++ unless ( &List::update_email_netidmap_db($robot, $old_email, $new_email) ){
++ &report::reject_report_web('intern','update_netidmap_failed',{'user'=>$new_email,
++ 'old_email' => $old_email},
++ $param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','change_email: update failed');
++ &web_db_log({'target_email' => $old_email,
++ 'status' => 'error',
++ 'error_type' => 'internal'});
++ return undef;
++ }
++
++ ## Update the data structure that tells which lists the current user is member/owner/editor of
++ unless ($edited_by_listmaster == 1) {
++ @{$param->{'get_which'}} = &List::get_which($param->{'user'}{'email'},$robot,'member');
++ @{$param->{'get_which_owner'}} = &List::get_which($param->{'user'}{'email'},$robot,'owner');
++ @{$param->{'get_which_editor'}} = &List::get_which($param->{'user'}{'email'},$robot,'editor');
++ }
++
++ if ($edited_by_listmaster == 1) {
++ return 'serveradmin';
++ }
++
++
++ if ($in{'previous_action'}) {
++ $in{'list'} = $in{'previous_list'};
++ return $in{'previous_action'};
++ }elsif ($edited_by_listmaster == 1) {
++ return 'serveradmin';
++ }
++
++ return 'pref';
++
++ }
++
++####################################################
++# do_suspend_request
++####################################################
++# Suspend a subscription to one or more lists #
++# for a given period: start date and end date #
++# (or unlimited). The user may at any time #
++# stop the suspension. #
++# #
++# IN : - #
++# OUT : 'loginrequest' #
++# | 'info' | undef #
++# #
++####################################################
++sub do_suspend_request {
++
++ &wwslog('info', 'do_suspend_request', $in{'action'}); #Action = suspend_request
++ my $email = $param->{'user'}{'email'};
++ my $data;
++
++ ## Sets the date of the field "start date" to "today"
++ my @d_day = localtime(time);
++ $param->{'d_day'} = ($d_day[3])."-".($d_day[4]+1)."-".($d_day[5]+1900);
++ my $display_resume = 0;
++
++ ## We display in the table the lists of the subscriber and the state in which they are.
++ ## reception : - nomail/digest/mail ||
++ ## - . suspended From XX/XX/XXXX To XX/XX/XXXX
++ my @lists = &List::get_which($email, $robot, 'member');
++
++ foreach my $list (@lists) {
++ my $member_info = $list->get_subscriber($param->{'user'}{'email'});
++ if(($member_info->{'enddate'} < time) && ($member_info->{'enddate'})){
++ ## If end date is < time, update the BDD by deleting the suspending's data
++ &List::restore_suspended_subscription($param->{'user'}{'email'},$list->{'name'},$list->{'domain'});
++ }
++ my $final_start_date = gettext_strftime "%d %b %Y", localtime($member_info->{'startdate'});
++ my $final_end_date;
++
++ if($member_info->{'suspend'} == 1){
++ $display_resume = 1;
++ }
++ if($member_info->{'enddate'}){
++ $final_end_date = gettext_strftime "%d %b %Y", localtime($member_info->{'enddate'});
++ }else{
++ $final_end_date = undef;
++ }
++
++ $member_info->{'reception'} ||= 'mail';
++ $member_info->{'visibility'} ||= 'noconceal';
++ foreach my $mode (keys %wwslib::reception_mode) {
++ if ($list->is_available_reception_mode($mode)) {
++ $param->{'reception'}{$list->{'name'}}{$mode}{'description'} = sprintf(gettext($wwslib::reception_mode{$mode}->{'gettext_id'}));
++ if ($member_info->{'reception'} eq $mode) {
++ $param->{'reception'}{$list->{'name'}}{$mode}{'selected'} = 'selected="selected"';
++ }else {
++ $param->{'reception'}{$list->{'name'}}{$mode}{'selected'} = '';
++ }
++ }
++ }
++
++ my $subscription = {'listname' => $list->{'name'},
++ 'listdomain' => $list->{'domain'},
++ 'listreception' => $member_info->{'reception'},
++ 'listsuspend' => $member_info->{'suspend'},
++ 'liststartdate' =>$final_start_date,
++ 'listenddate' => $final_end_date,
++ 'display' => $display_resume,
++ 'visibility' => $member_info->{'visibility'},
++ 'reception' => $param->{'reception'}{$list->{'name'}},
++ };
++ push @{$param->{'suspend_list'}}, $subscription;
++ }
++
++ return 1;
++}
++
++####################################################
++# do_suspend_request_action
++####################################################
++# Suspend a subscription for lists. #
++# Action from the suspend form. #
++# #
++# IN : %in : HASH with the form's values #
++# OUT : 'pref' : action #
++# | 'info' | undef #
++####################################################
++sub do_suspend_request_action {
++
++ &wwslog('info', 'do_suspend_request_action', $in{'action'});
++
++ my $day1;
++ my $month1;
++ my $year1;
++ my $day2;
++ my $month2;
++ my $year2;
++ my @lists;
++ my $data;
++
++ if($in{'sub_action'} eq 'suspendsave'){
++
++ # to retrieve the selected list
++ @lists = split /\0/, $in{'listname'};
++ my @list_selected;
++ foreach my $list (@lists){
++ unless($list eq ''){
++ push @list_selected, $list;
++ }
++ }
++
++ if($list_selected[0] eq ''){
++ &report::reject_report_web('user','missing_arg',{'argument' => 'must picked one or more list(s) you are subscribed'}, $param->{'action'});
++ &wwslog('info','suspend_request: must picked one or more list(s) you are subscribed');
++ return 'suspend_request';
++ }
++
++ if ($in{'date_deb'}){
++ ($day1, $month1, $year1) = split(/\-/, $in{'date_deb'});
++ $month1 = $month1-1;
++
++ if (($day1 =~ /([0-9]*)/) && ($month1 =~ /([0-9]*)/) && ($year1 =~ /([0-9]*)/)){
++ if (((1<=$day1) && ($day1<=31)) && ((0<=$month1) && ($month1<=11)) && (1900<=$year1)){
++ ## Return an epoch date
++ $data->{'startdate'} = timelocal(0, 0, 0, $day1,$month1,$year1);
++ }else{
++ &report::reject_report_web('user','missing_arg',{'argument' => 'Start Date doesn\'t exist.'}, $param->{'action'});
++ &wwslog('info','suspend_request: Date doesn\'t exist.');
++ return 'suspend_request';
++ }
++ }else{
++ &report::reject_report_web('user','missing_arg',{'argument' => 'Start Date doesn\'t exist.'}, $param->{'action'});
++ &wwslog('info','suspend_request: Date doesn\'t exist.');
++ return 'suspend_request';
++ }
++ ## Case 1 : Start date & End date (without indefinite)
++ if (($in{'date_fin'}) && (!$in{'indefinite'})){
++ ($day2, $month2, $year2) = split(/\-/, $in{'date_fin'});
++ $month2 = $month2-1;
++
++ if (($day2 =~ /([0-9]*)/) && ($month2 =~ /([0-9]*)/) && ($year2 =~ /([0-9]*)/)){
++ if (((1<=$day2) && ($day2<=31)) && ((0<=$month2) && ($month2<=11)) && (1900<=$year2)){
++ ## Return an epoch date
++ $data->{'enddate'} = timelocal(0, 0, 0, $day2,$month2,$year2);
++ }else{
++ &report::reject_report_web('user','missing_arg',{'argument' => 'End Date doesn\'t exist.'}, $param->{'action'});
++ &wwslog('info','suspend_request: Date doesn\'t exist.');
++ return 'suspend_request';
++ }
++ }else{
++ &report::reject_report_web('user','missing_arg',{'argument' => 'End Date doesn\'t exist.'}, $param->{'action'});
++ &wwslog('info','suspend_request: Date doesn\'t exist.');
++ return 'suspend_request';
++ }
++
++ unless($data->{'startdate'} <= $data->{'enddate'}){
++ &report::reject_report_web('user','missing_arg',{'argument' => 'The start date must be less than the end date.'}, $param->{'action'});
++ &wwslog('info','suspend_request: The start date must be less than the end date.');
++ return 'suspend_request';
++ }
++ ## Case 2 : Start date & without indefinite (without end date)
++ }elsif((!$in{'date_fin'}) && ($in{'indefinite'})){
++ $data->{'enddate'} = undef;
++ }else{
++ &report::reject_report_web('user','missing_arg',{'argument' => 'Choose end date (dd/mm/yyyy) or indefinite end date'}, $param->{'action'});
++ &wwslog('info','suspend_request: missing argument for the end date or syntax error : dd/mm/yyyy or must choose a end date or indefinite end date');
++ return 'suspend_request';
++ }
++ }else{
++ &report::reject_report_web('user','missing_arg',{'argument' => 'Miss start date (dd/mm/yyyy)'}, $param->{'action'});
++ &wwslog('info','suspend_request: missing argument for the start date or syntax error : dd/mm/yyyy');
++ return 'suspend_request';
++ }
++
++ ## Suspend subscription
++ foreach my $list (@list_selected){
++ unless(&List::suspend_subscription($param->{'user'}{'email'}, $list, $data, $robot)){
++ &wwslog('info','Can\'t do List suspend_subscription');
++ return 'suspend_request';
++ }
++ }
++
++ &report::notice_report_web('performed',{},$in{'sub_action'});
++ }
++ ## Restore suspended subscription
++ elsif($in{'sub_action'} eq 'suspendstop'){
++
++ # to renew membership lists selected
++ @lists = split /\0/, $in{'listname'};
++ foreach my $line (@lists) {
++ &List::restore_suspended_subscription($param->{'user'}{'email'}, $line, $robot);
++ }
++
++ if($lists[0] eq ''){
++ &report::reject_report_web('user','missing_arg',{'argument' => 'must picked one or more list(s)'}, $param->{'action'});
++ &wwslog('info','suspend_request: must picked one or more list(s)');
++ return 'suspend_request';
++ }
++ &report::notice_report_web('performed',{},"Resume the subscription for the list(s)");
++
++ }
++ ## Unsubscribe from the selected lists
++ elsif($in{'sub_action'} eq 'signoff'){
++
++ # lists selected
++ @lists = split /\0/, $in{'listname'};
++ my $report = "";
++ foreach my $line (@lists) {
++
++ my $unsub_list = new List ($line, $robot);
++ unless ($unsub_list) {
++ &wwslog('info', 'List %s unknown' , $unsub_list);
++ return undef;
++ }
++
++ my %result = &unsubscribe($param->{'user'}{'email'}, $unsub_list);
++ if ($result{'success'} == 1) {
++ if ($result{'details'} eq 'sent_to_owner') {
++ $report .= sprintf(gettext("Your unsubscription request to list %s was sent to the list owner."),$unsub_list->{'name'});
++ }else{
++ $report .= sprintf(gettext("You were successfully unsubscribed from list %s."),$unsub_list->{'name'});
++ }
++ }else{
++ if ($result{'category_error'} eq 'auth') {
++ $report .= sprintf(gettext("Unsubscription from list %s denied: Unsubscription from this list is closed."),$unsub_list->{'name'});
++ }else{
++ $report .= sprintf(gettext("Unsubscription from list %s failed."),$unsub_list->{'name'});
++ }
++ }
++ $report .= "\n";
++
++ }
++ if($lists[0] eq ''){
++ &report::reject_report_web('user','missing_arg',{'argument' => 'must picked one or more list(s)'}, $param->{'action'});
++ &wwslog('info','suspend_request: must picked one or more list(s)');
++ return 'suspend_request';
++ }
++
++ &report::notice_report_web($report,{},'');
++ }else{
++ &report::reject_report_web('user','unknown_action',{},$in{'sub_action'},$list);
++ &wwslog('info','unknown action %s', $in{'sub_action'});
++ return undef;
++ }
++
++ return 'suspend_request';
++}
++
++####################################################
++# do_compose_mail
++####################################################
++sub do_compose_mail {
++
++ &wwslog('info', 'do_compose_mail', $in{'subaction'});
++
++ unless ($param->{'may_post'}) {
++ &report::reject_report_web('auth',$param->{'may_post_reason'},{},$param->{'action'},$list);
++ &wwslog('info','do_compose_mail: may not send message');
++ return undef;
++ }
++
++ # Set the subaction to html_news_letter or undef
++ $param->{'subaction'} = $in{'subaction'};
++ if ($in{'to'}) {
++ # In archive we hide email replacing @ by ' '. Here we must do the reverse transformation
++ $in{'to'} =~ s/ /\@/g;
++ $param->{'to'} = $in{'to'};
++ }else{
++ $param->{'to'} = $list->get_list_address();
++ }
++ foreach my $recipient (split(',',$param->{'to'})) {
++ ($param->{'recipients'}{$recipient}{'local_to'},$param->{'recipients'}{$recipient}{'domain_to'}) = split ('@',$recipient);
++ }
++ $param->{'mailto'}= &mailto($list,$param->{'to'});
++ # headers will be encoded later.
++ #XXX$param->{'subject'}= &MIME::Words::encode_mimewords($in{'subject'});
++ $param->{'subject'} = $in{'subject'};
++ $param->{'in_reply_to'}= '<'.$in{'in_reply_to'}.'>';
++ $param->{'message_id'} = &tools::get_message_id($robot);
++
++ if ($list->is_there_msg_topic()) {
++
++ $param->{'request_topic'} = 1;
++
++ foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
++ if ($top->{'name'}) {
++ push (@{$param->{'available_topics'}},$top);
++ }
++ }
++ $param->{'topic_required'} = $list->is_msg_topic_tagging_required();
++ }
++
++ return 1;
++ }
++
++####################################################
++# do_send_mail
++####################################################
++# Sends a message to a list by the Web interface
++# or an html page getting its url.
++# Need MIME::Lite - MIME::Lite::HTML - EMAIL::DATE::FORMAT
++# It uses mail::mail_file() to do it.
++#
++# IN : -
++#
++# OUT : 'loginrequest'
++# | 'info' | undef
++#
++####################################################
++ sub do_send_mail {
++
++ &wwslog('info', 'do_send_mail');
++
++ # Get the sender mail
++ my $from = $param->{'user'}{'email'};
++ my $to;
++ # Send the message to the list or to the sender as clicking the send to the list or to me.
++ # First if : send to the list
++ if ($in{'sub_action'} eq 'sendmailtolist'){
++
++ # In archive we hide email replacing @ by ' '. Here we must do the reverse transformation
++ $in{'to'} =~ s/ /\@/g;
++ $to = $in{'to'};
++
++ unless ($in{'to'}) {
++ unless ($param->{'list'}) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
++ &wwslog('info','do_send_mail: no list');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_list','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ unless ($param->{'may_post'}) {
++ &report::reject_report_web('auth',$param->{'may_post_reason'},{},$param->{'action'},$list);
++ &wwslog('info','do_send_mail: may not send message');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ $to = $list->get_list_address();
++ }
++ }
++
++ # Send the mail to the sender. To test his message
++ # Second if : send to the sender "send to me"
++ if($in{'sub_action'} eq 'sendmailtome') {
++ #Set the sender mail to the addressee
++ $to = $from;
++ }
++
++ if (defined $param->{'subscriber'}) {
++ $from = &tools::addrencode($from, $param->{'subscriber'}{'gecos'},
++ &Language::GetCharset());
++ }
++
++ ##--------------- TOPICS --------------------
++ my $list_topics;
++ if ($list->is_there_msg_topic()) {
++ my @msg_topics;
++
++ foreach my $msg_topic (@{$list->{'admin'}{'msg_topic'}}) {
++ my $var_name = "topic_"."$msg_topic->{'name'}";
++ if ($in{"$var_name"}) {
++ push @msg_topics, $msg_topic->{'name'};
++ }
++ }
++
++ $list_topics = join(',',@msg_topics);
++ }
++
++ if (!$list_topics && $list->is_msg_topic_tagging_required()) {
++ &report::reject_report_web('user','msg_topic_missing',{},$param->{'action'});
++ &wwslog('info','do_send_mail: message(s) without topic but in a required list');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_topic','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ if ($list_topics) {
++ my $filetopic = $list->tag_topic($in{'message_id'},$list_topics,'sender');
++ }
++
++ ##--------------- send an html page or a message --------------------
++
++ if ($in{'html_news_letter'}) {
++
++ # url should not be empty -> missing argument
++ if ($in{'url'} =~ /^\s*$/) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'url'},$param->{'action'});
++ ($Log::log_level >= 0) && &wwslog('info','Missing url');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_url','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ # Generate a newsletter from an HTML URL and send it to a list by the Web interface.
++ # Else you must use parse routine of MIME::Lite::HTML and send of MIME::Lite.
++ my $mailHTML = new MIME::Lite::HTML(
++ {
++ From => $from,
++ To => $to,
++ Headers => {'In-Reply-To' => $in{'in_reply_to'}, 'Message-ID' => $in{'message_id'}},
++ 'return_path' => &Conf::get_robot_conf($robot, 'sympa'),
++ Subject => $in{'subject'},
++ HTMLCharset => 'utf-8',
++ TextCharset => 'utf-8',
++ TextEncoding => '8bit',
++ HTMLEncoding => '8bit',
++ remove_jscript => '1', #delete the scripts in the html
++ }
++ );
++ my $pages_url;
++ $pages_url = $in{'url'};
++
++ # parse return the MIME::Lite part to send
++ my $MIMEmail = $mailHTML->parse($pages_url);
++
++ $in{'body'} = $MIMEmail->as_string;
++
++ }else{
++
++ ## Message body should not be empty
++ if ($in{'body'} =~ /^\s*$/) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'body'},$param->{'action'});
++ ($Log::log_level >= 0) && &wwslog('info','Missing body');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_body','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ $in{'body'} = "\n".$in{'body'};
++ }
++
++ my $data = {'headers' => {'Message-ID' => $in{'message_id'}},
++ 'subject' => $in{'subject'},
++ 'return_path' => &Conf::get_robot_conf($robot, 'sympa'),
++ 'to' => $to,
++ 'body' => "From: $from\n" . $in{'body'},
++ 'sign_mode' => '',
++ 'header_possible' => '1'};
++
++ $data->{'headers'}{'In-Reply-To'} = $in{'in_reply_to'} if (($in{'in_reply_to'}) && $in{'in_reply_to'} ne '<>');
++ $data->{'not_auto_submitted'} = 1;
++ unless (&mail::mail_file('', $to, $data, $robot)) {
++ &report::reject_report_web('intern','cannot_send_mail',{'from' => $param->{'user'}{'email'},'listname'=>$list->{'name'}},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_send_mail: failed to send message for $to list');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++
++ &report::notice_report_web('performed',{},$param->{'action'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 'info';
++
++ }
++
++####################################################
++# do_request_topic
++####################################################
++# Web page for a sender to tag his mail in message
++# topic context.
++#
++# IN : -
++#
++# OUT : '1' | 'loginrequest' | undef
++#
++####################################################
++ sub do_request_topic {
++ &wwslog('info', 'do_request_topic(%s)', $in{'authkey'});
++
++ unless ($list->is_there_msg_topic()) {
++ &report::reject_report_web('user','no_topic',{},$param->{'action'},$list);
++ &wwslog('info','do_request_topic: list without topic message');
++ return undef;
++ }
++
++ foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
++ if ($top->{'name'}) {
++ push (@{$param->{'available_topics'}},$top);
++ }
++ }
++
++ $param->{'to'} = $list->get_list_address();
++ $param->{'mailto'}= &mailto($list,$param->{'to'});
++ $param->{'authkey'} = $in{'authkey'};
++
++ my $listname = $list->{'name'};
++ my $authqueue = &Conf::get_robot_conf($robot,'queueauth');
++ my $filename = "$authqueue\/$listname\_$in{'authkey'}";
++
++ ## For compatibility concerns
++ foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
++ $filename = $authqueue.'/'.$list_id.'_'.$in{'authkey'};
++ last if (-f $filename);
++ }
++
++ my $parser;
++ unless ($parser = new MIME::Parser) {
++ &report::reject_report_web('intern','cannot_parse_message',{'file' => $filename},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('notice', 'Cannot parse message %s', $filename);
++ return undef;
++ }
++ $parser->output_to_core(1);
++
++ unless (open FILE, "$filename") {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $filename},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('notice', 'Cannot open file %s', $filename);
++ return undef;
++ }
++ my $msg = $parser->parse(\*FILE);
++ my $head = $msg->head();
++ # headers will be encoded later.
++ #XXX$param->{'subject'}= &MIME::Words::encode_mimewords($head->get('subject'));
++ $param->{'subject'} = MIME::EncWords::decode_mimewords($head->get('subject'), Charset=>'utf8');
++ chomp $param->{'subject'};
++ $param->{'subject'} = &tools::escape_html($param->{'subject'});
++ $param->{'from'} = MIME::EncWords::decode_mimewords($head->get('from'), Charset=>'utf8');
++ chomp $param->{'from'};
++ $param->{'from'} = &tools::escape_html($param->{'from'});
++ $param->{'date'} = MIME::EncWords::decode_mimewords($head->get('date'), Charset=>'utf8');
++ chomp $param->{'date'};
++ $param->{'date'} = &tools::escape_html($param->{'date'});
++ $param->{'message_id'} = &tools::clean_msg_id($head->get('Message-Id'));
++
++ my $body = $msg->bodyhandle();
++ if ($body) {
++ $param->{'body'} = $body->as_string();
++ }else{
++ $param->{'body'} = '';
++ }
++ $param->{'topic_required'} = $list->is_msg_topic_tagging_required();
++
++ return 1;
++ }
++
++####################################################
++# do_tag_topic_by_sender
++####################################################
++# Tag a mail by its sender : tag the mail and
++# send a command CONFIRM for it
++#
++# IN : -
++#
++# OUT : 'loginrequest' | 'info' | undef
++#
++####################################################
++ sub do_tag_topic_by_sender {
++ &wwslog('info', 'do_tag_topic_by_sender');
++
++ my $parser;
++ my $listname = $list->{'name'};
++ my $authqueue = &Conf::get_robot_conf($robot,'queueauth');
++ my $filename = "$authqueue\/$listname".'@'."$robot\_$in{'authkey'}";
++
++ my $mail ;
++ unless($mail = new Message($filename,'noxsympato')) {
++ &report::reject_report_web('intern','cannot_parse_message',{'file' => $filename},$param->{'action'});
++ &wwslog('info','do_tag_topic_by_sender: cannot parse message %s',$filename);
++ return undef;
++ }
++ my $sender = $mail->{'sender'};
++
++ unless ($list->is_there_msg_topic()) {
++ &report::reject_report_web('user','no_topic',{},$param->{'action'},$list);
++ &wwslog('info','do_tag_topic_by_sender: list without topic message');
++ return undef;
++ }
++
++ my @msg_topics;
++ foreach my $msg_topic (@{$list->{'admin'}{'msg_topic'}}) {
++ my $var_name = "topic_"."$msg_topic->{'name'}";
++ if ($in{"$var_name"}) {
++ push @msg_topics, $msg_topic->{'name'};
++ }
++ }
++ my $list_topics = join(',',@msg_topics);
++
++ if (!$list_topics && $list->is_msg_topic_tagging_required()) {
++ &report::reject_report_web('user','msg_topic_missing',{},$param->{'action'},$list);
++ &wwslog('info','do_tag_topic_by_sender: message without topic but in a required list');
++ return undef;
++ }
++
++ ## TAG
++ my $filetopic = $list->tag_topic($in{'message_id'},$list_topics,'sender');
++
++ ## CONFIRM
++ my $time = time;
++ my $data = {'headers' => {'Message-ID' => '<'.$time.'@wwsympa>',
++ 'X-Sympa-NoWrap' => 'yes'},
++ 'from'=> $sender};
++
++ $data->{'body'} = sprintf ("QUIET CONFIRM %s\n",$in{'authkey'});
++
++ my $queueauth = &Conf::get_robot_conf($robot, 'queueauth');
++ my $filemsg = "$queueauth/$list->{'name'}_$in{'authkey'}";
++
++ ## For compatibility concerns
++ foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
++ $filemsg = $queueauth.'/'.$list_id.'_'.$in{'authkey'};
++ last if (-f $filemsg);
++ }
++
++ unless ($filemsg && (-r $filemsg)) {
++ &report::reject_report_web('intern','tag_topic_by_sender_failed',{'key' => $in{'authkey'}},$param->{'action'},$robot);
++ &wwslog('err', 'do_tag_topic_by_sender: Unable to find message %s from %s, auth failed', $in{'authkey'},$param->{'user'}{'email'});
++ return undef;
++ }
++
++ $data->{'not_auto_submitted'} = 1;
++ unless (&mail::mail_file('',&Conf::get_robot_conf($robot, 'sympa'),$data,$robot)) {
++ &report::reject_report_web('intern','cannot_send_mail',{'from' => $param->{'user'}{'email'},'listname'=>$list->{'name'}},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err','do_tag_topic_by_sender: failed to send message for file %s', $filemsg);
++ return undef;
++ }
++
++ &report::notice_report_web('performed_soon',{},$param->{'action'});
++ return 'info';
++ }
++
++
++
++ sub do_search_user {
++ &wwslog('info', 'do_search_user');
++
++ if ($in{'email'} =~ /[<>\\\*\$]/) {
++ &report::reject_report_web('user','syntax_errors',{'params' => 'email'},$param->{'action'});
++ &wwslog('err','do_search_user: syntax error');
++ return undef;
++ }
++
++ foreach my $role ('member','owner','editor') {
++ foreach my $list ( &List::get_which($in{'email'},$robot, $role) ) {
++ my $l = $list->{'name'};
++
++ next unless (defined $list);
++ $param->{'which'}{$l}{'subject'} = $list->{'admin'}{'subject'};
++ $param->{'which'}{$l}{'host'} = $list->{'admin'}{'host'};
++
++ # show the requestor role not the requested one
++ if ( ($list->am_i('owner',$param->{'user'}{'email'}) || $list->am_i('editor',$param->{'user'}{'email'})) ) {
++ $param->{'which'}{$l}{'admin'} = 1;
++ }
++
++ if ($role eq 'member') {
++ $param->{'which'}{$l}{'is_member'} = 1;
++ $param->{'which'}{$l}{'reception'} = $list->{'user'}{'reception'};
++ $param->{'which'}{$l}{'include_source'} = $list->{'user'}{'include_source'};
++ $param->{'which'}{$l}{'bounce'} = $list->{'user'}{'bounce'} ;
++ $param->{'which'}{$l}{'topic'} = $list->{'user'}{'topic'} ;
++ $param->{'which'}{$l}{'included'} = $list->{'user'}{'included'} if ($list->{'user'}{'included'} == 1) ;
++ $param->{'which'}{$l}{'subscribed'} = $list->{'user'}{'subscribed'} if ($list->{'user'}{'subscribed'} == 1);
++ my $un = $list->{'user'}{'subscribed'};
++# $param->{'which'}{$l}{'subscribed'} = 1;
++
++ }elsif ($role eq 'owner') {
++ $param->{'which'}{$l}{'is_owner'} = 1;
++ }elsif ($role eq 'editor') {
++ $param->{'which'}{$l}{'is_editor'} = 1;
++ }
++ }
++ }
++
++ $param->{'email'} = $in{'email'};
++
++ unless (defined $param->{'which'}) {
++ &report::reject_report_web('user','no_entry',{'email' => $in{'email'}},$param->{'action'});
++ &wwslog('info','do_search_user: no entry for %s', $in{'email'});
++ return 'serveradmin';
++ }
++
++ return 1;
++ }
++
++ ## Set language
++ sub do_set_lang {
++ &wwslog('info', 'do_set_lang(%s)', $in{'lang'});
++
++ $session->{'lang'} = $in{'lang'} ;
++ $param->{'lang'} = $in{'lang'};
++
++ if ($param->{'user'}{'email'}) {
++ if (&List::is_user_db($param->{'user'}{'email'})) {
++ unless (&List::update_user_db($param->{'user'}{'email'}, {'lang' => $in{'lang'}})) {
++ &report::reject_report_web('intern','update_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_set_lang: update failed');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'lang'}",'target_email' => "$param->{'user'}{'email'}",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }else {
++ unless (&List::add_user_db({'email' => $param->{'user'}{'email'}, 'lang' => $in{'lang'}})) {
++ &report::reject_report_web('intern','add_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_set_lang: update failed');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'lang'}",'target_email' => "$param->{'user'}{'email'}",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++ }
++
++ if ($in{'previous_action'}) {
++ ## Some actions don't make sense with GET method, redirecting to other functions
++ if ($in{'previous_action'} eq 'arcsearch') {
++ $in{'previous_action'} = 'arc';
++ }
++ $in{'list'} = $in{'previous_list'};
++ return $in{'previous_action'};
++ }
++
++ return 'home';
++ }
++ ## Function do_attach
++ sub do_attach {
++ &wwslog('info', 'do_attach(%s,%s)', $in{'dir'},$in{'file'});
++
++
++ ### Useful variables
++
++ # current list / current shared directory
++ my $list_name = $list->{'name'};
++
++ # path of the urlized directory
++ my $urlizeddir = $list->{'dir'}.'/urlized';
++
++ # document to read
++ my $doc = $urlizeddir.'/'.$in{'dir'}.'/'.$in{'file'};
++
++ ### Document exist ?
++ unless (-e "$doc") {
++ &wwslog('info',"do_attach : unable to read $doc : no such file or directory");
++ &report::reject_report_web('user','no_such_document',{'path' => $in{'dir'}.'/'.$in{'file'}},$param->{'action'},$list);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'dir'},$in{'file'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ### Document has non-size zero?
++ unless (-s "$doc") {
++ &wwslog('info',"do_attach : unable to read $doc : empty document");
++ &report::reject_report_web('user','empty_document',{'path' => $in{'dir'}.'/'.$in{'file'}},$param->{'action'},$list);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'dir'},$in{'file'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'empty_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ## Access control
++ return undef unless (defined &check_authz('do_attach', 'web_archive.access'));
++
++ # parameters for the template file
++ # view a file
++ $param->{'file'} = $doc;
++ $param->{'bypass'} = 'asis';
++
++ ## File type
++ if ($in{'file'} =~ /\.(\w+)$/) {
++ $param->{'file_extension'} = $1;
++ }
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'dir'},$in{'file'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++ sub do_subindex {
++ &wwslog('info', 'do_subindex');
++
++ my $subscriptions = $list->get_subscription_requests();
++ foreach my $sub (keys %{$subscriptions}) {
++ $subscriptions->{$sub}{'date'} = gettext_strftime "%d %b %Y", localtime($subscriptions->{$sub}{'date'});
++ }
++
++ $param->{'subscriptions'} = $subscriptions;
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++ }
++
++ sub do_ignoresub {
++ &wwslog('info', 'do_ignoresub');
++
++ my @users;
++
++ foreach my $pair (split /\0/, $in{'pending_email'}) {
++ if ($pair =~ /,/) {
++ push @users, $`;
++ }
++ }
++
++ foreach my $u (@users) {
++ unless ($list->delete_subscription_request($u)) {
++ &report::reject_report_web('intern','del_sub_request',{'sub'=>$u},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_ignoresub: delete_subscription_request(%s) failed', $u);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 'subindex';
++ }
++ }
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 'subindex';
++ }
++
++sub do_stats {
++ &wwslog('info', 'do_stats');
++
++ $param->{'shared_size'} = int (($list->get_shared_size + 512)/1024);
++ $param->{'arc_size'} = int (($list->get_arc_size($wwsconf->{'arc_path'}) + 512)/1024);
++
++ return 1;
++}
++
++
++## setting the topics list for templates
++sub export_topics {
++
++ my $robot = shift;
++ wwslog ('debug2',"export_topics($robot)");
++ my %topics = &List::load_topics($robot);
++
++ unless (%topics) {
++ &wwslog('err','No topics defined');
++ return undef;
++ }
++
++ ## Remove existing topics
++ $param->{'topics'} = undef;
++
++ my $total = 0;
++ foreach my $t (sort {$topics{$a}{'order'} <=> $topics{$b}{'order'}} keys %topics) {
++ my $result = &Scenario::request_action ('topics_visibility', $param->{'auth_method'},$robot,
++ {'topicname' => $t,
++ 'sender' => $param->{'user'}{'email'},
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $action;
++ $action = $result->{'action'} if (ref($result) eq 'HASH');
++ next unless ($action =~ /do_it/);
++
++ my $current = $topics{$t};
++ $current->{'id'} = $t;
++
++ ## For compatibility reasons
++ $current->{'mod'} = $total % 3;
++ $current->{'mod2'} = $total % 2;
++
++ push @{$param->{'topics'}}, $current;
++
++ $total++;
++ }
++
++ push @{$param->{'topics'}}, {'id' => 'topicsless',
++ 'mod' => $total,
++ 'sub' => {}
++ };
++
++ $param->{'topics'}[int($total / 2)]{'next'} = 1;
++ }
++
++
++# manage blacklist
++sub do_blacklist {
++ &wwslog('info', 'do_blacklist(%d)', $param->{'list'});
++
++ unless ($param->{'list'}){
++ &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
++ &wwslog('info','do_blacklist: no list');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_list','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ unless($param->{'is_owner'}|| $param->{'is_editor'} || $param->{'is_listmaster'}) {
++ &wwslog('info','do_blacklist : not listmaster or list owner or list editor');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ my $file = $list->{'dir'}.'/search_filters/blacklist.txt';
++ $param->{'rows'} = 0 ;
++
++ if (defined $in{'blacklist'}){
++ &wwslog('info','do_blacklist : submit blacklist update');
++ my $dir = $list->{'dir'}.'/search_filters';
++ unless ((-d $dir) || mkdir ($dir, 0755)) {
++ &report::reject_report_web('intern','unable to create dir');
++ &wwslog('info','do_blacklist : unable to create dir %s',$dir);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++ my $file = $dir.'/blacklist.txt';
++ unless (open BLACKLIST, "> $file"){
++ &report::reject_report_web('intern','unable to create file');
++ &wwslog('info','do_blacklist : unable to create file %s',$file);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++ my @lines = split(/\n/, $in{'blacklist'});
++ $param->{'ignored'} = 0;
++ my $count = 0; # count utils lines in order to remove empty blacklist file
++ foreach my $line (@lines) {
++ $line =~ s/\015//;
++
++ if ($line =~ /\*.*\*/) {
++ $param->{'ignored_linest'} .= $line."\n";
++ $param->{'ignored'} += 1;
++ }else{
++ printf BLACKLIST "$line\n";
++ $param->{'blacklist'} .= $line."\n";
++ $param->{'rows'} += 1;
++ $count += 1 unless ($line =~ /^\s*$/o || /^[\#\;]/o);
++ }
++ }
++ close BLACKLIST;
++ if ($count == 0) {
++ unless (unlink $file) {
++ &report::reject_report_web('intern','unable to remove empty blacklist file');
++ &wwslog('info','do_blacklist : unable to remove empty blacklist file %s',$file);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++ &wwslog('info','do_blacklist : removed empty blacklist file %s',$file);
++ }
++ }else{
++ if (-f $file) {
++ unless (open BLACKLIST, $file) {
++ &report::reject_report_web('intern','unable to open file',{'file' => $file,$param->{'action'},'',$param->{'user'}{'email'}},$robot);
++ &wwslog('err','unable to read %s',$file);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++ while (<BLACKLIST>) {
++ $param->{'blacklist'} .= $_ ;
++ $param->{'rows'} += 1;
++ }
++ close BLACKLIST;
++ }
++ }
++
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++}
++
++# output in text/plain format a scenario
++sub do_dump_scenario {
++ &wwslog('info', "do_dump_scenario($param->{'list'}), $in{'pname'}");
++
++ my $scenario = new Scenario ('function' => $in{'pname'},
++ 'robot' => $robot,
++ 'name' => $list->{'admin'}{$in{'pname'}}{'name'},
++ 'directory' => $list->{'dir'});
++ unless (defined $scenario) {
++ &report::reject_report_web('intern','cannot_open_file',{},$param->{'action'},$list);
++ &wwslog('info','failed to load scenario');
++ return undef;
++ }
++ ($param->{'dumped_scenario'}, $param->{'scenario_path'}) = ($scenario->{'data'}, $scenario->{'file_path'});
++ $param->{'pname'} = $in{'pname'};
++ $param->{'scenario_name'} = $list->{'admin'}{$in{'pname'}}{'name'};
++
++ if ($in{'new_scenario_name'}) {
++ # in this case it's a submit.
++ my $scenario_dir = $list->{'dir'}.'/scenari/';
++ my $scenario_file = $scenario_dir.$in{'pname'}.'.'.$in{'new_scenario_name'} ;
++ if ($param->{'dumped_scenario'} eq $in{'new_scenario_content'}){
++ &wwslog('info','do_dump_scenario: scenario unchanged');
++ $param->{'result'} = 'unchanged';
++ return 1;
++ }
++ unless (-d $scenario_dir) {
++ unless (mkdir ($scenario_dir, 0777)) {
++ &do_log('err',"do_dump_scenario: cannot_create_dir %s : %s ", $scenario_dir, $!);
++ &report::reject_report_web('intern','cannot_create_dir',{'file' => $scenario_dir,$param->{'action'},'',$param->{'user'}{'email'}},$robot);
++ return undef;
++ }
++ }
++ unless (open SCENARIO , ">$scenario_file") {
++ &wwslog('info','do_dump_scenario: cannot_open_file %s', $scenario_file);
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $scenario_file,$param->{'action'},'',$param->{'user'}{'email'}},$robot);
++ return undef;
++ }
++ print SCENARIO $in{'new_scenario_content'};
++ close SCENARIO;
++ # load the new scenario in the list config.
++ if ($in{'new_scenario_name'} eq $in{'scenario_name'}) {
++ $param->{'result'} = 'success';
++ }else{
++ $param->{'result'} = 'success_new_name';
++ }
++ }
++ return 1 ;
++}
++
++ ## Subscribers' list
++ sub do_dump {
++ &wwslog('info', "do_dump($param->{'list'})");
++
++ ## Whatever the action return, it must never send a complex html page
++ $param->{'bypass'} = 1;
++ $param->{'content_type'} = "text/plain";
++ $param->{'file'} = undef ;
++
++ ## Access control
++ unless (defined &check_authz('do_dump', 'review')) {
++ undef $param->{'bypass'};
++ return undef;
++ }
++
++ $list->dump();
++ $param->{'file'} = $list->{'dir'}.'/subscribers.db.dump';
++
++ if ($in{'format'} eq 'light') {
++ unless (open (DUMP,$param->{'file'} )) {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $param->{'file'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog ('info', 'unable to open file %s\n',$param->{'file'} );
++ return undef;
++ }
++ unless (open (LIGHTDUMP,">$param->{'file'}.light")) {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => "$param->{'file'}.light"},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err','unable to create file %s.light\n',$param->{'file'} );
++ return undef;
++ }
++ while (<DUMP>){
++ next unless ($_ =~ /^email\s(.*)/);
++ print LIGHTDUMP "$1\n";
++ }
++ close LIGHTDUMP;
++ close DUMP;
++ $param->{'file'} = "$list->{'dir'}/subscribers.db.dump.light";
++
++ } else {
++ $param->{'file'} = "$list->{'dir'}/select.dump";
++ &wwslog('info','opening %s',$param->{'file'});
++
++ unless (open (DUMP,">$param->{'file'}")) {
++ &report::reject_report_web('intern','file_update_failed',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err','unable to create file %s\n',$param->{'file'} );
++ return undef;
++ }
++
++ if ($in{'format'} eq 'bounce') {
++ $in{'size'} = 'all';
++ do_reviewbouncing();
++ print DUMP "# Exported bouncing subscribers\n";
++ print DUMP "# Email\t\tName\tBounce score\tBounce count\tFirst bounce\tLast bounce\n";
++ foreach my $user (@{$param->{'members'}}){
++ print DUMP "$user->{'email'}\t$user->{'gecos'}\t$user->{'bounce_score'}\t$user->{'bounce_count'}\t$user->{'first_bounce'}\t$user->{'last_bounce'}\n";
++ }
++ }
++ else {
++ $in{'filter'} = $in{'format'};
++ do_search();
++ print DUMP "# Exported subscribers with search filter \"$in{'format'}\"\n";
++ foreach my $user (@{$param->{'members'}}){
++ print DUMP "$user->{'email'}\t$user->{'gecos'}\n";
++ }
++ }
++ close DUMP;
++ }
++ return 1;
++ }
++
++
++## returns a mailto according to list spam protection parameter
++sub mailto {
++
++ my $list = shift;
++ my $email = shift;
++ my $gecos = shift;
++ my $next_one;
++
++ my $mailto = '';
++ my @addresses;
++ my %recipients;
++
++ @addresses = split (',',$email);
++
++ $gecos = $email unless ($gecos);
++ $gecos =~ s/&/&/g;
++ $gecos =~ s/</</g;
++ $gecos =~ s/>/>/g;
++ foreach my $address (@addresses) {
++
++ ($recipients{$address}{'local'},$recipients{$address}{'domain'}) = split ('@',$address);
++ }
++
++ if ($list->{'admin'}{'spam_protection'} eq 'none') {
++ $mailto .= "<a href=\"mailto:?";
++ foreach my $address (@addresses) {
++ $mailto .= "&" if ($next_one);
++ $mailto .= "to=$address";
++ $next_one = 1;
++ }
++ $mailto .= "\">$gecos</a>";
++ }elsif($list->{'admin'}{'spam_protection'} eq 'javascript') {
++
++ if ($gecos =~ /\@/) {
++ $gecos =~ s/@/\" + \"@\" + \"/;
++ }
++
++ $mailto .= "<script type=\"text/javascript\">
++ <!--
++ document.write(\"<a href=\\\"\" + \"mail\" + \"to:?\" + ";
++ foreach my $address (@addresses) {
++ $mailto .= "\"\&\;\" + " if ($next_one);
++ $mailto .= "\"to=\" + \"$recipients{$address}{'local'}\" + \"@\" + \"$recipients{$address}{'domain'}\" + ";
++ $next_one = 1;
++ }
++ $mailto .= "\"\\\">$gecos<\" + \"/a>\")
++ // --></script>";
++
++ }elsif($list->{'admin'}{'spam_protection'} eq 'at') {
++ foreach my $address (@addresses) {
++ $mailto .= " AND " if ($next_one);
++ $mailto .= "$recipients{$address}{'local'} AT $recipients{$address}{'domain'}";
++ $next_one = 1;
++ }
++ }
++ return $mailto;
++
++}
++
++## Returns a spam-protected form of email address
++sub get_protected_email_address {
++ my ($local_part, $domain_part) = @_;
++
++ if($list->{'admin'}{'spam_protection'} eq 'javascript') {
++
++ my $return = "<script type=\"text/javascript\">
++ <!--
++ document.write(\"$local_part\" + \"@\" + \"$domain_part\")
++ // --></script>";
++ return ($return);
++ }elsif($list->{'admin'}{'spam_protection'} eq 'at') {
++ return ("$local_part AT $domain_part");
++ }else {
++ return($local_part.'@'.$domain_part);
++ }
++
++}
++
++ ## view logs stored in RDBMS
++ ## this function as been writen in order to allow list owner and listmater to views logs
++ ## of there robot or there is real problems with privacy policy and law in such services.
++ ##
++sub do_viewlogs {
++ &wwslog('info', 'do_viewlogs(%d)',$in{'page'});
++
++ my $size = $in{'size'} || $wwsconf->{'viewlogs_page_size'};
++ my $sortby = $in{'sortby'} || 'email';
++ my @date = &Log::get_log_date();
++
++ $param->{'date_from_formated'} = gettext_strftime "%Y-%m-%d-%H-%M-%S", localtime($date[0]);
++ $param->{'date_to_formated'} = gettext_strftime "%Y-%m-%d-%H-%M-%S", localtime($date[1]);
++
++ $param->{'total'} = '17';
++
++ unless ($param->{'total'}) {
++ &report::reject_report_web('user','no_logs',{},$param->{'action'});
++ &wwslog('info','do_viewlogs: no subscriber');
++ return 1;
++ }
++
++ ## Owner
++ $param->{'page'} = $in{'page'} || 1;
++ $param->{'total_page'} = int ($param->{'total'} / $size);
++ $param->{'total_page'} ++ if ($param->{'total'} % $size);
++
++ if ($param->{'page'} > $param->{'total_page'}) {
++ &report::reject_report_web('user','no_page',{'page' => $param->{'page'}},$param->{'action'});
++ ('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'review',$param->{'list'},$robot,'','out of pages');
++ &wwslog('info','do_viewlogs: no page %d', $param->{'page'});
++ return undef;
++ }
++
++ my $offset;
++ if ($param->{'page'} > 1) {
++ $offset = (($param->{'page'} - 1) * $size);
++ }else {
++ $offset = 0;
++ }
++
++
++ my @lines;
++
++ #display and search parameters preparation
++ my $select = {};
++
++ $select->{'robot'} = $robot;
++ $select->{'list'} = $param->{'list'};
++
++ foreach my $p ('target_type','target','date_deb','date_fin','type','ip') {
++ $param->{$p} = $in{$p};
++ $select->{$p} = $in{$p};
++ }
++
++ unless ($in{'first'}) {
++ #sending of search parameters for the query
++ my $line = &Log::get_first_db_log($select);
++ unless (defined $line) {
++ &report::reject_report_web('intern','db_error',{},$param->{'action'}, $param->{'list'}, $param->{'user'}{'email'}, $robot);
++ &wwslog('info','do_viewlogs failed to get logs from DB');
++ return undef;
++ }
++
++ do {
++ last unless (defined $line->{'date'}); ## Means an empty entry
++ $line->{'date'} = gettext_strftime "%d %b %Y %H:%M:%S", localtime($line->{'date'});
++ push @{$param->{'log_entries'}}, $line;
++ } while ($line = &Log::get_next_db_log());
++
++
++ #display the number of rows of the query.
++ if (&Log::return_rows_nb() != 0) {
++ $param->{'rows_nb'} = &Log::return_rows_nb();
++ }else {
++ $param->{'rows_nb'} = undef;
++ }
++
++ if ($param->{'page'} > 1) {
++ $param->{'prev_page'} = $param->{'page'} - 1;
++ }
++
++ unless (($offset + $size) >= $param->{'total'}) {
++ $param->{'next_page'} = $param->{'page'} + 1;
++ }
++
++ $param->{'size'} = $size;
++ $param->{'sortby'} = $sortby;
++ }
++
++
++ return 1;
++}
++
++
++sub do_arc_manage {
++ &wwslog('info', "do_arc_manage ($in{'list'})");
++
++ my $search_base = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
++ opendir ARC, "$search_base";
++ foreach my $dir (sort {$b cmp $a} grep(!/^\./,readdir ARC)) {
++ if ($dir =~ /^(\d{4})-(\d{2})$/) {
++ push @{$param->{'yyyymm'}}, $dir;
++ }
++ }
++ closedir ARC;
++
++ return 1;
++}
++
++## create a zip file with archives from (list,month)
++sub do_arc_download {
++
++ &wwslog('info', "do_arc_download ($in{'list'})");
++
++ ##zip file name:listname_archives.zip
++ my $zip_file_name = $in{'list'}.'_archives.zip';
++ my $zip_abs_file = $Conf{'tmpdir'}.'/'.$zip_file_name;
++ my $zip = Archive::Zip->new();
++
++ #Search for months to put in zip
++ unless (defined($in{'directories'})) {
++ &report::reject_report_web('user','select_month',{},$param->{'action'});
++ &wwslog('info','do_arc_download : no archives specified');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'select_month','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 'arc_manage';
++ }
++
++ #for each selected month
++ foreach my $dir (split/\0/, $in{'directories'}) {
++ ## Tainted vars problem
++ if ($dir =~ /^(\d+\-\d+)$/) {
++ $dir = $1;
++ }
++
++ my $abs_dir = $wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$dir.'/arctxt';
++ ##check arc directory
++ unless (-d $abs_dir) {
++ &report::reject_report_web('intern','arc_not_found',{'arc_file' => $dir,
++ 'listname' => $in{'list'},
++ 'path' => $abs_dir},
++ $param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','archive %s not found',$dir);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ next;
++ }
++
++ $zip->addDirectory($abs_dir, $in{'list'}.'_'.$dir);
++
++ unless (opendir SPOOL, $abs_dir) {
++ &report::reject_report_web('intern','cannot_open_dir',{'dir' =>$abs_dir },$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_arc_download: unable to open %s', $abs_dir);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ foreach my $msg (sort grep(!/^\./, readdir SPOOL)) {
++ unless ($zip->addFile ($abs_dir.'/'.$msg, $in{'list'}.'_'.$dir.'/'.$msg)) {
++ &report::reject_report_web('intern','add_file_zip',{'file' => "$abs_dir/$msg"},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','do_arc_download: failed to add %s file to archive', $abs_dir.'/'.$msg);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ }
++
++ closedir SPOOL;
++
++ ## create and fill a new folder in zip
++ #$zip->addTree ($abs_dir, $in{'list'}.'_'.$dir);
++ }
++
++ ## check if zip isn't empty
++ if ($zip->numberOfMembers()== 0) {
++ &report::reject_report_web('intern','inaccessible_archive',{'listname' => $in{'list'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('info','Error : empty directories');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ ##writing zip file
++ unless ($zip->writeToFileNamed($zip_abs_file) == AZ_OK){
++ &report::reject_report_web('intern','write_file_zip',{'zipfile'=>$zip_abs_file},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog ('info', 'Error while writing Zip File %s\n',$zip_file_name);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ ##Sending Zip to browser
++ $param->{'bypass'} ='extreme';
++ printf("Content-Type: application/zip;\nContent-disposition: filename=\"%s\";\n\n",$zip_file_name);
++ ##MIME Header
++ unless (open (ZIP,$zip_abs_file)) {
++ &report::reject_report_web('intern','cannot_open_file',{'file' => $zip_abs_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog ('info', 'Error while reading Zip File %s\n',$zip_abs_file);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++ print <ZIP>;
++ close ZIP ;
++
++ ## remove zip file from server disk
++ unless (unlink ($zip_abs_file)){
++ &report::reject_report_web('intern','erase_file',{'file' => $zip_abs_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog ('info', 'Error while unlinking File %s\n',$zip_abs_file);
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ }
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++}
++
++sub do_arc_delete {
++
++ my @abs_dirs;
++
++ &wwslog('info', "do_arc_delete ($in{'list'})");
++
++ unless (defined $in{'directories'}){
++ &report::reject_report_web('user','select_month',{},$param->{'action'});
++ &wwslog('info','No Archives months selected');
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'select_month','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 'arc_manage';
++ }
++
++ ## if user want to download archives before delete
++ &wwslog('notice', "ZIP: $in{'zip'}");
++ if ($in{'zip'} == 1) {
++ &do_arc_download();
++ }
++
++
++ foreach my $dir (split/\0/, $in{'directories'}) {
++ push(@abs_dirs ,$wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$dir);
++ }
++
++ unless (tools::remove_dir(@abs_dirs)) {
++ &wwslog('info','Error while Calling tools::remove_dir');
++ }
++
++ &report::notice_report_web('performed',{},$param->{'action'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 'arc_manage';
++}
++
++
++sub do_css {
++ &wwslog('debug', "do_css ($in{'file'})");
++ $param->{'bypass'} = 'extreme';
++ printf "Content-type: text/css\n\n";
++ $param->{'css'} = $in{'file'};
++
++ my $lang = &Language::Lang2Locale($param->{'lang'});
++ my $tt2_include_path = &tools::make_tt2_include_path($robot,'web_tt2',$lang,'');
++
++ unless (&tt2::parse_tt2($param,'css.tt2' ,\*STDOUT, $tt2_include_path)) {
++ my $error = &tt2::get_error();
++ $param->{'tt2_error'} = $error;
++ &List::send_notify_to_listmaster('web_tt2_error', $robot, [$error]);
++ &wwslog('info', "do_css/$in{'file'} : error");
++ }
++
++ return;
++}
++
++sub do_rss_request {
++ &wwslog('info', "do_rss_request");
++
++ my $args ;
++
++ $in{'count'} ||= 20;
++ $in{'for'} ||= 10;
++
++ $args = 'count='.$in{'count'}.'&' if ($in{'count'}) ;
++ $args .= 'for='.$in{'for'} if ($in{'for'});
++ if ($list ) {
++ $param->{'latest_arc_url'} = &Conf::get_robot_conf($robot, 'wwsympa_url')."/rss/latest_arc/".$list->{'name'}."?".$args;
++ $param->{'latest_d_read_url'} = &Conf::get_robot_conf($robot, 'wwsympa_url')."/rss/latest_d_read/".$list->{'name'}."?".$args;
++ }
++ $param->{'active_lists_url'} = &Conf::get_robot_conf($robot, 'wwsympa_url')."/rss/active_lists?".$args;
++ $param->{'latest_lists_url'} = &Conf::get_robot_conf($robot, 'wwsympa_url')."/rss/latest_lists?".$args;
++
++ $param->{'output'} = 1;
++ return 1;
++}
++
++sub do_wsdl {
++
++ &wwslog('info', "do_wsdl ()");
++ my $sympawsdl = &tools::get_filename('etc',{}, 'sympa.wsdl', $robot);
++
++ unless (-r $sympawsdl){
++ &report::reject_report_web('intern','err_404',{},$param->{'action'});
++ &wwslog('err','could not find $sympawsdl');
++ return undef;
++ }
++
++ my $soap_url= &Conf::get_robot_conf($robot,'soap_url');
++ unless (defined $soap_url) {
++ &report::reject_report_web('user','no_soap_service',{},$param->{'action'});
++ &wwslog('err','No SOAP service was defined in sympa.conf (soap_url parameter)');
++ return undef;
++ }
++
++ $param->{'bypass'} = 'extreme';
++ printf "Content-type: text/xml\n\n";
++
++ $param->{'conf'}{'soap_url'} = $soap_url;
++
++ ## Get the directory path, without the file name
++ my $wsdl_path = $sympawsdl;
++ $wsdl_path =~ s/\/sympa.wsdl//;
++
++ &tt2::parse_tt2($param, 'sympa.wsdl' , \*STDOUT, [$wsdl_path]);
++
++# unless (open (WSDL,$sympawsdl)) {
++# &error_message('404');
++# &wwslog('info','could not open $sympawsdl');
++# return undef;
++# }
++# print <WSDL>;
++# close WSDL;
++ return 1;
++}
++
++## Synchronize list members with data sources
++sub do_sync_include {
++ &wwslog('info', "do_sync_include($in{'list'})");
++
++ unless ($list->sync_include()) {
++ &report::reject_report_web('intern','sync_include_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ return undef;
++ }
++ &report::notice_report_web('subscribers_updated',{},$param->{'action'});
++ return 'review';
++}
++
++## Review lists from a family
++sub do_review_family {
++ &wwslog('info', 'do_review_family');
++
++ my $family = new Family ($in{'family_name'}, $robot);
++ unless (defined $family) {
++ &report::reject_report_web('user','unknown_family',{'family'=>$in{'family_name'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
++ &wwslog('err', 'do_review_family: incorrect family %s', $in{'family_name'});
++ return undef;
++ }
++
++ my $all_lists = $family->get_family_lists();
++ foreach my $flist (@{$all_lists}) {
++ my $l = $list->{'name'};
++
++ unless (defined $flist) {
++ &wwslog('err', 'do_review_family: incorrect list %s', $l);
++ next;
++ }
++ push @{$param->{'family_lists'}}, {'name' => $flist->{'name'},
++ 'status' => $flist->{'admin'}{'status'},
++ 'instantiation_date' => $flist->{'admin'}{'latest_instantiation'}{'date'},
++ 'subject' => $flist->{'admin'}{'subject'},
++ };
++ }
++
++ return 1;
++}
++
++################################################################
++## do_ca : executes a custom action
++##
++## IN:
++## - 'custom_action': ther name of the custom action (and subsequent tt2 file to use, see below)
++## - '@cap': an array of parameters.
++##
++## Custom actions are used to display user defined templates.
++## To use it, follow these steps:
++## 1- create a new file "your_action.tt2" and put it in the relevant dir (either etc or expl)
++## 2- in this file, add the HTML fragment you want to insert to the web interface. You don't need the <head/> section or the <body/> tag.
++## 3- you can type your action URL: http://your-sympa-server-root-url/ca/your_action/param2/param2/param3/...
++##
++## the HTML code in 'your_action.tt2' can make use of the parameters this way: [% cap.1 %] for param1, [% cap.2 %] for param, and so on.
++###############################################################
++sub do_ca {
++ &wwslog('info', 'custom action: %s (robot %s) with params: (%s, %s, %s, %s, %s)',$in{'custom_action'},$robot,$in{'cap'});
++ $param->{'custom_action'} = $in{'custom_action'};
++ $param->{'cap'} = [split '/',$in{'cap'}];
++ return 1;
++}
++
++################################################################
++## do_ca : executes a custom action in list context
++##
++## IN:
++## - 'custom_action': ther name of the custom action (and subsequent tt2 file to use, see below)
++## - 'list': the nalme of the list (without the '@robot' part) in the context of which the action is executed.
++## - '@lcap': an array of parameters.
++##
++## Custom actions are used to display user defined templates.
++## To use it, follow these steps:
++## 1- create a new file "your_action.tt2" and put it in the relevant dir (either etc or expl)
++## 2- in this file, add the HTML fragment you want to insert to the web interface. You don't need the <head/> section or the <body/> tag.
++## 3- you can type your action URL: http://your-sympa-server-root-url/ca/your_action/param2/param2/param3/...
++##
++## the HTML code in 'your_action.tt2' can make use of the parameters this way: [% lcap.1 %] for param1, [% lcap.2 %] for param, and so on.
++###############################################################
++sub do_lca {
++ &wwslog('info', 'List custom action: %s for list %s (robot %s) with params: (%s, %s, %s, %s, %s)',$in{'custom_action'},$in{'list'},$robot,$in{'lcap'});
++ $param->{'custom_action'} = $in{'custom_action'};
++ $param->{'cap'} = [split '/',$in{'cap'}];
++ return 1;
++}
++
++## Prepare subscriber data to be prompted on the web interface
++## Used by review, search,...
++sub _prepare_subscriber {
++ my $user = shift;
++ my $additional_fields = shift;
++ my $sources = shift;
++
++ ## Add user
++ $user->{'date'} = gettext_strftime "%d %b %Y", localtime($user->{'date'});
++ $user->{'update_date'} = gettext_strftime "%d %b %Y", localtime($user->{'update_date'});
++
++ ## Reception mode and topics
++ $user->{'reception'} ||= 'mail';
++ if (($user->{'reception'} eq 'mail') && $user->{'topics'}) {
++ $user->{'reception'} = "topic ($user->{'topics'})";
++ }
++
++ $user->{'email'} =~ /\@(.+)$/;
++ $user->{'domain'} = $1;
++ $user->{'pictures_url'} = &tools::make_pictures_url('email' => $user->{'email'}, 'list' => $list);
++
++ ## Escape some weird chars
++ $user->{'escaped_email'} = &tools::escape_chars($user->{'email'});
++
++ ## Check data sources
++ $user->{'sources'} = $list->get_datasource_name($user->{'id'}) if ($user->{'id'});
++
++ if (@{$additional_fields}) {
++ my @fields;
++ foreach my $f (@{$additional_fields}) {
++ push @fields, $user->{$f};
++ }
++ $user->{'additional'} = join ',', @fields;
++ }
++
++ return 1;
++}
++
++## New d_read function using SharedDocument module
++## The following features should be tested :
++## * inheritance on privileges
++## X moderation
++## * escaping special chars
++sub new_d_read {
++ &wwslog('info', 'new_d_read(%s)', $in{'path'});
++
++ ### action relative to a list ?
++ unless ($param->{'list'}) {
++ &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
++ &wwslog('err','do_d_read: no list');
++ return undef;
++ }
++
++ # current list / current shared directory
++ my $list_name = $list->{'name'};
++
++ my $document = new SharedDocument ($list, $in{'path'}, $param);
++
++ unless (defined $document) {
++ &report::reject_report_web('intern','new_document_failed',{'path'=>$in{'path'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ &wwslog('err',"d_read : cannot open $document->{'absolute_path'} : $!");
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ my $path = $document->{'path'};
++ my $visible_path = $document->{'visible_path'};
++ my $shareddir = $document->{'shared_dir'};
++ my $doc = $document->{'absolute_path'};
++ my $ref_access = $document->{'access'}; my %access = %{$ref_access};
++ $param->{'doc_owner'} = $document->{'owner'};
++ $param->{'doc_title'} = $document->{'title'};
++ $param->{'doc_date'} = $document->{'date'};
++
++ ### Access control
++ unless ($access{'may'}{'read'}) {
++ &report::reject_report_web('auth',$access{'reason'}{'read'},{},$param->{'action'},$list);
++ &wwslog('err','d_read : access denied for %s', $param->{'user'}{'email'});
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return undef;
++ }
++
++ my $may_edit = $access{'may'}{'edit'};
++ my $may_control = $access{'may'}{'control'};
++ $param->{'may_edit'} = $may_edit;
++ $param->{'may_control'} = $may_control;
++
++ ### File or directory ?
++ if ($document->{'type'} eq 'url') {
++ $param->{'file_extension'} = $document->{'file_extension'};
++ $param->{'redirect_to'} = $document->{'url'};
++ return 1;
++
++ }elsif ($document->{'type'} eq 'file') {
++ $param->{'file'} = $document->{'absolute_path'};
++ $param->{'bypass'} = 1;
++ return 1;
++
++ }else { # directory
++
++ $param->{'empty'} = $#{$document->{'subdir'}} == -1;
++
++ # subdirectories hash
++ my %subdirs;
++ # file hash
++ my %files;
++
++ ## for the exception of index.html
++ # name of the file "index.html" if exists in the directory read
++ my $indexhtml;
++
++ # boolean : one of the subdirectories or files inside
++ # can be edited -> normal mode of read -> d_read.tt2;
++ my $normal_mode;
++
++ my $path_doc;
++ my %desc_hash;
++ my $may, my $def_desc;
++
++ foreach my $subdocument (@{$document->{'subdir'}}) {
++
++ my $d = $subdocument->{'filename'};
++ my $path_doc = $subdocument->{'path'};
++
++ ## Subdir
++ if ($subdocument->{'type'} eq 'directory') {
++
++ if ($subdocument->{'access'}{'may'}{'read'}) {
++
++ $subdirs{$d} = $subdocument->dup();
++ $subdirs{$d}{'doc'} = $subdocument->{'visible_filename'};
++ $subdirs{$d}{'escaped_doc'} = $subdocument->{'escaped_filename'};
++
++ if ($param->{'user'}{'email'}) {
++ if ($subdocument->{'access'}{'may'}{'control'} == 1) {
++
++ $subdirs{$d}{'edit'} = 1; # or = $may_action_edit ?
++ # if index.html, must know if something can be edit in the dir
++ $normal_mode = 1;
++ }elsif ($subdocument->{'access'}{'may'}{'edit'} != 0) {
++ # $may_action_edit = 0.5 or 1
++ $subdirs{$d}{'edit'} = $subdocument->{'access'}{'may'}{'edit'};
++ # if index.html, must know if something can be edit in the dir
++ $normal_mode = 1;
++ }
++
++ if ($subdocument->{'access'}{'may'}{'control'}) {
++ $subdirs{$d}{'control'} = 1;
++ }
++ }
++ }
++ }else {
++ # case file
++
++ if ($subdocument->{'access'}{'may'}{'read'}) {
++
++ $files{$d} = $subdocument->dup();
++
++ $files{$d}{'doc'} = $subdocument->{'visible_filename'};
++ $files{$d}{'escaped_doc'} = $subdocument->{'escaped_filename'};
++
++ ## exception of index.html
++ if ($d =~ /^(index\.html?)$/i) {
++ $indexhtml = $1;
++ }
++
++ if ($param->{'user'}{'email'}) {
++ if ($subdocument->{'access'}{'may'}{'edit'} == 1) {
++ $normal_mode = 1;
++ $files{$d}{'edit'} = 1; # or = $may_action_edit ?
++ } elsif ($subdocument->{'access'}{'may'}{'edit'} != 0){
++ # $may_action_edit = 1 or 0.5
++ $normal_mode = 1;
++ $files{$d}{'edit'} = $subdocument->{'access'}{'may'}{'edit'};
++ }
++
++ if ($subdocument->{'access'}{'may'}{'control'}) {
++ $files{$d}{'control'} = 1;
++ }
++ }
++ }
++ }
++ }
++
++ ### Exception : index.html
++ if ($indexhtml) {
++ unless ($normal_mode) {
++ $param->{'file_extension'} = 'html';
++ $param->{'bypass'} = 1;
++ $param->{'file'} = $document->{'absolute_path'};
++ return 1;
++ }
++ }
++
++ ## to sort subdirs
++ my @sort_subdirs;
++ my $order = $in{'order'} || 'order_by_doc';
++ $param->{'order_by'} = $order;
++ foreach my $k (sort {by_order($order,\%subdirs)} keys %subdirs) {
++ push @sort_subdirs, $subdirs{$k};
++ }
++
++ ## to sort files
++ my @sort_files;
++ foreach my $k (sort {by_order($order,\%files)} keys %files) {
++ push @sort_files, $files{$k};
++ }
++
++ # parameters for the template file
++ $param->{'list'} = $list_name;
++
++ $param->{'father'} = $document->{'father_path'};
++ $param->{'escaped_father'} = $document->{'escaped_father_path'} ;
++ $param->{'description'} = $document->{'title'};
++ $param->{'serial_desc'} = $document->{'serial_desc'};
++ $param->{'path'} = $document->{'path'};
++ $param->{'visible_path'} = $document->{'visible_path'};
++ $param->{'escaped_path'} = $document->{'escaped_path'};
++
++ if (scalar keys %subdirs) {
++ $param->{'sort_subdirs'} = \@sort_subdirs;
++ }
++ if (scalar keys %files) {
++ $param->{'sort_files'} = \@sort_files;
++ }
++ }
++ $param->{'father_icon'} = $icon_table{'father'};
++ $param->{'sort_icon'} = $icon_table{'sort'};
++
++
++ ## Show expert commands / user page
++
++ # for the curent directory
++ if ($may_edit == 0 && $may_control == 0) {
++ $param->{'has_dir_rights'} = 0;
++ } else {
++ $param->{'has_dir_rights'} = 1;
++ if ($may_edit == 1) { # (is_author || ! moderated)
++ $param->{'total_edit'} = 1;
++ }
++ }
++
++ # set the page mode
++ if ($in{'show_expert_page'} && $param->{'has_dir_rights'}) {
++ $session->{'shared_mode'}='expert';
++ if ($param->{'user'}{'prefs'}{'shared_mode'} ne 'expert') {
++ # update user pref as soon as connected user change shared mode
++ $param->{'user'}{'prefs'}{'shared_mode'} = 'expert';
++ &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
++ }
++ $param->{'expert_page'} = 1;
++
++ } elsif ($in{'show_user_page'}) {
++ $session->{'shared_mode'}='basic';
++ if ($param->{'user'}{'prefs'}{'shared_mode'} ne 'basic') {
++ # update user pref as soon as connected user change shared mode
++ $param->{'user'}{'prefs'}{'shared_mode'} = 'basic';
++ &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
++ }
++ $param->{'expert_page'} = 0;
++ } else {
++ if ($session->{'shared_mode'} eq 'expert' && $param->{'has_dir_rights'}) {
++ $param->{'expert_page'} = 1;
++ } else {
++ $param->{'expert_page'} = 0;
++ }
++ }
++
++ &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
++ return 1;
++}
++
++
++## Check authorizations to the current action
++## used in common cases where actions fails unless result is 'do_it'
++## It does not apply to actions that can be moderated
++sub check_authz {
++ my ($subname, $action) = @_;
++
++ my $result = $list->check_list_authz($action,$param->{'auth_method'},
++ {'sender' => $param->{'user'}{'email'} || 'nobody',
++ 'remote_host' => $param->{'remote_host'},
++ 'remote_addr' => $param->{'remote_addr'}});
++ my $r_action;
++ my $reason;
++ if (ref($result) eq 'HASH') {
++ $r_action = $result->{'action'};
++ $reason = $result->{'reason'};
++ }
++
++ unless ($r_action =~ /do_it/i) {
++ &report::reject_report_web('auth',$reason,{'login'=> $param->{'need_login'}},$param->{'action'});
++ &wwslog('info','check_authz: access denied in %s for %s', $subname, $param->{'user'}{'email'});
++ return undef;
++ }
++
++ return 1;
++}
++
++sub get_server_details {
++ ## All Robots are shown to super listmaster
++ if (&List::is_listmaster($param->{'user'}{'email'})) {
++ $param->{'main_robot'} = 1;
++ $param->{'robots'} = $Conf{'robots'};
++ }
++
++ ## Families
++ my @families = &Family::get_available_families($robot);
++
++ if (@families) {
++ $param->{'families'} = \@families;
++ }
++}
++
++sub get_icon {
++ my $type = shift;
++
++ return $icon_table{$type};
++}
++
++sub get_mime_type {
++ my $type = shift;
++
++ return $mime_types->{$type};
++}
++
++sub do_maintenance {
++ &wwslog('notice', 'do_maintenance()');
++
++ return 1;
++}
++
++=pod
++
++=head1 AUTHORS
++
++=over
++
++=item * Serge Aumont <sa AT cru.fr>
++
++=item * Olivier Salaun <os AT cru.fr>
++
++=back
++
++=cut
diff --git a/6.1.7/patches/03_rename_lists_no_pending b/6.1.7/patches/03_rename_lists_no_pending
new file mode 100644
index 0000000000000000000000000000000000000000..f9d7c99668c37245e963c05a8ee2ed602cd4d71b
--- /dev/null
+++ b/6.1.7/patches/03_rename_lists_no_pending
@@ -0,0 +1,16948 @@
+diff --git a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
+index c062cb9..cba0fb3 100644
+--- a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
++++ b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
+@@ -10303,9 +10303,9 @@ sub do_rename_list {
+ }
+
+ # set list status to pending if creation list is moderated
+- if ($param->{'status'} eq 'pending') {
+- &report::notice_report_web('pending_list',{},$param->{'action'},$list);
+- }
++# if ($param->{'status'} eq 'pending') {
++# &report::notice_report_web('pending_list',{},$param->{'action'},$list);
++# }
+
+ if ($in{'new_robot'} eq '$robot') {
+ $param->{'redirect_to'} = "$param->{'base_url'}$param->{'path_cgi'}/admin/$in{'new_listname'}";
+diff --git a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in.orig b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in.orig
+deleted file mode 100644
+index e6f8ba6..0000000
+--- a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in.orig
++++ /dev/null
+@@ -1,16925 +0,0 @@
+-#!--PERL-- -U
+-# wwsympa.fcgi - This script provides the web interface to Sympa
+-# RCS Identication ; $Revision: 7135 $ ; $Date: 2011-07-15 16:33:38 +0200 (ven 15 jui 2011) $
+-#
+-# Sympa - SYsteme de Multi-Postage Automatique
+-# Copyright (c) 1997-2003 Comite Reseau des Universites
+-#
+-# This program is free software; you can redistribute it and/or modify
+-# it under the terms of the GNU General Public License as published by
+-# the Free Software Foundation; either version 2 of the License, or
+-# (at your option) any later version.
+-#
+-# This program is distributed in the hope that it will be useful,
+-# but WITHOUT ANY WARRANTY; without even the implied warranty of
+-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-# GNU General Public License for more details.
+-#
+-# You should have received a copy of the GNU General Public License
+-# along with this program; if not, write to the Free Software
+-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+-
+-## Copyright 1999 Comit� R�seaux des Universit�s
+-## web interface to Sympa mailing lists manager
+-## Sympa: http://www.sympa.org/
+-## Authors :
+-## Serge Aumont <sa AT cru.fr>
+-## Olivier Sala�n <os AT cru.fr>
+-=pod
+-
+-=head1 NAME
+-
+-I<wwsympa.fcgi> - Sympa web interface
+-
+-=head1 DESCRIPTION
+-
+-This fcgi script completely handles all aspects of the Sympa web interface
+-
+-=cut
+-
+-use lib '--modulesdir--';
+-
+-use Getopt::Long;
+-use Archive::Zip;
+-
+-use strict 'vars';
+-use Time::Local;
+-use MIME::Lite::HTML;
+-
+-## Sympa API
+-use List;
+-use mail;
+-use Conf;
+-use confdef;
+-use Commands;
+-use Language;
+-use Log;
+-use Auth;
+-use admin;
+-use SharedDocument;
+-use report;
+-use SympaSession;
+-use Log;
+-use tools;
+-use time_utils;
+-use Sympa::Constants;
+-use wwslib;
+-use cookielib;
+-use Robot;
+-use tt2;
+-#use DateTime;
+-#use open ':utf8'; ## Default is to consider files utf8
+-
+-use Mail::Header;
+-use Mail::Address;
+-
+-my $crypt_openssl_x509_ok;
+-BEGIN {
+- if (eval "require Crypt::OpenSSL::X509") {
+- require Crypt::OpenSSL::X509;
+- $crypt_openssl_x509_ok = 1;
+- } else {
+- $crypt_openssl_x509_ok = 0;
+- }
+-};
+-
+-## WWSympa librairies
+-my %options;
+-
+-## Configuration
+-my $wwsconf = {};
+-
+-## Change to your wwsympa.conf location
+-my $conf_file = Sympa::Constants::WWSCONFIG;
+-my $sympa_conf_file = Sympa::Constants::CONFIG;
+-
+-
+-
+-my $loop = 0;
+-my $list;
+-my $param = {};
+-my ($robot, $robot_object);
+-my $ip ;
+-my $rss ;
+-my $session;
+-
+-## Load config
+-unless ($wwsconf = &wwslib::load_config($conf_file)) {
+- &fatal_err('Unable to load config file %s', $conf_file);
+-}
+-
+-## Load sympa config
+-unless (&Conf::load( $sympa_conf_file )) {
+- &fatal_err('Unable to load sympa config file %s', $sympa_conf_file);
+-}
+-
+-&Log::set_log_level($Conf{'log_level'}) if ($Conf{'log_level'});
+-
+-&mail::set_send_spool($Conf{'queue'});
+-
+-if ($wwsconf->{'use_fast_cgi'}) {
+- require CGI::Fast;
+-}else {
+- require CGI;
+-}
+-my $daemon_name = &Log::set_daemon($0);
+-
+-my $mime_types = &wwslib::load_mime_types();
+-
+-
+-# hash of all the description files already loaded
+-# format :
+-# $desc_files{pathfile}{'date'} : date of the last load
+-# $desc_files{pathfile}{'desc_hash'} : hash which describes
+-# the description file
+-
+-#%desc_files_map; NOT USED ANYMORE
+-
+-# hash of the icons linked with a type of file
+-my %icon_table;
+-
+- # application file
+-$icon_table{'unknown'} = $Conf{'static_content_url'}.'/icons/unknown.png';
+-$icon_table{'folder'} = $Conf{'static_content_url'}.'/icons/folder.png';
+-$icon_table{'current_folder'} = $Conf{'static_content_url'}.'/icons/folder.open.png';
+-$icon_table{'application'} = $Conf{'static_content_url'}.'/icons/unknown.png';
+-$icon_table{'octet-stream'} = $Conf{'static_content_url'}.'/icons/binary.png';
+-$icon_table{'audio'} = $Conf{'static_content_url'}.'/icons/sound1.png';
+-$icon_table{'image'} = $Conf{'static_content_url'}.'/icons/image2.png';
+-$icon_table{'text'} = $Conf{'static_content_url'}.'/icons/text.png';
+-$icon_table{'video'} = $Conf{'static_content_url'}.'/icons/movie.png';
+-$icon_table{'father'} = $Conf{'static_content_url'}.'/icons/back.png';
+-$icon_table{'sort'} = $Conf{'static_content_url'}.'/icons/down.png';
+-$icon_table{'url'} = $Conf{'static_content_url'}.'/icons/link.png';
+-$icon_table{'left'} = $Conf{'static_content_url'}.'/icons/left.png';
+-$icon_table{'right'} = $Conf{'static_content_url'}.'/icons/right.png';
+-## Shared directory and description file
+-
+-#$shared = 'shared';
+-#$desc = '.desc';
+-
+-
+-## subroutines
+-my %comm = ('home' => 'do_home',
+- 'logout' => 'do_logout',
+- 'loginrequest' => 'do_loginrequest',
+- 'login' => 'do_login',
+- 'sso_login' => 'do_sso_login',
+- 'sso_login_succeeded' => 'do_sso_login_succeeded',
+- 'subscribe' => 'do_subscribe',
+- 'multiple_subscribe' => 'do_multiple_subscribe',
+- 'subrequest' => 'do_subrequest',
+- 'subindex' => 'do_subindex',
+- 'suboptions' => 'do_suboptions',
+- 'signoff' => 'do_signoff',
+- 'auto_signoff' => 'do_auto_signoff',
+- 'multiple_signoff' => 'do_multiple_sigoff',
+- 'sigrequest' => 'do_sigrequest',
+- 'ignoresub' => 'do_ignoresub',
+- 'which' => 'do_which',
+- 'lists' => 'do_lists',
+- 'latest_lists' => 'do_latest_lists',
+- 'active_lists' => 'do_active_lists',
+- 'info' => 'do_info',
+- 'subscriber_count' => 'do_subscriber_count',
+- 'review' => 'do_review',
+- 'search' => 'do_search',
+- 'pref', => 'do_pref',
+- 'setpref' => 'do_setpref',
+- 'setpasswd' => 'do_setpasswd',
+- 'renewpasswd' => 'do_renewpasswd',
+- 'firstpasswd' => 'do_firstpasswd',
+- 'requestpasswd' => 'do_requestpasswd',
+- 'choosepasswd' => 'do_choosepasswd',
+- 'viewfile' => 'do_viewfile',
+- 'set' => 'do_set',
+- 'admin' => 'do_admin',
+- 'add_request' => 'do_add_request',
+- 'add' => 'do_add',
+- 'del' => 'do_del',
+- 'modindex' => 'do_modindex',
+- 'reject' => 'do_reject',
+- 'reject_notify' => 'do_reject_notify',
+- 'reject_notify_shared' =>'admin',
+- 'distribute' => 'do_distribute',
+- 'viewmod' => 'do_viewmod',
+- 'd_reject_shared' => 'do_d_reject_shared',
+- 'reject_notify_shared' => 'do_reject_notify_shared',
+- 'd_install_shared' => 'do_d_install_shared',
+- 'editfile' => 'do_editfile',
+- 'savefile' => 'do_savefile',
+- 'arc' => 'do_arc',
+- 'latest_arc' => 'do_latest_arc',
+- 'latest_d_read' => 'do_latest_d_read',
+- 'arc_manage' => 'do_arc_manage',
+- 'remove_arc' => 'do_remove_arc',
+- 'send_me' => 'do_send_me',
+- 'view_source' => 'do_view_source',
+- 'arcsearch_form' => 'do_arcsearch_form',
+- 'arcsearch_id' => 'do_arcsearch_id',
+- 'arcsearch' => 'do_arcsearch',
+- 'rebuildarc' => 'do_rebuildarc',
+- 'rebuildallarc' => 'do_rebuildallarc',
+- 'arc_download' => 'do_arc_download',
+- 'arc_delete' => 'do_arc_delete',
+- 'serveradmin' => 'do_serveradmin',
+- 'set_loglevel' => 'do_set_loglevel',
+- 'set_dumpvars' => 'do_set_dumpvars',
+- 'show_sessions' => 'do_show_sessions',
+- 'unset_dumpvars' => 'do_unset_dumpvars',
+- 'set_session_email' => 'do_set_session_email',
+- 'restore_email' => 'do_restore_email',
+- 'skinsedit' => 'do_skinsedit',
+- 'css' => 'do_css',
+- 'help' => 'do_help',
+- 'edit_list_request' => 'do_edit_list_request',
+- 'edit_list' => 'do_edit_list',
+- 'create_list_request' => 'do_create_list_request',
+- 'create_list' => 'do_create_list',
+- 'get_pending_lists' => 'do_get_pending_lists',
+- 'get_closed_lists' => 'do_get_closed_lists',
+- 'get_latest_lists' => 'do_get_latest_lists',
+- 'get_inactive_lists' => 'do_get_inactive_lists',
+- 'set_pending_list_request' => 'do_set_pending_list_request',
+- 'install_pending_list' => 'do_install_pending_list',
+- 'edit_config' => 'do_edit_config',
+- 'submit_list' => 'do_submit_list',
+- 'editsubscriber' => 'do_editsubscriber',
+- 'viewbounce' => 'do_viewbounce',
+- 'redirect' => 'do_redirect',
+- 'rename_list_request' => 'do_rename_list_request',
+- 'rename_list' => 'do_rename_list',
+- 'copy_list' => 'do_copy_list',
+- 'reviewbouncing' => 'do_reviewbouncing',
+- 'resetbounce' => 'do_resetbounce',
+- 'scenario_test' => 'do_scenario_test',
+- 'search_list' => 'do_search_list',
+- 'show_cert' => 'show_cert',
+- 'close_list_request' => 'do_close_list_request',
+- 'close_list' => 'do_close_list',
+- 'purge_list' => 'do_purge_list',
+- 'restore_list' => 'do_restore_list',
+- 'upload_pictures' => 'do_upload_pictures',
+- 'delete_pictures' => 'do_delete_pictures',
+- 'd_read' => 'do_d_read',
+- 'd_create_dir' => 'do_d_create_dir',
+- 'd_upload' => 'do_d_upload',
+- 'd_unzip' => 'do_d_unzip',
+- 'd_editfile' => 'do_d_editfile',
+- 'd_properties' => 'do_d_properties',
+- 'd_overwrite' => 'do_d_overwrite',
+- 'd_savefile' => 'do_d_savefile',
+- 'd_describe' => 'do_d_describe',
+- 'd_delete' => 'do_d_delete',
+- 'd_rename' => 'do_d_rename',
+- 'd_control' => 'do_d_control',
+- 'd_change_access' => 'do_d_change_access',
+- 'd_set_owner' => 'do_d_set_owner',
+- 'd_admin' => 'do_d_admin',
+- 'dump_scenario' => 'do_dump_scenario',
+- 'dump' => 'do_dump',
+- 'arc_protect' => 'do_arc_protect',
+- 'remind' => 'do_remind',
+- 'change_email' => 'do_change_email',
+- 'change_email_request' => 'do_change_email_request',
+- 'load_cert' => 'do_load_cert',
+- 'compose_mail' => 'do_compose_mail',
+- 'send_mail' => 'do_send_mail',
+- 'request_topic' => 'do_request_topic',
+- 'tag_topic_by_sender' =>'do_tag_topic_by_sender',
+- 'search_user' => 'do_search_user',
+- 'set_lang' => 'do_set_lang',
+- 'attach' => 'do_attach',
+- 'stats' => 'do_stats',
+- 'viewlogs'=> 'do_viewlogs',
+- 'wsdl'=> 'do_wsdl',
+- 'sync_include' => 'do_sync_include',
+- 'review_family' => 'do_review_family',
+- 'ls_templates' => 'do_ls_templates',
+- 'remove_template' => 'do_remove_template',
+- 'copy_template' => 'do_copy_template',
+- 'view_template' => 'do_view_template',
+- 'edit_template' => 'do_edit_template',
+- 'rss_request' => 'do_rss_request',
+- 'maintenance' => 'do_maintenance',
+- 'blacklist' => 'do_blacklist',
+- 'edit_attributes' => 'do_edit_attributes',
+- 'ticket' => 'do_ticket',
+- 'manage_template' => 'do_manage_template',
+- 'send_newsletter' => 'do_send_newsletter',
+- 'suspend_request' => 'do_suspend_request',
+- 'suspend_request_action' => 'do_suspend_request_action',
+- 'show_exclude' => 'do_show_exclude',
+- 'ca' => 'do_ca', # 'ca' stands for 'custom_action'. I used a short name to make it discrete in a URL.
+- 'lca' => 'do_lca', # 'lca' stands for 'list_custom_action'. I used a short name to make it discrete in a URL.
+- );
+-
+-my %auth_action = ('logout' => 1,
+- 'loginrequest' => 1,
+- 'login' => 1,
+- 'sso_login' => 1,
+- 'sso_login_succeeded' => 1,
+- 'renewpasswd' => 1,
+- 'firstpasswd' => 1,
+- 'choosepasswd' => 1,
+- 'sendssopasswd' => 1,
+- 'ticket' => 1,
+- );
+-
+-## Arguments awaited in the PATH_INFO, depending on the action
+-my %action_args = ('default' => ['list'],
+- 'editfile' => ['list','file'],
+- 'viewfile' => ['list','file'],
+- 'requestpasswd' => ['email'],
+- 'choosepasswd' => ['email','passwd'],
+- 'lists' => ['topic','subtopic'],
+- 'latest_lists' => ['topic','subtopic'],
+- 'active_lists' => ['topic','subtopic'],
+- 'login' => ['email','passwd','previous_action','previous_list'],
+- 'sso_login' => ['auth_service_name','subaction','email', 'ticket'],
+- 'sso_login_succeeded' => ['auth_service_name','previous_action','previous_list'],
+- 'loginrequest' => ['previous_action','previous_list'],
+- 'logout' => ['previous_action','previous_list'],
+- 'renewpasswd' => ['previous_action','previous_list'],
+- 'firstpasswd' => ['previous_action','previous_list'],
+- 'css' => ['file'],
+- 'pref' => ['previous_action','previous_list'],
+- 'reject' => ['list','id'],
+- 'distribute' => ['list','id'],
+- 'dump_scenario' => ['list','pname'],
+- 'd_reject_shared' => ['list','id'],
+- 'd_install_shared' => ['list','id'],
+- 'modindex' => ['list'],
+- 'viewmod' => ['list','id','@file'],
+- 'viewfile' => ['list','file'],
+- 'add' => ['list','email'],
+- 'add_request' => ['list'],
+- 'del' => ['list','email'],
+- 'editsubscriber' => ['list','email','previous_action','custom_attribute'],
+-# 'editsubscriber' => ['list','email','previous_action'],
+- 'viewbounce' => ['list','email'],
+- 'resetbounce' => ['list','email'],
+- 'review' => ['list','page','size','sortby'],
+- 'reviewbouncing' => ['list','page','size'],
+- 'arc' => ['list','month','@arc_file'],
+- 'latest_arc' => ['list'],
+- 'arc_manage' => ['list'],
+- 'arcsearch_form' => ['list','archive_name'],
+- 'arcsearch_id' => ['list','archive_name','msgid'],
+- 'rebuildarc' => ['list','month'],
+- 'rebuildallarc' => [],
+- 'arc_download' => ['list'],
+- 'arc_delete' => ['list','zip'],
+- 'home' => [],
+- 'help' => ['help_topic'],
+- 'show_cert' => [],
+- 'subscribe' => ['list','email','passwd'],
+- 'subrequest' => ['list','email'],
+- 'subrequest' => ['list'],
+- 'subindex' => ['list'],
+- 'ignoresub' => ['list','@email','@gecos'],
+- 'signoff' => ['list','email','passwd'],
+- 'auto_signoff' => ['list','email'],
+- 'sigrequest' => ['list','email'],
+- 'set' => ['list','email','reception','gecos'],
+- 'serveradmin' => ['subaction'],
+- 'set_session_email' => ['email'],
+- 'skinsedit' => [],
+- 'get_pending_lists' => [],
+- 'get_closed_lists' => [],
+- 'get_latest_lists' => [],
+- 'get_inactive_lists' => [],
+- 'search_list' => ['filter'],
+- 'shared' => ['list','@path'],
+- 'd_read' => ['list','@path'],
+- 'latest_d_read' => ['list'],
+- 'd_admin' => ['list','d_admin'],
+- 'd_delete' => ['list','@path'],
+- 'd_rename' => ['list','@path'],
+- 'd_create_dir' => ['list','@path'],
+- 'd_overwrite' => ['list','@path'],
+- 'd_savefile' => ['list','@path'],
+- 'd_describe' => ['list','@path'],
+- 'd_editfile' => ['list','@path'],
+- 'd_properties' => ['list','@path'],
+- 'd_control' => ['list','@path'],
+- 'd_change_access' => ['list','@path'],
+- 'd_set_owner' => ['list','@path'],
+- 'dump' => ['list','format'],
+- 'search' => ['list','filter'],
+- 'search_user' => ['email'],
+- 'set_lang' => ['lang'],
+- 'attach' => ['list','dir','file'],
+- 'edit_list_request' => ['list','group'],
+- 'rename_list' => ['list','new_list','new_robot'],
+- 'copy_list' => ['list','new_list','new_robot'],
+- 'redirect' => [],
+- 'viewlogs' => ['list','first'],
+- 'wsdl' => [],
+- 'sync_include' => ['list'],
+- 'review_family' => ['family_name'],
+- 'ls_templates' => ['list'],
+- 'view_template' => [],
+- 'remove_template' => [],
+- 'copy_template' => ['list'],
+- 'edit_template' => ['list'],
+- 'rss_request' => ['list'],
+- 'request_topic' => ['list','authkey'],
+- 'tag_topic_by_sender' => ['list'],
+- 'multiple_subscribe' => ['lists'],
+- 'multiple_signoff' => ['lists'],
+- 'ticket' => ['ticket'],
+- 'change_email' => ['email'],
+- 'manage_template' => ['subaction','list','message_template'],
+- 'send_newsletter' => [],
+- 'compose_mail' => ['list','subaction'],
+- 'suspend_request' => ['subaction'],
+- 'show_exclude' => ['list'],
+- 'ca' => ['custom_action','@cap'],
+- 'lca' => ['custom_action','list','@cap'],
+- );
+-
+-## Define the required parameters for each action
+-## Parameter names refer to the %in structure of to $param if mentionned as 'param.x'
+-## This structure is used to determine if any parameter is missing
+-## The list of parameters is not ordered
+-## Some keywords are reserved: param.list and param.user.email
+-## Alternate parameters can be defined with the '|' character
+-## Limits of this structure: it does not define optional parameters (a or b)
+-## Limit: it does not allow to have a specific error message and redirect to a given page if the parameter is missing
+-my %required_args = ('active_lists' => ['for|count'],
+- 'admin' => ['param.list','param.user.email'],
+- 'add' => ['param.list','param.user.email'],
+- 'add_request' => ['param.list','param.user.email'],
+- 'arc' => ['param.list'],
+- 'arc_delete' => ['param.user.email','param.list'],
+- 'arc_download' => ['param.user.email','param.list'],
+- 'arc_manage' => ['param.list'],
+- 'arc_protect' => ['param.list'],
+- 'arcsearch' => ['param.list'],
+- 'arcsearch_form' => ['param.list'],
+- 'arcsearch_id' => ['param.list'],
+- 'attach' => ['param.list'],
+- 'blacklist' => ['param.list'],
+- 'change_email' => ['param.user.email'],
+- 'change_email_request' => ['param.user.email','new_email'],
+- 'close_list' => ['param.user.email','param.list'],
+- 'close_list_request' => ['param.user.email','param.list'],
+- 'compose_mail' => ['param.user.email','param.list'],
+- 'copy_template' => ['webormail'],
+- 'create_list' => ['param.user.email'], ## other required parameters are checked in the subroutine
+- 'create_list_request' => ['param.user.email'],
+- 'css' => [],
+- 'd_admin' => ['param.list','param.user.email'],
+- 'd_change_access' => ['param.list','param.user.email'],
+- 'd_control' => ['param.list','param.user.email'],
+- 'd_create_dir' => ['param.list','param.user.email','name_doc'],
+- 'd_delete' => ['param.list','param.user.email'],
+- 'd_describe' => ['param.list','param.user.email','content'],
+- 'd_editfile' => ['param.list','param.user.email'],
+- 'd_install_shared' => ['param.list','param.user.email','id'],
+- 'd_overwrite' => ['param.list','param.user.email'],
+- 'd_properties' => ['param.list','param.user.email'],
+- 'd_read' => ['param.list'],
+- 'd_reject_shared' => ['param.list','param.user.email','id'],
+- 'd_rename' => ['param.list','param.user.email','new_name'],
+- 'd_savefile' => ['param.list','param.user.email','content|url'],
+- 'd_set_owner' => ['param.list','param.user.email'],
+- 'd_unzip' => ['param.list','param.user.email'],
+- 'd_upload' => ['param.list','param.user.email'],
+- 'del' => ['param.list','param.user.email','email'],
+- 'delete_pictures' => ['param.list','param.user.email'],
+- 'distribute' => ['param.list','param.user.email','id|idspam'],
+- 'dump' => ['param.list'],
+- 'dump_scenario' => ['param.list','pname'],
+- 'edit_list' => ['param.user.email','param.list'],
+- 'edit_list_request' => ['param.user.email','param.list'],
+- 'edit_template' => ['webormail'],
+- 'editfile' => ['param.user.email'],
+- 'editsubscriber' => ['param.list','param.user.email','email'],
+- 'get_closed_lists' => ['param.user.email'],
+- 'get_inactive_lists' => ['param.user.email'],
+- 'get_latest_lists' => ['param.user.email'],
+- 'get_pending_lists' => ['param.user.email'],
+- 'ignoresub' => ['param.list','param.user.email'],
+- 'info' => ['param.list'],
+- 'install_pending_list' => ['param.user.email'],
+- 'edit_config' => ['param.user.email'],
+- 'latest_arc' => ['param.list','for|count'],
+- 'latest_d_read' => ['param.list','for','count'],
+- 'latest_lists' => ['for|count'],
+- 'load_cert' => ['param.list'],
+- 'logout' => ['param.user.email'],
+- 'manage_template' => ['param.list','param.user.email'],
+- 'modindex' => ['param.list','param.user.email'],
+- 'multiple_subscribe' => ['param.list'],
+- 'pref' => ['param.user.email'],
+- 'purge_list' => ['param.user.email','selected_lists'],
+- 'rebuildallarc' => ['param.user.email'],
+- 'rebuildarc' => ['param.user.email','param.list'],
+- 'reject' => ['param.list','param.user.email','id|idspam'],
+- 'remind' => ['param.list','param.user.email'],
+- 'remove_arc' => ['param.list'],
+- 'remove_templates' => ['webormail'],
+- 'rename_list' => ['param.user.email','param.list','new_listname','new_robot'],
+- 'copy_list' => ['param.user.email','param.list','new_listname','new_robot'],
+- 'rename_list_request' => ['param.user.email','param.list'],
+- 'request_topic' => ['param.list','authkey'],
+- 'resetbounce' => ['param.list','param.user.email','email'],
+- 'restore_list' => ['param.user.email','param.list'],
+- 'review' => ['param.list'],
+- 'review_family' => ['param.user.email','family_name'],
+- 'reviewbouncing' => ['param.list'],
+- 'rss_request' => [],
+- 'savefile' => ['param.user.email','file'],
+- 'search' => ['param.list','filter'],
+- 'search_user' => ['param.user.email','email'],
+- 'send_mail' => ['param.user.email'],
+- 'send_newsletter' => ['param.list','param.user.email', 'url'],
+- 'send_me' => ['param.list'],
+- 'view_source' => ['param.list'],
+- 'requestpasswd' => ['email'],
+- 'serveradmin' => ['param.user.email'],
+- 'set' => ['param.list','reception|visibility'],
+- 'set_lang' => [],
+- 'set_pending_list_request' => ['param.user.email'],
+- 'setpasswd' => ['param.user.email','newpasswd1','newpasswd2'],
+- 'setpref' => ['param.user.email'],
+- 'signoff' => ['param.list'],
+- 'sigrequest' => ['param.list'],
+- 'skinedit' => ['param.user.email'],
+- 'sso_login' => ['auth_service_name'],
+- 'stats' => ['param.user.email','param.list'],
+- 'subindex' => ['param.list','param.user.email'],
+- 'suboptions' => ['param.list','param.user.email'],
+- 'subrequest' => ['param.list'],
+- 'subscribe' => ['param.list'],
+- 'subscriber_count' => ['param.list'],
+- 'suspend_request' => [],
+- 'suspend_request_action' => [],
+- 'show_exclude' => ['param.list'],
+- 'sync_include' => ['param.list','param.user.email'],
+- 'tag_topic_by_sender' => ['param.list'],
+- 'upload_pictures' => ['param.user.email','param.list'],
+- 'view_template' => ['webormail'],
+- 'viewbounce' => ['param.list','email'],
+- 'viewfile' => ['file','param.list'],
+- 'viewlogs' => ['param.list'],
+- 'viewmod' => ['param.list','param.user.email','id|idspam'],
+- 'wsdl' => [],
+- 'which' => ['param.user.email'],
+- );
+-
+-## Defines the required privileges to access privileged actions
+-## You can define a set ofequiivalent privileges in the ARRAYREF
+-my %required_privileges = ('admin' => ['owner','editor'],
+- 'arc_download' => ['owner'],
+- 'blacklist' => ['owner','editor'],
+- 'close_list' => ['privileged_owner'],
+- 'close_list_request' => ['privileged_owner'],
+- 'copy_template' => ['listmaster'],
+- 'd_install_shared' => ['editor'],
+- 'd_reject_shared' => ['editor'],
+- 'distribute' => ['editor'],
+- 'dump_scenario' => ['listmaster'],
+- 'edit_list' => ['owner'],
+- 'edit_list_request' => ['owner'],
+- 'edit_template' => ['listmaster'],
+- 'editsubscriber' => ['owner'],
+- 'get_closed_lists' => ['listmaster'],
+- 'get_inactive_lists' => ['listmaster'],
+- 'get_latest_lists' => ['listmaster'],
+- 'get_pending_lists' => ['listmaster'],
+- 'ignoresub' => ['owner'],
+- 'install_pending_list' => ['listmaster'],
+- 'edit_config' => ['listmaster'],
+- 'ls_templates' => ['listmaster'],
+- 'manage_template' => ['owner'],
+- 'manage_template' => ['owner'],
+- 'modindex' => ['editor'],
+- 'purge_list' => ['privileged_owner','listmaster'],
+- 'rebuildallarc' => ['listmaster'],
+- 'rebuildarc' => ['listmaster'],
+- 'reject' => ['editor'],
+- 'remove_template' => ['listmaster'],
+- 'rename_list' => ['privileged_owner'],
+- 'copy_list' => ['owner'],
+- 'rename_list_request' => ['privileged_owner'],
+- 'resetbounce' => ['owner'],
+- 'restore_list' => ['listmaster'],
+- 'review_family' => ['listmaster'],
+- 'reviewbouncing' => ['owner'],
+- 'search_user' => ['listmaster'],
+- 'serveradmin' => ['listmaster'],
+- 'set_dumpvars' => ['listmaster'],
+- 'set_loglevel' => ['listmaster'],
+- 'set_pending_list_request' => ['listmaster'],
+- 'set_session_email' => ['listmaster'],
+- 'show_sessions' => ['listmaster'],
+- 'stats' => ['owner'],
+- 'subindex' => ['owner'],
+- 'sync_include' => ['owner'],
+- 'skinedit' => ['listmaster'],
+- 'view_template' => ['listmaster'],
+- 'viewbounce' => ['owner'],
+- 'viewlogs' => ['owner','editor'],
+- 'viewmod' => ['editor'],
+- );
+-
+-# this definition is used to choose the left side menu type (admin -> listowner admin menu | serveradmin -> server_admin menu | none list or your_list menu)
+-my %action_type = ('editfile' => 'admin',
+- 'review' => 'admin',
+- 'search' => 'admin',
+- 'viewfile' => 'admin',
+- 'admin' => 'admin',
+- 'add_request' =>'admin',
+- 'add' =>'admin',
+- 'del' =>'admin',
+-# 'modindex' =>'admin',
+- 'reject' =>'admin',
+- 'reject_notify' =>'admin',
+- 'add_request' =>'admin',
+- 'distribute' =>'admin',
+- 'viewmod' =>'admin',
+- 'savefile' =>'admin',
+- 'rebuildarc' =>'admin',
+- 'rebuildallarc' =>'admin',
+- 'reviewbouncing' =>'admin',
+- 'edit_list_request' =>'admin',
+- 'edit_list' =>'admin',
+- 'editsubscriber' =>'admin',
+- 'viewbounce' =>'admin',
+- 'resetbounce' =>'admin',
+- 'scenario_test' =>'admin',
+- 'close_list_request' =>'admin',
+- 'close_list' =>'admin',
+- 'restore_list' => 'admin',
+- 'd_admin' => 'admin',
+- 'd_reject_shared' =>'admin',
+- 'd_install_shared' =>'admin',
+- 'dump_scenario' => 'admin',
+- 'dump' => 'admin',
+- 'remind' => 'admin',
+-# 'subindex' => 'admin',
+- 'stats' => 'admin',
+- 'ignoresub' => 'admin',
+- 'rename_list' => 'admin',
+- 'copy_list' => 'admin',
+- 'rename_list_request' => 'admin',
+- 'arc_manage' => 'admin',
+- 'sync_include' => 'admin',
+- 'ls_templates' => 'admin',
+- 'view_template' => 'admin',
+- 'remove_template' => 'admin',
+- 'copy_template' => 'admin',
+- 'edit_template' => 'admin',
+- 'blacklist' => 'admin',
+- 'viewlogs' => 'admin',
+- 'serveradmin' => 'serveradmin',
+- 'get_pending_lists' => 'serveradmin',
+- 'get_closed_lists' => 'serveradmin',
+- 'get_inactive_lists' => 'serveradmin',
+- 'get_latest_lists' => 'serveradmin',
+- 'ls_templates' => 'serveradmin',
+- 'skinedit' => 'serveradmin',
+- 'review_family' => 'serveradmin',
+- 'search_user' => 'serveradmin',
+- 'show_sessions' => 'serveradmin',
+- 'show_exclude' => 'admin',
+- 'rebuildarc' => 'serveradmin',
+- 'set_session_email' => 'serveradmin',
+- 'set_loglevel' => 'serveradmin',
+- 'editfile' => 'serveradmin',
+- 'unset_dumpvars' => 'serveradmin',
+- 'set_dumpvars' => 'serveradmin'
+-);
+-
+-## actions tthat are not used in return of login,
+-my %temporary_actions = ( 'logout' => 1,
+- 'loginrequest' => 1,
+- 'login' => 1,
+- 'sso_login' => 1,
+- 'sso_login_succeeded' => 1,
+- 'ticket' => 1,
+- 'css' => 1,
+- 'rss' => 1,
+- 'wsdl' => 1,
+- 'redirect' => 1,
+- );
+-
+-## Regexp applied on incoming parameters (%in)
+-## The aim is not a strict definition of parameter format
+-## but rather a security check
+-my %in_regexp = (
+- ## Default regexp
+- '*' => '[\w\-\.]+',
+-
+- ## List config parameters
+- 'single_param' => '.+',
+- 'multiple_param' => '.+',
+-
+- ## Textarea content
+- 'template_content' => '.+',
+- 'content' => '.+',
+- 'body' => '.+',
+- 'info' => '.+',
+- 'new_scenario_content' => '.+',
+- 'blacklist' => '.*',
+-
+- ## Integer
+- 'page' => '\d+',
+- 'size' => '\d+',
+-
+- ## Free data
+- 'subject' => '.*',
+- 'gecos' => '[^<>\\\*\$\n]+',
+- 'additional_field' => '[^<>\\\*\$\n]+',
+- 'dump' => '[^<>\\\*\$]+', # contents email + gecos
+-
+- ## Search
+- 'filter' => '[^<>\\\[\]\(\)\$\n]+', # search list
+- 'key_word' => '.*',
+- 'format' => '[^<>\\\$\n]+', # dump format/filter string
+-
+- ## File names
+- 'file' => '[^<>\*\$\n]+',
+- 'template_path' => '[\w\-\.\/_]+',
+- 'arc_file' => '[^<>\\\*\$\n]+',
+- 'path' => '[^<>\\\*\$\n]+',
+- 'uploaded_file' => '[^<>\*\$\n]+', # Could be precised (use of "'")
+- 'unzipped_file' => '[^<>\*\$\n]+',
+- 'dir' => '[^<>\\\*\$\n]+',
+- 'name_doc' => '[^<>\\\*\$\[\]\/\n]+',
+- 'shortname' => '[^<>\\\*\$\n]+',
+- 'new_name' => '[^<>\\\*\$\n]+',
+- 'id' => '[^<>\\\*\$\n]+',
+- 'template_name' => &tools::get_regexp('template_name'),
+- 'new_template_name' => &tools::get_regexp('template_name'),
+- 'message_template' => &tools::get_regexp('template_name'),
+- 'new_default' => &tools::get_regexp('template_name'),
+-
+- ## Archives
+- 'month' => '\d{2}|\d{4}\-\d{2}', ## format is yyyy-mm for 'arc' and mm for 'send_me'
+-
+- ## URL
+- 'referer' => '[^\\\$\*\"\'\`\^\|\<\>\n]+',
+- 'failure_referer' => '[^\\\$\*\"\'\`\^\|\<\>\n]+',
+- 'url' => '[^\\\$\*\"\'\`\^\|\<\>\n]+',
+-
+- ## Msg ID
+- 'msgid' => '[^\\\*\"\'\`\^\|\n]+',
+- 'in_reply_to' => '[^\\\*\"\'\`\^\|\n]+',
+- 'message_id' => '[^\\\*\"\'\`\^\|\n]+',
+-
+- ## Password
+- 'passwd' => '.+',
+- 'password' => '.+',
+- 'newpasswd1' => '.+',
+- 'newpasswd2' => '.+',
+- 'new_password' => '.+',
+-
+- ## Topics
+- 'topic' => '[\-\w\/]+',
+- 'topics' => '[\-\w\/]+',
+- 'subtopic' => '[\-\w\/]+',
+-
+-
+- ## List names
+- 'list' => '[\w\-\.\+]*', ## &tools::get_regexp('listname') + uppercase
+- 'previous_list' => '[\w\-\.\+]*',
+- 'new_list' => '[\w\-\.\+]*',
+- 'listname' => '[\w\-\.\+]*',
+- 'new_listname' => '[\w\-\.\+]*',
+- 'selected_lists' => '[\w\-\.\+]*',
+-
+- ## Family names
+- 'family_name' => &tools::get_regexp('family_name'),
+-
+- ## Email addresses
+- 'email' => &tools::get_regexp('email').'|'.&tools::get_regexp('uid'),
+- 'init_email' => &tools::get_regexp('email'),
+- 'old_email' => &tools::get_regexp('email'),
+- 'new_email' => &tools::get_regexp('email'),
+- 'pending_email' => &tools::get_regexp('email').',.*', # Email address is followed by ',' + gecos data
+- 'sender' => &tools::get_regexp('email'),
+- 'to' => '(([\w\-\_\.\/\+\=\']+|\".*\")\s[\w\-]+(\.[\w\-]+)+(,?))*',
+-
+- ## Host
+- 'new_robot' => &tools::get_regexp('host'),
+- 'remote_host' => &tools::get_regexp('host'),
+- 'remote_addr' => &tools::get_regexp('host'),
+-
+- ## Scenario name
+- 'scenario' => &tools::get_regexp('scenario'),
+- 'read_access' => &tools::get_regexp('scenario'),
+- 'edit_access' => &tools::get_regexp('scenario'),
+- ## RSS URL or blank
+- 'active_lists' => '.*',
+- 'latest_lists' => '.*',
+- 'latest_arc' => '.*',
+- 'latest_d_read' => '.*',
+-
+- ##Logs
+- 'target_type' => '[\w\-\.\:]*',
+- 'target' => &tools::get_regexp('email'),
+- 'date_from' => '[\d\/]+',
+- 'date_to' => '[\d\/]+',
+- 'ip' => &tools::get_regexp('host'),
+-
+- ## colors
+- 'subaction_test' => '.*',
+- 'subaction_reset' => '.*',
+- 'subaction_install' => '.*',
+- 'custom_color_value' => '\#.*',
+- 'custom_color_0' => '.*',
+- 'custom_color_1' => '.*',
+- 'custom_color_2' => '.*',
+- 'custom_color_3' => '.*',
+- 'custom_color_4' => '.*',
+- 'custom_color_5' => '.*',
+- 'custom_color_6' => '.*',
+- 'custom_color_7' => '.*',
+- 'custom_color_8' => '.*',
+- 'custom_color_9' => '.*',
+- 'custom_color_10' => '.*',
+- 'custom_color_11' => '.*',
+- 'custom_color_12' => '.*',
+- 'custom_color_13' => '.*',
+- 'custom_color_14' => '.*',
+- 'custom_color_15' => '.*',
+-
+- ## Custom attribute
+- 'custom_attribute' => '.*',
+-
+- ## Templates
+- 'scope' => 'distrib|robot|family|list|site',
+-
+- ## Custom Inputs from create_list_request.tt2
+- 'custom_input' => '.*',
+-
+- ## conf parameters
+- 'conf_new_value' => '.*',
+-
+- ## custom actions
+- 'cap' => '.*',
+- 'lcap' => '.*',
+- );
+-
+-## Regexp applied on incoming parameters (%in)
+-## This regular expression defines forbidden expressions applied on all incoming parameters
+-## Note that you can use the ^ and $ expressions to match beginning and ending of expressions
+-my %in_negative_regexp = (
+- 'arc_file' => '^(arctxt|\.)'
+- );
+-
+-## List some required filtering of incoming parameters, depending on current action
+-## Paramater can be '*' or 'param*'
+-## Like Q-encoding
+-my %filtering = ('d_reject_shared' => {'id' => 'qencode'},
+- 'd_install_shared' => {'id' => 'qencode'},
+- 'd_read' => {'path' => 'qencode'},
+- 'd_create_dir' => {'name_doc' => 'qencode', 'path' => 'qencode'},
+- 'd_upload' => {'path' => 'qencode'},
+- 'd_unzip' => {'path' => 'qencode'},
+- 'd_editfile' => {'path' => 'qencode'},
+- 'd_properties' => {'path' => 'qencode'},
+- 'd_overwrite' => {'path' => 'qencode'},
+- 'd_savefile' => {'path' => 'qencode', 'name_doc' => 'qencode'},
+- 'd_describe' => {'path' => 'qencode'},
+- 'd_delete' => {'path' => 'qencode'},
+- 'd_rename' => {'path' => 'qencode','new_name' => 'qencode'},
+- 'd_control' => {'path' => 'qencode'},
+- 'd_change_access' => {'path' => 'qencode'},
+- 'd_set_owner' => {'path' => 'qencode'},
+- 'requestpasswd' => {'email' => 'fix_escape_uri'},
+- 'viewbounce' => {'email' => 'fix_escape_uri'},
+- 'editsubscriber' => {'email' => 'fix_escape_uri'},
+- 'edit_list' => {'*param*' => 'unescape_html'}, ## Required because outgoing parameters have been html-escaped in edit_list_request
+- 'change_email' => {'*email' => 'normalize'}, ## Remove leading/trailing white spaces and lowercase
+- );
+-
+-## Open log
+-$wwsconf->{'log_facility'}||= $Conf{'syslog'};
+-
+-&Log::do_openlog($wwsconf->{'log_facility'}, $Conf{'log_socket_type'}, 'wwsympa');
+-&do_log('info', 'WWSympa started');
+-
+-## Set locale configuration
+-$Language::default_lang = $Conf{'lang'};
+-
+-## Important to leave this there because it defined defaults for user_data_source
+-&List::check_db_connect();
+-
+-my $pinfo = &List::_apply_defaults();
+-
+-## Check that the data structure is uptodate
+-## If not, set the web interface to maintenance mode
+-my $maintenance_mode;
+-unless (&Upgrade::data_structure_uptodate()) {
+- $maintenance_mode = 1;
+- &do_log('err',"Web interface set to maintenance mode ; you should run sympa.pl --upgrade");
+-}
+-
+-&tools::ciphersaber_installed();
+-
+-%::changed_params;
+-
+-my (%in, $query);
+-
+-my $birthday = time ;
+-
+-# Now internal encoding is same as input/output.
+-#XXX## Set output encoding
+-#XXX## All outgoing strings will be recoded transparently using this charset
+-#XXXbinmode STDOUT, ":utf8";
+-
+-#XXX## Incoming data is utf8-encoded
+-#XXXbinmode STDIN, ":utf8";
+-
+- ## Main loop
+- my $loop_count;
+- my $start_time = &POSIX::strftime("%d %b %Y at %H:%M:%S", localtime(time));
+- while ($query = &new_loop()) {
+-
+- undef %::changed_params;
+-
+- undef $param;
+- undef $list;
+- undef $robot;
+- undef $robot_object;
+- undef $ip;
+- undef $rss;
+- undef $session;
+-
+- &Log::set_log_level($Conf{'log_level'});
+- &Language::SetLang($Language::default_lang);
+-
+- ## Empty cache of the List.pm module
+- &List::init_list_cache();
+-
+- ## Check effective ID
+- unless ($> eq (getpwnam(Sympa::Constants::USER))[2]) {
+- $maintenance_mode = 1;
+- &report::reject_report_web('intern_quiet','incorrect_server_config',{},'','');
+- &wwslog('err','Config error: wwsympa should run with UID %s (instead of %s). *** Switching to maintenance mode. ***', (getpwnam(Sympa::Constants::USER))[2], $>);
+- }
+-
+- unless (&List::check_db_connect()) {
+- &report::reject_report_web('system_quiet','no_database',{},'','');
+- &do_log('info','WWSympa requires a RDBMS to run');
+- }
+-
+- ## If in maintenance mode, check if the data structure is now uptodate
+- if ($maintenance_mode && (&Upgrade::data_structure_uptodate() && ($> eq (getpwnam(Sympa::Constants::USER))[2]))) {
+- $maintenance_mode = undef;
+- &do_log('notice',"Data structure seem updated, setting OFF maintenance mode");
+- }
+-
+- ## Get params in a hash
+- # foreach ($query->param) {
+- # $in{$_} = $query->param($_);
+- # }
+- %in = $query->Vars;
+-
+- foreach my $k (keys %::changed_params) {
+- &do_log('debug3', 'Changed Param: %s', $k);
+- }
+-
+- ## Free terminated sendmail processes
+- # &smtp::reaper;
+-
+- ## Parse CGI parameters
+- # &CGI::ReadParse();
+-
+- if (defined $Conf{'robot_by_http_host'}{&get_header_field('SERVER_NAME')}) {
+- my ($selected_robot, $selected_path);
+- my ($k,$v);
+- while (($k, $v) = each %{$Conf{'robot_by_http_host'}{&get_header_field('SERVER_NAME')}}) {
+- if ($ENV{'REQUEST_URI'} =~ /^$k/) {
+- ## Longer path wins
+- if (length($k) > length($selected_path)) {
+- ($selected_robot, $selected_path) = ($v, $k);
+- }
+- }
+- }
+- $robot = $selected_robot;
+- }
+-
+- $robot = $Conf{'host'} unless $robot;
+-
+- ## Create Robot object
+- $robot_object = new Robot $robot;
+-
+- ## Default robot
+- if ($robot eq $Conf{'host'}) {
+- $param->{'default_robot'} = 1;
+- }
+-
+- $param->{'cookie_domain'} = $Conf{'robots'}{$robot}{'cookie_domain'} if $Conf{'robots'}{$robot};
+- $param->{'cookie_domain'} ||= $wwsconf->{'cookie_domain'};
+- $ip = $ENV{'REMOTE_HOST'};
+- $ip = $ENV{'REMOTE_ADDR'} unless ($ip);
+- $ip = 'undef' unless ($ip);
+- ## In case HTTP_HOST does not match cookie_domain
+- my $http_host = &get_header_field('HTTP_HOST');
+- $http_host =~ s/:\d+$//; ## suppress port
+- unless (($http_host =~ /$param->{'cookie_domain'}$/) ||
+- ($param->{'cookie_domain'} eq 'localhost')) {
+- &wwslog('notice', 'Cookie_domain(%s) does NOT match HTTP_HOST; setting cookie_domain to %s', $param->{'cookie_domain'}, $http_host);
+- $param->{'cookie_domain'} = $http_host;
+- }
+-
+- &Log::set_log_level($Conf{'robots'}{$robot}{'log_level'});
+-
+- ## Sympa parameters in $param->{'conf'}
+- $param->{'conf'} = {};
+- foreach my $p ('email','host','sympa','request','soap_url','wwsympa_url','listmaster_email','logo_html_definition',
+- 'main_menu_custom_button_1_url','main_menu_custom_button_1_title','main_menu_custom_button_1_target',
+- 'main_menu_custom_button_2_url','main_menu_custom_button_2_title','main_menu_custom_button_2_target',
+- 'main_menu_custom_button_3_url','main_menu_custom_button_3_title','main_menu_custom_button_3_target',
+- 'dark_color','light_color','text_color','bg_color','error_color','use_blacklist','antispam_feature','custom_robot_parameter',
+- 'selected_color','shaded_color','color_0','color_1','color_2','color_3','color_4','color_5','color_6','color_7','color_8','color_9','color_10','color_11','color_12','color_13','color_14','color_15') {
+-
+- $param->{'conf'}{$p} = &Conf::get_robot_conf($robot, $p);
+- $param->{$p} = &Conf::get_robot_conf($robot, $p) if (($p =~ /_color$/)|| ($p =~ /color_/));
+- }
+-
+-
+- foreach my $auth (keys %{$Conf{'cas_id'}{$robot}}) {
+- &do_log('debug2', "cas authentication service $auth");
+- $param->{'sso'}{$auth} = $auth;
+- }
+-
+- foreach my $auth (keys %{$Conf{'generic_sso_id'}{$robot}}) {
+- &do_log('debug', "Generic SSO authentication service $auth");
+- $param->{'sso'}{$auth} = $Conf{'auth_services'}{$robot}[$Conf{'generic_sso_id'}{$robot}{$auth}]{'service_name'};
+- }
+-
+- $param->{'sso_number'} = $Conf{'cas_number'}{$robot} + $Conf{'generic_sso_number'}{$robot};
+- $param->{'use_passwd'} = $Conf{'use_passwd'}{$robot};
+- $param->{'use_sso'} = 1 if ($param->{'sso_number'});
+- $param->{'authentication_info_url'} = $Conf{'authentication_info_url'}{$robot};
+- $param->{'wwsconf'} = $wwsconf;
+-
+- $param->{'path_cgi'} = $ENV{'SCRIPT_NAME'};
+- $param->{'path_cgi'} =~ s/\/\//\//g; ## Replace '//' with '/' because it would break navigation
+- $param->{'version'} = Sympa::Constants::VERSION;
+- $param->{'date'} = gettext_strftime "%d %b %Y at %H:%M:%S", localtime(time);
+- $param->{'time'} = gettext_strftime "%H:%M:%S", localtime(time);
+-
+- ## Hash defining the parameters where no control is performed (because they are supposed to contain html and/or javascript).
+- $param->{'htmlAllowedParam'} = {
+- 'title' => 1,
+- 'hidden_head' => 1,
+- 'hidden_end' => 1,
+- 'hidden_at' => 1,
+- 'list_protected_email' => 1,
+- 'selected' => 1,
+- 'author_mailto' =>1,
+- 'mailto' =>1,
+- 'logo_html_definition' => 1,
+- 'template_content' => 1,
+- 'html_dumpvars' => 1,
+- };
+- ## Hash defining the parameters where HTML must be filtered.
+- $param->{'htmlToFilter'} = {
+- 'homepage_content' => 1,
+- 'info_content' => 1,
+- };
+-
+- ## Change to list root
+- unless (chdir($Conf{'home'})) {
+- &report::reject_report_web('intern','chdir_error',{},'','','',$robot);
+- &wwslog('info','unable to change directory');
+- exit (-1);
+- }
+-
+- ## Sets the UMASK
+- umask(oct($Conf{'umask'}));
+-
+- ## Authentication
+- ## use https client certificat information if define.
+-
+- ## Default auth method (for scenarios)
+- $param->{'auth_method'} = 'md5';
+-
+- &report::init_report_web();
+-
+- ## Get PATH_INFO parameters
+- &get_parameters();
+-
+- ## CSS related
+- $param->{'css_path'} = &Conf::get_robot_conf($robot, 'css_path');
+- $param->{'css_url'} = &Conf::get_robot_conf($robot, 'css_url');
+- ## If CSS file not found, let Sympa do the job...
+- unless (-f $param->{'css_path'}.'/style.css') {
+- &wwslog('err','Could not find CSS file %s, using default CSS', $param->{'css_path'}.'/style.css') if ($param->{'css_path'}); ## Notice only if path was defined
+- $param->{'css_url'} = $param->{'base_url'}.$param->{'path_cgi'}.'/css';
+- }
+-
+- &wwslog('info', "parameter css_url '%s' seems strange, it must be the url of a directory not a css file", $param->{'css_url'}) if ($param->{'css_url'} =~ /\.css$/);
+-
+- $session = new SympaSession ($robot,{'cookie'=>&SympaSession::get_session_cookie($ENV{'HTTP_COOKIE'}),
+- 'action'=>$in{'action'},
+- 'rss'=>$rss});
+- undef $ENV{'HTTP_COOKIE'}; # Getting rid of the environment variable to make sure it won't be affected to another anonymous session.
+- unless (defined $session) {
+- &List::send_notify_to_listmaster('failed_to_create_web_session', $robot);
+- &wwslog('info','Failed to create session');
+- $session->{'email'}= 'nobody'; $session->{'id_session'} = &get_random();
+- }
+-
+- $param->{'session'} = $session->as_hashref();
+-
+- &Log::set_log_level($session->{'log_level'}) if ($session->{'log_level'});
+- $param->{'restore_email'} = $session->{'restore_email'};
+- $param->{'dumpvars'} = $session->{'dumpvars'};
+- $param->{'unauthenticated_email'} = $session->{'unauthenticated_email'};
+-
+- if ($session->{'custom_color'} == 1) {
+- foreach my $i (0 .. 15){
+- $param->{'color_'.$i} = $session->{'color_'.$i} if ($session->{'color_'.$i});
+- }
+- }
+-
+- ## RSS does not require user authentication
+- unless ($rss) {
+-
+- if (($ENV{'SSL_CLIENT_VERIFY'} eq 'SUCCESS') &&
+- ($in{'action'} ne 'sso_login')) { ## Do not check client certificate automatically if in sso_login
+-
+- &do_log('debug2', "SSL verified, S_EMAIL = %s,"." S_DN_Email = %s", $ENV{'SSL_CLIENT_S_EMAIL'}, $ENV{'SSL_CLIENT_S_DN_Email'});
+- if (($ENV{'SSL_CLIENT_S_EMAIL'})) {
+- ## this is the X509v3 SubjectAlternativeName, and requires
+- ## a patch to mod_ssl -- cm@coretec.at
+- $param->{'user'}{'email'} = lc($ENV{'SSL_CLIENT_S_EMAIL'});
+- }elsif ($ENV{SSL_CLIENT_S_DN_Email}) {
+- $param->{'user'}{'email'} = lc($ENV{'SSL_CLIENT_S_DN_Email'});
+- }elsif ($ENV{'SSL_CLIENT_S_DN'} =~ /\+MAIL=([^\+\/]+)$/) {
+- ## Compatibility issue with old a-sign.at certs
+- $param->{'user'}{'email'} = lc($1);
+- }elsif ($crypt_openssl_x509_ok and exists($ENV{SSL_CLIENT_CERT})) {
+- ## this is the X509v3 SubjectAlternativeName, and does only
+- ## require "SSLOptions +ExportCertData" without patching
+- ## mod_ssl -- massar@unix-ag.uni-kl.de
+- $param->{'user'}{'email'} = lc(Crypt::OpenSSL::X509->new_from_string($ENV{SSL_CLIENT_CERT})->email());
+- }
+-
+- if($param->{user}{email}) {
+- $session->{'email'}= $param->{user}{email} ;
+- $param->{'auth_method'} = 'smime';
+- $session->{'auth'} = 'x509' ;
+- $param->{'ssl_client_s_dn'} = $ENV{'SSL_CLIENT_S_DN'};
+- $param->{'ssl_client_v_end'} = $ENV{'SSL_CLIENT_V_END'};
+- $param->{'ssl_client_i_dn'} = $ENV{'SSL_CLIENT_I_DN'};
+- $param->{'ssl_cipher_usekeysize'} = $ENV{'SSL_CIPHER_USEKEYSIZE'};
+- }
+-
+- }elsif (($session->{'email'}) && ($session->{'email'} ne 'nobody')) {
+- $param->{'user'}{'email'} = $session->{'email'};
+- }elsif($in{'ticket'}=~/(S|P)T\-/){ # the request contain a CAS named ticket that use CAS ticket format
+- delete $session->{'do_not_use_cas'}; #reset do_not_use_cas because this client probably use CAS
+- # select the cas server that redirect the user to sympa and check the ticket
+- do_log ('notice',"CAS ticket is detected. in{'ticket'}=$in{'ticket'} checked_cas=$session->{'checked_cas'}");
+-
+-
+- my $cas_id = '';
+- if ($in{'checked_cas'} =~ /^(\d+)\,?/) {
+- $cas_id = $1;
+- } elsif ($session->{'checked_cas'} =~ /^(\d+)\,?/) {
+- $cas_id = $1;
+- }
+- if ($cas_id ne '') {
+-
+- my $ticket = $in{'ticket'};
+- my $cas_server = $Conf{'auth_services'}{$robot}[$cas_id]{'cas_server'};
+-
+- my $service_url = &wwslib::get_my_url();
+- $service_url =~ s/(\?|&)ticket\=.+$//;
+-
+- my $net_id = $cas_server->validateST($service_url, $ticket);
+-
+- if(defined $net_id) { # the ticket is valid net-id
+- do_log('notice',"login CAS OK server netid=$net_id" );
+- $param->{'user'}{'email'} = lc(&Auth::get_email_by_net_id($robot, $cas_id, {'uid' => $net_id}));
+- $session->{'auth'} = 'cas';
+- $session->{'email'}= $param->{user}{email} ;
+-
+- $session->{'cas_server'} = $cas_id;
+-
+-
+- }else{
+- do_log('err',"CAS ticket validation failed : %s", &AuthCAS::get_errors());
+- }
+- }else{
+- do_log ('notice',"Internal error while receiving a CAS ticket $session->{'checked_cas'} ");
+- }
+- }elsif(($Conf{'cas_number'}{$robot} > 0) && ($in{'action'} !~ /^(login|sso_login|wsdl)$/)) { # some cas server are defined but no CAS ticket detected
+- unless ($session->{'do_not_use_cas'}) {
+- # user not taggued as not using cas
+- foreach my $auth_service (@{$Conf{'auth_services'}{$robot}}){
+- next unless ($auth_service->{'auth_type'} eq 'cas'); # skip auth services not related to cas
+- next unless ($auth_service->{'non_blocking_redirection'} eq 'on');
+-
+- ## skip cas server where client as been already redirect to the list of cas servers already checked is stored in the session
+- ## the check below works fine as long as we don't have more then 10 CAS servers (because we don't properly split the list of values)
+- &do_log ('debug',"check_cas checker_cas : $session->{'checked_cas'} current cas_id $Conf{'cas_id'}{$robot}{$auth_service->{'auth_service_name'}}");
+- next if ($session->{'checked_cas'} =~ /$Conf{'cas_id'}{$robot}{$auth_service->{'auth_service_name'}}/) ;
+-
+- # before redirect update the list of already checked cas server to prevent loop
+- my $cas_server = $auth_service->{'cas_server'};
+- my $return_url = &wwslib::get_my_url();
+-
+- ## Append the current CAS server ID to the list of checked CAS servers
+- $session->{'checked_cas'} .= $Conf{'cas_id'}{$robot}{$auth_service->{'auth_service_name'}};
+-
+- my $redirect_url = $cas_server->getServerLoginGatewayURL($return_url);
+-
+- if ($redirect_url =~ /http(s)+\:\//i) {
+- $in{'action'} = 'redirect';
+- $param->{'redirect_to'} = $redirect_url;
+-
+- last
+- }elsif($redirect_url == -1) { # CAS server auth error
+- do_log('notice',"CAS server auth error $auth_service->{'auth_service_name'}" );
+- }else{
+- do_log('notice',"Strange CAS ticket detected and validated check sympa code !" );
+- }
+- }
+- $session->{'do_not_use_cas'} = 1 unless ($param->{'redirect_to'} =~ /http(s)+\:\//i) ; #set do_not_use_cas because all cas servers have been checked without success
+- }
+- }
+-
+-
+- ##Cookie extern : sympa_altemails
+- ## !!
+- $param->{'alt_emails'} = &cookielib::check_cookie_extern($ENV{'HTTP_COOKIE'},$Conf{'cookie'},$param->{'user'}{'email'});
+-
+- if ($param->{'user'}{'email'}) {
+-# $param->{'auth'} = $param->{'alt_emails'}{$param->{'user'}{'email'}} || 'classic';
+-
+- if (&List::is_user_db($param->{'user'}{'email'})) {
+- $param->{'user'} = &List::get_user_db($param->{'user'}{'email'});
+- }
+-
+- ## For the parser to display an empty field instead of [xxx]
+- $param->{'user'}{'gecos'} ||= '';
+- unless (defined $param->{'user'}{'cookie_delay'}) {
+- $param->{'user'}{'cookie_delay'} = $wwsconf->{'cookie_expire'};
+- }
+-
+- ## Skip get_which if either in a list context or accessing the CSS
+- unless ($in{'action'} eq 'css' || defined $in{'list'}) {
+- @{$param->{'get_which'}} = &List::get_which($param->{'user'}{'email'},$robot,'member') ;
+- @{$param->{'get_which_owner'}} = &List::get_which($param->{'user'}{'email'},$robot,'owner') ;
+- @{$param->{'get_which_editor'}} = &List::get_which($param->{'user'}{'email'},$robot,'editor') ;
+- }
+-# }
+-
+- }
+- } ## END if RSS
+-
+- ## Action
+- my $action = $in{'action'};
+-
+- ## Store current action in the session in order to redirect after a logi or other temporary actions.
+- ## We should not memorize ULRs that are transitory actions
+- ## POST is not handled
+- ## A lot of other methods where used in the past (before session was introduced in Sympa). We must clean all.
+- unless ($temporary_actions{$action} || $ENV{'REQUEST_METHOD'} ne 'GET') {
+- $session->{'redirect_url'} = $param->{'base_url'}.$param->{'path_cgi'}.$ENV{'PATH_INFO'};
+- }
+-
+- $action ||= &Conf::get_robot_conf($robot, 'default_home');
+- $param->{'remote_addr'} = $ENV{'REMOTE_ADDR'} ;
+- $param->{'remote_host'} = $ENV{'REMOTE_HOST'};
+- $param->{'http_user_agent'} = $ENV{'HTTP_USER_AGENT'};
+- $param->{'htmlarea_url'} = $wwsconf->{'htmlarea_url'} ;
+- # if ($wwsconf->{'export_topics'} =~ /all/i);
+-
+- if ($in{'action'} eq 'css') {
+- &do_css();
+- $param->{'action'} = 'css';
+- }elsif ($maintenance_mode) {
+- &do_maintenance();
+- $param->{'action'} = 'maintenance';
+- }else {
+-
+- ## Session loop
+- while ($action) {
+- unless (&check_param_in()) {
+- &report::reject_report_web('user','wrong_param',{},$action,$list);
+- &wwslog('info','Wrong parameters');
+- last;
+- }
+-
+- $param->{'host'} = $list->{'admin'}{'host'} if (ref($list) eq 'List');
+- $param->{'host'} ||= $robot;
+- $param->{'domain'} = $list->{'domain'} if (ref($list) eq 'List');
+-
+- ## language ( $ENV{'HTTP_ACCEPT_LANGUAGE'} not used !)
+- $param->{'list_lang'} = $list->{'admin'}{'lang'} if (ref($list) eq 'List');
+- $param->{'user_lang'} = $param->{'user'}{'lang'} if (defined $param->{'user'});
+- $param->{'lang'} = $session->{'lang'} || $param->{'user_lang'} || $param->{'list_lang'} || &Conf::get_robot_conf($robot, 'lang');
+-
+- $param->{'locale'} = &Language::SetLang($param->{'lang'});
+-
+- &export_topics ($robot);
+-
+- unless ($comm{$action}) {
+- if (new List ($action, $robot)){
+- &do_redirect ($param->{'base_url'}.$param->{'path_cgi'}.'/info/'.$action);
+- last;
+- }
+- &report::reject_report_web('user','unknown_action',{},$action,$list);
+- &wwslog('info','unknown action %s', $action);
+- last;
+- }
+-
+- $param->{'action'} = $action;
+-
+- my $old_action = $action;
+- my $old_subaction = $in{'subaction'};
+-
+- ## Check required action parameters
+- my $check_output = &check_action_parameters($action);
+-
+- if (! defined $check_output ) {
+- &wwslog('err', "missing required parameters for action '$action'");
+- delete($param->{'action'});
+- last;
+-
+- }elsif ($check_output != 1) {
+- ## The output of the check may indicate another action to run first
+- ## Example : running loginrequest if user is not authenticated
+- $action = $param->{'action'} = $check_output;
+- }
+-
+- ## Execute the action ##
+- if (defined $action) {
+- $action = &{$comm{$action}}();
+- }
+-
+- unless (defined $action) {
+- delete($param->{'action'});
+- last;
+- }
+-
+- last if ($action =~ /redirect/) ; # after redirect do not send anything, it will crash fcgi lib
+-
+-
+- if ($action eq $old_action) {
+- # if a subaction is define and change, then it is not a loop
+- if (! defined ($in{'subaction'})||($in{'subaction'} eq $old_subaction)){
+- &wwslog('info','Stopping loop with %s action', $action);
+- #undef $action;
+- $action = 'home';
+- }
+- }
+-
+- undef $action if ($action == 1);
+- }
+- }
+-
+- ## Prepare outgoing params
+- &check_param_out();
+-
+- ## Params
+- $param->{'refparam'} = ref($param);
+- $param->{'action_type'} = $action_type{$param->{'action'}};
+-
+- $param->{'action_type'} = 'none' unless (($param->{'is_priv'})||($param->{'action_type'} eq 'serveradmin'));
+- $param->{'lang'} ||= $param->{'user'}{'lang'} if (defined $param->{'user'});
+- $param->{'lang'} ||= &Conf::get_robot_conf($robot, 'lang');
+-
+- if ($param->{'list'}) {
+- $param->{'list_title'} = $list->{'admin'}{'subject'};
+- $param->{'list_protected_email'} = &get_protected_email_address($param->{'list'}, $list->{'admin'}{'host'});
+- $param->{'title'} = &get_protected_email_address($param->{'list'}, $list->{'admin'}{'host'});
+- $param->{'title_clear_txt'} = "$param->{'list'}";
+-
+- if ($param->{'subtitle'}) {
+- $param->{'main_title'} = "$param->{'list'} - $param->{'subtitle'}";
+- }
+-
+- }else {
+- $param->{'main_title'} = $param->{'title'} = &Conf::get_robot_conf($robot,'title');
+- $param->{'title_clear_txt'} = $param->{'title'};
+- }
+- $param->{'robot_title'} = &Conf::get_robot_conf($robot,'title');
+-
+- ## store in session table this session contexte
+- $session->store();
+-
+- ## Do not manage cookies at this level if content was already sent
+- unless ($param->{'bypass'} eq 'extreme' ||
+- $param->{'action'} eq 'css' ||
+- $maintenance_mode ||
+- $rss) {
+-
+- my $delay = $param->{'user'}{'cookie_delay'};
+- unless (defined $delay) {
+- $delay = $wwsconf->{'cookie_expire'};
+- }
+-
+- if ($delay == 0) {
+- $delay = 'session';
+- }
+- $session->renew() unless($param->{'use_ssl'});
+-
+- unless ($session->set_cookie($param->{'cookie_domain'},$delay,$param->{'use_ssl'})) {
+- &wwslog('notice', 'Could not set HTTP cookie');
+- }
+-
+- ## Set cookies "your_subscribtions" unless in one list page
+- if ($param->{'user'}{'email'} && ref($list) ne 'List') {
+-
+- ## In case get_which was not set
+- @{$param->{'get_which'}} = &List::get_which($param->{'user'}{'email'},$robot,'member') unless (defined $param->{'get_which'});
+- @{$param->{'get_which_owner'}} = &List::get_which($param->{'user'}{'email'},$robot,'owner') unless (defined $param->{'get_which_owner'});
+- @{$param->{'get_which_editor'}} = &List::get_which($param->{'user'}{'email'},$robot,'editor') unless (defined $param->{'get_which_editor'});
+-
+- ## Add lists information to 'which_info'
+- foreach my $list (@{$param->{'get_which'}}) {
+- ## Evaluate AuthZ scenario first
+- my $result = $list->check_list_authz('visibility', $param->{'auth_method'},
+- {'sender' =>$param->{'user'}{'email'} ,
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- next unless (ref($result) eq 'HASH' && $result->{'action'} eq 'do_it');
+-
+- my $l = $list->{'name'};
+- $param->{'which_info'}{$l}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'which_info'}{$l}{'host'} = $list->{'admin'}{'host'};
+- $param->{'which_info'}{$l}{'info'} = 1;
+- }
+- foreach my $list (@{$param->{'get_which_owner'}}) {
+- my $l = $list->{'name'};
+- $param->{'which_info'}{$l}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'which_info'}{$l}{'host'} = $list->{'admin'}{'host'};
+- $param->{'which_info'}{$l}{'info'} = 1;
+- $param->{'which_info'}{$l}{'admin'} = 1;
+- }
+- foreach my $list (@{$param->{'get_which_editor'}}) {
+- my $l = $list->{'name'};
+-
+- $param->{'which_info'}{$l}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'which_info'}{$l}{'host'} = $list->{'admin'}{'host'};
+- $param->{'which_info'}{$l}{'info'} = 1;
+- $param->{'which_info'}{$l}{'admin'} = 1;
+- }
+- }
+- ## Set cookies unless client use https authentication
+- if ($param->{'user'}{'email'}) {
+- if ($param->{'user'}{'email'} ne 'x509') {
+- $session->{'auth'} ||= 'classic';
+- $param->{'cookie_set'} = 1;
+-
+-
+- ###Cookie extern : sympa_altemails
+- my $number = 0;
+- foreach my $element (keys %{$param->{'alt_emails'}}){
+- $number ++ if ($element);
+- }
+-
+- unless ($number == 0) {
+- unless(&cookielib::set_cookie_extern($Conf{'cookie'},$param->{'cookie_domain'},%{$param->{'alt_emails'}})){
+- &wwslog('notice', 'Could not set HTTP cookie for external_auth');
+- }
+- }
+- }
+- } #elsif ($ENV{'HTTP_COOKIE'} =~ /sympauser\=/){
+- # &cookielib::set_cookie('unknown', $Conf{'cookie'}, $param->{'cookie_domain'}, 'now');
+- #}
+- }
+-
+- ## Available languages
+- my $saved_lang = &Language::GetLang();
+-
+-
+- foreach my $l (@{&Language::GetSupportedLanguages($robot)}) {
+- &Language::SetLang($l) || next;
+-
+- if (gettext("_language_")) {
+- $param->{'languages'}{$l}{'complete'} = gettext("_language_");
+- }else {
+- $param->{'languages'}{$l}{'complete'} = $l;
+- }
+-
+- if ($param->{'locale'} eq $l) {
+- $param->{'languages'}{$l}{'selected'} = 'selected="selected"';
+- }else {
+- $param->{'languages'}{$l}{'selected'} = '';
+- }
+- }
+-
+- &Language::SetLang($saved_lang);
+-
+- $param->{'html_dumpvars'} = &tools::dump_html_var($param) if ($session->{'dumpvars'});
+-
+- # if bypass is defined select the content-type from various vars
+- if ($param->{'bypass'}) {
+-
+- ## if bypass = 'extreme' leave the action send the content-type and the content itself
+- unless ($param->{'bypass'} eq 'extreme') {
+-
+- ## if bypass = 'asis', file content-type is in the file itself as is define by the action in $param->{'content_type'};
+- unless ($param->{'bypass'} eq 'asis') {
+- my $type = $param->{'content_type'} || $mime_types->{$param->{'file_extension'}} || 'application/octet-stream';
+- printf "Content-Type: %s\n\n", $type;
+- }
+-
+- # $param->{'file'} or $param->{'error'} must be define in this case.
+-
+- if (open (FILE, $param->{'file'})){
+- print <FILE>;
+- close FILE;
+- }elsif(&report::is_there_any_reject_report_web()){
+- ## for compatibility : it could be better
+- my $intern = &report::get_intern_error_web();
+- my $system = &report::get_system_error_web();
+- my $user = &report::get_user_error_web();
+- my $auth = &report::get_auth_reject_web();
+-
+- if (ref($intern) eq 'ARRAY'){
+- printf "INTERNAL SERVER ERROR\n";
+- };
+- if (ref($system) eq 'ARRAY'){
+- printf "SYSTEM ERROR\n";
+- };
+- if (ref($user) eq 'ARRAY'){
+- foreach my $err (@$user){
+- printf "ERROR : $err\n";
+- }
+- };
+- if (ref($auth) eq 'ARRAY'){
+- foreach my $err (@$auth){
+- printf "AUTHORISATION FAILED : $err\n";
+- }
+- };
+-
+- }else{
+- printf "Internal error content-type nor file defined\n";
+- &do_log('err', 'Internal error content-type nor file defined');
+- }
+- }
+-
+- }elsif ($rss) {
+- ## Send RSS
+- print "Cache-control: no-cache\n";
+- print "Content-Type: application/rss+xml; charset=utf-8\n\n";
+-
+- ## Icons
+- $param->{'icons_url'} = $Conf{'static_content_url'}.'/icons';
+-
+- ## Retro compatibility concerns
+- $param->{'active'} = 1;
+-
+- if (defined $list) {
+- $param->{'list_conf'} = $list->{'admin'};
+- }
+-
+- my $lang = &Language::Lang2Locale($param->{'lang'});
+- my $tt2_include_path = &tools::make_tt2_include_path($robot,'web_tt2',$lang,$list);
+-
+- unless (&tt2::parse_tt2($param,'rss.tt2' ,\*STDOUT, $tt2_include_path, {})) {
+- my $error = &tt2::get_error();
+- $param->{'tt2_error'} = $error;
+- unless (&List::send_notify_to_listmaster('web_tt2_error', $robot, [$error])) {
+- &wwslog('notice','Unable to send notify "web_tt2_error" to listmaster');
+- }
+- }
+-
+-
+-# close FILE;
+- }elsif ($param->{'redirect_to'}) {
+- do_log ('notice',"Redirecting to $param->{'redirect_to'}");
+- print "Location: $param->{'redirect_to'}\n\n";
+- }else {
+- &prepare_report_user();
+- &send_html('main.tt2');
+- }
+-
+- # exit if wwsympa.fcgi itself has changed
+- if ((stat($ENV{'SCRIPT_FILENAME'}))[9] > $birthday ) {
+- do_log('notice',"Exiting because $ENV{'SCRIPT_FILENAME'} has changed since fastcgi server started");
+- exit(0);
+- }
+-
+- }
+-
+- ##############################################################
+- #-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/
+- ##############################################################
+-
+-
+- ## Write to log
+- sub wwslog {
+- my $facility = shift;
+-
+- # do not log if log level if too high regarding the log requested by user
+- return if ($Log::levels{$facility} > $Log::log_level);
+-
+- my $msg = shift;
+-
+- my $remote = $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'};
+-
+- ## Determine calling function and parameters
+- my @call = caller(1);
+- $msg = $call[3].'() ' . $msg if ($call[3]);
+-
+- $msg = "[list $param->{'list'}] " . $msg
+- if $param->{'list'};
+-
+-
+- if ($param->{'alt_emails'}) {
+- my @alts;
+- foreach my $alt (keys %{$param->{'alt_emails'}}) {
+- push @alts, $alt
+- unless ($alt eq $param->{'user'}{'email'});
+- }
+-
+- if ($#alts >= 0) {
+- my $alt_list = join ',', @alts;
+- $msg = "[alt $alt_list] " . $msg;
+- }
+- }
+-
+- $msg = "[user $param->{'user'}{'email'}] " . $msg
+- if $param->{'user'}{'email'};
+-
+- $msg = "[rss] ".$msg
+- if $rss;
+-
+- $msg = "[client $remote] ".$msg
+- if $remote;
+-
+- $msg = "[session $session->{'id_session'}] ".$msg
+- if $session;
+-
+- $msg = "[robot $robot] ".$msg;
+-
+- return &Log::do_log($facility, $msg, @_);
+- }
+-
+-sub web_db_log {
+- my $data = shift;
+-
+- $data->{'client'} = $param->{'remote_addr'};
+- $data->{'daemon'} = 'wwsympa';
+- $data->{'robot'} ||= $robot;
+- $data->{'list'} ||= $list->{'name'} if (defined $list);
+- $data->{'action'} ||= $param->{'action'};
+- $data->{'user_email'} ||= $param->{'user'}{'email'} if (defined $param->{'user'});
+- $data->{'target_email'} ||= $data->{'user_email'}; ## Default email is the user email
+-
+- unless (&Log::db_log($data)) {
+- &wwslog('err','web_db_log: failed to log in database');
+- return undef;
+- }
+-
+- return 1;
+-}
+-
+- sub new_loop {
+- $loop++;
+- my $query;
+-
+- if ($wwsconf->{'use_fast_cgi'}) {
+- $query = new CGI::Fast;
+- $loop_count++;
+- }else {
+- return undef if ($loop > 1);
+-
+- $query = new CGI;
+- }
+-
+- return $query;
+- }
+-
+-sub get_header_field {
+- my $field = shift;
+-
+- ## HTTP_X_ header fields set when using a proxy
+- if ($field eq 'SERVER_NAME') {
+- return $ENV{'HTTP_X_FORWARDED_SERVER'} || $ENV{'SERVER_NAME'};
+- }elsif ($field eq 'HTTP_HOST') {
+- return $ENV{'HTTP_X_FORWARDED_HOST'} || $ENV{'HTTP_HOST'};
+- }else {
+- return $ENV{$field};
+- }
+-}
+-
+-
+-
+-# _split_params is used by get_parameters to split path info in the appropriate parameters list.
+-# It is used also by action ticket to prepare the context stored in the one_time_ticket table in string like path_info
+-# input ENV{'PATH_INFO'} like string, output in the global $param hash
+-sub _split_params {
+- my $args_string = shift;
+-
+- &do_log('debug', "PATH_INFO: %s",$ENV{'PATH_INFO'});
+-
+- $args_string =~ s+^/++;
+-
+- my $ending_slash = 0;
+- if ($args_string =~ /\/$/) {
+- $ending_slash = 1;
+- }
+-
+- my @params = split /\//, $args_string;
+-
+- if ($params[0] eq 'nomenu') {
+- $param->{'nomenu'} = 1;
+- $param->{'path_cgi'} .= '/nomenu'; ## other links should keep the nomenu attribute
+- shift @params;
+- }
+-
+- ## debug mode
+- if ($params[0] =~ /debug(\d)?/) {
+- shift @params;
+- if ($1) {
+- $main::options{'debug_level'} = $1 if ($1);
+- }else{
+- $main::options{'debug_level'} = 1 ;
+- }
+- }else{
+- $main::options{'debug_level'} = 0 ;
+- }
+- do_log ('debug2', "debug level $main::options{'debug_level'}");
+-
+- ## rss mode
+- if ($params[0] eq 'rss') {
+- shift @params;
+- $rss = 1;
+- }
+-
+- if ($#params >= 0) {
+- $in{'action'} = $params[0];
+-
+- my $args;
+- if (defined $action_args{$in{'action'}}) {
+- $args = $action_args{$in{'action'}};
+- }else {
+- $args = $action_args{'default'};
+- }
+-
+- my $i = 1;
+- foreach my $p (@$args) {
+- my $pname;
+- ## More than 1 param
+- if ($p =~ /^\@(\w+)$/) {
+- $pname = $1;
+- $in{$pname} = join '/', @params[$i..$#params];
+- $in{$pname} .= '/' if $ending_slash;
+- last;
+- }
+- else {
+- $pname = $p;
+- $in{$pname} = $params[$i];
+- }
+- &wwslog('debug',"Incoming parameter: $pname=$in{$pname}");
+- $i++;
+- }
+- }
+-}
+-
+-sub get_parameters {
+- # &wwslog('debug3', 'get_parameters');
+-
+- ## CGI URL
+- if ($ENV{'HTTPS'} eq 'on') {
+- $param->{'base_url'} = sprintf 'https://%s', &get_header_field('HTTP_HOST');
+- $param->{'use_ssl'} = 1;
+- }else {
+- $param->{'base_url'} = sprintf 'http://%s', &get_header_field('HTTP_HOST');
+- $param->{'use_ssl'} = 0;
+- }
+-
+- $param->{'path_info'} = $ENV{'PATH_INFO'};
+- $param->{'http_method'} = $ENV{'REQUEST_METHOD'}; ## Usefull to skip previous_action when using POST
+- $param->{'robot_domain'} = $wwsconf->{'robot_domain'}{&get_header_field('SERVER_NAME')};
+-
+- if ($ENV{'REQUEST_METHOD'} eq 'GET') {
+- &_split_params ($ENV{'PATH_INFO'});
+- }elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
+- ## POST
+-
+- if ($in{'javascript_action'}) {
+- ## because of incompatibility javascript
+- $in{'action'} = $in{'javascript_action'};
+- }
+- foreach my $p (keys %in) {
+- do_log('debug2',"POST key $p value $in{$p}") unless ($p =~ /passwd/);
+- if ($p =~ /^((\w*)action)_(\w+)((\.\w+)*)$/) {
+-
+- $in{$1} = $3;
+- if ($4) {
+- foreach my $v (split /\./, $4) {
+- $v =~ s/^\.?(\w+)\.?/$1/;
+- $in{$v} = 1;
+- }
+- }
+- undef $in{$p};
+- }
+- }
+- $param->{'nomenu'} = $in{'nomenu'};
+- }
+-
+- ## Lowercase email addresses
+- $in{'email'} = lc ($in{'email'});
+-
+- ## Don't get multiple listnames
+- if ($in{'list'}) {
+- my @lists = split /\0/, $in{'list'};
+- $in{'list'} = $lists[0];
+- }
+-
+- my $custom_attribute ;
+- my $custom_input;
+-
+- ## Check parameters format
+- foreach my $p (keys %in) {
+-
+- ## Skip empty parameters
+- next if ($in{$p} =~ /^$/);
+-
+- ## Remove DOS linefeeds (^M) that cause problems with Outlook 98, AOL, and EIMS:
+- $in{$p} =~ s/\015//g;
+-
+- #XXX## Convert from the web encoding to unicode string
+- #XXX$in{$p} = Encode::decode('utf8', $in{$p});
+-
+- my @tokens = split (/\./, $p);
+- my $pname = $tokens[0];
+-
+- ## Regular expressions applied on parameters
+-
+- my $regexp;
+- if ($pname =~ /^additional_field/) {
+- $regexp = $in_regexp{'additional_field'};
+- }elsif ($pname =~ /^custom_attribute(.*)$/) {
+- my $key = $tokens[1] ;
+- $regexp = $in_regexp{'custom_attribute'};
+- do_log ('debug2', "get_parameters (custom_attribute) : ($p)($key) $pname $in{$p} $Conf{$key}{type}");
+- $custom_attribute->{$key} = {value=>$in{$p}} ;
+- undef $in{$p} ;
+- }elsif ($pname =~ /^custom_input(.*)$/) {
+- my $key = $tokens[1];
+- $regexp = $in_regexp{'custom_input'};
+- do_log ('debug2', "get_parameters (custom_input) : ($p)($key) $pname $in{$p} $Conf{$key}{type}");
+- $custom_input->{$key} = $in{$p};
+- undef $in{$p};
+- }elsif ($in_regexp{$pname}) {
+- $regexp = $in_regexp{$pname};
+- }else {
+- $regexp = $in_regexp{'*'};
+- }
+-
+- my $negative_regexp;
+- if ($pname =~ /^additional_field/) {
+- $negative_regexp = $in_negative_regexp{'additional_field'};
+- }elsif ($in_negative_regexp{$pname}) {
+- $negative_regexp = $in_negative_regexp{$pname};
+- }
+-
+- # If we are editing an HTML file in the shared, allow HTML but prevent XSS.
+- if ($pname eq 'content' && $in{'action'} eq 'd_savefile' && $in{'path'} =~ $list->{'dir'}.'/shared' && lc($in{'path'}) =~ /\.html?/) {
+- my $tmpparam = $in{$p};
+- $tmpparam = &tools::sanitize_html('robot' => $robot,
+- 'string' => $in{$p});
+- if (defined $tmpparam) {
+- $in{$p} = $tmpparam;
+- }
+- else {
+- &do_log('err','Unable to sanitize parameter %s',$pname);
+- }
+- }
+- foreach my $one_p (split /\0/, $in{$p}) {
+- if ($one_p !~ /^$regexp$/s ||
+- (defined $negative_regexp && $one_p =~ /$negative_regexp/s) ) {
+- ## Dump parameters in a tmp file for later analysis
+- my $dump_file = &Conf::get_robot_conf($robot, 'tmpdir').'/sympa_dump.'.time.'.'.$$;
+- unless (open DUMP, ">$dump_file") {
+- &wwslog('err','get_parameters: failed to create %s : %s', $dump_file, $!);
+- }
+- &tools::dump_var(\%in, 0, \*DUMP);
+- close DUMP;
+-
+- &report::reject_report_web('user','syntax_errors',{'params' => $p},'','');
+- &wwslog('err','get_parameters: syntax error for parameter %s value \'%s\' not conform to regexp:%s ; dumped vars in %s', $pname, $one_p, $regexp, $dump_file);
+- $in{$p} = '';
+- next;
+- }
+- }
+- }
+-
+- $in{custom_attribute} = $custom_attribute ;
+- $in{custom_input} = $custom_input;
+-
+- ## For shared-related actions, Q-encode filenames
+- ## This required for filenames that include non ascii characters
+- if (defined $filtering{$in{'action'}}) {
+-
+- my %apply_to; ## Build list of parameters filters apply to
+- foreach my $p (keys %{$filtering{$in{'action'}}}) {
+- if ($p =~ /\*/) { ## use of wildcar
+- my $p_regexp = $p; $p_regexp =~ s/\*/\.\*/g; ## Turn wildcar into a regexp
+- foreach my $in_key (keys %in) {
+- if ($in_key =~ /^$p_regexp$/) {
+- $apply_to{$in_key} = $filtering{$in{'action'}}{$p};
+- }
+- }
+- }else {
+- $apply_to{$p} = $filtering{$in{'action'}}{$p};
+- }
+- }
+-
+- foreach my $p (keys %apply_to) {
+- my $filtering_action = $apply_to{$p};
+- if ($filtering_action eq 'qencode') {
+- ## Q-encode file path
+- my @tokens = split /\//, $in{$p};
+- foreach my $i (0..$#tokens) {
+- $tokens[$i] = &tools::qencode_filename($tokens[$i]);
+- }
+- $in{$p} = join '/', @tokens;
+- ## Sympa's URI escaping subroutine (tools::escape_chars()) replaces '/' with %A5 ('�' character)
+- ## This should be transformed into a '/' again
+-
+- }elsif ($filtering_action eq 'unescape_html') {
+- $in{$p} = &tools::unescape_chars($in{$p});
+-
+- }elsif ($filtering_action eq 'fix_escape_uri') {
+- $in{$p} =~ s/\xa5/\//g;
+-
+- }elsif ($filtering_action eq 'normalize') {
+- $in{$p} =~ s/^\$+//; ## remove leading \s
+- $in{$p} =~ s/\$+$//; ## remove trailing \s
+- $in{$p} = lc($in{$p}); ## lowercase
+- }
+- }
+- }
+-
+- return 1;
+- }
+-
+-sub get_parameters_old {
+- # &wwslog('debug3', 'get_parameters');
+-
+- ## CGI URL
+- if ($ENV{'HTTPS'} eq 'on') {
+- $param->{'base_url'} = sprintf 'https://%s', &get_header_field('HTTP_HOST');
+- $param->{'use_ssl'} = 1;
+- }else {
+- $param->{'base_url'} = sprintf 'http://%s', &get_header_field('HTTP_HOST');
+- $param->{'use_ssl'} = 0;
+- }
+-
+- $param->{'path_info'} = $ENV{'PATH_INFO'};
+- $param->{'robot_domain'} = $wwsconf->{'robot_domain'}{&get_header_field('SERVER_NAME')};
+-
+- if ($ENV{'REQUEST_METHOD'} eq 'GET') {
+- my $path_info = $ENV{'PATH_INFO'};
+- &do_log('debug', "PATH_INFO: %s",$ENV{'PATH_INFO'});
+-
+- $path_info =~ s+^/++;
+-
+- my $ending_slash = 0;
+- if ($path_info =~ /\/$/) {
+- $ending_slash = 1;
+- }
+-
+- my @params = split /\//, $path_info;
+-
+-
+- # foreach my $i(0..$#params) {
+- # $params[$i] = &tools::unescape_chars($params[$i]);
+- # }
+-
+- if ($params[0] eq 'nomenu') {
+- $param->{'nomenu'} = 1;
+- $param->{'path_cgi'} .= '/nomenu'; ## other links should keep the nomenu attribute
+- shift @params;
+- }
+-
+- ## debug mode
+- if ($params[0] =~ /debug(\d)?/) {
+- shift @params;
+- if ($1) {
+- $main::options{'debug_level'} = $1 if ($1);
+- }else{
+- $main::options{'debug_level'} = 1 ;
+- }
+- }else{
+- $main::options{'debug_level'} = 0 ;
+- }
+- do_log ('debug2', "debug level $main::options{'debug_level'}");
+-
+-
+-
+- ## rss mode
+-########### /^rss$/ ???
+- if ($params[0] eq 'rss') {
+- shift @params;
+- $rss = 1;
+- }
+-
+- if ($#params >= 0) {
+- $in{'action'} = $params[0];
+-
+- my $args;
+- if (defined $action_args{$in{'action'}}) {
+- $args = $action_args{$in{'action'}};
+- }else {
+- $args = $action_args{'default'};
+- }
+-
+- my $i = 1;
+- foreach my $p (@$args) {
+- my $pname;
+- ## More than 1 param
+- if ($p =~ /^\@(\w+)$/) {
+- $pname = $1;
+- $in{$pname} = join '/', @params[$i..$#params];
+- $in{$pname} .= '/' if $ending_slash;
+- last;
+- }
+- else {
+- $pname = $p;
+- $in{$pname} = $params[$i];
+- }
+- $i++;
+- }
+- }
+- }elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
+- ## POST
+-
+- if ($in{'javascript_action'}) {
+- ## because of incompatibility javascript
+- $in{'action'} = $in{'javascript_action'};
+- }
+- foreach my $p (keys %in) {
+- do_log('debug2',"POST key $p value $in{$p}");
+- if ($p =~ /^((\w*)action)_(\w+)((\.\w+)*)$/) {
+-
+- $in{$1} = $3;
+- if ($4) {
+- foreach my $v (split /\./, $4) {
+- $v =~ s/^\.?(\w+)\.?/$1/;
+- $in{$v} = 1;
+- }
+- }
+-
+- undef $in{$p};
+- }
+- }
+-
+- $param->{'nomenu'} = $in{'nomenu'};
+- }
+-
+- ## Lowercase email addresses
+- $in{'email'} = lc ($in{'email'});
+-
+- ## Don't get multiple listnames
+- if ($in{'list'}) {
+- my @lists = split /\0/, $in{'list'};
+- $in{'list'} = $lists[0];
+- }
+-
+-
+- my $custom_attribute ;
+-
+- ## Check parameters format
+- foreach my $p (keys %in) {
+-
+- ## Skip empty parameters
+- next if ($in{$p} =~ /^$/);
+-
+- ## Remove DOS linefeeds (^M) that cause problems with Outlook 98, AOL, and EIMS:
+- $in{$p} =~ s/\015//g;
+-
+- #XXX## Convert from the web encoding to unicode string
+- #XXX$in{$p} = Encode::decode('utf8', $in{$p});
+-
+- my @tokens = split (/\./, $p);
+- my $pname = $tokens[0];
+-
+- ## Regular expressions applied on parameters
+-
+- my $regexp;
+- if ($pname =~ /^additional_field/) {
+- $regexp = $in_regexp{'additional_field'};
+- }elsif ($pname =~ /^custom_attribute(.*)$/) {
+- my $key = $tokens[1] ;
+- $regexp = $in_regexp{'custom_attribute'};
+- do_log ('debug2', "get_parameters (custom_attribute) : ($p)($key) $pname $in{$p} $Conf{$key}{type}");
+- $custom_attribute->{$key} = {value=>$in{$p}} ;
+- undef $in{$p} ;
+-
+- }elsif ($in_regexp{$pname}) {
+- $regexp = $in_regexp{$pname};
+- }else {
+- $regexp = $in_regexp{'*'};
+- }
+-
+- my $negative_regexp;
+- if ($pname =~ /^additional_field/) {
+- $negative_regexp = $in_negative_regexp{'additional_field'};
+- }elsif ($in_negative_regexp{$pname}) {
+- $negative_regexp = $in_negative_regexp{$pname};
+- }
+-
+- # If we are editing an HTML file in the shared, allow HTML but prevent XSS.
+- if ($pname eq 'content' && $in{'action'} eq 'd_savefile' && $in{'path'} =~ $list->{'dir'}.'/shared' && lc($in{'path'}) =~ /\.html?/) {
+- my $tmpparam = $in{$p};
+- $tmpparam = &tools::sanitize_html('robot' => $robot,
+- 'string' => $in{$p});
+- if (defined $tmpparam) {
+- $in{$p} = $tmpparam;
+- }
+- else {
+- &do_log('err','Unable to sanitize parameter %s',$pname);
+- }
+- }
+-
+- foreach my $one_p (split /\0/, $in{$p}) {
+- if ($one_p !~ /^$regexp$/s ||
+- (defined $negative_regexp && $one_p =~ /$negative_regexp/s) ) {
+- ## Dump parameters in a tmp file for later analysis
+- my $dump_file = &Conf::get_robot_conf($robot, 'tmpdir').'/sympa_dump.'.time.'.'.$$;
+- unless (open DUMP, ">$dump_file") {
+- &wwslog('err','get_parameters: failed to create %s : %s', $dump_file, $!);
+- }
+- &tools::dump_var(\%in, 0, \*DUMP);
+- close DUMP;
+-
+- &report::reject_report_web('user','syntax_errors',{'params' => $p},'','');
+- &wwslog('err','get_parameters: syntax error for parameter %s value \'%s\' not conform to regexp:%s ; dumped vars in %s', $pname, $one_p, $regexp, $dump_file);
+- $in{$p} = '';
+- next;
+- }
+- }
+- }
+-
+- $in{custom_attribute} = $custom_attribute ;
+-
+- ## For shared-related actions, Q-encode filenames
+- ## This required for filenames that include non ascii characters
+- if (defined $filtering{$in{'action'}}) {
+-
+- foreach my $p (keys %{$filtering{$in{'action'}}}) {
+- if ($filtering{$in{'action'}}{$p} eq 'qencode') {
+- ## Q-encode file path
+- my @tokens = split /\//, $in{$p};
+- foreach my $i (0..$#tokens) {
+- $tokens[$i] = &tools::qencode_filename($tokens[$i]);
+- }
+- $in{$p} = join '/', @tokens;
+- ## Sympa's URI escaping subroutine (tools::escape_chars()) replaces '/' with %A5 ('�' character)
+- ## This should be transformed into a '/' again
+-
+- }elsif ($filtering{$in{'action'}}{$p} eq 'fix_escape_uri') {
+- $in{$p} =~ s/\xa5/\//g;
+- }
+- }
+- }
+-
+- return 1;
+- }
+-
+-## Check required parameters for an action
+-## It compares incoming parameter to those declared as required in %required_args
+-## Also check required privileges to perform each action
+-sub check_action_parameters {
+- my $action = shift;
+-
+- if (defined $required_args{$action}) {
+- foreach my $arg_name (@{$required_args{$action}}) {
+-
+- ## Missing list parameter
+- if ($arg_name eq 'param.list') {
+- unless (defined $list) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$action);
+- &wwslog('info','missing list parameter');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'no_list'});
+-
+- return undef;
+- }
+-
+- ## User is not authenticated
+- }elsif ($arg_name eq 'param.user.email') {
+- unless (defined $param->{'user'} && $param->{'user'}{'email'}) {
+- &report::reject_report_web('user','no_user',{},$action);
+- &wwslog('err','user not logged in');
+- &web_db_log({'status' => 'error',
+- 'error_type' => "not_logged_in"});
+-
+- ## User is redirected to the login request form
+- $param->{'previous_action'} = $action;
+- $param->{'previous_list'} = $param->{'list'} if (defined $param->{'list'});
+- return 'loginrequest';
+-
+- }
+- ## Other incoming parameters
+- }else {
+- ## There may be alternate parameters
+- ## Then at least one of them MUST be set
+- my @req_parameters = split(/\|/, $arg_name);
+- my $ok = 0;
+- foreach my $req_param (@req_parameters) {
+- $ok =1 if ($in{$req_param});
+- }
+- unless ($ok) {
+- ## Replace \0 and '|' with ',' before logging
+- $in{$arg_name} =~ s/\0/,/g;
+- $in{$arg_name} =~ s/\|/,/g;
+-
+- &report::reject_report_web('user','missing_arg',{'argument' => $arg_name},$action);
+- &wwslog('info',"missing parameter '$arg_name'");
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return undef;
+- }
+- }
+- }
+- }
+-
+- ## Check required privileges
+- if (defined $required_privileges{$action}) {
+- ## There may be alternate privileges
+- ## Then at least one of them MUST verified
+- my $ok = 0;
+- my $missing_priv;
+- foreach my $req_priv (@{$required_privileges{$action}}) {
+- $ok =1 if ($param->{'is_'.$req_priv});
+- $missing_priv = $req_priv;
+- }
+- unless ($ok) {
+- &report::reject_report_web('auth','action_'.$missing_priv,{},$param->{'action'},$list);
+- &wwslog('info','authorization failed, insufficient privileges');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+- }
+-
+- return 1;
+-}
+-
+-## Send HTML output
+-sub send_html {
+-
+- my $tt2_file = shift;
+-
+- ## Send HTML
+- if ($param->{'date'}) {
+- Language::PushLang("en_US");
+- printf "Date: %s\n", &POSIX::strftime('%a, %d %b %Y %R %z',localtime(time));
+- Language::PopLang();
+- }
+- ## If we set the header indicating the last time the file to send was modified, add an HTTP header (limitate web harvesting).
+- if ($param->{'header_date'}) {
+- Language::PushLang("en_US");
+- printf "Last-Modified: %s\n", &POSIX::strftime('%a, %d %b %Y %R %z',localtime($param->{'header_date'}));
+- Language::PopLang();
+- }
+- print "Cache-control: no-cache\n" unless ( $param->{'action'} eq 'arc') ;
+- print "Content-Type: text/html\n\n";
+-
+- ## Icons
+- $param->{'icons_url'} = $Conf{'static_content_url'}.'/icons';
+-
+-
+- ## Retro compatibility concerns
+- $param->{'active'} = 1;
+-
+- if (defined $list) {
+- $param->{'list_conf'} = $list->{'admin'};
+- }
+-
+- ## Trying to use custom_vars
+- if (defined $list->{'admin'}{'custom_vars'}) {
+- foreach my $var (@{$list->{'admin'}{'custom_vars'}}) {
+- $param->{'custom_vars'}{$var->{'name'}} = $var->{'value'};
+- }
+- }
+-
+- my $lang = &Language::Lang2Locale($param->{'lang'});
+- my $tt2_include_path = &tools::make_tt2_include_path($robot,'web_tt2',$lang,$list);
+-
+- # XSS escaping applied to all outgoing parameters.
+- my $param_copy = &tools::dup_var($param); ## Escape parameters on a copy to avoid altering usefull data.
+- if(defined $param_copy) {
+- unless(&tools::sanitize_var('var' => $param_copy,
+- 'level' => 0,
+- 'robot' => $robot,
+- 'htmlAllowedParam' => $param_copy->{'htmlAllowedParam'} ,
+- 'htmlToFilter' => $param_copy->{'htmlToFilter'} ,
+- )
+- )
+- {
+- &do_log('err','Failed to sanitize $param in host %s', $robot);
+- }
+- }
+-
+- unless (&tt2::parse_tt2($param_copy,$tt2_file , \*STDOUT, $tt2_include_path, {})) {
+- my $error = &tt2::get_error();
+- $param->{'tt2_error'} = $error;
+- $param_copy->{'tt2_error'} = $error;
+- &List::send_notify_to_listmaster('web_tt2_error', $robot, [$error]);
+- &tt2::parse_tt2($param_copy,'tt2_error.tt2' , \*STDOUT, $tt2_include_path);
+- }
+-}
+-
+-sub prepare_report_user {
+-
+- $param->{'intern_errors'} = &report::get_intern_error_web();
+- $param->{'system_errors'} = &report::get_system_error_web();
+- $param->{'user_errors'} = &report::get_user_error_web();
+- $param->{'auth_rejects'} = &report::get_auth_reject_web();
+- $param->{'notices'} = &report::get_notice_web();
+- $param->{'errors'} = &report::is_there_any_reject_report_web();
+-}
+-
+-
+-
+-
+-=pod
+-
+-=head2 sub check_param_in
+-
+-Checks parameters contained in the global variable $in. It is the process used to analyze the incoming parameters.
+-Use it to create a List object and initialize output parameters.
+-
+-=head3 Arguments
+-
+-=over
+-
+-=item * I<None>
+-
+-=back
+-
+-=head3 Return
+-
+-=over
+-
+-=item * I<undef> if the process encounters problems.
+-
+-=item * I<1> if everything goes well
+-
+-=back
+-
+-=head3 Calls
+-
+-=over
+-
+-=item * d_access_control
+-
+-=item * make_pictures_url
+-
+-=item * wwslog
+-
+-=item * Language::SetLang
+-
+-=item * List::am_i
+-
+-=item * List::check_list_authz
+-
+-=item * List::get_mod_spool_size
+-
+-=item * List::get_shared_moderated
+-
+-=item * List::get_subscriber
+-
+-=item * List::get_subscription_request_count
+-
+-=item * List::get_total
+-
+-=item * List::get_total_bouncing
+-
+-=item * List::is_listmaster
+-
+-=item * List::is_moderated
+-
+-=item * List::is_user
+-
+-=item * List::new
+-
+-=item * List::request_action
+-
+-=item * report::reject_report_web
+-
+-=back
+-
+-=cut
+-
+- ## Analysis of incoming parameters
+- sub check_param_in {
+- &wwslog('debug2', 'check_param_in');
+-
+- ## Lowercase list name
+- $in{'list'} =~ tr/A-Z/a-z/;
+-
+- ## In case the variable was multiple
+- if ($in{'list'} =~ /^(\S+)\0/) {
+- $in{'list'} = $1;
+-
+- ## Create a new List instance.
+- unless ($list = new List ($in{'list'}, $robot)) {
+- &report::reject_report_web('user','unknown_list',{'list' => $in{'list'}},$param->{'action'},'');
+- &wwslog('info','check_param_in: unknown list %s', $in{'list'});
+- return undef;
+- }
+-
+- ## Set lang to list lang
+- &Language::SetLang($list->{'admin'}{'lang'});
+- }
+-
+- ## listmaster has owner and editor privileges for the list
+- if (&List::is_listmaster($param->{'user'}{'email'},$robot)) {
+- $param->{'is_listmaster'} = 1;
+- }
+-
+- if ($in{'list'}) {
+- ## Create a new List instance.
+- unless ($list = new List ($in{'list'}, $robot, {})) {
+- &report::reject_report_web('user','unknown_list',{'list' => $in{'list'}},$param->{'action'},'');
+- &wwslog('info','check_param_in: unknown list %s', $in{'list'});
+- return undef;
+- }
+-
+- ## Gather list configuration informations for further output.
+- $param->{'list'} = $in{'list'};
+- $param->{'subtitle'} = $list->{'admin'}{'subject'};
+- $param->{'subscribe'} = $list->{'admin'}{'subscribe'}{'name'};
+- $param->{'send'} = $list->{'admin'}{'send'}{'title'}{$param->{'lang'}};
+-
+- # Pictures are not available unless it is configured for the list and the robot
+- if ($list->{'admin'}{'pictures_feature'} eq 'off') {
+- $param->{'pictures_display'} = undef;
+- }
+- else {
+- $param->{'pictures_display'} = 'on';
+- }
+-
+- ## Get the total number of subscribers to the list.
+- if (defined $param->{'total'}) {
+- $param->{'total'} = $list->get_total();
+- }else {
+- $param->{'total'} = $list->get_total('nocache');
+- }
+-
+- ## Check if the current list has a public key X.509 certificate.
+- $param->{'list_as_x509_cert'} = $list->{'as_x509_cert'};
+-
+- ## Stores to output the whole list's admin configuration.
+- $param->{'listconf'} = $list->{'admin'};
+-
+- ## If an user is logged in, checks this user's privileges.
+- if ($param->{'user'}{'email'}) {
+- $param->{'is_subscriber'} = $list->is_user($param->{'user'}{'email'});
+- $param->{'subscriber'} = $list->get_subscriber($param->{'user'}{'email'})
+- if $param->{'is_subscriber'};
+- $param->{'is_privileged_owner'} = $param->{'is_listmaster'} || $list->am_i('privileged_owner', $param->{'user'}{'email'});
+- $param->{'is_owner'} = $param->{'is_privileged_owner'} || $list->am_i('owner', $param->{'user'}{'email'});
+- $param->{'is_editor'} = $list->am_i('editor', $param->{'user'}{'email'});
+- $param->{'is_priv'} = $param->{'is_owner'} || $param->{'is_editor'};
+- $param->{'pictures_url'} = &tools::make_pictures_url('email' => $param->{'user'}{'email'}, 'list' => $list);
+-
+- ## Checks if the user can post in this list.
+- my $result = $list->check_list_authz('send',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+- $param->{'may_post'} = 1 if ($r_action !~ /reject/);
+-
+- ## If no user logged in, the output can ask for authentification.
+- }else {
+- $param->{'user'}{'email'} = undef;
+- $param->{'need_login'} = 1;
+-
+- }
+-
+- ## Check if this list's messages must be moderated.
+- $param->{'is_moderated'} = $list->is_moderated();
+-
+- ## If the user logged in is a privileged user, gather informations relative to administration tasks
+- if ($param->{'is_priv'}) {
+- $param->{'mod_message'} = $list->get_mod_spool_size();
+-
+- $param->{'mod_subscription'} = $list->get_subscription_request_count();
+-
+- $param->{'doc_mod_list'} = $list->get_shared_moderated();
+- $param->{'mod_total_shared'} = $#{$param->{'doc_mod_list'}} + 1;
+-
+- if ($param->{'total'} > 0) {
+- $param->{'bounce_total'} = $list->get_total_bouncing();
+- $param->{'bounce_rate'} = $param->{'bounce_total'} * 100 / $param->{'total'};
+- $param->{'bounce_rate'} = int ($param->{'bounce_rate'} * 10) / 10;
+- }else {
+- $param->{'bounce_rate'} = 0;
+- }
+- $param->{'mod_total'} = $param->{'mod_total_shared'}+$param->{'mod_message'}+$param->{'mod_subscription'};
+- }
+-
+-
+- ## Check unsubscription authorization for the current user and list.
+- my $result = $list->check_list_authz('unsubscribe',$param->{'auth_method'},
+- {'sender' =>$param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- $main::action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- if (! $param->{'user'}{'email'}) {
+- $param->{'may_signoff'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
+-
+- }elsif ($param->{'is_subscriber'}) {
+- $param->{'may_signoff'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
+- $param->{'may_suboptions'} = 1;
+- }
+-
+- ## Check subscription authorization for the current user and list.
+- my $result = $list->check_list_authz('subscribe',$param->{'auth_method'},
+- {'sender' =>$param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- $main::action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- $param->{'may_subscribe'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
+-
+-
+- ## Check if the current user can read the shared documents.
+- my %mode;
+- $mode{'read'} = 1;
+- my %access = &d_access_control(\%mode,"");
+- $param->{'may_d_read'} = $access{'may'}{'read'};
+-
+- ## Check the status (exists, deleted, doesn't exist) of the shared directory
+- $param->{'shared'} = $list->get_shared_status();
+- }
+-
+- ## Check if the current user can create a list.
+- my $result = &Scenario::request_action ('create_list',$param->{'auth_method'},$robot,
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+- $param->{'create_list_reason'} = $reason;
+-
+- if ($param->{'user'}{'email'} &&
+- (($param->{'create_list'} = $r_action ) =~ /do_it|listmaster/)) {
+- $param->{'may_create_list'} = 1;
+- }else{
+- undef ($param->{'may_create_list'});
+- }
+-
+- return 1;
+-
+- }
+-
+- ## Prepare outgoing params
+- sub check_param_out {
+- &wwslog('debug2', 'check_param_out');
+-
+- $param->{'loop_count'} = $loop_count;
+- $param->{'start_time'} = $start_time;
+- $param->{'process_id'} = $$;
+-
+- ## listmaster has owner and editor privileges for the list
+- if (&List::is_listmaster($param->{'user'}{'email'},$robot)) {
+- $param->{'is_listmaster'} = 1;
+- }else {
+- undef $param->{'is_listmaster'};
+- }
+-
+- ## Reset $list variable if it is not expected for the current action
+- ## To prevent the list panel from being printed in a non list context
+- ## Only check if the corresponding entry exists in %action_args
+- if (defined $param->{'action'} && defined $action_args{$param->{'action'}}) {
+- unless (grep /^list$/, @{$action_args{$param->{'action'}}}) {
+- $param->{'list'} = undef;
+- $list = undef;
+- }
+- }
+-
+- ## Email addresses protection
+-
+- if (defined $list) {
+- if ($list->{'admin'}{'spam_protection'} eq 'at') {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = ' AT '; $param->{'hidden_end'} = '';
+- }elsif($list->{'admin'}{'spam_protection'} eq 'javascript') {
+- $param->{'protection_type'} = 'javascript';
+- $param->{'hidden_head'} = '
+- <script type="text/javascript">
+- <!--
+- document.write("';
+- $param->{'hidden_at'} ='" + "@" + "';
+- $param->{'hidden_end'} ='")
+- // -->
+- </script>';
+- }else {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = '@'; $param->{'hidden_end'} = '';
+- }
+- }else {
+- if (&Conf::get_robot_conf($robot,'spam_protection') eq 'at') {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = ' AT '; $param->{'hidden_end'} = '';
+- }elsif(&Conf::get_robot_conf($robot,'spam_protection') eq 'javascript') {
+- $param->{'protection_type'} = 'javascript';
+- $param->{'hidden_head'} = '
+- <script type="text/javascript">
+- <!--
+- document.write("';
+- $param->{'hidden_at'} ='" + "@" + "';
+- $param->{'hidden_end'} ='")
+- // -->
+- </script>';
+- }else {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = '@'; $param->{'hidden_end'} = '';
+- }
+- }
+-
+- if ($list->{'name'}) {
+- &wwslog('debug2', "list-name $list->{'name'}");
+-
+- ## Email addresses protection
+- if ($in{'action'} eq 'arc') {
+- $param->{'protection_type'} = undef;
+- if ($list->{'admin'}{'web_archive_spam_protection'} eq 'at') {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = ' AT '; $param->{'hidden_end'} = '';
+- }elsif($list->{'admin'}{'web_archive_spam_protection'} eq 'javascript') {
+- $param->{'protection_type'} = 'javascript';
+- $param->{'hidden_head'} = '
+- <script type="text/javascript">
+- <!--
+- document.write("';
+- $param->{'hidden_at'} ='" + "@" + "';
+- $param->{'hidden_end'} ='")
+- // -->
+- </script>';
+- }else {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = '@'; $param->{'hidden_end'} = '';
+- }
+- }else {
+- if ($list->{'admin'}{'spam_protection'} eq 'at') {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = ' AT '; $param->{'hidden_end'} = '';
+- }elsif($list->{'admin'}{'spam_protection'} eq 'javascript') {
+- $param->{'hidden_head'} = '
+- <script type="text/javascript">
+- <!--
+- document.write("';
+- $param->{'hidden_at'} ='" + "@" + "';
+- $param->{'hidden_end'} ='")
+- // -->
+- </script>';
+- }else {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = '@'; $param->{'hidden_end'} = '';
+- }
+- }
+-
+- ## Owners
+- my $owners = $list->get_owners();
+- foreach my $o (@{$owners}) {
+- next unless $o->{'email'};
+- $param->{'owner'}{$o->{'email'}}{'gecos'} = $o->{'gecos'};
+- $param->{'owner'}{$o->{'email'}}{'visibility'} = $o->{'visibility'};
+- $param->{'owner'}{$o->{'email'}}{'mailto'} = &mailto($list,$o->{'email'},$o->{'gecos'});
+- ($param->{'owner'}{$o->{'email'}}{'local'},$param->{'owner'}{$o->{'email'}}{'domain'}) = split ('@',$o->{'email'});
+- my $masked_email = $o->{'email'};
+- $masked_email =~ s/\@/ AT /;
+- $param->{'owner'}{$o->{'email'}}{'masked_email'} = $masked_email;
+- }
+-
+- ## Editors
+- if (defined $list->{'admin'}{'editor'}) {
+- my $editors = $list->get_editors();
+- foreach my $e (@{$editors}) {
+- next unless $e->{'email'};
+- $param->{'editor'}{$e->{'email'}}{'gecos'} = $e->{'gecos'};
+- $param->{'editor'}{$e->{'email'}}{'visibility'} = $e->{'visibility'};
+- $param->{'editor'}{$e->{'email'}}{'mailto'} = &mailto($list,$e->{'email'},$e->{'gecos'});
+- ($param->{'editor'}{$e->{'email'}}{'local'},$param->{'editor'}{$e->{'email'}}{'domain'}) = split ('@',$e->{'email'});
+- my $masked_email = $e->{'email'};
+- $masked_email =~ s/\@/ AT /;
+- $param->{'editor'}{$e->{'email'}}{'masked_email'} = $masked_email;
+- }
+- }
+-
+- ## Environment variables
+- foreach my $k (keys %ENV) {
+- $param->{'env'}{$k} = $ENV{$k};
+- }
+- ## privileges
+- if ($param->{'user'}{'email'}) {
+- $param->{'is_subscriber'} = $list->is_user($param->{'user'}{'email'});
+- $param->{'subscriber'} = $list->get_subscriber($param->{'user'}{'email'})
+- if $param->{'is_subscriber'};
+- $param->{'is_privileged_owner'} = $param->{'is_listmaster'} || $list->am_i('privileged_owner', $param->{'user'}{'email'});
+- $param->{'is_owner'} = $param->{'is_privileged_owner'} || $list->am_i('owner', $param->{'user'}{'email'});
+- $param->{'is_editor'} = $list->am_i('editor', $param->{'user'}{'email'});
+- $param->{'is_priv'} = $param->{'is_owner'} || $param->{'is_editor'};
+-
+- #May post:
+- my $result = $list->check_list_authz('send',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+-
+- my $r_action;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- if ($r_action =~ /do_it/) {
+- $param->{'may_post'} = 1 ;
+- }else {
+- $param->{'may_post_reason'} = $reason;
+- }
+-
+-
+- if (($list->{'admin'}{'user_data_source'} eq 'include2') &&
+- $list->has_include_data_sources() &&
+- $param->{'is_owner'}) {
+- $param->{'may_sync'} = 1;
+- }
+- }else {
+- ## If user not logged in && GET method && not an authN-related action
+- ## Keep track of the 'referer' parameter
+- if ($ENV{'REQUEST_METHOD'} eq 'GET' &&
+- ! $auth_action{$in{'action'}} ) {
+- $param->{'referer'} = &tools::escape_chars(&wwslib::get_my_url());
+- }else {
+- ## Keep the previous value of the referer
+- $param->{'referer'} = $in{'referer'};
+- }
+- }
+-
+- ## Should Not be used anymore ##
+- $param->{'may_subunsub'} = 1
+- if ($param->{'may_signoff'} || $param->{'may_subscribe'});
+-
+- ## May review
+- my $result = $list->check_list_authz('review',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- $param->{'may_suboptions'} = 1 unless ($list->{'admin'}{'user_data_source'} eq 'include');
+- $param->{'total'} = $list->get_total();
+- $param->{'may_review'} = 1 if ($r_action =~ /do_it/);
+- $param->{'list_status'} = $list->{'admin'}{'status'};
+-
+- ## May signoff
+- my $result = $list->check_list_authz('unsubscribe',$param->{'auth_method'},
+- {'sender' =>$param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- $main::action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- if (! $param->{'user'}{'email'}) {
+- $param->{'may_signoff'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
+-
+- }elsif ($param->{'is_subscriber'} &&
+- ($param->{'subscriber'}{'subscribed'} == 1)) {
+- $param->{'may_signoff'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
+- $param->{'may_suboptions'} = 1;
+- }
+-
+- ## May Subscribe
+- my $result = $list->check_list_authz('subscribe',$param->{'auth_method'},
+- {'sender' =>$param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- $main::action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- $param->{'may_subscribe'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
+-
+-
+-
+- ## Archives Access control
+- if (defined $list->{'admin'}{'web_archive'}) {
+- $param->{'is_archived'} = 1;
+-
+- ## Check if the current user may access web archives
+- my $result = $list->check_list_authz('web_archive.access',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- if ($r_action =~ /do_it/i) {
+- $param->{'arc_access'} = 1;
+- }else{
+- undef ($param->{'arc_access'});
+- }
+-
+- ## Check if web archive is publically accessible (useful information for RSS)
+- my $result = $list->check_list_authz('web_archive.access',$param->{'auth_method'},
+- {'sender' => 'nobody'});
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- if ($r_action =~ /do_it/i) {
+- $param->{'arc_public_access'} = 1;
+- }
+- }
+-
+- ## Shared documents access control
+- if ($list->get_shared_status() eq 'exist') {
+- ## Check if shared is publically accessible (useful information for RSS)
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => 'nobody'});
+- my $r_action;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- }
+-
+- if ($r_action =~ /do_it/i) {
+- $param->{'shared_public_access'} = 1;
+- }
+-
+- }
+- }
+-
+- $param->{'robot'} = $robot;
+-
+- ## If parameter has the Unicode Perl flag, then switch to utf-8
+- ## this switch is applied recursively
+- &tools::recursive_transformation($param, \&tools::unicode_to_utf8);
+-
+- }
+-
+-## ticket : this action is used if someone submits a one time ticket
+-sub do_ticket {
+- &wwslog('info', 'do_ticket(%s)', $in{'ticket'});
+-
+- $param->{'ticket_context'} = &Auth::get_one_time_ticket($in{'ticket'}, $ip );
+- $param->{'ticket_context'}{'printable_date'} = gettext_strftime "%d %b %Y at %H:%M:%S", localtime($param->{'ticket_context'}{'date'});
+-
+- return 1 unless ($param->{'ticket_context'}{'result'} eq 'success' or $param->{'ticket_context'}{'result'} eq 'closed');
+-
+- # if the ticket is related to someone which is not logged in, the system performs the same operation as for a login
+- my $email_regexp = &tools::get_regexp('email');
+- if ($param->{'ticket_context'}{'result'} eq 'success') {
+- $session->{'email'} = lc($param->{'ticket_context'}{'email'});
+- $param->{'user'} = &List::get_user_db($session->{'email'});
+- $param->{'user'}{'email'} = $session->{'email'} ;
+- $param->{'last_login _host'} = $param->{'user'}{'last_login_host'};
+- $param->{'last_login_date'} = &POSIX::strftime("%d %b %Y at %H:%M:%S", localtime($param->{'user'}{'last_login_date'})) if ($param->{'user'}{'last_login_date'});
+- &List::update_user_db($param->{'user'}{'email'},{last_login_date =>time(),last_login_host=>$ip }) ;
+- }elsif($param->{'ticket_context'}{'result'} eq 'closed'){
+- &wwslog('info', 'do_ticket(%s) : Refusing to perform login because the ticket has been used before', $in{'ticket'});
+- return 1;
+- }else{
+- &wwslog('err', 'do_ticket(%s) : Unable to evaluate the ticket validity (status: %s)', $in{'ticket'}, $param->{'ticket_context'}{'result'});
+- return 1;
+- }
+- &_split_params($param->{'ticket_context'}{'data'});
+- return $in{'action'} ;
+-
+-}
+-
+-
+- ## Login WWSympa
+- sub do_login {
+- &wwslog('info', 'do_login(%s)', $in{'email'});
+- my $user;
+- my $next_action;
+-
+- if ($in{'referer'}) {
+- $param->{'redirect_to'} = &tools::unescape_chars($in{'referer'});
+- }elsif ($in{'previous_action'} &&
+- $in{'previous_action'} !~ /^(login|logout|loginrequest)$/) {
+- $next_action = $in{'previous_action'};
+- $in{'list'} = $in{'previous_list'};
+- }else {
+- $next_action = 'home';
+- }
+- # never return to login or logout when login.
+- $next_action = 'home' if ($in{'next_action'} eq 'login') ;
+- $next_action = 'home' if ($in{'next_action'} eq 'logout') ;
+-
+- if ($param->{'user'}{'email'}) {
+- &report::reject_report_web('user','already_login',{'email' => $param->{'user'}{'email'}},$param->{'action'},'');
+- &wwslog('info','do_login: user %s already logged in', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'already_login'});
+- if ($param->{'nomenu'}) {
+- $param->{'back_to_mom'} = 1;
+- return 1;
+- }else {
+- return $next_action;
+- }
+- }
+-
+- unless ($in{'email'}) {
+- &report::reject_report_web('user','no_email',{},$param->{'action'},'');
+- &wwslog('info','do_login: no email');
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => "no_email"});
+- return $in{'previous_action'} || 'home';
+- }
+-
+- $session->{'unauthenticated_email'} = $param->{'unauthenticated_email'} = $in{'email'};
+-
+- unless ($in{'passwd'}) {
+- my $url_redirect;
+- #Does the email belongs to an ldap directory?
+- if($url_redirect = &is_ldap_user($in{'email'})){
+- $param->{'redirect_to'} = $url_redirect
+- if ($url_redirect && ($url_redirect != 1));
+- }elsif ($in{'failure_referer'}) {
+- $param->{'redirect_to'} = $in{'failure_referer'};
+- }else{
+- $in{'init_email'} = $in{'email'};
+- $param->{'init_email'} = $in{'email'};
+- $param->{'escaped_init_email'} = &tools::escape_chars($in{'email'});
+-
+- &report::reject_report_web('user','missing_arg',{'argument' => 'passwd'},$param->{'action'},'');
+- &wwslog('info','do_login: missing parameter passwd');
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => "missing_parameter"});
+- $param->{'login_error'} = 'missing_password';
+- return $in{'previous_action'} || 'renewpasswd';
+- }
+- }
+-
+- my $data;
+-
+- unless ($ENV{'REQUEST_METHOD'} eq 'POST') {
+- &do_log('notice', "Authentication failed, because do not use HTTP method POST but %s",$ENV{'REQUEST_METHOD'} );
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'not_using_post'});
+- return 'loginrequest';
+- }
+-
+-
+- unless($data = &Auth::check_auth($robot, $in{'email'},$in{'passwd'})){
+- &do_log('notice', "Authentication failed\n");
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'authentication'});
+- my $unauthenticated_user = &List::get_user_db($in{'email'});
+- if ($unauthenticated_user->{'wrong_login_count'} > &Conf::get_robot_conf($robot, 'max_wrong_password')){
+- $param->{'login_error'} = 'password_reset';
+- }else{
+- $param->{'login_error'} = 'wrong_password';
+- }
+- if ($in{'previous_action'}) {
+- delete $in{'passwd'};
+- $in{'list'} = $in{'previous_list'};
+- return $in{'previous_action'};
+- }elsif ($in{'failure_referer'}) {
+- $param->{'redirect_to'} = $in{'failure_referer'};
+- }else {
+- return 'renewpasswd';
+- }
+- }
+- $param->{'user'} = $data->{'user'};
+- $param->{'last_login_host'} = $data->{'user'}{'last_login_host'};
+- $param->{'last_login_date'} = &POSIX::strftime("%d %b %Y at %H:%M:%S", localtime($data->{'user'}{'last_login_date'})) if ($data->{'user'}{'last_login_date'});
+- $session->{'auth'} = $data->{'auth'};
+- my $email = lc($param->{'user'}{'email'});
+- $session->{'email'} = $email;
+- $session->{'unauthenticated_email'} = '';
+-
+- &List::update_user_db($param->{'user'}{'email'},{last_login_date =>time(),last_login_host=>$ip, wrong_login_count =>0}) ;
+-
+- ## Set alt_email
+- if ($data->{'alt_emails'}) {
+- foreach my $k (keys %{$data->{'alt_emails'}}) {
+- $param->{'alt_emails'}{$k} = $data->{'alt_emails'}{$k};
+- }
+- }
+-
+-
+- unless($param->{'alt_emails'}{$email}){
+- unless(&cookielib::set_cookie_extern($Conf{'cookie'},$param->{'cookie_domain'},%{$param->{'alt_emails'}})){
+- &wwslog('notice', 'Could not set HTTP cookie for external_auth');
+- &web_db_log({'parameters' => "$Conf{'cookie'},$param->{'cookie_domain'},%{$param->{'alt_emails'}}",
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'cookie'});
+- return undef;
+- }
+- }
+-
+- ## Current authentication mode
+- #$param->{'auth'} = $param->{'alt_emails'}{$param->{'user'}{'email'}} || 'classic';
+-
+-
+- if ($session->{'lang'}) { # user did choose a specific language before being logged. Apply it as a user pref.
+- &List::update_user_db($param->{'user'}{'email'},{lang=>$session->{'lang'}}) ;
+- $param->{'lang'} = $session->{'lang'};
+- }else{ # user did not choose a specific language, apply user pref for this session.
+- $param->{'lang'} = $user->{'lang'} || $list->{'admin'}{'lang'} || &Conf::get_robot_conf($robot, 'lang');
+- $session->{'lang'} = $param->{'lang'} ;
+- }
+-
+- if ($session->{'review_page_size'}) { # user did choose a specific page size upgrade prefs
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+-
+- if ($session->{'shared_mode'}) { # user did choose a shared expert/standard mode
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+-
+- if ($in{'newpasswd1'} && $in{'newpasswd2'}) {
+- my $old_action = $param->{'action'};
+- $param->{'action'} = 'setpasswd';
+- &do_setpasswd();
+- $param->{'action'} = $old_action;
+- }
+-
+- if ($param->{'nomenu'}) {
+- $param->{'back_to_mom'} = 1;
+- return 1;
+- }
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'success'});
+-
+- &do_redirect ($session->{'redirect_url'});
+- return ;
+-
+- }
+-
+-## Login WWSympa
+-## The sso_login action is made of 4 subactions that make a complete workflow.
+-## Note that this comlexe workflow is only used if the SSO server does not provide
+-## the user email address or if this email address is not trusted and therefore
+-## needs to be checked.
+-## The workflow:
+-## 1) init: determine if email address needs to be collected/checked
+-## 2) requestemail: collect the user email address in a web form. Note that form may be initialized with
+-## one email address provided by the SSO server
+-## 3) validateemail: a challenge is sent to the email address to validate it
+-## 4) confirmemail: user confirms his email address with the challenge
+-sub do_sso_login {
+- &wwslog('info', 'do_sso_login(%s)', $in{'auth_service_name'});
+-
+- delete $session->{'do_not_use_cas'}; #when user require CAS login, reset do_not_use_cas cookie
+- my $next_action;
+-
+- if ($param->{'user'}{'email'}) {
+- &report::reject_report_web('user','already_login',{'email' => $param->{'user'}{'email'}},$param->{'action'},'');
+- &wwslog('err','do_login: user %s already logged in', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'status' => 'error',
+- 'error_type' => "already_login"});
+- return 'home';
+- }
+-
+-
+- ## This is a CAS service
+- if (defined (my $cas_id = $Conf{'cas_id'}{$robot}{$in{'auth_service_name'}})) {
+- my $cas_server = $Conf{'auth_services'}{$robot}[$cas_id]{'cas_server'};
+-
+- my $path = '';
+- if ($param->{'nomenu'}) {
+- $path = "/nomenu";
+- }
+- $path .= "/sso_login_succeeded/$in{'auth_service_name'}";
+-
+- $session->{'checked_cas'} = $cas_id;
+- my $service = "$param->{'base_url'}$param->{'path_cgi'}".$path;
+-
+- my $redirect_url = $cas_server->getServerLoginURL($service);
+- &wwslog('info', 'do_sso_login: redirect_url(%s)', $redirect_url);
+- if ($redirect_url =~ /http(s)+\:\//i) {
+- $in{'action'} = 'redirect';
+- $param->{'redirect_to'} = $redirect_url;
+- $param->{'bypass'} = 'extreme';
+- $session->set_cookie('localhost','session');
+- print "Location: $param->{'redirect_to'}\n\n";
+- }
+-
+- }elsif (defined (my $sso_id = $Conf{'generic_sso_id'}{$robot}{$in{'auth_service_name'}})) {
+- ## Generic SSO
+-
+- ## If contacted via POST, then redirect the user to the URL for the access control to apply
+- if ($ENV{'REQUEST_METHOD'} eq 'POST') {
+- my $path = '';
+- my $service;
+-
+- if ($param->{'nomenu'}) {
+- $path = "/nomenu";
+- }
+- &wwslog('info', 'do_sso_login(): POST request processing');
+-
+- if ($in{'subaction'} eq 'validateemail') {
+- $path .= "/validateemail/$in{'email'}";
+-
+- }elsif ($in{'subaction'} eq 'confirmemail') {
+-
+- $path .= "/confirmemail/$in{'email'}/$in{'ticket'}";
+-
+- }else {
+-
+- $path .= "/init";
+- }
+-
+- my $service = "$param->{'base_url'}$param->{'path_cgi'}/sso_login/$in{'auth_service_name'}".$path;
+-
+- &wwslog('info', 'do_sso_login: redirect user to %s', $service);
+- $in{'action'} = 'redirect';
+- $param->{'redirect_to'} = $service;
+- $param->{'bypass'} = 'extreme';
+- print "Location: $param->{'redirect_to'}\n\n";
+-
+- return 1;
+- }
+-
+- my $email;
+- ## We need to collect/verify the user's email address
+- if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'force_email_verify'}) {
+- my $email_is_trusted = 0;
+-
+- ## the subactions order is : init, requestemail, validateemail, sendssopasswd, confirmemail
+-
+- ## get email from NetiD table
+- if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'internal_email_by_netid'}) {
+- &wwslog('debug', 'do_sso_login(): lookup email internal: %s', $sso_id);
+- if ($email = &Auth::get_email_by_net_id($robot, $sso_id, \%ENV)) {
+- $email_is_trusted = 1;
+- }
+- }
+-
+- ## get email from authN module
+- if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'} && ! $email_is_trusted) {
+- my @email_list = split(/$Conf{'auth_services'}{$robot}[$sso_id]{'http_header_value_separator'}/,
+- lc($ENV{$Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'}}));
+- $email = $email_list[0]; ## Only get the first occurence if multi-valued
+- }
+-
+- ## Start the email validation process
+- if ($in{'subaction'} eq 'init' &&
+- ($email_is_trusted == 0 || ! $email)) {
+- &wwslog('info', 'do_sso_login(): return request email');
+- $session->{'auth'} = 'generic_sso';
+- $param->{'server'}{'key'} = $in{'auth_service_name'};
+- $param->{'subaction'} = 'requestemail';
+- $param->{'init_email'} = $email;
+- return 1;
+- }
+-
+- if (defined($in{'email'}) and !($in{'subaction'} eq 'init')) {
+- $email = $in{'email'};
+- }
+-
+- ## Send a confirmation email and request it on the web interface
+- if ($in{'subaction'} eq 'validateemail') {
+- $session->{'auth'} = 'generic_sso';
+- $param->{'server'}{'key'} = $in{'auth_service_name'};
+- $param->{'init_email'} = $email;
+-
+- ## Replace sendpassword with one time ticket
+- $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'email'},$robot,'sso_login/confirmemail?auth_service_name='.$in{'auth_service_name'},$ip);
+-
+- unless (&sendssopasswd($email)) {
+- &report::reject_report_web('user','incorrect_email',{'email' => $email},$param->{'action'});
+- $param->{'subaction'} = 'requestemail';
+- return 1;
+- }
+-
+- $param->{'subaction'} = 'validateemail';
+- return 1;
+- }
+-
+- if ($in{'subaction'} eq 'confirmemail') {
+- $session->{'auth'} = 'generic_sso' ;
+- $param->{'server'}{'key'} = $in{'auth_service_name'};
+- $param->{'init_email'} = $email;
+- $in{'email'} = $email;
+-
+- #
+- # Check input parameters and verify ticket for email, stolen from do_login
+- #
+- unless ($in{'email'}) {
+- &report::reject_report_web('user','no_email',{},$param->{'action'});
+- &wwslog('info','confirmemail: no email');
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'no_email'});
+- $param->{'subaction'} = 'validateemail';
+- return 1;
+- }
+-
+- unless ($in{'ticket'}) {
+- $in{'init_email'} = $in{'email'};
+- $param->{'init_email'} = $in{'email'};
+- $param->{'escaped_init_email'} = &tools::escape_chars($in{'email'});
+-
+- &report::reject_report_web('user','missing_arg',{'argument' => 'ticket'},$param->{'action'});
+- &wwslog('info','do_sso_login: confirmemail: missing parameter ticket');
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- $param->{'subaction'} = 'validateemail';
+- return 1;
+- }
+-
+- ## Validate the ticket
+- my $ticket_output = &Auth::get_one_time_ticket($in{'ticket'}, $ip );
+- unless ($ticket_output->{'result'} eq 'success'){
+- &report::reject_report_web('user','auth_failed',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'authentication'});
+- &wwslog('err', "Authentication failed\n");
+-
+- $param->{'subaction'} = 'validateemail';
+- return 1;
+- }
+-
+- &wwslog('info', 'do_sso_login: confirmemail: email validation succeeded');
+- # need to create netid to email map entry
+- $email = $in{'email'};
+-
+- # everything is ok to proceed to with possible sympa account created and traddional sso login
+-
+- ## TODO : netidmap_table should also be used when no confirmation is performed
+- if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'internal_email_by_netid'}) {
+-
+- my $netid = $ENV{$Conf{'auth_services'}{$robot}[$sso_id]{'netid_http_header'}};
+- my $idpname = $Conf{'auth_services'}{$robot}[$sso_id]{'service_id'};
+-
+- unless(&List::set_netidtoemail_db($robot, $netid, $idpname, $in{'email'})) {
+- &report::reject_report_web('intern','db_update_failed',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err', 'error update netid map');
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return 'home';
+- }
+-
+- }else {
+- &wwslog('info', 'do_sso_login: confirmemail: validation failed');
+-
+- $param->{'subaction'} = 'validateemail';
+- return 1;
+- }
+- }
+-
+- }else {
+- ##
+- if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'}) {
+- my @email_list = split($Conf{'auth_services'}{$robot}[$sso_id]{'http_header_value_separator'},
+- lc($ENV{$Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'}}));
+- $email = $email_list[0]; ## Only get the first occurence if multi-valued
+-
+- }else {
+- unless (defined $Conf{'auth_services'}{$robot}[$sso_id]{'ldap_host'} &&
+- defined $Conf{'auth_services'}{$robot}[$sso_id]{'ldap_get_email_by_uid_filter'}) {
+- &report::reject_report_web('intern','auth_conf_no_identified_user',{},$param->{'action'},'','',$robot);
+- &wwslog('err','do_sso_login: auth.conf error : either email_http_header or ldap_host/ldap_get_email_by_uid_filter entries should be defined');
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return 'home';
+- }
+-
+- $email = &Auth::get_email_by_net_id($robot, $sso_id, \%ENV);
+- }
+- }
+-
+- unless ($email) {
+- &report::reject_report_web('intern','no_identified_user',{},$param->{'action'},'','',$robot);
+- &wwslog('err','do_sso_login: user could not be identified, no %s HTTP header set', $Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'});
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+-
+- 'status' => 'error',
+- 'error_type' => 'no_email'});
+- return 'home';
+- }
+-
+- $param->{'user'}{'email'} = $email;
+- $session->{'email'} = $email;
+- $session->{'auth'} = 'generic_sso' ;
+-
+- &wwslog('notice', 'User identified as %s', $email);
+-
+- ## There are two ways to list the attributes that Sympa will cache for the user
+- ## Either with a defined header prefix (http_header_prefix)
+- ## Or with an explicit list of header fields (http_header_list)
+- my @sso_attr;
+- if ($Conf{'auth_services'}{$robot}[$sso_id]{'http_header_list'}) {
+- my $list_of_headers = $Conf{'auth_services'}{$robot}[$sso_id]{'http_header_list'};
+-
+- foreach my $field (split(/,/, $list_of_headers)) {
+- if (defined $ENV{$field}) {
+- push @sso_attr, "$field=$ENV{$field}";
+- }
+- }
+-
+- }elsif ($Conf{'auth_services'}{$robot}[$sso_id]{'http_header_list'}) {
+-
+- my $prefix = $Conf{'auth_services'}{$robot}[$sso_id]{'http_header_prefix'};
+-
+- foreach my $k (keys %ENV) {
+- if ($k =~ /^$prefix/) {
+- push @sso_attr, "$k=$ENV{$k}";
+- }
+- }
+- }
+-
+- my $all_sso_attr = join ';', @sso_attr;
+-
+- ## Create user entry if required
+- unless (&List::is_user_db($email)) {
+- unless (&List::add_user_db({'email' => $email})) {
+- &report::reject_report_web('intern','add_user_db_failed',{'user'=>$email},$param->{'action'},'',$email,$robot);
+- &wwslog('info','do_sso_login: add failed');
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- unless (&List::update_user_db($email,
+- {'attributes' => $all_sso_attr })) {
+- &report::reject_report_web('intern','update_user_db_failed',{'user'=>$email},$param->{'action'},'',$email,$robot);
+- &wwslog('info','do_sso_login: update failed');
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &report::notice_report_web('you_have_been_authenticated',{},$param->{'action'});
+-
+- ## Keep track of the SSO used to login
+- ## Required to provide logout feature if available
+- $session->{'sso_id'} = $in{'auth_service_name'};
+-
+- &do_redirect ($session->{'redirect_url'});
+- return ;
+- }else{
+- ## Unknown SSO service
+- &report::reject_report_web('intern','unknown_authentication_service',{'name'=> $in{'auth_service_name'}},$param->{'action'},'','',$robot);
+- &wwslog('err','do_sso_login: unknown authentication service %s', $in{'auth_service_name'});
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return 'home';
+- }
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'success'});
+- return 1;
+-}
+-
+-sub do_sso_login_succeeded {
+- &wwslog('info', 'do_sso_login_succeeded(%s)', $in{'auth_service_name'});
+-
+- if (defined $param->{'user'} && $param->{'user'}{'email'}) {
+- &report::notice_report_web('you_have_been_authenticated',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'status' => 'success'});
+-
+- }else{
+- &report::reject_report_web('user','auth_failed',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'status' => 'error',
+- 'error_type' => 'authentication'});
+- }
+-
+- ## We should refresh the main window
+- if ($param->{'nomenu'}) {
+- $param->{'back_to_mom'} = 1;
+- return 1;
+- }else{
+- &do_redirect ($session->{'redirect_url'});
+- return;
+- }
+-}
+-
+- sub is_ldap_user {
+- my $auth = shift; ## User email or UID
+- &wwslog('debug2',"is_ldap_user ($auth)");
+-
+- unless (&tools::get_filename('etc',{}, 'auth.conf', $robot)) {
+- return undef;
+- }
+-
+- ## List all LDAP servers first
+- my @ldap_servers;
+- foreach my $ldap (@{$Conf{'auth_services'}{$robot}}){
+- next unless ($ldap->{'auth_type'} eq 'ldap');
+-
+- push @ldap_servers, $ldap;
+- }
+-
+- unless ($#ldap_servers >= 0) {
+- return undef;
+- }
+-
+- unless (eval "require Net::LDAP") {
+- &wwslog ('err',"Unable to use LDAP library, Net::LDAP required,install perl-ldap (CPAN) first");
+- return undef;
+- }
+- require Net::LDAP;
+-
+- my ($ldap_anonymous,$filter);
+-
+- foreach my $ldap (@ldap_servers){
+-
+- # skip ldap auth service if the user id or email do not match regexp auth service parameter
+- next unless ($auth =~ /$ldap->{'regexp'}/i);
+-
+- my $param = &tools::dup_var($ldap);
+- my $ds = new Datasource('LDAP', $param);
+-
+- unless (defined $ds && ($ldap_anonymous = $ds->connect())) {
+- &do_log('err',"Unable to connect to the LDAP server '%s'", $ldap->{'ldap_host'});
+- next;
+- }
+-
+- my @alternative_conf = split(/,/,$ldap->{'alternative_email_attribute'});
+- my $attrs = $ldap->{'email_attribute'};
+-
+- if (&tools::valid_email($auth)){
+- $filter = $ldap->{'get_dn_by_email_filter'};
+- }else{
+- $filter = $ldap->{'get_dn_by_uid_filter'};
+- }
+- $filter =~ s/\[sender\]/$auth/ig;
+-
+- ## !! une fonction get_dn_by_email/uid
+-
+- my $mesg = $ldap_anonymous->search(base => $ldap->{'suffix'} ,
+- filter => "$filter",
+- scope => $ldap->{'scope'},
+- timeout => $ldap->{'timeout'} );
+-
+- unless($mesg->count() != 0) {
+- &wwslog('notice','No entry in the Ldap Directory Tree of %s for %s',$ldap->{'host'},$auth);
+- $ds->disconnect();
+- last;
+- }
+-
+- $ds->disconnect();
+- my $redirect = $ldap->{'authentication_info_url'};
+- return $redirect || 1;
+-
+- next unless ($ldap_anonymous);
+- }
+- }
+-
+- ## send back login form
+- sub do_loginrequest {
+- &wwslog('info','do_loginrequest');
+-
+- if ($param->{'user'}{'email'}) {
+- &report::reject_report_web('user','already_login',{'email' => $param->{'user'}{'email'}},$param->{'action'});
+- &wwslog('info','do_loginrequest: already logged in as %s', $param->{'user'}{'email'});
+- return undef;
+- }
+-
+- if ($in{'init_email'}) {
+- $param->{'init_email'} = $in{'init_email'};
+- }
+-
+- if ($in{'previous_action'} eq 'referer') {
+- $param->{'referer'} = &tools::escape_chars($ENV{'HTTP_REFERER'});
+- }elsif (! $param->{'previous_action'}) {
+- $param->{'previous_action'} = 'loginrequest';
+- }
+-
+- $param->{'title'} = 'Login'
+- if ($param->{'nomenu'});
+-
+-
+- return 1;
+- }
+-
+- ## Help / about WWSympa
+- sub do_help {
+- &wwslog('info','do_help(%s)', $in{'help_topic'});
+-
+- ## Contextual help
+- if ($in{'help_topic'}) {
+- if ($in{'help_topic'} eq 'editlist') {
+- foreach my $pname (sort List::by_order keys %{$pinfo}) {
+- next if ($pname =~ /^(comment|defaults)$/);
+-
+- if ($pinfo->{$pname}{'gettext_id'}) {
+- $param->{'param'}{$pname}{'title'} = gettext($pinfo->{$pname}{'gettext_id'});
+- } else {
+- $param->{'param'}{$pname}{'title'} = $pinfo->{$pname}{'title'}{$param->{'lang'}};
+- }
+- $param->{'param'}{$pname}{'comment'} = $pinfo->{$pname}{'comment'}{$param->{'lang'}};
+- }
+- }
+-
+- $param->{'help_topic'} = $in{'help_topic'};
+- }
+-
+- return 1;
+- }
+-
+-# update session cookie and redirect the client to redirect_to parameter or glob var;
+-sub do_redirect {
+-
+- my $redirect_to = shift;
+- &wwslog('info','do_redirect(%s)', $redirect_to);
+-
+- $redirect_to ||= $param->{'redirect_to'};
+- # because of some bug Sympa did redirection to un empty URL. Next line should prevent it.
+- $redirect_to ||= $param->{'base_url'}.$param->{'path_cgi'};
+-
+- $session->set_cookie('localhost','session');
+- print "Location: $redirect_to\n\n";
+- $param->{'bypass'} = 'extreme';
+- return 1;
+-}
+-
+- ## Logout from WWSympa
+- sub do_logout {
+- &wwslog('info','do_logout(%s)', $param->{'user'}{'email'});
+-
+- delete $param->{'user'};
+- $session->{'email'} = 'nobody' ;
+-
+- # no reason to alter the lang because user perform logout
+- # $param->{'lang'} = $param->{'cookie_lang'} = &cookielib::check_lang_cookie($ENV{'HTTP_COOKIE'}) || $list->{'admin'}{'lang'} || &Conf::get_robot_conf($robot, 'lang');
+-
+- if (defined $session->{'cas_server'} && (defined $Conf{'auth_services'}{$robot}[$session->{'cas_server'}])) {
+- # this user was logged using CAS
+- my $cas_server = $Conf{'auth_services'}{$robot}[$session->{'cas_server'}]{'cas_server'};
+-
+- $in{'action'} = 'redirect';
+- my $return_url = &wwslib::get_my_url();
+- $return_url =~ s/\/logout//;
+-
+- $param->{'redirect_to'} = $cas_server->getServerLogoutURL($return_url);
+-
+- delete $session->{'cas_server'};
+- return 'redirect';
+- } elsif (defined $session->{'sso_id'}) {
+- # this user was logged using a generic_sso
+-
+- ## Check if logout_url is known for this SSO
+- my $sso;
+- unless ($sso = &Conf::get_sso_by_id(robot => $robot, service_id => $session->{'sso_id'})) {
+-
+- &wwslog('err',"unknown SSO service_id '%s'", $session->{'sso_id'});
+- return undef ;
+- }
+-
+- ## Remove sso_id
+- delete $session->{'sso_id'};
+-
+- if ($sso->{'logout_url'}) {
+-
+- $in{'action'} = 'redirect';
+- $param->{'redirect_to'} = $sso->{'logout_url'};
+-
+- return 'redirect';
+- }
+- }
+-
+- &wwslog('info','do_logout: logout performed');
+- &web_db_log({'parameters' => $param->{'user'}{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'success'});
+-
+- if ($in{'previous_action'} eq 'referer') {
+- $param->{'referer'} = &tools::escape_chars($in{'previous_list'});
+- }
+-
+- return 'home';
+- }
+-
+-sub sendssopasswd {
+- my $email = shift;
+- do_log('info', 'sendssopasswd(%s)', $email);
+-
+- my ($passwd, $user);
+-
+- unless ($email) {
+- &report::reject_report_web('user','no_email',{},$param->{'action'});
+- &wwslog('info','do_sendssopasswd: no email');
+- &web_db_log({'parameters' => $email,
+- 'target_email' => $email,
+- 'status' => 'error',
+- 'error_type' => "no_email"});
+- return 'requestemail';
+- }
+-
+- unless (&tools::valid_email($email)) {
+- &report::reject_report_web('user','incorrect_email',{'email' => $email},$param->{'action'});
+- &wwslog('info','do_sendssopasswd: incorrect email %s', $email);
+- &web_db_log({'parameters' => $email,
+- 'target_email' => $email,
+- 'status' => 'error',
+- 'error_type' => "incorrect_email"});
+-
+- return 'requestemail';
+- }
+-
+- my $url_redirect;
+-
+- if ($param->{'newuser'} = &List::get_user_db($email)) {
+-
+- ## Create a password if none
+- unless ($param->{'newuser'}{'password'}) {
+- unless ( &List::update_user_db($email,
+- {'password' => &tools::tmp_passwd($email)
+- })) {
+- &report::reject_report_web('intern','db_update_failed',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','sendssopasswd: update failed');
+- &web_db_log({'parameters' => $email,
+- 'target_email' => $email,
+- 'status' => 'error',
+- 'error_type' => "internal"});
+- return undef;
+- }
+- $param->{'newuser'}{'password'} = &tools::tmp_passwd($email);
+- }
+-
+- $param->{'newuser'}{'escaped_email'} = &tools::escape_chars($param->{'newuser'}{'email'});
+-
+- }else {
+-
+- $param->{'newuser'} = {'email' => $email,
+- 'escaped_email' => &tools::escape_chars($email),
+- 'password' => &tools::tmp_passwd($email)
+- };
+-
+- }
+-
+- $param->{'init_passwd'} = 1
+- if ($param->{'user'}{'password'} =~ /^init/);
+-
+- &List::send_global_file('sendssopasswd', $email, $robot, $param);
+-
+-
+- $param->{'email'} = $email;
+- &web_db_log({'parameters' => $email,
+- 'target_email' => $email,
+- 'status' => 'success'});
+-
+- return 'validateemail';
+-}
+-sub do_firstpasswd {
+- &wwslog('info', 'do_firstpasswd(%s)', $in{'email'});
+- $param->{'requestpasswd_context'} = 'firstpasswd';
+- return 'renewpasswd';
+-}
+- ## send a ticket for choosing a new password
+-sub do_renewpasswd {
+- &wwslog('info', 'do_renewpasswd(%s)', $in{'email'});
+-
+- my $url_redirect;
+- if($in{'email'}){
+- if($url_redirect = &is_ldap_user($in{'email'})){
+- $param->{'redirect_to'} = $url_redirect
+- if ($url_redirect && ($url_redirect != 1));
+- }elsif (! &tools::valid_email($in{'email'})) {
+- &report::reject_report_web('user','incorrect_email',{'email' => $in{'email'}},$param->{'action'});
+- &wwslog('info','do_renewpasswd: incorrect email \"%s\"', $in{'email'});
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'incorrect_email'});
+- return undef;
+- }
+- }
+-
+- $param->{'email'} = $in{'email'};
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'success',
+- });
+-
+- if ($in{'previous_action'} eq 'referer') {
+- $param->{'referer'} = &tools::escape_chars($in{'previous_list'});
+- }
+- return 1;
+- }
+-
+-####################################################
+-# do_requestpasswd
+-####################################################
+-# Sends a message to the user containing user password.
+-#
+-# IN : -
+-#
+-# OUT : 'renewpasswd' | 1 | 'loginrequest' | undef
+-#
+-####################################################
+- sub do_requestpasswd {
+- &wwslog('info', 'do_requestpasswd(%s)', $in{'email'});
+- my ($passwd, $user);
+-
+- $param->{'account_creation'} = 1;
+-
+- my $url_redirect;
+- if($url_redirect = &is_ldap_user($in{'email'})){
+- ## There might be no authentication_info_url URL defined in auth.conf
+- if ($url_redirect == 1) {
+- &report::reject_report_web('user','ldap_user',{},$param->{'action'});
+- &wwslog('info','do_requestpasswd: LDAP user %s, cannot remind password', $in{'email'});
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return 'home';
+- }else{
+- $param->{'redirect_to'} = $url_redirect if ($url_redirect && ($url_redirect != 1));
+- return 1;
+- }
+- }
+-
+- ## Check auth.conf before creating/sending a password
+- unless (&Auth::may_use_sympa_native_auth($robot, $in{'email'})) {
+- ## TODO: Error handling
+- &report::reject_report_web('user','passwd_reminder_not_allowed',{},$param->{'action'});
+- return undef
+- }
+- &wwslog('debug','do_requestpasswd: sending one tile ticket for %s', $in{'email'});
+- $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'email'},$robot,'choosepasswd',$ip);
+- $param->{'request_from_host'} = $ip;
+- $param->{'newuser'} = &List::get_user_db($in{'email'});
+- if ($param->{'one_time_ticket'}) {
+- $param->{'login_error'}='ticket_sent';
+- unless (&List::send_global_file('sendpasswd', $in{'email'}, $robot, $param)) {
+- &wwslog('notice',"Unable to send template 'sendpasswd' to $in{'email'}");
+- $param->{'login_error'}='unable_to_send_ticket';
+- }
+- }else{
+- &wwslog('notice',"Unable to create_one_time_ticket");
+- &report::reject_report_web('user','passwd_reminder_error',{},$param->{'action'});
+- $param->{'login_error'}='unable_to_create_ticket';
+- }
+-
+- return 1 unless ($param->{'previous_action'}) ;
+- return $param->{'previous_action'};
+- }
+-
+- ## Which list the user is subscribed to
+- ## TODO (pour listmaster, toutes les listes)
+- sub do_which {
+- my $which = {};
+-
+- &wwslog('info', 'do_which');
+-
+-
+- $param->{'get_which'} = undef ;
+- $param->{'which'} = undef ;
+-
+- foreach my $role ('member','owner','editor') {
+-
+- foreach my $list ( &List::get_which($param->{'user'}{'email'}, $robot, $role) ){
+- my $l = $list->{'name'};
+-
+- my $result = $list->check_list_authz('visibility', $param->{'auth_method'},
+- {'sender' =>$param->{'user'}{'email'} ,
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+-
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- next unless ($r_action =~ /do_it/);
+-
+- $param->{'which'}{$l}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'which'}{$l}{'host'} = $list->{'admin'}{'host'};
+-
+- if ($role eq 'member') {
+- push @{$param->{'get_which'}}, $list;
+- }
+-
+- if ($role eq 'owner' || $role eq 'editor') {
+- $param->{'which'}{$l}{'admin'} = 1;
+- }
+-
+- ## For compatibility concerns (3.0)
+- ## To be deleted one of these day
+- $param->{$role}{$l}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{$role}{$l}{'host'} = $list->{'admin'}{'host'};
+-
+- }
+-
+- }
+- # &List::db_log('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'which','',$robot,'','done');
+- return 1;
+- }
+-
+- ## The list of list
+- sub do_lists {
+- my @lists;
+- &wwslog('info', 'do_lists(%s,%s)', $in{'topic'}, $in{'subtopic'});
+-
+- my %topics = &List::load_topics($robot);
+-
+- if ($in{'topic'}) {
+- $param->{'topic'} = $in{'topic'};
+- if ($in{'subtopic'}) {
+- $param->{'subtopic'} = $in{'subtopic'};
+- $param->{'subtitle'} = sprintf "%s / %s", $topics{$in{'topic'}}{'current_title'}, $topics{$in{'topic'}}{'sub'}{$in{'subtopic'}}{'current_title'};
+- $param->{'subtitle'} ||= "$in{'topic'} / $in{'subtopic'}";
+- }else {
+- $param->{'subtitle'} = $topics{$in{'topic'}}{'current_title'} || $in{'topic'};
+- }
+- }
+-
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+-
+- my $sender = $param->{'user'}{'email'} || 'nobody';
+-
+- my $result = $list->check_list_authz('visibility',$param->{'auth_method'},
+- {'sender' => $sender,
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'options' => {'dont_reload_scenario' => 1}});
+-
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- next unless ($r_action eq 'do_it');
+-
+- my $list_info = {};
+- $list_info->{'subject'} = $list->{'admin'}{'subject'};
+- $list_info->{'host'} = $list->{'admin'}{'host'};
+- $list_info->{'date_epoch'} = $list->{'admin'}{'creation'}{'date_epoch'};
+- $list_info->{'date'} = $list->{'admin'}{'creation'}{'date'};
+- $list_info->{'topics'} = $list->{'admin'}{'topics'};
+- if ($param->{'user'}{'email'} &&
+- ($list->am_i('owner',$param->{'user'}{'email'}) ||
+- $list->am_i('editor',$param->{'user'}{'email'})) ) {
+- $list_info->{'admin'} = 1;
+- }
+- if ($param->{'user'}{'email'} &&
+- $list->is_user($param->{'user'}{'email'})) {
+- $list_info->{'is_subscriber'} = 1;
+- }
+-
+- ## no topic ; List all lists
+-
+- if (! $in{'topic'}) {
+- $param->{'which'}{$list->{'name'}} = $list_info;
+- }elsif ($list->{'admin'}{'topics'}) {
+- foreach my $topic (@{$list->{'admin'}{'topics'}}) {
+- my @tree = split '/', $topic;
+-
+- next if (($in{'topic'}) && ($tree[0] ne $in{'topic'}));
+- next if (($in{'subtopic'}) && ($tree[1] ne $in{'subtopic'}));
+-
+- $param->{'which'}{$list->{'name'}} = $list_info;
+- }
+- }elsif ($in{'topic'} eq 'topicsless') {
+- $param->{'which'}{$list->{'name'}} = $list_info;
+- }
+- }
+- foreach my $listname (sort keys %{$param->{'which'}}) {
+- if ($listname =~ /^([a-z])/){
+- push @{$param->{'orderedlist'}{$1}}, $listname ;
+- }else{
+- push @{$param->{'orderedlist'}{'others'}}, $listname ;
+- }
+- }
+- return 1;
+- }
+-
+- ## The list of latest created lists
+- sub do_latest_lists {
+- &wwslog('info', "do_latest_lists($in{'for'}, $in{'count'},$in{'topic'}, $in{'subtopic'})");
+-
+- unless (&do_lists()) {
+- &wwslog('err','do_latest_lists: error while calling do_lists');
+- return undef;
+- }
+-
+- my $today = time;
+-
+- my $oldest_day;
+- if (defined $in{'for'}) {
+- $oldest_day = $today - (3600 * 24 * ($in{'for'}));
+- $param->{'for'} = $in{'for'};
+- unless ($oldest_day >= 0){
+- &report::reject_report_web('user','nb_days_to_much',{'nb_days' => $in{'for'} },$param->{'action'});
+- &wwslog('err','do_latest_lists: parameter "for" is too big"');
+- }
+- }
+-
+- my $nb_lists = 0;
+- my @date_lists;
+- foreach my $listname (keys (%{$param->{'which'}})) {
+- if ($param->{'which'}{$listname}{'date_epoch'} < $oldest_day) {
+- delete $param->{'which'}{$listname};
+- next;
+- }
+- $nb_lists++;
+- }
+-
+- if (defined $in{'count'}) {
+- $param->{'count'} = $in{'count'};
+-
+- unless ($in{'count'}) {
+- $param->{'which'} = undef;
+- }
+- }
+-
+- my $count_lists = 0;
+- foreach my $l ( sort {$param->{'which'}{$b}{'date_epoch'} <=> $param->{'which'}{$a}{'date_epoch'}} (keys (%{$param->{'which'}}))) {
+-
+- $count_lists++;
+-
+- if ($in{'count'}) {
+- if ($count_lists > $in{'count'}){
+- last;
+- }
+- }
+-
+- $param->{'which'}{$l}{'name'} = $l;
+- push @{$param->{'latest_lists'}} , $param->{'which'}{$l};
+- }
+-
+- $param->{'which'} = undef;
+-
+- return 1;
+- }
+-
+-
+- ## The list of the most active lists
+- sub do_active_lists {
+- &wwslog('info', "do_active_lists($in{'for'}, $in{'count'},$in{'topic'}, $in{'subtopic'})");
+-
+- unless (&do_lists()) {
+- &wwslog('err','do_active_lists: error while calling do_lists');
+- return undef;
+- }
+-
+- ## oldest interesting day
+- my $oldest_day = 0;
+-
+- if (defined $in{'for'}) {
+- $oldest_day = int(time/86400) - $in{'for'};
+- unless ($oldest_day >= 0){
+- &report::reject_report_web('user','nb_days_to_much',{'nb_days' => $in{'for'} },$param->{'action'});
+- &wwslog('err','do_latest_lists: parameter "for" is too big"');
+- return undef;
+- }
+- }
+-
+- ## get msg count for each list
+- foreach my $l (keys (%{$param->{'which'}})) {
+- my $list = new List ($l, $robot);
+- my $file = "$list->{'dir'}/msg_count";
+-
+- my %count ;
+-
+- if (open(MSG_COUNT, $file)) {
+- while (<MSG_COUNT>){
+- if ($_ =~ /^(\d+)\s(\d+)$/) {
+- $count{$1} = $2;
+- }
+- }
+- close MSG_COUNT ;
+-
+- $param->{'which'}{$l}{'msg_count'} = &count_total_msg_since($oldest_day,\%count);
+-
+- if ($in{'for'}) {
+- my $average = $param->{'which'}{$l}{'msg_count'} / $in{'for'}; ## nb msg by day
+- $average = int($average * 10);
+- $param->{'which'}{$l}{'average'} = $average /10; ## one digit
+- }
+- } else {
+- $param->{'which'}{$l}{'msg_count'} = 0;
+- }
+- }
+-
+- my $nb_lists = 0;
+-
+- ## get "count" lists
+- foreach my $l ( sort {$param->{'which'}{$b}{'msg_count'} <=> $param->{'which'}{$a}{'msg_count'}} (keys (%{$param->{'which'}}))) {
+- if (defined $in{'count'}) {
+- $nb_lists++;
+- if ($nb_lists > $in{'count'}) {
+- last;
+- }
+- }
+-
+- $param->{'which'}{$l}{'name'} = $l;
+- push @{$param->{'active_lists'}} , $param->{'which'}{$l};
+-
+- }
+-
+- if (defined $in{'count'}) {
+- $param->{'count'} = $in{'count'};
+- }
+- if (defined $in{'for'}) {
+- $param->{'for'} = $in{'for'};
+- }
+-
+- $param->{'which'} = undef;
+-
+-
+- return 1;
+- }
+-
+- sub count_total_msg_since {
+- my $oldest_day = shift;
+- my $count = shift;
+-
+- my $total = 0;
+- foreach my $d (sort {$b <=> $a} (keys %$count)) {
+- if ($d < $oldest_day) {
+- last;
+- }
+- $total = $total + $count->{$d};
+- }
+- return $total;
+- }
+-
+- ## List information page
+- sub do_info {
+- &wwslog('info', 'do_info');
+-
+- ## Access control
+- unless (defined &check_authz('do_info', 'info')) {
+- delete $param->{'list'};
+- return undef;
+- }
+-
+- ## Get List Description
+- if (-r $list->{'dir'}.'/homepage') {
+- my $file_path = $list->{'dir'}.'/homepage';
+- unless (open FILE, "<", $file_path) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $file_path},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_info: failed to open file %s: %s', $file_path,$!);
+- &web_db_log({'parameters' => $file_path,
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- while (<FILE>) {
+- Encode::from_to($_, $Conf{'filesystem_encoding'}, 'utf8');
+- $param->{'homepage_content'} .= $_;
+- }
+- close FILE;
+-
+- ## Used by previous templates
+- $param->{'homepage'} = 1;
+- }elsif (-r $list->{'dir'}.'/info') {
+- my $file_path = $list->{'dir'}.'/info';
+- unless (open FILE, "<", $file_path) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $file_path},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_info: failed to open file %s: %s', $file_path,$!);
+- &web_db_log({'parameters' => $file_path,
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- while (<FILE>) {
+- Encode::from_to($_, $Conf{'filesystem_encoding'}, 'utf8');
+- $param->{'info_content'} .= $_;
+- }
+- close FILE;
+- $param->{'info_content'} =~ s/\n/\<br\/\>/g;
+- }
+-
+- &tt2::add_include_path($list->{'dir'});
+-
+- return 1;
+- }
+-
+-
+- ## List subcriber count page
+- sub do_subscriber_count {
+- &wwslog('info', 'do_subscriber_count');
+-
+- unless (&do_info()) {
+- &wwslog('info','do_subscriber_count: error while calling do_info');
+- return undef;
+- }
+-
+- print "Content-type: text/plain\n\n";
+- print $list->get_total()."\n";
+-
+- $param->{'bypass'} = 'extreme';
+-
+- return 1;
+- }
+-
+-
+- ## Subscribers' list
+- sub do_review {
+- &wwslog('info', 'do_review(%d)', $in{'page'});
+- my $record;
+- my @users;
+- my $size ;
+- my $sortby = $in{'sortby'} || 'email';
+- my %sources;
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_review', 'review'));
+-
+- if($in{'size'}){
+- $size = $in{'size'};
+- $session->{'review_page_size'} = $in{'size'} ;
+- if ($param->{'user'}{'prefs'}{'review_page_size'} ne $in{'size'}) {
+- # update user pref as soon as connected user change page size
+- $param->{'user'}{'prefs'}{'review_page_size'} = $in{'size'};
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+- }else{
+- $size = $param->{'user'}{'prefs'}{'review_page_size'} || $session->{'review_page_size'} || $wwsconf->{'review_page_size'};
+- }
+- $param->{'review_page_size'} = $size;
+-
+- unless ($param->{'total'}) {
+- &report::reject_report_web('user','no_subscriber',{},$param->{'action'},$list);
+- &wwslog('info','do_review: no subscriber');
+- # &List::db_log('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'review',$param->{'list'},$robot,'','no subscriber');
+- return 1;
+- }
+-
+- ## Owner
+- $param->{'page'} = $in{'page'} || 1;
+- $param->{'total_page'} = int ($param->{'total'} / $size);
+- $param->{'total_page'} ++
+- if ($param->{'total'} % $size);
+-
+- if ($param->{'total_page'} > 0 and ($param->{'page'} > $param->{'total_page'})) {
+- &report::reject_report_web('user','no_page',{'page' => $param->{'page'}},$param->{'action'},$list);
+- ('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'review',$param->{'list'},$robot,'','out of pages');
+- &wwslog('info','do_review: no page %d', $param->{'page'});
+- return undef;
+- }
+-
+- my $offset;
+- if ($param->{'page'} > 1) {
+- $offset = (($param->{'page'} - 1) * $size);
+- }else {
+- $offset = 0;
+- }
+-
+- ## We might not use LIMIT clause
+- my ($limit_not_used, $count);
+- unless (($list->{'admin'}{'user_data_source'} =~ /^(database|include2)$/) &&
+- ($Conf{'db_type'} =~ /^(Pg|mysql$)/)) {
+- $limit_not_used = 1;
+- }
+-
+- ## Additional DB fields
+- my @additional_fields = split ',', $Conf{'db_additional_subscriber_fields'};
+-
+- ## Members list synchronization if list has included data sources.
+- if ($list->has_include_data_sources()) {
+- if ($list->on_the_fly_sync_include('use_ttl'=>1)) {
+- &report::notice_report_web('subscribers_updated',{},$param->{'action'});
+- }else {
+- &report::reject_report_web('intern','sync_include_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }
+- }
+-
+- ## Members list
+- $count = -1;
+- for (my $i = $list->get_first_user({'sortby' => $sortby,
+- 'offset' => $offset,
+- 'rows' => $size});
+- $i; $i = $list->get_next_user()) {
+-
+- ## some review pages may be empty while viewed by subscribers
+- next if (($i->{'visibility'} eq 'conceal')
+- and (! $param->{'is_priv'}) );
+-
+- if ($limit_not_used) {
+- $count++;
+- next unless (($count >= $offset) && ($count <= $offset+$size));
+- }
+-
+- ## Add user
+- &_prepare_subscriber($i, \@additional_fields, \%sources);
+-
+- push @{$param->{'members'}}, $i;
+- }
+-
+- if ($param->{'page'} > 1) {
+- $param->{'prev_page'} = $param->{'page'} - 1;
+- }
+-
+- unless (($offset + $size) >= $param->{'total'}) {
+- $param->{'next_page'} = $param->{'page'} + 1;
+- }
+-
+- $param->{'size'} = $size;
+- $param->{'sortby'} = $sortby;
+-
+- ######################
+- if($in{'exclude'} eq '1'){
+- $param->{'exclude_opt'} = 0;
+- }else{
+- $param->{'exclude_opt'} = 1;
+- }
+- #######################
+-
+- ## additional DB fields
+- $param->{'additional_fields'} = $Conf{'db_additional_subscriber_fields'};
+- ('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'review',$param->{'list'},$robot,'','done');
+-
+- ## msg_topics
+- if ($list->is_there_msg_topic()) {
+- foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
+- if (defined $top->{'name'}) {
+- push (@{$param->{'available_topics'}},$top);
+- }
+- }
+- }
+-
+-
+- return 1;
+- }
+-
+-## Show the table of exclude
+-sub do_show_exclude {
+-
+- &wwslog('info', 'do_exclude()');
+- # Get the emails of the exclude about a list and the date of their insertion
+- my $data_exclu = &List::get_exclusion($list->{'name'});
+-
+- my $excluded;
+- my $key = 0;
+- while (($data_exclu->{emails}->[$key]) && ($data_exclu->{date}->[$key])){
+- my $email = $data_exclu->{'emails'}->[$key];
+- my $date = gettext_strftime "%d %b %Y", localtime($data_exclu->{'date'}->[$key]);
+-
+- $excluded = {'email' => $email,
+- 'since' => $date};
+- push @{$param->{'exclude_users'}}, $excluded;
+- $key = $key + 1;
+- }
+- return 1;
+-}
+-
+-## Search in subscribers and in exclude
+-sub do_search {
+- &wwslog('info', 'do_search(%s)', $in{'filter'});
+-
+- my %sources;
+-
+- ## Additional DB fields
+- my @additional_fields = split ',', $Conf{'db_additional_subscriber_fields'};
+- ## Access control
+- return undef unless (defined &check_authz('do_search', 'review'));
+- ## Regexp
+- $param->{'filter'} = $in{'filter'};
+- my $regexp = &tools::escape_regexp($param->{'filter'});
+-
+- my $sql_regexp;
+- if ($list->{'admin'}{'user_data_source'} eq 'database') {
+- $sql_regexp = $param->{'filter'};
+- $sql_regexp =~ s/\%/\\\%/g;
+- $sql_regexp =~ s/\*/\%/g;
+- #$sql_regexp = '%'.$sql_regexp.'%';
+- }
+-
+- my $record = 0;
+- ## Maximum size of selection
+- my $max_select = 50;
+-
+- ## Members list
+- for (my $i = $list->get_first_user({'sql_regexp' => $sql_regexp, 'sortby' => 'email'}); $i; $i = $list->get_next_user()) {
+-
+- ## Search filter
+- next if ($i->{'email'} !~ /$regexp/i
+- && $i->{'gecos'} !~ /$regexp/i);
+-
+- next if (($i->{'visibility'} eq 'conceal')
+- and (! $param->{'is_owner'}) );
+-
+- ## Add user
+- &_prepare_subscriber($i, \@additional_fields, \%sources);
+-
+- $record++;
+- push @{$param->{'members'}}, $i;
+- }
+-
+- my $data_exclu = &List::get_exclusion($list->{'name'});
+- my $key = 0;
+- ## Exclude users are searched too
+- while (($data_exclu->{emails}->[$key]) && ($data_exclu->{date}->[$key])){
+- my $email = $data_exclu->{'emails'}->[$key];
+- my $date = gettext_strftime "%d %b %Y", localtime($data_exclu->{'date'}->[$key]);
+- $key = $key + 1;
+-
+- ## Search filter
+- next if ($email !~ /$regexp/i);
+- next if (!$param->{'is_owner'});
+-
+- my $excluded = {'email' => $email,
+- 'since' => $date};
+-
+- push @{$param->{'exclude_users'}}, $excluded;
+- $record++;
+- }
+-
+- if ($record > $max_select) {
+- undef $param->{'members'};
+- $param->{'too_many_select'} = 1;
+- }
+-
+- $param->{'similar_subscribers'} = &List::get_ressembling_subscribers_no_object({'name'=>$list->{'name'},'domain'=>$robot,'email'=>$in{'filter'}});
+- $param->{'similar_subscribers_occurence'} =$#{$param->{'similar_subscribers'}}+1;
+-
+- $param->{'occurrence'} = $record;
+- return 1;
+-}
+-
+-## Access to user preferences
+-sub do_pref {
+- &wwslog('info', 'do_pref');
+-
+- ## Find nearest expiration period
+- my $selected = 0;
+- foreach my $p (sort {$b <=> $a} keys %wwslib::cookie_period) {
+- my $entry = {'value' => $p};
+-
+- ## Set description from NLS
+- $entry->{'desc'} = sprintf gettext($wwslib::cookie_period{$p}{'gettext_id'});
+-
+- ## Choose nearest delay
+- if ((! $selected) && $param->{'user'}{'cookie_delay'} >= $p) {
+- $entry->{'selected'} = 'selected="selected"';
+- $selected = 1;
+- }
+-
+- unshift @{$param->{'cookie_periods'}}, $entry;
+- }
+-
+- $param->{'previous_list'} = $in{'previous_list'};
+- $param->{'previous_action'} = $in{'previous_action'};
+-
+- return 1;
+- }
+-
+- ## Set the initial password
+- sub do_choosepasswd {
+- &wwslog('info', 'do_choosepasswd');
+-
+- if($session->{'auth'} eq 'ldap'){
+- &report::reject_report_web('auth','',{'login'=> $param->{'need_login'}},$param->{'action'});
+- &wwslog('notice', "do_choosepasswd : user not authorized\n");
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- }
+-
+- unless ($param->{'user'}{'email'}) {
+- unless ($in{'email'} && $in{'passwd'}) {
+- &report::reject_report_web('user','no_user',{},$param->{'action'});
+- &wwslog('info','do_pref: no user');
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'no_user'});
+- $param->{'previous_action'} = 'choosepasswd';
+- return 'loginrequest';
+- }
+-
+- $in{'previous_action'} = 'choosepasswd';
+- return 'login';
+- }
+- &web_db_log({'parameters' => "$in{'email'}",
+- 'target_email' => $in{'email'} || $param->{'user'}{'email'},
+- 'status' => 'success',
+- });
+- $param->{'init_passwd'} = 1 if ($param->{'user'}{'password'} =~ /^INIT/i);
+-
+- return 1;
+- }
+-
+-####################################################
+-# do_set
+-####################################################
+-# Changes subscription parameter (reception or visibility)
+-#
+-# IN : -
+-#
+-# OUT :'loginrequest'|'info' | undef
+-
+- sub do_set {
+- &wwslog('info', 'do_set(%s, %s)', $in{'reception'}, $in{'visibility'});
+-
+- my ($reception, $visibility) = ($in{'reception'}, $in{'visibility'});
+- my $email;
+-
+- my $xml_custom_attribute;
+- if ($in{custom_attribute}){
+- return undef if ( &check_custom_attribute() != 1) ;
+- my $xml = &List::createXMLCustomAttribute($in{custom_attribute});
+-
+- $xml_custom_attribute = $xml ;
+- }
+-
+- if ($in{'email'}) {
+- unless ($param->{'is_owner'}) {
+- &report::reject_report_web('auth','action_owner',{},$param->{'action'},$list);
+- &wwslog('info','do_set: not owner');
+- &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- $email = &tools::unescape_chars($in{'email'});
+- }else {
+- unless ($param->{'user'}{'email'}) {
+- &report::reject_report_web('user','no_user',{},$param->{'action'});
+- &wwslog('info','do_set: no user');
+- &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
+- 'status' => 'error',
+- 'error_type' => 'no_user'});
+- return 'loginrequest';
+- }
+- $email = $param->{'user'}{'email'};
+- }
+-
+- unless ($list->is_user($email)) {
+- &report::reject_report_web('user','not_subscriber',{'list'=> $param->{'list'}},$param->{'action'},$list);
+- &wwslog('info','do_set: %s not subscriber of list %s', $email, $param->{'list'});
+- &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
+- 'status' => 'error',
+- 'error_type' => 'not_subscriber'});
+- return undef;
+- }
+-
+- # Verify that the mode is allowed
+- if (! $list->is_available_reception_mode($reception)) {
+- &report::reject_report_web('user','not_available_reception_mode',{'recpetion_mode'=> $reception},$param->{'action'},$list);
+- return undef;
+- }
+-
+- $reception = '' if $reception eq 'mail';
+- $visibility = '' if $visibility eq 'noconceal';
+-
+- my $update = {'reception' => $reception,
+- 'visibility' => $visibility,
+- 'update_date' => time};
+-
+- ## Lower-case new email address
+- $in{'new_email'} = lc( $in{'new_email'});
+-
+- if ($in{'new_email'} && ($in{'email'} ne $in{'new_email'})) {
+-
+- unless ($in{'new_email'} && &tools::valid_email($in{'new_email'})) {
+- &wwslog('notice', "do_set:incorrect email %s",$in{'new_email'});
+- &report::reject_report_web('user','incorrect_email',{'email' => $in{'new_email'}},$param->{'action'});
+- &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
+- 'status' => 'error',
+- 'error_type' => 'incorrect_email'});
+- return undef;
+- }
+-
+- ## Check if new email is already subscribed
+- if ($list->is_user($in{'new_email'})) {
+- &report::reject_report_web('user','already_subscriber', {'list' => $list->{'name'}},$param->{'action'},$list);
+- &wwslog('info','do_set: %s already subscriber', $in{'new_email'});
+- &web_db_log({'parameters' => $in{'new_email'},
+- 'status' => 'error',
+- 'error_type' => 'already subscriber'});
+- return undef;
+- }
+-
+- ## Duplicate entry in user_table
+- unless (&List::is_user_db($in{'new_email'})) {
+-
+- my $user_pref = &List::get_user_db($in{'email'});
+- $user_pref->{'email'} = $in{'new_email'};
+- &List::add_user_db($user_pref);
+- }
+-
+- $update->{'email'} = $in{'new_email'};
+- }
+-
+- ## message topic subscription
+- if ($list->is_there_msg_topic()) {
+- my @user_topics;
+-
+- if ($in{'no_topic'}) {
+- $update->{'topics'} = undef;
+-
+- } else {
+- foreach my $msg_topic (@{$list->{'admin'}{'msg_topic'}}) {
+- my $var_name = "topic_"."$msg_topic->{'name'}";
+- if ($in{"$var_name"}) {
+- push @user_topics, $msg_topic->{'name'};
+- }
+- }
+-
+- if ($in{"topic_other"}) {
+- push @user_topics, 'other';
+- }
+-
+- $update->{'topics'} = join(',',@user_topics);
+- }
+- }
+-
+- if ($reception =~ /^(digest|digestplain|nomail|summary)$/i) {
+- $update->{'topics'} = '';
+- }
+-
+- ## Get additional DB fields
+- foreach my $v (keys %in) {
+- if ($v =~ /^additional_field_(\w+)$/) {
+- $update->{$1} = $in{$v};
+- }
+- }
+-
+- if ($in{'gecos'}) {
+- $update->{'gecos'} = $in{'gecos'};
+- }else{
+- $update->{'gecos'} = undef;
+- }
+- $update->{'custom_attribute'} = $xml_custom_attribute if $xml_custom_attribute;
+-
+- unless ( $list->update_user($email, $update) ) {
+- &report::reject_report_web('intern','update_subscriber_db_failed',{'sub'=>$email},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info', 'do_set: set failed');
+- &web_db_log({'parameters' => "$email,$update",
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
+- 'status' => 'success',
+- });
+-
+- return $in{'previous_action'} || 'info';
+- }
+-
+-
+-## checks if each element of the custom attribute is conform to the list's
+-## definition
+-sub check_custom_attribute {
+-
+- my @custom_attributes = @{$list->{'admin'}{'custom_attribute'}} ;
+- my $isOK = 1 ;
+-
+- foreach my $ca (@custom_attributes){
+- my $value = $in{custom_attribute}{$ca->{id}}{value} ;
+- if ($ca->{optional} eq 'required' && $value eq '') {
+- &report::reject_report_web('user','missing_arg',{'argument' => "\"$ca->{name}\" is required"},$param->{'action'});
+- &wwslog('info','do_set: missing parameter');
+- &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- $isOK = undef;
+- next ;
+- }
+-
+- ## No further checking if attribute if empty
+- next if ($value =~ /^$/);
+-
+- my @values = split(/,/ , $ca->{'enum_values'}) if (defined $ca->{'enum_values'});
+-
+- ## Check that the parameter has the correct format
+- unless (($ca->{'type'} eq 'enum' && grep(/^$value$/, @values)) ||
+- ($ca->{'type'} eq 'integer' && $value =~ /^\d+$/) ||
+- ($ca->{'type'} eq 'string' && $value =~ /^.+$/) ||
+- ($ca->{'type'} eq 'text' && $value =~ /^.+$/m)
+- ) {
+- &report::reject_report_web('user','syntax_errors',{'params' => $ca->{name}},$param->{'action'});
+- &wwslog('info','do_set: syntax error');
+- &web_db_log({'parameters' => $ca->{name}, 'status' => 'error', 'error_type' => 'missing_parameter'});
+- $isOK = undef;
+- next ;
+- }
+- }
+- return $isOK ;
+-}
+-
+-
+- ## Update of user preferences
+- sub do_setpref {
+- &wwslog('info', 'do_setpref');
+- my $changes = {};
+-
+- foreach my $p ('gecos','lang','cookie_delay') {
+- $changes->{$p} = $in{$p} if (defined($in{$p}));
+- }
+-
+- ## Set session language and user language to new value
+- $session->{'lang'} = $in{'lang'} ;
+- $param->{'lang'} = $in{'lang'};
+-
+- if (&List::is_user_db($param->{'user'}{'email'})) {
+-
+- unless (&List::update_user_db($param->{'user'}{'email'}, $changes)) {
+- &report::reject_report_web('intern','update_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_pref: update failed');
+- &web_db_log({'parameters' => "$in{'gecos'},$in{'lang'},$in{'cookie_delay'}",
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }else {
+- $changes->{'email'} = $param->{'user'}{'email'};
+- unless (&List::add_user_db($changes)) {
+- &report::reject_report_web('intern','add_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_pref: add failed');
+- &web_db_log({'parameters' => "$in{'gecos'},$in{'lang'},$in{'cookie_delay'}",
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- foreach my $p ('gecos','lang','cookie_delay') {
+- $param->{'user'}{$p} = $in{$p};
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'parameters' => "$in{'gecos'},$in{'lang'},$in{'cookie_delay'}",
+- 'status' => 'success',
+- });
+- if ($in{'previous_action'}) {
+- $in{'list'} = $in{'previous_list'};
+- return $in{'previous_action'};
+- }else {
+- return 'pref';
+- }
+- }
+-
+- ## Prendre en compte les d�fauts
+- sub do_viewfile {
+- &wwslog('info', 'do_viewfile');
+-
+- unless (defined $wwslib::filenames{$in{'file'}}) {
+- &report::reject_report_web('user','file_not_editable',{'file' => $in{'file'}},$param->{'action'});
+- &wwslog('info','do_viewfile: file %s not editable', $in{'file'});
+- return undef;
+- }
+-
+- $param->{'file'} = $in{'file'};
+-
+- $param->{'filepath'} = $list->{'dir'}.'/'.$in{'file'};
+-
+- if ((-e $param->{'filepath'}) and (! -r $param->{'filepath'})) {
+- &report::reject_report_web('intern','cannot_read',{'filepath' => $param->{'filepath'}},$param->{'action'},'','',$robot);
+- &wwslog('info','do_viewfile: cannot read %s', $param->{'filepath'});
+- return undef;
+- }
+-
+- return 1;
+- }
+-
+-
+-####################################################
+-# do_subscribe
+-####################################################
+-# Subscribes a user to the list
+-#
+-# IN : -
+-#
+-# OUT :'subrequest'|'login'|'info'|$in{'previous_action'}
+-# | undef
+-####################################################
+-## TOTO: accepter nouveaux users
+-sub do_subscribe {
+- &wwslog('info', 'do_subscribe(%s)', $in{'email'});
+-
+- if (defined $param->{'user'} && $param->{'user'}{'email'}) {
+- my $xml_custom_attribute;
+-
+- if ($list->{'admin'}{'custom_attribute'} ) {
+-
+- ## This variable is set in the subrequest form
+- ## If not set, it means that the user has not been prompted to provide custom_attributes
+- unless ($in{'via_subrequest'}) {
+- &wwslog('notice', 'Returning subrequest form');
+- return "subrequest";
+- }
+-
+- if (&check_custom_attribute() != 1) {
+- &wwslog('notice', "Missing required custom attributes") ;
+- return 'subrequest';
+- }
+- my $xml = &List::createXMLCustomAttribute($in{custom_attribute});
+- $xml_custom_attribute = $xml ;
+- }
+-
+- if ($param->{'is_subscriber'}) {
+- &report::reject_report_web('user','already_subscriber', {'list' => $list->{'name'}},$param->{'action'},$list);
+- &wwslog('info','do_subscribe: %s already subscriber', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'already_subscriber'});
+- return undef;
+- }
+- my $result = $list->check_list_authz('subscribe',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $sub_is;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $sub_is = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+- if ($sub_is =~ /reject/) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- &wwslog('info', 'do_subscribe: subscribe closed');
+- &web_db_log({'parameters' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- $param->{'may_subscribe'} = 1;
+-
+- if ($sub_is =~ /owner/) {
+-
+- unless ($list->send_notify_to_owner('subrequest',{'who' => $param->{'user'}{'email'},
+- 'keyauth' => $list->compute_auth($param->{'user'}{'email'}, 'add'),
+- 'replyto' => &Conf::get_robot_conf($robot, 'sympa'),
+- 'custom_attribute' => $in{custom_attribute},
+- 'gecos' => $param->{'user'}{'gecos'},
+- 'ip'=>$ip})) {
+- &wwslog('notice',"Unable to send notify 'subrequest' to $list->{'name'} listowner");
+- }
+-
+- $list->store_subscription_request($param->{'user'}{'email'}, "", $xml_custom_attribute);
+- &report::notice_report_web('sent_to_owner',{},$param->{'action'});
+- &wwslog('info', 'do_subscribe: subscribe sent to owners');
+-
+- return 'info';
+- }elsif ($sub_is =~ /do_it/) {
+- if ($param->{'is_subscriber'}) {
+- unless ($list->update_user($param->{'user'}{'email'},
+- {'subscribed' => 1,
+- 'update_date' => time})) {
+- &report::reject_report_web('intern','update_subscriber_db_failed',{'sub'=>$param->{'user'}{'email'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info', 'do_subscribe: update failed');
+- &web_db_log({'parameters' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }else {
+- my $defaults = $list->get_default_user_options();
+- my $u;
+- %{$u} = %{$defaults};
+- $u->{'email'} = $param->{'user'}{'email'};
+- $u->{'gecos'} = $param->{'user'}{'gecos'} || $in{'gecos'};
+- $u->{'date'} = $u->{'update_date'} = time;
+- $u->{'password'} = $param->{'user'}{'password'};
+- $u->{'custom_attribute'} = $xml_custom_attribute if (defined $xml_custom_attribute);
+- $u->{'lang'} = $param->{'user'}{'lang'} || $param->{'lang'};
+-
+- unless ($list->add_user($u)) {
+- &report::reject_report_web('intern','add_subscriber_db_failed',{'sub'=>$param->{'user'}{'email'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info', 'do_subscribe: subscribe failed');
+- &web_db_log({'parameters' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- unless ($sub_is =~ /quiet/i ) {
+- unless ($list->send_file('welcome', $param->{'user'}{'email'}, $robot,{})) {
+- &wwslog('notice',"Unable to send template 'welcome' to $param->{'user'}{'email'}");
+- }
+- }
+-
+- if ($sub_is =~ /notify/) {
+- unless ($list->send_notify_to_owner('notice',{'who' => $param->{'user'}{'email'},
+- 'gecos' => $param->{'user'}{'gecos'},
+- 'command' => 'subscribe'})) {
+- &wwslog('notice','Unable to send notify "notice" to listmaster');
+- }
+- }
+-
+- }
+- }else{ # user is not autenticated
+-
+- if ($in{'email'} && $in{'passwd'}) {
+- $in{'previous_action'} = 'subscribe';
+- $in{'previous_list'} = $param->{'list'};
+- return 'login';
+- }else{
+- return 'subrequest';
+- }
+- }
+- ## perform which to update your_subscriptions cookie ;
+- @{$param->{'get_which'}} = &List::get_which($param->{'user'}{'email'},$robot,'member') ;
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'email'},'status' => 'success'});
+-
+- if ($in{'previous_action'}) {
+- return $in{'previous_action'};
+- }
+-
+-# return 'suboptions';
+- return 'info';
+-}
+-
+-
+-####################################################
+-# do_multiple_subscribe
+-####################################################
+-# Subscribes a user to each lists
+-#
+-# IN : lists a array of lists
+-#
+-# OUT :'subrequest'|'login'|'info'|$in{'previous_action'}
+-# | undef
+-####################################################
+-sub do_multiple_subscribe {
+- &wwslog('info', 'do_multiple_subscribe(%s)', $in{'email'});
+-
+- ## Not authenticated
+- unless (defined $param->{'user'} && $param->{'user'}{'email'}) {
+- ## no email
+- unless ($in{'email'}) {
+- return 'lists';
+- }
+- }
+-
+- my @lists = split /\0/, $in{'lists'};
+- my $total;
+- my %results ;
+-
+-
+- foreach my $requested_list (@lists) {
+- my $param->{'list'} = new List ($requested_list, $robot);
+- $results{'requested_list'} = &do_subscribe();
+- }
+-}
+-
+-## Subscription request (user not authenticated)
+-sub do_suboptions {
+- &wwslog('info', 'do_suboptions()');
+-
+- unless($param->{'is_subscriber'} ) {
+- &report::reject_report_web('user','not_subscriber',{'list'=> $list->{'name'}},$param->{'action'},$list);
+- &wwslog('info','do_suboptions: %s not subscribed to %s',$param->{'user'}{'email'}, $param->{'list'} );
+- return undef;
+- }
+-
+- my ($s, $m);
+-
+- unless($s = $list->get_subscriber($param->{'user'}{'email'})) {
+- &report::reject_report_web('intern','subscriber_not_found',{'email' => $param->{'user'}{'email'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info', 'do_sub_options: subscriber %s not found', $param->{'user'}{'email'});
+- return undef;
+- }
+-
+- $s->{'reception'} ||= 'mail';
+- $s->{'visibility'} ||= 'noconceal';
+- $s->{'date'} = gettext_strftime "%d %b %Y", localtime($s->{'date'});
+- $s->{'update_date'} = gettext_strftime "%d %b %Y", localtime($s->{'update_date'});
+-
+- foreach $m (keys %wwslib::reception_mode) {
+- if ($list->is_available_reception_mode($m)) {
+- $param->{'reception'}{$m}{'description'} = sprintf(gettext($wwslib::reception_mode{$m}->{'gettext_id'}));
+- if ($s->{'reception'} eq $m) {
+- $param->{'reception'}{$m}{'selected'} = 'selected="selected"';
+- if ($m =~ /^(mail|notice|not_me|txt|html|urlize)$/i) {
+- $param->{'possible_topic'} = 1;
+- }
+- }else {
+- $param->{'reception'}{$m}{'selected'} = '';
+- }
+- }
+- }
+-
+- foreach $m (keys %wwslib::visibility_mode) {
+- $param->{'visibility'}{$m}{'description'} = sprintf(gettext($wwslib::visibility_mode{$m}->{'gettext_id'}));
+- if ($s->{'visibility'} eq $m) {
+- $param->{'visibility'}{$m}{'selected'} = 'selected="selected"';
+- }else {
+- $param->{'visibility'}{$m}{'selected'} = '';
+- }
+- }
+-
+- $param->{'subscriber'} = $s;
+-
+-
+- #msg_topic
+- $param->{'sub_user_topic'} = 0;
+- foreach my $user_topic (split (/,/,$s->{'topics'})) {
+- $param->{'topic_checked'}{$user_topic} = 1;
+- $param->{'sub_user_topic'}++;
+- }
+-
+- if ($list->is_there_msg_topic()) {
+- foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
+- if (defined $top->{'name'}) {
+- push (@{$param->{'available_topics'}},$top);
+- }
+- }
+- }
+-
+- return 1;
+-}
+-
+-## Subscription request (user not authenticated)
+-sub do_subrequest {
+- &wwslog('info', 'do_subrequest(%s,%s)', $in{'email'},$in{'custom_attribute'});
+-
+- if (defined $in{'custom_attribute'}) {
+- $param->{'custom_attribute'} = $in{'custom_attribute'};
+- }
+-
+- ## Auth ?
+- if ($param->{'user'}{'email'}) {
+- ## Subscriber ?
+- if ($param->{'is_subscriber'}) {
+- &report::reject_report_web('user','already_subscriber', {'list' => $list->{'name'}},$param->{'action'},$list);
+- &wwslog('info','%s already subscriber', $param->{'user'}{'email'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'already_subscriber'});
+- return undef;
+- }
+- $param->{'status'} = 'auth';
+- }else {
+- ## Provided email parameter ?
+- unless ($in{'email'}) {
+- $param->{'status'} = 'notauth_noemail';
+- return 1;
+- }
+- ## Subscriber ?
+- if ($list->is_user($in{'email'})) {
+- $param->{'status'} = 'notauth_subscriber';
+- return 1;
+- }
+- my $user;
+- $user = &List::get_user_db($in{'email'})
+- if &List::is_user_db($in{'email'});
+-
+- ## Need to send a password by email
+- $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'email'},$robot,'subscribe/'.$list->{'name'},$ip);
+- $param->{'login_error'}='ticket_sent';
+- $param->{'request_from_host'} = $ip;
+- $param->{'newuser'} = &List::get_user_db($in{'email'});
+- unless (&List::send_global_file('sendpasswd', $in{'email'}, $robot, $param)) {
+- &wwslog('notice',"Unable to send template 'sendpasswd' to $in{'email'}");
+- $param->{'login_error'}='unable_to_send_ticket';
+- }
+- # &do_requestpasswd();
+- $param->{'status'} = 'notauth_passwordsent';
+-
+- return 1;
+- }
+-
+- return 1;
+-}
+-sub do_auto_signoff {
+- &wwslog('info', 'do_signoff');
+- ## If the URL isn't valid, then go to home page. No need to guide the user: this function is supposed to be used by clicking on autocreated URL only.
+- return 'home' unless $in{'email'};
+-
+- ## If unsubscribe is forbidden, reject the request. Other
+-
+- my $result = $list->check_list_authz('unsubscribe',$param->{'auth_method'},
+- {'sender' => $in{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $sig_is;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $sig_is = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- if ($sig_is =~ /reject/) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- &wwslog('info', 'do_signoff: %s may not signoff from %s'
+- , $in{'email'}, $param->{'list'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- ## Send the confirmation email to the user.
+-
+- if ($list->is_user($in{'email'})) {
+-
+- my $ticket = &Auth::create_one_time_ticket($in{'email'},$robot,'signoff/'.$list->{'name'},$ip);
+-
+- my $tt2_param = {
+- 'list' => $list,
+- 'type' => 'ticket_to_signoff',
+- 'one_time_ticket' => $ticket,
+- 'email' => $in{'email'},
+- 'context' => 'auto_signoff',
+- 'ip' => $ip,
+- };
+- unless (&List::send_global_file('user_notification', $in{'email'}, $robot, $tt2_param)) {
+- &do_log('notice',"Unable to send template 'user_notification' to $in{'email'}");
+- return undef;
+- }
+- }else{
+- return 'home';
+- }
+- $param->{'signing_off_email'} = $in {'email'};
+- ## If OK, return the page displaying the informations to the user.
+- return 1;
+-
+-}
+-####################################################
+-# do_signoff
+-####################################################
+-# Unsubcribes a user from a list
+-#
+-# IN : -
+-#
+-# OUT : 'sigrequest' | 'login' | 'info'
+-#
+-####################################################
+- ## Unsubscribe from list
+- sub do_signoff {
+- &wwslog('info', 'do_signoff');
+-
+- my $authenticated_email_address = $param->{'user'}{'email'};
+-
+- unless ($authenticated_email_address) {
+- unless ($in{'email'}) {
+- return 'sigrequest';
+- }
+-
+- if ($in{'fingerprint'}) {
+-
+- unless(&tools::get_fingerprint($in{'email'}, $in{'fingerprint'})){
+- &report::reject_report_web('user','cannot_do_signoff');
+- &wwslog('err','do_signoff: failed to unsubscribe user %s', $in{'email'});
+- return undef;
+- }
+-
+- ## We don't set $param->{'user'}{'email'} because we don't want the user to be authenticated
+- ## to prevent the cookie from being set
+- $authenticated_email_address = $in{'email'};
+-
+- }else {
+-
+- ## Perform login first
+- if ($in{'passwd'}) {
+- $in{'previous_action'} = 'signoff';
+- $in{'previous_list'} = $param->{'list'};
+- return 'login';
+- }
+-
+- if ( &List::is_user_db($in{'email'}) ) {
+- &report::reject_report_web('user','no_user',{},$param->{'action'});
+- &wwslog('info','do_signoff: need auth for user %s', $in{'email'});
+- &web_db_log({'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'authentication'});
+- return undef;
+- }
+-
+- ## No passwd
+- &init_passwd($in{'email'}, {'lang' => $param->{'lang'} });
+-
+- $param->{'user'}{'email'} = $in{'email'};
+- $authenticated_email_address = $in{'email'};
+- }
+- }
+-
+- my %result = &unsubscribe($authenticated_email_address, $list);
+- if ($result{'success'} == 1) {
+- &report::notice_report_web($result{'details'},{},$param->{'action'});
+- $param->{'is_subscriber'} = 0;
+- $param->{'may_signoff'} = 0;
+- }else{
+- &report::reject_report_web($result{'category_error'},$result{'reason_error'},{%{$result{'reason_error'}},'list'=>$list->{'name'}},$param->{'action'},$list);
+- }
+- return 'home';
+- }
+-
+-## Unsubscribe current user from a list.
+-sub unsubscribe {
+- my $authenticated_email_address = shift;
+- my $list = shift;
+- my %report = ('success',1,'details','');
+-
+- unless ($list->is_user($authenticated_email_address)) {
+- &wwslog('info','do_signoff: %s not subscribed to %s',$authenticated_email_address, $param->{'list'} );
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'not_subscriber'});
+- $report{'success'} = 0;
+- $report{'category_error'} = 'user';
+- $report{'reason_error'} = 'not_subscribed';
+- $report{'details_error'} = {};
+- return %report;
+- }
+-
+- my $result = $list->check_list_authz('unsubscribe',$param->{'auth_method'},
+- {'sender' => $authenticated_email_address,
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $sig_is;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $sig_is = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- $param->{'may_signoff'} = 1 if ($sig_is =~ /do_it|owner/);
+-
+- if ($sig_is =~ /reject/) {
+- &wwslog('info', 'do_signoff: %s may not signoff from %s'
+- , $authenticated_email_address, $param->{'list'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'authorization'});
+- $report{'success'} = 0;
+- $report{'category_error'} = 'auth';
+- $report{'reason_error'} = $reason;
+- $report{'details_error'} = {};
+- return %report;
+- }elsif ($sig_is =~ /owner/) {
+- unless ($list->send_notify_to_owner('sigrequest',{'who' => $authenticated_email_address,
+- 'keyauth' => $list->compute_auth($authenticated_email_address, 'del')})) {
+- &wwslog('notice',"Unable to send notify 'sigrequest' to $list->{'name'} list owner");
+- }
+- &wwslog('info', 'do_signoff: signoff sent to owner');
+- $report{'success'} = 1;
+- $report{'details'} = 'sent_to_owner';
+- return %report;
+- }else {
+- unless ($list->delete_user('users' => [$authenticated_email_address], 'exclude' =>' 1')) {
+- &wwslog('info', 'do_signoff: signoff failed');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- $report{'success'} = 0;
+- $report{'category_error'} = 'intern';
+- $report{'reason_error'} = 'delete_subscriber_db_failed';
+- $report{'details_error'} = {'sub'=>$authenticated_email_address};
+- return %report;
+- }
+-
+- if ($sig_is =~ /notify/) {
+- unless ($list->send_notify_to_owner('notice',{'who' => $authenticated_email_address,
+- 'gecos' => '',
+- 'command' => 'signoff'})) {
+- &wwslog('notice',"Unable to send notify 'notice' to $list->{'name'} list owner");
+- }
+- }
+-
+- ## perform which to update your_subscribtions cookie ;
+- @{$param->{'get_which'}} = &List::get_which($authenticated_email_address,$robot,'member') ;
+-
+- unless ($list->send_file('bye', $authenticated_email_address, $robot, {})) {
+- &wwslog('notice',"Unable to send template 'bye' to $authenticated_email_address");
+- }
+- }
+- &web_db_log({'status' => 'success'});
+- $report{'success'} = 1;
+- $report{'details'} = 'performed';
+- return %report;
+-}
+-
+- ## Unsubscription request (user not authenticated)
+- sub do_sigrequest {
+- &wwslog('info', 'do_sigrequest(%s)', $in{'email'});
+-
+- ## If user is authenticated then redirect him to the signoff action but
+- ## get a confirmation (via the sigrequest web page) first
+- if ($param->{'user'}{'email'}) {
+- return 1;
+- }
+-
+- ## Not auth & no email => return the sigrequest web form to get the user email
+- unless ($in{'email'}) {
+- return 1;
+- }
+-
+-
+- if ($list->is_user($in{'email'})) {
+-
+- my $ticket = &Auth::create_one_time_ticket($in{'email'},$robot,'signoff/'.$list->{'name'},$ip);
+-
+- my $tt2_param = {'type' => 'ticket_to_signoff',
+- 'list' => $list,
+- 'one_time_ticket' => $ticket,
+- 'email' => $in{'email'}};
+- unless (&List::send_global_file('user_notification', $in{'email'}, $robot, $tt2_param)) {
+- &do_log('notice',"Unable to send template 'user_notification' to $in{'email'}");
+- return undef;
+- }
+-
+- }else {
+- $param->{'not_subscriber'} = 1;
+- }
+-
+- $param->{'email'} = $in{'email'};
+-
+- return 1;
+- }
+-
+-
+- ## Update of password
+- sub do_setpasswd {
+- &wwslog('info', 'do_setpasswd');
+- my $user;
+-
+- if ($in{'newpasswd1'} =~ /^\s+$/ ) {
+- &report::reject_report_web('user','no_passwd',{},$param->{'action'});
+- &wwslog('info','do_setpasswd: no newpasswd1');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return undef;
+- }
+-
+- unless ($in{'newpasswd1'} eq $in{'newpasswd2'}) {
+- &report::reject_report_web('user','diff_passwd',{},$param->{'action'});
+- &wwslog('info','do_setpasswd: different newpasswds');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'bad_parameter'});
+- return undef;
+- }
+-
+- if (&List::is_user_db($param->{'user'}{'email'})) {
+-
+- unless ( &List::update_user_db($param->{'user'}{'email'}, {'password' => $in{'newpasswd1'},'wrong_login_count' => 0} )) {
+- &report::reject_report_web('intern','update_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_setpasswd: update failed');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }else {
+-
+- unless ( &List::add_user_db({'email' => $param->{'user'}{'email'},
+- 'password' => $in{'newpasswd1'},
+- 'wrong_login_count' => 0} )) {
+- &report::reject_report_web('intern','add_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_setpasswd: update failed');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- $param->{'user'}{'password'} = $in{'newpasswd1'};
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+-
+- if ($in{'previous_action'}) {
+- $in{'list'} = $in{'previous_list'};
+- return $in{'previous_action'};
+- }else {
+- return 'pref';
+- }
+- }
+-
+- ## List admin page
+- sub do_admin {
+- &wwslog('info', 'do_admin');
+-
+- ## Messages edition
+- foreach my $f ('info','homepage','welcome.tt2','bye.tt2','removed.tt2','message.footer','message.header','remind.tt2','invite.tt2','reject.tt2') {
+- next unless ($list->may_edit($f, $param->{'user'}{'email'}) eq 'write');
+- if ($wwslib::filenames{$f}{'gettext_id'}) {
+- $param->{'files'}{$f}{'complete'} = gettext($wwslib::filenames{$f}{'gettext_id'});
+- }else {
+- $param->{'files'}{$f}{'complete'} = $f;
+- }
+- $param->{'files'}{$f}{'selected'} = '';
+- }
+- $param->{'files'}{'info'}{'selected'} = 'selected="selected"';
+-
+- # my %mode;
+- # $mode{'edit'} = 1;
+- # my %access = &d_access_control(\%mode,$path);
+-
+- return 1;
+- }
+-
+- ## Server admin page
+- sub do_serveradmin {
+- &wwslog('info', 'do_serveradmin');
+-
+- my $f;
+-
+- ## Lists Default files
+- foreach my $f ('welcome.tt2','bye.tt2','removed.tt2','message.footer','message.header','remind.tt2','invite.tt2','reject.tt2','your_infected_msg.tt2') {
+- if ($wwslib::filenames{$f}{'gettext_id'}){
+- $param->{'lists_default_files'}{$f}{'complete'} = gettext($wwslib::filenames{$f}{'gettext_id'});
+- }else {
+- $param->{'lists_default_files'}{$f}{'complete'} = $f;
+- }
+- $param->{'lists_default_files'}{$f}{'selected'} = '';
+- }
+-
+- ## Checking families and other virtual hosts.
+- &get_server_details();
+-
+- ## Server files
+- foreach my $f ('helpfile.tt2','lists.tt2','global_remind.tt2','summary.tt2','create_list_request.tt2','list_created.tt2','list_aliases.tt2') {
+- $param->{'server_files'}{$f}{'complete'} = gettext($wwslib::filenames{$f}{'gettext_id'});
+- $param->{'server_files'}{$f}{'selected'} = '';
+- }
+- $param->{'server_files'}{'helpfile.tt2'}{'selected'} = 'selected="selected"';
+- $param->{'log_level'} = $session->{'log_level'} ;
+- $param->{'subaction'} = $in{'subaction'} ;
+- return 1;
+- }
+-
+-sub do_edit_config {
+-
+- my @editable_params = @confdef::params ;
+-
+- &get_server_details;
+-
+- unless ($param->{'main_robot'}) {
+- &report::reject_report_web('auth','super lismaster feature only','{}',$param->{'action'});
+- &wwslog('info','check_authz: access denied in edit_config for %s because not super listmaster', $param->{'user'}{'email'});
+- }
+-
+- for my $i ( 0 .. $#editable_params ) {
+- if ($editable_params[$i]->{'name'}) {
+- $editable_params[$i]->{'current_value'} = &Conf::get_robot_conf($robot, $editable_params[$i]->{'name'});
+- $editable_params[$i]->{'current_value'} = join( ",", @{$editable_params[$i]->{'current_value'}}) if (ref($editable_params[$i]->{'current_value'}) eq 'ARRAY');
+- }
+- }
+-
+- if ($in{'conf_new_value'}) {
+- my $editable; my $i;
+- for $i ( 0 .. $#editable_params ) {
+- # if the parameter is editable and if the is a change
+- next unless ($editable_params[$i]->{'name'} eq $in{'conf_parameter_name'});
+- if ($editable_params[$i]->{'edit'} ne '1'){
+- do_log ('err','Ignoring change of parameter %s (value %s) because not editable', $in{'conf_parameter_name'}, $in{'conf_new_value'});
+- last;
+- }
+- if ($in{'conf_new_value'} eq $editable_params[$i]->{'current_value'} ){
+- do_log ('notice','Ignoring change of parameter %s (value %s) because inchanged', $in{'conf_parameter_name'}, $in{'conf_new_value'});
+- last;
+- }else{
+- $editable_params[$i]->{'current_value'} = $in{'conf_new_value'};
+- &Conf::set_robot_conf($robot, $in{'conf_parameter_name'}, $in{'conf_new_value'});
+- do_log ('notice','setting parameter %s to value %s', $in{'conf_parameter_name'}, $in{'conf_new_value'});
+- last;
+- }
+- }
+- }
+-
+- $param->{'editable_params'} = \@editable_params ;
+- return 1;
+-
+-}
+-
+-## Change log_level for the current session
+-sub do_set_loglevel {
+- &wwslog('info', 'do_set_loglevel');
+-
+- $session->{'log_level'} = $in{'log_level'};
+- return 'serveradmin';
+-}
+-
+-## activate dump var feature
+-sub do_set_dumpvars {
+- &wwslog('info', 'do_set_dumpvars');
+-
+- $session->{'dumpvars'} = 'true' ;
+- $param->{'dumpavars'} = $session->{'dumpvars'} ;
+- $param->{'redirect_to'} = $param->{'base_url'}.$param->{'path_cgi'}.'/serveradmin';
+- return '1';
+-}
+-## un-activate dump var feature
+-sub do_unset_dumpvars {
+- &wwslog('info', 'do_unset_dumpvars');
+-
+- $session->{'dumpvars'} = '' ;
+- $param->{'dumpavars'} = '';
+- $param->{'redirect_to'} = $param->{'base_url'}.$param->{'path_cgi'}.'/serveradmin';
+- return '1';
+-}
+-## un-activate dump var feature
+-sub do_show_sessions {
+- &wwslog('info', 'do_show_sessions');
+-
+- $in{'session_delay'} = 10 unless ($in{'session_delay'});
+- my $delay = 60 * $in{'session_delay'};
+- $param->{'sessions'} = &SympaSession::list_sessions($delay,$robot,$in{'connected_only'});
+- return '1';
+-}
+-
+-
+-## Change user email
+-sub do_set_session_email {
+- &wwslog('info', 'do_set_session_email');
+-
+- my $email_regexp = &tools::get_regexp('email');
+- unless ($in{'email'} =~ /^\s*$email_regexp\s*$/){
+- &report::reject_report_web('user','Invalid email provided.',{},$param->{'action'},$list);
+- return 'serveradmin';
+- };
+- if ($session){
+- $session->{'restore_email'} = $param->{'user'}{'email'};
+- $session->{'email'} = $in{'email'};
+- $param->{'redirect_to'} = $param->{'base_url'}.$param->{'path_cgi'};
+- return '1';
+- }else{
+- &report::reject_report_web('user','No active session',{},$param->{'action'},$list);
+- return 'serveradmin';
+- }
+-}
+-
+-## Change user email
+-sub do_restore_email {
+- &wwslog('info', 'do_restore_email');
+- &wwslog('debug2', 'do_restore_email from %s to %s',$session->{'email'},$session->{'restore_email'} );
+-
+- if ($param->{'restore_email'}){
+- $session->{'email'} = $session->{'restore_email'} ;
+- $param->{'restore_email'}= $session->{'restore_email'} = '' ;
+- $param->{'redirect_to'} = $param->{'base_url'}.$param->{'path_cgi'};
+- }else{
+- &wwslog('info','do_restore_email from %s no restore_email attached to current session', $param->{'user'}{'email'});
+- &report::reject_report_web('user','wrong_param',{},$param->{'action'},$list);
+- }
+- return 'home';
+-}
+-
+-## list available templates
+-sub do_ls_templates {
+- &wwslog('info', 'do_ls_templates');
+-
+- $in{'webormail'} ||= 'web';
+-
+- if (defined $list) {
+- $param->{'templates'} = &tools::get_templates_list($in{'webormail'},$robot,$list);
+- }else{
+- $param->{'templates'} = &tools::get_templates_list($in{'webormail'},$robot, undef);
+- }
+-
+- ## List of lang per type
+- foreach my $level ('site','robot','list') {
+- $param->{'lang_per_level'}{$level}{'default'} = 1;
+- }
+-
+- foreach my $file (keys %{$param->{'templates'}}) {
+- foreach my $level (keys %{$param->{'templates'}{$file}}) {
+- foreach my $lang (keys %{$param->{'templates'}{$file}{$level}}) {
+- $param->{'lang_per_level'}{$level}{$lang} = 1;
+- }
+- }
+- }
+-
+-
+- ## Colspan per level
+- foreach my $level (keys %{$param->{'lang_per_level'}}) {
+- foreach my $lang (keys %{$param->{'lang_per_level'}{$level}}) {
+- $param->{'colspan_per_level'}{$level}++;
+- foreach my $file (keys %{$param->{'templates'}}) {
+- $param->{'templates'}{$file}{$level}{$lang} ||= '';
+- }
+- }
+- }
+-
+- $param->{'webormail'} = $in{'webormail'};
+-
+- return 1;
+-}
+-
+-# show a template, used by copy_template and edit_emplate
+-sub do_remove_template {
+-
+- &wwslog('info', 'do_remove_template');
+-
+- my $template_path ;
+-
+- if ($in{'scope'} eq 'list') {
+- $template_path = &tools::get_template_path($in{'webormail'},$robot,'list',$in{'template_name'},$in{'tpl_lang'},$list);
+- }else{
+- $template_path = &tools::get_template_path($in{'webormail'},$robot,$in{'scope'},$in{'template_name'},$in{'tpl_lang'});
+- }
+-
+- my $template_old_path = &tools::shift_file($template_path,10);
+- unless ($template_old_path) {
+- &report::reject_report_web('intern','remove_failed',{'path'=>$template_path},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"remove_template: could not remove $template_path");
+- &web_db_log({'parameters' => $in{'webormail'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &report::notice_report_web('file_renamed',{'orig_file'=>$template_path,'new_file'=>$template_old_path}, $param->{'action'});
+- &web_db_log({'parameters' => $in{'webormail'},
+- 'status' => 'status'});
+- $param->{'webormail'} = $in{'webormail'};
+- $param->{'scope'} = $in{'scope'};
+- $param->{'template_name'} = $in{'template_name'};
+- $param->{'tpl_lang'} = $in{'tpl_lang'};
+-
+- return 'ls_templates';
+-}
+-
+-# show a template, used by copy_template and edit_emplate
+-sub do_view_template {
+-
+- &wwslog('info', "do_view_template(type=$in{'webormail'},template-name=$in{'template_name'},listname=$in{'list'},path=$in{'template_path'},scope=$in{'scope'},lang=$in{'tpl_lang'})");
+-
+- my $template_path ;
+-
+- if ($in{'scope'} eq 'list') {
+- $template_path = &tools::get_template_path($in{'webormail'},$robot,'list',$in{'template_name'},$in{'tpl_lang'},$list);
+- }else{
+- $template_path = &tools::get_template_path($in{'webormail'},$robot,$in{'scope'},$in{'template_name'},$in{'tpl_lang'});
+- }
+-
+- unless (open (TPL,$template_path)) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $in{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"view_template: can't open file %s",$template_path);
+- return undef;
+- }
+-
+- $param->{'rows'} = 5; # minimum size of 5 rows;
+- $param->{'template_content'} = ''; # init content
+- while(<TPL>) {$param->{'template_content'}.= $_; $param->{'rows'}++;}
+- $param->{'template_content'} = &tools::escape_html($param->{'template_content'});
+- close TPL;
+-
+-
+- $param->{'webormail'} = $in{'webormail'};
+- $param->{'template_name'} = $in{'template_name'};
+- $param->{'template_path'} = $template_path;
+- $param->{'scope'} = $in{'scope'};
+- $param->{'tpl_lang'} = $in{'tpl_lang'};
+-
+- return 1;
+-}
+-
+-## template copy
+-sub do_copy_template {
+- &wwslog('info', 'do_copy_template');
+-
+-
+- ## Load original template
+- &do_view_template();
+-
+- ## Return form
+- unless ($in{'scope_out'}) {
+- return 1;
+- }
+-
+-# one of theses parameters is commint from the form submission
+- if ($in{'scope_out'} eq 'list') {
+- if ($in{'list_out'}) {
+- my $list_out;
+- unless ($list_out = new List $in{'list_out'}, $robot) {
+- &report::reject_report_web('user','unknown_list',{'list' => $in{'list_out'}},$param->{'action'},'');
+- &wwslog('info','do_copy_template: unknown list %s', $in{'list_out'});
+- &web_db_log({'parameters' => $in{'list_out'},
+- 'status' => 'error',
+- 'error_type' => 'unknown_list'});
+- return undef;
+- }
+-
+- $param->{'template_path_out'} = &tools::get_template_path($in{'webormail'},$robot,$in{'scope_out'},$in{'template_name_out'},$in{'tpl_lang_out'},$list_out);
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
+- &wwslog('err','do_copy_template: missing parameter webormail');
+- &web_db_log({'parameters' => $in{'webormail'},
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return 1;
+- }
+- }else{
+- $param->{'template_path_out'} = &tools::get_template_path($in{'webormail'},$robot,$in{'scope_out'},$in{'template_name_out'},$in{'tpl_lang_out'});
+- }
+-
+- unless (&tools::mk_parent_dir($param->{'template_path_out'})) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path_out'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't create parent directory for %s : %s", $param->{'template_path_out'}, $!);
+- &web_db_log({'parameters' => $param->{'template_name_out'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- unless (open (TPLOUT,'>'.$param->{'template_path_out'})) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path_out'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't open file %s : %s", $param->{'template_path_out'}, $!);
+- &web_db_log({'parameters' => $param->{'template_name_out'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- print TPLOUT &tools::unescape_html($param->{'template_content'});
+- close TPLOUT;
+-
+- if ($in{'list_out'}) {$param->{'list'} = $in{'list'} = $in{'list_out'} ;}
+-
+- $param->{'webormail'} = $in{'webormail'};
+- $param->{'tpl_lang'} = $in{'tpl_lang'} = $in{'tpl_lang_out'};
+- $param->{'scope'} = $in{'scope'} = $in{'scope_out'} ;
+- $param->{'template_path'} = $in{'template_path'} = $param->{'template_path_out'};
+- $param->{'template_name'} = $in{'template_name'} = $in{'template_name_out'};
+- &web_db_log({'parameters' => $param->{'template_name_out'},
+- 'status' => 'success'});
+- return ('edit_template');
+-}
+-
+-
+-## manage the rejection templates
+-sub do_manage_template {
+- &wwslog('info', '(%s,%s)', $in{'subaction'}, $in{'message_template'});
+-
+- my $file;
+-
+- $in{'message_template'} =~ s/^reject_//;
+-
+- if ($in{'message_template'}) {
+- my $escaped_template_path = $in{'message_template'};
+- $escaped_template_path =~ s/\s/_/g ;
+- $param->{'template_path'} = &tools::get_template_path('mail',$robot,'list', ,'reject_'.$escaped_template_path.'.tt2','',$list);
+- }
+- my $tt2_include_path = &tools::make_tt2_include_path($robot,'mail_tt2','',$list);
+- my $default_file = &tools::find_file('reject.tt2',@{$tt2_include_path});
+-
+-
+- if ($in{'subaction'} eq 'save') {
+- ## create the parent directory if it doesn't already exist
+- unless (&tools::mk_parent_dir($param->{'template_path'})) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't create parent directory for %s : %s", $param->{'template_path'}, $!);
+- &web_db_log({'parameters' => $param->{'template_name'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- ## open the template
+- unless (open (TPLOUT ,'>' ,$param->{'template_path'})) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't open file %s : %s", $param->{'template_path'}, $!);
+- &web_db_log({'parameters' => $in{'template_name'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- ## save template contents
+- print TPLOUT $in{'template_content'};
+- close TPLOUT;
+- &report::notice_report_web('performed',{},$in{'subaction'});
+-
+- }elsif($in{'subaction'} eq 'create_new') {
+-
+- $in{'template_new'} = $in{'new_template_name'} ;
+-
+- unless ($in{'new_template_name'}) {
+- &report::reject_report_web('user','missing template name',{'path' => ''},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- return undef;
+- }
+- my $escaped_template_path = $in{'new_template_name'};$escaped_template_path =~ s/\s/_/g ;
+- my $new_template_path = &tools::get_template_path('mail',$robot,'list', ,'reject_'.$escaped_template_path.'.tt2','',$list);
+-
+- if (-f $new_template_path) {
+- &report::reject_report_web('intern','template already exist',{'path' => $new_template_path},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- return undef;
+- }
+- ## create the parent directory if it doesn't already exist
+- unless (&tools::mk_parent_dir($new_template_path)) {
+-
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't create parent directory for %s : %s", $param->{'template_path'}, $!);
+- &web_db_log({'parameters' => $param->{'template_name'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- my $default_file = &tools::get_template_path('mail',$robot,'robot', ,'reject.tt2','',$list);
+- $default_file = &tools::get_template_path('mail',$robot,'site', ,'reject.tt2','',$list) unless (-f $default_file);
+- $default_file = &tools::get_template_path('mail',$robot,'distrib', ,'reject.tt2','',$list)unless (-f $default_file);
+-
+- unless(open (DEFAULT, $default_file)){
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $default_file},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't open file %s : %s", $default_file, $!);
+- return undef;
+- }
+-
+- unless(open (TPL, '> '.$new_template_path)){
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $new_template_path},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't open file %s : %s", $new_template_path, $!);
+- return undef;
+- }
+-
+- while (<DEFAULT>){
+- print TPL $_;
+- }
+- close DEFAULT;
+- close TPL;
+- $in{'subaction'}='modify';
+- $in{'message_template'} = $in{'new_template_name'};
+- return 'manage_template';
+-
+- }elsif ($in{'subaction'} eq 'modify') {
+-
+- unless(open (FILE, $param->{'template_path'})){
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't open file MODIFY %s : %s", $param->{'template_path'}, $!);
+- &web_db_log({'parameters' => $param->{'template_path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- while (<FILE>){
+- $param->{'content'} .= $_;
+- }
+- $param->{'content'} = &tools::escape_html($param->{'content'});
+- close FILE;
+- $param->{'message_template'} = $in{'message_template'};
+-
+- }elsif($in{'subaction'} eq 'setdefault') {
+- # replace existing reject.tt2 file by a symlink to reject_default.tt2 for compatibility with version older than 6.0
+- my $base = $list->{'dir'}.'/mail_tt2/';
+- $in{'new_default'} =~ s/\s/_/g ;
+- my $absolute_file = $base.'reject_'.$in{'new_default'}.'.tt2';
+-
+- &do_log('info','Change default by linking %s 2 %s',$base.'reject.tt2',$absolute_file);
+- if (-l $base.'reject.tt2') {
+- unless (unlink ($base.'reject.tt2')){
+- &wwslog('err','Could not unlink %s',$base.'reject.tt2');
+- }
+- }
+- unless (symlink ($absolute_file,$base.'reject.tt2')){
+- &wwslog('err','Could not symlink %s,%s',$absolute_file,$base.'reject.tt2');
+- }
+-
+- }elsif ($in{'subaction'} eq 'delete') {
+-
+- unless(unlink $param->{'template_path'}) {
+- &report::reject_report_web('intern','cannot_delete',{'file_del' => $param->{'template_path'}},'','','',$robot);
+- &wwslog('err',"can't open file %s : %s", $param->{'template_path'}, $!);
+- &web_db_log({'parameters' => $param->{'template_path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- &report::notice_report_web('performed',{},$in{'subaction'});
+- }
+- ## Build the list of available templates
+- my $available_files = &tools::get_templates_list('mail','',$list, {'ignore_global' => 1});
+- foreach $file (keys %$available_files) {
+- if ($file eq 'reject.tt2') {
+- my $base = $list->{'dir'}.'/mail_tt2/';
+- my $absolute_file = $base.'reject.tt2';
+- if (-l $absolute_file){
+- my $default = readlink ($absolute_file);
+- if ((-f $default )||( -f $base.$default )) {
+-
+- $default =~ s/^.*reject_//;
+- $default =~ s/.tt2$//;
+- $default =~ s/_/ /g;
+- $param->{'default_reject_template'} = $default;
+- }else{
+- # link to no existing file. remove link
+- &wwslog('err','Link %s point to un no existing file (%s)', $base.'reject.tt2',$default);
+- unless (unlink ($absolute_file)){
+- &wwslog('err','do_modindex: could not unlink %s',$base.'reject.tt2');
+- }
+- }
+- }elsif(-f $absolute_file){
+- # replace existing reject.tt2 file by a symlink to reject_default.tt2 for compatibility with version older than 6.0
+- unless (rename ($absolute_file,$base.'reject_default.tt2')){
+- &wwslog('err','Could not rename %,%s',$base.'reject.tt2',$base.'reject_default.tt2');
+- }
+- unless (symlink ($base.'reject_default.tt2',$absolute_file)){
+- &wwslog('err','Could not symlink %s,%s',$base.'reject_default.tt2',$absolute_file);
+- }
+-
+- $param->{'default_reject_template'} = 'default';
+- push (@{$param->{'available_files'}},'default');
+- }
+- }else{
+- next unless($file =~ /^reject_/);
+- $file =~ s/^reject_//;
+- $file =~ s/.tt2$//;
+- $file =~ s/_/ /g;
+- push (@{$param->{'available_files'}},$file);
+- }
+- }
+-
+- return 1;
+-}
+-
+-## online template edition
+-sub do_edit_template {
+-
+- $in{'subdir'} ||= 'default';
+-
+- &wwslog('info', "do_edit_template(type=$in{'webormail'},template-name=$in{'template_name'},listname=$in{'list'},path=$in{'template_path'},scope=$in{'scope'},lang=$in{'tpl_lang'})");
+-
+- ## Load original template
+- &do_view_template;
+-
+- unless ($in{'content'}) {
+- return 1;
+- }
+- if ($in{'scope'} eq 'list') {
+- if ($in{'list'}) {
+- $param->{'template_path'} = &tools::get_template_path($in{'webormail'},$robot,$in{'scope'},$in{'template_name'},$in{'tpl_lang'},$list);
+- }else{
+- &report::reject_report_web('user','listname_needed',{},$param->{'action'});
+- &wwslog('info',"edit_template : no output lisname while output scope is list");
+- &web_db_log({'parameters' => $in{'template_name'},
+- 'status' => 'error',
+- 'error_type' => 'no_list'});
+- return undef;
+- }
+- }else {
+- $param->{'template_path'} = &tools::get_template_path($in{'webormail'},$robot,$in{'scope'},$in{'template_name'},$in{'tpl_lang'});
+- }
+-
+- unless (open (TPLOUT,'>'.$param->{'template_path'})) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"edit_template: can't open file %s", $param->{'template_path'});
+- &web_db_log({'parameters' => $in{'template_name'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- print TPLOUT &tools::unescape_html($in{'content'});
+- close TPLOUT;
+-
+- $param->{'saved'} = 1;
+- $param->{'template_content'} = $in{'content'};
+- $param->{'webormail'} = $in{'webormail'};
+- $param->{'template_name'} = $in{'template_name'};
+- $param->{'list'} = $in{'list'};
+- $param->{'scope'} = $in{'scope'};
+- $param->{'template_path'} = $in{'template_path'};
+- $param->{'tpl_lang'} = $in{'tpl_lang'};
+-
+- &web_db_log({'parameters' => $in{'template_name'},
+- 'status' => 'success'});
+-
+- return 'ls_templates';
+-
+-}
+-
+-
+- ## Server show colors, and install static css in future edit colors etc
+-
+-
+- ## Server show colors, and install static css in futur edit colors etc
+-sub do_skinsedit {
+- &wwslog('info', 'do_skinsedit');
+- my $f;
+-
+- my $dir = &Conf::get_robot_conf($robot, 'css_path');
+- my $css_url = &Conf::get_robot_conf($robot, 'css_url');
+-
+- ## Checking families and other virtual hosts.
+- &get_server_details();
+-
+- $param->{'css_warning'} = "parameter css_url seems strange, it must be the url of a directory not a css file" if ($css_url =~ /\.css$/);
+-
+- if(($in{'editcolors'})&&($in{'subaction'} eq 'reset')){
+- delete $session->{'custom_css'};
+- delete $param ->{'session'}{'custom_css'};
+- delete $param->{'custom_css'};
+-
+- foreach my $colornumber (0..15){
+- delete $session->{'color_'.$colornumber} ;
+- delete $param ->{'session'}{'color_'.$colornumber};
+- }
+- }
+-
+- if(($in{'editcolors'})&&($in{'subaction'} eq 'test')){
+-
+- return unless ($in{'custom_color_number'} =~ /color_/);
+- $param->{'custom_color_number'} = $in{'custom_color_number'};
+- $param->{'custom_color_value'} = $in{'custom_color_value'};
+- $param->{'custom_css'} = $css_url.'/'.$param->{'user'}{'email'}.'.style.css';
+- $session->{'custom_css'} = $param->{'custom_css'} ;
+-
+- $session->{$in{'custom_color_number'}} = $in{'custom_color_value'};
+-
+- $param->{$in{'custom_color_number'}} = $in{'custom_color_value'};
+- foreach my $colornumber (0..15){
+- if ($session->{'color_'.$colornumber} ) {
+- $param->{'color_'.$colornumber} = $session->{'color_'.$colornumber} ;
+- $param->{'session'}{'color_'.$colornumber} = $session->{'color_'.$colornumber} ;
+- }
+- }
+-
+- }
+- if (($in{'subaction'} eq 'install')||($in{'installcss'})) {
+-
+- my $lang = &Language::Lang2Locale($param->{'lang'});
+- my $tt2_include_path = &tools::make_tt2_include_path($robot,'web_tt2',$lang,'');
+-
+- my $date= time;
+- my $style_file;
+-
+- # update config
+- foreach my $colornumber (0..15){
+- &Conf::set_robot_conf($robot, 'color_'.$colornumber, $session->{'color_'.$colornumber}) if ($session->{'color_'.$colornumber});
+- }
+- $param->{'conf'}=$Conf::Conf;
+-
+- foreach my $css ('style.css','print.css','fullPage.css','print-preview.css') {
+- $param->{'css'} = $css;
+- my $css_file;
+- # if user use editcolor form we must generate a static CSS that used custom colors.
+- if($in{'subaction_test'}){
+- $css_file = "$dir/$param->{'user'}{'email'}.$css";
+- }else{
+- $css_file = "$dir/$css";
+- }
+- unless (-d $dir) {
+- unless (mkdir $dir, 0775) {
+- &report::reject_report_web('intern',"mkdir_failed",{'path' => $dir}, $param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err','skinsedit : failed to create directory %s : %s',$dir, $!);
+- return undef;
+- }
+- chmod 0775, $dir;
+- &wwslog('notice','skinsedit : created missing directory %s',$dir);
+- }
+-
+- ## Keep a copy of the previous CSS (only if this is not a custom css).
+- if ((-f "$css_file")&&!($in{'editcolors'})) {
+- unless (rename "$css_file", "$css_file.$date") {
+- &report::reject_report_web('intern','cannot_rename_file',{'path' => "$css_file.$date"},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err','skinsedit : can\'t open file %s.%s',$css_file,$date);
+- return undef;
+- }
+- }
+-
+- if ($in{'subaction_install'}) {
+- foreach my $colornumber (0..15){
+- $param->{'color_'.$colornumber} = $session->{'color_'.$colornumber} if ($session->{'color_'.$colornumber});
+- }
+- }
+-
+- unless (open (CSS,">$css_file")) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => "$css_file"},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err','skinsedit : can\'t open file (write) %s',$css_file);
+- return undef;
+- }
+- unless (&tt2::parse_tt2($param,'css.tt2' ,\*CSS, $tt2_include_path)) {
+- my $error = &tt2::get_error();
+- $param->{'tt2_error'} = $error;
+- &List::send_notify_to_listmaster('web_tt2_error', $robot,[$error]);
+- &wwslog('info', "do_skinsedit : error while installing $css_file");
+- }
+- close (CSS) ;
+-
+- ## Make the CSS readable to anyone
+- chmod 0775, "$css_file";
+-
+-
+- }
+-
+- $param->{'css_result'} = 1 ;
+- }
+- return 1;
+-}
+-
+- ## Multiple add
+- sub do_add_request {
+- &wwslog('info', 'do_add_request(%s)', $in{'email'});
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_add_request', 'add'));
+-
+- return 1;
+- }
+-
+-
+-####################################################
+-# do_add
+-####################################################
+-# Adds a user to a list (requested by an other user)
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest'
+-# | ($in{'previous_action'} || 'review')
+-# | undef
+-####################################################
+-## TODO: v�rifier validit� email
+- sub do_add {
+- &wwslog('info', 'do_add(%s)', $in{'email'}||$in{'pending_email'});
+- my $subscriptions = $list->get_subscription_requests();
+-
+- my %user;
+-
+- ## If a list is not 'open' and allow_subscribe_if_pending has been set to 'off' returns undef.
+- unless (($list->{'admin'}{'status'} eq 'open') || (&Conf::get_robot_conf($robot, 'allow_subscribe_if_pending') eq 'on')) {
+- &report::reject_report_web('user','list_not_open',{'status' => $list->{'admin'}{'status'}},$param->{'action'});
+- &wwslog('info','list not open');
+- &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
+- 'status' => 'error',
+- 'error_type' => 'list_not_open'});
+- return undef;
+- }
+-
+- my $email_regexp = &tools::get_regexp('email');
+- if ($in{'dump'}) {
+- foreach (split /\n/, $in{'dump'}) {
+- if (/^\s*($email_regexp)(\s+(.*))?\s*$/) {
+- $user{&tools::get_canonical_email($1)} = $5;
+- }
+- }
+- }elsif ($in{'email'} =~ /,/) {
+- foreach my $pair (split /\0/, $in{'email'}) {
+- if ($pair =~ /^($email_regexp)(,(.*))?\s*$/) {
+- $user{&tools::get_canonical_email($1)} = $5;
+- }
+- }
+- }elsif ($in{'email'}) {
+- $user{&tools::get_canonical_email($in{'email'})} = $in{'gecos'};
+- }elsif ($in{'pending_email'}) {
+- foreach my $pair (split /\0/, $in{'pending_email'}) {
+- my ($email, $gecos);
+- if ($pair =~ /^($email_regexp)(,(.*))?\s*$/) {
+- ($email, $gecos) = ($1,$5);
+- $user{&tools::get_canonical_email($email)} = $gecos;
+- }
+- }
+- }else {
+- &report::reject_report_web('user','no_email',{},$param->{'action'});
+- &wwslog('info','do_add: no email');
+- &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
+- 'status' => 'error',
+- 'error_type' => 'no_email'});
+- return undef;
+- }
+-
+- my ($total, @new_users, @added_users );
+- my $comma_emails ;
+- foreach my $email (keys %user) {
+- &wwslog('debug', "do_add subscription \$subscriptions->{$email}{custom_attribute} = $subscriptions->{$email}{'custom_attribute'})" );
+- if (ref($subscriptions->{$email}{'custom_attribute'}) eq 'HASH') {
+- my $xml = List::createXMLCustomAttribute($subscriptions->{$email}{'custom_attribute'}) ;
+- &wwslog('debug', "do_add subscription XML \$subscriptions->{$email}{custom_attribute} = $xml;");
+- }
+-
+- my $result = $list->check_list_authz('add',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'email' => $in{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $add_is;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $add_is = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- unless ($add_is =~ /do_it/) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- &wwslog('info','do_add: %s may not add', $param->{'user'}{'email'});
+- &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- next;
+- }
+-
+- unless (&tools::valid_email($email)) {
+- &report::reject_report_web('user','incorrect_email',{'email' => $email},$param->{'action'},$list);
+- &wwslog('info','do_add: incorrect email %s', $email);
+- &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
+- 'status' => 'error',
+- 'error_type' => 'incorrect_email'});
+- next;
+- }
+-
+- my $user_entry = $list->get_subscriber($email);
+-
+- if (defined($user_entry)) {
+- &report::reject_report_web('user','user_already_subscriber', {'list' => $list->{'name'},'email' => $email},$param->{'action'},$list);
+- &wwslog('info','do_add: %s already subscriber', $email);
+- &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
+- 'status' => 'error',
+- 'error_type' => 'already_subscriber'});
+- next;
+- }
+-
+- my $u2 = &List::get_user_db($email);
+- my $defaults = $list->get_default_user_options();
+- my $u;
+- %{$u} = %{$defaults};
+- $u->{'email'} = $email;
+- $u->{'gecos'} = $user{$email} || $u2->{'gecos'};
+- $u->{'date'} = $u->{'update_date'} = time;
+- $u->{'password'} = $u2->{'password'} || &tools::tmp_passwd($email) ;
+- $u->{'lang'} = $u2->{'lang'} || $list->{'admin'}{'lang'};
+- if ($comma_emails) {
+- $comma_emails = $comma_emails .','. $email;
+- }else{
+- $comma_emails = $email;
+- }
+-
+- ##
+- push @new_users, $u;
+- push @added_users, $email; ## List only email addresses ; used later to remove pending subrequests
+-
+- unless ($in{'quiet'} || $add_is =~ /quiet/i) {
+- unless ($list->send_file('welcome', $email, $robot,{})) {
+- &wwslog('err',"Unable to send template 'welcome' to $email");
+- }
+- }
+- }
+-
+- $total = $list->add_user(@new_users);
+- unless( defined $total) {
+- &report::reject_report_web('intern','add_subscriber_db_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_add: failed adding');
+- &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## Delete subscription request if any
+- $list->delete_subscription_request(@added_users);
+-
+- &report::notice_report_web('add_performed', {'total' => $total},$param->{'action'});
+-
+- foreach my $email (@added_users) {
+- &web_db_log({'target_email' => $email,
+- 'status' => 'success'});
+- }
+-
+- $in{'list'} = $in{'previous_list'} if ($in{'previous_list'});
+- return $in{'previous_action'} || 'review';
+- }
+-
+-
+-
+-####################################################
+-# do_del
+-####################################################
+-# Deletes a user from a list (requested by an other user)
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest'
+-# | ($in{'previous_action'} || 'review') | undef
+-#
+-####################################################
+- ## TODO: v�rifier validit� email
+- sub do_del {
+- &wwslog('info', 'do_del()');
+-
+- $in{'email'} = &tools::unescape_chars($in{'email'});
+-
+- my $result = $list->check_list_authz('del',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'email' => $in{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $del_is;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $del_is = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- unless ( $del_is =~ /do_it/) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- # &List::db_log('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'del',$param->{'list'},$robot,$in{'email'},'may not');
+- &wwslog('info','do_del: %s may not del', $param->{'user'}{'email'});
+- &web_db_log({'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- my @emails = split /\0/, $in{'email'};
+-
+- my ($total, @removed_users);
+-
+- foreach my $email (@emails) {
+-
+- my $escaped_email = &tools::escape_chars($email);
+-
+- my $user_entry = $list->get_subscriber($email);
+-
+- unless (defined($user_entry)) {
+- &report::reject_report_web('user','not_subscriber',{'email' => $email},$param->{'action'},$list);
+- # &List::db_log('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'del',$param->{'list'},$robot,$email,'not subscriber');
+- &wwslog('info','do_del: %s not subscribed', $email);
+- &web_db_log({'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'not_subscriber'});
+- next;
+- }
+-
+- push @removed_users, $email;
+-
+-
+- my $bounce_dir = $list->get_bounce_dir();
+-
+- if (-f $bounce_dir.'/'.$escaped_email) {
+- unless (unlink $bounce_dir.'/'.$escaped_email) {
+- &wwslog('info','do_resetbounce: failed deleting %s', $bounce_dir.'/'.$escaped_email);
+- &web_db_log({'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- next;
+- }
+- }
+-
+-
+- &wwslog('info','do_del: subscriber %s deleted from list %s', $email, $param->{'list'});
+-
+- unless ($in{'quiet'}) {
+- unless ($list->send_file('removed', $email, $robot,{})) {
+- &wwslog('notice',"Unable to send template 'removed' to $email");
+- }
+- }
+- }
+-
+- $total = $list->delete_user('users' => \@removed_users, 'exclude' =>'1');
+-
+- unless( defined $total) {
+- &report::reject_report_web('intern','delete_subscriber_db_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_del: failed');
+- &web_db_log({'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &report::notice_report_web('del_performed',{'total' => $total},$param->{'action'});
+- &web_db_log({'target_email' => $in{'email'},
+- 'status' => 'success'});
+-
+- $param->{'is_subscriber'} = 1;
+- $param->{'may_signoff'} = 1;
+-
+- ## Skip search because we don't have the expression anymore
+- delete $in{'previous_action'} if ($in{'previous_action'} eq 'search');
+-
+- return $in{'previous_action'} || 'review';
+- }
+-
+-
+-####################################################
+-# do_modindex
+-####################################################
+-# Web page for an editor to moderate documents and
+-# and/or to tag message in message topic context
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest' | 'admin' | '1' | undef
+-#
+-#######################################################
+- sub do_modindex {
+- &wwslog('info', 'do_modindex');
+- my $msg;
+- my $doc;
+-
+- ## Loads message list
+- unless (opendir SPOOL, $Conf{'queuemod'}) {
+- &report::reject_report_web('intern','cannot_open_spool',{'spool'=>$Conf{'queuemod'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_modindex: unable to read spool');
+- return 'admin';
+- }
+-
+- my $list_name = $list->{'name'};
+- my $list_id = $list->get_list_id();
+- foreach $msg ( sort grep(!/^\./, readdir SPOOL )) {
+- next
+- unless ($msg =~ /^$list_id\_(\w+)$/ ||
+- $msg =~ /^$list_name\_(\w+)$/);
+-
+- my $id = $1;
+-
+- ## Load msg
+- my $mail = new Message("$Conf{'queuemod'}/$msg");
+-
+- unless (defined $mail) {
+- &report::reject_report_web('intern','cannot_get_msg',{'msg'=>"$Conf{'queuemod'}/$msg"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_modindex: unable to parse msg %s', $msg);
+- closedir SPOOL;
+- next;
+- }
+-
+-
+- $param->{'spool'}{$id}{'size'} = int( (-s "$Conf{'queuemod'}/$msg") / 1024 + 0.5);
+- $param->{'spool'}{$id}{'subject'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('Subject'), Charset=>'utf8');
+- $param->{'spool'}{$id}{'subject'} ||= 'no_subject';
+- $param->{'spool'}{$id}{'date'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('Date'), Charset=>'utf8');
+- $param->{'spool'}{$id}{'from'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('From'), Charset=>'utf8');
+- $param->{'spool'}{$id}{'spam_status'} = $mail->{'spam_status'};
+- foreach my $field ('subject','date','from') {
+- $param->{'spool'}{$id}{$field} =~ s/&/&/g;
+- $param->{'spool'}{$id}{$field} =~ s/</</g;
+- $param->{'spool'}{$id}{$field} =~ s/>/>/g;
+- }
+- }
+- closedir SPOOL;
+-
+- if ($list->is_there_msg_topic()) {
+-
+- $param->{'request_topic'} = 1;
+-
+- foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
+- if ($top->{'name'}) {
+- push (@{$param->{'available_topics'}},$top);
+- }
+- }
+- $param->{'topic_required'} = $list->is_msg_topic_tagging_required();
+- }
+-
+- my $available_files = &tools::get_templates_list('mail','',$list, {'ignore_global' => 1});
+- foreach my $file (keys %$available_files) {
+-
+- if ($file eq 'reject.tt2') {
+-
+- my $base = $list->{'dir'}.'/mail_tt2/';
+- my $absolute_file = $base.'reject.tt2';
+- if (-l $absolute_file){
+-
+- my $default = readlink ($absolute_file);
+- if ((-f $default )||( -f $base.$default )) {
+- $default =~ s/^.*reject_//;
+- $default =~ s/.tt2$//;
+- $param->{'default_reject_template'} = $default;
+- }else{
+- # link to no existing file. remove link
+- &wwslog('err','do_modindex: link %s point to un no existing file (%s)', $base.'reject.tt2',$default);
+- unless (unlink ($absolute_file)){
+- &wwslog('err','do_modindex: could not unlink %s',$base.'reject.tt2');
+- }
+- }
+- }elsif(-f $absolute_file){
+- # replace existing reject.tt2 file by a symlink to reject_default.tt2 for compatibility with version older than 6.0
+- unless (rename ($absolute_file,$base.'reject_default.tt2')){
+- &wwslog('err','do_modindex: could not rename %,%s',$base.'reject.tt2',$base.'reject_default.tt2');
+- }
+- unless (symlink ($base.'reject_default.tt2',$absolute_file)){
+- &wwslog('err','do_modindex: could not symlink %s,%s',$base.'reject_default.tt2',$absolute_file);
+- }
+-
+- $param->{'default_reject_template'} = 'default';
+- push (@{$param->{'available_files'}},'default');
+- }
+- }else{
+- next unless($file =~ /^reject_/);
+- $file =~ s/^reject_//;
+- $file =~ s/.tt2$//;
+- push (@{$param->{'available_files'}},$file);
+- }
+- }
+- ## shared documents awaiting moderation
+- foreach my $d (@{$param->{'doc_mod_list'}}) {
+-
+- $d =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+-
+- my $long_path = $1; # path without the filename
+- my $fname = $3; # the filename with .moderate
+- my $path = $long_path; $path =~ s/^.*\/shared//; #the path for the user, without the filename
+- my $visible_fname = &make_visible_path($fname); # the filename without .moderate
+- my $visible_path = $path;
+- $visible_path = &make_visible_path($visible_path);
+-
+- my %desc_hash;
+- if ($d && (-e "$long_path.desc.$fname")){
+- %desc_hash = &get_desc_file("$long_path.desc.$fname");
+- }
+-
+- my @info = stat $d;
+-
+- my $doc = {};
+- $doc->{'visible_path'} = $visible_path;
+- $doc->{'visible_fname'} = $visible_fname;
+- $doc->{'escaped_fname'} = &tools::escape_docname($fname, '/');
+- $doc->{'escaped_path'} = &tools::escape_docname($path, '/');
+- $doc->{'fname'} = $fname;
+- $doc->{'size'} = (-s $d)/1000;
+- $doc->{'date'} = gettext_strftime "%d %b %Y", localtime($info[9]);
+- $doc->{'author'} = $desc_hash{'email'};
+- $doc->{'path'} = $path;
+-
+- push(@{$param->{'info_doc_mod'}},$doc)
+- }
+-
+- unless (($param->{'spool'}) || ($param->{'mod_total_shared'} > 0)) {
+- &report::notice_report_web('no_msg_document', {'list' => $in{'list'}},$param->{'action'});
+- &wwslog('err','do_modindex: no message and no document');
+- }
+-
+- return 1;
+- }
+-
+-### installation of moderated documents of shared
+- sub do_d_install_shared {
+- &wwslog('info', 'do_d_install_shared(%s)', $in{'id'});
+-
+- if ($in{'mode_cancel'}) {
+- return 'modindex';
+- }
+-
+- my $shareddir = $list->{'dir'}.'/shared';
+- my $file;
+- my $slash_path;
+- my $fname;
+- my $visible_fname;
+- # list of file already existing
+- my @list_file_exist;
+-
+- unless($in{'mode_confirm'} || $in{'mode_cancel'}) {
+-
+- # file already exists ?
+- foreach my $id (split /\0/, $in{'id'}) {
+-
+- $file = "$shareddir$id";
+- $id =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- $slash_path = $1;
+- $fname = $3;
+- $visible_fname = &make_visible_path($fname);
+-
+- if (-e "$file") {
+- if (-e "$shareddir$slash_path$visible_fname") {
+- push(@list_file_exist,"$slash_path$visible_fname");
+- }
+- }
+- }
+-
+- if (@list_file_exist) {
+-
+- $param->{'list_file'}=\@list_file_exist;
+- my @id = split(/\0/,$in{'id'});
+- $param->{'id'} = \@id;
+-
+- return 1;
+- }
+- }
+-
+- # install the file(s) selected
+- foreach my $id (split /\0/, $in{'id'}) {
+-
+- $file = "$shareddir$id";
+- $id =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- $slash_path = $1;
+- $fname = $3;
+- my $new_fname; ## new filename without the .moderate extension
+- if ($fname =~ /^\.(.+)\.moderate$/) {
+- $new_fname = $1;
+- }
+- my $visible_path = &make_visible_path($slash_path);
+- $visible_fname = &make_visible_path($fname);
+-
+- if (-e "$file") {
+-
+- # rename the old file in .old if exists
+- if (-e "$shareddir$slash_path$new_fname") {
+- unless (rename "$shareddir$slash_path$new_fname","$shareddir$slash_path$new_fname.old"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir$slash_path$new_fname",
+- 'new'=>"$shareddir$slash_path$new_fname.old" },
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_install_shared : Failed to rename $shareddir$slash_path$new_fname to .old : %s",$!);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- unless (rename "$shareddir$slash_path.desc.$new_fname","$shareddir$slash_path.desc.$new_fname.old"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir$slash_path.desc.$new_fname",
+- 'new'=>"$shareddir$slash_path.desc.$new_fname.old"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_install_shared : Failed to rename shareddir$slash_path.desc.$new_fname to .old : %s",$!);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- }
+-
+- unless (rename ("$shareddir$id","$shareddir$slash_path$new_fname")){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir$id",
+- 'new'=>"$shareddir$slash_path$new_fname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_install_shared : Failed to rename $file to $shareddir$slash_path$new_fname : $!");
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- unless (rename ("$shareddir$slash_path.desc.$fname","$shareddir$slash_path.desc.$new_fname")){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir$slash_path.desc.$fname",
+- 'new'=>"$shareddir$slash_path.desc.$new_fname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_install_shared : Failed to rename $file to $shareddir$slash_path$new_fname : $!");
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # send a message to the author
+- my %context;
+- $context{'installed_by'} = $param->{'user'}{'email'};
+- $context{'filename'} = "$visible_path$visible_fname";
+-
+- my %desc_hash;
+- if ($id && (-e "$shareddir$slash_path.desc.$visible_fname")){
+- %desc_hash = &get_desc_file("$shareddir$slash_path.desc.$visible_fname");
+- }
+-
+- my $sender = $desc_hash{'email'};
+- unless ($list->send_file('d_install_shared', $sender, $robot, \%context)) {
+- &wwslog('notice',"Unable to send template 'd_install_shared' to $sender");
+- }
+- }
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+- return 'modindex';
+- }
+-
+-### reject moderated documents of shared
+- sub do_d_reject_shared {
+- &wwslog('info', 'do_d_reject_shared(%s)', $in{'id'});
+-
+- my $shareddir = $list->{'dir'}.'/shared';
+- my $file;
+- my $slash_path;
+- my $fname;
+- my $visible_fname;
+-
+- foreach my $id (split /\0/, $in{'id'}) {
+-
+- $file = "$shareddir$id";
+- $id =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- $slash_path = $1;
+- $fname = $3;
+- $visible_fname = &make_visible_path($fname);
+- my $visible_path = &make_visible_path($slash_path);
+-
+- unless ($in{'quiet'}) {
+-
+- my %context;
+- my $sender;
+- $context{'rejected_by'} = $param->{'user'}{'email'};
+- $context{'filename'} = "$visible_path$visible_fname";
+-
+- my %desc_hash;
+- if ($id && (-e "$shareddir$slash_path.desc.$fname")){
+- %desc_hash = &get_desc_file("$shareddir$slash_path.desc.$fname");
+- }
+- $sender = $desc_hash{'email'};
+-
+- unless ($list->send_file('d_reject_shared', $sender, $robot, \%context)) {
+- &wwslog('notice',"Unable to send template 'd_reject_shared' to $sender");
+- }
+- }
+-
+-
+- unless (unlink($file)) {
+- &report::reject_report_web('intern','erase_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_d_reject_shared: failed to erase %s', $file);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- unless (unlink("$shareddir$slash_path.desc.$fname")) {
+- &report::reject_report_web('intern','erase_file',{'file' => "$shareddir$slash_path.desc.$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_reject_shared: failed to erase $shareddir$slash_path.desc.$fname");
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'success'});
+- return 'modindex';
+- }
+-
+-
+-
+-####################################################
+-# do_reject
+-####################################################
+-# Moderation of messages : rejects messages and notifies
+-# their senders. If in{'blacklist'} add sender to list blacklist
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest' | 'modindex' | undef
+-#
+-####################################################
+- sub do_reject {
+-
+- # toggle selection javascript have a distinction of spam and ham base on the checkbox name . It is not useful here so join id list and idspam list.
+- $in{'id'} .= ','.$in{'idspam'} if ($in{'idspam'});
+- $in{'id'} =~ s/^,//;
+- $in{'id'} =~ s/\0/,/g;
+- $in{'message_template'};
+-
+- ## The quiet information might either be provided by the 'quiet' variable
+- ## or by the 'quiet' value of the 'message_template' variable
+- if ($in{'message_template'} eq 'quiet') {
+- $in{'quiet'} = 1;
+- delete $in{'message_template'};
+- }
+- if ($in{'blacklist'}) {
+- $in{'quiet'} = 1;
+- }
+-
+- &wwslog('info', 'do_reject(%s)', $in{'id'});
+- my ($msg, $file);
+-
+- $param->{'blacklist_added'} = 0;
+- $param->{'blacklist_ignored'} = 0;
+- foreach my $id (split (/,/, $in{'id'})) {
+-
+- ## For compatibility concerns
+- foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
+- $file = $Conf{'queuemod'}.'/'.$list_id.'_'.$id;
+- last if (-f $file);
+- }
+-
+- ## Open the file
+- unless (open(IN, $file)) {
+- &report::reject_report_web('user','already_moderated',{},$param->{'action'});
+- &wwslog('err','do_reject: Unable to open %s', $file);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- next;
+- }
+-
+- # extract sender address is needed to report reject to sender and in case the sender is to be added to the blacklist
+- if (($in{'quiet'} ne '1')||($in{'blacklist'})) {
+- my $msg;
+- my $parser = new MIME::Parser;
+- $parser->output_to_core(1);
+- unless ($msg = $parser->read(\*IN)) {
+- &wwslog('err', 'Unable to parse message %s', $file);
+- next;
+- }
+-
+- my @sender_hdr = Mail::Address->parse($msg->head->get('From'));
+- unless ($#sender_hdr == -1) {
+- my $rejected_sender = $sender_hdr[0]->address;
+- unless ($in{'quiet'}) {
+- my %context;
+- $context{'subject'} = &MIME::EncWords::decode_mimewords($msg->head->get('subject'), Charset=>'utf8');
+- chomp $context{'subject'};
+- $context{'rejected_by'} = $param->{'user'}{'email'};
+- $context{'template_used'} = $in{'message_template'};
+- unless ($list->send_file($in{'message_template'}, $rejected_sender, $robot, \%context)) {
+- &wwslog('notice',"Unable to send template $in{'message_template'} to $rejected_sender");
+- }
+- }
+- if ($in{'blacklist'}) {
+- if (&tools::add_in_blacklist($rejected_sender,$robot,$list)) {
+- $param->{'blacklist_added'} += 1;
+- &wwslog('info',"added $rejected_sender to $list->{'name'} blacklist");
+- }else{
+- &wwslog('notice',"Unable to add $rejected_sender to $list->{'name'} blacklist");
+- $param->{'blacklist_ignored'} += 0;
+- }
+- }
+- }
+- }
+- close(IN);
+-
+- unless (unlink($file)) {
+- &report::reject_report_web('intern','erase_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_reject: failed to erase %s', $file);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- }
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'success'});
+- &report::notice_report_web('performed',{},$param->{'action'});
+-
+- return 'modindex';
+- }
+-
+-####################################################
+-# do_distribute
+-####################################################
+-# Moderation of messages : distributes moderated
+-# messages and tag it in message moderation context
+-#
+-# IN : - id of message to distribute. This value can also be in idspam parameter
+-#
+-# OUT : 'loginrequest' | 'modindex' | undef
+-#
+-######################################################
+- sub do_distribute {
+-
+- $in{'id'} .= ','.$in{'idspam'} if ( $in{'idspam'});
+- $in{'id'} =~ s/^,//;
+- $in{'id'} =~ s/\0/,/g;
+-
+- &wwslog('info', 'do_distribute(%s)', $in{'id'});
+- my ($msg, $file);
+-
+- my $time = time;
+- my $data = {'headers' => {'Message-ID' => &tools::get_message_id($robot),
+- 'X-Sympa-NoWrap' => 'yes'},
+- 'from'=> $param->{'user'}{'email'}};
+-
+- ## msg topics
+- my @msg_topics;
+- foreach my $msg_topic (@{$list->{'admin'}{'msg_topic'}}) {
+- my $var_name = "topic_"."$msg_topic->{'name'}";
+- if ($in{"$var_name"}) {
+- push @msg_topics, $msg_topic->{'name'};
+- }
+- }
+- my $list_topics = join(',',@msg_topics);
+-
+- if (!$list_topics && $list->is_msg_topic_tagging_required()) {
+- &report::reject_report_web('user','msg_topic_missing',{},$param->{'action'});
+- &wwslog('info','do_distribute: message(s) without topic but in a required list');
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'no_topic'});
+- return undef;
+- }
+-
+-
+- ## messages
+- foreach my $id (split (/,/, $in{'id'})) {
+- my $mail_command = sprintf ("QUIET DISTRIBUTE %s %s\n",$list->{'name'},$id);
+- $data->{'body'} .= $mail_command;
+-
+- ## For compatibility concerns
+- foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
+- $file = $Conf{'queuemod'}.'/'.$list_id.'_'.$id;
+- last if (-f $file);
+- }
+-
+- unless (-f $file) {
+- &report::reject_report_web('user','already_moderated',{},$param->{'action'});
+- &wwslog('err','do_distribute: Unable to open %s', $file);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- next;
+- }
+-
+- ## TAG
+- if ($list_topics) {
+-
+- my $parser = new MIME::Parser;
+- $parser->output_to_core(1);
+-
+- unless (open FILE, "$file") {
+- &wwslog('notice', 'do_distribute: Cannot open file %s', $file);
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- my $msg = $parser->parse(\*FILE);
+- my $head = $msg->head();
+- my $filetopic = $list->tag_topic(&tools::clean_msg_id($head->get('Message-Id')),$list_topics,'editor');
+- }
+-
+- unless (rename($file,"$file.distribute")) {
+- &report::reject_report_web('intern','rename_file',{'old'=>$file,
+- 'new'=>"$file.distribute"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_distribute: failed to rename %s', $file);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- }
+- }
+-
+- $data->{'not_auto_submitted'} = 1;
+- unless (&mail::mail_file('',&Conf::get_robot_conf($robot, 'sympa'), $data, $robot)) {
+- &report::reject_report_web('intern','cannot_send_distribute',{'from' => $param->{'user'}{'email'},'listname'=>$list->{'name'}},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_distribute: failed to send message for file %s', $file);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'success'});
+-
+- &report::notice_report_web('performed_soon',{},$param->{'action'});
+-
+- return 'modindex';
+- }
+-
+-####################################################
+-# do_viewmod
+-####################################################
+-# Web page for an editor to moderate a mail and/or
+-# to tag it in message topic context
+-#
+-# IN : -
+-#
+-# OUT : 'login,request' | '1' | undef
+-#
+-####################################################
+-sub do_viewmod {
+- &wwslog('info', 'do_viewmod(%s,%s)', $in{'id'},$in{'file'});
+-
+- my $msg;
+- my $tmp_dir;
+-
+- my $available_files = &tools::get_templates_list('mail','',$list, {'ignore_global' => 1});
+- foreach my $file (keys %$available_files) {
+- next unless($file =~ /^reject_/);
+- $file =~ s/^reject_//;
+- $file =~ s/.tt2$//;
+- push (@{$param->{'available_files'}},$file);
+- }
+-
+- ## For compatibility concerns
+- foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
+- $tmp_dir = $Conf{'queuemod'}.'/.'.$list_id.'_'.$in{'id'};
+- if (-d $tmp_dir) {
+- last;
+- }
+- }
+-
+- unless (-d $tmp_dir) {
+- &report::reject_report_web('intern','no_html_message_available',{'dir' => $tmp_dir},$param->{'action'});
+- &wwslog('err','do_viewmod: no HTML version of the message available in %s', $tmp_dir);
+- return undef;
+- }
+-
+- if ($in{'file'}) {
+- $in{'file'} =~ /\.(\w+)$/;
+- $param->{'file_extension'} = $1;
+- $param->{'file'} = $tmp_dir.'/'.$in{'file'};
+- $param->{'bypass'} = 1;
+- }else {
+- &tt2::add_include_path($tmp_dir) ;
+- }
+-
+- $param->{'base'} = sprintf "%s/viewmod/%s/%s/", &Conf::get_robot_conf($robot, 'wwsympa_url'), $param->{'list'}, $in{'id'};
+- $param->{'id'} = $in{'id'};
+-
+- if ($list->is_there_msg_topic()) {
+-
+- $param->{'request_topic'} = 1;
+-
+- foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
+- if ($top->{'name'}) {
+- push (@{$param->{'available_topics'}},$top);
+- }
+- }
+- $param->{'topic_required'} = $list->is_msg_topic_tagging_required();
+- }
+-
+- return 1;
+- }
+-
+-
+-## Edition of list/sympa files
+-## No list -> sympa files (helpfile,...)
+-## TODO : upload
+-## TODO : edit family file ???
+- sub do_editfile {
+- &wwslog('info', 'do_editfile(%s)', $in{'file'});
+-
+- $param->{'subtitle'} = sprintf $param->{'subtitle'}, $in{'file'};
+-
+- unless ($in{'file'}) {
+- ## Messages edition
+- foreach my $f ('info','homepage','welcome.tt2','bye.tt2','removed.tt2','message.footer','message.header','remind.tt2','invite.tt2','reject.tt2','your_infected_msg.tt2') {
+- next unless ($list->may_edit($f, $param->{'user'}{'email'}) eq 'write');
+- if ($wwslib::filenames{$f}{'gettext_id'}) {
+- $param->{'files'}{$f}{'complete'} = gettext($wwslib::filenames{$f}{'gettext_id'});
+- }else {
+- $param->{'files'}{$f}{'complete'} = $f;
+- }
+- $param->{'files'}{$f}{'selected'} = '';
+- }
+- return 1;
+- }
+-
+- unless (defined $wwslib::filenames{$in{'file'}}) {
+- &report::reject_report_web('user','file_not_editable',{'file' => $in{'file'}},$param->{'action'});
+- &wwslog('err','do_editfile: file %s not editable', $in{'file'});
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- $param->{'file'} = $in{'file'};
+-
+- my $subdir = '';
+- if ($in{'file'} =~ /\.tt2$/) {
+- $subdir = 'mail_tt2/';
+- }
+-
+- if ($param->{'list'}) {
+- my ($role,$right) = $list->may_edit($in{'file'}, $param->{'user'}{'email'});
+-
+- unless ($right eq 'write') {
+- &report::reject_report_web('auth','edit_right',{'role'=>$role, 'right' => $right},$param->{'action'},$list);
+- &wwslog('err','do_editfile: not allowed');
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- ## Add list lang to tpl filename
+- my $file = $in{'file'};
+- #$file =~ s/\.tpl$/\.$list->{'admin'}{'lang'}\.tpl/;
+-
+- ## Look for the template
+- $param->{'filepath'} = &tools::get_filename('etc',{},$subdir.$file,$robot, $list);
+-
+- ## There might be no matching file if default template not provided with Sympa
+- if (defined $param->{'filepath'}) {
+- ## open file and provide filecontent to the parser
+- ## It allows to us the correct file encoding
+- unless (open FILE, "<", $param->{'filepath'}) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $param->{'filepath'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_editfile: failed to open file %s: %s', $param->{'filepath'},$!);
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- while (<FILE>) {
+- Encode::from_to($_, $Conf{'filesystem_encoding'}, 'utf8');
+- $param->{'filecontent'} .= $_;
+- }
+- close FILE;
+- }else {
+- $param->{'filepath'} = $list->{'dir'}.'/'.$subdir.$file;
+- }
+-
+- ## Default for 'homepage' is 'info'
+- if (($in{'file'} eq 'homepage') &&
+- ! $param->{'filepath'}) {
+- $param->{'filepath'} = &tools::get_filename('etc',{},$subdir.'info',$robot, $list);
+- }
+- }else {
+- unless (&List::is_listmaster($param->{'user'}{'email'},$robot)) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
+- &wwslog('err','do_editfile: no list');
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'no_list'});
+- return undef;
+- }
+-
+- my $file = $in{'file'};
+-
+- ## Look for the template
+- if ($file eq 'list_aliases.tt2') {
+- $param->{'filepath'} = &tools::get_filename('etc',{},$file,$robot,$list);
+- }else {
+- #my $lang = &Conf::get_robot_conf($robot, 'lang');
+- #$file =~ s/\.tpl$/\.$lang\.tpl/;
+-
+- $param->{'filepath'} = &tools::get_filename('etc',{},$subdir.$file,$robot,$list);
+- }
+- }
+-
+- if (-f $param->{'filepath'} && (! -r $param->{'filepath'})) {
+- &report::reject_report_web('intern','cannot_read',{'filepath' => $param->{'filepath'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_editfile: cannot read %s', $param->{'filepath'});
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'success'});
+- &tt2::allow_absolute_path();
+-
+- return 1;
+- }
+-
+-
+-
+-
+-
+-#####################################################################################
+-
+- ## Saving of list files
+- sub do_savefile {
+- &wwslog('info', 'do_savefile(%s)', $in{'file'});
+-
+- $param->{'subtitle'} = sprintf $param->{'subtitle'}, $in{'file'};
+-
+- if ($param->{'list'}) {
+- unless ($list->am_i('owner', $param->{'user'}{'email'})) {
+- &report::reject_report_web('auth','action_owner',{},$param->{'action'},$list);
+- &wwslog('err','do_savefile: not allowed');
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- if ($in{'file'} =~ /\.tt2$/) {
+- $param->{'filepath'} = $list->{'dir'}.'/mail_tt2/'.$in{'file'};
+- }else {
+- $param->{'filepath'} = $list->{'dir'}.'/'.$in{'file'};
+-
+- if (defined $list->{'admin'}{'family_name'}) {
+- unless ($list->update_config_changes('file',$in{'file'})) {
+- &report::reject_report_web('intern','update_config_changes',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_savefile: cannot write in config_changes for file %s', $param->{'filepath'});
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- }
+- }else {
+- unless (&List::is_listmaster($param->{'user'}{'email'}),$robot) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
+- &wwslog('err','do_savefile: no list');
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'no_list'});
+- return undef;
+- }
+-
+- if ($robot ne $Conf{'domain'}) {
+- if ($in{'file'} eq 'list_aliases.tt2') {
+- $param->{'filepath'} = "$Conf{'etc'}/$robot/$in{'file'}";
+- }else {
+- $param->{'filepath'} = "$Conf{'etc'}/$robot/mail_tt2/$in{'file'}";
+- }
+- }else {
+- if ($in{'file'} eq 'list_aliases.tt2') {
+- $param->{'filepath'} = "$Conf{'etc'}/$in{'file'}";
+- }else {
+- $param->{'filepath'} = "$Conf{'etc'}/mail_tt2/$in{'file'}";
+- }
+- }
+- }
+-
+- unless ((! -e $param->{'filepath'}) or (-w $param->{'filepath'})) {
+- &report::reject_report_web('intern','cannot_write',{'filepath' => $param->{'filepath'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_savefile: cannot write %s', $param->{'filepath'});
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## Keep the old file
+- if (-e $param->{'filepath'}) {
+- rename($param->{'filepath'}, "$param->{'filepath'}.orig");
+- }
+-
+- ## Not empty
+- if ($in{'content'} && ($in{'content'} !~ /^\s*$/)) {
+-
+- ## Remove DOS linefeeds (^M) that cause problems with Outlook 98, AOL, and EIMS:
+- $in{'content'} =~ s/\015//g;
+-
+- ## Create directory if required
+- my $dir = $param->{'filepath'};
+- $dir =~ s/\/[^\/]+$//;
+- unless (-d $dir) {
+- unless (mkdir $dir, 0777) {
+- &report::reject_report_web('intern','cannot_mkdir',{'dir' => $dir},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_savefile: failed to create directory %s: %s', $dir,$!);
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- ## Save new file
+- unless (open FILE, ">", $param->{'filepath'}) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $param->{'filepath'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_savefile: failed to save file %s: %s', $param->{'filepath'},$!);
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- my $e = $in{'content'};
+- Encode::from_to($e, 'utf8', $Conf{'filesystem_encoding'});
+- print FILE $e;
+- close FILE;
+- }elsif (-f $param->{'filepath'}) {
+- &wwslog('info', 'do_savefile: deleting %s', $param->{'filepath'});
+- unlink $param->{'filepath'};
+- }
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'success'});
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+-
+- # undef $in{'file'};
+- # undef $param->{'file'};
+- return 'editfile';
+- }
+-
+- ## Access to web archives
+-sub do_arc {
+- &wwslog('info', 'do_arc(%s, %s)', $in{'month'}, $in{'arc_file'});
+- my $latest;
+-
+- my $index = $session->{'arc_mode'} ;
+- unless ($index) {$index = $wwsconf->{'archive_default_index'};}
+-
+- ## Clean arc_file
+- if ($in{'arc_file'} eq '/') {
+- delete $in{'arc_file'};
+- }
+-
+- ## Access control
+- unless (defined &check_authz('do_arc', 'web_archive.access')) {
+- $param->{'previous_action'} = 'arc';
+- $param->{'previous_list'} = $list->{'name'};
+- return undef;
+- }
+-
+- $session->{'archive_sniffer'} = 'false' if ($param->{'user'}{'email'} or $in{'not_a_sniffer'}) ;
+-
+- if ($list->{'admin'}{'web_archive_spam_protection'} eq 'cookie'){
+- return 'arc_protect' unless ($session->{'archive_sniffer'} eq 'false') ;
+- }
+-
+- my $arc_path = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
+- ## Calendar
+- unless (opendir ARC, $arc_path) {
+- &report::reject_report_web('user','empty_archives',{},$param->{'action'},$list);
+- &wwslog('err','do_arc: no directory %s', $arc_path);
+- return undef;
+- }
+- foreach my $dir (sort grep(!/^\./,readdir ARC)) {
+- if ($dir =~ /^(\d{4})-(\d{2})$/ && -d $arc_path.'/'.$dir.'/arctxt') {
+- $param->{'calendar'}{$1}{$2} = '???';
+- if (open(IDX, $arc_path.'/'.$dir.'/index')) {
+- my ($msgs) = <IDX>;
+- chomp ($msgs);
+- close IDX;
+- $param->{'calendar'}{$1}{$2} = $msgs if ($msgs);
+- }
+- $latest = $dir;
+- }
+- }
+- closedir ARC;
+-
+- ## Read html file
+- $in{'month'} ||= $latest;
+- my $arc_month_path = $arc_path.'/'.$in{'month'};
+-
+- unless ($in{'arc_file'}) {
+- undef $latest;
+- unless (opendir ARC, $arc_month_path) {
+- &wwslog('err',"unable to readdir $arc_month_path");
+- &report::reject_report_web('user','month_not_found',{'month' => $in{'month'},
+- 'dir' => $arc_month_path,
+- 'listname' => $param->{'list'}},
+- $param->{'action'},
+- $list,$param->{'user'}{'email'},
+- $robot);
+- }
+- foreach my $file (grep(/^$index/,readdir ARC)) {
+- if ($file =~ /^$index(\d+)\.html$/) {
+- $latest = $1 if ($latest < $1);
+- }
+- }
+- closedir ARC;
+-
+- $in{'arc_file'} = $index.$latest.".html";
+- }
+-
+- ## File exist ?
+- my $arc_file_path = $arc_month_path.'/'.$in{'arc_file'};
+- unless (-r $arc_file_path) {
+- &wwslog('err',"unable to read $arc_file_path");
+- &report::reject_report_web('user','arc_not_found',{'arc_file' => $in{'arc_file'},
+- 'path' => $arc_file_path,
+- 'listname' => $param->{'list'}},
+- $param->{'action'},
+- $list,$param->{'user'}{'email'},
+- $robot);
+- return undef;
+- }
+-
+- ## File type
+- if ($in{'arc_file'} =~ /^(mail\d+|msg\d+|thrd\d+)\.html$/) {
+-
+- if ($in{'arc_file'} =~/^(thrd|mail)\d+\.html/) {
+- $session->{'arc_mode'} = $1;
+- }
+- if ($param->{'user'}{'email'}){
+- if ($param->{'user'}{'prefs'}{'arc_mode'} ne $session->{'arc_mode'}) {
+- # update user pref as soon as connected user change the way he consult archives
+- $param->{'user'}{'prefs'}{'arc_mode'} = $session->{'arc_mode'};
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+- }
+-
+- if ($in{'arc_file'} =~ /^(msg\d+)\.html$/) {
+- ## If the file is a message, load the metadata to find out who is the author of the message
+- my $metadata = &Archive::load_html_message('file_path' => $arc_file_path);
+- $param->{'include_picture'} = &tools::make_pictures_url('email' => $metadata->{'X-From'}, 'list' => $list);
+-
+- $param->{'subtitle'} = $metadata->{'X-Subject'};
+- }
+-
+- ## Provide a filehandle to the TT2 parser (instead of a filename previously)
+- ## It allows to set the appropriate utf8 binmode on the FH
+- open $param->{'file_handle'}, "<", $arc_file_path;
+-
+- &tt2::add_include_path($arc_month_path);
+- }else {
+-
+- if ($in{'arc_file'} =~ /\.(\w+)$/) {
+- $param->{'file_extension'} = $1;
+- }
+-
+- $param->{'bypass'} = 1;
+-
+- $param->{'file'} = $arc_file_path;
+- }
+-
+- my @stat = stat ($arc_file_path);
+- $param->{'date'} = $stat[9];
+- # send page as static if client is a bot. That's prevent crawling all archices every weeks by google, yahoo and others bots
+- if ($session->{'is_a_crawler'}) {
+- $param->{'header_date'} = $stat[9];
+- }
+- $param->{'base'} = sprintf "%s%s/arc/%s/%s/%s", $param->{'base_url'}, $param->{'path_cgi'}, $param->{'list'}, $in{'month'}, $in{'arc_file'};
+- $param->{'archive_name'} = $in{'month'};
+-
+- return 1;
+-}
+-
+- ## Access to latest web archives
+- sub do_latest_arc {
+- &wwslog('info', 'do_latest_arc(%s,%s,%s)', $in{'list'}, $in{'for'}, $in{'count'});
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_latest_arc', 'web_archive.access'));
+-
+- ## parameters of the query
+- my $today = time;
+-
+- my $oldest_day;
+- if (defined $in{'for'}) {
+- $oldest_day = $today - (86400 * ($in{'for'}));
+- $param->{'for'} = $in{'for'};
+- unless ($oldest_day >= 0){
+- &report::reject_report_web('user','nb_days_to_much',{'nb_days' => $in{'for'} },$param->{'action'},$list);
+- &wwslog('err','do_latest_lists: parameter "for" is too big"');
+- }
+- }
+-
+- my $nb_arc;
+- my $NB_ARC_MAX = 100;
+- if (defined $in{'count'}) {
+- if ($in{'count'} > $NB_ARC_MAX) {
+- $in{'count'} = $NB_ARC_MAX;
+- }
+- $param->{'count'} = $in{'count'};
+- $nb_arc = $in{'count'};
+- } else {
+- $nb_arc = $NB_ARC_MAX;
+- }
+-
+- my $arc_path = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
+- unless (opendir ARC_DIR, $arc_path) {
+- &report::reject_report_web('user','empty_archives',{},$param->{'action'},$list);
+- &wwslog('err','do_latest_arc: no directory %s', $arc_path);
+- return undef;
+- }
+-
+- my @months;
+- my $latest;
+- foreach my $dir (sort grep(!/^\./,readdir ARC_DIR)) {
+- if ($dir =~ /^(\d{4})-(\d{2})$/) {
+- push @months, $dir;
+- $latest = $dir;
+- }
+- }
+- closedir ARC_DIR;
+-
+- @months = reverse @months;
+- my $stop_search;
+-
+- my @archives;
+-
+- ## year-month directory
+- foreach my $year_month (@months) {
+- if ($nb_arc <= 0) {
+- last;
+- }
+-
+- last if $stop_search;
+-
+- my $arc_month_path = $arc_path.'/'.$year_month.'/arctxt';
+- unless (opendir MONTH, $arc_month_path) {
+- &report::reject_report_web('intern','inaccessible_archive',{'path' => $arc_month_path,
+- 'listname' => $list->{'name'}},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_latest_arc: unable to open directory %s', $arc_month_path);
+- next;
+- }
+-
+- ## mails in the year-month directory
+- foreach my $arc (sort {$b <=> $a} grep(!/^\./,readdir MONTH)) {
+- last if ($nb_arc <= 0);
+-
+- if ($arc =~ /^(\d)+$/) {
+- my %msg_info;
+-
+- use MIME::Parser;
+- my $parser = new MIME::Parser;
+- $parser->output_to_core(1);
+-
+- my $arc_file = $arc_month_path.'/'.$arc;
+-
+- unless (open (FILE, $arc_file)) {
+- &wwslog('err', 'Unable to open file %s', $arc_file);
+- }
+-
+- my $message;
+- unless ($message = $parser->read(\*FILE)) {
+- &wwslog('err', 'Unable to parse message %s', $arc_file);
+- next;
+- }
+-
+- use Mail::Header;
+- my $hdr = $message->head;
+-
+- unless (defined $hdr) {
+- &wwslog('err', 'Unable to parse header of message %s', $arc_file);
+- next;
+- }
+-
+- foreach my $field ('message-id','subject','from') {
+-
+- my $var = $field; $var =~ s/-/_/g;
+-
+- $msg_info{$var} = $hdr->get($field);
+-
+- if (ref $msg_info{$var} eq 'ARRAY') {
+- $msg_info{$var} = $msg_info{$var}->[0];
+- }
+-
+- ## Hide full email address
+- if ($field eq 'from') {
+- if ($msg_info{$var} =~ /(.+)\<.+\>/) {
+- $msg_info{$var} = $1;
+- }else {
+- my @email = split /\@/, $msg_info{$var};
+- $msg_info{$var} = $email[0];
+- }
+- }
+-
+- if ($field eq 'message-id') {
+- $msg_info{$var} = &tools::clean_msg_id($msg_info{'message_id'});
+- $msg_info{$var} = &tools::escape_chars($msg_info{$var});
+-
+- $msg_info{'year_month'} = $year_month;
+- }else {
+- $msg_info{$var} = &MIME::EncWords::decode_mimewords($msg_info{$var}, Charset=>'utf8');
+- $msg_info{$var} = &tools::escape_html($msg_info{$var});
+- }
+- }
+-
+- my $date = $hdr->get('Date');
+-
+- unless (defined $date) {
+- &wwslog('err', 'No date found in message %s', $arc_file);
+- next;
+- }
+-
+- my @array_date = &time_utils::parse_date($date);
+-
+- $msg_info{'date_smtp'} = $date;
+- $msg_info{'date_epoch'} = &get_timelocal_from_date(@array_date[1..$#array_date]);
+-
+- $msg_info{'date'} = gettext_strftime "%d %b %Y", localtime($msg_info{'date_epoch'});
+- if ($msg_info{'date_epoch'} < $oldest_day) {
+- $stop_search = 1;
+- last;
+- }
+-
+- foreach my $key (keys %msg_info) {
+- chomp($msg_info{$key});
+- }
+-
+- push @archives,\%msg_info;
+- $nb_arc--;
+- }
+- }
+- closedir MONTH;
+-
+-
+- }
+-
+- @{$param->{'archives'}} = sort ({$b->{'date_epoch'} <=> $a->{'date_epoch'}} @archives);
+-
+- return 1;
+- }
+-
+-
+-sub get_timelocal_from_date {
+- my($mday, $mon, $yr, $hr, $min, $sec, $zone) = @_;
+- my($time) = 0;
+-
+- $yr -= 1900 if $yr >= 1900; # if given full 4 digit year
+- $yr += 100 if $yr <= 37; # in case of 2 digit years
+- if (($yr < 70) || ($yr > 137)) {
+- warn "Warning: Bad year (", $yr+1900, ") using current\n";
+- $yr = (localtime(time))[5];
+- }
+-
+- $time = &timelocal($sec,$min,$hr,$mday,$mon,$yr);
+- return $time
+-
+-}
+-
+-
+-
+-####################################################
+-# do_remove_arc
+-####################################################
+-#
+-# request by list owner or message sender to remove message from archive
+-# Create in the outgoing spool a file containing the message-id of mesage to be removed
+-#
+-# IN : list@host yyyy month and a tab of msgid
+-#
+-# OUT : 1 | undef
+-#
+-####################################################
+-
+-sub do_remove_arc {
+- &wwslog('info', 'do_remove_arc : list %s, yyyy %s, mm %s, #message %s', $in{'list'}, $in{'yyyy'}, $in{'month'});
+-
+- my $arcpath = $wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$in{'yyyy'}.'-'.$in{'month'};
+-
+- ## Access control
+-
+-# $in{'msgid'} = &tools::unescape_chars($in{'msgid'});
+- my @msgids = split /\0/, $in{'msgid'};
+-
+- if ($#msgids == -1) {
+- &report::reject_report_web('user','may_not_remove_arc',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','remove_arc: no message id found');
+- &web_db_log({'parameters' => $in{'msgid'},
+- 'msg_id' => $in{'msgid'},
+- 'status' => 'error',
+- 'error_type' => 'no_msgid'});
+- $param->{'status'} = 'no_msgid';
+- return undef;
+- }
+-
+- my $file = $Conf{'queueoutgoing'}.'/.remove.'.$list->get_list_id().'.'.$in{'yyyy'}.'-'.$in{'month'}.'.'.time;
+- unless (open REBUILD, ">$file") {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_remove: cannot create %s', $file);
+- &web_db_log({'parameters' => $in{'msgid'},
+- 'msg_id' => $in{'msgid'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- closedir ARC;
+- return undef;
+- }
+-
+- foreach my $msgid (@msgids) {
+- chomp $msgid ;
+- printf REBUILD ('%s||%s',$msgid,$param->{'user'}{'email'}) ; printf REBUILD "\n";
+- }
+- close REBUILD;
+- &wwslog('info', 'do_remove_arc %d messages marked to be removed by archived', $#msgids+1);
+- &web_db_log({'parameters' => $in{'msgid'},
+- 'msg_id' => $in{'msgid'},
+- 'status' => 'success'});
+- $param->{'status'} = 'done';
+-
+- return 1;
+-}
+-
+-
+-####################################################
+-# do_send_me
+-####################################################
+-# Sends a web archive message to a
+-# requesting user
+-# It uses mail::mail_forward() to do it.
+-#
+-# IN : -
+-#
+-# OUT : 'arc' | 1 | undef
+-#
+-####################################################
+- sub do_send_me {
+- &wwslog('info', 'do_send_me(%s, %s, %s, %s', $in{'list'}, $in{'yyyy'}, $in{'month'}, $in{'msgid'});
+-
+- if (! $in{'msgid'} ||
+- $in{'msgid'} =~ /NO-ID-FOUND\.mhonarc\.org/) {
+- &report::reject_report_web('intern','may_not_send_me',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','send_me: no message id found');
+- $param->{'status'} = 'no_msgid';
+- return undef;
+- }
+- ##
+- my $arcpath = $wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$in{'yyyy'}.'-'.$in{'month'};
+-
+- opendir ARC, "$arcpath/arctxt";
+- my $msgfile;
+- foreach my $file (grep (!/\./,readdir ARC)) {
+- &wwslog('debug','send_me: scanning %s', $file);
+- next unless (open MAIL,"$arcpath/arctxt/$file") ;
+- while (<MAIL>) {
+- last if /^$/ ;
+- if (/^Message-id:\s?<?([^>\s]+)>?\s?/i ) {
+- my $id = $1;
+- if ($id eq $in{'msgid'}) {
+- $msgfile = $file ;
+- }
+- last ;
+- }
+- }
+- close MAIL ;
+- }
+- if ($msgfile) {
+- unless (open MSG, "$arcpath/arctxt/$msgfile") {
+- $param->{'status'} = 'message_err';
+- &wwslog('info', 'do_send_me : could not read file %s',"$arcpath/arctxt/$msgfile");
+- }
+- my $msg_string;
+- while (<MSG>){
+- $msg_string .= $_ ;
+- }
+- close MSG;
+-
+- unless (&mail::mail_forward($msg_string,&Conf::get_robot_conf($robot, 'sympa'),\$param->{'user'}{'email'},$robot)) {
+- $param->{'status'} = 'message_err';
+- &wwslog('err',"do_send_me : impossible to send archive file to %s",$param->{'user'}{'email'});
+- return undef;
+- }
+- &wwslog('info', 'do_send_me message %s spooled for %s', "$arcpath/arctxt/$msgfile", $param->{'user'}{'email'} );
+- &report::notice_report_web('performed',{},$param->{'action'});
+- $in{'month'} = $in{'yyyy'}."-".$in{'month'};
+- return 'arc';
+-
+- }else{
+- &wwslog('info', 'do_send_me : no file match msgid');
+- $param->{'status'} = 'not_found';
+- return undef;
+- }
+-
+- return 1;
+- }
+-
+-####################################################
+-# do_view_source
+-####################################################
+-# Display message as text/plain in archives
+-#
+-# IN : -
+-#
+-# OUT : 'arc' | 1 | undef
+-#
+-####################################################
+- sub do_view_source {
+- &wwslog('info', 'do_view_source(%s, %s, %s, %s', $in{'list'}, $in{'yyyy'}, $in{'month'}, $in{'msgid'});
+-
+-
+- ## Access control
+- unless (defined &check_authz('do_arc', 'web_archive.access')) {
+- $param->{'previous_action'} = 'arc';
+- $param->{'previous_list'} = $list->{'name'};
+- return undef;
+- }
+-
+- if (! $in{'msgid'} ||
+- $in{'msgid'} =~ /NO-ID-FOUND\.mhonarc\.org/) {
+- &report::reject_report_web('intern','may_not_view_source',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','view_source: no message id found');
+- $param->{'status'} = 'no_msgid';
+- return undef;
+- }
+- ##
+- my $arcpath = $wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$in{'yyyy'}.'-'.$in{'month'};
+-
+- opendir ARC, "$arcpath/arctxt";
+- my $msgfile;
+- foreach my $file (grep (!/\./,readdir ARC)) {
+- &wwslog('debug','view_source: scanning %s', $file);
+- next unless (open MAIL,"$arcpath/arctxt/$file") ;
+- while (<MAIL>) {
+- last if /^$/ ;
+- if (/^Message-id:\s?<?([^>\s]+)>?\s?/i ) {
+- my $id = $1;
+- if ($id eq $in{'msgid'}) {
+- $msgfile = $file ;
+- }
+- last ;
+- }
+- }
+- close MAIL ;
+- }
+- if ($msgfile) {
+- unless (open MSG, "$arcpath/arctxt/$msgfile") {
+- $param->{'status'} = 'message_err';
+- &wwslog('info', 'do_view_source : could not read file %s',"$arcpath/arctxt/$msgfile");
+- }
+-
+- $param->{'bypass'} = 'extreme';
+- printf "Content-Type: text/plain\n\n";
+- while (<MSG>){
+- printf $_ ;
+- }
+- close MSG;
+-
+-
+- }else{
+- &wwslog('info', 'do_view_source : no file match msgid');
+- $param->{'status'} = 'not_found';
+- return undef;
+- }
+-
+- return 1;
+- }
+-
+- ## Output an initial form to search in web archives
+- sub do_arcsearch_form {
+- &wwslog('info', 'do_arcsearch_form(%s)', $param->{'list'});
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_arcsearch_form', 'web_archive.access'));
+-
+- my $search_base = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
+- opendir ARC, "$search_base";
+- foreach my $dir (sort {$b cmp $a} grep(!/^\./,readdir ARC)) {
+- if ($dir =~ /^(\d{4})-(\d{2})$/) {
+- push @{$param->{'yyyymm'}}, $dir;
+- }
+- }
+- closedir ARC;
+-
+- $param->{'key_word'} = $in{'key_word'};
+- $param->{'archive_name'} = $in{'archive_name'};
+-
+- return 1;
+- }
+-
+- ## Search in web archives
+- sub do_arcsearch {
+- &wwslog('info', 'do_arcsearch(%s)', $param->{'list'});
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_arcsearch', 'web_archive.access'));
+-
+- use Marc::Search;
+-
+- my $search = new Marc::Search;
+- $search->search_base ($wwsconf->{'arc_path'} . '/' . $list->get_list_id());
+- $search->base_href (&Conf::get_robot_conf($robot, 'wwsympa_url') . '/arc/' . $param->{'list'});
+- $search->archive_name ($in{'archive_name'});
+-
+- unless (defined($in{'directories'})) {
+- # by default search in current month and in the previous none empty one
+- my $search_base = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
+- opendir ARC, "$search_base";
+- foreach my $dir (sort {$b cmp $a} grep(!/^\./,readdir ARC)) {
+- if ($dir =~ /^(\d{4})-(\d{2})$/) {
+- push @{$param->{'yyyymm'}}, $dir;
+- }
+- }
+- closedir ARC;
+- $in{'directories'} = join "\0",@{$param->{'yyyymm'}} ;
+- }
+-
+- if (defined($in{'directories'})) {
+- $search->directories ($in{'directories'});
+- foreach my $dir (split/\0/, $in{'directories'}) {
+- push @{$param->{'directories'}}, $dir;
+- }
+- }
+-
+- if (defined $in{'previous'}) {
+- $search->body_count ($in{'body_count'});
+- $search->date_count ($in{'date_count'});
+- $search->from_count ($in{'from_count'});
+- $search->subj_count ($in{'subj_count'});
+- $search->previous ($in{'previous'});
+- }
+-
+- ## User didn't enter any search terms
+- if ($in{'key_word'} =~ /^\s*$/) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'key_word'},$param->{'action'});
+- &wwslog('info','do_arcsearch: no search term');
+- return undef;
+- }elsif ($in{'key_word'} =~ /[<>\\\*\$]/) {
+- &report::reject_report_web('user','syntax_errors',{'params' => 'key_word'},$param->{'action'});
+- &wwslog('info','do_arcsearch: syntax error');
+- return undef;
+- }
+-
+- $param->{'key_word'} = &tools::escape_regexp($in{'key_word'});
+-
+- $search->limit ($in{'limit'});
+-
+- $search->age (1)
+- if ($in{'age'} eq 'new');
+-
+- $search->match (1)
+- if (($in{'match'} eq 'partial') or ($in{'match'} eq '1'));
+-
+- my @words = split(/\s+/,&tools::escape_regexp($in{'key_word'}));
+- $search->words (\@words);
+- $search->clean_words ($in{'key_word'});
+- my @clean_words = @words;
+-
+- for my $i (0 .. $#words) {
+- $words[$i] =~ s,/,\\/,g;
+- $words[$i] = '\b' . $words[$i] . '\b' if ($in{'match'} eq 'exact');
+- }
+- $search->key_word (join('|',@words));
+-
+- if ($in{'case'} eq 'off') {
+- $search->case(1);
+- $search->key_word ('(?i)' . $search->key_word);
+- }
+- if ($in{'how'} eq 'any') {
+- $search->function2 ($search->match_any(@words));
+- $search->how ('any');
+- }elsif ($in{'how'} eq 'all') {
+- $search->function1 ($search->body_match_all(@clean_words,@words));
+- $search->function2 ($search->match_all(@words));
+- $search->how ('all');
+- }else {
+- $search->function2 ($search->match_this(@words));
+- $search->how ('phrase');
+- }
+-
+- $search->subj (defined($in{'subj'}));
+- $search->from (defined($in{'from'}));
+- $search->date (defined($in{'date'}));
+- $search->body (defined($in{'body'}));
+-
+- $search->body (1)
+- if ( not ($search->subj)
+- and not ($search->from)
+- and not ($search->body)
+- and not ($search->date));
+-
+- my $searched = $search->search;
+-
+- if (defined($search->error)) {
+- &wwslog('info','do_arcsearch_search_error : %s', $search->error);
+- }
+-
+- $search->searched($searched);
+-
+- if ($searched < $search->file_count) {
+- $param->{'continue'} = 1;
+- }
+-
+- foreach my $field ('list','archive_name','age','body','case','date','from','how','limit','match','subj') {
+- $param->{$field} = $in{$field};
+- }
+-
+- $param->{'body_count'} = $search->body_count;
+- $param->{'clean_words'} = $search->clean_words;
+- $param->{'date_count'} = $search->date_count;
+- $param->{'from_count'} = $search->from_count;
+- $param->{'subj_count'} = $search->subj_count;
+-
+- $param->{'num'} = $search->file_count + 1;
+- $param->{'searched'} = $search->searched;
+-
+- $param->{'res'} = $search->res;
+-
+- ## Decode subject header fields
+- foreach my $m (@{$param->{'res'}}) {
+- $m->{'subj'} = &MIME::EncWords::decode_mimewords($m->{'subj'}, Charset=>'utf8');
+- }
+-
+- return 1;
+- }
+-
+- ## Search message-id in web archives
+- sub do_arcsearch_id {
+- &wwslog('info', 'do_arcsearch_id(%s,%s,%s)', $param->{'list'},$in{'archive_name'},$in{'msgid'});
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_arcsearch_id', 'web_archive.access'));
+-
+- use Marc::Search;
+-
+- my $search = new Marc::Search;
+- $search->search_base ($wwsconf->{'arc_path'} . '/' . $list->get_list_id());
+- $search->base_href (&Conf::get_robot_conf($robot, 'wwsympa_url') . '/arc/' . $param->{'list'});
+-
+- $search->archive_name ($in{'archive_name'});
+-
+- # search in current month and in the previous none empty one
+- my $search_base = $search->search_base;
+- my $previous_active_dir ;
+- opendir ARC, "$search_base";
+- foreach my $dir (sort {$b cmp $a} grep(!/^\./,readdir ARC)) {
+- if (($dir =~ /^(\d{4})-(\d{2})$/) && ($dir lt $search->archive_name)) {
+- $previous_active_dir = $dir;
+- last;
+- }
+- }
+- closedir ARC;
+- $in{'archive_name'} = $search->archive_name."\0".$previous_active_dir ;
+-
+- $search->directories ($in{'archive_name'});
+- # $search->directories ($search->archive_name);
+-
+- ## User didn't enter any search terms
+- if ($in{'msgid'} =~ /^\s*$/) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'msgid'},$param->{'action'});
+- &wwslog('info','do_arcsearch_id: no search term');
+- return undef;
+- }
+-
+- $param->{'msgid'} = &tools::unescape_chars($in{'msgid'});
+- $in{'msgid'} = &tools::escape_regexp($in{'msgid'});
+-
+- ## Mhonarc escapes some characters : '-' (-) and '&' (&)
+- $in{'msgid'} =~ s/\&/\&\#38\;/g;
+- $in{'msgid'} =~ s/\-/\&\#45\;/g;
+-
+- $search->limit (1);
+-
+- my @words = split(/\s+/,$in{'msgid'});
+- $search->words (\@words);
+- $search->clean_words ($in{'msgid'});
+- my @clean_words = @words;
+-
+- $search->key_word (join('|',@words));
+-
+- $search->function2 ($search->match_this(@words));
+-
+- $search->id (1);
+-
+- my $searched = $search->search;
+-
+- if (defined($search->error)) {
+- &wwslog('info','do_arcsearch_id_search_error : %s', $search->error);
+- }
+-
+- $search->searched($searched);
+-
+- $param->{'res'} = $search->res;
+-
+- unless ($#{$param->{'res'}} >= 0) {
+- &report::reject_report_web('intern_quiet','archive_not_found',{'msgid'=> $in{'msgid'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','No message found in archives matching Message-ID %s', $in{'msgid'});
+- return 'arc';
+- }
+-
+- $param->{'redirect_to'} = $param->{'res'}[0]{'file'};
+-
+- return 1;
+- }
+-
+- # get pendings lists
+- sub do_get_pending_lists {
+-
+- &wwslog('info', 'get_pending_lists');
+-
+- ## Checking families and other virtual hosts.
+- &get_server_details();
+-
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+- if ($list->{'admin'}{'status'} eq 'pending') {
+- $param->{'pending'}{$list->{'name'}}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'pending'}{$list->{'name'}}{'by'} = $list->{'admin'}{'creation'}{'email'};
+- $param->{'pending'}{$list->{'name'}}{'date'} = gettext_strftime "%d %b %y %H:%M", localtime($list->{'admin'}{'creation'}{'date_epoch'});
+- }
+- }
+-
+- return 1;
+- }
+-
+- # get closed lists
+- sub do_get_closed_lists {
+-
+- &wwslog('info', 'get_closed_lists');
+-
+- ## Checking families and other virtual hosts.
+- &get_server_details();
+-
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+- if ($list->{'admin'}{'status'} eq 'closed' ||
+- $list->{'admin'}{'status'} eq 'family_closed') {
+- $param->{'closed'}{$list->{'name'}}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'closed'}{$list->{'name'}}{'by'} = $list->{'admin'}{'creation'}{'email'};
+- }
+- }
+-
+- return 1;
+- }
+-
+- # get ordered latest lists
+- sub do_get_latest_lists {
+-
+- &wwslog('info', 'get_latest_lists');
+-
+- ## Checking families and other virtual hosts.
+- &get_server_details();
+-
+- my @unordered_lists;
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+-
+- push @unordered_lists, {'name' => $list->{'name'},
+- 'subject' => $list->{'admin'}{'subject'},
+- 'creation_date' => $list->{'admin'}{'creation'}{'date_epoch'}};
+- }
+-
+- foreach my $l (sort {$b->{'creation_date'} <=> $a->{'creation_date'}} @unordered_lists) {
+- push @{$param->{'latest_lists'}}, $l;
+- $l->{'creation_date'} = gettext_strftime "%d %b %Y", localtime($l->{'creation_date'});
+- }
+-
+- return 1;
+- }
+-
+-
+-# get inactive lists
+-sub do_get_inactive_lists {
+-
+- &wwslog('info', 'get_inactive_lists');
+-
+- ## Checking families and other virtual hosts.
+- &get_server_details();
+-
+- my @unordered_lists;
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+-
+- ## skip closed lists
+- if ($list->{'admin'}{'status'} eq 'closed') {
+- next;
+- }
+-
+- my $last_message;
+-
+- if (open COUNT, $list->{'dir'}.'/msg_count') {
+- while (<COUNT>) {
+- $last_message = $1 if (/^(\d+)\s/ && ($1 > $last_message));
+- }
+- close COUNT;
+-
+- }else {
+- &wwslog('info', 'Could not open file %s', $list->{'dir'}.'/msg_count');
+- }
+-
+-
+- push @unordered_lists, {
+- 'name' => $list->{'name'},
+- 'creator' =>$list->{'admin'}{'creation'}{'email'},
+- 'send_scenario' =>$list->{'admin'}{'send'}{'name'},
+- 'owners' => join(", ", map {$_->{'email'}} @{$list->{'admin'}{'owner'}}),
+- 'editors' => join(", ", map {$_->{'email'}} @{$list->{'admin'}{'editor'}}),
+- 'subscribers_count' => $list->get_total('nocache'),
+- 'subject' => $list->{'admin'}{'subject'},
+- 'msg_count' => $list->get_msg_count(),
+- 'last_message_epoch' => $last_message,
+- 'last_message_date' => (gettext_strftime "%d %b %Y", localtime($last_message*86400)),
+- 'creation_date_epoch' => $list->{'admin'}{'creation'}{'date_epoch'},
+- 'creation_date' => (gettext_strftime "%d %b %Y", localtime($list->{'admin'}{'creation'}{'date_epoch'})),
+- };
+- }
+-
+- foreach my $l (sort {$a->{'last_message_epoch'} <=> $b->{'last_message_epoch'}} @unordered_lists) {
+- push @{$param->{'inactive_lists'}}, $l;
+- }
+-
+- return 1;
+- }
+-
+-## show a list parameters
+-sub do_set_pending_list_request {
+- &wwslog('info', 'set_pending_list(%s)',$in{'list'});
+-
+- my $list_dir = $list->{'dir'};
+-
+- $param->{'list_config'} = $list_dir.'/config';
+- if (-f $list_dir.'/info'){
+- $param->{'list_info_file_exists'} = 1;
+- }
+- $param->{'list_info'} = $list_dir.'/info';
+- $param->{'list_subject'} = $list->{'admin'}{'subject'};
+- $param->{'list_request_by'} = $list->{'admin'}{'creation'}{'email'};
+- $param->{'list_request_date'} = $list->{'admin'}{'creation'}{'date'};
+- $param->{'list_serial'} = $list->{'admin'}{'serial'};
+- $param->{'list_status'} = $list->{'admin'}{'status'};
+-
+- &tt2::add_include_path($list->{'dir'});
+-
+- return 1;
+- }
+-
+- ## show a list parameters
+- sub do_install_pending_list {
+- &wwslog('info', 'do_install_pending_list(%s,%s,%s)',$in{'list'},$in{'status'},$in{'notify'});
+-
+- unless ($in{'status'} && (($in{'status'} eq 'open') || ($in{'status'} eq 'closed'))) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'status'},$param->{'action'});
+- &wwslog('info', 'Missing status parameter',);
+- &web_db_log({'parameters' => "$in{'status'},$in{'notify'}",
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return undef;
+- }
+-
+- if ($list->{'admin'}{'status'} eq $in{'status'}) {
+- &report::reject_report_web('user','didnt_change_anything',{},$param->{'action'});
+- &wwslog('info','view_pending_list: didn t change really the status, nothing to do');
+- &web_db_log({'parameters' => "$in{'status'},$in{'notify'}",
+- 'status' => 'error',
+- 'error_type' => 'didnt_change_anything'});
+- return undef ;
+- }
+-
+- $list->{'admin'}{'status'} = $in{'status'};
+-
+- # open TMP, ">/tmp/dump1";
+- # &tools::dump_var ($list->{'admin'}, 0, \*TMP);
+- # close TMP;
+-
+- unless ($list->save_config($param->{'user'}{'email'})) {
+- &report::reject_report_web('intern','cannot_save_config',{'listname'=> $list->{'name'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','_create_list: Cannot save config file');
+- &web_db_log({'parameters' => "$in{'status'},$in{'notify'}",
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # open TMP, ">/tmp/dump2";
+- # &tools::dump_var ($list->{'admin'}, 0, \*TMP);
+- # close TMP;
+-
+- ## create the aliases
+- if ($in{'status'} eq 'open') {
+- my $aliases = &admin::install_aliases($list,$robot);
+- if ($aliases == 1) {
+- $param->{'auto_aliases'} = 1;
+- }else {
+- &report::reject_report_web('intern','failed_to_install_aliases',{'listname'=> $list->{'name'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','Failed to install list aliases');
+- }
+-
+- }
+-
+- ## Notify listmasters
+- if ($in{'status'} eq 'open') {
+- unless ($list->send_file('list_created', &Conf::get_robot_conf($robot, 'listmaster'), $robot,{})) {
+- &wwslog('notice',"Unable to send template 'list_created' to listmaster");
+- }
+- }elsif ($in{'status'} eq 'closed') {
+- unless ($list->send_file('list_rejected', &Conf::get_robot_conf($robot, 'listmaster'), $robot,{})) {
+- &wwslog('notice',"Unable to send template 'list_rejected' to listmaster");
+- }
+- }
+-
+- if ($in{'notify'}) {
+- my $owners = $list->get_owners();
+- foreach my $i (@{$owners}) {
+- ## Notify all listowners, even if reception is nomail
+- next unless ($i->{'email'});
+- if ($in{'status'} eq 'open') {
+- unless ($list->send_file('list_created', $i->{'email'}, $robot,{})) {
+- &wwslog('notice',"Unable to send template 'list_created' to $i->{'email'}");
+- }
+- }elsif ($in{'status'} eq 'closed') {
+- unless ($list->send_file('list_rejected', $i->{'email'}, $robot,{})) {
+- &wwslog('notice',"Unable to send template 'list_rejected' to $i->{'email'}");
+- }
+- }
+- }
+- }
+-
+- $param->{'status'} = $in{'status'};
+-
+- $list = $param->{'list'} = $in{'list'} = undef;
+- return 'get_pending_lists';
+- &web_db_log({'parameters' => "$in{'status'},$in{'notify'}",
+- 'status' => 'success'});
+- return 1;
+- }
+-
+- ## check if the requested list exists already using smtp 'rcpt to'
+- sub list_check_smtp {
+- my $list = shift;
+- my $conf = '';
+- my $smtp;
+- my (@suf, @addresses);
+-
+- my $smtp_relay = $Conf{'robots'}{$robot}{'list_check_smtp'} || $Conf{'list_check_smtp'};
+- my $suffixes = $Conf{'robots'}{$robot}{'list_check_suffixes'} || $Conf{'list_check_suffixes'};
+- return 0
+- unless ($smtp_relay && $suffixes);
+- my $domain = &Conf::get_robot_conf($robot, 'host');
+- &wwslog('debug2', 'list_check_smtp(%s)',$in{'listname'});
+- @suf = split(/,/,$suffixes);
+- return 0 if ! @suf;
+- for(@suf) {
+- push @addresses, $list."-$_\@".$domain;
+- }
+- push @addresses,"$list\@" . $domain;
+-
+- unless (eval "require Net::SMTP") {
+- wwslog ('err',"Unable to use Net library, Net::SMTP required, install it (CPAN) first");
+- return undef;
+- }
+- require Net::SMTP;
+-
+- if( $smtp = Net::SMTP->new($smtp_relay,
+- Hello => $smtp_relay,
+- Timeout => 30) ) {
+- $smtp->mail('');
+- for(@addresses) {
+- $conf = $smtp->to($_);
+- last if $conf;
+- }
+- $smtp->quit();
+- return $conf;
+- }
+- return undef;
+- }
+-
+-=pod
+-
+-=head2 sub do_create_list
+-
+-Creates a list using a list template
+-
+-=head3 Arguments
+-
+-=over
+-
+-=item * I<None>
+-
+-=back
+-
+-=head3 Return
+-
+-=over
+-
+-=item * I<1>, if no problem is encountered
+-
+-=item * I<undef>, if anything goes wrong
+-
+-=item * I<'loginrequest'> if no user is logged in at the time the function is called.
+-
+-=back
+-
+-=head3 Calls
+-
+-=over
+-
+-=item * web_db_log
+-
+-=item * wwslog
+-
+-=item * admin::create_list_old
+-
+-=item * check_param_in
+-
+-=item * List::send_notify_to_listmaster
+-
+-=item * report::reject_report_web
+-
+-=back
+-
+-=cut
+-
+-## create a liste using a list template.
+- sub do_create_list {
+-
+- &wwslog('info', 'do_create_list(%s,%s,%s)',$in{'listname'},$in{'subject'},$in{'template'});
+-
+- ## Check that all the needed arguments are present.
+- ## This is checked here because it requires to return the incomplete form to the user
+- foreach my $arg ('listname','subject','template','info','topics') {
+- unless ($in{$arg}) {
+- &report::reject_report_web('user','missing_arg',{'argument' => $arg},$param->{'action'});
+- &wwslog('info','do_create_list: missing param %s', $arg);
+- &web_db_log({'parameters' => $in{'listname'},
+- 'list' => $in{'listname'},
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return 'create_list_request';
+- }
+- }
+-
+- ## Lowercase listname if required
+- if ($in{'listname'} =~ /[A-Z]/) {
+- $in{'listname'} = lc($in{'listname'});
+- &report::notice_report_web('listname_lowercased',{},$param->{'action'});
+- }
+-
+- $param->{'create_action'} = $param->{'create_list'};
+-
+- &wwslog('info',"do_create_list, get action : $param->{'create_action'} ");
+-
+- ## If the action is forbidden, stop here.
+- if ($param->{'create_action'} =~ /reject/) {
+- &report::reject_report_web('auth',$param->{'reason'},{},$param->{'action'},$list);
+- &wwslog('info','do_create_list: not allowed');
+- &web_db_log({'parameters' => $in{'listname'},
+- 'list' => $in{'listname'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+-
+- ## If the action is reserved to listmaster, note that it will have to be moderated
+- }elsif ($param->{'create_action'} =~ /listmaster/i) {
+- $param->{'status'} = 'pending' ;
+-
+- ## If the action is plainly authorized, note that it will be executed.
+- }elsif ($param->{'create_action'} =~ /do_it/i) {
+- $param->{'status'} = 'open' ;
+-
+- ## If the action hasn't an authorization status, stop here.
+- }else{
+- &report::reject_report_web('intern','internal_scenario_error_create_list',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_create_list: internal error in scenario create_list');
+- &web_db_log({'parameters' => $in{'listname'},
+- 'list' => $in{'listname'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## 'other' topic means no topic
+- $in{'topics'} = undef if ($in{'topics'} eq 'other');
+-
+- ## Store creation parameters.
+- my %owner;
+- $owner{'email'} = $param->{'user'}{'email'};
+- $owner{'gecos'} = $param->{'user'}{'gecos'};
+-
+- my $parameters;
+- push @{$parameters->{'owner'}},\%owner;
+- $parameters->{'listname'} = $in{'listname'};
+- $parameters->{'subject'} = $in{'subject'};
+- $parameters->{'creation_email'} = $param->{'user'}{'email'};
+- $parameters->{'lang'} = $param->{'lang'};
+- $parameters->{'status'} = $param->{'status'};
+- $parameters->{'topics'} = $in{'topics'};
+- $parameters->{'description'} = $in{'info'};
+- $parameters->{'custom_input'} = $in{'custom_input'};
+-
+- ## create liste
+- if (my $testlist = new List($in{'listname'},$robot)){
+- &report::reject_report_web('user','list_already_exists',{'new_listname'=> $in{'listname'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_create_list: requested list %s already exist (from %s)',$in{'listname'},$param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'listname'},
+- 'list' => $in{'listname'},
+- 'status' => 'error',
+- 'error_type' => 'user'});
+- return undef
+- }
+- my $resul = &admin::create_list_old($parameters,$in{'template'},$robot,"web");
+- unless(defined $resul) {
+- &report::reject_report_web('intern','create_list',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_create_list: unable to create list %s for %s',$in{'listname'},$param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'listname'},
+- 'list' => $in{'listname'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef
+- }
+-
+- ## Create list object
+- $in{'list'} = $in{'listname'};
+- &check_param_in();
+-
+- if ($param->{'create_action'} =~ /do_it/i) {
+- if ($resul->{'aliases'} == 1) {
+- $param->{'auto_aliases'} = 1;
+- }else {
+- &report::reject_report_web('intern','failed_to_install_aliases',{'listname'=> $in{'listname'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','Failed to install list aliases');
+- }
+- }
+-
+- ## notify listmaster
+- my $list = new List $in{'listname'};
+- unless (defined $list) {
+- &wwslog('info',"failed to create list object for list '%s'",$in{'listname'});
+- &report::reject_report_web('intern','create_list',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- return undef;
+- }
+-
+- if ($param->{'create_action'} =~ /notify/) {
+- &wwslog('info','notify listmaster');
+-
+- unless (&List::send_notify_to_listmaster('request_list_creation',$robot,
+- {'list' => $list,
+- 'email' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'request_list_creation' to listmaster");
+- }
+- }
+-
+- &web_db_log({'parameters' => $in{'listname'},
+- 'list' => $in{'listname'},
+- 'status' => 'success'});
+-
+- $in{'list'} = $resul->{'list'}{'name'};
+- &check_param_in();
+-
+- $param->{'listname'} = $resul->{'list'}{'name'};
+- return 1;
+- }
+-
+-=pod
+-
+-=head2 sub do_create_list_request
+-
+-Sends back the list creation edition form.
+-
+-=head3 Arguments
+-
+-=over
+-
+-=item * I<None>
+-
+-=back
+-
+-=head3 Return
+-
+-=over
+-
+-=item * I<1>, if no problem is encountered
+-
+-=item * I<undef>, if anything goes wrong
+-
+-=item * I<'loginrequest'> if no user is logged in at the time the function is called.
+-
+-=back
+-
+-=head3 Calls
+-
+-=over
+-
+-=item * wwslog
+-
+-=item * _prepare_edit_form
+-
+-=item * List::request_action
+-
+-=item * List::load_topics
+-
+-=item * tools::get_list_list_tpl
+-
+-=item * tt2::allow_absolute_path
+-
+-=item * report::reject_report_web
+-
+-=back
+-
+-=cut
+-
+- ## Return the creation form
+- sub do_create_list_request {
+- &wwslog('info', 'do_create_list_request()');
+-
+- my $result = &Scenario::request_action('create_list',$param->{'auth_method'},$robot,
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+-
+- my $r_action;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- $param->{'create_action'} = $r_action;
+- ## Initialize the form
+- ## When returning to the form
+- foreach my $p ('listname','template','subject','topics','info') {
+- $param->{'saved'}{$p} = $in{$p};
+- }
+-
+- if ($param->{'create_action'} =~ /reject/) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- &wwslog('info','do_create_list: not allowed');
+- return undef;
+- }
+-
+- my %topics;
+- unless (%topics = &List::load_topics($robot)) {
+- &report::reject_report_web('intern','unable_to_load_list_of_topics',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- }
+- $param->{'list_of_topics'} = \%topics;
+-
+- $param->{'list_of_topics'}{$in{'topics'}}{'selected'} = 1
+- if ($in{'topics'});
+-
+- unless ($param->{'list_list_tpl'} = &tools::get_list_list_tpl($robot)) {
+- &report::reject_report_web('intern','unable_to_load_create_list_templates',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- }
+-
+- &tt2::allow_absolute_path();
+-
+- foreach my $template (keys %{$param->{'list_list_tpl'}}){
+- $param->{'tpl_count'} ++ ;
+- }
+-
+- $param->{'list_list_tpl'}{$in{'template'}}{'selected'} = 1
+- if ($in{'template'});
+-
+-
+- return 1 ;
+-
+- }
+-
+-## WWSympa Home-Page
+- sub do_home {
+- &wwslog('info', 'do_home');
+-
+- return 1;
+- }
+-
+- sub do_editsubscriber {
+- &wwslog('info', 'do_editsubscriber(%s)', $in{'email'});
+-
+- my $subscriber;
+-
+- $in{'email'} = &tools::unescape_chars($in{'email'});
+-
+- unless($subscriber = $list->get_subscriber($in{'email'})) {
+- &report::reject_report_web('intern','subscriber_not_found',{'email' => $in{'email'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_editsubscriber: subscriber %s not found', $in{'email'});
+- return undef;
+- }
+-
+- $param->{'current_subscriber'} = $subscriber;
+- $param->{'current_subscriber'}{'escaped_email'} = &tools::escape_html($param->{'current_subscriber'}{'email'});
+- $param->{'current_subscriber'}{'escaped_bounce_address'} = &tools::escape_html($param->{'current_subscriber'}{'bounce_address'});
+- $param->{'current_subscriber'}{'date'} = gettext_strftime "%d %b %Y", localtime($subscriber->{'date'});
+- $param->{'current_subscriber'}{'update_date'} = gettext_strftime "%d %b %Y", localtime($subscriber->{'update_date'});
+- $param->{'current_subscriber'}{'pictures_url'} = &tools::make_pictures_url('email' => $subscriber->{'email'}, 'list' => $list);
+-
+- ## Prefs
+- $param->{'current_subscriber'}{'reception'} ||= 'mail';
+- $param->{'current_subscriber'}{'visibility'} ||= 'noconceal';
+-
+- ## Get language from user_table
+- my $user = &List::get_user_db($in{'email'});
+- $param->{'current_subscriber'}{'lang'} = &Language::GetLangName($user->{'lang'});
+-
+- foreach my $m (keys %wwslib::reception_mode) {
+- if ($list->is_available_reception_mode($m)) {
+- $param->{'reception'}{$m}{'description'} = sprintf(gettext($wwslib::reception_mode{$m}->{'gettext_id'}));
+- if ($param->{'current_subscriber'}{'reception'} eq $m) {
+- $param->{'reception'}{$m}{'selected'} = 'selected="selected"';
+- }else {
+- $param->{'reception'}{$m}{'selected'} = '';
+- }
+- }
+- }
+-
+- foreach my $m (keys %wwslib::visibility_mode) {
+- $param->{'visibility'}{$m}{'description'} = sprintf(gettext($wwslib::visibility_mode{$m}->{'gettext_id'}));
+- if ($param->{'current_subscriber'}{'visibility'} eq $m) {
+- $param->{'visibility'}{$m}{'selected'} = 'selected="selected"';
+- }else {
+- $param->{'visibility'}{$m}{'selected'} = '';
+- }
+- }
+-
+- ## Bounces
+- if ($subscriber->{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/) {
+- my @bounce = ($1, $2, $3, $5);
+- $param->{'current_subscriber'}{'first_bounce'} = gettext_strftime "%d %b %Y", localtime($bounce[0]);
+- $param->{'current_subscriber'}{'last_bounce'} = gettext_strftime "%d %b %Y", localtime($bounce[1]);
+- $param->{'current_subscriber'}{'bounce_count'} = $bounce[2];
+- if ($bounce[3] =~ /^(\d+\.(\d+\.\d+))$/) {
+- $subscriber->{'bounce_code'} = $1;
+- $subscriber->{'bounce_status'} = $wwslib::bounce_status{$2};
+- }
+-
+- $param->{'previous_action'} = $in{'previous_action'};
+- }
+-
+- ## Additional DB fields
+- if ($Conf{'db_additional_subscriber_fields'}) {
+- my @additional_fields = split ',', $Conf{'db_additional_subscriber_fields'};
+-
+- my %data;
+-
+- foreach my $field (@additional_fields) {
+-
+- ## Is the Database defined
+- unless ($Conf{'db_name'}) {
+- &wwslog('info', 'No db_name defined in configuration file');
+- return undef;
+- }
+-
+- ## Check field type (enum or not) with MySQL
+- $data{$field}{'type'} = &List::get_db_field_type('subscriber_table', $field);
+- if ($data{$field}{'type'} =~ /^enum\((\S+)\)$/) {
+- my @enum = split /,/,$1;
+- foreach my $e (@enum) {
+- $e =~ s/^\'([^\']+)\'$/$1/;
+- $data{$field}{'enum'}{$e} = '';
+- }
+- $data{$field}{'type'} = 'enum';
+-
+- $data{$field}{'enum'}{$subscriber->{$field}} = 'selected="selected"'
+- if (defined $subscriber->{$field});
+- }else {
+- $data{$field}{'type'} = 'string';
+- $data{$field}{'value'} = $subscriber->{$field};
+- }
+- }
+- $param->{'additional_fields'} = \%data;
+- }
+-
+- $param->{'previous_action'} = $in{'previous_action'};
+-
+- return 1;
+- }
+-
+- sub do_viewbounce {
+- &wwslog('info', 'do_viewbounce(%s)', $in{'email'});
+-
+- my $escaped_email = &tools::escape_chars($in{'email'});
+-
+- $param->{'lastbounce_path'} = $list->get_bounce_dir().'/'.$escaped_email;
+-
+- unless (-r $param->{'lastbounce_path'}) {
+- &report::reject_report_web('user','no_bounce_user',{'email'=>$in{'email'}},$param->{'action'},$list);
+- &wwslog('info','do_viewbounce: no bounce %s', $param->{'lastbounce_path'});
+- return undef;
+- }
+-
+- &tt2::allow_absolute_path();
+-
+- return 1;
+- }
+-
+- ## some help for listmaster and developpers
+- sub do_scenario_test {
+- &wwslog('info', 'do_scenario_test');
+-
+- ## List available scenarii
+- unless (opendir SCENARI, Sympa::Constants::DEFAULTDIR.'/scenari/'){
+- &report::reject_report_web('intern','cannot_open_dir',{'dir' => Sympa::Constants::DEFAULTDIR.'/scenari/'},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"do_scenario_test : unable to open %s/scenari", Sympa::Constants::DEFAULTDIR);
+- return undef;
+- }
+-
+- foreach my $scfile (readdir SCENARI) {
+- if ($scfile =~ /^(\w+)\.(\w+)/ ) {
+- $param->{'scenario'}{$1}{'defined'}=1 ;
+- }
+- }
+- closedir SCENARI;
+- my $all_lists = &List::get_lists('*');
+- foreach my $list ( @$all_lists ) {
+- $param->{'listname'}{$list->{'name'}}{'defined'}=1 ;
+- }
+- foreach my $a ('smtp','md5','smime') {
+- #$param->{'auth_method'}{$a}{'define'}=1 ;
+- $param->{'authmethod'}{$a}{'defined'}=1 ;
+- }
+-
+- $param->{'scenario'}{$in{'scenario'}}{'selected'} = 'selected="selected"' if $in{'scenario'};
+-
+- $param->{'listname'}{$in{'listname'}}{'selected'} = 'selected="selected"' if $in{'listname'};
+-
+- $param->{'authmethod'}{$in{'auth_method'}}{'selected'} = 'selected="selected"' if $in{'auth_method'};
+-
+- $param->{'email'} = $in{'email'};
+-
+- if ($in{'scenario'}) {
+- my $operation = $in{'scenario'};
+- &wwslog('debug3', 'do_scenario_test: perform scenario_test');
+-
+- my $result = &Scenario::request_action ($operation,$in{'auth_method'},$robot,
+- {'listname' => $in{'listname'},
+- 'sender' => $in{'sender'},
+- 'email' => $in{'email'},
+- 'remote_host' => $in{'remote_host'},
+- 'remote_addr' => $in{'remote_addr'}},'debug');
+- if (ref($result) eq 'HASH'){
+- $param->{'scenario_action'} = $result->{'action'};
+- $param->{'scenario_condition'} = $result->{'condition'};
+- $param->{'scenario_auth_method'} = $result->{'auth_method'};
+- $param->{'scenario_reason'} = $result->{'reason'};
+- }
+- }
+- return 1;
+- }
+-
+- ## Bouncing addresses review
+- sub do_reviewbouncing {
+- &wwslog('info', 'do_reviewbouncing(%d)', $in{'page'});
+- my $size = $in{'size'} || $wwsconf->{'review_page_size'};
+-
+- ## Owner
+- $param->{'page'} = $in{'page'} || 1;
+- if ($size eq 'all') {
+- $param->{'total_page'} = $param->{'bounce_total'};
+- }else {
+- $param->{'total_page'} = int ( $param->{'bounce_total'} / $size);
+- $param->{'total_page'} ++
+- if ($param->{'bounce_total'} % $size);
+- }
+-
+- if ($param->{'total_page'} > 0 and ($param->{'page'} > $param->{'total_page'})) {
+- &report::reject_report_web('user','no_page',{'page' => $param->{'page'}},$param->{'action'});
+- &wwslog('info','do_reviewbouncing: no page %d', $param->{'page'});
+- return 'admin';
+- }
+-
+- my @users;
+- ## Members list
+- for (my $i = $list->get_first_bouncing_user(); $i; $i = $list->get_next_bouncing_user()) {
+- $i->{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/;
+- $i->{'first_bounce'} = $1;
+- $i->{'last_bounce'} = $2;
+- $i->{'bounce_count'} = $3;
+- if ($5 =~ /^(\d+)\.\d+\.\d+$/) {
+- $i->{'bounce_class'} = $1;
+- }
+-
+- ## Define color in function of bounce_score
+- if ($i->{'bounce_score'} <= $list->{'admin'}{'bouncers_level1'}{'rate'}) {
+- $i->{'bounce_level'} = 0;
+- }elsif ($i->{'bounce_score'} <= $list->{'admin'}{'bouncers_level2'}{'rate'}){
+- $i->{'bounce_level'} = 1;
+- }else{
+- $i->{'bounce_level'} = 2;
+- }
+- push @users, $i;
+- }
+-
+- my $record;
+- foreach my $i (sort
+- {($b->{'bounce_score'} <=> $a->{'bounce_score'}) ||
+- ($b->{'last_bounce'} <=> $a->{'last_bounce'}) ||
+- ($b->{'bounce_class'} <=> $a->{'bounce_class'}) }
+- @users) {
+- $record++;
+-
+- if (($size ne 'all') && ($record > ( $size * ($param->{'page'} ) ) ) ) {
+- $param->{'next_page'} = $param->{'page'} + 1;
+- last;
+- }
+-
+- next if (($size ne 'all') && ($record <= ( ($param->{'page'} - 1) * $size)));
+-
+- $i->{'first_bounce'} = gettext_strftime "%d %b %Y", localtime($i->{'first_bounce'});
+- $i->{'last_bounce'} = gettext_strftime "%d %b %Y", localtime($i->{'last_bounce'});
+-
+- ## Escape some weird chars
+- $i->{'escaped_email'} = &tools::escape_chars($i->{'email'});
+-
+- push @{$param->{'members'}}, $i;
+- }
+-
+- if ($param->{'page'} > 1) {
+- $param->{'prev_page'} = $param->{'page'} - 1;
+- }
+-
+- $param->{'size'} = $size;
+-
+- return 1;
+- }
+-
+- sub do_resetbounce {
+- &wwslog('info', 'do_resetbounce()');
+-
+- $in{'email'} = &tools::unescape_chars($in{'email'});
+-
+- my @emails = split /\0/, $in{'email'};
+-
+- foreach my $email (@emails) {
+-
+- my $escaped_email = &tools::escape_chars($email);
+-
+- unless ( $list->is_user($email) ) {
+- &report::reject_report_web('user','not_subscriber',{'email'=> $email},$param->{'action'},$list);
+- &wwslog('info','do_del: %s not subscribed', $email);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'not_subscriber'});
+- return undef;
+- }
+-
+- unless( $list->update_user($email, {'bounce' => 'NULL', 'update_date' => time, 'score' => 0})) {
+- &report::reject_report_web('intern','update_subscriber_db_failed',{'sub'=> $email},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_resetbounce: failed update database for %s', $email);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- my $bounce_dir = $list->get_bounce_dir();
+-
+- unless (unlink $bounce_dir.'/'.$escaped_email) {
+- &wwslog('info','do_resetbounce: failed deleting %s', $bounce_dir.'/'.$escaped_email);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- }
+-
+- &wwslog('info','do_resetbounce: bounces for %s reset ', $email);
+- &web_db_log({'status' => 'success'});
+-
+- }
+-
+- return $in{'previous_action'} || 'review';
+- }
+-
+- ## Rebuild an archive using arctxt/
+- sub do_rebuildarc {
+- &wwslog('info', 'do_rebuildarc(%s, %s)', $param->{'list'}, $in{'month'});
+-
+- my $file = $Conf{'queueoutgoing'}.'/.rebuild.'.$list->get_list_id();
+-
+- unless (open REBUILD, ">$file") {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_rebuildarc: cannot create %s', $file);
+- &web_db_log({'parameters' => $in{'month'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &wwslog('info', 'File: %s', $file);
+-
+- print REBUILD ' ';
+- close REBUILD;
+-
+- &report::notice_report_web('performed_soon',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'month'},
+- 'status' => 'success'});
+- return 'admin';
+- }
+-
+- ## Rebuild all archives using arctxt/
+- sub do_rebuildallarc {
+- &wwslog('info', 'do_rebuildallarc');
+-
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+- next unless (defined $list->{'admin'}{'web_archive'});
+- my $file = $Conf{'queueoutgoing'}.'/.rebuild.'.$list->get_list_id();
+-
+- unless (open REBUILD, ">$file") {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $file},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_rebuildarc: cannot create %s', $file);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &wwslog('info', 'File: %s', $file);
+-
+- print REBUILD ' ';
+- close REBUILD;
+-
+- }
+- &report::notice_report_web('performed_soon',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+- return 'serveradmin';
+- }
+-
+- ## Search among lists
+- sub do_edit_attributes {
+- &wwslog('info', 'do_edit_attributes(%s)', $in{'filter'});
+-
+- return 1;
+- }
+-
+- ## Search among lists
+- sub do_search_list {
+- &wwslog('info', 'do_search_list(%s)', $in{'filter'});
+-
+- unless ($in{'filter'}) {
+- &report::reject_report_web('user','no_filter',{},$param->{'action'});
+- &wwslog('info','do_search_list: no filter');
+- return undef;
+- }elsif ($in{'filter'} =~ /[<>\\\*\$]/) {
+- &report::reject_report_web('user','syntax_errors',{'params' => 'filter'},$param->{'action'});
+- &wwslog('err','do_search_list: syntax error');
+- return undef;
+- }
+-
+- ## Regexp
+- $param->{'filter'} = $in{'filter'};
+- $param->{'regexp'} = &tools::escape_regexp($param->{'filter'});
+-
+- ## Members list
+- my $record = 0;
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+- my $is_admin;
+- ## Search filter
+- my $regtest = eval { (($list->{'name'} !~ /$param->{'regexp'}/i)
+- && ($list->{'admin'}{'subject'} !~ /$param->{'regexp'}/i)) };
+- unless (defined($regtest)) {
+- &report::reject_report_web('user','syntax_errors',{'params' => 'filter'},$param->{'action'});
+- &wwslog('err','do_search_list: syntax error');
+- return undef;
+- }
+- next if $regtest;
+-
+- my $result = $list->check_list_authz('visibility',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+- next unless ($r_action eq 'do_it');
+-
+- if ($param->{'user'}{'email'} &&
+- ($list->am_i('owner',$param->{'user'}{'email'}) ||
+- $list->am_i('editor',$param->{'user'}{'email'})) ) {
+- $is_admin = 1;
+- }
+-
+- $record++;
+- $param->{'which'}{$list->{'name'}} = {'host' => $list->{'admin'}{'host'},
+- 'subject' => $list->{'admin'}{'subject'},
+- 'admin' => $is_admin,
+- 'export' => 'no'};
+- }
+- $param->{'occurrence'} = $record;
+- foreach my $listname (sort keys %{$param->{'which'}}) {
+- if ($listname =~ /^([a-z])/){
+- push @{$param->{'orderedlist'}{$1}}, $listname ;
+- }else{
+- push @{$param->{'orderedlist'}{'others'}}, $listname ;
+- }
+- }
+-
+- return 1;
+- }
+-
+-sub do_edit_list {
+- &wwslog('info', 'do_edit_list()');
+-
+- ## Check if the list belong to a family.
+- my $family;
+- if (defined $list->{'admin'}{'family_name'}) {
+- unless ($family = $list->get_family()) {
+- &report::reject_report_web('intern','unable_get_family',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_list : impossible to get list %s\'s family',$list->{'name'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- ## This hash will contain all the data gathered from the edit list form.
+- ## The keys are the parameter names.
+- ## The values are either the parameter value or an array containing this value if this is a multiple values parameter.
+- ## The value can be a scalar or a hash.
+- my $new_admin = {};
+-
+- ## This hash contains the names of all the parameters sent by the form to the FCGI.
+- ## The keys are the parameters name, the value is always 1.
+- ## Used only to parse the data.
+- my $edited_param = {};
+-
+- ## Parse all the data sent from the web interface to the FCGI.
+- ## Fills the $new_admin and $edited_param hashes.
+- foreach my $key (sort keys %in) {
+- next unless ($key =~ /^(single_param|multiple_param)\.(\S+)$/);
+-
+- $key =~ /^(single_param|multiple_param)\.(\S+)$/;
+- my ($type, $name) = ($1, $2);
+-
+- ## Tag parameter as present in the form
+- if ($name =~ /^([^\.]+)(\.)/ ||
+- $name =~ /^([^\.]+)$/) {
+- $edited_param->{$1} = 1;
+- }
+-
+- ## Parameter value
+- my $value = $in{$key};
+- next if ($value =~ /^\s*$/);
+-
+- ## If the parameter is a multiple values parameter, store the values into an array.
+- if ($type eq 'multiple_param') {
+- my @values = split /\0/, $value;
+- $value = \@values;
+- }
+-
+- my @token = split (/\./, $name);
+-
+- ## make it an entry in $new_admin
+- my $var = &_shift_var(0, $new_admin, @token);
+- $$var = $value;
+- }
+-
+- ## Check that the serial number sent by the form is the same as the one we expect.
+- ## Avoid modifying a list previously modified by another way.
+- unless ($list->{'admin'}{'serial'} == $in{'serial'}) {
+- &report::reject_report_web('user','config_changed',{'email' => $list->{'admin'}{'update'}{'email'}},$param->{'action'},$list);
+- &wwslog('info','do_edit_list: Config file has been modified(%d => %d) by %s. Cannot apply changes', $in{'single_param.serial'}, $list->{'admin'}{'serial'}, $list->{'admin'}{'update'}{'email'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## Check changes & check syntax
+- ## %changed stores the names of the parameters whose values differs from the value in the config file.
+- ## %stores the name of parameter for which values have been deleted. The keys are the parameter name, the values are the index of the deleted value.
+- ## @syntax_error stores the list of parameters for which syntax errors wre founs while evaluating the data sent by the form.
+- my (%changed, %delete);
+- my @syntax_error;
+-
+- ## Check family constraints.
+- ## %check_family is a hash whose keys are a parameter name and whose values are the constraints
+- ## defined for this parameter.
+- my %check_family;
+-
+-
+- ## Getting changes about owners or editors
+- ## If changes occured in the owner or editor definition, these scalars are set to 1.
+- my $owner_update = 0;
+- my $editor_update = 0;
+-
+- ######################################################################
+- ## Start of the loop parsing the data sent by the edition form. ##
+- ######################################################################
+-
+- foreach my $pname (sort List::by_order keys %{$edited_param}) {
+-
+- ## $p will contain the values of the current parameter in the previous list config
+- ## $new_p will contain the values sent by the form for the current parameter.
+- my ($p, $new_p);
+-
+- ## Check privileges first
+- next unless ($list->may_edit($pname,$param->{'user'}{'email'}) eq 'write');
+-
+- ## If the list belongs to a family, gather all the constraints for each edited parameter.
+- if (ref($family) eq 'Family') {
+-
+- if ((ref($::pinfo{$pname}{'format'}) ne 'HASH') && (!ref($pname))) { # simple parameter
+- my $constraint = $family->get_param_constraint($pname);
+-
+- if (ref($constraint) eq 'HASH') { # controlled parameter
+- $check_family{$pname} = $constraint;
+-
+- } elsif ($constraint ne '0') { # fixed parameter (free : no control)
+- next;
+- }
+- }
+- }
+-
+- ## Skip the obsolete parameters.
+- next if $pinfo->{$pname}{'obsolete'};
+-
+- ## $to_index value will correspond to the number of not empty parameters sent by the form.
+- my $to_index;
+-
+- ####### Validation, step 1: remove empty entries ###########
+-
+- ## If the parameter can have multiple values...
+- if ($pinfo->{$pname}{'occurrence'} =~ /n$/) {
+-
+- ## They were either entries removed by the user or empty entries added by wwsympa
+- ## The loop is going backward so we can remove empty entries
+- my @all = 0..$#{$new_admin->{$pname}};
+- foreach my $i (reverse @all ) {
+- ## If the parameter has a complex structure
+- if (ref ($pinfo->{$pname}{'format'}) eq 'HASH') {
+- ## Check each component of the complex parameter.
+- foreach my $key (keys %{$pinfo->{$pname}{'format'}}) {
+- ## As soon as a required component is found missing, the whole parameter instance is removed.
+- if ($pinfo->{$pname}{'format'}{$key}{'occurrence'} =~ /^1/ &&
+- $new_admin->{$pname}[$i]{$key} =~ /^\s*$/ ) {
+- splice(@{$new_admin->{$pname}}, $i, 1);
+- last;
+- }
+- }
+- ## Else if the parameter has only a scalar value
+- }else {
+- ## Remove if empty
+- if ($new_admin->{$pname}[$i] =~ /^\s*$/) {
+- splice(@{$new_admin->{$pname}}, $i, 1);
+- next;
+- }
+- }
+- }
+-
+- ## Now, %new_admin contains only entries for which all the mandatory values are accounted for.
+-
+- ## $last_index corresponds to the number of remaining instances of this param sent by the form.
+- my $last_index = $#{$new_admin->{$pname}};
+-
+-
+- ## If a mandatory parameter is missing, issue an error and stop here.
+- if ($pinfo->{$pname}{'occurrence'} =~ /^1/ && !($last_index >= 0)){
+- delete $new_admin->{$pname};
+- &wwslog('err','Error: Parameter %s is mandatory.', $pname);
+- &report::reject_report_web('user','mandatory_parameter',{'p_name' => $pname},$param->{'action'},$list);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'syntax_errors'});
+- next;
+- }
+-
+- ## If there are less entries in the config file than were sent by the form,
+- ## $to_index must correspond to the number of entries sent.
+- if ($#{$list->{'admin'}{$pname}} < $last_index) {
+- $to_index = $last_index;
+- ## Otherwise, $to_index must correspond to the number of entries in the config file.
+- }else {
+- $to_index = $#{$list->{'admin'}{$pname}};
+- }
+-
+- $p = $list->{'admin'}{$pname};
+- $new_p = $new_admin->{$pname};
+-
+- ## If the parameter can't have multiple values...
+- }else {
+-
+- ## If the parameter has a complex structure
+- if (ref ($pinfo->{$pname}{'format'}) eq 'HASH') {
+-
+- ## Check each component of the complex parameter.
+- foreach my $key (keys %{$pinfo->{$pname}{'format'}}) {
+-
+- ## Remove the full record if a component is emtpy and required
+- if ($pinfo->{$pname}{'format'}{$key}{'occurrence'} =~ /^1/ &&
+- $new_admin->{$pname}{$key} =~ /^\s*$/ ) {
+- delete $new_admin->{$pname};
+- last;
+- }
+- }
+- ## If the parameter contains a simple scalar value.
+- }else {
+-
+- ## Remove if empty
+- if ($new_admin->{$pname} =~ /^\s*$/) {
+- delete $new_admin->{$pname};
+- }
+- }
+-
+- $p = [$list->{'admin'}{$pname}];
+- $new_p = [$new_admin->{$pname}];
+- }
+-
+- ####### Validation, step 2: - check if the parameter was modified. ###########
+- ####### - check that the new values have the right syntax. ###########
+- ####### Note: this step is performed for each occurrence of the parameter. ###########
+-
+- foreach my $i (0..$to_index) {
+- unless (defined $new_p->[$i]) {
+- push @{$delete{$pname}}, $i;
+- $changed{$pname} = 1; next;
+- }
+- ## If the parameter corresponds to a scenario or a task, mark it as changed if its name was changed.
+- ## Example: 'subscribe'
+- if ($pinfo->{$pname}{'scenario'} ||
+- $pinfo->{$pname}{'task'} ) {
+- if ($p->[$i]{'name'} ne $new_p->[$i]{'name'}) {
+- $changed{$pname} = 1; next;
+- }
+- ## If the parameter has a complex structure, we need to check all its components.
+- ## Example: 'owner'
+- }elsif (ref ($pinfo->{$pname}{'format'}) eq 'HASH') {
+- ## Check each parameter component.
+- ## Example: 'owner->email'
+- foreach my $key (keys %{$pinfo->{$pname}{'format'}}) {
+-
+- ## Check that the user is allowed to edit this parameter component.
+- next unless ($list->may_edit("$pname.$key",$param->{'user'}{'email'}) eq 'write');
+-
+- ## If the list belongs to a family, check the possible constraints on this parameter component.
+- if (ref($family) eq 'Family') {
+- ## Test constraints only if the parameter component is not a complex structure.
+- if (!ref($key)) {
+- my $constraint = $family->get_param_constraint("$pname.$key");
+- if (ref($constraint) eq 'HASH') { # controlled parameter
+- $check_family{$pname}{$key} = $constraint;
+- } elsif ($constraint ne '0') { # fixed parameter
+- next; # Go to the next parameter component.
+- }
+- }
+- }
+-
+- ## If the parameter component corresponds to a task or a scenario, mark it as changed if its name was changed.
+- if ($pinfo->{$pname}{'format'}{$key}{'scenario'} ||
+- $pinfo->{$pname}{'format'}{$key}{'task'} ) {
+- if ($p->[$i]{$key}{'name'} ne $new_p->[$i]{$key}{'name'}) {
+- $changed{$pname} = 1; next; # Mark as changed and go to the next parameter component.
+- }
+- ## If the parameter component doesn't correspond to a task or a scenario, we must check its content.
+- }else{
+- ## Parameter component check, case 1: this parameter component can have multiple occurence.
+- ## Example: 'digest->days'
+- if ($pinfo->{$pname}{'format'}{$key}{'occurrence'} =~ /n$/) {
+- ## If the new value differs from the previous value, mark as changed and go to the next parameter component.
+- if ($#{$p->[$i]{$key}} != $#{$new_p->[$i]{$key}}) {
+- $changed{$pname} = 1; next;
+- }
+-
+- ## For each occurrence of this parameter component, check value
+- foreach my $index (0..$#{$p->[$i]{$key}}) {
+- my $format = $pinfo->{$pname}{'format'}{$key}{'format'};
+-
+- ## If the format has a complex structure, it is the description of a file format.
+- if (ref ($format)) {
+- $format = $pinfo->{$pname}{'format'}{$key}{'file_format'};
+- }
+- ## If this occurrence of the parameter component differs from the corresponding one in the config
+- ## check the syntax and mark as changed.
+- if ($p->[$i]{$key}[$index] ne $new_p->[$i]{$key}[$index]) {
+-
+- if (defined($new_p->[$i]{$key}[$index]) && $new_p->[$i]{$key}[$index] !~ /^$format$/i) {
+- &wwslog('err', "Syntax error : $pname/$i/$key/$index = $new_p->[$i]{$key}[$index]");
+- push @syntax_error, $pname;
+- }
+- $changed{$pname} = 1; next; # Mark as changed and go to the next parameter component.
+- }
+- }
+-
+- ## Parameter component check, case 2: this component is limited to one occurence.
+- ## Example: 'owner->email'
+- }else {
+- ## If the parameter component value differs from the corresponding one in the config, go on.
+- if ($p->[$i]{$key} ne $new_p->[$i]{$key}) {
+- my $format = $pinfo->{$pname}{'format'}{$key}{'format'};
+-
+- ## If the format has a complex structure, it is the description of a file format.
+- if (ref ($format)) {
+- $format = $pinfo->{$pname}{'format'}{$key}{'file_format'};
+- }
+-
+- ## Check the syntax and mark as changed if the syntax is correct.
+- if (defined($new_p->[$i]{$key}) && $new_p->[$i]{$key} !~ /^$format$/i) {
+- &wwslog('err', "Syntax error : $pname/$i/$key = $new_p->[$i]{$key}");
+- push @syntax_error, $pname;
+- }
+-
+- $changed{$pname} = 1; next; # Mark as changed and go to the next parameter component.
+- }
+- }
+- }
+- }
+- ## If the parameter has just a scalar value, just check its value.
+- ## Example: 'max_size'
+- }else {
+- ## If the value differs from the one in the config file, mark parameter as changed if the syntax is correct.
+- if ($p->[$i] ne $new_p->[$i]) {
+- unless ($new_p->[$i] =~ /^$pinfo->{$pname}{'file_format'}$/) {
+- &wwslog('err', "Syntax error : $pname/$i = $new_p->[$i]");
+- push @syntax_error, $pname;
+- }
+- $changed{$pname} = 1;
+- }
+- }
+- }
+- }
+-
+- ######################################################################
+- ## Validation of the form finished. Start of valid data treatments ##
+- ######################################################################
+-
+- ## Error if no parameter was edited
+- unless (keys %changed) {
+- &report::reject_report_web('user','no_parameter_edited',{},$param->{'action'},$list);
+- &wwslog('info','No parameter was edited by user');
+- return 'edit_list_request';
+- }
+-
+- ## Syntax errors
+- if ($#syntax_error > -1) {
+- &report::reject_report_web('user','syntax_errors',{'params' => 'filter'},$param->{'action'},$list);
+- &wwslog('info','do_edit_list: Syntax errors for parameters %s', join(',', @syntax_error));
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'syntax_errors'});
+- return undef;
+- }
+-
+- ## Checking no topic named "other"
+- foreach my $msg_topic (@{$new_admin->{'msg_topic'}}) {
+- if ($msg_topic->{'name'} =~ /^other$/i) {
+- $msg_topic->{'name'} = undef;
+- $msg_topic->{'title'} = undef;
+- &report::reject_report_web('user','topic_other',{},$param->{'action'},$list);
+- &wwslog('notice',"do_edit_list: topic other is a reserved word");
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'syntax_errors'});
+- return undef;
+- }
+- }
+-
+- ## For changed msg_topic.name
+- if (defined $new_admin->{'msg_topic'} && $list->modifying_msg_topic_for_subscribers($new_admin->{'msg_topic'})) {
+- &report::notice_report_web('subscribers_noticed_deleted_topics',{},$param->{'action'});
+- }
+-
+- ## Delete selected params
+- foreach my $p (keys %delete) {
+-
+- if (($p eq 'owner') || ($p eq 'owner_include')) {
+- $owner_update = 1;
+- }
+-
+- if (($p eq 'editor') || ($p eq 'editor_include')) {
+- $editor_update = 1;
+- }
+-
+- ## Delete ALL entries
+- unless (ref ($delete{$p})) {
+- undef $new_admin->{$p};
+- next;
+- }
+-
+- ## Delete selected entries
+- foreach my $k (reverse @{$delete{$p}}) {
+- splice @{$new_admin->{$p}}, $k, 1;
+- }
+-
+- if (defined $check_family{$p}) { # $p is family controlled
+- if ($#{$new_admin->{$p}} < 0) {
+- &report::reject_report_web('user','p_family_controlled',{'param' => $p},$param->{'action'},$list);
+- &wwslog('info','do_edit_list : parameter %s must have values (family context)',$p);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return undef;
+- }
+- }
+- }
+-
+- # updating config_changes for deleted parameters
+- if (ref($family)) {
+- my @array_delete = keys %delete;
+- unless ($list->update_config_changes('param',\@array_delete)) {
+- &report::reject_report_web('intern','update_config_changes',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_list: cannot write in config_changes for deleted parameters from list %s', $list->{'name'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- ## Update config in memory
+- my $data_source_updated;
+- foreach my $parameter (keys %changed) {
+-
+- my $pname;
+- if ($parameter =~ /^([\w-]+)\.([\w-]+)$/) {
+- $pname = $1;
+- } else{
+- $pname = $parameter;
+- }
+-
+- my @users;
+-
+- ## If new owners/editors have been added, then notify them
+- foreach my $admin_type ('owner','editor') {
+- my (%previous_emails, %new_emails);
+-
+- ## Check previous entries
+- foreach my $entry (@{$list->{'admin'}{$admin_type}}) {
+- $previous_emails{$entry->{'email'}} = 1;
+- }
+-
+- ## Compare with new entries
+- foreach my $entry (@{$new_admin->{$admin_type}}) {
+-
+- unless ($previous_emails{$entry->{'email'}}) {
+-
+- ## Notify the new list owner/editor
+- $list->send_notify_to_user('added_as_listadmin', $entry->{'email'},{'admin_type' => $admin_type, 'delegator' => $param->{'user'}{'email'}});
+- &report::notice_report_web('user_notified',{'notified_user' => $entry->{'email'}},$param->{'action'});
+- }
+- }
+- }
+-
+- if (defined $check_family{$pname}) { # $pname is CONTROLLED
+- &_check_new_values(\%check_family,$pname,$new_admin);
+- }
+-
+- ## If datasource config changed
+- if ($pname =~ /^(include_.*|user_data_source|ttl)$/) {
+- $data_source_updated = 1;
+- }
+-
+- ## User Data Source
+- if ($pname eq 'user_data_source') {
+- ## Migrating to database
+- if (($list->{'admin'}{'user_data_source'} eq 'file') && ($new_admin->{'user_data_source'} eq 'database' || $new_admin->{'user_data_source'} eq 'include2')) {
+- unless (-f "$list->{'dir'}/subscribers") {
+- &wwslog('notice', 'No subscribers to load in database');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'no_subsciber'});
+- }
+- @users = &List::_load_users_file("$list->{'dir'}/subscribers");
+- }elsif (($list->{'admin'}{'user_data_source'} ne 'include2') &&
+- ($new_admin->{'user_data_source'} eq 'include2')) {
+- $list->update_user('*', {'subscribed' => 1});
+- &report::notice_report_web('subscribers_updated_soon',{},$param->{'action'});
+- }elsif (($list->{'admin'}{'user_data_source'} eq 'include2') &&
+- ($new_admin->{'user_data_source'} eq 'database')) {
+- $list->sync_include('purge');
+- }
+-
+- ## Update total of subscribers
+- $list->{'total'} = $list->_load_total_db();
+- $list->savestats();
+- }
+-
+- $list->{'admin'}{$pname} = $new_admin->{$pname};
+- if (defined $new_admin->{$pname} || $pinfo->{$pname}{'internal'}) {
+- delete $list->{'admin'}{'defaults'}{$pname};
+- }else {
+- $list->{'admin'}{'defaults'}{$pname} = 1;
+- }
+-
+- if (($pname eq 'user_data_source') &&
+- ($#users >= 0)) {
+-
+- $list->{'total'} = 0;
+-
+- ## Insert users in database
+- foreach my $user (@users) {
+- $list->add_user($user);
+- }
+-
+- $list->get_total();
+- $list->{'mtime'}[1] = 0;
+- }
+-
+- if (($pname eq 'owner') || ($pname eq 'owner_include')){
+- $owner_update = 1;
+- }
+-
+- if (($pname eq 'editor') || ($pname eq 'editor_include')){
+- $editor_update = 1;
+- }
+-
+- # updating config_changes for changed parameters
+-
+- if (ref($family)) {
+- my @array_changed = keys %changed;
+- unless ($list->update_config_changes('param',\@array_changed)) {
+- &report::reject_report_web('intern','update_config_changes',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_file: cannot write in config_changes for changed parameters from list %s', $list->{'name'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+- }
+-
+- ## Save config file
+- unless ($list->save_config($param->{'user'}{'email'})) {
+- &report::reject_report_web('intern','cannot_save_config',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_list: Cannot save config file');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+-
+- ## Reload config to clean some empty entries in $list->{'admin'}
+- $list = new List $list->{'name'}, $robot, {'reload_config' => 1};
+-
+- unless (defined $list) {
+- &report::reject_report_web('intern','list_reload',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_list: error in list reloading');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## If list has included data sources, update them and delete sync_include task.
+- if ($data_source_updated) {
+- if ($list->on_the_fly_sync_include('use_ttl'=>0)) {
+- &report::notice_report_web('subscribers_updated',{},$param->{'action'});
+- }else {
+- &report::reject_report_web('intern','sync_include_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }
+- }
+-
+- ## call sync_include_admin if there are changes about owners or editors and we're in mode include2
+- if ( ($list->{'admin'}{'user_data_source'} eq 'include2')) {
+- unless ($list->sync_include_admin()) {
+- &report::reject_report_web('intern','sync_include_admin_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_list: sync_include_admin() failed');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-#($owner_update || $editor_update) &&
+- ## checking there is some owner(s) in case of sync_include_admin not called
+- if (($owner_update || $data_source_updated) && ($list->{'admin'}{'user_data_source'} ne 'include2')) {
+-
+- unless ( $list->get_nb_owners()) {
+- &report::reject_report_web('intern','no_owner_defined',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_list: no owner defined for list %s',$list->{'name'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+-
+- ## Tag changed parameters
+- foreach my $pname (keys %changed) {
+- $::changed_params{$pname} = 1;
+- }
+-
+- ## Save stats
+- $list->savestats();
+-
+-# print "Content-type: text/plain\n\n";
+- # &tools::dump_var($list->{'admin'}{'msg_topic'},0);
+- # &tools::dump_var($param->{'param'},0);
+-
+-
+- &report::notice_report_web('list_config_updated',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+- return 'edit_list_request';
+- }
+-
+- ## Shift tokens to get a reference to the desired
+- ## entry in $var (recursive)
+- sub _shift_var {
+- my ($i, $var, @tokens) = @_;
+- &wwslog('debug3','shift_var(%s,%s,%s)',$i, $var, join('.',@tokens));
+- my $newvar;
+-
+- my $token = shift @tokens;
+-
+- if ($token =~ /^\d+$/) {
+- return \$var->[$token]
+- if ($#tokens == -1);
+-
+- if ($tokens[0] =~ /^\d+$/) {
+- unless (ref $var->[$token]) {
+- $var->[$token] = [];
+- }
+- $newvar = $var->[$token];
+- }else {
+- unless (ref $var->[$token]) {
+- $var->[$token] = {};
+- }
+- $newvar = $var->[$token];
+- }
+- }else {
+- return \$var->{$token}
+- if ($#tokens == -1);
+-
+- if ($tokens[0] =~ /^\d+$/) {
+- unless (ref $var->{$token}) {
+- $var->{$token} = [];
+- }
+- $newvar = $var->{$token};
+- }else {
+- unless (ref $var->{$token}) {
+- $var->{$token} = {};
+- }
+- $newvar = $var->{$token};
+- }
+-
+- }
+-
+- if ($#tokens > -1) {
+- $i++;
+- return &_shift_var($i, $newvar, @tokens);
+- }
+- return $newvar;
+- }
+-
+-=pod
+-
+-=head2 sub do_edit_list_request
+-
+-Sends back the list config edition form.
+-
+-=head3 Arguments
+-
+-=over
+-
+-=item * I<None>
+-
+-=back
+-
+-=head3 Return
+-
+-=over
+-
+-=item * I<1>, if no problem is encountered
+-
+-=item * I<undef>, if anything goes wrong
+-
+-=item * I<'loginrequest'> if no user is logged in at the time the function is called.
+-
+-=back
+-
+-=head3 Calls
+-
+-=over
+-
+-=item * wwslog
+-
+-=item * _prepare_edit_form
+-
+-=item * report::reject_report_web
+-
+-=back
+-
+-=cut
+-
+- ## Send back the list config edition form
+- sub do_edit_list_request {
+- &wwslog('info', 'do_edit_list_request(%s)', $in{'group'});
+-
+- if ($in{'group'}) {
+- $param->{'group'} = $in{'group'};
+- &_prepare_edit_form ($list);
+- }
+-
+- # print "Content-type: text/plain\n\n";
+- # &tools::dump_var(\%pinfo,0);
+- # &tools::dump_var($list->{'admin'},0);
+- # &tools::dump_var($param->{'param'},0);
+-
+- $param->{'serial'} = $list->{'admin'}{'serial'};
+-
+- return 1;
+- }
+-
+-sub _check_new_values {
+- my $check_family = shift;
+- my $pname = shift;
+- my $new_admin = shift;
+- &wwslog('debug3', '_check_new_values(%s)',$pname);
+-
+- my $uncompellable_param = &Family::get_uncompellable_param();
+-
+- if (ref($::pinfo{$pname}{'format'}) eq 'HASH') { #composed parameter
+-
+- foreach my $key (keys %{$check_family->{$pname}}) {
+-
+- my $constraint = $check_family->{$pname}{$key};
+- my $values = &List::_get_param_value_anywhere($new_admin,"$pname.$key");
+- my $nb_for = 0;
+-
+- # exception for uncompellable param
+- foreach my $p (keys %{$uncompellable_param}) {
+- if (($pname eq $p) && !($uncompellable_param->{$p})) {
+- return 1;
+- }
+-
+- if (($pname eq $p) && ($key eq $uncompellable_param->{$p})) {
+- return 1;
+- }
+- }
+- foreach my $p_val (@{$values}) { #each element value
+- $nb_for++;
+- if (ref($p_val) eq 'ARRAY') { # multiple values
+- foreach my $p (@{$p_val}) {
+- if (!($constraint->{$p}) && (($nb_for == 1) || ($p ne ''))) {
+- &report::reject_report_web('user','p_family_wrong',{'param' => $pname,'val'=> $p},$param->{'action'});
+- &wwslog('info','do_edit_list : parameter %s has got wrong value : %s (family context), %s, %d',$pname,$p);
+- return undef;
+- }
+- }
+- } else { # single value
+- if (!($constraint->{$p_val}) && (($nb_for == 1) || ($p_val ne ''))) {
+- &report::reject_report_web('user','p_family_wrong',{'param' => $pname,'val'=> $p_val},$param->{'action'});
+- &wwslog('info','do_edit_list : parameter %s has got wrong value : %s (family context), %s, %d',$pname,$p_val);
+- return undef;
+- }
+- }
+- }
+- }
+- } else { #simple parameter
+-
+- # exception for uncompellable param
+- foreach my $p (keys %{$uncompellable_param}) {
+- if ($pname eq $p) {
+- return 1;
+- }
+- }
+-
+-
+- my $constraint = $check_family->{$pname};
+- my $values = &List::_get_param_value_anywhere($new_admin,$pname);
+- my $nb_for = 0;
+-
+-
+- foreach my $p_val (@{$values}) { #each element value
+- $nb_for++;
+- if (ref($p_val) eq 'ARRAY') { # multiple values
+- foreach my $p (@{$p_val}) {
+- if (!($constraint->{$p}) && (($nb_for == 1) || ($p ne ''))) {
+- &report::reject_report_web('user','p_family_wrong',{'param' => $pname,'val'=> $p},$param->{'action'});
+- &wwslog('info','do_edit_list : parameter %s has got wrong value : %s (family context), %s, %d',$pname,$p);
+- return undef;
+- }
+- }
+- } else { # single value
+- if (!($constraint->{$p_val}) && (($nb_for == 1) || ($p_val ne ''))) {
+- &report::reject_report_web('user','p_family_wrong',{'param' => $pname,'val'=> $p_val},$param->{'action'});
+- &wwslog('info','do_edit_list : parameter %s has got wrong value : %s (family context), %s, %d',$pname,$p_val);
+- return undef;
+- }
+- }
+- }
+- }
+-}
+-
+-=pod
+-
+-=head2 sub _prepare_edit_form(LIST)
+-
+-Prepares config data to be sent in the edition form. Adds to the parameters array a hash for each parameter to be edited.
+-
+-=head3 Arguments
+-
+-=over
+-
+-=item * I<$list>, a List object
+-
+-=back
+-
+-=head3 Return
+-
+-=over
+-
+-=item * I<1>, if no problem is encountered
+-
+-=item * I<undef>, if anything goes wrong
+-
+-=back
+-
+-=head3 Calls
+-
+-=over
+-
+-=item * _prepare_data
+-
+-=item * _restrict_values
+-
+-=item * wwslog
+-
+-=item * List::by_order
+-
+-=item * List::get_family
+-
+-=item * List::load_topics
+-
+-=item * List::may_edit
+-
+-=item * Language::GetLang
+-
+-=item * Language::SetLang
+-
+-=item * report::reject_report_web
+-
+-=item * tools::dup_var
+-
+-=back
+-
+-=cut
+-
+-## Prepare config data to be sent in the
+-## edition form
+-sub _prepare_edit_form {
+- my $list = shift;
+- my $list_config = &tools::dup_var($list->{'admin'});
+- my $family;
+- my $is_form_editable = '0';
+-
+- ## If the list belongs to a family, check if the said family can be retrieved.
+- if (defined $list_config->{'family_name'}) {
+- unless ($family = $list->get_family()) {
+- &report::reject_report_web('intern','unable_get_family',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','_prepare_edit_form : impossible to get list %s\'s family',$list->{'name'});
+- return undef;
+- }
+- }
+-
+- ## For each parameter defined in List.pm, retrieve and prepare for editing
+- foreach my $pname (sort List::by_order keys %{$pinfo}) {
+-
+- ## Skip comments and default values.
+- next if ($pname =~ /^(comment|defaults)$/);
+-
+- ## Skip parameters belonging to another group.
+- next if ($in{'group'} && ($pinfo->{$pname}{'group'} ne $in{'group'}));
+-
+- ## Skip obsolete parameters.
+- next if $pinfo->{$pname}{'obsolete'};
+-
+- ## Check whether the parameter can be edited by the logged user.
+- my $may_edit = $list->may_edit($pname,$param->{'user'}{'email'});
+-
+- ## Valid form global edit status as soon as at least one editable parameter is found.
+- if ($may_edit eq 'write') {
+- $is_form_editable = '1';
+- }
+-
+- ## Store in $p a reference to the hash containing the informations relative to the parameter editing.
+- my $p = &_prepare_data($pname, $pinfo->{$pname}, $list_config->{$pname},$may_edit,$family);
+-
+- ## Store if the parameter is still at its default value or not.
+- $p->{'default'} = $list_config->{'defaults'}{$pname};
+-
+- ## Store the change state of this parameter, taken from the global variable %changed_params.
+- $p->{'changed'} = $::changed_params{$pname};
+-
+- ## Exceptions...too many
+- if ($pname eq 'topics') {
+- $p->{'type'} = 'enum';
+-
+- my @topics;
+- foreach my $topic(@{$p->{'value'}}) {
+- push @topics, $topic->{'value'};
+- }
+- undef $p->{'value'};
+- my %list_of_topics = &List::load_topics($robot);
+-
+- if (defined $p->{'constraint'}) {
+- &_restrict_values(\%list_of_topics,$p->{'constraint'});
+- }
+-
+- foreach my $topic (keys %list_of_topics) {
+- $p->{'value'}{$topic}{'selected'} = 0;
+- $p->{'value'}{$topic}{'title'} = $list_of_topics{$topic}{'current_title'};
+-
+- if ($list_of_topics{$topic}{'sub'}) {
+- foreach my $subtopic (keys %{$list_of_topics{$topic}{'sub'}}) {
+- $p->{'value'}{"$topic/$subtopic"}{'selected'} = 0;
+- $p->{'value'}{"$topic/$subtopic"}{'title'} = "$list_of_topics{$topic}{'current_title'}/$list_of_topics{$topic}{'sub'}{$subtopic}{'current_title'}";
+- }
+- }
+- }
+- foreach my $selected_topic (@topics) {
+- next unless (defined $selected_topic);
+- $p->{'value'}{$selected_topic}{'selected'} = 1;
+- $p->{'value'}{$selected_topic}{'title'} = "Unknown ($selected_topic)"
+- unless (defined $p->{'value'}{$selected_topic}{'title'});
+- }
+- }elsif ($pname eq 'digest') {
+- foreach my $v (@{$p->{'value'}}) {
+- next unless ($v->{'name'} eq 'days');
+- if (ref($v->{'value'}) eq 'ARRAY'){
+- &tools::do_log('debug2','Empty digest parameter. Putting a dummy value.');
+- $v->{'value'} = undef;
+- $v->{'type'} = 'enum';
+- }else{
+- foreach my $day (keys %{$v->{'value'}}) {
+- $v->{'value'}{$day}{'title'} = gettext_strftime "%A", gmtime(0 + ($day +3) * (3600 * 24));
+- }
+- }
+- }
+- }elsif ($pname eq 'lang') {
+- my $saved_lang = &Language::GetLang();
+-
+- foreach my $lang (keys %{$p->{'value'}}) {
+- #&wwslog('notice','LANG: %s', $lang);
+- &Language::SetLang($lang);
+- $p->{'value'}{$lang}{'title'} = gettext('_language_');
+- }
+- &Language::SetLang($saved_lang);
+- }
+-
+- push @{$param->{'param'}}, $p;
+- }
+-
+- ## If at least one param was editable, make the update button appear in the form.
+- $param->{'is_form_editable'} = $is_form_editable;
+- return 1;
+- }
+-
+-=pod
+-
+-=head2 sub _prepare_data(STRING $name, HASH_Ref $struct, SCALAR $data, STRING $may_edit, FAMILY $family, STRING $main_p)
+-
+-Returns a reference to a hash containing the data used to edit the parameter (of name $name, corresponding to the structure $struct in pinfo, with the $may_edit editing status) containing the data in the Sympa web interface.
+-
+-=head3 Arguments
+-
+-=over
+-
+-=item * I<$name> (STRING), the name of the parameter processed
+-
+-=item * I<$struct> (HASH_Ref), a ref to the hash describing this parameter in %List::pinfo
+-
+-=item * I<$data> (), the value(s) taken by this parameter in the current list. Can be a reference to a list or the value of a single parameter.
+-
+-=item * I<$may_edit> (STRING), the editing status of this parameter in the current context.
+-
+-=item * I<$family> (FAMILY), the family the list belongs to.
+-
+-=item * I<$main_p> (STRING), the prefix composing the complete name of the parameter.
+-
+-=back
+-
+-=head3 Return
+-
+-=over
+-
+-=item * I<$p_glob>, a reference to a hash containing the data used to edit the parameter.
+-
+-=back
+-
+-=head3 Calls
+-
+-=over
+-
+-=item * _restrict_values
+-
+-=item * _prepare_data
+-
+-=item * load_data_sources_list
+-
+-=item * Family::get_param_constraint
+-
+-=item * List::load_scenario_list
+-
+-=item * List::load_task_list
+-
+-=item * List::may_edit
+-
+-=item * tools::escape_html
+-
+-=back
+-
+-=cut
+-
+- sub _prepare_data {
+- my ($name, $struct,$data,$may_edit,$family,$main_p) = @_;
+- # &wwslog('debug2', '_prepare_data(%s, %s)', $name, $data);
+- # $family and $main_p (recursive call) are optionnal
+- # if $main_p is needed, $family also
+- next if ($struct->{'obsolete'});
+-
+- ## Prepare data structure for the parser
+- my $p_glob = {'name' => $name,
+- 'comment' => $struct->{'comment'}{$param->{'lang'}}
+- };
+-
+- ## Check if some family constraint modify the editing rights.
+- my $restrict = 0;
+- my $constraint;
+- if ((ref($family) eq 'Family') && ($may_edit eq 'write')) {
+-
+- if ($main_p && defined $::pinfo{$main_p}) {
+- if (ref($::pinfo{$main_p}{'format'}) eq 'HASH') { # composed parameter
+- $constraint = $family->get_param_constraint("$main_p.$p_glob->{'name'}");
+- }
+- } else { # simple parameter
+- if (ref($::pinfo{$p_glob->{'name'}}{'format'}) ne 'HASH') { # simple parameter
+- $constraint = $family->get_param_constraint($p_glob->{'name'});
+- }
+- }
+- if ($constraint eq '0') { # free parameter
+- $p_glob->{'may_edit'} = 'write';
+-
+- } elsif (ref($constraint) eq 'HASH') { # controlled parameter
+- $p_glob->{'may_edit'} = 'write';
+- $restrict = 1;
+-
+- } else { # fixed parameter
+- $p_glob->{'may_edit'} = 'read';
+- }
+-
+- } else {
+- $p_glob->{'may_edit'} = $may_edit;
+- }
+-
+- ## Naming the parameter.
+- if ($struct->{'gettext_id'}) {
+- $p_glob->{'title'} = gettext($struct->{'gettext_id'});
+- }else {
+- $p_glob->{'title'} = $name;
+- }
+-
+- ## Occurrences : if the parameter can have multiple occurences,
+- ## its values are transfered into the array pointed by $data2
+- ## if they were given in arguments (if not, an empty array is created).
+- ## if it is a single occurence parameter, an array is created with
+- ## its single value.
+-
+- my $data2;
+- if ($struct->{'occurrence'} =~ /n$/) {
+- $p_glob->{'occurrence'} = 'multiple';
+- if (defined($data)) {
+- $data2 = $data;
+-
+- if ($may_edit eq 'write') {
+- ## Add an empty entry
+- unless (($name eq 'days') || ($name eq 'reception') || ($name eq 'rfc2369_header_fields') || ($name eq 'topics')) {
+-
+- my $empty_entry;
+- ## Structured parameter
+- if (ref($struct->{'format'}) eq 'HASH') {
+- foreach my $sub_parameter (keys %{$struct->{'format'}}) {
+-
+- ## Use default value if defined
+- if ($struct->{'format'}{$sub_parameter}{'default'}) {
+- $empty_entry->{$sub_parameter} = $struct->{'format'}{$sub_parameter}{'default'};
+- }
+- }
+-
+- ## Simpe parameter
+- }else {
+- $empty_entry = undef;
+- }
+-
+- push @{$data2}, $empty_entry;
+- ## &wwslog('debug2', 'Add 1 %s', $name);
+- }
+- }
+- }else {
+- if ($may_edit eq 'write') {
+- $data2 = [undef];
+- }
+- }
+- }else {
+- $data2 = [$data];
+- }
+-
+- my @all_p;
+-
+- ## Foreach occurrence of param
+- foreach my $d (@{$data2}) {
+- my $p = {};
+-
+- ## Type of data
+- if ($struct->{'scenario'}) {
+- $p_glob->{'type'} = 'scenario';
+- my $list_of_scenario;
+-
+- my $tmp_list_of_scenario = $list->load_scenario_list($struct->{'scenario'},$robot);
+-
+- ## Only get required scenario attributes
+- foreach my $scenario (keys %{$tmp_list_of_scenario}) {
+- $list_of_scenario->{$scenario} = {'name' => $tmp_list_of_scenario->{$scenario}{'name'},
+- 'web_title' => $tmp_list_of_scenario->{$scenario}{'web_title'}};
+- }
+-
+- $list_of_scenario->{$d->{'name'}}{'selected'} = 1;
+-
+- $p->{'value'} = $list_of_scenario;
+-
+- if ($restrict) {
+- &_restrict_values($p->{'value'},$constraint);
+- }
+-
+- }elsif ($struct->{'task'}) {
+- $p_glob->{'type'} = 'task';
+- my $list_of_task = $list->load_task_list($struct->{'task'}, $robot);
+-
+- $list_of_task->{$d->{'name'}}{'selected'} = 1;
+-
+- $p->{'value'} = $list_of_task;
+-
+- if ($restrict) {
+- &_restrict_values($p->{'value'},$constraint);
+- }
+-
+- }elsif ($struct->{'datasource'}) {
+- $p_glob->{'type'} = 'datasource';
+- my $list_of_data_sources = $list->load_data_sources_list($robot);
+-
+- $list_of_data_sources->{$d}{'selected'} = 1;
+-
+- $p->{'value'} = $list_of_data_sources;
+-
+- if ($restrict) {
+- &_restrict_values($p->{'value'},$constraint);
+- }
+-
+- }elsif (ref ($struct->{'format'}) eq 'HASH') {
+- $p_glob->{'type'} = 'paragraph';
+- unless (ref($d) eq 'HASH') {
+- $d = {};
+- }
+-
+- foreach my $k (sort {$struct->{'format'}{$a}{'order'} <=> $struct->{'format'}{$b}{'order'}}
+- keys %{$struct->{'format'}}) {
+- ## Prepare data recursively
+- my $m_e = $list->may_edit("$name.$k",$param->{'user'}{'email'});
+- my $v = &_prepare_data($k, $struct->{'format'}{$k}, $d->{$k},$m_e,$family,$name);
+-
+- push @{$p->{'value'}}, $v;
+- }
+-
+- }elsif ((ref ($struct->{'format'}) eq 'ARRAY') || ($restrict && ($main_p eq 'msg_topic' && $name eq 'keywords'))) {
+- $p_glob->{'type'} = 'enum';
+-
+- unless (defined $p_glob->{'value'}) {
+- ## Initialize
+- foreach my $elt (@{$struct->{'format'}}) {
+- $p_glob->{'value'}{$elt}{'selected'} = 0;
+- }
+-
+- ## Check obsolete values ; they should not be printed
+- if (defined $struct->{'obsolete_values'}) {
+- foreach my $elt (@{$struct->{'obsolete_values'}}) {
+- delete $p_glob->{'value'}{$elt};
+- }
+- }
+- }
+- if (ref ($d)) {
+- next unless (ref ($d) eq 'ARRAY');
+- foreach my $v (@{$d}) {
+- $p_glob->{'value'}{$v}{'selected'} = 1;
+- }
+- }else {
+- $p_glob->{'value'}{$d}{'selected'} = 1 if (defined $d);
+- }
+-
+- if ($restrict) {
+- &_restrict_values($p_glob->{'value'},$constraint);
+- }
+-
+- }else {
+- if ($restrict && ($name ne 'topics')) {
+- $p_glob->{'type'} = 'enum';
+-
+- foreach my $elt (keys %{$constraint}) {
+- $p->{'value'}{&tools::escape_html($elt)}{'selected'} = 0;
+- }
+-
+- $p->{'value'}{&tools::escape_html($d)}{'selected'} = 1;
+- $p->{'length'} = $struct->{'length'};
+- $p->{'unit'} = gettext($struct->{'gettext_unit'});
+-
+- } else {
+-
+- $p_glob->{'type'} = 'scalar';
+- $p->{'value'} = &tools::escape_html($d);
+- $p->{'length'} = $struct->{'length'};
+- $p->{'field_type'} = $struct->{'field_type'};
+- my $l = length($p->{'value'});
+- $p->{'hidden_field'} = '*' x $l;
+- $p->{'unit'} = gettext($struct->{'gettext_unit'});
+- if ($restrict) { # for topics
+- $p_glob->{'constraint'} = $constraint;
+- }
+- }
+- }
+-
+- push @all_p, $p;
+- }
+-
+- if (($p_glob->{'occurrence'} eq 'multiple')
+- && ($p_glob->{'type'} ne 'enum')) {
+- $p_glob->{'value'} = \@all_p;
+- }else {
+- foreach my $k (keys %{$all_p[0]}) {
+- $p_glob->{$k} = $all_p[0]->{$k};
+- }
+- }
+-
+- return $p_glob;
+- }
+-
+-## Restrict allowed values in the hash
+-sub _restrict_values {
+- my $values = shift; #ref on hash of values
+- my $allowed = shift; #ref on hash of allowed values
+- &wwslog('debug3', '_restrict_values()');
+-
+- foreach my $v (keys %{$values}) {
+- unless (defined $allowed->{$v}) {
+- delete $values->{$v};
+- }
+- }
+-}
+-
+- ## NOT USED anymore (expect chinese)
+- sub do_close_list_request {
+- &wwslog('info', 'do_close_list_request()');
+-
+- if ($list->{'admin'}{'status'} eq 'closed') {
+- &report::reject_report_web('user','already_closed',{},$param->{'action'},$list);
+- &wwslog('info','do_close_list_request: already closed');
+- return undef;
+- }
+-
+- return 1;
+- }
+-
+-
+- # in order to rename a list you must be list owner and you must be allowed to create new list
+- sub do_rename_list_request {
+- &wwslog('info', 'do_rename_list_request()');
+-
+- my $result = &Scenario::request_action ('create_list',$param->{'auth_method'},$robot,
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- unless ($r_action =~ /do_it|listmaster/) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- &wwslog('info','do_rename_list_request: not owner');
+- return undef;
+- }
+-
+- ## Super listmaster can move a list to another robot
+- if (&List::is_listmaster($param->{'user'}{'email'}, $robot)) {
+- foreach (keys %{$Conf{'robots'}}) {
+- if ($_ eq $robot) {
+- $param->{'robots'}{$_} = 'selected="selected"';
+- }else {
+- $param->{'robots'}{$_} = '';
+- }
+- }
+- }
+-
+- return '1';
+- }
+-
+-sub do_copy_list {
+- &wwslog('info', 'do_copy_list(%s,%s)', $in{'new_listname'}, $in{'new_robot'});
+- &do_rename_list('copy');
+-}
+-
+-# in order to rename a list you must be list owner and you must be allowed to create new list
+-sub do_rename_list {
+- my $mode = shift;
+-
+- if ($in{'new_listname'} =~ /[A-Z]/) {
+- $in{'new_listname'} = lc($in{'new_listname'});
+- &report::notice_report_web('listname_lowercased',{},$param->{'action'});
+- }
+-
+- &wwslog('info', 'do_rename_list(%s,%s, mode = %s)', $in{'new_listname'}, $in{'new_robot'},$mode);
+-
+- my $result = &admin::rename_list(list => $list,
+- new_listname =>$in{'new_listname'},
+- new_robot => $in{'new_robot'},
+- mode => $mode,
+- auth_method => $param->{'auth_method'},
+- user_email => $param->{'user'}{'email'},
+- remote_host => $param->{'remote_host'},
+- remote_addr => $param->{'remote_addr'},
+- aliases => $param->{'aliases'},
+- status => $param->{'status'},
+- );
+-
+- if ($result eq 'incorrect_listname') {
+- &report::reject_report_web('user','incorrect_listname', {'bad_listname' => $in{'new_listname'}},$param->{'action'},$list);
+- &wwslog('info','do_rename_list: incorrect listname %s', $in{'new_listname'});
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'error',
+- 'error_type' => 'incorrect_listname'});
+- return 'rename_list_request';
+-
+- }elsif ($result eq 'authorization') {
+- &report::reject_report_web('auth','authorization',{},$param->{'action'},$list);
+- &wwslog('info','do_rename_list: not owner');
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+-
+- }elsif ($result eq 'internal') {
+- &report::reject_report_web('intern','UUUUnable_to_rename_list',{'new_listname' => $in{'new_listname'}},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err', "can't rename list %s to %s@%s", $list->get_list_address(), $in{'new_listname'}, $in{'new_robot'});
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+-
+- }elsif ($result eq 'list_already_exists') {
+- &report::reject_report_web('user','list_already_exists',{'new_listname' => $in{'new_listname'}},$param->{'action'},$list);
+- &wwslog('info', 'Could not rename list %s for %s: new list %s already existing list',
+- $in{'listname'},$param->{'user'}{'email'},$in{'new_listname'});
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'error',
+- 'error_type' => 'list_already_exists'});
+- return undef;
+-
+- }elsif ($result eq 'incorrect_listname') {
+- &report::reject_report_web('user','listname_matches_aliases',{'new_listname' => $in{'new_listname'}},$param->{'action'},$list);
+- &wwslog('info','do_create_list: incorrect listname %s', $in{'new_listname'});
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'error',
+- 'error_type' => 'incorrect_listname'});
+- return 'rename_list_request';
+- }elsif ($result eq 'unknown_robot') {
+- &wwslog('info',"do_rename_list : unknown robot $in{'new_robot'}");
+- &report::reject_report_web('user','unknown_robot',{'new_robot' => $in{'new_robot'}},$param->{'action'},$list);
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'error',
+- 'error_type' => 'unknown_robot'});
+- return undef;
+- }
+-
+- ## Were aliases installed?
+- if ($param->{'aliases'} == 1) {
+- $param->{'auto_aliases'} = 1;
+- }else {
+- $param->{'auto_aliases'} = 0;
+- }
+-
+- # set list status to pending if creation list is moderated
+- if ($param->{'status'} eq 'pending') {
+- &report::notice_report_web('pending_list',{},$param->{'action'},$list);
+- }
+-
+- if ($in{'new_robot'} eq '$robot') {
+- $param->{'redirect_to'} = "$param->{'base_url'}$param->{'path_cgi'}/admin/$in{'new_listname'}";
+- }else {
+- $param->{'redirect_to'} = &Conf::get_robot_conf($in{'new_robot'}, 'wwsympa_url')."/admin/$in{'new_listname'}";
+- }
+-
+- $param->{'list'} = $in{'new_listname'};
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'success'});
+-
+- return 1;
+-}
+-
+-
+-sub do_purge_list {
+- &wwslog('info', 'do_purge_list()');
+-
+- my @lists = split /\0/, $in{'selected_lists'};
+-
+- foreach my $l (@lists) {
+- my $list = new List ($l, $robot);
+- next unless (defined $list);
+- $list->purge($param->{'user'}{'email'});
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'selected_lists'},
+- 'status' => 'success'});
+- return 'get_closed_lists';
+- }
+-
+- sub do_close_list {
+- &wwslog('info', "do_close_list($list->{'name'})");
+-
+- if ($list->{'admin'}{'status'} eq 'closed') {
+- &report::reject_report_web('user','already_closed',{},$param->{'action'},$list);
+- &wwslog('info','do_close_list: already closed');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'already_closed'});
+- return undef;
+- }elsif($list->{'admin'}{'status'} eq 'pending') {
+- &wwslog('info','do_close_list: closing a pending list makes it purged');
+- $list->purge($param->{'user'}{'email'});
+- &report::notice_report_web('list_purged',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+- return 'home';
+- }else{
+- $list->close($param->{'user'}{'email'});
+- &report::notice_report_web('list_closed',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+- return 'admin';
+- }
+-
+- }
+-
+- sub do_restore_list {
+- &wwslog('info', 'do_restore_list()');
+-
+-
+- unless ($list->{'admin'}{'status'} eq 'closed') {
+- &report::reject_report_web('user','not_closed',{},$param->{'action'},$list);
+- &wwslog('info','do_restore_list: list not closed');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'not_closed'});
+- return undef;
+- }
+-
+- ## Change status & save config
+- $list->{'admin'}{'status'} = 'open';
+- $list->save_config($param->{'user'}{'email'});
+-
+- if ($list->{'admin'}{'user_data_source'} eq 'file') {
+- $list->{'users'} = &List::_load_users_file("$list->{'dir'}/subscribers.closed.dump");
+- }elsif ($list->{'admin'}{'user_data_source'} =~ /^(database|include2)$/) {
+- unless (-f "$list->{'dir'}/subscribers.closed.dump") {
+- &wwslog('notice', 'No subscribers to restore');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'no_subscribers'});
+- }
+- my @users = &List::_load_users_file("$list->{'dir'}/subscribers.closed.dump");
+-
+- ## Insert users in database
+- foreach my $user (@users) {
+- $list->add_user($user);
+- }
+- }
+-
+- $list->savestats();
+-
+- my $aliases = &admin::install_aliases($list,$robot);
+- if ($aliases == 1) {
+- $param->{'auto_aliases'} = 1;
+- }else {
+- $param->{'aliases'} = $aliases;
+- $param->{'auto_aliases'} = 0;
+- }
+-
+- &report::notice_report_web('list_restored',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+- return 'admin';
+- }
+-
+-
+- sub get_desc_file {
+- my $file = shift;
+- my $ligne;
+- my %hash;
+-
+- open DESC_FILE,"$file";
+-
+- while ($ligne = <DESC_FILE>) {
+- if ($ligne =~ /^title\s*$/) {
+- #case title of the document
+- while (($ligne = <DESC_FILE>) and ($ligne!~/^\s*$/)) {
+- $ligne =~ /^\s*(\S.*\S)\s*/;
+- $hash{'title'} = $hash{'title'}.$1." ";
+- }
+- }
+-
+-
+-
+- if ($ligne =~ /^creation\s*$/) {
+- #case creation of the document
+- while (($ligne = <DESC_FILE>) and ($ligne!~/^\s*$/)) {
+- if ($ligne =~ /^\s*email\s*(\S*)\s*/) {
+- $hash{'email'} = $1;
+- }
+- if ($ligne =~ /^\s*date_epoch\s*(\d*)\s*/) {
+- $hash{'date'} = $1;
+- }
+-
+- }
+- }
+-
+- if ($ligne =~ /^access\s*$/) {
+- #case access scenari for the document
+- while (($ligne = <DESC_FILE>) and ($ligne!~/^\s*$/)) {
+- if ($ligne =~ /^\s*read\s*(\S*)\s*/) {
+- $hash{'read'} = $1;
+- }
+- if ($ligne =~ /^\s*edit\s*(\S*)\s*/) {
+- $hash{'edit'} = $1;
+- }
+-
+- }
+- }
+-
+- }
+-
+-
+- close DESC_FILE;
+-
+- return %hash;
+-
+- }
+-
+-
+- sub show_cert {
+- return 1;
+- }
+-
+- ## Function synchronize
+- ## Return true if the file in parameter can be overwrited
+- ## false if it has changes since the parameter date_epoch
+- sub synchronize {
+- # args : 'path' , 'date_epoch'
+- my $path = shift;
+- my $date_epoch = shift;
+-
+- my @info = stat $path;
+-
+- return ($date_epoch == $info[9]);
+- }
+-
+-
+- #*******************************************
+- # Function : d_access_control
+- # Description : return a hash with privileges
+- # in read, edit, control
+- # if first parameter require
+- # it
+- #******************************************
+-
+- ## Regulars
+- # read(/) = default (config list)
+- # edit(/) = default (config list)
+- # control(/) = not defined
+-# read(A/B)= (read(A) && read(B)) ||
+- # (author(A) || author(B))
+- # edit = idem read
+- # control (A/B) : author(A) || author(B)
+- # + (set owner A/B) if (empty directory &&
+- # control A)
+-
+-
+- sub d_access_control {
+- # Arguments:
+- # (\%mode,$path)
+- # if mode->{'read'} control access only for read
+- # if mode->{'edit'} control access only for edit
+- # if mode->{'control'} control access only for control
+-
+- # return the hash (
+- # $result{'may'}{'read'} == $result{'may'}{'edit'} == $result{'may'}{'control'} if is_author else :
+- # $result{'may'}{'read'} = 0 or 1 (right or not)
+- # $result{'may'}{'edit'} = 0(not may edit) or 0.5(may edit with moderation) or 1(may edit ) : it is not a boolean anymore
+- # $result{'may'}{'control'} = 0 or 1 (right or not)
+- # $result{'reason'}{'read'} = string for authorization_reject.tt2 when may_read == 0
+- # $result{'reason'}{'edit'} = string for authorization_reject.tt2 when may_edit == 0
+- # $result{'scenario'}{'read'} = scenario name for the document
+- # $result{'scenario'}{'edit'} = scenario name for the document
+-
+-
+- # Result
+- my %result;
+- $result{'reason'} = {};
+-
+- # Control
+-
+- # Arguments
+- my $mode = shift;
+- my $path = shift;
+-
+- &wwslog('debug', "d_access_control(%s, %s)", join('/',%$mode), $path);
+-
+- my $mode_read = $mode->{'read'};
+- my $mode_edit = $mode->{'edit'};
+- my $mode_control = $mode->{'control'};
+-
+- # Useful parameters
+- my $list_name = $list->{'name'};
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+-
+- # document to read
+- my $doc;
+- if ($path) {
+- # the path must have no slash a its end
+- $path =~ /^(.*[^\/])?(\/*)$/;
+- $path = $1;
+- $doc = $shareddir.'/'.$path;
+- } else {
+- $doc = $shareddir;
+- }
+-
+- # Control for editing
+- my $may_read = 1;
+- my $why_not_read = '';
+- my $may_edit = 1;
+- my $why_not_edit = '';
+- my $is_author = 0; # <=> $may_control
+-
+- ## First check privileges on the root shared directory
+- $result{'scenario'}{'read'} = $list->{'admin'}{'shared_doc'}{'d_read'}{'name'};
+- $result{'scenario'}{'edit'} = $list->{'admin'}{'shared_doc'}{'d_edit'}{'name'};
+-
+- ## Privileged owner has all privileges
+- if ($param->{'is_privileged_owner'}) {
+- $result{'may'}{'read'} = 1;
+- $result{'may'}{'edit'} = 1;
+- $result{'may'}{'control'} = 1;
+- return %result;
+- }
+-
+- # if not privileged owner
+- if ($mode_read) {
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $action;
+- if (ref($result) eq 'HASH') {
+- $action = $result->{'action'};
+- $why_not_read = $result->{'reason'};
+- }
+-
+- $may_read = ($action =~ /do_it/i);
+- }
+-
+- if ($mode_edit) {
+- my $result = $list->check_list_authz('shared_doc.d_edit',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $action;
+- if (ref($result) eq 'HASH') {
+- $action = $result->{'action'};
+- $why_not_edit = $result->{'reason'};
+- }
+-
+- #edit = 0, 0.5 or 1
+- $may_edit = &find_edit_mode($action);
+- $why_not_edit = '' if ($may_edit);
+- }
+-
+- ## Only authenticated users can edit files
+- unless ($param->{'user'}{'email'}) {
+- $may_edit = 0;
+- $why_not_edit = 'not_authenticated';
+- }
+-
+-# if ($mode_control) {
+-# $result{'may'}{'control'} = 0;
+-# }
+-
+- my $current_path = $path;
+- my $current_document;
+- my %desc_hash;
+- my $user = $param->{'user'}{'email'} || 'nobody';
+-
+- while ($current_path ne "" && $current_path ne '/') {
+- # no description file found yet
+- my $def_desc_file = 0;
+- my $desc_file;
+-
+- $current_path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- $current_document = $3;
+- my $next_path = $1;
+-
+- # opening of the description file appropriated
+- if (-d $shareddir.'/'.$current_path) {
+- # case directory
+-
+- # unless ($slash) {
+- $current_path = $current_path.'/';
+- # }
+-
+- if (-e "$shareddir/$current_path.desc"){
+- $desc_file = $shareddir.'/'.$current_path.".desc";
+- $def_desc_file = 1;
+- }
+-
+- }else {
+- # case file
+- if (-e "$shareddir/$next_path.desc.$3"){
+- $desc_file = $shareddir.'/'.$next_path.".desc.".$3;
+- $def_desc_file = 1;
+- }
+- }
+-
+- if ($def_desc_file) {
+- # a description file was found
+- # loading of acces information
+-
+- %desc_hash = &get_desc_file($desc_file);
+-
+- if ($mode_read) {
+-
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario'=> $desc_hash{'read'}});
+- my $action;
+- if (ref($result) eq 'HASH') {
+- $action = $result->{'action'};
+- $why_not_read = $result->{'reason'};
+- }
+-
+- $may_read = $may_read && ( $action=~ /do_it/i);
+- $why_not_read = '' if ($may_read);
+- }
+-
+- if ($mode_edit) {
+- my $result = $list->check_list_authz('shared_doc.d_edit',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario'=> $desc_hash{'edit'}});
+- my $action_edit;
+- if (ref($result) eq 'HASH') {
+- $action_edit = $result->{'action'};
+- $why_not_edit = $result->{'reason'};
+- }
+-
+-
+- # $may_edit = 0, 0.5 or 1
+- my $may_action_edit = &find_edit_mode($action_edit);
+- $may_edit = &merge_edit($may_edit,$may_action_edit);
+- $why_not_edit = '' if ($may_edit);
+-
+-
+- }
+-
+- ## Only authenticated users can edit files
+- unless ($param->{'user'}{'email'}) {
+- $may_edit = 0;
+- $why_not_edit = 'not_authenticated';
+- }
+-
+- $is_author = $is_author || ($user eq $desc_hash{'email'});
+-
+- unless (defined $result{'scenario'}{'read'}) {
+- $result{'scenario'}{'read'} = $desc_hash{'read'};
+- $result{'scenario'}{'edit'} = $desc_hash{'edit'};
+- }
+-
+- ## Author has all privileges
+- if ($is_author) {
+- $result{'may'}{'read'} = 1;
+- $result{'may'}{'edit'} = 1;
+- $result{'may'}{'control'} = 1;
+- return %result;
+- }
+-
+- }
+-
+- # truncate the path for the while
+- $current_path = $next_path;
+- }
+-
+- if ($mode_read) {
+- $result{'may'}{'read'} = $may_read;
+- $result{'reason'}{'read'} = $why_not_read;
+- }
+-
+- if ($mode_edit) {
+- $result{'may'}{'edit'} = $may_edit;
+- $result{'reason'}{'edit'} = $why_not_edit;
+- }
+-
+-# if ($mode_control) {
+-# $result{'may'}{'control'} = 0;
+-# }
+-
+-
+-
+- return %result;
+- }
+-
+-## return the mode of editing included in $action : 0, 0.5 or 1
+-sub find_edit_mode{
+- my $action=shift;
+-
+- my $result;
+- if ($action =~ /editor/i){
+- $result = 0.5;
+- } elsif ($action =~ /do_it/i){
+- $result = 1;
+- } else {
+- $result = 0;
+- }
+- return $result;
+-}
+-
+-## return the mode of editing : 0, 0.5 or 1 :
+-# do the merging between 2 args of right access edit : "0" > "0.5" > "1"
+-# instead of a "and" between two booleans : the most restrictive right is
+-# imposed
+-sub merge_edit{
+- my $arg1=shift;
+- my $arg2=shift;
+- my $result;
+-
+- if ($arg1 == 0 || $arg2 == 0){
+- $result = 0;
+- }elsif ($arg1 == 0.5 || $arg2 == 0.5){
+- $result = 0.5;
+- }else {
+- $result = 1;
+- }
+- return $result;
+-}
+-
+-
+-
+-
+- # create the root shared document
+- sub do_d_admin {
+- &wwslog('info', 'do_d_admin(%s,%s)', $in{'list'}, $in{'d_admin'});
+-
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$in{'path'});
+-
+-
+- my $dir = $list->{'dir'};
+-
+- unless ($access{'may'}{'edit'}) {
+- &wwslog('info',"do_d_admin : permission denied for $param->{'user'}{'email'} ");
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- if ($in{'d_admin'} eq 'create') {
+-
+- unless ($list->create_shared()) {
+- &wwslog('info',"do_d_admin : could not create the shared");
+- &report::reject_report_web('intern','create_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- return 'd_read';
+-
+- }elsif($in{'d_admin'} eq 'restore') {
+- unless (-e "$dir/pending.shared") {
+- &wwslog('info',"do_d_admin : restore; $dir/pending.shared not found");
+- &report::reject_report_web('intern','restore_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- if (-e "$dir/shared") {
+- &wwslog('info',"do_d_admin : restore; $dir/shared already exist");
+- &report::reject_report_web('intern','restore_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- unless (rename ("$dir/pending.shared", "$dir/shared")){
+- &wwslog('info',"do_d_admin : restore; unable to rename $dir/pending.shared");
+- &report::reject_report_web('intern','restore_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+- return 'd_read';
+- }elsif($in{'d_admin'} eq 'delete') {
+- unless (-e "$dir/shared") {
+- &wwslog('info',"do_d_admin : restore; $dir/shared not found");
+- &report::reject_report_web('intern','delete_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- if (-e "$dir/pending.shared") {
+- &wwslog('info',"do_d_admin : delete ; $dir/pending.shared already exist");
+- &report::reject_report_web('intern','delete_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- unless (rename ("$dir/shared", "$dir/pending.shared")){
+- &wwslog('info',"do_d_admin : restore; unable to rename $dir/shared");
+- &report::reject_report_web('intern','delete_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+- return 'admin';
+- }
+-
+- # Function which sorts a hash of documents
+- # Sort by various parameters
+- sub by_order {
+- my $order = shift;
+- my $hash = shift;
+- # $order = 'order_by_size'/'order_by_doc'/'order_by_author'/'order_by_date'
+-
+- if ($order eq 'order_by_doc') {
+- $hash->{$a}{'doc'} cmp $hash->{$b}{'doc'}
+- or $hash->{$b}{'date_epoch'} <=> $hash->{$a}{'date_epoch'};
+- }
+- elsif ($order eq 'order_by_author') {
+- $hash->{$a}{'author'} cmp $hash->{$b}{'author'}
+- or $hash->{$b}{'date_epoch'} <=> $hash->{$a}{'date_epoch'};
+- }
+- elsif ($order eq 'order_by_size') {
+- $hash->{$a}{'size'} <=> $hash->{$b}{'size'}
+- or $hash->{$b}{'date_epoch'} <=> $hash->{$a}{'date_epoch'};
+- }
+- elsif ($order eq 'order_by_date') {
+- $hash->{$b}{'date_epoch'} <=> $hash->{$a}{'date_epoch'} or $a cmp $b;
+- }
+-
+- else {
+- $a cmp $b;
+- }
+- }
+-
+-
+- #*******************************************
+-# Function : do_d_read
+- # Description : reads a file or a directory
+- #******************************************
+-##
+-## Function do_d_read
+-sub do_d_read {
+- &wwslog('info', 'do_d_read(%s)', $in{'path'});
+-
+- ### Useful variables
+-
+- # current list / current shared directory
+- my $list_name = $list->{'name'};
+-
+- # relative path / directory shared of the document
+- my $path = &no_slash_end($in{'path'});
+-
+- # moderation
+- my $visible_path = &make_visible_path($path);
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- # document to read
+- my $doc;
+- if ($path) {
+- $doc = $shareddir.'/'.$path;
+- } else {
+- $doc = $shareddir;
+- }
+-
+- ### is list open ?
+- unless ($list->{'admin'}{'status'} eq 'open'){
+- &report::reject_report_web('user','list_not_open',{'status' => $list->{'admin'}{'status'}},$param->{'action'},$list);
+- &wwslog('err','d_read : access denied for %s because list is not open', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- ### Document exists ?
+- unless (-r "$doc") {
+- &wwslog('err',"do_d_read : unable to read $shareddir/$path : no such file or directory");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ### Document has non-size zero?
+- unless (-s "$doc") {
+- &wwslog('err',"do_d_read : unable to read $shareddir/$path : empty document");
+- &report::reject_report_web('user','empty_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ### Document isn't a description file
+- unless ($path !~ /\.desc/) {
+- &wwslog('err',"do_d_read : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ### Access control
+- my %mode;
+- $mode{'read'} = 1;
+- $mode{'edit'} = 1;
+- $mode{'control'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+- my $may_read = $access{'may'}{'read'};
+- unless ($may_read) {
+- &report::reject_report_web('auth',$access{'reason'}{'read'},{},$param->{'action'},$list);
+- &wwslog('err','d_read : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- my $may_edit = $access{'may'}{'edit'};
+- my $may_control = $access{'may'}{'control'};
+-
+-
+- ### File or directory ?
+-
+- if (!(-d $doc)) {
+- my @tokens = split /\//,$doc;
+- my $filename = $tokens[$#tokens];
+-
+- ## Jump to the URL
+- if ($filename =~ /^\..*\.(\w+)\.moderate$/) {
+- $param->{'file_extension'} = $1;
+- }elsif ($filename =~ /^.*\.(\w+)$/) {
+- $param->{'file_extension'} = $1;
+- }
+-
+- if ($param->{'file_extension'} eq 'url') {
+- open DOC, $doc;
+- my $url = <DOC>;
+- close DOC;
+- chomp $url;
+- $param->{'redirect_to'} = $url;
+- return 1;
+- }else {
+- # parameters for the template file
+- # view a file
+- $param->{'file'} = $doc;
+- $param->{'bypass'} = 1;
+- return 1;
+- }
+- }else { # directory
+- # verification of the URL (the path must have a slash at its end)
+- # if ($ENV{'PATH_INFO'} !~ /\/$/) {
+- # $param->{'redirect_to'} = "$param->{'base_url'}$param->{'path_cgi'}/d_read/$list_name/";
+- # return 1;
+- # }
+-
+- ## parameters of the current directory
+- if ($path && (-e "$doc/.desc")) {
+- my %desc_hash = &get_desc_file("$doc/.desc");
+- $param->{'doc_owner'} = $desc_hash{'email'};
+- $param->{'doc_title'} = $desc_hash{'title'};
+- }
+- my @info = stat $doc;
+- $param->{'doc_date'} = gettext_strftime "%d %b %Y", localtime($info[9]);
+-
+-
+- # listing of all the shared documents of the directory
+- unless (opendir DIR, "$doc") {
+- &report::reject_report_web('intern','cannot_open_dir',{'dir' => $doc },$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_read : cannot open $doc : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # array of entry of the directory DIR
+- my @tmpdir = readdir DIR;
+- closedir DIR;
+-
+- my $dir = &get_directory_content(\@tmpdir,$param->{'user'}{'email'},$list,$doc);
+-
+- # empty directory?
+- $param->{'empty'} = ($#{$dir} == -1);
+-
+- # subdirectories hash
+- my %subdirs;
+- # file hash
+- my %files;
+-
+- ## for the exception of index.html
+- # name of the file "index.html" if exists in the directory read
+- my $indexhtml;
+-
+- # boolean : one of the subdirectories or files inside
+- # can be edited -> normal mode of read -> d_read.tt2;
+- my $normal_mode;
+-
+-
+- my $path_doc;
+- my %desc_hash;
+- my $may, my $def_desc;
+- my $user = $param->{'user'}{'email'} || 'nobody';
+-
+- foreach my $d (@{$dir}) {
+-
+- # current document
+- my $path_doc = "$doc/$d";
+-
+- #case subdirectory
+- if (-d $path_doc) {
+-
+- # last update
+- my @info = stat $path_doc;
+-
+- if (-e "$path_doc/.desc") {
+-
+- # check access permission for reading
+- %desc_hash = &get_desc_file("$path_doc/.desc");
+-
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario' => $desc_hash{'read'}});
+- my $action;
+- $action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- if (($user eq $desc_hash{'email'}) || ($may_control) ||
+- ($action =~ /do_it/i)) {
+-
+- $subdirs{$d}{'date_epoch'} = $info[9];
+- $subdirs{$d}{'date'} = gettext_strftime "%d %b %Y", localtime($info[9]);
+-
+- # Case read authorized : fill the hash
+- $subdirs{$d}{'icon'} = $icon_table{'folder'};
+-
+- $subdirs{$d}{'doc'} = &make_visible_path($d);
+- $subdirs{$d}{'escaped_doc'} = &tools::escape_docname($d, '/');
+-
+- # size of the doc
+- $subdirs{$d}{'size'} = (-s $path_doc)/1000;
+-
+- # description
+- $subdirs{$d}{'title'} = $desc_hash{'title'};
+- $subdirs{$d}{'escaped_title'}=&tools::escape_html($desc_hash{'title'});
+-
+- # Author
+- if ($desc_hash{'email'}) {
+- $subdirs{$d}{'author'} = $desc_hash{'email'};
+- $subdirs{$d}{'author_mailto'} = &mailto($list,$desc_hash{'email'});
+- $subdirs{$d}{'author_known'} = 1;
+- }
+-
+- # if the file can be read, check for edit access & edit description files access
+- ## only authenticated users can edit a file
+-
+- if ($param->{'user'}{'email'}) {
+- my $result = $list->check_list_authz('shared_doc.d_edit',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario' => $desc_hash{'edit'}});
+- my $action_edit;
+- $action_edit = $result->{'action'} if (ref($result) eq 'HASH');
+- #may_action_edit = 0, 0.5 or 1
+- my $may_action_edit=&find_edit_mode($action_edit);
+- $may_action_edit=&merge_edit($may_action_edit,$may_edit);
+-
+- if ($may_control || ($user eq $desc_hash{'email'})){
+-
+- $subdirs{$d}{'edit'} = 1;# or = $may_action_edit ?
+- # if index.html, must know if something can be edit in the dir
+- $normal_mode = 1;
+- } elsif ($may_action_edit != 0) {
+- # $may_action_edit = 0.5 or 1
+- $subdirs{$d}{'edit'} = $may_action_edit;
+- # if index.html, must know if something can be edit in the dir
+- $normal_mode = 1;
+- }
+- }
+-
+- if ($may_control || ($user eq $desc_hash{'email'})) {
+- $subdirs{$d}{'control'} = 1;
+- }
+-
+- }
+- } else {
+- # no description file = no need to check access for read
+- # access for edit and control
+-
+- if ($may_control) {
+- $subdirs{$d}{'edit'} = 1; # or = $may_action_edit ?
+- $normal_mode = 1;
+- } elsif ($may_edit !=0) {
+- # $may_action_edit = 1 or 0.5
+- $subdirs{$d}{'edit'} = $may_edit;
+- $normal_mode = 1;
+- }
+-
+- if ($may_control) {$subdirs{$d}{'control'} = 1;}
+- }
+-
+- }else {
+- # case file
+- $may = 1;
+- $def_desc = 0;
+-
+- if (-e "$doc/.desc.$d") {
+- # a desc file was found
+- $def_desc = 1;
+-
+- # check access permission
+- %desc_hash = &get_desc_file("$doc/.desc.$d");
+-
+-
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario' => $desc_hash{'read'}});
+- my $action;
+- $action = $result->{'action'} if (ref($result) eq 'HASH');
+- unless (($user eq $desc_hash{'email'}) || ($may_control) ||
+- ($action =~ /do_it/i)) {
+- $may = 0;
+- }
+- }
+-
+- # if permission or no description file
+- if ($may) {
+- $path_doc =~ /^([^\/]*\/)*([^\/]+)\.([^\/]+)$/;
+-
+- ## Bookmark
+- if (($path_doc =~ /\.url$/) || ($path_doc =~ /\.url\.moderate$/)) {
+- open DOC, $path_doc;
+- my $url = <DOC>;
+- close DOC;
+- chomp $url;
+- $files{$d}{'url'} = $url;
+- $files{$d}{'anchor'} = &make_visible_path($d);
+- $files{$d}{'icon'} = $icon_table{'url'};
+-
+- ## MIME - TYPES : icons for template
+- }elsif (my $type = $mime_types->{$3}) {
+- # type of the file and apache icon
+- $type =~ /^([\w\-]+)\/([\w\-]+)$/;
+- my $mimet = $1;
+- my $subt = $2;
+- if ($subt) {
+- if ($subt =~ /^octet-stream$/) {
+- $mimet = 'octet-stream';
+- $subt = 'binary';
+- }
+- $files{$d}{'type'} = "$subt file";
+- }
+- $files{$d}{'icon'} = $icon_table{$mimet} || $icon_table{'unknown'};
+- } else {
+- # unknown file type
+- $files{$d}{'icon'} = $icon_table{'unknown'};
+- }
+-
+- ## case html
+- if ($3 =~ /^html?$/i) {
+- $files{$d}{'html'} = 1;
+- $files{$d}{'type'} = 'html file';
+- $files{$d}{'icon'} = $icon_table{'text'};
+- }
+- ## exception of index.html
+- if ($d =~ /^(index\.html?)$/i) {
+- $indexhtml = $1;
+- }
+-
+- ## Access control for edit and control
+- if ($def_desc) {
+- # check access for edit and control the file
+- ## Only authenticated users can edit files
+-
+- if ($param->{'user'}{'email'}) {
+- my $result= $list->check_list_authz('shared_doc.d_edit',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario' => $desc_hash{'edit'}});
+- my $action_edit;
+- $action_edit = $result->{'action'} if (ref($result) eq 'HASH');
+- #may_action_edit = 0, 0.5 or 1
+- my $may_action_edit=&find_edit_mode($action_edit);
+- $may_action_edit=&merge_edit($may_action_edit,$may_edit);
+-
+- if ($may_control || ($user eq $desc_hash{'email'})){
+- $normal_mode = 1;
+- $files{$d}{'edit'} = 1; # or = $may_action_edit ?
+- } elsif ($may_action_edit != 0){
+- # $may_action_edit = 1 or 0.5
+- $normal_mode = 1;
+- $files{$d}{'edit'} = $may_action_edit;
+- }
+-
+- if (($user eq $desc_hash{'email'}) || $may_control) {
+- $files{$d}{'control'} = 1;
+- }
+-
+- # fill the file hash
+- # description of the file
+- $files{$d}{'title'} = $desc_hash{'title'};
+- $files{$d}{'escaped_title'}=&tools::escape_html($desc_hash{'title'});
+- # author
+- if ($desc_hash{'email'}) {
+- $files{$d}{'author'} = $desc_hash{'email'};
+- $files{$d}{'author_known'} = 1;
+- $files{$d}{'author_mailto'} = &mailto($list,$desc_hash{'email'});
+- }
+- } else {
+- if ($may_edit!=0) {
+- $files{$d}{'edit'} = $may_edit ;
+- $normal_mode = 1;
+- }
+- if ($may_control) {$files{$d}{'control'} = 1;}
+- }
+-
+- # name of the file
+- if ($d =~ /^(\.).*(.moderate)$/) {
+- # file not yet moderated can be seen by its author
+- $files{$d}{'doc'} = &make_visible_path($d);
+- $files{$d}{'moderate'} = 1;
+- } else {
+- $files{$d}{'doc'} = &make_visible_path($d);
+- }
+- $files{$d}{'escaped_doc'} = &tools::escape_docname($d, '/');
+-
+- # last update
+- my @info = stat $path_doc;
+- $files{$d}{'date_epoch'} = $info[9];
+- $files{$d}{'date'} = gettext_strftime "%d %b %Y", localtime($info[9]);
+- # size
+- $files{$d}{'size'} = (-s $path_doc)/1000;
+- }
+- }
+- }
+-
+- }
+-
+- ### Exception : index.html
+- if ($indexhtml) {
+- unless ($normal_mode) {
+- $param->{'file_extension'} = 'html';
+- $param->{'bypass'} = 1;
+- $param->{'file'} = "$doc/$indexhtml";
+- return 1;
+- }
+- }
+-
+- ## to sort subdirs
+- my @sort_subdirs;
+- my $order = $in{'order'} || 'order_by_doc';
+- $param->{'order_by'} = $order;
+- foreach my $k (sort {by_order($order,\%subdirs)} keys %subdirs) {
+- push @sort_subdirs, $subdirs{$k};
+- }
+-
+- ## to sort files
+- my @sort_files;
+- foreach my $k (sort {by_order($order,\%files)} keys %files) {
+- push @sort_files, $files{$k};
+- }
+-
+- # parameters for the template file
+- $param->{'list'} = $list_name;
+-
+- $param->{'may_edit'} = $may_edit;
+- $param->{'may_control'} = $may_control;
+-
+- if ($path) {
+- # building of the parent directory path
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)$/) {
+- $param->{'father'} = $1;
+- }else {
+- $param->{'father'} = '';
+- }
+- $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
+-
+-
+- # Parameters for the description
+- if (-e "$doc/.desc") {
+- my @info = stat "$doc/.desc";
+- $param->{'serial_desc'} = $info[9];
+- my %desc_hash = &get_desc_file("$doc/.desc");
+- $param->{'description'} = $desc_hash{'title'};
+- }
+-
+- $param->{'path'} = $path;
+- $param->{'visible_path'} = $visible_path;
+- $param->{'escaped_path'} = &tools::escape_docname($param->{'path'}, '/');
+- }
+- if (scalar keys %subdirs) {
+- $param->{'sort_subdirs'} = \@sort_subdirs;
+- }
+- if (scalar keys %files) {
+- $param->{'sort_files'} = \@sort_files;
+- }
+- }
+- $param->{'father_icon'} = $icon_table{'father'};
+- $param->{'sort_icon'} = $icon_table{'sort'};
+-
+-
+- ## Show expert commands / user page
+-
+- # for the curent directory
+- if ($may_edit == 0 && $may_control == 0) {
+- $param->{'has_dir_rights'} = 0;
+- } else {
+- $param->{'has_dir_rights'} = 1;
+- if ($may_edit == 1) { # (is_author || ! moderated)
+- $param->{'total_edit'} = 1;
+- }
+- }
+-
+- # set the page mode
+- if ($in{'show_expert_page'} && $param->{'has_dir_rights'}) {
+- $session->{'shared_mode'}='expert';
+- if ($param->{'user'}{'prefs'}{'shared_mode'} ne 'expert') {
+- # update user pref as soon as connected user change shared mode
+- $param->{'user'}{'prefs'}{'shared_mode'} = 'expert';
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+- $param->{'expert_page'} = 1;
+-
+- } elsif ($in{'show_user_page'}) {
+- $session->{'shared_mode'}='basic';
+- if ($param->{'user'}{'prefs'}{'shared_mode'} ne 'basic') {
+- # update user pref as soon as connected user change shared mode
+- $param->{'user'}{'prefs'}{'shared_mode'} = 'basic';
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+- $param->{'expert_page'} = 0;
+- } else {
+- if ( $session->{'shared_mode'} eq 'expert' && $param->{'has_dir_rights'}) {
+- $param->{'expert_page'} = 1;
+- } else {
+- $param->{'expert_page'} = 0;
+- }
+- }
+-
+- #open TMP, ">/tmp/dump1";
+- #&tools::dump_var($param, 0,\*TMP);
+- #close TMP;
+-
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+-
+- return 1;
+-}
+-
+-## return a ref on an array of file (or subdirecties) to show to user
+-sub get_directory_content {
+- my $tmpdir = shift;
+- my $user = shift;
+- my $list = shift;
+- my $doc = shift;
+-
+- # array of file not hidden
+- my @dir = grep !/^\./, @$tmpdir;
+-
+- # array with documents not yet moderated
+- my @moderate_dir = grep (/(\.moderate)$/, @$tmpdir);
+- @moderate_dir = grep (!/^\.desc\./, @moderate_dir);
+-
+- # the editor can see file not yet moderated
+- # a user can see file not yet moderated if he is th owner of these files
+- if ($list->am_i('editor',$user)) {
+- push(@dir,@moderate_dir);
+- }else {
+- my @privatedir = &select_my_files($user,$doc,\@moderate_dir);
+- push(@dir,@privatedir);
+- }
+-
+- return \@dir;
+-}
+-
+-
+-## return an array that contains only file from @$refdir that belongs to $user
+-sub select_my_files {
+- my ($user,$path,$refdir)=@_;
+- my @new_dir;
+-
+- foreach my $d (@$refdir) {
+- if (-e "$path/.desc.$d") {
+- my %desc_hash = &get_desc_file("$path/.desc.$d");
+- if ($user eq $desc_hash{'email'}){
+- $new_dir[$#new_dir+1]=$d;
+- }
+- }
+- }
+- return @new_dir;
+-}
+-
+- ## Useful function to get off the slash at the end of the path
+- ## at its end
+- sub no_slash_end {
+- my $path = shift;
+-
+- ## supress ending '/'
+- $path =~ s/\/+$//;
+-
+- return $path;
+- }
+-
+-## return a visible path from a moderated file or not
+-sub make_visible_path {
+- my $path = shift;
+-
+- my $visible_path = $path;
+-
+- if ($path =~ /\.url(\.moderate)?$/){
+- if ($path =~ /^([^\/]*\/)*([^\/]+)\.([^\/]+)$/) {
+- $visible_path =~ s/\.moderate$//;
+- $visible_path =~ s/^\.//;
+- $visible_path =~ s/\.url$//;
+- }
+-
+- }elsif ($path =~ /\.moderate$/){
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
+- my $name = $3;
+- $name =~ s/^\.//;
+- $name =~ s/\.moderate//;
+- $visible_path = "$2"."$name";
+- }
+- }
+-
+- ## Qdecode the visible path
+- return &tools::qdecode_filename($visible_path);
+-}
+-
+-
+- ## Access to latest shared documents
+-sub do_latest_d_read {
+- &wwslog('info', 'do_latest_d_read(%s,%s,%s)', $in{'list'}, $in{'for'}, $in{'count'});
+-
+- ### is list open ?
+- unless ($list->{'admin'}{'status'} eq 'open'){
+- &report::reject_report_web('user','list_not_open',{'status' => $list->{'admin'}{'status'}},$param->{'action'},$list);
+- &wwslog('err','d_latest_d_read : access denied for %s because list is not open', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- ### shared exist ?
+- my $shareddir = $list->{'dir'}.'/shared';
+- unless (-r "$shareddir") {
+- &wwslog('err',"do_latest_d_read : unable to read $shareddir : no such file or directory");
+- &report::reject_report_web('user','no_shared',{},$param->{'action'},$list);
+- return undef;
+- }
+-
+- ### Document has non-size zero?
+- unless (-s "$shareddir") {
+- &wwslog('err',"do_latest_d_read : unable to read $shareddir : empty document");
+- &report::reject_report_web('user','shared_empty',{},$param->{'action'},$list);
+- return undef;
+- }
+-
+- ### Access control
+- my %mode;
+- $mode{'read'} = 1;
+- $mode{'control'} = 1;
+-
+- my %access = &d_access_control(\%mode,$shareddir);
+- unless ($access{'may'}{'read'}) {
+- &report::reject_report_web('auth',$access{'reason'}{'read'},{},$param->{'action'},$list);
+- &wwslog('err','latest_d_read : access denied for %s', $param->{'user'}{'email'});
+- return undef;
+- }
+-
+- ## parameters of the query
+- my $today = time;
+-
+- my $oldest_day;
+- if (defined $in{'for'}) {
+- $oldest_day = $today - (86400 * ($in{'for'}));
+- $param->{'for'} = $in{'for'};
+- unless ($oldest_day >= 0){
+- &report::reject_report_web('user','nb_days_to_much',{'nb_days' => $in{'for'} },$param->{'action'},$list);
+- &wwslog('err','do_latest_d_read: parameter "for" is too big"');
+- }
+- }
+-
+- my $nb_doc;
+- my $NB_DOC_MAX = 100;
+- if (defined $in{'count'}) {
+- if ($in{'count'} > $NB_DOC_MAX) {
+- $in{'count'} = $NB_DOC_MAX;
+- }
+- $param->{'count'} = $in{'count'};
+- $nb_doc = $in{'count'};
+- } else {
+- $nb_doc = $NB_DOC_MAX;
+- }
+-
+- my $documents;
+- unless ($documents = &directory_browsing('',$oldest_day,$access{'may'}{'control'})) {
+- &wwslog('err',"do_d_latest_d_read($list) : impossible to browse shared");
+- &report::reject_report_web('intern','browse_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- return undef;
+- }
+-
+- @$documents = sort ({$b->{'date_epoch'} <=> $a->{'date_epoch'}} @$documents);
+-
+- @{$param->{'documents'}} = splice(@$documents,0,$nb_doc);
+-
+- return 1;
+- }
+-
+-## browse a directory recursively and return documents younger than $oldest_day
+- sub directory_browsing {
+- my ($dir,$oldest_day,$may_control) = @_;
+- &wwslog('debug2',"directory_browsing($dir,$oldest_day)");
+-
+- my @result;
+- my $shareddir = $list->{'dir'}.'/shared';
+- my $path_dir = "$shareddir/$dir";
+-
+- ## listing of all the shared documents of the directory
+- unless (opendir DIR, "$path_dir") {
+- &wwslog('err',"directory_browsing($dir) : cannot open the directory : $!");
+- return undef;
+- }
+-
+- my @tmpdir = readdir DIR;
+- closedir DIR;
+-
+- # array of file not hidden
+- my @directory = grep !/^\./, @tmpdir;
+-
+- my $user = $param->{'user'}{'email'} || 'nobody';
+-
+- ## browsing
+- foreach my $d (@directory) {
+- my $path_d = "$path_dir/$d";
+-
+- #case subdirectory
+- if (-d $path_d) {
+- if (-e "$path_d/.desc") {
+- # check access permission for reading
+- my %desc_hash = &get_desc_file("$path_d/.desc");
+-
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario' => $desc_hash{'read'}});
+- my $action;
+- $action = $result->{'action'} if (ref($result) eq 'HASH');
+- if (($user eq $desc_hash{'email'}) || ($may_control) ||
+- ($action =~ /do_it/i)) {
+- my $content_d;
+- unless($content_d = &directory_browsing("$dir/$d",$oldest_day)) {
+- &wwslog('err',"directory_browsing($dir) : impossible to browse subdirectory $d");
+- next;
+- }
+- if (ref($content_d) eq "ARRAY") {
+- push @result,@$content_d;
+- }
+- }
+- }
+-
+- #case file
+- } else {
+-
+- my %file_info;
+-
+- ## last update
+- my @info = stat $path_d;
+- $file_info{'date_epoch'} = $info[9];
+-
+- if ($file_info{'date_epoch'} < $oldest_day) {
+- next;
+- }
+-
+- $file_info{'last_update'} = gettext_strftime "%d %b %Y", localtime($info[9]);
+-
+- ## exception of index.html
+- if ($d =~ /^(index\.html?)$/i) {
+- next;
+- }
+-
+- my $may = 1;
+- my $def_desc = 0;
+- my %desc_hash;
+-
+- if (-e "$path_dir/.desc.$d") {
+- # a desc file was found
+- $def_desc = 1;
+-
+- # check access permission
+- %desc_hash = &get_desc_file("$path_dir/.desc.$d");
+-
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario' => $desc_hash{'read'}});
+- my $action;
+- $action = $result->{'action'} if (ref($result) eq 'HASH');
+- unless (($user eq $desc_hash{'email'}) || ($may_control) ||
+- ($action =~ /do_it/i)) {
+- $may = 0;
+- }
+- }
+-
+- # if permission or no description file
+- if ($may) {
+- $path_d =~ /^([^\/]*\/)*([^\/]+)\.([^\/]+)$/;
+-
+- ## Bookmark
+- if ($path_d =~ /\.url$/) {
+- open DOC, $path_d;
+- my $url = <DOC>;
+- close DOC;
+- chomp $url;
+- $file_info{'url'} = $url;
+- $file_info{'anchor'} = &make_visible_path($d);
+- $file_info{'icon'} = $icon_table{'url'};
+-
+- ## MIME - TYPES : icons for template
+- }elsif (my $type = $mime_types->{$3}) {
+- # type of the file and apache icon
+- $type =~ /^([\w\-]+)\/([\w\-]+)$/;
+- my $mimet = $1;
+- my $subt = $2;
+- if ($subt) {
+- if ($subt =~ /^octet-stream$/) {
+- $mimet = 'octet-stream';
+- $subt = 'binary';
+- }
+- }
+- $file_info{'icon'} = $icon_table{$mimet} || $icon_table{'unknown'};
+-
+- ## UNKNOWN FILE TYPE
+- } else {
+- $file_info{'icon'} = $icon_table{'unknown'};
+- }
+-
+- ## case html
+- if ($3 =~ /^html?$/i) {
+- $file_info{'html'} = 1;
+- $file_info{'icon'} = $icon_table{'text'};
+- }
+-
+- ## name of the file
+- $file_info{'name'} = &make_visible_path($d);
+- $file_info{'escaped_name'} = &tools::escape_docname($d, '/');
+-
+- ## content_directory
+- if ($dir) {
+- $file_info{'content_dir'} = &make_visible_path($dir);
+- } else {
+- $file_info{'content_dir'} = "/";
+- }
+- $file_info{'escaped_content_dir'} = &tools::escape_docname($dir,'/');
+-
+- if ($def_desc) {
+- ## description
+- $file_info{'title'} = $desc_hash{'title'};
+- $file_info{'escaped_title'}=&tools::escape_html($desc_hash{'title'});
+-
+- ## author
+- if ($desc_hash{'email'}) {
+- $file_info{'author'} = $desc_hash{'email'};
+- }
+- }
+-
+- push @result,\%file_info;
+- }
+- } # else (file)
+-
+- } # foreach
+-
+- return \@result;
+-
+- }
+-
+- #*******************************************
+- # Function : do_d_editfile
+- # Description : prepares the parameters to
+- # edit a file
+- #*******************************************
+-
+- sub do_d_editfile {
+- &wwslog('info', 'do_d_editfile(%s)', $in{'path'});
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+-
+- my $list_name = $list->{'name'};
+- my $shareddir = $list->{'dir'}.'/shared';
+- my $visible_path = &make_visible_path($path);
+-
+- $param->{'directory'} = -d "$shareddir/$path";
+-
+- # Control
+-
+- unless ($path) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'file name'},$param->{'action'});
+- &wwslog('err','do_d_editfile: no file name');
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return undef;
+- }
+-
+- # Existing document? File?
+- unless (-w "$shareddir/$path") {
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('err',"d_editfile : Cannot edit $shareddir/$path : not an existing file");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'no_file'});
+- return undef;
+- }
+-
+- ### Document isn't a description file?
+- unless ($path !~ /\.desc/) {
+- &wwslog('err',"do_editfile : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- if (($path =~ /\.url$/) ||($path =~ /^\..+\.url.moderate$/)) {
+- ## Get URL of bookmark
+- open URL, "$shareddir/$path";
+- my $url = <URL>;
+- close URL;
+- chomp $url;
+-
+- $param->{'url'} = $url;
+- $visible_path =~ s/\.url$//;
+- }
+-
+- ### is list open ?
+- unless ($list->{'admin'}{'status'} eq 'open'){
+- &report::reject_report_web('user','list_not_open',{'status' => $list->{'admin'}{'status'}},$param->{'action'},$list);
+- &wwslog('err','d_edit : access denied for %s because list is not open', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+- my $may_edit = $access{'may'}{'edit'};
+-
+- unless ($may_edit > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','d_editfile : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'autorization'});
+- return undef;
+- }
+-
+- ## End of controls
+-
+- $param->{'list'} = $list_name;
+- $param->{'path'} = $path;
+- $param->{'visible_path'} = $visible_path;
+-
+- # test if it's a text file
+- if (-T "$shareddir/$path") {
+- $param->{'textfile'} = 1;
+- $param->{'filepath'} = "$shareddir/$path";
+- } else {
+- $param->{'textfile'} = 0;
+- }
+- $param->{'use_htmlarea'} = '1' if (($wwsconf->{'htmlarea_url'}) and ($param->{'textfile'}) and ($path =~ /\.html?/));
+-
+-
+-
+- #Current directory
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
+- $param->{'father'} = $1;
+- }else {
+- $param->{'father'} = '';
+- }
+- $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
+-
+- # Description of the file
+- my $descfile;
+- if (-d "$shareddir/$path") {
+- $descfile = "$shareddir/$1$3/.desc";
+- }else {
+- $descfile = "$shareddir/$1.desc.$3";
+- }
+-
+- if (-e $descfile) {
+- my %desc_hash = &get_desc_file($descfile);
+- $param->{'desc'} = $desc_hash{'title'};
+- $param->{'doc_owner'} = $desc_hash{'email'};
+- ## Synchronization
+- my @info = stat $descfile;
+- $param->{'serial_desc'} = $info[9];
+- }
+-
+- ## Synchronization
+- my @info = stat "$shareddir/$path";
+- $param->{'serial_file'} = $info[9];
+- ## parameters of the current directory
+- $param->{'doc_date'} = gettext_strftime "%d %b %y %H:%M", localtime($info[9]);
+-
+- &tt2::allow_absolute_path();
+-
+- $param->{'father_icon'} = $icon_table{'father'};
+-
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+-
+- return 1;
+- }
+-
+- #*******************************************
+- # Function : do_d_properties
+- # Description : prepares the parameters to
+- # change a file properties
+- #*******************************************
+-
+- sub do_d_properties {
+- &wwslog('info', 'do_d_properties(%s)', $in{'path'});
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+-
+- my $list_name = $list->{'name'};
+- my $shareddir = $list->{'dir'}.'/shared';
+- my $visible_path = &make_visible_path($path);
+-
+- $param->{'directory'} = -d "$shareddir/$path";
+-
+- # Control
+-
+- unless ($path) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'filename'},$param->{'action'});
+- &wwslog('err','do_d_properties: no file name');
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'no_file'});
+- return undef;
+- }
+-
+- # Existing document? File?
+- unless (-w "$shareddir/$path") {
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('err',"do_d_properties : Cannot edit $shareddir/$path : not an existing file");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'no_file'});
+- return undef;
+- }
+-
+- ### Document isn't a description file?
+- unless ($path !~ /\.desc/) {
+- &wwslog('err',"do_d_properties : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- if ($path =~ /\.url$/) {
+- ## Get URL of bookmark
+- open URL, "$shareddir/$path";
+- my $url = <URL>;
+- close URL;
+- chomp $url;
+-
+- $param->{'url'} = $url;
+- }
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+- my $may_edit = $access{'may'}{'edit'};
+-
+- unless ($may_edit > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_properties : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- ## End of controls
+-
+- $param->{'list'} = $list_name;
+- $param->{'path'} = $path;
+- $param->{'visible_path'} = $visible_path;
+-
+- # test if it's a text file
+- if (-T "$shareddir/$path") {
+- $param->{'textfile'} = 1;
+- $param->{'filepath'} = "$shareddir/$path";
+- } else {
+- $param->{'textfile'} = 0;
+- }
+- $param->{'use_htmlarea'} = '1' if (($wwsconf->{'htmlarea_url'}) and ($param->{'textfile'}) and ($path =~ /\.html?/));
+-
+-
+-
+- #Current directory
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
+- $param->{'father'} = $1;
+- }else {
+- $param->{'father'} = '';
+- }
+- $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
+-
+- $param->{'fname'} = &make_visible_path($3);
+- # Description of the file
+- my $descfile;
+- if (-d "$shareddir/$path") {
+- $descfile = "$shareddir/$1$3/.desc";
+- }else {
+- $descfile = "$shareddir/$1.desc.$3";
+- }
+-
+- if (-e $descfile) {
+- my %desc_hash = &get_desc_file($descfile);
+- $param->{'desc'} = $desc_hash{'title'};
+- $param->{'doc_owner'} = $desc_hash{'email'};
+- ## Synchronization
+- my @info = stat $descfile;
+- $param->{'serial_desc'} = $info[9];
+- }
+-
+- ## Synchronization
+- my @info = stat "$shareddir/$path";
+- $param->{'serial_file'} = $info[9];
+- ## parameters of the current directory
+- $param->{'doc_date'} = gettext_strftime "%d %b %y %H:%M", localtime($info[9]);
+-
+- &tt2::allow_absolute_path();
+-
+- $param->{'father_icon'} = $icon_table{'father'};
+-
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+-
+- return 1;
+- }
+-
+- #*******************************************
+- # Function : do_d_describe
+- # Description : Saves the description of
+- # the file
+- #******************************************
+-
+- sub do_d_describe {
+- &wwslog('info', 'do_d_describe(%s)', $in{'path'});
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+- my $visible_path=&make_visible_path($path);
+- my $list_name = $list->{'name'};
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #### Controls
+-
+- ### Document isn't a description file?
+- unless ($path !~ /\.desc/) {
+- &wwslog('info',"do_d_describe : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## the path must not be empty (the description file of the shared directory
+- # doesn't exist)
+- unless ($path) {
+- &report::reject_report_web('intern','cannot_describe_shared_directory',{'path' => $path },$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"d_describe : Cannot describe $shareddir : root directory");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # the file to describe must already exist
+- unless (-e "$shareddir/$path") {
+- &report::reject_report_web('user','no_doc_to_describe',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('info',"d_describe : Unable to describe $shareddir/$path : not an existing document");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'no_file'});
+- return undef;in{'shortname'}
+- }
+-
+- # Access control
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'edit'} > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('info','d_describe : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+-
+- ## End of controls
+-
+- if ($in{'content'} !~ /^\s*$/) {
+-
+- # Description file
+- $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- my $dir = $1;
+- my $file = $3;
+-
+- my $desc_file;
+- if (-d "$shareddir/$path") {
+- $desc_file = "$shareddir/$dir$file/.desc";
+- } else {
+- $desc_file = "$shareddir/$dir.desc.$file";
+- }
+-
+- if (-r "$desc_file"){
+- # if description file already exists : open it and modify it
+- my %desc_hash = &get_desc_file ("$desc_file");
+-
+- # Synchronization
+- unless (&synchronize($desc_file,$in{'serial'})){
+- &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
+- &wwslog('info',"d_describe : Synchronization failed for $desc_file");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # fill the description file
+- unless (open DESC,">$desc_file") {
+- &wwslog('info',"do_d_describe : cannot open $desc_file : $!");
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # information modified
+- print DESC "title\n $in{'content'}\n\n";
+- # information not modified
+- print DESC "access\n read $desc_hash{'read'}\n edit $desc_hash{'edit'}\n\n";
+- print DESC "creation\n";
+- # time
+- print DESC " date_epoch $desc_hash{'date'}\n";
+- # author
+- print DESC " email $desc_hash{'email'}\n\n";
+-
+- close DESC;
+-
+- } else {
+- # Creation of a description file
+- unless (open (DESC,">$desc_file")) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"d_describe : Cannot create description file $desc_file : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- # fill
+- # description
+- print DESC "title\n $in{'content'}\n\n";
+- # date and author
+- my @info = stat "$shareddir/$path";
+- print DESC "creation\n date_epoch ".$info[10]."\n email\n\n";
+- # access rights
+- print DESC "access\n";
+- print DESC " read $access{'scenario'}{'read'}\n";
+- print DESC " edit $access{'scenario'}{'edit'}\n\n";
+-
+- close DESC;
+-
+- }
+-
+- $in{'path'} = &no_slash_end($dir);
+- }
+-
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+-
+- return 'd_read';
+-
+- }
+-
+- #*******************************************
+- # Function : do_d_savefile
+- # Description : Saves a file edited in a
+- # text area
+- #******************************************
+-
+-sub do_d_savefile {
+- &wwslog('info', 'do_d_savefile(%s)', $in{'path'});
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+-
+- if ($in{'url'} &&
+- $in{'previous_action'} eq 'd_read') {
+- $path .= '/'.$in{'name_doc'} . '.url';
+- }
+-
+-
+- my $visible_path = &make_visible_path($path);
+-
+- my $moderated;
+- if ($visible_path ne $path) {
+- $moderated = 1;
+- }
+-
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+-
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #### Controls
+-
+- my $creation = 1 unless (-f "$shareddir/$path");
+-
+- ### Document isn't a description file
+- unless ($path !~ /\.desc/) {
+- &wwslog('err',"do_d_savefile : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'edit'} > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_savefile : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+- #### End of controls
+-
+- if (($in{'content'} =~ /^\s*$/) && ($in{'url'} =~ /^\s*$/)) {
+- &report::reject_report_web('user','no_content',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_savefile : Cannot save file $shareddir/$path : no content");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return undef;
+- }
+-
+- # Synchronization
+- unless ($in{'url'}) { # only for files
+- unless (&synchronize("$shareddir/$path",$in{'serial'})){
+- &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_savefile : Synchronization failed for $shareddir/$path");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- # Renaming of the old file
+-############""" pas les url ?
+- rename ("$shareddir/$path","$shareddir/$path.old")
+- unless ($creation);
+-
+- my $dir;
+- my $file;
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/){
+- $dir = $1;
+- $file = $3;
+- }
+-
+- if ($in{'url'}) {
+-##############
+-# if ($access{'may'}{'edit'} == 0.5) {
+-# open URL, ">$shareddir/$dir.$file.moderate";
+-# }else {
+- open URL, ">$shareddir/$path";
+-# }
+- print URL "$in{'url'}\n";
+- close URL;
+- }else {
+- # Creation of the shared file
+- unless (open FILE, ">$shareddir/$path") {
+- rename("$shareddir/$path.old","$shareddir/$path");
+- &report::reject_report_web('user','cannot_overwrite', {'reason' => $1,
+- 'path' => $visible_path }
+- ,$param->{'action'},$list);
+- &wwslog('err',"do_d_savefile : Cannot open for replace $shareddir/$path : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- print FILE $in{'content'};
+- close FILE;
+- }
+-
+- unlink "$shareddir/$path.old";
+-
+- # Description file
+- if (-e "$shareddir/$dir.desc.$file"){
+-
+- # if description file already exists : open it and modify it
+- my %desc_hash = &get_desc_file ("$shareddir/$dir.desc.$file");
+-
+- open DESC,">$shareddir/$dir.desc.$file";
+-
+- # information not modified
+- print DESC "title\n $desc_hash{'title'}\n\n";
+- print DESC "access\n read $desc_hash{'read'}\n edit $desc_hash{'edit'}\n\n";
+- print DESC "creation\n";
+- # date
+- print DESC ' date_epoch '.$desc_hash{'date'}."\n";
+-
+- # information modified
+- # author
+- print DESC " email $param->{'user'}{'email'}\n\n";
+-
+- close DESC;
+-
+- } else {
+- # Creation of a description file if author is known
+-
+- unless (open (DESC,">$shareddir/$dir.desc.$file")) {
+- &wwslog('info',"do_d_savefile: cannot create description file $shareddir/$dir.desc.$file");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- }
+- # description
+- print DESC "title\n \n\n";
+- # date of creation and author
+- my @info = stat "$shareddir/$path";
+- print DESC "creation\n date_epoch ".$info[10]."\n email $param->{'user'}{'email'}\n\n";
+- # Access
+- print DESC "access\n";
+- print DESC " read $access{'scenario'}{'read'}\n";
+- print DESC " edit $access{'scenario'}{'edit'}\n\n";
+-
+- close DESC;
+- }
+-
+- # shared_moderated
+-#######################
+- if (($access{'may'}{'edit'} == 0.5) && ($creation)) {
+-
+- unless (rename "$shareddir/$path","$shareddir/$dir.$file.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$path",
+- 'new'=>"$shareddir/$dir.$file.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_savefile : Failed to rename $path to $dir.$file.moderate : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- }
+- unless (rename "$shareddir/$dir.desc.$file","$shareddir/$dir.desc..$file.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$dir.desc.$file",
+- 'new'=>"$shareddir/$dir.desc..$file.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_savefile : Failed to rename $dir.desc.$file to $dir.desc..$file.moderate : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- }
+-
+- if (!$in{'url'}){
+- $in{'path'}=$path;
+- $param->{'path'}=$path;
+- }else {
+- $visible_path = $file;
+- $visible_path =~ s/\.url$//
+- }
+-
+- unless ($list->send_notify_to_editor('shared_moderated',{'filename' => $visible_path,
+- 'who' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
+- }
+-
+- &report::notice_report_web('to_moderate', {'path' => $visible_path},$param->{'action'});
+- }
+-
+- &report::notice_report_web('save_success', {'path' => $visible_path},$param->{'action'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+- if ($in{'previous_action'}) {
+- return $in{'previous_action'};
+- }else {
+- $in{'path'} =~ s/([^\/]+)$//;
+- $param->{'path'} =~ s/([^\/]+)$//;
+- return 'd_read';
+- }
+- }
+-
+- #*******************************************
+- # Function : do_d_overwrite
+- # Description : Overwrites a file with a
+- # uploaded file
+- #******************************************
+-
+- sub do_d_overwrite {
+- &wwslog('info', 'do_d_overwrite(%s)', $in{'path'});
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+-
+- my $visible_path = &make_visible_path($path);
+-
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- # Parameters of the uploaded file
+- my $fh = $query->upload('uploaded_file');
+- my $fn = $query->param('uploaded_file');
+-
+- # name of the file
+- my $fname;
+- if ($fn =~ /([^\/\\]+)$/) {
+- $fname = $1;
+- }
+-
+- ### uploaded file must have a name
+- unless ($fname) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'file name'},$param->{'action'});
+- &wwslog('info',"do_d_overwrite : No file specified to overwrite");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'no_file'});
+- return undef;
+- }
+-
+- ####### Controls
+-
+- ### Document isn't a description file?
+- unless ($path !~ /\.desc/) {
+- &wwslog('err',"do_d_overwrite : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # the path to replace must already exist
+- unless (-e "$shareddir/$path") {
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('err',"do_d_overwrite : Unable to overwrite $shareddir/$path : not an existing file");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'no_file'});
+- return undef;
+- }
+-
+- # the path must represent a file
+- if (-d "$shareddir/$path") {
+- &report::reject_report_web('user','doc_already_a_dir',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('err',"do_d_overwrite : Unable to create $shareddir/$path : a directory named $path already exists");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'already_exists'});
+- return undef;
+- }
+-
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'edit'} > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_overwrite : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+- #### End of controls
+-
+- # Synchronization
+- unless (&synchronize("$shareddir/$path",$in{'serial'})){
+- &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_overwrite : Synchronization failed for $shareddir/$path");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # Renaming of the old file
+- rename ("$shareddir/$path","$shareddir/$path.old");
+-
+- # Creation of the shared file
+- unless (open FILE, ">:bytes", "$shareddir/$path") {
+- &report::reject_report_web('user','cannot_overwrite', {'reason' => $!,
+- 'path' => $visible_path }
+- ,$param->{'action'},$list);
+- &wwslog('err',"d_overwrite : Cannot open for replace $shareddir/$path : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'cannot_overwrite'});
+- return undef;
+- }
+- while (<$fh>) {
+- print FILE;
+- }
+- close FILE;
+-
+- # Description file
+- my ($dir, $file);
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
+- $dir = $1;
+- $file = $3;
+- }
+-
+- if (-e "$shareddir/$dir.desc.$file"){
+- # if description file already exists: open it and modify it
+- my %desc_hash = &get_desc_file ("$shareddir/$dir.desc.$file");
+-
+- open DESC,">$shareddir/$dir.desc.$file";
+-
+- # information not modified
+- print DESC "title\n $desc_hash{'title'}\n\n";
+- print DESC "access\n read $desc_hash{'read'}\n edit $desc_hash{'edit'}\n\n";
+- print DESC "creation\n";
+- # time
+- print DESC " date_epoch $desc_hash{'date'}\n";
+- # information modified
+- # author
+- print DESC " email $param->{'user'}{'email'}\n\n";
+-
+- close DESC;
+- } else {
+- # Creation of a description file
+- unless (open (DESC,">$shareddir/$dir.desc.$file")) {
+- &wwslog('info',"do_d_overwrite : Cannot create description file $shareddir/$dir.desc.$file");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- # description
+- print DESC "title\n \n\n";
+- # date of creation and author
+- my @info = stat "$shareddir/$path";
+- print DESC "creation\n date_epoch ".$info[10]."\n email $param->{'user'}{'email'}\n\n";
+- # access rights
+- print DESC "access\n";
+- print DESC " read $access{'scenario'}{'read'}\n";
+- print DESC " edit $access{'scenario'}{'edit'}\n\n";
+-
+- close DESC;
+-
+- }
+-
+- # shared_moderated
+- if (($access{'may'}{'edit'} == 0.5) && ($path eq $visible_path)) {
+- unless (rename "$shareddir/$path","$shareddir/$dir.$file.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$path",
+- 'new'=>"$shareddir/$dir.$file.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_overwrite : Failed to rename $path to $dir.$file.moderate : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- unless (rename "$shareddir/$dir.desc.$file","$shareddir/$dir.desc..$file.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$dir.desc.$file",
+- 'new'=>"$shareddir/$dir.desc..$file.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_overwrite : Failed to rename $dir.desc.$file to $dir.desc..$file.moderate : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- }
+- unless ($list->send_notify_to_editor('shared_moderated',{'filename' => $visible_path,
+- 'who' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
+- }
+- $in{'path'}="$dir.$file.moderate";
+- &report::notice_report_web('to_moderate',{'path' => $visible_path},$param->{'action'});
+- }
+-
+- # Removing of the old file
+- unlink "$shareddir/$path.old";
+-
+- $in{'list'} = $list_name;
+- #$in{'path'} = $dir;
+-
+- # message of success
+- &report::notice_report_web('upload_success', {'path' => $visible_path});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+- return 'd_editfile';
+- }
+-
+- #*******************************************
+- # Function : do_d_upload
+- # Description : Creates a new file with a
+- # uploaded file
+-#******************************************
+-
+- sub do_d_upload {
+- # Parameters of the uploaded file (from d_read.tt2)
+- my $fn = $in{'uploaded_file'};
+-
+- # name of the file, without path
+- my ($fname, $visible_fname);
+- if ($fn =~ /([^\/\\]+)$/) {
+- $fname = &tools::qencode_filename($1);
+- $visible_fname = &make_visible_path($fname);
+- }
+-
+- # param from d_upload.tt2
+- if ($in{'shortname'}){
+- $fname = $in{'shortname'};
+- }
+- &wwslog('info', 'do_d_upload(%s/%s)', $in{'path'},$fname);
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+- my $visible_path = &make_visible_path($path);
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- # name of the file
+- my $longname = "$shareddir/$path/$fname";
+- $longname =~ s/\/+/\//g;
+-
+-# ## $path must have a slash at its end
+-# $path = &format_path('with_slash',$path);
+-
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+-
+-
+- ## Controls
+-
+- # uploaded file must have a name
+- unless ($fname) {
+- &report::reject_report_web('user','no_name',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : No file specified to upload");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## Check quota
+- if ($list->{'admin'}{'shared_doc'}{'quota'}) {
+- if ($list->get_shared_size() >= $list->{'admin'}{'shared_doc'}{'quota'} * 1024){
+- &report::reject_report_web('user','shared_full',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : Shared Quota exceeded for list $list->{'name'}");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'shared_full','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- # The name of the file must be correct and musn't not be a description file
+- if ($fname =~ /^\./
+- || $fname =~ /\.desc/
+- || $fname =~ /[~\#\[\]]$/) {
+-
+- # unless ($fname =~ /^\w/ and
+- # $fname =~ /\w$/ and
+- # $fname =~ /^[\w\-\.]+$/ and
+- # $fname !~ /\.desc/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => $fname},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : Unable to create file $fname : incorrect name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # the file must be uploaded in a directory existing
+- unless (-d "$shareddir/$path") {
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : $shareddir/$path : not a directory");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Access control for the directory where there is the uploading
+- my %mode;
+- $mode{'edit'} = 1;
+- $mode{'control'} = 1; # for the exception index.html
+- my %access_dir = &d_access_control(\%mode,$path);
+-
+- if ($access_dir{'may'}{'edit'} == 0) {
+- &report::reject_report_web('auth',$access_dir{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_upload : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Lowercase for file name
+- # $fname = $fname;
+-
+- ## when the file already exists :
+-
+- # the temporary name of the uploaded file : with .duplicate
+- my $tmpname="."."$fname".".duplicate";
+- my $longtmpname="$shareddir/$path/$tmpname";
+- $longtmpname =~ s/\/+/\//g;
+-
+- # the temporary desc of the uploaded file : with .duplicate
+- my $tmpdesc=".desc."."$tmpname";
+- my $longtmpdesc="$shareddir/$path/$tmpdesc";
+- $longtmpdesc =~ s/\/+/\//g;
+-
+- # if we aren't in mode_delete nor in mode_rename nor in mode_cancel and the file already exists
+- # then we create of a temporary file
+- if ((-e "$longname") &&
+- ($in{'mode_delete'} eq undef) &&
+- ($in{'mode_rename'} eq undef) &&
+- ($in{'mode_cancel'} eq undef)) {
+-
+- #access control for the file already existing
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access_file = &d_access_control(\%mode,"$path/$fname");
+-
+- unless ($access_file{'may'}{'edit'} > 0) {
+- &report::reject_report_web('auth',$access_file{'reason'}{'edit'},{},$param->{'action'},$list);
+- return undef;
+- }
+-
+- if (-e "$longtmpname"){
+- # if exists a temp file younger than 5 minutes that belongs to another user : upload refused
+- my @info = stat $longtmpname;
+- my $timeold = time - $info[10];
+-
+- if ($timeold<=300){
+- my %desc_hash = &get_desc_file($longtmpdesc);
+-
+- unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
+- &report::reject_report_web('user','cannot_upload',{'path' => "$visible_path/$visible_fname",
+- 'reason' => "file being uploaded by $desc_hash{'email'} at this time" },
+- $param->{'action'},$list);
+- &wwslog('err',"do_d_upload : Unable to upload $longtmpname : file being uploaded at this time ");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+- }
+-
+- &creation_shared_file($shareddir,$path,$tmpname);
+- &creation_desc_file($shareddir,$path,$tmpname,%access_file);
+-
+- my @info = stat $longname;
+- $param->{'serial_file'} = $info[9];
+- $param->{'path'} = $path;
+- $param->{'shortname'} = $fname;
+-
+- return 1;
+- }
+-
+-
+- # for the moderation
+- my $longmodname = "$shareddir/$path/"."."."$fname".".moderate";
+- $longmodname =~ s/\/+/\//g;
+-
+- my $longmoddesc="$shareddir/$path/".".desc.."."$fname".".moderate";
+- $longmoddesc =~ s/\/+/\//g;
+-
+- # when a file is already waiting for moderation
+- my $file_moderated;
+-
+- if (-e "$longmodname"){
+-
+- my %desc_hash = &get_desc_file("$longmoddesc");
+- $file_moderated = 1;
+-
+- unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
+- &report::reject_report_web('user','cannot_upload',{'path' => "$path/$fname",
+- 'reason' => "file already exists but not yet moderated"},
+- $param->{'action'},$list);
+- &wwslog('err',"do_d_upload : Unable to create $longname : file already exists but not yet moderated");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+-
+- ## Exception index.html
+- unless ($fname !~ /^index.html?$/i) {
+- unless ($access_dir{'may'}{'control'}) {
+- &report::reject_report_web('user','index_html',{'dir' => $path,
+- 'reason' => "d_access_control"},
+- $param->{'action'},$list);
+- &wwslog('err',"do_d_upload : $param->{'user'}{'email'} not authorized to upload a INDEX.HTML file in $path");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- # if we're in mode_delete or mode_rename or mode_cancel, the temp file and his desc file must exist
+- if ($in{'mode_delete'} ||
+- $in{'mode_rename'} ||
+- $in{'mode_cancel'}) {
+-
+- unless(-e $longtmpname){
+- &report::reject_report_web('user','no_uploaded_file',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : there isn't any temp file for the uploaded file $fname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- unless(-e $longtmpdesc){
+- &report::reject_report_web('user','no_uploaded_file',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : there isn't any desc temp file for the uploaded file $fname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- }
+- ## End of controls
+-
+-
+- # in mode_delete the file is going to be overwritten
+- if ($in{'mode_delete'}) {
+-
+- # Synchronization
+- unless (&synchronize("$longname",$in{'serial'})){
+- &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : Synchronization failed for $longname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'synchro_failed','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Renaming the tmp file and the desc file
+-
+- if ($access_dir{'may'}{'edit'} == 1 ){
+-
+- # Renaming of the old file
+- my $longgoodname="$shareddir/$path/$fname";
+- $longgoodname =~ s/\/+/\//g;
+- unless (rename "$longgoodname","$longgoodname.old"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longgoodname",
+- 'new'=>"$longgoodname.old"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to .old : %s",$longgoodname, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Renaming of the old desc
+- my $longgooddesc="$shareddir/$path/".".desc."."$fname";
+- $longgooddesc =~ s/\/+/\//g;
+- unless (rename "$longgooddesc","$longgooddesc.old"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longgooddesc",
+- 'new'=>"$longgooddesc.old"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to .old : %s", $longgooddesc, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- # the tmp file
+- unless (rename "$longtmpname","$longgoodname"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpname",
+- 'new'=>"$longgoodname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpname, $longgoodname, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- # the tmp desc file
+- unless (rename "$longtmpdesc","$longgooddesc"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpdesc",
+- 'new'=>"$longgooddesc"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpdesc, $longgooddesc, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- }elsif ($access_dir{'may'}{'edit'} == 0.5 ){
+-
+- unless (rename "$longtmpname","$longmodname"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpname",
+- 'new'=>"$longmodname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpname, $longmodname, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- unless (rename "$longtmpdesc","$longmoddesc"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpdesc",
+- 'new'=>"$longmoddesc"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpdesc, $longmoddesc, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- unless ($list->send_notify_to_editor('shared_moderated',{'filename' => "$path/$fname",
+- 'who' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
+- }
+-
+- }else {
+- &report::reject_report_web('auth',$access_dir{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_upload : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+-# $in{'list'} = $list_name;
+-
+- # message of success
+- &report::notice_report_web('upload_success', {'path' => $fname},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'd_read';
+- }
+-
+- # in mode_rename the file is going to be renamed
+- if ($in{'mode_rename'}) {
+-
+- my $longnewname="$shareddir/$path/$in{'new_name'}";
+- $longnewname =~ s/\/+/\//g;
+-
+- # Control new document name
+- unless ($in{'new_name'}) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'new name'},$param->{'action'});
+- &wwslog('err',"do_d_upload : new name missing to rename the uploaded file");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'missing_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- if ($in{'new_name'} =~ /^\./
+- || $in{'new_name'} =~ /\.desc/
+- || $in{'new_name'} =~ /[~\#\[\]\/]$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : Unable to create file $in{'new_name'} : incorrect name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- if (($fname =~ /\.url$/) && ($in{'new_name'} !~ /\.url$/)) {
+- &report::reject_report_web('user','incorrect_name',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : New file name $in{'new_name'} does not match URL filenames");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- if (-e $longnewname){
+- &report::reject_report_web('user','doc_already_exist',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : $in{'new_name'} is an existing name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # when a file is already waiting for moderation
+- if (-e "$shareddir/$path/.$in{'new_name'}.moderate"){
+- &report::reject_report_web('user','doc_already_exist',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : $in{'new_name'} is an existing name for a not yet moderated file" );
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- # when a file is being uploaded
+- if (-e "$shareddir/$path/.$in{'new_name'}.duplicate"){
+- &report::reject_report_web('user','doc_already_exist',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : $in{'new_name'} is an existing name for a file being uploaded ");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- # Renaming the tmp file and the desc file
+-
+- if ($access_dir{'may'}{'edit'} == 1 ){
+- unless (rename "$longtmpname","$longnewname"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpname",
+- 'new'=>"$longnewname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpname, $longnewname, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- my $longnewdesc="$shareddir/$path/.desc.$in{'new_name'}";
+- $longnewdesc =~ s/\/+/\//g;
+-
+- unless (rename "$longtmpdesc","$longnewdesc"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpdesc",
+- 'new'=>"$longnewdesc"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpdesc, $longnewdesc, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- }elsif ($access_dir{'may'}{'edit'} == 0.5 ){
+-
+- unless (rename "$longtmpname","$shareddir/$path/.$in{'new_name'}.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpname",
+- 'new'=>"$shareddir/$path/.$in{'new_name'}.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename $longtmpname to $shareddir/$path/.$in{'new_name'}.moderate : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- unless (rename "$longtmpdesc","$shareddir/$path/.desc..$in{'new_name'}.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpdesc",
+- 'new'=>"$shareddir/$path/.desc..$in{'new_name'}.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename $longtmpdesc to $shareddir/$path/.desc..$in{'new_name'}.moderate: $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- unless ($list->send_notify_to_editor('shared_moderated',{'filename' => "$path/$in{'new_name'}",
+- 'who' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
+- }
+-
+- }else {
+- &report::reject_report_web('auth',$access_dir{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_upload : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+-# $in{'list'} = $list_name;
+-
+- # message of success
+- &report::notice_report_web('upload_success', {'path' => $fname},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'd_read';
+- }
+-
+- # in mode_cancel, we delete the temp file and his desc
+- if ($in{'mode_cancel'}) {
+-
+- # removing of the temp file
+- unless (unlink($longtmpname)) {
+- &report::reject_report_web('intern','erase_file',{'file' => $longtmpname},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_d_upload: failed to erase the temp file %s', $longtmpname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # removing of the description temp file
+- unless (unlink($longtmpdesc)) {
+- &report::reject_report_web('intern','erase_file',{'file' => $longtmpdesc},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_d_upload: failed to erase the desc temp file %s', $longtmpdesc);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- return 'd_read';
+- }
+-
+- ## usual case
+-
+- # shared_moderated
+- if ($access_dir{'may'}{'edit'} == 0.5 ) {
+- my $modname="."."$fname".".moderate";
+-
+- &creation_shared_file($shareddir,$path,$modname);
+- &creation_desc_file($shareddir,$path,$modname,%access_dir);
+-
+- unless ($file_moderated){
+- unless ($list->send_notify_to_editor('shared_moderated',{'filename' => "$path/$fname",
+- 'who' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
+- }
+- }
+-
+- &report::notice_report_web('to_moderate', {'path' => $fname},$param->{'action'});
+-
+- } else {
+- &creation_shared_file($shareddir,$path,$fname);
+- &creation_desc_file($shareddir,$path,$fname,%access_dir);
+- }
+-
+- $in{'list'} = $list_name;
+-
+- &report::notice_report_web('upload_success', {'path' => $visible_fname},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'd_read';
+- }
+-
+-## Creation of a picture file
+-sub creation_picture_file {
+- my($root_dir, $path ,$fname)=@_;
+-
+- unless(-d $root_dir.'/'.$path) {
+- &wwslog('notice',"creation_picture_file : Create dir $root_dir/$path/");
+-
+- unless (&tools::mkdir_all($root_dir.'/'.$path, 0755)){
+- &wwslog('err',"creation_picture_file : Unable to create dir $root_dir/$path/");
+- return undef;
+- }
+-
+- unless (open(FF,">$root_dir".'/'.$path.'/index.html')){
+- &wwslog('err',"creation_picture_file : Unable to create dir $root_dir/$path/index.html");
+- }
+- chmod 0755, $root_dir.'/'.$path.'/index.html';
+- close FF;
+- }
+-
+- my $fh = $query->upload('uploaded_file');
+- unless (open FILE, ">:bytes", "$root_dir/$path/$fname") {
+- &report::reject_report_web('intern','cannot_upload',{'path' => "$path/$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"creation_picture_file : Cannot open file $root_dir/$path/$fname : $!");
+- return undef;
+- }
+- while (<$fh>) {
+- print FILE;
+- }
+- close FILE;
+- chmod 0755, "$root_dir/$path/$fname";
+-}
+-
+-
+-## Creation of a shared file
+-sub creation_shared_file {
+- my($shareddir,$path,$fname)=@_;
+-
+- unless(-d $shareddir.'/'.$path) {
+- &wwslog('notice',"creation_shared_file : Create dir $shareddir/$path/");
+-
+- unless (mkdir($shareddir.'/'.$path,0755)){
+- &wwslog('err',"creation_shared_file : Unable to create dir $shareddir/$path/");
+- return undef;
+- }
+-
+- }
+-
+- my $fh = $query->upload('uploaded_file');
+-
+- unless (open FILE, ">:bytes", "$shareddir/$path/$fname") {
+- &report::reject_report_web('intern','cannot_upload',{'path' => "$path/$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"creation_shared_file : Cannot open file $shareddir/$path/$fname : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- while (<$fh>) {
+- print FILE;
+- }
+- close FILE;
+-
+- ## XSS Protection for HTML files.
+- if (lc($fname) =~ /\.html?/) {
+- my $sanitized_file = &tools::sanitize_html_file('robot' => $robot,
+- 'file' => "$shareddir/$path/$fname");
+- if (defined $sanitized_file) {
+- open HTMLFILE, ">:bytes", "$shareddir/$path/$fname";
+- print HTMLFILE $sanitized_file;
+- close HTMLFILE;
+- }
+- else {
+- &do_log('err','Unable to sanitize file %s',$fname);
+- }
+- }
+-
+-}
+-
+-## Creation of the description file
+-sub creation_desc_file {
+- my($shareddir,$path,$fname,%access)=@_;
+-
+- unless (open (DESC,">$shareddir/$path/.desc.$fname")) {
+- &wwslog('err',"creation_desc_file: cannot create description file $shareddir/.desc.$path/$fname");
+- }
+-
+- print DESC "title\n \n\n";
+- print DESC "creation\n date_epoch ".time."\n email $param->{'user'}{'email'}\n\n";
+-
+- print DESC "access\n";
+- print DESC " read $access{'scenario'}{'read'}\n";
+- print DESC " edit $access{'scenario'}{'edit'}\n";
+-
+- close DESC;
+-}
+-
+- #*******************************************
+- # Function : do_d_unzip
+- # Description : unzip a file or a tree structure
+- # from an uploaded zip file
+- #******************************************
+-
+- sub do_d_unzip {
+- # Parameters of the uploaded file (from d_read.tt2)
+- my $fn = $in{'unzipped_file'};
+-
+- # name of the file, without path
+- my $fname;
+- if ($fn =~ /([^\/\\]+)$/) {
+- $fname = $1;
+- }
+-
+- &wwslog('info', 'do_d_unzip(%s/%s)', $in{'path'},$fname);
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- # name of the file
+- my $longname = "$shareddir/$path/$fname";
+- $longname =~ s/\/+/\//g;
+-
+- ## Controls
+-
+- my $listname = $list->{'name'};
+-
+- # uploaded file must have a name
+- unless ($fname) {
+- &report::reject_report_web('user','no_name',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_unzip(%s/%s) : No file specified to upload",$path,$fname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # must have .zip extension
+- unless ($fname =~ /^.+\.zip$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => "$fname",
+- 'reason' => "must have the '.zip' extension"},$param->{'action'},$list);
+- &wwslog('err',"do_d_unzip(%s/%s) : the file must have '.zip' extension",$path,$fname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## Check quota
+- if ($list->{'admin'}{'shared_doc'}{'quota'}) {
+- if ($list->get_shared_size() >= $list->{'admin'}{'shared_doc'}{'quota'} * 1024){
+- &report::reject_report_web('user','shared_full',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_unzip(%s/%s) : Shared Quota exceeded for list $list->{'name'}",$path,$fname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'shared_full','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- # The name of the file must be correct and must not be a description file
+- if ($fname =~ /^\./
+- || $fname =~ /\.desc/
+- || $fname =~ /[~\#\[\]]$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => "$fname"},$param->{'action'},$list);
+- &wwslog('err',"do_d_unzip(%s/%s) : incorrect name",$path,$fname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # the file must be uploaded in a directory existing
+- unless (-d "$shareddir/$path") {
+- &report::reject_report_web('user','no_such_document',{'path'=> $path},$param->{'action'},$list);
+- &wwslog('err',"do_d_unzip(%s/%s) : $shareddir/$path : not a directory",$path,$fname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Access control for the directory where there is the uploading
+- # only for (is_author || !moderated)
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access_dir = &d_access_control(\%mode,$path);
+-
+- if ($access_dir{'may'}{'edit'} == 0) {
+- &report::reject_report_web('auth',$access_dir{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_unzip(%s/%s) : access denied for %s',$path,$fname, $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- if ($access_dir{'may'}{'edit'} == 0.5) {
+- &report::reject_report_web('auth','edit_moderated',{},$param->{'action'},$list);
+- &wwslog('err','do_d_unzip(%s/%s) : access denied for %s',$path,$fname, $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## End of control
+-
+- # directory for the uploaded file
+- my $date = time;
+- my $zip_dir_name = $listname.$date.$$;
+- my $zip_abs_dir = $Conf{'tmpdir'}.'/'.$zip_dir_name;
+-
+- unless (mkdir ("$zip_abs_dir",0777)) {
+- &report::reject_report_web('intern','cannot_mkdir',{'dir' => $zip_abs_dir},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_unzip($path/$fname) : Unable to create $zip_abs_dir : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### directory for unzipped files
+- unless (mkdir ("$zip_abs_dir"."/zip",0777)) {
+- &report::reject_report_web('intern','cannot_mkdir',{'dir' => "$zip_abs_dir"."/zip"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_unzip($path/$fname) : Unable to create $zip_abs_dir/zip : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### uploaded of the file.zip
+- my $fh = $query->upload('unzipped_file');
+- unless (open FILE, ">:bytes", "$zip_abs_dir/$fname") {
+- &report::reject_report_web('intern','cannot_upload',{'path' => "$path/$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_unzip($path/$fname) : Cannot open file $zip_abs_dir/$fname : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- while (<$fh>) {
+- print FILE;
+- }
+- close FILE;
+-
+- ### unzip the file
+- my $status = &d_unzip_shared_file($zip_abs_dir,$fname,$path);
+-
+- unless (defined($status)) {
+- &report::reject_report_web('intern','cannot_unzip',{'path' => "$zip_abs_dir/$fname", 'name' => $fname},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_unzip($path/$fname) : Unable to unzip the file $zip_abs_dir/$fname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- unless ($status) {
+- &report::reject_report_web('intern','cannot_unzip',{'name' => "$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }
+-
+- ### install the file hierarchy
+-
+- unless (&d_install_file_hierarchy("$zip_abs_dir/zip",$shareddir,$path,\%access_dir)) {
+- &wwslog('err',"do_d_unzip($path/$fname) : unable to install file hierarchy");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## remove tmp directories and files
+-# &tools::remove_dir($zip_abs_dir);
+-
+- $in{'list'} = $listname;
+-
+- &report::notice_report_web('unzip_success', {'path' => $fname},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'd_read'
+- }
+-
+-## unzip a shared file in the tmp directory
+-sub d_unzip_shared_file {
+- my ($zip_abs_dir,$fname) = @_;
+- &wwslog('info', 'd_unzip_shared_file(%s/%s)', $zip_abs_dir,$fname);
+-
+- my $status = 1;
+-
+- my $zip = Archive::Zip->new();
+-
+- my $az = $zip->read( "$zip_abs_dir/$fname" );
+-
+- unless ($az == AZ_OK){
+- &wwslog('err',"unzip_shared_file : Unable to read the zip file $zip_abs_dir/$fname : $az");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$zip_abs_dir,$fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- my @memberNames = $zip->memberNames();
+-
+- foreach my $name (@memberNames) {
+- my $az = $zip->extractMember($name, $zip_abs_dir.'/zip/'.$name);
+- unless ($az == AZ_OK) {
+- &wwslog('err',"unzip_shared_file : Unable to extract member $name of the zip file $zip_abs_dir/$fname : $az");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$zip_abs_dir,$fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- $status = 0;
+- }
+- }
+-
+- ## Qencode 8bit filenames afterward
+- ## The suspected charset is the one that is associated to the user's language
+- &tools::qencode_hierarchy($zip_abs_dir.'/zip', &Language::GetCharset());
+-
+- return $status;
+-}
+-
+-## Install file hierarchy from $tmp_dir directory to $shareddir/$path directory
+-sub d_install_file_hierarchy {
+- my ($tmp_dir,$shareddir,$path,$access_dir)=@_;
+- &wwslog('debug2', 'd_install_file_hierarchy(%s,%s)',$tmp_dir,$path);
+-
+- $tmp_dir = &no_slash_end($tmp_dir);
+- $shareddir = &no_slash_end($shareddir);
+- $path = &no_slash_end($path);
+-
+- my $fatal_error = 0;
+-
+- unless (opendir DIR,"$tmp_dir") {
+- &report::reject_report_web('intern','cannot_open_dir',{'dir' => $tmp_dir},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','d_install_file_hierarchy(%s) : impossible to open %s directory',$path,$tmp_dir);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$tmp_dir,$shareddir,$path,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- my @from_dir = readdir DIR;
+- closedir DIR;
+-
+- foreach my $doc (@from_dir) {
+- next
+- if($doc eq '.' || $doc eq '..');
+- if (-d "$tmp_dir/$doc") {
+- if ($fatal_error) {
+- &report::reject_report_web('user','directory_no_copied',{'name'=> "$path/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }else {
+- unless (&d_copy_rec_dir("$tmp_dir","$path","$shareddir/$path",$doc)){
+- $fatal_error = 1;
+- &report::reject_report_web('user','directory_no_copied',{'name'=> "$path/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- # return undef;
+- }
+- }
+- } else {
+- if ($fatal_error) {
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }else {
+- unless (&d_copy_file("$tmp_dir","$path","$shareddir/$path",$doc,$access_dir)) {
+- &wwslog('err',"d_install_hierarchy($path) : fatal error from d_copy_file($doc)");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$tmp_dir,$shareddir,$path,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+-
+- $fatal_error = 1;
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }
+- # return undef;
+- }
+- }
+- }
+-
+- if ($fatal_error) {
+- return undef;
+- }else {
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$tmp_dir,$shareddir,$path,$access_dir",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-}
+-
+-## copy $dname from $from to $list->{shared}/$path if rights are ok
+-sub d_copy_rec_dir {
+- my ($from,$path,$dest_dir,$dname) = @_;
+- &wwslog('debug3', 'd_copy_rec_dir(%s,%s,%s)',$from,$dest_dir,$dname);
+-
+- $from = &no_slash_end($from);
+- $path = &no_slash_end($path);
+- $dest_dir = &no_slash_end($dest_dir);
+-
+- my $fatal_error = 0;
+-
+- # Access control on the directory $path where there is the copy
+- # Copy allowed only for (is_author || !moderate)
+- my %mode;
+- $mode{'edit'} = 1;
+- $mode{'control'} = 1;
+- my %access_dir = &d_access_control(\%mode,$path);
+-
+- unless ($access_dir{'may'}{'edit'} == 1) {
+- &report::reject_report_web('user','directory_no_copied',{'name'=> $dname,
+- 'reason' => "no edition right on father directory"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','d_copy_rec_dir(%s): access denied for %s',$path,$param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- my $may;
+- unless ($may = &d_test_existing_and_rights($path,$dname,$dest_dir)) {
+- &report::reject_report_web('user','directory_no_copied',{'name'=> $dname },
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','d_copy_rec_dir(%s) : error while calling "test_existing_and_rights(%s/%s)"',$dname,$dest_dir,$dname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- unless ($may->{'exists'}) {
+-
+- # The name of the directory must be correct and musn't not be a description file
+- if ($dname =~ /^\./
+- || $dname =~ /\.desc/
+- || $dname =~ /[~\#\[\]]$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => "$dname"},$param->{'action'},$list);
+- &wwslog('err',"d_copy_rec_dir : $dname : incorrect name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- ## Exception index.html
+- unless ($dname !~ /^index.html?$/i) {
+- &report::reject_report_web('user','index_html',{'dir' => $path},$param->{'action'},$list);
+- &wwslog('err',"d_copy_rec_dir : the directory cannot be called INDEX.HTML ");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- ## directory creation
+- unless (mkdir ("$dest_dir/$dname",0777)) {
+- &report::reject_report_web('user','directory_no_copied',{'name'=> "$dname"},$param->{'action'},$list);
+- &wwslog('err',"d_copy_rec_dir : Unable to create directory $dest_dir/$dname : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- ## desc directory creation
+- unless (open (DESC,">$dest_dir/$dname/.desc")) {
+- &wwslog('err',"d_copy_rec_dir: cannot create description file $dest_dir/$dname/.desc");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- print DESC "title\n \n\n";
+- print DESC "creation\n date_epoch ".time."\n email $param->{'user'}{'email'}\n\n";
+-
+- print DESC "access\n";
+- print DESC " read $access_dir{'scenario'}{'read'}\n";
+- print DESC " edit $access_dir{'scenario'}{'edit'}\n";
+-
+- close DESC;
+- }
+-
+- if ($may->{'rights'} || !($may->{'exists'})) {
+-
+- unless (opendir DIR,"$from/$dname") {
+- &report::reject_report_web('user','directory_no_copied',{'name'=> "$dname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','d_copy_rec_dir(%s) : impossible to open %s directory',$dname,$from);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- my @from_dir = readdir DIR;
+- closedir DIR;
+-
+-
+- foreach my $doc (@from_dir) {
+-
+- if ($doc eq '.' || $doc eq '..') {
+- next;
+- }
+- if (-d "$from/$dname/$doc") {
+- if ($fatal_error) {
+- &report::reject_report_web('user','directory_no_copied',{'name'=> "$dname/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+-
+- }else {
+-
+- unless (&d_copy_rec_dir("$from/$dname","$path/$dname","$dest_dir/$dname",$doc)){
+- $fatal_error = 1;
+- &report::reject_report_web('user','directory_no_copied',{'name'=> "$dname/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+-# return undef;
+- }
+- }
+-
+- }else {
+- if ($fatal_error) {
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$dname/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+-
+- }else {
+- unless (&d_copy_file("$from/$dname","$path/$dname","$dest_dir/$dname",$doc,\%access_dir)){
+- &wwslog('err',"d_copy_rec_dir($path/$dname) : fatal error from d_copy_file($doc)");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- $fatal_error = 1;
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$dname/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }
+-# return undef;
+- }
+- }
+- }
+-
+- }else{
+- &report::reject_report_web('user','directory_no_copied',{'name'=> $dname,
+- 'reason' => "no edition right on the father directory"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+-
+- &wwslog('err',"d_copy_rec_file : impossible to copy content directory $dname, the user doesn't have edit rights on directory $path");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- if ($fatal_error) {
+- return undef;
+- } else {
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-}
+-
+-## copy $from/$fname to $list->{shared}/$path if rights are ok
+-sub d_copy_file {
+- my ($from,$path,$dest_dir,$fname,$access_dir) = @_;
+- &wwslog('debug3', 'd_copy_file(%s,%s,%s',$from,$dest_dir,$fname);
+-
+- $from = &no_slash_end($from);
+- $path = &no_slash_end($path);
+- $dest_dir = &no_slash_end($dest_dir);
+-
+- my $may;
+- unless ($may = &d_test_existing_and_rights($path,$fname,$dest_dir)) {
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$fname",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','d_copy_file(%s) : error while calling "test_existing_and_rights(%s/%s)"',$fname,$dest_dir,$fname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- if ($may->{'rights'} || !($may->{'exists'})) {
+-
+- # The name of the file must be correct and musn't not be a description file
+- if ($fname =~ /^\./
+- || $fname =~ /\.desc/
+- || $fname =~ /[~\#\[\]]$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => "$fname"},$param->{'action'},$list);
+- &wwslog('err',"d_copy_file : $fname : incorrect name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- ## Exception index.html
+- unless ($fname !~ /^index.html?$/i) {
+- unless ($access_dir->{'may'}{'control'}) {
+- &report::reject_report_web('user','index_html',{'dir' => $path},$param->{'action'},$list);
+- &wwslog('err',"d_copy_file : the user is not authorized to upload a INDEX.HTML file in $dest_dir");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+- }
+-
+- ## Check quota
+- if ($list->{'admin'}{'shared_doc'}{'quota'}) {
+-
+- if ($list->get_shared_size() >= $list->{'admin'}{'shared_doc'}{'quota'} * 1024){
+- &report::reject_report_web('user','shared_full',{},$param->{'action'},$list);
+- &wwslog('err',"d_copy_file : Shared Quota exceeded for list $list->{'name'} on file $path/$fname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'shared_full','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- ## if already existing :delete it
+- unlink ("$dest_dir/$fname")
+- if (-e "$dest_dir/$fname");
+- unlink ("$dest_dir/.desc.$fname")
+- if (-e "$dest_dir/.desc.$fname");
+-
+- ## # if exists a temp file younger than 5 minutes that belongs to another user : file copy refused
+- if (-e "$dest_dir/.$fname.duplicate") {
+- my @info = stat "$dest_dir/.$fname.duplicate";
+- my $timeold = time - $info[10];
+- if ($timeold <= 300){
+- my %desc_hash = &get_desc_file("$dest_dir/.desc..$fname.duplicate");
+- unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$fname",
+- 'reason' => "file being uploading by $desc_hash{'email'} at this time"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_copy_file : unable to copy $path/$fname : file being uploaded at this time ");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+- }
+-
+- unlink ("$dest_dir/.$fname.duplicate");
+- unlink ("$dest_dir/.desc..$fname.duplicate")
+- if (-e "$dest_dir/.desc..$fname.duplicate");
+- }
+-
+- if (-e "$dest_dir/.$fname.moderate") {
+- my %desc_hash = &get_desc_file("$dest_dir/.$fname.moderate");
+-
+- unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$fname",
+- 'reason' => "file awaiting for moderation, uploaded by $desc_hash{'email'}"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_copy_file : unable to copy $path/$fname : file awaiting for moderation");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+- unlink ("$dest_dir/.$fname.moderate");
+-
+- unlink ("$dest_dir/.desc..$fname.moderate")
+- if (-e "$dest_dir/.desc..$fname.moderate");
+- }
+-
+- ## file copy
+- unless (open FROM_FILE,"$from/$fname") {
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$fname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_copy_file : impossible to open $from/$fname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- my $visible_fname = &make_visible_path($fname);
+-
+- unless (open DEST_FILE, ">$dest_dir/$fname") {
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$visible_fname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_copy_file : Cannot create file $dest_dir/$fname : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- while (<FROM_FILE>) {
+- print DEST_FILE;
+- }
+- close FROM_FILE;
+- close DEST_FILE;
+-
+- ## XSS Protection for HTML files.
+- if (lc($fname) =~ /\.html?/) {
+- my $sanitized_file = &tools::sanitize_html_file('robot' => $robot,
+- 'file' => "$dest_dir/$fname");
+- if (defined $sanitized_file) {
+- open HTMLFILE, ">:bytes", "$dest_dir/$fname";
+- print HTMLFILE $sanitized_file;
+- close HTMLFILE;
+- }
+- else {
+- &do_log('err','Unable to sanitize file %s',$fname);
+- }
+- }
+-
+- ## desc file creation
+- unless (open (DESC,">$dest_dir/.desc.$fname")) {
+- &wwslog('err',"d_copy_file: cannot create description file $dest_dir/.desc.$fname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- print DESC "title\n \n\n";
+- print DESC "creation\n date_epoch ".time."\n email $param->{'user'}{'email'}\n\n";
+-
+- print DESC "access\n";
+- print DESC " read $access_dir->{'scenario'}{'read'}\n";
+- print DESC " edit $access_dir->{'scenario'}{'edit'}\n";
+-
+- close DESC;
+-
+- ## information
+-
+- &report::notice_report_web('file_erased',{'path'=> "$path/$visible_fname"},$param->{'action'})
+- if ($may->{'exists'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }else{
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$fname",
+- 'reason' => "you do not have total edit right on the file"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_copy_file : impossible to copy file $fname, the user doesn't have total edit rights on the file");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- return 1;
+-}
+-
+-## return information on file or dir : existing and edit rights for the user in $param
+-sub d_test_existing_and_rights {
+- my ($path,$name,$dest_dir) = @_;
+-
+- $path = &no_slash_end($path);
+- $name = &no_slash_end($name);
+- $dest_dir = &no_slash_end($dest_dir);
+-
+- my $return;
+-
+- $return->{'exists'} = 0;
+- $return->{'rights'} = 0;
+-
+- if ((-e "$dest_dir/$name") ||
+- (-e "$dest_dir/.$name.duplicate") ||
+- (-e "$dest_dir/.$name.moderate")) {
+-
+- $return->{'exists'} = 1;
+-
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,"$path/$name");
+- $return->{'rights'} = 1
+- if $access{'may'}{'edit'} == 1;
+- }
+-
+- return $return;
+-}
+-
+-
+- #*******************************************
+- # Function : do_d_delete
+- # Description : Delete an existing document
+- # (file or directory)
+- #******************************************
+-
+- sub do_d_delete {
+- &wwslog('info', 'do_d_delete(%s)', $in{'path'});
+-
+- #useful variables
+- my $path = &no_slash_end($in{'path'});
+-
+- my $visible_path = &make_visible_path($path);
+-
+- #Current directory and document to delete
+- $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- my $current_directory = &no_slash_end($1);
+- my $document = $3;
+-
+- # path of the shared directory
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #### Controls
+-
+- ## must be something to delete
+- unless ($document) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'doccument'},$param->{'action'});
+- &wwslog('err',"do_d_delete : no document to delete has been specified");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'missing_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### Document isn't a description file?
+- unless ($document !~ /^\.desc/) {
+- &wwslog('err',"do_d_delete : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'description_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### Document exists?
+- unless (-e "$shareddir/$path") {
+- &wwslog('err',"do_d_delete : $shareddir/$path : no such file or directory");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # removing of the document
+- my $doc = "$shareddir/$path";
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'edit'} > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_delete : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## Directory
+- if (-d "$shareddir/$path") {
+-
+- # test of emptiness
+- opendir DIR, "$doc";
+- my @readdir = readdir DIR;
+- close DIR;
+-
+- # test for "ordinary" files
+- my @test_normal = grep !/^\./, @readdir;
+- my @test_hidden = grep !(/^\.desc$/ | /^\.(\.)?$/ | /^[^\.]/), @readdir;
+- if (($#test_normal != -1) || ($#test_hidden != -1)) {
+- &report::reject_report_web('user','full_directory',{'directory'=> $path},$param->{'action'},$list);
+- &wwslog('err',"do_d_delete : Failed to erase $doc : directory not empty");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # removing of the description file if exists
+- if (-e "$doc/\.desc") {
+- unless (unlink("$doc/.desc")) {
+- &report::reject_report_web('intern','erase_file',{'file' => "$doc/.desc"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_delete : Failed to erase $doc/.desc : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+- # removing of the directory
+- rmdir $doc;
+-
+- ## File
+- }else {
+-
+- # removing of the document
+- unless (unlink($doc)) {
+- &report::reject_report_web('intern','erase_file',{'file' => "$doc"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_d_delete: failed to erase %s', $doc);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- # removing of the description file if exists
+- if (-e "$shareddir/$current_directory/.desc.$document") {
+- unless (unlink("$shareddir/$current_directory/.desc.$document")) {
+- &wwslog('err',"do_d_delete: failed to erase $shareddir/$current_directory/.desc.$document");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+- }
+- }
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- $in{'list'} = $list_name;
+- $in{'path'} = $current_directory;
+- return 'd_read';
+- }
+-
+- #*******************************************
+- # Function : do_d_rename
+- # Description : Rename a document
+- # (file or directory)
+- #******************************************
+-
+- sub do_d_rename {
+- &wwslog('info', 'do_d_rename(%s)', $in{'path'});
+-
+- #useful variables
+- my $path = &no_slash_end($in{'path'});
+-
+- #moderation
+- my $visible_path = &make_visible_path($path);
+- my $moderate;
+- if ($path =~ /\.moderate$/) {
+- $moderate=1;
+- }
+-
+- #Current directory and document to delete
+- my $current_directory;
+- if ($path =~ /^(.*)\/([^\/]+)$/) {
+- $current_directory = &no_slash_end($1);
+- }else {
+- $current_directory = '.';
+- }
+- $path =~ /(^|\/)([^\/]+)$/;
+- my $document = $2;
+-
+- # path of the shared directory
+- my $list_name = $list->{'name'};
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #### Controls
+-
+- ## must be something to delete
+- unless ($document) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'document'},$param->{'action'});
+- &wwslog('err',"do_d_rename : no document to rename has been specified");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### Document isn't a description file?
+- unless ($document !~ /^\.desc/) {
+- &wwslog('err',"do_d_rename : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_such_document','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### Document exists?
+- unless (-e "$shareddir/$path") {
+- &wwslog('err',"do_d_rename : $shareddir/$path : no such file or directory");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_such_document','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- if ($in{'new_name'} =~ /^\./
+- || $in{'new_name'} =~ /\.desc/
+- || $in{'new_name'} =~ /[~\#\[\]\/]$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_rename : Unable to create file $in{'new_name'} : incorrect name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- if (($document =~ /\.url$/) && ($in{'new_name'} !~ /\.url$/)) {
+- &report::reject_report_web('user','incorrect_name',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_rename : New file name $in{'new_name'} does not match URL filenames");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- my $doc = "$shareddir/$path";
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'edit'} > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_rename : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- if ($moderate){
+- &do_log('notice', "RENAME: $doc, $shareddir/$current_directory/$in{'new_name'}");
+- unless (rename $doc, "$shareddir/$current_directory/.$in{'new_name'}.moderate") {
+- &report::reject_report_web('intern','rename_file',{'old'=>$doc,
+- 'new'=>"$shareddir/$current_directory/.$in{'new_name'}.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_rename : Failed to rename %s to %s : %s", $doc, "$shareddir/$current_directory/$in{'new_name'}", $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }else {
+- &do_log('notice', "RENAME: $doc, $shareddir/$current_directory/$in{'new_name'}");
+- unless (rename $doc, "$shareddir/$current_directory/$in{'new_name'}") {
+- &report::reject_report_web('intern','rename_file',{'old'=>$doc,
+- 'new'=>"$shareddir/$current_directory/$in{'new_name'}"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_rename : Failed to rename %s to %s : %s", $doc, "$shareddir/$current_directory/$in{'new_name'}", $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+- ## Rename description file
+- my $desc_file = "$shareddir/$current_directory/.desc.$document";
+- my $new_desc_file = $desc_file;
+-
+- if (-f $desc_file) {
+- if ($moderate){
+- $new_desc_file =~ s/\Q$document/\.$in{'new_name'}\.moderate/;
+- }else {
+- $new_desc_file =~ s/\Q$document/$in{'new_name'}/;
+- }
+- unless (rename $desc_file, $new_desc_file) {
+- &report::reject_report_web('intern','rename_file',{'old'=>$desc_file,
+- 'new'=> $new_desc_file},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_rename : Failed to rename $desc_file : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- $in{'list'} = $list_name;
+- if ($current_directory eq '.') {
+- $in{'path'} = '';
+- } else {
+- $in{'path'} = $current_directory.'';
+- }
+- return 'd_read';
+- }
+-
+- #*******************************************
+- # Function : do_d_create_dir
+- # Description : Creates a new file / directory
+- #******************************************
+- sub do_d_create_dir {
+- &wwslog('info', 'do_d_create_dir(%s)', $in{'name_doc'});
+-
+- #useful variables
+- my $path = &no_slash_end($in{'path'});
+-
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+- my $name_doc = $in{'name_doc'};
+-
+- $param->{'list'} = $list_name;
+- $param->{'path'} = $path;
+-
+- ## Q-decode file path and names
+- $param->{'decoded_path'} = &tools::qdecode_filename($param->{'path'});
+- $param->{'decoded_name_doc'} = &tools::qdecode_filename($name_doc);
+-
+- my $type = $in{'type'} || 'directory';
+- my $desc_file;
+-
+- ### Controls
+-
+- # Must be a directory to create (directory name not empty)
+- unless ($name_doc) {
+- &report::reject_report_web('user','no_name',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_create_dir : Unable to create : no name specified!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'missing_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # The name of the directory must be correct
+- if ($name_doc =~ /^\./
+- || $name_doc =~ /\.desc/
+- || $name_doc =~ /[~\#\[\]\/]$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => $name_doc},$param->{'action'},$list);
+- &wwslog('err',"do_d_create_dir : Unable to create directory $name_doc : incorrect name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode, $path);
+-
+- if ($type eq 'directory') { ## only when (is_author || !moderated)
+- if ($access{'may'}{'edit'} == 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_create_dir : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- if ($access{'may'}{'edit'} == 0.5) {
+- &report::reject_report_web('auth','dir_edit_moderated',{},$param->{'action'},$list);
+- &wwslog('err','do_d_create_dir : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- } else {
+- if ($access{'may'}{'edit'} == 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_create_dir : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- my $document = "$shareddir/$path/$name_doc";
+-
+- $param->{'document'} = $document;
+-
+- # the file musn't already exists
+- if (-e $document){
+- &report::reject_report_web('user','doc_already_exist',{'name' => "$path/$name_doc"},$param->{'action'},$list);
+- &wwslog('err',"do_d_create_dir : cannot create $path/$name_doc : file already exists");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # if the file .moderate exists, only its author can erase it
+-
+- my $doc_moderate = "$shareddir/$path/"."."."$name_doc".".moderate";
+- my $file_moderated;
+-
+- if (-e "$doc_moderate"){
+-
+- $file_moderated = 1;
+- my $desc="$shareddir/$path/".".desc.."."$name_doc".".moderate";
+- $desc =~ s/\/+/\//g;
+- my %desc_hash = &get_desc_file("$desc");
+-
+- unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
+- &report::reject_report_web('user','cannot_upload',{'path' => "$path/$name_doc",
+- 'reason' => "file already exists but not yet moderated"},$param->{'action'},$list);
+- &wwslog('err',"do_d_create_dir : Unable to create $doc_moderate : file already exists but not yet moderated");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- ### End of controls
+-
+- if ($type eq 'directory') {
+- # Creation of the new directory
+- unless (mkdir ("$document",0777)) {
+- &report::reject_report_web('intern','cannot_mkdir',{'dir' => $document},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_create_dir : Unable to create $document : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- $desc_file = "$document/.desc";
+-
+- }else {
+- # Creation of the new file
+- unless (open FILE, ">$document") {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => "$path/$name_doc"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_create_dir : Unable to create $document : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- close FILE;
+-
+- $desc_file = "$shareddir/$path/.desc.$name_doc";
+- }
+-
+- # Creation of a default description file
+- unless (open (DESC,">$desc_file")) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => "$desc_file"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }
+-
+- print DESC "title\n \n\n";
+- print DESC "creation\n date_epoch ".time."\n email $param->{'user'}{'email'}\n\n";
+-
+- print DESC "access\n";
+- print DESC " read $access{'scenario'}{'read'}\n";
+- print DESC " edit $access{'scenario'}{'edit'}\n\n";
+-
+- close DESC;
+-
+- # moderation
+- if ($access{'may'}{'edit'} == 0.5 && ($type ne 'directory')) {
+- unless (rename "$shareddir/$path/$name_doc","$shareddir/$path/.$name_doc.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$path/$name_doc",
+- 'new'=>"$shareddir/$path/.$name_doc.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_create_dir : Failed to rename $path/$name_doc to $path/.$name_doc.moderate : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- unless (rename "$desc_file","$shareddir/$path/.desc..$name_doc.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>$desc_file,
+- 'new'=>"$shareddir/$path/.desc..$name_doc.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_create_dir : Failed to rename $desc_file to $path/.desc..$name_doc.moderate : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- unless ($file_moderated){
+- unless ($list->send_notify_to_editor('shared_moderated',{'filename' => $param->{'decoded_path'}.'/'.$param->{'decoded_name_doc'},
+- 'who' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
+- }
+- }
+- }
+-
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+-
+- if ($type eq 'directory') {
+- return 'd_read';
+- }
+-
+- if ($access{'may'}{'edit'} == 0.5) {
+- $in{'path'} = "$path/.$name_doc.moderate";
+- }else {
+- $in{'path'} = "$path/$name_doc";
+- }
+-
+- return 'd_editfile';
+- }
+-
+- ############## Control
+-
+-
+- #*******************************************
+- # Function : do_d_control
+- # Description : prepares the parameters
+- # to edit access for a doc
+- #*******************************************
+-
+- sub do_d_control {
+- &wwslog('info', "do_d_control $in{'path'}");
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #moderation
+- my $visible_path = &make_visible_path($path);
+-
+- unless ($path) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'document'},$param->{'action'});
+- &wwslog('info','do_d_control: no document name');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'missing_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Existing document?
+- unless (-e "$shareddir/$path") {
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('info',"do_d_control : Cannot control $shareddir/$path : not an existing document");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_such_document','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### Document isn't a description file?
+- unless ($path !~ /\.desc/) {
+- &wwslog('info',"do_d_control : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_such_document','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Access control
+- my %mode;
+- $mode{'control'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+- unless ($access{'may'}{'control'}) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('info','d_control : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+-
+- ## End of controls
+-
+-
+- #Current directory
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
+- $param->{'father'} = &no_slash_end($1);
+- }else {
+- $param->{'father'} = '';
+- }
+- $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
+-
+- my $desc_file;
+- # path of the description file
+- if (-d "$shareddir/$path") {
+- $desc_file = "$shareddir/$1$3/.desc";
+- } else {
+- $desc_file = "$shareddir/$1.desc.$3";
+- }
+-
+- # Description of the file
+- my $read;
+- my $edit;
+-
+- if (-e $desc_file) {
+-
+- ## Synchronization
+- my @info = stat "$desc_file";
+- $param->{'serial_desc'} = $info[9];
+- my %desc_hash = &get_desc_file("$desc_file");
+- # rights for read and edit
+- $read = $desc_hash{'read'};
+- $edit = $desc_hash{'edit'};
+- # owner of the document
+- $param->{'owner'} = $desc_hash{'email'};
+- $param->{'doc_title'} = $desc_hash{'title'};
+- }else {
+- $read = $access{'scenario'}{'read'};
+- $edit = $access{'scenario'}{'edit'};
+- }
+-
+- ## other info
+- my @info = stat "$shareddir/$path";
+- $param->{'doc_date'} = gettext_strftime "%d %b %y %H:%M", localtime($info[9]);
+-
+- # template parameters
+- $param->{'list'} = $list_name;
+- $param->{'path'} = $path;
+- $param->{'visible_path'} = $visible_path;
+-
+- my $lang = $param->{'lang'};
+-
+- ## Scenario list for READ
+-
+- my $tmp_list_of_scenario = $list->load_scenario_list('d_read',$robot);
+-
+- ## Only get required scenario attributes
+- foreach my $scenario (keys %{$tmp_list_of_scenario}) {
+- $param->{'scenari_read'}{$scenario} = {'name' => $tmp_list_of_scenario->{$scenario}{'name'},
+- 'web_title' => $tmp_list_of_scenario->{$scenario}{'web_title'}};
+- }
+-
+- $param->{'scenari_read'}{$read}{'selected'} = 'selected="selected"';
+-
+- ## Scenario list for EDIT
+- my $tmp_list_of_scenario = $list->load_scenario_list('d_edit',$robot);
+-
+- ## Only get required scenario attributes
+- foreach my $scenario (keys %{$tmp_list_of_scenario}) {
+- $param->{'scenari_edit'}{$scenario} = {'name' => $tmp_list_of_scenario->{$scenario}{'name'},
+- 'web_title' => $tmp_list_of_scenario->{$scenario}{'web_title'}};
+- }
+- $param->{'scenari_edit'}{$edit}{'selected'} = 'selected="selected"';
+-
+- ## father directory
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
+- $param->{'father'} = &no_slash_end($1);
+- }else {
+- $param->{'father'} = '';
+- }
+- $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
+-
+- $param->{'set_owner'} = 1;
+-
+- $param->{'father_icon'} = $icon_table{'father'};
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+-
+- #*******************************************
+- # Function : do_d_change_access
+- # Description : Saves the description of
+- # the file
+- #******************************************
+-
+- sub do_d_change_access {
+- &wwslog('info', 'do_d_change_access(%s)', $in{'path'});
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+-
+- my $list_name = $list->{'name'};
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #### Controls
+-
+- ## the path must not be empty (the description file of the shared directory
+- # doesn't exist)
+- unless ($path) {
+- &report::reject_report_web('intern','cannot_describe_shared_directory',{'path' => $path },$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"do_d_change_access : Cannot change access $shareddir : root directory");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # the document to describe must already exist
+- unless (-e "$shareddir/$path") {
+- &report::reject_report_web('user','no_doc_to_describe',{'path'=> $path},$param->{'action'},$list);
+- &wwslog('info',"d_change_access : Unable to change access $shareddir/$path : no such document");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+-
+- # Access control
+- my %mode;
+- $mode{'control'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'control'}) {
+- &report::reject_report_web('auth','action_listmaster_or_privileged_owner_or_author',{},$param->{'action'},$list);
+- &wwslog('info','d_change_access : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## End of controls
+-
+- # Description file
+- $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- my $dir = $1;
+- my $file = $3;
+-
+- my $desc_file;
+- if (-d "$shareddir/$path") {
+- $desc_file = "$shareddir/$1$3/.desc";
+- } else {
+- $desc_file = "$shareddir/$1.desc.$3";
+- }
+-
+- if (-e "$desc_file"){
+- # if description file already exists : open it and modify it
+- my %desc_hash = &get_desc_file ("$desc_file");
+-
+- # Synchronization
+- unless (&synchronize($desc_file,$in{'serial'})){
+- &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
+- &wwslog('info',"d_change_access : Synchronization failed for $desc_file");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'synchro_failed','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- unless (open DESC,">$desc_file") {
+- &wwslog('info',"d_change_access : cannot open $desc_file : $!");
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # information not modified
+- print DESC "title\n $desc_hash{'title'}\n\n";
+-
+- # access rights
+- print DESC "access\n read $in{'read_access'}\n";
+- print DESC " edit $in{'edit_access'}\n\n";
+-
+- print DESC "creation\n";
+- # time
+- print DESC " date_epoch $desc_hash{'date'}\n";
+- # author
+- print DESC " email $desc_hash{'email'}\n\n";
+-
+- close DESC;
+-
+- } else {
+- # Creation of a description file
+- unless (open (DESC,">$desc_file")) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"d_change_access : Cannot create description file $desc_file : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- print DESC "title\n \n\n";
+-
+- my @info = stat "$shareddir/$path";
+- print DESC "creation\n date_epoch ".$info[10]."\n email\n\n";
+- print DESC "access\n read $in{'read_access'}\n";
+- print DESC " edit $in{'edit_access'}\n\n";
+-
+- close DESC;
+-
+- }
+-
+- return 'd_control';
+-
+-
+- }
+-
+- sub do_d_set_owner {
+- &wwslog('info', 'do_d_set_owner(%s)', $in{'path'});
+-
+- # Variables
+- my $desc_file;
+-
+- my $path = &no_slash_end($in{'path'});
+-
+- #moderation
+- my $visible_path = &make_visible_path($path);
+-
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #### Controls
+-
+- ## the path must not be empty (the description file of the shared directory
+- # doesn't exist)
+- unless ($path) {
+- &report::reject_report_web('intern','cannot_describe_shared_directory',{'path' => $path },$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"do_d_set_owner : Cannot change access $shareddir : root directory");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # the email must look like an email "somebody@somewhere"
+- unless (&tools::valid_email($in{'content'})) {
+- &report::reject_report_web('user','incorrect_email',{'email' => $in{'content'}},$param->{'action'},$list);
+- &wwslog('info',"d_set_owner : $in{'content'} : incorrect email");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'incorrect_email','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Access control
+- ## father directory
+- $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- my $dir = $1;
+- my $file = $3;
+- if (-d "$shareddir/$path") {
+- $desc_file = "$shareddir/$dir$file/.desc";
+- }else {
+- $desc_file = "$shareddir/$dir.desc.$file";
+- }
+-
+- my %mode;
+- $mode{'control'} = 1;
+- ## must be authorized to control father directory
+- #my %access = &d_access_control(\%mode,$1);
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'control'}) {
+- &report::reject_report_web('auth','action_listmaster_or_privileged_owner_or_author',{},$param->{'action'},$list);
+- &wwslog('info','d_set_owner : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authentication','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- my $may_set = 1;
+-
+- unless ($may_set) {
+- &report::reject_report_web('user','full_directory',{'directory'=> $visible_path},$param->{'action'},$list);
+- &wwslog('info',"d_set_owner : cannot set owner of a full directory");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'full_directory','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## End of controls
+-
+- my %desc_hash;
+-
+- if (-e "$desc_file"){
+- # if description file already exists : open it and modify it
+- %desc_hash = &get_desc_file ("$desc_file");
+-
+- # Synchronization
+- unless (&synchronize($desc_file,$in{'serial'})) {
+-
+- &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
+- &wwslog('info',"d_set_owner : Synchronization failed for $desc_file");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'synchro_failed','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- unless (open DESC,">$desc_file") {
+- &wwslog('info',"d_set_owner : cannot open $desc_file : $!");
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # information not modified
+- print DESC "title\n $desc_hash{'title'}\n\n";
+-
+- print DESC "access\n read $desc_hash{'read'}\n";
+- print DESC " edit $desc_hash{'edit'}\n\n";
+- print DESC "creation\n";
+- # time
+- print DESC " date_epoch $desc_hash{'date'}\n";
+-
+- #information modified
+- # author
+- print DESC " email $in{'content'}\n\n";
+-
+- close DESC;
+-
+- } else {
+- # Creation of a description file
+- unless (open (DESC,">$desc_file")) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"d_set_owner : Cannot create description file $desc_file : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- print DESC "title\n $desc_hash{'title'}\n\n";
+- my @info = stat "$shareddir/$path";
+- print DESC "creation\n date_epoch ".$info[10]."\n email $in{'content'}\n\n";
+-
+- print DESC "access\n read $access{'scenario'}{'read'}\n";
+- print DESC " edit $access{'scenario'}{'edit'}\n\n";
+-
+- close DESC;
+-
+- }
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- ## ONLY IF SET_OWNER can be performed even if not control of the father directory
+- $mode{'control'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+- unless ($access{'may'}{'control'}) {
+- ## father directory
+- $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- $in{'path'} = &no_slash_end($1);
+- return 'd_read';
+- }
+-
+- ## ELSE
+- return 'd_control';
+- }
+-
+- ## Protecting archives from Email Sniffers
+- sub do_arc_protect {
+- &wwslog('info', 'do_arc_protect()');
+-
+- return 1;
+- }
+-
+-####################################################
+-# do_remind
+-####################################################
+-# Sends a remind command to sympa.pl.
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest' | 'admin' | undef
+-#
+-#####################################################
+- sub do_remind {
+- &wwslog('info', 'do_remind()');
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_remind', 'remind'));
+-
+- my $extention = time.".".int(rand 9999) ;
+- my $mail_command;
+-
+- ## Sympa will require a confirmation
+- my $result = $list->check_list_authz('remind','smtp',
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- if ($r_action =~ /reject/i) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- &wwslog('info','remind : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+-
+- }else {
+- $mail_command = sprintf "REMIND %s", $param->{'list'};
+- }
+-
+- my $time = time;
+- my $data = {'headers' => {'Message-ID' => '<'.$time.'@wwsympa>',
+- 'X-Sympa-NoWrap' => 'yes'},
+- 'from'=> $param->{'user'}{'email'},
+- 'body' => $mail_command};
+-
+- $data->{'not_auto_submitted'} = 1;
+- unless (&mail::mail_file('',&Conf::get_robot_conf($robot, 'sympa'),$data,$robot)) {
+- &report::reject_report_web('intern','cannot_send_remind',{'from' => $param->{'user'}{'email'},'listname'=>$list->{'name'}},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_remind: failed to send message for command REMIND');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- &report::notice_report_web('performed_soon',{},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'admin';
+- }
+-
+- ## Load list certificat
+- sub do_load_cert {
+- &wwslog('info','do_load_cert(%s)', $param->{'list'});
+-
+- my @cert = $list->get_cert('der');
+- unless (@cert) {
+- &report::reject_report_web('user','missing_cert',{},$param->{'action'},$list);
+- &wwslog('info','do_load_cert: no cert for this list');
+- return undef;
+- }
+-
+- # don't you just HATE it when every single browser seems to want a
+- # different content-type for certificates? order is important, as
+- # everybody calls themselves "mozilla", and opera identifies as
+- # IE if told so (but Opera doesn't do S/MIME anyways, it seems)
+- my ($ua, $ct) = ($ENV{HTTP_USER_AGENT}, 'application/x-x509-email-cert');
+- if ($ua =~ /MSIE/) {
+- $ct = 'application/pkix-cert';
+- }
+- $param->{'bypass'} = 'extreme';
+- printf "Content-type: $ct\n\n";
+- foreach my $l (@cert) {
+- printf "$l";
+- }
+- return 1;
+- }
+-
+-
+-#*******************************************
+-# Function : do_upload_pictures
+-# Description : Creates a new pictures with a
+-# uploaded file
+-#******************************************
+-
+-sub do_upload_pictures {
+- # Parameters of the uploaded file (from suboptions.tt2)
+- my $fn = $query->param('uploaded_file');
+- &wwslog('info', 'do_upload_pictures(%s,%s)',$fn,$param->{'user'}{'email'});
+-
+- # name of the file, without path
+- my $fname;
+- if ($fn =~ /([^\/\\]+)$/) {
+- $fname = $1;
+- }
+-
+- # type of the file
+- my $filetype;
+- if ($fn =~ /\.(jpg|jpeg|png|gif)$/i) {
+- $filetype = $1;
+- }
+- else {$filetype = undef};
+-
+- my $filename = &tools::md5_fingerprint($param->{'user'}{'email'});
+- my $fullfilename = $filename.'.'.$filetype;
+-
+- #uploaded file must have a name
+- unless ($fname) {
+- &report::reject_report_web('user','no_name',{},$param->{'action'});
+- &wwslog('err',"do_upload_pictures : No file specified to upload");
+- return 'suboptions';
+- }
+-
+- unless($filetype) {
+- &report::reject_report_web('user','cannot_upload',{'path' => $fullfilename,
+- 'reason' => "your file does not have an authorized format." },$param->{'action'});
+- &wwslog('err',"do_upload_pictures : unauthorized format");
+- return 'suboptions';
+- }
+-
+- my $filetmp;
+-
+- #check if there is not already a file for the user with a different extension
+- foreach my $ext ('.gif','.png','.jpg','.jpeg') {
+- my $file = &Conf::get_robot_conf($robot,'pictures_path').'/'.$in{'list'}.'@'.$robot.'/'.$filename;
+- if(-f $file.$ext) {
+- rename($file.$ext,$file.$ext.'.tmp');
+- $filetmp = $file.$ext;
+- last;
+- }
+- }
+-
+- unless(&creation_picture_file(&Conf::get_robot_conf($robot,'pictures_path'),$param->{'list'}.'@'.$robot,$fullfilename)) {
+- &report::reject_report_web('user','upload_failed', {'path' => $fullfilename},$param->{'action'});
+- &wwslog('err','do_upload_pictures : Failed to create file %s/%s@%s%s',&Conf::get_robot_conf($robot,'pictures_path'),$param->{'list'},$robot,$filename);
+- return 'suboptions';
+- }
+- my $uploadedfile = &Conf::get_robot_conf($robot,'pictures_path').'/'.$in{'list'}.'@'.$robot.'/'.$fullfilename;
+- my @info = stat($uploadedfile);
+- my $size = $info[7];
+-
+- unless($size <= $Conf{'pictures_max_size'}) {
+- unlink($uploadedfile);
+- rename($filetmp.'.tmp',$filetmp);
+- &report::reject_report_web('user','cannot_upload',{'path' => $fullfilename,
+- 'reason' => "Your file exceeds the authorized size." },$param->{'action'});
+- &wwslog('err',"do_upload_pictures : Failed to upload pictures");
+- return 'suboptions';
+- }
+-
+- # message of success
+- unlink($filetmp.'.tmp');
+- &wwslog('info',"do_upload_pictures : Upload of the pictures succeeded");
+- return 'suboptions';
+-
+-}
+-
+-## Delete a picture file
+-sub do_delete_pictures {
+- &wwslog('info', 'do_delete_pictures(%s,%s,%s)', $param->{'list'},$robot,$param->{'user'}{'email'});
+-
+- my $email = $param->{'user'}{'email'};
+-
+- #deleted file must exist
+- unless(&tools::pictures_filename('email' => $email, 'list' => $list)) {
+- &report::reject_report_web('user','no_name',{},$param->{'action'},$list);
+- &wwslog('err',"do_delete_pictures : No file exists to delete");
+- return 'suboptions';
+- }
+-
+- unless($list->delete_user_picture($email)) {
+- &report::reject_report_web('intern','erase_file',{'file' => &tools::pictures_filename('email' => $email, 'list' => $list)},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_delete_pictures : Failed to erase ".&tools::pictures_filename('email' => $email, 'list' => $list));
+- return undef;
+- }
+- else {
+- &wwslog('notice',"do_delete_pictures : File deleted successfull");
+- return 'suboptions';
+- }
+-}
+-
+-
+-####################################################
+-# do_change_email_request
+-####################################################
+-# Checks a user's new email address and passes it
+-# to 'change_email'
+-#
+-# IN : -
+-#
+-# OUT : '1' | 'change_email'
+-#
+-####################################################
+-## Checks a users new email address by sending a ticket to the new email address
+-## and demanding that they click it to verify. Leads to 'change_email'
+-sub do_change_email_request {
+- &wwslog('info','do_change_email_request(%s)', $in{'new_email'});
+-
+- unless ($param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'new_email'},$robot,'change_email/'.$param->{'user'}{'email'},$ip)){
+-
+- &do_log('notice',"Unable to create one_time_ticket for $in{'new_email'}, service do_change_email_request");
+- }else{
+- &do_log('notice',"ticket : $param->{'one_time_ticket'}");
+- }
+-
+- $param->{'new_email'} = $in{'new_email'};
+- my $tt2_param = {'type' => 'ticket_to_send',
+- 'one_time_ticket' => $param->{'one_time_ticket'},
+- 'to' => $in{'new_email'},
+- };
+- unless (&List::send_global_file('user_notification', $in{'new_email'}, $robot, $tt2_param)) {
+- &do_log('notice',"Unable to send template 'user_notification' to $in{'new_email'}");
+- return undef;
+- }
+- return '1';
+-}
+-
+-
+-
+-####################################################
+-# do_change_email
+-####################################################
+-# Changes a user's email address in Sympa environment
+-#
+-# IN : -
+-#
+-# OUT : '1' | 'pref' | undef
+-#
+-####################################################
+-## Change a user's email address in Sympa environment
+-sub do_change_email {
+- &wwslog('info','do_change_email(%s)', $in{'email'});
+-
+- my ($old_email, $new_email);
+- my $edited_by_listmaster;
+-
+- unless ($in{'email'} || ($in{'old_email'} && $in{'new_email'})) {
+- &report::reject_report_web('user','Missing argument',{},$param->{'action'});
+- &wwslog('err',"Lacking parameter : $in{'email'} or $in{'old_email'} or $in{'new_email'} ");
+- &web_db_log({'parameters' => $in{'email'},$in{'old_email'},$in{'new_email'},
+- 'status' => 'error',
+- 'error_type' => 'user'});
+- }
+-
+- ## There are two ways to access this function 'change_email'. One from the preferences page and one from the serveradmin page
+- ## If the process comes from server admin it needs the variables 'old_email' and 'new_email'.
+- if ($in{'old_email'} && $in{'new_email'}) {
+- ## if variables old_email and new_email are present $edited_by_listmaster is set to one
+- ## so that at the end of the function we can return to the SympaAdmin page
+- ## instead of the preferences page
+- $edited_by_listmaster = 1;
+- unless (&List::is_listmaster ($param->{'user'}{'email'}, $robot)) {
+- &report::reject_report_web('auth','User is not Listmaster',{},$param->{'action'});
+- &wwslog('err','do_change_email : not listmaster');
+- &web_db_log({'parameters' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- $old_email = $in{'old_email'};
+- $new_email = $in{'new_email'};
+- }else {
+- $old_email = $in{'email'};
+- $new_email = $param->{'user'}{'email'};
+- }
+-
+- my ($password, $newuser);
+-
+- if ($newuser = &List::get_user_db($old_email)) {
+-
+- $password = $newuser->{'password'};
+- }
+-
+- ## Change email as list MEMBER
+- foreach my $list ( &List::get_which($old_email,$robot, 'member') ) {
+-
+-
+- my $l = $list->{'name'};
+-
+- my $user_entry = $list->get_subscriber($old_email);
+- if ($user_entry->{'included'} == 1) {
+- ## Notify list owner
+- $list->send_notify_to_owner('failed_to_change_included_member',{'current_email' => $old_email,
+- 'new_email' => $new_email,
+- 'datasource' => $list->get_datasource_name($user_entry->{'id'})});
+-
+- &report::reject_report_web('user','change_member_email_failed_included',{'listname'=>$list->{'name'}},
+- $param->{'action'},$list,$old_email,$robot);
+- &wwslog('err', 'could not change member email for list %s because member is included', $l);
+- next;
+- }
+-
+- ## Check if user is already member of the list with his new address
+- ## then we just need to remove the old address
+- if ($list->is_user($new_email)) {
+- unless ($list->delete_user('users' => [$old_email]) ) {
+- &report::reject_report_web('intern','delete_subscriber_db_failed',{'sub'=>$new_email},
+- $param->{'action'},$list,$old_email,$robot);
+- &wwslog('info', 'do_change_email: could not remove email from list %s', $l);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$new_email",'target_email' => "$new_email",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $old_email,'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- }else {
+-
+- unless ($list->update_user($old_email, {'email' => $new_email, 'update_date' => time}) ) {
+- &report::reject_report_web('intern','update_subscriber_db_failed',{'sub'=>$new_email},
+- 'old_email' => $old_email,
+- $param->{'action'},$list,$old_email,$robot);
+- &wwslog('info', 'do_change_email: could not change email for list %s', $l);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$new_email",'target_email' => "$new_email",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $old_email,'client' => $ip,'daemon' => $daemon_name});
+- }
+- }
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+-
+- ## Change email as list OWNER/MODERATOR
+- my %updated_lists;
+- foreach my $role ('owner', 'editor') {
+- foreach my $list ( &List::get_which($old_email,$robot, $role) ) {
+-
+- ## Check if admin is include via an external datasource
+- my $admin_user = $list->get_admin_user($role, $old_email);
+- if ($admin_user->{'included'}) {
+- ## Notify listmaster
+- &List::send_notify_to_listmaster('failed_to_change_included_admin',$robot,{'list' => $list,
+- 'current_email' => $old_email,
+- 'new_email' => $new_email,
+- 'datasource' => $list->get_datasource_name($admin_user->{'id'})});
+-
+- &report::reject_report_web('user','change_admin_email_failed_included',{'listname'=>$list->{'name'}},
+- $param->{'action'},$list,$old_email,$robot);
+- &wwslog('err', 'could not change %s email for list %s because admin is included', $role, $list->{'name'});
+- next;
+- }
+-
+- ## Go through owners/editors of the list
+- foreach my $admin (@{$list->{'admin'}{$role}}) {
+- next unless (lc($admin->{'email'}) eq lc($old_email));
+-
+- ## Update entry with new email address
+- $admin->{'email'} = $new_email;
+- $updated_lists{$list->{'name'}}++;
+- }
+-
+- ## Update Db cache for the list
+- $list->sync_include_admin();
+- $list->save_config();
+- }
+- }
+- ## Notify listmasters that list owners/moderators email have changed
+- if (keys %updated_lists) {
+- &List::send_notify_to_listmaster('listowner_email_changed',$robot,
+- {'list' => $list,
+- 'previous_email' => $old_email,
+- 'new_email' => $new_email,
+- 'updated_lists' => keys %updated_lists})
+- }
+-
+- ## Update User_table and remove existing entry first (to avoid duplicate entries)
+- &List::delete_user_db($new_email,);
+-
+- unless ( &List::update_user_db($old_email,
+- {'email' => $new_email,
+-
+- })) {
+- &report::reject_report_web('intern','update_user_db_failed',{'user'=>$new_email,
+- 'old_email' => $old_email},
+- $param->{'action'},'',$old_email,$robot);
+- &wwslog('info','change_email: update failed');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$new_email",'target_email' => "$new_email",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $old_email,'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## Update netidmap_table
+- unless ( &List::update_email_netidmap_db($robot, $old_email, $new_email) ){
+- &report::reject_report_web('intern','update_netidmap_failed',{'user'=>$new_email,
+- 'old_email' => $old_email},
+- $param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','change_email: update failed');
+- &web_db_log({'target_email' => $old_email,
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## Update the data structure that tells which lists the current user is member/owner/editor of
+- unless ($edited_by_listmaster == 1) {
+- @{$param->{'get_which'}} = &List::get_which($param->{'user'}{'email'},$robot,'member');
+- @{$param->{'get_which_owner'}} = &List::get_which($param->{'user'}{'email'},$robot,'owner');
+- @{$param->{'get_which_editor'}} = &List::get_which($param->{'user'}{'email'},$robot,'editor');
+- }
+-
+- if ($edited_by_listmaster == 1) {
+- return 'serveradmin';
+- }
+-
+-
+- if ($in{'previous_action'}) {
+- $in{'list'} = $in{'previous_list'};
+- return $in{'previous_action'};
+- }elsif ($edited_by_listmaster == 1) {
+- return 'serveradmin';
+- }
+-
+- return 'pref';
+-
+- }
+-
+-####################################################
+-# do_suspend_request
+-####################################################
+-# Suspend a subscription to one or more lists #
+-# for a given period: start date and end date #
+-# (or unlimited). The user may at any time #
+-# stop the suspension. #
+-# #
+-# IN : - #
+-# OUT : 'loginrequest' #
+-# | 'info' | undef #
+-# #
+-####################################################
+-sub do_suspend_request {
+-
+- &wwslog('info', 'do_suspend_request', $in{'action'}); #Action = suspend_request
+- my $email = $param->{'user'}{'email'};
+- my $data;
+-
+- ## Sets the date of the field "start date" to "today"
+- my @d_day = localtime(time);
+- $param->{'d_day'} = ($d_day[3])."-".($d_day[4]+1)."-".($d_day[5]+1900);
+- my $display_resume = 0;
+-
+- ## We display in the table the lists of the subscriber and the state in which they are.
+- ## reception : - nomail/digest/mail ||
+- ## - . suspended From XX/XX/XXXX To XX/XX/XXXX
+- my @lists = &List::get_which($email, $robot, 'member');
+-
+- foreach my $list (@lists) {
+- my $member_info = $list->get_subscriber($param->{'user'}{'email'});
+- if(($member_info->{'enddate'} < time) && ($member_info->{'enddate'})){
+- ## If end date is < time, update the BDD by deleting the suspending's data
+- &List::restore_suspended_subscription($param->{'user'}{'email'},$list->{'name'},$list->{'domain'});
+- }
+- my $final_start_date = gettext_strftime "%d %b %Y", localtime($member_info->{'startdate'});
+- my $final_end_date;
+-
+- if($member_info->{'suspend'} == 1){
+- $display_resume = 1;
+- }
+- if($member_info->{'enddate'}){
+- $final_end_date = gettext_strftime "%d %b %Y", localtime($member_info->{'enddate'});
+- }else{
+- $final_end_date = undef;
+- }
+-
+- $member_info->{'reception'} ||= 'mail';
+- $member_info->{'visibility'} ||= 'noconceal';
+- foreach my $mode (keys %wwslib::reception_mode) {
+- if ($list->is_available_reception_mode($mode)) {
+- $param->{'reception'}{$list->{'name'}}{$mode}{'description'} = sprintf(gettext($wwslib::reception_mode{$mode}->{'gettext_id'}));
+- if ($member_info->{'reception'} eq $mode) {
+- $param->{'reception'}{$list->{'name'}}{$mode}{'selected'} = 'selected="selected"';
+- }else {
+- $param->{'reception'}{$list->{'name'}}{$mode}{'selected'} = '';
+- }
+- }
+- }
+-
+- my $subscription = {'listname' => $list->{'name'},
+- 'listdomain' => $list->{'domain'},
+- 'listreception' => $member_info->{'reception'},
+- 'listsuspend' => $member_info->{'suspend'},
+- 'liststartdate' =>$final_start_date,
+- 'listenddate' => $final_end_date,
+- 'display' => $display_resume,
+- 'visibility' => $member_info->{'visibility'},
+- 'reception' => $param->{'reception'}{$list->{'name'}},
+- };
+- push @{$param->{'suspend_list'}}, $subscription;
+- }
+-
+- return 1;
+-}
+-
+-####################################################
+-# do_suspend_request_action
+-####################################################
+-# Suspend a subscription for lists. #
+-# Action from the suspend form. #
+-# #
+-# IN : %in : HASH with the form's values #
+-# OUT : 'pref' : action #
+-# | 'info' | undef #
+-####################################################
+-sub do_suspend_request_action {
+-
+- &wwslog('info', 'do_suspend_request_action', $in{'action'});
+-
+- my $day1;
+- my $month1;
+- my $year1;
+- my $day2;
+- my $month2;
+- my $year2;
+- my @lists;
+- my $data;
+-
+- if($in{'sub_action'} eq 'suspendsave'){
+-
+- # to retrieve the selected list
+- @lists = split /\0/, $in{'listname'};
+- my @list_selected;
+- foreach my $list (@lists){
+- unless($list eq ''){
+- push @list_selected, $list;
+- }
+- }
+-
+- if($list_selected[0] eq ''){
+- &report::reject_report_web('user','missing_arg',{'argument' => 'must picked one or more list(s) you are subscribed'}, $param->{'action'});
+- &wwslog('info','suspend_request: must picked one or more list(s) you are subscribed');
+- return 'suspend_request';
+- }
+-
+- if ($in{'date_deb'}){
+- ($day1, $month1, $year1) = split(/\-/, $in{'date_deb'});
+- $month1 = $month1-1;
+-
+- if (($day1 =~ /([0-9]*)/) && ($month1 =~ /([0-9]*)/) && ($year1 =~ /([0-9]*)/)){
+- if (((1<=$day1) && ($day1<=31)) && ((0<=$month1) && ($month1<=11)) && (1900<=$year1)){
+- ## Return an epoch date
+- $data->{'startdate'} = timelocal(0, 0, 0, $day1,$month1,$year1);
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'Start Date doesn\'t exist.'}, $param->{'action'});
+- &wwslog('info','suspend_request: Date doesn\'t exist.');
+- return 'suspend_request';
+- }
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'Start Date doesn\'t exist.'}, $param->{'action'});
+- &wwslog('info','suspend_request: Date doesn\'t exist.');
+- return 'suspend_request';
+- }
+- ## Case 1 : Start date & End date (without indefinite)
+- if (($in{'date_fin'}) && (!$in{'indefinite'})){
+- ($day2, $month2, $year2) = split(/\-/, $in{'date_fin'});
+- $month2 = $month2-1;
+-
+- if (($day2 =~ /([0-9]*)/) && ($month2 =~ /([0-9]*)/) && ($year2 =~ /([0-9]*)/)){
+- if (((1<=$day2) && ($day2<=31)) && ((0<=$month2) && ($month2<=11)) && (1900<=$year2)){
+- ## Return an epoch date
+- $data->{'enddate'} = timelocal(0, 0, 0, $day2,$month2,$year2);
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'End Date doesn\'t exist.'}, $param->{'action'});
+- &wwslog('info','suspend_request: Date doesn\'t exist.');
+- return 'suspend_request';
+- }
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'End Date doesn\'t exist.'}, $param->{'action'});
+- &wwslog('info','suspend_request: Date doesn\'t exist.');
+- return 'suspend_request';
+- }
+-
+- unless($data->{'startdate'} <= $data->{'enddate'}){
+- &report::reject_report_web('user','missing_arg',{'argument' => 'The start date must be less than the end date.'}, $param->{'action'});
+- &wwslog('info','suspend_request: The start date must be less than the end date.');
+- return 'suspend_request';
+- }
+- ## Case 2 : Start date & without indefinite (without end date)
+- }elsif((!$in{'date_fin'}) && ($in{'indefinite'})){
+- $data->{'enddate'} = undef;
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'Choose end date (dd/mm/yyyy) or indefinite end date'}, $param->{'action'});
+- &wwslog('info','suspend_request: missing argument for the end date or syntax error : dd/mm/yyyy or must choose a end date or indefinite end date');
+- return 'suspend_request';
+- }
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'Miss start date (dd/mm/yyyy)'}, $param->{'action'});
+- &wwslog('info','suspend_request: missing argument for the start date or syntax error : dd/mm/yyyy');
+- return 'suspend_request';
+- }
+-
+- ## Suspend subscription
+- foreach my $list (@list_selected){
+- unless(&List::suspend_subscription($param->{'user'}{'email'}, $list, $data, $robot)){
+- &wwslog('info','Can\'t do List suspend_subscription');
+- return 'suspend_request';
+- }
+- }
+-
+- &report::notice_report_web('performed',{},$in{'sub_action'});
+- }
+- ## Restore suspended subscription
+- elsif($in{'sub_action'} eq 'suspendstop'){
+-
+- # to renew membership lists selected
+- @lists = split /\0/, $in{'listname'};
+- foreach my $line (@lists) {
+- &List::restore_suspended_subscription($param->{'user'}{'email'}, $line, $robot);
+- }
+-
+- if($lists[0] eq ''){
+- &report::reject_report_web('user','missing_arg',{'argument' => 'must picked one or more list(s)'}, $param->{'action'});
+- &wwslog('info','suspend_request: must picked one or more list(s)');
+- return 'suspend_request';
+- }
+- &report::notice_report_web('performed',{},"Resume the subscription for the list(s)");
+-
+- }
+- ## Unsubscribe from the selected lists
+- elsif($in{'sub_action'} eq 'signoff'){
+-
+- # lists selected
+- @lists = split /\0/, $in{'listname'};
+- my $report = "";
+- foreach my $line (@lists) {
+-
+- my $unsub_list = new List ($line, $robot);
+- unless ($unsub_list) {
+- &wwslog('info', 'List %s unknown' , $unsub_list);
+- return undef;
+- }
+-
+- my %result = &unsubscribe($param->{'user'}{'email'}, $unsub_list);
+- if ($result{'success'} == 1) {
+- if ($result{'details'} eq 'sent_to_owner') {
+- $report .= sprintf(gettext("Your unsubscription request to list %s was sent to the list owner."),$unsub_list->{'name'});
+- }else{
+- $report .= sprintf(gettext("You were successfully unsubscribed from list %s."),$unsub_list->{'name'});
+- }
+- }else{
+- if ($result{'category_error'} eq 'auth') {
+- $report .= sprintf(gettext("Unsubscription from list %s denied: Unsubscription from this list is closed."),$unsub_list->{'name'});
+- }else{
+- $report .= sprintf(gettext("Unsubscription from list %s failed."),$unsub_list->{'name'});
+- }
+- }
+- $report .= "\n";
+-
+- }
+- if($lists[0] eq ''){
+- &report::reject_report_web('user','missing_arg',{'argument' => 'must picked one or more list(s)'}, $param->{'action'});
+- &wwslog('info','suspend_request: must picked one or more list(s)');
+- return 'suspend_request';
+- }
+-
+- &report::notice_report_web($report,{},'');
+- }else{
+- &report::reject_report_web('user','unknown_action',{},$in{'sub_action'},$list);
+- &wwslog('info','unknown action %s', $in{'sub_action'});
+- return undef;
+- }
+-
+- return 'suspend_request';
+-}
+-
+-####################################################
+-# do_compose_mail
+-####################################################
+-sub do_compose_mail {
+-
+- &wwslog('info', 'do_compose_mail', $in{'subaction'});
+-
+- unless ($param->{'may_post'}) {
+- &report::reject_report_web('auth',$param->{'may_post_reason'},{},$param->{'action'},$list);
+- &wwslog('info','do_compose_mail: may not send message');
+- return undef;
+- }
+-
+- # Set the subaction to html_news_letter or undef
+- $param->{'subaction'} = $in{'subaction'};
+- if ($in{'to'}) {
+- # In archive we hide email replacing @ by ' '. Here we must do the reverse transformation
+- $in{'to'} =~ s/ /\@/g;
+- $param->{'to'} = $in{'to'};
+- }else{
+- $param->{'to'} = $list->get_list_address();
+- }
+- foreach my $recipient (split(',',$param->{'to'})) {
+- ($param->{'recipients'}{$recipient}{'local_to'},$param->{'recipients'}{$recipient}{'domain_to'}) = split ('@',$recipient);
+- }
+- $param->{'mailto'}= &mailto($list,$param->{'to'});
+- # headers will be encoded later.
+- #XXX$param->{'subject'}= &MIME::Words::encode_mimewords($in{'subject'});
+- $param->{'subject'} = $in{'subject'};
+- $param->{'in_reply_to'}= '<'.$in{'in_reply_to'}.'>';
+- $param->{'message_id'} = &tools::get_message_id($robot);
+-
+- if ($list->is_there_msg_topic()) {
+-
+- $param->{'request_topic'} = 1;
+-
+- foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
+- if ($top->{'name'}) {
+- push (@{$param->{'available_topics'}},$top);
+- }
+- }
+- $param->{'topic_required'} = $list->is_msg_topic_tagging_required();
+- }
+-
+- return 1;
+- }
+-
+-####################################################
+-# do_send_mail
+-####################################################
+-# Sends a message to a list by the Web interface
+-# or an html page getting its url.
+-# Need MIME::Lite - MIME::Lite::HTML - EMAIL::DATE::FORMAT
+-# It uses mail::mail_file() to do it.
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest'
+-# | 'info' | undef
+-#
+-####################################################
+- sub do_send_mail {
+-
+- &wwslog('info', 'do_send_mail');
+-
+- # Get the sender mail
+- my $from = $param->{'user'}{'email'};
+- my $to;
+- # Send the message to the list or to the sender as clicking the send to the list or to me.
+- # First if : send to the list
+- if ($in{'sub_action'} eq 'sendmailtolist'){
+-
+- # In archive we hide email replacing @ by ' '. Here we must do the reverse transformation
+- $in{'to'} =~ s/ /\@/g;
+- $to = $in{'to'};
+-
+- unless ($in{'to'}) {
+- unless ($param->{'list'}) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
+- &wwslog('info','do_send_mail: no list');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_list','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- unless ($param->{'may_post'}) {
+- &report::reject_report_web('auth',$param->{'may_post_reason'},{},$param->{'action'},$list);
+- &wwslog('info','do_send_mail: may not send message');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- $to = $list->get_list_address();
+- }
+- }
+-
+- # Send the mail to the sender. To test his message
+- # Second if : send to the sender "send to me"
+- if($in{'sub_action'} eq 'sendmailtome') {
+- #Set the sender mail to the addressee
+- $to = $from;
+- }
+-
+- if (defined $param->{'subscriber'}) {
+- $from = &tools::addrencode($from, $param->{'subscriber'}{'gecos'},
+- &Language::GetCharset());
+- }
+-
+- ##--------------- TOPICS --------------------
+- my $list_topics;
+- if ($list->is_there_msg_topic()) {
+- my @msg_topics;
+-
+- foreach my $msg_topic (@{$list->{'admin'}{'msg_topic'}}) {
+- my $var_name = "topic_"."$msg_topic->{'name'}";
+- if ($in{"$var_name"}) {
+- push @msg_topics, $msg_topic->{'name'};
+- }
+- }
+-
+- $list_topics = join(',',@msg_topics);
+- }
+-
+- if (!$list_topics && $list->is_msg_topic_tagging_required()) {
+- &report::reject_report_web('user','msg_topic_missing',{},$param->{'action'});
+- &wwslog('info','do_send_mail: message(s) without topic but in a required list');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_topic','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- if ($list_topics) {
+- my $filetopic = $list->tag_topic($in{'message_id'},$list_topics,'sender');
+- }
+-
+- ##--------------- send an html page or a message --------------------
+-
+- if ($in{'html_news_letter'}) {
+-
+- # url should not be empty -> missing argument
+- if ($in{'url'} =~ /^\s*$/) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'url'},$param->{'action'});
+- ($Log::log_level >= 0) && &wwslog('info','Missing url');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_url','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Generate a newsletter from an HTML URL and send it to a list by the Web interface.
+- # Else you must use parse routine of MIME::Lite::HTML and send of MIME::Lite.
+- my $mailHTML = new MIME::Lite::HTML(
+- {
+- From => $from,
+- To => $to,
+- Headers => {'In-Reply-To' => $in{'in_reply_to'}, 'Message-ID' => $in{'message_id'}},
+- 'return_path' => &Conf::get_robot_conf($robot, 'sympa'),
+- Subject => $in{'subject'},
+- HTMLCharset => 'utf-8',
+- TextCharset => 'utf-8',
+- TextEncoding => '8bit',
+- HTMLEncoding => '8bit',
+- remove_jscript => '1', #delete the scripts in the html
+- }
+- );
+- my $pages_url;
+- $pages_url = $in{'url'};
+-
+- # parse return the MIME::Lite part to send
+- my $MIMEmail = $mailHTML->parse($pages_url);
+-
+- $in{'body'} = $MIMEmail->as_string;
+-
+- }else{
+-
+- ## Message body should not be empty
+- if ($in{'body'} =~ /^\s*$/) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'body'},$param->{'action'});
+- ($Log::log_level >= 0) && &wwslog('info','Missing body');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_body','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- $in{'body'} = "\n".$in{'body'};
+- }
+-
+- my $data = {'headers' => {'Message-ID' => $in{'message_id'}},
+- 'subject' => $in{'subject'},
+- 'return_path' => &Conf::get_robot_conf($robot, 'sympa'),
+- 'to' => $to,
+- 'body' => "From: $from\n" . $in{'body'},
+- 'sign_mode' => '',
+- 'header_possible' => '1'};
+-
+- $data->{'headers'}{'In-Reply-To'} = $in{'in_reply_to'} if (($in{'in_reply_to'}) && $in{'in_reply_to'} ne '<>');
+- $data->{'not_auto_submitted'} = 1;
+- unless (&mail::mail_file('', $to, $data, $robot)) {
+- &report::reject_report_web('intern','cannot_send_mail',{'from' => $param->{'user'}{'email'},'listname'=>$list->{'name'}},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_send_mail: failed to send message for $to list');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'info';
+-
+- }
+-
+-####################################################
+-# do_request_topic
+-####################################################
+-# Web page for a sender to tag his mail in message
+-# topic context.
+-#
+-# IN : -
+-#
+-# OUT : '1' | 'loginrequest' | undef
+-#
+-####################################################
+- sub do_request_topic {
+- &wwslog('info', 'do_request_topic(%s)', $in{'authkey'});
+-
+- unless ($list->is_there_msg_topic()) {
+- &report::reject_report_web('user','no_topic',{},$param->{'action'},$list);
+- &wwslog('info','do_request_topic: list without topic message');
+- return undef;
+- }
+-
+- foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
+- if ($top->{'name'}) {
+- push (@{$param->{'available_topics'}},$top);
+- }
+- }
+-
+- $param->{'to'} = $list->get_list_address();
+- $param->{'mailto'}= &mailto($list,$param->{'to'});
+- $param->{'authkey'} = $in{'authkey'};
+-
+- my $listname = $list->{'name'};
+- my $authqueue = &Conf::get_robot_conf($robot,'queueauth');
+- my $filename = "$authqueue\/$listname\_$in{'authkey'}";
+-
+- ## For compatibility concerns
+- foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
+- $filename = $authqueue.'/'.$list_id.'_'.$in{'authkey'};
+- last if (-f $filename);
+- }
+-
+- my $parser;
+- unless ($parser = new MIME::Parser) {
+- &report::reject_report_web('intern','cannot_parse_message',{'file' => $filename},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('notice', 'Cannot parse message %s', $filename);
+- return undef;
+- }
+- $parser->output_to_core(1);
+-
+- unless (open FILE, "$filename") {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $filename},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('notice', 'Cannot open file %s', $filename);
+- return undef;
+- }
+- my $msg = $parser->parse(\*FILE);
+- my $head = $msg->head();
+- # headers will be encoded later.
+- #XXX$param->{'subject'}= &MIME::Words::encode_mimewords($head->get('subject'));
+- $param->{'subject'} = MIME::EncWords::decode_mimewords($head->get('subject'), Charset=>'utf8');
+- chomp $param->{'subject'};
+- $param->{'subject'} = &tools::escape_html($param->{'subject'});
+- $param->{'from'} = MIME::EncWords::decode_mimewords($head->get('from'), Charset=>'utf8');
+- chomp $param->{'from'};
+- $param->{'from'} = &tools::escape_html($param->{'from'});
+- $param->{'date'} = MIME::EncWords::decode_mimewords($head->get('date'), Charset=>'utf8');
+- chomp $param->{'date'};
+- $param->{'date'} = &tools::escape_html($param->{'date'});
+- $param->{'message_id'} = &tools::clean_msg_id($head->get('Message-Id'));
+-
+- my $body = $msg->bodyhandle();
+- if ($body) {
+- $param->{'body'} = $body->as_string();
+- }else{
+- $param->{'body'} = '';
+- }
+- $param->{'topic_required'} = $list->is_msg_topic_tagging_required();
+-
+- return 1;
+- }
+-
+-####################################################
+-# do_tag_topic_by_sender
+-####################################################
+-# Tag a mail by its sender : tag the mail and
+-# send a command CONFIRM for it
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest' | 'info' | undef
+-#
+-####################################################
+- sub do_tag_topic_by_sender {
+- &wwslog('info', 'do_tag_topic_by_sender');
+-
+- my $parser;
+- my $listname = $list->{'name'};
+- my $authqueue = &Conf::get_robot_conf($robot,'queueauth');
+- my $filename = "$authqueue\/$listname".'@'."$robot\_$in{'authkey'}";
+-
+- my $mail ;
+- unless($mail = new Message($filename,'noxsympato')) {
+- &report::reject_report_web('intern','cannot_parse_message',{'file' => $filename},$param->{'action'});
+- &wwslog('info','do_tag_topic_by_sender: cannot parse message %s',$filename);
+- return undef;
+- }
+- my $sender = $mail->{'sender'};
+-
+- unless ($list->is_there_msg_topic()) {
+- &report::reject_report_web('user','no_topic',{},$param->{'action'},$list);
+- &wwslog('info','do_tag_topic_by_sender: list without topic message');
+- return undef;
+- }
+-
+- my @msg_topics;
+- foreach my $msg_topic (@{$list->{'admin'}{'msg_topic'}}) {
+- my $var_name = "topic_"."$msg_topic->{'name'}";
+- if ($in{"$var_name"}) {
+- push @msg_topics, $msg_topic->{'name'};
+- }
+- }
+- my $list_topics = join(',',@msg_topics);
+-
+- if (!$list_topics && $list->is_msg_topic_tagging_required()) {
+- &report::reject_report_web('user','msg_topic_missing',{},$param->{'action'},$list);
+- &wwslog('info','do_tag_topic_by_sender: message without topic but in a required list');
+- return undef;
+- }
+-
+- ## TAG
+- my $filetopic = $list->tag_topic($in{'message_id'},$list_topics,'sender');
+-
+- ## CONFIRM
+- my $time = time;
+- my $data = {'headers' => {'Message-ID' => '<'.$time.'@wwsympa>',
+- 'X-Sympa-NoWrap' => 'yes'},
+- 'from'=> $sender};
+-
+- $data->{'body'} = sprintf ("QUIET CONFIRM %s\n",$in{'authkey'});
+-
+- my $queueauth = &Conf::get_robot_conf($robot, 'queueauth');
+- my $filemsg = "$queueauth/$list->{'name'}_$in{'authkey'}";
+-
+- ## For compatibility concerns
+- foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
+- $filemsg = $queueauth.'/'.$list_id.'_'.$in{'authkey'};
+- last if (-f $filemsg);
+- }
+-
+- unless ($filemsg && (-r $filemsg)) {
+- &report::reject_report_web('intern','tag_topic_by_sender_failed',{'key' => $in{'authkey'}},$param->{'action'},$robot);
+- &wwslog('err', 'do_tag_topic_by_sender: Unable to find message %s from %s, auth failed', $in{'authkey'},$param->{'user'}{'email'});
+- return undef;
+- }
+-
+- $data->{'not_auto_submitted'} = 1;
+- unless (&mail::mail_file('',&Conf::get_robot_conf($robot, 'sympa'),$data,$robot)) {
+- &report::reject_report_web('intern','cannot_send_mail',{'from' => $param->{'user'}{'email'},'listname'=>$list->{'name'}},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_tag_topic_by_sender: failed to send message for file %s', $filemsg);
+- return undef;
+- }
+-
+- &report::notice_report_web('performed_soon',{},$param->{'action'});
+- return 'info';
+- }
+-
+-
+-
+- sub do_search_user {
+- &wwslog('info', 'do_search_user');
+-
+- if ($in{'email'} =~ /[<>\\\*\$]/) {
+- &report::reject_report_web('user','syntax_errors',{'params' => 'email'},$param->{'action'});
+- &wwslog('err','do_search_user: syntax error');
+- return undef;
+- }
+-
+- foreach my $role ('member','owner','editor') {
+- foreach my $list ( &List::get_which($in{'email'},$robot, $role) ) {
+- my $l = $list->{'name'};
+-
+- next unless (defined $list);
+- $param->{'which'}{$l}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'which'}{$l}{'host'} = $list->{'admin'}{'host'};
+-
+- # show the requestor role not the requested one
+- if ( ($list->am_i('owner',$param->{'user'}{'email'}) || $list->am_i('editor',$param->{'user'}{'email'})) ) {
+- $param->{'which'}{$l}{'admin'} = 1;
+- }
+-
+- if ($role eq 'member') {
+- $param->{'which'}{$l}{'is_member'} = 1;
+- $param->{'which'}{$l}{'reception'} = $list->{'user'}{'reception'};
+- $param->{'which'}{$l}{'include_source'} = $list->{'user'}{'include_source'};
+- $param->{'which'}{$l}{'bounce'} = $list->{'user'}{'bounce'} ;
+- $param->{'which'}{$l}{'topic'} = $list->{'user'}{'topic'} ;
+- $param->{'which'}{$l}{'included'} = $list->{'user'}{'included'} if ($list->{'user'}{'included'} == 1) ;
+- $param->{'which'}{$l}{'subscribed'} = $list->{'user'}{'subscribed'} if ($list->{'user'}{'subscribed'} == 1);
+- my $un = $list->{'user'}{'subscribed'};
+-# $param->{'which'}{$l}{'subscribed'} = 1;
+-
+- }elsif ($role eq 'owner') {
+- $param->{'which'}{$l}{'is_owner'} = 1;
+- }elsif ($role eq 'editor') {
+- $param->{'which'}{$l}{'is_editor'} = 1;
+- }
+- }
+- }
+-
+- $param->{'email'} = $in{'email'};
+-
+- unless (defined $param->{'which'}) {
+- &report::reject_report_web('user','no_entry',{'email' => $in{'email'}},$param->{'action'});
+- &wwslog('info','do_search_user: no entry for %s', $in{'email'});
+- return 'serveradmin';
+- }
+-
+- return 1;
+- }
+-
+- ## Set language
+- sub do_set_lang {
+- &wwslog('info', 'do_set_lang(%s)', $in{'lang'});
+-
+- $session->{'lang'} = $in{'lang'} ;
+- $param->{'lang'} = $in{'lang'};
+-
+- if ($param->{'user'}{'email'}) {
+- if (&List::is_user_db($param->{'user'}{'email'})) {
+- unless (&List::update_user_db($param->{'user'}{'email'}, {'lang' => $in{'lang'}})) {
+- &report::reject_report_web('intern','update_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_set_lang: update failed');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'lang'}",'target_email' => "$param->{'user'}{'email'}",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }else {
+- unless (&List::add_user_db({'email' => $param->{'user'}{'email'}, 'lang' => $in{'lang'}})) {
+- &report::reject_report_web('intern','add_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_set_lang: update failed');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'lang'}",'target_email' => "$param->{'user'}{'email'}",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+- }
+-
+- if ($in{'previous_action'}) {
+- ## Some actions don't make sense with GET method, redirecting to other functions
+- if ($in{'previous_action'} eq 'arcsearch') {
+- $in{'previous_action'} = 'arc';
+- }
+- $in{'list'} = $in{'previous_list'};
+- return $in{'previous_action'};
+- }
+-
+- return 'home';
+- }
+- ## Function do_attach
+- sub do_attach {
+- &wwslog('info', 'do_attach(%s,%s)', $in{'dir'},$in{'file'});
+-
+-
+- ### Useful variables
+-
+- # current list / current shared directory
+- my $list_name = $list->{'name'};
+-
+- # path of the urlized directory
+- my $urlizeddir = $list->{'dir'}.'/urlized';
+-
+- # document to read
+- my $doc = $urlizeddir.'/'.$in{'dir'}.'/'.$in{'file'};
+-
+- ### Document exist ?
+- unless (-e "$doc") {
+- &wwslog('info',"do_attach : unable to read $doc : no such file or directory");
+- &report::reject_report_web('user','no_such_document',{'path' => $in{'dir'}.'/'.$in{'file'}},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'dir'},$in{'file'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### Document has non-size zero?
+- unless (-s "$doc") {
+- &wwslog('info',"do_attach : unable to read $doc : empty document");
+- &report::reject_report_web('user','empty_document',{'path' => $in{'dir'}.'/'.$in{'file'}},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'dir'},$in{'file'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'empty_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_attach', 'web_archive.access'));
+-
+- # parameters for the template file
+- # view a file
+- $param->{'file'} = $doc;
+- $param->{'bypass'} = 'asis';
+-
+- ## File type
+- if ($in{'file'} =~ /\.(\w+)$/) {
+- $param->{'file_extension'} = $1;
+- }
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'dir'},$in{'file'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- sub do_subindex {
+- &wwslog('info', 'do_subindex');
+-
+- my $subscriptions = $list->get_subscription_requests();
+- foreach my $sub (keys %{$subscriptions}) {
+- $subscriptions->{$sub}{'date'} = gettext_strftime "%d %b %Y", localtime($subscriptions->{$sub}{'date'});
+- }
+-
+- $param->{'subscriptions'} = $subscriptions;
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- sub do_ignoresub {
+- &wwslog('info', 'do_ignoresub');
+-
+- my @users;
+-
+- foreach my $pair (split /\0/, $in{'pending_email'}) {
+- if ($pair =~ /,/) {
+- push @users, $`;
+- }
+- }
+-
+- foreach my $u (@users) {
+- unless ($list->delete_subscription_request($u)) {
+- &report::reject_report_web('intern','del_sub_request',{'sub'=>$u},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_ignoresub: delete_subscription_request(%s) failed', $u);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'subindex';
+- }
+- }
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'subindex';
+- }
+-
+-sub do_stats {
+- &wwslog('info', 'do_stats');
+-
+- $param->{'shared_size'} = int (($list->get_shared_size + 512)/1024);
+- $param->{'arc_size'} = int (($list->get_arc_size($wwsconf->{'arc_path'}) + 512)/1024);
+-
+- return 1;
+-}
+-
+-
+-## setting the topics list for templates
+-sub export_topics {
+-
+- my $robot = shift;
+- wwslog ('debug2',"export_topics($robot)");
+- my %topics = &List::load_topics($robot);
+-
+- unless (%topics) {
+- &wwslog('err','No topics defined');
+- return undef;
+- }
+-
+- ## Remove existing topics
+- $param->{'topics'} = undef;
+-
+- my $total = 0;
+- foreach my $t (sort {$topics{$a}{'order'} <=> $topics{$b}{'order'}} keys %topics) {
+- my $result = &Scenario::request_action ('topics_visibility', $param->{'auth_method'},$robot,
+- {'topicname' => $t,
+- 'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $action;
+- $action = $result->{'action'} if (ref($result) eq 'HASH');
+- next unless ($action =~ /do_it/);
+-
+- my $current = $topics{$t};
+- $current->{'id'} = $t;
+-
+- ## For compatibility reasons
+- $current->{'mod'} = $total % 3;
+- $current->{'mod2'} = $total % 2;
+-
+- push @{$param->{'topics'}}, $current;
+-
+- $total++;
+- }
+-
+- push @{$param->{'topics'}}, {'id' => 'topicsless',
+- 'mod' => $total,
+- 'sub' => {}
+- };
+-
+- $param->{'topics'}[int($total / 2)]{'next'} = 1;
+- }
+-
+-
+-# manage blacklist
+-sub do_blacklist {
+- &wwslog('info', 'do_blacklist(%d)', $param->{'list'});
+-
+- unless ($param->{'list'}){
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
+- &wwslog('info','do_blacklist: no list');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_list','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- unless($param->{'is_owner'}|| $param->{'is_editor'} || $param->{'is_listmaster'}) {
+- &wwslog('info','do_blacklist : not listmaster or list owner or list editor');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- my $file = $list->{'dir'}.'/search_filters/blacklist.txt';
+- $param->{'rows'} = 0 ;
+-
+- if (defined $in{'blacklist'}){
+- &wwslog('info','do_blacklist : submit blacklist update');
+- my $dir = $list->{'dir'}.'/search_filters';
+- unless ((-d $dir) || mkdir ($dir, 0755)) {
+- &report::reject_report_web('intern','unable to create dir');
+- &wwslog('info','do_blacklist : unable to create dir %s',$dir);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+- my $file = $dir.'/blacklist.txt';
+- unless (open BLACKLIST, "> $file"){
+- &report::reject_report_web('intern','unable to create file');
+- &wwslog('info','do_blacklist : unable to create file %s',$file);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+- my @lines = split(/\n/, $in{'blacklist'});
+- $param->{'ignored'} = 0;
+- my $count = 0; # count utils lines in order to remove empty blacklist file
+- foreach my $line (@lines) {
+- $line =~ s/\015//;
+-
+- if ($line =~ /\*.*\*/) {
+- $param->{'ignored_linest'} .= $line."\n";
+- $param->{'ignored'} += 1;
+- }else{
+- printf BLACKLIST "$line\n";
+- $param->{'blacklist'} .= $line."\n";
+- $param->{'rows'} += 1;
+- $count += 1 unless ($line =~ /^\s*$/o || /^[\#\;]/o);
+- }
+- }
+- close BLACKLIST;
+- if ($count == 0) {
+- unless (unlink $file) {
+- &report::reject_report_web('intern','unable to remove empty blacklist file');
+- &wwslog('info','do_blacklist : unable to remove empty blacklist file %s',$file);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+- &wwslog('info','do_blacklist : removed empty blacklist file %s',$file);
+- }
+- }else{
+- if (-f $file) {
+- unless (open BLACKLIST, $file) {
+- &report::reject_report_web('intern','unable to open file',{'file' => $file,$param->{'action'},'',$param->{'user'}{'email'}},$robot);
+- &wwslog('err','unable to read %s',$file);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+- while (<BLACKLIST>) {
+- $param->{'blacklist'} .= $_ ;
+- $param->{'rows'} += 1;
+- }
+- close BLACKLIST;
+- }
+- }
+-
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+-}
+-
+-# output in text/plain format a scenario
+-sub do_dump_scenario {
+- &wwslog('info', "do_dump_scenario($param->{'list'}), $in{'pname'}");
+-
+- my $scenario = new Scenario ('function' => $in{'pname'},
+- 'robot' => $robot,
+- 'name' => $list->{'admin'}{$in{'pname'}}{'name'},
+- 'directory' => $list->{'dir'});
+- unless (defined $scenario) {
+- &report::reject_report_web('intern','cannot_open_file',{},$param->{'action'},$list);
+- &wwslog('info','failed to load scenario');
+- return undef;
+- }
+- ($param->{'dumped_scenario'}, $param->{'scenario_path'}) = ($scenario->{'data'}, $scenario->{'file_path'});
+- $param->{'pname'} = $in{'pname'};
+- $param->{'scenario_name'} = $list->{'admin'}{$in{'pname'}}{'name'};
+-
+- if ($in{'new_scenario_name'}) {
+- # in this case it's a submit.
+- my $scenario_dir = $list->{'dir'}.'/scenari/';
+- my $scenario_file = $scenario_dir.$in{'pname'}.'.'.$in{'new_scenario_name'} ;
+- if ($param->{'dumped_scenario'} eq $in{'new_scenario_content'}){
+- &wwslog('info','do_dump_scenario: scenario unchanged');
+- $param->{'result'} = 'unchanged';
+- return 1;
+- }
+- unless (-d $scenario_dir) {
+- unless (mkdir ($scenario_dir, 0777)) {
+- &do_log('err',"do_dump_scenario: cannot_create_dir %s : %s ", $scenario_dir, $!);
+- &report::reject_report_web('intern','cannot_create_dir',{'file' => $scenario_dir,$param->{'action'},'',$param->{'user'}{'email'}},$robot);
+- return undef;
+- }
+- }
+- unless (open SCENARIO , ">$scenario_file") {
+- &wwslog('info','do_dump_scenario: cannot_open_file %s', $scenario_file);
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $scenario_file,$param->{'action'},'',$param->{'user'}{'email'}},$robot);
+- return undef;
+- }
+- print SCENARIO $in{'new_scenario_content'};
+- close SCENARIO;
+- # load the new scenario in the list config.
+- if ($in{'new_scenario_name'} eq $in{'scenario_name'}) {
+- $param->{'result'} = 'success';
+- }else{
+- $param->{'result'} = 'success_new_name';
+- }
+- }
+- return 1 ;
+-}
+-
+- ## Subscribers' list
+- sub do_dump {
+- &wwslog('info', "do_dump($param->{'list'})");
+-
+- ## Whatever the action return, it must never send a complex html page
+- $param->{'bypass'} = 1;
+- $param->{'content_type'} = "text/plain";
+- $param->{'file'} = undef ;
+-
+- ## Access control
+- unless (defined &check_authz('do_dump', 'review')) {
+- undef $param->{'bypass'};
+- return undef;
+- }
+-
+- $list->dump();
+- $param->{'file'} = $list->{'dir'}.'/subscribers.db.dump';
+-
+- if ($in{'format'} eq 'light') {
+- unless (open (DUMP,$param->{'file'} )) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $param->{'file'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog ('info', 'unable to open file %s\n',$param->{'file'} );
+- return undef;
+- }
+- unless (open (LIGHTDUMP,">$param->{'file'}.light")) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => "$param->{'file'}.light"},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err','unable to create file %s.light\n',$param->{'file'} );
+- return undef;
+- }
+- while (<DUMP>){
+- next unless ($_ =~ /^email\s(.*)/);
+- print LIGHTDUMP "$1\n";
+- }
+- close LIGHTDUMP;
+- close DUMP;
+- $param->{'file'} = "$list->{'dir'}/subscribers.db.dump.light";
+-
+- } else {
+- $param->{'file'} = "$list->{'dir'}/select.dump";
+- &wwslog('info','opening %s',$param->{'file'});
+-
+- unless (open (DUMP,">$param->{'file'}")) {
+- &report::reject_report_web('intern','file_update_failed',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err','unable to create file %s\n',$param->{'file'} );
+- return undef;
+- }
+-
+- if ($in{'format'} eq 'bounce') {
+- $in{'size'} = 'all';
+- do_reviewbouncing();
+- print DUMP "# Exported bouncing subscribers\n";
+- print DUMP "# Email\t\tName\tBounce score\tBounce count\tFirst bounce\tLast bounce\n";
+- foreach my $user (@{$param->{'members'}}){
+- print DUMP "$user->{'email'}\t$user->{'gecos'}\t$user->{'bounce_score'}\t$user->{'bounce_count'}\t$user->{'first_bounce'}\t$user->{'last_bounce'}\n";
+- }
+- }
+- else {
+- $in{'filter'} = $in{'format'};
+- do_search();
+- print DUMP "# Exported subscribers with search filter \"$in{'format'}\"\n";
+- foreach my $user (@{$param->{'members'}}){
+- print DUMP "$user->{'email'}\t$user->{'gecos'}\n";
+- }
+- }
+- close DUMP;
+- }
+- return 1;
+- }
+-
+-
+-## returns a mailto according to list spam protection parameter
+-sub mailto {
+-
+- my $list = shift;
+- my $email = shift;
+- my $gecos = shift;
+- my $next_one;
+-
+- my $mailto = '';
+- my @addresses;
+- my %recipients;
+-
+- @addresses = split (',',$email);
+-
+- $gecos = $email unless ($gecos);
+- $gecos =~ s/&/&/g;
+- $gecos =~ s/</</g;
+- $gecos =~ s/>/>/g;
+- foreach my $address (@addresses) {
+-
+- ($recipients{$address}{'local'},$recipients{$address}{'domain'}) = split ('@',$address);
+- }
+-
+- if ($list->{'admin'}{'spam_protection'} eq 'none') {
+- $mailto .= "<a href=\"mailto:?";
+- foreach my $address (@addresses) {
+- $mailto .= "&" if ($next_one);
+- $mailto .= "to=$address";
+- $next_one = 1;
+- }
+- $mailto .= "\">$gecos</a>";
+- }elsif($list->{'admin'}{'spam_protection'} eq 'javascript') {
+-
+- if ($gecos =~ /\@/) {
+- $gecos =~ s/@/\" + \"@\" + \"/;
+- }
+-
+- $mailto .= "<script type=\"text/javascript\">
+- <!--
+- document.write(\"<a href=\\\"\" + \"mail\" + \"to:?\" + ";
+- foreach my $address (@addresses) {
+- $mailto .= "\"\&\;\" + " if ($next_one);
+- $mailto .= "\"to=\" + \"$recipients{$address}{'local'}\" + \"@\" + \"$recipients{$address}{'domain'}\" + ";
+- $next_one = 1;
+- }
+- $mailto .= "\"\\\">$gecos<\" + \"/a>\")
+- // --></script>";
+-
+- }elsif($list->{'admin'}{'spam_protection'} eq 'at') {
+- foreach my $address (@addresses) {
+- $mailto .= " AND " if ($next_one);
+- $mailto .= "$recipients{$address}{'local'} AT $recipients{$address}{'domain'}";
+- $next_one = 1;
+- }
+- }
+- return $mailto;
+-
+-}
+-
+-## Returns a spam-protected form of email address
+-sub get_protected_email_address {
+- my ($local_part, $domain_part) = @_;
+-
+- if($list->{'admin'}{'spam_protection'} eq 'javascript') {
+-
+- my $return = "<script type=\"text/javascript\">
+- <!--
+- document.write(\"$local_part\" + \"@\" + \"$domain_part\")
+- // --></script>";
+- return ($return);
+- }elsif($list->{'admin'}{'spam_protection'} eq 'at') {
+- return ("$local_part AT $domain_part");
+- }else {
+- return($local_part.'@'.$domain_part);
+- }
+-
+-}
+-
+- ## view logs stored in RDBMS
+- ## this function as been writen in order to allow list owner and listmater to views logs
+- ## of there robot or there is real problems with privacy policy and law in such services.
+- ##
+-sub do_viewlogs {
+- &wwslog('info', 'do_viewlogs(%d)',$in{'page'});
+-
+- my $size = $in{'size'} || $wwsconf->{'viewlogs_page_size'};
+- my $sortby = $in{'sortby'} || 'email';
+- my @date = &Log::get_log_date();
+-
+- $param->{'date_from_formated'} = gettext_strftime "%Y-%m-%d-%H-%M-%S", localtime($date[0]);
+- $param->{'date_to_formated'} = gettext_strftime "%Y-%m-%d-%H-%M-%S", localtime($date[1]);
+-
+- $param->{'total'} = '17';
+-
+- unless ($param->{'total'}) {
+- &report::reject_report_web('user','no_logs',{},$param->{'action'});
+- &wwslog('info','do_viewlogs: no subscriber');
+- return 1;
+- }
+-
+- ## Owner
+- $param->{'page'} = $in{'page'} || 1;
+- $param->{'total_page'} = int ($param->{'total'} / $size);
+- $param->{'total_page'} ++ if ($param->{'total'} % $size);
+-
+- if ($param->{'page'} > $param->{'total_page'}) {
+- &report::reject_report_web('user','no_page',{'page' => $param->{'page'}},$param->{'action'});
+- ('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'review',$param->{'list'},$robot,'','out of pages');
+- &wwslog('info','do_viewlogs: no page %d', $param->{'page'});
+- return undef;
+- }
+-
+- my $offset;
+- if ($param->{'page'} > 1) {
+- $offset = (($param->{'page'} - 1) * $size);
+- }else {
+- $offset = 0;
+- }
+-
+-
+- my @lines;
+-
+- #display and search parameters preparation
+- my $select = {};
+-
+- $select->{'robot'} = $robot;
+- $select->{'list'} = $param->{'list'};
+-
+- foreach my $p ('target_type','target','date_deb','date_fin','type','ip') {
+- $param->{$p} = $in{$p};
+- $select->{$p} = $in{$p};
+- }
+-
+- unless ($in{'first'}) {
+- #sending of search parameters for the query
+- my $line = &Log::get_first_db_log($select);
+- unless (defined $line) {
+- &report::reject_report_web('intern','db_error',{},$param->{'action'}, $param->{'list'}, $param->{'user'}{'email'}, $robot);
+- &wwslog('info','do_viewlogs failed to get logs from DB');
+- return undef;
+- }
+-
+- do {
+- last unless (defined $line->{'date'}); ## Means an empty entry
+- $line->{'date'} = gettext_strftime "%d %b %Y %H:%M:%S", localtime($line->{'date'});
+- push @{$param->{'log_entries'}}, $line;
+- } while ($line = &Log::get_next_db_log());
+-
+-
+- #display the number of rows of the query.
+- if (&Log::return_rows_nb() != 0) {
+- $param->{'rows_nb'} = &Log::return_rows_nb();
+- }else {
+- $param->{'rows_nb'} = undef;
+- }
+-
+- if ($param->{'page'} > 1) {
+- $param->{'prev_page'} = $param->{'page'} - 1;
+- }
+-
+- unless (($offset + $size) >= $param->{'total'}) {
+- $param->{'next_page'} = $param->{'page'} + 1;
+- }
+-
+- $param->{'size'} = $size;
+- $param->{'sortby'} = $sortby;
+- }
+-
+-
+- return 1;
+-}
+-
+-
+-sub do_arc_manage {
+- &wwslog('info', "do_arc_manage ($in{'list'})");
+-
+- my $search_base = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
+- opendir ARC, "$search_base";
+- foreach my $dir (sort {$b cmp $a} grep(!/^\./,readdir ARC)) {
+- if ($dir =~ /^(\d{4})-(\d{2})$/) {
+- push @{$param->{'yyyymm'}}, $dir;
+- }
+- }
+- closedir ARC;
+-
+- return 1;
+-}
+-
+-## create a zip file with archives from (list,month)
+-sub do_arc_download {
+-
+- &wwslog('info', "do_arc_download ($in{'list'})");
+-
+- ##zip file name:listname_archives.zip
+- my $zip_file_name = $in{'list'}.'_archives.zip';
+- my $zip_abs_file = $Conf{'tmpdir'}.'/'.$zip_file_name;
+- my $zip = Archive::Zip->new();
+-
+- #Search for months to put in zip
+- unless (defined($in{'directories'})) {
+- &report::reject_report_web('user','select_month',{},$param->{'action'});
+- &wwslog('info','do_arc_download : no archives specified');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'select_month','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'arc_manage';
+- }
+-
+- #for each selected month
+- foreach my $dir (split/\0/, $in{'directories'}) {
+- ## Tainted vars problem
+- if ($dir =~ /^(\d+\-\d+)$/) {
+- $dir = $1;
+- }
+-
+- my $abs_dir = $wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$dir.'/arctxt';
+- ##check arc directory
+- unless (-d $abs_dir) {
+- &report::reject_report_web('intern','arc_not_found',{'arc_file' => $dir,
+- 'listname' => $in{'list'},
+- 'path' => $abs_dir},
+- $param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','archive %s not found',$dir);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- next;
+- }
+-
+- $zip->addDirectory($abs_dir, $in{'list'}.'_'.$dir);
+-
+- unless (opendir SPOOL, $abs_dir) {
+- &report::reject_report_web('intern','cannot_open_dir',{'dir' =>$abs_dir },$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_arc_download: unable to open %s', $abs_dir);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- foreach my $msg (sort grep(!/^\./, readdir SPOOL)) {
+- unless ($zip->addFile ($abs_dir.'/'.$msg, $in{'list'}.'_'.$dir.'/'.$msg)) {
+- &report::reject_report_web('intern','add_file_zip',{'file' => "$abs_dir/$msg"},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_arc_download: failed to add %s file to archive', $abs_dir.'/'.$msg);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- closedir SPOOL;
+-
+- ## create and fill a new folder in zip
+- #$zip->addTree ($abs_dir, $in{'list'}.'_'.$dir);
+- }
+-
+- ## check if zip isn't empty
+- if ($zip->numberOfMembers()== 0) {
+- &report::reject_report_web('intern','inaccessible_archive',{'listname' => $in{'list'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','Error : empty directories');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- ##writing zip file
+- unless ($zip->writeToFileNamed($zip_abs_file) == AZ_OK){
+- &report::reject_report_web('intern','write_file_zip',{'zipfile'=>$zip_abs_file},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog ('info', 'Error while writing Zip File %s\n',$zip_file_name);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ##Sending Zip to browser
+- $param->{'bypass'} ='extreme';
+- printf("Content-Type: application/zip;\nContent-disposition: filename=\"%s\";\n\n",$zip_file_name);
+- ##MIME Header
+- unless (open (ZIP,$zip_abs_file)) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $zip_abs_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog ('info', 'Error while reading Zip File %s\n',$zip_abs_file);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- print <ZIP>;
+- close ZIP ;
+-
+- ## remove zip file from server disk
+- unless (unlink ($zip_abs_file)){
+- &report::reject_report_web('intern','erase_file',{'file' => $zip_abs_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog ('info', 'Error while unlinking File %s\n',$zip_abs_file);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+-}
+-
+-sub do_arc_delete {
+-
+- my @abs_dirs;
+-
+- &wwslog('info', "do_arc_delete ($in{'list'})");
+-
+- unless (defined $in{'directories'}){
+- &report::reject_report_web('user','select_month',{},$param->{'action'});
+- &wwslog('info','No Archives months selected');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'select_month','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'arc_manage';
+- }
+-
+- ## if user want to download archives before delete
+- &wwslog('notice', "ZIP: $in{'zip'}");
+- if ($in{'zip'} == 1) {
+- &do_arc_download();
+- }
+-
+-
+- foreach my $dir (split/\0/, $in{'directories'}) {
+- push(@abs_dirs ,$wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$dir);
+- }
+-
+- unless (tools::remove_dir(@abs_dirs)) {
+- &wwslog('info','Error while Calling tools::remove_dir');
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'arc_manage';
+-}
+-
+-
+-sub do_css {
+- &wwslog('debug', "do_css ($in{'file'})");
+- $param->{'bypass'} = 'extreme';
+- printf "Content-type: text/css\n\n";
+- $param->{'css'} = $in{'file'};
+-
+- my $lang = &Language::Lang2Locale($param->{'lang'});
+- my $tt2_include_path = &tools::make_tt2_include_path($robot,'web_tt2',$lang,'');
+-
+- unless (&tt2::parse_tt2($param,'css.tt2' ,\*STDOUT, $tt2_include_path)) {
+- my $error = &tt2::get_error();
+- $param->{'tt2_error'} = $error;
+- &List::send_notify_to_listmaster('web_tt2_error', $robot, [$error]);
+- &wwslog('info', "do_css/$in{'file'} : error");
+- }
+-
+- return;
+-}
+-
+-sub do_rss_request {
+- &wwslog('info', "do_rss_request");
+-
+- my $args ;
+-
+- $in{'count'} ||= 20;
+- $in{'for'} ||= 10;
+-
+- $args = 'count='.$in{'count'}.'&' if ($in{'count'}) ;
+- $args .= 'for='.$in{'for'} if ($in{'for'});
+- if ($list ) {
+- $param->{'latest_arc_url'} = &Conf::get_robot_conf($robot, 'wwsympa_url')."/rss/latest_arc/".$list->{'name'}."?".$args;
+- $param->{'latest_d_read_url'} = &Conf::get_robot_conf($robot, 'wwsympa_url')."/rss/latest_d_read/".$list->{'name'}."?".$args;
+- }
+- $param->{'active_lists_url'} = &Conf::get_robot_conf($robot, 'wwsympa_url')."/rss/active_lists?".$args;
+- $param->{'latest_lists_url'} = &Conf::get_robot_conf($robot, 'wwsympa_url')."/rss/latest_lists?".$args;
+-
+- $param->{'output'} = 1;
+- return 1;
+-}
+-
+-sub do_wsdl {
+-
+- &wwslog('info', "do_wsdl ()");
+- my $sympawsdl = &tools::get_filename('etc',{}, 'sympa.wsdl', $robot);
+-
+- unless (-r $sympawsdl){
+- &report::reject_report_web('intern','err_404',{},$param->{'action'});
+- &wwslog('err','could not find $sympawsdl');
+- return undef;
+- }
+-
+- my $soap_url= &Conf::get_robot_conf($robot,'soap_url');
+- unless (defined $soap_url) {
+- &report::reject_report_web('user','no_soap_service',{},$param->{'action'});
+- &wwslog('err','No SOAP service was defined in sympa.conf (soap_url parameter)');
+- return undef;
+- }
+-
+- $param->{'bypass'} = 'extreme';
+- printf "Content-type: text/xml\n\n";
+-
+- $param->{'conf'}{'soap_url'} = $soap_url;
+-
+- ## Get the directory path, without the file name
+- my $wsdl_path = $sympawsdl;
+- $wsdl_path =~ s/\/sympa.wsdl//;
+-
+- &tt2::parse_tt2($param, 'sympa.wsdl' , \*STDOUT, [$wsdl_path]);
+-
+-# unless (open (WSDL,$sympawsdl)) {
+-# &error_message('404');
+-# &wwslog('info','could not open $sympawsdl');
+-# return undef;
+-# }
+-# print <WSDL>;
+-# close WSDL;
+- return 1;
+-}
+-
+-## Synchronize list members with data sources
+-sub do_sync_include {
+- &wwslog('info', "do_sync_include($in{'list'})");
+-
+- unless ($list->sync_include()) {
+- &report::reject_report_web('intern','sync_include_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- return undef;
+- }
+- &report::notice_report_web('subscribers_updated',{},$param->{'action'});
+- return 'review';
+-}
+-
+-## Review lists from a family
+-sub do_review_family {
+- &wwslog('info', 'do_review_family');
+-
+- my $family = new Family ($in{'family_name'}, $robot);
+- unless (defined $family) {
+- &report::reject_report_web('user','unknown_family',{'family'=>$in{'family_name'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err', 'do_review_family: incorrect family %s', $in{'family_name'});
+- return undef;
+- }
+-
+- my $all_lists = $family->get_family_lists();
+- foreach my $flist (@{$all_lists}) {
+- my $l = $list->{'name'};
+-
+- unless (defined $flist) {
+- &wwslog('err', 'do_review_family: incorrect list %s', $l);
+- next;
+- }
+- push @{$param->{'family_lists'}}, {'name' => $flist->{'name'},
+- 'status' => $flist->{'admin'}{'status'},
+- 'instantiation_date' => $flist->{'admin'}{'latest_instantiation'}{'date'},
+- 'subject' => $flist->{'admin'}{'subject'},
+- };
+- }
+-
+- return 1;
+-}
+-
+-################################################################
+-## do_ca : executes a custom action
+-##
+-## IN:
+-## - 'custom_action': ther name of the custom action (and subsequent tt2 file to use, see below)
+-## - '@cap': an array of parameters.
+-##
+-## Custom actions are used to display user defined templates.
+-## To use it, follow these steps:
+-## 1- create a new file "your_action.tt2" and put it in the relevant dir (either etc or expl)
+-## 2- in this file, add the HTML fragment you want to insert to the web interface. You don't need the <head/> section or the <body/> tag.
+-## 3- you can type your action URL: http://your-sympa-server-root-url/ca/your_action/param2/param2/param3/...
+-##
+-## the HTML code in 'your_action.tt2' can make use of the parameters this way: [% cap.1 %] for param1, [% cap.2 %] for param, and so on.
+-###############################################################
+-sub do_ca {
+- &wwslog('info', 'custom action: %s (robot %s) with params: (%s, %s, %s, %s, %s)',$in{'custom_action'},$robot,$in{'cap'});
+- $param->{'custom_action'} = $in{'custom_action'};
+- $param->{'cap'} = [split '/',$in{'cap'}];
+- return 1;
+-}
+-
+-################################################################
+-## do_ca : executes a custom action in list context
+-##
+-## IN:
+-## - 'custom_action': ther name of the custom action (and subsequent tt2 file to use, see below)
+-## - 'list': the nalme of the list (without the '@robot' part) in the context of which the action is executed.
+-## - '@lcap': an array of parameters.
+-##
+-## Custom actions are used to display user defined templates.
+-## To use it, follow these steps:
+-## 1- create a new file "your_action.tt2" and put it in the relevant dir (either etc or expl)
+-## 2- in this file, add the HTML fragment you want to insert to the web interface. You don't need the <head/> section or the <body/> tag.
+-## 3- you can type your action URL: http://your-sympa-server-root-url/ca/your_action/param2/param2/param3/...
+-##
+-## the HTML code in 'your_action.tt2' can make use of the parameters this way: [% lcap.1 %] for param1, [% lcap.2 %] for param, and so on.
+-###############################################################
+-sub do_lca {
+- &wwslog('info', 'List custom action: %s for list %s (robot %s) with params: (%s, %s, %s, %s, %s)',$in{'custom_action'},$in{'list'},$robot,$in{'lcap'});
+- $param->{'custom_action'} = $in{'custom_action'};
+- $param->{'cap'} = [split '/',$in{'cap'}];
+- return 1;
+-}
+-
+-## Prepare subscriber data to be prompted on the web interface
+-## Used by review, search,...
+-sub _prepare_subscriber {
+- my $user = shift;
+- my $additional_fields = shift;
+- my $sources = shift;
+-
+- ## Add user
+- $user->{'date'} = gettext_strftime "%d %b %Y", localtime($user->{'date'});
+- $user->{'update_date'} = gettext_strftime "%d %b %Y", localtime($user->{'update_date'});
+-
+- ## Reception mode and topics
+- $user->{'reception'} ||= 'mail';
+- if (($user->{'reception'} eq 'mail') && $user->{'topics'}) {
+- $user->{'reception'} = "topic ($user->{'topics'})";
+- }
+-
+- $user->{'email'} =~ /\@(.+)$/;
+- $user->{'domain'} = $1;
+- $user->{'pictures_url'} = &tools::make_pictures_url('email' => $user->{'email'}, 'list' => $list);
+-
+- ## Escape some weird chars
+- $user->{'escaped_email'} = &tools::escape_chars($user->{'email'});
+-
+- ## Check data sources
+- $user->{'sources'} = $list->get_datasource_name($user->{'id'}) if ($user->{'id'});
+-
+- if (@{$additional_fields}) {
+- my @fields;
+- foreach my $f (@{$additional_fields}) {
+- push @fields, $user->{$f};
+- }
+- $user->{'additional'} = join ',', @fields;
+- }
+-
+- return 1;
+-}
+-
+-## New d_read function using SharedDocument module
+-## The following features should be tested :
+-## * inheritance on privileges
+-## X moderation
+-## * escaping special chars
+-sub new_d_read {
+- &wwslog('info', 'new_d_read(%s)', $in{'path'});
+-
+- ### action relative to a list ?
+- unless ($param->{'list'}) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
+- &wwslog('err','do_d_read: no list');
+- return undef;
+- }
+-
+- # current list / current shared directory
+- my $list_name = $list->{'name'};
+-
+- my $document = new SharedDocument ($list, $in{'path'}, $param);
+-
+- unless (defined $document) {
+- &report::reject_report_web('intern','new_document_failed',{'path'=>$in{'path'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_read : cannot open $document->{'absolute_path'} : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- my $path = $document->{'path'};
+- my $visible_path = $document->{'visible_path'};
+- my $shareddir = $document->{'shared_dir'};
+- my $doc = $document->{'absolute_path'};
+- my $ref_access = $document->{'access'}; my %access = %{$ref_access};
+- $param->{'doc_owner'} = $document->{'owner'};
+- $param->{'doc_title'} = $document->{'title'};
+- $param->{'doc_date'} = $document->{'date'};
+-
+- ### Access control
+- unless ($access{'may'}{'read'}) {
+- &report::reject_report_web('auth',$access{'reason'}{'read'},{},$param->{'action'},$list);
+- &wwslog('err','d_read : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- my $may_edit = $access{'may'}{'edit'};
+- my $may_control = $access{'may'}{'control'};
+- $param->{'may_edit'} = $may_edit;
+- $param->{'may_control'} = $may_control;
+-
+- ### File or directory ?
+- if ($document->{'type'} eq 'url') {
+- $param->{'file_extension'} = $document->{'file_extension'};
+- $param->{'redirect_to'} = $document->{'url'};
+- return 1;
+-
+- }elsif ($document->{'type'} eq 'file') {
+- $param->{'file'} = $document->{'absolute_path'};
+- $param->{'bypass'} = 1;
+- return 1;
+-
+- }else { # directory
+-
+- $param->{'empty'} = $#{$document->{'subdir'}} == -1;
+-
+- # subdirectories hash
+- my %subdirs;
+- # file hash
+- my %files;
+-
+- ## for the exception of index.html
+- # name of the file "index.html" if exists in the directory read
+- my $indexhtml;
+-
+- # boolean : one of the subdirectories or files inside
+- # can be edited -> normal mode of read -> d_read.tt2;
+- my $normal_mode;
+-
+- my $path_doc;
+- my %desc_hash;
+- my $may, my $def_desc;
+-
+- foreach my $subdocument (@{$document->{'subdir'}}) {
+-
+- my $d = $subdocument->{'filename'};
+- my $path_doc = $subdocument->{'path'};
+-
+- ## Subdir
+- if ($subdocument->{'type'} eq 'directory') {
+-
+- if ($subdocument->{'access'}{'may'}{'read'}) {
+-
+- $subdirs{$d} = $subdocument->dup();
+- $subdirs{$d}{'doc'} = $subdocument->{'visible_filename'};
+- $subdirs{$d}{'escaped_doc'} = $subdocument->{'escaped_filename'};
+-
+- if ($param->{'user'}{'email'}) {
+- if ($subdocument->{'access'}{'may'}{'control'} == 1) {
+-
+- $subdirs{$d}{'edit'} = 1; # or = $may_action_edit ?
+- # if index.html, must know if something can be edit in the dir
+- $normal_mode = 1;
+- }elsif ($subdocument->{'access'}{'may'}{'edit'} != 0) {
+- # $may_action_edit = 0.5 or 1
+- $subdirs{$d}{'edit'} = $subdocument->{'access'}{'may'}{'edit'};
+- # if index.html, must know if something can be edit in the dir
+- $normal_mode = 1;
+- }
+-
+- if ($subdocument->{'access'}{'may'}{'control'}) {
+- $subdirs{$d}{'control'} = 1;
+- }
+- }
+- }
+- }else {
+- # case file
+-
+- if ($subdocument->{'access'}{'may'}{'read'}) {
+-
+- $files{$d} = $subdocument->dup();
+-
+- $files{$d}{'doc'} = $subdocument->{'visible_filename'};
+- $files{$d}{'escaped_doc'} = $subdocument->{'escaped_filename'};
+-
+- ## exception of index.html
+- if ($d =~ /^(index\.html?)$/i) {
+- $indexhtml = $1;
+- }
+-
+- if ($param->{'user'}{'email'}) {
+- if ($subdocument->{'access'}{'may'}{'edit'} == 1) {
+- $normal_mode = 1;
+- $files{$d}{'edit'} = 1; # or = $may_action_edit ?
+- } elsif ($subdocument->{'access'}{'may'}{'edit'} != 0){
+- # $may_action_edit = 1 or 0.5
+- $normal_mode = 1;
+- $files{$d}{'edit'} = $subdocument->{'access'}{'may'}{'edit'};
+- }
+-
+- if ($subdocument->{'access'}{'may'}{'control'}) {
+- $files{$d}{'control'} = 1;
+- }
+- }
+- }
+- }
+- }
+-
+- ### Exception : index.html
+- if ($indexhtml) {
+- unless ($normal_mode) {
+- $param->{'file_extension'} = 'html';
+- $param->{'bypass'} = 1;
+- $param->{'file'} = $document->{'absolute_path'};
+- return 1;
+- }
+- }
+-
+- ## to sort subdirs
+- my @sort_subdirs;
+- my $order = $in{'order'} || 'order_by_doc';
+- $param->{'order_by'} = $order;
+- foreach my $k (sort {by_order($order,\%subdirs)} keys %subdirs) {
+- push @sort_subdirs, $subdirs{$k};
+- }
+-
+- ## to sort files
+- my @sort_files;
+- foreach my $k (sort {by_order($order,\%files)} keys %files) {
+- push @sort_files, $files{$k};
+- }
+-
+- # parameters for the template file
+- $param->{'list'} = $list_name;
+-
+- $param->{'father'} = $document->{'father_path'};
+- $param->{'escaped_father'} = $document->{'escaped_father_path'} ;
+- $param->{'description'} = $document->{'title'};
+- $param->{'serial_desc'} = $document->{'serial_desc'};
+- $param->{'path'} = $document->{'path'};
+- $param->{'visible_path'} = $document->{'visible_path'};
+- $param->{'escaped_path'} = $document->{'escaped_path'};
+-
+- if (scalar keys %subdirs) {
+- $param->{'sort_subdirs'} = \@sort_subdirs;
+- }
+- if (scalar keys %files) {
+- $param->{'sort_files'} = \@sort_files;
+- }
+- }
+- $param->{'father_icon'} = $icon_table{'father'};
+- $param->{'sort_icon'} = $icon_table{'sort'};
+-
+-
+- ## Show expert commands / user page
+-
+- # for the curent directory
+- if ($may_edit == 0 && $may_control == 0) {
+- $param->{'has_dir_rights'} = 0;
+- } else {
+- $param->{'has_dir_rights'} = 1;
+- if ($may_edit == 1) { # (is_author || ! moderated)
+- $param->{'total_edit'} = 1;
+- }
+- }
+-
+- # set the page mode
+- if ($in{'show_expert_page'} && $param->{'has_dir_rights'}) {
+- $session->{'shared_mode'}='expert';
+- if ($param->{'user'}{'prefs'}{'shared_mode'} ne 'expert') {
+- # update user pref as soon as connected user change shared mode
+- $param->{'user'}{'prefs'}{'shared_mode'} = 'expert';
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+- $param->{'expert_page'} = 1;
+-
+- } elsif ($in{'show_user_page'}) {
+- $session->{'shared_mode'}='basic';
+- if ($param->{'user'}{'prefs'}{'shared_mode'} ne 'basic') {
+- # update user pref as soon as connected user change shared mode
+- $param->{'user'}{'prefs'}{'shared_mode'} = 'basic';
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+- $param->{'expert_page'} = 0;
+- } else {
+- if ($session->{'shared_mode'} eq 'expert' && $param->{'has_dir_rights'}) {
+- $param->{'expert_page'} = 1;
+- } else {
+- $param->{'expert_page'} = 0;
+- }
+- }
+-
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+-}
+-
+-
+-## Check authorizations to the current action
+-## used in common cases where actions fails unless result is 'do_it'
+-## It does not apply to actions that can be moderated
+-sub check_authz {
+- my ($subname, $action) = @_;
+-
+- my $result = $list->check_list_authz($action,$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'} || 'nobody',
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- unless ($r_action =~ /do_it/i) {
+- &report::reject_report_web('auth',$reason,{'login'=> $param->{'need_login'}},$param->{'action'});
+- &wwslog('info','check_authz: access denied in %s for %s', $subname, $param->{'user'}{'email'});
+- return undef;
+- }
+-
+- return 1;
+-}
+-
+-sub get_server_details {
+- ## All Robots are shown to super listmaster
+- if (&List::is_listmaster($param->{'user'}{'email'})) {
+- $param->{'main_robot'} = 1;
+- $param->{'robots'} = $Conf{'robots'};
+- }
+-
+- ## Families
+- my @families = &Family::get_available_families($robot);
+-
+- if (@families) {
+- $param->{'families'} = \@families;
+- }
+-}
+-
+-sub get_icon {
+- my $type = shift;
+-
+- return $icon_table{$type};
+-}
+-
+-sub get_mime_type {
+- my $type = shift;
+-
+- return $mime_types->{$type};
+-}
+-
+-sub do_maintenance {
+- &wwslog('notice', 'do_maintenance()');
+-
+- return 1;
+-}
+-
+-=pod
+-
+-=head1 AUTHORS
+-
+-=over
+-
+-=item * Serge Aumont <sa AT cru.fr>
+-
+-=item * Olivier Salaun <os AT cru.fr>
+-
+-=back
+-
+-=cut
diff --git a/6.1.7/patches/03_rename_lists_no_pending.actual b/6.1.7/patches/03_rename_lists_no_pending.actual
new file mode 100644
index 0000000000000000000000000000000000000000..f9d7c99668c37245e963c05a8ee2ed602cd4d71b
--- /dev/null
+++ b/6.1.7/patches/03_rename_lists_no_pending.actual
@@ -0,0 +1,16948 @@
+diff --git a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
+index c062cb9..cba0fb3 100644
+--- a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
++++ b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
+@@ -10303,9 +10303,9 @@ sub do_rename_list {
+ }
+
+ # set list status to pending if creation list is moderated
+- if ($param->{'status'} eq 'pending') {
+- &report::notice_report_web('pending_list',{},$param->{'action'},$list);
+- }
++# if ($param->{'status'} eq 'pending') {
++# &report::notice_report_web('pending_list',{},$param->{'action'},$list);
++# }
+
+ if ($in{'new_robot'} eq '$robot') {
+ $param->{'redirect_to'} = "$param->{'base_url'}$param->{'path_cgi'}/admin/$in{'new_listname'}";
+diff --git a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in.orig b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in.orig
+deleted file mode 100644
+index e6f8ba6..0000000
+--- a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in.orig
++++ /dev/null
+@@ -1,16925 +0,0 @@
+-#!--PERL-- -U
+-# wwsympa.fcgi - This script provides the web interface to Sympa
+-# RCS Identication ; $Revision: 7135 $ ; $Date: 2011-07-15 16:33:38 +0200 (ven 15 jui 2011) $
+-#
+-# Sympa - SYsteme de Multi-Postage Automatique
+-# Copyright (c) 1997-2003 Comite Reseau des Universites
+-#
+-# This program is free software; you can redistribute it and/or modify
+-# it under the terms of the GNU General Public License as published by
+-# the Free Software Foundation; either version 2 of the License, or
+-# (at your option) any later version.
+-#
+-# This program is distributed in the hope that it will be useful,
+-# but WITHOUT ANY WARRANTY; without even the implied warranty of
+-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-# GNU General Public License for more details.
+-#
+-# You should have received a copy of the GNU General Public License
+-# along with this program; if not, write to the Free Software
+-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+-
+-## Copyright 1999 Comit� R�seaux des Universit�s
+-## web interface to Sympa mailing lists manager
+-## Sympa: http://www.sympa.org/
+-## Authors :
+-## Serge Aumont <sa AT cru.fr>
+-## Olivier Sala�n <os AT cru.fr>
+-=pod
+-
+-=head1 NAME
+-
+-I<wwsympa.fcgi> - Sympa web interface
+-
+-=head1 DESCRIPTION
+-
+-This fcgi script completely handles all aspects of the Sympa web interface
+-
+-=cut
+-
+-use lib '--modulesdir--';
+-
+-use Getopt::Long;
+-use Archive::Zip;
+-
+-use strict 'vars';
+-use Time::Local;
+-use MIME::Lite::HTML;
+-
+-## Sympa API
+-use List;
+-use mail;
+-use Conf;
+-use confdef;
+-use Commands;
+-use Language;
+-use Log;
+-use Auth;
+-use admin;
+-use SharedDocument;
+-use report;
+-use SympaSession;
+-use Log;
+-use tools;
+-use time_utils;
+-use Sympa::Constants;
+-use wwslib;
+-use cookielib;
+-use Robot;
+-use tt2;
+-#use DateTime;
+-#use open ':utf8'; ## Default is to consider files utf8
+-
+-use Mail::Header;
+-use Mail::Address;
+-
+-my $crypt_openssl_x509_ok;
+-BEGIN {
+- if (eval "require Crypt::OpenSSL::X509") {
+- require Crypt::OpenSSL::X509;
+- $crypt_openssl_x509_ok = 1;
+- } else {
+- $crypt_openssl_x509_ok = 0;
+- }
+-};
+-
+-## WWSympa librairies
+-my %options;
+-
+-## Configuration
+-my $wwsconf = {};
+-
+-## Change to your wwsympa.conf location
+-my $conf_file = Sympa::Constants::WWSCONFIG;
+-my $sympa_conf_file = Sympa::Constants::CONFIG;
+-
+-
+-
+-my $loop = 0;
+-my $list;
+-my $param = {};
+-my ($robot, $robot_object);
+-my $ip ;
+-my $rss ;
+-my $session;
+-
+-## Load config
+-unless ($wwsconf = &wwslib::load_config($conf_file)) {
+- &fatal_err('Unable to load config file %s', $conf_file);
+-}
+-
+-## Load sympa config
+-unless (&Conf::load( $sympa_conf_file )) {
+- &fatal_err('Unable to load sympa config file %s', $sympa_conf_file);
+-}
+-
+-&Log::set_log_level($Conf{'log_level'}) if ($Conf{'log_level'});
+-
+-&mail::set_send_spool($Conf{'queue'});
+-
+-if ($wwsconf->{'use_fast_cgi'}) {
+- require CGI::Fast;
+-}else {
+- require CGI;
+-}
+-my $daemon_name = &Log::set_daemon($0);
+-
+-my $mime_types = &wwslib::load_mime_types();
+-
+-
+-# hash of all the description files already loaded
+-# format :
+-# $desc_files{pathfile}{'date'} : date of the last load
+-# $desc_files{pathfile}{'desc_hash'} : hash which describes
+-# the description file
+-
+-#%desc_files_map; NOT USED ANYMORE
+-
+-# hash of the icons linked with a type of file
+-my %icon_table;
+-
+- # application file
+-$icon_table{'unknown'} = $Conf{'static_content_url'}.'/icons/unknown.png';
+-$icon_table{'folder'} = $Conf{'static_content_url'}.'/icons/folder.png';
+-$icon_table{'current_folder'} = $Conf{'static_content_url'}.'/icons/folder.open.png';
+-$icon_table{'application'} = $Conf{'static_content_url'}.'/icons/unknown.png';
+-$icon_table{'octet-stream'} = $Conf{'static_content_url'}.'/icons/binary.png';
+-$icon_table{'audio'} = $Conf{'static_content_url'}.'/icons/sound1.png';
+-$icon_table{'image'} = $Conf{'static_content_url'}.'/icons/image2.png';
+-$icon_table{'text'} = $Conf{'static_content_url'}.'/icons/text.png';
+-$icon_table{'video'} = $Conf{'static_content_url'}.'/icons/movie.png';
+-$icon_table{'father'} = $Conf{'static_content_url'}.'/icons/back.png';
+-$icon_table{'sort'} = $Conf{'static_content_url'}.'/icons/down.png';
+-$icon_table{'url'} = $Conf{'static_content_url'}.'/icons/link.png';
+-$icon_table{'left'} = $Conf{'static_content_url'}.'/icons/left.png';
+-$icon_table{'right'} = $Conf{'static_content_url'}.'/icons/right.png';
+-## Shared directory and description file
+-
+-#$shared = 'shared';
+-#$desc = '.desc';
+-
+-
+-## subroutines
+-my %comm = ('home' => 'do_home',
+- 'logout' => 'do_logout',
+- 'loginrequest' => 'do_loginrequest',
+- 'login' => 'do_login',
+- 'sso_login' => 'do_sso_login',
+- 'sso_login_succeeded' => 'do_sso_login_succeeded',
+- 'subscribe' => 'do_subscribe',
+- 'multiple_subscribe' => 'do_multiple_subscribe',
+- 'subrequest' => 'do_subrequest',
+- 'subindex' => 'do_subindex',
+- 'suboptions' => 'do_suboptions',
+- 'signoff' => 'do_signoff',
+- 'auto_signoff' => 'do_auto_signoff',
+- 'multiple_signoff' => 'do_multiple_sigoff',
+- 'sigrequest' => 'do_sigrequest',
+- 'ignoresub' => 'do_ignoresub',
+- 'which' => 'do_which',
+- 'lists' => 'do_lists',
+- 'latest_lists' => 'do_latest_lists',
+- 'active_lists' => 'do_active_lists',
+- 'info' => 'do_info',
+- 'subscriber_count' => 'do_subscriber_count',
+- 'review' => 'do_review',
+- 'search' => 'do_search',
+- 'pref', => 'do_pref',
+- 'setpref' => 'do_setpref',
+- 'setpasswd' => 'do_setpasswd',
+- 'renewpasswd' => 'do_renewpasswd',
+- 'firstpasswd' => 'do_firstpasswd',
+- 'requestpasswd' => 'do_requestpasswd',
+- 'choosepasswd' => 'do_choosepasswd',
+- 'viewfile' => 'do_viewfile',
+- 'set' => 'do_set',
+- 'admin' => 'do_admin',
+- 'add_request' => 'do_add_request',
+- 'add' => 'do_add',
+- 'del' => 'do_del',
+- 'modindex' => 'do_modindex',
+- 'reject' => 'do_reject',
+- 'reject_notify' => 'do_reject_notify',
+- 'reject_notify_shared' =>'admin',
+- 'distribute' => 'do_distribute',
+- 'viewmod' => 'do_viewmod',
+- 'd_reject_shared' => 'do_d_reject_shared',
+- 'reject_notify_shared' => 'do_reject_notify_shared',
+- 'd_install_shared' => 'do_d_install_shared',
+- 'editfile' => 'do_editfile',
+- 'savefile' => 'do_savefile',
+- 'arc' => 'do_arc',
+- 'latest_arc' => 'do_latest_arc',
+- 'latest_d_read' => 'do_latest_d_read',
+- 'arc_manage' => 'do_arc_manage',
+- 'remove_arc' => 'do_remove_arc',
+- 'send_me' => 'do_send_me',
+- 'view_source' => 'do_view_source',
+- 'arcsearch_form' => 'do_arcsearch_form',
+- 'arcsearch_id' => 'do_arcsearch_id',
+- 'arcsearch' => 'do_arcsearch',
+- 'rebuildarc' => 'do_rebuildarc',
+- 'rebuildallarc' => 'do_rebuildallarc',
+- 'arc_download' => 'do_arc_download',
+- 'arc_delete' => 'do_arc_delete',
+- 'serveradmin' => 'do_serveradmin',
+- 'set_loglevel' => 'do_set_loglevel',
+- 'set_dumpvars' => 'do_set_dumpvars',
+- 'show_sessions' => 'do_show_sessions',
+- 'unset_dumpvars' => 'do_unset_dumpvars',
+- 'set_session_email' => 'do_set_session_email',
+- 'restore_email' => 'do_restore_email',
+- 'skinsedit' => 'do_skinsedit',
+- 'css' => 'do_css',
+- 'help' => 'do_help',
+- 'edit_list_request' => 'do_edit_list_request',
+- 'edit_list' => 'do_edit_list',
+- 'create_list_request' => 'do_create_list_request',
+- 'create_list' => 'do_create_list',
+- 'get_pending_lists' => 'do_get_pending_lists',
+- 'get_closed_lists' => 'do_get_closed_lists',
+- 'get_latest_lists' => 'do_get_latest_lists',
+- 'get_inactive_lists' => 'do_get_inactive_lists',
+- 'set_pending_list_request' => 'do_set_pending_list_request',
+- 'install_pending_list' => 'do_install_pending_list',
+- 'edit_config' => 'do_edit_config',
+- 'submit_list' => 'do_submit_list',
+- 'editsubscriber' => 'do_editsubscriber',
+- 'viewbounce' => 'do_viewbounce',
+- 'redirect' => 'do_redirect',
+- 'rename_list_request' => 'do_rename_list_request',
+- 'rename_list' => 'do_rename_list',
+- 'copy_list' => 'do_copy_list',
+- 'reviewbouncing' => 'do_reviewbouncing',
+- 'resetbounce' => 'do_resetbounce',
+- 'scenario_test' => 'do_scenario_test',
+- 'search_list' => 'do_search_list',
+- 'show_cert' => 'show_cert',
+- 'close_list_request' => 'do_close_list_request',
+- 'close_list' => 'do_close_list',
+- 'purge_list' => 'do_purge_list',
+- 'restore_list' => 'do_restore_list',
+- 'upload_pictures' => 'do_upload_pictures',
+- 'delete_pictures' => 'do_delete_pictures',
+- 'd_read' => 'do_d_read',
+- 'd_create_dir' => 'do_d_create_dir',
+- 'd_upload' => 'do_d_upload',
+- 'd_unzip' => 'do_d_unzip',
+- 'd_editfile' => 'do_d_editfile',
+- 'd_properties' => 'do_d_properties',
+- 'd_overwrite' => 'do_d_overwrite',
+- 'd_savefile' => 'do_d_savefile',
+- 'd_describe' => 'do_d_describe',
+- 'd_delete' => 'do_d_delete',
+- 'd_rename' => 'do_d_rename',
+- 'd_control' => 'do_d_control',
+- 'd_change_access' => 'do_d_change_access',
+- 'd_set_owner' => 'do_d_set_owner',
+- 'd_admin' => 'do_d_admin',
+- 'dump_scenario' => 'do_dump_scenario',
+- 'dump' => 'do_dump',
+- 'arc_protect' => 'do_arc_protect',
+- 'remind' => 'do_remind',
+- 'change_email' => 'do_change_email',
+- 'change_email_request' => 'do_change_email_request',
+- 'load_cert' => 'do_load_cert',
+- 'compose_mail' => 'do_compose_mail',
+- 'send_mail' => 'do_send_mail',
+- 'request_topic' => 'do_request_topic',
+- 'tag_topic_by_sender' =>'do_tag_topic_by_sender',
+- 'search_user' => 'do_search_user',
+- 'set_lang' => 'do_set_lang',
+- 'attach' => 'do_attach',
+- 'stats' => 'do_stats',
+- 'viewlogs'=> 'do_viewlogs',
+- 'wsdl'=> 'do_wsdl',
+- 'sync_include' => 'do_sync_include',
+- 'review_family' => 'do_review_family',
+- 'ls_templates' => 'do_ls_templates',
+- 'remove_template' => 'do_remove_template',
+- 'copy_template' => 'do_copy_template',
+- 'view_template' => 'do_view_template',
+- 'edit_template' => 'do_edit_template',
+- 'rss_request' => 'do_rss_request',
+- 'maintenance' => 'do_maintenance',
+- 'blacklist' => 'do_blacklist',
+- 'edit_attributes' => 'do_edit_attributes',
+- 'ticket' => 'do_ticket',
+- 'manage_template' => 'do_manage_template',
+- 'send_newsletter' => 'do_send_newsletter',
+- 'suspend_request' => 'do_suspend_request',
+- 'suspend_request_action' => 'do_suspend_request_action',
+- 'show_exclude' => 'do_show_exclude',
+- 'ca' => 'do_ca', # 'ca' stands for 'custom_action'. I used a short name to make it discrete in a URL.
+- 'lca' => 'do_lca', # 'lca' stands for 'list_custom_action'. I used a short name to make it discrete in a URL.
+- );
+-
+-my %auth_action = ('logout' => 1,
+- 'loginrequest' => 1,
+- 'login' => 1,
+- 'sso_login' => 1,
+- 'sso_login_succeeded' => 1,
+- 'renewpasswd' => 1,
+- 'firstpasswd' => 1,
+- 'choosepasswd' => 1,
+- 'sendssopasswd' => 1,
+- 'ticket' => 1,
+- );
+-
+-## Arguments awaited in the PATH_INFO, depending on the action
+-my %action_args = ('default' => ['list'],
+- 'editfile' => ['list','file'],
+- 'viewfile' => ['list','file'],
+- 'requestpasswd' => ['email'],
+- 'choosepasswd' => ['email','passwd'],
+- 'lists' => ['topic','subtopic'],
+- 'latest_lists' => ['topic','subtopic'],
+- 'active_lists' => ['topic','subtopic'],
+- 'login' => ['email','passwd','previous_action','previous_list'],
+- 'sso_login' => ['auth_service_name','subaction','email', 'ticket'],
+- 'sso_login_succeeded' => ['auth_service_name','previous_action','previous_list'],
+- 'loginrequest' => ['previous_action','previous_list'],
+- 'logout' => ['previous_action','previous_list'],
+- 'renewpasswd' => ['previous_action','previous_list'],
+- 'firstpasswd' => ['previous_action','previous_list'],
+- 'css' => ['file'],
+- 'pref' => ['previous_action','previous_list'],
+- 'reject' => ['list','id'],
+- 'distribute' => ['list','id'],
+- 'dump_scenario' => ['list','pname'],
+- 'd_reject_shared' => ['list','id'],
+- 'd_install_shared' => ['list','id'],
+- 'modindex' => ['list'],
+- 'viewmod' => ['list','id','@file'],
+- 'viewfile' => ['list','file'],
+- 'add' => ['list','email'],
+- 'add_request' => ['list'],
+- 'del' => ['list','email'],
+- 'editsubscriber' => ['list','email','previous_action','custom_attribute'],
+-# 'editsubscriber' => ['list','email','previous_action'],
+- 'viewbounce' => ['list','email'],
+- 'resetbounce' => ['list','email'],
+- 'review' => ['list','page','size','sortby'],
+- 'reviewbouncing' => ['list','page','size'],
+- 'arc' => ['list','month','@arc_file'],
+- 'latest_arc' => ['list'],
+- 'arc_manage' => ['list'],
+- 'arcsearch_form' => ['list','archive_name'],
+- 'arcsearch_id' => ['list','archive_name','msgid'],
+- 'rebuildarc' => ['list','month'],
+- 'rebuildallarc' => [],
+- 'arc_download' => ['list'],
+- 'arc_delete' => ['list','zip'],
+- 'home' => [],
+- 'help' => ['help_topic'],
+- 'show_cert' => [],
+- 'subscribe' => ['list','email','passwd'],
+- 'subrequest' => ['list','email'],
+- 'subrequest' => ['list'],
+- 'subindex' => ['list'],
+- 'ignoresub' => ['list','@email','@gecos'],
+- 'signoff' => ['list','email','passwd'],
+- 'auto_signoff' => ['list','email'],
+- 'sigrequest' => ['list','email'],
+- 'set' => ['list','email','reception','gecos'],
+- 'serveradmin' => ['subaction'],
+- 'set_session_email' => ['email'],
+- 'skinsedit' => [],
+- 'get_pending_lists' => [],
+- 'get_closed_lists' => [],
+- 'get_latest_lists' => [],
+- 'get_inactive_lists' => [],
+- 'search_list' => ['filter'],
+- 'shared' => ['list','@path'],
+- 'd_read' => ['list','@path'],
+- 'latest_d_read' => ['list'],
+- 'd_admin' => ['list','d_admin'],
+- 'd_delete' => ['list','@path'],
+- 'd_rename' => ['list','@path'],
+- 'd_create_dir' => ['list','@path'],
+- 'd_overwrite' => ['list','@path'],
+- 'd_savefile' => ['list','@path'],
+- 'd_describe' => ['list','@path'],
+- 'd_editfile' => ['list','@path'],
+- 'd_properties' => ['list','@path'],
+- 'd_control' => ['list','@path'],
+- 'd_change_access' => ['list','@path'],
+- 'd_set_owner' => ['list','@path'],
+- 'dump' => ['list','format'],
+- 'search' => ['list','filter'],
+- 'search_user' => ['email'],
+- 'set_lang' => ['lang'],
+- 'attach' => ['list','dir','file'],
+- 'edit_list_request' => ['list','group'],
+- 'rename_list' => ['list','new_list','new_robot'],
+- 'copy_list' => ['list','new_list','new_robot'],
+- 'redirect' => [],
+- 'viewlogs' => ['list','first'],
+- 'wsdl' => [],
+- 'sync_include' => ['list'],
+- 'review_family' => ['family_name'],
+- 'ls_templates' => ['list'],
+- 'view_template' => [],
+- 'remove_template' => [],
+- 'copy_template' => ['list'],
+- 'edit_template' => ['list'],
+- 'rss_request' => ['list'],
+- 'request_topic' => ['list','authkey'],
+- 'tag_topic_by_sender' => ['list'],
+- 'multiple_subscribe' => ['lists'],
+- 'multiple_signoff' => ['lists'],
+- 'ticket' => ['ticket'],
+- 'change_email' => ['email'],
+- 'manage_template' => ['subaction','list','message_template'],
+- 'send_newsletter' => [],
+- 'compose_mail' => ['list','subaction'],
+- 'suspend_request' => ['subaction'],
+- 'show_exclude' => ['list'],
+- 'ca' => ['custom_action','@cap'],
+- 'lca' => ['custom_action','list','@cap'],
+- );
+-
+-## Define the required parameters for each action
+-## Parameter names refer to the %in structure of to $param if mentionned as 'param.x'
+-## This structure is used to determine if any parameter is missing
+-## The list of parameters is not ordered
+-## Some keywords are reserved: param.list and param.user.email
+-## Alternate parameters can be defined with the '|' character
+-## Limits of this structure: it does not define optional parameters (a or b)
+-## Limit: it does not allow to have a specific error message and redirect to a given page if the parameter is missing
+-my %required_args = ('active_lists' => ['for|count'],
+- 'admin' => ['param.list','param.user.email'],
+- 'add' => ['param.list','param.user.email'],
+- 'add_request' => ['param.list','param.user.email'],
+- 'arc' => ['param.list'],
+- 'arc_delete' => ['param.user.email','param.list'],
+- 'arc_download' => ['param.user.email','param.list'],
+- 'arc_manage' => ['param.list'],
+- 'arc_protect' => ['param.list'],
+- 'arcsearch' => ['param.list'],
+- 'arcsearch_form' => ['param.list'],
+- 'arcsearch_id' => ['param.list'],
+- 'attach' => ['param.list'],
+- 'blacklist' => ['param.list'],
+- 'change_email' => ['param.user.email'],
+- 'change_email_request' => ['param.user.email','new_email'],
+- 'close_list' => ['param.user.email','param.list'],
+- 'close_list_request' => ['param.user.email','param.list'],
+- 'compose_mail' => ['param.user.email','param.list'],
+- 'copy_template' => ['webormail'],
+- 'create_list' => ['param.user.email'], ## other required parameters are checked in the subroutine
+- 'create_list_request' => ['param.user.email'],
+- 'css' => [],
+- 'd_admin' => ['param.list','param.user.email'],
+- 'd_change_access' => ['param.list','param.user.email'],
+- 'd_control' => ['param.list','param.user.email'],
+- 'd_create_dir' => ['param.list','param.user.email','name_doc'],
+- 'd_delete' => ['param.list','param.user.email'],
+- 'd_describe' => ['param.list','param.user.email','content'],
+- 'd_editfile' => ['param.list','param.user.email'],
+- 'd_install_shared' => ['param.list','param.user.email','id'],
+- 'd_overwrite' => ['param.list','param.user.email'],
+- 'd_properties' => ['param.list','param.user.email'],
+- 'd_read' => ['param.list'],
+- 'd_reject_shared' => ['param.list','param.user.email','id'],
+- 'd_rename' => ['param.list','param.user.email','new_name'],
+- 'd_savefile' => ['param.list','param.user.email','content|url'],
+- 'd_set_owner' => ['param.list','param.user.email'],
+- 'd_unzip' => ['param.list','param.user.email'],
+- 'd_upload' => ['param.list','param.user.email'],
+- 'del' => ['param.list','param.user.email','email'],
+- 'delete_pictures' => ['param.list','param.user.email'],
+- 'distribute' => ['param.list','param.user.email','id|idspam'],
+- 'dump' => ['param.list'],
+- 'dump_scenario' => ['param.list','pname'],
+- 'edit_list' => ['param.user.email','param.list'],
+- 'edit_list_request' => ['param.user.email','param.list'],
+- 'edit_template' => ['webormail'],
+- 'editfile' => ['param.user.email'],
+- 'editsubscriber' => ['param.list','param.user.email','email'],
+- 'get_closed_lists' => ['param.user.email'],
+- 'get_inactive_lists' => ['param.user.email'],
+- 'get_latest_lists' => ['param.user.email'],
+- 'get_pending_lists' => ['param.user.email'],
+- 'ignoresub' => ['param.list','param.user.email'],
+- 'info' => ['param.list'],
+- 'install_pending_list' => ['param.user.email'],
+- 'edit_config' => ['param.user.email'],
+- 'latest_arc' => ['param.list','for|count'],
+- 'latest_d_read' => ['param.list','for','count'],
+- 'latest_lists' => ['for|count'],
+- 'load_cert' => ['param.list'],
+- 'logout' => ['param.user.email'],
+- 'manage_template' => ['param.list','param.user.email'],
+- 'modindex' => ['param.list','param.user.email'],
+- 'multiple_subscribe' => ['param.list'],
+- 'pref' => ['param.user.email'],
+- 'purge_list' => ['param.user.email','selected_lists'],
+- 'rebuildallarc' => ['param.user.email'],
+- 'rebuildarc' => ['param.user.email','param.list'],
+- 'reject' => ['param.list','param.user.email','id|idspam'],
+- 'remind' => ['param.list','param.user.email'],
+- 'remove_arc' => ['param.list'],
+- 'remove_templates' => ['webormail'],
+- 'rename_list' => ['param.user.email','param.list','new_listname','new_robot'],
+- 'copy_list' => ['param.user.email','param.list','new_listname','new_robot'],
+- 'rename_list_request' => ['param.user.email','param.list'],
+- 'request_topic' => ['param.list','authkey'],
+- 'resetbounce' => ['param.list','param.user.email','email'],
+- 'restore_list' => ['param.user.email','param.list'],
+- 'review' => ['param.list'],
+- 'review_family' => ['param.user.email','family_name'],
+- 'reviewbouncing' => ['param.list'],
+- 'rss_request' => [],
+- 'savefile' => ['param.user.email','file'],
+- 'search' => ['param.list','filter'],
+- 'search_user' => ['param.user.email','email'],
+- 'send_mail' => ['param.user.email'],
+- 'send_newsletter' => ['param.list','param.user.email', 'url'],
+- 'send_me' => ['param.list'],
+- 'view_source' => ['param.list'],
+- 'requestpasswd' => ['email'],
+- 'serveradmin' => ['param.user.email'],
+- 'set' => ['param.list','reception|visibility'],
+- 'set_lang' => [],
+- 'set_pending_list_request' => ['param.user.email'],
+- 'setpasswd' => ['param.user.email','newpasswd1','newpasswd2'],
+- 'setpref' => ['param.user.email'],
+- 'signoff' => ['param.list'],
+- 'sigrequest' => ['param.list'],
+- 'skinedit' => ['param.user.email'],
+- 'sso_login' => ['auth_service_name'],
+- 'stats' => ['param.user.email','param.list'],
+- 'subindex' => ['param.list','param.user.email'],
+- 'suboptions' => ['param.list','param.user.email'],
+- 'subrequest' => ['param.list'],
+- 'subscribe' => ['param.list'],
+- 'subscriber_count' => ['param.list'],
+- 'suspend_request' => [],
+- 'suspend_request_action' => [],
+- 'show_exclude' => ['param.list'],
+- 'sync_include' => ['param.list','param.user.email'],
+- 'tag_topic_by_sender' => ['param.list'],
+- 'upload_pictures' => ['param.user.email','param.list'],
+- 'view_template' => ['webormail'],
+- 'viewbounce' => ['param.list','email'],
+- 'viewfile' => ['file','param.list'],
+- 'viewlogs' => ['param.list'],
+- 'viewmod' => ['param.list','param.user.email','id|idspam'],
+- 'wsdl' => [],
+- 'which' => ['param.user.email'],
+- );
+-
+-## Defines the required privileges to access privileged actions
+-## You can define a set ofequiivalent privileges in the ARRAYREF
+-my %required_privileges = ('admin' => ['owner','editor'],
+- 'arc_download' => ['owner'],
+- 'blacklist' => ['owner','editor'],
+- 'close_list' => ['privileged_owner'],
+- 'close_list_request' => ['privileged_owner'],
+- 'copy_template' => ['listmaster'],
+- 'd_install_shared' => ['editor'],
+- 'd_reject_shared' => ['editor'],
+- 'distribute' => ['editor'],
+- 'dump_scenario' => ['listmaster'],
+- 'edit_list' => ['owner'],
+- 'edit_list_request' => ['owner'],
+- 'edit_template' => ['listmaster'],
+- 'editsubscriber' => ['owner'],
+- 'get_closed_lists' => ['listmaster'],
+- 'get_inactive_lists' => ['listmaster'],
+- 'get_latest_lists' => ['listmaster'],
+- 'get_pending_lists' => ['listmaster'],
+- 'ignoresub' => ['owner'],
+- 'install_pending_list' => ['listmaster'],
+- 'edit_config' => ['listmaster'],
+- 'ls_templates' => ['listmaster'],
+- 'manage_template' => ['owner'],
+- 'manage_template' => ['owner'],
+- 'modindex' => ['editor'],
+- 'purge_list' => ['privileged_owner','listmaster'],
+- 'rebuildallarc' => ['listmaster'],
+- 'rebuildarc' => ['listmaster'],
+- 'reject' => ['editor'],
+- 'remove_template' => ['listmaster'],
+- 'rename_list' => ['privileged_owner'],
+- 'copy_list' => ['owner'],
+- 'rename_list_request' => ['privileged_owner'],
+- 'resetbounce' => ['owner'],
+- 'restore_list' => ['listmaster'],
+- 'review_family' => ['listmaster'],
+- 'reviewbouncing' => ['owner'],
+- 'search_user' => ['listmaster'],
+- 'serveradmin' => ['listmaster'],
+- 'set_dumpvars' => ['listmaster'],
+- 'set_loglevel' => ['listmaster'],
+- 'set_pending_list_request' => ['listmaster'],
+- 'set_session_email' => ['listmaster'],
+- 'show_sessions' => ['listmaster'],
+- 'stats' => ['owner'],
+- 'subindex' => ['owner'],
+- 'sync_include' => ['owner'],
+- 'skinedit' => ['listmaster'],
+- 'view_template' => ['listmaster'],
+- 'viewbounce' => ['owner'],
+- 'viewlogs' => ['owner','editor'],
+- 'viewmod' => ['editor'],
+- );
+-
+-# this definition is used to choose the left side menu type (admin -> listowner admin menu | serveradmin -> server_admin menu | none list or your_list menu)
+-my %action_type = ('editfile' => 'admin',
+- 'review' => 'admin',
+- 'search' => 'admin',
+- 'viewfile' => 'admin',
+- 'admin' => 'admin',
+- 'add_request' =>'admin',
+- 'add' =>'admin',
+- 'del' =>'admin',
+-# 'modindex' =>'admin',
+- 'reject' =>'admin',
+- 'reject_notify' =>'admin',
+- 'add_request' =>'admin',
+- 'distribute' =>'admin',
+- 'viewmod' =>'admin',
+- 'savefile' =>'admin',
+- 'rebuildarc' =>'admin',
+- 'rebuildallarc' =>'admin',
+- 'reviewbouncing' =>'admin',
+- 'edit_list_request' =>'admin',
+- 'edit_list' =>'admin',
+- 'editsubscriber' =>'admin',
+- 'viewbounce' =>'admin',
+- 'resetbounce' =>'admin',
+- 'scenario_test' =>'admin',
+- 'close_list_request' =>'admin',
+- 'close_list' =>'admin',
+- 'restore_list' => 'admin',
+- 'd_admin' => 'admin',
+- 'd_reject_shared' =>'admin',
+- 'd_install_shared' =>'admin',
+- 'dump_scenario' => 'admin',
+- 'dump' => 'admin',
+- 'remind' => 'admin',
+-# 'subindex' => 'admin',
+- 'stats' => 'admin',
+- 'ignoresub' => 'admin',
+- 'rename_list' => 'admin',
+- 'copy_list' => 'admin',
+- 'rename_list_request' => 'admin',
+- 'arc_manage' => 'admin',
+- 'sync_include' => 'admin',
+- 'ls_templates' => 'admin',
+- 'view_template' => 'admin',
+- 'remove_template' => 'admin',
+- 'copy_template' => 'admin',
+- 'edit_template' => 'admin',
+- 'blacklist' => 'admin',
+- 'viewlogs' => 'admin',
+- 'serveradmin' => 'serveradmin',
+- 'get_pending_lists' => 'serveradmin',
+- 'get_closed_lists' => 'serveradmin',
+- 'get_inactive_lists' => 'serveradmin',
+- 'get_latest_lists' => 'serveradmin',
+- 'ls_templates' => 'serveradmin',
+- 'skinedit' => 'serveradmin',
+- 'review_family' => 'serveradmin',
+- 'search_user' => 'serveradmin',
+- 'show_sessions' => 'serveradmin',
+- 'show_exclude' => 'admin',
+- 'rebuildarc' => 'serveradmin',
+- 'set_session_email' => 'serveradmin',
+- 'set_loglevel' => 'serveradmin',
+- 'editfile' => 'serveradmin',
+- 'unset_dumpvars' => 'serveradmin',
+- 'set_dumpvars' => 'serveradmin'
+-);
+-
+-## actions tthat are not used in return of login,
+-my %temporary_actions = ( 'logout' => 1,
+- 'loginrequest' => 1,
+- 'login' => 1,
+- 'sso_login' => 1,
+- 'sso_login_succeeded' => 1,
+- 'ticket' => 1,
+- 'css' => 1,
+- 'rss' => 1,
+- 'wsdl' => 1,
+- 'redirect' => 1,
+- );
+-
+-## Regexp applied on incoming parameters (%in)
+-## The aim is not a strict definition of parameter format
+-## but rather a security check
+-my %in_regexp = (
+- ## Default regexp
+- '*' => '[\w\-\.]+',
+-
+- ## List config parameters
+- 'single_param' => '.+',
+- 'multiple_param' => '.+',
+-
+- ## Textarea content
+- 'template_content' => '.+',
+- 'content' => '.+',
+- 'body' => '.+',
+- 'info' => '.+',
+- 'new_scenario_content' => '.+',
+- 'blacklist' => '.*',
+-
+- ## Integer
+- 'page' => '\d+',
+- 'size' => '\d+',
+-
+- ## Free data
+- 'subject' => '.*',
+- 'gecos' => '[^<>\\\*\$\n]+',
+- 'additional_field' => '[^<>\\\*\$\n]+',
+- 'dump' => '[^<>\\\*\$]+', # contents email + gecos
+-
+- ## Search
+- 'filter' => '[^<>\\\[\]\(\)\$\n]+', # search list
+- 'key_word' => '.*',
+- 'format' => '[^<>\\\$\n]+', # dump format/filter string
+-
+- ## File names
+- 'file' => '[^<>\*\$\n]+',
+- 'template_path' => '[\w\-\.\/_]+',
+- 'arc_file' => '[^<>\\\*\$\n]+',
+- 'path' => '[^<>\\\*\$\n]+',
+- 'uploaded_file' => '[^<>\*\$\n]+', # Could be precised (use of "'")
+- 'unzipped_file' => '[^<>\*\$\n]+',
+- 'dir' => '[^<>\\\*\$\n]+',
+- 'name_doc' => '[^<>\\\*\$\[\]\/\n]+',
+- 'shortname' => '[^<>\\\*\$\n]+',
+- 'new_name' => '[^<>\\\*\$\n]+',
+- 'id' => '[^<>\\\*\$\n]+',
+- 'template_name' => &tools::get_regexp('template_name'),
+- 'new_template_name' => &tools::get_regexp('template_name'),
+- 'message_template' => &tools::get_regexp('template_name'),
+- 'new_default' => &tools::get_regexp('template_name'),
+-
+- ## Archives
+- 'month' => '\d{2}|\d{4}\-\d{2}', ## format is yyyy-mm for 'arc' and mm for 'send_me'
+-
+- ## URL
+- 'referer' => '[^\\\$\*\"\'\`\^\|\<\>\n]+',
+- 'failure_referer' => '[^\\\$\*\"\'\`\^\|\<\>\n]+',
+- 'url' => '[^\\\$\*\"\'\`\^\|\<\>\n]+',
+-
+- ## Msg ID
+- 'msgid' => '[^\\\*\"\'\`\^\|\n]+',
+- 'in_reply_to' => '[^\\\*\"\'\`\^\|\n]+',
+- 'message_id' => '[^\\\*\"\'\`\^\|\n]+',
+-
+- ## Password
+- 'passwd' => '.+',
+- 'password' => '.+',
+- 'newpasswd1' => '.+',
+- 'newpasswd2' => '.+',
+- 'new_password' => '.+',
+-
+- ## Topics
+- 'topic' => '[\-\w\/]+',
+- 'topics' => '[\-\w\/]+',
+- 'subtopic' => '[\-\w\/]+',
+-
+-
+- ## List names
+- 'list' => '[\w\-\.\+]*', ## &tools::get_regexp('listname') + uppercase
+- 'previous_list' => '[\w\-\.\+]*',
+- 'new_list' => '[\w\-\.\+]*',
+- 'listname' => '[\w\-\.\+]*',
+- 'new_listname' => '[\w\-\.\+]*',
+- 'selected_lists' => '[\w\-\.\+]*',
+-
+- ## Family names
+- 'family_name' => &tools::get_regexp('family_name'),
+-
+- ## Email addresses
+- 'email' => &tools::get_regexp('email').'|'.&tools::get_regexp('uid'),
+- 'init_email' => &tools::get_regexp('email'),
+- 'old_email' => &tools::get_regexp('email'),
+- 'new_email' => &tools::get_regexp('email'),
+- 'pending_email' => &tools::get_regexp('email').',.*', # Email address is followed by ',' + gecos data
+- 'sender' => &tools::get_regexp('email'),
+- 'to' => '(([\w\-\_\.\/\+\=\']+|\".*\")\s[\w\-]+(\.[\w\-]+)+(,?))*',
+-
+- ## Host
+- 'new_robot' => &tools::get_regexp('host'),
+- 'remote_host' => &tools::get_regexp('host'),
+- 'remote_addr' => &tools::get_regexp('host'),
+-
+- ## Scenario name
+- 'scenario' => &tools::get_regexp('scenario'),
+- 'read_access' => &tools::get_regexp('scenario'),
+- 'edit_access' => &tools::get_regexp('scenario'),
+- ## RSS URL or blank
+- 'active_lists' => '.*',
+- 'latest_lists' => '.*',
+- 'latest_arc' => '.*',
+- 'latest_d_read' => '.*',
+-
+- ##Logs
+- 'target_type' => '[\w\-\.\:]*',
+- 'target' => &tools::get_regexp('email'),
+- 'date_from' => '[\d\/]+',
+- 'date_to' => '[\d\/]+',
+- 'ip' => &tools::get_regexp('host'),
+-
+- ## colors
+- 'subaction_test' => '.*',
+- 'subaction_reset' => '.*',
+- 'subaction_install' => '.*',
+- 'custom_color_value' => '\#.*',
+- 'custom_color_0' => '.*',
+- 'custom_color_1' => '.*',
+- 'custom_color_2' => '.*',
+- 'custom_color_3' => '.*',
+- 'custom_color_4' => '.*',
+- 'custom_color_5' => '.*',
+- 'custom_color_6' => '.*',
+- 'custom_color_7' => '.*',
+- 'custom_color_8' => '.*',
+- 'custom_color_9' => '.*',
+- 'custom_color_10' => '.*',
+- 'custom_color_11' => '.*',
+- 'custom_color_12' => '.*',
+- 'custom_color_13' => '.*',
+- 'custom_color_14' => '.*',
+- 'custom_color_15' => '.*',
+-
+- ## Custom attribute
+- 'custom_attribute' => '.*',
+-
+- ## Templates
+- 'scope' => 'distrib|robot|family|list|site',
+-
+- ## Custom Inputs from create_list_request.tt2
+- 'custom_input' => '.*',
+-
+- ## conf parameters
+- 'conf_new_value' => '.*',
+-
+- ## custom actions
+- 'cap' => '.*',
+- 'lcap' => '.*',
+- );
+-
+-## Regexp applied on incoming parameters (%in)
+-## This regular expression defines forbidden expressions applied on all incoming parameters
+-## Note that you can use the ^ and $ expressions to match beginning and ending of expressions
+-my %in_negative_regexp = (
+- 'arc_file' => '^(arctxt|\.)'
+- );
+-
+-## List some required filtering of incoming parameters, depending on current action
+-## Paramater can be '*' or 'param*'
+-## Like Q-encoding
+-my %filtering = ('d_reject_shared' => {'id' => 'qencode'},
+- 'd_install_shared' => {'id' => 'qencode'},
+- 'd_read' => {'path' => 'qencode'},
+- 'd_create_dir' => {'name_doc' => 'qencode', 'path' => 'qencode'},
+- 'd_upload' => {'path' => 'qencode'},
+- 'd_unzip' => {'path' => 'qencode'},
+- 'd_editfile' => {'path' => 'qencode'},
+- 'd_properties' => {'path' => 'qencode'},
+- 'd_overwrite' => {'path' => 'qencode'},
+- 'd_savefile' => {'path' => 'qencode', 'name_doc' => 'qencode'},
+- 'd_describe' => {'path' => 'qencode'},
+- 'd_delete' => {'path' => 'qencode'},
+- 'd_rename' => {'path' => 'qencode','new_name' => 'qencode'},
+- 'd_control' => {'path' => 'qencode'},
+- 'd_change_access' => {'path' => 'qencode'},
+- 'd_set_owner' => {'path' => 'qencode'},
+- 'requestpasswd' => {'email' => 'fix_escape_uri'},
+- 'viewbounce' => {'email' => 'fix_escape_uri'},
+- 'editsubscriber' => {'email' => 'fix_escape_uri'},
+- 'edit_list' => {'*param*' => 'unescape_html'}, ## Required because outgoing parameters have been html-escaped in edit_list_request
+- 'change_email' => {'*email' => 'normalize'}, ## Remove leading/trailing white spaces and lowercase
+- );
+-
+-## Open log
+-$wwsconf->{'log_facility'}||= $Conf{'syslog'};
+-
+-&Log::do_openlog($wwsconf->{'log_facility'}, $Conf{'log_socket_type'}, 'wwsympa');
+-&do_log('info', 'WWSympa started');
+-
+-## Set locale configuration
+-$Language::default_lang = $Conf{'lang'};
+-
+-## Important to leave this there because it defined defaults for user_data_source
+-&List::check_db_connect();
+-
+-my $pinfo = &List::_apply_defaults();
+-
+-## Check that the data structure is uptodate
+-## If not, set the web interface to maintenance mode
+-my $maintenance_mode;
+-unless (&Upgrade::data_structure_uptodate()) {
+- $maintenance_mode = 1;
+- &do_log('err',"Web interface set to maintenance mode ; you should run sympa.pl --upgrade");
+-}
+-
+-&tools::ciphersaber_installed();
+-
+-%::changed_params;
+-
+-my (%in, $query);
+-
+-my $birthday = time ;
+-
+-# Now internal encoding is same as input/output.
+-#XXX## Set output encoding
+-#XXX## All outgoing strings will be recoded transparently using this charset
+-#XXXbinmode STDOUT, ":utf8";
+-
+-#XXX## Incoming data is utf8-encoded
+-#XXXbinmode STDIN, ":utf8";
+-
+- ## Main loop
+- my $loop_count;
+- my $start_time = &POSIX::strftime("%d %b %Y at %H:%M:%S", localtime(time));
+- while ($query = &new_loop()) {
+-
+- undef %::changed_params;
+-
+- undef $param;
+- undef $list;
+- undef $robot;
+- undef $robot_object;
+- undef $ip;
+- undef $rss;
+- undef $session;
+-
+- &Log::set_log_level($Conf{'log_level'});
+- &Language::SetLang($Language::default_lang);
+-
+- ## Empty cache of the List.pm module
+- &List::init_list_cache();
+-
+- ## Check effective ID
+- unless ($> eq (getpwnam(Sympa::Constants::USER))[2]) {
+- $maintenance_mode = 1;
+- &report::reject_report_web('intern_quiet','incorrect_server_config',{},'','');
+- &wwslog('err','Config error: wwsympa should run with UID %s (instead of %s). *** Switching to maintenance mode. ***', (getpwnam(Sympa::Constants::USER))[2], $>);
+- }
+-
+- unless (&List::check_db_connect()) {
+- &report::reject_report_web('system_quiet','no_database',{},'','');
+- &do_log('info','WWSympa requires a RDBMS to run');
+- }
+-
+- ## If in maintenance mode, check if the data structure is now uptodate
+- if ($maintenance_mode && (&Upgrade::data_structure_uptodate() && ($> eq (getpwnam(Sympa::Constants::USER))[2]))) {
+- $maintenance_mode = undef;
+- &do_log('notice',"Data structure seem updated, setting OFF maintenance mode");
+- }
+-
+- ## Get params in a hash
+- # foreach ($query->param) {
+- # $in{$_} = $query->param($_);
+- # }
+- %in = $query->Vars;
+-
+- foreach my $k (keys %::changed_params) {
+- &do_log('debug3', 'Changed Param: %s', $k);
+- }
+-
+- ## Free terminated sendmail processes
+- # &smtp::reaper;
+-
+- ## Parse CGI parameters
+- # &CGI::ReadParse();
+-
+- if (defined $Conf{'robot_by_http_host'}{&get_header_field('SERVER_NAME')}) {
+- my ($selected_robot, $selected_path);
+- my ($k,$v);
+- while (($k, $v) = each %{$Conf{'robot_by_http_host'}{&get_header_field('SERVER_NAME')}}) {
+- if ($ENV{'REQUEST_URI'} =~ /^$k/) {
+- ## Longer path wins
+- if (length($k) > length($selected_path)) {
+- ($selected_robot, $selected_path) = ($v, $k);
+- }
+- }
+- }
+- $robot = $selected_robot;
+- }
+-
+- $robot = $Conf{'host'} unless $robot;
+-
+- ## Create Robot object
+- $robot_object = new Robot $robot;
+-
+- ## Default robot
+- if ($robot eq $Conf{'host'}) {
+- $param->{'default_robot'} = 1;
+- }
+-
+- $param->{'cookie_domain'} = $Conf{'robots'}{$robot}{'cookie_domain'} if $Conf{'robots'}{$robot};
+- $param->{'cookie_domain'} ||= $wwsconf->{'cookie_domain'};
+- $ip = $ENV{'REMOTE_HOST'};
+- $ip = $ENV{'REMOTE_ADDR'} unless ($ip);
+- $ip = 'undef' unless ($ip);
+- ## In case HTTP_HOST does not match cookie_domain
+- my $http_host = &get_header_field('HTTP_HOST');
+- $http_host =~ s/:\d+$//; ## suppress port
+- unless (($http_host =~ /$param->{'cookie_domain'}$/) ||
+- ($param->{'cookie_domain'} eq 'localhost')) {
+- &wwslog('notice', 'Cookie_domain(%s) does NOT match HTTP_HOST; setting cookie_domain to %s', $param->{'cookie_domain'}, $http_host);
+- $param->{'cookie_domain'} = $http_host;
+- }
+-
+- &Log::set_log_level($Conf{'robots'}{$robot}{'log_level'});
+-
+- ## Sympa parameters in $param->{'conf'}
+- $param->{'conf'} = {};
+- foreach my $p ('email','host','sympa','request','soap_url','wwsympa_url','listmaster_email','logo_html_definition',
+- 'main_menu_custom_button_1_url','main_menu_custom_button_1_title','main_menu_custom_button_1_target',
+- 'main_menu_custom_button_2_url','main_menu_custom_button_2_title','main_menu_custom_button_2_target',
+- 'main_menu_custom_button_3_url','main_menu_custom_button_3_title','main_menu_custom_button_3_target',
+- 'dark_color','light_color','text_color','bg_color','error_color','use_blacklist','antispam_feature','custom_robot_parameter',
+- 'selected_color','shaded_color','color_0','color_1','color_2','color_3','color_4','color_5','color_6','color_7','color_8','color_9','color_10','color_11','color_12','color_13','color_14','color_15') {
+-
+- $param->{'conf'}{$p} = &Conf::get_robot_conf($robot, $p);
+- $param->{$p} = &Conf::get_robot_conf($robot, $p) if (($p =~ /_color$/)|| ($p =~ /color_/));
+- }
+-
+-
+- foreach my $auth (keys %{$Conf{'cas_id'}{$robot}}) {
+- &do_log('debug2', "cas authentication service $auth");
+- $param->{'sso'}{$auth} = $auth;
+- }
+-
+- foreach my $auth (keys %{$Conf{'generic_sso_id'}{$robot}}) {
+- &do_log('debug', "Generic SSO authentication service $auth");
+- $param->{'sso'}{$auth} = $Conf{'auth_services'}{$robot}[$Conf{'generic_sso_id'}{$robot}{$auth}]{'service_name'};
+- }
+-
+- $param->{'sso_number'} = $Conf{'cas_number'}{$robot} + $Conf{'generic_sso_number'}{$robot};
+- $param->{'use_passwd'} = $Conf{'use_passwd'}{$robot};
+- $param->{'use_sso'} = 1 if ($param->{'sso_number'});
+- $param->{'authentication_info_url'} = $Conf{'authentication_info_url'}{$robot};
+- $param->{'wwsconf'} = $wwsconf;
+-
+- $param->{'path_cgi'} = $ENV{'SCRIPT_NAME'};
+- $param->{'path_cgi'} =~ s/\/\//\//g; ## Replace '//' with '/' because it would break navigation
+- $param->{'version'} = Sympa::Constants::VERSION;
+- $param->{'date'} = gettext_strftime "%d %b %Y at %H:%M:%S", localtime(time);
+- $param->{'time'} = gettext_strftime "%H:%M:%S", localtime(time);
+-
+- ## Hash defining the parameters where no control is performed (because they are supposed to contain html and/or javascript).
+- $param->{'htmlAllowedParam'} = {
+- 'title' => 1,
+- 'hidden_head' => 1,
+- 'hidden_end' => 1,
+- 'hidden_at' => 1,
+- 'list_protected_email' => 1,
+- 'selected' => 1,
+- 'author_mailto' =>1,
+- 'mailto' =>1,
+- 'logo_html_definition' => 1,
+- 'template_content' => 1,
+- 'html_dumpvars' => 1,
+- };
+- ## Hash defining the parameters where HTML must be filtered.
+- $param->{'htmlToFilter'} = {
+- 'homepage_content' => 1,
+- 'info_content' => 1,
+- };
+-
+- ## Change to list root
+- unless (chdir($Conf{'home'})) {
+- &report::reject_report_web('intern','chdir_error',{},'','','',$robot);
+- &wwslog('info','unable to change directory');
+- exit (-1);
+- }
+-
+- ## Sets the UMASK
+- umask(oct($Conf{'umask'}));
+-
+- ## Authentication
+- ## use https client certificat information if define.
+-
+- ## Default auth method (for scenarios)
+- $param->{'auth_method'} = 'md5';
+-
+- &report::init_report_web();
+-
+- ## Get PATH_INFO parameters
+- &get_parameters();
+-
+- ## CSS related
+- $param->{'css_path'} = &Conf::get_robot_conf($robot, 'css_path');
+- $param->{'css_url'} = &Conf::get_robot_conf($robot, 'css_url');
+- ## If CSS file not found, let Sympa do the job...
+- unless (-f $param->{'css_path'}.'/style.css') {
+- &wwslog('err','Could not find CSS file %s, using default CSS', $param->{'css_path'}.'/style.css') if ($param->{'css_path'}); ## Notice only if path was defined
+- $param->{'css_url'} = $param->{'base_url'}.$param->{'path_cgi'}.'/css';
+- }
+-
+- &wwslog('info', "parameter css_url '%s' seems strange, it must be the url of a directory not a css file", $param->{'css_url'}) if ($param->{'css_url'} =~ /\.css$/);
+-
+- $session = new SympaSession ($robot,{'cookie'=>&SympaSession::get_session_cookie($ENV{'HTTP_COOKIE'}),
+- 'action'=>$in{'action'},
+- 'rss'=>$rss});
+- undef $ENV{'HTTP_COOKIE'}; # Getting rid of the environment variable to make sure it won't be affected to another anonymous session.
+- unless (defined $session) {
+- &List::send_notify_to_listmaster('failed_to_create_web_session', $robot);
+- &wwslog('info','Failed to create session');
+- $session->{'email'}= 'nobody'; $session->{'id_session'} = &get_random();
+- }
+-
+- $param->{'session'} = $session->as_hashref();
+-
+- &Log::set_log_level($session->{'log_level'}) if ($session->{'log_level'});
+- $param->{'restore_email'} = $session->{'restore_email'};
+- $param->{'dumpvars'} = $session->{'dumpvars'};
+- $param->{'unauthenticated_email'} = $session->{'unauthenticated_email'};
+-
+- if ($session->{'custom_color'} == 1) {
+- foreach my $i (0 .. 15){
+- $param->{'color_'.$i} = $session->{'color_'.$i} if ($session->{'color_'.$i});
+- }
+- }
+-
+- ## RSS does not require user authentication
+- unless ($rss) {
+-
+- if (($ENV{'SSL_CLIENT_VERIFY'} eq 'SUCCESS') &&
+- ($in{'action'} ne 'sso_login')) { ## Do not check client certificate automatically if in sso_login
+-
+- &do_log('debug2', "SSL verified, S_EMAIL = %s,"." S_DN_Email = %s", $ENV{'SSL_CLIENT_S_EMAIL'}, $ENV{'SSL_CLIENT_S_DN_Email'});
+- if (($ENV{'SSL_CLIENT_S_EMAIL'})) {
+- ## this is the X509v3 SubjectAlternativeName, and requires
+- ## a patch to mod_ssl -- cm@coretec.at
+- $param->{'user'}{'email'} = lc($ENV{'SSL_CLIENT_S_EMAIL'});
+- }elsif ($ENV{SSL_CLIENT_S_DN_Email}) {
+- $param->{'user'}{'email'} = lc($ENV{'SSL_CLIENT_S_DN_Email'});
+- }elsif ($ENV{'SSL_CLIENT_S_DN'} =~ /\+MAIL=([^\+\/]+)$/) {
+- ## Compatibility issue with old a-sign.at certs
+- $param->{'user'}{'email'} = lc($1);
+- }elsif ($crypt_openssl_x509_ok and exists($ENV{SSL_CLIENT_CERT})) {
+- ## this is the X509v3 SubjectAlternativeName, and does only
+- ## require "SSLOptions +ExportCertData" without patching
+- ## mod_ssl -- massar@unix-ag.uni-kl.de
+- $param->{'user'}{'email'} = lc(Crypt::OpenSSL::X509->new_from_string($ENV{SSL_CLIENT_CERT})->email());
+- }
+-
+- if($param->{user}{email}) {
+- $session->{'email'}= $param->{user}{email} ;
+- $param->{'auth_method'} = 'smime';
+- $session->{'auth'} = 'x509' ;
+- $param->{'ssl_client_s_dn'} = $ENV{'SSL_CLIENT_S_DN'};
+- $param->{'ssl_client_v_end'} = $ENV{'SSL_CLIENT_V_END'};
+- $param->{'ssl_client_i_dn'} = $ENV{'SSL_CLIENT_I_DN'};
+- $param->{'ssl_cipher_usekeysize'} = $ENV{'SSL_CIPHER_USEKEYSIZE'};
+- }
+-
+- }elsif (($session->{'email'}) && ($session->{'email'} ne 'nobody')) {
+- $param->{'user'}{'email'} = $session->{'email'};
+- }elsif($in{'ticket'}=~/(S|P)T\-/){ # the request contain a CAS named ticket that use CAS ticket format
+- delete $session->{'do_not_use_cas'}; #reset do_not_use_cas because this client probably use CAS
+- # select the cas server that redirect the user to sympa and check the ticket
+- do_log ('notice',"CAS ticket is detected. in{'ticket'}=$in{'ticket'} checked_cas=$session->{'checked_cas'}");
+-
+-
+- my $cas_id = '';
+- if ($in{'checked_cas'} =~ /^(\d+)\,?/) {
+- $cas_id = $1;
+- } elsif ($session->{'checked_cas'} =~ /^(\d+)\,?/) {
+- $cas_id = $1;
+- }
+- if ($cas_id ne '') {
+-
+- my $ticket = $in{'ticket'};
+- my $cas_server = $Conf{'auth_services'}{$robot}[$cas_id]{'cas_server'};
+-
+- my $service_url = &wwslib::get_my_url();
+- $service_url =~ s/(\?|&)ticket\=.+$//;
+-
+- my $net_id = $cas_server->validateST($service_url, $ticket);
+-
+- if(defined $net_id) { # the ticket is valid net-id
+- do_log('notice',"login CAS OK server netid=$net_id" );
+- $param->{'user'}{'email'} = lc(&Auth::get_email_by_net_id($robot, $cas_id, {'uid' => $net_id}));
+- $session->{'auth'} = 'cas';
+- $session->{'email'}= $param->{user}{email} ;
+-
+- $session->{'cas_server'} = $cas_id;
+-
+-
+- }else{
+- do_log('err',"CAS ticket validation failed : %s", &AuthCAS::get_errors());
+- }
+- }else{
+- do_log ('notice',"Internal error while receiving a CAS ticket $session->{'checked_cas'} ");
+- }
+- }elsif(($Conf{'cas_number'}{$robot} > 0) && ($in{'action'} !~ /^(login|sso_login|wsdl)$/)) { # some cas server are defined but no CAS ticket detected
+- unless ($session->{'do_not_use_cas'}) {
+- # user not taggued as not using cas
+- foreach my $auth_service (@{$Conf{'auth_services'}{$robot}}){
+- next unless ($auth_service->{'auth_type'} eq 'cas'); # skip auth services not related to cas
+- next unless ($auth_service->{'non_blocking_redirection'} eq 'on');
+-
+- ## skip cas server where client as been already redirect to the list of cas servers already checked is stored in the session
+- ## the check below works fine as long as we don't have more then 10 CAS servers (because we don't properly split the list of values)
+- &do_log ('debug',"check_cas checker_cas : $session->{'checked_cas'} current cas_id $Conf{'cas_id'}{$robot}{$auth_service->{'auth_service_name'}}");
+- next if ($session->{'checked_cas'} =~ /$Conf{'cas_id'}{$robot}{$auth_service->{'auth_service_name'}}/) ;
+-
+- # before redirect update the list of already checked cas server to prevent loop
+- my $cas_server = $auth_service->{'cas_server'};
+- my $return_url = &wwslib::get_my_url();
+-
+- ## Append the current CAS server ID to the list of checked CAS servers
+- $session->{'checked_cas'} .= $Conf{'cas_id'}{$robot}{$auth_service->{'auth_service_name'}};
+-
+- my $redirect_url = $cas_server->getServerLoginGatewayURL($return_url);
+-
+- if ($redirect_url =~ /http(s)+\:\//i) {
+- $in{'action'} = 'redirect';
+- $param->{'redirect_to'} = $redirect_url;
+-
+- last
+- }elsif($redirect_url == -1) { # CAS server auth error
+- do_log('notice',"CAS server auth error $auth_service->{'auth_service_name'}" );
+- }else{
+- do_log('notice',"Strange CAS ticket detected and validated check sympa code !" );
+- }
+- }
+- $session->{'do_not_use_cas'} = 1 unless ($param->{'redirect_to'} =~ /http(s)+\:\//i) ; #set do_not_use_cas because all cas servers have been checked without success
+- }
+- }
+-
+-
+- ##Cookie extern : sympa_altemails
+- ## !!
+- $param->{'alt_emails'} = &cookielib::check_cookie_extern($ENV{'HTTP_COOKIE'},$Conf{'cookie'},$param->{'user'}{'email'});
+-
+- if ($param->{'user'}{'email'}) {
+-# $param->{'auth'} = $param->{'alt_emails'}{$param->{'user'}{'email'}} || 'classic';
+-
+- if (&List::is_user_db($param->{'user'}{'email'})) {
+- $param->{'user'} = &List::get_user_db($param->{'user'}{'email'});
+- }
+-
+- ## For the parser to display an empty field instead of [xxx]
+- $param->{'user'}{'gecos'} ||= '';
+- unless (defined $param->{'user'}{'cookie_delay'}) {
+- $param->{'user'}{'cookie_delay'} = $wwsconf->{'cookie_expire'};
+- }
+-
+- ## Skip get_which if either in a list context or accessing the CSS
+- unless ($in{'action'} eq 'css' || defined $in{'list'}) {
+- @{$param->{'get_which'}} = &List::get_which($param->{'user'}{'email'},$robot,'member') ;
+- @{$param->{'get_which_owner'}} = &List::get_which($param->{'user'}{'email'},$robot,'owner') ;
+- @{$param->{'get_which_editor'}} = &List::get_which($param->{'user'}{'email'},$robot,'editor') ;
+- }
+-# }
+-
+- }
+- } ## END if RSS
+-
+- ## Action
+- my $action = $in{'action'};
+-
+- ## Store current action in the session in order to redirect after a logi or other temporary actions.
+- ## We should not memorize ULRs that are transitory actions
+- ## POST is not handled
+- ## A lot of other methods where used in the past (before session was introduced in Sympa). We must clean all.
+- unless ($temporary_actions{$action} || $ENV{'REQUEST_METHOD'} ne 'GET') {
+- $session->{'redirect_url'} = $param->{'base_url'}.$param->{'path_cgi'}.$ENV{'PATH_INFO'};
+- }
+-
+- $action ||= &Conf::get_robot_conf($robot, 'default_home');
+- $param->{'remote_addr'} = $ENV{'REMOTE_ADDR'} ;
+- $param->{'remote_host'} = $ENV{'REMOTE_HOST'};
+- $param->{'http_user_agent'} = $ENV{'HTTP_USER_AGENT'};
+- $param->{'htmlarea_url'} = $wwsconf->{'htmlarea_url'} ;
+- # if ($wwsconf->{'export_topics'} =~ /all/i);
+-
+- if ($in{'action'} eq 'css') {
+- &do_css();
+- $param->{'action'} = 'css';
+- }elsif ($maintenance_mode) {
+- &do_maintenance();
+- $param->{'action'} = 'maintenance';
+- }else {
+-
+- ## Session loop
+- while ($action) {
+- unless (&check_param_in()) {
+- &report::reject_report_web('user','wrong_param',{},$action,$list);
+- &wwslog('info','Wrong parameters');
+- last;
+- }
+-
+- $param->{'host'} = $list->{'admin'}{'host'} if (ref($list) eq 'List');
+- $param->{'host'} ||= $robot;
+- $param->{'domain'} = $list->{'domain'} if (ref($list) eq 'List');
+-
+- ## language ( $ENV{'HTTP_ACCEPT_LANGUAGE'} not used !)
+- $param->{'list_lang'} = $list->{'admin'}{'lang'} if (ref($list) eq 'List');
+- $param->{'user_lang'} = $param->{'user'}{'lang'} if (defined $param->{'user'});
+- $param->{'lang'} = $session->{'lang'} || $param->{'user_lang'} || $param->{'list_lang'} || &Conf::get_robot_conf($robot, 'lang');
+-
+- $param->{'locale'} = &Language::SetLang($param->{'lang'});
+-
+- &export_topics ($robot);
+-
+- unless ($comm{$action}) {
+- if (new List ($action, $robot)){
+- &do_redirect ($param->{'base_url'}.$param->{'path_cgi'}.'/info/'.$action);
+- last;
+- }
+- &report::reject_report_web('user','unknown_action',{},$action,$list);
+- &wwslog('info','unknown action %s', $action);
+- last;
+- }
+-
+- $param->{'action'} = $action;
+-
+- my $old_action = $action;
+- my $old_subaction = $in{'subaction'};
+-
+- ## Check required action parameters
+- my $check_output = &check_action_parameters($action);
+-
+- if (! defined $check_output ) {
+- &wwslog('err', "missing required parameters for action '$action'");
+- delete($param->{'action'});
+- last;
+-
+- }elsif ($check_output != 1) {
+- ## The output of the check may indicate another action to run first
+- ## Example : running loginrequest if user is not authenticated
+- $action = $param->{'action'} = $check_output;
+- }
+-
+- ## Execute the action ##
+- if (defined $action) {
+- $action = &{$comm{$action}}();
+- }
+-
+- unless (defined $action) {
+- delete($param->{'action'});
+- last;
+- }
+-
+- last if ($action =~ /redirect/) ; # after redirect do not send anything, it will crash fcgi lib
+-
+-
+- if ($action eq $old_action) {
+- # if a subaction is define and change, then it is not a loop
+- if (! defined ($in{'subaction'})||($in{'subaction'} eq $old_subaction)){
+- &wwslog('info','Stopping loop with %s action', $action);
+- #undef $action;
+- $action = 'home';
+- }
+- }
+-
+- undef $action if ($action == 1);
+- }
+- }
+-
+- ## Prepare outgoing params
+- &check_param_out();
+-
+- ## Params
+- $param->{'refparam'} = ref($param);
+- $param->{'action_type'} = $action_type{$param->{'action'}};
+-
+- $param->{'action_type'} = 'none' unless (($param->{'is_priv'})||($param->{'action_type'} eq 'serveradmin'));
+- $param->{'lang'} ||= $param->{'user'}{'lang'} if (defined $param->{'user'});
+- $param->{'lang'} ||= &Conf::get_robot_conf($robot, 'lang');
+-
+- if ($param->{'list'}) {
+- $param->{'list_title'} = $list->{'admin'}{'subject'};
+- $param->{'list_protected_email'} = &get_protected_email_address($param->{'list'}, $list->{'admin'}{'host'});
+- $param->{'title'} = &get_protected_email_address($param->{'list'}, $list->{'admin'}{'host'});
+- $param->{'title_clear_txt'} = "$param->{'list'}";
+-
+- if ($param->{'subtitle'}) {
+- $param->{'main_title'} = "$param->{'list'} - $param->{'subtitle'}";
+- }
+-
+- }else {
+- $param->{'main_title'} = $param->{'title'} = &Conf::get_robot_conf($robot,'title');
+- $param->{'title_clear_txt'} = $param->{'title'};
+- }
+- $param->{'robot_title'} = &Conf::get_robot_conf($robot,'title');
+-
+- ## store in session table this session contexte
+- $session->store();
+-
+- ## Do not manage cookies at this level if content was already sent
+- unless ($param->{'bypass'} eq 'extreme' ||
+- $param->{'action'} eq 'css' ||
+- $maintenance_mode ||
+- $rss) {
+-
+- my $delay = $param->{'user'}{'cookie_delay'};
+- unless (defined $delay) {
+- $delay = $wwsconf->{'cookie_expire'};
+- }
+-
+- if ($delay == 0) {
+- $delay = 'session';
+- }
+- $session->renew() unless($param->{'use_ssl'});
+-
+- unless ($session->set_cookie($param->{'cookie_domain'},$delay,$param->{'use_ssl'})) {
+- &wwslog('notice', 'Could not set HTTP cookie');
+- }
+-
+- ## Set cookies "your_subscribtions" unless in one list page
+- if ($param->{'user'}{'email'} && ref($list) ne 'List') {
+-
+- ## In case get_which was not set
+- @{$param->{'get_which'}} = &List::get_which($param->{'user'}{'email'},$robot,'member') unless (defined $param->{'get_which'});
+- @{$param->{'get_which_owner'}} = &List::get_which($param->{'user'}{'email'},$robot,'owner') unless (defined $param->{'get_which_owner'});
+- @{$param->{'get_which_editor'}} = &List::get_which($param->{'user'}{'email'},$robot,'editor') unless (defined $param->{'get_which_editor'});
+-
+- ## Add lists information to 'which_info'
+- foreach my $list (@{$param->{'get_which'}}) {
+- ## Evaluate AuthZ scenario first
+- my $result = $list->check_list_authz('visibility', $param->{'auth_method'},
+- {'sender' =>$param->{'user'}{'email'} ,
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- next unless (ref($result) eq 'HASH' && $result->{'action'} eq 'do_it');
+-
+- my $l = $list->{'name'};
+- $param->{'which_info'}{$l}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'which_info'}{$l}{'host'} = $list->{'admin'}{'host'};
+- $param->{'which_info'}{$l}{'info'} = 1;
+- }
+- foreach my $list (@{$param->{'get_which_owner'}}) {
+- my $l = $list->{'name'};
+- $param->{'which_info'}{$l}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'which_info'}{$l}{'host'} = $list->{'admin'}{'host'};
+- $param->{'which_info'}{$l}{'info'} = 1;
+- $param->{'which_info'}{$l}{'admin'} = 1;
+- }
+- foreach my $list (@{$param->{'get_which_editor'}}) {
+- my $l = $list->{'name'};
+-
+- $param->{'which_info'}{$l}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'which_info'}{$l}{'host'} = $list->{'admin'}{'host'};
+- $param->{'which_info'}{$l}{'info'} = 1;
+- $param->{'which_info'}{$l}{'admin'} = 1;
+- }
+- }
+- ## Set cookies unless client use https authentication
+- if ($param->{'user'}{'email'}) {
+- if ($param->{'user'}{'email'} ne 'x509') {
+- $session->{'auth'} ||= 'classic';
+- $param->{'cookie_set'} = 1;
+-
+-
+- ###Cookie extern : sympa_altemails
+- my $number = 0;
+- foreach my $element (keys %{$param->{'alt_emails'}}){
+- $number ++ if ($element);
+- }
+-
+- unless ($number == 0) {
+- unless(&cookielib::set_cookie_extern($Conf{'cookie'},$param->{'cookie_domain'},%{$param->{'alt_emails'}})){
+- &wwslog('notice', 'Could not set HTTP cookie for external_auth');
+- }
+- }
+- }
+- } #elsif ($ENV{'HTTP_COOKIE'} =~ /sympauser\=/){
+- # &cookielib::set_cookie('unknown', $Conf{'cookie'}, $param->{'cookie_domain'}, 'now');
+- #}
+- }
+-
+- ## Available languages
+- my $saved_lang = &Language::GetLang();
+-
+-
+- foreach my $l (@{&Language::GetSupportedLanguages($robot)}) {
+- &Language::SetLang($l) || next;
+-
+- if (gettext("_language_")) {
+- $param->{'languages'}{$l}{'complete'} = gettext("_language_");
+- }else {
+- $param->{'languages'}{$l}{'complete'} = $l;
+- }
+-
+- if ($param->{'locale'} eq $l) {
+- $param->{'languages'}{$l}{'selected'} = 'selected="selected"';
+- }else {
+- $param->{'languages'}{$l}{'selected'} = '';
+- }
+- }
+-
+- &Language::SetLang($saved_lang);
+-
+- $param->{'html_dumpvars'} = &tools::dump_html_var($param) if ($session->{'dumpvars'});
+-
+- # if bypass is defined select the content-type from various vars
+- if ($param->{'bypass'}) {
+-
+- ## if bypass = 'extreme' leave the action send the content-type and the content itself
+- unless ($param->{'bypass'} eq 'extreme') {
+-
+- ## if bypass = 'asis', file content-type is in the file itself as is define by the action in $param->{'content_type'};
+- unless ($param->{'bypass'} eq 'asis') {
+- my $type = $param->{'content_type'} || $mime_types->{$param->{'file_extension'}} || 'application/octet-stream';
+- printf "Content-Type: %s\n\n", $type;
+- }
+-
+- # $param->{'file'} or $param->{'error'} must be define in this case.
+-
+- if (open (FILE, $param->{'file'})){
+- print <FILE>;
+- close FILE;
+- }elsif(&report::is_there_any_reject_report_web()){
+- ## for compatibility : it could be better
+- my $intern = &report::get_intern_error_web();
+- my $system = &report::get_system_error_web();
+- my $user = &report::get_user_error_web();
+- my $auth = &report::get_auth_reject_web();
+-
+- if (ref($intern) eq 'ARRAY'){
+- printf "INTERNAL SERVER ERROR\n";
+- };
+- if (ref($system) eq 'ARRAY'){
+- printf "SYSTEM ERROR\n";
+- };
+- if (ref($user) eq 'ARRAY'){
+- foreach my $err (@$user){
+- printf "ERROR : $err\n";
+- }
+- };
+- if (ref($auth) eq 'ARRAY'){
+- foreach my $err (@$auth){
+- printf "AUTHORISATION FAILED : $err\n";
+- }
+- };
+-
+- }else{
+- printf "Internal error content-type nor file defined\n";
+- &do_log('err', 'Internal error content-type nor file defined');
+- }
+- }
+-
+- }elsif ($rss) {
+- ## Send RSS
+- print "Cache-control: no-cache\n";
+- print "Content-Type: application/rss+xml; charset=utf-8\n\n";
+-
+- ## Icons
+- $param->{'icons_url'} = $Conf{'static_content_url'}.'/icons';
+-
+- ## Retro compatibility concerns
+- $param->{'active'} = 1;
+-
+- if (defined $list) {
+- $param->{'list_conf'} = $list->{'admin'};
+- }
+-
+- my $lang = &Language::Lang2Locale($param->{'lang'});
+- my $tt2_include_path = &tools::make_tt2_include_path($robot,'web_tt2',$lang,$list);
+-
+- unless (&tt2::parse_tt2($param,'rss.tt2' ,\*STDOUT, $tt2_include_path, {})) {
+- my $error = &tt2::get_error();
+- $param->{'tt2_error'} = $error;
+- unless (&List::send_notify_to_listmaster('web_tt2_error', $robot, [$error])) {
+- &wwslog('notice','Unable to send notify "web_tt2_error" to listmaster');
+- }
+- }
+-
+-
+-# close FILE;
+- }elsif ($param->{'redirect_to'}) {
+- do_log ('notice',"Redirecting to $param->{'redirect_to'}");
+- print "Location: $param->{'redirect_to'}\n\n";
+- }else {
+- &prepare_report_user();
+- &send_html('main.tt2');
+- }
+-
+- # exit if wwsympa.fcgi itself has changed
+- if ((stat($ENV{'SCRIPT_FILENAME'}))[9] > $birthday ) {
+- do_log('notice',"Exiting because $ENV{'SCRIPT_FILENAME'} has changed since fastcgi server started");
+- exit(0);
+- }
+-
+- }
+-
+- ##############################################################
+- #-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/#-#\#|#/
+- ##############################################################
+-
+-
+- ## Write to log
+- sub wwslog {
+- my $facility = shift;
+-
+- # do not log if log level if too high regarding the log requested by user
+- return if ($Log::levels{$facility} > $Log::log_level);
+-
+- my $msg = shift;
+-
+- my $remote = $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'};
+-
+- ## Determine calling function and parameters
+- my @call = caller(1);
+- $msg = $call[3].'() ' . $msg if ($call[3]);
+-
+- $msg = "[list $param->{'list'}] " . $msg
+- if $param->{'list'};
+-
+-
+- if ($param->{'alt_emails'}) {
+- my @alts;
+- foreach my $alt (keys %{$param->{'alt_emails'}}) {
+- push @alts, $alt
+- unless ($alt eq $param->{'user'}{'email'});
+- }
+-
+- if ($#alts >= 0) {
+- my $alt_list = join ',', @alts;
+- $msg = "[alt $alt_list] " . $msg;
+- }
+- }
+-
+- $msg = "[user $param->{'user'}{'email'}] " . $msg
+- if $param->{'user'}{'email'};
+-
+- $msg = "[rss] ".$msg
+- if $rss;
+-
+- $msg = "[client $remote] ".$msg
+- if $remote;
+-
+- $msg = "[session $session->{'id_session'}] ".$msg
+- if $session;
+-
+- $msg = "[robot $robot] ".$msg;
+-
+- return &Log::do_log($facility, $msg, @_);
+- }
+-
+-sub web_db_log {
+- my $data = shift;
+-
+- $data->{'client'} = $param->{'remote_addr'};
+- $data->{'daemon'} = 'wwsympa';
+- $data->{'robot'} ||= $robot;
+- $data->{'list'} ||= $list->{'name'} if (defined $list);
+- $data->{'action'} ||= $param->{'action'};
+- $data->{'user_email'} ||= $param->{'user'}{'email'} if (defined $param->{'user'});
+- $data->{'target_email'} ||= $data->{'user_email'}; ## Default email is the user email
+-
+- unless (&Log::db_log($data)) {
+- &wwslog('err','web_db_log: failed to log in database');
+- return undef;
+- }
+-
+- return 1;
+-}
+-
+- sub new_loop {
+- $loop++;
+- my $query;
+-
+- if ($wwsconf->{'use_fast_cgi'}) {
+- $query = new CGI::Fast;
+- $loop_count++;
+- }else {
+- return undef if ($loop > 1);
+-
+- $query = new CGI;
+- }
+-
+- return $query;
+- }
+-
+-sub get_header_field {
+- my $field = shift;
+-
+- ## HTTP_X_ header fields set when using a proxy
+- if ($field eq 'SERVER_NAME') {
+- return $ENV{'HTTP_X_FORWARDED_SERVER'} || $ENV{'SERVER_NAME'};
+- }elsif ($field eq 'HTTP_HOST') {
+- return $ENV{'HTTP_X_FORWARDED_HOST'} || $ENV{'HTTP_HOST'};
+- }else {
+- return $ENV{$field};
+- }
+-}
+-
+-
+-
+-# _split_params is used by get_parameters to split path info in the appropriate parameters list.
+-# It is used also by action ticket to prepare the context stored in the one_time_ticket table in string like path_info
+-# input ENV{'PATH_INFO'} like string, output in the global $param hash
+-sub _split_params {
+- my $args_string = shift;
+-
+- &do_log('debug', "PATH_INFO: %s",$ENV{'PATH_INFO'});
+-
+- $args_string =~ s+^/++;
+-
+- my $ending_slash = 0;
+- if ($args_string =~ /\/$/) {
+- $ending_slash = 1;
+- }
+-
+- my @params = split /\//, $args_string;
+-
+- if ($params[0] eq 'nomenu') {
+- $param->{'nomenu'} = 1;
+- $param->{'path_cgi'} .= '/nomenu'; ## other links should keep the nomenu attribute
+- shift @params;
+- }
+-
+- ## debug mode
+- if ($params[0] =~ /debug(\d)?/) {
+- shift @params;
+- if ($1) {
+- $main::options{'debug_level'} = $1 if ($1);
+- }else{
+- $main::options{'debug_level'} = 1 ;
+- }
+- }else{
+- $main::options{'debug_level'} = 0 ;
+- }
+- do_log ('debug2', "debug level $main::options{'debug_level'}");
+-
+- ## rss mode
+- if ($params[0] eq 'rss') {
+- shift @params;
+- $rss = 1;
+- }
+-
+- if ($#params >= 0) {
+- $in{'action'} = $params[0];
+-
+- my $args;
+- if (defined $action_args{$in{'action'}}) {
+- $args = $action_args{$in{'action'}};
+- }else {
+- $args = $action_args{'default'};
+- }
+-
+- my $i = 1;
+- foreach my $p (@$args) {
+- my $pname;
+- ## More than 1 param
+- if ($p =~ /^\@(\w+)$/) {
+- $pname = $1;
+- $in{$pname} = join '/', @params[$i..$#params];
+- $in{$pname} .= '/' if $ending_slash;
+- last;
+- }
+- else {
+- $pname = $p;
+- $in{$pname} = $params[$i];
+- }
+- &wwslog('debug',"Incoming parameter: $pname=$in{$pname}");
+- $i++;
+- }
+- }
+-}
+-
+-sub get_parameters {
+- # &wwslog('debug3', 'get_parameters');
+-
+- ## CGI URL
+- if ($ENV{'HTTPS'} eq 'on') {
+- $param->{'base_url'} = sprintf 'https://%s', &get_header_field('HTTP_HOST');
+- $param->{'use_ssl'} = 1;
+- }else {
+- $param->{'base_url'} = sprintf 'http://%s', &get_header_field('HTTP_HOST');
+- $param->{'use_ssl'} = 0;
+- }
+-
+- $param->{'path_info'} = $ENV{'PATH_INFO'};
+- $param->{'http_method'} = $ENV{'REQUEST_METHOD'}; ## Usefull to skip previous_action when using POST
+- $param->{'robot_domain'} = $wwsconf->{'robot_domain'}{&get_header_field('SERVER_NAME')};
+-
+- if ($ENV{'REQUEST_METHOD'} eq 'GET') {
+- &_split_params ($ENV{'PATH_INFO'});
+- }elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
+- ## POST
+-
+- if ($in{'javascript_action'}) {
+- ## because of incompatibility javascript
+- $in{'action'} = $in{'javascript_action'};
+- }
+- foreach my $p (keys %in) {
+- do_log('debug2',"POST key $p value $in{$p}") unless ($p =~ /passwd/);
+- if ($p =~ /^((\w*)action)_(\w+)((\.\w+)*)$/) {
+-
+- $in{$1} = $3;
+- if ($4) {
+- foreach my $v (split /\./, $4) {
+- $v =~ s/^\.?(\w+)\.?/$1/;
+- $in{$v} = 1;
+- }
+- }
+- undef $in{$p};
+- }
+- }
+- $param->{'nomenu'} = $in{'nomenu'};
+- }
+-
+- ## Lowercase email addresses
+- $in{'email'} = lc ($in{'email'});
+-
+- ## Don't get multiple listnames
+- if ($in{'list'}) {
+- my @lists = split /\0/, $in{'list'};
+- $in{'list'} = $lists[0];
+- }
+-
+- my $custom_attribute ;
+- my $custom_input;
+-
+- ## Check parameters format
+- foreach my $p (keys %in) {
+-
+- ## Skip empty parameters
+- next if ($in{$p} =~ /^$/);
+-
+- ## Remove DOS linefeeds (^M) that cause problems with Outlook 98, AOL, and EIMS:
+- $in{$p} =~ s/\015//g;
+-
+- #XXX## Convert from the web encoding to unicode string
+- #XXX$in{$p} = Encode::decode('utf8', $in{$p});
+-
+- my @tokens = split (/\./, $p);
+- my $pname = $tokens[0];
+-
+- ## Regular expressions applied on parameters
+-
+- my $regexp;
+- if ($pname =~ /^additional_field/) {
+- $regexp = $in_regexp{'additional_field'};
+- }elsif ($pname =~ /^custom_attribute(.*)$/) {
+- my $key = $tokens[1] ;
+- $regexp = $in_regexp{'custom_attribute'};
+- do_log ('debug2', "get_parameters (custom_attribute) : ($p)($key) $pname $in{$p} $Conf{$key}{type}");
+- $custom_attribute->{$key} = {value=>$in{$p}} ;
+- undef $in{$p} ;
+- }elsif ($pname =~ /^custom_input(.*)$/) {
+- my $key = $tokens[1];
+- $regexp = $in_regexp{'custom_input'};
+- do_log ('debug2', "get_parameters (custom_input) : ($p)($key) $pname $in{$p} $Conf{$key}{type}");
+- $custom_input->{$key} = $in{$p};
+- undef $in{$p};
+- }elsif ($in_regexp{$pname}) {
+- $regexp = $in_regexp{$pname};
+- }else {
+- $regexp = $in_regexp{'*'};
+- }
+-
+- my $negative_regexp;
+- if ($pname =~ /^additional_field/) {
+- $negative_regexp = $in_negative_regexp{'additional_field'};
+- }elsif ($in_negative_regexp{$pname}) {
+- $negative_regexp = $in_negative_regexp{$pname};
+- }
+-
+- # If we are editing an HTML file in the shared, allow HTML but prevent XSS.
+- if ($pname eq 'content' && $in{'action'} eq 'd_savefile' && $in{'path'} =~ $list->{'dir'}.'/shared' && lc($in{'path'}) =~ /\.html?/) {
+- my $tmpparam = $in{$p};
+- $tmpparam = &tools::sanitize_html('robot' => $robot,
+- 'string' => $in{$p});
+- if (defined $tmpparam) {
+- $in{$p} = $tmpparam;
+- }
+- else {
+- &do_log('err','Unable to sanitize parameter %s',$pname);
+- }
+- }
+- foreach my $one_p (split /\0/, $in{$p}) {
+- if ($one_p !~ /^$regexp$/s ||
+- (defined $negative_regexp && $one_p =~ /$negative_regexp/s) ) {
+- ## Dump parameters in a tmp file for later analysis
+- my $dump_file = &Conf::get_robot_conf($robot, 'tmpdir').'/sympa_dump.'.time.'.'.$$;
+- unless (open DUMP, ">$dump_file") {
+- &wwslog('err','get_parameters: failed to create %s : %s', $dump_file, $!);
+- }
+- &tools::dump_var(\%in, 0, \*DUMP);
+- close DUMP;
+-
+- &report::reject_report_web('user','syntax_errors',{'params' => $p},'','');
+- &wwslog('err','get_parameters: syntax error for parameter %s value \'%s\' not conform to regexp:%s ; dumped vars in %s', $pname, $one_p, $regexp, $dump_file);
+- $in{$p} = '';
+- next;
+- }
+- }
+- }
+-
+- $in{custom_attribute} = $custom_attribute ;
+- $in{custom_input} = $custom_input;
+-
+- ## For shared-related actions, Q-encode filenames
+- ## This required for filenames that include non ascii characters
+- if (defined $filtering{$in{'action'}}) {
+-
+- my %apply_to; ## Build list of parameters filters apply to
+- foreach my $p (keys %{$filtering{$in{'action'}}}) {
+- if ($p =~ /\*/) { ## use of wildcar
+- my $p_regexp = $p; $p_regexp =~ s/\*/\.\*/g; ## Turn wildcar into a regexp
+- foreach my $in_key (keys %in) {
+- if ($in_key =~ /^$p_regexp$/) {
+- $apply_to{$in_key} = $filtering{$in{'action'}}{$p};
+- }
+- }
+- }else {
+- $apply_to{$p} = $filtering{$in{'action'}}{$p};
+- }
+- }
+-
+- foreach my $p (keys %apply_to) {
+- my $filtering_action = $apply_to{$p};
+- if ($filtering_action eq 'qencode') {
+- ## Q-encode file path
+- my @tokens = split /\//, $in{$p};
+- foreach my $i (0..$#tokens) {
+- $tokens[$i] = &tools::qencode_filename($tokens[$i]);
+- }
+- $in{$p} = join '/', @tokens;
+- ## Sympa's URI escaping subroutine (tools::escape_chars()) replaces '/' with %A5 ('�' character)
+- ## This should be transformed into a '/' again
+-
+- }elsif ($filtering_action eq 'unescape_html') {
+- $in{$p} = &tools::unescape_chars($in{$p});
+-
+- }elsif ($filtering_action eq 'fix_escape_uri') {
+- $in{$p} =~ s/\xa5/\//g;
+-
+- }elsif ($filtering_action eq 'normalize') {
+- $in{$p} =~ s/^\$+//; ## remove leading \s
+- $in{$p} =~ s/\$+$//; ## remove trailing \s
+- $in{$p} = lc($in{$p}); ## lowercase
+- }
+- }
+- }
+-
+- return 1;
+- }
+-
+-sub get_parameters_old {
+- # &wwslog('debug3', 'get_parameters');
+-
+- ## CGI URL
+- if ($ENV{'HTTPS'} eq 'on') {
+- $param->{'base_url'} = sprintf 'https://%s', &get_header_field('HTTP_HOST');
+- $param->{'use_ssl'} = 1;
+- }else {
+- $param->{'base_url'} = sprintf 'http://%s', &get_header_field('HTTP_HOST');
+- $param->{'use_ssl'} = 0;
+- }
+-
+- $param->{'path_info'} = $ENV{'PATH_INFO'};
+- $param->{'robot_domain'} = $wwsconf->{'robot_domain'}{&get_header_field('SERVER_NAME')};
+-
+- if ($ENV{'REQUEST_METHOD'} eq 'GET') {
+- my $path_info = $ENV{'PATH_INFO'};
+- &do_log('debug', "PATH_INFO: %s",$ENV{'PATH_INFO'});
+-
+- $path_info =~ s+^/++;
+-
+- my $ending_slash = 0;
+- if ($path_info =~ /\/$/) {
+- $ending_slash = 1;
+- }
+-
+- my @params = split /\//, $path_info;
+-
+-
+- # foreach my $i(0..$#params) {
+- # $params[$i] = &tools::unescape_chars($params[$i]);
+- # }
+-
+- if ($params[0] eq 'nomenu') {
+- $param->{'nomenu'} = 1;
+- $param->{'path_cgi'} .= '/nomenu'; ## other links should keep the nomenu attribute
+- shift @params;
+- }
+-
+- ## debug mode
+- if ($params[0] =~ /debug(\d)?/) {
+- shift @params;
+- if ($1) {
+- $main::options{'debug_level'} = $1 if ($1);
+- }else{
+- $main::options{'debug_level'} = 1 ;
+- }
+- }else{
+- $main::options{'debug_level'} = 0 ;
+- }
+- do_log ('debug2', "debug level $main::options{'debug_level'}");
+-
+-
+-
+- ## rss mode
+-########### /^rss$/ ???
+- if ($params[0] eq 'rss') {
+- shift @params;
+- $rss = 1;
+- }
+-
+- if ($#params >= 0) {
+- $in{'action'} = $params[0];
+-
+- my $args;
+- if (defined $action_args{$in{'action'}}) {
+- $args = $action_args{$in{'action'}};
+- }else {
+- $args = $action_args{'default'};
+- }
+-
+- my $i = 1;
+- foreach my $p (@$args) {
+- my $pname;
+- ## More than 1 param
+- if ($p =~ /^\@(\w+)$/) {
+- $pname = $1;
+- $in{$pname} = join '/', @params[$i..$#params];
+- $in{$pname} .= '/' if $ending_slash;
+- last;
+- }
+- else {
+- $pname = $p;
+- $in{$pname} = $params[$i];
+- }
+- $i++;
+- }
+- }
+- }elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
+- ## POST
+-
+- if ($in{'javascript_action'}) {
+- ## because of incompatibility javascript
+- $in{'action'} = $in{'javascript_action'};
+- }
+- foreach my $p (keys %in) {
+- do_log('debug2',"POST key $p value $in{$p}");
+- if ($p =~ /^((\w*)action)_(\w+)((\.\w+)*)$/) {
+-
+- $in{$1} = $3;
+- if ($4) {
+- foreach my $v (split /\./, $4) {
+- $v =~ s/^\.?(\w+)\.?/$1/;
+- $in{$v} = 1;
+- }
+- }
+-
+- undef $in{$p};
+- }
+- }
+-
+- $param->{'nomenu'} = $in{'nomenu'};
+- }
+-
+- ## Lowercase email addresses
+- $in{'email'} = lc ($in{'email'});
+-
+- ## Don't get multiple listnames
+- if ($in{'list'}) {
+- my @lists = split /\0/, $in{'list'};
+- $in{'list'} = $lists[0];
+- }
+-
+-
+- my $custom_attribute ;
+-
+- ## Check parameters format
+- foreach my $p (keys %in) {
+-
+- ## Skip empty parameters
+- next if ($in{$p} =~ /^$/);
+-
+- ## Remove DOS linefeeds (^M) that cause problems with Outlook 98, AOL, and EIMS:
+- $in{$p} =~ s/\015//g;
+-
+- #XXX## Convert from the web encoding to unicode string
+- #XXX$in{$p} = Encode::decode('utf8', $in{$p});
+-
+- my @tokens = split (/\./, $p);
+- my $pname = $tokens[0];
+-
+- ## Regular expressions applied on parameters
+-
+- my $regexp;
+- if ($pname =~ /^additional_field/) {
+- $regexp = $in_regexp{'additional_field'};
+- }elsif ($pname =~ /^custom_attribute(.*)$/) {
+- my $key = $tokens[1] ;
+- $regexp = $in_regexp{'custom_attribute'};
+- do_log ('debug2', "get_parameters (custom_attribute) : ($p)($key) $pname $in{$p} $Conf{$key}{type}");
+- $custom_attribute->{$key} = {value=>$in{$p}} ;
+- undef $in{$p} ;
+-
+- }elsif ($in_regexp{$pname}) {
+- $regexp = $in_regexp{$pname};
+- }else {
+- $regexp = $in_regexp{'*'};
+- }
+-
+- my $negative_regexp;
+- if ($pname =~ /^additional_field/) {
+- $negative_regexp = $in_negative_regexp{'additional_field'};
+- }elsif ($in_negative_regexp{$pname}) {
+- $negative_regexp = $in_negative_regexp{$pname};
+- }
+-
+- # If we are editing an HTML file in the shared, allow HTML but prevent XSS.
+- if ($pname eq 'content' && $in{'action'} eq 'd_savefile' && $in{'path'} =~ $list->{'dir'}.'/shared' && lc($in{'path'}) =~ /\.html?/) {
+- my $tmpparam = $in{$p};
+- $tmpparam = &tools::sanitize_html('robot' => $robot,
+- 'string' => $in{$p});
+- if (defined $tmpparam) {
+- $in{$p} = $tmpparam;
+- }
+- else {
+- &do_log('err','Unable to sanitize parameter %s',$pname);
+- }
+- }
+-
+- foreach my $one_p (split /\0/, $in{$p}) {
+- if ($one_p !~ /^$regexp$/s ||
+- (defined $negative_regexp && $one_p =~ /$negative_regexp/s) ) {
+- ## Dump parameters in a tmp file for later analysis
+- my $dump_file = &Conf::get_robot_conf($robot, 'tmpdir').'/sympa_dump.'.time.'.'.$$;
+- unless (open DUMP, ">$dump_file") {
+- &wwslog('err','get_parameters: failed to create %s : %s', $dump_file, $!);
+- }
+- &tools::dump_var(\%in, 0, \*DUMP);
+- close DUMP;
+-
+- &report::reject_report_web('user','syntax_errors',{'params' => $p},'','');
+- &wwslog('err','get_parameters: syntax error for parameter %s value \'%s\' not conform to regexp:%s ; dumped vars in %s', $pname, $one_p, $regexp, $dump_file);
+- $in{$p} = '';
+- next;
+- }
+- }
+- }
+-
+- $in{custom_attribute} = $custom_attribute ;
+-
+- ## For shared-related actions, Q-encode filenames
+- ## This required for filenames that include non ascii characters
+- if (defined $filtering{$in{'action'}}) {
+-
+- foreach my $p (keys %{$filtering{$in{'action'}}}) {
+- if ($filtering{$in{'action'}}{$p} eq 'qencode') {
+- ## Q-encode file path
+- my @tokens = split /\//, $in{$p};
+- foreach my $i (0..$#tokens) {
+- $tokens[$i] = &tools::qencode_filename($tokens[$i]);
+- }
+- $in{$p} = join '/', @tokens;
+- ## Sympa's URI escaping subroutine (tools::escape_chars()) replaces '/' with %A5 ('�' character)
+- ## This should be transformed into a '/' again
+-
+- }elsif ($filtering{$in{'action'}}{$p} eq 'fix_escape_uri') {
+- $in{$p} =~ s/\xa5/\//g;
+- }
+- }
+- }
+-
+- return 1;
+- }
+-
+-## Check required parameters for an action
+-## It compares incoming parameter to those declared as required in %required_args
+-## Also check required privileges to perform each action
+-sub check_action_parameters {
+- my $action = shift;
+-
+- if (defined $required_args{$action}) {
+- foreach my $arg_name (@{$required_args{$action}}) {
+-
+- ## Missing list parameter
+- if ($arg_name eq 'param.list') {
+- unless (defined $list) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$action);
+- &wwslog('info','missing list parameter');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'no_list'});
+-
+- return undef;
+- }
+-
+- ## User is not authenticated
+- }elsif ($arg_name eq 'param.user.email') {
+- unless (defined $param->{'user'} && $param->{'user'}{'email'}) {
+- &report::reject_report_web('user','no_user',{},$action);
+- &wwslog('err','user not logged in');
+- &web_db_log({'status' => 'error',
+- 'error_type' => "not_logged_in"});
+-
+- ## User is redirected to the login request form
+- $param->{'previous_action'} = $action;
+- $param->{'previous_list'} = $param->{'list'} if (defined $param->{'list'});
+- return 'loginrequest';
+-
+- }
+- ## Other incoming parameters
+- }else {
+- ## There may be alternate parameters
+- ## Then at least one of them MUST be set
+- my @req_parameters = split(/\|/, $arg_name);
+- my $ok = 0;
+- foreach my $req_param (@req_parameters) {
+- $ok =1 if ($in{$req_param});
+- }
+- unless ($ok) {
+- ## Replace \0 and '|' with ',' before logging
+- $in{$arg_name} =~ s/\0/,/g;
+- $in{$arg_name} =~ s/\|/,/g;
+-
+- &report::reject_report_web('user','missing_arg',{'argument' => $arg_name},$action);
+- &wwslog('info',"missing parameter '$arg_name'");
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return undef;
+- }
+- }
+- }
+- }
+-
+- ## Check required privileges
+- if (defined $required_privileges{$action}) {
+- ## There may be alternate privileges
+- ## Then at least one of them MUST verified
+- my $ok = 0;
+- my $missing_priv;
+- foreach my $req_priv (@{$required_privileges{$action}}) {
+- $ok =1 if ($param->{'is_'.$req_priv});
+- $missing_priv = $req_priv;
+- }
+- unless ($ok) {
+- &report::reject_report_web('auth','action_'.$missing_priv,{},$param->{'action'},$list);
+- &wwslog('info','authorization failed, insufficient privileges');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+- }
+-
+- return 1;
+-}
+-
+-## Send HTML output
+-sub send_html {
+-
+- my $tt2_file = shift;
+-
+- ## Send HTML
+- if ($param->{'date'}) {
+- Language::PushLang("en_US");
+- printf "Date: %s\n", &POSIX::strftime('%a, %d %b %Y %R %z',localtime(time));
+- Language::PopLang();
+- }
+- ## If we set the header indicating the last time the file to send was modified, add an HTTP header (limitate web harvesting).
+- if ($param->{'header_date'}) {
+- Language::PushLang("en_US");
+- printf "Last-Modified: %s\n", &POSIX::strftime('%a, %d %b %Y %R %z',localtime($param->{'header_date'}));
+- Language::PopLang();
+- }
+- print "Cache-control: no-cache\n" unless ( $param->{'action'} eq 'arc') ;
+- print "Content-Type: text/html\n\n";
+-
+- ## Icons
+- $param->{'icons_url'} = $Conf{'static_content_url'}.'/icons';
+-
+-
+- ## Retro compatibility concerns
+- $param->{'active'} = 1;
+-
+- if (defined $list) {
+- $param->{'list_conf'} = $list->{'admin'};
+- }
+-
+- ## Trying to use custom_vars
+- if (defined $list->{'admin'}{'custom_vars'}) {
+- foreach my $var (@{$list->{'admin'}{'custom_vars'}}) {
+- $param->{'custom_vars'}{$var->{'name'}} = $var->{'value'};
+- }
+- }
+-
+- my $lang = &Language::Lang2Locale($param->{'lang'});
+- my $tt2_include_path = &tools::make_tt2_include_path($robot,'web_tt2',$lang,$list);
+-
+- # XSS escaping applied to all outgoing parameters.
+- my $param_copy = &tools::dup_var($param); ## Escape parameters on a copy to avoid altering usefull data.
+- if(defined $param_copy) {
+- unless(&tools::sanitize_var('var' => $param_copy,
+- 'level' => 0,
+- 'robot' => $robot,
+- 'htmlAllowedParam' => $param_copy->{'htmlAllowedParam'} ,
+- 'htmlToFilter' => $param_copy->{'htmlToFilter'} ,
+- )
+- )
+- {
+- &do_log('err','Failed to sanitize $param in host %s', $robot);
+- }
+- }
+-
+- unless (&tt2::parse_tt2($param_copy,$tt2_file , \*STDOUT, $tt2_include_path, {})) {
+- my $error = &tt2::get_error();
+- $param->{'tt2_error'} = $error;
+- $param_copy->{'tt2_error'} = $error;
+- &List::send_notify_to_listmaster('web_tt2_error', $robot, [$error]);
+- &tt2::parse_tt2($param_copy,'tt2_error.tt2' , \*STDOUT, $tt2_include_path);
+- }
+-}
+-
+-sub prepare_report_user {
+-
+- $param->{'intern_errors'} = &report::get_intern_error_web();
+- $param->{'system_errors'} = &report::get_system_error_web();
+- $param->{'user_errors'} = &report::get_user_error_web();
+- $param->{'auth_rejects'} = &report::get_auth_reject_web();
+- $param->{'notices'} = &report::get_notice_web();
+- $param->{'errors'} = &report::is_there_any_reject_report_web();
+-}
+-
+-
+-
+-
+-=pod
+-
+-=head2 sub check_param_in
+-
+-Checks parameters contained in the global variable $in. It is the process used to analyze the incoming parameters.
+-Use it to create a List object and initialize output parameters.
+-
+-=head3 Arguments
+-
+-=over
+-
+-=item * I<None>
+-
+-=back
+-
+-=head3 Return
+-
+-=over
+-
+-=item * I<undef> if the process encounters problems.
+-
+-=item * I<1> if everything goes well
+-
+-=back
+-
+-=head3 Calls
+-
+-=over
+-
+-=item * d_access_control
+-
+-=item * make_pictures_url
+-
+-=item * wwslog
+-
+-=item * Language::SetLang
+-
+-=item * List::am_i
+-
+-=item * List::check_list_authz
+-
+-=item * List::get_mod_spool_size
+-
+-=item * List::get_shared_moderated
+-
+-=item * List::get_subscriber
+-
+-=item * List::get_subscription_request_count
+-
+-=item * List::get_total
+-
+-=item * List::get_total_bouncing
+-
+-=item * List::is_listmaster
+-
+-=item * List::is_moderated
+-
+-=item * List::is_user
+-
+-=item * List::new
+-
+-=item * List::request_action
+-
+-=item * report::reject_report_web
+-
+-=back
+-
+-=cut
+-
+- ## Analysis of incoming parameters
+- sub check_param_in {
+- &wwslog('debug2', 'check_param_in');
+-
+- ## Lowercase list name
+- $in{'list'} =~ tr/A-Z/a-z/;
+-
+- ## In case the variable was multiple
+- if ($in{'list'} =~ /^(\S+)\0/) {
+- $in{'list'} = $1;
+-
+- ## Create a new List instance.
+- unless ($list = new List ($in{'list'}, $robot)) {
+- &report::reject_report_web('user','unknown_list',{'list' => $in{'list'}},$param->{'action'},'');
+- &wwslog('info','check_param_in: unknown list %s', $in{'list'});
+- return undef;
+- }
+-
+- ## Set lang to list lang
+- &Language::SetLang($list->{'admin'}{'lang'});
+- }
+-
+- ## listmaster has owner and editor privileges for the list
+- if (&List::is_listmaster($param->{'user'}{'email'},$robot)) {
+- $param->{'is_listmaster'} = 1;
+- }
+-
+- if ($in{'list'}) {
+- ## Create a new List instance.
+- unless ($list = new List ($in{'list'}, $robot, {})) {
+- &report::reject_report_web('user','unknown_list',{'list' => $in{'list'}},$param->{'action'},'');
+- &wwslog('info','check_param_in: unknown list %s', $in{'list'});
+- return undef;
+- }
+-
+- ## Gather list configuration informations for further output.
+- $param->{'list'} = $in{'list'};
+- $param->{'subtitle'} = $list->{'admin'}{'subject'};
+- $param->{'subscribe'} = $list->{'admin'}{'subscribe'}{'name'};
+- $param->{'send'} = $list->{'admin'}{'send'}{'title'}{$param->{'lang'}};
+-
+- # Pictures are not available unless it is configured for the list and the robot
+- if ($list->{'admin'}{'pictures_feature'} eq 'off') {
+- $param->{'pictures_display'} = undef;
+- }
+- else {
+- $param->{'pictures_display'} = 'on';
+- }
+-
+- ## Get the total number of subscribers to the list.
+- if (defined $param->{'total'}) {
+- $param->{'total'} = $list->get_total();
+- }else {
+- $param->{'total'} = $list->get_total('nocache');
+- }
+-
+- ## Check if the current list has a public key X.509 certificate.
+- $param->{'list_as_x509_cert'} = $list->{'as_x509_cert'};
+-
+- ## Stores to output the whole list's admin configuration.
+- $param->{'listconf'} = $list->{'admin'};
+-
+- ## If an user is logged in, checks this user's privileges.
+- if ($param->{'user'}{'email'}) {
+- $param->{'is_subscriber'} = $list->is_user($param->{'user'}{'email'});
+- $param->{'subscriber'} = $list->get_subscriber($param->{'user'}{'email'})
+- if $param->{'is_subscriber'};
+- $param->{'is_privileged_owner'} = $param->{'is_listmaster'} || $list->am_i('privileged_owner', $param->{'user'}{'email'});
+- $param->{'is_owner'} = $param->{'is_privileged_owner'} || $list->am_i('owner', $param->{'user'}{'email'});
+- $param->{'is_editor'} = $list->am_i('editor', $param->{'user'}{'email'});
+- $param->{'is_priv'} = $param->{'is_owner'} || $param->{'is_editor'};
+- $param->{'pictures_url'} = &tools::make_pictures_url('email' => $param->{'user'}{'email'}, 'list' => $list);
+-
+- ## Checks if the user can post in this list.
+- my $result = $list->check_list_authz('send',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+- $param->{'may_post'} = 1 if ($r_action !~ /reject/);
+-
+- ## If no user logged in, the output can ask for authentification.
+- }else {
+- $param->{'user'}{'email'} = undef;
+- $param->{'need_login'} = 1;
+-
+- }
+-
+- ## Check if this list's messages must be moderated.
+- $param->{'is_moderated'} = $list->is_moderated();
+-
+- ## If the user logged in is a privileged user, gather informations relative to administration tasks
+- if ($param->{'is_priv'}) {
+- $param->{'mod_message'} = $list->get_mod_spool_size();
+-
+- $param->{'mod_subscription'} = $list->get_subscription_request_count();
+-
+- $param->{'doc_mod_list'} = $list->get_shared_moderated();
+- $param->{'mod_total_shared'} = $#{$param->{'doc_mod_list'}} + 1;
+-
+- if ($param->{'total'} > 0) {
+- $param->{'bounce_total'} = $list->get_total_bouncing();
+- $param->{'bounce_rate'} = $param->{'bounce_total'} * 100 / $param->{'total'};
+- $param->{'bounce_rate'} = int ($param->{'bounce_rate'} * 10) / 10;
+- }else {
+- $param->{'bounce_rate'} = 0;
+- }
+- $param->{'mod_total'} = $param->{'mod_total_shared'}+$param->{'mod_message'}+$param->{'mod_subscription'};
+- }
+-
+-
+- ## Check unsubscription authorization for the current user and list.
+- my $result = $list->check_list_authz('unsubscribe',$param->{'auth_method'},
+- {'sender' =>$param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- $main::action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- if (! $param->{'user'}{'email'}) {
+- $param->{'may_signoff'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
+-
+- }elsif ($param->{'is_subscriber'}) {
+- $param->{'may_signoff'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
+- $param->{'may_suboptions'} = 1;
+- }
+-
+- ## Check subscription authorization for the current user and list.
+- my $result = $list->check_list_authz('subscribe',$param->{'auth_method'},
+- {'sender' =>$param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- $main::action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- $param->{'may_subscribe'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
+-
+-
+- ## Check if the current user can read the shared documents.
+- my %mode;
+- $mode{'read'} = 1;
+- my %access = &d_access_control(\%mode,"");
+- $param->{'may_d_read'} = $access{'may'}{'read'};
+-
+- ## Check the status (exists, deleted, doesn't exist) of the shared directory
+- $param->{'shared'} = $list->get_shared_status();
+- }
+-
+- ## Check if the current user can create a list.
+- my $result = &Scenario::request_action ('create_list',$param->{'auth_method'},$robot,
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+- $param->{'create_list_reason'} = $reason;
+-
+- if ($param->{'user'}{'email'} &&
+- (($param->{'create_list'} = $r_action ) =~ /do_it|listmaster/)) {
+- $param->{'may_create_list'} = 1;
+- }else{
+- undef ($param->{'may_create_list'});
+- }
+-
+- return 1;
+-
+- }
+-
+- ## Prepare outgoing params
+- sub check_param_out {
+- &wwslog('debug2', 'check_param_out');
+-
+- $param->{'loop_count'} = $loop_count;
+- $param->{'start_time'} = $start_time;
+- $param->{'process_id'} = $$;
+-
+- ## listmaster has owner and editor privileges for the list
+- if (&List::is_listmaster($param->{'user'}{'email'},$robot)) {
+- $param->{'is_listmaster'} = 1;
+- }else {
+- undef $param->{'is_listmaster'};
+- }
+-
+- ## Reset $list variable if it is not expected for the current action
+- ## To prevent the list panel from being printed in a non list context
+- ## Only check if the corresponding entry exists in %action_args
+- if (defined $param->{'action'} && defined $action_args{$param->{'action'}}) {
+- unless (grep /^list$/, @{$action_args{$param->{'action'}}}) {
+- $param->{'list'} = undef;
+- $list = undef;
+- }
+- }
+-
+- ## Email addresses protection
+-
+- if (defined $list) {
+- if ($list->{'admin'}{'spam_protection'} eq 'at') {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = ' AT '; $param->{'hidden_end'} = '';
+- }elsif($list->{'admin'}{'spam_protection'} eq 'javascript') {
+- $param->{'protection_type'} = 'javascript';
+- $param->{'hidden_head'} = '
+- <script type="text/javascript">
+- <!--
+- document.write("';
+- $param->{'hidden_at'} ='" + "@" + "';
+- $param->{'hidden_end'} ='")
+- // -->
+- </script>';
+- }else {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = '@'; $param->{'hidden_end'} = '';
+- }
+- }else {
+- if (&Conf::get_robot_conf($robot,'spam_protection') eq 'at') {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = ' AT '; $param->{'hidden_end'} = '';
+- }elsif(&Conf::get_robot_conf($robot,'spam_protection') eq 'javascript') {
+- $param->{'protection_type'} = 'javascript';
+- $param->{'hidden_head'} = '
+- <script type="text/javascript">
+- <!--
+- document.write("';
+- $param->{'hidden_at'} ='" + "@" + "';
+- $param->{'hidden_end'} ='")
+- // -->
+- </script>';
+- }else {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = '@'; $param->{'hidden_end'} = '';
+- }
+- }
+-
+- if ($list->{'name'}) {
+- &wwslog('debug2', "list-name $list->{'name'}");
+-
+- ## Email addresses protection
+- if ($in{'action'} eq 'arc') {
+- $param->{'protection_type'} = undef;
+- if ($list->{'admin'}{'web_archive_spam_protection'} eq 'at') {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = ' AT '; $param->{'hidden_end'} = '';
+- }elsif($list->{'admin'}{'web_archive_spam_protection'} eq 'javascript') {
+- $param->{'protection_type'} = 'javascript';
+- $param->{'hidden_head'} = '
+- <script type="text/javascript">
+- <!--
+- document.write("';
+- $param->{'hidden_at'} ='" + "@" + "';
+- $param->{'hidden_end'} ='")
+- // -->
+- </script>';
+- }else {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = '@'; $param->{'hidden_end'} = '';
+- }
+- }else {
+- if ($list->{'admin'}{'spam_protection'} eq 'at') {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = ' AT '; $param->{'hidden_end'} = '';
+- }elsif($list->{'admin'}{'spam_protection'} eq 'javascript') {
+- $param->{'hidden_head'} = '
+- <script type="text/javascript">
+- <!--
+- document.write("';
+- $param->{'hidden_at'} ='" + "@" + "';
+- $param->{'hidden_end'} ='")
+- // -->
+- </script>';
+- }else {
+- $param->{'hidden_head'} = ''; $param->{'hidden_at'} = '@'; $param->{'hidden_end'} = '';
+- }
+- }
+-
+- ## Owners
+- my $owners = $list->get_owners();
+- foreach my $o (@{$owners}) {
+- next unless $o->{'email'};
+- $param->{'owner'}{$o->{'email'}}{'gecos'} = $o->{'gecos'};
+- $param->{'owner'}{$o->{'email'}}{'visibility'} = $o->{'visibility'};
+- $param->{'owner'}{$o->{'email'}}{'mailto'} = &mailto($list,$o->{'email'},$o->{'gecos'});
+- ($param->{'owner'}{$o->{'email'}}{'local'},$param->{'owner'}{$o->{'email'}}{'domain'}) = split ('@',$o->{'email'});
+- my $masked_email = $o->{'email'};
+- $masked_email =~ s/\@/ AT /;
+- $param->{'owner'}{$o->{'email'}}{'masked_email'} = $masked_email;
+- }
+-
+- ## Editors
+- if (defined $list->{'admin'}{'editor'}) {
+- my $editors = $list->get_editors();
+- foreach my $e (@{$editors}) {
+- next unless $e->{'email'};
+- $param->{'editor'}{$e->{'email'}}{'gecos'} = $e->{'gecos'};
+- $param->{'editor'}{$e->{'email'}}{'visibility'} = $e->{'visibility'};
+- $param->{'editor'}{$e->{'email'}}{'mailto'} = &mailto($list,$e->{'email'},$e->{'gecos'});
+- ($param->{'editor'}{$e->{'email'}}{'local'},$param->{'editor'}{$e->{'email'}}{'domain'}) = split ('@',$e->{'email'});
+- my $masked_email = $e->{'email'};
+- $masked_email =~ s/\@/ AT /;
+- $param->{'editor'}{$e->{'email'}}{'masked_email'} = $masked_email;
+- }
+- }
+-
+- ## Environment variables
+- foreach my $k (keys %ENV) {
+- $param->{'env'}{$k} = $ENV{$k};
+- }
+- ## privileges
+- if ($param->{'user'}{'email'}) {
+- $param->{'is_subscriber'} = $list->is_user($param->{'user'}{'email'});
+- $param->{'subscriber'} = $list->get_subscriber($param->{'user'}{'email'})
+- if $param->{'is_subscriber'};
+- $param->{'is_privileged_owner'} = $param->{'is_listmaster'} || $list->am_i('privileged_owner', $param->{'user'}{'email'});
+- $param->{'is_owner'} = $param->{'is_privileged_owner'} || $list->am_i('owner', $param->{'user'}{'email'});
+- $param->{'is_editor'} = $list->am_i('editor', $param->{'user'}{'email'});
+- $param->{'is_priv'} = $param->{'is_owner'} || $param->{'is_editor'};
+-
+- #May post:
+- my $result = $list->check_list_authz('send',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+-
+- my $r_action;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- if ($r_action =~ /do_it/) {
+- $param->{'may_post'} = 1 ;
+- }else {
+- $param->{'may_post_reason'} = $reason;
+- }
+-
+-
+- if (($list->{'admin'}{'user_data_source'} eq 'include2') &&
+- $list->has_include_data_sources() &&
+- $param->{'is_owner'}) {
+- $param->{'may_sync'} = 1;
+- }
+- }else {
+- ## If user not logged in && GET method && not an authN-related action
+- ## Keep track of the 'referer' parameter
+- if ($ENV{'REQUEST_METHOD'} eq 'GET' &&
+- ! $auth_action{$in{'action'}} ) {
+- $param->{'referer'} = &tools::escape_chars(&wwslib::get_my_url());
+- }else {
+- ## Keep the previous value of the referer
+- $param->{'referer'} = $in{'referer'};
+- }
+- }
+-
+- ## Should Not be used anymore ##
+- $param->{'may_subunsub'} = 1
+- if ($param->{'may_signoff'} || $param->{'may_subscribe'});
+-
+- ## May review
+- my $result = $list->check_list_authz('review',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- $param->{'may_suboptions'} = 1 unless ($list->{'admin'}{'user_data_source'} eq 'include');
+- $param->{'total'} = $list->get_total();
+- $param->{'may_review'} = 1 if ($r_action =~ /do_it/);
+- $param->{'list_status'} = $list->{'admin'}{'status'};
+-
+- ## May signoff
+- my $result = $list->check_list_authz('unsubscribe',$param->{'auth_method'},
+- {'sender' =>$param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- $main::action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- if (! $param->{'user'}{'email'}) {
+- $param->{'may_signoff'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
+-
+- }elsif ($param->{'is_subscriber'} &&
+- ($param->{'subscriber'}{'subscribed'} == 1)) {
+- $param->{'may_signoff'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
+- $param->{'may_suboptions'} = 1;
+- }
+-
+- ## May Subscribe
+- my $result = $list->check_list_authz('subscribe',$param->{'auth_method'},
+- {'sender' =>$param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- $main::action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- $param->{'may_subscribe'} = 1 if ($main::action =~ /do_it|owner|request_auth/);
+-
+-
+-
+- ## Archives Access control
+- if (defined $list->{'admin'}{'web_archive'}) {
+- $param->{'is_archived'} = 1;
+-
+- ## Check if the current user may access web archives
+- my $result = $list->check_list_authz('web_archive.access',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- if ($r_action =~ /do_it/i) {
+- $param->{'arc_access'} = 1;
+- }else{
+- undef ($param->{'arc_access'});
+- }
+-
+- ## Check if web archive is publically accessible (useful information for RSS)
+- my $result = $list->check_list_authz('web_archive.access',$param->{'auth_method'},
+- {'sender' => 'nobody'});
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- if ($r_action =~ /do_it/i) {
+- $param->{'arc_public_access'} = 1;
+- }
+- }
+-
+- ## Shared documents access control
+- if ($list->get_shared_status() eq 'exist') {
+- ## Check if shared is publically accessible (useful information for RSS)
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => 'nobody'});
+- my $r_action;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- }
+-
+- if ($r_action =~ /do_it/i) {
+- $param->{'shared_public_access'} = 1;
+- }
+-
+- }
+- }
+-
+- $param->{'robot'} = $robot;
+-
+- ## If parameter has the Unicode Perl flag, then switch to utf-8
+- ## this switch is applied recursively
+- &tools::recursive_transformation($param, \&tools::unicode_to_utf8);
+-
+- }
+-
+-## ticket : this action is used if someone submits a one time ticket
+-sub do_ticket {
+- &wwslog('info', 'do_ticket(%s)', $in{'ticket'});
+-
+- $param->{'ticket_context'} = &Auth::get_one_time_ticket($in{'ticket'}, $ip );
+- $param->{'ticket_context'}{'printable_date'} = gettext_strftime "%d %b %Y at %H:%M:%S", localtime($param->{'ticket_context'}{'date'});
+-
+- return 1 unless ($param->{'ticket_context'}{'result'} eq 'success' or $param->{'ticket_context'}{'result'} eq 'closed');
+-
+- # if the ticket is related to someone which is not logged in, the system performs the same operation as for a login
+- my $email_regexp = &tools::get_regexp('email');
+- if ($param->{'ticket_context'}{'result'} eq 'success') {
+- $session->{'email'} = lc($param->{'ticket_context'}{'email'});
+- $param->{'user'} = &List::get_user_db($session->{'email'});
+- $param->{'user'}{'email'} = $session->{'email'} ;
+- $param->{'last_login _host'} = $param->{'user'}{'last_login_host'};
+- $param->{'last_login_date'} = &POSIX::strftime("%d %b %Y at %H:%M:%S", localtime($param->{'user'}{'last_login_date'})) if ($param->{'user'}{'last_login_date'});
+- &List::update_user_db($param->{'user'}{'email'},{last_login_date =>time(),last_login_host=>$ip }) ;
+- }elsif($param->{'ticket_context'}{'result'} eq 'closed'){
+- &wwslog('info', 'do_ticket(%s) : Refusing to perform login because the ticket has been used before', $in{'ticket'});
+- return 1;
+- }else{
+- &wwslog('err', 'do_ticket(%s) : Unable to evaluate the ticket validity (status: %s)', $in{'ticket'}, $param->{'ticket_context'}{'result'});
+- return 1;
+- }
+- &_split_params($param->{'ticket_context'}{'data'});
+- return $in{'action'} ;
+-
+-}
+-
+-
+- ## Login WWSympa
+- sub do_login {
+- &wwslog('info', 'do_login(%s)', $in{'email'});
+- my $user;
+- my $next_action;
+-
+- if ($in{'referer'}) {
+- $param->{'redirect_to'} = &tools::unescape_chars($in{'referer'});
+- }elsif ($in{'previous_action'} &&
+- $in{'previous_action'} !~ /^(login|logout|loginrequest)$/) {
+- $next_action = $in{'previous_action'};
+- $in{'list'} = $in{'previous_list'};
+- }else {
+- $next_action = 'home';
+- }
+- # never return to login or logout when login.
+- $next_action = 'home' if ($in{'next_action'} eq 'login') ;
+- $next_action = 'home' if ($in{'next_action'} eq 'logout') ;
+-
+- if ($param->{'user'}{'email'}) {
+- &report::reject_report_web('user','already_login',{'email' => $param->{'user'}{'email'}},$param->{'action'},'');
+- &wwslog('info','do_login: user %s already logged in', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'already_login'});
+- if ($param->{'nomenu'}) {
+- $param->{'back_to_mom'} = 1;
+- return 1;
+- }else {
+- return $next_action;
+- }
+- }
+-
+- unless ($in{'email'}) {
+- &report::reject_report_web('user','no_email',{},$param->{'action'},'');
+- &wwslog('info','do_login: no email');
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => "no_email"});
+- return $in{'previous_action'} || 'home';
+- }
+-
+- $session->{'unauthenticated_email'} = $param->{'unauthenticated_email'} = $in{'email'};
+-
+- unless ($in{'passwd'}) {
+- my $url_redirect;
+- #Does the email belongs to an ldap directory?
+- if($url_redirect = &is_ldap_user($in{'email'})){
+- $param->{'redirect_to'} = $url_redirect
+- if ($url_redirect && ($url_redirect != 1));
+- }elsif ($in{'failure_referer'}) {
+- $param->{'redirect_to'} = $in{'failure_referer'};
+- }else{
+- $in{'init_email'} = $in{'email'};
+- $param->{'init_email'} = $in{'email'};
+- $param->{'escaped_init_email'} = &tools::escape_chars($in{'email'});
+-
+- &report::reject_report_web('user','missing_arg',{'argument' => 'passwd'},$param->{'action'},'');
+- &wwslog('info','do_login: missing parameter passwd');
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => "missing_parameter"});
+- $param->{'login_error'} = 'missing_password';
+- return $in{'previous_action'} || 'renewpasswd';
+- }
+- }
+-
+- my $data;
+-
+- unless ($ENV{'REQUEST_METHOD'} eq 'POST') {
+- &do_log('notice', "Authentication failed, because do not use HTTP method POST but %s",$ENV{'REQUEST_METHOD'} );
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'not_using_post'});
+- return 'loginrequest';
+- }
+-
+-
+- unless($data = &Auth::check_auth($robot, $in{'email'},$in{'passwd'})){
+- &do_log('notice', "Authentication failed\n");
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'authentication'});
+- my $unauthenticated_user = &List::get_user_db($in{'email'});
+- if ($unauthenticated_user->{'wrong_login_count'} > &Conf::get_robot_conf($robot, 'max_wrong_password')){
+- $param->{'login_error'} = 'password_reset';
+- }else{
+- $param->{'login_error'} = 'wrong_password';
+- }
+- if ($in{'previous_action'}) {
+- delete $in{'passwd'};
+- $in{'list'} = $in{'previous_list'};
+- return $in{'previous_action'};
+- }elsif ($in{'failure_referer'}) {
+- $param->{'redirect_to'} = $in{'failure_referer'};
+- }else {
+- return 'renewpasswd';
+- }
+- }
+- $param->{'user'} = $data->{'user'};
+- $param->{'last_login_host'} = $data->{'user'}{'last_login_host'};
+- $param->{'last_login_date'} = &POSIX::strftime("%d %b %Y at %H:%M:%S", localtime($data->{'user'}{'last_login_date'})) if ($data->{'user'}{'last_login_date'});
+- $session->{'auth'} = $data->{'auth'};
+- my $email = lc($param->{'user'}{'email'});
+- $session->{'email'} = $email;
+- $session->{'unauthenticated_email'} = '';
+-
+- &List::update_user_db($param->{'user'}{'email'},{last_login_date =>time(),last_login_host=>$ip, wrong_login_count =>0}) ;
+-
+- ## Set alt_email
+- if ($data->{'alt_emails'}) {
+- foreach my $k (keys %{$data->{'alt_emails'}}) {
+- $param->{'alt_emails'}{$k} = $data->{'alt_emails'}{$k};
+- }
+- }
+-
+-
+- unless($param->{'alt_emails'}{$email}){
+- unless(&cookielib::set_cookie_extern($Conf{'cookie'},$param->{'cookie_domain'},%{$param->{'alt_emails'}})){
+- &wwslog('notice', 'Could not set HTTP cookie for external_auth');
+- &web_db_log({'parameters' => "$Conf{'cookie'},$param->{'cookie_domain'},%{$param->{'alt_emails'}}",
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'cookie'});
+- return undef;
+- }
+- }
+-
+- ## Current authentication mode
+- #$param->{'auth'} = $param->{'alt_emails'}{$param->{'user'}{'email'}} || 'classic';
+-
+-
+- if ($session->{'lang'}) { # user did choose a specific language before being logged. Apply it as a user pref.
+- &List::update_user_db($param->{'user'}{'email'},{lang=>$session->{'lang'}}) ;
+- $param->{'lang'} = $session->{'lang'};
+- }else{ # user did not choose a specific language, apply user pref for this session.
+- $param->{'lang'} = $user->{'lang'} || $list->{'admin'}{'lang'} || &Conf::get_robot_conf($robot, 'lang');
+- $session->{'lang'} = $param->{'lang'} ;
+- }
+-
+- if ($session->{'review_page_size'}) { # user did choose a specific page size upgrade prefs
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+-
+- if ($session->{'shared_mode'}) { # user did choose a shared expert/standard mode
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+-
+- if ($in{'newpasswd1'} && $in{'newpasswd2'}) {
+- my $old_action = $param->{'action'};
+- $param->{'action'} = 'setpasswd';
+- &do_setpasswd();
+- $param->{'action'} = $old_action;
+- }
+-
+- if ($param->{'nomenu'}) {
+- $param->{'back_to_mom'} = 1;
+- return 1;
+- }
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'success'});
+-
+- &do_redirect ($session->{'redirect_url'});
+- return ;
+-
+- }
+-
+-## Login WWSympa
+-## The sso_login action is made of 4 subactions that make a complete workflow.
+-## Note that this comlexe workflow is only used if the SSO server does not provide
+-## the user email address or if this email address is not trusted and therefore
+-## needs to be checked.
+-## The workflow:
+-## 1) init: determine if email address needs to be collected/checked
+-## 2) requestemail: collect the user email address in a web form. Note that form may be initialized with
+-## one email address provided by the SSO server
+-## 3) validateemail: a challenge is sent to the email address to validate it
+-## 4) confirmemail: user confirms his email address with the challenge
+-sub do_sso_login {
+- &wwslog('info', 'do_sso_login(%s)', $in{'auth_service_name'});
+-
+- delete $session->{'do_not_use_cas'}; #when user require CAS login, reset do_not_use_cas cookie
+- my $next_action;
+-
+- if ($param->{'user'}{'email'}) {
+- &report::reject_report_web('user','already_login',{'email' => $param->{'user'}{'email'}},$param->{'action'},'');
+- &wwslog('err','do_login: user %s already logged in', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'status' => 'error',
+- 'error_type' => "already_login"});
+- return 'home';
+- }
+-
+-
+- ## This is a CAS service
+- if (defined (my $cas_id = $Conf{'cas_id'}{$robot}{$in{'auth_service_name'}})) {
+- my $cas_server = $Conf{'auth_services'}{$robot}[$cas_id]{'cas_server'};
+-
+- my $path = '';
+- if ($param->{'nomenu'}) {
+- $path = "/nomenu";
+- }
+- $path .= "/sso_login_succeeded/$in{'auth_service_name'}";
+-
+- $session->{'checked_cas'} = $cas_id;
+- my $service = "$param->{'base_url'}$param->{'path_cgi'}".$path;
+-
+- my $redirect_url = $cas_server->getServerLoginURL($service);
+- &wwslog('info', 'do_sso_login: redirect_url(%s)', $redirect_url);
+- if ($redirect_url =~ /http(s)+\:\//i) {
+- $in{'action'} = 'redirect';
+- $param->{'redirect_to'} = $redirect_url;
+- $param->{'bypass'} = 'extreme';
+- $session->set_cookie('localhost','session');
+- print "Location: $param->{'redirect_to'}\n\n";
+- }
+-
+- }elsif (defined (my $sso_id = $Conf{'generic_sso_id'}{$robot}{$in{'auth_service_name'}})) {
+- ## Generic SSO
+-
+- ## If contacted via POST, then redirect the user to the URL for the access control to apply
+- if ($ENV{'REQUEST_METHOD'} eq 'POST') {
+- my $path = '';
+- my $service;
+-
+- if ($param->{'nomenu'}) {
+- $path = "/nomenu";
+- }
+- &wwslog('info', 'do_sso_login(): POST request processing');
+-
+- if ($in{'subaction'} eq 'validateemail') {
+- $path .= "/validateemail/$in{'email'}";
+-
+- }elsif ($in{'subaction'} eq 'confirmemail') {
+-
+- $path .= "/confirmemail/$in{'email'}/$in{'ticket'}";
+-
+- }else {
+-
+- $path .= "/init";
+- }
+-
+- my $service = "$param->{'base_url'}$param->{'path_cgi'}/sso_login/$in{'auth_service_name'}".$path;
+-
+- &wwslog('info', 'do_sso_login: redirect user to %s', $service);
+- $in{'action'} = 'redirect';
+- $param->{'redirect_to'} = $service;
+- $param->{'bypass'} = 'extreme';
+- print "Location: $param->{'redirect_to'}\n\n";
+-
+- return 1;
+- }
+-
+- my $email;
+- ## We need to collect/verify the user's email address
+- if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'force_email_verify'}) {
+- my $email_is_trusted = 0;
+-
+- ## the subactions order is : init, requestemail, validateemail, sendssopasswd, confirmemail
+-
+- ## get email from NetiD table
+- if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'internal_email_by_netid'}) {
+- &wwslog('debug', 'do_sso_login(): lookup email internal: %s', $sso_id);
+- if ($email = &Auth::get_email_by_net_id($robot, $sso_id, \%ENV)) {
+- $email_is_trusted = 1;
+- }
+- }
+-
+- ## get email from authN module
+- if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'} && ! $email_is_trusted) {
+- my @email_list = split(/$Conf{'auth_services'}{$robot}[$sso_id]{'http_header_value_separator'}/,
+- lc($ENV{$Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'}}));
+- $email = $email_list[0]; ## Only get the first occurence if multi-valued
+- }
+-
+- ## Start the email validation process
+- if ($in{'subaction'} eq 'init' &&
+- ($email_is_trusted == 0 || ! $email)) {
+- &wwslog('info', 'do_sso_login(): return request email');
+- $session->{'auth'} = 'generic_sso';
+- $param->{'server'}{'key'} = $in{'auth_service_name'};
+- $param->{'subaction'} = 'requestemail';
+- $param->{'init_email'} = $email;
+- return 1;
+- }
+-
+- if (defined($in{'email'}) and !($in{'subaction'} eq 'init')) {
+- $email = $in{'email'};
+- }
+-
+- ## Send a confirmation email and request it on the web interface
+- if ($in{'subaction'} eq 'validateemail') {
+- $session->{'auth'} = 'generic_sso';
+- $param->{'server'}{'key'} = $in{'auth_service_name'};
+- $param->{'init_email'} = $email;
+-
+- ## Replace sendpassword with one time ticket
+- $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'email'},$robot,'sso_login/confirmemail?auth_service_name='.$in{'auth_service_name'},$ip);
+-
+- unless (&sendssopasswd($email)) {
+- &report::reject_report_web('user','incorrect_email',{'email' => $email},$param->{'action'});
+- $param->{'subaction'} = 'requestemail';
+- return 1;
+- }
+-
+- $param->{'subaction'} = 'validateemail';
+- return 1;
+- }
+-
+- if ($in{'subaction'} eq 'confirmemail') {
+- $session->{'auth'} = 'generic_sso' ;
+- $param->{'server'}{'key'} = $in{'auth_service_name'};
+- $param->{'init_email'} = $email;
+- $in{'email'} = $email;
+-
+- #
+- # Check input parameters and verify ticket for email, stolen from do_login
+- #
+- unless ($in{'email'}) {
+- &report::reject_report_web('user','no_email',{},$param->{'action'});
+- &wwslog('info','confirmemail: no email');
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'no_email'});
+- $param->{'subaction'} = 'validateemail';
+- return 1;
+- }
+-
+- unless ($in{'ticket'}) {
+- $in{'init_email'} = $in{'email'};
+- $param->{'init_email'} = $in{'email'};
+- $param->{'escaped_init_email'} = &tools::escape_chars($in{'email'});
+-
+- &report::reject_report_web('user','missing_arg',{'argument' => 'ticket'},$param->{'action'});
+- &wwslog('info','do_sso_login: confirmemail: missing parameter ticket');
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- $param->{'subaction'} = 'validateemail';
+- return 1;
+- }
+-
+- ## Validate the ticket
+- my $ticket_output = &Auth::get_one_time_ticket($in{'ticket'}, $ip );
+- unless ($ticket_output->{'result'} eq 'success'){
+- &report::reject_report_web('user','auth_failed',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'authentication'});
+- &wwslog('err', "Authentication failed\n");
+-
+- $param->{'subaction'} = 'validateemail';
+- return 1;
+- }
+-
+- &wwslog('info', 'do_sso_login: confirmemail: email validation succeeded');
+- # need to create netid to email map entry
+- $email = $in{'email'};
+-
+- # everything is ok to proceed to with possible sympa account created and traddional sso login
+-
+- ## TODO : netidmap_table should also be used when no confirmation is performed
+- if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'internal_email_by_netid'}) {
+-
+- my $netid = $ENV{$Conf{'auth_services'}{$robot}[$sso_id]{'netid_http_header'}};
+- my $idpname = $Conf{'auth_services'}{$robot}[$sso_id]{'service_id'};
+-
+- unless(&List::set_netidtoemail_db($robot, $netid, $idpname, $in{'email'})) {
+- &report::reject_report_web('intern','db_update_failed',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err', 'error update netid map');
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return 'home';
+- }
+-
+- }else {
+- &wwslog('info', 'do_sso_login: confirmemail: validation failed');
+-
+- $param->{'subaction'} = 'validateemail';
+- return 1;
+- }
+- }
+-
+- }else {
+- ##
+- if (defined $Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'}) {
+- my @email_list = split($Conf{'auth_services'}{$robot}[$sso_id]{'http_header_value_separator'},
+- lc($ENV{$Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'}}));
+- $email = $email_list[0]; ## Only get the first occurence if multi-valued
+-
+- }else {
+- unless (defined $Conf{'auth_services'}{$robot}[$sso_id]{'ldap_host'} &&
+- defined $Conf{'auth_services'}{$robot}[$sso_id]{'ldap_get_email_by_uid_filter'}) {
+- &report::reject_report_web('intern','auth_conf_no_identified_user',{},$param->{'action'},'','',$robot);
+- &wwslog('err','do_sso_login: auth.conf error : either email_http_header or ldap_host/ldap_get_email_by_uid_filter entries should be defined');
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return 'home';
+- }
+-
+- $email = &Auth::get_email_by_net_id($robot, $sso_id, \%ENV);
+- }
+- }
+-
+- unless ($email) {
+- &report::reject_report_web('intern','no_identified_user',{},$param->{'action'},'','',$robot);
+- &wwslog('err','do_sso_login: user could not be identified, no %s HTTP header set', $Conf{'auth_services'}{$robot}[$sso_id]{'email_http_header'});
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+-
+- 'status' => 'error',
+- 'error_type' => 'no_email'});
+- return 'home';
+- }
+-
+- $param->{'user'}{'email'} = $email;
+- $session->{'email'} = $email;
+- $session->{'auth'} = 'generic_sso' ;
+-
+- &wwslog('notice', 'User identified as %s', $email);
+-
+- ## There are two ways to list the attributes that Sympa will cache for the user
+- ## Either with a defined header prefix (http_header_prefix)
+- ## Or with an explicit list of header fields (http_header_list)
+- my @sso_attr;
+- if ($Conf{'auth_services'}{$robot}[$sso_id]{'http_header_list'}) {
+- my $list_of_headers = $Conf{'auth_services'}{$robot}[$sso_id]{'http_header_list'};
+-
+- foreach my $field (split(/,/, $list_of_headers)) {
+- if (defined $ENV{$field}) {
+- push @sso_attr, "$field=$ENV{$field}";
+- }
+- }
+-
+- }elsif ($Conf{'auth_services'}{$robot}[$sso_id]{'http_header_list'}) {
+-
+- my $prefix = $Conf{'auth_services'}{$robot}[$sso_id]{'http_header_prefix'};
+-
+- foreach my $k (keys %ENV) {
+- if ($k =~ /^$prefix/) {
+- push @sso_attr, "$k=$ENV{$k}";
+- }
+- }
+- }
+-
+- my $all_sso_attr = join ';', @sso_attr;
+-
+- ## Create user entry if required
+- unless (&List::is_user_db($email)) {
+- unless (&List::add_user_db({'email' => $email})) {
+- &report::reject_report_web('intern','add_user_db_failed',{'user'=>$email},$param->{'action'},'',$email,$robot);
+- &wwslog('info','do_sso_login: add failed');
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- unless (&List::update_user_db($email,
+- {'attributes' => $all_sso_attr })) {
+- &report::reject_report_web('intern','update_user_db_failed',{'user'=>$email},$param->{'action'},'',$email,$robot);
+- &wwslog('info','do_sso_login: update failed');
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &report::notice_report_web('you_have_been_authenticated',{},$param->{'action'});
+-
+- ## Keep track of the SSO used to login
+- ## Required to provide logout feature if available
+- $session->{'sso_id'} = $in{'auth_service_name'};
+-
+- &do_redirect ($session->{'redirect_url'});
+- return ;
+- }else{
+- ## Unknown SSO service
+- &report::reject_report_web('intern','unknown_authentication_service',{'name'=> $in{'auth_service_name'}},$param->{'action'},'','',$robot);
+- &wwslog('err','do_sso_login: unknown authentication service %s', $in{'auth_service_name'});
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return 'home';
+- }
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'target_email' => $in{'email'},
+- 'status' => 'success'});
+- return 1;
+-}
+-
+-sub do_sso_login_succeeded {
+- &wwslog('info', 'do_sso_login_succeeded(%s)', $in{'auth_service_name'});
+-
+- if (defined $param->{'user'} && $param->{'user'}{'email'}) {
+- &report::notice_report_web('you_have_been_authenticated',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'status' => 'success'});
+-
+- }else{
+- &report::reject_report_web('user','auth_failed',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'auth_service_name'},
+- 'status' => 'error',
+- 'error_type' => 'authentication'});
+- }
+-
+- ## We should refresh the main window
+- if ($param->{'nomenu'}) {
+- $param->{'back_to_mom'} = 1;
+- return 1;
+- }else{
+- &do_redirect ($session->{'redirect_url'});
+- return;
+- }
+-}
+-
+- sub is_ldap_user {
+- my $auth = shift; ## User email or UID
+- &wwslog('debug2',"is_ldap_user ($auth)");
+-
+- unless (&tools::get_filename('etc',{}, 'auth.conf', $robot)) {
+- return undef;
+- }
+-
+- ## List all LDAP servers first
+- my @ldap_servers;
+- foreach my $ldap (@{$Conf{'auth_services'}{$robot}}){
+- next unless ($ldap->{'auth_type'} eq 'ldap');
+-
+- push @ldap_servers, $ldap;
+- }
+-
+- unless ($#ldap_servers >= 0) {
+- return undef;
+- }
+-
+- unless (eval "require Net::LDAP") {
+- &wwslog ('err',"Unable to use LDAP library, Net::LDAP required,install perl-ldap (CPAN) first");
+- return undef;
+- }
+- require Net::LDAP;
+-
+- my ($ldap_anonymous,$filter);
+-
+- foreach my $ldap (@ldap_servers){
+-
+- # skip ldap auth service if the user id or email do not match regexp auth service parameter
+- next unless ($auth =~ /$ldap->{'regexp'}/i);
+-
+- my $param = &tools::dup_var($ldap);
+- my $ds = new Datasource('LDAP', $param);
+-
+- unless (defined $ds && ($ldap_anonymous = $ds->connect())) {
+- &do_log('err',"Unable to connect to the LDAP server '%s'", $ldap->{'ldap_host'});
+- next;
+- }
+-
+- my @alternative_conf = split(/,/,$ldap->{'alternative_email_attribute'});
+- my $attrs = $ldap->{'email_attribute'};
+-
+- if (&tools::valid_email($auth)){
+- $filter = $ldap->{'get_dn_by_email_filter'};
+- }else{
+- $filter = $ldap->{'get_dn_by_uid_filter'};
+- }
+- $filter =~ s/\[sender\]/$auth/ig;
+-
+- ## !! une fonction get_dn_by_email/uid
+-
+- my $mesg = $ldap_anonymous->search(base => $ldap->{'suffix'} ,
+- filter => "$filter",
+- scope => $ldap->{'scope'},
+- timeout => $ldap->{'timeout'} );
+-
+- unless($mesg->count() != 0) {
+- &wwslog('notice','No entry in the Ldap Directory Tree of %s for %s',$ldap->{'host'},$auth);
+- $ds->disconnect();
+- last;
+- }
+-
+- $ds->disconnect();
+- my $redirect = $ldap->{'authentication_info_url'};
+- return $redirect || 1;
+-
+- next unless ($ldap_anonymous);
+- }
+- }
+-
+- ## send back login form
+- sub do_loginrequest {
+- &wwslog('info','do_loginrequest');
+-
+- if ($param->{'user'}{'email'}) {
+- &report::reject_report_web('user','already_login',{'email' => $param->{'user'}{'email'}},$param->{'action'});
+- &wwslog('info','do_loginrequest: already logged in as %s', $param->{'user'}{'email'});
+- return undef;
+- }
+-
+- if ($in{'init_email'}) {
+- $param->{'init_email'} = $in{'init_email'};
+- }
+-
+- if ($in{'previous_action'} eq 'referer') {
+- $param->{'referer'} = &tools::escape_chars($ENV{'HTTP_REFERER'});
+- }elsif (! $param->{'previous_action'}) {
+- $param->{'previous_action'} = 'loginrequest';
+- }
+-
+- $param->{'title'} = 'Login'
+- if ($param->{'nomenu'});
+-
+-
+- return 1;
+- }
+-
+- ## Help / about WWSympa
+- sub do_help {
+- &wwslog('info','do_help(%s)', $in{'help_topic'});
+-
+- ## Contextual help
+- if ($in{'help_topic'}) {
+- if ($in{'help_topic'} eq 'editlist') {
+- foreach my $pname (sort List::by_order keys %{$pinfo}) {
+- next if ($pname =~ /^(comment|defaults)$/);
+-
+- if ($pinfo->{$pname}{'gettext_id'}) {
+- $param->{'param'}{$pname}{'title'} = gettext($pinfo->{$pname}{'gettext_id'});
+- } else {
+- $param->{'param'}{$pname}{'title'} = $pinfo->{$pname}{'title'}{$param->{'lang'}};
+- }
+- $param->{'param'}{$pname}{'comment'} = $pinfo->{$pname}{'comment'}{$param->{'lang'}};
+- }
+- }
+-
+- $param->{'help_topic'} = $in{'help_topic'};
+- }
+-
+- return 1;
+- }
+-
+-# update session cookie and redirect the client to redirect_to parameter or glob var;
+-sub do_redirect {
+-
+- my $redirect_to = shift;
+- &wwslog('info','do_redirect(%s)', $redirect_to);
+-
+- $redirect_to ||= $param->{'redirect_to'};
+- # because of some bug Sympa did redirection to un empty URL. Next line should prevent it.
+- $redirect_to ||= $param->{'base_url'}.$param->{'path_cgi'};
+-
+- $session->set_cookie('localhost','session');
+- print "Location: $redirect_to\n\n";
+- $param->{'bypass'} = 'extreme';
+- return 1;
+-}
+-
+- ## Logout from WWSympa
+- sub do_logout {
+- &wwslog('info','do_logout(%s)', $param->{'user'}{'email'});
+-
+- delete $param->{'user'};
+- $session->{'email'} = 'nobody' ;
+-
+- # no reason to alter the lang because user perform logout
+- # $param->{'lang'} = $param->{'cookie_lang'} = &cookielib::check_lang_cookie($ENV{'HTTP_COOKIE'}) || $list->{'admin'}{'lang'} || &Conf::get_robot_conf($robot, 'lang');
+-
+- if (defined $session->{'cas_server'} && (defined $Conf{'auth_services'}{$robot}[$session->{'cas_server'}])) {
+- # this user was logged using CAS
+- my $cas_server = $Conf{'auth_services'}{$robot}[$session->{'cas_server'}]{'cas_server'};
+-
+- $in{'action'} = 'redirect';
+- my $return_url = &wwslib::get_my_url();
+- $return_url =~ s/\/logout//;
+-
+- $param->{'redirect_to'} = $cas_server->getServerLogoutURL($return_url);
+-
+- delete $session->{'cas_server'};
+- return 'redirect';
+- } elsif (defined $session->{'sso_id'}) {
+- # this user was logged using a generic_sso
+-
+- ## Check if logout_url is known for this SSO
+- my $sso;
+- unless ($sso = &Conf::get_sso_by_id(robot => $robot, service_id => $session->{'sso_id'})) {
+-
+- &wwslog('err',"unknown SSO service_id '%s'", $session->{'sso_id'});
+- return undef ;
+- }
+-
+- ## Remove sso_id
+- delete $session->{'sso_id'};
+-
+- if ($sso->{'logout_url'}) {
+-
+- $in{'action'} = 'redirect';
+- $param->{'redirect_to'} = $sso->{'logout_url'};
+-
+- return 'redirect';
+- }
+- }
+-
+- &wwslog('info','do_logout: logout performed');
+- &web_db_log({'parameters' => $param->{'user'}{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'success'});
+-
+- if ($in{'previous_action'} eq 'referer') {
+- $param->{'referer'} = &tools::escape_chars($in{'previous_list'});
+- }
+-
+- return 'home';
+- }
+-
+-sub sendssopasswd {
+- my $email = shift;
+- do_log('info', 'sendssopasswd(%s)', $email);
+-
+- my ($passwd, $user);
+-
+- unless ($email) {
+- &report::reject_report_web('user','no_email',{},$param->{'action'});
+- &wwslog('info','do_sendssopasswd: no email');
+- &web_db_log({'parameters' => $email,
+- 'target_email' => $email,
+- 'status' => 'error',
+- 'error_type' => "no_email"});
+- return 'requestemail';
+- }
+-
+- unless (&tools::valid_email($email)) {
+- &report::reject_report_web('user','incorrect_email',{'email' => $email},$param->{'action'});
+- &wwslog('info','do_sendssopasswd: incorrect email %s', $email);
+- &web_db_log({'parameters' => $email,
+- 'target_email' => $email,
+- 'status' => 'error',
+- 'error_type' => "incorrect_email"});
+-
+- return 'requestemail';
+- }
+-
+- my $url_redirect;
+-
+- if ($param->{'newuser'} = &List::get_user_db($email)) {
+-
+- ## Create a password if none
+- unless ($param->{'newuser'}{'password'}) {
+- unless ( &List::update_user_db($email,
+- {'password' => &tools::tmp_passwd($email)
+- })) {
+- &report::reject_report_web('intern','db_update_failed',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','sendssopasswd: update failed');
+- &web_db_log({'parameters' => $email,
+- 'target_email' => $email,
+- 'status' => 'error',
+- 'error_type' => "internal"});
+- return undef;
+- }
+- $param->{'newuser'}{'password'} = &tools::tmp_passwd($email);
+- }
+-
+- $param->{'newuser'}{'escaped_email'} = &tools::escape_chars($param->{'newuser'}{'email'});
+-
+- }else {
+-
+- $param->{'newuser'} = {'email' => $email,
+- 'escaped_email' => &tools::escape_chars($email),
+- 'password' => &tools::tmp_passwd($email)
+- };
+-
+- }
+-
+- $param->{'init_passwd'} = 1
+- if ($param->{'user'}{'password'} =~ /^init/);
+-
+- &List::send_global_file('sendssopasswd', $email, $robot, $param);
+-
+-
+- $param->{'email'} = $email;
+- &web_db_log({'parameters' => $email,
+- 'target_email' => $email,
+- 'status' => 'success'});
+-
+- return 'validateemail';
+-}
+-sub do_firstpasswd {
+- &wwslog('info', 'do_firstpasswd(%s)', $in{'email'});
+- $param->{'requestpasswd_context'} = 'firstpasswd';
+- return 'renewpasswd';
+-}
+- ## send a ticket for choosing a new password
+-sub do_renewpasswd {
+- &wwslog('info', 'do_renewpasswd(%s)', $in{'email'});
+-
+- my $url_redirect;
+- if($in{'email'}){
+- if($url_redirect = &is_ldap_user($in{'email'})){
+- $param->{'redirect_to'} = $url_redirect
+- if ($url_redirect && ($url_redirect != 1));
+- }elsif (! &tools::valid_email($in{'email'})) {
+- &report::reject_report_web('user','incorrect_email',{'email' => $in{'email'}},$param->{'action'});
+- &wwslog('info','do_renewpasswd: incorrect email \"%s\"', $in{'email'});
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'incorrect_email'});
+- return undef;
+- }
+- }
+-
+- $param->{'email'} = $in{'email'};
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'success',
+- });
+-
+- if ($in{'previous_action'} eq 'referer') {
+- $param->{'referer'} = &tools::escape_chars($in{'previous_list'});
+- }
+- return 1;
+- }
+-
+-####################################################
+-# do_requestpasswd
+-####################################################
+-# Sends a message to the user containing user password.
+-#
+-# IN : -
+-#
+-# OUT : 'renewpasswd' | 1 | 'loginrequest' | undef
+-#
+-####################################################
+- sub do_requestpasswd {
+- &wwslog('info', 'do_requestpasswd(%s)', $in{'email'});
+- my ($passwd, $user);
+-
+- $param->{'account_creation'} = 1;
+-
+- my $url_redirect;
+- if($url_redirect = &is_ldap_user($in{'email'})){
+- ## There might be no authentication_info_url URL defined in auth.conf
+- if ($url_redirect == 1) {
+- &report::reject_report_web('user','ldap_user',{},$param->{'action'});
+- &wwslog('info','do_requestpasswd: LDAP user %s, cannot remind password', $in{'email'});
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return 'home';
+- }else{
+- $param->{'redirect_to'} = $url_redirect if ($url_redirect && ($url_redirect != 1));
+- return 1;
+- }
+- }
+-
+- ## Check auth.conf before creating/sending a password
+- unless (&Auth::may_use_sympa_native_auth($robot, $in{'email'})) {
+- ## TODO: Error handling
+- &report::reject_report_web('user','passwd_reminder_not_allowed',{},$param->{'action'});
+- return undef
+- }
+- &wwslog('debug','do_requestpasswd: sending one tile ticket for %s', $in{'email'});
+- $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'email'},$robot,'choosepasswd',$ip);
+- $param->{'request_from_host'} = $ip;
+- $param->{'newuser'} = &List::get_user_db($in{'email'});
+- if ($param->{'one_time_ticket'}) {
+- $param->{'login_error'}='ticket_sent';
+- unless (&List::send_global_file('sendpasswd', $in{'email'}, $robot, $param)) {
+- &wwslog('notice',"Unable to send template 'sendpasswd' to $in{'email'}");
+- $param->{'login_error'}='unable_to_send_ticket';
+- }
+- }else{
+- &wwslog('notice',"Unable to create_one_time_ticket");
+- &report::reject_report_web('user','passwd_reminder_error',{},$param->{'action'});
+- $param->{'login_error'}='unable_to_create_ticket';
+- }
+-
+- return 1 unless ($param->{'previous_action'}) ;
+- return $param->{'previous_action'};
+- }
+-
+- ## Which list the user is subscribed to
+- ## TODO (pour listmaster, toutes les listes)
+- sub do_which {
+- my $which = {};
+-
+- &wwslog('info', 'do_which');
+-
+-
+- $param->{'get_which'} = undef ;
+- $param->{'which'} = undef ;
+-
+- foreach my $role ('member','owner','editor') {
+-
+- foreach my $list ( &List::get_which($param->{'user'}{'email'}, $robot, $role) ){
+- my $l = $list->{'name'};
+-
+- my $result = $list->check_list_authz('visibility', $param->{'auth_method'},
+- {'sender' =>$param->{'user'}{'email'} ,
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+-
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- next unless ($r_action =~ /do_it/);
+-
+- $param->{'which'}{$l}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'which'}{$l}{'host'} = $list->{'admin'}{'host'};
+-
+- if ($role eq 'member') {
+- push @{$param->{'get_which'}}, $list;
+- }
+-
+- if ($role eq 'owner' || $role eq 'editor') {
+- $param->{'which'}{$l}{'admin'} = 1;
+- }
+-
+- ## For compatibility concerns (3.0)
+- ## To be deleted one of these day
+- $param->{$role}{$l}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{$role}{$l}{'host'} = $list->{'admin'}{'host'};
+-
+- }
+-
+- }
+- # &List::db_log('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'which','',$robot,'','done');
+- return 1;
+- }
+-
+- ## The list of list
+- sub do_lists {
+- my @lists;
+- &wwslog('info', 'do_lists(%s,%s)', $in{'topic'}, $in{'subtopic'});
+-
+- my %topics = &List::load_topics($robot);
+-
+- if ($in{'topic'}) {
+- $param->{'topic'} = $in{'topic'};
+- if ($in{'subtopic'}) {
+- $param->{'subtopic'} = $in{'subtopic'};
+- $param->{'subtitle'} = sprintf "%s / %s", $topics{$in{'topic'}}{'current_title'}, $topics{$in{'topic'}}{'sub'}{$in{'subtopic'}}{'current_title'};
+- $param->{'subtitle'} ||= "$in{'topic'} / $in{'subtopic'}";
+- }else {
+- $param->{'subtitle'} = $topics{$in{'topic'}}{'current_title'} || $in{'topic'};
+- }
+- }
+-
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+-
+- my $sender = $param->{'user'}{'email'} || 'nobody';
+-
+- my $result = $list->check_list_authz('visibility',$param->{'auth_method'},
+- {'sender' => $sender,
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'options' => {'dont_reload_scenario' => 1}});
+-
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- next unless ($r_action eq 'do_it');
+-
+- my $list_info = {};
+- $list_info->{'subject'} = $list->{'admin'}{'subject'};
+- $list_info->{'host'} = $list->{'admin'}{'host'};
+- $list_info->{'date_epoch'} = $list->{'admin'}{'creation'}{'date_epoch'};
+- $list_info->{'date'} = $list->{'admin'}{'creation'}{'date'};
+- $list_info->{'topics'} = $list->{'admin'}{'topics'};
+- if ($param->{'user'}{'email'} &&
+- ($list->am_i('owner',$param->{'user'}{'email'}) ||
+- $list->am_i('editor',$param->{'user'}{'email'})) ) {
+- $list_info->{'admin'} = 1;
+- }
+- if ($param->{'user'}{'email'} &&
+- $list->is_user($param->{'user'}{'email'})) {
+- $list_info->{'is_subscriber'} = 1;
+- }
+-
+- ## no topic ; List all lists
+-
+- if (! $in{'topic'}) {
+- $param->{'which'}{$list->{'name'}} = $list_info;
+- }elsif ($list->{'admin'}{'topics'}) {
+- foreach my $topic (@{$list->{'admin'}{'topics'}}) {
+- my @tree = split '/', $topic;
+-
+- next if (($in{'topic'}) && ($tree[0] ne $in{'topic'}));
+- next if (($in{'subtopic'}) && ($tree[1] ne $in{'subtopic'}));
+-
+- $param->{'which'}{$list->{'name'}} = $list_info;
+- }
+- }elsif ($in{'topic'} eq 'topicsless') {
+- $param->{'which'}{$list->{'name'}} = $list_info;
+- }
+- }
+- foreach my $listname (sort keys %{$param->{'which'}}) {
+- if ($listname =~ /^([a-z])/){
+- push @{$param->{'orderedlist'}{$1}}, $listname ;
+- }else{
+- push @{$param->{'orderedlist'}{'others'}}, $listname ;
+- }
+- }
+- return 1;
+- }
+-
+- ## The list of latest created lists
+- sub do_latest_lists {
+- &wwslog('info', "do_latest_lists($in{'for'}, $in{'count'},$in{'topic'}, $in{'subtopic'})");
+-
+- unless (&do_lists()) {
+- &wwslog('err','do_latest_lists: error while calling do_lists');
+- return undef;
+- }
+-
+- my $today = time;
+-
+- my $oldest_day;
+- if (defined $in{'for'}) {
+- $oldest_day = $today - (3600 * 24 * ($in{'for'}));
+- $param->{'for'} = $in{'for'};
+- unless ($oldest_day >= 0){
+- &report::reject_report_web('user','nb_days_to_much',{'nb_days' => $in{'for'} },$param->{'action'});
+- &wwslog('err','do_latest_lists: parameter "for" is too big"');
+- }
+- }
+-
+- my $nb_lists = 0;
+- my @date_lists;
+- foreach my $listname (keys (%{$param->{'which'}})) {
+- if ($param->{'which'}{$listname}{'date_epoch'} < $oldest_day) {
+- delete $param->{'which'}{$listname};
+- next;
+- }
+- $nb_lists++;
+- }
+-
+- if (defined $in{'count'}) {
+- $param->{'count'} = $in{'count'};
+-
+- unless ($in{'count'}) {
+- $param->{'which'} = undef;
+- }
+- }
+-
+- my $count_lists = 0;
+- foreach my $l ( sort {$param->{'which'}{$b}{'date_epoch'} <=> $param->{'which'}{$a}{'date_epoch'}} (keys (%{$param->{'which'}}))) {
+-
+- $count_lists++;
+-
+- if ($in{'count'}) {
+- if ($count_lists > $in{'count'}){
+- last;
+- }
+- }
+-
+- $param->{'which'}{$l}{'name'} = $l;
+- push @{$param->{'latest_lists'}} , $param->{'which'}{$l};
+- }
+-
+- $param->{'which'} = undef;
+-
+- return 1;
+- }
+-
+-
+- ## The list of the most active lists
+- sub do_active_lists {
+- &wwslog('info', "do_active_lists($in{'for'}, $in{'count'},$in{'topic'}, $in{'subtopic'})");
+-
+- unless (&do_lists()) {
+- &wwslog('err','do_active_lists: error while calling do_lists');
+- return undef;
+- }
+-
+- ## oldest interesting day
+- my $oldest_day = 0;
+-
+- if (defined $in{'for'}) {
+- $oldest_day = int(time/86400) - $in{'for'};
+- unless ($oldest_day >= 0){
+- &report::reject_report_web('user','nb_days_to_much',{'nb_days' => $in{'for'} },$param->{'action'});
+- &wwslog('err','do_latest_lists: parameter "for" is too big"');
+- return undef;
+- }
+- }
+-
+- ## get msg count for each list
+- foreach my $l (keys (%{$param->{'which'}})) {
+- my $list = new List ($l, $robot);
+- my $file = "$list->{'dir'}/msg_count";
+-
+- my %count ;
+-
+- if (open(MSG_COUNT, $file)) {
+- while (<MSG_COUNT>){
+- if ($_ =~ /^(\d+)\s(\d+)$/) {
+- $count{$1} = $2;
+- }
+- }
+- close MSG_COUNT ;
+-
+- $param->{'which'}{$l}{'msg_count'} = &count_total_msg_since($oldest_day,\%count);
+-
+- if ($in{'for'}) {
+- my $average = $param->{'which'}{$l}{'msg_count'} / $in{'for'}; ## nb msg by day
+- $average = int($average * 10);
+- $param->{'which'}{$l}{'average'} = $average /10; ## one digit
+- }
+- } else {
+- $param->{'which'}{$l}{'msg_count'} = 0;
+- }
+- }
+-
+- my $nb_lists = 0;
+-
+- ## get "count" lists
+- foreach my $l ( sort {$param->{'which'}{$b}{'msg_count'} <=> $param->{'which'}{$a}{'msg_count'}} (keys (%{$param->{'which'}}))) {
+- if (defined $in{'count'}) {
+- $nb_lists++;
+- if ($nb_lists > $in{'count'}) {
+- last;
+- }
+- }
+-
+- $param->{'which'}{$l}{'name'} = $l;
+- push @{$param->{'active_lists'}} , $param->{'which'}{$l};
+-
+- }
+-
+- if (defined $in{'count'}) {
+- $param->{'count'} = $in{'count'};
+- }
+- if (defined $in{'for'}) {
+- $param->{'for'} = $in{'for'};
+- }
+-
+- $param->{'which'} = undef;
+-
+-
+- return 1;
+- }
+-
+- sub count_total_msg_since {
+- my $oldest_day = shift;
+- my $count = shift;
+-
+- my $total = 0;
+- foreach my $d (sort {$b <=> $a} (keys %$count)) {
+- if ($d < $oldest_day) {
+- last;
+- }
+- $total = $total + $count->{$d};
+- }
+- return $total;
+- }
+-
+- ## List information page
+- sub do_info {
+- &wwslog('info', 'do_info');
+-
+- ## Access control
+- unless (defined &check_authz('do_info', 'info')) {
+- delete $param->{'list'};
+- return undef;
+- }
+-
+- ## Get List Description
+- if (-r $list->{'dir'}.'/homepage') {
+- my $file_path = $list->{'dir'}.'/homepage';
+- unless (open FILE, "<", $file_path) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $file_path},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_info: failed to open file %s: %s', $file_path,$!);
+- &web_db_log({'parameters' => $file_path,
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- while (<FILE>) {
+- Encode::from_to($_, $Conf{'filesystem_encoding'}, 'utf8');
+- $param->{'homepage_content'} .= $_;
+- }
+- close FILE;
+-
+- ## Used by previous templates
+- $param->{'homepage'} = 1;
+- }elsif (-r $list->{'dir'}.'/info') {
+- my $file_path = $list->{'dir'}.'/info';
+- unless (open FILE, "<", $file_path) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $file_path},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_info: failed to open file %s: %s', $file_path,$!);
+- &web_db_log({'parameters' => $file_path,
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- while (<FILE>) {
+- Encode::from_to($_, $Conf{'filesystem_encoding'}, 'utf8');
+- $param->{'info_content'} .= $_;
+- }
+- close FILE;
+- $param->{'info_content'} =~ s/\n/\<br\/\>/g;
+- }
+-
+- &tt2::add_include_path($list->{'dir'});
+-
+- return 1;
+- }
+-
+-
+- ## List subcriber count page
+- sub do_subscriber_count {
+- &wwslog('info', 'do_subscriber_count');
+-
+- unless (&do_info()) {
+- &wwslog('info','do_subscriber_count: error while calling do_info');
+- return undef;
+- }
+-
+- print "Content-type: text/plain\n\n";
+- print $list->get_total()."\n";
+-
+- $param->{'bypass'} = 'extreme';
+-
+- return 1;
+- }
+-
+-
+- ## Subscribers' list
+- sub do_review {
+- &wwslog('info', 'do_review(%d)', $in{'page'});
+- my $record;
+- my @users;
+- my $size ;
+- my $sortby = $in{'sortby'} || 'email';
+- my %sources;
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_review', 'review'));
+-
+- if($in{'size'}){
+- $size = $in{'size'};
+- $session->{'review_page_size'} = $in{'size'} ;
+- if ($param->{'user'}{'prefs'}{'review_page_size'} ne $in{'size'}) {
+- # update user pref as soon as connected user change page size
+- $param->{'user'}{'prefs'}{'review_page_size'} = $in{'size'};
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+- }else{
+- $size = $param->{'user'}{'prefs'}{'review_page_size'} || $session->{'review_page_size'} || $wwsconf->{'review_page_size'};
+- }
+- $param->{'review_page_size'} = $size;
+-
+- unless ($param->{'total'}) {
+- &report::reject_report_web('user','no_subscriber',{},$param->{'action'},$list);
+- &wwslog('info','do_review: no subscriber');
+- # &List::db_log('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'review',$param->{'list'},$robot,'','no subscriber');
+- return 1;
+- }
+-
+- ## Owner
+- $param->{'page'} = $in{'page'} || 1;
+- $param->{'total_page'} = int ($param->{'total'} / $size);
+- $param->{'total_page'} ++
+- if ($param->{'total'} % $size);
+-
+- if ($param->{'total_page'} > 0 and ($param->{'page'} > $param->{'total_page'})) {
+- &report::reject_report_web('user','no_page',{'page' => $param->{'page'}},$param->{'action'},$list);
+- ('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'review',$param->{'list'},$robot,'','out of pages');
+- &wwslog('info','do_review: no page %d', $param->{'page'});
+- return undef;
+- }
+-
+- my $offset;
+- if ($param->{'page'} > 1) {
+- $offset = (($param->{'page'} - 1) * $size);
+- }else {
+- $offset = 0;
+- }
+-
+- ## We might not use LIMIT clause
+- my ($limit_not_used, $count);
+- unless (($list->{'admin'}{'user_data_source'} =~ /^(database|include2)$/) &&
+- ($Conf{'db_type'} =~ /^(Pg|mysql$)/)) {
+- $limit_not_used = 1;
+- }
+-
+- ## Additional DB fields
+- my @additional_fields = split ',', $Conf{'db_additional_subscriber_fields'};
+-
+- ## Members list synchronization if list has included data sources.
+- if ($list->has_include_data_sources()) {
+- if ($list->on_the_fly_sync_include('use_ttl'=>1)) {
+- &report::notice_report_web('subscribers_updated',{},$param->{'action'});
+- }else {
+- &report::reject_report_web('intern','sync_include_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }
+- }
+-
+- ## Members list
+- $count = -1;
+- for (my $i = $list->get_first_user({'sortby' => $sortby,
+- 'offset' => $offset,
+- 'rows' => $size});
+- $i; $i = $list->get_next_user()) {
+-
+- ## some review pages may be empty while viewed by subscribers
+- next if (($i->{'visibility'} eq 'conceal')
+- and (! $param->{'is_priv'}) );
+-
+- if ($limit_not_used) {
+- $count++;
+- next unless (($count >= $offset) && ($count <= $offset+$size));
+- }
+-
+- ## Add user
+- &_prepare_subscriber($i, \@additional_fields, \%sources);
+-
+- push @{$param->{'members'}}, $i;
+- }
+-
+- if ($param->{'page'} > 1) {
+- $param->{'prev_page'} = $param->{'page'} - 1;
+- }
+-
+- unless (($offset + $size) >= $param->{'total'}) {
+- $param->{'next_page'} = $param->{'page'} + 1;
+- }
+-
+- $param->{'size'} = $size;
+- $param->{'sortby'} = $sortby;
+-
+- ######################
+- if($in{'exclude'} eq '1'){
+- $param->{'exclude_opt'} = 0;
+- }else{
+- $param->{'exclude_opt'} = 1;
+- }
+- #######################
+-
+- ## additional DB fields
+- $param->{'additional_fields'} = $Conf{'db_additional_subscriber_fields'};
+- ('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'review',$param->{'list'},$robot,'','done');
+-
+- ## msg_topics
+- if ($list->is_there_msg_topic()) {
+- foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
+- if (defined $top->{'name'}) {
+- push (@{$param->{'available_topics'}},$top);
+- }
+- }
+- }
+-
+-
+- return 1;
+- }
+-
+-## Show the table of exclude
+-sub do_show_exclude {
+-
+- &wwslog('info', 'do_exclude()');
+- # Get the emails of the exclude about a list and the date of their insertion
+- my $data_exclu = &List::get_exclusion($list->{'name'});
+-
+- my $excluded;
+- my $key = 0;
+- while (($data_exclu->{emails}->[$key]) && ($data_exclu->{date}->[$key])){
+- my $email = $data_exclu->{'emails'}->[$key];
+- my $date = gettext_strftime "%d %b %Y", localtime($data_exclu->{'date'}->[$key]);
+-
+- $excluded = {'email' => $email,
+- 'since' => $date};
+- push @{$param->{'exclude_users'}}, $excluded;
+- $key = $key + 1;
+- }
+- return 1;
+-}
+-
+-## Search in subscribers and in exclude
+-sub do_search {
+- &wwslog('info', 'do_search(%s)', $in{'filter'});
+-
+- my %sources;
+-
+- ## Additional DB fields
+- my @additional_fields = split ',', $Conf{'db_additional_subscriber_fields'};
+- ## Access control
+- return undef unless (defined &check_authz('do_search', 'review'));
+- ## Regexp
+- $param->{'filter'} = $in{'filter'};
+- my $regexp = &tools::escape_regexp($param->{'filter'});
+-
+- my $sql_regexp;
+- if ($list->{'admin'}{'user_data_source'} eq 'database') {
+- $sql_regexp = $param->{'filter'};
+- $sql_regexp =~ s/\%/\\\%/g;
+- $sql_regexp =~ s/\*/\%/g;
+- #$sql_regexp = '%'.$sql_regexp.'%';
+- }
+-
+- my $record = 0;
+- ## Maximum size of selection
+- my $max_select = 50;
+-
+- ## Members list
+- for (my $i = $list->get_first_user({'sql_regexp' => $sql_regexp, 'sortby' => 'email'}); $i; $i = $list->get_next_user()) {
+-
+- ## Search filter
+- next if ($i->{'email'} !~ /$regexp/i
+- && $i->{'gecos'} !~ /$regexp/i);
+-
+- next if (($i->{'visibility'} eq 'conceal')
+- and (! $param->{'is_owner'}) );
+-
+- ## Add user
+- &_prepare_subscriber($i, \@additional_fields, \%sources);
+-
+- $record++;
+- push @{$param->{'members'}}, $i;
+- }
+-
+- my $data_exclu = &List::get_exclusion($list->{'name'});
+- my $key = 0;
+- ## Exclude users are searched too
+- while (($data_exclu->{emails}->[$key]) && ($data_exclu->{date}->[$key])){
+- my $email = $data_exclu->{'emails'}->[$key];
+- my $date = gettext_strftime "%d %b %Y", localtime($data_exclu->{'date'}->[$key]);
+- $key = $key + 1;
+-
+- ## Search filter
+- next if ($email !~ /$regexp/i);
+- next if (!$param->{'is_owner'});
+-
+- my $excluded = {'email' => $email,
+- 'since' => $date};
+-
+- push @{$param->{'exclude_users'}}, $excluded;
+- $record++;
+- }
+-
+- if ($record > $max_select) {
+- undef $param->{'members'};
+- $param->{'too_many_select'} = 1;
+- }
+-
+- $param->{'similar_subscribers'} = &List::get_ressembling_subscribers_no_object({'name'=>$list->{'name'},'domain'=>$robot,'email'=>$in{'filter'}});
+- $param->{'similar_subscribers_occurence'} =$#{$param->{'similar_subscribers'}}+1;
+-
+- $param->{'occurrence'} = $record;
+- return 1;
+-}
+-
+-## Access to user preferences
+-sub do_pref {
+- &wwslog('info', 'do_pref');
+-
+- ## Find nearest expiration period
+- my $selected = 0;
+- foreach my $p (sort {$b <=> $a} keys %wwslib::cookie_period) {
+- my $entry = {'value' => $p};
+-
+- ## Set description from NLS
+- $entry->{'desc'} = sprintf gettext($wwslib::cookie_period{$p}{'gettext_id'});
+-
+- ## Choose nearest delay
+- if ((! $selected) && $param->{'user'}{'cookie_delay'} >= $p) {
+- $entry->{'selected'} = 'selected="selected"';
+- $selected = 1;
+- }
+-
+- unshift @{$param->{'cookie_periods'}}, $entry;
+- }
+-
+- $param->{'previous_list'} = $in{'previous_list'};
+- $param->{'previous_action'} = $in{'previous_action'};
+-
+- return 1;
+- }
+-
+- ## Set the initial password
+- sub do_choosepasswd {
+- &wwslog('info', 'do_choosepasswd');
+-
+- if($session->{'auth'} eq 'ldap'){
+- &report::reject_report_web('auth','',{'login'=> $param->{'need_login'}},$param->{'action'});
+- &wwslog('notice', "do_choosepasswd : user not authorized\n");
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- }
+-
+- unless ($param->{'user'}{'email'}) {
+- unless ($in{'email'} && $in{'passwd'}) {
+- &report::reject_report_web('user','no_user',{},$param->{'action'});
+- &wwslog('info','do_pref: no user');
+- &web_db_log({'parameters' => $in{'email'},
+- 'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'no_user'});
+- $param->{'previous_action'} = 'choosepasswd';
+- return 'loginrequest';
+- }
+-
+- $in{'previous_action'} = 'choosepasswd';
+- return 'login';
+- }
+- &web_db_log({'parameters' => "$in{'email'}",
+- 'target_email' => $in{'email'} || $param->{'user'}{'email'},
+- 'status' => 'success',
+- });
+- $param->{'init_passwd'} = 1 if ($param->{'user'}{'password'} =~ /^INIT/i);
+-
+- return 1;
+- }
+-
+-####################################################
+-# do_set
+-####################################################
+-# Changes subscription parameter (reception or visibility)
+-#
+-# IN : -
+-#
+-# OUT :'loginrequest'|'info' | undef
+-
+- sub do_set {
+- &wwslog('info', 'do_set(%s, %s)', $in{'reception'}, $in{'visibility'});
+-
+- my ($reception, $visibility) = ($in{'reception'}, $in{'visibility'});
+- my $email;
+-
+- my $xml_custom_attribute;
+- if ($in{custom_attribute}){
+- return undef if ( &check_custom_attribute() != 1) ;
+- my $xml = &List::createXMLCustomAttribute($in{custom_attribute});
+-
+- $xml_custom_attribute = $xml ;
+- }
+-
+- if ($in{'email'}) {
+- unless ($param->{'is_owner'}) {
+- &report::reject_report_web('auth','action_owner',{},$param->{'action'},$list);
+- &wwslog('info','do_set: not owner');
+- &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- $email = &tools::unescape_chars($in{'email'});
+- }else {
+- unless ($param->{'user'}{'email'}) {
+- &report::reject_report_web('user','no_user',{},$param->{'action'});
+- &wwslog('info','do_set: no user');
+- &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
+- 'status' => 'error',
+- 'error_type' => 'no_user'});
+- return 'loginrequest';
+- }
+- $email = $param->{'user'}{'email'};
+- }
+-
+- unless ($list->is_user($email)) {
+- &report::reject_report_web('user','not_subscriber',{'list'=> $param->{'list'}},$param->{'action'},$list);
+- &wwslog('info','do_set: %s not subscriber of list %s', $email, $param->{'list'});
+- &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
+- 'status' => 'error',
+- 'error_type' => 'not_subscriber'});
+- return undef;
+- }
+-
+- # Verify that the mode is allowed
+- if (! $list->is_available_reception_mode($reception)) {
+- &report::reject_report_web('user','not_available_reception_mode',{'recpetion_mode'=> $reception},$param->{'action'},$list);
+- return undef;
+- }
+-
+- $reception = '' if $reception eq 'mail';
+- $visibility = '' if $visibility eq 'noconceal';
+-
+- my $update = {'reception' => $reception,
+- 'visibility' => $visibility,
+- 'update_date' => time};
+-
+- ## Lower-case new email address
+- $in{'new_email'} = lc( $in{'new_email'});
+-
+- if ($in{'new_email'} && ($in{'email'} ne $in{'new_email'})) {
+-
+- unless ($in{'new_email'} && &tools::valid_email($in{'new_email'})) {
+- &wwslog('notice', "do_set:incorrect email %s",$in{'new_email'});
+- &report::reject_report_web('user','incorrect_email',{'email' => $in{'new_email'}},$param->{'action'});
+- &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
+- 'status' => 'error',
+- 'error_type' => 'incorrect_email'});
+- return undef;
+- }
+-
+- ## Check if new email is already subscribed
+- if ($list->is_user($in{'new_email'})) {
+- &report::reject_report_web('user','already_subscriber', {'list' => $list->{'name'}},$param->{'action'},$list);
+- &wwslog('info','do_set: %s already subscriber', $in{'new_email'});
+- &web_db_log({'parameters' => $in{'new_email'},
+- 'status' => 'error',
+- 'error_type' => 'already subscriber'});
+- return undef;
+- }
+-
+- ## Duplicate entry in user_table
+- unless (&List::is_user_db($in{'new_email'})) {
+-
+- my $user_pref = &List::get_user_db($in{'email'});
+- $user_pref->{'email'} = $in{'new_email'};
+- &List::add_user_db($user_pref);
+- }
+-
+- $update->{'email'} = $in{'new_email'};
+- }
+-
+- ## message topic subscription
+- if ($list->is_there_msg_topic()) {
+- my @user_topics;
+-
+- if ($in{'no_topic'}) {
+- $update->{'topics'} = undef;
+-
+- } else {
+- foreach my $msg_topic (@{$list->{'admin'}{'msg_topic'}}) {
+- my $var_name = "topic_"."$msg_topic->{'name'}";
+- if ($in{"$var_name"}) {
+- push @user_topics, $msg_topic->{'name'};
+- }
+- }
+-
+- if ($in{"topic_other"}) {
+- push @user_topics, 'other';
+- }
+-
+- $update->{'topics'} = join(',',@user_topics);
+- }
+- }
+-
+- if ($reception =~ /^(digest|digestplain|nomail|summary)$/i) {
+- $update->{'topics'} = '';
+- }
+-
+- ## Get additional DB fields
+- foreach my $v (keys %in) {
+- if ($v =~ /^additional_field_(\w+)$/) {
+- $update->{$1} = $in{$v};
+- }
+- }
+-
+- if ($in{'gecos'}) {
+- $update->{'gecos'} = $in{'gecos'};
+- }else{
+- $update->{'gecos'} = undef;
+- }
+- $update->{'custom_attribute'} = $xml_custom_attribute if $xml_custom_attribute;
+-
+- unless ( $list->update_user($email, $update) ) {
+- &report::reject_report_web('intern','update_subscriber_db_failed',{'sub'=>$email},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info', 'do_set: set failed');
+- &web_db_log({'parameters' => "$email,$update",
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
+- 'status' => 'success',
+- });
+-
+- return $in{'previous_action'} || 'info';
+- }
+-
+-
+-## checks if each element of the custom attribute is conform to the list's
+-## definition
+-sub check_custom_attribute {
+-
+- my @custom_attributes = @{$list->{'admin'}{'custom_attribute'}} ;
+- my $isOK = 1 ;
+-
+- foreach my $ca (@custom_attributes){
+- my $value = $in{custom_attribute}{$ca->{id}}{value} ;
+- if ($ca->{optional} eq 'required' && $value eq '') {
+- &report::reject_report_web('user','missing_arg',{'argument' => "\"$ca->{name}\" is required"},$param->{'action'});
+- &wwslog('info','do_set: missing parameter');
+- &web_db_log({'parameters' => "$in{'reception'},$in{'visibility'}",
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- $isOK = undef;
+- next ;
+- }
+-
+- ## No further checking if attribute if empty
+- next if ($value =~ /^$/);
+-
+- my @values = split(/,/ , $ca->{'enum_values'}) if (defined $ca->{'enum_values'});
+-
+- ## Check that the parameter has the correct format
+- unless (($ca->{'type'} eq 'enum' && grep(/^$value$/, @values)) ||
+- ($ca->{'type'} eq 'integer' && $value =~ /^\d+$/) ||
+- ($ca->{'type'} eq 'string' && $value =~ /^.+$/) ||
+- ($ca->{'type'} eq 'text' && $value =~ /^.+$/m)
+- ) {
+- &report::reject_report_web('user','syntax_errors',{'params' => $ca->{name}},$param->{'action'});
+- &wwslog('info','do_set: syntax error');
+- &web_db_log({'parameters' => $ca->{name}, 'status' => 'error', 'error_type' => 'missing_parameter'});
+- $isOK = undef;
+- next ;
+- }
+- }
+- return $isOK ;
+-}
+-
+-
+- ## Update of user preferences
+- sub do_setpref {
+- &wwslog('info', 'do_setpref');
+- my $changes = {};
+-
+- foreach my $p ('gecos','lang','cookie_delay') {
+- $changes->{$p} = $in{$p} if (defined($in{$p}));
+- }
+-
+- ## Set session language and user language to new value
+- $session->{'lang'} = $in{'lang'} ;
+- $param->{'lang'} = $in{'lang'};
+-
+- if (&List::is_user_db($param->{'user'}{'email'})) {
+-
+- unless (&List::update_user_db($param->{'user'}{'email'}, $changes)) {
+- &report::reject_report_web('intern','update_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_pref: update failed');
+- &web_db_log({'parameters' => "$in{'gecos'},$in{'lang'},$in{'cookie_delay'}",
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }else {
+- $changes->{'email'} = $param->{'user'}{'email'};
+- unless (&List::add_user_db($changes)) {
+- &report::reject_report_web('intern','add_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_pref: add failed');
+- &web_db_log({'parameters' => "$in{'gecos'},$in{'lang'},$in{'cookie_delay'}",
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- foreach my $p ('gecos','lang','cookie_delay') {
+- $param->{'user'}{$p} = $in{$p};
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'parameters' => "$in{'gecos'},$in{'lang'},$in{'cookie_delay'}",
+- 'status' => 'success',
+- });
+- if ($in{'previous_action'}) {
+- $in{'list'} = $in{'previous_list'};
+- return $in{'previous_action'};
+- }else {
+- return 'pref';
+- }
+- }
+-
+- ## Prendre en compte les d�fauts
+- sub do_viewfile {
+- &wwslog('info', 'do_viewfile');
+-
+- unless (defined $wwslib::filenames{$in{'file'}}) {
+- &report::reject_report_web('user','file_not_editable',{'file' => $in{'file'}},$param->{'action'});
+- &wwslog('info','do_viewfile: file %s not editable', $in{'file'});
+- return undef;
+- }
+-
+- $param->{'file'} = $in{'file'};
+-
+- $param->{'filepath'} = $list->{'dir'}.'/'.$in{'file'};
+-
+- if ((-e $param->{'filepath'}) and (! -r $param->{'filepath'})) {
+- &report::reject_report_web('intern','cannot_read',{'filepath' => $param->{'filepath'}},$param->{'action'},'','',$robot);
+- &wwslog('info','do_viewfile: cannot read %s', $param->{'filepath'});
+- return undef;
+- }
+-
+- return 1;
+- }
+-
+-
+-####################################################
+-# do_subscribe
+-####################################################
+-# Subscribes a user to the list
+-#
+-# IN : -
+-#
+-# OUT :'subrequest'|'login'|'info'|$in{'previous_action'}
+-# | undef
+-####################################################
+-## TOTO: accepter nouveaux users
+-sub do_subscribe {
+- &wwslog('info', 'do_subscribe(%s)', $in{'email'});
+-
+- if (defined $param->{'user'} && $param->{'user'}{'email'}) {
+- my $xml_custom_attribute;
+-
+- if ($list->{'admin'}{'custom_attribute'} ) {
+-
+- ## This variable is set in the subrequest form
+- ## If not set, it means that the user has not been prompted to provide custom_attributes
+- unless ($in{'via_subrequest'}) {
+- &wwslog('notice', 'Returning subrequest form');
+- return "subrequest";
+- }
+-
+- if (&check_custom_attribute() != 1) {
+- &wwslog('notice', "Missing required custom attributes") ;
+- return 'subrequest';
+- }
+- my $xml = &List::createXMLCustomAttribute($in{custom_attribute});
+- $xml_custom_attribute = $xml ;
+- }
+-
+- if ($param->{'is_subscriber'}) {
+- &report::reject_report_web('user','already_subscriber', {'list' => $list->{'name'}},$param->{'action'},$list);
+- &wwslog('info','do_subscribe: %s already subscriber', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'already_subscriber'});
+- return undef;
+- }
+- my $result = $list->check_list_authz('subscribe',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $sub_is;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $sub_is = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+- if ($sub_is =~ /reject/) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- &wwslog('info', 'do_subscribe: subscribe closed');
+- &web_db_log({'parameters' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- $param->{'may_subscribe'} = 1;
+-
+- if ($sub_is =~ /owner/) {
+-
+- unless ($list->send_notify_to_owner('subrequest',{'who' => $param->{'user'}{'email'},
+- 'keyauth' => $list->compute_auth($param->{'user'}{'email'}, 'add'),
+- 'replyto' => &Conf::get_robot_conf($robot, 'sympa'),
+- 'custom_attribute' => $in{custom_attribute},
+- 'gecos' => $param->{'user'}{'gecos'},
+- 'ip'=>$ip})) {
+- &wwslog('notice',"Unable to send notify 'subrequest' to $list->{'name'} listowner");
+- }
+-
+- $list->store_subscription_request($param->{'user'}{'email'}, "", $xml_custom_attribute);
+- &report::notice_report_web('sent_to_owner',{},$param->{'action'});
+- &wwslog('info', 'do_subscribe: subscribe sent to owners');
+-
+- return 'info';
+- }elsif ($sub_is =~ /do_it/) {
+- if ($param->{'is_subscriber'}) {
+- unless ($list->update_user($param->{'user'}{'email'},
+- {'subscribed' => 1,
+- 'update_date' => time})) {
+- &report::reject_report_web('intern','update_subscriber_db_failed',{'sub'=>$param->{'user'}{'email'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info', 'do_subscribe: update failed');
+- &web_db_log({'parameters' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }else {
+- my $defaults = $list->get_default_user_options();
+- my $u;
+- %{$u} = %{$defaults};
+- $u->{'email'} = $param->{'user'}{'email'};
+- $u->{'gecos'} = $param->{'user'}{'gecos'} || $in{'gecos'};
+- $u->{'date'} = $u->{'update_date'} = time;
+- $u->{'password'} = $param->{'user'}{'password'};
+- $u->{'custom_attribute'} = $xml_custom_attribute if (defined $xml_custom_attribute);
+- $u->{'lang'} = $param->{'user'}{'lang'} || $param->{'lang'};
+-
+- unless ($list->add_user($u)) {
+- &report::reject_report_web('intern','add_subscriber_db_failed',{'sub'=>$param->{'user'}{'email'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info', 'do_subscribe: subscribe failed');
+- &web_db_log({'parameters' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- unless ($sub_is =~ /quiet/i ) {
+- unless ($list->send_file('welcome', $param->{'user'}{'email'}, $robot,{})) {
+- &wwslog('notice',"Unable to send template 'welcome' to $param->{'user'}{'email'}");
+- }
+- }
+-
+- if ($sub_is =~ /notify/) {
+- unless ($list->send_notify_to_owner('notice',{'who' => $param->{'user'}{'email'},
+- 'gecos' => $param->{'user'}{'gecos'},
+- 'command' => 'subscribe'})) {
+- &wwslog('notice','Unable to send notify "notice" to listmaster');
+- }
+- }
+-
+- }
+- }else{ # user is not autenticated
+-
+- if ($in{'email'} && $in{'passwd'}) {
+- $in{'previous_action'} = 'subscribe';
+- $in{'previous_list'} = $param->{'list'};
+- return 'login';
+- }else{
+- return 'subrequest';
+- }
+- }
+- ## perform which to update your_subscriptions cookie ;
+- @{$param->{'get_which'}} = &List::get_which($param->{'user'}{'email'},$robot,'member') ;
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'email'},'status' => 'success'});
+-
+- if ($in{'previous_action'}) {
+- return $in{'previous_action'};
+- }
+-
+-# return 'suboptions';
+- return 'info';
+-}
+-
+-
+-####################################################
+-# do_multiple_subscribe
+-####################################################
+-# Subscribes a user to each lists
+-#
+-# IN : lists a array of lists
+-#
+-# OUT :'subrequest'|'login'|'info'|$in{'previous_action'}
+-# | undef
+-####################################################
+-sub do_multiple_subscribe {
+- &wwslog('info', 'do_multiple_subscribe(%s)', $in{'email'});
+-
+- ## Not authenticated
+- unless (defined $param->{'user'} && $param->{'user'}{'email'}) {
+- ## no email
+- unless ($in{'email'}) {
+- return 'lists';
+- }
+- }
+-
+- my @lists = split /\0/, $in{'lists'};
+- my $total;
+- my %results ;
+-
+-
+- foreach my $requested_list (@lists) {
+- my $param->{'list'} = new List ($requested_list, $robot);
+- $results{'requested_list'} = &do_subscribe();
+- }
+-}
+-
+-## Subscription request (user not authenticated)
+-sub do_suboptions {
+- &wwslog('info', 'do_suboptions()');
+-
+- unless($param->{'is_subscriber'} ) {
+- &report::reject_report_web('user','not_subscriber',{'list'=> $list->{'name'}},$param->{'action'},$list);
+- &wwslog('info','do_suboptions: %s not subscribed to %s',$param->{'user'}{'email'}, $param->{'list'} );
+- return undef;
+- }
+-
+- my ($s, $m);
+-
+- unless($s = $list->get_subscriber($param->{'user'}{'email'})) {
+- &report::reject_report_web('intern','subscriber_not_found',{'email' => $param->{'user'}{'email'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info', 'do_sub_options: subscriber %s not found', $param->{'user'}{'email'});
+- return undef;
+- }
+-
+- $s->{'reception'} ||= 'mail';
+- $s->{'visibility'} ||= 'noconceal';
+- $s->{'date'} = gettext_strftime "%d %b %Y", localtime($s->{'date'});
+- $s->{'update_date'} = gettext_strftime "%d %b %Y", localtime($s->{'update_date'});
+-
+- foreach $m (keys %wwslib::reception_mode) {
+- if ($list->is_available_reception_mode($m)) {
+- $param->{'reception'}{$m}{'description'} = sprintf(gettext($wwslib::reception_mode{$m}->{'gettext_id'}));
+- if ($s->{'reception'} eq $m) {
+- $param->{'reception'}{$m}{'selected'} = 'selected="selected"';
+- if ($m =~ /^(mail|notice|not_me|txt|html|urlize)$/i) {
+- $param->{'possible_topic'} = 1;
+- }
+- }else {
+- $param->{'reception'}{$m}{'selected'} = '';
+- }
+- }
+- }
+-
+- foreach $m (keys %wwslib::visibility_mode) {
+- $param->{'visibility'}{$m}{'description'} = sprintf(gettext($wwslib::visibility_mode{$m}->{'gettext_id'}));
+- if ($s->{'visibility'} eq $m) {
+- $param->{'visibility'}{$m}{'selected'} = 'selected="selected"';
+- }else {
+- $param->{'visibility'}{$m}{'selected'} = '';
+- }
+- }
+-
+- $param->{'subscriber'} = $s;
+-
+-
+- #msg_topic
+- $param->{'sub_user_topic'} = 0;
+- foreach my $user_topic (split (/,/,$s->{'topics'})) {
+- $param->{'topic_checked'}{$user_topic} = 1;
+- $param->{'sub_user_topic'}++;
+- }
+-
+- if ($list->is_there_msg_topic()) {
+- foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
+- if (defined $top->{'name'}) {
+- push (@{$param->{'available_topics'}},$top);
+- }
+- }
+- }
+-
+- return 1;
+-}
+-
+-## Subscription request (user not authenticated)
+-sub do_subrequest {
+- &wwslog('info', 'do_subrequest(%s,%s)', $in{'email'},$in{'custom_attribute'});
+-
+- if (defined $in{'custom_attribute'}) {
+- $param->{'custom_attribute'} = $in{'custom_attribute'};
+- }
+-
+- ## Auth ?
+- if ($param->{'user'}{'email'}) {
+- ## Subscriber ?
+- if ($param->{'is_subscriber'}) {
+- &report::reject_report_web('user','already_subscriber', {'list' => $list->{'name'}},$param->{'action'},$list);
+- &wwslog('info','%s already subscriber', $param->{'user'}{'email'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'already_subscriber'});
+- return undef;
+- }
+- $param->{'status'} = 'auth';
+- }else {
+- ## Provided email parameter ?
+- unless ($in{'email'}) {
+- $param->{'status'} = 'notauth_noemail';
+- return 1;
+- }
+- ## Subscriber ?
+- if ($list->is_user($in{'email'})) {
+- $param->{'status'} = 'notauth_subscriber';
+- return 1;
+- }
+- my $user;
+- $user = &List::get_user_db($in{'email'})
+- if &List::is_user_db($in{'email'});
+-
+- ## Need to send a password by email
+- $param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'email'},$robot,'subscribe/'.$list->{'name'},$ip);
+- $param->{'login_error'}='ticket_sent';
+- $param->{'request_from_host'} = $ip;
+- $param->{'newuser'} = &List::get_user_db($in{'email'});
+- unless (&List::send_global_file('sendpasswd', $in{'email'}, $robot, $param)) {
+- &wwslog('notice',"Unable to send template 'sendpasswd' to $in{'email'}");
+- $param->{'login_error'}='unable_to_send_ticket';
+- }
+- # &do_requestpasswd();
+- $param->{'status'} = 'notauth_passwordsent';
+-
+- return 1;
+- }
+-
+- return 1;
+-}
+-sub do_auto_signoff {
+- &wwslog('info', 'do_signoff');
+- ## If the URL isn't valid, then go to home page. No need to guide the user: this function is supposed to be used by clicking on autocreated URL only.
+- return 'home' unless $in{'email'};
+-
+- ## If unsubscribe is forbidden, reject the request. Other
+-
+- my $result = $list->check_list_authz('unsubscribe',$param->{'auth_method'},
+- {'sender' => $in{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $sig_is;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $sig_is = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- if ($sig_is =~ /reject/) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- &wwslog('info', 'do_signoff: %s may not signoff from %s'
+- , $in{'email'}, $param->{'list'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- ## Send the confirmation email to the user.
+-
+- if ($list->is_user($in{'email'})) {
+-
+- my $ticket = &Auth::create_one_time_ticket($in{'email'},$robot,'signoff/'.$list->{'name'},$ip);
+-
+- my $tt2_param = {
+- 'list' => $list,
+- 'type' => 'ticket_to_signoff',
+- 'one_time_ticket' => $ticket,
+- 'email' => $in{'email'},
+- 'context' => 'auto_signoff',
+- 'ip' => $ip,
+- };
+- unless (&List::send_global_file('user_notification', $in{'email'}, $robot, $tt2_param)) {
+- &do_log('notice',"Unable to send template 'user_notification' to $in{'email'}");
+- return undef;
+- }
+- }else{
+- return 'home';
+- }
+- $param->{'signing_off_email'} = $in {'email'};
+- ## If OK, return the page displaying the informations to the user.
+- return 1;
+-
+-}
+-####################################################
+-# do_signoff
+-####################################################
+-# Unsubcribes a user from a list
+-#
+-# IN : -
+-#
+-# OUT : 'sigrequest' | 'login' | 'info'
+-#
+-####################################################
+- ## Unsubscribe from list
+- sub do_signoff {
+- &wwslog('info', 'do_signoff');
+-
+- my $authenticated_email_address = $param->{'user'}{'email'};
+-
+- unless ($authenticated_email_address) {
+- unless ($in{'email'}) {
+- return 'sigrequest';
+- }
+-
+- if ($in{'fingerprint'}) {
+-
+- unless(&tools::get_fingerprint($in{'email'}, $in{'fingerprint'})){
+- &report::reject_report_web('user','cannot_do_signoff');
+- &wwslog('err','do_signoff: failed to unsubscribe user %s', $in{'email'});
+- return undef;
+- }
+-
+- ## We don't set $param->{'user'}{'email'} because we don't want the user to be authenticated
+- ## to prevent the cookie from being set
+- $authenticated_email_address = $in{'email'};
+-
+- }else {
+-
+- ## Perform login first
+- if ($in{'passwd'}) {
+- $in{'previous_action'} = 'signoff';
+- $in{'previous_list'} = $param->{'list'};
+- return 'login';
+- }
+-
+- if ( &List::is_user_db($in{'email'}) ) {
+- &report::reject_report_web('user','no_user',{},$param->{'action'});
+- &wwslog('info','do_signoff: need auth for user %s', $in{'email'});
+- &web_db_log({'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'authentication'});
+- return undef;
+- }
+-
+- ## No passwd
+- &init_passwd($in{'email'}, {'lang' => $param->{'lang'} });
+-
+- $param->{'user'}{'email'} = $in{'email'};
+- $authenticated_email_address = $in{'email'};
+- }
+- }
+-
+- my %result = &unsubscribe($authenticated_email_address, $list);
+- if ($result{'success'} == 1) {
+- &report::notice_report_web($result{'details'},{},$param->{'action'});
+- $param->{'is_subscriber'} = 0;
+- $param->{'may_signoff'} = 0;
+- }else{
+- &report::reject_report_web($result{'category_error'},$result{'reason_error'},{%{$result{'reason_error'}},'list'=>$list->{'name'}},$param->{'action'},$list);
+- }
+- return 'home';
+- }
+-
+-## Unsubscribe current user from a list.
+-sub unsubscribe {
+- my $authenticated_email_address = shift;
+- my $list = shift;
+- my %report = ('success',1,'details','');
+-
+- unless ($list->is_user($authenticated_email_address)) {
+- &wwslog('info','do_signoff: %s not subscribed to %s',$authenticated_email_address, $param->{'list'} );
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'not_subscriber'});
+- $report{'success'} = 0;
+- $report{'category_error'} = 'user';
+- $report{'reason_error'} = 'not_subscribed';
+- $report{'details_error'} = {};
+- return %report;
+- }
+-
+- my $result = $list->check_list_authz('unsubscribe',$param->{'auth_method'},
+- {'sender' => $authenticated_email_address,
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $sig_is;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $sig_is = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- $param->{'may_signoff'} = 1 if ($sig_is =~ /do_it|owner/);
+-
+- if ($sig_is =~ /reject/) {
+- &wwslog('info', 'do_signoff: %s may not signoff from %s'
+- , $authenticated_email_address, $param->{'list'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'authorization'});
+- $report{'success'} = 0;
+- $report{'category_error'} = 'auth';
+- $report{'reason_error'} = $reason;
+- $report{'details_error'} = {};
+- return %report;
+- }elsif ($sig_is =~ /owner/) {
+- unless ($list->send_notify_to_owner('sigrequest',{'who' => $authenticated_email_address,
+- 'keyauth' => $list->compute_auth($authenticated_email_address, 'del')})) {
+- &wwslog('notice',"Unable to send notify 'sigrequest' to $list->{'name'} list owner");
+- }
+- &wwslog('info', 'do_signoff: signoff sent to owner');
+- $report{'success'} = 1;
+- $report{'details'} = 'sent_to_owner';
+- return %report;
+- }else {
+- unless ($list->delete_user('users' => [$authenticated_email_address], 'exclude' =>' 1')) {
+- &wwslog('info', 'do_signoff: signoff failed');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- $report{'success'} = 0;
+- $report{'category_error'} = 'intern';
+- $report{'reason_error'} = 'delete_subscriber_db_failed';
+- $report{'details_error'} = {'sub'=>$authenticated_email_address};
+- return %report;
+- }
+-
+- if ($sig_is =~ /notify/) {
+- unless ($list->send_notify_to_owner('notice',{'who' => $authenticated_email_address,
+- 'gecos' => '',
+- 'command' => 'signoff'})) {
+- &wwslog('notice',"Unable to send notify 'notice' to $list->{'name'} list owner");
+- }
+- }
+-
+- ## perform which to update your_subscribtions cookie ;
+- @{$param->{'get_which'}} = &List::get_which($authenticated_email_address,$robot,'member') ;
+-
+- unless ($list->send_file('bye', $authenticated_email_address, $robot, {})) {
+- &wwslog('notice',"Unable to send template 'bye' to $authenticated_email_address");
+- }
+- }
+- &web_db_log({'status' => 'success'});
+- $report{'success'} = 1;
+- $report{'details'} = 'performed';
+- return %report;
+-}
+-
+- ## Unsubscription request (user not authenticated)
+- sub do_sigrequest {
+- &wwslog('info', 'do_sigrequest(%s)', $in{'email'});
+-
+- ## If user is authenticated then redirect him to the signoff action but
+- ## get a confirmation (via the sigrequest web page) first
+- if ($param->{'user'}{'email'}) {
+- return 1;
+- }
+-
+- ## Not auth & no email => return the sigrequest web form to get the user email
+- unless ($in{'email'}) {
+- return 1;
+- }
+-
+-
+- if ($list->is_user($in{'email'})) {
+-
+- my $ticket = &Auth::create_one_time_ticket($in{'email'},$robot,'signoff/'.$list->{'name'},$ip);
+-
+- my $tt2_param = {'type' => 'ticket_to_signoff',
+- 'list' => $list,
+- 'one_time_ticket' => $ticket,
+- 'email' => $in{'email'}};
+- unless (&List::send_global_file('user_notification', $in{'email'}, $robot, $tt2_param)) {
+- &do_log('notice',"Unable to send template 'user_notification' to $in{'email'}");
+- return undef;
+- }
+-
+- }else {
+- $param->{'not_subscriber'} = 1;
+- }
+-
+- $param->{'email'} = $in{'email'};
+-
+- return 1;
+- }
+-
+-
+- ## Update of password
+- sub do_setpasswd {
+- &wwslog('info', 'do_setpasswd');
+- my $user;
+-
+- if ($in{'newpasswd1'} =~ /^\s+$/ ) {
+- &report::reject_report_web('user','no_passwd',{},$param->{'action'});
+- &wwslog('info','do_setpasswd: no newpasswd1');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return undef;
+- }
+-
+- unless ($in{'newpasswd1'} eq $in{'newpasswd2'}) {
+- &report::reject_report_web('user','diff_passwd',{},$param->{'action'});
+- &wwslog('info','do_setpasswd: different newpasswds');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'bad_parameter'});
+- return undef;
+- }
+-
+- if (&List::is_user_db($param->{'user'}{'email'})) {
+-
+- unless ( &List::update_user_db($param->{'user'}{'email'}, {'password' => $in{'newpasswd1'},'wrong_login_count' => 0} )) {
+- &report::reject_report_web('intern','update_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_setpasswd: update failed');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }else {
+-
+- unless ( &List::add_user_db({'email' => $param->{'user'}{'email'},
+- 'password' => $in{'newpasswd1'},
+- 'wrong_login_count' => 0} )) {
+- &report::reject_report_web('intern','add_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_setpasswd: update failed');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- $param->{'user'}{'password'} = $in{'newpasswd1'};
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+-
+- if ($in{'previous_action'}) {
+- $in{'list'} = $in{'previous_list'};
+- return $in{'previous_action'};
+- }else {
+- return 'pref';
+- }
+- }
+-
+- ## List admin page
+- sub do_admin {
+- &wwslog('info', 'do_admin');
+-
+- ## Messages edition
+- foreach my $f ('info','homepage','welcome.tt2','bye.tt2','removed.tt2','message.footer','message.header','remind.tt2','invite.tt2','reject.tt2') {
+- next unless ($list->may_edit($f, $param->{'user'}{'email'}) eq 'write');
+- if ($wwslib::filenames{$f}{'gettext_id'}) {
+- $param->{'files'}{$f}{'complete'} = gettext($wwslib::filenames{$f}{'gettext_id'});
+- }else {
+- $param->{'files'}{$f}{'complete'} = $f;
+- }
+- $param->{'files'}{$f}{'selected'} = '';
+- }
+- $param->{'files'}{'info'}{'selected'} = 'selected="selected"';
+-
+- # my %mode;
+- # $mode{'edit'} = 1;
+- # my %access = &d_access_control(\%mode,$path);
+-
+- return 1;
+- }
+-
+- ## Server admin page
+- sub do_serveradmin {
+- &wwslog('info', 'do_serveradmin');
+-
+- my $f;
+-
+- ## Lists Default files
+- foreach my $f ('welcome.tt2','bye.tt2','removed.tt2','message.footer','message.header','remind.tt2','invite.tt2','reject.tt2','your_infected_msg.tt2') {
+- if ($wwslib::filenames{$f}{'gettext_id'}){
+- $param->{'lists_default_files'}{$f}{'complete'} = gettext($wwslib::filenames{$f}{'gettext_id'});
+- }else {
+- $param->{'lists_default_files'}{$f}{'complete'} = $f;
+- }
+- $param->{'lists_default_files'}{$f}{'selected'} = '';
+- }
+-
+- ## Checking families and other virtual hosts.
+- &get_server_details();
+-
+- ## Server files
+- foreach my $f ('helpfile.tt2','lists.tt2','global_remind.tt2','summary.tt2','create_list_request.tt2','list_created.tt2','list_aliases.tt2') {
+- $param->{'server_files'}{$f}{'complete'} = gettext($wwslib::filenames{$f}{'gettext_id'});
+- $param->{'server_files'}{$f}{'selected'} = '';
+- }
+- $param->{'server_files'}{'helpfile.tt2'}{'selected'} = 'selected="selected"';
+- $param->{'log_level'} = $session->{'log_level'} ;
+- $param->{'subaction'} = $in{'subaction'} ;
+- return 1;
+- }
+-
+-sub do_edit_config {
+-
+- my @editable_params = @confdef::params ;
+-
+- &get_server_details;
+-
+- unless ($param->{'main_robot'}) {
+- &report::reject_report_web('auth','super lismaster feature only','{}',$param->{'action'});
+- &wwslog('info','check_authz: access denied in edit_config for %s because not super listmaster', $param->{'user'}{'email'});
+- }
+-
+- for my $i ( 0 .. $#editable_params ) {
+- if ($editable_params[$i]->{'name'}) {
+- $editable_params[$i]->{'current_value'} = &Conf::get_robot_conf($robot, $editable_params[$i]->{'name'});
+- $editable_params[$i]->{'current_value'} = join( ",", @{$editable_params[$i]->{'current_value'}}) if (ref($editable_params[$i]->{'current_value'}) eq 'ARRAY');
+- }
+- }
+-
+- if ($in{'conf_new_value'}) {
+- my $editable; my $i;
+- for $i ( 0 .. $#editable_params ) {
+- # if the parameter is editable and if the is a change
+- next unless ($editable_params[$i]->{'name'} eq $in{'conf_parameter_name'});
+- if ($editable_params[$i]->{'edit'} ne '1'){
+- do_log ('err','Ignoring change of parameter %s (value %s) because not editable', $in{'conf_parameter_name'}, $in{'conf_new_value'});
+- last;
+- }
+- if ($in{'conf_new_value'} eq $editable_params[$i]->{'current_value'} ){
+- do_log ('notice','Ignoring change of parameter %s (value %s) because inchanged', $in{'conf_parameter_name'}, $in{'conf_new_value'});
+- last;
+- }else{
+- $editable_params[$i]->{'current_value'} = $in{'conf_new_value'};
+- &Conf::set_robot_conf($robot, $in{'conf_parameter_name'}, $in{'conf_new_value'});
+- do_log ('notice','setting parameter %s to value %s', $in{'conf_parameter_name'}, $in{'conf_new_value'});
+- last;
+- }
+- }
+- }
+-
+- $param->{'editable_params'} = \@editable_params ;
+- return 1;
+-
+-}
+-
+-## Change log_level for the current session
+-sub do_set_loglevel {
+- &wwslog('info', 'do_set_loglevel');
+-
+- $session->{'log_level'} = $in{'log_level'};
+- return 'serveradmin';
+-}
+-
+-## activate dump var feature
+-sub do_set_dumpvars {
+- &wwslog('info', 'do_set_dumpvars');
+-
+- $session->{'dumpvars'} = 'true' ;
+- $param->{'dumpavars'} = $session->{'dumpvars'} ;
+- $param->{'redirect_to'} = $param->{'base_url'}.$param->{'path_cgi'}.'/serveradmin';
+- return '1';
+-}
+-## un-activate dump var feature
+-sub do_unset_dumpvars {
+- &wwslog('info', 'do_unset_dumpvars');
+-
+- $session->{'dumpvars'} = '' ;
+- $param->{'dumpavars'} = '';
+- $param->{'redirect_to'} = $param->{'base_url'}.$param->{'path_cgi'}.'/serveradmin';
+- return '1';
+-}
+-## un-activate dump var feature
+-sub do_show_sessions {
+- &wwslog('info', 'do_show_sessions');
+-
+- $in{'session_delay'} = 10 unless ($in{'session_delay'});
+- my $delay = 60 * $in{'session_delay'};
+- $param->{'sessions'} = &SympaSession::list_sessions($delay,$robot,$in{'connected_only'});
+- return '1';
+-}
+-
+-
+-## Change user email
+-sub do_set_session_email {
+- &wwslog('info', 'do_set_session_email');
+-
+- my $email_regexp = &tools::get_regexp('email');
+- unless ($in{'email'} =~ /^\s*$email_regexp\s*$/){
+- &report::reject_report_web('user','Invalid email provided.',{},$param->{'action'},$list);
+- return 'serveradmin';
+- };
+- if ($session){
+- $session->{'restore_email'} = $param->{'user'}{'email'};
+- $session->{'email'} = $in{'email'};
+- $param->{'redirect_to'} = $param->{'base_url'}.$param->{'path_cgi'};
+- return '1';
+- }else{
+- &report::reject_report_web('user','No active session',{},$param->{'action'},$list);
+- return 'serveradmin';
+- }
+-}
+-
+-## Change user email
+-sub do_restore_email {
+- &wwslog('info', 'do_restore_email');
+- &wwslog('debug2', 'do_restore_email from %s to %s',$session->{'email'},$session->{'restore_email'} );
+-
+- if ($param->{'restore_email'}){
+- $session->{'email'} = $session->{'restore_email'} ;
+- $param->{'restore_email'}= $session->{'restore_email'} = '' ;
+- $param->{'redirect_to'} = $param->{'base_url'}.$param->{'path_cgi'};
+- }else{
+- &wwslog('info','do_restore_email from %s no restore_email attached to current session', $param->{'user'}{'email'});
+- &report::reject_report_web('user','wrong_param',{},$param->{'action'},$list);
+- }
+- return 'home';
+-}
+-
+-## list available templates
+-sub do_ls_templates {
+- &wwslog('info', 'do_ls_templates');
+-
+- $in{'webormail'} ||= 'web';
+-
+- if (defined $list) {
+- $param->{'templates'} = &tools::get_templates_list($in{'webormail'},$robot,$list);
+- }else{
+- $param->{'templates'} = &tools::get_templates_list($in{'webormail'},$robot, undef);
+- }
+-
+- ## List of lang per type
+- foreach my $level ('site','robot','list') {
+- $param->{'lang_per_level'}{$level}{'default'} = 1;
+- }
+-
+- foreach my $file (keys %{$param->{'templates'}}) {
+- foreach my $level (keys %{$param->{'templates'}{$file}}) {
+- foreach my $lang (keys %{$param->{'templates'}{$file}{$level}}) {
+- $param->{'lang_per_level'}{$level}{$lang} = 1;
+- }
+- }
+- }
+-
+-
+- ## Colspan per level
+- foreach my $level (keys %{$param->{'lang_per_level'}}) {
+- foreach my $lang (keys %{$param->{'lang_per_level'}{$level}}) {
+- $param->{'colspan_per_level'}{$level}++;
+- foreach my $file (keys %{$param->{'templates'}}) {
+- $param->{'templates'}{$file}{$level}{$lang} ||= '';
+- }
+- }
+- }
+-
+- $param->{'webormail'} = $in{'webormail'};
+-
+- return 1;
+-}
+-
+-# show a template, used by copy_template and edit_emplate
+-sub do_remove_template {
+-
+- &wwslog('info', 'do_remove_template');
+-
+- my $template_path ;
+-
+- if ($in{'scope'} eq 'list') {
+- $template_path = &tools::get_template_path($in{'webormail'},$robot,'list',$in{'template_name'},$in{'tpl_lang'},$list);
+- }else{
+- $template_path = &tools::get_template_path($in{'webormail'},$robot,$in{'scope'},$in{'template_name'},$in{'tpl_lang'});
+- }
+-
+- my $template_old_path = &tools::shift_file($template_path,10);
+- unless ($template_old_path) {
+- &report::reject_report_web('intern','remove_failed',{'path'=>$template_path},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"remove_template: could not remove $template_path");
+- &web_db_log({'parameters' => $in{'webormail'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &report::notice_report_web('file_renamed',{'orig_file'=>$template_path,'new_file'=>$template_old_path}, $param->{'action'});
+- &web_db_log({'parameters' => $in{'webormail'},
+- 'status' => 'status'});
+- $param->{'webormail'} = $in{'webormail'};
+- $param->{'scope'} = $in{'scope'};
+- $param->{'template_name'} = $in{'template_name'};
+- $param->{'tpl_lang'} = $in{'tpl_lang'};
+-
+- return 'ls_templates';
+-}
+-
+-# show a template, used by copy_template and edit_emplate
+-sub do_view_template {
+-
+- &wwslog('info', "do_view_template(type=$in{'webormail'},template-name=$in{'template_name'},listname=$in{'list'},path=$in{'template_path'},scope=$in{'scope'},lang=$in{'tpl_lang'})");
+-
+- my $template_path ;
+-
+- if ($in{'scope'} eq 'list') {
+- $template_path = &tools::get_template_path($in{'webormail'},$robot,'list',$in{'template_name'},$in{'tpl_lang'},$list);
+- }else{
+- $template_path = &tools::get_template_path($in{'webormail'},$robot,$in{'scope'},$in{'template_name'},$in{'tpl_lang'});
+- }
+-
+- unless (open (TPL,$template_path)) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $in{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"view_template: can't open file %s",$template_path);
+- return undef;
+- }
+-
+- $param->{'rows'} = 5; # minimum size of 5 rows;
+- $param->{'template_content'} = ''; # init content
+- while(<TPL>) {$param->{'template_content'}.= $_; $param->{'rows'}++;}
+- $param->{'template_content'} = &tools::escape_html($param->{'template_content'});
+- close TPL;
+-
+-
+- $param->{'webormail'} = $in{'webormail'};
+- $param->{'template_name'} = $in{'template_name'};
+- $param->{'template_path'} = $template_path;
+- $param->{'scope'} = $in{'scope'};
+- $param->{'tpl_lang'} = $in{'tpl_lang'};
+-
+- return 1;
+-}
+-
+-## template copy
+-sub do_copy_template {
+- &wwslog('info', 'do_copy_template');
+-
+-
+- ## Load original template
+- &do_view_template();
+-
+- ## Return form
+- unless ($in{'scope_out'}) {
+- return 1;
+- }
+-
+-# one of theses parameters is commint from the form submission
+- if ($in{'scope_out'} eq 'list') {
+- if ($in{'list_out'}) {
+- my $list_out;
+- unless ($list_out = new List $in{'list_out'}, $robot) {
+- &report::reject_report_web('user','unknown_list',{'list' => $in{'list_out'}},$param->{'action'},'');
+- &wwslog('info','do_copy_template: unknown list %s', $in{'list_out'});
+- &web_db_log({'parameters' => $in{'list_out'},
+- 'status' => 'error',
+- 'error_type' => 'unknown_list'});
+- return undef;
+- }
+-
+- $param->{'template_path_out'} = &tools::get_template_path($in{'webormail'},$robot,$in{'scope_out'},$in{'template_name_out'},$in{'tpl_lang_out'},$list_out);
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
+- &wwslog('err','do_copy_template: missing parameter webormail');
+- &web_db_log({'parameters' => $in{'webormail'},
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return 1;
+- }
+- }else{
+- $param->{'template_path_out'} = &tools::get_template_path($in{'webormail'},$robot,$in{'scope_out'},$in{'template_name_out'},$in{'tpl_lang_out'});
+- }
+-
+- unless (&tools::mk_parent_dir($param->{'template_path_out'})) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path_out'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't create parent directory for %s : %s", $param->{'template_path_out'}, $!);
+- &web_db_log({'parameters' => $param->{'template_name_out'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- unless (open (TPLOUT,'>'.$param->{'template_path_out'})) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path_out'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't open file %s : %s", $param->{'template_path_out'}, $!);
+- &web_db_log({'parameters' => $param->{'template_name_out'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- print TPLOUT &tools::unescape_html($param->{'template_content'});
+- close TPLOUT;
+-
+- if ($in{'list_out'}) {$param->{'list'} = $in{'list'} = $in{'list_out'} ;}
+-
+- $param->{'webormail'} = $in{'webormail'};
+- $param->{'tpl_lang'} = $in{'tpl_lang'} = $in{'tpl_lang_out'};
+- $param->{'scope'} = $in{'scope'} = $in{'scope_out'} ;
+- $param->{'template_path'} = $in{'template_path'} = $param->{'template_path_out'};
+- $param->{'template_name'} = $in{'template_name'} = $in{'template_name_out'};
+- &web_db_log({'parameters' => $param->{'template_name_out'},
+- 'status' => 'success'});
+- return ('edit_template');
+-}
+-
+-
+-## manage the rejection templates
+-sub do_manage_template {
+- &wwslog('info', '(%s,%s)', $in{'subaction'}, $in{'message_template'});
+-
+- my $file;
+-
+- $in{'message_template'} =~ s/^reject_//;
+-
+- if ($in{'message_template'}) {
+- my $escaped_template_path = $in{'message_template'};
+- $escaped_template_path =~ s/\s/_/g ;
+- $param->{'template_path'} = &tools::get_template_path('mail',$robot,'list', ,'reject_'.$escaped_template_path.'.tt2','',$list);
+- }
+- my $tt2_include_path = &tools::make_tt2_include_path($robot,'mail_tt2','',$list);
+- my $default_file = &tools::find_file('reject.tt2',@{$tt2_include_path});
+-
+-
+- if ($in{'subaction'} eq 'save') {
+- ## create the parent directory if it doesn't already exist
+- unless (&tools::mk_parent_dir($param->{'template_path'})) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't create parent directory for %s : %s", $param->{'template_path'}, $!);
+- &web_db_log({'parameters' => $param->{'template_name'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- ## open the template
+- unless (open (TPLOUT ,'>' ,$param->{'template_path'})) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't open file %s : %s", $param->{'template_path'}, $!);
+- &web_db_log({'parameters' => $in{'template_name'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- ## save template contents
+- print TPLOUT $in{'template_content'};
+- close TPLOUT;
+- &report::notice_report_web('performed',{},$in{'subaction'});
+-
+- }elsif($in{'subaction'} eq 'create_new') {
+-
+- $in{'template_new'} = $in{'new_template_name'} ;
+-
+- unless ($in{'new_template_name'}) {
+- &report::reject_report_web('user','missing template name',{'path' => ''},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- return undef;
+- }
+- my $escaped_template_path = $in{'new_template_name'};$escaped_template_path =~ s/\s/_/g ;
+- my $new_template_path = &tools::get_template_path('mail',$robot,'list', ,'reject_'.$escaped_template_path.'.tt2','',$list);
+-
+- if (-f $new_template_path) {
+- &report::reject_report_web('intern','template already exist',{'path' => $new_template_path},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- return undef;
+- }
+- ## create the parent directory if it doesn't already exist
+- unless (&tools::mk_parent_dir($new_template_path)) {
+-
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't create parent directory for %s : %s", $param->{'template_path'}, $!);
+- &web_db_log({'parameters' => $param->{'template_name'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- my $default_file = &tools::get_template_path('mail',$robot,'robot', ,'reject.tt2','',$list);
+- $default_file = &tools::get_template_path('mail',$robot,'site', ,'reject.tt2','',$list) unless (-f $default_file);
+- $default_file = &tools::get_template_path('mail',$robot,'distrib', ,'reject.tt2','',$list)unless (-f $default_file);
+-
+- unless(open (DEFAULT, $default_file)){
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $default_file},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't open file %s : %s", $default_file, $!);
+- return undef;
+- }
+-
+- unless(open (TPL, '> '.$new_template_path)){
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $new_template_path},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't open file %s : %s", $new_template_path, $!);
+- return undef;
+- }
+-
+- while (<DEFAULT>){
+- print TPL $_;
+- }
+- close DEFAULT;
+- close TPL;
+- $in{'subaction'}='modify';
+- $in{'message_template'} = $in{'new_template_name'};
+- return 'manage_template';
+-
+- }elsif ($in{'subaction'} eq 'modify') {
+-
+- unless(open (FILE, $param->{'template_path'})){
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"can't open file MODIFY %s : %s", $param->{'template_path'}, $!);
+- &web_db_log({'parameters' => $param->{'template_path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- while (<FILE>){
+- $param->{'content'} .= $_;
+- }
+- $param->{'content'} = &tools::escape_html($param->{'content'});
+- close FILE;
+- $param->{'message_template'} = $in{'message_template'};
+-
+- }elsif($in{'subaction'} eq 'setdefault') {
+- # replace existing reject.tt2 file by a symlink to reject_default.tt2 for compatibility with version older than 6.0
+- my $base = $list->{'dir'}.'/mail_tt2/';
+- $in{'new_default'} =~ s/\s/_/g ;
+- my $absolute_file = $base.'reject_'.$in{'new_default'}.'.tt2';
+-
+- &do_log('info','Change default by linking %s 2 %s',$base.'reject.tt2',$absolute_file);
+- if (-l $base.'reject.tt2') {
+- unless (unlink ($base.'reject.tt2')){
+- &wwslog('err','Could not unlink %s',$base.'reject.tt2');
+- }
+- }
+- unless (symlink ($absolute_file,$base.'reject.tt2')){
+- &wwslog('err','Could not symlink %s,%s',$absolute_file,$base.'reject.tt2');
+- }
+-
+- }elsif ($in{'subaction'} eq 'delete') {
+-
+- unless(unlink $param->{'template_path'}) {
+- &report::reject_report_web('intern','cannot_delete',{'file_del' => $param->{'template_path'}},'','','',$robot);
+- &wwslog('err',"can't open file %s : %s", $param->{'template_path'}, $!);
+- &web_db_log({'parameters' => $param->{'template_path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- &report::notice_report_web('performed',{},$in{'subaction'});
+- }
+- ## Build the list of available templates
+- my $available_files = &tools::get_templates_list('mail','',$list, {'ignore_global' => 1});
+- foreach $file (keys %$available_files) {
+- if ($file eq 'reject.tt2') {
+- my $base = $list->{'dir'}.'/mail_tt2/';
+- my $absolute_file = $base.'reject.tt2';
+- if (-l $absolute_file){
+- my $default = readlink ($absolute_file);
+- if ((-f $default )||( -f $base.$default )) {
+-
+- $default =~ s/^.*reject_//;
+- $default =~ s/.tt2$//;
+- $default =~ s/_/ /g;
+- $param->{'default_reject_template'} = $default;
+- }else{
+- # link to no existing file. remove link
+- &wwslog('err','Link %s point to un no existing file (%s)', $base.'reject.tt2',$default);
+- unless (unlink ($absolute_file)){
+- &wwslog('err','do_modindex: could not unlink %s',$base.'reject.tt2');
+- }
+- }
+- }elsif(-f $absolute_file){
+- # replace existing reject.tt2 file by a symlink to reject_default.tt2 for compatibility with version older than 6.0
+- unless (rename ($absolute_file,$base.'reject_default.tt2')){
+- &wwslog('err','Could not rename %,%s',$base.'reject.tt2',$base.'reject_default.tt2');
+- }
+- unless (symlink ($base.'reject_default.tt2',$absolute_file)){
+- &wwslog('err','Could not symlink %s,%s',$base.'reject_default.tt2',$absolute_file);
+- }
+-
+- $param->{'default_reject_template'} = 'default';
+- push (@{$param->{'available_files'}},'default');
+- }
+- }else{
+- next unless($file =~ /^reject_/);
+- $file =~ s/^reject_//;
+- $file =~ s/.tt2$//;
+- $file =~ s/_/ /g;
+- push (@{$param->{'available_files'}},$file);
+- }
+- }
+-
+- return 1;
+-}
+-
+-## online template edition
+-sub do_edit_template {
+-
+- $in{'subdir'} ||= 'default';
+-
+- &wwslog('info', "do_edit_template(type=$in{'webormail'},template-name=$in{'template_name'},listname=$in{'list'},path=$in{'template_path'},scope=$in{'scope'},lang=$in{'tpl_lang'})");
+-
+- ## Load original template
+- &do_view_template;
+-
+- unless ($in{'content'}) {
+- return 1;
+- }
+- if ($in{'scope'} eq 'list') {
+- if ($in{'list'}) {
+- $param->{'template_path'} = &tools::get_template_path($in{'webormail'},$robot,$in{'scope'},$in{'template_name'},$in{'tpl_lang'},$list);
+- }else{
+- &report::reject_report_web('user','listname_needed',{},$param->{'action'});
+- &wwslog('info',"edit_template : no output lisname while output scope is list");
+- &web_db_log({'parameters' => $in{'template_name'},
+- 'status' => 'error',
+- 'error_type' => 'no_list'});
+- return undef;
+- }
+- }else {
+- $param->{'template_path'} = &tools::get_template_path($in{'webormail'},$robot,$in{'scope'},$in{'template_name'},$in{'tpl_lang'});
+- }
+-
+- unless (open (TPLOUT,'>'.$param->{'template_path'})) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => $param->{'template_path'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err',"edit_template: can't open file %s", $param->{'template_path'});
+- &web_db_log({'parameters' => $in{'template_name'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- print TPLOUT &tools::unescape_html($in{'content'});
+- close TPLOUT;
+-
+- $param->{'saved'} = 1;
+- $param->{'template_content'} = $in{'content'};
+- $param->{'webormail'} = $in{'webormail'};
+- $param->{'template_name'} = $in{'template_name'};
+- $param->{'list'} = $in{'list'};
+- $param->{'scope'} = $in{'scope'};
+- $param->{'template_path'} = $in{'template_path'};
+- $param->{'tpl_lang'} = $in{'tpl_lang'};
+-
+- &web_db_log({'parameters' => $in{'template_name'},
+- 'status' => 'success'});
+-
+- return 'ls_templates';
+-
+-}
+-
+-
+- ## Server show colors, and install static css in future edit colors etc
+-
+-
+- ## Server show colors, and install static css in futur edit colors etc
+-sub do_skinsedit {
+- &wwslog('info', 'do_skinsedit');
+- my $f;
+-
+- my $dir = &Conf::get_robot_conf($robot, 'css_path');
+- my $css_url = &Conf::get_robot_conf($robot, 'css_url');
+-
+- ## Checking families and other virtual hosts.
+- &get_server_details();
+-
+- $param->{'css_warning'} = "parameter css_url seems strange, it must be the url of a directory not a css file" if ($css_url =~ /\.css$/);
+-
+- if(($in{'editcolors'})&&($in{'subaction'} eq 'reset')){
+- delete $session->{'custom_css'};
+- delete $param ->{'session'}{'custom_css'};
+- delete $param->{'custom_css'};
+-
+- foreach my $colornumber (0..15){
+- delete $session->{'color_'.$colornumber} ;
+- delete $param ->{'session'}{'color_'.$colornumber};
+- }
+- }
+-
+- if(($in{'editcolors'})&&($in{'subaction'} eq 'test')){
+-
+- return unless ($in{'custom_color_number'} =~ /color_/);
+- $param->{'custom_color_number'} = $in{'custom_color_number'};
+- $param->{'custom_color_value'} = $in{'custom_color_value'};
+- $param->{'custom_css'} = $css_url.'/'.$param->{'user'}{'email'}.'.style.css';
+- $session->{'custom_css'} = $param->{'custom_css'} ;
+-
+- $session->{$in{'custom_color_number'}} = $in{'custom_color_value'};
+-
+- $param->{$in{'custom_color_number'}} = $in{'custom_color_value'};
+- foreach my $colornumber (0..15){
+- if ($session->{'color_'.$colornumber} ) {
+- $param->{'color_'.$colornumber} = $session->{'color_'.$colornumber} ;
+- $param->{'session'}{'color_'.$colornumber} = $session->{'color_'.$colornumber} ;
+- }
+- }
+-
+- }
+- if (($in{'subaction'} eq 'install')||($in{'installcss'})) {
+-
+- my $lang = &Language::Lang2Locale($param->{'lang'});
+- my $tt2_include_path = &tools::make_tt2_include_path($robot,'web_tt2',$lang,'');
+-
+- my $date= time;
+- my $style_file;
+-
+- # update config
+- foreach my $colornumber (0..15){
+- &Conf::set_robot_conf($robot, 'color_'.$colornumber, $session->{'color_'.$colornumber}) if ($session->{'color_'.$colornumber});
+- }
+- $param->{'conf'}=$Conf::Conf;
+-
+- foreach my $css ('style.css','print.css','fullPage.css','print-preview.css') {
+- $param->{'css'} = $css;
+- my $css_file;
+- # if user use editcolor form we must generate a static CSS that used custom colors.
+- if($in{'subaction_test'}){
+- $css_file = "$dir/$param->{'user'}{'email'}.$css";
+- }else{
+- $css_file = "$dir/$css";
+- }
+- unless (-d $dir) {
+- unless (mkdir $dir, 0775) {
+- &report::reject_report_web('intern',"mkdir_failed",{'path' => $dir}, $param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err','skinsedit : failed to create directory %s : %s',$dir, $!);
+- return undef;
+- }
+- chmod 0775, $dir;
+- &wwslog('notice','skinsedit : created missing directory %s',$dir);
+- }
+-
+- ## Keep a copy of the previous CSS (only if this is not a custom css).
+- if ((-f "$css_file")&&!($in{'editcolors'})) {
+- unless (rename "$css_file", "$css_file.$date") {
+- &report::reject_report_web('intern','cannot_rename_file',{'path' => "$css_file.$date"},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err','skinsedit : can\'t open file %s.%s',$css_file,$date);
+- return undef;
+- }
+- }
+-
+- if ($in{'subaction_install'}) {
+- foreach my $colornumber (0..15){
+- $param->{'color_'.$colornumber} = $session->{'color_'.$colornumber} if ($session->{'color_'.$colornumber});
+- }
+- }
+-
+- unless (open (CSS,">$css_file")) {
+- &report::reject_report_web('intern','cannot_open_file',{'path' => "$css_file"},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err','skinsedit : can\'t open file (write) %s',$css_file);
+- return undef;
+- }
+- unless (&tt2::parse_tt2($param,'css.tt2' ,\*CSS, $tt2_include_path)) {
+- my $error = &tt2::get_error();
+- $param->{'tt2_error'} = $error;
+- &List::send_notify_to_listmaster('web_tt2_error', $robot,[$error]);
+- &wwslog('info', "do_skinsedit : error while installing $css_file");
+- }
+- close (CSS) ;
+-
+- ## Make the CSS readable to anyone
+- chmod 0775, "$css_file";
+-
+-
+- }
+-
+- $param->{'css_result'} = 1 ;
+- }
+- return 1;
+-}
+-
+- ## Multiple add
+- sub do_add_request {
+- &wwslog('info', 'do_add_request(%s)', $in{'email'});
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_add_request', 'add'));
+-
+- return 1;
+- }
+-
+-
+-####################################################
+-# do_add
+-####################################################
+-# Adds a user to a list (requested by an other user)
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest'
+-# | ($in{'previous_action'} || 'review')
+-# | undef
+-####################################################
+-## TODO: v�rifier validit� email
+- sub do_add {
+- &wwslog('info', 'do_add(%s)', $in{'email'}||$in{'pending_email'});
+- my $subscriptions = $list->get_subscription_requests();
+-
+- my %user;
+-
+- ## If a list is not 'open' and allow_subscribe_if_pending has been set to 'off' returns undef.
+- unless (($list->{'admin'}{'status'} eq 'open') || (&Conf::get_robot_conf($robot, 'allow_subscribe_if_pending') eq 'on')) {
+- &report::reject_report_web('user','list_not_open',{'status' => $list->{'admin'}{'status'}},$param->{'action'});
+- &wwslog('info','list not open');
+- &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
+- 'status' => 'error',
+- 'error_type' => 'list_not_open'});
+- return undef;
+- }
+-
+- my $email_regexp = &tools::get_regexp('email');
+- if ($in{'dump'}) {
+- foreach (split /\n/, $in{'dump'}) {
+- if (/^\s*($email_regexp)(\s+(.*))?\s*$/) {
+- $user{&tools::get_canonical_email($1)} = $5;
+- }
+- }
+- }elsif ($in{'email'} =~ /,/) {
+- foreach my $pair (split /\0/, $in{'email'}) {
+- if ($pair =~ /^($email_regexp)(,(.*))?\s*$/) {
+- $user{&tools::get_canonical_email($1)} = $5;
+- }
+- }
+- }elsif ($in{'email'}) {
+- $user{&tools::get_canonical_email($in{'email'})} = $in{'gecos'};
+- }elsif ($in{'pending_email'}) {
+- foreach my $pair (split /\0/, $in{'pending_email'}) {
+- my ($email, $gecos);
+- if ($pair =~ /^($email_regexp)(,(.*))?\s*$/) {
+- ($email, $gecos) = ($1,$5);
+- $user{&tools::get_canonical_email($email)} = $gecos;
+- }
+- }
+- }else {
+- &report::reject_report_web('user','no_email',{},$param->{'action'});
+- &wwslog('info','do_add: no email');
+- &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
+- 'status' => 'error',
+- 'error_type' => 'no_email'});
+- return undef;
+- }
+-
+- my ($total, @new_users, @added_users );
+- my $comma_emails ;
+- foreach my $email (keys %user) {
+- &wwslog('debug', "do_add subscription \$subscriptions->{$email}{custom_attribute} = $subscriptions->{$email}{'custom_attribute'})" );
+- if (ref($subscriptions->{$email}{'custom_attribute'}) eq 'HASH') {
+- my $xml = List::createXMLCustomAttribute($subscriptions->{$email}{'custom_attribute'}) ;
+- &wwslog('debug', "do_add subscription XML \$subscriptions->{$email}{custom_attribute} = $xml;");
+- }
+-
+- my $result = $list->check_list_authz('add',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'email' => $in{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $add_is;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $add_is = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- unless ($add_is =~ /do_it/) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- &wwslog('info','do_add: %s may not add', $param->{'user'}{'email'});
+- &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- next;
+- }
+-
+- unless (&tools::valid_email($email)) {
+- &report::reject_report_web('user','incorrect_email',{'email' => $email},$param->{'action'},$list);
+- &wwslog('info','do_add: incorrect email %s', $email);
+- &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
+- 'status' => 'error',
+- 'error_type' => 'incorrect_email'});
+- next;
+- }
+-
+- my $user_entry = $list->get_subscriber($email);
+-
+- if (defined($user_entry)) {
+- &report::reject_report_web('user','user_already_subscriber', {'list' => $list->{'name'},'email' => $email},$param->{'action'},$list);
+- &wwslog('info','do_add: %s already subscriber', $email);
+- &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
+- 'status' => 'error',
+- 'error_type' => 'already_subscriber'});
+- next;
+- }
+-
+- my $u2 = &List::get_user_db($email);
+- my $defaults = $list->get_default_user_options();
+- my $u;
+- %{$u} = %{$defaults};
+- $u->{'email'} = $email;
+- $u->{'gecos'} = $user{$email} || $u2->{'gecos'};
+- $u->{'date'} = $u->{'update_date'} = time;
+- $u->{'password'} = $u2->{'password'} || &tools::tmp_passwd($email) ;
+- $u->{'lang'} = $u2->{'lang'} || $list->{'admin'}{'lang'};
+- if ($comma_emails) {
+- $comma_emails = $comma_emails .','. $email;
+- }else{
+- $comma_emails = $email;
+- }
+-
+- ##
+- push @new_users, $u;
+- push @added_users, $email; ## List only email addresses ; used later to remove pending subrequests
+-
+- unless ($in{'quiet'} || $add_is =~ /quiet/i) {
+- unless ($list->send_file('welcome', $email, $robot,{})) {
+- &wwslog('err',"Unable to send template 'welcome' to $email");
+- }
+- }
+- }
+-
+- $total = $list->add_user(@new_users);
+- unless( defined $total) {
+- &report::reject_report_web('intern','add_subscriber_db_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_add: failed adding');
+- &web_db_log({'target_email' => $in{'email'}||$in{'pending_email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## Delete subscription request if any
+- $list->delete_subscription_request(@added_users);
+-
+- &report::notice_report_web('add_performed', {'total' => $total},$param->{'action'});
+-
+- foreach my $email (@added_users) {
+- &web_db_log({'target_email' => $email,
+- 'status' => 'success'});
+- }
+-
+- $in{'list'} = $in{'previous_list'} if ($in{'previous_list'});
+- return $in{'previous_action'} || 'review';
+- }
+-
+-
+-
+-####################################################
+-# do_del
+-####################################################
+-# Deletes a user from a list (requested by an other user)
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest'
+-# | ($in{'previous_action'} || 'review') | undef
+-#
+-####################################################
+- ## TODO: v�rifier validit� email
+- sub do_del {
+- &wwslog('info', 'do_del()');
+-
+- $in{'email'} = &tools::unescape_chars($in{'email'});
+-
+- my $result = $list->check_list_authz('del',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'email' => $in{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $del_is;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $del_is = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- unless ( $del_is =~ /do_it/) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- # &List::db_log('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'del',$param->{'list'},$robot,$in{'email'},'may not');
+- &wwslog('info','do_del: %s may not del', $param->{'user'}{'email'});
+- &web_db_log({'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- my @emails = split /\0/, $in{'email'};
+-
+- my ($total, @removed_users);
+-
+- foreach my $email (@emails) {
+-
+- my $escaped_email = &tools::escape_chars($email);
+-
+- my $user_entry = $list->get_subscriber($email);
+-
+- unless (defined($user_entry)) {
+- &report::reject_report_web('user','not_subscriber',{'email' => $email},$param->{'action'},$list);
+- # &List::db_log('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'del',$param->{'list'},$robot,$email,'not subscriber');
+- &wwslog('info','do_del: %s not subscribed', $email);
+- &web_db_log({'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'not_subscriber'});
+- next;
+- }
+-
+- push @removed_users, $email;
+-
+-
+- my $bounce_dir = $list->get_bounce_dir();
+-
+- if (-f $bounce_dir.'/'.$escaped_email) {
+- unless (unlink $bounce_dir.'/'.$escaped_email) {
+- &wwslog('info','do_resetbounce: failed deleting %s', $bounce_dir.'/'.$escaped_email);
+- &web_db_log({'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- next;
+- }
+- }
+-
+-
+- &wwslog('info','do_del: subscriber %s deleted from list %s', $email, $param->{'list'});
+-
+- unless ($in{'quiet'}) {
+- unless ($list->send_file('removed', $email, $robot,{})) {
+- &wwslog('notice',"Unable to send template 'removed' to $email");
+- }
+- }
+- }
+-
+- $total = $list->delete_user('users' => \@removed_users, 'exclude' =>'1');
+-
+- unless( defined $total) {
+- &report::reject_report_web('intern','delete_subscriber_db_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_del: failed');
+- &web_db_log({'target_email' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &report::notice_report_web('del_performed',{'total' => $total},$param->{'action'});
+- &web_db_log({'target_email' => $in{'email'},
+- 'status' => 'success'});
+-
+- $param->{'is_subscriber'} = 1;
+- $param->{'may_signoff'} = 1;
+-
+- ## Skip search because we don't have the expression anymore
+- delete $in{'previous_action'} if ($in{'previous_action'} eq 'search');
+-
+- return $in{'previous_action'} || 'review';
+- }
+-
+-
+-####################################################
+-# do_modindex
+-####################################################
+-# Web page for an editor to moderate documents and
+-# and/or to tag message in message topic context
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest' | 'admin' | '1' | undef
+-#
+-#######################################################
+- sub do_modindex {
+- &wwslog('info', 'do_modindex');
+- my $msg;
+- my $doc;
+-
+- ## Loads message list
+- unless (opendir SPOOL, $Conf{'queuemod'}) {
+- &report::reject_report_web('intern','cannot_open_spool',{'spool'=>$Conf{'queuemod'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_modindex: unable to read spool');
+- return 'admin';
+- }
+-
+- my $list_name = $list->{'name'};
+- my $list_id = $list->get_list_id();
+- foreach $msg ( sort grep(!/^\./, readdir SPOOL )) {
+- next
+- unless ($msg =~ /^$list_id\_(\w+)$/ ||
+- $msg =~ /^$list_name\_(\w+)$/);
+-
+- my $id = $1;
+-
+- ## Load msg
+- my $mail = new Message("$Conf{'queuemod'}/$msg");
+-
+- unless (defined $mail) {
+- &report::reject_report_web('intern','cannot_get_msg',{'msg'=>"$Conf{'queuemod'}/$msg"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_modindex: unable to parse msg %s', $msg);
+- closedir SPOOL;
+- next;
+- }
+-
+-
+- $param->{'spool'}{$id}{'size'} = int( (-s "$Conf{'queuemod'}/$msg") / 1024 + 0.5);
+- $param->{'spool'}{$id}{'subject'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('Subject'), Charset=>'utf8');
+- $param->{'spool'}{$id}{'subject'} ||= 'no_subject';
+- $param->{'spool'}{$id}{'date'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('Date'), Charset=>'utf8');
+- $param->{'spool'}{$id}{'from'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('From'), Charset=>'utf8');
+- $param->{'spool'}{$id}{'spam_status'} = $mail->{'spam_status'};
+- foreach my $field ('subject','date','from') {
+- $param->{'spool'}{$id}{$field} =~ s/&/&/g;
+- $param->{'spool'}{$id}{$field} =~ s/</</g;
+- $param->{'spool'}{$id}{$field} =~ s/>/>/g;
+- }
+- }
+- closedir SPOOL;
+-
+- if ($list->is_there_msg_topic()) {
+-
+- $param->{'request_topic'} = 1;
+-
+- foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
+- if ($top->{'name'}) {
+- push (@{$param->{'available_topics'}},$top);
+- }
+- }
+- $param->{'topic_required'} = $list->is_msg_topic_tagging_required();
+- }
+-
+- my $available_files = &tools::get_templates_list('mail','',$list, {'ignore_global' => 1});
+- foreach my $file (keys %$available_files) {
+-
+- if ($file eq 'reject.tt2') {
+-
+- my $base = $list->{'dir'}.'/mail_tt2/';
+- my $absolute_file = $base.'reject.tt2';
+- if (-l $absolute_file){
+-
+- my $default = readlink ($absolute_file);
+- if ((-f $default )||( -f $base.$default )) {
+- $default =~ s/^.*reject_//;
+- $default =~ s/.tt2$//;
+- $param->{'default_reject_template'} = $default;
+- }else{
+- # link to no existing file. remove link
+- &wwslog('err','do_modindex: link %s point to un no existing file (%s)', $base.'reject.tt2',$default);
+- unless (unlink ($absolute_file)){
+- &wwslog('err','do_modindex: could not unlink %s',$base.'reject.tt2');
+- }
+- }
+- }elsif(-f $absolute_file){
+- # replace existing reject.tt2 file by a symlink to reject_default.tt2 for compatibility with version older than 6.0
+- unless (rename ($absolute_file,$base.'reject_default.tt2')){
+- &wwslog('err','do_modindex: could not rename %,%s',$base.'reject.tt2',$base.'reject_default.tt2');
+- }
+- unless (symlink ($base.'reject_default.tt2',$absolute_file)){
+- &wwslog('err','do_modindex: could not symlink %s,%s',$base.'reject_default.tt2',$absolute_file);
+- }
+-
+- $param->{'default_reject_template'} = 'default';
+- push (@{$param->{'available_files'}},'default');
+- }
+- }else{
+- next unless($file =~ /^reject_/);
+- $file =~ s/^reject_//;
+- $file =~ s/.tt2$//;
+- push (@{$param->{'available_files'}},$file);
+- }
+- }
+- ## shared documents awaiting moderation
+- foreach my $d (@{$param->{'doc_mod_list'}}) {
+-
+- $d =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+-
+- my $long_path = $1; # path without the filename
+- my $fname = $3; # the filename with .moderate
+- my $path = $long_path; $path =~ s/^.*\/shared//; #the path for the user, without the filename
+- my $visible_fname = &make_visible_path($fname); # the filename without .moderate
+- my $visible_path = $path;
+- $visible_path = &make_visible_path($visible_path);
+-
+- my %desc_hash;
+- if ($d && (-e "$long_path.desc.$fname")){
+- %desc_hash = &get_desc_file("$long_path.desc.$fname");
+- }
+-
+- my @info = stat $d;
+-
+- my $doc = {};
+- $doc->{'visible_path'} = $visible_path;
+- $doc->{'visible_fname'} = $visible_fname;
+- $doc->{'escaped_fname'} = &tools::escape_docname($fname, '/');
+- $doc->{'escaped_path'} = &tools::escape_docname($path, '/');
+- $doc->{'fname'} = $fname;
+- $doc->{'size'} = (-s $d)/1000;
+- $doc->{'date'} = gettext_strftime "%d %b %Y", localtime($info[9]);
+- $doc->{'author'} = $desc_hash{'email'};
+- $doc->{'path'} = $path;
+-
+- push(@{$param->{'info_doc_mod'}},$doc)
+- }
+-
+- unless (($param->{'spool'}) || ($param->{'mod_total_shared'} > 0)) {
+- &report::notice_report_web('no_msg_document', {'list' => $in{'list'}},$param->{'action'});
+- &wwslog('err','do_modindex: no message and no document');
+- }
+-
+- return 1;
+- }
+-
+-### installation of moderated documents of shared
+- sub do_d_install_shared {
+- &wwslog('info', 'do_d_install_shared(%s)', $in{'id'});
+-
+- if ($in{'mode_cancel'}) {
+- return 'modindex';
+- }
+-
+- my $shareddir = $list->{'dir'}.'/shared';
+- my $file;
+- my $slash_path;
+- my $fname;
+- my $visible_fname;
+- # list of file already existing
+- my @list_file_exist;
+-
+- unless($in{'mode_confirm'} || $in{'mode_cancel'}) {
+-
+- # file already exists ?
+- foreach my $id (split /\0/, $in{'id'}) {
+-
+- $file = "$shareddir$id";
+- $id =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- $slash_path = $1;
+- $fname = $3;
+- $visible_fname = &make_visible_path($fname);
+-
+- if (-e "$file") {
+- if (-e "$shareddir$slash_path$visible_fname") {
+- push(@list_file_exist,"$slash_path$visible_fname");
+- }
+- }
+- }
+-
+- if (@list_file_exist) {
+-
+- $param->{'list_file'}=\@list_file_exist;
+- my @id = split(/\0/,$in{'id'});
+- $param->{'id'} = \@id;
+-
+- return 1;
+- }
+- }
+-
+- # install the file(s) selected
+- foreach my $id (split /\0/, $in{'id'}) {
+-
+- $file = "$shareddir$id";
+- $id =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- $slash_path = $1;
+- $fname = $3;
+- my $new_fname; ## new filename without the .moderate extension
+- if ($fname =~ /^\.(.+)\.moderate$/) {
+- $new_fname = $1;
+- }
+- my $visible_path = &make_visible_path($slash_path);
+- $visible_fname = &make_visible_path($fname);
+-
+- if (-e "$file") {
+-
+- # rename the old file in .old if exists
+- if (-e "$shareddir$slash_path$new_fname") {
+- unless (rename "$shareddir$slash_path$new_fname","$shareddir$slash_path$new_fname.old"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir$slash_path$new_fname",
+- 'new'=>"$shareddir$slash_path$new_fname.old" },
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_install_shared : Failed to rename $shareddir$slash_path$new_fname to .old : %s",$!);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- unless (rename "$shareddir$slash_path.desc.$new_fname","$shareddir$slash_path.desc.$new_fname.old"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir$slash_path.desc.$new_fname",
+- 'new'=>"$shareddir$slash_path.desc.$new_fname.old"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_install_shared : Failed to rename shareddir$slash_path.desc.$new_fname to .old : %s",$!);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- }
+-
+- unless (rename ("$shareddir$id","$shareddir$slash_path$new_fname")){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir$id",
+- 'new'=>"$shareddir$slash_path$new_fname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_install_shared : Failed to rename $file to $shareddir$slash_path$new_fname : $!");
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- unless (rename ("$shareddir$slash_path.desc.$fname","$shareddir$slash_path.desc.$new_fname")){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir$slash_path.desc.$fname",
+- 'new'=>"$shareddir$slash_path.desc.$new_fname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_install_shared : Failed to rename $file to $shareddir$slash_path$new_fname : $!");
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # send a message to the author
+- my %context;
+- $context{'installed_by'} = $param->{'user'}{'email'};
+- $context{'filename'} = "$visible_path$visible_fname";
+-
+- my %desc_hash;
+- if ($id && (-e "$shareddir$slash_path.desc.$visible_fname")){
+- %desc_hash = &get_desc_file("$shareddir$slash_path.desc.$visible_fname");
+- }
+-
+- my $sender = $desc_hash{'email'};
+- unless ($list->send_file('d_install_shared', $sender, $robot, \%context)) {
+- &wwslog('notice',"Unable to send template 'd_install_shared' to $sender");
+- }
+- }
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+- return 'modindex';
+- }
+-
+-### reject moderated documents of shared
+- sub do_d_reject_shared {
+- &wwslog('info', 'do_d_reject_shared(%s)', $in{'id'});
+-
+- my $shareddir = $list->{'dir'}.'/shared';
+- my $file;
+- my $slash_path;
+- my $fname;
+- my $visible_fname;
+-
+- foreach my $id (split /\0/, $in{'id'}) {
+-
+- $file = "$shareddir$id";
+- $id =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- $slash_path = $1;
+- $fname = $3;
+- $visible_fname = &make_visible_path($fname);
+- my $visible_path = &make_visible_path($slash_path);
+-
+- unless ($in{'quiet'}) {
+-
+- my %context;
+- my $sender;
+- $context{'rejected_by'} = $param->{'user'}{'email'};
+- $context{'filename'} = "$visible_path$visible_fname";
+-
+- my %desc_hash;
+- if ($id && (-e "$shareddir$slash_path.desc.$fname")){
+- %desc_hash = &get_desc_file("$shareddir$slash_path.desc.$fname");
+- }
+- $sender = $desc_hash{'email'};
+-
+- unless ($list->send_file('d_reject_shared', $sender, $robot, \%context)) {
+- &wwslog('notice',"Unable to send template 'd_reject_shared' to $sender");
+- }
+- }
+-
+-
+- unless (unlink($file)) {
+- &report::reject_report_web('intern','erase_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_d_reject_shared: failed to erase %s', $file);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- unless (unlink("$shareddir$slash_path.desc.$fname")) {
+- &report::reject_report_web('intern','erase_file',{'file' => "$shareddir$slash_path.desc.$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_reject_shared: failed to erase $shareddir$slash_path.desc.$fname");
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'success'});
+- return 'modindex';
+- }
+-
+-
+-
+-####################################################
+-# do_reject
+-####################################################
+-# Moderation of messages : rejects messages and notifies
+-# their senders. If in{'blacklist'} add sender to list blacklist
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest' | 'modindex' | undef
+-#
+-####################################################
+- sub do_reject {
+-
+- # toggle selection javascript have a distinction of spam and ham base on the checkbox name . It is not useful here so join id list and idspam list.
+- $in{'id'} .= ','.$in{'idspam'} if ($in{'idspam'});
+- $in{'id'} =~ s/^,//;
+- $in{'id'} =~ s/\0/,/g;
+- $in{'message_template'};
+-
+- ## The quiet information might either be provided by the 'quiet' variable
+- ## or by the 'quiet' value of the 'message_template' variable
+- if ($in{'message_template'} eq 'quiet') {
+- $in{'quiet'} = 1;
+- delete $in{'message_template'};
+- }
+- if ($in{'blacklist'}) {
+- $in{'quiet'} = 1;
+- }
+-
+- &wwslog('info', 'do_reject(%s)', $in{'id'});
+- my ($msg, $file);
+-
+- $param->{'blacklist_added'} = 0;
+- $param->{'blacklist_ignored'} = 0;
+- foreach my $id (split (/,/, $in{'id'})) {
+-
+- ## For compatibility concerns
+- foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
+- $file = $Conf{'queuemod'}.'/'.$list_id.'_'.$id;
+- last if (-f $file);
+- }
+-
+- ## Open the file
+- unless (open(IN, $file)) {
+- &report::reject_report_web('user','already_moderated',{},$param->{'action'});
+- &wwslog('err','do_reject: Unable to open %s', $file);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- next;
+- }
+-
+- # extract sender address is needed to report reject to sender and in case the sender is to be added to the blacklist
+- if (($in{'quiet'} ne '1')||($in{'blacklist'})) {
+- my $msg;
+- my $parser = new MIME::Parser;
+- $parser->output_to_core(1);
+- unless ($msg = $parser->read(\*IN)) {
+- &wwslog('err', 'Unable to parse message %s', $file);
+- next;
+- }
+-
+- my @sender_hdr = Mail::Address->parse($msg->head->get('From'));
+- unless ($#sender_hdr == -1) {
+- my $rejected_sender = $sender_hdr[0]->address;
+- unless ($in{'quiet'}) {
+- my %context;
+- $context{'subject'} = &MIME::EncWords::decode_mimewords($msg->head->get('subject'), Charset=>'utf8');
+- chomp $context{'subject'};
+- $context{'rejected_by'} = $param->{'user'}{'email'};
+- $context{'template_used'} = $in{'message_template'};
+- unless ($list->send_file($in{'message_template'}, $rejected_sender, $robot, \%context)) {
+- &wwslog('notice',"Unable to send template $in{'message_template'} to $rejected_sender");
+- }
+- }
+- if ($in{'blacklist'}) {
+- if (&tools::add_in_blacklist($rejected_sender,$robot,$list)) {
+- $param->{'blacklist_added'} += 1;
+- &wwslog('info',"added $rejected_sender to $list->{'name'} blacklist");
+- }else{
+- &wwslog('notice',"Unable to add $rejected_sender to $list->{'name'} blacklist");
+- $param->{'blacklist_ignored'} += 0;
+- }
+- }
+- }
+- }
+- close(IN);
+-
+- unless (unlink($file)) {
+- &report::reject_report_web('intern','erase_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_reject: failed to erase %s', $file);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- }
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'success'});
+- &report::notice_report_web('performed',{},$param->{'action'});
+-
+- return 'modindex';
+- }
+-
+-####################################################
+-# do_distribute
+-####################################################
+-# Moderation of messages : distributes moderated
+-# messages and tag it in message moderation context
+-#
+-# IN : - id of message to distribute. This value can also be in idspam parameter
+-#
+-# OUT : 'loginrequest' | 'modindex' | undef
+-#
+-######################################################
+- sub do_distribute {
+-
+- $in{'id'} .= ','.$in{'idspam'} if ( $in{'idspam'});
+- $in{'id'} =~ s/^,//;
+- $in{'id'} =~ s/\0/,/g;
+-
+- &wwslog('info', 'do_distribute(%s)', $in{'id'});
+- my ($msg, $file);
+-
+- my $time = time;
+- my $data = {'headers' => {'Message-ID' => &tools::get_message_id($robot),
+- 'X-Sympa-NoWrap' => 'yes'},
+- 'from'=> $param->{'user'}{'email'}};
+-
+- ## msg topics
+- my @msg_topics;
+- foreach my $msg_topic (@{$list->{'admin'}{'msg_topic'}}) {
+- my $var_name = "topic_"."$msg_topic->{'name'}";
+- if ($in{"$var_name"}) {
+- push @msg_topics, $msg_topic->{'name'};
+- }
+- }
+- my $list_topics = join(',',@msg_topics);
+-
+- if (!$list_topics && $list->is_msg_topic_tagging_required()) {
+- &report::reject_report_web('user','msg_topic_missing',{},$param->{'action'});
+- &wwslog('info','do_distribute: message(s) without topic but in a required list');
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'no_topic'});
+- return undef;
+- }
+-
+-
+- ## messages
+- foreach my $id (split (/,/, $in{'id'})) {
+- my $mail_command = sprintf ("QUIET DISTRIBUTE %s %s\n",$list->{'name'},$id);
+- $data->{'body'} .= $mail_command;
+-
+- ## For compatibility concerns
+- foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
+- $file = $Conf{'queuemod'}.'/'.$list_id.'_'.$id;
+- last if (-f $file);
+- }
+-
+- unless (-f $file) {
+- &report::reject_report_web('user','already_moderated',{},$param->{'action'});
+- &wwslog('err','do_distribute: Unable to open %s', $file);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- next;
+- }
+-
+- ## TAG
+- if ($list_topics) {
+-
+- my $parser = new MIME::Parser;
+- $parser->output_to_core(1);
+-
+- unless (open FILE, "$file") {
+- &wwslog('notice', 'do_distribute: Cannot open file %s', $file);
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- my $msg = $parser->parse(\*FILE);
+- my $head = $msg->head();
+- my $filetopic = $list->tag_topic(&tools::clean_msg_id($head->get('Message-Id')),$list_topics,'editor');
+- }
+-
+- unless (rename($file,"$file.distribute")) {
+- &report::reject_report_web('intern','rename_file',{'old'=>$file,
+- 'new'=>"$file.distribute"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_distribute: failed to rename %s', $file);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- }
+- }
+-
+- $data->{'not_auto_submitted'} = 1;
+- unless (&mail::mail_file('',&Conf::get_robot_conf($robot, 'sympa'), $data, $robot)) {
+- &report::reject_report_web('intern','cannot_send_distribute',{'from' => $param->{'user'}{'email'},'listname'=>$list->{'name'}},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_distribute: failed to send message for file %s', $file);
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &web_db_log({'parameters' => $in{'id'},
+- 'status' => 'success'});
+-
+- &report::notice_report_web('performed_soon',{},$param->{'action'});
+-
+- return 'modindex';
+- }
+-
+-####################################################
+-# do_viewmod
+-####################################################
+-# Web page for an editor to moderate a mail and/or
+-# to tag it in message topic context
+-#
+-# IN : -
+-#
+-# OUT : 'login,request' | '1' | undef
+-#
+-####################################################
+-sub do_viewmod {
+- &wwslog('info', 'do_viewmod(%s,%s)', $in{'id'},$in{'file'});
+-
+- my $msg;
+- my $tmp_dir;
+-
+- my $available_files = &tools::get_templates_list('mail','',$list, {'ignore_global' => 1});
+- foreach my $file (keys %$available_files) {
+- next unless($file =~ /^reject_/);
+- $file =~ s/^reject_//;
+- $file =~ s/.tt2$//;
+- push (@{$param->{'available_files'}},$file);
+- }
+-
+- ## For compatibility concerns
+- foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
+- $tmp_dir = $Conf{'queuemod'}.'/.'.$list_id.'_'.$in{'id'};
+- if (-d $tmp_dir) {
+- last;
+- }
+- }
+-
+- unless (-d $tmp_dir) {
+- &report::reject_report_web('intern','no_html_message_available',{'dir' => $tmp_dir},$param->{'action'});
+- &wwslog('err','do_viewmod: no HTML version of the message available in %s', $tmp_dir);
+- return undef;
+- }
+-
+- if ($in{'file'}) {
+- $in{'file'} =~ /\.(\w+)$/;
+- $param->{'file_extension'} = $1;
+- $param->{'file'} = $tmp_dir.'/'.$in{'file'};
+- $param->{'bypass'} = 1;
+- }else {
+- &tt2::add_include_path($tmp_dir) ;
+- }
+-
+- $param->{'base'} = sprintf "%s/viewmod/%s/%s/", &Conf::get_robot_conf($robot, 'wwsympa_url'), $param->{'list'}, $in{'id'};
+- $param->{'id'} = $in{'id'};
+-
+- if ($list->is_there_msg_topic()) {
+-
+- $param->{'request_topic'} = 1;
+-
+- foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
+- if ($top->{'name'}) {
+- push (@{$param->{'available_topics'}},$top);
+- }
+- }
+- $param->{'topic_required'} = $list->is_msg_topic_tagging_required();
+- }
+-
+- return 1;
+- }
+-
+-
+-## Edition of list/sympa files
+-## No list -> sympa files (helpfile,...)
+-## TODO : upload
+-## TODO : edit family file ???
+- sub do_editfile {
+- &wwslog('info', 'do_editfile(%s)', $in{'file'});
+-
+- $param->{'subtitle'} = sprintf $param->{'subtitle'}, $in{'file'};
+-
+- unless ($in{'file'}) {
+- ## Messages edition
+- foreach my $f ('info','homepage','welcome.tt2','bye.tt2','removed.tt2','message.footer','message.header','remind.tt2','invite.tt2','reject.tt2','your_infected_msg.tt2') {
+- next unless ($list->may_edit($f, $param->{'user'}{'email'}) eq 'write');
+- if ($wwslib::filenames{$f}{'gettext_id'}) {
+- $param->{'files'}{$f}{'complete'} = gettext($wwslib::filenames{$f}{'gettext_id'});
+- }else {
+- $param->{'files'}{$f}{'complete'} = $f;
+- }
+- $param->{'files'}{$f}{'selected'} = '';
+- }
+- return 1;
+- }
+-
+- unless (defined $wwslib::filenames{$in{'file'}}) {
+- &report::reject_report_web('user','file_not_editable',{'file' => $in{'file'}},$param->{'action'});
+- &wwslog('err','do_editfile: file %s not editable', $in{'file'});
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- $param->{'file'} = $in{'file'};
+-
+- my $subdir = '';
+- if ($in{'file'} =~ /\.tt2$/) {
+- $subdir = 'mail_tt2/';
+- }
+-
+- if ($param->{'list'}) {
+- my ($role,$right) = $list->may_edit($in{'file'}, $param->{'user'}{'email'});
+-
+- unless ($right eq 'write') {
+- &report::reject_report_web('auth','edit_right',{'role'=>$role, 'right' => $right},$param->{'action'},$list);
+- &wwslog('err','do_editfile: not allowed');
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- ## Add list lang to tpl filename
+- my $file = $in{'file'};
+- #$file =~ s/\.tpl$/\.$list->{'admin'}{'lang'}\.tpl/;
+-
+- ## Look for the template
+- $param->{'filepath'} = &tools::get_filename('etc',{},$subdir.$file,$robot, $list);
+-
+- ## There might be no matching file if default template not provided with Sympa
+- if (defined $param->{'filepath'}) {
+- ## open file and provide filecontent to the parser
+- ## It allows to us the correct file encoding
+- unless (open FILE, "<", $param->{'filepath'}) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $param->{'filepath'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_editfile: failed to open file %s: %s', $param->{'filepath'},$!);
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- while (<FILE>) {
+- Encode::from_to($_, $Conf{'filesystem_encoding'}, 'utf8');
+- $param->{'filecontent'} .= $_;
+- }
+- close FILE;
+- }else {
+- $param->{'filepath'} = $list->{'dir'}.'/'.$subdir.$file;
+- }
+-
+- ## Default for 'homepage' is 'info'
+- if (($in{'file'} eq 'homepage') &&
+- ! $param->{'filepath'}) {
+- $param->{'filepath'} = &tools::get_filename('etc',{},$subdir.'info',$robot, $list);
+- }
+- }else {
+- unless (&List::is_listmaster($param->{'user'}{'email'},$robot)) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
+- &wwslog('err','do_editfile: no list');
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'no_list'});
+- return undef;
+- }
+-
+- my $file = $in{'file'};
+-
+- ## Look for the template
+- if ($file eq 'list_aliases.tt2') {
+- $param->{'filepath'} = &tools::get_filename('etc',{},$file,$robot,$list);
+- }else {
+- #my $lang = &Conf::get_robot_conf($robot, 'lang');
+- #$file =~ s/\.tpl$/\.$lang\.tpl/;
+-
+- $param->{'filepath'} = &tools::get_filename('etc',{},$subdir.$file,$robot,$list);
+- }
+- }
+-
+- if (-f $param->{'filepath'} && (! -r $param->{'filepath'})) {
+- &report::reject_report_web('intern','cannot_read',{'filepath' => $param->{'filepath'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_editfile: cannot read %s', $param->{'filepath'});
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'success'});
+- &tt2::allow_absolute_path();
+-
+- return 1;
+- }
+-
+-
+-
+-
+-
+-#####################################################################################
+-
+- ## Saving of list files
+- sub do_savefile {
+- &wwslog('info', 'do_savefile(%s)', $in{'file'});
+-
+- $param->{'subtitle'} = sprintf $param->{'subtitle'}, $in{'file'};
+-
+- if ($param->{'list'}) {
+- unless ($list->am_i('owner', $param->{'user'}{'email'})) {
+- &report::reject_report_web('auth','action_owner',{},$param->{'action'},$list);
+- &wwslog('err','do_savefile: not allowed');
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- if ($in{'file'} =~ /\.tt2$/) {
+- $param->{'filepath'} = $list->{'dir'}.'/mail_tt2/'.$in{'file'};
+- }else {
+- $param->{'filepath'} = $list->{'dir'}.'/'.$in{'file'};
+-
+- if (defined $list->{'admin'}{'family_name'}) {
+- unless ($list->update_config_changes('file',$in{'file'})) {
+- &report::reject_report_web('intern','update_config_changes',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_savefile: cannot write in config_changes for file %s', $param->{'filepath'});
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- }
+- }else {
+- unless (&List::is_listmaster($param->{'user'}{'email'}),$robot) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
+- &wwslog('err','do_savefile: no list');
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'no_list'});
+- return undef;
+- }
+-
+- if ($robot ne $Conf{'domain'}) {
+- if ($in{'file'} eq 'list_aliases.tt2') {
+- $param->{'filepath'} = "$Conf{'etc'}/$robot/$in{'file'}";
+- }else {
+- $param->{'filepath'} = "$Conf{'etc'}/$robot/mail_tt2/$in{'file'}";
+- }
+- }else {
+- if ($in{'file'} eq 'list_aliases.tt2') {
+- $param->{'filepath'} = "$Conf{'etc'}/$in{'file'}";
+- }else {
+- $param->{'filepath'} = "$Conf{'etc'}/mail_tt2/$in{'file'}";
+- }
+- }
+- }
+-
+- unless ((! -e $param->{'filepath'}) or (-w $param->{'filepath'})) {
+- &report::reject_report_web('intern','cannot_write',{'filepath' => $param->{'filepath'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_savefile: cannot write %s', $param->{'filepath'});
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## Keep the old file
+- if (-e $param->{'filepath'}) {
+- rename($param->{'filepath'}, "$param->{'filepath'}.orig");
+- }
+-
+- ## Not empty
+- if ($in{'content'} && ($in{'content'} !~ /^\s*$/)) {
+-
+- ## Remove DOS linefeeds (^M) that cause problems with Outlook 98, AOL, and EIMS:
+- $in{'content'} =~ s/\015//g;
+-
+- ## Create directory if required
+- my $dir = $param->{'filepath'};
+- $dir =~ s/\/[^\/]+$//;
+- unless (-d $dir) {
+- unless (mkdir $dir, 0777) {
+- &report::reject_report_web('intern','cannot_mkdir',{'dir' => $dir},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_savefile: failed to create directory %s: %s', $dir,$!);
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- ## Save new file
+- unless (open FILE, ">", $param->{'filepath'}) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $param->{'filepath'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_savefile: failed to save file %s: %s', $param->{'filepath'},$!);
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- my $e = $in{'content'};
+- Encode::from_to($e, 'utf8', $Conf{'filesystem_encoding'});
+- print FILE $e;
+- close FILE;
+- }elsif (-f $param->{'filepath'}) {
+- &wwslog('info', 'do_savefile: deleting %s', $param->{'filepath'});
+- unlink $param->{'filepath'};
+- }
+- &web_db_log({'parameters' => $in{'file'},
+- 'status' => 'success'});
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+-
+- # undef $in{'file'};
+- # undef $param->{'file'};
+- return 'editfile';
+- }
+-
+- ## Access to web archives
+-sub do_arc {
+- &wwslog('info', 'do_arc(%s, %s)', $in{'month'}, $in{'arc_file'});
+- my $latest;
+-
+- my $index = $session->{'arc_mode'} ;
+- unless ($index) {$index = $wwsconf->{'archive_default_index'};}
+-
+- ## Clean arc_file
+- if ($in{'arc_file'} eq '/') {
+- delete $in{'arc_file'};
+- }
+-
+- ## Access control
+- unless (defined &check_authz('do_arc', 'web_archive.access')) {
+- $param->{'previous_action'} = 'arc';
+- $param->{'previous_list'} = $list->{'name'};
+- return undef;
+- }
+-
+- $session->{'archive_sniffer'} = 'false' if ($param->{'user'}{'email'} or $in{'not_a_sniffer'}) ;
+-
+- if ($list->{'admin'}{'web_archive_spam_protection'} eq 'cookie'){
+- return 'arc_protect' unless ($session->{'archive_sniffer'} eq 'false') ;
+- }
+-
+- my $arc_path = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
+- ## Calendar
+- unless (opendir ARC, $arc_path) {
+- &report::reject_report_web('user','empty_archives',{},$param->{'action'},$list);
+- &wwslog('err','do_arc: no directory %s', $arc_path);
+- return undef;
+- }
+- foreach my $dir (sort grep(!/^\./,readdir ARC)) {
+- if ($dir =~ /^(\d{4})-(\d{2})$/ && -d $arc_path.'/'.$dir.'/arctxt') {
+- $param->{'calendar'}{$1}{$2} = '???';
+- if (open(IDX, $arc_path.'/'.$dir.'/index')) {
+- my ($msgs) = <IDX>;
+- chomp ($msgs);
+- close IDX;
+- $param->{'calendar'}{$1}{$2} = $msgs if ($msgs);
+- }
+- $latest = $dir;
+- }
+- }
+- closedir ARC;
+-
+- ## Read html file
+- $in{'month'} ||= $latest;
+- my $arc_month_path = $arc_path.'/'.$in{'month'};
+-
+- unless ($in{'arc_file'}) {
+- undef $latest;
+- unless (opendir ARC, $arc_month_path) {
+- &wwslog('err',"unable to readdir $arc_month_path");
+- &report::reject_report_web('user','month_not_found',{'month' => $in{'month'},
+- 'dir' => $arc_month_path,
+- 'listname' => $param->{'list'}},
+- $param->{'action'},
+- $list,$param->{'user'}{'email'},
+- $robot);
+- }
+- foreach my $file (grep(/^$index/,readdir ARC)) {
+- if ($file =~ /^$index(\d+)\.html$/) {
+- $latest = $1 if ($latest < $1);
+- }
+- }
+- closedir ARC;
+-
+- $in{'arc_file'} = $index.$latest.".html";
+- }
+-
+- ## File exist ?
+- my $arc_file_path = $arc_month_path.'/'.$in{'arc_file'};
+- unless (-r $arc_file_path) {
+- &wwslog('err',"unable to read $arc_file_path");
+- &report::reject_report_web('user','arc_not_found',{'arc_file' => $in{'arc_file'},
+- 'path' => $arc_file_path,
+- 'listname' => $param->{'list'}},
+- $param->{'action'},
+- $list,$param->{'user'}{'email'},
+- $robot);
+- return undef;
+- }
+-
+- ## File type
+- if ($in{'arc_file'} =~ /^(mail\d+|msg\d+|thrd\d+)\.html$/) {
+-
+- if ($in{'arc_file'} =~/^(thrd|mail)\d+\.html/) {
+- $session->{'arc_mode'} = $1;
+- }
+- if ($param->{'user'}{'email'}){
+- if ($param->{'user'}{'prefs'}{'arc_mode'} ne $session->{'arc_mode'}) {
+- # update user pref as soon as connected user change the way he consult archives
+- $param->{'user'}{'prefs'}{'arc_mode'} = $session->{'arc_mode'};
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+- }
+-
+- if ($in{'arc_file'} =~ /^(msg\d+)\.html$/) {
+- ## If the file is a message, load the metadata to find out who is the author of the message
+- my $metadata = &Archive::load_html_message('file_path' => $arc_file_path);
+- $param->{'include_picture'} = &tools::make_pictures_url('email' => $metadata->{'X-From'}, 'list' => $list);
+-
+- $param->{'subtitle'} = $metadata->{'X-Subject'};
+- }
+-
+- ## Provide a filehandle to the TT2 parser (instead of a filename previously)
+- ## It allows to set the appropriate utf8 binmode on the FH
+- open $param->{'file_handle'}, "<", $arc_file_path;
+-
+- &tt2::add_include_path($arc_month_path);
+- }else {
+-
+- if ($in{'arc_file'} =~ /\.(\w+)$/) {
+- $param->{'file_extension'} = $1;
+- }
+-
+- $param->{'bypass'} = 1;
+-
+- $param->{'file'} = $arc_file_path;
+- }
+-
+- my @stat = stat ($arc_file_path);
+- $param->{'date'} = $stat[9];
+- # send page as static if client is a bot. That's prevent crawling all archices every weeks by google, yahoo and others bots
+- if ($session->{'is_a_crawler'}) {
+- $param->{'header_date'} = $stat[9];
+- }
+- $param->{'base'} = sprintf "%s%s/arc/%s/%s/%s", $param->{'base_url'}, $param->{'path_cgi'}, $param->{'list'}, $in{'month'}, $in{'arc_file'};
+- $param->{'archive_name'} = $in{'month'};
+-
+- return 1;
+-}
+-
+- ## Access to latest web archives
+- sub do_latest_arc {
+- &wwslog('info', 'do_latest_arc(%s,%s,%s)', $in{'list'}, $in{'for'}, $in{'count'});
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_latest_arc', 'web_archive.access'));
+-
+- ## parameters of the query
+- my $today = time;
+-
+- my $oldest_day;
+- if (defined $in{'for'}) {
+- $oldest_day = $today - (86400 * ($in{'for'}));
+- $param->{'for'} = $in{'for'};
+- unless ($oldest_day >= 0){
+- &report::reject_report_web('user','nb_days_to_much',{'nb_days' => $in{'for'} },$param->{'action'},$list);
+- &wwslog('err','do_latest_lists: parameter "for" is too big"');
+- }
+- }
+-
+- my $nb_arc;
+- my $NB_ARC_MAX = 100;
+- if (defined $in{'count'}) {
+- if ($in{'count'} > $NB_ARC_MAX) {
+- $in{'count'} = $NB_ARC_MAX;
+- }
+- $param->{'count'} = $in{'count'};
+- $nb_arc = $in{'count'};
+- } else {
+- $nb_arc = $NB_ARC_MAX;
+- }
+-
+- my $arc_path = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
+- unless (opendir ARC_DIR, $arc_path) {
+- &report::reject_report_web('user','empty_archives',{},$param->{'action'},$list);
+- &wwslog('err','do_latest_arc: no directory %s', $arc_path);
+- return undef;
+- }
+-
+- my @months;
+- my $latest;
+- foreach my $dir (sort grep(!/^\./,readdir ARC_DIR)) {
+- if ($dir =~ /^(\d{4})-(\d{2})$/) {
+- push @months, $dir;
+- $latest = $dir;
+- }
+- }
+- closedir ARC_DIR;
+-
+- @months = reverse @months;
+- my $stop_search;
+-
+- my @archives;
+-
+- ## year-month directory
+- foreach my $year_month (@months) {
+- if ($nb_arc <= 0) {
+- last;
+- }
+-
+- last if $stop_search;
+-
+- my $arc_month_path = $arc_path.'/'.$year_month.'/arctxt';
+- unless (opendir MONTH, $arc_month_path) {
+- &report::reject_report_web('intern','inaccessible_archive',{'path' => $arc_month_path,
+- 'listname' => $list->{'name'}},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_latest_arc: unable to open directory %s', $arc_month_path);
+- next;
+- }
+-
+- ## mails in the year-month directory
+- foreach my $arc (sort {$b <=> $a} grep(!/^\./,readdir MONTH)) {
+- last if ($nb_arc <= 0);
+-
+- if ($arc =~ /^(\d)+$/) {
+- my %msg_info;
+-
+- use MIME::Parser;
+- my $parser = new MIME::Parser;
+- $parser->output_to_core(1);
+-
+- my $arc_file = $arc_month_path.'/'.$arc;
+-
+- unless (open (FILE, $arc_file)) {
+- &wwslog('err', 'Unable to open file %s', $arc_file);
+- }
+-
+- my $message;
+- unless ($message = $parser->read(\*FILE)) {
+- &wwslog('err', 'Unable to parse message %s', $arc_file);
+- next;
+- }
+-
+- use Mail::Header;
+- my $hdr = $message->head;
+-
+- unless (defined $hdr) {
+- &wwslog('err', 'Unable to parse header of message %s', $arc_file);
+- next;
+- }
+-
+- foreach my $field ('message-id','subject','from') {
+-
+- my $var = $field; $var =~ s/-/_/g;
+-
+- $msg_info{$var} = $hdr->get($field);
+-
+- if (ref $msg_info{$var} eq 'ARRAY') {
+- $msg_info{$var} = $msg_info{$var}->[0];
+- }
+-
+- ## Hide full email address
+- if ($field eq 'from') {
+- if ($msg_info{$var} =~ /(.+)\<.+\>/) {
+- $msg_info{$var} = $1;
+- }else {
+- my @email = split /\@/, $msg_info{$var};
+- $msg_info{$var} = $email[0];
+- }
+- }
+-
+- if ($field eq 'message-id') {
+- $msg_info{$var} = &tools::clean_msg_id($msg_info{'message_id'});
+- $msg_info{$var} = &tools::escape_chars($msg_info{$var});
+-
+- $msg_info{'year_month'} = $year_month;
+- }else {
+- $msg_info{$var} = &MIME::EncWords::decode_mimewords($msg_info{$var}, Charset=>'utf8');
+- $msg_info{$var} = &tools::escape_html($msg_info{$var});
+- }
+- }
+-
+- my $date = $hdr->get('Date');
+-
+- unless (defined $date) {
+- &wwslog('err', 'No date found in message %s', $arc_file);
+- next;
+- }
+-
+- my @array_date = &time_utils::parse_date($date);
+-
+- $msg_info{'date_smtp'} = $date;
+- $msg_info{'date_epoch'} = &get_timelocal_from_date(@array_date[1..$#array_date]);
+-
+- $msg_info{'date'} = gettext_strftime "%d %b %Y", localtime($msg_info{'date_epoch'});
+- if ($msg_info{'date_epoch'} < $oldest_day) {
+- $stop_search = 1;
+- last;
+- }
+-
+- foreach my $key (keys %msg_info) {
+- chomp($msg_info{$key});
+- }
+-
+- push @archives,\%msg_info;
+- $nb_arc--;
+- }
+- }
+- closedir MONTH;
+-
+-
+- }
+-
+- @{$param->{'archives'}} = sort ({$b->{'date_epoch'} <=> $a->{'date_epoch'}} @archives);
+-
+- return 1;
+- }
+-
+-
+-sub get_timelocal_from_date {
+- my($mday, $mon, $yr, $hr, $min, $sec, $zone) = @_;
+- my($time) = 0;
+-
+- $yr -= 1900 if $yr >= 1900; # if given full 4 digit year
+- $yr += 100 if $yr <= 37; # in case of 2 digit years
+- if (($yr < 70) || ($yr > 137)) {
+- warn "Warning: Bad year (", $yr+1900, ") using current\n";
+- $yr = (localtime(time))[5];
+- }
+-
+- $time = &timelocal($sec,$min,$hr,$mday,$mon,$yr);
+- return $time
+-
+-}
+-
+-
+-
+-####################################################
+-# do_remove_arc
+-####################################################
+-#
+-# request by list owner or message sender to remove message from archive
+-# Create in the outgoing spool a file containing the message-id of mesage to be removed
+-#
+-# IN : list@host yyyy month and a tab of msgid
+-#
+-# OUT : 1 | undef
+-#
+-####################################################
+-
+-sub do_remove_arc {
+- &wwslog('info', 'do_remove_arc : list %s, yyyy %s, mm %s, #message %s', $in{'list'}, $in{'yyyy'}, $in{'month'});
+-
+- my $arcpath = $wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$in{'yyyy'}.'-'.$in{'month'};
+-
+- ## Access control
+-
+-# $in{'msgid'} = &tools::unescape_chars($in{'msgid'});
+- my @msgids = split /\0/, $in{'msgid'};
+-
+- if ($#msgids == -1) {
+- &report::reject_report_web('user','may_not_remove_arc',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','remove_arc: no message id found');
+- &web_db_log({'parameters' => $in{'msgid'},
+- 'msg_id' => $in{'msgid'},
+- 'status' => 'error',
+- 'error_type' => 'no_msgid'});
+- $param->{'status'} = 'no_msgid';
+- return undef;
+- }
+-
+- my $file = $Conf{'queueoutgoing'}.'/.remove.'.$list->get_list_id().'.'.$in{'yyyy'}.'-'.$in{'month'}.'.'.time;
+- unless (open REBUILD, ">$file") {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_remove: cannot create %s', $file);
+- &web_db_log({'parameters' => $in{'msgid'},
+- 'msg_id' => $in{'msgid'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- closedir ARC;
+- return undef;
+- }
+-
+- foreach my $msgid (@msgids) {
+- chomp $msgid ;
+- printf REBUILD ('%s||%s',$msgid,$param->{'user'}{'email'}) ; printf REBUILD "\n";
+- }
+- close REBUILD;
+- &wwslog('info', 'do_remove_arc %d messages marked to be removed by archived', $#msgids+1);
+- &web_db_log({'parameters' => $in{'msgid'},
+- 'msg_id' => $in{'msgid'},
+- 'status' => 'success'});
+- $param->{'status'} = 'done';
+-
+- return 1;
+-}
+-
+-
+-####################################################
+-# do_send_me
+-####################################################
+-# Sends a web archive message to a
+-# requesting user
+-# It uses mail::mail_forward() to do it.
+-#
+-# IN : -
+-#
+-# OUT : 'arc' | 1 | undef
+-#
+-####################################################
+- sub do_send_me {
+- &wwslog('info', 'do_send_me(%s, %s, %s, %s', $in{'list'}, $in{'yyyy'}, $in{'month'}, $in{'msgid'});
+-
+- if (! $in{'msgid'} ||
+- $in{'msgid'} =~ /NO-ID-FOUND\.mhonarc\.org/) {
+- &report::reject_report_web('intern','may_not_send_me',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','send_me: no message id found');
+- $param->{'status'} = 'no_msgid';
+- return undef;
+- }
+- ##
+- my $arcpath = $wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$in{'yyyy'}.'-'.$in{'month'};
+-
+- opendir ARC, "$arcpath/arctxt";
+- my $msgfile;
+- foreach my $file (grep (!/\./,readdir ARC)) {
+- &wwslog('debug','send_me: scanning %s', $file);
+- next unless (open MAIL,"$arcpath/arctxt/$file") ;
+- while (<MAIL>) {
+- last if /^$/ ;
+- if (/^Message-id:\s?<?([^>\s]+)>?\s?/i ) {
+- my $id = $1;
+- if ($id eq $in{'msgid'}) {
+- $msgfile = $file ;
+- }
+- last ;
+- }
+- }
+- close MAIL ;
+- }
+- if ($msgfile) {
+- unless (open MSG, "$arcpath/arctxt/$msgfile") {
+- $param->{'status'} = 'message_err';
+- &wwslog('info', 'do_send_me : could not read file %s',"$arcpath/arctxt/$msgfile");
+- }
+- my $msg_string;
+- while (<MSG>){
+- $msg_string .= $_ ;
+- }
+- close MSG;
+-
+- unless (&mail::mail_forward($msg_string,&Conf::get_robot_conf($robot, 'sympa'),\$param->{'user'}{'email'},$robot)) {
+- $param->{'status'} = 'message_err';
+- &wwslog('err',"do_send_me : impossible to send archive file to %s",$param->{'user'}{'email'});
+- return undef;
+- }
+- &wwslog('info', 'do_send_me message %s spooled for %s', "$arcpath/arctxt/$msgfile", $param->{'user'}{'email'} );
+- &report::notice_report_web('performed',{},$param->{'action'});
+- $in{'month'} = $in{'yyyy'}."-".$in{'month'};
+- return 'arc';
+-
+- }else{
+- &wwslog('info', 'do_send_me : no file match msgid');
+- $param->{'status'} = 'not_found';
+- return undef;
+- }
+-
+- return 1;
+- }
+-
+-####################################################
+-# do_view_source
+-####################################################
+-# Display message as text/plain in archives
+-#
+-# IN : -
+-#
+-# OUT : 'arc' | 1 | undef
+-#
+-####################################################
+- sub do_view_source {
+- &wwslog('info', 'do_view_source(%s, %s, %s, %s', $in{'list'}, $in{'yyyy'}, $in{'month'}, $in{'msgid'});
+-
+-
+- ## Access control
+- unless (defined &check_authz('do_arc', 'web_archive.access')) {
+- $param->{'previous_action'} = 'arc';
+- $param->{'previous_list'} = $list->{'name'};
+- return undef;
+- }
+-
+- if (! $in{'msgid'} ||
+- $in{'msgid'} =~ /NO-ID-FOUND\.mhonarc\.org/) {
+- &report::reject_report_web('intern','may_not_view_source',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','view_source: no message id found');
+- $param->{'status'} = 'no_msgid';
+- return undef;
+- }
+- ##
+- my $arcpath = $wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$in{'yyyy'}.'-'.$in{'month'};
+-
+- opendir ARC, "$arcpath/arctxt";
+- my $msgfile;
+- foreach my $file (grep (!/\./,readdir ARC)) {
+- &wwslog('debug','view_source: scanning %s', $file);
+- next unless (open MAIL,"$arcpath/arctxt/$file") ;
+- while (<MAIL>) {
+- last if /^$/ ;
+- if (/^Message-id:\s?<?([^>\s]+)>?\s?/i ) {
+- my $id = $1;
+- if ($id eq $in{'msgid'}) {
+- $msgfile = $file ;
+- }
+- last ;
+- }
+- }
+- close MAIL ;
+- }
+- if ($msgfile) {
+- unless (open MSG, "$arcpath/arctxt/$msgfile") {
+- $param->{'status'} = 'message_err';
+- &wwslog('info', 'do_view_source : could not read file %s',"$arcpath/arctxt/$msgfile");
+- }
+-
+- $param->{'bypass'} = 'extreme';
+- printf "Content-Type: text/plain\n\n";
+- while (<MSG>){
+- printf $_ ;
+- }
+- close MSG;
+-
+-
+- }else{
+- &wwslog('info', 'do_view_source : no file match msgid');
+- $param->{'status'} = 'not_found';
+- return undef;
+- }
+-
+- return 1;
+- }
+-
+- ## Output an initial form to search in web archives
+- sub do_arcsearch_form {
+- &wwslog('info', 'do_arcsearch_form(%s)', $param->{'list'});
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_arcsearch_form', 'web_archive.access'));
+-
+- my $search_base = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
+- opendir ARC, "$search_base";
+- foreach my $dir (sort {$b cmp $a} grep(!/^\./,readdir ARC)) {
+- if ($dir =~ /^(\d{4})-(\d{2})$/) {
+- push @{$param->{'yyyymm'}}, $dir;
+- }
+- }
+- closedir ARC;
+-
+- $param->{'key_word'} = $in{'key_word'};
+- $param->{'archive_name'} = $in{'archive_name'};
+-
+- return 1;
+- }
+-
+- ## Search in web archives
+- sub do_arcsearch {
+- &wwslog('info', 'do_arcsearch(%s)', $param->{'list'});
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_arcsearch', 'web_archive.access'));
+-
+- use Marc::Search;
+-
+- my $search = new Marc::Search;
+- $search->search_base ($wwsconf->{'arc_path'} . '/' . $list->get_list_id());
+- $search->base_href (&Conf::get_robot_conf($robot, 'wwsympa_url') . '/arc/' . $param->{'list'});
+- $search->archive_name ($in{'archive_name'});
+-
+- unless (defined($in{'directories'})) {
+- # by default search in current month and in the previous none empty one
+- my $search_base = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
+- opendir ARC, "$search_base";
+- foreach my $dir (sort {$b cmp $a} grep(!/^\./,readdir ARC)) {
+- if ($dir =~ /^(\d{4})-(\d{2})$/) {
+- push @{$param->{'yyyymm'}}, $dir;
+- }
+- }
+- closedir ARC;
+- $in{'directories'} = join "\0",@{$param->{'yyyymm'}} ;
+- }
+-
+- if (defined($in{'directories'})) {
+- $search->directories ($in{'directories'});
+- foreach my $dir (split/\0/, $in{'directories'}) {
+- push @{$param->{'directories'}}, $dir;
+- }
+- }
+-
+- if (defined $in{'previous'}) {
+- $search->body_count ($in{'body_count'});
+- $search->date_count ($in{'date_count'});
+- $search->from_count ($in{'from_count'});
+- $search->subj_count ($in{'subj_count'});
+- $search->previous ($in{'previous'});
+- }
+-
+- ## User didn't enter any search terms
+- if ($in{'key_word'} =~ /^\s*$/) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'key_word'},$param->{'action'});
+- &wwslog('info','do_arcsearch: no search term');
+- return undef;
+- }elsif ($in{'key_word'} =~ /[<>\\\*\$]/) {
+- &report::reject_report_web('user','syntax_errors',{'params' => 'key_word'},$param->{'action'});
+- &wwslog('info','do_arcsearch: syntax error');
+- return undef;
+- }
+-
+- $param->{'key_word'} = &tools::escape_regexp($in{'key_word'});
+-
+- $search->limit ($in{'limit'});
+-
+- $search->age (1)
+- if ($in{'age'} eq 'new');
+-
+- $search->match (1)
+- if (($in{'match'} eq 'partial') or ($in{'match'} eq '1'));
+-
+- my @words = split(/\s+/,&tools::escape_regexp($in{'key_word'}));
+- $search->words (\@words);
+- $search->clean_words ($in{'key_word'});
+- my @clean_words = @words;
+-
+- for my $i (0 .. $#words) {
+- $words[$i] =~ s,/,\\/,g;
+- $words[$i] = '\b' . $words[$i] . '\b' if ($in{'match'} eq 'exact');
+- }
+- $search->key_word (join('|',@words));
+-
+- if ($in{'case'} eq 'off') {
+- $search->case(1);
+- $search->key_word ('(?i)' . $search->key_word);
+- }
+- if ($in{'how'} eq 'any') {
+- $search->function2 ($search->match_any(@words));
+- $search->how ('any');
+- }elsif ($in{'how'} eq 'all') {
+- $search->function1 ($search->body_match_all(@clean_words,@words));
+- $search->function2 ($search->match_all(@words));
+- $search->how ('all');
+- }else {
+- $search->function2 ($search->match_this(@words));
+- $search->how ('phrase');
+- }
+-
+- $search->subj (defined($in{'subj'}));
+- $search->from (defined($in{'from'}));
+- $search->date (defined($in{'date'}));
+- $search->body (defined($in{'body'}));
+-
+- $search->body (1)
+- if ( not ($search->subj)
+- and not ($search->from)
+- and not ($search->body)
+- and not ($search->date));
+-
+- my $searched = $search->search;
+-
+- if (defined($search->error)) {
+- &wwslog('info','do_arcsearch_search_error : %s', $search->error);
+- }
+-
+- $search->searched($searched);
+-
+- if ($searched < $search->file_count) {
+- $param->{'continue'} = 1;
+- }
+-
+- foreach my $field ('list','archive_name','age','body','case','date','from','how','limit','match','subj') {
+- $param->{$field} = $in{$field};
+- }
+-
+- $param->{'body_count'} = $search->body_count;
+- $param->{'clean_words'} = $search->clean_words;
+- $param->{'date_count'} = $search->date_count;
+- $param->{'from_count'} = $search->from_count;
+- $param->{'subj_count'} = $search->subj_count;
+-
+- $param->{'num'} = $search->file_count + 1;
+- $param->{'searched'} = $search->searched;
+-
+- $param->{'res'} = $search->res;
+-
+- ## Decode subject header fields
+- foreach my $m (@{$param->{'res'}}) {
+- $m->{'subj'} = &MIME::EncWords::decode_mimewords($m->{'subj'}, Charset=>'utf8');
+- }
+-
+- return 1;
+- }
+-
+- ## Search message-id in web archives
+- sub do_arcsearch_id {
+- &wwslog('info', 'do_arcsearch_id(%s,%s,%s)', $param->{'list'},$in{'archive_name'},$in{'msgid'});
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_arcsearch_id', 'web_archive.access'));
+-
+- use Marc::Search;
+-
+- my $search = new Marc::Search;
+- $search->search_base ($wwsconf->{'arc_path'} . '/' . $list->get_list_id());
+- $search->base_href (&Conf::get_robot_conf($robot, 'wwsympa_url') . '/arc/' . $param->{'list'});
+-
+- $search->archive_name ($in{'archive_name'});
+-
+- # search in current month and in the previous none empty one
+- my $search_base = $search->search_base;
+- my $previous_active_dir ;
+- opendir ARC, "$search_base";
+- foreach my $dir (sort {$b cmp $a} grep(!/^\./,readdir ARC)) {
+- if (($dir =~ /^(\d{4})-(\d{2})$/) && ($dir lt $search->archive_name)) {
+- $previous_active_dir = $dir;
+- last;
+- }
+- }
+- closedir ARC;
+- $in{'archive_name'} = $search->archive_name."\0".$previous_active_dir ;
+-
+- $search->directories ($in{'archive_name'});
+- # $search->directories ($search->archive_name);
+-
+- ## User didn't enter any search terms
+- if ($in{'msgid'} =~ /^\s*$/) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'msgid'},$param->{'action'});
+- &wwslog('info','do_arcsearch_id: no search term');
+- return undef;
+- }
+-
+- $param->{'msgid'} = &tools::unescape_chars($in{'msgid'});
+- $in{'msgid'} = &tools::escape_regexp($in{'msgid'});
+-
+- ## Mhonarc escapes some characters : '-' (-) and '&' (&)
+- $in{'msgid'} =~ s/\&/\&\#38\;/g;
+- $in{'msgid'} =~ s/\-/\&\#45\;/g;
+-
+- $search->limit (1);
+-
+- my @words = split(/\s+/,$in{'msgid'});
+- $search->words (\@words);
+- $search->clean_words ($in{'msgid'});
+- my @clean_words = @words;
+-
+- $search->key_word (join('|',@words));
+-
+- $search->function2 ($search->match_this(@words));
+-
+- $search->id (1);
+-
+- my $searched = $search->search;
+-
+- if (defined($search->error)) {
+- &wwslog('info','do_arcsearch_id_search_error : %s', $search->error);
+- }
+-
+- $search->searched($searched);
+-
+- $param->{'res'} = $search->res;
+-
+- unless ($#{$param->{'res'}} >= 0) {
+- &report::reject_report_web('intern_quiet','archive_not_found',{'msgid'=> $in{'msgid'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','No message found in archives matching Message-ID %s', $in{'msgid'});
+- return 'arc';
+- }
+-
+- $param->{'redirect_to'} = $param->{'res'}[0]{'file'};
+-
+- return 1;
+- }
+-
+- # get pendings lists
+- sub do_get_pending_lists {
+-
+- &wwslog('info', 'get_pending_lists');
+-
+- ## Checking families and other virtual hosts.
+- &get_server_details();
+-
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+- if ($list->{'admin'}{'status'} eq 'pending') {
+- $param->{'pending'}{$list->{'name'}}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'pending'}{$list->{'name'}}{'by'} = $list->{'admin'}{'creation'}{'email'};
+- $param->{'pending'}{$list->{'name'}}{'date'} = gettext_strftime "%d %b %y %H:%M", localtime($list->{'admin'}{'creation'}{'date_epoch'});
+- }
+- }
+-
+- return 1;
+- }
+-
+- # get closed lists
+- sub do_get_closed_lists {
+-
+- &wwslog('info', 'get_closed_lists');
+-
+- ## Checking families and other virtual hosts.
+- &get_server_details();
+-
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+- if ($list->{'admin'}{'status'} eq 'closed' ||
+- $list->{'admin'}{'status'} eq 'family_closed') {
+- $param->{'closed'}{$list->{'name'}}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'closed'}{$list->{'name'}}{'by'} = $list->{'admin'}{'creation'}{'email'};
+- }
+- }
+-
+- return 1;
+- }
+-
+- # get ordered latest lists
+- sub do_get_latest_lists {
+-
+- &wwslog('info', 'get_latest_lists');
+-
+- ## Checking families and other virtual hosts.
+- &get_server_details();
+-
+- my @unordered_lists;
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+-
+- push @unordered_lists, {'name' => $list->{'name'},
+- 'subject' => $list->{'admin'}{'subject'},
+- 'creation_date' => $list->{'admin'}{'creation'}{'date_epoch'}};
+- }
+-
+- foreach my $l (sort {$b->{'creation_date'} <=> $a->{'creation_date'}} @unordered_lists) {
+- push @{$param->{'latest_lists'}}, $l;
+- $l->{'creation_date'} = gettext_strftime "%d %b %Y", localtime($l->{'creation_date'});
+- }
+-
+- return 1;
+- }
+-
+-
+-# get inactive lists
+-sub do_get_inactive_lists {
+-
+- &wwslog('info', 'get_inactive_lists');
+-
+- ## Checking families and other virtual hosts.
+- &get_server_details();
+-
+- my @unordered_lists;
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+-
+- ## skip closed lists
+- if ($list->{'admin'}{'status'} eq 'closed') {
+- next;
+- }
+-
+- my $last_message;
+-
+- if (open COUNT, $list->{'dir'}.'/msg_count') {
+- while (<COUNT>) {
+- $last_message = $1 if (/^(\d+)\s/ && ($1 > $last_message));
+- }
+- close COUNT;
+-
+- }else {
+- &wwslog('info', 'Could not open file %s', $list->{'dir'}.'/msg_count');
+- }
+-
+-
+- push @unordered_lists, {
+- 'name' => $list->{'name'},
+- 'creator' =>$list->{'admin'}{'creation'}{'email'},
+- 'send_scenario' =>$list->{'admin'}{'send'}{'name'},
+- 'owners' => join(", ", map {$_->{'email'}} @{$list->{'admin'}{'owner'}}),
+- 'editors' => join(", ", map {$_->{'email'}} @{$list->{'admin'}{'editor'}}),
+- 'subscribers_count' => $list->get_total('nocache'),
+- 'subject' => $list->{'admin'}{'subject'},
+- 'msg_count' => $list->get_msg_count(),
+- 'last_message_epoch' => $last_message,
+- 'last_message_date' => (gettext_strftime "%d %b %Y", localtime($last_message*86400)),
+- 'creation_date_epoch' => $list->{'admin'}{'creation'}{'date_epoch'},
+- 'creation_date' => (gettext_strftime "%d %b %Y", localtime($list->{'admin'}{'creation'}{'date_epoch'})),
+- };
+- }
+-
+- foreach my $l (sort {$a->{'last_message_epoch'} <=> $b->{'last_message_epoch'}} @unordered_lists) {
+- push @{$param->{'inactive_lists'}}, $l;
+- }
+-
+- return 1;
+- }
+-
+-## show a list parameters
+-sub do_set_pending_list_request {
+- &wwslog('info', 'set_pending_list(%s)',$in{'list'});
+-
+- my $list_dir = $list->{'dir'};
+-
+- $param->{'list_config'} = $list_dir.'/config';
+- if (-f $list_dir.'/info'){
+- $param->{'list_info_file_exists'} = 1;
+- }
+- $param->{'list_info'} = $list_dir.'/info';
+- $param->{'list_subject'} = $list->{'admin'}{'subject'};
+- $param->{'list_request_by'} = $list->{'admin'}{'creation'}{'email'};
+- $param->{'list_request_date'} = $list->{'admin'}{'creation'}{'date'};
+- $param->{'list_serial'} = $list->{'admin'}{'serial'};
+- $param->{'list_status'} = $list->{'admin'}{'status'};
+-
+- &tt2::add_include_path($list->{'dir'});
+-
+- return 1;
+- }
+-
+- ## show a list parameters
+- sub do_install_pending_list {
+- &wwslog('info', 'do_install_pending_list(%s,%s,%s)',$in{'list'},$in{'status'},$in{'notify'});
+-
+- unless ($in{'status'} && (($in{'status'} eq 'open') || ($in{'status'} eq 'closed'))) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'status'},$param->{'action'});
+- &wwslog('info', 'Missing status parameter',);
+- &web_db_log({'parameters' => "$in{'status'},$in{'notify'}",
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return undef;
+- }
+-
+- if ($list->{'admin'}{'status'} eq $in{'status'}) {
+- &report::reject_report_web('user','didnt_change_anything',{},$param->{'action'});
+- &wwslog('info','view_pending_list: didn t change really the status, nothing to do');
+- &web_db_log({'parameters' => "$in{'status'},$in{'notify'}",
+- 'status' => 'error',
+- 'error_type' => 'didnt_change_anything'});
+- return undef ;
+- }
+-
+- $list->{'admin'}{'status'} = $in{'status'};
+-
+- # open TMP, ">/tmp/dump1";
+- # &tools::dump_var ($list->{'admin'}, 0, \*TMP);
+- # close TMP;
+-
+- unless ($list->save_config($param->{'user'}{'email'})) {
+- &report::reject_report_web('intern','cannot_save_config',{'listname'=> $list->{'name'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','_create_list: Cannot save config file');
+- &web_db_log({'parameters' => "$in{'status'},$in{'notify'}",
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # open TMP, ">/tmp/dump2";
+- # &tools::dump_var ($list->{'admin'}, 0, \*TMP);
+- # close TMP;
+-
+- ## create the aliases
+- if ($in{'status'} eq 'open') {
+- my $aliases = &admin::install_aliases($list,$robot);
+- if ($aliases == 1) {
+- $param->{'auto_aliases'} = 1;
+- }else {
+- &report::reject_report_web('intern','failed_to_install_aliases',{'listname'=> $list->{'name'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','Failed to install list aliases');
+- }
+-
+- }
+-
+- ## Notify listmasters
+- if ($in{'status'} eq 'open') {
+- unless ($list->send_file('list_created', &Conf::get_robot_conf($robot, 'listmaster'), $robot,{})) {
+- &wwslog('notice',"Unable to send template 'list_created' to listmaster");
+- }
+- }elsif ($in{'status'} eq 'closed') {
+- unless ($list->send_file('list_rejected', &Conf::get_robot_conf($robot, 'listmaster'), $robot,{})) {
+- &wwslog('notice',"Unable to send template 'list_rejected' to listmaster");
+- }
+- }
+-
+- if ($in{'notify'}) {
+- my $owners = $list->get_owners();
+- foreach my $i (@{$owners}) {
+- ## Notify all listowners, even if reception is nomail
+- next unless ($i->{'email'});
+- if ($in{'status'} eq 'open') {
+- unless ($list->send_file('list_created', $i->{'email'}, $robot,{})) {
+- &wwslog('notice',"Unable to send template 'list_created' to $i->{'email'}");
+- }
+- }elsif ($in{'status'} eq 'closed') {
+- unless ($list->send_file('list_rejected', $i->{'email'}, $robot,{})) {
+- &wwslog('notice',"Unable to send template 'list_rejected' to $i->{'email'}");
+- }
+- }
+- }
+- }
+-
+- $param->{'status'} = $in{'status'};
+-
+- $list = $param->{'list'} = $in{'list'} = undef;
+- return 'get_pending_lists';
+- &web_db_log({'parameters' => "$in{'status'},$in{'notify'}",
+- 'status' => 'success'});
+- return 1;
+- }
+-
+- ## check if the requested list exists already using smtp 'rcpt to'
+- sub list_check_smtp {
+- my $list = shift;
+- my $conf = '';
+- my $smtp;
+- my (@suf, @addresses);
+-
+- my $smtp_relay = $Conf{'robots'}{$robot}{'list_check_smtp'} || $Conf{'list_check_smtp'};
+- my $suffixes = $Conf{'robots'}{$robot}{'list_check_suffixes'} || $Conf{'list_check_suffixes'};
+- return 0
+- unless ($smtp_relay && $suffixes);
+- my $domain = &Conf::get_robot_conf($robot, 'host');
+- &wwslog('debug2', 'list_check_smtp(%s)',$in{'listname'});
+- @suf = split(/,/,$suffixes);
+- return 0 if ! @suf;
+- for(@suf) {
+- push @addresses, $list."-$_\@".$domain;
+- }
+- push @addresses,"$list\@" . $domain;
+-
+- unless (eval "require Net::SMTP") {
+- wwslog ('err',"Unable to use Net library, Net::SMTP required, install it (CPAN) first");
+- return undef;
+- }
+- require Net::SMTP;
+-
+- if( $smtp = Net::SMTP->new($smtp_relay,
+- Hello => $smtp_relay,
+- Timeout => 30) ) {
+- $smtp->mail('');
+- for(@addresses) {
+- $conf = $smtp->to($_);
+- last if $conf;
+- }
+- $smtp->quit();
+- return $conf;
+- }
+- return undef;
+- }
+-
+-=pod
+-
+-=head2 sub do_create_list
+-
+-Creates a list using a list template
+-
+-=head3 Arguments
+-
+-=over
+-
+-=item * I<None>
+-
+-=back
+-
+-=head3 Return
+-
+-=over
+-
+-=item * I<1>, if no problem is encountered
+-
+-=item * I<undef>, if anything goes wrong
+-
+-=item * I<'loginrequest'> if no user is logged in at the time the function is called.
+-
+-=back
+-
+-=head3 Calls
+-
+-=over
+-
+-=item * web_db_log
+-
+-=item * wwslog
+-
+-=item * admin::create_list_old
+-
+-=item * check_param_in
+-
+-=item * List::send_notify_to_listmaster
+-
+-=item * report::reject_report_web
+-
+-=back
+-
+-=cut
+-
+-## create a liste using a list template.
+- sub do_create_list {
+-
+- &wwslog('info', 'do_create_list(%s,%s,%s)',$in{'listname'},$in{'subject'},$in{'template'});
+-
+- ## Check that all the needed arguments are present.
+- ## This is checked here because it requires to return the incomplete form to the user
+- foreach my $arg ('listname','subject','template','info','topics') {
+- unless ($in{$arg}) {
+- &report::reject_report_web('user','missing_arg',{'argument' => $arg},$param->{'action'});
+- &wwslog('info','do_create_list: missing param %s', $arg);
+- &web_db_log({'parameters' => $in{'listname'},
+- 'list' => $in{'listname'},
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return 'create_list_request';
+- }
+- }
+-
+- ## Lowercase listname if required
+- if ($in{'listname'} =~ /[A-Z]/) {
+- $in{'listname'} = lc($in{'listname'});
+- &report::notice_report_web('listname_lowercased',{},$param->{'action'});
+- }
+-
+- $param->{'create_action'} = $param->{'create_list'};
+-
+- &wwslog('info',"do_create_list, get action : $param->{'create_action'} ");
+-
+- ## If the action is forbidden, stop here.
+- if ($param->{'create_action'} =~ /reject/) {
+- &report::reject_report_web('auth',$param->{'reason'},{},$param->{'action'},$list);
+- &wwslog('info','do_create_list: not allowed');
+- &web_db_log({'parameters' => $in{'listname'},
+- 'list' => $in{'listname'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+-
+- ## If the action is reserved to listmaster, note that it will have to be moderated
+- }elsif ($param->{'create_action'} =~ /listmaster/i) {
+- $param->{'status'} = 'pending' ;
+-
+- ## If the action is plainly authorized, note that it will be executed.
+- }elsif ($param->{'create_action'} =~ /do_it/i) {
+- $param->{'status'} = 'open' ;
+-
+- ## If the action hasn't an authorization status, stop here.
+- }else{
+- &report::reject_report_web('intern','internal_scenario_error_create_list',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_create_list: internal error in scenario create_list');
+- &web_db_log({'parameters' => $in{'listname'},
+- 'list' => $in{'listname'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## 'other' topic means no topic
+- $in{'topics'} = undef if ($in{'topics'} eq 'other');
+-
+- ## Store creation parameters.
+- my %owner;
+- $owner{'email'} = $param->{'user'}{'email'};
+- $owner{'gecos'} = $param->{'user'}{'gecos'};
+-
+- my $parameters;
+- push @{$parameters->{'owner'}},\%owner;
+- $parameters->{'listname'} = $in{'listname'};
+- $parameters->{'subject'} = $in{'subject'};
+- $parameters->{'creation_email'} = $param->{'user'}{'email'};
+- $parameters->{'lang'} = $param->{'lang'};
+- $parameters->{'status'} = $param->{'status'};
+- $parameters->{'topics'} = $in{'topics'};
+- $parameters->{'description'} = $in{'info'};
+- $parameters->{'custom_input'} = $in{'custom_input'};
+-
+- ## create liste
+- if (my $testlist = new List($in{'listname'},$robot)){
+- &report::reject_report_web('user','list_already_exists',{'new_listname'=> $in{'listname'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_create_list: requested list %s already exist (from %s)',$in{'listname'},$param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'listname'},
+- 'list' => $in{'listname'},
+- 'status' => 'error',
+- 'error_type' => 'user'});
+- return undef
+- }
+- my $resul = &admin::create_list_old($parameters,$in{'template'},$robot,"web");
+- unless(defined $resul) {
+- &report::reject_report_web('intern','create_list',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_create_list: unable to create list %s for %s',$in{'listname'},$param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'listname'},
+- 'list' => $in{'listname'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef
+- }
+-
+- ## Create list object
+- $in{'list'} = $in{'listname'};
+- &check_param_in();
+-
+- if ($param->{'create_action'} =~ /do_it/i) {
+- if ($resul->{'aliases'} == 1) {
+- $param->{'auto_aliases'} = 1;
+- }else {
+- &report::reject_report_web('intern','failed_to_install_aliases',{'listname'=> $in{'listname'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','Failed to install list aliases');
+- }
+- }
+-
+- ## notify listmaster
+- my $list = new List $in{'listname'};
+- unless (defined $list) {
+- &wwslog('info',"failed to create list object for list '%s'",$in{'listname'});
+- &report::reject_report_web('intern','create_list',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- return undef;
+- }
+-
+- if ($param->{'create_action'} =~ /notify/) {
+- &wwslog('info','notify listmaster');
+-
+- unless (&List::send_notify_to_listmaster('request_list_creation',$robot,
+- {'list' => $list,
+- 'email' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'request_list_creation' to listmaster");
+- }
+- }
+-
+- &web_db_log({'parameters' => $in{'listname'},
+- 'list' => $in{'listname'},
+- 'status' => 'success'});
+-
+- $in{'list'} = $resul->{'list'}{'name'};
+- &check_param_in();
+-
+- $param->{'listname'} = $resul->{'list'}{'name'};
+- return 1;
+- }
+-
+-=pod
+-
+-=head2 sub do_create_list_request
+-
+-Sends back the list creation edition form.
+-
+-=head3 Arguments
+-
+-=over
+-
+-=item * I<None>
+-
+-=back
+-
+-=head3 Return
+-
+-=over
+-
+-=item * I<1>, if no problem is encountered
+-
+-=item * I<undef>, if anything goes wrong
+-
+-=item * I<'loginrequest'> if no user is logged in at the time the function is called.
+-
+-=back
+-
+-=head3 Calls
+-
+-=over
+-
+-=item * wwslog
+-
+-=item * _prepare_edit_form
+-
+-=item * List::request_action
+-
+-=item * List::load_topics
+-
+-=item * tools::get_list_list_tpl
+-
+-=item * tt2::allow_absolute_path
+-
+-=item * report::reject_report_web
+-
+-=back
+-
+-=cut
+-
+- ## Return the creation form
+- sub do_create_list_request {
+- &wwslog('info', 'do_create_list_request()');
+-
+- my $result = &Scenario::request_action('create_list',$param->{'auth_method'},$robot,
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+-
+- my $r_action;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- $param->{'create_action'} = $r_action;
+- ## Initialize the form
+- ## When returning to the form
+- foreach my $p ('listname','template','subject','topics','info') {
+- $param->{'saved'}{$p} = $in{$p};
+- }
+-
+- if ($param->{'create_action'} =~ /reject/) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- &wwslog('info','do_create_list: not allowed');
+- return undef;
+- }
+-
+- my %topics;
+- unless (%topics = &List::load_topics($robot)) {
+- &report::reject_report_web('intern','unable_to_load_list_of_topics',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- }
+- $param->{'list_of_topics'} = \%topics;
+-
+- $param->{'list_of_topics'}{$in{'topics'}}{'selected'} = 1
+- if ($in{'topics'});
+-
+- unless ($param->{'list_list_tpl'} = &tools::get_list_list_tpl($robot)) {
+- &report::reject_report_web('intern','unable_to_load_create_list_templates',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- }
+-
+- &tt2::allow_absolute_path();
+-
+- foreach my $template (keys %{$param->{'list_list_tpl'}}){
+- $param->{'tpl_count'} ++ ;
+- }
+-
+- $param->{'list_list_tpl'}{$in{'template'}}{'selected'} = 1
+- if ($in{'template'});
+-
+-
+- return 1 ;
+-
+- }
+-
+-## WWSympa Home-Page
+- sub do_home {
+- &wwslog('info', 'do_home');
+-
+- return 1;
+- }
+-
+- sub do_editsubscriber {
+- &wwslog('info', 'do_editsubscriber(%s)', $in{'email'});
+-
+- my $subscriber;
+-
+- $in{'email'} = &tools::unescape_chars($in{'email'});
+-
+- unless($subscriber = $list->get_subscriber($in{'email'})) {
+- &report::reject_report_web('intern','subscriber_not_found',{'email' => $in{'email'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_editsubscriber: subscriber %s not found', $in{'email'});
+- return undef;
+- }
+-
+- $param->{'current_subscriber'} = $subscriber;
+- $param->{'current_subscriber'}{'escaped_email'} = &tools::escape_html($param->{'current_subscriber'}{'email'});
+- $param->{'current_subscriber'}{'escaped_bounce_address'} = &tools::escape_html($param->{'current_subscriber'}{'bounce_address'});
+- $param->{'current_subscriber'}{'date'} = gettext_strftime "%d %b %Y", localtime($subscriber->{'date'});
+- $param->{'current_subscriber'}{'update_date'} = gettext_strftime "%d %b %Y", localtime($subscriber->{'update_date'});
+- $param->{'current_subscriber'}{'pictures_url'} = &tools::make_pictures_url('email' => $subscriber->{'email'}, 'list' => $list);
+-
+- ## Prefs
+- $param->{'current_subscriber'}{'reception'} ||= 'mail';
+- $param->{'current_subscriber'}{'visibility'} ||= 'noconceal';
+-
+- ## Get language from user_table
+- my $user = &List::get_user_db($in{'email'});
+- $param->{'current_subscriber'}{'lang'} = &Language::GetLangName($user->{'lang'});
+-
+- foreach my $m (keys %wwslib::reception_mode) {
+- if ($list->is_available_reception_mode($m)) {
+- $param->{'reception'}{$m}{'description'} = sprintf(gettext($wwslib::reception_mode{$m}->{'gettext_id'}));
+- if ($param->{'current_subscriber'}{'reception'} eq $m) {
+- $param->{'reception'}{$m}{'selected'} = 'selected="selected"';
+- }else {
+- $param->{'reception'}{$m}{'selected'} = '';
+- }
+- }
+- }
+-
+- foreach my $m (keys %wwslib::visibility_mode) {
+- $param->{'visibility'}{$m}{'description'} = sprintf(gettext($wwslib::visibility_mode{$m}->{'gettext_id'}));
+- if ($param->{'current_subscriber'}{'visibility'} eq $m) {
+- $param->{'visibility'}{$m}{'selected'} = 'selected="selected"';
+- }else {
+- $param->{'visibility'}{$m}{'selected'} = '';
+- }
+- }
+-
+- ## Bounces
+- if ($subscriber->{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/) {
+- my @bounce = ($1, $2, $3, $5);
+- $param->{'current_subscriber'}{'first_bounce'} = gettext_strftime "%d %b %Y", localtime($bounce[0]);
+- $param->{'current_subscriber'}{'last_bounce'} = gettext_strftime "%d %b %Y", localtime($bounce[1]);
+- $param->{'current_subscriber'}{'bounce_count'} = $bounce[2];
+- if ($bounce[3] =~ /^(\d+\.(\d+\.\d+))$/) {
+- $subscriber->{'bounce_code'} = $1;
+- $subscriber->{'bounce_status'} = $wwslib::bounce_status{$2};
+- }
+-
+- $param->{'previous_action'} = $in{'previous_action'};
+- }
+-
+- ## Additional DB fields
+- if ($Conf{'db_additional_subscriber_fields'}) {
+- my @additional_fields = split ',', $Conf{'db_additional_subscriber_fields'};
+-
+- my %data;
+-
+- foreach my $field (@additional_fields) {
+-
+- ## Is the Database defined
+- unless ($Conf{'db_name'}) {
+- &wwslog('info', 'No db_name defined in configuration file');
+- return undef;
+- }
+-
+- ## Check field type (enum or not) with MySQL
+- $data{$field}{'type'} = &List::get_db_field_type('subscriber_table', $field);
+- if ($data{$field}{'type'} =~ /^enum\((\S+)\)$/) {
+- my @enum = split /,/,$1;
+- foreach my $e (@enum) {
+- $e =~ s/^\'([^\']+)\'$/$1/;
+- $data{$field}{'enum'}{$e} = '';
+- }
+- $data{$field}{'type'} = 'enum';
+-
+- $data{$field}{'enum'}{$subscriber->{$field}} = 'selected="selected"'
+- if (defined $subscriber->{$field});
+- }else {
+- $data{$field}{'type'} = 'string';
+- $data{$field}{'value'} = $subscriber->{$field};
+- }
+- }
+- $param->{'additional_fields'} = \%data;
+- }
+-
+- $param->{'previous_action'} = $in{'previous_action'};
+-
+- return 1;
+- }
+-
+- sub do_viewbounce {
+- &wwslog('info', 'do_viewbounce(%s)', $in{'email'});
+-
+- my $escaped_email = &tools::escape_chars($in{'email'});
+-
+- $param->{'lastbounce_path'} = $list->get_bounce_dir().'/'.$escaped_email;
+-
+- unless (-r $param->{'lastbounce_path'}) {
+- &report::reject_report_web('user','no_bounce_user',{'email'=>$in{'email'}},$param->{'action'},$list);
+- &wwslog('info','do_viewbounce: no bounce %s', $param->{'lastbounce_path'});
+- return undef;
+- }
+-
+- &tt2::allow_absolute_path();
+-
+- return 1;
+- }
+-
+- ## some help for listmaster and developpers
+- sub do_scenario_test {
+- &wwslog('info', 'do_scenario_test');
+-
+- ## List available scenarii
+- unless (opendir SCENARI, Sympa::Constants::DEFAULTDIR.'/scenari/'){
+- &report::reject_report_web('intern','cannot_open_dir',{'dir' => Sympa::Constants::DEFAULTDIR.'/scenari/'},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"do_scenario_test : unable to open %s/scenari", Sympa::Constants::DEFAULTDIR);
+- return undef;
+- }
+-
+- foreach my $scfile (readdir SCENARI) {
+- if ($scfile =~ /^(\w+)\.(\w+)/ ) {
+- $param->{'scenario'}{$1}{'defined'}=1 ;
+- }
+- }
+- closedir SCENARI;
+- my $all_lists = &List::get_lists('*');
+- foreach my $list ( @$all_lists ) {
+- $param->{'listname'}{$list->{'name'}}{'defined'}=1 ;
+- }
+- foreach my $a ('smtp','md5','smime') {
+- #$param->{'auth_method'}{$a}{'define'}=1 ;
+- $param->{'authmethod'}{$a}{'defined'}=1 ;
+- }
+-
+- $param->{'scenario'}{$in{'scenario'}}{'selected'} = 'selected="selected"' if $in{'scenario'};
+-
+- $param->{'listname'}{$in{'listname'}}{'selected'} = 'selected="selected"' if $in{'listname'};
+-
+- $param->{'authmethod'}{$in{'auth_method'}}{'selected'} = 'selected="selected"' if $in{'auth_method'};
+-
+- $param->{'email'} = $in{'email'};
+-
+- if ($in{'scenario'}) {
+- my $operation = $in{'scenario'};
+- &wwslog('debug3', 'do_scenario_test: perform scenario_test');
+-
+- my $result = &Scenario::request_action ($operation,$in{'auth_method'},$robot,
+- {'listname' => $in{'listname'},
+- 'sender' => $in{'sender'},
+- 'email' => $in{'email'},
+- 'remote_host' => $in{'remote_host'},
+- 'remote_addr' => $in{'remote_addr'}},'debug');
+- if (ref($result) eq 'HASH'){
+- $param->{'scenario_action'} = $result->{'action'};
+- $param->{'scenario_condition'} = $result->{'condition'};
+- $param->{'scenario_auth_method'} = $result->{'auth_method'};
+- $param->{'scenario_reason'} = $result->{'reason'};
+- }
+- }
+- return 1;
+- }
+-
+- ## Bouncing addresses review
+- sub do_reviewbouncing {
+- &wwslog('info', 'do_reviewbouncing(%d)', $in{'page'});
+- my $size = $in{'size'} || $wwsconf->{'review_page_size'};
+-
+- ## Owner
+- $param->{'page'} = $in{'page'} || 1;
+- if ($size eq 'all') {
+- $param->{'total_page'} = $param->{'bounce_total'};
+- }else {
+- $param->{'total_page'} = int ( $param->{'bounce_total'} / $size);
+- $param->{'total_page'} ++
+- if ($param->{'bounce_total'} % $size);
+- }
+-
+- if ($param->{'total_page'} > 0 and ($param->{'page'} > $param->{'total_page'})) {
+- &report::reject_report_web('user','no_page',{'page' => $param->{'page'}},$param->{'action'});
+- &wwslog('info','do_reviewbouncing: no page %d', $param->{'page'});
+- return 'admin';
+- }
+-
+- my @users;
+- ## Members list
+- for (my $i = $list->get_first_bouncing_user(); $i; $i = $list->get_next_bouncing_user()) {
+- $i->{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/;
+- $i->{'first_bounce'} = $1;
+- $i->{'last_bounce'} = $2;
+- $i->{'bounce_count'} = $3;
+- if ($5 =~ /^(\d+)\.\d+\.\d+$/) {
+- $i->{'bounce_class'} = $1;
+- }
+-
+- ## Define color in function of bounce_score
+- if ($i->{'bounce_score'} <= $list->{'admin'}{'bouncers_level1'}{'rate'}) {
+- $i->{'bounce_level'} = 0;
+- }elsif ($i->{'bounce_score'} <= $list->{'admin'}{'bouncers_level2'}{'rate'}){
+- $i->{'bounce_level'} = 1;
+- }else{
+- $i->{'bounce_level'} = 2;
+- }
+- push @users, $i;
+- }
+-
+- my $record;
+- foreach my $i (sort
+- {($b->{'bounce_score'} <=> $a->{'bounce_score'}) ||
+- ($b->{'last_bounce'} <=> $a->{'last_bounce'}) ||
+- ($b->{'bounce_class'} <=> $a->{'bounce_class'}) }
+- @users) {
+- $record++;
+-
+- if (($size ne 'all') && ($record > ( $size * ($param->{'page'} ) ) ) ) {
+- $param->{'next_page'} = $param->{'page'} + 1;
+- last;
+- }
+-
+- next if (($size ne 'all') && ($record <= ( ($param->{'page'} - 1) * $size)));
+-
+- $i->{'first_bounce'} = gettext_strftime "%d %b %Y", localtime($i->{'first_bounce'});
+- $i->{'last_bounce'} = gettext_strftime "%d %b %Y", localtime($i->{'last_bounce'});
+-
+- ## Escape some weird chars
+- $i->{'escaped_email'} = &tools::escape_chars($i->{'email'});
+-
+- push @{$param->{'members'}}, $i;
+- }
+-
+- if ($param->{'page'} > 1) {
+- $param->{'prev_page'} = $param->{'page'} - 1;
+- }
+-
+- $param->{'size'} = $size;
+-
+- return 1;
+- }
+-
+- sub do_resetbounce {
+- &wwslog('info', 'do_resetbounce()');
+-
+- $in{'email'} = &tools::unescape_chars($in{'email'});
+-
+- my @emails = split /\0/, $in{'email'};
+-
+- foreach my $email (@emails) {
+-
+- my $escaped_email = &tools::escape_chars($email);
+-
+- unless ( $list->is_user($email) ) {
+- &report::reject_report_web('user','not_subscriber',{'email'=> $email},$param->{'action'},$list);
+- &wwslog('info','do_del: %s not subscribed', $email);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'not_subscriber'});
+- return undef;
+- }
+-
+- unless( $list->update_user($email, {'bounce' => 'NULL', 'update_date' => time, 'score' => 0})) {
+- &report::reject_report_web('intern','update_subscriber_db_failed',{'sub'=> $email},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_resetbounce: failed update database for %s', $email);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- my $bounce_dir = $list->get_bounce_dir();
+-
+- unless (unlink $bounce_dir.'/'.$escaped_email) {
+- &wwslog('info','do_resetbounce: failed deleting %s', $bounce_dir.'/'.$escaped_email);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- }
+-
+- &wwslog('info','do_resetbounce: bounces for %s reset ', $email);
+- &web_db_log({'status' => 'success'});
+-
+- }
+-
+- return $in{'previous_action'} || 'review';
+- }
+-
+- ## Rebuild an archive using arctxt/
+- sub do_rebuildarc {
+- &wwslog('info', 'do_rebuildarc(%s, %s)', $param->{'list'}, $in{'month'});
+-
+- my $file = $Conf{'queueoutgoing'}.'/.rebuild.'.$list->get_list_id();
+-
+- unless (open REBUILD, ">$file") {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_rebuildarc: cannot create %s', $file);
+- &web_db_log({'parameters' => $in{'month'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &wwslog('info', 'File: %s', $file);
+-
+- print REBUILD ' ';
+- close REBUILD;
+-
+- &report::notice_report_web('performed_soon',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'month'},
+- 'status' => 'success'});
+- return 'admin';
+- }
+-
+- ## Rebuild all archives using arctxt/
+- sub do_rebuildallarc {
+- &wwslog('info', 'do_rebuildallarc');
+-
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+- next unless (defined $list->{'admin'}{'web_archive'});
+- my $file = $Conf{'queueoutgoing'}.'/.rebuild.'.$list->get_list_id();
+-
+- unless (open REBUILD, ">$file") {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $file},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_rebuildarc: cannot create %s', $file);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &wwslog('info', 'File: %s', $file);
+-
+- print REBUILD ' ';
+- close REBUILD;
+-
+- }
+- &report::notice_report_web('performed_soon',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+- return 'serveradmin';
+- }
+-
+- ## Search among lists
+- sub do_edit_attributes {
+- &wwslog('info', 'do_edit_attributes(%s)', $in{'filter'});
+-
+- return 1;
+- }
+-
+- ## Search among lists
+- sub do_search_list {
+- &wwslog('info', 'do_search_list(%s)', $in{'filter'});
+-
+- unless ($in{'filter'}) {
+- &report::reject_report_web('user','no_filter',{},$param->{'action'});
+- &wwslog('info','do_search_list: no filter');
+- return undef;
+- }elsif ($in{'filter'} =~ /[<>\\\*\$]/) {
+- &report::reject_report_web('user','syntax_errors',{'params' => 'filter'},$param->{'action'});
+- &wwslog('err','do_search_list: syntax error');
+- return undef;
+- }
+-
+- ## Regexp
+- $param->{'filter'} = $in{'filter'};
+- $param->{'regexp'} = &tools::escape_regexp($param->{'filter'});
+-
+- ## Members list
+- my $record = 0;
+- my $all_lists = &List::get_lists($robot);
+- foreach my $list ( @$all_lists ) {
+- my $is_admin;
+- ## Search filter
+- my $regtest = eval { (($list->{'name'} !~ /$param->{'regexp'}/i)
+- && ($list->{'admin'}{'subject'} !~ /$param->{'regexp'}/i)) };
+- unless (defined($regtest)) {
+- &report::reject_report_web('user','syntax_errors',{'params' => 'filter'},$param->{'action'});
+- &wwslog('err','do_search_list: syntax error');
+- return undef;
+- }
+- next if $regtest;
+-
+- my $result = $list->check_list_authz('visibility',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- $r_action = $result->{'action'} if (ref($result) eq 'HASH');
+- next unless ($r_action eq 'do_it');
+-
+- if ($param->{'user'}{'email'} &&
+- ($list->am_i('owner',$param->{'user'}{'email'}) ||
+- $list->am_i('editor',$param->{'user'}{'email'})) ) {
+- $is_admin = 1;
+- }
+-
+- $record++;
+- $param->{'which'}{$list->{'name'}} = {'host' => $list->{'admin'}{'host'},
+- 'subject' => $list->{'admin'}{'subject'},
+- 'admin' => $is_admin,
+- 'export' => 'no'};
+- }
+- $param->{'occurrence'} = $record;
+- foreach my $listname (sort keys %{$param->{'which'}}) {
+- if ($listname =~ /^([a-z])/){
+- push @{$param->{'orderedlist'}{$1}}, $listname ;
+- }else{
+- push @{$param->{'orderedlist'}{'others'}}, $listname ;
+- }
+- }
+-
+- return 1;
+- }
+-
+-sub do_edit_list {
+- &wwslog('info', 'do_edit_list()');
+-
+- ## Check if the list belong to a family.
+- my $family;
+- if (defined $list->{'admin'}{'family_name'}) {
+- unless ($family = $list->get_family()) {
+- &report::reject_report_web('intern','unable_get_family',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_list : impossible to get list %s\'s family',$list->{'name'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- ## This hash will contain all the data gathered from the edit list form.
+- ## The keys are the parameter names.
+- ## The values are either the parameter value or an array containing this value if this is a multiple values parameter.
+- ## The value can be a scalar or a hash.
+- my $new_admin = {};
+-
+- ## This hash contains the names of all the parameters sent by the form to the FCGI.
+- ## The keys are the parameters name, the value is always 1.
+- ## Used only to parse the data.
+- my $edited_param = {};
+-
+- ## Parse all the data sent from the web interface to the FCGI.
+- ## Fills the $new_admin and $edited_param hashes.
+- foreach my $key (sort keys %in) {
+- next unless ($key =~ /^(single_param|multiple_param)\.(\S+)$/);
+-
+- $key =~ /^(single_param|multiple_param)\.(\S+)$/;
+- my ($type, $name) = ($1, $2);
+-
+- ## Tag parameter as present in the form
+- if ($name =~ /^([^\.]+)(\.)/ ||
+- $name =~ /^([^\.]+)$/) {
+- $edited_param->{$1} = 1;
+- }
+-
+- ## Parameter value
+- my $value = $in{$key};
+- next if ($value =~ /^\s*$/);
+-
+- ## If the parameter is a multiple values parameter, store the values into an array.
+- if ($type eq 'multiple_param') {
+- my @values = split /\0/, $value;
+- $value = \@values;
+- }
+-
+- my @token = split (/\./, $name);
+-
+- ## make it an entry in $new_admin
+- my $var = &_shift_var(0, $new_admin, @token);
+- $$var = $value;
+- }
+-
+- ## Check that the serial number sent by the form is the same as the one we expect.
+- ## Avoid modifying a list previously modified by another way.
+- unless ($list->{'admin'}{'serial'} == $in{'serial'}) {
+- &report::reject_report_web('user','config_changed',{'email' => $list->{'admin'}{'update'}{'email'}},$param->{'action'},$list);
+- &wwslog('info','do_edit_list: Config file has been modified(%d => %d) by %s. Cannot apply changes', $in{'single_param.serial'}, $list->{'admin'}{'serial'}, $list->{'admin'}{'update'}{'email'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## Check changes & check syntax
+- ## %changed stores the names of the parameters whose values differs from the value in the config file.
+- ## %stores the name of parameter for which values have been deleted. The keys are the parameter name, the values are the index of the deleted value.
+- ## @syntax_error stores the list of parameters for which syntax errors wre founs while evaluating the data sent by the form.
+- my (%changed, %delete);
+- my @syntax_error;
+-
+- ## Check family constraints.
+- ## %check_family is a hash whose keys are a parameter name and whose values are the constraints
+- ## defined for this parameter.
+- my %check_family;
+-
+-
+- ## Getting changes about owners or editors
+- ## If changes occured in the owner or editor definition, these scalars are set to 1.
+- my $owner_update = 0;
+- my $editor_update = 0;
+-
+- ######################################################################
+- ## Start of the loop parsing the data sent by the edition form. ##
+- ######################################################################
+-
+- foreach my $pname (sort List::by_order keys %{$edited_param}) {
+-
+- ## $p will contain the values of the current parameter in the previous list config
+- ## $new_p will contain the values sent by the form for the current parameter.
+- my ($p, $new_p);
+-
+- ## Check privileges first
+- next unless ($list->may_edit($pname,$param->{'user'}{'email'}) eq 'write');
+-
+- ## If the list belongs to a family, gather all the constraints for each edited parameter.
+- if (ref($family) eq 'Family') {
+-
+- if ((ref($::pinfo{$pname}{'format'}) ne 'HASH') && (!ref($pname))) { # simple parameter
+- my $constraint = $family->get_param_constraint($pname);
+-
+- if (ref($constraint) eq 'HASH') { # controlled parameter
+- $check_family{$pname} = $constraint;
+-
+- } elsif ($constraint ne '0') { # fixed parameter (free : no control)
+- next;
+- }
+- }
+- }
+-
+- ## Skip the obsolete parameters.
+- next if $pinfo->{$pname}{'obsolete'};
+-
+- ## $to_index value will correspond to the number of not empty parameters sent by the form.
+- my $to_index;
+-
+- ####### Validation, step 1: remove empty entries ###########
+-
+- ## If the parameter can have multiple values...
+- if ($pinfo->{$pname}{'occurrence'} =~ /n$/) {
+-
+- ## They were either entries removed by the user or empty entries added by wwsympa
+- ## The loop is going backward so we can remove empty entries
+- my @all = 0..$#{$new_admin->{$pname}};
+- foreach my $i (reverse @all ) {
+- ## If the parameter has a complex structure
+- if (ref ($pinfo->{$pname}{'format'}) eq 'HASH') {
+- ## Check each component of the complex parameter.
+- foreach my $key (keys %{$pinfo->{$pname}{'format'}}) {
+- ## As soon as a required component is found missing, the whole parameter instance is removed.
+- if ($pinfo->{$pname}{'format'}{$key}{'occurrence'} =~ /^1/ &&
+- $new_admin->{$pname}[$i]{$key} =~ /^\s*$/ ) {
+- splice(@{$new_admin->{$pname}}, $i, 1);
+- last;
+- }
+- }
+- ## Else if the parameter has only a scalar value
+- }else {
+- ## Remove if empty
+- if ($new_admin->{$pname}[$i] =~ /^\s*$/) {
+- splice(@{$new_admin->{$pname}}, $i, 1);
+- next;
+- }
+- }
+- }
+-
+- ## Now, %new_admin contains only entries for which all the mandatory values are accounted for.
+-
+- ## $last_index corresponds to the number of remaining instances of this param sent by the form.
+- my $last_index = $#{$new_admin->{$pname}};
+-
+-
+- ## If a mandatory parameter is missing, issue an error and stop here.
+- if ($pinfo->{$pname}{'occurrence'} =~ /^1/ && !($last_index >= 0)){
+- delete $new_admin->{$pname};
+- &wwslog('err','Error: Parameter %s is mandatory.', $pname);
+- &report::reject_report_web('user','mandatory_parameter',{'p_name' => $pname},$param->{'action'},$list);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'syntax_errors'});
+- next;
+- }
+-
+- ## If there are less entries in the config file than were sent by the form,
+- ## $to_index must correspond to the number of entries sent.
+- if ($#{$list->{'admin'}{$pname}} < $last_index) {
+- $to_index = $last_index;
+- ## Otherwise, $to_index must correspond to the number of entries in the config file.
+- }else {
+- $to_index = $#{$list->{'admin'}{$pname}};
+- }
+-
+- $p = $list->{'admin'}{$pname};
+- $new_p = $new_admin->{$pname};
+-
+- ## If the parameter can't have multiple values...
+- }else {
+-
+- ## If the parameter has a complex structure
+- if (ref ($pinfo->{$pname}{'format'}) eq 'HASH') {
+-
+- ## Check each component of the complex parameter.
+- foreach my $key (keys %{$pinfo->{$pname}{'format'}}) {
+-
+- ## Remove the full record if a component is emtpy and required
+- if ($pinfo->{$pname}{'format'}{$key}{'occurrence'} =~ /^1/ &&
+- $new_admin->{$pname}{$key} =~ /^\s*$/ ) {
+- delete $new_admin->{$pname};
+- last;
+- }
+- }
+- ## If the parameter contains a simple scalar value.
+- }else {
+-
+- ## Remove if empty
+- if ($new_admin->{$pname} =~ /^\s*$/) {
+- delete $new_admin->{$pname};
+- }
+- }
+-
+- $p = [$list->{'admin'}{$pname}];
+- $new_p = [$new_admin->{$pname}];
+- }
+-
+- ####### Validation, step 2: - check if the parameter was modified. ###########
+- ####### - check that the new values have the right syntax. ###########
+- ####### Note: this step is performed for each occurrence of the parameter. ###########
+-
+- foreach my $i (0..$to_index) {
+- unless (defined $new_p->[$i]) {
+- push @{$delete{$pname}}, $i;
+- $changed{$pname} = 1; next;
+- }
+- ## If the parameter corresponds to a scenario or a task, mark it as changed if its name was changed.
+- ## Example: 'subscribe'
+- if ($pinfo->{$pname}{'scenario'} ||
+- $pinfo->{$pname}{'task'} ) {
+- if ($p->[$i]{'name'} ne $new_p->[$i]{'name'}) {
+- $changed{$pname} = 1; next;
+- }
+- ## If the parameter has a complex structure, we need to check all its components.
+- ## Example: 'owner'
+- }elsif (ref ($pinfo->{$pname}{'format'}) eq 'HASH') {
+- ## Check each parameter component.
+- ## Example: 'owner->email'
+- foreach my $key (keys %{$pinfo->{$pname}{'format'}}) {
+-
+- ## Check that the user is allowed to edit this parameter component.
+- next unless ($list->may_edit("$pname.$key",$param->{'user'}{'email'}) eq 'write');
+-
+- ## If the list belongs to a family, check the possible constraints on this parameter component.
+- if (ref($family) eq 'Family') {
+- ## Test constraints only if the parameter component is not a complex structure.
+- if (!ref($key)) {
+- my $constraint = $family->get_param_constraint("$pname.$key");
+- if (ref($constraint) eq 'HASH') { # controlled parameter
+- $check_family{$pname}{$key} = $constraint;
+- } elsif ($constraint ne '0') { # fixed parameter
+- next; # Go to the next parameter component.
+- }
+- }
+- }
+-
+- ## If the parameter component corresponds to a task or a scenario, mark it as changed if its name was changed.
+- if ($pinfo->{$pname}{'format'}{$key}{'scenario'} ||
+- $pinfo->{$pname}{'format'}{$key}{'task'} ) {
+- if ($p->[$i]{$key}{'name'} ne $new_p->[$i]{$key}{'name'}) {
+- $changed{$pname} = 1; next; # Mark as changed and go to the next parameter component.
+- }
+- ## If the parameter component doesn't correspond to a task or a scenario, we must check its content.
+- }else{
+- ## Parameter component check, case 1: this parameter component can have multiple occurence.
+- ## Example: 'digest->days'
+- if ($pinfo->{$pname}{'format'}{$key}{'occurrence'} =~ /n$/) {
+- ## If the new value differs from the previous value, mark as changed and go to the next parameter component.
+- if ($#{$p->[$i]{$key}} != $#{$new_p->[$i]{$key}}) {
+- $changed{$pname} = 1; next;
+- }
+-
+- ## For each occurrence of this parameter component, check value
+- foreach my $index (0..$#{$p->[$i]{$key}}) {
+- my $format = $pinfo->{$pname}{'format'}{$key}{'format'};
+-
+- ## If the format has a complex structure, it is the description of a file format.
+- if (ref ($format)) {
+- $format = $pinfo->{$pname}{'format'}{$key}{'file_format'};
+- }
+- ## If this occurrence of the parameter component differs from the corresponding one in the config
+- ## check the syntax and mark as changed.
+- if ($p->[$i]{$key}[$index] ne $new_p->[$i]{$key}[$index]) {
+-
+- if (defined($new_p->[$i]{$key}[$index]) && $new_p->[$i]{$key}[$index] !~ /^$format$/i) {
+- &wwslog('err', "Syntax error : $pname/$i/$key/$index = $new_p->[$i]{$key}[$index]");
+- push @syntax_error, $pname;
+- }
+- $changed{$pname} = 1; next; # Mark as changed and go to the next parameter component.
+- }
+- }
+-
+- ## Parameter component check, case 2: this component is limited to one occurence.
+- ## Example: 'owner->email'
+- }else {
+- ## If the parameter component value differs from the corresponding one in the config, go on.
+- if ($p->[$i]{$key} ne $new_p->[$i]{$key}) {
+- my $format = $pinfo->{$pname}{'format'}{$key}{'format'};
+-
+- ## If the format has a complex structure, it is the description of a file format.
+- if (ref ($format)) {
+- $format = $pinfo->{$pname}{'format'}{$key}{'file_format'};
+- }
+-
+- ## Check the syntax and mark as changed if the syntax is correct.
+- if (defined($new_p->[$i]{$key}) && $new_p->[$i]{$key} !~ /^$format$/i) {
+- &wwslog('err', "Syntax error : $pname/$i/$key = $new_p->[$i]{$key}");
+- push @syntax_error, $pname;
+- }
+-
+- $changed{$pname} = 1; next; # Mark as changed and go to the next parameter component.
+- }
+- }
+- }
+- }
+- ## If the parameter has just a scalar value, just check its value.
+- ## Example: 'max_size'
+- }else {
+- ## If the value differs from the one in the config file, mark parameter as changed if the syntax is correct.
+- if ($p->[$i] ne $new_p->[$i]) {
+- unless ($new_p->[$i] =~ /^$pinfo->{$pname}{'file_format'}$/) {
+- &wwslog('err', "Syntax error : $pname/$i = $new_p->[$i]");
+- push @syntax_error, $pname;
+- }
+- $changed{$pname} = 1;
+- }
+- }
+- }
+- }
+-
+- ######################################################################
+- ## Validation of the form finished. Start of valid data treatments ##
+- ######################################################################
+-
+- ## Error if no parameter was edited
+- unless (keys %changed) {
+- &report::reject_report_web('user','no_parameter_edited',{},$param->{'action'},$list);
+- &wwslog('info','No parameter was edited by user');
+- return 'edit_list_request';
+- }
+-
+- ## Syntax errors
+- if ($#syntax_error > -1) {
+- &report::reject_report_web('user','syntax_errors',{'params' => 'filter'},$param->{'action'},$list);
+- &wwslog('info','do_edit_list: Syntax errors for parameters %s', join(',', @syntax_error));
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'syntax_errors'});
+- return undef;
+- }
+-
+- ## Checking no topic named "other"
+- foreach my $msg_topic (@{$new_admin->{'msg_topic'}}) {
+- if ($msg_topic->{'name'} =~ /^other$/i) {
+- $msg_topic->{'name'} = undef;
+- $msg_topic->{'title'} = undef;
+- &report::reject_report_web('user','topic_other',{},$param->{'action'},$list);
+- &wwslog('notice',"do_edit_list: topic other is a reserved word");
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'syntax_errors'});
+- return undef;
+- }
+- }
+-
+- ## For changed msg_topic.name
+- if (defined $new_admin->{'msg_topic'} && $list->modifying_msg_topic_for_subscribers($new_admin->{'msg_topic'})) {
+- &report::notice_report_web('subscribers_noticed_deleted_topics',{},$param->{'action'});
+- }
+-
+- ## Delete selected params
+- foreach my $p (keys %delete) {
+-
+- if (($p eq 'owner') || ($p eq 'owner_include')) {
+- $owner_update = 1;
+- }
+-
+- if (($p eq 'editor') || ($p eq 'editor_include')) {
+- $editor_update = 1;
+- }
+-
+- ## Delete ALL entries
+- unless (ref ($delete{$p})) {
+- undef $new_admin->{$p};
+- next;
+- }
+-
+- ## Delete selected entries
+- foreach my $k (reverse @{$delete{$p}}) {
+- splice @{$new_admin->{$p}}, $k, 1;
+- }
+-
+- if (defined $check_family{$p}) { # $p is family controlled
+- if ($#{$new_admin->{$p}} < 0) {
+- &report::reject_report_web('user','p_family_controlled',{'param' => $p},$param->{'action'},$list);
+- &wwslog('info','do_edit_list : parameter %s must have values (family context)',$p);
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return undef;
+- }
+- }
+- }
+-
+- # updating config_changes for deleted parameters
+- if (ref($family)) {
+- my @array_delete = keys %delete;
+- unless ($list->update_config_changes('param',\@array_delete)) {
+- &report::reject_report_web('intern','update_config_changes',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_list: cannot write in config_changes for deleted parameters from list %s', $list->{'name'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- ## Update config in memory
+- my $data_source_updated;
+- foreach my $parameter (keys %changed) {
+-
+- my $pname;
+- if ($parameter =~ /^([\w-]+)\.([\w-]+)$/) {
+- $pname = $1;
+- } else{
+- $pname = $parameter;
+- }
+-
+- my @users;
+-
+- ## If new owners/editors have been added, then notify them
+- foreach my $admin_type ('owner','editor') {
+- my (%previous_emails, %new_emails);
+-
+- ## Check previous entries
+- foreach my $entry (@{$list->{'admin'}{$admin_type}}) {
+- $previous_emails{$entry->{'email'}} = 1;
+- }
+-
+- ## Compare with new entries
+- foreach my $entry (@{$new_admin->{$admin_type}}) {
+-
+- unless ($previous_emails{$entry->{'email'}}) {
+-
+- ## Notify the new list owner/editor
+- $list->send_notify_to_user('added_as_listadmin', $entry->{'email'},{'admin_type' => $admin_type, 'delegator' => $param->{'user'}{'email'}});
+- &report::notice_report_web('user_notified',{'notified_user' => $entry->{'email'}},$param->{'action'});
+- }
+- }
+- }
+-
+- if (defined $check_family{$pname}) { # $pname is CONTROLLED
+- &_check_new_values(\%check_family,$pname,$new_admin);
+- }
+-
+- ## If datasource config changed
+- if ($pname =~ /^(include_.*|user_data_source|ttl)$/) {
+- $data_source_updated = 1;
+- }
+-
+- ## User Data Source
+- if ($pname eq 'user_data_source') {
+- ## Migrating to database
+- if (($list->{'admin'}{'user_data_source'} eq 'file') && ($new_admin->{'user_data_source'} eq 'database' || $new_admin->{'user_data_source'} eq 'include2')) {
+- unless (-f "$list->{'dir'}/subscribers") {
+- &wwslog('notice', 'No subscribers to load in database');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'no_subsciber'});
+- }
+- @users = &List::_load_users_file("$list->{'dir'}/subscribers");
+- }elsif (($list->{'admin'}{'user_data_source'} ne 'include2') &&
+- ($new_admin->{'user_data_source'} eq 'include2')) {
+- $list->update_user('*', {'subscribed' => 1});
+- &report::notice_report_web('subscribers_updated_soon',{},$param->{'action'});
+- }elsif (($list->{'admin'}{'user_data_source'} eq 'include2') &&
+- ($new_admin->{'user_data_source'} eq 'database')) {
+- $list->sync_include('purge');
+- }
+-
+- ## Update total of subscribers
+- $list->{'total'} = $list->_load_total_db();
+- $list->savestats();
+- }
+-
+- $list->{'admin'}{$pname} = $new_admin->{$pname};
+- if (defined $new_admin->{$pname} || $pinfo->{$pname}{'internal'}) {
+- delete $list->{'admin'}{'defaults'}{$pname};
+- }else {
+- $list->{'admin'}{'defaults'}{$pname} = 1;
+- }
+-
+- if (($pname eq 'user_data_source') &&
+- ($#users >= 0)) {
+-
+- $list->{'total'} = 0;
+-
+- ## Insert users in database
+- foreach my $user (@users) {
+- $list->add_user($user);
+- }
+-
+- $list->get_total();
+- $list->{'mtime'}[1] = 0;
+- }
+-
+- if (($pname eq 'owner') || ($pname eq 'owner_include')){
+- $owner_update = 1;
+- }
+-
+- if (($pname eq 'editor') || ($pname eq 'editor_include')){
+- $editor_update = 1;
+- }
+-
+- # updating config_changes for changed parameters
+-
+- if (ref($family)) {
+- my @array_changed = keys %changed;
+- unless ($list->update_config_changes('param',\@array_changed)) {
+- &report::reject_report_web('intern','update_config_changes',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_file: cannot write in config_changes for changed parameters from list %s', $list->{'name'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+- }
+-
+- ## Save config file
+- unless ($list->save_config($param->{'user'}{'email'})) {
+- &report::reject_report_web('intern','cannot_save_config',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_list: Cannot save config file');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+-
+- ## Reload config to clean some empty entries in $list->{'admin'}
+- $list = new List $list->{'name'}, $robot, {'reload_config' => 1};
+-
+- unless (defined $list) {
+- &report::reject_report_web('intern','list_reload',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_list: error in list reloading');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## If list has included data sources, update them and delete sync_include task.
+- if ($data_source_updated) {
+- if ($list->on_the_fly_sync_include('use_ttl'=>0)) {
+- &report::notice_report_web('subscribers_updated',{},$param->{'action'});
+- }else {
+- &report::reject_report_web('intern','sync_include_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }
+- }
+-
+- ## call sync_include_admin if there are changes about owners or editors and we're in mode include2
+- if ( ($list->{'admin'}{'user_data_source'} eq 'include2')) {
+- unless ($list->sync_include_admin()) {
+- &report::reject_report_web('intern','sync_include_admin_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_list: sync_include_admin() failed');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-#($owner_update || $editor_update) &&
+- ## checking there is some owner(s) in case of sync_include_admin not called
+- if (($owner_update || $data_source_updated) && ($list->{'admin'}{'user_data_source'} ne 'include2')) {
+-
+- unless ( $list->get_nb_owners()) {
+- &report::reject_report_web('intern','no_owner_defined',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_edit_list: no owner defined for list %s',$list->{'name'});
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+-
+- ## Tag changed parameters
+- foreach my $pname (keys %changed) {
+- $::changed_params{$pname} = 1;
+- }
+-
+- ## Save stats
+- $list->savestats();
+-
+-# print "Content-type: text/plain\n\n";
+- # &tools::dump_var($list->{'admin'}{'msg_topic'},0);
+- # &tools::dump_var($param->{'param'},0);
+-
+-
+- &report::notice_report_web('list_config_updated',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+- return 'edit_list_request';
+- }
+-
+- ## Shift tokens to get a reference to the desired
+- ## entry in $var (recursive)
+- sub _shift_var {
+- my ($i, $var, @tokens) = @_;
+- &wwslog('debug3','shift_var(%s,%s,%s)',$i, $var, join('.',@tokens));
+- my $newvar;
+-
+- my $token = shift @tokens;
+-
+- if ($token =~ /^\d+$/) {
+- return \$var->[$token]
+- if ($#tokens == -1);
+-
+- if ($tokens[0] =~ /^\d+$/) {
+- unless (ref $var->[$token]) {
+- $var->[$token] = [];
+- }
+- $newvar = $var->[$token];
+- }else {
+- unless (ref $var->[$token]) {
+- $var->[$token] = {};
+- }
+- $newvar = $var->[$token];
+- }
+- }else {
+- return \$var->{$token}
+- if ($#tokens == -1);
+-
+- if ($tokens[0] =~ /^\d+$/) {
+- unless (ref $var->{$token}) {
+- $var->{$token} = [];
+- }
+- $newvar = $var->{$token};
+- }else {
+- unless (ref $var->{$token}) {
+- $var->{$token} = {};
+- }
+- $newvar = $var->{$token};
+- }
+-
+- }
+-
+- if ($#tokens > -1) {
+- $i++;
+- return &_shift_var($i, $newvar, @tokens);
+- }
+- return $newvar;
+- }
+-
+-=pod
+-
+-=head2 sub do_edit_list_request
+-
+-Sends back the list config edition form.
+-
+-=head3 Arguments
+-
+-=over
+-
+-=item * I<None>
+-
+-=back
+-
+-=head3 Return
+-
+-=over
+-
+-=item * I<1>, if no problem is encountered
+-
+-=item * I<undef>, if anything goes wrong
+-
+-=item * I<'loginrequest'> if no user is logged in at the time the function is called.
+-
+-=back
+-
+-=head3 Calls
+-
+-=over
+-
+-=item * wwslog
+-
+-=item * _prepare_edit_form
+-
+-=item * report::reject_report_web
+-
+-=back
+-
+-=cut
+-
+- ## Send back the list config edition form
+- sub do_edit_list_request {
+- &wwslog('info', 'do_edit_list_request(%s)', $in{'group'});
+-
+- if ($in{'group'}) {
+- $param->{'group'} = $in{'group'};
+- &_prepare_edit_form ($list);
+- }
+-
+- # print "Content-type: text/plain\n\n";
+- # &tools::dump_var(\%pinfo,0);
+- # &tools::dump_var($list->{'admin'},0);
+- # &tools::dump_var($param->{'param'},0);
+-
+- $param->{'serial'} = $list->{'admin'}{'serial'};
+-
+- return 1;
+- }
+-
+-sub _check_new_values {
+- my $check_family = shift;
+- my $pname = shift;
+- my $new_admin = shift;
+- &wwslog('debug3', '_check_new_values(%s)',$pname);
+-
+- my $uncompellable_param = &Family::get_uncompellable_param();
+-
+- if (ref($::pinfo{$pname}{'format'}) eq 'HASH') { #composed parameter
+-
+- foreach my $key (keys %{$check_family->{$pname}}) {
+-
+- my $constraint = $check_family->{$pname}{$key};
+- my $values = &List::_get_param_value_anywhere($new_admin,"$pname.$key");
+- my $nb_for = 0;
+-
+- # exception for uncompellable param
+- foreach my $p (keys %{$uncompellable_param}) {
+- if (($pname eq $p) && !($uncompellable_param->{$p})) {
+- return 1;
+- }
+-
+- if (($pname eq $p) && ($key eq $uncompellable_param->{$p})) {
+- return 1;
+- }
+- }
+- foreach my $p_val (@{$values}) { #each element value
+- $nb_for++;
+- if (ref($p_val) eq 'ARRAY') { # multiple values
+- foreach my $p (@{$p_val}) {
+- if (!($constraint->{$p}) && (($nb_for == 1) || ($p ne ''))) {
+- &report::reject_report_web('user','p_family_wrong',{'param' => $pname,'val'=> $p},$param->{'action'});
+- &wwslog('info','do_edit_list : parameter %s has got wrong value : %s (family context), %s, %d',$pname,$p);
+- return undef;
+- }
+- }
+- } else { # single value
+- if (!($constraint->{$p_val}) && (($nb_for == 1) || ($p_val ne ''))) {
+- &report::reject_report_web('user','p_family_wrong',{'param' => $pname,'val'=> $p_val},$param->{'action'});
+- &wwslog('info','do_edit_list : parameter %s has got wrong value : %s (family context), %s, %d',$pname,$p_val);
+- return undef;
+- }
+- }
+- }
+- }
+- } else { #simple parameter
+-
+- # exception for uncompellable param
+- foreach my $p (keys %{$uncompellable_param}) {
+- if ($pname eq $p) {
+- return 1;
+- }
+- }
+-
+-
+- my $constraint = $check_family->{$pname};
+- my $values = &List::_get_param_value_anywhere($new_admin,$pname);
+- my $nb_for = 0;
+-
+-
+- foreach my $p_val (@{$values}) { #each element value
+- $nb_for++;
+- if (ref($p_val) eq 'ARRAY') { # multiple values
+- foreach my $p (@{$p_val}) {
+- if (!($constraint->{$p}) && (($nb_for == 1) || ($p ne ''))) {
+- &report::reject_report_web('user','p_family_wrong',{'param' => $pname,'val'=> $p},$param->{'action'});
+- &wwslog('info','do_edit_list : parameter %s has got wrong value : %s (family context), %s, %d',$pname,$p);
+- return undef;
+- }
+- }
+- } else { # single value
+- if (!($constraint->{$p_val}) && (($nb_for == 1) || ($p_val ne ''))) {
+- &report::reject_report_web('user','p_family_wrong',{'param' => $pname,'val'=> $p_val},$param->{'action'});
+- &wwslog('info','do_edit_list : parameter %s has got wrong value : %s (family context), %s, %d',$pname,$p_val);
+- return undef;
+- }
+- }
+- }
+- }
+-}
+-
+-=pod
+-
+-=head2 sub _prepare_edit_form(LIST)
+-
+-Prepares config data to be sent in the edition form. Adds to the parameters array a hash for each parameter to be edited.
+-
+-=head3 Arguments
+-
+-=over
+-
+-=item * I<$list>, a List object
+-
+-=back
+-
+-=head3 Return
+-
+-=over
+-
+-=item * I<1>, if no problem is encountered
+-
+-=item * I<undef>, if anything goes wrong
+-
+-=back
+-
+-=head3 Calls
+-
+-=over
+-
+-=item * _prepare_data
+-
+-=item * _restrict_values
+-
+-=item * wwslog
+-
+-=item * List::by_order
+-
+-=item * List::get_family
+-
+-=item * List::load_topics
+-
+-=item * List::may_edit
+-
+-=item * Language::GetLang
+-
+-=item * Language::SetLang
+-
+-=item * report::reject_report_web
+-
+-=item * tools::dup_var
+-
+-=back
+-
+-=cut
+-
+-## Prepare config data to be sent in the
+-## edition form
+-sub _prepare_edit_form {
+- my $list = shift;
+- my $list_config = &tools::dup_var($list->{'admin'});
+- my $family;
+- my $is_form_editable = '0';
+-
+- ## If the list belongs to a family, check if the said family can be retrieved.
+- if (defined $list_config->{'family_name'}) {
+- unless ($family = $list->get_family()) {
+- &report::reject_report_web('intern','unable_get_family',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','_prepare_edit_form : impossible to get list %s\'s family',$list->{'name'});
+- return undef;
+- }
+- }
+-
+- ## For each parameter defined in List.pm, retrieve and prepare for editing
+- foreach my $pname (sort List::by_order keys %{$pinfo}) {
+-
+- ## Skip comments and default values.
+- next if ($pname =~ /^(comment|defaults)$/);
+-
+- ## Skip parameters belonging to another group.
+- next if ($in{'group'} && ($pinfo->{$pname}{'group'} ne $in{'group'}));
+-
+- ## Skip obsolete parameters.
+- next if $pinfo->{$pname}{'obsolete'};
+-
+- ## Check whether the parameter can be edited by the logged user.
+- my $may_edit = $list->may_edit($pname,$param->{'user'}{'email'});
+-
+- ## Valid form global edit status as soon as at least one editable parameter is found.
+- if ($may_edit eq 'write') {
+- $is_form_editable = '1';
+- }
+-
+- ## Store in $p a reference to the hash containing the informations relative to the parameter editing.
+- my $p = &_prepare_data($pname, $pinfo->{$pname}, $list_config->{$pname},$may_edit,$family);
+-
+- ## Store if the parameter is still at its default value or not.
+- $p->{'default'} = $list_config->{'defaults'}{$pname};
+-
+- ## Store the change state of this parameter, taken from the global variable %changed_params.
+- $p->{'changed'} = $::changed_params{$pname};
+-
+- ## Exceptions...too many
+- if ($pname eq 'topics') {
+- $p->{'type'} = 'enum';
+-
+- my @topics;
+- foreach my $topic(@{$p->{'value'}}) {
+- push @topics, $topic->{'value'};
+- }
+- undef $p->{'value'};
+- my %list_of_topics = &List::load_topics($robot);
+-
+- if (defined $p->{'constraint'}) {
+- &_restrict_values(\%list_of_topics,$p->{'constraint'});
+- }
+-
+- foreach my $topic (keys %list_of_topics) {
+- $p->{'value'}{$topic}{'selected'} = 0;
+- $p->{'value'}{$topic}{'title'} = $list_of_topics{$topic}{'current_title'};
+-
+- if ($list_of_topics{$topic}{'sub'}) {
+- foreach my $subtopic (keys %{$list_of_topics{$topic}{'sub'}}) {
+- $p->{'value'}{"$topic/$subtopic"}{'selected'} = 0;
+- $p->{'value'}{"$topic/$subtopic"}{'title'} = "$list_of_topics{$topic}{'current_title'}/$list_of_topics{$topic}{'sub'}{$subtopic}{'current_title'}";
+- }
+- }
+- }
+- foreach my $selected_topic (@topics) {
+- next unless (defined $selected_topic);
+- $p->{'value'}{$selected_topic}{'selected'} = 1;
+- $p->{'value'}{$selected_topic}{'title'} = "Unknown ($selected_topic)"
+- unless (defined $p->{'value'}{$selected_topic}{'title'});
+- }
+- }elsif ($pname eq 'digest') {
+- foreach my $v (@{$p->{'value'}}) {
+- next unless ($v->{'name'} eq 'days');
+- if (ref($v->{'value'}) eq 'ARRAY'){
+- &tools::do_log('debug2','Empty digest parameter. Putting a dummy value.');
+- $v->{'value'} = undef;
+- $v->{'type'} = 'enum';
+- }else{
+- foreach my $day (keys %{$v->{'value'}}) {
+- $v->{'value'}{$day}{'title'} = gettext_strftime "%A", gmtime(0 + ($day +3) * (3600 * 24));
+- }
+- }
+- }
+- }elsif ($pname eq 'lang') {
+- my $saved_lang = &Language::GetLang();
+-
+- foreach my $lang (keys %{$p->{'value'}}) {
+- #&wwslog('notice','LANG: %s', $lang);
+- &Language::SetLang($lang);
+- $p->{'value'}{$lang}{'title'} = gettext('_language_');
+- }
+- &Language::SetLang($saved_lang);
+- }
+-
+- push @{$param->{'param'}}, $p;
+- }
+-
+- ## If at least one param was editable, make the update button appear in the form.
+- $param->{'is_form_editable'} = $is_form_editable;
+- return 1;
+- }
+-
+-=pod
+-
+-=head2 sub _prepare_data(STRING $name, HASH_Ref $struct, SCALAR $data, STRING $may_edit, FAMILY $family, STRING $main_p)
+-
+-Returns a reference to a hash containing the data used to edit the parameter (of name $name, corresponding to the structure $struct in pinfo, with the $may_edit editing status) containing the data in the Sympa web interface.
+-
+-=head3 Arguments
+-
+-=over
+-
+-=item * I<$name> (STRING), the name of the parameter processed
+-
+-=item * I<$struct> (HASH_Ref), a ref to the hash describing this parameter in %List::pinfo
+-
+-=item * I<$data> (), the value(s) taken by this parameter in the current list. Can be a reference to a list or the value of a single parameter.
+-
+-=item * I<$may_edit> (STRING), the editing status of this parameter in the current context.
+-
+-=item * I<$family> (FAMILY), the family the list belongs to.
+-
+-=item * I<$main_p> (STRING), the prefix composing the complete name of the parameter.
+-
+-=back
+-
+-=head3 Return
+-
+-=over
+-
+-=item * I<$p_glob>, a reference to a hash containing the data used to edit the parameter.
+-
+-=back
+-
+-=head3 Calls
+-
+-=over
+-
+-=item * _restrict_values
+-
+-=item * _prepare_data
+-
+-=item * load_data_sources_list
+-
+-=item * Family::get_param_constraint
+-
+-=item * List::load_scenario_list
+-
+-=item * List::load_task_list
+-
+-=item * List::may_edit
+-
+-=item * tools::escape_html
+-
+-=back
+-
+-=cut
+-
+- sub _prepare_data {
+- my ($name, $struct,$data,$may_edit,$family,$main_p) = @_;
+- # &wwslog('debug2', '_prepare_data(%s, %s)', $name, $data);
+- # $family and $main_p (recursive call) are optionnal
+- # if $main_p is needed, $family also
+- next if ($struct->{'obsolete'});
+-
+- ## Prepare data structure for the parser
+- my $p_glob = {'name' => $name,
+- 'comment' => $struct->{'comment'}{$param->{'lang'}}
+- };
+-
+- ## Check if some family constraint modify the editing rights.
+- my $restrict = 0;
+- my $constraint;
+- if ((ref($family) eq 'Family') && ($may_edit eq 'write')) {
+-
+- if ($main_p && defined $::pinfo{$main_p}) {
+- if (ref($::pinfo{$main_p}{'format'}) eq 'HASH') { # composed parameter
+- $constraint = $family->get_param_constraint("$main_p.$p_glob->{'name'}");
+- }
+- } else { # simple parameter
+- if (ref($::pinfo{$p_glob->{'name'}}{'format'}) ne 'HASH') { # simple parameter
+- $constraint = $family->get_param_constraint($p_glob->{'name'});
+- }
+- }
+- if ($constraint eq '0') { # free parameter
+- $p_glob->{'may_edit'} = 'write';
+-
+- } elsif (ref($constraint) eq 'HASH') { # controlled parameter
+- $p_glob->{'may_edit'} = 'write';
+- $restrict = 1;
+-
+- } else { # fixed parameter
+- $p_glob->{'may_edit'} = 'read';
+- }
+-
+- } else {
+- $p_glob->{'may_edit'} = $may_edit;
+- }
+-
+- ## Naming the parameter.
+- if ($struct->{'gettext_id'}) {
+- $p_glob->{'title'} = gettext($struct->{'gettext_id'});
+- }else {
+- $p_glob->{'title'} = $name;
+- }
+-
+- ## Occurrences : if the parameter can have multiple occurences,
+- ## its values are transfered into the array pointed by $data2
+- ## if they were given in arguments (if not, an empty array is created).
+- ## if it is a single occurence parameter, an array is created with
+- ## its single value.
+-
+- my $data2;
+- if ($struct->{'occurrence'} =~ /n$/) {
+- $p_glob->{'occurrence'} = 'multiple';
+- if (defined($data)) {
+- $data2 = $data;
+-
+- if ($may_edit eq 'write') {
+- ## Add an empty entry
+- unless (($name eq 'days') || ($name eq 'reception') || ($name eq 'rfc2369_header_fields') || ($name eq 'topics')) {
+-
+- my $empty_entry;
+- ## Structured parameter
+- if (ref($struct->{'format'}) eq 'HASH') {
+- foreach my $sub_parameter (keys %{$struct->{'format'}}) {
+-
+- ## Use default value if defined
+- if ($struct->{'format'}{$sub_parameter}{'default'}) {
+- $empty_entry->{$sub_parameter} = $struct->{'format'}{$sub_parameter}{'default'};
+- }
+- }
+-
+- ## Simpe parameter
+- }else {
+- $empty_entry = undef;
+- }
+-
+- push @{$data2}, $empty_entry;
+- ## &wwslog('debug2', 'Add 1 %s', $name);
+- }
+- }
+- }else {
+- if ($may_edit eq 'write') {
+- $data2 = [undef];
+- }
+- }
+- }else {
+- $data2 = [$data];
+- }
+-
+- my @all_p;
+-
+- ## Foreach occurrence of param
+- foreach my $d (@{$data2}) {
+- my $p = {};
+-
+- ## Type of data
+- if ($struct->{'scenario'}) {
+- $p_glob->{'type'} = 'scenario';
+- my $list_of_scenario;
+-
+- my $tmp_list_of_scenario = $list->load_scenario_list($struct->{'scenario'},$robot);
+-
+- ## Only get required scenario attributes
+- foreach my $scenario (keys %{$tmp_list_of_scenario}) {
+- $list_of_scenario->{$scenario} = {'name' => $tmp_list_of_scenario->{$scenario}{'name'},
+- 'web_title' => $tmp_list_of_scenario->{$scenario}{'web_title'}};
+- }
+-
+- $list_of_scenario->{$d->{'name'}}{'selected'} = 1;
+-
+- $p->{'value'} = $list_of_scenario;
+-
+- if ($restrict) {
+- &_restrict_values($p->{'value'},$constraint);
+- }
+-
+- }elsif ($struct->{'task'}) {
+- $p_glob->{'type'} = 'task';
+- my $list_of_task = $list->load_task_list($struct->{'task'}, $robot);
+-
+- $list_of_task->{$d->{'name'}}{'selected'} = 1;
+-
+- $p->{'value'} = $list_of_task;
+-
+- if ($restrict) {
+- &_restrict_values($p->{'value'},$constraint);
+- }
+-
+- }elsif ($struct->{'datasource'}) {
+- $p_glob->{'type'} = 'datasource';
+- my $list_of_data_sources = $list->load_data_sources_list($robot);
+-
+- $list_of_data_sources->{$d}{'selected'} = 1;
+-
+- $p->{'value'} = $list_of_data_sources;
+-
+- if ($restrict) {
+- &_restrict_values($p->{'value'},$constraint);
+- }
+-
+- }elsif (ref ($struct->{'format'}) eq 'HASH') {
+- $p_glob->{'type'} = 'paragraph';
+- unless (ref($d) eq 'HASH') {
+- $d = {};
+- }
+-
+- foreach my $k (sort {$struct->{'format'}{$a}{'order'} <=> $struct->{'format'}{$b}{'order'}}
+- keys %{$struct->{'format'}}) {
+- ## Prepare data recursively
+- my $m_e = $list->may_edit("$name.$k",$param->{'user'}{'email'});
+- my $v = &_prepare_data($k, $struct->{'format'}{$k}, $d->{$k},$m_e,$family,$name);
+-
+- push @{$p->{'value'}}, $v;
+- }
+-
+- }elsif ((ref ($struct->{'format'}) eq 'ARRAY') || ($restrict && ($main_p eq 'msg_topic' && $name eq 'keywords'))) {
+- $p_glob->{'type'} = 'enum';
+-
+- unless (defined $p_glob->{'value'}) {
+- ## Initialize
+- foreach my $elt (@{$struct->{'format'}}) {
+- $p_glob->{'value'}{$elt}{'selected'} = 0;
+- }
+-
+- ## Check obsolete values ; they should not be printed
+- if (defined $struct->{'obsolete_values'}) {
+- foreach my $elt (@{$struct->{'obsolete_values'}}) {
+- delete $p_glob->{'value'}{$elt};
+- }
+- }
+- }
+- if (ref ($d)) {
+- next unless (ref ($d) eq 'ARRAY');
+- foreach my $v (@{$d}) {
+- $p_glob->{'value'}{$v}{'selected'} = 1;
+- }
+- }else {
+- $p_glob->{'value'}{$d}{'selected'} = 1 if (defined $d);
+- }
+-
+- if ($restrict) {
+- &_restrict_values($p_glob->{'value'},$constraint);
+- }
+-
+- }else {
+- if ($restrict && ($name ne 'topics')) {
+- $p_glob->{'type'} = 'enum';
+-
+- foreach my $elt (keys %{$constraint}) {
+- $p->{'value'}{&tools::escape_html($elt)}{'selected'} = 0;
+- }
+-
+- $p->{'value'}{&tools::escape_html($d)}{'selected'} = 1;
+- $p->{'length'} = $struct->{'length'};
+- $p->{'unit'} = gettext($struct->{'gettext_unit'});
+-
+- } else {
+-
+- $p_glob->{'type'} = 'scalar';
+- $p->{'value'} = &tools::escape_html($d);
+- $p->{'length'} = $struct->{'length'};
+- $p->{'field_type'} = $struct->{'field_type'};
+- my $l = length($p->{'value'});
+- $p->{'hidden_field'} = '*' x $l;
+- $p->{'unit'} = gettext($struct->{'gettext_unit'});
+- if ($restrict) { # for topics
+- $p_glob->{'constraint'} = $constraint;
+- }
+- }
+- }
+-
+- push @all_p, $p;
+- }
+-
+- if (($p_glob->{'occurrence'} eq 'multiple')
+- && ($p_glob->{'type'} ne 'enum')) {
+- $p_glob->{'value'} = \@all_p;
+- }else {
+- foreach my $k (keys %{$all_p[0]}) {
+- $p_glob->{$k} = $all_p[0]->{$k};
+- }
+- }
+-
+- return $p_glob;
+- }
+-
+-## Restrict allowed values in the hash
+-sub _restrict_values {
+- my $values = shift; #ref on hash of values
+- my $allowed = shift; #ref on hash of allowed values
+- &wwslog('debug3', '_restrict_values()');
+-
+- foreach my $v (keys %{$values}) {
+- unless (defined $allowed->{$v}) {
+- delete $values->{$v};
+- }
+- }
+-}
+-
+- ## NOT USED anymore (expect chinese)
+- sub do_close_list_request {
+- &wwslog('info', 'do_close_list_request()');
+-
+- if ($list->{'admin'}{'status'} eq 'closed') {
+- &report::reject_report_web('user','already_closed',{},$param->{'action'},$list);
+- &wwslog('info','do_close_list_request: already closed');
+- return undef;
+- }
+-
+- return 1;
+- }
+-
+-
+- # in order to rename a list you must be list owner and you must be allowed to create new list
+- sub do_rename_list_request {
+- &wwslog('info', 'do_rename_list_request()');
+-
+- my $result = &Scenario::request_action ('create_list',$param->{'auth_method'},$robot,
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- unless ($r_action =~ /do_it|listmaster/) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- &wwslog('info','do_rename_list_request: not owner');
+- return undef;
+- }
+-
+- ## Super listmaster can move a list to another robot
+- if (&List::is_listmaster($param->{'user'}{'email'}, $robot)) {
+- foreach (keys %{$Conf{'robots'}}) {
+- if ($_ eq $robot) {
+- $param->{'robots'}{$_} = 'selected="selected"';
+- }else {
+- $param->{'robots'}{$_} = '';
+- }
+- }
+- }
+-
+- return '1';
+- }
+-
+-sub do_copy_list {
+- &wwslog('info', 'do_copy_list(%s,%s)', $in{'new_listname'}, $in{'new_robot'});
+- &do_rename_list('copy');
+-}
+-
+-# in order to rename a list you must be list owner and you must be allowed to create new list
+-sub do_rename_list {
+- my $mode = shift;
+-
+- if ($in{'new_listname'} =~ /[A-Z]/) {
+- $in{'new_listname'} = lc($in{'new_listname'});
+- &report::notice_report_web('listname_lowercased',{},$param->{'action'});
+- }
+-
+- &wwslog('info', 'do_rename_list(%s,%s, mode = %s)', $in{'new_listname'}, $in{'new_robot'},$mode);
+-
+- my $result = &admin::rename_list(list => $list,
+- new_listname =>$in{'new_listname'},
+- new_robot => $in{'new_robot'},
+- mode => $mode,
+- auth_method => $param->{'auth_method'},
+- user_email => $param->{'user'}{'email'},
+- remote_host => $param->{'remote_host'},
+- remote_addr => $param->{'remote_addr'},
+- aliases => $param->{'aliases'},
+- status => $param->{'status'},
+- );
+-
+- if ($result eq 'incorrect_listname') {
+- &report::reject_report_web('user','incorrect_listname', {'bad_listname' => $in{'new_listname'}},$param->{'action'},$list);
+- &wwslog('info','do_rename_list: incorrect listname %s', $in{'new_listname'});
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'error',
+- 'error_type' => 'incorrect_listname'});
+- return 'rename_list_request';
+-
+- }elsif ($result eq 'authorization') {
+- &report::reject_report_web('auth','authorization',{},$param->{'action'},$list);
+- &wwslog('info','do_rename_list: not owner');
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+-
+- }elsif ($result eq 'internal') {
+- &report::reject_report_web('intern','UUUUnable_to_rename_list',{'new_listname' => $in{'new_listname'}},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err', "can't rename list %s to %s@%s", $list->get_list_address(), $in{'new_listname'}, $in{'new_robot'});
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+-
+- }elsif ($result eq 'list_already_exists') {
+- &report::reject_report_web('user','list_already_exists',{'new_listname' => $in{'new_listname'}},$param->{'action'},$list);
+- &wwslog('info', 'Could not rename list %s for %s: new list %s already existing list',
+- $in{'listname'},$param->{'user'}{'email'},$in{'new_listname'});
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'error',
+- 'error_type' => 'list_already_exists'});
+- return undef;
+-
+- }elsif ($result eq 'incorrect_listname') {
+- &report::reject_report_web('user','listname_matches_aliases',{'new_listname' => $in{'new_listname'}},$param->{'action'},$list);
+- &wwslog('info','do_create_list: incorrect listname %s', $in{'new_listname'});
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'error',
+- 'error_type' => 'incorrect_listname'});
+- return 'rename_list_request';
+- }elsif ($result eq 'unknown_robot') {
+- &wwslog('info',"do_rename_list : unknown robot $in{'new_robot'}");
+- &report::reject_report_web('user','unknown_robot',{'new_robot' => $in{'new_robot'}},$param->{'action'},$list);
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'error',
+- 'error_type' => 'unknown_robot'});
+- return undef;
+- }
+-
+- ## Were aliases installed?
+- if ($param->{'aliases'} == 1) {
+- $param->{'auto_aliases'} = 1;
+- }else {
+- $param->{'auto_aliases'} = 0;
+- }
+-
+- # set list status to pending if creation list is moderated
+- if ($param->{'status'} eq 'pending') {
+- &report::notice_report_web('pending_list',{},$param->{'action'},$list);
+- }
+-
+- if ($in{'new_robot'} eq '$robot') {
+- $param->{'redirect_to'} = "$param->{'base_url'}$param->{'path_cgi'}/admin/$in{'new_listname'}";
+- }else {
+- $param->{'redirect_to'} = &Conf::get_robot_conf($in{'new_robot'}, 'wwsympa_url')."/admin/$in{'new_listname'}";
+- }
+-
+- $param->{'list'} = $in{'new_listname'};
+- &web_db_log({'parameters' => "$in{'new_listname'},$in{'new_robot'}",
+- 'status' => 'success'});
+-
+- return 1;
+-}
+-
+-
+-sub do_purge_list {
+- &wwslog('info', 'do_purge_list()');
+-
+- my @lists = split /\0/, $in{'selected_lists'};
+-
+- foreach my $l (@lists) {
+- my $list = new List ($l, $robot);
+- next unless (defined $list);
+- $list->purge($param->{'user'}{'email'});
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'parameters' => $in{'selected_lists'},
+- 'status' => 'success'});
+- return 'get_closed_lists';
+- }
+-
+- sub do_close_list {
+- &wwslog('info', "do_close_list($list->{'name'})");
+-
+- if ($list->{'admin'}{'status'} eq 'closed') {
+- &report::reject_report_web('user','already_closed',{},$param->{'action'},$list);
+- &wwslog('info','do_close_list: already closed');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'already_closed'});
+- return undef;
+- }elsif($list->{'admin'}{'status'} eq 'pending') {
+- &wwslog('info','do_close_list: closing a pending list makes it purged');
+- $list->purge($param->{'user'}{'email'});
+- &report::notice_report_web('list_purged',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+- return 'home';
+- }else{
+- $list->close($param->{'user'}{'email'});
+- &report::notice_report_web('list_closed',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+- return 'admin';
+- }
+-
+- }
+-
+- sub do_restore_list {
+- &wwslog('info', 'do_restore_list()');
+-
+-
+- unless ($list->{'admin'}{'status'} eq 'closed') {
+- &report::reject_report_web('user','not_closed',{},$param->{'action'},$list);
+- &wwslog('info','do_restore_list: list not closed');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'not_closed'});
+- return undef;
+- }
+-
+- ## Change status & save config
+- $list->{'admin'}{'status'} = 'open';
+- $list->save_config($param->{'user'}{'email'});
+-
+- if ($list->{'admin'}{'user_data_source'} eq 'file') {
+- $list->{'users'} = &List::_load_users_file("$list->{'dir'}/subscribers.closed.dump");
+- }elsif ($list->{'admin'}{'user_data_source'} =~ /^(database|include2)$/) {
+- unless (-f "$list->{'dir'}/subscribers.closed.dump") {
+- &wwslog('notice', 'No subscribers to restore');
+- &web_db_log({'status' => 'error',
+- 'error_type' => 'no_subscribers'});
+- }
+- my @users = &List::_load_users_file("$list->{'dir'}/subscribers.closed.dump");
+-
+- ## Insert users in database
+- foreach my $user (@users) {
+- $list->add_user($user);
+- }
+- }
+-
+- $list->savestats();
+-
+- my $aliases = &admin::install_aliases($list,$robot);
+- if ($aliases == 1) {
+- $param->{'auto_aliases'} = 1;
+- }else {
+- $param->{'aliases'} = $aliases;
+- $param->{'auto_aliases'} = 0;
+- }
+-
+- &report::notice_report_web('list_restored',{},$param->{'action'});
+- &web_db_log({'status' => 'success'});
+- return 'admin';
+- }
+-
+-
+- sub get_desc_file {
+- my $file = shift;
+- my $ligne;
+- my %hash;
+-
+- open DESC_FILE,"$file";
+-
+- while ($ligne = <DESC_FILE>) {
+- if ($ligne =~ /^title\s*$/) {
+- #case title of the document
+- while (($ligne = <DESC_FILE>) and ($ligne!~/^\s*$/)) {
+- $ligne =~ /^\s*(\S.*\S)\s*/;
+- $hash{'title'} = $hash{'title'}.$1." ";
+- }
+- }
+-
+-
+-
+- if ($ligne =~ /^creation\s*$/) {
+- #case creation of the document
+- while (($ligne = <DESC_FILE>) and ($ligne!~/^\s*$/)) {
+- if ($ligne =~ /^\s*email\s*(\S*)\s*/) {
+- $hash{'email'} = $1;
+- }
+- if ($ligne =~ /^\s*date_epoch\s*(\d*)\s*/) {
+- $hash{'date'} = $1;
+- }
+-
+- }
+- }
+-
+- if ($ligne =~ /^access\s*$/) {
+- #case access scenari for the document
+- while (($ligne = <DESC_FILE>) and ($ligne!~/^\s*$/)) {
+- if ($ligne =~ /^\s*read\s*(\S*)\s*/) {
+- $hash{'read'} = $1;
+- }
+- if ($ligne =~ /^\s*edit\s*(\S*)\s*/) {
+- $hash{'edit'} = $1;
+- }
+-
+- }
+- }
+-
+- }
+-
+-
+- close DESC_FILE;
+-
+- return %hash;
+-
+- }
+-
+-
+- sub show_cert {
+- return 1;
+- }
+-
+- ## Function synchronize
+- ## Return true if the file in parameter can be overwrited
+- ## false if it has changes since the parameter date_epoch
+- sub synchronize {
+- # args : 'path' , 'date_epoch'
+- my $path = shift;
+- my $date_epoch = shift;
+-
+- my @info = stat $path;
+-
+- return ($date_epoch == $info[9]);
+- }
+-
+-
+- #*******************************************
+- # Function : d_access_control
+- # Description : return a hash with privileges
+- # in read, edit, control
+- # if first parameter require
+- # it
+- #******************************************
+-
+- ## Regulars
+- # read(/) = default (config list)
+- # edit(/) = default (config list)
+- # control(/) = not defined
+-# read(A/B)= (read(A) && read(B)) ||
+- # (author(A) || author(B))
+- # edit = idem read
+- # control (A/B) : author(A) || author(B)
+- # + (set owner A/B) if (empty directory &&
+- # control A)
+-
+-
+- sub d_access_control {
+- # Arguments:
+- # (\%mode,$path)
+- # if mode->{'read'} control access only for read
+- # if mode->{'edit'} control access only for edit
+- # if mode->{'control'} control access only for control
+-
+- # return the hash (
+- # $result{'may'}{'read'} == $result{'may'}{'edit'} == $result{'may'}{'control'} if is_author else :
+- # $result{'may'}{'read'} = 0 or 1 (right or not)
+- # $result{'may'}{'edit'} = 0(not may edit) or 0.5(may edit with moderation) or 1(may edit ) : it is not a boolean anymore
+- # $result{'may'}{'control'} = 0 or 1 (right or not)
+- # $result{'reason'}{'read'} = string for authorization_reject.tt2 when may_read == 0
+- # $result{'reason'}{'edit'} = string for authorization_reject.tt2 when may_edit == 0
+- # $result{'scenario'}{'read'} = scenario name for the document
+- # $result{'scenario'}{'edit'} = scenario name for the document
+-
+-
+- # Result
+- my %result;
+- $result{'reason'} = {};
+-
+- # Control
+-
+- # Arguments
+- my $mode = shift;
+- my $path = shift;
+-
+- &wwslog('debug', "d_access_control(%s, %s)", join('/',%$mode), $path);
+-
+- my $mode_read = $mode->{'read'};
+- my $mode_edit = $mode->{'edit'};
+- my $mode_control = $mode->{'control'};
+-
+- # Useful parameters
+- my $list_name = $list->{'name'};
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+-
+- # document to read
+- my $doc;
+- if ($path) {
+- # the path must have no slash a its end
+- $path =~ /^(.*[^\/])?(\/*)$/;
+- $path = $1;
+- $doc = $shareddir.'/'.$path;
+- } else {
+- $doc = $shareddir;
+- }
+-
+- # Control for editing
+- my $may_read = 1;
+- my $why_not_read = '';
+- my $may_edit = 1;
+- my $why_not_edit = '';
+- my $is_author = 0; # <=> $may_control
+-
+- ## First check privileges on the root shared directory
+- $result{'scenario'}{'read'} = $list->{'admin'}{'shared_doc'}{'d_read'}{'name'};
+- $result{'scenario'}{'edit'} = $list->{'admin'}{'shared_doc'}{'d_edit'}{'name'};
+-
+- ## Privileged owner has all privileges
+- if ($param->{'is_privileged_owner'}) {
+- $result{'may'}{'read'} = 1;
+- $result{'may'}{'edit'} = 1;
+- $result{'may'}{'control'} = 1;
+- return %result;
+- }
+-
+- # if not privileged owner
+- if ($mode_read) {
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $action;
+- if (ref($result) eq 'HASH') {
+- $action = $result->{'action'};
+- $why_not_read = $result->{'reason'};
+- }
+-
+- $may_read = ($action =~ /do_it/i);
+- }
+-
+- if ($mode_edit) {
+- my $result = $list->check_list_authz('shared_doc.d_edit',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $action;
+- if (ref($result) eq 'HASH') {
+- $action = $result->{'action'};
+- $why_not_edit = $result->{'reason'};
+- }
+-
+- #edit = 0, 0.5 or 1
+- $may_edit = &find_edit_mode($action);
+- $why_not_edit = '' if ($may_edit);
+- }
+-
+- ## Only authenticated users can edit files
+- unless ($param->{'user'}{'email'}) {
+- $may_edit = 0;
+- $why_not_edit = 'not_authenticated';
+- }
+-
+-# if ($mode_control) {
+-# $result{'may'}{'control'} = 0;
+-# }
+-
+- my $current_path = $path;
+- my $current_document;
+- my %desc_hash;
+- my $user = $param->{'user'}{'email'} || 'nobody';
+-
+- while ($current_path ne "" && $current_path ne '/') {
+- # no description file found yet
+- my $def_desc_file = 0;
+- my $desc_file;
+-
+- $current_path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- $current_document = $3;
+- my $next_path = $1;
+-
+- # opening of the description file appropriated
+- if (-d $shareddir.'/'.$current_path) {
+- # case directory
+-
+- # unless ($slash) {
+- $current_path = $current_path.'/';
+- # }
+-
+- if (-e "$shareddir/$current_path.desc"){
+- $desc_file = $shareddir.'/'.$current_path.".desc";
+- $def_desc_file = 1;
+- }
+-
+- }else {
+- # case file
+- if (-e "$shareddir/$next_path.desc.$3"){
+- $desc_file = $shareddir.'/'.$next_path.".desc.".$3;
+- $def_desc_file = 1;
+- }
+- }
+-
+- if ($def_desc_file) {
+- # a description file was found
+- # loading of acces information
+-
+- %desc_hash = &get_desc_file($desc_file);
+-
+- if ($mode_read) {
+-
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario'=> $desc_hash{'read'}});
+- my $action;
+- if (ref($result) eq 'HASH') {
+- $action = $result->{'action'};
+- $why_not_read = $result->{'reason'};
+- }
+-
+- $may_read = $may_read && ( $action=~ /do_it/i);
+- $why_not_read = '' if ($may_read);
+- }
+-
+- if ($mode_edit) {
+- my $result = $list->check_list_authz('shared_doc.d_edit',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario'=> $desc_hash{'edit'}});
+- my $action_edit;
+- if (ref($result) eq 'HASH') {
+- $action_edit = $result->{'action'};
+- $why_not_edit = $result->{'reason'};
+- }
+-
+-
+- # $may_edit = 0, 0.5 or 1
+- my $may_action_edit = &find_edit_mode($action_edit);
+- $may_edit = &merge_edit($may_edit,$may_action_edit);
+- $why_not_edit = '' if ($may_edit);
+-
+-
+- }
+-
+- ## Only authenticated users can edit files
+- unless ($param->{'user'}{'email'}) {
+- $may_edit = 0;
+- $why_not_edit = 'not_authenticated';
+- }
+-
+- $is_author = $is_author || ($user eq $desc_hash{'email'});
+-
+- unless (defined $result{'scenario'}{'read'}) {
+- $result{'scenario'}{'read'} = $desc_hash{'read'};
+- $result{'scenario'}{'edit'} = $desc_hash{'edit'};
+- }
+-
+- ## Author has all privileges
+- if ($is_author) {
+- $result{'may'}{'read'} = 1;
+- $result{'may'}{'edit'} = 1;
+- $result{'may'}{'control'} = 1;
+- return %result;
+- }
+-
+- }
+-
+- # truncate the path for the while
+- $current_path = $next_path;
+- }
+-
+- if ($mode_read) {
+- $result{'may'}{'read'} = $may_read;
+- $result{'reason'}{'read'} = $why_not_read;
+- }
+-
+- if ($mode_edit) {
+- $result{'may'}{'edit'} = $may_edit;
+- $result{'reason'}{'edit'} = $why_not_edit;
+- }
+-
+-# if ($mode_control) {
+-# $result{'may'}{'control'} = 0;
+-# }
+-
+-
+-
+- return %result;
+- }
+-
+-## return the mode of editing included in $action : 0, 0.5 or 1
+-sub find_edit_mode{
+- my $action=shift;
+-
+- my $result;
+- if ($action =~ /editor/i){
+- $result = 0.5;
+- } elsif ($action =~ /do_it/i){
+- $result = 1;
+- } else {
+- $result = 0;
+- }
+- return $result;
+-}
+-
+-## return the mode of editing : 0, 0.5 or 1 :
+-# do the merging between 2 args of right access edit : "0" > "0.5" > "1"
+-# instead of a "and" between two booleans : the most restrictive right is
+-# imposed
+-sub merge_edit{
+- my $arg1=shift;
+- my $arg2=shift;
+- my $result;
+-
+- if ($arg1 == 0 || $arg2 == 0){
+- $result = 0;
+- }elsif ($arg1 == 0.5 || $arg2 == 0.5){
+- $result = 0.5;
+- }else {
+- $result = 1;
+- }
+- return $result;
+-}
+-
+-
+-
+-
+- # create the root shared document
+- sub do_d_admin {
+- &wwslog('info', 'do_d_admin(%s,%s)', $in{'list'}, $in{'d_admin'});
+-
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$in{'path'});
+-
+-
+- my $dir = $list->{'dir'};
+-
+- unless ($access{'may'}{'edit'}) {
+- &wwslog('info',"do_d_admin : permission denied for $param->{'user'}{'email'} ");
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- if ($in{'d_admin'} eq 'create') {
+-
+- unless ($list->create_shared()) {
+- &wwslog('info',"do_d_admin : could not create the shared");
+- &report::reject_report_web('intern','create_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- return 'd_read';
+-
+- }elsif($in{'d_admin'} eq 'restore') {
+- unless (-e "$dir/pending.shared") {
+- &wwslog('info',"do_d_admin : restore; $dir/pending.shared not found");
+- &report::reject_report_web('intern','restore_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- if (-e "$dir/shared") {
+- &wwslog('info',"do_d_admin : restore; $dir/shared already exist");
+- &report::reject_report_web('intern','restore_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- unless (rename ("$dir/pending.shared", "$dir/shared")){
+- &wwslog('info',"do_d_admin : restore; unable to rename $dir/pending.shared");
+- &report::reject_report_web('intern','restore_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+- return 'd_read';
+- }elsif($in{'d_admin'} eq 'delete') {
+- unless (-e "$dir/shared") {
+- &wwslog('info',"do_d_admin : restore; $dir/shared not found");
+- &report::reject_report_web('intern','delete_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- if (-e "$dir/pending.shared") {
+- &wwslog('info',"do_d_admin : delete ; $dir/pending.shared already exist");
+- &report::reject_report_web('intern','delete_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- unless (rename ("$dir/shared", "$dir/pending.shared")){
+- &wwslog('info',"do_d_admin : restore; unable to rename $dir/shared");
+- &report::reject_report_web('intern','delete_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+- return 'admin';
+- }
+-
+- # Function which sorts a hash of documents
+- # Sort by various parameters
+- sub by_order {
+- my $order = shift;
+- my $hash = shift;
+- # $order = 'order_by_size'/'order_by_doc'/'order_by_author'/'order_by_date'
+-
+- if ($order eq 'order_by_doc') {
+- $hash->{$a}{'doc'} cmp $hash->{$b}{'doc'}
+- or $hash->{$b}{'date_epoch'} <=> $hash->{$a}{'date_epoch'};
+- }
+- elsif ($order eq 'order_by_author') {
+- $hash->{$a}{'author'} cmp $hash->{$b}{'author'}
+- or $hash->{$b}{'date_epoch'} <=> $hash->{$a}{'date_epoch'};
+- }
+- elsif ($order eq 'order_by_size') {
+- $hash->{$a}{'size'} <=> $hash->{$b}{'size'}
+- or $hash->{$b}{'date_epoch'} <=> $hash->{$a}{'date_epoch'};
+- }
+- elsif ($order eq 'order_by_date') {
+- $hash->{$b}{'date_epoch'} <=> $hash->{$a}{'date_epoch'} or $a cmp $b;
+- }
+-
+- else {
+- $a cmp $b;
+- }
+- }
+-
+-
+- #*******************************************
+-# Function : do_d_read
+- # Description : reads a file or a directory
+- #******************************************
+-##
+-## Function do_d_read
+-sub do_d_read {
+- &wwslog('info', 'do_d_read(%s)', $in{'path'});
+-
+- ### Useful variables
+-
+- # current list / current shared directory
+- my $list_name = $list->{'name'};
+-
+- # relative path / directory shared of the document
+- my $path = &no_slash_end($in{'path'});
+-
+- # moderation
+- my $visible_path = &make_visible_path($path);
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- # document to read
+- my $doc;
+- if ($path) {
+- $doc = $shareddir.'/'.$path;
+- } else {
+- $doc = $shareddir;
+- }
+-
+- ### is list open ?
+- unless ($list->{'admin'}{'status'} eq 'open'){
+- &report::reject_report_web('user','list_not_open',{'status' => $list->{'admin'}{'status'}},$param->{'action'},$list);
+- &wwslog('err','d_read : access denied for %s because list is not open', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- ### Document exists ?
+- unless (-r "$doc") {
+- &wwslog('err',"do_d_read : unable to read $shareddir/$path : no such file or directory");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ### Document has non-size zero?
+- unless (-s "$doc") {
+- &wwslog('err',"do_d_read : unable to read $shareddir/$path : empty document");
+- &report::reject_report_web('user','empty_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ### Document isn't a description file
+- unless ($path !~ /\.desc/) {
+- &wwslog('err',"do_d_read : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ### Access control
+- my %mode;
+- $mode{'read'} = 1;
+- $mode{'edit'} = 1;
+- $mode{'control'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+- my $may_read = $access{'may'}{'read'};
+- unless ($may_read) {
+- &report::reject_report_web('auth',$access{'reason'}{'read'},{},$param->{'action'},$list);
+- &wwslog('err','d_read : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- my $may_edit = $access{'may'}{'edit'};
+- my $may_control = $access{'may'}{'control'};
+-
+-
+- ### File or directory ?
+-
+- if (!(-d $doc)) {
+- my @tokens = split /\//,$doc;
+- my $filename = $tokens[$#tokens];
+-
+- ## Jump to the URL
+- if ($filename =~ /^\..*\.(\w+)\.moderate$/) {
+- $param->{'file_extension'} = $1;
+- }elsif ($filename =~ /^.*\.(\w+)$/) {
+- $param->{'file_extension'} = $1;
+- }
+-
+- if ($param->{'file_extension'} eq 'url') {
+- open DOC, $doc;
+- my $url = <DOC>;
+- close DOC;
+- chomp $url;
+- $param->{'redirect_to'} = $url;
+- return 1;
+- }else {
+- # parameters for the template file
+- # view a file
+- $param->{'file'} = $doc;
+- $param->{'bypass'} = 1;
+- return 1;
+- }
+- }else { # directory
+- # verification of the URL (the path must have a slash at its end)
+- # if ($ENV{'PATH_INFO'} !~ /\/$/) {
+- # $param->{'redirect_to'} = "$param->{'base_url'}$param->{'path_cgi'}/d_read/$list_name/";
+- # return 1;
+- # }
+-
+- ## parameters of the current directory
+- if ($path && (-e "$doc/.desc")) {
+- my %desc_hash = &get_desc_file("$doc/.desc");
+- $param->{'doc_owner'} = $desc_hash{'email'};
+- $param->{'doc_title'} = $desc_hash{'title'};
+- }
+- my @info = stat $doc;
+- $param->{'doc_date'} = gettext_strftime "%d %b %Y", localtime($info[9]);
+-
+-
+- # listing of all the shared documents of the directory
+- unless (opendir DIR, "$doc") {
+- &report::reject_report_web('intern','cannot_open_dir',{'dir' => $doc },$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_read : cannot open $doc : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # array of entry of the directory DIR
+- my @tmpdir = readdir DIR;
+- closedir DIR;
+-
+- my $dir = &get_directory_content(\@tmpdir,$param->{'user'}{'email'},$list,$doc);
+-
+- # empty directory?
+- $param->{'empty'} = ($#{$dir} == -1);
+-
+- # subdirectories hash
+- my %subdirs;
+- # file hash
+- my %files;
+-
+- ## for the exception of index.html
+- # name of the file "index.html" if exists in the directory read
+- my $indexhtml;
+-
+- # boolean : one of the subdirectories or files inside
+- # can be edited -> normal mode of read -> d_read.tt2;
+- my $normal_mode;
+-
+-
+- my $path_doc;
+- my %desc_hash;
+- my $may, my $def_desc;
+- my $user = $param->{'user'}{'email'} || 'nobody';
+-
+- foreach my $d (@{$dir}) {
+-
+- # current document
+- my $path_doc = "$doc/$d";
+-
+- #case subdirectory
+- if (-d $path_doc) {
+-
+- # last update
+- my @info = stat $path_doc;
+-
+- if (-e "$path_doc/.desc") {
+-
+- # check access permission for reading
+- %desc_hash = &get_desc_file("$path_doc/.desc");
+-
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario' => $desc_hash{'read'}});
+- my $action;
+- $action = $result->{'action'} if (ref($result) eq 'HASH');
+-
+- if (($user eq $desc_hash{'email'}) || ($may_control) ||
+- ($action =~ /do_it/i)) {
+-
+- $subdirs{$d}{'date_epoch'} = $info[9];
+- $subdirs{$d}{'date'} = gettext_strftime "%d %b %Y", localtime($info[9]);
+-
+- # Case read authorized : fill the hash
+- $subdirs{$d}{'icon'} = $icon_table{'folder'};
+-
+- $subdirs{$d}{'doc'} = &make_visible_path($d);
+- $subdirs{$d}{'escaped_doc'} = &tools::escape_docname($d, '/');
+-
+- # size of the doc
+- $subdirs{$d}{'size'} = (-s $path_doc)/1000;
+-
+- # description
+- $subdirs{$d}{'title'} = $desc_hash{'title'};
+- $subdirs{$d}{'escaped_title'}=&tools::escape_html($desc_hash{'title'});
+-
+- # Author
+- if ($desc_hash{'email'}) {
+- $subdirs{$d}{'author'} = $desc_hash{'email'};
+- $subdirs{$d}{'author_mailto'} = &mailto($list,$desc_hash{'email'});
+- $subdirs{$d}{'author_known'} = 1;
+- }
+-
+- # if the file can be read, check for edit access & edit description files access
+- ## only authenticated users can edit a file
+-
+- if ($param->{'user'}{'email'}) {
+- my $result = $list->check_list_authz('shared_doc.d_edit',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario' => $desc_hash{'edit'}});
+- my $action_edit;
+- $action_edit = $result->{'action'} if (ref($result) eq 'HASH');
+- #may_action_edit = 0, 0.5 or 1
+- my $may_action_edit=&find_edit_mode($action_edit);
+- $may_action_edit=&merge_edit($may_action_edit,$may_edit);
+-
+- if ($may_control || ($user eq $desc_hash{'email'})){
+-
+- $subdirs{$d}{'edit'} = 1;# or = $may_action_edit ?
+- # if index.html, must know if something can be edit in the dir
+- $normal_mode = 1;
+- } elsif ($may_action_edit != 0) {
+- # $may_action_edit = 0.5 or 1
+- $subdirs{$d}{'edit'} = $may_action_edit;
+- # if index.html, must know if something can be edit in the dir
+- $normal_mode = 1;
+- }
+- }
+-
+- if ($may_control || ($user eq $desc_hash{'email'})) {
+- $subdirs{$d}{'control'} = 1;
+- }
+-
+- }
+- } else {
+- # no description file = no need to check access for read
+- # access for edit and control
+-
+- if ($may_control) {
+- $subdirs{$d}{'edit'} = 1; # or = $may_action_edit ?
+- $normal_mode = 1;
+- } elsif ($may_edit !=0) {
+- # $may_action_edit = 1 or 0.5
+- $subdirs{$d}{'edit'} = $may_edit;
+- $normal_mode = 1;
+- }
+-
+- if ($may_control) {$subdirs{$d}{'control'} = 1;}
+- }
+-
+- }else {
+- # case file
+- $may = 1;
+- $def_desc = 0;
+-
+- if (-e "$doc/.desc.$d") {
+- # a desc file was found
+- $def_desc = 1;
+-
+- # check access permission
+- %desc_hash = &get_desc_file("$doc/.desc.$d");
+-
+-
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario' => $desc_hash{'read'}});
+- my $action;
+- $action = $result->{'action'} if (ref($result) eq 'HASH');
+- unless (($user eq $desc_hash{'email'}) || ($may_control) ||
+- ($action =~ /do_it/i)) {
+- $may = 0;
+- }
+- }
+-
+- # if permission or no description file
+- if ($may) {
+- $path_doc =~ /^([^\/]*\/)*([^\/]+)\.([^\/]+)$/;
+-
+- ## Bookmark
+- if (($path_doc =~ /\.url$/) || ($path_doc =~ /\.url\.moderate$/)) {
+- open DOC, $path_doc;
+- my $url = <DOC>;
+- close DOC;
+- chomp $url;
+- $files{$d}{'url'} = $url;
+- $files{$d}{'anchor'} = &make_visible_path($d);
+- $files{$d}{'icon'} = $icon_table{'url'};
+-
+- ## MIME - TYPES : icons for template
+- }elsif (my $type = $mime_types->{$3}) {
+- # type of the file and apache icon
+- $type =~ /^([\w\-]+)\/([\w\-]+)$/;
+- my $mimet = $1;
+- my $subt = $2;
+- if ($subt) {
+- if ($subt =~ /^octet-stream$/) {
+- $mimet = 'octet-stream';
+- $subt = 'binary';
+- }
+- $files{$d}{'type'} = "$subt file";
+- }
+- $files{$d}{'icon'} = $icon_table{$mimet} || $icon_table{'unknown'};
+- } else {
+- # unknown file type
+- $files{$d}{'icon'} = $icon_table{'unknown'};
+- }
+-
+- ## case html
+- if ($3 =~ /^html?$/i) {
+- $files{$d}{'html'} = 1;
+- $files{$d}{'type'} = 'html file';
+- $files{$d}{'icon'} = $icon_table{'text'};
+- }
+- ## exception of index.html
+- if ($d =~ /^(index\.html?)$/i) {
+- $indexhtml = $1;
+- }
+-
+- ## Access control for edit and control
+- if ($def_desc) {
+- # check access for edit and control the file
+- ## Only authenticated users can edit files
+-
+- if ($param->{'user'}{'email'}) {
+- my $result= $list->check_list_authz('shared_doc.d_edit',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario' => $desc_hash{'edit'}});
+- my $action_edit;
+- $action_edit = $result->{'action'} if (ref($result) eq 'HASH');
+- #may_action_edit = 0, 0.5 or 1
+- my $may_action_edit=&find_edit_mode($action_edit);
+- $may_action_edit=&merge_edit($may_action_edit,$may_edit);
+-
+- if ($may_control || ($user eq $desc_hash{'email'})){
+- $normal_mode = 1;
+- $files{$d}{'edit'} = 1; # or = $may_action_edit ?
+- } elsif ($may_action_edit != 0){
+- # $may_action_edit = 1 or 0.5
+- $normal_mode = 1;
+- $files{$d}{'edit'} = $may_action_edit;
+- }
+-
+- if (($user eq $desc_hash{'email'}) || $may_control) {
+- $files{$d}{'control'} = 1;
+- }
+-
+- # fill the file hash
+- # description of the file
+- $files{$d}{'title'} = $desc_hash{'title'};
+- $files{$d}{'escaped_title'}=&tools::escape_html($desc_hash{'title'});
+- # author
+- if ($desc_hash{'email'}) {
+- $files{$d}{'author'} = $desc_hash{'email'};
+- $files{$d}{'author_known'} = 1;
+- $files{$d}{'author_mailto'} = &mailto($list,$desc_hash{'email'});
+- }
+- } else {
+- if ($may_edit!=0) {
+- $files{$d}{'edit'} = $may_edit ;
+- $normal_mode = 1;
+- }
+- if ($may_control) {$files{$d}{'control'} = 1;}
+- }
+-
+- # name of the file
+- if ($d =~ /^(\.).*(.moderate)$/) {
+- # file not yet moderated can be seen by its author
+- $files{$d}{'doc'} = &make_visible_path($d);
+- $files{$d}{'moderate'} = 1;
+- } else {
+- $files{$d}{'doc'} = &make_visible_path($d);
+- }
+- $files{$d}{'escaped_doc'} = &tools::escape_docname($d, '/');
+-
+- # last update
+- my @info = stat $path_doc;
+- $files{$d}{'date_epoch'} = $info[9];
+- $files{$d}{'date'} = gettext_strftime "%d %b %Y", localtime($info[9]);
+- # size
+- $files{$d}{'size'} = (-s $path_doc)/1000;
+- }
+- }
+- }
+-
+- }
+-
+- ### Exception : index.html
+- if ($indexhtml) {
+- unless ($normal_mode) {
+- $param->{'file_extension'} = 'html';
+- $param->{'bypass'} = 1;
+- $param->{'file'} = "$doc/$indexhtml";
+- return 1;
+- }
+- }
+-
+- ## to sort subdirs
+- my @sort_subdirs;
+- my $order = $in{'order'} || 'order_by_doc';
+- $param->{'order_by'} = $order;
+- foreach my $k (sort {by_order($order,\%subdirs)} keys %subdirs) {
+- push @sort_subdirs, $subdirs{$k};
+- }
+-
+- ## to sort files
+- my @sort_files;
+- foreach my $k (sort {by_order($order,\%files)} keys %files) {
+- push @sort_files, $files{$k};
+- }
+-
+- # parameters for the template file
+- $param->{'list'} = $list_name;
+-
+- $param->{'may_edit'} = $may_edit;
+- $param->{'may_control'} = $may_control;
+-
+- if ($path) {
+- # building of the parent directory path
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)$/) {
+- $param->{'father'} = $1;
+- }else {
+- $param->{'father'} = '';
+- }
+- $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
+-
+-
+- # Parameters for the description
+- if (-e "$doc/.desc") {
+- my @info = stat "$doc/.desc";
+- $param->{'serial_desc'} = $info[9];
+- my %desc_hash = &get_desc_file("$doc/.desc");
+- $param->{'description'} = $desc_hash{'title'};
+- }
+-
+- $param->{'path'} = $path;
+- $param->{'visible_path'} = $visible_path;
+- $param->{'escaped_path'} = &tools::escape_docname($param->{'path'}, '/');
+- }
+- if (scalar keys %subdirs) {
+- $param->{'sort_subdirs'} = \@sort_subdirs;
+- }
+- if (scalar keys %files) {
+- $param->{'sort_files'} = \@sort_files;
+- }
+- }
+- $param->{'father_icon'} = $icon_table{'father'};
+- $param->{'sort_icon'} = $icon_table{'sort'};
+-
+-
+- ## Show expert commands / user page
+-
+- # for the curent directory
+- if ($may_edit == 0 && $may_control == 0) {
+- $param->{'has_dir_rights'} = 0;
+- } else {
+- $param->{'has_dir_rights'} = 1;
+- if ($may_edit == 1) { # (is_author || ! moderated)
+- $param->{'total_edit'} = 1;
+- }
+- }
+-
+- # set the page mode
+- if ($in{'show_expert_page'} && $param->{'has_dir_rights'}) {
+- $session->{'shared_mode'}='expert';
+- if ($param->{'user'}{'prefs'}{'shared_mode'} ne 'expert') {
+- # update user pref as soon as connected user change shared mode
+- $param->{'user'}{'prefs'}{'shared_mode'} = 'expert';
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+- $param->{'expert_page'} = 1;
+-
+- } elsif ($in{'show_user_page'}) {
+- $session->{'shared_mode'}='basic';
+- if ($param->{'user'}{'prefs'}{'shared_mode'} ne 'basic') {
+- # update user pref as soon as connected user change shared mode
+- $param->{'user'}{'prefs'}{'shared_mode'} = 'basic';
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+- $param->{'expert_page'} = 0;
+- } else {
+- if ( $session->{'shared_mode'} eq 'expert' && $param->{'has_dir_rights'}) {
+- $param->{'expert_page'} = 1;
+- } else {
+- $param->{'expert_page'} = 0;
+- }
+- }
+-
+- #open TMP, ">/tmp/dump1";
+- #&tools::dump_var($param, 0,\*TMP);
+- #close TMP;
+-
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+-
+- return 1;
+-}
+-
+-## return a ref on an array of file (or subdirecties) to show to user
+-sub get_directory_content {
+- my $tmpdir = shift;
+- my $user = shift;
+- my $list = shift;
+- my $doc = shift;
+-
+- # array of file not hidden
+- my @dir = grep !/^\./, @$tmpdir;
+-
+- # array with documents not yet moderated
+- my @moderate_dir = grep (/(\.moderate)$/, @$tmpdir);
+- @moderate_dir = grep (!/^\.desc\./, @moderate_dir);
+-
+- # the editor can see file not yet moderated
+- # a user can see file not yet moderated if he is th owner of these files
+- if ($list->am_i('editor',$user)) {
+- push(@dir,@moderate_dir);
+- }else {
+- my @privatedir = &select_my_files($user,$doc,\@moderate_dir);
+- push(@dir,@privatedir);
+- }
+-
+- return \@dir;
+-}
+-
+-
+-## return an array that contains only file from @$refdir that belongs to $user
+-sub select_my_files {
+- my ($user,$path,$refdir)=@_;
+- my @new_dir;
+-
+- foreach my $d (@$refdir) {
+- if (-e "$path/.desc.$d") {
+- my %desc_hash = &get_desc_file("$path/.desc.$d");
+- if ($user eq $desc_hash{'email'}){
+- $new_dir[$#new_dir+1]=$d;
+- }
+- }
+- }
+- return @new_dir;
+-}
+-
+- ## Useful function to get off the slash at the end of the path
+- ## at its end
+- sub no_slash_end {
+- my $path = shift;
+-
+- ## supress ending '/'
+- $path =~ s/\/+$//;
+-
+- return $path;
+- }
+-
+-## return a visible path from a moderated file or not
+-sub make_visible_path {
+- my $path = shift;
+-
+- my $visible_path = $path;
+-
+- if ($path =~ /\.url(\.moderate)?$/){
+- if ($path =~ /^([^\/]*\/)*([^\/]+)\.([^\/]+)$/) {
+- $visible_path =~ s/\.moderate$//;
+- $visible_path =~ s/^\.//;
+- $visible_path =~ s/\.url$//;
+- }
+-
+- }elsif ($path =~ /\.moderate$/){
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
+- my $name = $3;
+- $name =~ s/^\.//;
+- $name =~ s/\.moderate//;
+- $visible_path = "$2"."$name";
+- }
+- }
+-
+- ## Qdecode the visible path
+- return &tools::qdecode_filename($visible_path);
+-}
+-
+-
+- ## Access to latest shared documents
+-sub do_latest_d_read {
+- &wwslog('info', 'do_latest_d_read(%s,%s,%s)', $in{'list'}, $in{'for'}, $in{'count'});
+-
+- ### is list open ?
+- unless ($list->{'admin'}{'status'} eq 'open'){
+- &report::reject_report_web('user','list_not_open',{'status' => $list->{'admin'}{'status'}},$param->{'action'},$list);
+- &wwslog('err','d_latest_d_read : access denied for %s because list is not open', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- ### shared exist ?
+- my $shareddir = $list->{'dir'}.'/shared';
+- unless (-r "$shareddir") {
+- &wwslog('err',"do_latest_d_read : unable to read $shareddir : no such file or directory");
+- &report::reject_report_web('user','no_shared',{},$param->{'action'},$list);
+- return undef;
+- }
+-
+- ### Document has non-size zero?
+- unless (-s "$shareddir") {
+- &wwslog('err',"do_latest_d_read : unable to read $shareddir : empty document");
+- &report::reject_report_web('user','shared_empty',{},$param->{'action'},$list);
+- return undef;
+- }
+-
+- ### Access control
+- my %mode;
+- $mode{'read'} = 1;
+- $mode{'control'} = 1;
+-
+- my %access = &d_access_control(\%mode,$shareddir);
+- unless ($access{'may'}{'read'}) {
+- &report::reject_report_web('auth',$access{'reason'}{'read'},{},$param->{'action'},$list);
+- &wwslog('err','latest_d_read : access denied for %s', $param->{'user'}{'email'});
+- return undef;
+- }
+-
+- ## parameters of the query
+- my $today = time;
+-
+- my $oldest_day;
+- if (defined $in{'for'}) {
+- $oldest_day = $today - (86400 * ($in{'for'}));
+- $param->{'for'} = $in{'for'};
+- unless ($oldest_day >= 0){
+- &report::reject_report_web('user','nb_days_to_much',{'nb_days' => $in{'for'} },$param->{'action'},$list);
+- &wwslog('err','do_latest_d_read: parameter "for" is too big"');
+- }
+- }
+-
+- my $nb_doc;
+- my $NB_DOC_MAX = 100;
+- if (defined $in{'count'}) {
+- if ($in{'count'} > $NB_DOC_MAX) {
+- $in{'count'} = $NB_DOC_MAX;
+- }
+- $param->{'count'} = $in{'count'};
+- $nb_doc = $in{'count'};
+- } else {
+- $nb_doc = $NB_DOC_MAX;
+- }
+-
+- my $documents;
+- unless ($documents = &directory_browsing('',$oldest_day,$access{'may'}{'control'})) {
+- &wwslog('err',"do_d_latest_d_read($list) : impossible to browse shared");
+- &report::reject_report_web('intern','browse_shared',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- return undef;
+- }
+-
+- @$documents = sort ({$b->{'date_epoch'} <=> $a->{'date_epoch'}} @$documents);
+-
+- @{$param->{'documents'}} = splice(@$documents,0,$nb_doc);
+-
+- return 1;
+- }
+-
+-## browse a directory recursively and return documents younger than $oldest_day
+- sub directory_browsing {
+- my ($dir,$oldest_day,$may_control) = @_;
+- &wwslog('debug2',"directory_browsing($dir,$oldest_day)");
+-
+- my @result;
+- my $shareddir = $list->{'dir'}.'/shared';
+- my $path_dir = "$shareddir/$dir";
+-
+- ## listing of all the shared documents of the directory
+- unless (opendir DIR, "$path_dir") {
+- &wwslog('err',"directory_browsing($dir) : cannot open the directory : $!");
+- return undef;
+- }
+-
+- my @tmpdir = readdir DIR;
+- closedir DIR;
+-
+- # array of file not hidden
+- my @directory = grep !/^\./, @tmpdir;
+-
+- my $user = $param->{'user'}{'email'} || 'nobody';
+-
+- ## browsing
+- foreach my $d (@directory) {
+- my $path_d = "$path_dir/$d";
+-
+- #case subdirectory
+- if (-d $path_d) {
+- if (-e "$path_d/.desc") {
+- # check access permission for reading
+- my %desc_hash = &get_desc_file("$path_d/.desc");
+-
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario' => $desc_hash{'read'}});
+- my $action;
+- $action = $result->{'action'} if (ref($result) eq 'HASH');
+- if (($user eq $desc_hash{'email'}) || ($may_control) ||
+- ($action =~ /do_it/i)) {
+- my $content_d;
+- unless($content_d = &directory_browsing("$dir/$d",$oldest_day)) {
+- &wwslog('err',"directory_browsing($dir) : impossible to browse subdirectory $d");
+- next;
+- }
+- if (ref($content_d) eq "ARRAY") {
+- push @result,@$content_d;
+- }
+- }
+- }
+-
+- #case file
+- } else {
+-
+- my %file_info;
+-
+- ## last update
+- my @info = stat $path_d;
+- $file_info{'date_epoch'} = $info[9];
+-
+- if ($file_info{'date_epoch'} < $oldest_day) {
+- next;
+- }
+-
+- $file_info{'last_update'} = gettext_strftime "%d %b %Y", localtime($info[9]);
+-
+- ## exception of index.html
+- if ($d =~ /^(index\.html?)$/i) {
+- next;
+- }
+-
+- my $may = 1;
+- my $def_desc = 0;
+- my %desc_hash;
+-
+- if (-e "$path_dir/.desc.$d") {
+- # a desc file was found
+- $def_desc = 1;
+-
+- # check access permission
+- %desc_hash = &get_desc_file("$path_dir/.desc.$d");
+-
+- my $result = $list->check_list_authz('shared_doc.d_read',$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'},
+- 'scenario' => $desc_hash{'read'}});
+- my $action;
+- $action = $result->{'action'} if (ref($result) eq 'HASH');
+- unless (($user eq $desc_hash{'email'}) || ($may_control) ||
+- ($action =~ /do_it/i)) {
+- $may = 0;
+- }
+- }
+-
+- # if permission or no description file
+- if ($may) {
+- $path_d =~ /^([^\/]*\/)*([^\/]+)\.([^\/]+)$/;
+-
+- ## Bookmark
+- if ($path_d =~ /\.url$/) {
+- open DOC, $path_d;
+- my $url = <DOC>;
+- close DOC;
+- chomp $url;
+- $file_info{'url'} = $url;
+- $file_info{'anchor'} = &make_visible_path($d);
+- $file_info{'icon'} = $icon_table{'url'};
+-
+- ## MIME - TYPES : icons for template
+- }elsif (my $type = $mime_types->{$3}) {
+- # type of the file and apache icon
+- $type =~ /^([\w\-]+)\/([\w\-]+)$/;
+- my $mimet = $1;
+- my $subt = $2;
+- if ($subt) {
+- if ($subt =~ /^octet-stream$/) {
+- $mimet = 'octet-stream';
+- $subt = 'binary';
+- }
+- }
+- $file_info{'icon'} = $icon_table{$mimet} || $icon_table{'unknown'};
+-
+- ## UNKNOWN FILE TYPE
+- } else {
+- $file_info{'icon'} = $icon_table{'unknown'};
+- }
+-
+- ## case html
+- if ($3 =~ /^html?$/i) {
+- $file_info{'html'} = 1;
+- $file_info{'icon'} = $icon_table{'text'};
+- }
+-
+- ## name of the file
+- $file_info{'name'} = &make_visible_path($d);
+- $file_info{'escaped_name'} = &tools::escape_docname($d, '/');
+-
+- ## content_directory
+- if ($dir) {
+- $file_info{'content_dir'} = &make_visible_path($dir);
+- } else {
+- $file_info{'content_dir'} = "/";
+- }
+- $file_info{'escaped_content_dir'} = &tools::escape_docname($dir,'/');
+-
+- if ($def_desc) {
+- ## description
+- $file_info{'title'} = $desc_hash{'title'};
+- $file_info{'escaped_title'}=&tools::escape_html($desc_hash{'title'});
+-
+- ## author
+- if ($desc_hash{'email'}) {
+- $file_info{'author'} = $desc_hash{'email'};
+- }
+- }
+-
+- push @result,\%file_info;
+- }
+- } # else (file)
+-
+- } # foreach
+-
+- return \@result;
+-
+- }
+-
+- #*******************************************
+- # Function : do_d_editfile
+- # Description : prepares the parameters to
+- # edit a file
+- #*******************************************
+-
+- sub do_d_editfile {
+- &wwslog('info', 'do_d_editfile(%s)', $in{'path'});
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+-
+- my $list_name = $list->{'name'};
+- my $shareddir = $list->{'dir'}.'/shared';
+- my $visible_path = &make_visible_path($path);
+-
+- $param->{'directory'} = -d "$shareddir/$path";
+-
+- # Control
+-
+- unless ($path) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'file name'},$param->{'action'});
+- &wwslog('err','do_d_editfile: no file name');
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return undef;
+- }
+-
+- # Existing document? File?
+- unless (-w "$shareddir/$path") {
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('err',"d_editfile : Cannot edit $shareddir/$path : not an existing file");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'no_file'});
+- return undef;
+- }
+-
+- ### Document isn't a description file?
+- unless ($path !~ /\.desc/) {
+- &wwslog('err',"do_editfile : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- if (($path =~ /\.url$/) ||($path =~ /^\..+\.url.moderate$/)) {
+- ## Get URL of bookmark
+- open URL, "$shareddir/$path";
+- my $url = <URL>;
+- close URL;
+- chomp $url;
+-
+- $param->{'url'} = $url;
+- $visible_path =~ s/\.url$//;
+- }
+-
+- ### is list open ?
+- unless ($list->{'admin'}{'status'} eq 'open'){
+- &report::reject_report_web('user','list_not_open',{'status' => $list->{'admin'}{'status'}},$param->{'action'},$list);
+- &wwslog('err','d_edit : access denied for %s because list is not open', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+- my $may_edit = $access{'may'}{'edit'};
+-
+- unless ($may_edit > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','d_editfile : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'autorization'});
+- return undef;
+- }
+-
+- ## End of controls
+-
+- $param->{'list'} = $list_name;
+- $param->{'path'} = $path;
+- $param->{'visible_path'} = $visible_path;
+-
+- # test if it's a text file
+- if (-T "$shareddir/$path") {
+- $param->{'textfile'} = 1;
+- $param->{'filepath'} = "$shareddir/$path";
+- } else {
+- $param->{'textfile'} = 0;
+- }
+- $param->{'use_htmlarea'} = '1' if (($wwsconf->{'htmlarea_url'}) and ($param->{'textfile'}) and ($path =~ /\.html?/));
+-
+-
+-
+- #Current directory
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
+- $param->{'father'} = $1;
+- }else {
+- $param->{'father'} = '';
+- }
+- $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
+-
+- # Description of the file
+- my $descfile;
+- if (-d "$shareddir/$path") {
+- $descfile = "$shareddir/$1$3/.desc";
+- }else {
+- $descfile = "$shareddir/$1.desc.$3";
+- }
+-
+- if (-e $descfile) {
+- my %desc_hash = &get_desc_file($descfile);
+- $param->{'desc'} = $desc_hash{'title'};
+- $param->{'doc_owner'} = $desc_hash{'email'};
+- ## Synchronization
+- my @info = stat $descfile;
+- $param->{'serial_desc'} = $info[9];
+- }
+-
+- ## Synchronization
+- my @info = stat "$shareddir/$path";
+- $param->{'serial_file'} = $info[9];
+- ## parameters of the current directory
+- $param->{'doc_date'} = gettext_strftime "%d %b %y %H:%M", localtime($info[9]);
+-
+- &tt2::allow_absolute_path();
+-
+- $param->{'father_icon'} = $icon_table{'father'};
+-
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+-
+- return 1;
+- }
+-
+- #*******************************************
+- # Function : do_d_properties
+- # Description : prepares the parameters to
+- # change a file properties
+- #*******************************************
+-
+- sub do_d_properties {
+- &wwslog('info', 'do_d_properties(%s)', $in{'path'});
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+-
+- my $list_name = $list->{'name'};
+- my $shareddir = $list->{'dir'}.'/shared';
+- my $visible_path = &make_visible_path($path);
+-
+- $param->{'directory'} = -d "$shareddir/$path";
+-
+- # Control
+-
+- unless ($path) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'filename'},$param->{'action'});
+- &wwslog('err','do_d_properties: no file name');
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'no_file'});
+- return undef;
+- }
+-
+- # Existing document? File?
+- unless (-w "$shareddir/$path") {
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('err',"do_d_properties : Cannot edit $shareddir/$path : not an existing file");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'no_file'});
+- return undef;
+- }
+-
+- ### Document isn't a description file?
+- unless ($path !~ /\.desc/) {
+- &wwslog('err',"do_d_properties : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- if ($path =~ /\.url$/) {
+- ## Get URL of bookmark
+- open URL, "$shareddir/$path";
+- my $url = <URL>;
+- close URL;
+- chomp $url;
+-
+- $param->{'url'} = $url;
+- }
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+- my $may_edit = $access{'may'}{'edit'};
+-
+- unless ($may_edit > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_properties : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- ## End of controls
+-
+- $param->{'list'} = $list_name;
+- $param->{'path'} = $path;
+- $param->{'visible_path'} = $visible_path;
+-
+- # test if it's a text file
+- if (-T "$shareddir/$path") {
+- $param->{'textfile'} = 1;
+- $param->{'filepath'} = "$shareddir/$path";
+- } else {
+- $param->{'textfile'} = 0;
+- }
+- $param->{'use_htmlarea'} = '1' if (($wwsconf->{'htmlarea_url'}) and ($param->{'textfile'}) and ($path =~ /\.html?/));
+-
+-
+-
+- #Current directory
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
+- $param->{'father'} = $1;
+- }else {
+- $param->{'father'} = '';
+- }
+- $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
+-
+- $param->{'fname'} = &make_visible_path($3);
+- # Description of the file
+- my $descfile;
+- if (-d "$shareddir/$path") {
+- $descfile = "$shareddir/$1$3/.desc";
+- }else {
+- $descfile = "$shareddir/$1.desc.$3";
+- }
+-
+- if (-e $descfile) {
+- my %desc_hash = &get_desc_file($descfile);
+- $param->{'desc'} = $desc_hash{'title'};
+- $param->{'doc_owner'} = $desc_hash{'email'};
+- ## Synchronization
+- my @info = stat $descfile;
+- $param->{'serial_desc'} = $info[9];
+- }
+-
+- ## Synchronization
+- my @info = stat "$shareddir/$path";
+- $param->{'serial_file'} = $info[9];
+- ## parameters of the current directory
+- $param->{'doc_date'} = gettext_strftime "%d %b %y %H:%M", localtime($info[9]);
+-
+- &tt2::allow_absolute_path();
+-
+- $param->{'father_icon'} = $icon_table{'father'};
+-
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+-
+- return 1;
+- }
+-
+- #*******************************************
+- # Function : do_d_describe
+- # Description : Saves the description of
+- # the file
+- #******************************************
+-
+- sub do_d_describe {
+- &wwslog('info', 'do_d_describe(%s)', $in{'path'});
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+- my $visible_path=&make_visible_path($path);
+- my $list_name = $list->{'name'};
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #### Controls
+-
+- ### Document isn't a description file?
+- unless ($path !~ /\.desc/) {
+- &wwslog('info',"do_d_describe : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## the path must not be empty (the description file of the shared directory
+- # doesn't exist)
+- unless ($path) {
+- &report::reject_report_web('intern','cannot_describe_shared_directory',{'path' => $path },$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"d_describe : Cannot describe $shareddir : root directory");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # the file to describe must already exist
+- unless (-e "$shareddir/$path") {
+- &report::reject_report_web('user','no_doc_to_describe',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('info',"d_describe : Unable to describe $shareddir/$path : not an existing document");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'no_file'});
+- return undef;in{'shortname'}
+- }
+-
+- # Access control
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'edit'} > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('info','d_describe : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+-
+- ## End of controls
+-
+- if ($in{'content'} !~ /^\s*$/) {
+-
+- # Description file
+- $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- my $dir = $1;
+- my $file = $3;
+-
+- my $desc_file;
+- if (-d "$shareddir/$path") {
+- $desc_file = "$shareddir/$dir$file/.desc";
+- } else {
+- $desc_file = "$shareddir/$dir.desc.$file";
+- }
+-
+- if (-r "$desc_file"){
+- # if description file already exists : open it and modify it
+- my %desc_hash = &get_desc_file ("$desc_file");
+-
+- # Synchronization
+- unless (&synchronize($desc_file,$in{'serial'})){
+- &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
+- &wwslog('info',"d_describe : Synchronization failed for $desc_file");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # fill the description file
+- unless (open DESC,">$desc_file") {
+- &wwslog('info',"do_d_describe : cannot open $desc_file : $!");
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # information modified
+- print DESC "title\n $in{'content'}\n\n";
+- # information not modified
+- print DESC "access\n read $desc_hash{'read'}\n edit $desc_hash{'edit'}\n\n";
+- print DESC "creation\n";
+- # time
+- print DESC " date_epoch $desc_hash{'date'}\n";
+- # author
+- print DESC " email $desc_hash{'email'}\n\n";
+-
+- close DESC;
+-
+- } else {
+- # Creation of a description file
+- unless (open (DESC,">$desc_file")) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"d_describe : Cannot create description file $desc_file : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- # fill
+- # description
+- print DESC "title\n $in{'content'}\n\n";
+- # date and author
+- my @info = stat "$shareddir/$path";
+- print DESC "creation\n date_epoch ".$info[10]."\n email\n\n";
+- # access rights
+- print DESC "access\n";
+- print DESC " read $access{'scenario'}{'read'}\n";
+- print DESC " edit $access{'scenario'}{'edit'}\n\n";
+-
+- close DESC;
+-
+- }
+-
+- $in{'path'} = &no_slash_end($dir);
+- }
+-
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+-
+- return 'd_read';
+-
+- }
+-
+- #*******************************************
+- # Function : do_d_savefile
+- # Description : Saves a file edited in a
+- # text area
+- #******************************************
+-
+-sub do_d_savefile {
+- &wwslog('info', 'do_d_savefile(%s)', $in{'path'});
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+-
+- if ($in{'url'} &&
+- $in{'previous_action'} eq 'd_read') {
+- $path .= '/'.$in{'name_doc'} . '.url';
+- }
+-
+-
+- my $visible_path = &make_visible_path($path);
+-
+- my $moderated;
+- if ($visible_path ne $path) {
+- $moderated = 1;
+- }
+-
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+-
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #### Controls
+-
+- my $creation = 1 unless (-f "$shareddir/$path");
+-
+- ### Document isn't a description file
+- unless ($path !~ /\.desc/) {
+- &wwslog('err',"do_d_savefile : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'edit'} > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_savefile : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+- #### End of controls
+-
+- if (($in{'content'} =~ /^\s*$/) && ($in{'url'} =~ /^\s*$/)) {
+- &report::reject_report_web('user','no_content',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_savefile : Cannot save file $shareddir/$path : no content");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'missing_parameter'});
+- return undef;
+- }
+-
+- # Synchronization
+- unless ($in{'url'}) { # only for files
+- unless (&synchronize("$shareddir/$path",$in{'serial'})){
+- &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_savefile : Synchronization failed for $shareddir/$path");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- }
+-
+- # Renaming of the old file
+-############""" pas les url ?
+- rename ("$shareddir/$path","$shareddir/$path.old")
+- unless ($creation);
+-
+- my $dir;
+- my $file;
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/){
+- $dir = $1;
+- $file = $3;
+- }
+-
+- if ($in{'url'}) {
+-##############
+-# if ($access{'may'}{'edit'} == 0.5) {
+-# open URL, ">$shareddir/$dir.$file.moderate";
+-# }else {
+- open URL, ">$shareddir/$path";
+-# }
+- print URL "$in{'url'}\n";
+- close URL;
+- }else {
+- # Creation of the shared file
+- unless (open FILE, ">$shareddir/$path") {
+- rename("$shareddir/$path.old","$shareddir/$path");
+- &report::reject_report_web('user','cannot_overwrite', {'reason' => $1,
+- 'path' => $visible_path }
+- ,$param->{'action'},$list);
+- &wwslog('err',"do_d_savefile : Cannot open for replace $shareddir/$path : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- print FILE $in{'content'};
+- close FILE;
+- }
+-
+- unlink "$shareddir/$path.old";
+-
+- # Description file
+- if (-e "$shareddir/$dir.desc.$file"){
+-
+- # if description file already exists : open it and modify it
+- my %desc_hash = &get_desc_file ("$shareddir/$dir.desc.$file");
+-
+- open DESC,">$shareddir/$dir.desc.$file";
+-
+- # information not modified
+- print DESC "title\n $desc_hash{'title'}\n\n";
+- print DESC "access\n read $desc_hash{'read'}\n edit $desc_hash{'edit'}\n\n";
+- print DESC "creation\n";
+- # date
+- print DESC ' date_epoch '.$desc_hash{'date'}."\n";
+-
+- # information modified
+- # author
+- print DESC " email $param->{'user'}{'email'}\n\n";
+-
+- close DESC;
+-
+- } else {
+- # Creation of a description file if author is known
+-
+- unless (open (DESC,">$shareddir/$dir.desc.$file")) {
+- &wwslog('info',"do_d_savefile: cannot create description file $shareddir/$dir.desc.$file");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- }
+- # description
+- print DESC "title\n \n\n";
+- # date of creation and author
+- my @info = stat "$shareddir/$path";
+- print DESC "creation\n date_epoch ".$info[10]."\n email $param->{'user'}{'email'}\n\n";
+- # Access
+- print DESC "access\n";
+- print DESC " read $access{'scenario'}{'read'}\n";
+- print DESC " edit $access{'scenario'}{'edit'}\n\n";
+-
+- close DESC;
+- }
+-
+- # shared_moderated
+-#######################
+- if (($access{'may'}{'edit'} == 0.5) && ($creation)) {
+-
+- unless (rename "$shareddir/$path","$shareddir/$dir.$file.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$path",
+- 'new'=>"$shareddir/$dir.$file.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_savefile : Failed to rename $path to $dir.$file.moderate : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- }
+- unless (rename "$shareddir/$dir.desc.$file","$shareddir/$dir.desc..$file.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$dir.desc.$file",
+- 'new'=>"$shareddir/$dir.desc..$file.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_savefile : Failed to rename $dir.desc.$file to $dir.desc..$file.moderate : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- }
+-
+- if (!$in{'url'}){
+- $in{'path'}=$path;
+- $param->{'path'}=$path;
+- }else {
+- $visible_path = $file;
+- $visible_path =~ s/\.url$//
+- }
+-
+- unless ($list->send_notify_to_editor('shared_moderated',{'filename' => $visible_path,
+- 'who' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
+- }
+-
+- &report::notice_report_web('to_moderate', {'path' => $visible_path},$param->{'action'});
+- }
+-
+- &report::notice_report_web('save_success', {'path' => $visible_path},$param->{'action'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+- if ($in{'previous_action'}) {
+- return $in{'previous_action'};
+- }else {
+- $in{'path'} =~ s/([^\/]+)$//;
+- $param->{'path'} =~ s/([^\/]+)$//;
+- return 'd_read';
+- }
+- }
+-
+- #*******************************************
+- # Function : do_d_overwrite
+- # Description : Overwrites a file with a
+- # uploaded file
+- #******************************************
+-
+- sub do_d_overwrite {
+- &wwslog('info', 'do_d_overwrite(%s)', $in{'path'});
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+-
+- my $visible_path = &make_visible_path($path);
+-
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- # Parameters of the uploaded file
+- my $fh = $query->upload('uploaded_file');
+- my $fn = $query->param('uploaded_file');
+-
+- # name of the file
+- my $fname;
+- if ($fn =~ /([^\/\\]+)$/) {
+- $fname = $1;
+- }
+-
+- ### uploaded file must have a name
+- unless ($fname) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'file name'},$param->{'action'});
+- &wwslog('info',"do_d_overwrite : No file specified to overwrite");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'no_file'});
+- return undef;
+- }
+-
+- ####### Controls
+-
+- ### Document isn't a description file?
+- unless ($path !~ /\.desc/) {
+- &wwslog('err',"do_d_overwrite : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # the path to replace must already exist
+- unless (-e "$shareddir/$path") {
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('err',"do_d_overwrite : Unable to overwrite $shareddir/$path : not an existing file");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'no_file'});
+- return undef;
+- }
+-
+- # the path must represent a file
+- if (-d "$shareddir/$path") {
+- &report::reject_report_web('user','doc_already_a_dir',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('err',"do_d_overwrite : Unable to create $shareddir/$path : a directory named $path already exists");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'already_exists'});
+- return undef;
+- }
+-
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'edit'} > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_overwrite : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+- #### End of controls
+-
+- # Synchronization
+- unless (&synchronize("$shareddir/$path",$in{'serial'})){
+- &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_overwrite : Synchronization failed for $shareddir/$path");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- # Renaming of the old file
+- rename ("$shareddir/$path","$shareddir/$path.old");
+-
+- # Creation of the shared file
+- unless (open FILE, ">:bytes", "$shareddir/$path") {
+- &report::reject_report_web('user','cannot_overwrite', {'reason' => $!,
+- 'path' => $visible_path }
+- ,$param->{'action'},$list);
+- &wwslog('err',"d_overwrite : Cannot open for replace $shareddir/$path : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'cannot_overwrite'});
+- return undef;
+- }
+- while (<$fh>) {
+- print FILE;
+- }
+- close FILE;
+-
+- # Description file
+- my ($dir, $file);
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
+- $dir = $1;
+- $file = $3;
+- }
+-
+- if (-e "$shareddir/$dir.desc.$file"){
+- # if description file already exists: open it and modify it
+- my %desc_hash = &get_desc_file ("$shareddir/$dir.desc.$file");
+-
+- open DESC,">$shareddir/$dir.desc.$file";
+-
+- # information not modified
+- print DESC "title\n $desc_hash{'title'}\n\n";
+- print DESC "access\n read $desc_hash{'read'}\n edit $desc_hash{'edit'}\n\n";
+- print DESC "creation\n";
+- # time
+- print DESC " date_epoch $desc_hash{'date'}\n";
+- # information modified
+- # author
+- print DESC " email $param->{'user'}{'email'}\n\n";
+-
+- close DESC;
+- } else {
+- # Creation of a description file
+- unless (open (DESC,">$shareddir/$dir.desc.$file")) {
+- &wwslog('info',"do_d_overwrite : Cannot create description file $shareddir/$dir.desc.$file");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- # description
+- print DESC "title\n \n\n";
+- # date of creation and author
+- my @info = stat "$shareddir/$path";
+- print DESC "creation\n date_epoch ".$info[10]."\n email $param->{'user'}{'email'}\n\n";
+- # access rights
+- print DESC "access\n";
+- print DESC " read $access{'scenario'}{'read'}\n";
+- print DESC " edit $access{'scenario'}{'edit'}\n\n";
+-
+- close DESC;
+-
+- }
+-
+- # shared_moderated
+- if (($access{'may'}{'edit'} == 0.5) && ($path eq $visible_path)) {
+- unless (rename "$shareddir/$path","$shareddir/$dir.$file.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$path",
+- 'new'=>"$shareddir/$dir.$file.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_overwrite : Failed to rename $path to $dir.$file.moderate : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+- unless (rename "$shareddir/$dir.desc.$file","$shareddir/$dir.desc..$file.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$dir.desc.$file",
+- 'new'=>"$shareddir/$dir.desc..$file.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_overwrite : Failed to rename $dir.desc.$file to $dir.desc..$file.moderate : $!");
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- }
+- unless ($list->send_notify_to_editor('shared_moderated',{'filename' => $visible_path,
+- 'who' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
+- }
+- $in{'path'}="$dir.$file.moderate";
+- &report::notice_report_web('to_moderate',{'path' => $visible_path},$param->{'action'});
+- }
+-
+- # Removing of the old file
+- unlink "$shareddir/$path.old";
+-
+- $in{'list'} = $list_name;
+- #$in{'path'} = $dir;
+-
+- # message of success
+- &report::notice_report_web('upload_success', {'path' => $visible_path});
+- &web_db_log({'parameters' => $in{'path'},
+- 'status' => 'success'});
+- return 'd_editfile';
+- }
+-
+- #*******************************************
+- # Function : do_d_upload
+- # Description : Creates a new file with a
+- # uploaded file
+-#******************************************
+-
+- sub do_d_upload {
+- # Parameters of the uploaded file (from d_read.tt2)
+- my $fn = $in{'uploaded_file'};
+-
+- # name of the file, without path
+- my ($fname, $visible_fname);
+- if ($fn =~ /([^\/\\]+)$/) {
+- $fname = &tools::qencode_filename($1);
+- $visible_fname = &make_visible_path($fname);
+- }
+-
+- # param from d_upload.tt2
+- if ($in{'shortname'}){
+- $fname = $in{'shortname'};
+- }
+- &wwslog('info', 'do_d_upload(%s/%s)', $in{'path'},$fname);
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+- my $visible_path = &make_visible_path($path);
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- # name of the file
+- my $longname = "$shareddir/$path/$fname";
+- $longname =~ s/\/+/\//g;
+-
+-# ## $path must have a slash at its end
+-# $path = &format_path('with_slash',$path);
+-
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+-
+-
+- ## Controls
+-
+- # uploaded file must have a name
+- unless ($fname) {
+- &report::reject_report_web('user','no_name',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : No file specified to upload");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## Check quota
+- if ($list->{'admin'}{'shared_doc'}{'quota'}) {
+- if ($list->get_shared_size() >= $list->{'admin'}{'shared_doc'}{'quota'} * 1024){
+- &report::reject_report_web('user','shared_full',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : Shared Quota exceeded for list $list->{'name'}");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'shared_full','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- # The name of the file must be correct and musn't not be a description file
+- if ($fname =~ /^\./
+- || $fname =~ /\.desc/
+- || $fname =~ /[~\#\[\]]$/) {
+-
+- # unless ($fname =~ /^\w/ and
+- # $fname =~ /\w$/ and
+- # $fname =~ /^[\w\-\.]+$/ and
+- # $fname !~ /\.desc/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => $fname},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : Unable to create file $fname : incorrect name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # the file must be uploaded in a directory existing
+- unless (-d "$shareddir/$path") {
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : $shareddir/$path : not a directory");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Access control for the directory where there is the uploading
+- my %mode;
+- $mode{'edit'} = 1;
+- $mode{'control'} = 1; # for the exception index.html
+- my %access_dir = &d_access_control(\%mode,$path);
+-
+- if ($access_dir{'may'}{'edit'} == 0) {
+- &report::reject_report_web('auth',$access_dir{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_upload : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Lowercase for file name
+- # $fname = $fname;
+-
+- ## when the file already exists :
+-
+- # the temporary name of the uploaded file : with .duplicate
+- my $tmpname="."."$fname".".duplicate";
+- my $longtmpname="$shareddir/$path/$tmpname";
+- $longtmpname =~ s/\/+/\//g;
+-
+- # the temporary desc of the uploaded file : with .duplicate
+- my $tmpdesc=".desc."."$tmpname";
+- my $longtmpdesc="$shareddir/$path/$tmpdesc";
+- $longtmpdesc =~ s/\/+/\//g;
+-
+- # if we aren't in mode_delete nor in mode_rename nor in mode_cancel and the file already exists
+- # then we create of a temporary file
+- if ((-e "$longname") &&
+- ($in{'mode_delete'} eq undef) &&
+- ($in{'mode_rename'} eq undef) &&
+- ($in{'mode_cancel'} eq undef)) {
+-
+- #access control for the file already existing
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access_file = &d_access_control(\%mode,"$path/$fname");
+-
+- unless ($access_file{'may'}{'edit'} > 0) {
+- &report::reject_report_web('auth',$access_file{'reason'}{'edit'},{},$param->{'action'},$list);
+- return undef;
+- }
+-
+- if (-e "$longtmpname"){
+- # if exists a temp file younger than 5 minutes that belongs to another user : upload refused
+- my @info = stat $longtmpname;
+- my $timeold = time - $info[10];
+-
+- if ($timeold<=300){
+- my %desc_hash = &get_desc_file($longtmpdesc);
+-
+- unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
+- &report::reject_report_web('user','cannot_upload',{'path' => "$visible_path/$visible_fname",
+- 'reason' => "file being uploaded by $desc_hash{'email'} at this time" },
+- $param->{'action'},$list);
+- &wwslog('err',"do_d_upload : Unable to upload $longtmpname : file being uploaded at this time ");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+- }
+-
+- &creation_shared_file($shareddir,$path,$tmpname);
+- &creation_desc_file($shareddir,$path,$tmpname,%access_file);
+-
+- my @info = stat $longname;
+- $param->{'serial_file'} = $info[9];
+- $param->{'path'} = $path;
+- $param->{'shortname'} = $fname;
+-
+- return 1;
+- }
+-
+-
+- # for the moderation
+- my $longmodname = "$shareddir/$path/"."."."$fname".".moderate";
+- $longmodname =~ s/\/+/\//g;
+-
+- my $longmoddesc="$shareddir/$path/".".desc.."."$fname".".moderate";
+- $longmoddesc =~ s/\/+/\//g;
+-
+- # when a file is already waiting for moderation
+- my $file_moderated;
+-
+- if (-e "$longmodname"){
+-
+- my %desc_hash = &get_desc_file("$longmoddesc");
+- $file_moderated = 1;
+-
+- unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
+- &report::reject_report_web('user','cannot_upload',{'path' => "$path/$fname",
+- 'reason' => "file already exists but not yet moderated"},
+- $param->{'action'},$list);
+- &wwslog('err',"do_d_upload : Unable to create $longname : file already exists but not yet moderated");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+-
+- ## Exception index.html
+- unless ($fname !~ /^index.html?$/i) {
+- unless ($access_dir{'may'}{'control'}) {
+- &report::reject_report_web('user','index_html',{'dir' => $path,
+- 'reason' => "d_access_control"},
+- $param->{'action'},$list);
+- &wwslog('err',"do_d_upload : $param->{'user'}{'email'} not authorized to upload a INDEX.HTML file in $path");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- # if we're in mode_delete or mode_rename or mode_cancel, the temp file and his desc file must exist
+- if ($in{'mode_delete'} ||
+- $in{'mode_rename'} ||
+- $in{'mode_cancel'}) {
+-
+- unless(-e $longtmpname){
+- &report::reject_report_web('user','no_uploaded_file',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : there isn't any temp file for the uploaded file $fname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- unless(-e $longtmpdesc){
+- &report::reject_report_web('user','no_uploaded_file',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : there isn't any desc temp file for the uploaded file $fname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- }
+- ## End of controls
+-
+-
+- # in mode_delete the file is going to be overwritten
+- if ($in{'mode_delete'}) {
+-
+- # Synchronization
+- unless (&synchronize("$longname",$in{'serial'})){
+- &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : Synchronization failed for $longname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'synchro_failed','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Renaming the tmp file and the desc file
+-
+- if ($access_dir{'may'}{'edit'} == 1 ){
+-
+- # Renaming of the old file
+- my $longgoodname="$shareddir/$path/$fname";
+- $longgoodname =~ s/\/+/\//g;
+- unless (rename "$longgoodname","$longgoodname.old"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longgoodname",
+- 'new'=>"$longgoodname.old"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to .old : %s",$longgoodname, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Renaming of the old desc
+- my $longgooddesc="$shareddir/$path/".".desc."."$fname";
+- $longgooddesc =~ s/\/+/\//g;
+- unless (rename "$longgooddesc","$longgooddesc.old"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longgooddesc",
+- 'new'=>"$longgooddesc.old"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to .old : %s", $longgooddesc, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- # the tmp file
+- unless (rename "$longtmpname","$longgoodname"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpname",
+- 'new'=>"$longgoodname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpname, $longgoodname, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- # the tmp desc file
+- unless (rename "$longtmpdesc","$longgooddesc"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpdesc",
+- 'new'=>"$longgooddesc"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpdesc, $longgooddesc, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- }elsif ($access_dir{'may'}{'edit'} == 0.5 ){
+-
+- unless (rename "$longtmpname","$longmodname"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpname",
+- 'new'=>"$longmodname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpname, $longmodname, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- unless (rename "$longtmpdesc","$longmoddesc"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpdesc",
+- 'new'=>"$longmoddesc"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpdesc, $longmoddesc, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- unless ($list->send_notify_to_editor('shared_moderated',{'filename' => "$path/$fname",
+- 'who' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
+- }
+-
+- }else {
+- &report::reject_report_web('auth',$access_dir{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_upload : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+-# $in{'list'} = $list_name;
+-
+- # message of success
+- &report::notice_report_web('upload_success', {'path' => $fname},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'd_read';
+- }
+-
+- # in mode_rename the file is going to be renamed
+- if ($in{'mode_rename'}) {
+-
+- my $longnewname="$shareddir/$path/$in{'new_name'}";
+- $longnewname =~ s/\/+/\//g;
+-
+- # Control new document name
+- unless ($in{'new_name'}) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'new name'},$param->{'action'});
+- &wwslog('err',"do_d_upload : new name missing to rename the uploaded file");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'missing_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- if ($in{'new_name'} =~ /^\./
+- || $in{'new_name'} =~ /\.desc/
+- || $in{'new_name'} =~ /[~\#\[\]\/]$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : Unable to create file $in{'new_name'} : incorrect name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- if (($fname =~ /\.url$/) && ($in{'new_name'} !~ /\.url$/)) {
+- &report::reject_report_web('user','incorrect_name',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : New file name $in{'new_name'} does not match URL filenames");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- if (-e $longnewname){
+- &report::reject_report_web('user','doc_already_exist',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : $in{'new_name'} is an existing name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # when a file is already waiting for moderation
+- if (-e "$shareddir/$path/.$in{'new_name'}.moderate"){
+- &report::reject_report_web('user','doc_already_exist',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : $in{'new_name'} is an existing name for a not yet moderated file" );
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- # when a file is being uploaded
+- if (-e "$shareddir/$path/.$in{'new_name'}.duplicate"){
+- &report::reject_report_web('user','doc_already_exist',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_upload : $in{'new_name'} is an existing name for a file being uploaded ");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- # Renaming the tmp file and the desc file
+-
+- if ($access_dir{'may'}{'edit'} == 1 ){
+- unless (rename "$longtmpname","$longnewname"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpname",
+- 'new'=>"$longnewname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpname, $longnewname, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- my $longnewdesc="$shareddir/$path/.desc.$in{'new_name'}";
+- $longnewdesc =~ s/\/+/\//g;
+-
+- unless (rename "$longtmpdesc","$longnewdesc"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpdesc",
+- 'new'=>"$longnewdesc"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename %s to %s : %s", $longtmpdesc, $longnewdesc, $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- }elsif ($access_dir{'may'}{'edit'} == 0.5 ){
+-
+- unless (rename "$longtmpname","$shareddir/$path/.$in{'new_name'}.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpname",
+- 'new'=>"$shareddir/$path/.$in{'new_name'}.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename $longtmpname to $shareddir/$path/.$in{'new_name'}.moderate : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- unless (rename "$longtmpdesc","$shareddir/$path/.desc..$in{'new_name'}.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$longtmpdesc",
+- 'new'=>"$shareddir/$path/.desc..$in{'new_name'}.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_upload : Failed to rename $longtmpdesc to $shareddir/$path/.desc..$in{'new_name'}.moderate: $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- unless ($list->send_notify_to_editor('shared_moderated',{'filename' => "$path/$in{'new_name'}",
+- 'who' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
+- }
+-
+- }else {
+- &report::reject_report_web('auth',$access_dir{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_upload : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+-# $in{'list'} = $list_name;
+-
+- # message of success
+- &report::notice_report_web('upload_success', {'path' => $fname},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'd_read';
+- }
+-
+- # in mode_cancel, we delete the temp file and his desc
+- if ($in{'mode_cancel'}) {
+-
+- # removing of the temp file
+- unless (unlink($longtmpname)) {
+- &report::reject_report_web('intern','erase_file',{'file' => $longtmpname},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_d_upload: failed to erase the temp file %s', $longtmpname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # removing of the description temp file
+- unless (unlink($longtmpdesc)) {
+- &report::reject_report_web('intern','erase_file',{'file' => $longtmpdesc},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_d_upload: failed to erase the desc temp file %s', $longtmpdesc);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- return 'd_read';
+- }
+-
+- ## usual case
+-
+- # shared_moderated
+- if ($access_dir{'may'}{'edit'} == 0.5 ) {
+- my $modname="."."$fname".".moderate";
+-
+- &creation_shared_file($shareddir,$path,$modname);
+- &creation_desc_file($shareddir,$path,$modname,%access_dir);
+-
+- unless ($file_moderated){
+- unless ($list->send_notify_to_editor('shared_moderated',{'filename' => "$path/$fname",
+- 'who' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
+- }
+- }
+-
+- &report::notice_report_web('to_moderate', {'path' => $fname},$param->{'action'});
+-
+- } else {
+- &creation_shared_file($shareddir,$path,$fname);
+- &creation_desc_file($shareddir,$path,$fname,%access_dir);
+- }
+-
+- $in{'list'} = $list_name;
+-
+- &report::notice_report_web('upload_success', {'path' => $visible_fname},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$visible_path,$visible_fname",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'd_read';
+- }
+-
+-## Creation of a picture file
+-sub creation_picture_file {
+- my($root_dir, $path ,$fname)=@_;
+-
+- unless(-d $root_dir.'/'.$path) {
+- &wwslog('notice',"creation_picture_file : Create dir $root_dir/$path/");
+-
+- unless (&tools::mkdir_all($root_dir.'/'.$path, 0755)){
+- &wwslog('err',"creation_picture_file : Unable to create dir $root_dir/$path/");
+- return undef;
+- }
+-
+- unless (open(FF,">$root_dir".'/'.$path.'/index.html')){
+- &wwslog('err',"creation_picture_file : Unable to create dir $root_dir/$path/index.html");
+- }
+- chmod 0755, $root_dir.'/'.$path.'/index.html';
+- close FF;
+- }
+-
+- my $fh = $query->upload('uploaded_file');
+- unless (open FILE, ">:bytes", "$root_dir/$path/$fname") {
+- &report::reject_report_web('intern','cannot_upload',{'path' => "$path/$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"creation_picture_file : Cannot open file $root_dir/$path/$fname : $!");
+- return undef;
+- }
+- while (<$fh>) {
+- print FILE;
+- }
+- close FILE;
+- chmod 0755, "$root_dir/$path/$fname";
+-}
+-
+-
+-## Creation of a shared file
+-sub creation_shared_file {
+- my($shareddir,$path,$fname)=@_;
+-
+- unless(-d $shareddir.'/'.$path) {
+- &wwslog('notice',"creation_shared_file : Create dir $shareddir/$path/");
+-
+- unless (mkdir($shareddir.'/'.$path,0755)){
+- &wwslog('err',"creation_shared_file : Unable to create dir $shareddir/$path/");
+- return undef;
+- }
+-
+- }
+-
+- my $fh = $query->upload('uploaded_file');
+-
+- unless (open FILE, ">:bytes", "$shareddir/$path/$fname") {
+- &report::reject_report_web('intern','cannot_upload',{'path' => "$path/$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"creation_shared_file : Cannot open file $shareddir/$path/$fname : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- while (<$fh>) {
+- print FILE;
+- }
+- close FILE;
+-
+- ## XSS Protection for HTML files.
+- if (lc($fname) =~ /\.html?/) {
+- my $sanitized_file = &tools::sanitize_html_file('robot' => $robot,
+- 'file' => "$shareddir/$path/$fname");
+- if (defined $sanitized_file) {
+- open HTMLFILE, ">:bytes", "$shareddir/$path/$fname";
+- print HTMLFILE $sanitized_file;
+- close HTMLFILE;
+- }
+- else {
+- &do_log('err','Unable to sanitize file %s',$fname);
+- }
+- }
+-
+-}
+-
+-## Creation of the description file
+-sub creation_desc_file {
+- my($shareddir,$path,$fname,%access)=@_;
+-
+- unless (open (DESC,">$shareddir/$path/.desc.$fname")) {
+- &wwslog('err',"creation_desc_file: cannot create description file $shareddir/.desc.$path/$fname");
+- }
+-
+- print DESC "title\n \n\n";
+- print DESC "creation\n date_epoch ".time."\n email $param->{'user'}{'email'}\n\n";
+-
+- print DESC "access\n";
+- print DESC " read $access{'scenario'}{'read'}\n";
+- print DESC " edit $access{'scenario'}{'edit'}\n";
+-
+- close DESC;
+-}
+-
+- #*******************************************
+- # Function : do_d_unzip
+- # Description : unzip a file or a tree structure
+- # from an uploaded zip file
+- #******************************************
+-
+- sub do_d_unzip {
+- # Parameters of the uploaded file (from d_read.tt2)
+- my $fn = $in{'unzipped_file'};
+-
+- # name of the file, without path
+- my $fname;
+- if ($fn =~ /([^\/\\]+)$/) {
+- $fname = $1;
+- }
+-
+- &wwslog('info', 'do_d_unzip(%s/%s)', $in{'path'},$fname);
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- # name of the file
+- my $longname = "$shareddir/$path/$fname";
+- $longname =~ s/\/+/\//g;
+-
+- ## Controls
+-
+- my $listname = $list->{'name'};
+-
+- # uploaded file must have a name
+- unless ($fname) {
+- &report::reject_report_web('user','no_name',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_unzip(%s/%s) : No file specified to upload",$path,$fname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # must have .zip extension
+- unless ($fname =~ /^.+\.zip$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => "$fname",
+- 'reason' => "must have the '.zip' extension"},$param->{'action'},$list);
+- &wwslog('err',"do_d_unzip(%s/%s) : the file must have '.zip' extension",$path,$fname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## Check quota
+- if ($list->{'admin'}{'shared_doc'}{'quota'}) {
+- if ($list->get_shared_size() >= $list->{'admin'}{'shared_doc'}{'quota'} * 1024){
+- &report::reject_report_web('user','shared_full',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_unzip(%s/%s) : Shared Quota exceeded for list $list->{'name'}",$path,$fname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'shared_full','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- # The name of the file must be correct and must not be a description file
+- if ($fname =~ /^\./
+- || $fname =~ /\.desc/
+- || $fname =~ /[~\#\[\]]$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => "$fname"},$param->{'action'},$list);
+- &wwslog('err',"do_d_unzip(%s/%s) : incorrect name",$path,$fname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # the file must be uploaded in a directory existing
+- unless (-d "$shareddir/$path") {
+- &report::reject_report_web('user','no_such_document',{'path'=> $path},$param->{'action'},$list);
+- &wwslog('err',"do_d_unzip(%s/%s) : $shareddir/$path : not a directory",$path,$fname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Access control for the directory where there is the uploading
+- # only for (is_author || !moderated)
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access_dir = &d_access_control(\%mode,$path);
+-
+- if ($access_dir{'may'}{'edit'} == 0) {
+- &report::reject_report_web('auth',$access_dir{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_unzip(%s/%s) : access denied for %s',$path,$fname, $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- if ($access_dir{'may'}{'edit'} == 0.5) {
+- &report::reject_report_web('auth','edit_moderated',{},$param->{'action'},$list);
+- &wwslog('err','do_d_unzip(%s/%s) : access denied for %s',$path,$fname, $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## End of control
+-
+- # directory for the uploaded file
+- my $date = time;
+- my $zip_dir_name = $listname.$date.$$;
+- my $zip_abs_dir = $Conf{'tmpdir'}.'/'.$zip_dir_name;
+-
+- unless (mkdir ("$zip_abs_dir",0777)) {
+- &report::reject_report_web('intern','cannot_mkdir',{'dir' => $zip_abs_dir},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_unzip($path/$fname) : Unable to create $zip_abs_dir : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### directory for unzipped files
+- unless (mkdir ("$zip_abs_dir"."/zip",0777)) {
+- &report::reject_report_web('intern','cannot_mkdir',{'dir' => "$zip_abs_dir"."/zip"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_unzip($path/$fname) : Unable to create $zip_abs_dir/zip : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### uploaded of the file.zip
+- my $fh = $query->upload('unzipped_file');
+- unless (open FILE, ">:bytes", "$zip_abs_dir/$fname") {
+- &report::reject_report_web('intern','cannot_upload',{'path' => "$path/$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_unzip($path/$fname) : Cannot open file $zip_abs_dir/$fname : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- while (<$fh>) {
+- print FILE;
+- }
+- close FILE;
+-
+- ### unzip the file
+- my $status = &d_unzip_shared_file($zip_abs_dir,$fname,$path);
+-
+- unless (defined($status)) {
+- &report::reject_report_web('intern','cannot_unzip',{'path' => "$zip_abs_dir/$fname", 'name' => $fname},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_unzip($path/$fname) : Unable to unzip the file $zip_abs_dir/$fname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- unless ($status) {
+- &report::reject_report_web('intern','cannot_unzip',{'name' => "$fname"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }
+-
+- ### install the file hierarchy
+-
+- unless (&d_install_file_hierarchy("$zip_abs_dir/zip",$shareddir,$path,\%access_dir)) {
+- &wwslog('err',"do_d_unzip($path/$fname) : unable to install file hierarchy");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## remove tmp directories and files
+-# &tools::remove_dir($zip_abs_dir);
+-
+- $in{'list'} = $listname;
+-
+- &report::notice_report_web('unzip_success', {'path' => $fname},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'd_read'
+- }
+-
+-## unzip a shared file in the tmp directory
+-sub d_unzip_shared_file {
+- my ($zip_abs_dir,$fname) = @_;
+- &wwslog('info', 'd_unzip_shared_file(%s/%s)', $zip_abs_dir,$fname);
+-
+- my $status = 1;
+-
+- my $zip = Archive::Zip->new();
+-
+- my $az = $zip->read( "$zip_abs_dir/$fname" );
+-
+- unless ($az == AZ_OK){
+- &wwslog('err',"unzip_shared_file : Unable to read the zip file $zip_abs_dir/$fname : $az");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$zip_abs_dir,$fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- my @memberNames = $zip->memberNames();
+-
+- foreach my $name (@memberNames) {
+- my $az = $zip->extractMember($name, $zip_abs_dir.'/zip/'.$name);
+- unless ($az == AZ_OK) {
+- &wwslog('err',"unzip_shared_file : Unable to extract member $name of the zip file $zip_abs_dir/$fname : $az");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$zip_abs_dir,$fname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- $status = 0;
+- }
+- }
+-
+- ## Qencode 8bit filenames afterward
+- ## The suspected charset is the one that is associated to the user's language
+- &tools::qencode_hierarchy($zip_abs_dir.'/zip', &Language::GetCharset());
+-
+- return $status;
+-}
+-
+-## Install file hierarchy from $tmp_dir directory to $shareddir/$path directory
+-sub d_install_file_hierarchy {
+- my ($tmp_dir,$shareddir,$path,$access_dir)=@_;
+- &wwslog('debug2', 'd_install_file_hierarchy(%s,%s)',$tmp_dir,$path);
+-
+- $tmp_dir = &no_slash_end($tmp_dir);
+- $shareddir = &no_slash_end($shareddir);
+- $path = &no_slash_end($path);
+-
+- my $fatal_error = 0;
+-
+- unless (opendir DIR,"$tmp_dir") {
+- &report::reject_report_web('intern','cannot_open_dir',{'dir' => $tmp_dir},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','d_install_file_hierarchy(%s) : impossible to open %s directory',$path,$tmp_dir);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$tmp_dir,$shareddir,$path,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- my @from_dir = readdir DIR;
+- closedir DIR;
+-
+- foreach my $doc (@from_dir) {
+- next
+- if($doc eq '.' || $doc eq '..');
+- if (-d "$tmp_dir/$doc") {
+- if ($fatal_error) {
+- &report::reject_report_web('user','directory_no_copied',{'name'=> "$path/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }else {
+- unless (&d_copy_rec_dir("$tmp_dir","$path","$shareddir/$path",$doc)){
+- $fatal_error = 1;
+- &report::reject_report_web('user','directory_no_copied',{'name'=> "$path/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- # return undef;
+- }
+- }
+- } else {
+- if ($fatal_error) {
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }else {
+- unless (&d_copy_file("$tmp_dir","$path","$shareddir/$path",$doc,$access_dir)) {
+- &wwslog('err',"d_install_hierarchy($path) : fatal error from d_copy_file($doc)");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$tmp_dir,$shareddir,$path,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+-
+- $fatal_error = 1;
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }
+- # return undef;
+- }
+- }
+- }
+-
+- if ($fatal_error) {
+- return undef;
+- }else {
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$tmp_dir,$shareddir,$path,$access_dir",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-}
+-
+-## copy $dname from $from to $list->{shared}/$path if rights are ok
+-sub d_copy_rec_dir {
+- my ($from,$path,$dest_dir,$dname) = @_;
+- &wwslog('debug3', 'd_copy_rec_dir(%s,%s,%s)',$from,$dest_dir,$dname);
+-
+- $from = &no_slash_end($from);
+- $path = &no_slash_end($path);
+- $dest_dir = &no_slash_end($dest_dir);
+-
+- my $fatal_error = 0;
+-
+- # Access control on the directory $path where there is the copy
+- # Copy allowed only for (is_author || !moderate)
+- my %mode;
+- $mode{'edit'} = 1;
+- $mode{'control'} = 1;
+- my %access_dir = &d_access_control(\%mode,$path);
+-
+- unless ($access_dir{'may'}{'edit'} == 1) {
+- &report::reject_report_web('user','directory_no_copied',{'name'=> $dname,
+- 'reason' => "no edition right on father directory"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','d_copy_rec_dir(%s): access denied for %s',$path,$param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- my $may;
+- unless ($may = &d_test_existing_and_rights($path,$dname,$dest_dir)) {
+- &report::reject_report_web('user','directory_no_copied',{'name'=> $dname },
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','d_copy_rec_dir(%s) : error while calling "test_existing_and_rights(%s/%s)"',$dname,$dest_dir,$dname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- unless ($may->{'exists'}) {
+-
+- # The name of the directory must be correct and musn't not be a description file
+- if ($dname =~ /^\./
+- || $dname =~ /\.desc/
+- || $dname =~ /[~\#\[\]]$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => "$dname"},$param->{'action'},$list);
+- &wwslog('err',"d_copy_rec_dir : $dname : incorrect name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- ## Exception index.html
+- unless ($dname !~ /^index.html?$/i) {
+- &report::reject_report_web('user','index_html',{'dir' => $path},$param->{'action'},$list);
+- &wwslog('err',"d_copy_rec_dir : the directory cannot be called INDEX.HTML ");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- ## directory creation
+- unless (mkdir ("$dest_dir/$dname",0777)) {
+- &report::reject_report_web('user','directory_no_copied',{'name'=> "$dname"},$param->{'action'},$list);
+- &wwslog('err',"d_copy_rec_dir : Unable to create directory $dest_dir/$dname : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- ## desc directory creation
+- unless (open (DESC,">$dest_dir/$dname/.desc")) {
+- &wwslog('err',"d_copy_rec_dir: cannot create description file $dest_dir/$dname/.desc");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- print DESC "title\n \n\n";
+- print DESC "creation\n date_epoch ".time."\n email $param->{'user'}{'email'}\n\n";
+-
+- print DESC "access\n";
+- print DESC " read $access_dir{'scenario'}{'read'}\n";
+- print DESC " edit $access_dir{'scenario'}{'edit'}\n";
+-
+- close DESC;
+- }
+-
+- if ($may->{'rights'} || !($may->{'exists'})) {
+-
+- unless (opendir DIR,"$from/$dname") {
+- &report::reject_report_web('user','directory_no_copied',{'name'=> "$dname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','d_copy_rec_dir(%s) : impossible to open %s directory',$dname,$from);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- my @from_dir = readdir DIR;
+- closedir DIR;
+-
+-
+- foreach my $doc (@from_dir) {
+-
+- if ($doc eq '.' || $doc eq '..') {
+- next;
+- }
+- if (-d "$from/$dname/$doc") {
+- if ($fatal_error) {
+- &report::reject_report_web('user','directory_no_copied',{'name'=> "$dname/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+-
+- }else {
+-
+- unless (&d_copy_rec_dir("$from/$dname","$path/$dname","$dest_dir/$dname",$doc)){
+- $fatal_error = 1;
+- &report::reject_report_web('user','directory_no_copied',{'name'=> "$dname/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+-# return undef;
+- }
+- }
+-
+- }else {
+- if ($fatal_error) {
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$dname/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+-
+- }else {
+- unless (&d_copy_file("$from/$dname","$path/$dname","$dest_dir/$dname",$doc,\%access_dir)){
+- &wwslog('err',"d_copy_rec_dir($path/$dname) : fatal error from d_copy_file($doc)");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- $fatal_error = 1;
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$dname/$doc",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }
+-# return undef;
+- }
+- }
+- }
+-
+- }else{
+- &report::reject_report_web('user','directory_no_copied',{'name'=> $dname,
+- 'reason' => "no edition right on the father directory"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+-
+- &wwslog('err',"d_copy_rec_file : impossible to copy content directory $dname, the user doesn't have edit rights on directory $path");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- if ($fatal_error) {
+- return undef;
+- } else {
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$dname",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-}
+-
+-## copy $from/$fname to $list->{shared}/$path if rights are ok
+-sub d_copy_file {
+- my ($from,$path,$dest_dir,$fname,$access_dir) = @_;
+- &wwslog('debug3', 'd_copy_file(%s,%s,%s',$from,$dest_dir,$fname);
+-
+- $from = &no_slash_end($from);
+- $path = &no_slash_end($path);
+- $dest_dir = &no_slash_end($dest_dir);
+-
+- my $may;
+- unless ($may = &d_test_existing_and_rights($path,$fname,$dest_dir)) {
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$fname",
+- 'reason' => "quota exceeded"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','d_copy_file(%s) : error while calling "test_existing_and_rights(%s/%s)"',$fname,$dest_dir,$fname);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- if ($may->{'rights'} || !($may->{'exists'})) {
+-
+- # The name of the file must be correct and musn't not be a description file
+- if ($fname =~ /^\./
+- || $fname =~ /\.desc/
+- || $fname =~ /[~\#\[\]]$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => "$fname"},$param->{'action'},$list);
+- &wwslog('err',"d_copy_file : $fname : incorrect name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- ## Exception index.html
+- unless ($fname !~ /^index.html?$/i) {
+- unless ($access_dir->{'may'}{'control'}) {
+- &report::reject_report_web('user','index_html',{'dir' => $path},$param->{'action'},$list);
+- &wwslog('err',"d_copy_file : the user is not authorized to upload a INDEX.HTML file in $dest_dir");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+- }
+-
+- ## Check quota
+- if ($list->{'admin'}{'shared_doc'}{'quota'}) {
+-
+- if ($list->get_shared_size() >= $list->{'admin'}{'shared_doc'}{'quota'} * 1024){
+- &report::reject_report_web('user','shared_full',{},$param->{'action'},$list);
+- &wwslog('err',"d_copy_file : Shared Quota exceeded for list $list->{'name'} on file $path/$fname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'shared_full','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- ## if already existing :delete it
+- unlink ("$dest_dir/$fname")
+- if (-e "$dest_dir/$fname");
+- unlink ("$dest_dir/.desc.$fname")
+- if (-e "$dest_dir/.desc.$fname");
+-
+- ## # if exists a temp file younger than 5 minutes that belongs to another user : file copy refused
+- if (-e "$dest_dir/.$fname.duplicate") {
+- my @info = stat "$dest_dir/.$fname.duplicate";
+- my $timeold = time - $info[10];
+- if ($timeold <= 300){
+- my %desc_hash = &get_desc_file("$dest_dir/.desc..$fname.duplicate");
+- unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$fname",
+- 'reason' => "file being uploading by $desc_hash{'email'} at this time"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_copy_file : unable to copy $path/$fname : file being uploaded at this time ");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+- }
+-
+- unlink ("$dest_dir/.$fname.duplicate");
+- unlink ("$dest_dir/.desc..$fname.duplicate")
+- if (-e "$dest_dir/.desc..$fname.duplicate");
+- }
+-
+- if (-e "$dest_dir/.$fname.moderate") {
+- my %desc_hash = &get_desc_file("$dest_dir/.$fname.moderate");
+-
+- unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$fname",
+- 'reason' => "file awaiting for moderation, uploaded by $desc_hash{'email'}"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_copy_file : unable to copy $path/$fname : file awaiting for moderation");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+- unlink ("$dest_dir/.$fname.moderate");
+-
+- unlink ("$dest_dir/.desc..$fname.moderate")
+- if (-e "$dest_dir/.desc..$fname.moderate");
+- }
+-
+- ## file copy
+- unless (open FROM_FILE,"$from/$fname") {
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$fname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_copy_file : impossible to open $from/$fname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- my $visible_fname = &make_visible_path($fname);
+-
+- unless (open DEST_FILE, ">$dest_dir/$fname") {
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$visible_fname"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_copy_file : Cannot create file $dest_dir/$fname : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- while (<FROM_FILE>) {
+- print DEST_FILE;
+- }
+- close FROM_FILE;
+- close DEST_FILE;
+-
+- ## XSS Protection for HTML files.
+- if (lc($fname) =~ /\.html?/) {
+- my $sanitized_file = &tools::sanitize_html_file('robot' => $robot,
+- 'file' => "$dest_dir/$fname");
+- if (defined $sanitized_file) {
+- open HTMLFILE, ">:bytes", "$dest_dir/$fname";
+- print HTMLFILE $sanitized_file;
+- close HTMLFILE;
+- }
+- else {
+- &do_log('err','Unable to sanitize file %s',$fname);
+- }
+- }
+-
+- ## desc file creation
+- unless (open (DESC,">$dest_dir/.desc.$fname")) {
+- &wwslog('err',"d_copy_file: cannot create description file $dest_dir/.desc.$fname");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- print DESC "title\n \n\n";
+- print DESC "creation\n date_epoch ".time."\n email $param->{'user'}{'email'}\n\n";
+-
+- print DESC "access\n";
+- print DESC " read $access_dir->{'scenario'}{'read'}\n";
+- print DESC " edit $access_dir->{'scenario'}{'edit'}\n";
+-
+- close DESC;
+-
+- ## information
+-
+- &report::notice_report_web('file_erased',{'path'=> "$path/$visible_fname"},$param->{'action'})
+- if ($may->{'exists'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }else{
+- &report::reject_report_web('user','file_no_copied',{'name'=> "$path/$fname",
+- 'reason' => "you do not have total edit right on the file"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_copy_file : impossible to copy file $fname, the user doesn't have total edit rights on the file");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$from,$path,$dest_dir,$fname,$access_dir",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_no_copied','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- return 1;
+-}
+-
+-## return information on file or dir : existing and edit rights for the user in $param
+-sub d_test_existing_and_rights {
+- my ($path,$name,$dest_dir) = @_;
+-
+- $path = &no_slash_end($path);
+- $name = &no_slash_end($name);
+- $dest_dir = &no_slash_end($dest_dir);
+-
+- my $return;
+-
+- $return->{'exists'} = 0;
+- $return->{'rights'} = 0;
+-
+- if ((-e "$dest_dir/$name") ||
+- (-e "$dest_dir/.$name.duplicate") ||
+- (-e "$dest_dir/.$name.moderate")) {
+-
+- $return->{'exists'} = 1;
+-
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,"$path/$name");
+- $return->{'rights'} = 1
+- if $access{'may'}{'edit'} == 1;
+- }
+-
+- return $return;
+-}
+-
+-
+- #*******************************************
+- # Function : do_d_delete
+- # Description : Delete an existing document
+- # (file or directory)
+- #******************************************
+-
+- sub do_d_delete {
+- &wwslog('info', 'do_d_delete(%s)', $in{'path'});
+-
+- #useful variables
+- my $path = &no_slash_end($in{'path'});
+-
+- my $visible_path = &make_visible_path($path);
+-
+- #Current directory and document to delete
+- $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- my $current_directory = &no_slash_end($1);
+- my $document = $3;
+-
+- # path of the shared directory
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #### Controls
+-
+- ## must be something to delete
+- unless ($document) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'doccument'},$param->{'action'});
+- &wwslog('err',"do_d_delete : no document to delete has been specified");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'missing_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### Document isn't a description file?
+- unless ($document !~ /^\.desc/) {
+- &wwslog('err',"do_d_delete : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'description_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### Document exists?
+- unless (-e "$shareddir/$path") {
+- &wwslog('err',"do_d_delete : $shareddir/$path : no such file or directory");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # removing of the document
+- my $doc = "$shareddir/$path";
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'edit'} > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_delete : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## Directory
+- if (-d "$shareddir/$path") {
+-
+- # test of emptiness
+- opendir DIR, "$doc";
+- my @readdir = readdir DIR;
+- close DIR;
+-
+- # test for "ordinary" files
+- my @test_normal = grep !/^\./, @readdir;
+- my @test_hidden = grep !(/^\.desc$/ | /^\.(\.)?$/ | /^[^\.]/), @readdir;
+- if (($#test_normal != -1) || ($#test_hidden != -1)) {
+- &report::reject_report_web('user','full_directory',{'directory'=> $path},$param->{'action'},$list);
+- &wwslog('err',"do_d_delete : Failed to erase $doc : directory not empty");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # removing of the description file if exists
+- if (-e "$doc/\.desc") {
+- unless (unlink("$doc/.desc")) {
+- &report::reject_report_web('intern','erase_file',{'file' => "$doc/.desc"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_delete : Failed to erase $doc/.desc : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+- # removing of the directory
+- rmdir $doc;
+-
+- ## File
+- }else {
+-
+- # removing of the document
+- unless (unlink($doc)) {
+- &report::reject_report_web('intern','erase_file',{'file' => "$doc"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_d_delete: failed to erase %s', $doc);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- # removing of the description file if exists
+- if (-e "$shareddir/$current_directory/.desc.$document") {
+- unless (unlink("$shareddir/$current_directory/.desc.$document")) {
+- &wwslog('err',"do_d_delete: failed to erase $shareddir/$current_directory/.desc.$document");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+- }
+- }
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- $in{'list'} = $list_name;
+- $in{'path'} = $current_directory;
+- return 'd_read';
+- }
+-
+- #*******************************************
+- # Function : do_d_rename
+- # Description : Rename a document
+- # (file or directory)
+- #******************************************
+-
+- sub do_d_rename {
+- &wwslog('info', 'do_d_rename(%s)', $in{'path'});
+-
+- #useful variables
+- my $path = &no_slash_end($in{'path'});
+-
+- #moderation
+- my $visible_path = &make_visible_path($path);
+- my $moderate;
+- if ($path =~ /\.moderate$/) {
+- $moderate=1;
+- }
+-
+- #Current directory and document to delete
+- my $current_directory;
+- if ($path =~ /^(.*)\/([^\/]+)$/) {
+- $current_directory = &no_slash_end($1);
+- }else {
+- $current_directory = '.';
+- }
+- $path =~ /(^|\/)([^\/]+)$/;
+- my $document = $2;
+-
+- # path of the shared directory
+- my $list_name = $list->{'name'};
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #### Controls
+-
+- ## must be something to delete
+- unless ($document) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'document'},$param->{'action'});
+- &wwslog('err',"do_d_rename : no document to rename has been specified");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### Document isn't a description file?
+- unless ($document !~ /^\.desc/) {
+- &wwslog('err',"do_d_rename : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_such_document','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### Document exists?
+- unless (-e "$shareddir/$path") {
+- &wwslog('err',"do_d_rename : $shareddir/$path : no such file or directory");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_such_document','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- if ($in{'new_name'} =~ /^\./
+- || $in{'new_name'} =~ /\.desc/
+- || $in{'new_name'} =~ /[~\#\[\]\/]$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_rename : Unable to create file $in{'new_name'} : incorrect name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- if (($document =~ /\.url$/) && ($in{'new_name'} !~ /\.url$/)) {
+- &report::reject_report_web('user','incorrect_name',{'name' => $in{'new_name'}},$param->{'action'},$list);
+- &wwslog('err',"do_d_rename : New file name $in{'new_name'} does not match URL filenames");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- my $doc = "$shareddir/$path";
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'edit'} > 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_rename : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- if ($moderate){
+- &do_log('notice', "RENAME: $doc, $shareddir/$current_directory/$in{'new_name'}");
+- unless (rename $doc, "$shareddir/$current_directory/.$in{'new_name'}.moderate") {
+- &report::reject_report_web('intern','rename_file',{'old'=>$doc,
+- 'new'=>"$shareddir/$current_directory/.$in{'new_name'}.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_rename : Failed to rename %s to %s : %s", $doc, "$shareddir/$current_directory/$in{'new_name'}", $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }else {
+- &do_log('notice', "RENAME: $doc, $shareddir/$current_directory/$in{'new_name'}");
+- unless (rename $doc, "$shareddir/$current_directory/$in{'new_name'}") {
+- &report::reject_report_web('intern','rename_file',{'old'=>$doc,
+- 'new'=>"$shareddir/$current_directory/$in{'new_name'}"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_rename : Failed to rename %s to %s : %s", $doc, "$shareddir/$current_directory/$in{'new_name'}", $!);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+- ## Rename description file
+- my $desc_file = "$shareddir/$current_directory/.desc.$document";
+- my $new_desc_file = $desc_file;
+-
+- if (-f $desc_file) {
+- if ($moderate){
+- $new_desc_file =~ s/\Q$document/\.$in{'new_name'}\.moderate/;
+- }else {
+- $new_desc_file =~ s/\Q$document/$in{'new_name'}/;
+- }
+- unless (rename $desc_file, $new_desc_file) {
+- &report::reject_report_web('intern','rename_file',{'old'=>$desc_file,
+- 'new'=> $new_desc_file},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_rename : Failed to rename $desc_file : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- $in{'list'} = $list_name;
+- if ($current_directory eq '.') {
+- $in{'path'} = '';
+- } else {
+- $in{'path'} = $current_directory.'';
+- }
+- return 'd_read';
+- }
+-
+- #*******************************************
+- # Function : do_d_create_dir
+- # Description : Creates a new file / directory
+- #******************************************
+- sub do_d_create_dir {
+- &wwslog('info', 'do_d_create_dir(%s)', $in{'name_doc'});
+-
+- #useful variables
+- my $path = &no_slash_end($in{'path'});
+-
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+- my $name_doc = $in{'name_doc'};
+-
+- $param->{'list'} = $list_name;
+- $param->{'path'} = $path;
+-
+- ## Q-decode file path and names
+- $param->{'decoded_path'} = &tools::qdecode_filename($param->{'path'});
+- $param->{'decoded_name_doc'} = &tools::qdecode_filename($name_doc);
+-
+- my $type = $in{'type'} || 'directory';
+- my $desc_file;
+-
+- ### Controls
+-
+- # Must be a directory to create (directory name not empty)
+- unless ($name_doc) {
+- &report::reject_report_web('user','no_name',{},$param->{'action'},$list);
+- &wwslog('err',"do_d_create_dir : Unable to create : no name specified!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'missing_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # The name of the directory must be correct
+- if ($name_doc =~ /^\./
+- || $name_doc =~ /\.desc/
+- || $name_doc =~ /[~\#\[\]\/]$/) {
+- &report::reject_report_web('user','incorrect_name',{'name' => $name_doc},$param->{'action'},$list);
+- &wwslog('err',"do_d_create_dir : Unable to create directory $name_doc : incorrect name");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'bad_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+-
+- # Access control
+- my %mode;
+- $mode{'edit'} = 1;
+- my %access = &d_access_control(\%mode, $path);
+-
+- if ($type eq 'directory') { ## only when (is_author || !moderated)
+- if ($access{'may'}{'edit'} == 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_create_dir : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- if ($access{'may'}{'edit'} == 0.5) {
+- &report::reject_report_web('auth','dir_edit_moderated',{},$param->{'action'},$list);
+- &wwslog('err','do_d_create_dir : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- } else {
+- if ($access{'may'}{'edit'} == 0) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('err','do_d_create_dir : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- my $document = "$shareddir/$path/$name_doc";
+-
+- $param->{'document'} = $document;
+-
+- # the file musn't already exists
+- if (-e $document){
+- &report::reject_report_web('user','doc_already_exist',{'name' => "$path/$name_doc"},$param->{'action'},$list);
+- &wwslog('err',"do_d_create_dir : cannot create $path/$name_doc : file already exists");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # if the file .moderate exists, only its author can erase it
+-
+- my $doc_moderate = "$shareddir/$path/"."."."$name_doc".".moderate";
+- my $file_moderated;
+-
+- if (-e "$doc_moderate"){
+-
+- $file_moderated = 1;
+- my $desc="$shareddir/$path/".".desc.."."$name_doc".".moderate";
+- $desc =~ s/\/+/\//g;
+- my %desc_hash = &get_desc_file("$desc");
+-
+- unless($desc_hash{'email'} eq $param->{'user'}{'email'}){
+- &report::reject_report_web('user','cannot_upload',{'path' => "$path/$name_doc",
+- 'reason' => "file already exists but not yet moderated"},$param->{'action'},$list);
+- &wwslog('err',"do_d_create_dir : Unable to create $doc_moderate : file already exists but not yet moderated");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'file_already_exists','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- ### End of controls
+-
+- if ($type eq 'directory') {
+- # Creation of the new directory
+- unless (mkdir ("$document",0777)) {
+- &report::reject_report_web('intern','cannot_mkdir',{'dir' => $document},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_create_dir : Unable to create $document : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- $desc_file = "$document/.desc";
+-
+- }else {
+- # Creation of the new file
+- unless (open FILE, ">$document") {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => "$path/$name_doc"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_create_dir : Unable to create $document : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- close FILE;
+-
+- $desc_file = "$shareddir/$path/.desc.$name_doc";
+- }
+-
+- # Creation of a default description file
+- unless (open (DESC,">$desc_file")) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => "$desc_file"},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- }
+-
+- print DESC "title\n \n\n";
+- print DESC "creation\n date_epoch ".time."\n email $param->{'user'}{'email'}\n\n";
+-
+- print DESC "access\n";
+- print DESC " read $access{'scenario'}{'read'}\n";
+- print DESC " edit $access{'scenario'}{'edit'}\n\n";
+-
+- close DESC;
+-
+- # moderation
+- if ($access{'may'}{'edit'} == 0.5 && ($type ne 'directory')) {
+- unless (rename "$shareddir/$path/$name_doc","$shareddir/$path/.$name_doc.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>"$shareddir/$path/$name_doc",
+- 'new'=>"$shareddir/$path/.$name_doc.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_create_dir : Failed to rename $path/$name_doc to $path/.$name_doc.moderate : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- unless (rename "$desc_file","$shareddir/$path/.desc..$name_doc.moderate"){
+- &report::reject_report_web('intern','rename_file',{'old'=>$desc_file,
+- 'new'=>"$shareddir/$path/.desc..$name_doc.moderate"},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_d_create_dir : Failed to rename $desc_file to $path/.desc..$name_doc.moderate : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- unless ($file_moderated){
+- unless ($list->send_notify_to_editor('shared_moderated',{'filename' => $param->{'decoded_path'}.'/'.$param->{'decoded_name_doc'},
+- 'who' => $param->{'user'}{'email'}})) {
+- &wwslog('notice',"Unable to send notify 'shared_moderated' to $list->{'name'} list editor");
+- }
+- }
+- }
+-
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+-
+- if ($type eq 'directory') {
+- return 'd_read';
+- }
+-
+- if ($access{'may'}{'edit'} == 0.5) {
+- $in{'path'} = "$path/.$name_doc.moderate";
+- }else {
+- $in{'path'} = "$path/$name_doc";
+- }
+-
+- return 'd_editfile';
+- }
+-
+- ############## Control
+-
+-
+- #*******************************************
+- # Function : do_d_control
+- # Description : prepares the parameters
+- # to edit access for a doc
+- #*******************************************
+-
+- sub do_d_control {
+- &wwslog('info', "do_d_control $in{'path'}");
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #moderation
+- my $visible_path = &make_visible_path($path);
+-
+- unless ($path) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'document'},$param->{'action'});
+- &wwslog('info','do_d_control: no document name');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'missing_parameter','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Existing document?
+- unless (-e "$shareddir/$path") {
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &wwslog('info',"do_d_control : Cannot control $shareddir/$path : not an existing document");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_such_document','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### Document isn't a description file?
+- unless ($path !~ /\.desc/) {
+- &wwslog('info',"do_d_control : $shareddir/$path : description file");
+- &report::reject_report_web('user','no_such_document',{'path'=> $visible_path},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_such_document','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Access control
+- my %mode;
+- $mode{'control'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+- unless ($access{'may'}{'control'}) {
+- &report::reject_report_web('auth',$access{'reason'}{'edit'},{},$param->{'action'},$list);
+- &wwslog('info','d_control : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+-
+- ## End of controls
+-
+-
+- #Current directory
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
+- $param->{'father'} = &no_slash_end($1);
+- }else {
+- $param->{'father'} = '';
+- }
+- $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
+-
+- my $desc_file;
+- # path of the description file
+- if (-d "$shareddir/$path") {
+- $desc_file = "$shareddir/$1$3/.desc";
+- } else {
+- $desc_file = "$shareddir/$1.desc.$3";
+- }
+-
+- # Description of the file
+- my $read;
+- my $edit;
+-
+- if (-e $desc_file) {
+-
+- ## Synchronization
+- my @info = stat "$desc_file";
+- $param->{'serial_desc'} = $info[9];
+- my %desc_hash = &get_desc_file("$desc_file");
+- # rights for read and edit
+- $read = $desc_hash{'read'};
+- $edit = $desc_hash{'edit'};
+- # owner of the document
+- $param->{'owner'} = $desc_hash{'email'};
+- $param->{'doc_title'} = $desc_hash{'title'};
+- }else {
+- $read = $access{'scenario'}{'read'};
+- $edit = $access{'scenario'}{'edit'};
+- }
+-
+- ## other info
+- my @info = stat "$shareddir/$path";
+- $param->{'doc_date'} = gettext_strftime "%d %b %y %H:%M", localtime($info[9]);
+-
+- # template parameters
+- $param->{'list'} = $list_name;
+- $param->{'path'} = $path;
+- $param->{'visible_path'} = $visible_path;
+-
+- my $lang = $param->{'lang'};
+-
+- ## Scenario list for READ
+-
+- my $tmp_list_of_scenario = $list->load_scenario_list('d_read',$robot);
+-
+- ## Only get required scenario attributes
+- foreach my $scenario (keys %{$tmp_list_of_scenario}) {
+- $param->{'scenari_read'}{$scenario} = {'name' => $tmp_list_of_scenario->{$scenario}{'name'},
+- 'web_title' => $tmp_list_of_scenario->{$scenario}{'web_title'}};
+- }
+-
+- $param->{'scenari_read'}{$read}{'selected'} = 'selected="selected"';
+-
+- ## Scenario list for EDIT
+- my $tmp_list_of_scenario = $list->load_scenario_list('d_edit',$robot);
+-
+- ## Only get required scenario attributes
+- foreach my $scenario (keys %{$tmp_list_of_scenario}) {
+- $param->{'scenari_edit'}{$scenario} = {'name' => $tmp_list_of_scenario->{$scenario}{'name'},
+- 'web_title' => $tmp_list_of_scenario->{$scenario}{'web_title'}};
+- }
+- $param->{'scenari_edit'}{$edit}{'selected'} = 'selected="selected"';
+-
+- ## father directory
+- if ($path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/) {
+- $param->{'father'} = &no_slash_end($1);
+- }else {
+- $param->{'father'} = '';
+- }
+- $param->{'escaped_father'} = &tools::escape_docname($param->{'father'}, '/');
+-
+- $param->{'set_owner'} = 1;
+-
+- $param->{'father_icon'} = $icon_table{'father'};
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+-
+- #*******************************************
+- # Function : do_d_change_access
+- # Description : Saves the description of
+- # the file
+- #******************************************
+-
+- sub do_d_change_access {
+- &wwslog('info', 'do_d_change_access(%s)', $in{'path'});
+-
+- # Variables
+- my $path = &no_slash_end($in{'path'});
+-
+- my $list_name = $list->{'name'};
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #### Controls
+-
+- ## the path must not be empty (the description file of the shared directory
+- # doesn't exist)
+- unless ($path) {
+- &report::reject_report_web('intern','cannot_describe_shared_directory',{'path' => $path },$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"do_d_change_access : Cannot change access $shareddir : root directory");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # the document to describe must already exist
+- unless (-e "$shareddir/$path") {
+- &report::reject_report_web('user','no_doc_to_describe',{'path'=> $path},$param->{'action'},$list);
+- &wwslog('info',"d_change_access : Unable to change access $shareddir/$path : no such document");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+-
+- # Access control
+- my %mode;
+- $mode{'control'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'control'}) {
+- &report::reject_report_web('auth','action_listmaster_or_privileged_owner_or_author',{},$param->{'action'},$list);
+- &wwslog('info','d_change_access : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## End of controls
+-
+- # Description file
+- $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- my $dir = $1;
+- my $file = $3;
+-
+- my $desc_file;
+- if (-d "$shareddir/$path") {
+- $desc_file = "$shareddir/$1$3/.desc";
+- } else {
+- $desc_file = "$shareddir/$1.desc.$3";
+- }
+-
+- if (-e "$desc_file"){
+- # if description file already exists : open it and modify it
+- my %desc_hash = &get_desc_file ("$desc_file");
+-
+- # Synchronization
+- unless (&synchronize($desc_file,$in{'serial'})){
+- &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
+- &wwslog('info',"d_change_access : Synchronization failed for $desc_file");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'synchro_failed','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- unless (open DESC,">$desc_file") {
+- &wwslog('info',"d_change_access : cannot open $desc_file : $!");
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # information not modified
+- print DESC "title\n $desc_hash{'title'}\n\n";
+-
+- # access rights
+- print DESC "access\n read $in{'read_access'}\n";
+- print DESC " edit $in{'edit_access'}\n\n";
+-
+- print DESC "creation\n";
+- # time
+- print DESC " date_epoch $desc_hash{'date'}\n";
+- # author
+- print DESC " email $desc_hash{'email'}\n\n";
+-
+- close DESC;
+-
+- } else {
+- # Creation of a description file
+- unless (open (DESC,">$desc_file")) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"d_change_access : Cannot create description file $desc_file : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- print DESC "title\n \n\n";
+-
+- my @info = stat "$shareddir/$path";
+- print DESC "creation\n date_epoch ".$info[10]."\n email\n\n";
+- print DESC "access\n read $in{'read_access'}\n";
+- print DESC " edit $in{'edit_access'}\n\n";
+-
+- close DESC;
+-
+- }
+-
+- return 'd_control';
+-
+-
+- }
+-
+- sub do_d_set_owner {
+- &wwslog('info', 'do_d_set_owner(%s)', $in{'path'});
+-
+- # Variables
+- my $desc_file;
+-
+- my $path = &no_slash_end($in{'path'});
+-
+- #moderation
+- my $visible_path = &make_visible_path($path);
+-
+- #my $list_name = $in{'list'};
+- my $list_name = $list->{'name'};
+-
+- # path of the shared directory
+- my $shareddir = $list->{'dir'}.'/shared';
+-
+- #### Controls
+-
+- ## the path must not be empty (the description file of the shared directory
+- # doesn't exist)
+- unless ($path) {
+- &report::reject_report_web('intern','cannot_describe_shared_directory',{'path' => $path },$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"do_d_set_owner : Cannot change access $shareddir : root directory");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # the email must look like an email "somebody@somewhere"
+- unless (&tools::valid_email($in{'content'})) {
+- &report::reject_report_web('user','incorrect_email',{'email' => $in{'content'}},$param->{'action'},$list);
+- &wwslog('info',"d_set_owner : $in{'content'} : incorrect email");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'incorrect_email','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Access control
+- ## father directory
+- $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- my $dir = $1;
+- my $file = $3;
+- if (-d "$shareddir/$path") {
+- $desc_file = "$shareddir/$dir$file/.desc";
+- }else {
+- $desc_file = "$shareddir/$dir.desc.$file";
+- }
+-
+- my %mode;
+- $mode{'control'} = 1;
+- ## must be authorized to control father directory
+- #my %access = &d_access_control(\%mode,$1);
+- my %access = &d_access_control(\%mode,$path);
+-
+- unless ($access{'may'}{'control'}) {
+- &report::reject_report_web('auth','action_listmaster_or_privileged_owner_or_author',{},$param->{'action'},$list);
+- &wwslog('info','d_set_owner : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authentication','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- my $may_set = 1;
+-
+- unless ($may_set) {
+- &report::reject_report_web('user','full_directory',{'directory'=> $visible_path},$param->{'action'},$list);
+- &wwslog('info',"d_set_owner : cannot set owner of a full directory");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'full_directory','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## End of controls
+-
+- my %desc_hash;
+-
+- if (-e "$desc_file"){
+- # if description file already exists : open it and modify it
+- %desc_hash = &get_desc_file ("$desc_file");
+-
+- # Synchronization
+- unless (&synchronize($desc_file,$in{'serial'})) {
+-
+- &report::reject_report_web('user','synchro_failed',{},$param->{'action'},$list);
+- &wwslog('info',"d_set_owner : Synchronization failed for $desc_file");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'synchro_failed','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- unless (open DESC,">$desc_file") {
+- &wwslog('info',"d_set_owner : cannot open $desc_file : $!");
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # information not modified
+- print DESC "title\n $desc_hash{'title'}\n\n";
+-
+- print DESC "access\n read $desc_hash{'read'}\n";
+- print DESC " edit $desc_hash{'edit'}\n\n";
+- print DESC "creation\n";
+- # time
+- print DESC " date_epoch $desc_hash{'date'}\n";
+-
+- #information modified
+- # author
+- print DESC " email $in{'content'}\n\n";
+-
+- close DESC;
+-
+- } else {
+- # Creation of a description file
+- unless (open (DESC,">$desc_file")) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $desc_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info',"d_set_owner : Cannot create description file $desc_file : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- print DESC "title\n $desc_hash{'title'}\n\n";
+- my @info = stat "$shareddir/$path";
+- print DESC "creation\n date_epoch ".$info[10]."\n email $in{'content'}\n\n";
+-
+- print DESC "access\n read $access{'scenario'}{'read'}\n";
+- print DESC " edit $access{'scenario'}{'edit'}\n\n";
+-
+- close DESC;
+-
+- }
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'name_doc'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- ## ONLY IF SET_OWNER can be performed even if not control of the father directory
+- $mode{'control'} = 1;
+- my %access = &d_access_control(\%mode,$path);
+- unless ($access{'may'}{'control'}) {
+- ## father directory
+- $path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
+- $in{'path'} = &no_slash_end($1);
+- return 'd_read';
+- }
+-
+- ## ELSE
+- return 'd_control';
+- }
+-
+- ## Protecting archives from Email Sniffers
+- sub do_arc_protect {
+- &wwslog('info', 'do_arc_protect()');
+-
+- return 1;
+- }
+-
+-####################################################
+-# do_remind
+-####################################################
+-# Sends a remind command to sympa.pl.
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest' | 'admin' | undef
+-#
+-#####################################################
+- sub do_remind {
+- &wwslog('info', 'do_remind()');
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_remind', 'remind'));
+-
+- my $extention = time.".".int(rand 9999) ;
+- my $mail_command;
+-
+- ## Sympa will require a confirmation
+- my $result = $list->check_list_authz('remind','smtp',
+- {'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- if ($r_action =~ /reject/i) {
+- &report::reject_report_web('auth',$reason,{},$param->{'action'},$list);
+- &wwslog('info','remind : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+-
+- }else {
+- $mail_command = sprintf "REMIND %s", $param->{'list'};
+- }
+-
+- my $time = time;
+- my $data = {'headers' => {'Message-ID' => '<'.$time.'@wwsympa>',
+- 'X-Sympa-NoWrap' => 'yes'},
+- 'from'=> $param->{'user'}{'email'},
+- 'body' => $mail_command};
+-
+- $data->{'not_auto_submitted'} = 1;
+- unless (&mail::mail_file('',&Conf::get_robot_conf($robot, 'sympa'),$data,$robot)) {
+- &report::reject_report_web('intern','cannot_send_remind',{'from' => $param->{'user'}{'email'},'listname'=>$list->{'name'}},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_remind: failed to send message for command REMIND');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- &report::notice_report_web('performed_soon',{},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'admin';
+- }
+-
+- ## Load list certificat
+- sub do_load_cert {
+- &wwslog('info','do_load_cert(%s)', $param->{'list'});
+-
+- my @cert = $list->get_cert('der');
+- unless (@cert) {
+- &report::reject_report_web('user','missing_cert',{},$param->{'action'},$list);
+- &wwslog('info','do_load_cert: no cert for this list');
+- return undef;
+- }
+-
+- # don't you just HATE it when every single browser seems to want a
+- # different content-type for certificates? order is important, as
+- # everybody calls themselves "mozilla", and opera identifies as
+- # IE if told so (but Opera doesn't do S/MIME anyways, it seems)
+- my ($ua, $ct) = ($ENV{HTTP_USER_AGENT}, 'application/x-x509-email-cert');
+- if ($ua =~ /MSIE/) {
+- $ct = 'application/pkix-cert';
+- }
+- $param->{'bypass'} = 'extreme';
+- printf "Content-type: $ct\n\n";
+- foreach my $l (@cert) {
+- printf "$l";
+- }
+- return 1;
+- }
+-
+-
+-#*******************************************
+-# Function : do_upload_pictures
+-# Description : Creates a new pictures with a
+-# uploaded file
+-#******************************************
+-
+-sub do_upload_pictures {
+- # Parameters of the uploaded file (from suboptions.tt2)
+- my $fn = $query->param('uploaded_file');
+- &wwslog('info', 'do_upload_pictures(%s,%s)',$fn,$param->{'user'}{'email'});
+-
+- # name of the file, without path
+- my $fname;
+- if ($fn =~ /([^\/\\]+)$/) {
+- $fname = $1;
+- }
+-
+- # type of the file
+- my $filetype;
+- if ($fn =~ /\.(jpg|jpeg|png|gif)$/i) {
+- $filetype = $1;
+- }
+- else {$filetype = undef};
+-
+- my $filename = &tools::md5_fingerprint($param->{'user'}{'email'});
+- my $fullfilename = $filename.'.'.$filetype;
+-
+- #uploaded file must have a name
+- unless ($fname) {
+- &report::reject_report_web('user','no_name',{},$param->{'action'});
+- &wwslog('err',"do_upload_pictures : No file specified to upload");
+- return 'suboptions';
+- }
+-
+- unless($filetype) {
+- &report::reject_report_web('user','cannot_upload',{'path' => $fullfilename,
+- 'reason' => "your file does not have an authorized format." },$param->{'action'});
+- &wwslog('err',"do_upload_pictures : unauthorized format");
+- return 'suboptions';
+- }
+-
+- my $filetmp;
+-
+- #check if there is not already a file for the user with a different extension
+- foreach my $ext ('.gif','.png','.jpg','.jpeg') {
+- my $file = &Conf::get_robot_conf($robot,'pictures_path').'/'.$in{'list'}.'@'.$robot.'/'.$filename;
+- if(-f $file.$ext) {
+- rename($file.$ext,$file.$ext.'.tmp');
+- $filetmp = $file.$ext;
+- last;
+- }
+- }
+-
+- unless(&creation_picture_file(&Conf::get_robot_conf($robot,'pictures_path'),$param->{'list'}.'@'.$robot,$fullfilename)) {
+- &report::reject_report_web('user','upload_failed', {'path' => $fullfilename},$param->{'action'});
+- &wwslog('err','do_upload_pictures : Failed to create file %s/%s@%s%s',&Conf::get_robot_conf($robot,'pictures_path'),$param->{'list'},$robot,$filename);
+- return 'suboptions';
+- }
+- my $uploadedfile = &Conf::get_robot_conf($robot,'pictures_path').'/'.$in{'list'}.'@'.$robot.'/'.$fullfilename;
+- my @info = stat($uploadedfile);
+- my $size = $info[7];
+-
+- unless($size <= $Conf{'pictures_max_size'}) {
+- unlink($uploadedfile);
+- rename($filetmp.'.tmp',$filetmp);
+- &report::reject_report_web('user','cannot_upload',{'path' => $fullfilename,
+- 'reason' => "Your file exceeds the authorized size." },$param->{'action'});
+- &wwslog('err',"do_upload_pictures : Failed to upload pictures");
+- return 'suboptions';
+- }
+-
+- # message of success
+- unlink($filetmp.'.tmp');
+- &wwslog('info',"do_upload_pictures : Upload of the pictures succeeded");
+- return 'suboptions';
+-
+-}
+-
+-## Delete a picture file
+-sub do_delete_pictures {
+- &wwslog('info', 'do_delete_pictures(%s,%s,%s)', $param->{'list'},$robot,$param->{'user'}{'email'});
+-
+- my $email = $param->{'user'}{'email'};
+-
+- #deleted file must exist
+- unless(&tools::pictures_filename('email' => $email, 'list' => $list)) {
+- &report::reject_report_web('user','no_name',{},$param->{'action'},$list);
+- &wwslog('err',"do_delete_pictures : No file exists to delete");
+- return 'suboptions';
+- }
+-
+- unless($list->delete_user_picture($email)) {
+- &report::reject_report_web('intern','erase_file',{'file' => &tools::pictures_filename('email' => $email, 'list' => $list)},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"do_delete_pictures : Failed to erase ".&tools::pictures_filename('email' => $email, 'list' => $list));
+- return undef;
+- }
+- else {
+- &wwslog('notice',"do_delete_pictures : File deleted successfull");
+- return 'suboptions';
+- }
+-}
+-
+-
+-####################################################
+-# do_change_email_request
+-####################################################
+-# Checks a user's new email address and passes it
+-# to 'change_email'
+-#
+-# IN : -
+-#
+-# OUT : '1' | 'change_email'
+-#
+-####################################################
+-## Checks a users new email address by sending a ticket to the new email address
+-## and demanding that they click it to verify. Leads to 'change_email'
+-sub do_change_email_request {
+- &wwslog('info','do_change_email_request(%s)', $in{'new_email'});
+-
+- unless ($param->{'one_time_ticket'} = &Auth::create_one_time_ticket($in{'new_email'},$robot,'change_email/'.$param->{'user'}{'email'},$ip)){
+-
+- &do_log('notice',"Unable to create one_time_ticket for $in{'new_email'}, service do_change_email_request");
+- }else{
+- &do_log('notice',"ticket : $param->{'one_time_ticket'}");
+- }
+-
+- $param->{'new_email'} = $in{'new_email'};
+- my $tt2_param = {'type' => 'ticket_to_send',
+- 'one_time_ticket' => $param->{'one_time_ticket'},
+- 'to' => $in{'new_email'},
+- };
+- unless (&List::send_global_file('user_notification', $in{'new_email'}, $robot, $tt2_param)) {
+- &do_log('notice',"Unable to send template 'user_notification' to $in{'new_email'}");
+- return undef;
+- }
+- return '1';
+-}
+-
+-
+-
+-####################################################
+-# do_change_email
+-####################################################
+-# Changes a user's email address in Sympa environment
+-#
+-# IN : -
+-#
+-# OUT : '1' | 'pref' | undef
+-#
+-####################################################
+-## Change a user's email address in Sympa environment
+-sub do_change_email {
+- &wwslog('info','do_change_email(%s)', $in{'email'});
+-
+- my ($old_email, $new_email);
+- my $edited_by_listmaster;
+-
+- unless ($in{'email'} || ($in{'old_email'} && $in{'new_email'})) {
+- &report::reject_report_web('user','Missing argument',{},$param->{'action'});
+- &wwslog('err',"Lacking parameter : $in{'email'} or $in{'old_email'} or $in{'new_email'} ");
+- &web_db_log({'parameters' => $in{'email'},$in{'old_email'},$in{'new_email'},
+- 'status' => 'error',
+- 'error_type' => 'user'});
+- }
+-
+- ## There are two ways to access this function 'change_email'. One from the preferences page and one from the serveradmin page
+- ## If the process comes from server admin it needs the variables 'old_email' and 'new_email'.
+- if ($in{'old_email'} && $in{'new_email'}) {
+- ## if variables old_email and new_email are present $edited_by_listmaster is set to one
+- ## so that at the end of the function we can return to the SympaAdmin page
+- ## instead of the preferences page
+- $edited_by_listmaster = 1;
+- unless (&List::is_listmaster ($param->{'user'}{'email'}, $robot)) {
+- &report::reject_report_web('auth','User is not Listmaster',{},$param->{'action'});
+- &wwslog('err','do_change_email : not listmaster');
+- &web_db_log({'parameters' => $in{'email'},
+- 'status' => 'error',
+- 'error_type' => 'authorization'});
+- return undef;
+- }
+-
+- $old_email = $in{'old_email'};
+- $new_email = $in{'new_email'};
+- }else {
+- $old_email = $in{'email'};
+- $new_email = $param->{'user'}{'email'};
+- }
+-
+- my ($password, $newuser);
+-
+- if ($newuser = &List::get_user_db($old_email)) {
+-
+- $password = $newuser->{'password'};
+- }
+-
+- ## Change email as list MEMBER
+- foreach my $list ( &List::get_which($old_email,$robot, 'member') ) {
+-
+-
+- my $l = $list->{'name'};
+-
+- my $user_entry = $list->get_subscriber($old_email);
+- if ($user_entry->{'included'} == 1) {
+- ## Notify list owner
+- $list->send_notify_to_owner('failed_to_change_included_member',{'current_email' => $old_email,
+- 'new_email' => $new_email,
+- 'datasource' => $list->get_datasource_name($user_entry->{'id'})});
+-
+- &report::reject_report_web('user','change_member_email_failed_included',{'listname'=>$list->{'name'}},
+- $param->{'action'},$list,$old_email,$robot);
+- &wwslog('err', 'could not change member email for list %s because member is included', $l);
+- next;
+- }
+-
+- ## Check if user is already member of the list with his new address
+- ## then we just need to remove the old address
+- if ($list->is_user($new_email)) {
+- unless ($list->delete_user('users' => [$old_email]) ) {
+- &report::reject_report_web('intern','delete_subscriber_db_failed',{'sub'=>$new_email},
+- $param->{'action'},$list,$old_email,$robot);
+- &wwslog('info', 'do_change_email: could not remove email from list %s', $l);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$new_email",'target_email' => "$new_email",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $old_email,'client' => $ip,'daemon' => $daemon_name});
+- }
+-
+- }else {
+-
+- unless ($list->update_user($old_email, {'email' => $new_email, 'update_date' => time}) ) {
+- &report::reject_report_web('intern','update_subscriber_db_failed',{'sub'=>$new_email},
+- 'old_email' => $old_email,
+- $param->{'action'},$list,$old_email,$robot);
+- &wwslog('info', 'do_change_email: could not change email for list %s', $l);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$new_email",'target_email' => "$new_email",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $old_email,'client' => $ip,'daemon' => $daemon_name});
+- }
+- }
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+-
+- ## Change email as list OWNER/MODERATOR
+- my %updated_lists;
+- foreach my $role ('owner', 'editor') {
+- foreach my $list ( &List::get_which($old_email,$robot, $role) ) {
+-
+- ## Check if admin is include via an external datasource
+- my $admin_user = $list->get_admin_user($role, $old_email);
+- if ($admin_user->{'included'}) {
+- ## Notify listmaster
+- &List::send_notify_to_listmaster('failed_to_change_included_admin',$robot,{'list' => $list,
+- 'current_email' => $old_email,
+- 'new_email' => $new_email,
+- 'datasource' => $list->get_datasource_name($admin_user->{'id'})});
+-
+- &report::reject_report_web('user','change_admin_email_failed_included',{'listname'=>$list->{'name'}},
+- $param->{'action'},$list,$old_email,$robot);
+- &wwslog('err', 'could not change %s email for list %s because admin is included', $role, $list->{'name'});
+- next;
+- }
+-
+- ## Go through owners/editors of the list
+- foreach my $admin (@{$list->{'admin'}{$role}}) {
+- next unless (lc($admin->{'email'}) eq lc($old_email));
+-
+- ## Update entry with new email address
+- $admin->{'email'} = $new_email;
+- $updated_lists{$list->{'name'}}++;
+- }
+-
+- ## Update Db cache for the list
+- $list->sync_include_admin();
+- $list->save_config();
+- }
+- }
+- ## Notify listmasters that list owners/moderators email have changed
+- if (keys %updated_lists) {
+- &List::send_notify_to_listmaster('listowner_email_changed',$robot,
+- {'list' => $list,
+- 'previous_email' => $old_email,
+- 'new_email' => $new_email,
+- 'updated_lists' => keys %updated_lists})
+- }
+-
+- ## Update User_table and remove existing entry first (to avoid duplicate entries)
+- &List::delete_user_db($new_email,);
+-
+- unless ( &List::update_user_db($old_email,
+- {'email' => $new_email,
+-
+- })) {
+- &report::reject_report_web('intern','update_user_db_failed',{'user'=>$new_email,
+- 'old_email' => $old_email},
+- $param->{'action'},'',$old_email,$robot);
+- &wwslog('info','change_email: update failed');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$new_email",'target_email' => "$new_email",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $old_email,'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## Update netidmap_table
+- unless ( &List::update_email_netidmap_db($robot, $old_email, $new_email) ){
+- &report::reject_report_web('intern','update_netidmap_failed',{'user'=>$new_email,
+- 'old_email' => $old_email},
+- $param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','change_email: update failed');
+- &web_db_log({'target_email' => $old_email,
+- 'status' => 'error',
+- 'error_type' => 'internal'});
+- return undef;
+- }
+-
+- ## Update the data structure that tells which lists the current user is member/owner/editor of
+- unless ($edited_by_listmaster == 1) {
+- @{$param->{'get_which'}} = &List::get_which($param->{'user'}{'email'},$robot,'member');
+- @{$param->{'get_which_owner'}} = &List::get_which($param->{'user'}{'email'},$robot,'owner');
+- @{$param->{'get_which_editor'}} = &List::get_which($param->{'user'}{'email'},$robot,'editor');
+- }
+-
+- if ($edited_by_listmaster == 1) {
+- return 'serveradmin';
+- }
+-
+-
+- if ($in{'previous_action'}) {
+- $in{'list'} = $in{'previous_list'};
+- return $in{'previous_action'};
+- }elsif ($edited_by_listmaster == 1) {
+- return 'serveradmin';
+- }
+-
+- return 'pref';
+-
+- }
+-
+-####################################################
+-# do_suspend_request
+-####################################################
+-# Suspend a subscription to one or more lists #
+-# for a given period: start date and end date #
+-# (or unlimited). The user may at any time #
+-# stop the suspension. #
+-# #
+-# IN : - #
+-# OUT : 'loginrequest' #
+-# | 'info' | undef #
+-# #
+-####################################################
+-sub do_suspend_request {
+-
+- &wwslog('info', 'do_suspend_request', $in{'action'}); #Action = suspend_request
+- my $email = $param->{'user'}{'email'};
+- my $data;
+-
+- ## Sets the date of the field "start date" to "today"
+- my @d_day = localtime(time);
+- $param->{'d_day'} = ($d_day[3])."-".($d_day[4]+1)."-".($d_day[5]+1900);
+- my $display_resume = 0;
+-
+- ## We display in the table the lists of the subscriber and the state in which they are.
+- ## reception : - nomail/digest/mail ||
+- ## - . suspended From XX/XX/XXXX To XX/XX/XXXX
+- my @lists = &List::get_which($email, $robot, 'member');
+-
+- foreach my $list (@lists) {
+- my $member_info = $list->get_subscriber($param->{'user'}{'email'});
+- if(($member_info->{'enddate'} < time) && ($member_info->{'enddate'})){
+- ## If end date is < time, update the BDD by deleting the suspending's data
+- &List::restore_suspended_subscription($param->{'user'}{'email'},$list->{'name'},$list->{'domain'});
+- }
+- my $final_start_date = gettext_strftime "%d %b %Y", localtime($member_info->{'startdate'});
+- my $final_end_date;
+-
+- if($member_info->{'suspend'} == 1){
+- $display_resume = 1;
+- }
+- if($member_info->{'enddate'}){
+- $final_end_date = gettext_strftime "%d %b %Y", localtime($member_info->{'enddate'});
+- }else{
+- $final_end_date = undef;
+- }
+-
+- $member_info->{'reception'} ||= 'mail';
+- $member_info->{'visibility'} ||= 'noconceal';
+- foreach my $mode (keys %wwslib::reception_mode) {
+- if ($list->is_available_reception_mode($mode)) {
+- $param->{'reception'}{$list->{'name'}}{$mode}{'description'} = sprintf(gettext($wwslib::reception_mode{$mode}->{'gettext_id'}));
+- if ($member_info->{'reception'} eq $mode) {
+- $param->{'reception'}{$list->{'name'}}{$mode}{'selected'} = 'selected="selected"';
+- }else {
+- $param->{'reception'}{$list->{'name'}}{$mode}{'selected'} = '';
+- }
+- }
+- }
+-
+- my $subscription = {'listname' => $list->{'name'},
+- 'listdomain' => $list->{'domain'},
+- 'listreception' => $member_info->{'reception'},
+- 'listsuspend' => $member_info->{'suspend'},
+- 'liststartdate' =>$final_start_date,
+- 'listenddate' => $final_end_date,
+- 'display' => $display_resume,
+- 'visibility' => $member_info->{'visibility'},
+- 'reception' => $param->{'reception'}{$list->{'name'}},
+- };
+- push @{$param->{'suspend_list'}}, $subscription;
+- }
+-
+- return 1;
+-}
+-
+-####################################################
+-# do_suspend_request_action
+-####################################################
+-# Suspend a subscription for lists. #
+-# Action from the suspend form. #
+-# #
+-# IN : %in : HASH with the form's values #
+-# OUT : 'pref' : action #
+-# | 'info' | undef #
+-####################################################
+-sub do_suspend_request_action {
+-
+- &wwslog('info', 'do_suspend_request_action', $in{'action'});
+-
+- my $day1;
+- my $month1;
+- my $year1;
+- my $day2;
+- my $month2;
+- my $year2;
+- my @lists;
+- my $data;
+-
+- if($in{'sub_action'} eq 'suspendsave'){
+-
+- # to retrieve the selected list
+- @lists = split /\0/, $in{'listname'};
+- my @list_selected;
+- foreach my $list (@lists){
+- unless($list eq ''){
+- push @list_selected, $list;
+- }
+- }
+-
+- if($list_selected[0] eq ''){
+- &report::reject_report_web('user','missing_arg',{'argument' => 'must picked one or more list(s) you are subscribed'}, $param->{'action'});
+- &wwslog('info','suspend_request: must picked one or more list(s) you are subscribed');
+- return 'suspend_request';
+- }
+-
+- if ($in{'date_deb'}){
+- ($day1, $month1, $year1) = split(/\-/, $in{'date_deb'});
+- $month1 = $month1-1;
+-
+- if (($day1 =~ /([0-9]*)/) && ($month1 =~ /([0-9]*)/) && ($year1 =~ /([0-9]*)/)){
+- if (((1<=$day1) && ($day1<=31)) && ((0<=$month1) && ($month1<=11)) && (1900<=$year1)){
+- ## Return an epoch date
+- $data->{'startdate'} = timelocal(0, 0, 0, $day1,$month1,$year1);
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'Start Date doesn\'t exist.'}, $param->{'action'});
+- &wwslog('info','suspend_request: Date doesn\'t exist.');
+- return 'suspend_request';
+- }
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'Start Date doesn\'t exist.'}, $param->{'action'});
+- &wwslog('info','suspend_request: Date doesn\'t exist.');
+- return 'suspend_request';
+- }
+- ## Case 1 : Start date & End date (without indefinite)
+- if (($in{'date_fin'}) && (!$in{'indefinite'})){
+- ($day2, $month2, $year2) = split(/\-/, $in{'date_fin'});
+- $month2 = $month2-1;
+-
+- if (($day2 =~ /([0-9]*)/) && ($month2 =~ /([0-9]*)/) && ($year2 =~ /([0-9]*)/)){
+- if (((1<=$day2) && ($day2<=31)) && ((0<=$month2) && ($month2<=11)) && (1900<=$year2)){
+- ## Return an epoch date
+- $data->{'enddate'} = timelocal(0, 0, 0, $day2,$month2,$year2);
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'End Date doesn\'t exist.'}, $param->{'action'});
+- &wwslog('info','suspend_request: Date doesn\'t exist.');
+- return 'suspend_request';
+- }
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'End Date doesn\'t exist.'}, $param->{'action'});
+- &wwslog('info','suspend_request: Date doesn\'t exist.');
+- return 'suspend_request';
+- }
+-
+- unless($data->{'startdate'} <= $data->{'enddate'}){
+- &report::reject_report_web('user','missing_arg',{'argument' => 'The start date must be less than the end date.'}, $param->{'action'});
+- &wwslog('info','suspend_request: The start date must be less than the end date.');
+- return 'suspend_request';
+- }
+- ## Case 2 : Start date & without indefinite (without end date)
+- }elsif((!$in{'date_fin'}) && ($in{'indefinite'})){
+- $data->{'enddate'} = undef;
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'Choose end date (dd/mm/yyyy) or indefinite end date'}, $param->{'action'});
+- &wwslog('info','suspend_request: missing argument for the end date or syntax error : dd/mm/yyyy or must choose a end date or indefinite end date');
+- return 'suspend_request';
+- }
+- }else{
+- &report::reject_report_web('user','missing_arg',{'argument' => 'Miss start date (dd/mm/yyyy)'}, $param->{'action'});
+- &wwslog('info','suspend_request: missing argument for the start date or syntax error : dd/mm/yyyy');
+- return 'suspend_request';
+- }
+-
+- ## Suspend subscription
+- foreach my $list (@list_selected){
+- unless(&List::suspend_subscription($param->{'user'}{'email'}, $list, $data, $robot)){
+- &wwslog('info','Can\'t do List suspend_subscription');
+- return 'suspend_request';
+- }
+- }
+-
+- &report::notice_report_web('performed',{},$in{'sub_action'});
+- }
+- ## Restore suspended subscription
+- elsif($in{'sub_action'} eq 'suspendstop'){
+-
+- # to renew membership lists selected
+- @lists = split /\0/, $in{'listname'};
+- foreach my $line (@lists) {
+- &List::restore_suspended_subscription($param->{'user'}{'email'}, $line, $robot);
+- }
+-
+- if($lists[0] eq ''){
+- &report::reject_report_web('user','missing_arg',{'argument' => 'must picked one or more list(s)'}, $param->{'action'});
+- &wwslog('info','suspend_request: must picked one or more list(s)');
+- return 'suspend_request';
+- }
+- &report::notice_report_web('performed',{},"Resume the subscription for the list(s)");
+-
+- }
+- ## Unsubscribe from the selected lists
+- elsif($in{'sub_action'} eq 'signoff'){
+-
+- # lists selected
+- @lists = split /\0/, $in{'listname'};
+- my $report = "";
+- foreach my $line (@lists) {
+-
+- my $unsub_list = new List ($line, $robot);
+- unless ($unsub_list) {
+- &wwslog('info', 'List %s unknown' , $unsub_list);
+- return undef;
+- }
+-
+- my %result = &unsubscribe($param->{'user'}{'email'}, $unsub_list);
+- if ($result{'success'} == 1) {
+- if ($result{'details'} eq 'sent_to_owner') {
+- $report .= sprintf(gettext("Your unsubscription request to list %s was sent to the list owner."),$unsub_list->{'name'});
+- }else{
+- $report .= sprintf(gettext("You were successfully unsubscribed from list %s."),$unsub_list->{'name'});
+- }
+- }else{
+- if ($result{'category_error'} eq 'auth') {
+- $report .= sprintf(gettext("Unsubscription from list %s denied: Unsubscription from this list is closed."),$unsub_list->{'name'});
+- }else{
+- $report .= sprintf(gettext("Unsubscription from list %s failed."),$unsub_list->{'name'});
+- }
+- }
+- $report .= "\n";
+-
+- }
+- if($lists[0] eq ''){
+- &report::reject_report_web('user','missing_arg',{'argument' => 'must picked one or more list(s)'}, $param->{'action'});
+- &wwslog('info','suspend_request: must picked one or more list(s)');
+- return 'suspend_request';
+- }
+-
+- &report::notice_report_web($report,{},'');
+- }else{
+- &report::reject_report_web('user','unknown_action',{},$in{'sub_action'},$list);
+- &wwslog('info','unknown action %s', $in{'sub_action'});
+- return undef;
+- }
+-
+- return 'suspend_request';
+-}
+-
+-####################################################
+-# do_compose_mail
+-####################################################
+-sub do_compose_mail {
+-
+- &wwslog('info', 'do_compose_mail', $in{'subaction'});
+-
+- unless ($param->{'may_post'}) {
+- &report::reject_report_web('auth',$param->{'may_post_reason'},{},$param->{'action'},$list);
+- &wwslog('info','do_compose_mail: may not send message');
+- return undef;
+- }
+-
+- # Set the subaction to html_news_letter or undef
+- $param->{'subaction'} = $in{'subaction'};
+- if ($in{'to'}) {
+- # In archive we hide email replacing @ by ' '. Here we must do the reverse transformation
+- $in{'to'} =~ s/ /\@/g;
+- $param->{'to'} = $in{'to'};
+- }else{
+- $param->{'to'} = $list->get_list_address();
+- }
+- foreach my $recipient (split(',',$param->{'to'})) {
+- ($param->{'recipients'}{$recipient}{'local_to'},$param->{'recipients'}{$recipient}{'domain_to'}) = split ('@',$recipient);
+- }
+- $param->{'mailto'}= &mailto($list,$param->{'to'});
+- # headers will be encoded later.
+- #XXX$param->{'subject'}= &MIME::Words::encode_mimewords($in{'subject'});
+- $param->{'subject'} = $in{'subject'};
+- $param->{'in_reply_to'}= '<'.$in{'in_reply_to'}.'>';
+- $param->{'message_id'} = &tools::get_message_id($robot);
+-
+- if ($list->is_there_msg_topic()) {
+-
+- $param->{'request_topic'} = 1;
+-
+- foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
+- if ($top->{'name'}) {
+- push (@{$param->{'available_topics'}},$top);
+- }
+- }
+- $param->{'topic_required'} = $list->is_msg_topic_tagging_required();
+- }
+-
+- return 1;
+- }
+-
+-####################################################
+-# do_send_mail
+-####################################################
+-# Sends a message to a list by the Web interface
+-# or an html page getting its url.
+-# Need MIME::Lite - MIME::Lite::HTML - EMAIL::DATE::FORMAT
+-# It uses mail::mail_file() to do it.
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest'
+-# | 'info' | undef
+-#
+-####################################################
+- sub do_send_mail {
+-
+- &wwslog('info', 'do_send_mail');
+-
+- # Get the sender mail
+- my $from = $param->{'user'}{'email'};
+- my $to;
+- # Send the message to the list or to the sender as clicking the send to the list or to me.
+- # First if : send to the list
+- if ($in{'sub_action'} eq 'sendmailtolist'){
+-
+- # In archive we hide email replacing @ by ' '. Here we must do the reverse transformation
+- $in{'to'} =~ s/ /\@/g;
+- $to = $in{'to'};
+-
+- unless ($in{'to'}) {
+- unless ($param->{'list'}) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
+- &wwslog('info','do_send_mail: no list');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_list','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- unless ($param->{'may_post'}) {
+- &report::reject_report_web('auth',$param->{'may_post_reason'},{},$param->{'action'},$list);
+- &wwslog('info','do_send_mail: may not send message');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- $to = $list->get_list_address();
+- }
+- }
+-
+- # Send the mail to the sender. To test his message
+- # Second if : send to the sender "send to me"
+- if($in{'sub_action'} eq 'sendmailtome') {
+- #Set the sender mail to the addressee
+- $to = $from;
+- }
+-
+- if (defined $param->{'subscriber'}) {
+- $from = &tools::addrencode($from, $param->{'subscriber'}{'gecos'},
+- &Language::GetCharset());
+- }
+-
+- ##--------------- TOPICS --------------------
+- my $list_topics;
+- if ($list->is_there_msg_topic()) {
+- my @msg_topics;
+-
+- foreach my $msg_topic (@{$list->{'admin'}{'msg_topic'}}) {
+- my $var_name = "topic_"."$msg_topic->{'name'}";
+- if ($in{"$var_name"}) {
+- push @msg_topics, $msg_topic->{'name'};
+- }
+- }
+-
+- $list_topics = join(',',@msg_topics);
+- }
+-
+- if (!$list_topics && $list->is_msg_topic_tagging_required()) {
+- &report::reject_report_web('user','msg_topic_missing',{},$param->{'action'});
+- &wwslog('info','do_send_mail: message(s) without topic but in a required list');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_topic','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- if ($list_topics) {
+- my $filetopic = $list->tag_topic($in{'message_id'},$list_topics,'sender');
+- }
+-
+- ##--------------- send an html page or a message --------------------
+-
+- if ($in{'html_news_letter'}) {
+-
+- # url should not be empty -> missing argument
+- if ($in{'url'} =~ /^\s*$/) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'url'},$param->{'action'});
+- ($Log::log_level >= 0) && &wwslog('info','Missing url');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_url','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- # Generate a newsletter from an HTML URL and send it to a list by the Web interface.
+- # Else you must use parse routine of MIME::Lite::HTML and send of MIME::Lite.
+- my $mailHTML = new MIME::Lite::HTML(
+- {
+- From => $from,
+- To => $to,
+- Headers => {'In-Reply-To' => $in{'in_reply_to'}, 'Message-ID' => $in{'message_id'}},
+- 'return_path' => &Conf::get_robot_conf($robot, 'sympa'),
+- Subject => $in{'subject'},
+- HTMLCharset => 'utf-8',
+- TextCharset => 'utf-8',
+- TextEncoding => '8bit',
+- HTMLEncoding => '8bit',
+- remove_jscript => '1', #delete the scripts in the html
+- }
+- );
+- my $pages_url;
+- $pages_url = $in{'url'};
+-
+- # parse return the MIME::Lite part to send
+- my $MIMEmail = $mailHTML->parse($pages_url);
+-
+- $in{'body'} = $MIMEmail->as_string;
+-
+- }else{
+-
+- ## Message body should not be empty
+- if ($in{'body'} =~ /^\s*$/) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'body'},$param->{'action'});
+- ($Log::log_level >= 0) && &wwslog('info','Missing body');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_body','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- $in{'body'} = "\n".$in{'body'};
+- }
+-
+- my $data = {'headers' => {'Message-ID' => $in{'message_id'}},
+- 'subject' => $in{'subject'},
+- 'return_path' => &Conf::get_robot_conf($robot, 'sympa'),
+- 'to' => $to,
+- 'body' => "From: $from\n" . $in{'body'},
+- 'sign_mode' => '',
+- 'header_possible' => '1'};
+-
+- $data->{'headers'}{'In-Reply-To'} = $in{'in_reply_to'} if (($in{'in_reply_to'}) && $in{'in_reply_to'} ne '<>');
+- $data->{'not_auto_submitted'} = 1;
+- unless (&mail::mail_file('', $to, $data, $robot)) {
+- &report::reject_report_web('intern','cannot_send_mail',{'from' => $param->{'user'}{'email'},'listname'=>$list->{'name'}},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_send_mail: failed to send message for $to list');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'info';
+-
+- }
+-
+-####################################################
+-# do_request_topic
+-####################################################
+-# Web page for a sender to tag his mail in message
+-# topic context.
+-#
+-# IN : -
+-#
+-# OUT : '1' | 'loginrequest' | undef
+-#
+-####################################################
+- sub do_request_topic {
+- &wwslog('info', 'do_request_topic(%s)', $in{'authkey'});
+-
+- unless ($list->is_there_msg_topic()) {
+- &report::reject_report_web('user','no_topic',{},$param->{'action'},$list);
+- &wwslog('info','do_request_topic: list without topic message');
+- return undef;
+- }
+-
+- foreach my $top (@{$list->{'admin'}{'msg_topic'}}) {
+- if ($top->{'name'}) {
+- push (@{$param->{'available_topics'}},$top);
+- }
+- }
+-
+- $param->{'to'} = $list->get_list_address();
+- $param->{'mailto'}= &mailto($list,$param->{'to'});
+- $param->{'authkey'} = $in{'authkey'};
+-
+- my $listname = $list->{'name'};
+- my $authqueue = &Conf::get_robot_conf($robot,'queueauth');
+- my $filename = "$authqueue\/$listname\_$in{'authkey'}";
+-
+- ## For compatibility concerns
+- foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
+- $filename = $authqueue.'/'.$list_id.'_'.$in{'authkey'};
+- last if (-f $filename);
+- }
+-
+- my $parser;
+- unless ($parser = new MIME::Parser) {
+- &report::reject_report_web('intern','cannot_parse_message',{'file' => $filename},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('notice', 'Cannot parse message %s', $filename);
+- return undef;
+- }
+- $parser->output_to_core(1);
+-
+- unless (open FILE, "$filename") {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $filename},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('notice', 'Cannot open file %s', $filename);
+- return undef;
+- }
+- my $msg = $parser->parse(\*FILE);
+- my $head = $msg->head();
+- # headers will be encoded later.
+- #XXX$param->{'subject'}= &MIME::Words::encode_mimewords($head->get('subject'));
+- $param->{'subject'} = MIME::EncWords::decode_mimewords($head->get('subject'), Charset=>'utf8');
+- chomp $param->{'subject'};
+- $param->{'subject'} = &tools::escape_html($param->{'subject'});
+- $param->{'from'} = MIME::EncWords::decode_mimewords($head->get('from'), Charset=>'utf8');
+- chomp $param->{'from'};
+- $param->{'from'} = &tools::escape_html($param->{'from'});
+- $param->{'date'} = MIME::EncWords::decode_mimewords($head->get('date'), Charset=>'utf8');
+- chomp $param->{'date'};
+- $param->{'date'} = &tools::escape_html($param->{'date'});
+- $param->{'message_id'} = &tools::clean_msg_id($head->get('Message-Id'));
+-
+- my $body = $msg->bodyhandle();
+- if ($body) {
+- $param->{'body'} = $body->as_string();
+- }else{
+- $param->{'body'} = '';
+- }
+- $param->{'topic_required'} = $list->is_msg_topic_tagging_required();
+-
+- return 1;
+- }
+-
+-####################################################
+-# do_tag_topic_by_sender
+-####################################################
+-# Tag a mail by its sender : tag the mail and
+-# send a command CONFIRM for it
+-#
+-# IN : -
+-#
+-# OUT : 'loginrequest' | 'info' | undef
+-#
+-####################################################
+- sub do_tag_topic_by_sender {
+- &wwslog('info', 'do_tag_topic_by_sender');
+-
+- my $parser;
+- my $listname = $list->{'name'};
+- my $authqueue = &Conf::get_robot_conf($robot,'queueauth');
+- my $filename = "$authqueue\/$listname".'@'."$robot\_$in{'authkey'}";
+-
+- my $mail ;
+- unless($mail = new Message($filename,'noxsympato')) {
+- &report::reject_report_web('intern','cannot_parse_message',{'file' => $filename},$param->{'action'});
+- &wwslog('info','do_tag_topic_by_sender: cannot parse message %s',$filename);
+- return undef;
+- }
+- my $sender = $mail->{'sender'};
+-
+- unless ($list->is_there_msg_topic()) {
+- &report::reject_report_web('user','no_topic',{},$param->{'action'},$list);
+- &wwslog('info','do_tag_topic_by_sender: list without topic message');
+- return undef;
+- }
+-
+- my @msg_topics;
+- foreach my $msg_topic (@{$list->{'admin'}{'msg_topic'}}) {
+- my $var_name = "topic_"."$msg_topic->{'name'}";
+- if ($in{"$var_name"}) {
+- push @msg_topics, $msg_topic->{'name'};
+- }
+- }
+- my $list_topics = join(',',@msg_topics);
+-
+- if (!$list_topics && $list->is_msg_topic_tagging_required()) {
+- &report::reject_report_web('user','msg_topic_missing',{},$param->{'action'},$list);
+- &wwslog('info','do_tag_topic_by_sender: message without topic but in a required list');
+- return undef;
+- }
+-
+- ## TAG
+- my $filetopic = $list->tag_topic($in{'message_id'},$list_topics,'sender');
+-
+- ## CONFIRM
+- my $time = time;
+- my $data = {'headers' => {'Message-ID' => '<'.$time.'@wwsympa>',
+- 'X-Sympa-NoWrap' => 'yes'},
+- 'from'=> $sender};
+-
+- $data->{'body'} = sprintf ("QUIET CONFIRM %s\n",$in{'authkey'});
+-
+- my $queueauth = &Conf::get_robot_conf($robot, 'queueauth');
+- my $filemsg = "$queueauth/$list->{'name'}_$in{'authkey'}";
+-
+- ## For compatibility concerns
+- foreach my $list_id ($list->get_list_id(),$list->{'name'}) {
+- $filemsg = $queueauth.'/'.$list_id.'_'.$in{'authkey'};
+- last if (-f $filemsg);
+- }
+-
+- unless ($filemsg && (-r $filemsg)) {
+- &report::reject_report_web('intern','tag_topic_by_sender_failed',{'key' => $in{'authkey'}},$param->{'action'},$robot);
+- &wwslog('err', 'do_tag_topic_by_sender: Unable to find message %s from %s, auth failed', $in{'authkey'},$param->{'user'}{'email'});
+- return undef;
+- }
+-
+- $data->{'not_auto_submitted'} = 1;
+- unless (&mail::mail_file('',&Conf::get_robot_conf($robot, 'sympa'),$data,$robot)) {
+- &report::reject_report_web('intern','cannot_send_mail',{'from' => $param->{'user'}{'email'},'listname'=>$list->{'name'}},
+- $param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err','do_tag_topic_by_sender: failed to send message for file %s', $filemsg);
+- return undef;
+- }
+-
+- &report::notice_report_web('performed_soon',{},$param->{'action'});
+- return 'info';
+- }
+-
+-
+-
+- sub do_search_user {
+- &wwslog('info', 'do_search_user');
+-
+- if ($in{'email'} =~ /[<>\\\*\$]/) {
+- &report::reject_report_web('user','syntax_errors',{'params' => 'email'},$param->{'action'});
+- &wwslog('err','do_search_user: syntax error');
+- return undef;
+- }
+-
+- foreach my $role ('member','owner','editor') {
+- foreach my $list ( &List::get_which($in{'email'},$robot, $role) ) {
+- my $l = $list->{'name'};
+-
+- next unless (defined $list);
+- $param->{'which'}{$l}{'subject'} = $list->{'admin'}{'subject'};
+- $param->{'which'}{$l}{'host'} = $list->{'admin'}{'host'};
+-
+- # show the requestor role not the requested one
+- if ( ($list->am_i('owner',$param->{'user'}{'email'}) || $list->am_i('editor',$param->{'user'}{'email'})) ) {
+- $param->{'which'}{$l}{'admin'} = 1;
+- }
+-
+- if ($role eq 'member') {
+- $param->{'which'}{$l}{'is_member'} = 1;
+- $param->{'which'}{$l}{'reception'} = $list->{'user'}{'reception'};
+- $param->{'which'}{$l}{'include_source'} = $list->{'user'}{'include_source'};
+- $param->{'which'}{$l}{'bounce'} = $list->{'user'}{'bounce'} ;
+- $param->{'which'}{$l}{'topic'} = $list->{'user'}{'topic'} ;
+- $param->{'which'}{$l}{'included'} = $list->{'user'}{'included'} if ($list->{'user'}{'included'} == 1) ;
+- $param->{'which'}{$l}{'subscribed'} = $list->{'user'}{'subscribed'} if ($list->{'user'}{'subscribed'} == 1);
+- my $un = $list->{'user'}{'subscribed'};
+-# $param->{'which'}{$l}{'subscribed'} = 1;
+-
+- }elsif ($role eq 'owner') {
+- $param->{'which'}{$l}{'is_owner'} = 1;
+- }elsif ($role eq 'editor') {
+- $param->{'which'}{$l}{'is_editor'} = 1;
+- }
+- }
+- }
+-
+- $param->{'email'} = $in{'email'};
+-
+- unless (defined $param->{'which'}) {
+- &report::reject_report_web('user','no_entry',{'email' => $in{'email'}},$param->{'action'});
+- &wwslog('info','do_search_user: no entry for %s', $in{'email'});
+- return 'serveradmin';
+- }
+-
+- return 1;
+- }
+-
+- ## Set language
+- sub do_set_lang {
+- &wwslog('info', 'do_set_lang(%s)', $in{'lang'});
+-
+- $session->{'lang'} = $in{'lang'} ;
+- $param->{'lang'} = $in{'lang'};
+-
+- if ($param->{'user'}{'email'}) {
+- if (&List::is_user_db($param->{'user'}{'email'})) {
+- unless (&List::update_user_db($param->{'user'}{'email'}, {'lang' => $in{'lang'}})) {
+- &report::reject_report_web('intern','update_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_set_lang: update failed');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'lang'}",'target_email' => "$param->{'user'}{'email'}",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }else {
+- unless (&List::add_user_db({'email' => $param->{'user'}{'email'}, 'lang' => $in{'lang'}})) {
+- &report::reject_report_web('intern','add_user_db_failed',{'user'=>$param->{'user'}{'email'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_set_lang: update failed');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'lang'}",'target_email' => "$param->{'user'}{'email'}",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+- }
+-
+- if ($in{'previous_action'}) {
+- ## Some actions don't make sense with GET method, redirecting to other functions
+- if ($in{'previous_action'} eq 'arcsearch') {
+- $in{'previous_action'} = 'arc';
+- }
+- $in{'list'} = $in{'previous_list'};
+- return $in{'previous_action'};
+- }
+-
+- return 'home';
+- }
+- ## Function do_attach
+- sub do_attach {
+- &wwslog('info', 'do_attach(%s,%s)', $in{'dir'},$in{'file'});
+-
+-
+- ### Useful variables
+-
+- # current list / current shared directory
+- my $list_name = $list->{'name'};
+-
+- # path of the urlized directory
+- my $urlizeddir = $list->{'dir'}.'/urlized';
+-
+- # document to read
+- my $doc = $urlizeddir.'/'.$in{'dir'}.'/'.$in{'file'};
+-
+- ### Document exist ?
+- unless (-e "$doc") {
+- &wwslog('info',"do_attach : unable to read $doc : no such file or directory");
+- &report::reject_report_web('user','no_such_document',{'path' => $in{'dir'}.'/'.$in{'file'}},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'dir'},$in{'file'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ### Document has non-size zero?
+- unless (-s "$doc") {
+- &wwslog('info',"do_attach : unable to read $doc : empty document");
+- &report::reject_report_web('user','empty_document',{'path' => $in{'dir'}.'/'.$in{'file'}},$param->{'action'},$list);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'dir'},$in{'file'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'empty_file','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ## Access control
+- return undef unless (defined &check_authz('do_attach', 'web_archive.access'));
+-
+- # parameters for the template file
+- # view a file
+- $param->{'file'} = $doc;
+- $param->{'bypass'} = 'asis';
+-
+- ## File type
+- if ($in{'file'} =~ /\.(\w+)$/) {
+- $param->{'file_extension'} = $1;
+- }
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'dir'},$in{'file'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- sub do_subindex {
+- &wwslog('info', 'do_subindex');
+-
+- my $subscriptions = $list->get_subscription_requests();
+- foreach my $sub (keys %{$subscriptions}) {
+- $subscriptions->{$sub}{'date'} = gettext_strftime "%d %b %Y", localtime($subscriptions->{$sub}{'date'});
+- }
+-
+- $param->{'subscriptions'} = $subscriptions;
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+- }
+-
+- sub do_ignoresub {
+- &wwslog('info', 'do_ignoresub');
+-
+- my @users;
+-
+- foreach my $pair (split /\0/, $in{'pending_email'}) {
+- if ($pair =~ /,/) {
+- push @users, $`;
+- }
+- }
+-
+- foreach my $u (@users) {
+- unless ($list->delete_subscription_request($u)) {
+- &report::reject_report_web('intern','del_sub_request',{'sub'=>$u},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_ignoresub: delete_subscription_request(%s) failed', $u);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'subindex';
+- }
+- }
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'subindex';
+- }
+-
+-sub do_stats {
+- &wwslog('info', 'do_stats');
+-
+- $param->{'shared_size'} = int (($list->get_shared_size + 512)/1024);
+- $param->{'arc_size'} = int (($list->get_arc_size($wwsconf->{'arc_path'}) + 512)/1024);
+-
+- return 1;
+-}
+-
+-
+-## setting the topics list for templates
+-sub export_topics {
+-
+- my $robot = shift;
+- wwslog ('debug2',"export_topics($robot)");
+- my %topics = &List::load_topics($robot);
+-
+- unless (%topics) {
+- &wwslog('err','No topics defined');
+- return undef;
+- }
+-
+- ## Remove existing topics
+- $param->{'topics'} = undef;
+-
+- my $total = 0;
+- foreach my $t (sort {$topics{$a}{'order'} <=> $topics{$b}{'order'}} keys %topics) {
+- my $result = &Scenario::request_action ('topics_visibility', $param->{'auth_method'},$robot,
+- {'topicname' => $t,
+- 'sender' => $param->{'user'}{'email'},
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $action;
+- $action = $result->{'action'} if (ref($result) eq 'HASH');
+- next unless ($action =~ /do_it/);
+-
+- my $current = $topics{$t};
+- $current->{'id'} = $t;
+-
+- ## For compatibility reasons
+- $current->{'mod'} = $total % 3;
+- $current->{'mod2'} = $total % 2;
+-
+- push @{$param->{'topics'}}, $current;
+-
+- $total++;
+- }
+-
+- push @{$param->{'topics'}}, {'id' => 'topicsless',
+- 'mod' => $total,
+- 'sub' => {}
+- };
+-
+- $param->{'topics'}[int($total / 2)]{'next'} = 1;
+- }
+-
+-
+-# manage blacklist
+-sub do_blacklist {
+- &wwslog('info', 'do_blacklist(%d)', $param->{'list'});
+-
+- unless ($param->{'list'}){
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
+- &wwslog('info','do_blacklist: no list');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'no_list','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- unless($param->{'is_owner'}|| $param->{'is_editor'} || $param->{'is_listmaster'}) {
+- &wwslog('info','do_blacklist : not listmaster or list owner or list editor');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- my $file = $list->{'dir'}.'/search_filters/blacklist.txt';
+- $param->{'rows'} = 0 ;
+-
+- if (defined $in{'blacklist'}){
+- &wwslog('info','do_blacklist : submit blacklist update');
+- my $dir = $list->{'dir'}.'/search_filters';
+- unless ((-d $dir) || mkdir ($dir, 0755)) {
+- &report::reject_report_web('intern','unable to create dir');
+- &wwslog('info','do_blacklist : unable to create dir %s',$dir);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+- my $file = $dir.'/blacklist.txt';
+- unless (open BLACKLIST, "> $file"){
+- &report::reject_report_web('intern','unable to create file');
+- &wwslog('info','do_blacklist : unable to create file %s',$file);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+- my @lines = split(/\n/, $in{'blacklist'});
+- $param->{'ignored'} = 0;
+- my $count = 0; # count utils lines in order to remove empty blacklist file
+- foreach my $line (@lines) {
+- $line =~ s/\015//;
+-
+- if ($line =~ /\*.*\*/) {
+- $param->{'ignored_linest'} .= $line."\n";
+- $param->{'ignored'} += 1;
+- }else{
+- printf BLACKLIST "$line\n";
+- $param->{'blacklist'} .= $line."\n";
+- $param->{'rows'} += 1;
+- $count += 1 unless ($line =~ /^\s*$/o || /^[\#\;]/o);
+- }
+- }
+- close BLACKLIST;
+- if ($count == 0) {
+- unless (unlink $file) {
+- &report::reject_report_web('intern','unable to remove empty blacklist file');
+- &wwslog('info','do_blacklist : unable to remove empty blacklist file %s',$file);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+- &wwslog('info','do_blacklist : removed empty blacklist file %s',$file);
+- }
+- }else{
+- if (-f $file) {
+- unless (open BLACKLIST, $file) {
+- &report::reject_report_web('intern','unable to open file',{'file' => $file,$param->{'action'},'',$param->{'user'}{'email'}},$robot);
+- &wwslog('err','unable to read %s',$file);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+- while (<BLACKLIST>) {
+- $param->{'blacklist'} .= $_ ;
+- $param->{'rows'} += 1;
+- }
+- close BLACKLIST;
+- }
+- }
+-
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$param->{'list'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+-}
+-
+-# output in text/plain format a scenario
+-sub do_dump_scenario {
+- &wwslog('info', "do_dump_scenario($param->{'list'}), $in{'pname'}");
+-
+- my $scenario = new Scenario ('function' => $in{'pname'},
+- 'robot' => $robot,
+- 'name' => $list->{'admin'}{$in{'pname'}}{'name'},
+- 'directory' => $list->{'dir'});
+- unless (defined $scenario) {
+- &report::reject_report_web('intern','cannot_open_file',{},$param->{'action'},$list);
+- &wwslog('info','failed to load scenario');
+- return undef;
+- }
+- ($param->{'dumped_scenario'}, $param->{'scenario_path'}) = ($scenario->{'data'}, $scenario->{'file_path'});
+- $param->{'pname'} = $in{'pname'};
+- $param->{'scenario_name'} = $list->{'admin'}{$in{'pname'}}{'name'};
+-
+- if ($in{'new_scenario_name'}) {
+- # in this case it's a submit.
+- my $scenario_dir = $list->{'dir'}.'/scenari/';
+- my $scenario_file = $scenario_dir.$in{'pname'}.'.'.$in{'new_scenario_name'} ;
+- if ($param->{'dumped_scenario'} eq $in{'new_scenario_content'}){
+- &wwslog('info','do_dump_scenario: scenario unchanged');
+- $param->{'result'} = 'unchanged';
+- return 1;
+- }
+- unless (-d $scenario_dir) {
+- unless (mkdir ($scenario_dir, 0777)) {
+- &do_log('err',"do_dump_scenario: cannot_create_dir %s : %s ", $scenario_dir, $!);
+- &report::reject_report_web('intern','cannot_create_dir',{'file' => $scenario_dir,$param->{'action'},'',$param->{'user'}{'email'}},$robot);
+- return undef;
+- }
+- }
+- unless (open SCENARIO , ">$scenario_file") {
+- &wwslog('info','do_dump_scenario: cannot_open_file %s', $scenario_file);
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $scenario_file,$param->{'action'},'',$param->{'user'}{'email'}},$robot);
+- return undef;
+- }
+- print SCENARIO $in{'new_scenario_content'};
+- close SCENARIO;
+- # load the new scenario in the list config.
+- if ($in{'new_scenario_name'} eq $in{'scenario_name'}) {
+- $param->{'result'} = 'success';
+- }else{
+- $param->{'result'} = 'success_new_name';
+- }
+- }
+- return 1 ;
+-}
+-
+- ## Subscribers' list
+- sub do_dump {
+- &wwslog('info', "do_dump($param->{'list'})");
+-
+- ## Whatever the action return, it must never send a complex html page
+- $param->{'bypass'} = 1;
+- $param->{'content_type'} = "text/plain";
+- $param->{'file'} = undef ;
+-
+- ## Access control
+- unless (defined &check_authz('do_dump', 'review')) {
+- undef $param->{'bypass'};
+- return undef;
+- }
+-
+- $list->dump();
+- $param->{'file'} = $list->{'dir'}.'/subscribers.db.dump';
+-
+- if ($in{'format'} eq 'light') {
+- unless (open (DUMP,$param->{'file'} )) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $param->{'file'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog ('info', 'unable to open file %s\n',$param->{'file'} );
+- return undef;
+- }
+- unless (open (LIGHTDUMP,">$param->{'file'}.light")) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => "$param->{'file'}.light"},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err','unable to create file %s.light\n',$param->{'file'} );
+- return undef;
+- }
+- while (<DUMP>){
+- next unless ($_ =~ /^email\s(.*)/);
+- print LIGHTDUMP "$1\n";
+- }
+- close LIGHTDUMP;
+- close DUMP;
+- $param->{'file'} = "$list->{'dir'}/subscribers.db.dump.light";
+-
+- } else {
+- $param->{'file'} = "$list->{'dir'}/select.dump";
+- &wwslog('info','opening %s',$param->{'file'});
+-
+- unless (open (DUMP,">$param->{'file'}")) {
+- &report::reject_report_web('intern','file_update_failed',{},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err','unable to create file %s\n',$param->{'file'} );
+- return undef;
+- }
+-
+- if ($in{'format'} eq 'bounce') {
+- $in{'size'} = 'all';
+- do_reviewbouncing();
+- print DUMP "# Exported bouncing subscribers\n";
+- print DUMP "# Email\t\tName\tBounce score\tBounce count\tFirst bounce\tLast bounce\n";
+- foreach my $user (@{$param->{'members'}}){
+- print DUMP "$user->{'email'}\t$user->{'gecos'}\t$user->{'bounce_score'}\t$user->{'bounce_count'}\t$user->{'first_bounce'}\t$user->{'last_bounce'}\n";
+- }
+- }
+- else {
+- $in{'filter'} = $in{'format'};
+- do_search();
+- print DUMP "# Exported subscribers with search filter \"$in{'format'}\"\n";
+- foreach my $user (@{$param->{'members'}}){
+- print DUMP "$user->{'email'}\t$user->{'gecos'}\n";
+- }
+- }
+- close DUMP;
+- }
+- return 1;
+- }
+-
+-
+-## returns a mailto according to list spam protection parameter
+-sub mailto {
+-
+- my $list = shift;
+- my $email = shift;
+- my $gecos = shift;
+- my $next_one;
+-
+- my $mailto = '';
+- my @addresses;
+- my %recipients;
+-
+- @addresses = split (',',$email);
+-
+- $gecos = $email unless ($gecos);
+- $gecos =~ s/&/&/g;
+- $gecos =~ s/</</g;
+- $gecos =~ s/>/>/g;
+- foreach my $address (@addresses) {
+-
+- ($recipients{$address}{'local'},$recipients{$address}{'domain'}) = split ('@',$address);
+- }
+-
+- if ($list->{'admin'}{'spam_protection'} eq 'none') {
+- $mailto .= "<a href=\"mailto:?";
+- foreach my $address (@addresses) {
+- $mailto .= "&" if ($next_one);
+- $mailto .= "to=$address";
+- $next_one = 1;
+- }
+- $mailto .= "\">$gecos</a>";
+- }elsif($list->{'admin'}{'spam_protection'} eq 'javascript') {
+-
+- if ($gecos =~ /\@/) {
+- $gecos =~ s/@/\" + \"@\" + \"/;
+- }
+-
+- $mailto .= "<script type=\"text/javascript\">
+- <!--
+- document.write(\"<a href=\\\"\" + \"mail\" + \"to:?\" + ";
+- foreach my $address (@addresses) {
+- $mailto .= "\"\&\;\" + " if ($next_one);
+- $mailto .= "\"to=\" + \"$recipients{$address}{'local'}\" + \"@\" + \"$recipients{$address}{'domain'}\" + ";
+- $next_one = 1;
+- }
+- $mailto .= "\"\\\">$gecos<\" + \"/a>\")
+- // --></script>";
+-
+- }elsif($list->{'admin'}{'spam_protection'} eq 'at') {
+- foreach my $address (@addresses) {
+- $mailto .= " AND " if ($next_one);
+- $mailto .= "$recipients{$address}{'local'} AT $recipients{$address}{'domain'}";
+- $next_one = 1;
+- }
+- }
+- return $mailto;
+-
+-}
+-
+-## Returns a spam-protected form of email address
+-sub get_protected_email_address {
+- my ($local_part, $domain_part) = @_;
+-
+- if($list->{'admin'}{'spam_protection'} eq 'javascript') {
+-
+- my $return = "<script type=\"text/javascript\">
+- <!--
+- document.write(\"$local_part\" + \"@\" + \"$domain_part\")
+- // --></script>";
+- return ($return);
+- }elsif($list->{'admin'}{'spam_protection'} eq 'at') {
+- return ("$local_part AT $domain_part");
+- }else {
+- return($local_part.'@'.$domain_part);
+- }
+-
+-}
+-
+- ## view logs stored in RDBMS
+- ## this function as been writen in order to allow list owner and listmater to views logs
+- ## of there robot or there is real problems with privacy policy and law in such services.
+- ##
+-sub do_viewlogs {
+- &wwslog('info', 'do_viewlogs(%d)',$in{'page'});
+-
+- my $size = $in{'size'} || $wwsconf->{'viewlogs_page_size'};
+- my $sortby = $in{'sortby'} || 'email';
+- my @date = &Log::get_log_date();
+-
+- $param->{'date_from_formated'} = gettext_strftime "%Y-%m-%d-%H-%M-%S", localtime($date[0]);
+- $param->{'date_to_formated'} = gettext_strftime "%Y-%m-%d-%H-%M-%S", localtime($date[1]);
+-
+- $param->{'total'} = '17';
+-
+- unless ($param->{'total'}) {
+- &report::reject_report_web('user','no_logs',{},$param->{'action'});
+- &wwslog('info','do_viewlogs: no subscriber');
+- return 1;
+- }
+-
+- ## Owner
+- $param->{'page'} = $in{'page'} || 1;
+- $param->{'total_page'} = int ($param->{'total'} / $size);
+- $param->{'total_page'} ++ if ($param->{'total'} % $size);
+-
+- if ($param->{'page'} > $param->{'total_page'}) {
+- &report::reject_report_web('user','no_page',{'page' => $param->{'page'}},$param->{'action'});
+- ('wwsympa',$param->{'user'}{'email'},$param->{'auth_method'},$ip,'review',$param->{'list'},$robot,'','out of pages');
+- &wwslog('info','do_viewlogs: no page %d', $param->{'page'});
+- return undef;
+- }
+-
+- my $offset;
+- if ($param->{'page'} > 1) {
+- $offset = (($param->{'page'} - 1) * $size);
+- }else {
+- $offset = 0;
+- }
+-
+-
+- my @lines;
+-
+- #display and search parameters preparation
+- my $select = {};
+-
+- $select->{'robot'} = $robot;
+- $select->{'list'} = $param->{'list'};
+-
+- foreach my $p ('target_type','target','date_deb','date_fin','type','ip') {
+- $param->{$p} = $in{$p};
+- $select->{$p} = $in{$p};
+- }
+-
+- unless ($in{'first'}) {
+- #sending of search parameters for the query
+- my $line = &Log::get_first_db_log($select);
+- unless (defined $line) {
+- &report::reject_report_web('intern','db_error',{},$param->{'action'}, $param->{'list'}, $param->{'user'}{'email'}, $robot);
+- &wwslog('info','do_viewlogs failed to get logs from DB');
+- return undef;
+- }
+-
+- do {
+- last unless (defined $line->{'date'}); ## Means an empty entry
+- $line->{'date'} = gettext_strftime "%d %b %Y %H:%M:%S", localtime($line->{'date'});
+- push @{$param->{'log_entries'}}, $line;
+- } while ($line = &Log::get_next_db_log());
+-
+-
+- #display the number of rows of the query.
+- if (&Log::return_rows_nb() != 0) {
+- $param->{'rows_nb'} = &Log::return_rows_nb();
+- }else {
+- $param->{'rows_nb'} = undef;
+- }
+-
+- if ($param->{'page'} > 1) {
+- $param->{'prev_page'} = $param->{'page'} - 1;
+- }
+-
+- unless (($offset + $size) >= $param->{'total'}) {
+- $param->{'next_page'} = $param->{'page'} + 1;
+- }
+-
+- $param->{'size'} = $size;
+- $param->{'sortby'} = $sortby;
+- }
+-
+-
+- return 1;
+-}
+-
+-
+-sub do_arc_manage {
+- &wwslog('info', "do_arc_manage ($in{'list'})");
+-
+- my $search_base = $wwsconf->{'arc_path'}.'/'.$list->get_list_id();
+- opendir ARC, "$search_base";
+- foreach my $dir (sort {$b cmp $a} grep(!/^\./,readdir ARC)) {
+- if ($dir =~ /^(\d{4})-(\d{2})$/) {
+- push @{$param->{'yyyymm'}}, $dir;
+- }
+- }
+- closedir ARC;
+-
+- return 1;
+-}
+-
+-## create a zip file with archives from (list,month)
+-sub do_arc_download {
+-
+- &wwslog('info', "do_arc_download ($in{'list'})");
+-
+- ##zip file name:listname_archives.zip
+- my $zip_file_name = $in{'list'}.'_archives.zip';
+- my $zip_abs_file = $Conf{'tmpdir'}.'/'.$zip_file_name;
+- my $zip = Archive::Zip->new();
+-
+- #Search for months to put in zip
+- unless (defined($in{'directories'})) {
+- &report::reject_report_web('user','select_month',{},$param->{'action'});
+- &wwslog('info','do_arc_download : no archives specified');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'select_month','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'arc_manage';
+- }
+-
+- #for each selected month
+- foreach my $dir (split/\0/, $in{'directories'}) {
+- ## Tainted vars problem
+- if ($dir =~ /^(\d+\-\d+)$/) {
+- $dir = $1;
+- }
+-
+- my $abs_dir = $wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$dir.'/arctxt';
+- ##check arc directory
+- unless (-d $abs_dir) {
+- &report::reject_report_web('intern','arc_not_found',{'arc_file' => $dir,
+- 'listname' => $in{'list'},
+- 'path' => $abs_dir},
+- $param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','archive %s not found',$dir);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- next;
+- }
+-
+- $zip->addDirectory($abs_dir, $in{'list'}.'_'.$dir);
+-
+- unless (opendir SPOOL, $abs_dir) {
+- &report::reject_report_web('intern','cannot_open_dir',{'dir' =>$abs_dir },$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_arc_download: unable to open %s', $abs_dir);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- foreach my $msg (sort grep(!/^\./, readdir SPOOL)) {
+- unless ($zip->addFile ($abs_dir.'/'.$msg, $in{'list'}.'_'.$dir.'/'.$msg)) {
+- &report::reject_report_web('intern','add_file_zip',{'file' => "$abs_dir/$msg"},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','do_arc_download: failed to add %s file to archive', $abs_dir.'/'.$msg);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- }
+-
+- closedir SPOOL;
+-
+- ## create and fill a new folder in zip
+- #$zip->addTree ($abs_dir, $in{'list'}.'_'.$dir);
+- }
+-
+- ## check if zip isn't empty
+- if ($zip->numberOfMembers()== 0) {
+- &report::reject_report_web('intern','inaccessible_archive',{'listname' => $in{'list'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('info','Error : empty directories');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- ##writing zip file
+- unless ($zip->writeToFileNamed($zip_abs_file) == AZ_OK){
+- &report::reject_report_web('intern','write_file_zip',{'zipfile'=>$zip_abs_file},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog ('info', 'Error while writing Zip File %s\n',$zip_file_name);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- ##Sending Zip to browser
+- $param->{'bypass'} ='extreme';
+- printf("Content-Type: application/zip;\nContent-disposition: filename=\"%s\";\n\n",$zip_file_name);
+- ##MIME Header
+- unless (open (ZIP,$zip_abs_file)) {
+- &report::reject_report_web('intern','cannot_open_file',{'file' => $zip_abs_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog ('info', 'Error while reading Zip File %s\n',$zip_abs_file);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+- print <ZIP>;
+- close ZIP ;
+-
+- ## remove zip file from server disk
+- unless (unlink ($zip_abs_file)){
+- &report::reject_report_web('intern','erase_file',{'file' => $zip_abs_file},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog ('info', 'Error while unlinking File %s\n',$zip_abs_file);
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- }
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+-}
+-
+-sub do_arc_delete {
+-
+- my @abs_dirs;
+-
+- &wwslog('info', "do_arc_delete ($in{'list'})");
+-
+- unless (defined $in{'directories'}){
+- &report::reject_report_web('user','select_month',{},$param->{'action'});
+- &wwslog('info','No Archives months selected');
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'select_month','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'arc_manage';
+- }
+-
+- ## if user want to download archives before delete
+- &wwslog('notice', "ZIP: $in{'zip'}");
+- if ($in{'zip'} == 1) {
+- &do_arc_download();
+- }
+-
+-
+- foreach my $dir (split/\0/, $in{'directories'}) {
+- push(@abs_dirs ,$wwsconf->{'arc_path'}.'/'.$list->get_list_id().'/'.$dir);
+- }
+-
+- unless (tools::remove_dir(@abs_dirs)) {
+- &wwslog('info','Error while Calling tools::remove_dir');
+- }
+-
+- &report::notice_report_web('performed',{},$param->{'action'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'list'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 'arc_manage';
+-}
+-
+-
+-sub do_css {
+- &wwslog('debug', "do_css ($in{'file'})");
+- $param->{'bypass'} = 'extreme';
+- printf "Content-type: text/css\n\n";
+- $param->{'css'} = $in{'file'};
+-
+- my $lang = &Language::Lang2Locale($param->{'lang'});
+- my $tt2_include_path = &tools::make_tt2_include_path($robot,'web_tt2',$lang,'');
+-
+- unless (&tt2::parse_tt2($param,'css.tt2' ,\*STDOUT, $tt2_include_path)) {
+- my $error = &tt2::get_error();
+- $param->{'tt2_error'} = $error;
+- &List::send_notify_to_listmaster('web_tt2_error', $robot, [$error]);
+- &wwslog('info', "do_css/$in{'file'} : error");
+- }
+-
+- return;
+-}
+-
+-sub do_rss_request {
+- &wwslog('info', "do_rss_request");
+-
+- my $args ;
+-
+- $in{'count'} ||= 20;
+- $in{'for'} ||= 10;
+-
+- $args = 'count='.$in{'count'}.'&' if ($in{'count'}) ;
+- $args .= 'for='.$in{'for'} if ($in{'for'});
+- if ($list ) {
+- $param->{'latest_arc_url'} = &Conf::get_robot_conf($robot, 'wwsympa_url')."/rss/latest_arc/".$list->{'name'}."?".$args;
+- $param->{'latest_d_read_url'} = &Conf::get_robot_conf($robot, 'wwsympa_url')."/rss/latest_d_read/".$list->{'name'}."?".$args;
+- }
+- $param->{'active_lists_url'} = &Conf::get_robot_conf($robot, 'wwsympa_url')."/rss/active_lists?".$args;
+- $param->{'latest_lists_url'} = &Conf::get_robot_conf($robot, 'wwsympa_url')."/rss/latest_lists?".$args;
+-
+- $param->{'output'} = 1;
+- return 1;
+-}
+-
+-sub do_wsdl {
+-
+- &wwslog('info', "do_wsdl ()");
+- my $sympawsdl = &tools::get_filename('etc',{}, 'sympa.wsdl', $robot);
+-
+- unless (-r $sympawsdl){
+- &report::reject_report_web('intern','err_404',{},$param->{'action'});
+- &wwslog('err','could not find $sympawsdl');
+- return undef;
+- }
+-
+- my $soap_url= &Conf::get_robot_conf($robot,'soap_url');
+- unless (defined $soap_url) {
+- &report::reject_report_web('user','no_soap_service',{},$param->{'action'});
+- &wwslog('err','No SOAP service was defined in sympa.conf (soap_url parameter)');
+- return undef;
+- }
+-
+- $param->{'bypass'} = 'extreme';
+- printf "Content-type: text/xml\n\n";
+-
+- $param->{'conf'}{'soap_url'} = $soap_url;
+-
+- ## Get the directory path, without the file name
+- my $wsdl_path = $sympawsdl;
+- $wsdl_path =~ s/\/sympa.wsdl//;
+-
+- &tt2::parse_tt2($param, 'sympa.wsdl' , \*STDOUT, [$wsdl_path]);
+-
+-# unless (open (WSDL,$sympawsdl)) {
+-# &error_message('404');
+-# &wwslog('info','could not open $sympawsdl');
+-# return undef;
+-# }
+-# print <WSDL>;
+-# close WSDL;
+- return 1;
+-}
+-
+-## Synchronize list members with data sources
+-sub do_sync_include {
+- &wwslog('info', "do_sync_include($in{'list'})");
+-
+- unless ($list->sync_include()) {
+- &report::reject_report_web('intern','sync_include_failed',{},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- return undef;
+- }
+- &report::notice_report_web('subscribers_updated',{},$param->{'action'});
+- return 'review';
+-}
+-
+-## Review lists from a family
+-sub do_review_family {
+- &wwslog('info', 'do_review_family');
+-
+- my $family = new Family ($in{'family_name'}, $robot);
+- unless (defined $family) {
+- &report::reject_report_web('user','unknown_family',{'family'=>$in{'family_name'}},$param->{'action'},'',$param->{'user'}{'email'},$robot);
+- &wwslog('err', 'do_review_family: incorrect family %s', $in{'family_name'});
+- return undef;
+- }
+-
+- my $all_lists = $family->get_family_lists();
+- foreach my $flist (@{$all_lists}) {
+- my $l = $list->{'name'};
+-
+- unless (defined $flist) {
+- &wwslog('err', 'do_review_family: incorrect list %s', $l);
+- next;
+- }
+- push @{$param->{'family_lists'}}, {'name' => $flist->{'name'},
+- 'status' => $flist->{'admin'}{'status'},
+- 'instantiation_date' => $flist->{'admin'}{'latest_instantiation'}{'date'},
+- 'subject' => $flist->{'admin'}{'subject'},
+- };
+- }
+-
+- return 1;
+-}
+-
+-################################################################
+-## do_ca : executes a custom action
+-##
+-## IN:
+-## - 'custom_action': ther name of the custom action (and subsequent tt2 file to use, see below)
+-## - '@cap': an array of parameters.
+-##
+-## Custom actions are used to display user defined templates.
+-## To use it, follow these steps:
+-## 1- create a new file "your_action.tt2" and put it in the relevant dir (either etc or expl)
+-## 2- in this file, add the HTML fragment you want to insert to the web interface. You don't need the <head/> section or the <body/> tag.
+-## 3- you can type your action URL: http://your-sympa-server-root-url/ca/your_action/param2/param2/param3/...
+-##
+-## the HTML code in 'your_action.tt2' can make use of the parameters this way: [% cap.1 %] for param1, [% cap.2 %] for param, and so on.
+-###############################################################
+-sub do_ca {
+- &wwslog('info', 'custom action: %s (robot %s) with params: (%s, %s, %s, %s, %s)',$in{'custom_action'},$robot,$in{'cap'});
+- $param->{'custom_action'} = $in{'custom_action'};
+- $param->{'cap'} = [split '/',$in{'cap'}];
+- return 1;
+-}
+-
+-################################################################
+-## do_ca : executes a custom action in list context
+-##
+-## IN:
+-## - 'custom_action': ther name of the custom action (and subsequent tt2 file to use, see below)
+-## - 'list': the nalme of the list (without the '@robot' part) in the context of which the action is executed.
+-## - '@lcap': an array of parameters.
+-##
+-## Custom actions are used to display user defined templates.
+-## To use it, follow these steps:
+-## 1- create a new file "your_action.tt2" and put it in the relevant dir (either etc or expl)
+-## 2- in this file, add the HTML fragment you want to insert to the web interface. You don't need the <head/> section or the <body/> tag.
+-## 3- you can type your action URL: http://your-sympa-server-root-url/ca/your_action/param2/param2/param3/...
+-##
+-## the HTML code in 'your_action.tt2' can make use of the parameters this way: [% lcap.1 %] for param1, [% lcap.2 %] for param, and so on.
+-###############################################################
+-sub do_lca {
+- &wwslog('info', 'List custom action: %s for list %s (robot %s) with params: (%s, %s, %s, %s, %s)',$in{'custom_action'},$in{'list'},$robot,$in{'lcap'});
+- $param->{'custom_action'} = $in{'custom_action'};
+- $param->{'cap'} = [split '/',$in{'cap'}];
+- return 1;
+-}
+-
+-## Prepare subscriber data to be prompted on the web interface
+-## Used by review, search,...
+-sub _prepare_subscriber {
+- my $user = shift;
+- my $additional_fields = shift;
+- my $sources = shift;
+-
+- ## Add user
+- $user->{'date'} = gettext_strftime "%d %b %Y", localtime($user->{'date'});
+- $user->{'update_date'} = gettext_strftime "%d %b %Y", localtime($user->{'update_date'});
+-
+- ## Reception mode and topics
+- $user->{'reception'} ||= 'mail';
+- if (($user->{'reception'} eq 'mail') && $user->{'topics'}) {
+- $user->{'reception'} = "topic ($user->{'topics'})";
+- }
+-
+- $user->{'email'} =~ /\@(.+)$/;
+- $user->{'domain'} = $1;
+- $user->{'pictures_url'} = &tools::make_pictures_url('email' => $user->{'email'}, 'list' => $list);
+-
+- ## Escape some weird chars
+- $user->{'escaped_email'} = &tools::escape_chars($user->{'email'});
+-
+- ## Check data sources
+- $user->{'sources'} = $list->get_datasource_name($user->{'id'}) if ($user->{'id'});
+-
+- if (@{$additional_fields}) {
+- my @fields;
+- foreach my $f (@{$additional_fields}) {
+- push @fields, $user->{$f};
+- }
+- $user->{'additional'} = join ',', @fields;
+- }
+-
+- return 1;
+-}
+-
+-## New d_read function using SharedDocument module
+-## The following features should be tested :
+-## * inheritance on privileges
+-## X moderation
+-## * escaping special chars
+-sub new_d_read {
+- &wwslog('info', 'new_d_read(%s)', $in{'path'});
+-
+- ### action relative to a list ?
+- unless ($param->{'list'}) {
+- &report::reject_report_web('user','missing_arg',{'argument' => 'list'},$param->{'action'});
+- &wwslog('err','do_d_read: no list');
+- return undef;
+- }
+-
+- # current list / current shared directory
+- my $list_name = $list->{'name'};
+-
+- my $document = new SharedDocument ($list, $in{'path'}, $param);
+-
+- unless (defined $document) {
+- &report::reject_report_web('intern','new_document_failed',{'path'=>$in{'path'}},$param->{'action'},$list,$param->{'user'}{'email'},$robot);
+- &wwslog('err',"d_read : cannot open $document->{'absolute_path'} : $!");
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'internal','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- my $path = $document->{'path'};
+- my $visible_path = $document->{'visible_path'};
+- my $shareddir = $document->{'shared_dir'};
+- my $doc = $document->{'absolute_path'};
+- my $ref_access = $document->{'access'}; my %access = %{$ref_access};
+- $param->{'doc_owner'} = $document->{'owner'};
+- $param->{'doc_title'} = $document->{'title'};
+- $param->{'doc_date'} = $document->{'date'};
+-
+- ### Access control
+- unless ($access{'may'}{'read'}) {
+- &report::reject_report_web('auth',$access{'reason'}{'read'},{},$param->{'action'},$list);
+- &wwslog('err','d_read : access denied for %s', $param->{'user'}{'email'});
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'error','error_type' => 'authorization','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return undef;
+- }
+-
+- my $may_edit = $access{'may'}{'edit'};
+- my $may_control = $access{'may'}{'control'};
+- $param->{'may_edit'} = $may_edit;
+- $param->{'may_control'} = $may_control;
+-
+- ### File or directory ?
+- if ($document->{'type'} eq 'url') {
+- $param->{'file_extension'} = $document->{'file_extension'};
+- $param->{'redirect_to'} = $document->{'url'};
+- return 1;
+-
+- }elsif ($document->{'type'} eq 'file') {
+- $param->{'file'} = $document->{'absolute_path'};
+- $param->{'bypass'} = 1;
+- return 1;
+-
+- }else { # directory
+-
+- $param->{'empty'} = $#{$document->{'subdir'}} == -1;
+-
+- # subdirectories hash
+- my %subdirs;
+- # file hash
+- my %files;
+-
+- ## for the exception of index.html
+- # name of the file "index.html" if exists in the directory read
+- my $indexhtml;
+-
+- # boolean : one of the subdirectories or files inside
+- # can be edited -> normal mode of read -> d_read.tt2;
+- my $normal_mode;
+-
+- my $path_doc;
+- my %desc_hash;
+- my $may, my $def_desc;
+-
+- foreach my $subdocument (@{$document->{'subdir'}}) {
+-
+- my $d = $subdocument->{'filename'};
+- my $path_doc = $subdocument->{'path'};
+-
+- ## Subdir
+- if ($subdocument->{'type'} eq 'directory') {
+-
+- if ($subdocument->{'access'}{'may'}{'read'}) {
+-
+- $subdirs{$d} = $subdocument->dup();
+- $subdirs{$d}{'doc'} = $subdocument->{'visible_filename'};
+- $subdirs{$d}{'escaped_doc'} = $subdocument->{'escaped_filename'};
+-
+- if ($param->{'user'}{'email'}) {
+- if ($subdocument->{'access'}{'may'}{'control'} == 1) {
+-
+- $subdirs{$d}{'edit'} = 1; # or = $may_action_edit ?
+- # if index.html, must know if something can be edit in the dir
+- $normal_mode = 1;
+- }elsif ($subdocument->{'access'}{'may'}{'edit'} != 0) {
+- # $may_action_edit = 0.5 or 1
+- $subdirs{$d}{'edit'} = $subdocument->{'access'}{'may'}{'edit'};
+- # if index.html, must know if something can be edit in the dir
+- $normal_mode = 1;
+- }
+-
+- if ($subdocument->{'access'}{'may'}{'control'}) {
+- $subdirs{$d}{'control'} = 1;
+- }
+- }
+- }
+- }else {
+- # case file
+-
+- if ($subdocument->{'access'}{'may'}{'read'}) {
+-
+- $files{$d} = $subdocument->dup();
+-
+- $files{$d}{'doc'} = $subdocument->{'visible_filename'};
+- $files{$d}{'escaped_doc'} = $subdocument->{'escaped_filename'};
+-
+- ## exception of index.html
+- if ($d =~ /^(index\.html?)$/i) {
+- $indexhtml = $1;
+- }
+-
+- if ($param->{'user'}{'email'}) {
+- if ($subdocument->{'access'}{'may'}{'edit'} == 1) {
+- $normal_mode = 1;
+- $files{$d}{'edit'} = 1; # or = $may_action_edit ?
+- } elsif ($subdocument->{'access'}{'may'}{'edit'} != 0){
+- # $may_action_edit = 1 or 0.5
+- $normal_mode = 1;
+- $files{$d}{'edit'} = $subdocument->{'access'}{'may'}{'edit'};
+- }
+-
+- if ($subdocument->{'access'}{'may'}{'control'}) {
+- $files{$d}{'control'} = 1;
+- }
+- }
+- }
+- }
+- }
+-
+- ### Exception : index.html
+- if ($indexhtml) {
+- unless ($normal_mode) {
+- $param->{'file_extension'} = 'html';
+- $param->{'bypass'} = 1;
+- $param->{'file'} = $document->{'absolute_path'};
+- return 1;
+- }
+- }
+-
+- ## to sort subdirs
+- my @sort_subdirs;
+- my $order = $in{'order'} || 'order_by_doc';
+- $param->{'order_by'} = $order;
+- foreach my $k (sort {by_order($order,\%subdirs)} keys %subdirs) {
+- push @sort_subdirs, $subdirs{$k};
+- }
+-
+- ## to sort files
+- my @sort_files;
+- foreach my $k (sort {by_order($order,\%files)} keys %files) {
+- push @sort_files, $files{$k};
+- }
+-
+- # parameters for the template file
+- $param->{'list'} = $list_name;
+-
+- $param->{'father'} = $document->{'father_path'};
+- $param->{'escaped_father'} = $document->{'escaped_father_path'} ;
+- $param->{'description'} = $document->{'title'};
+- $param->{'serial_desc'} = $document->{'serial_desc'};
+- $param->{'path'} = $document->{'path'};
+- $param->{'visible_path'} = $document->{'visible_path'};
+- $param->{'escaped_path'} = $document->{'escaped_path'};
+-
+- if (scalar keys %subdirs) {
+- $param->{'sort_subdirs'} = \@sort_subdirs;
+- }
+- if (scalar keys %files) {
+- $param->{'sort_files'} = \@sort_files;
+- }
+- }
+- $param->{'father_icon'} = $icon_table{'father'};
+- $param->{'sort_icon'} = $icon_table{'sort'};
+-
+-
+- ## Show expert commands / user page
+-
+- # for the curent directory
+- if ($may_edit == 0 && $may_control == 0) {
+- $param->{'has_dir_rights'} = 0;
+- } else {
+- $param->{'has_dir_rights'} = 1;
+- if ($may_edit == 1) { # (is_author || ! moderated)
+- $param->{'total_edit'} = 1;
+- }
+- }
+-
+- # set the page mode
+- if ($in{'show_expert_page'} && $param->{'has_dir_rights'}) {
+- $session->{'shared_mode'}='expert';
+- if ($param->{'user'}{'prefs'}{'shared_mode'} ne 'expert') {
+- # update user pref as soon as connected user change shared mode
+- $param->{'user'}{'prefs'}{'shared_mode'} = 'expert';
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+- $param->{'expert_page'} = 1;
+-
+- } elsif ($in{'show_user_page'}) {
+- $session->{'shared_mode'}='basic';
+- if ($param->{'user'}{'prefs'}{'shared_mode'} ne 'basic') {
+- # update user pref as soon as connected user change shared mode
+- $param->{'user'}{'prefs'}{'shared_mode'} = 'basic';
+- &List::update_user_db($param->{'user'}{'email'},{data=>&tools::hash_2_string($param->{'user'}{'prefs'})}) ;
+- }
+- $param->{'expert_page'} = 0;
+- } else {
+- if ($session->{'shared_mode'} eq 'expert' && $param->{'has_dir_rights'}) {
+- $param->{'expert_page'} = 1;
+- } else {
+- $param->{'expert_page'} = 0;
+- }
+- }
+-
+- &web_db_log({'robot' => $robot,'list' => $list->{'name'},'action' => $param->{'action'},'parameters' => "$in{'path'}",'target_email' => "",'msg_id' => '','status' => 'success','error_type' => '','user_email' => $param->{'user'}{'email'},'client' => $ip,'daemon' => $daemon_name});
+- return 1;
+-}
+-
+-
+-## Check authorizations to the current action
+-## used in common cases where actions fails unless result is 'do_it'
+-## It does not apply to actions that can be moderated
+-sub check_authz {
+- my ($subname, $action) = @_;
+-
+- my $result = $list->check_list_authz($action,$param->{'auth_method'},
+- {'sender' => $param->{'user'}{'email'} || 'nobody',
+- 'remote_host' => $param->{'remote_host'},
+- 'remote_addr' => $param->{'remote_addr'}});
+- my $r_action;
+- my $reason;
+- if (ref($result) eq 'HASH') {
+- $r_action = $result->{'action'};
+- $reason = $result->{'reason'};
+- }
+-
+- unless ($r_action =~ /do_it/i) {
+- &report::reject_report_web('auth',$reason,{'login'=> $param->{'need_login'}},$param->{'action'});
+- &wwslog('info','check_authz: access denied in %s for %s', $subname, $param->{'user'}{'email'});
+- return undef;
+- }
+-
+- return 1;
+-}
+-
+-sub get_server_details {
+- ## All Robots are shown to super listmaster
+- if (&List::is_listmaster($param->{'user'}{'email'})) {
+- $param->{'main_robot'} = 1;
+- $param->{'robots'} = $Conf{'robots'};
+- }
+-
+- ## Families
+- my @families = &Family::get_available_families($robot);
+-
+- if (@families) {
+- $param->{'families'} = \@families;
+- }
+-}
+-
+-sub get_icon {
+- my $type = shift;
+-
+- return $icon_table{$type};
+-}
+-
+-sub get_mime_type {
+- my $type = shift;
+-
+- return $mime_types->{$type};
+-}
+-
+-sub do_maintenance {
+- &wwslog('notice', 'do_maintenance()');
+-
+- return 1;
+-}
+-
+-=pod
+-
+-=head1 AUTHORS
+-
+-=over
+-
+-=item * Serge Aumont <sa AT cru.fr>
+-
+-=item * Olivier Salaun <os AT cru.fr>
+-
+-=back
+-
+-=cut
diff --git a/6.1.7/patches/04_fix_owner_privileges b/6.1.7/patches/04_fix_owner_privileges
new file mode 100644
index 0000000000000000000000000000000000000000..b3af859d557d1a9c047cc2ef9e71e963ba57390e
--- /dev/null
+++ b/6.1.7/patches/04_fix_owner_privileges
@@ -0,0 +1,52 @@
+diff --git a/sympa-6.1.7-src/src/etc/edit_list.conf b/sympa-6.1.7-src/src/etc/edit_list.conf
+index 13061e4..37f9224 100644
+--- a/sympa-6.1.7-src/src/etc/edit_list.conf
++++ b/sympa-6.1.7-src/src/etc/edit_list.conf
+@@ -48,8 +48,7 @@ shared_doc.quota owner,privileged_owner read
+
+ web_archive.quota owner,privileged_owner read
+
+-review owner read
+-review privileged_owner write
++review privileged_owner,owner write
+
+ add owner,privileged_owner hidden
+
+@@ -65,7 +64,8 @@ priority owner,privileged_owner hidden
+
+ max_size owner,privileged_owner hidden
+
+-footer_type owner,privileged_owner hidden
++# we might want to rever this one to hidden? changed on user request
++footer_type owner,privileged_owner write
+
+ cookie owner,privileged_owner hidden
+
+@@ -81,20 +81,17 @@ account owner,privileged_owner hidden
+
+ family_name listmaster,privileged_owner,owner read
+
+-owner owner read
+-owner.profile owner,privileged_owner read
+-owner privileged_owner write
+-owner.info owner hidden
+-
++owner.profile owner,privileged_owner write
++owner privileged_owner,owner write
++owner.info owner,privileged_owner hidden
++owner.gecos owner,privileged_owner hidden
+ owner_include owner read
+
+-editor owner read
+-editor privileged_owner write
+-
++editor privileged_owner,owner write
++editor.info privileged_owner,owner hidden
+ editor_include owner read
+
+-send owner read
+-send privileged_owner write
++send privileged_owner,owner write
+
+ status owner hidden
+ status privileged_owner read
diff --git a/6.1.7/patches/05_disable_copy_list b/6.1.7/patches/05_disable_copy_list
new file mode 100644
index 0000000000000000000000000000000000000000..dc2b5a87f43dd99961b1facf2dfc01f8490e9df3
--- /dev/null
+++ b/6.1.7/patches/05_disable_copy_list
@@ -0,0 +1,16 @@
+diff --git a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
+index cba0fb3..1ced0ed 100644
+--- a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
++++ b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
+@@ -10219,7 +10219,10 @@ sub _restrict_values {
+
+ sub do_copy_list {
+ &wwslog('info', 'do_copy_list(%s,%s)', $in{'new_listname'}, $in{'new_robot'});
+- &do_rename_list('copy');
++ # mysteriously reject copy list requests - this needs a real solution
++ &report::reject_report_web('intern','UUUUnable_to_rename_list', {'new_listname' => $in{'new_listname'}},
++ $param->{'action'},$list,$param->{'user'}{'email'},$robot);
++ return undef;
+ }
+
+ # in order to rename a list you must be list owner and you must be allowed to create new list
diff --git a/6.1.7/patches/06_do_not_save_unauth_arcsearch_id_not_applied_yet b/6.1.7/patches/06_do_not_save_unauth_arcsearch_id_not_applied_yet
new file mode 100644
index 0000000000000000000000000000000000000000..55db6e4967b9df232bf9b09d1799f4a4d1ca2c27
--- /dev/null
+++ b/6.1.7/patches/06_do_not_save_unauth_arcsearch_id_not_applied_yet
@@ -0,0 +1,25 @@
+diff --git a/sympa-6.0.6/wwsympa/wwsympa.fcgi.in sympa-6.1.4-src/wwsympa/wwsympa.fcgi.in
+index 0bb3147..1a61b2b 100644
+--- a/sympa-6.0.6/wwsympa/wwsympa.fcgi.in
++++ sympa-6.1.4-src/wwsympa/wwsympa.fcgi.in
+@@ -687,6 +687,7 @@ my %temporary_actions = ( 'logout' => 1,
+ 'rss' => 1,
+ 'wsdl' => 1,
+ 'redirect' => 1,
++ 'arcsearch_id' => 1,
+ );
+
+ ## Regexp applied on incoming parameters (%in)
+@@ -7663,7 +7664,11 @@ sub do_remove_arc {
+ &wwslog('info', 'do_arcsearch_id(%s,%s,%s)', $param->{'list'},$in{'archive_name'},$in{'msgid'});
+
+ ## Access control
+- return undef unless (defined &check_authz('do_arcsearch_id', 'web_archive.access'));
++ unless (defined &check_authz('do_arcsearch_id', 'web_archive.access')) {
++ $param->{'action'} = 'authorization_reject';
++ $param->{'reason'} = 'web_archive_closed';
++ return 1;
++ }
+
+ use Marc::Search;
+
diff --git a/6.1.7/patches/07_disable_active_and_latest_lists b/6.1.7/patches/07_disable_active_and_latest_lists
new file mode 100644
index 0000000000000000000000000000000000000000..2ad4ba7d69a24bbb936f111df397cb1b5b0bce0a
--- /dev/null
+++ b/6.1.7/patches/07_disable_active_and_latest_lists
@@ -0,0 +1,22 @@
+diff --git a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
+index 1ced0ed..5a571c6 100644
+--- a/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
++++ b/sympa-6.1.7-src/wwsympa/wwsympa.fcgi.in
+@@ -3918,6 +3918,8 @@ sub do_renewpasswd {
+ ## The list of latest created lists
+ sub do_latest_lists {
+ &wwslog('info', "do_latest_lists($in{'for'}, $in{'count'},$in{'topic'}, $in{'subtopic'})");
++ # should try to actually fix this one day
++ return 0;
+
+ unless (&do_lists()) {
+ &wwslog('err','do_latest_lists: error while calling do_lists');
+@@ -3978,6 +3980,8 @@ sub do_renewpasswd {
+ ## The list of the most active lists
+ sub do_active_lists {
+ &wwslog('info', "do_active_lists($in{'for'}, $in{'count'},$in{'topic'}, $in{'subtopic'})");
++ # should try to actually fix this one day
++ return 0;
+
+ unless (&do_lists()) {
+ &wwslog('err','do_active_lists: error while calling do_lists');