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