← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:09 2021

Filename/usr/local/libexec/sympa/Sympa/Tools/Data.pm
StatementsExecuted 3577 statements in 6.45s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
150711267ms6.44sSympa::Tools::Data::::clone_varSympa::Tools::Data::clone_var
345111.85ms1.85msSympa::Tools::Data::::smart_eqSympa::Tools::Data::smart_eq
0000s0sSympa::Tools::Data::::BEGIN@30Sympa::Tools::Data::BEGIN@30
0000s0sSympa::Tools::Data::::BEGIN@31Sympa::Tools::Data::BEGIN@31
0000s0sSympa::Tools::Data::::BEGIN@32Sympa::Tools::Data::BEGIN@32
0000s0sSympa::Tools::Data::::BEGIN@33Sympa::Tools::Data::BEGIN@33
0000s0sSympa::Tools::Data::::BEGIN@34Sympa::Tools::Data::BEGIN@34
0000s0sSympa::Tools::Data::::BEGIN@35Sympa::Tools::Data::BEGIN@35
0000s0sSympa::Tools::Data::::BEGIN@36Sympa::Tools::Data::BEGIN@36
0000s0sSympa::Tools::Data::::BEGIN@38Sympa::Tools::Data::BEGIN@38
0000s0sSympa::Tools::Data::::__ANON__Sympa::Tools::Data::__ANON__ (xsub)
0000s0sSympa::Tools::Data::::decode_custom_attributeSympa::Tools::Data::decode_custom_attribute
0000s0sSympa::Tools::Data::::diff_on_arraysSympa::Tools::Data::diff_on_arrays
0000s0sSympa::Tools::Data::::dump_html_varSympa::Tools::Data::dump_html_var
0000s0sSympa::Tools::Data::::dump_varSympa::Tools::Data::dump_var
0000s0sSympa::Tools::Data::::dup_varSympa::Tools::Data::dup_var
0000s0sSympa::Tools::Data::::encode_custom_attributeSympa::Tools::Data::encode_custom_attribute
0000s0sSympa::Tools::Data::::get_array_from_splitted_stringSympa::Tools::Data::get_array_from_splitted_string
0000s0sSympa::Tools::Data::::hash_2_stringSympa::Tools::Data::hash_2_string
0000s0sSympa::Tools::Data::::is_in_arraySympa::Tools::Data::is_in_array
0000s0sSympa::Tools::Data::::recursive_transformationSympa::Tools::Data::recursive_transformation
0000s0sSympa::Tools::Data::::smart_lessthanSympa::Tools::Data::smart_lessthan
0000s0sSympa::Tools::Data::::sort_uniqSympa::Tools::Data::sort_uniq
0000s0sSympa::Tools::Data::::string_2_hashSympa::Tools::Data::string_2_hash
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
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()'; }
# spent 0s executing statements in string eval
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.
141
# spent 6.44s (267ms+6.18) within Sympa::Tools::Data::clone_var which was called 1507 times, avg 4.28ms/call: # 1507 times (267ms+6.18s) by Sympa::Robot::list_params at line 443 of /usr/local/libexec/sympa/Sympa/Robot.pm, avg 4.28ms/call
sub clone_var {
14215076.44s15076.18s return Clone::clone($_[0]) if $Clone::VERSION;
# spent 6.18s making 1507 calls to Clone::clone, avg 4.10ms/call
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
331
# spent 1.85ms within Sympa::Tools::Data::smart_eq which was called 345 times, avg 5µs/call: # 345 times (1.85ms+0s) by Sympa::List::get_lists at line 4528 of /usr/local/libexec/sympa/Sympa/List.pm, avg 5µs/call
sub smart_eq {
332345263µs die 'missing argument' if scalar @_ < 2;
333345246µs my ($a, $b) = @_;
334
335345289µs if (defined $a and defined $b) {
336345280µs if (ref $b eq 'Regexp') {
337 return 1 if $a =~ $b;
338 } else {
339345104µs return 1 if $a eq $b;
340 }
341 } elsif (!defined $a and !defined $b) {
342 return 1;
343 }
344
345345656µs 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;