lib/Yaala/Data/Persistent.pm

   1 package Yaala::Data::Persistent;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 Yaala::Data::Persistent
   7
   8 Saves datastructures to disk and retrieves them again. This allows data
   9 to exist for longer than just one run.
  10
  11 =cut
  12
  13 use Yaala::Config qw#get_config get_checksum#;
  14
  15 @Yaala::Data::Persistent::EXPORT_OK = qw#init#;
  16 @Yaala::Data::Persistent::ISA = ('Exporter');
  17
  18 our $HAVE_STORABLE = 0;
  19 our $WANT_PERSISTENCY = 1;
  20 our $DATA_STRUCTURE = {};
  21 our $FILENAME = 'persistency.data';
  22
  23 my $VERSION = '$Id: Persistent.pm,v 1.5 2004/11/07 11:15:28 octo Exp $';
  24 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
  25
  26 eval "use Storable qw#store retrieve#;";
  27 if (!$@)
  28 {
  29         $HAVE_STORABLE = 1;
  30         print STDERR ' - Storable is installed' if ($::DEBUG);
  31 }
  32 else
  33 {
  34         print STDERR ' - Storable is NOT installed' if ($::DEBUG);
  35 }
  36
  37 =head1 Configuration options
  38
  39 =head2 use_persistency
  40
  41 If set to false persistency will not be used, even if the required
  42 module ``Storable'' is installed.
  43
  44 If unset it defaults to automatic detection of the ``Storable'' module
  45 and uses persistency if possible.
  46
  47 =cut
  48
  49 if (get_config ('use_persistency'))
  50 {
  51         my $want = lc (get_config ('use_persistency'));
  52         if ($want eq 'no' or $want eq 'false' or $want eq 'off')
  53         {
  54                 $WANT_PERSISTENCY = 0;
  55         }
  56         elsif ($want eq 'yes' or $want eq 'true' or $want eq 'on')
  57         {
  58                 if (!$HAVE_STORABLE)
  59                 {
  60                         print STDERR $/, __FILE__, ": You've set ``use_persistency'' to ``$want''.",
  61                         $/, __FILE__, "  For this to work you need to have the perl module ``Storable'' installed.",
  62                         $/, __FILE__, '  Please go to your nearest CPAN-mirror and install it first.',
  63                         $/, __FILE__, '  This config-option will be ignored.';
  64                 }
  65         }
  66         elsif ($want eq 'auto' or $want eq 'automatic')
  67         {
  68                 # do nothing.. Already been done.
  69         }
  70         else
  71         {
  72                 print STDERR $/, __FILE__, ": You've set ``use_persistency'' to ``$want''.",
  73                 $/, __FILE__, '  This value is not understood and is being ignored.';
  74         }
  75 }
  76
  77 =head2 persistency_file
  78
  79 Sets the file to store persistency data in. Defaults to
  80 ``persistency.data''
  81
  82 =cut
  83
  84 if (get_config ('persistency_file'))
  85 {
  86         $FILENAME = get_config ('persistency_file');
  87 }
  88
  89 if ($HAVE_STORABLE and $WANT_PERSISTENCY and -e $FILENAME)
  90 {
  91         $DATA_STRUCTURE = retrieve ($FILENAME);
  92
  93         my $checksum = get_checksum ();
  94         print STDERR $/, __FILE__, ": Config-checksum is ``$checksum''" if ($::DEBUG & 0x200);
  95
  96         if (!defined ($DATA_STRUCTURE))
  97         {
  98                 print STDERR $/, __FILE__, ": Persistent data could not be loaded.",
  99                 $/, __FILE__, "``$FILENAME'' will be overwritten when the program exits.";
 100                 $DATA_STRUCTURE = {'*CHECKSUM*' => $checksum};
 101         }
 102         else
 103         {
 104                 if (!defined ($DATA_STRUCTURE->{'*CHECKSUM*'})
 105                                 or ($DATA_STRUCTURE->{'*CHECKSUM*'} ne $checksum))
 106                 {
 107                         print STDERR $/, __FILE__, ": Persistent data could be read, but checksums didn't match.",
 108                         $/, __FILE__, ": The data will not be used and the file overwritten." if ($::DEBUG);
 109
 110                         if ($::DEBUG & 200)
 111                         {
 112                                 if (!defined ($DATA_STRUCTURE->{'*CHECKSUM*'}))
 113                                 {
 114                                         print STDERR $/, __FILE__, ": \$DATA_STRUCTURE->{'*CHECKSUM*'} isn't defined.";
 115                                 }
 116                                 else
 117                                 {
 118                                         my $tmp = $DATA_STRUCTURE->{'*CHECKSUM*'};
 119                                         print STDERR $/, __FILE__, ": ``$tmp'' ne ``$checksum''";
 120                                 }
 121                         }
 122
 123                         $DATA_STRUCTURE = {'*CHECKSUM*' => $checksum};
 124                 }
 125         }
 126 }
 127 elsif ($HAVE_STORABLE and $WANT_PERSISTENCY and !-e $FILENAME)
 128 {
 129         my $checksum = get_checksum ();
 130         print STDERR $/, __FILE__, ": Config-checksum is ``$checksum''" if ($::DEBUG & 0x200);
 131
 132         $DATA_STRUCTURE = {'*CHECKSUM*' => $checksum};
 133 }
 134
 135 return (1);
 136
 137 sub data_save
 138 {
 139         if (!$HAVE_STORABLE) { return (undef); }
 140
 141         my $pkg = caller;
 142         my $name = shift;
 143         my $ptr = shift;
 144
 145         $DATA_STRUCTURE->{$pkg}{$name} = $ptr;
 146 }
 147
 148 sub data_load
 149 {
 150         if (!$HAVE_STORABLE) { return (undef); }
 151
 152         my $pkg = caller;
 153         my $name = shift;
 154         my $ptr; # = undef;
 155
 156         if (defined ($DATA_STRUCTURE->{$pkg}{$name}))
 157         {
 158                 $ptr = $DATA_STRUCTURE->{$pkg}{$name};
 159         }
 160
 161         return ($ptr);
 162 }
 163
 164 =head1 Exported routines
 165
 166 =head2 init ($name, $type)
 167
 168 Initializes a variable in the persistency-namespace which is daved
 169 automatically upon termination.
 170
 171 The type is needed for proper initialisazion when the persistency-file
 172 could not be read. Valid veriable types are ``scalar'', ``hash'' and
 173 ``array''.
 174
 175 The name must be uniqe for each package so the module can identify which
 176 variable is requested,
 177
 178 =cut
 179
 180 sub init
 181 {
 182         my $pkg = caller;
 183         my $name = shift;
 184         my $type = shift;
 185         my $ptr;
 186
 187         if (defined ($DATA_STRUCTURE->{$pkg}{$name}))
 188         {
 189                 $ptr = $DATA_STRUCTURE->{$pkg}{$name};
 190         }
 191         else
 192         {
 193                 if ($type eq 'scalar')
 194                 {
 195                         my $tmp = '';
 196                         $ptr = \$tmp;
 197                 }
 198                 elsif ($type eq 'hash')
 199                 {
 200                         my %tmp = ();
 201                         $ptr = \%tmp;
 202                 }
 203                 elsif ($type eq 'array')
 204                 {
 205                         my @tmp = ();
 206                         $ptr = \@tmp;
 207                 }
 208                 else
 209                 {
 210                         die;
 211                 }
 212
 213                 $DATA_STRUCTURE->{$pkg}{$name} = $ptr;
 214         }
 215
 216         return ($ptr);
 217 }
 218
 219 END
 220 {
 221         if ($HAVE_STORABLE and $WANT_PERSISTENCY)
 222         {
 223                 print STDERR $/, __FILE__, ": Writing persistent data to ``$FILENAME''" if ($::DEBUG);
 224                 store ($DATA_STRUCTURE, $FILENAME);
 225         }
 226 }