DB/FileSystem/SuikaWikiCache09.pm


=head1 NAME

SuikaWiki::DB::FileSystem::SuikaWikiCache09 - WikiDatabase interface to SuikaWikiCache/0.9 databases

=head1 DESCRIPTION

This module provides SuikaWiki WikiDatabase interface to SuikaWikiCache/0.9
format of database.

This module is part of SuikaWiki.

=cut

package SuikaWiki::DB::FileSystem::SuikaWikiCache09;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require SuikaWiki::DB::Util;
push our @ISA, 'SuikaWiki::DB::Util::template';
my $Sep = '//';
my $Self = '.';
my $Parent = '..';

sub new ($%) {
  my $self = shift->SUPER::new (@_);
  my %opt = @_;
  $self->{directory} = $opt{directory}
    or report SuikaWiki::DB::Util::Error
         -type => 'DB_METHOD_PARAMETER_REQUIRED',
         -object => $self, method => 'new',
         parameter => 'directory';
  $self->{directory} .= '/' unless substr ($self->{directory}, -1, 1) eq '/';
  $self->{prefix} = $opt{prefix} || '.tmp.cache.';
  $self->{suffix} = $opt{suffix} || '.dat';
  $self->{expires} = $opt{expires} || 86400;
  $self->{removes} = $opt{removes} || 604800;
  $self->{now} = $opt{now};
  $self;
}

sub __encode_base16 ($$) {
  my ($self, $s) = @_;
  $s =~ s/(.)/sprintf '%02X', ord $1/ges;
  $s;
}
sub __decode_base16 ($$) {
  my ($self, $s) = @_;
  $s =~ s/([0-9A-Fa-f]{2})/chr hex $1/ge;
  $s;
}

sub ___open_prop ($$) {
  my ($self, $opt) = @_;
  local $Error::Depth = $Error::Depth + 1;
  my $file = $self->{directory}
            .$self->{prefix}
            .$self->__encode_base16 ($opt->{prop})
            .$self->{suffix};
  unless (-e $file) {
    $self->{db_hash}->{$opt->{prop}} = {};
  } else {
    CORE::open DB, '<', $file 
            or report SuikaWiki::DB::Util::Error
                      -type => 'STOP_DB_PROP_CANT_OPEN', file => $file,
                      msg => $!, prop => $opt->{prop},
                      -object => $self, method => '__read_meta';
    binmode DB;
    local $/ = undef;
    my $val = <DB>;
    CORE::close DB;
    
    my $decode = sub {my $s = shift; $s =~ s/%([0-9A-F]{2})/chr hex $1/ge; $s};
    my $now = $self->{now} || time;
    
    if ($val =~ s!^\#\?SuikaWikiCache/0.9[^\x02]*\x02!!s) {
      $self->{db_hash}->{$opt->{prop}} =
        {map {$decode->($_->[0]) => [$decode->($_->[1]), $_->[2]]}
         grep {$_->[2] + $self->{removes} > $now}
                                          map {[split /\x1F/, $_, 3]}
                                          split /\x1E/, $val};
    } elsif (length $val) {
      report SuikaWiki::DB::Util::Error
        -type => 'DB_UNSUPPORTED_FORMAT', file => $file,
        method => '__read_meta', -object => $self,
        prop => $opt->{prop};
    } else {  ## Blank file
      $self->{db_hash}->{$opt->{prop}} = {};
    }
  }
  $self->{prop_modified}->{$opt->{prop}} = 0;
}

