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