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