sub ___close_prop ($$) {
  my ($self, $opt) = @_;
  local $Error::Depth = $Error::Depth + 1;
  unless ($self->{prop_modified}->{$opt->{prop}}) {
    report SuikaWiki::DB::Util::Error
      -type => 'INFO_DB_PROP_NOT_MODIFIED',
      -object => $self, method => '___close_prop',
      prop => $opt->{prop};
    return;
  }
  if ($self->{lock} and not $self->{lock}->locked) {
    $self->{lock}->lock
      or report SuikaWiki::DB::Util::Error
           -type => 'LOCK_START', method => '__write_meta',
           -object => $self, prop => $opt->{prop};
  }
  report SuikaWiki::DB::Util::Error 
    -type => 'DB_READ_ONLY', method => '___close_prop'
    -object => $self,
    if $self->{lock} and not $self->{lock}->writable;
  my $file = $opt->{prop};
  $file = $self->{directory}.$self->{prefix}.$self->__encode_base16 ($file)
         .$self->{suffix};
  
  my $encode = sub {my $s = $_[0]; $s =~ s/([\x00-\x1F%])/sprintf '%%%02X', ord $1/ge; $s};
  my $temp = $file.'.'.time.'.tmp';
  CORE::open FILE, '>', $temp
    or report SuikaWiki::DB::Util::Error
         -type => 'STOP_DB_PROP_CANT_SAVE', msg => $!,
         method => '___close_prop', file => $file,
         prop => $opt->{prop}, -object => $self;
  binmode FILE;
  print FILE "#?SuikaWikiCache/0.9\n\x02"
            .join "\x1E",
             map {
               my ($n, $v) = ($_, $self->{db_hash}->{$opt->{prop}}->{$_});
               $encode->($n)."\x1F".$encode->($v->[0])
                            ."\x1F".(0+$v->[1]);
             }
             keys %{$self->{db_hash}->{$opt->{prop}}};
  CORE::close FILE;
  if (-e $file) {
    unlink $file or report SuikaWiki::DB::Util::Error
                      -type => 'STOP_DB_PROP_CANT_SAVE', file => $file,
                      method => '___close_prop (unlink)',
                      msg => $!, prop => $opt->{prop},
                      -object => $self;
  }
  rename $temp => $file
    or report SuikaWiki::DB::Util::Error
         -type => 'STOP_DB_PROP_CANT_SAVE', file => $file,
         method => '___close_prop (rename)',
         msg => $!, prop => $opt->{prop},
         -object => $self;
  $self->{prop_modified}->{$opt->{prop}} = 0;
  report SuikaWiki::DB::Util::Error
    -type => 'INFO_DB_PROP_WROTE',
    -object => $self, method => '___close_prop',
    file => $file, prop => $opt->{prop};
  CORE::delete $self->{db_hash}->{$opt->{prop}};
}

sub __name2name ($$) {
  my ($self, $key) = @_;
  join $Sep, @$key;
}

sub __check_name ($$) {
  my ($self, $key) = @_;
  return 0 unless ref $key;
  for (@$key) {
    return 0 unless $_;  # '' or 0 or undef
#    return 0 if index ($_, $Sep) > -1;
#    return 0 if $_ eq $Self || $_ eq $Parent;
  }
  return 1;  
}

sub get ($$$) {
  my ($self, $prop, $key) = @_;
  unless ($self->{opened}->{$prop}) {
    local $Error::Depth = $Error::Depth + 1;
    $self->open_prop (prop => $prop);
  }
  my $v = $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
  if (ref $v and $v->[1] + $self->{expires} > ($self->{now} || time)) {
    return $v->[0];
  } else {
    return undef;
  }
}

sub set ($$$$) {
  my ($self, $prop, $key => $value) = @_;
  report SuikaWiki::DB::Util::Error 
    -type => 'KEY_INVALID_NAME',
    -object => $self, method => 'set',
    prop => $prop, key => $key
    unless $self->__check_name ($key);
  unless ($self->{opened}->{$prop}) {
    local $Error::Depth = $Error::Depth + 1;
    $self->open_prop (prop => $prop);
  }
  $self->{prop_modified}->{$prop} = 1;
  $self->{db_hash}->{$prop}->{ $self->__name2name ($key) }
    = [$value, $self->{now} || time];
}

sub exist ($$$) {
  my ($self, $prop, $key) = @_;
  return 0 unless $self->__check_name ($key);
  unless ($self->{opened}->{$prop}) {
    local $Error::Depth = $Error::Depth + 1;
    $self->open_prop (prop => $prop);
  }
  my $v = $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
  if (ref $v and $v->[1] + $self->{expires} > ($self->{now} || time)) {
    1;
  } else {
    0;
  }
}

