Überflüssige "jquery-ui"-Einbindungen gelöscht
[kivitendo-erp.git] / SL / MoreCommon.pm
1 package SL::MoreCommon;
2
3 require Exporter;
4 our @ISA = qw(Exporter);
5
6 our @EXPORT    = qw(save_form restore_form compare_numbers any cross);
7 our @EXPORT_OK = qw(ary_union ary_intersect ary_diff listify ary_to_hash uri_encode uri_decode);
8
9 use List::MoreUtils qw(zip);
10 use YAML;
11
12 use SL::AM;
13
14 use strict;
15
16 sub save_form {
17   $main::lxdebug->enter_sub();
18
19   my @dont_dump_keys = @_;
20   my %not_dumped_values;
21
22   foreach my $key (@dont_dump_keys) {
23     $not_dumped_values{$key} = $main::form->{$key};
24     delete $main::form->{$key};
25   }
26
27   my $old_form = YAML::Dump($main::form);
28   $old_form =~ s|!|!:|g;
29   $old_form =~ s|\n|!n|g;
30   $old_form =~ s|\r|!r|g;
31
32   map { $main::form->{$_} = $not_dumped_values{$_} } keys %not_dumped_values;
33
34   $main::lxdebug->leave_sub();
35
36   return $old_form;
37 }
38
39 sub restore_form {
40   $main::lxdebug->enter_sub();
41
42   my ($old_form, $no_delete, @keep_vars) = @_;
43
44   my $form          = $main::form;
45   my %keep_vars_map = map { $_ => 1 } @keep_vars;
46
47   map { delete $form->{$_} if (!$keep_vars_map{$_}); } keys %{$form} unless ($no_delete);
48
49   $old_form =~ s|!r|\r|g;
50   $old_form =~ s|!n|\n|g;
51   $old_form =~ s|![!:]|!|g;
52
53   my $new_form = YAML::Load($old_form);
54   map { $form->{$_} = $new_form->{$_} if (!$keep_vars_map{$_}) } keys %{ $new_form };
55
56   $main::lxdebug->leave_sub();
57 }
58
59 sub compare_numbers {
60   $main::lxdebug->enter_sub();
61
62   my ($a, $a_unit, $b, $b_unit) = @_;
63
64   my $units          = AM->retrieve_all_units;
65
66   if (!$units->{$a_unit} || !$units->{$b_unit} || ($units->{$a_unit}->{base_unit} ne $units->{$b_unit}->{base_unit})) {
67     $main::lxdebug->leave_sub();
68     return undef;
69   }
70
71   $a *= $units->{$a_unit}->{factor};
72   $b *= $units->{$b_unit}->{factor};
73
74   $main::lxdebug->leave_sub();
75
76   return $a <=> $b;
77 }
78
79 sub any (&@) {
80   my $f = shift;
81   return if ! @_;
82   for (@_) {
83     return 1 if $f->();
84   }
85   return 0;
86 }
87
88 sub cross(&\@\@) {
89   my $op = shift;
90   use vars qw/@A @B/;
91   local (*A, *B) = @_;    # syms for caller's input arrays
92
93   # Localise $a, $b
94   my ($caller_a, $caller_b) = do {
95     my $pkg = caller();
96     no strict 'refs';
97     \*{$pkg.'::a'}, \*{$pkg.'::b'};
98   };
99
100   local(*$caller_a, *$caller_b);
101
102   # This map expression is also the return value.
103   map { my $a_index = $_;
104     map { my $b_index = $_;
105       # assign to $a, $b as refs to caller's array elements
106       (*$caller_a, *$caller_b) = \($A[$a_index], $B[$b_index]);
107       $op->();    # perform the transformation
108     }  0 .. $#B;
109   }  0 .. $#A;
110 }
111
112 sub _ary_calc_union_intersect {
113   my ($a, $b) = @_;
114
115   my %count = ();
116
117   foreach my $e (@$a, @$b) { $count{$e}++ }
118
119   my @union = ();
120   my @isect = ();
121   foreach my $e (keys %count) {
122     push @union, $e;
123     push @isect, $e if $count{$e} == 2;
124   }
125
126   return (\@union, \@isect);
127 }
128
129 sub ary_union {
130   return @{ (_ary_calc_union_intersect @_)[0] };
131 }
132
133 sub ary_intersect {
134   return @{ (_ary_calc_union_intersect @_)[1] };
135 }
136
137 sub ary_diff {
138   my ($a, $b) = @_;
139   my %in_b    = map { $_ => 1 } @$b;
140   return grep { !$in_b{$_} } @$a;
141 }
142
143 sub listify {
144   my @ary = scalar @_ > 1 ? @_ : ref $_[0] eq 'ARRAY' ? @{ $_[0] } : (@_);
145   return wantarray ? @ary : scalar @ary;
146 }
147
148 sub ary_to_hash {
149   my $idx_key   = shift;
150   my $value_key = shift;
151
152   return map { ($_, 1) } @_ if !defined($idx_key);
153
154   my @indexes = map { ref $_ eq 'HASH' ? $_->{ $idx_key } : $_->$idx_key(); } @_;
155   my @values  = map {
156       !defined($value_key) ? $_
157     : ref $_ eq 'HASH'     ? $_->{ $value_key }
158     :                        $_->$value_key()
159   } @_;
160
161   return zip(@indexes, @values);
162 }
163
164 sub uri_encode {
165   my ($str) = @_;
166
167   $str =  Encode::encode('utf-8-strict', $str) if $::locale->is_utf8;
168   $str =~ s/([^a-zA-Z0-9_.:-])/sprintf("%%%02x", ord($1))/ge;
169
170   return $str;
171 }
172
173 sub uri_decode {
174   my ($str) = @_;
175
176   $str =~ tr/+/ /;
177   $str =~ s/\\$//;
178
179   $str =~ s/%([0-9a-fA-Z]{2})/pack("C",hex($1))/eg;
180   $str =  Encode::decode('utf-8-strict', $str) if $::locale->is_utf8;
181
182   return $str;
183 }
184
185 1;
186
187 __END__
188
189 =head1 NAME
190
191 SL::MoreCommon.pm - helper functions
192
193 =head1 DESCRIPTION
194
195 this is a collection of helper functions used in kivitendo.
196 Most of them are either obvious or too obscure to care about unless you really have to.
197 The exceptions are documented here.
198
199 =head2 FUNCTIONS
200
201 =over 4
202
203 =item save_form
204
205 =item restore_form
206
207 A lot of the old sql-ledger routines are strictly procedural. They search for params in the $form object, do stuff with it, and return a status code.
208
209 Once in a while you'll want something from such a function without altering $form. Yeah, you could rewrite the routine from scratch... not. Just save you form, execute the routine, grab your results, and restore the previous form while you curse at the original design.
210
211 =item cross BLOCK ARRAY ARRAY
212
213 Evaluates BLOCK for each combination of elements in ARRAY1 and ARRAY2
214 and returns a new list consisting of BLOCK's return values.
215 The two elements are set to $a and $b.
216 Note that those two are aliases to the original value so changing them
217 will modify the input arrays.
218
219   # append each to each
220   @a = qw/a b c/;
221   @b = qw/1 2 3/;
222   @x = cross { "$a$b" } @a, @b;
223   # returns a1, a2, a3, b1, b2, b3, c1, c2, c3
224
225 As cross expects an array but returns a list it is not directly chainable
226 at the moment. This will be corrected in the future.
227
228 =item ary_to_hash INDEX_KEY, VALUE_KEY, ARRAY
229
230 Returns a hash with the content of ARRAY based on the values of
231 INDEX_KEY and VALUE_KEY.
232
233 If INDEX_KEY is undefined then the elements of ARRAY are the keys and
234 '1' is the value for each of them.
235
236 If INDEX_KEY is defined then each element of ARRAY is checked whether
237 or not it is a hash. If it is then its element at the position
238 INDEX_KEY will be the resulting hash element's key. Otherwise the
239 element is assumed to be a blessed reference, and its INDEX_KEY
240 function will be called.
241
242 The values of the resulting hash follow a similar pattern. If
243 VALUE_KEY is undefined then the current element itself is the new hash
244 element's value. If the current element is a hash then its element at
245 the position VALUE_KEY will be the resulting hash element's
246 key. Otherwise the element is assumed to be a blessed reference, and
247 its VALUE_KEY function will be called.
248
249 =back
250
251 =cut