tools.pm 30.4 KB
Newer Older
1
2
3
4
# -*- indent-tabs-mode: nil; -*-
# vim:ft=perl:et:sw=4
# $Id$

5
# Sympa - SYsteme de Multi-Postage Automatique
6
7
8
9
#
# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
10
# Copyright (c) 2011, 2012, 2013, 2014, 2015 GIP RENATER
11
12
13
14
15
16
17
18
19
20
21
22
#
# 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
23
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
root's avatar
root committed
24
25
26

package tools;

27
use strict;
28
use warnings;
sikeda's avatar
sikeda committed
29
use Encode qw();
30
use Encode::MIME::Header;    # for 'MIME-Q' encoding
31
use English;                 # FIXME: drop $MATCH usage
sikeda's avatar
sikeda committed
32
use MIME::EncWords;
33

34
use Sympa;
35
use Conf;
36
use Sympa::Constants;
37
use Sympa::Language;
sikeda's avatar
sikeda committed
38
use Sympa::ListDef;
39
use Sympa::Log;
40
use Sympa::Regexps;
41
42
use Sympa::Tools::Data;
use Sympa::Tools::File;
43

44
45
my $log = Sympa::Log->instance;

46
47
## Returns an HTML::StripScripts::Parser object built with  the parameters
## provided as arguments.
48
49
# DEPRECATED: Use Sympa::HTMLSanitizer::new().
#sub _create_xss_parser(robot => $robot);
50

51
52
## Returns sanitized version (using StripScripts) of the string provided as
## argument.
53
54
# DEPRECATED: Use Sympa::HTMLSanitizer::filter_html().
#sub sanitize_html(robot => $robot, string => $string);
55

56
57
## Returns sanitized version (using StripScripts) of the content of the file
## whose path is provided as argument.
58
59
# DEPRECATED: Use Sympa::HTMLSanitizer::filter_html_file().
#sub sanitize_html_file($robot => $robot, file => $file);
60
61

## Sanitize all values in the hash $var, starting from $level
62
63
# DEPRECATED: Use Sympa::HTMLSanitizer().
#sub sanitize_var(robot => $robot, var => $var, ...);
64

65
66
# DEPRECATED: No longer used.
#sub sortbydomain($x, $y);
root's avatar
root committed
67