sub delete ($$$) {
  my ($self, $prop, $key) = @_;
  unless ($self->{opened}->{$prop}) {
    local $Error::Depth = $Error::Depth + 1;
    $self->open_prop (prop => $prop);
  }
  $self->{prop_modified}->{$prop} = 1;
  CORE::delete $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
}

sub keys ($$;%) {
  my ($self, $prop, %opt) = @_;
  unless ($self->{opened}->{$prop}) {
    local $Error::Depth = $Error::Depth + 1;
    $self->open_prop (prop => $prop);
  }
  my $ns = $self->__name2name ($opt{ns}) . $Sep;
  my $ns_l = length $ns;
  my @result;
  my $now = $self->{now} || time;
  for (grep {ref $_ and $_->[1] + $self->{expires} > $now}
       CORE::keys %{$self->{db_hash}->{$prop}}) {
    ## Namespace matchs
    if (substr ($_, 0, $ns_l) eq $ns) {
      ## Child or grandchild in recursive mode
      if ($opt{recursive} || not (index ($_, $Sep) > -1)) {
        push @result, $_;
      }
    }
  }
  return map {[split /\Q$Sep\E/, $_]} @result;
}

# close: Inherited

# DESTROY: Inherited

=head1 METHODS

This module provides common interface of SuikaWiki WikiDatabase
modules. See C<SuikaWiki::DB>.

=head1 AUTHOR

Wakaba <[email protected]>.

=head1 LICENSE

