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