lib/Onis/Data/Persistent/None.pm

   1 package Onis::Data::Persistent::None;
   2
   3 use strict;
   4 use warnings;
   5 use vars (qw($TREE));
   6
   7 use Carp qw(carp confess);
   8 use Exporter;
   9
  10 =head1 NAME
  11
  12 Onis::Data::Persistent::None - Storage backend without storage.. ;)
  13
  14 =head1 DESCRIPTION
  15
  16 Simple storage backend that handles data in-memory only..
  17
  18 =head1 CONFIGURATION OPTIONS
  19
  20 None.
  21
  22 =cut
  23
  24 @Onis::Data::Persistent::None::EXPORT_OK = (qw($TREE));
  25 @Onis::Data::Persistent::None::ISA = ('Exporter');
  26
  27 if ($::DEBUG & 0x0200)
  28 {
  29         require Data::Dumper;
  30 }
  31
  32 return (1);
  33
  34 sub new
  35 {
  36         my $pkg    = shift;
  37         my $name   = shift;
  38         my $key    = shift;
  39         my @fields = @_;
  40         my $caller = caller ();
  41         my $obj    = {};
  42         my $i = 0;
  43
  44         my $id = $caller . ':' . $name;
  45
  46         if (exists ($TREE->{$id}))
  47         {
  48                 print STDERR $/, __FILE__, ": Name $name has been used in context $caller before.";
  49                 return (undef);
  50         }
  51
  52         $TREE->{$id} = {};
  53         $obj->{'data'} = $TREE->{$id};
  54
  55         $obj->{'key'} = $key;
  56         $obj->{'fields'} = [@fields];
  57         $obj->{'num_fields'} = scalar (@fields);
  58         $obj->{'field_index'} = {map { $_ => $i++ } (@fields)};
  59         $obj->{'id'} = $id;
  60
  61         if ($::DEBUG & 0x0200)
  62         {
  63                 my $prefix = __FILE__ . ': ';
  64                 my $dbg = Data::Dumper->Dump ([$obj], ['obj']);
  65                 $dbg =~ s/^/$prefix/mg; chomp ($dbg);
  66                 print STDOUT $/, $dbg;
  67         }
  68
  69         return (bless ($obj, $pkg));
  70 }
  71
  72 sub put
  73 {
  74         my $obj    = shift;
  75         my $key    = shift;
  76         my @fields = @_;
  77
  78         if ($obj->{'num_fields'} != scalar (@fields))
  79         {
  80                 my $id = $obj->{'id'};
  81                 carp ("Number of fields do not match ($id).");
  82                 return;
  83         }
  84
  85         if ($::DEBUG & 0x0200)
  86         {
  87                 print STDOUT $/, __FILE__, ': PUT(', $obj->{'id'}, ', ', $key, ') = (' . join (', ', @fields) . ')';
  88         }
  89
  90         $obj->{'data'}{$key} = [@fields];
  91 }
  92
  93 sub get
  94 {
  95         my $obj = shift;
  96         my $key = shift;
  97
  98         if (!defined ($obj->{'data'}{$key}))
  99         {
 100                 return (qw());
 101         }
 102
 103         if ($::DEBUG & 0x0200)
 104         {
 105                 print STDOUT $/, __FILE__, ': GET(', $obj->{'id'}, ', ', $key, ') = (' . join (', ', @{$obj->{'data'}{$key}}) . ')';
 106         }
 107
 108         return (@{$obj->{'data'}{$key}});
 109 }
 110
 111 sub keys
 112 {
 113         my $obj = shift;
 114         my @fields = @_;
 115         my @field_indizes = ();
 116         my @keys = keys %{$obj->{'data'}};
 117
 118         if (!@fields)
 119         {
 120                 return (@keys);
 121         }
 122
 123         for (@fields)
 124         {
 125                 my $field = $_;
 126                 if (!defined ($obj->{'field_index'}{$field}))
 127                 {
 128                         my $id = $obj->{'id'};
 129                         print STDERR $/, __FILE__, ": $field is not a valid field ($id).";
 130                 }
 131                 push (@field_indizes, $obj->{'field_index'}{$field});
 132         }
 133
 134         return (sort
 135         sub {
 136                 for (@field_indizes)
 137                 {
 138                         my $d = $obj->{'data'}{$a}[$_] cmp $obj->{'data'}{$b}[$_];
 139                         return ($d) if ($d);
 140                 }
 141         }, @keys);
 142 }
 143
 144 sub del
 145 {
 146         my $obj = shift;
 147         my $key = shift;
 148
 149         if (defined ($obj->{'data'}{$key}))
 150         {
 151                 delete ($obj->{'data'}{$key});
 152         }
 153 }
 154
 155 =head1 AUTHOR
 156
 157 Florian octo Forster, L<octo@verplant.org>
 158
 159 =cut
 160
 161 exit (0);