Copyright 2004 Wakaba <[email protected]>.  All rights reserved.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1; # $Date: 2004/02/07 02:48:35 $
1	wakaba	1.1
2			=head1 NAME
3
4			SuikaWiki::DB::FileSystem::SuikaWikiCache09 - WikiDatabase interface to SuikaWikiCache/0.9 databases
5
6			=head1 DESCRIPTION
7
8			This module provides SuikaWiki WikiDatabase interface to SuikaWikiCache/0.9
9			format of database.
10
11			This module is part of SuikaWiki.
12
13			=cut
14
15			package SuikaWiki::DB::FileSystem::SuikaWikiCache09;
16			use strict;
17	wakaba	1.2	our $VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18	wakaba	1.1	require SuikaWiki::DB::Util;
19			push our @ISA, 'SuikaWiki::DB::Util::template';
20			my $Sep = '//';
21			my $Self = '.';
22			my $Parent = '..';
23
24			sub new ($%) {
25			my $self = shift->SUPER::new (@_);
26			my %opt = @_;
27			$self->{directory} = $opt{directory}
28			or report SuikaWiki::DB::Util::Error
29			-type => 'DB_METHOD_PARAMETER_REQUIRED',
30			-object => $self, method => 'new',
31			parameter => 'directory';
32			$self->{directory} .= '/' unless substr ($self->{directory}, -1, 1) eq '/';
33			$self->{prefix} = $opt{prefix} \|\| '.tmp.cache.';
34			$self->{suffix} = $opt{suffix} \|\| '.dat';
35			$self->{expires} = $opt{expires} \|\| 86400;
36			$self->{removes} = $opt{removes} \|\| 604800;
37			$self->{now} = $opt{now};
38			$self;
39			}
40
41			sub __encode_base16 ($$) {
42			my ($self, $s) = @_;
43			$s =~ s/(.)/sprintf '%02X', ord $1/ges;
44			$s;
45			}
46			sub __decode_base16 ($$) {
47			my ($self, $s) = @_;
48			$s =~ s/([0-9A-Fa-f]{2})/chr hex $1/ge;
49			$s;
50			}
51
52			sub ___open_prop ($$) {
53			my ($self, $opt) = @_;
54			local $Error::Depth = $Error::Depth + 1;
55			my $file = $self->{directory}
56			.$self->{prefix}
57			.$self->__encode_base16 ($opt->{prop})
58			.$self->{suffix};
59			unless (-e $file) {
60			$self->{db_hash}->{$opt->{prop}} = {};
61			} else {
62			CORE::open DB, '<', $file
63			or report SuikaWiki::DB::Util::Error
64			-type => 'STOP_DB_PROP_CANT_OPEN', file => $file,
65			msg => $!, prop => $opt->{prop},
66			-object => $self, method => '__read_meta';
67			binmode DB;
68			local $/ = undef;
69			my $val = <DB>;
70			CORE::close DB;
71
72			my $decode = sub {my $s = shift; $s =~ s/%([0-9A-F]{2})/chr hex $1/ge; $s};
73			my $now = $self->{now} \|\| time;
74
75			if ($val =~ s!^\#\?SuikaWikiCache/0.9[^\x02]*\x02!!s) {
76			$self->{db_hash}->{$opt->{prop}} =
77			{map {$decode->($_->[0]) => [$decode->($_->[1]), $_->[2]]}
78			grep {$_->[2] + $self->{removes} > $now}
79			map {[split /\x1F/, $_, 3]}
80			split /\x1E/, $val};
81			} elsif (length $val) {
82			report SuikaWiki::DB::Util::Error
83			-type => 'DB_UNSUPPORTED_FORMAT', file => $file,
84			method => '__read_meta', -object => $self,
85			prop => $opt->{prop};
86			} else { ## Blank file
87			$self->{db_hash}->{$opt->{prop}} = {};
88			}
89			}
90			$self->{prop_modified}->{$opt->{prop}} = 0;
91			}
92
93			sub ___close_prop ($$) {
94			my ($self, $opt) = @_;
95			local $Error::Depth = $Error::Depth + 1;
96			unless ($self->{prop_modified}->{$opt->{prop}}) {
97			report SuikaWiki::DB::Util::Error
98			-type => 'INFO_DB_PROP_NOT_MODIFIED',
99			-object => $self, method => '___close_prop',
100			prop => $opt->{prop};
101			return;
102			}
103			if ($self->{lock} and not $self->{lock}->locked) {
104			$self->{lock}->lock
105			or report SuikaWiki::DB::Util::Error
106			-type => 'LOCK_START', method => '__write_meta',
107			-object => $self, prop => $opt->{prop};
108			}
109			report SuikaWiki::DB::Util::Error
110			-type => 'DB_READ_ONLY', method => '___close_prop'
111			-object => $self,
112			if $self->{lock} and not $self->{lock}->writable;
113			my $file = $opt->{prop};
114			$file = $self->{directory}.$self->{prefix}.$self->__encode_base16 ($file)
115			.$self->{suffix};
116
117			my $encode = sub {my $s = $_[0]; $s =~ s/([\x00-\x1F%])/sprintf '%%%02X', ord $1/ge; $s};
118			my $temp = $file.'.'.time.'.tmp';
119			CORE::open FILE, '>', $temp
120			or report SuikaWiki::DB::Util::Error
121			-type => 'STOP_DB_PROP_CANT_SAVE', msg => $!,
122			method => '___close_prop', file => $file,
123			prop => $opt->{prop}, -object => $self;
124			binmode FILE;
125			print FILE "#?SuikaWikiCache/0.9\n\x02"
126			.join "\x1E",
127			map {
128			my ($n, $v) = ($_, $self->{db_hash}->{$opt->{prop}}->{$_});
129			$encode->($n)."\x1F".$encode->($v->[0])
130			."\x1F".(0+$v->[1]);
131			}
132			keys %{$self->{db_hash}->{$opt->{prop}}};
133			CORE::close FILE;
134			if (-e $file) {
135			unlink $file or report SuikaWiki::DB::Util::Error
136			-type => 'STOP_DB_PROP_CANT_SAVE', file => $file,
137			method => '___close_prop (unlink)',
138			msg => $!, prop => $opt->{prop},
139			-object => $self;
140			}
141			rename $temp => $file
142			or report SuikaWiki::DB::Util::Error
143			-type => 'STOP_DB_PROP_CANT_SAVE', file => $file,
144			method => '___close_prop (rename)',
145			msg => $!, prop => $opt->{prop},
146			-object => $self;
147			$self->{prop_modified}->{$opt->{prop}} = 0;
148			report SuikaWiki::DB::Util::Error
149			-type => 'INFO_DB_PROP_WROTE',
150			-object => $self, method => '___close_prop',
151			file => $file, prop => $opt->{prop};
152			CORE::delete $self->{db_hash}->{$opt->{prop}};
153			}
154
155			sub __name2name ($$) {
156			my ($self, $key) = @_;
157			join $Sep, @$key;
158			}
159
160			sub __check_name ($$) {
161			my ($self, $key) = @_;
162			return 0 unless ref $key;
163			for (@$key) {
164			return 0 unless $_; # '' or 0 or undef
165			# return 0 if index ($_, $Sep) > -1;
166			# return 0 if $_ eq $Self \|\| $_ eq $Parent;
167			}
168			return 1;
169			}
170
171			sub get ($$$) {
172			my ($self, $prop, $key) = @_;
173			unless ($self->{opened}->{$prop}) {
174			local $Error::Depth = $Error::Depth + 1;
175			$self->open_prop (prop => $prop);
176			}
177			my $v = $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
178			if (ref $v and $v->[1] + $self->{expires} > ($self->{now} \|\| time)) {
179			return $v->[0];
180			} else {
181			return undef;
182			}
183			}
184
185			sub set ($$$$) {
186			my ($self, $prop, $key => $value) = @_;
187			report SuikaWiki::DB::Util::Error
188			-type => 'KEY_INVALID_NAME',
189			-object => $self, method => 'set',
190			prop => $prop, key => $key
191			unless $self->__check_name ($key);
192			unless ($self->{opened}->{$prop}) {
193			local $Error::Depth = $Error::Depth + 1;
194			$self->open_prop (prop => $prop);
195			}
196			$self->{prop_modified}->{$prop} = 1;
197			$self->{db_hash}->{$prop}->{ $self->__name2name ($key) }
198			= [$value, $self->{now} \|\| time];
199			}
200
201			sub exist ($$$) {
202			my ($self, $prop, $key) = @_;
203			return 0 unless $self->__check_name ($key);
204			unless ($self->{opened}->{$prop}) {
205			local $Error::Depth = $Error::Depth + 1;
206			$self->open_prop (prop => $prop);
207			}
208	wakaba	1.2	my $v = $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
209			if (ref $v and $v->[1] + $self->{expires} > ($self->{now} \|\| time)) {
210			1;
211			} else {
212			0;
213			}
214	wakaba	1.1	}
215
216			sub delete ($$$) {
217			my ($self, $prop, $key) = @_;
218			unless ($self->{opened}->{$prop}) {
219			local $Error::Depth = $Error::Depth + 1;
220			$self->open_prop (prop => $prop);
221			}
222			$self->{prop_modified}->{$prop} = 1;
223			CORE::delete $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
224			}
225
226			sub keys ($$;%) {
227			my ($self, $prop, %opt) = @_;
228			unless ($self->{opened}->{$prop}) {
229			local $Error::Depth = $Error::Depth + 1;
230			$self->open_prop (prop => $prop);
231			}
232			my $ns = $self->__name2name ($opt{ns}) . $Sep;
233			my $ns_l = length $ns;
234			my @result;
235	wakaba	1.2	my $now = $self->{now} \|\| time;
236			for (grep {ref $_ and $_->[1] + $self->{expires} > $now}
237			CORE::keys %{$self->{db_hash}->{$prop}}) {
238	wakaba	1.1	## Namespace matchs
239			if (substr ($_, 0, $ns_l) eq $ns) {
240			## Child or grandchild in recursive mode
241			if ($opt{recursive} \|\| not (index ($_, $Sep) > -1)) {
242			push @result, $_;
243			}
244			}
245			}
246			return map {[split /\Q$Sep\E/, $_]} @result;
247			}
248
249			# close: Inherited
250
251			# DESTROY: Inherited
252
253			=head1 METHODS
254
255			This module provides common interface of SuikaWiki WikiDatabase
256			modules. See C<SuikaWiki::DB>.
257
258			=head1 AUTHOR
259
260			Wakaba <[email protected]>.
261
262			=head1 LICENSE
263
264			Copyright 2004 Wakaba <[email protected]>. All rights reserved.
265
266			This program is free software; you can redistribute it and/or
267			modify it under the same terms as Perl itself.
268
269			=cut
270
271	wakaba	1.2	1; # $Date: 2004/02/07 02:48:35 $