sikeda's avatar
sikeda committed
68
69
# Sort subroutine to order files in sympa spool by date
#OBSOLETED: No longer used.
70
sub by_date {
71
72
    my @a_tokens = split /\./, ($a || '');
    my @b_tokens = split /\./, ($b || '');
73
74

    ## File format : list@dom.date.pid
75
76
    my $a_time = $a_tokens[$#a_tokens - 1] || 0;
    my $b_time = $b_tokens[$#b_tokens - 1] || 0;
77
78
79
80
81

    return $a_time <=> $b_time;

}

82
# Moved to Sympa::Mailer::_safefork().
83
#sub safefork ($i, $pid);
root's avatar
root committed
84

85
####################################################
86
# checkcommand
87
88
####################################################
# Checks for no command in the body of the message.
89
# If there are some command in it, it return true
90
# and send a message to $sender
91
#
92
93
94
95
96
97
# IN : -$msg (+): ref(MIME::Entity) - message to check
#      -$sender (+): the sender of $msg
#
# OUT : -1 if there are some command in $msg
#       -0 else
#
98
######################################################
root's avatar
root committed
99
sub checkcommand {
100
    my ($msg, $sender) = @_;
root's avatar
root committed
101

102
    my $i;
103
    my $hdr = $msg->head;
root's avatar
root committed
104

105
106
    ## Check for commands in the subject.
    my $subject = $msg->head->get('Subject');
107

108
    $log->syslog('debug3', '(msg->head->get(subject) %s, %s)',
109
        $subject, $sender);
110

111
112
    if ($subject) {
        if ($Conf::Conf{'misaddressed_commands_regexp'}
113
114
            && ($subject =~ /^$Conf::Conf{'misaddressed_commands_regexp'}$/im)
            ) {
115
116
117
            return 1;
        }
    }
118

119
    return 0 if ($#{$msg->body} >= 5);    ## More than 5 lines in the text.
120

121
122
123
124
125
    foreach $i (@{$msg->body}) {
        if ($Conf::Conf{'misaddressed_commands_regexp'}
            && ($i =~ /^$Conf::Conf{'misaddressed_commands_regexp'}\b/im)) {
            return 1;
        }
126

127
128
129
130
        ## Control is only applied to first non-blank line
        last unless $i =~ /^\s*$/;
    }
    return 0;
root's avatar
root committed
131
132
133
134
}

## return a hash from the edit_list_conf file
sub load_edit_list_conf {
135
    $log->syslog('debug2', '(%s)', @_);
136
    my $list = shift;
137

138
    my $robot = $list->{'domain'};
root's avatar
root committed
139
    my $file;
140
    my $conf;
root's avatar
root committed
141

142
    return undef
143
        unless $file = Sympa::search_fullpath($list, 'edit_list.conf');
144
145

    unless (open(FILE, $file)) {
146
        $log->syslog('info', 'Unable to open config file %s', $file);
147
        return undef;
root's avatar
root committed
148
149
    }

150
    my $error_in_conf;
151
152
    my $roles_regexp =
        'listmaster|privileged_owner|owner|editor|subscriber|default';
root's avatar
root committed
153
    while (<FILE>) {
154
155
156
157
158
159
160
161
162
163
        next if /^\s*(\#.*|\s*)$/;

        if (/^\s*(\S+)\s+(($roles_regexp)\s*(,\s*($roles_regexp))*)\s+(read|write|hidden)\s*$/i
            ) {
            my ($param, $role, $priv) = ($1, $2, $6);
            my @roles = split /,/, $role;
            foreach my $r (@roles) {
                $r =~ s/^\s*(\S+)\s*$/$1/;
                if ($r eq 'default') {
                    $error_in_conf = 1;
164
                    $log->syslog('notice', '"default" is no more recognised');
165
166
167
168
169
170
171
172
173
                    foreach
                        my $set ('owner', 'privileged_owner', 'listmaster') {
                        $conf->{$param}{$set} = $priv;
                    }
                    next;
                }
                $conf->{$param}{$r} = $priv;
            }
        } else {
174
            $log->syslog(
175
                'info',
176
                'Unknown parameter in %s (Ignored) %s',
177
178
179
180
                "$Conf::Conf{'etc'}/edit_list.conf", $_
            );
            next;
        }
root's avatar
root committed
181
    }
182
183

    if ($error_in_conf) {
184
        Sympa::send_notify_to_listmaster($robot, 'edit_list_error', [$file]);
185
    }
186

root's avatar
root committed
187
188
189
190
191
192
    close FILE;
    return $conf;
}

## return a hash from the edit_list_conf file
sub load_create_list_conf {
salaun's avatar
salaun committed
193
    my $robot = shift;
root's avatar
root committed
194
195

    my $file;
196
197
    my $conf;

198
    $file = Sympa::search_fullpath($robot, 'create_list.conf');
salaun's avatar
salaun committed
199
    unless ($file) {
200
        $log->syslog(
201
            'info',
202
            'Unable to read %s',
203
204
205
            Sympa::Constants::DEFAULTDIR . '/create_list.conf'
        );
        return undef;
root's avatar
root committed
206
207
    }

208
    unless (open(FILE, $file)) {
209
        $log->syslog('info', 'Unable to open config file %s', $file);
210
        return undef;
root's avatar
root committed
211
212
213
    }

    while (<FILE>) {
214
        next if /^\s*(\#.*|\s*)$/;
root's avatar
root committed
215

216
217
218
        if (/^\s*(\S+)\s+(read|hidden)\s*$/i) {
            $conf->{$1} = lc($2);
        } else {
219
            $log->syslog(
220
                'info',
221
                'Unknown parameter in %s (Ignored) %s',
222
223
224
225
                "$Conf::Conf{'etc'}/create_list.conf", $_
            );
            next;
        }
root's avatar
root committed
226
    }
227

root's avatar
root committed
228
229
230
231
232
233
234
235
236
237
    close FILE;
    return $conf;
}

sub _add_topic {
    my ($name, $title) = @_;
    my $topic = {};

    my @tree = split '/', $name;
    if ($#tree == 0) {
238
239
240
241
242
        return {'title' => $title};
    } else {
        $topic->{'sub'}{$name} =
            _add_topic(join('/', @tree[1 .. $#tree]), $title);
        return $topic;
root's avatar
root committed
243
244
245
246
    }
}

sub get_list_list_tpl {
salaun's avatar
salaun committed
247
248
    my $robot = shift;

root's avatar
root committed
249
    my $list_conf;
250
    my $list_templates;
251
    unless ($list_conf = tools::load_create_list_conf($robot)) {
252
        return undef;
root's avatar
root committed
253
    }
254

255
    foreach my $dir (
256
        reverse
257
        @{Sympa::get_search_path($robot, subdir => 'create_list_templates')})
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
    {
        if (opendir(DIR, $dir)) {
        LOOP_FOREACH_TEMPLATE:
            foreach my $template (sort grep (!/^\./, readdir(DIR))) {
                my $status = $list_conf->{$template}
                    || $list_conf->{'default'};
                next if $status eq 'hidden';

                $list_templates->{$template}{'path'} = $dir;

                # Look for a comment.tt2.
                # Check old style locale first then canonic language and its
                # fallbacks.
                my $lang = Sympa::Language->instance->get_lang;
                my $comment_tt2;
                foreach my $l (
                    Sympa::Language::lang2oldlocale($lang),
                    Sympa::Language::implicated_langs($lang)
                    ) {
                    next unless $l;
                    $comment_tt2 =
                        $dir . '/' . $template . '/' . $l . '/comment.tt2';
                    if (-r $comment_tt2) {
                        $list_templates->{$template}{'comment'} =
                            $comment_tt2;
                        next LOOP_FOREACH_TEMPLATE;
                    }
                }
                $comment_tt2 = $dir . '/' . $template . '/comment.tt2';
                if (-r $comment_tt2) {
                    $list_templates->{$template}{'comment'} = $comment_tt2;
                }
            }
            closedir(DIR);
        }
root's avatar
root committed
293
294
295
296
297
    }

    return ($list_templates);
}

sympa-authors's avatar
   
sympa-authors committed
298
sub get_templates_list {
299
    $log->syslog('debug3', '(%s, %s, %s, %s)', @_);
300
301
302
    my $type    = shift;
    my $robot   = shift;
    my $list    = shift;
303
    my $options = shift;
304
305

    my $listdir;
sympa-authors's avatar
   
sympa-authors committed
306

307
    unless (($type eq 'web') || ($type eq 'mail')) {
308
        $log->syslog('info', 'Internal error incorrect parameter');
sympa-authors's avatar
   
sympa-authors committed
309
310
    }

311
312
313
    my $distrib_dir = Sympa::Constants::DEFAULTDIR . '/' . $type . '_tt2';
    my $site_dir    = $Conf::Conf{'etc'} . '/' . $type . '_tt2';
    my $robot_dir = $Conf::Conf{'etc'} . '/' . $robot . '/' . $type . '_tt2';
sympa-authors's avatar
   
sympa-authors committed
314
315

    my @try;
316
317
318

    ## The 'ignore_global' option allows to look for files at list level only
    unless ($options->{'ignore_global'}) {
319
320
321
322
        push @try, $distrib_dir;
        push @try, $site_dir;
        push @try, $robot_dir;
    }
323

324
    if (defined $list) {
325
326
        $listdir = $list->{'dir'} . '/' . $type . '_tt2';
        push @try, $listdir;
sikeda's avatar
sikeda committed
327
328
    } else {
        $listdir = '';
sympa-authors's avatar
   
sympa-authors committed
329
    }
330

331
    my $i = 0;
sympa-authors's avatar
   
sympa-authors committed
332
    my $tpl;
sympa-authors's avatar
   
sympa-authors committed
333

sympa-authors's avatar
   
sympa-authors committed
334
    foreach my $dir (@try) {
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
        next unless opendir(DIR, $dir);
        foreach my $file (grep (!/^\./, readdir(DIR))) {
            ## Subdirectory for a lang
            if (-d $dir . '/' . $file) {
                my $lang = $file;
                next unless opendir(LANGDIR, $dir . '/' . $lang);
                foreach my $file (grep (!/^\./, readdir(LANGDIR))) {
                    next unless ($file =~ /\.tt2$/);
                    if ($dir eq $distrib_dir) {
                        $tpl->{$file}{'distrib'}{$lang} =
                            $dir . '/' . $lang . '/' . $file;
                    }
                    if ($dir eq $site_dir) {
                        $tpl->{$file}{'site'}{$lang} =
                            $dir . '/' . $lang . '/' . $file;
                    }
                    if ($dir eq $robot_dir) {
                        $tpl->{$file}{'robot'}{$lang} =
                            $dir . '/' . $lang . '/' . $file;
                    }
                    if ($dir eq $listdir) {
                        $tpl->{$file}{'list'}{$lang} =
                            $dir . '/' . $lang . '/' . $file;
                    }
                }
                closedir LANGDIR;

            } else {
                next unless ($file =~ /\.tt2$/);
                if ($dir eq $distrib_dir) {
                    $tpl->{$file}{'distrib'}{'default'} = $dir . '/' . $file;
                }
                if ($dir eq $site_dir) {
                    $tpl->{$file}{'site'}{'default'} = $dir . '/' . $file;
                }
                if ($dir eq $robot_dir) {
                    $tpl->{$file}{'robot'}{'default'} = $dir . '/' . $file;
                }
                if ($dir eq $listdir) {
                    $tpl->{$file}{'list'}{'default'} = $dir . '/' . $file;
                }
            }
        }
        closedir DIR;
sympa-authors's avatar
   
sympa-authors committed
379
    }
380
    return ($tpl);
sympa-authors's avatar
   
sympa-authors committed
381

sympa-authors's avatar
   
sympa-authors committed
382
383
384
385
}

# return the path for a specific template
sub get_template_path {
386
    $log->syslog('debug2', '(%s, %s. %s, %s, %s, %s)', @_);
387
    my $type  = shift;
sympa-authors's avatar
   
sympa-authors committed
388
389
    my $robot = shift;
    my $scope = shift;
390
391
392
    my $tpl   = shift;
    my $lang  = shift || 'default';
    my $list  = shift;
sympa-authors's avatar
   
sympa-authors committed
393

394
395
396
    my $subdir = '';
    # canonicalize language name which may be old-style locale name.
    unless ($lang eq 'default') {
397
398
399
400
        my $oldlocale = Sympa::Language::lang2oldlocale($lang);
        unless ($oldlocale eq $lang) {
            $subdir = Sympa::Language::canonic_lang($lang);
            unless ($subdir) {
401
                $log->syslog('info', 'Internal error incorrect parameter');
402
403
404
                return undef;
            }
        }
sympa-authors's avatar
   
sympa-authors committed
405
    }
sympa-authors's avatar
   
sympa-authors committed
406

407
    unless ($type eq 'web' or $type eq 'mail') {
408
        $log->syslog('info', 'Internal error incorrect parameter');
409
        return undef;
sympa-authors's avatar
   
sympa-authors committed
410
411
    }

412
    my $dir;
413
    if ($scope eq 'list') {
414
        unless (ref $list eq 'Sympa::List') {
415
            $log->syslog('err', 'Missing parameter "list"');
416
417
418
            return undef;
        }
        $dir = $list->{'dir'};
419
    } elsif ($scope eq 'robot') {
420
421
422
423
424
425
426
        $dir = $Conf::Conf{'etc'} . '/' . $robot;
    } elsif ($scope eq 'site') {
        $dir = $Conf::Conf{'etc'};
    } elsif ($scope eq 'distrib') {
        $dir = Sympa::Constants::DEFAULTDIR;
    } else {
        return undef;
sympa-authors's avatar
   
sympa-authors committed
427
    }
428

429
    $dir .= '/' . $type . '_tt2';
430
    $dir .= '/' . $subdir if length $subdir;
431
    return $dir . '/' . $tpl;
sympa-authors's avatar
   
sympa-authors committed
432
433
}

sikeda's avatar
sikeda committed
434
435
436
## Make a multipart/alternative to a singlepart
# DEPRECATED: Use Sympa::Message::_as_singlepart().
#sub as_singlepart($msg, $preferred_type, $loops);
root's avatar
root committed
437

438
## Escape characters before using a string within a regexp parameter
439
## Escaped characters are : @ $ [ ] ( ) ' ! '\' * . + ?
440
441
# DEPRECATED: Use "s/([\x00-\x1F\s\w\x7F-\xFF])/\\$1/g;".
#sub escape_regexp ($s);
root's avatar
root committed
442

443
444
# Escape weird characters
# FIXME: Should not use.
root's avatar
root committed
445
sub escape_chars {
446
    my $s          = shift;
447
    my $except     = shift;                            ## Exceptions
448
    my $ord_except = ord $except if defined $except;
root's avatar
root committed
449

salaun's avatar
salaun committed
450
    ## Escape chars
salaun's avatar
salaun committed
451
    ##  !"#$%&'()+,:;<=>?[] AND accented chars
salaun's avatar
salaun committed
452
    ## escape % first
453
454
455
456
457
458
459
460
461
    foreach my $i (
        0x25,
        0x20 .. 0x24,
        0x26 .. 0x2c,
        0x3a .. 0x3f,
        0x5b, 0x5d,
        0x80 .. 0x9f,
        0xa0 .. 0xff
        ) {
462
        next if defined $ord_except and $i == $ord_except;
463
464
465
        my $hex_i = sprintf "%lx", $i;
        $s =~ s/\x$hex_i/%$hex_i/g;
    }
466
467
    ## Special traetment for '/'
    $s =~ s/\//%a5/g unless defined $except and $except eq '/';
salaun's avatar
salaun committed
468

root's avatar
root committed
469
470
471
    return $s;
}

472
473
474
475
## Escape shared document file name
## Q-decode it first
sub escape_docname {
    my $filename = shift;
476
    my $except   = shift;    ## Exceptions
477
478

    ## Q-decode
479
    $filename = MIME::EncWords::decode_mimewords($filename);
480
481

    ## Decode from FS encoding to utf-8
sikeda's avatar
sikeda committed
482
    #$filename = Encode::decode($Conf::Conf{'filesystem_encoding'}, $filename);
483
484

    ## escapesome chars for use in URL
485
    return tools::escape_chars($filename, $except);
486
487
}

488
489
490
## Convert from Perl unicode encoding to UTF8
sub unicode_to_utf8 {
    my $s = shift;
491

sikeda's avatar
sikeda committed
492
    if (Encode::is_utf8($s)) {
493
        return Encode::encode_utf8($s);
494
495
496
497
498
    }

    return $s;
}

499
500
501
502
## Q-Encode web file name
sub qencode_filename {
    my $filename = shift;

503
504
    ## We don't use MIME::Words here because it does not encode properly
    ## Unicode
505
    ## Check if string is already Q-encoded first
506
    ## Also check if the string contains 8bit chars
507
508
    unless ($filename =~ /\=\?UTF-8\?/
        || $filename =~ /^[\x00-\x7f]*$/) {
509

510
511
512
513
514
515
        ## Don't encode elements such as .desc. or .url or .moderate
        ## or .extension
        my $part = $filename;
        my ($leading, $trailing);
        $leading  = $1 if ($part =~ s/^(\.desc\.)//);    ## leading .desc
        $trailing = $1 if ($part =~ s/((\.\w+)+)$//);    ## trailing .xx
516

517
518
519
520
521
522
523
        my $encoded_part = MIME::EncWords::encode_mimewords(
            $part,
            Charset    => 'utf8',
            Encoding   => 'q',
            MaxLineLen => 1000,
            Minimal    => 'NO'
        );
524

525
        $filename = $leading . $encoded_part . $trailing;
526
    }
527

528
529
530
531
532
533
    return $filename;
}

## Q-Decode web file name
sub qdecode_filename {
    my $filename = shift;
534
535
536

    ## We don't use MIME::Words here because it does not encode properly
    ## Unicode
537
538
    ## Check if string is already Q-encoded first
    #if ($filename =~ /\=\?UTF-8\?/) {
sikeda's avatar
sikeda committed
539
    $filename = Encode::encode_utf8(Encode::decode('MIME-Q', $filename));
540
    #}
541

542
543
544
    return $filename;
}

root's avatar
root committed
545
546
547
548
## Unescape weird characters
sub unescape_chars {
    my $s = shift;

549
550
551
552
553
554
    $s =~ s/%a5/\//g;    ## Special traetment for '/'
    foreach my $i (0x20 .. 0x2c, 0x3a .. 0x3f, 0x5b, 0x5d, 0x80 .. 0x9f,
        0xa0 .. 0xff) {
        my $hex_i = sprintf "%lx", $i;
        my $hex_s = sprintf "%c",  $i;
        $s =~ s/%$hex_i/$hex_s/g;
salaun's avatar
salaun committed
555
556
    }

root's avatar
root committed
557
558
559
    return $s;
}

560
561
sub escape_html {
    my $s = shift;
sikeda's avatar
sikeda committed
562
    return $s unless defined $s;
563

564
565
566
    $s =~ s/\"/\&quot\;/gm;
    $s =~ s/\</&lt\;/gm;
    $s =~ s/\>/&gt\;/gm;
567

568
569
    return $s;
}
root's avatar
root committed
570

571
572
sub unescape_html {
    my $s = shift;
sikeda's avatar
sikeda committed
573
    return $s unless defined $s;
574
575
576
577

    $s =~ s/\&quot\;/\"/g;
    $s =~ s/&lt\;/\</g;
    $s =~ s/&gt\;/\>/g;
578

579
580
581
    return $s;
}

582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
# Old name: tt2::escape_url().
sub escape_url {
    my $string = shift;

    $string =~ s/[\s+]/sprintf('%%%02x', ord($MATCH))/eg;
    # Some MUAs aren't able to decode ``%40'' (escaped ``@'') in e-mail
    # address of mailto: URL, or take ``@'' in query component for a
    # delimiter to separate URL from the rest.
    my ($body, $query) = split(/\?/, $string, 2);
    if (defined $query) {
        $query =~ s/\@/sprintf('%%%02x', ord($MATCH))/eg;
        $string = $body . '?' . $query;
    }

    return $string;
}

# Old name: tt2::escape_xml().
sub escape_xml {
    my $string = shift;

    $string =~ s/&/&amp;/g;
    $string =~ s/</&lt;/g;
    $string =~ s/>/&gt;/g;
    $string =~ s/\'/&apos;/g;
    $string =~ s/\"/&quot;/g;

    return $string;
}

# Old name: tt2::escape_quote().
sub escape_quote {
    my $string = shift;

    $string =~ s/\'/\\\'/g;
    $string =~ s/\"/\\\"/g;

    return $string;
}

root's avatar
root committed
622
# Check sum used to authenticate communication from wwsympa to sympa
623
624
625
# DEPRECATED: No longer used: This is moved to upgrade_send_spool.pl to be
# used for migrating old spool.
#sub sympa_checksum($rcpt);
root's avatar
root committed
626

627
628
# Moved to Conf::cookie_changed().
#sub cookie_changed;
629

630
631
# Moved to Sympa::Tools::WWW:_load_mime_types()
#sub load_mime_types();
632

633
# Old name: List::compute_auth().
634
635
# Moved to Sympa::compute_auth().
#sub compute_auth;
636
637

# Old name: List::request_auth().
638
639
# Moved to Sympa::request_auth().
#sub request_auth;
640

641
642
# Moved to Sympa::search_fullpath().
#sub search_fullpath;
643

644
645
# Moved to Sympa::get_search_path().
#sub get_search_path;
646

647
648
# Moved to Sympa::send_dsn().
#sub send_dsn;
649

650
# Old name: List::send_file(), List::send_global_file().
651
652
# Moved to Sympa::send_file().
#sub send_file;
653
654

# Old name: List::send_notify_to_listmaster()
655
656
# Moved to Sympa::send_notify_to_listmaster().
#sub send_notify_to_listmaster;
657

sympa-authors's avatar
sympa-authors committed
658
## Q-encode a complete file hierarchy
659
## Usefull to Q-encode subshared documents
sympa-authors's avatar
sympa-authors committed
660
sub qencode_hierarchy {
661
    my $dir               = shift; ## Root directory
662
    my $original_encoding = shift; ## Suspected original encoding of filenames
sympa-authors's avatar
sympa-authors committed
663
664
665

    my $count;
    my @all_files;
666
    Sympa::Tools::File::list_dir($dir, \@all_files, $original_encoding);
sympa-authors's avatar
sympa-authors committed
667
668

    foreach my $f_struct (reverse @all_files) {
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684

        ## At least one 8bit char
        next
            unless ($f_struct->{'filename'} =~ /[^\x00-\x7f]/);

        my $new_filename = $f_struct->{'filename'};
        my $encoding     = $f_struct->{'encoding'};
        Encode::from_to($new_filename, $encoding, 'utf8') if $encoding;

        ## Q-encode filename to escape chars with accents
        $new_filename = tools::qencode_filename($new_filename);

        my $orig_f = $f_struct->{'directory'} . '/' . $f_struct->{'filename'};
        my $new_f  = $f_struct->{'directory'} . '/' . $new_filename;

        ## Rename the file using utf8
685
        $log->syslog('notice', "Renaming %s to %s", $orig_f, $new_f);
686
        unless (rename $orig_f, $new_f) {
687
            $log->syslog('err', 'Failed to rename %s to %s: %m',
688
                $orig_f, $new_f);
689
690
691
            next;
        }
        $count++;
sympa-authors's avatar
sympa-authors committed
692
    }
693

sympa-authors's avatar
sympa-authors committed
694
695
696
    return $count;
}

697
698
# DEPRECATED: No longer used.
#sub dump_encoding($out);
699

700
701
# MOVED to Sympa::Session::_is_a_crawler().
#sub is_a_crawler;
702

703
704
705
sub get_message_id {
    my $robot = shift;

706
707
708
709
710
711
    my $domain;
    if ($robot and $robot ne '*') {
        $domain = Conf::get_robot_conf($robot, 'domain');
    } else {
        $domain = $Conf::Conf{'domain'};
    }
712

713
    return sprintf '<sympa.%d.%d.%d@%s>', time, $PID, int(rand(999)), $domain;
714
715
}

716
717
718
## Basic check of an email address
sub valid_email {
    my $email = shift;
719

720
721
    my $email_re = Sympa::Regexps::email();
    unless ($email =~ /^${email_re}$/) {
722
        $log->syslog('err', 'Invalid email address "%s"', $email);
723
        return undef;
724
    }
725

726
727
    ## Forbidden characters
    if ($email =~ /[\|\$\*\?\!]/) {
728
        $log->syslog('err', 'Invalid email address "%s"', $email);
729
        return undef;
730
731
732
    }

    return 1;
733
734
}

735
736
737
738
739
740
741
742
743
744
745
746
747
## Clean email address
sub clean_email {
    my $email = shift;

    ## Lower-case
    $email = lc($email);

    ## remove leading and trailing spaces
    $email =~ s/^\s*//;
    $email =~ s/\s*$//;

    return $email;
}
748

salaun's avatar
salaun committed
749
750
751
752
753
754
755
756
757
758
759
760
761
762
## Return canonical email address (lower-cased + space cleanup)
## It could also support alternate email
sub get_canonical_email {
    my $email = shift;

    ## Remove leading and trailing white spaces
    $email =~ s/^\s*(\S.*\S)\s*$/$1/;

    ## Lower-case
    $email = lc($email);

    return $email;
}

763
764
#DEPRECATED: No longer used.
# sub dump_html_var2($var);
765

766
767
#DEPRECATED: No longer used.
# sub remove_empty_entries($var);
768

769
770
771
772
####################################################
# clean_msg_id
####################################################
# clean msg_id to use it without  \n, \s or <,>
773
#
774
775
776
777
778
779
780
# IN : -$msg_id (+) : the msg_id
#
# OUT : -$msg_id : the clean msg_id
#
######################################################
sub clean_msg_id {
    my $msg_id = shift;
781

sikeda's avatar
sikeda committed
782
    return $msg_id unless defined $msg_id;
783

784
785
786
    chomp $msg_id;

    if ($msg_id =~ /\<(.+)\>/) {
787
        $msg_id = $1;
788
    }
789
790
791
792

    return $msg_id;
}

793
794
795
# Change X-Sympa-To: header field in the message
# DEPRECATED: No longer used
# sub change_x_sympa_to($file, $value);
796

797
# Compare 2 versions of Sympa
798
799
# DEPRECATED: Never used.
# sub higher_version($v1, $v2);
800

801
## Compare 2 versions of Sympa
802
803
# Moved to Sympa::Upgrade::lower_version().
#sub lower_version ($v1, $v2);
804

805
806
807
sub add_in_blacklist {
    my $entry = shift;
    my $robot = shift;
808
    my $list  = shift;
809

810
    $log->syslog('info', '(%s, %s, %s)', $entry, $robot, $list->{'name'});
811
812
813
    $entry = lc($entry);
    chomp $entry;

814
    # robot blacklist not yet availible
815
    unless ($list) {
816
        $log->syslog('info',
817
818
819
            "tools::add_in_blacklist: robot blacklist not yet availible, missing list parameter"
        );
        return undef;
820
    }
821
    unless (($entry) && ($robot)) {
822
        $log->syslog('info', 'Missing parameters');
823
        return undef;
824
825
    }
    if ($entry =~ /\*.*\*/) {
826
        $log->syslog('info', 'Incorrect parameter %s', $entry);
827
828
829
830
        return undef;
    }
    my $dir = $list->{'dir'} . '/search_filters';
    unless ((-d $dir) || mkdir($dir, 0755)) {
831
        $log->syslog('info', 'Unable to create dir %s', $dir);
832
833
834
835
836
837
838
839
840
841
842
843
        return undef;
    }
    my $file = $dir . '/blacklist.txt';

    if (open BLACKLIST, "$file") {
        while (<BLACKLIST>) {
            next if (/^\s*$/o || /^[\#\;]/o);
            my $regexp = $_;
            chomp $regexp;
            $regexp =~ s/\*/.*/;
            $regexp = '^' . $regexp . '$';
            if ($entry =~ /$regexp/i) {
844
                $log->syslog('notice', '%s already in blacklist(%s)',
845
846
847
848
849
850
851
                    $entry, $_);
                return 0;
            }
        }
        close BLACKLIST;
    }
    unless (open BLACKLIST, ">> $file") {
852
        $log->syslog('info', 'Append to file %s', $file);
853
        return undef;
854
    }
855
    print BLACKLIST "$entry\n";
856
857
858
859
    close BLACKLIST;

}

860
861
# DEPRECATED: No longer used.
# sub get_fingerprint($email, $fingerprint);
862

863
864
# DEPRECATED: Use Digest::MD5::md5_hex.
#sub md5_fingerprint($input_string);
865

866
867
# DEPRECATED: No longer used.
# sub get_db_random();
868

869
870
# DEPRECATED: No longer used.
# sub init_db_random();
871

872
873
874
875
876
877
# DEPRECATED: No longer used.
#my $separator =
#    "------- CUT --- CUT --- CUT --- CUT --- CUT --- CUT --- CUT -------";
#sub get_separator {
#    return $separator;
#}
878
879

## Return the Sympa regexp corresponding to the input param
880
# OBSOLETED: Use Sympa::Regexps::<type>().
881
882
883
sub get_regexp {
    my $type = shift;

884
    if (my $re = Sympa::Regexps->can($type)) {
885
886
887
        return $re->();
    } else {
        return '\w+';    ## default is a very strict regexp
888
889
890
    }

}
891

892
893
# OBSOLETED.  Moved to _save_to_bad() in archived.pl.
#sub save_to_bad;
894

895
## Returns the counf of numbers found in the string given as argument.
896
897
# DEPRECATED: No longer used.
# sub count_numbers_in_string($str);
898

899
900
901
#*******************************************
# Function : addrencode
# Description : return formatted (and encoded) name-addr as RFC5322 3.4.
902
## IN : addr, [phrase, [charset, [comment]]]
903
904
#*******************************************
sub addrencode {
905
906
    my $addr    = shift;
    my $phrase  = (shift || '');
907
    my $charset = (shift || 'utf8');
908
    my $comment = (shift || '');
909
910
911
912

    return undef unless $addr =~ /\S/;

    if ($phrase =~ /[^\s\x21-\x7E]/) {
913
914
915
916
917
918
919
920
        $phrase = MIME::EncWords::encode_mimewords(
            Encode::decode('utf8', $phrase),
            'Encoding'    => 'A',
            'Charset'     => $charset,
            'Replacement' => 'FALLBACK',
            'Field'       => 'Resent-Sender', # almost longest
            'Minimal'     => 'DISPNAME',      # needs MIME::EncWords >= 1.012.
        );
921
    } elsif ($phrase =~ /\S/) {
922
923
        $phrase =~ s/([\\\"])/\\$1/g;
        $phrase = '"' . $phrase . '"';
924
    }
925
    if ($comment =~ /[^\s\x21-\x27\x2A-\x5B\x5D-\x7E]/) {
926
927
928
929
930
931
932
        $comment = MIME::EncWords::encode_mimewords(
            Encode::decode('utf8', $comment),
            'Encoding'    => 'A',
            'Charset'     => $charset,
            'Replacement' => 'FALLBACK',
            'Minimal'     => 'DISPNAME',
        );
933
    } elsif ($comment =~ /\S/) {
934
        $comment =~ s/([\\\"])/\\$1/g;
935
936
    }

937
938
939
940
    return
          ($phrase  =~ /\S/ ? "$phrase "    : '')
        . ($comment =~ /\S/ ? "($comment) " : '')
        . "<$addr>";
941
}
942

943
# Generate a newsletter from an HTML URL or a file path.
944
945
#sub create_html_part_from_web_page($param);
#DEPRECATED: No longer used.
946

sikeda's avatar
sikeda committed
947
948
#DEPRECATED: Use Sympa::Message::get_decoded_header().
#sub decode_header($msg, $tag, $sep=undef);
949

950
BEGIN { 'use Data::Password'; }
sikeda's avatar
sikeda committed
951

952
my @validation_messages = (
sikeda's avatar
sikeda committed
953
954
955
956
957
958
959
    {gettext_id => 'Not between %d and %d characters'},
    {gettext_id => 'Not %d characters or greater'},
    {gettext_id => 'Not less than or equal to %d characters'},
    {gettext_id => 'contains bad characters'},
    {gettext_id => 'contains less than %d character groups'},
    {gettext_id => 'contains over %d leading characters in sequence'},
    {gettext_id => "contains the dictionary word '%s'"},
960
961
);

962
963
964
965
966
967
968
sub password_validation {
    my ($password) = @_;

    my $pv = $Conf::Conf{'password_validation'};
    return undef
        unless $pv
            and defined $password
969
            and $Data::Password::VERSION;
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997

    local (
        $Data::Password::DICTIONARY, $Data::Password::FOLLOWING,
        $Data::Password::GROUPS,     $Data::Password::MINLEN,
        $Data::Password::MAXLEN
    );
    local @Data::Password::DICTIONARIES = @Data::Password::DICTIONARIES;

    my @techniques = split(/\s*,\s*/, $pv);
    foreach my $technique (@techniques) {
        my ($key, $value) = $technique =~ /([^=]+)=(.*)/;
        $key = uc $key;

        if ($key eq 'DICTIONARY') {
            $Data::Password::DICTIONARY = $value;
        } elsif ($key eq 'FOLLOWING') {
            $Data::Password::FOLLOWING = $value;
        } elsif ($key eq 'GROUPS') {
            $Data::Password::GROUPS = $value;
        } elsif ($key eq 'MINLEN') {
            $Data::Password::MINLEN = $value;
        } elsif ($key eq 'MAXLEN') {
            $Data::Password::MAXLEN = $value;
        } elsif ($key eq 'DICTIONARIES') {
            # TODO: How do we handle a list of dictionaries?
            push @