1# -*- indent-tabs-mode: nil; -*-
2# vim:ft=perl:et:sw=4
3# $Id$
4
5# Sympa - SYsteme de Multi-Postage Automatique
6#
7# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
8# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
9# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
10# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER
11# Copyright 2018 The Sympa Community. See the AUTHORS.md file at the
12# top-level directory of this distribution and at
13# <https://github.com/sympa-community/sympa.git>.
14#
15# This program is free software; you can redistribute it and/or modify
16# it under the terms of the GNU General Public License as published by
17# the Free Software Foundation; either version 2 of the License, or
18# (at your option) any later version.
19#
20# This program is distributed in the hope that it will be useful,
21# but WITHOUT ANY WARRANTY; without even the implied warranty of
22# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23# GNU General Public License for more details.
24#
25# You should have received a copy of the GNU General Public License
26# along with this program.  If not, see <http://www.gnu.org/licenses/>.
27
28package Sympa::Tools::Data;
29
30use strict;
31use warnings;
32use Encode qw();
33use English qw(-no_match_vars);
34use POSIX qw();
35use XML::LibXML qw();
36BEGIN { eval 'use Clone qw()'; }
37
38use Sympa::Tools::Text;
39
40## This applies recursively to a data structure
41## The transformation subroutine is passed as a ref
42sub recursive_transformation {
43    my ($var, $subref) = @_;
44
45    return unless (ref($var));
46
47    if (ref($var) eq 'ARRAY') {
48        foreach my $index (0 .. $#{$var}) {
49            if (ref($var->[$index])) {
50                recursive_transformation($var->[$index], $subref);
51            } else {
52                $var->[$index] = &{$subref}($var->[$index]);
53            }
54        }
55    } elsif (ref($var) eq 'HASH') {
56        foreach my $key (keys %{$var}) {
57            if (ref($var->{$key})) {
58                recursive_transformation($var->{$key}, $subref);
59            } else {
60                $var->{$key} = &{$subref}($var->{$key});
61            }
62        }
63    }
64
65    return;
66}
67
68## Dump a variable's content
69sub dump_var {
70    my ($var, $level, $fd) = @_;
71
72    return undef unless ($fd);
73
74    if (ref($var)) {
75        if (ref($var) eq 'ARRAY') {
76            foreach my $index (0 .. $#{$var}) {
77                print $fd "\t" x $level . $index . "\n";
78                dump_var($var->[$index], $level + 1, $fd);
79            }
80        } elsif (ref($var) eq 'HASH'
81            || ref($var) eq 'Sympa::Scenario'
82            || ref($var) eq 'Sympa::List'
83            || ref($var) eq 'CGI::Fast') {
84            foreach my $key (sort keys %{$var}) {
85                print $fd "\t" x $level . '_' . $key . '_' . "\n";
86                dump_var($var->{$key}, $level + 1, $fd);
87            }
88        } else {
89            printf $fd "\t" x $level . "'%s'" . "\n", ref($var);
90        }
91    } else {
92        if (defined $var) {
93            print $fd "\t" x $level . "'$var'" . "\n";
94        } else {
95            print $fd "\t" x $level . "UNDEF\n";
96        }
97    }
98}
99
100## Dump a variable's content
101sub dump_html_var {
102    my ($var) = shift;
103    my $html = '';
104
105    if (ref($var)) {
106
107        if (ref($var) eq 'ARRAY') {
108            $html .= '<ul>';
109            foreach my $index (0 .. $#{$var}) {
110                $html .= '<li> ' . $index . ':';
111                $html .= dump_html_var($var->[$index]);
112                $html .= '</li>';
113            }
114            $html .= '</ul>';
115        } elsif (ref($var) eq 'HASH'
116            || ref($var) eq 'Sympa::Scenario'
117            || ref($var) eq 'Sympa::List') {
118            $html .= '<ul>';
119            foreach my $key (sort keys %{$var}) {
120                $html .= '<li>' . $key . '=';
121                $html .= dump_html_var($var->{$key});
122                $html .= '</li>';
123            }
124            $html .= '</ul>';
125        } else {
126            $html .= 'EEEEEEEEEEEEEEEEEEEEE' . ref($var);
127        }
128    } else {
129        if (defined $var) {
130            $html .= Sympa::Tools::Text::encode_html($var);
131        } else {
132            $html .= 'UNDEF';
133        }
134    }
135    return $html;
136}
137
138# Duplicates a complex variable (faster).
139# CAUTION: This duplicates blessed elements even if they are
140# singleton/multiton; this breaks subroutine references.
141sub clone_var {
142    return Clone::clone($_[0]) if $Clone::VERSION;
143    goto &dup_var;    # '&' needed
144}
145
146## Duplictate a complex variable
147sub dup_var {
148    my ($var) = @_;
149
150    if (ref($var)) {
151        if (ref($var) eq 'ARRAY') {
152            my $new_var = [];
153            foreach my $index (0 .. $#{$var}) {
154                $new_var->[$index] = dup_var($var->[$index]);
155            }
156            return $new_var;
157        } elsif (ref($var) eq 'HASH') {
158            my $new_var = {};
159            foreach my $key (sort keys %{$var}) {
160                $new_var->{$key} = dup_var($var->{$key});
161            }
162            return $new_var;
163        }
164    }
165
166    return $var;
167}
168
169####################################################
170# get_array_from_splitted_string
171####################################################
172# return an array made on a string splited by ','.
173# It removes spaces.
174#
175#
176# IN : -$string (+): string to split
177#
178# OUT : -ref(ARRAY)
179#
180######################################################
181# Note: This is used only by Sympa::List.
182sub get_array_from_splitted_string {
183    my ($string) = @_;
184    my @array;
185
186    foreach my $word (split /,/, $string) {
187        $word =~ s/^\s+//;
188        $word =~ s/\s+$//;
189        push @array, $word;
190    }
191
192    return \@array;
193}
194
195####################################################
196# diff_on_arrays
197####################################################
198# Makes set operation on arrays (seen as set, with no double) :
199#  - deleted : A \ B
200#  - added : B \ A
201#  - intersection : A /\ B
202#  - union : A \/ B
203#
204# IN : -$setA : ref(ARRAY) - set
205#      -$setB : ref(ARRAY) - set
206#
207# OUT : -ref(HASH) with keys :
208#          deleted, added, intersection, union
209#
210#######################################################
211sub diff_on_arrays {
212    my ($setA, $setB) = @_;
213    my $result = {
214        'intersection' => [],
215        'union'        => [],
216        'added'        => [],
217        'deleted'      => []
218    };
219    my %deleted;
220    my %added;
221    my %intersection;
222    my %union;
223
224    my %hashA;
225    my %hashB;
226
227    foreach my $eltA (@$setA) {
228        $hashA{$eltA}   = 1;
229        $deleted{$eltA} = 1;
230        $union{$eltA}   = 1;
231    }
232
233    foreach my $eltB (@$setB) {
234        $hashB{$eltB} = 1;
235        $added{$eltB} = 1;
236
237        if ($hashA{$eltB}) {
238            $intersection{$eltB} = 1;
239            $deleted{$eltB}      = 0;
240        } else {
241            $union{$eltB} = 1;
242        }
243    }
244
245    foreach my $eltA (@$setA) {
246        if ($hashB{$eltA}) {
247            $added{$eltA} = 0;
248        }
249    }
250
251    foreach my $elt (keys %deleted) {
252        next unless $elt;
253        push @{$result->{'deleted'}}, $elt if ($deleted{$elt});
254    }
255    foreach my $elt (keys %added) {
256        next unless $elt;
257        push @{$result->{'added'}}, $elt if ($added{$elt});
258    }
259    foreach my $elt (keys %intersection) {
260        next unless $elt;
261        push @{$result->{'intersection'}}, $elt if ($intersection{$elt});
262    }
263    foreach my $elt (keys %union) {
264        next unless $elt;
265        push @{$result->{'union'}}, $elt if ($union{$elt});
266    }
267
268    return $result;
269
270}
271
272####################################################
273# is_in_array
274####################################################
275# Test if a value is on an array
276#
277# IN : -$setA : ref(ARRAY) - set
278#      -$value : a serached value
279#
280# OUT : boolean
281#######################################################
282sub is_in_array {
283    my $set = shift;
284    die 'missing parameter "$value"' unless @_;
285    my $value = shift;
286
287    if (defined $value) {
288        foreach my $elt (@{$set || []}) {
289            next unless defined $elt;
290            return 1 if $elt eq $value;
291        }
292    } else {
293        foreach my $elt (@{$set || []}) {
294            return 1 unless defined $elt;
295        }
296    }
297
298    return undef;
299}
300
301=over
302
303=item smart_eq ( $a, $b )
304
305I<Function>.
306Check if two strings are identical.
307
308Parameters:
309
310=over
311
312=item $a, $b
313
314Operands.
315
316If both of them are undefined, they are equal.
317If only one of them is undefined, the are not equal.
318If C<$b> is a L<Regexp> object and it matches to C<$a>, they are equal.
319Otherwise, they are compared as strings.
320
321=back
322
323Returns:
324
325If arguments matched, true value.  Otherwise false value.
326
327=back
328
329=cut
330
331sub smart_eq {
332    die 'missing argument' if scalar @_ < 2;
333    my ($a, $b) = @_;
334
335    if (defined $a and defined $b) {
336        if (ref $b eq 'Regexp') {
337            return 1 if $a =~ $b;
338        } else {
339            return 1 if $a eq $b;
340        }
341    } elsif (!defined $a and !defined $b) {
342        return 1;
343    }
344
345    return undef;
346}
347
348## convert a string formated as var1="value1";var2="value2"; into a hash.
349## Used when extracting from session table some session properties or when
350## extracting users preference from user table
351## Current encoding is NOT compatible with encoding of values with '"'
352##
353sub string_2_hash {
354    my $data = shift;
355    my %hash;
356
357    pos($data) = 0;
358    while ($data =~ /\G;?(\w+)\=\"((\\[\"\\]|[^\"])*)\"(?=(;|\z))/g) {
359        my ($var, $val) = ($1, $2);
360        $val =~ s/\\([\"\\])/$1/g;
361        $hash{$var} = $val;
362    }
363
364    return (%hash);
365
366}
367## convert a hash into a string formated as var1="value1";var2="value2"; into
368## a hash
369sub hash_2_string {
370    my $refhash = shift;
371
372    return undef unless ref $refhash eq 'HASH';
373
374    my $data_string;
375    foreach my $var (keys %$refhash) {
376        next unless length $var;
377        my $val = $refhash->{$var};
378        $val = '' unless defined $val;
379
380        $val =~ s/([\"\\])/\\$1/g;
381        $data_string .= ';' . $var . '="' . $val . '"';
382    }
383    return ($data_string);
384}
385
386## compare 2 scalars, string/numeric independant
387sub smart_lessthan {
388    my ($stra, $strb) = @_;
389    $stra =~ s/^\s+//;
390    $stra =~ s/\s+$//;
391    $strb =~ s/^\s+//;
392    $strb =~ s/\s+$//;
393    $ERRNO = 0;
394    my ($numa, $unparsed) = POSIX::strtod($stra);
395    my $numb;
396    $numb = POSIX::strtod($strb)
397        unless ($ERRNO || $unparsed != 0);
398
399    if (($stra eq '') || ($strb eq '') || ($unparsed != 0) || $ERRNO) {
400        return $stra lt $strb;
401    } else {
402        return $stra < $strb;
403    }
404}
405
406=over
407
408=item sort_uniq ( [ \&comp ], @items )
409
410Returns sorted array of unique elements in the list.
411
412Parameters:
413
414=over
415
416=item \&comp
417
418Optional subroutine reference to compare each pairs of elements.
419It should take two arguments and return negative, zero or positive result.
420
421=item @items
422
423Items to be sorted.
424
425=back
426
427This function was added on Sympa 6.2.16.
428
429=back
430
431=cut
432
433sub sort_uniq {
434    my $comp;
435    if (ref $_[0] eq 'CODE') {
436        $comp = shift;
437    }
438
439    my %items;
440    @items{@_} = ();
441
442    if ($comp) {
443        return sort { $comp->($a, $b) } keys %items;
444    } else {
445        return sort keys %items;
446    }
447}
448
449# Create a custom attribute from an XML description
450# IN : A string, XML formed data as stored in database
451# OUT : HASH data storing custome attributes.
452# Old name: Sympa::List::parseCustomAttribute().
453sub decode_custom_attribute {
454    my $xmldoc = shift;
455    return undef unless defined $xmldoc and length $xmldoc;
456
457    my $parser = XML::LibXML->new();
458    my $tree;
459
460    ## We should use eval to parse to prevent the program to crash if it fails
461    if (ref($xmldoc) eq 'GLOB') {
462        $tree = eval { $parser->parse_fh($xmldoc) };
463    } else {
464        $tree = eval { $parser->parse_string($xmldoc) };
465    }
466
467    return undef unless defined $tree;
468
469    my $doc = $tree->getDocumentElement;
470
471    my @custom_attr = $doc->getChildrenByTagName('custom_attribute');
472    my %ca;
473    foreach my $ca (@custom_attr) {
474        my $id    = Encode::encode_utf8($ca->getAttribute('id'));
475        my $value = Encode::encode_utf8($ca->getElementsByTagName('value'));
476        $ca{$id} = {value => $value};
477    }
478    return \%ca;
479}
480
481# Create an XML Custom attribute to be stored into data base.
482# IN : HASH data storing custome attributes
483# OUT : string, XML formed data to be stored in database
484# Old name: Sympa::List::createXMLCustomAttribute().
485sub encode_custom_attribute {
486    my $custom_attr = shift;
487    return
488        '<?xml version="1.0" encoding="UTF-8" ?><custom_attributes></custom_attributes>'
489        if (not defined $custom_attr);
490    my $XMLstr = '<?xml version="1.0" encoding="UTF-8" ?><custom_attributes>';
491    foreach my $k (sort keys %{$custom_attr}) {
492        my $value = $custom_attr->{$k}{value};
493        $value = '' unless defined $value;
494
495        $XMLstr .=
496              "<custom_attribute id=\"$k\"><value>"
497            . Sympa::Tools::Text::encode_html($value, '\000-\037')
498            . "</value></custom_attribute>";
499    }
500    $XMLstr .= "</custom_attributes>";
501    $XMLstr =~ s/\s*\n\s*/ /g;
502
503    return $XMLstr;
504}
505
5061;
507