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