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