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