lib/Yaala/Data/Core.pm

   1 package Yaala::Data::Core;
   2
   3 use strict;
   4 use warnings;
   5 #use vars qw#$DATA#;
   6
   7 =head1 Yaala::Data::Core
   8
   9 Store data to the internal structure and retrieve it again.
  10
  11 =cut
  12
  13 use Exporter;
  14 use Yaala::Data::Setup qw#$USED_FIELDS $USED_AGGREGATIONS $SELECTS#;
  15 use Yaala::Data::Convert qw#convert#;
  16 use Yaala::Data::Persistent qw#init#;
  17
  18 @Yaala::Data::Core::EXPORT_OK = qw#receive store get_values#;
  19 @Yaala::Data::Core::ISA = ('Exporter');
  20
  21 # holds all data
  22 #our $DATA = {};
  23 our $DATA = init ('$DATA', 'hash');
  24
  25 # holds the order of all fields stored in $DATA
  26 our @FIELD_ORDER = ();
  27
  28 # holds all values for each field (key)
  29 our $VALUES_PER_FIELD = init ('$VALUES_PER_FIELD', 'hash');
  30
  31 # sort fields by occurence count in the config file.
  32 # This _might_ speed things up.
  33 @FIELD_ORDER = (sort { $USED_FIELDS->{$b} <=> $USED_FIELDS->{$a} } (keys %$USED_FIELDS));
  34
  35 my $VERSION = '$Id: Core.pm,v 1.13 2003/12/09 09:12:05 octo Exp $';
  36 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
  37
  38 if ($::DEBUG)
  39 {
  40         require Data::Dumper;
  41         import Data::Dumper qw#Dumper#;
  42 }
  43
  44 return (1);
  45
  46 =head1 Routines
  47
  48 =head2 Yaala::Data::Core::delete_fields (\%data)
  49
  50 Removes uninteresting fields from the hash-ref
  51
  52 =cut
  53 sub delete_fields
  54 {
  55         my $data = shift;
  56
  57         foreach my $key (keys %$data)
  58         {
  59                 unless (defined ($USED_FIELDS->{$key})
  60                                         or defined ($USED_AGGREGATIONS->{$key}))
  61                 {
  62                         delete ($data->{$key});
  63                 }
  64         }
  65 }
  66
  67 =head2 Yaala::Data::Core:receive ($sel, $agg, \%query)
  68
  69 query data from the internal structure. Takes care of wildcards (missing
  70 keys in the query hash) itself..
  71
  72 =cut
  73 sub receive
  74 {
  75         my $sel = shift;
  76         my $agg = shift;
  77         my $query = shift;
  78         my $retval = 0;
  79         my $sel_string = $sel->[3];
  80
  81         if (ref ($agg))
  82         {
  83                 print STDERR $/, "Bug: ", join (', ', caller ());
  84         }
  85
  86         if (!defined ($DATA->{$sel_string}{$agg}))
  87         {
  88                 print STDERR $/, __FILE__, ": Unavailable aggregation requested: ``$agg''. Returning 0.";
  89
  90                 if ($::DEBUG)
  91                 {
  92                         my $dump = Data::Dumper->Dump ([$sel, $query], [qw#$sel $query#]);
  93                         my $file = __FILE__ . ': ';
  94                         $dump =~ s/^/$file/gm;
  95                         $dump =~ s/[\n\r]+$//s;
  96                         print STDERR $/, $dump;
  97                 }
  98
  99                 return (0);
 100         }
 101
 102         my $ptr = $DATA->{$sel_string}{$agg};
 103
 104         if ($::DEBUG & 0x80)
 105         {
 106                 my $dump = Data::Dumper->Dump ([$query], ['$query']);
 107                 my $tmp = __FILE__ . ': ';
 108                 $dump =~ s/^/$tmp/gm;
 109                 $dump =~ s/[\n\r]+$//g;
 110                 print STDERR $/, $dump;
 111         }
 112
 113         for (@{$sel->[1]})
 114         {
 115                 my $fld = $_;
 116                 if (defined ($query->{$fld}))
 117                 {
 118                         if (defined ($ptr->{$query->{$fld}}))
 119                         {
 120                                 $ptr = $ptr->{$query->{$fld}};
 121                         }
 122                         else
 123                         {
 124                                 print STDERR $/, __FILE__, ': Unavailable field requested. Returning 0.'
 125                                 if ($::DEBUG & 0x10);
 126                                 return (0);
 127                         }
 128                 }
 129                 else
 130                 {
 131                         my $sum = 0;
 132                         my @val = keys (%{$VALUES_PER_FIELD->{$sel_string}{$fld}});
 133                         print STDERR $/, __FILE__, ': Query not unique. Performing subqueries for ',
 134                         scalar (@val), " values of field '$fld'." if ($::DEBUG & 0x10);
 135                         for (@val)
 136                         {
 137                                 my $val = $_;
 138                                 my %new_query = %$query;
 139                                 $new_query{$fld} = $val;
 140                                 $sum += receive ($sel, $agg, \%new_query);
 141                         }
 142                         print $/, __FILE__, ": Returning, \$sum = $sum" if ($::DEBUG & 0x10);
 143                         return ($sum);
 144                 }
 145         }
 146         print $/, __FILE__, ": Returning, \$\$ptr = $$ptr" if ($::DEBUG & 0x10);
 147         return ($$ptr);
 148 }
 149
 150 =head2 Yaala::Data::Core:store (\%data)
 151
 152 Saves data in the internal structure.
 153
 154 =cut
 155 sub store
 156 {
 157         my $data = shift;
 158
 159         delete_fields ($data);
 160
 161         if ($::DEBUG & 0x80)
 162         {
 163                 my $dump = Data::Dumper->Dump ([$data, $DATA], [qw#$data $DATA#]);
 164                 my $file = __FILE__ . ': ';
 165                 $dump =~ s/^/$file/gm;
 166                 $dump =~ s/[\n\r]+$//s;
 167                 print STDERR $/, $dump;
 168         }
 169
 170         for (@$SELECTS)
 171         {
 172                 my $sel = $_;
 173                 my $agg = $sel->[0];
 174                 my $sel_string = $sel->[3];
 175                 my $ptr;
 176                 my $total_fields = 0;
 177                 my $i = 0;
 178
 179                 if (check_where_clauses ($sel, $data))
 180                 {
 181                         next;
 182                 }
 183
 184                 for (@{$sel->[0]})
 185                 {
 186                         my $agg = $_;
 187
 188                         if (!defined $DATA->{$sel_string}{$agg}) { $DATA->{$sel_string}{$agg} = {}; }
 189                         my $ptr = $DATA->{$sel_string}{$agg};
 190
 191                         print STDERR $/, __FILE__, ": \$DATA->{$sel_string}{$agg}" if ($::DEBUG & 0x10);
 192
 193                         $total_fields = scalar (@{$sel->[1]});
 194                         for ($i = 0; $i < $total_fields; $i++)
 195                         {
 196                                 my $fld = $sel->[1][$i];
 197
 198                                 my $field_value = convert ($fld, $data->{$fld});
 199                                 print STDERR '{', $field_value, '}' if ($::DEBUG & 0x10);
 200
 201                                 if (!defined ($ptr->{$field_value}))
 202                                 {
 203                                         if ($i == ($total_fields - 1))
 204                                         {
 205                                                 my $tmp = 0;
 206                                                 $ptr->{$field_value} = \$tmp;
 207                                         }
 208                                         else
 209                                         {
 210                                                 $ptr->{$field_value} = {};
 211                                         }
 212                                 }
 213
 214                                 $ptr = $ptr->{$field_value};
 215
 216                                 $VALUES_PER_FIELD->{$sel_string}{$fld}{$field_value}++;
 217                         }
 218                         print STDERR " += ", $data->{$agg} if ($::DEBUG & 0x10);
 219
 220                         if (!defined ($$ptr) or !defined ($data->{$agg}))
 221                         {
 222                                 print STDERR $/, __FILE__, ': ',
 223                                 Data::Dumper->Dump ([$sel, $data], [qw/sel data/]);
 224                         }
 225
 226                         $$ptr += $data->{$agg};
 227                 }
 228         }
 229 }
 230
 231 sub get_values
 232 {
 233         my $sel = shift;
 234         my $sel_string = $sel->[3];
 235         my $field = shift;
 236
 237         if (!defined ($VALUES_PER_FIELD->{$sel_string}))
 238         {
 239                 print STDERR $/, __FILE__, ': selection not defined in $VALUES_PER_FIELD.' if ($::DEBUG);
 240                 return ();
 241         }
 242
 243         my @vals = keys (%{$VALUES_PER_FIELD->{$sel_string}{$field}});
 244
 245         return (@vals);
 246 }
 247
 248 sub check_where_clauses
 249 # true  == reject
 250 # false == accept
 251 {
 252         my $sel = shift;
 253         my $data = shift;
 254
 255         for (@{$sel->[2]})
 256         {
 257                 my $where = $_;
 258                 my ($key, $op, $val) = @$where;
 259                 my $data_val;
 260
 261                 if (!defined ($data->{$key}) and
 262                         ($op ne '!=' and
 263                                 $op ne '!~' and
 264                                 $op ne '<=' and
 265                                 $op ne '<'))
 266                 {
 267                         print STDERR $/, __FILE__, ": \$data->{$key} not defined." if ($::DEBUG);
 268                         return (1);
 269                 }
 270                 elsif (!defined ($data->{$key}) and
 271                         ($op eq '!=' or
 272                                 $op eq '!~' or
 273                                 $op eq '<=' or
 274                                 $op eq '<'))
 275                 {
 276                         next;
 277                 }
 278
 279                 $data_val = $data->{$key};
 280
 281                 if ($op eq '=~')
 282                 {
 283                         if ($data_val =~ qr/$val/)
 284                         {
 285                                 next;
 286                         }
 287                         else
 288                         {
 289                                 return (1);
 290                         }
 291                 }
 292                 elsif ($op eq '!~')
 293                 {
 294                         if ($data_val !~ qr/$val/)
 295                         {
 296                                 next;
 297                         }
 298                         else
 299                         {
 300                                 return (1);
 301                         }
 302                 }
 303                 else
 304                 {
 305                         my $retval = 0;
 306                         my $eval = qq#if (\$data_val $op \$val) { \$retval = 0; } else { \$retval = 1; }#;
 307                         eval "$eval";
 308                         die ('eval: ' . $@) if ($@);
 309
 310                         return (1) if ($retval);
 311                 }
 312         }
 313
 314         return (0);
 315 }