DB/FileSystem/Base.pm


=head1 NAME

SuikaWiki::DB::FileSystem::Base

=head1 SYNOPSIS

  package Example::WikiDBModule;
  push our @ISA, 'SuikaWiki::DB::FileSystem::Base';

  sub ... {
    
  }
  
  ...

=head1 DESCRIPTION


This module is part of SuikaWiki.

=cut

package SuikaWiki::DB::FileSystem::Base;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require SuikaWiki::DB::Util;
push our @ISA, 'SuikaWiki::DB::Util::template';
require File::Spec;
require IO::Dir;
use File::Path;

sub ___open_prop ($$) {
  shift->{opened} ? "0 but true" : 0;
}
sub ___close_prop ($$) {
  "0 but true";
}

sub keys ($$%) {
  my ($self, $prop, %opt) = @_;
  report SuikaWiki::DB::Util::Error
    -type => 'KEY_INVALID_NS_NAME', key => $opt{-ns},
    -object => $self, method => 'keys'
    unless $opt{no_key_check} or
           $self->__check_key (key => $opt{-ns} ||= [], allow_empty => 1);

  unless ($self->{opened}->{$prop}) {
    local $Error::Depth = $Error::Depth + 1;
    $self->open_prop (prop => $prop);
  }

  my @result;
  
  my $dir = $self->__key2dirpath (key => $opt{-ns});
  tie my %dir, 'IO::Dir', $dir;
  if (($opt{-type} ||= 'key') eq 'key') {
    for (grep -f File::Spec->rel2abs ($_, $dir),
         grep /^$self->{option}->{file_prefix}/,
         grep /$self->{option}->{file_suffix}$/, keys %dir) {
      my $keyname = $self->__filename2keyname (filename => $_);
      push @result, [@{$opt{-ns}}, $keyname] if length $keyname;
    }
  } else {
    for (grep -d File::Spec->rel2abs ($_, $dir),
         grep /^$self->{option}->{directory_prefix}/,
         grep /$self->{option}->{directory_suffix}$/, keys %dir) {
      my $keyname = $self->__dirname2keyns (dirname => $_);
      push @result, [@{$opt{-ns}}, $keyname] if length $keyname;
    }
  }
  
  @result;
}

sub exist ($$$%) {
  my ($self, $prop, $key, %opt) = @_;

  unless ($self->{opened}->{$prop}) {
    local $Error::Depth = $Error::Depth + 1;
    $self->open_prop (prop => $prop);
  }

  return 0 unless $opt{no_key_check} or $self->__check_key (key => $key);

  if (($opt{-type} ||= 'key') eq 'key') {
    my $path = $self->__key2filepath (key => $key);
    return -f $path;
  } else {
    my $path = $self->__key2dirpath (key => $key);
    return -d $path;
  }
}

sub delete ($$%) {
  my ($self, $prop, $key, %opt) = @_;
  report SuikaWiki::DB::Util::Error
    -type => 'KEY_INVALID_NAME', key => $key,
    -object => $self, method => 'delete'
    unless $opt{no_key_check} or
           $self->__check_key (key => $key);

  if ($self->{lock} and not $self->{lock}->writable) {
    report SuikaWiki::DB::Util::Error
      -type => 'KEY_SAVE_LOCKED', 
      -object => $self, method => 'delete',
      key => $key,
      prop => $prop;
    return 0;
  }

  if (($opt{-type} ||= 'key') eq 'key') {
    my $path = $self->__key2filepath (key => $key);
    return "0 but true" unless -e $path;
    unlink $path or
      report SuikaWiki::DB::Util::Error
        -type => 'FILE_REMOVE_FAILURE',
        -object => $self, method => 'delete',
        key => $key,
        file => $path,
        msg => $!;
    return 1;
  } else {
    report SuikaWiki::DB::Util::Error
      -type => 'DB_METHOD_NOT_IMPLEMENTED',
      method => 'delete',
      -object => $self;
    return 0;
  }
}

=head1 INTERNAL METHODS

This module provides some internal methods that might be useful
in other WikiDatabase module which is derived from this base module.

Derived modules are able to override these methods as long as
method input and output interface is kept.

=cut

sub ___init ($%) {
  my ($self, %opt) = @_;
  for (qw/base_directory root_file/) {
    $self->{option}->{$_} = defined $opt{$_} ? $opt{$_} : '';
  }
  for (qw/directory_prefix directory_suffix file_prefix file_suffix/) {
    $self->{option}->{$_} = defined $opt{$_} ? $opt{$_} : '';
    $self->{option}->{$_.'_reg'} = defined $opt{$_.'_reg'} ? $opt{$_.'_reg'} :
                                  qr/\Q$self->{option}->{$_}\E/;
  }
  for (qw/root_key auto_mkdir/) {
    $self->{option}->{$_} = $opt{$_};
  }
}

=item 1/0 = $db->__check_key (key => $key)

Check whether given key is valid or not.

=cut

sub __check_key ($%) {
  my ($self, %opt) = @_;
  return 0 unless ref $opt{key};
  if (@{$opt{key}} == 0) {
    return 1 if $opt{allow_empty};
    return 1 if defined $self->{option}->{root_file} or
                $self->{option}->{root_key};
    return 0;
  }
  for (@{$opt{key}}) {
    return 0 unless defined $_ and length $_;  # '' or 0 or undef
  }
  return 1;
}

=item $path = $db->__key2filepath (key => $key)

Converts key into file name path.  This internal method does not
check whether key is valid or not.

=cut

sub __key2filepath ($%) {
  my ($self, %opt) = @_;
  if (@{$opt{key}} != 0) {
    File::Spec->catfile (
      $self->{option}->{base_directory},
      (map {$self->__keyns2dirname (keyns => $_)}
           @{$opt{key}}[0..$#{$opt{key}}-1]),
      $self->__keyname2filename (keyname => $opt{key}->[-1]),
    );
  } else {
    if ($self->{option}->{root_key}) {
      File::Spec->catfile (
        $self->{option}->{base_directory},
        (map {$self->__keyns2dirname (keyns => $_)}
             @{$self->{option}->{root_key}}[0..$#{$self->{option}->{root_key}}-1]),
        $self->__keyname2filename (keyname => $self->{option}->{root_key}->[-1]),
      );
    } else {
      File::Spec->rel2abs ($self->{option}->{root_file},
                           $self->{option}->{base_directory});
    }
  }
}

=item $path = $db->__key2dirpath (key => $key)

Converts key (assumed as key namespace) into directory name path.  
This internal method does not check whether key is valid or not.

=cut

sub __key2dirpath ($%) {
  my ($self, %opt) = @_;
  my $key = $opt{key} || [@{$opt{fullkey}}[0..$#{$opt{fullkey}}-1]];
  File::Spec->catdir (
    $self->{option}->{base_directory},
    (map {$self->__keyns2dirname (keyns => $_)} @$key),
  );
}

=item $dirname = $db->__keyns2dirname (keyns => $keyns)

Converts key namespace (a component in key other than last one) into
directory component name.

=cut

sub __keyns2dirname ($%) {
  my ($self, %opt) = @_;
  $self->{option}->{directory_prefix} .
  $self->__encode_base16 ($opt{keyns}) .
  $self->{option}->{directory_suffix};
}

=item $keyns = $db->__dirname2keyns (dirname => $dirname)

Converts directory component name into key namespace component name.
Note that directory name is not validated before converted
(ie. directory name that does not match to
C<I<prefix>I<base16ed-keyns>I<suffix>> will not raise error).

=cut

sub __dirname2keyns ($%) {
  my ($self, %opt) = @_;
  my $s = $opt{dirname};
  $s =~ s/^$self->{option}->{directory_prefix_reg}//;
  $s =~ s/$self->{option}->{directory_suffix_reg}$//;
  $self->__decode_base16 ($s);
}

=item $filename = $db->__keyname2filename (keyname => $keyname)

Converts key name (last component in key) into file name 
(not including directory path).

=cut

sub __keyname2filename ($%) {
  my ($self, %opt) = @_;
  $self->{option}->{file_prefix} .
  $self->__encode_base16 ($opt{keyname}) .
  $self->{option}->{file_suffix};
}

=item $keyname = $db->__filename2keyname (filename => $filename)

Converts file name into key name.
Note that file name is not validated before converted
(ie. file name that does not match to
C<I<prefix>I<base16ed-keyname>I<suffix>> will not raise error).

=cut

sub __filename2keyname ($%) {
  my ($self, %opt) = @_;
  my $s = $opt{filename};
  $s =~ s/^$self->{option}->{file_prefix_reg}//;
  $s =~ s/$self->{option}->{file_suffix_reg}$//;
  $self->__decode_base16 ($s);
}

=item $base16 = $db->__encode_base16 ($string)

Encodes C<$string> in base 16.

=cut

sub __encode_base16 ($$) {
  my (undef, $s) = @_;
## TODO: utf8 support
  $s =~ s/(.)/sprintf '%02X', ord $1/ges;
  $s;
}

=item $string = $db->__decode_base16 ($base16)

Decodes C<$base16> which is encoded in base 16.

=cut

sub __decode_base16 ($$) {
  my (undef, $s) = @_;
  $s =~ s/([0-9A-Fa-f][0-9A-Fa-f])/pack 'C', hex $1/ge;
## TODO: utf8 support
  $s;
}

sub __make_directory ($%) {
  my ($self, %opt) = @_;
  return "0 but true" if -d $opt{directory};
  eval {
    mkpath $opt{directory}, 0, $opt{directory_permission};
    1;
  } or do {
    local $Error::Depth = $Error::Depth + 1;
    report SuikaWiki::DB::Util::Error
      -type => 'DIR_MAKE_FAILURE',
      -object => $self, method => '__make_directory',
      dir => $opt{directory},
      msg => $@;
    0;
  };
}

=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/04/17 04:15:39 $
1	wakaba	1.1
2			=head1 NAME
3
4			SuikaWiki::DB::FileSystem::Base
5
6			=head1 SYNOPSIS
7
8			package Example::WikiDBModule;
9			push our @ISA, 'SuikaWiki::DB::FileSystem::Base';
10
11			sub ... {
12
13			}
14
15			...
16
17			=head1 DESCRIPTION
18
19
20
21			This module is part of SuikaWiki.
22
23			=cut
24
25			package SuikaWiki::DB::FileSystem::Base;
26			use strict;
27	wakaba	1.3	our $VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
28	wakaba	1.1	require SuikaWiki::DB::Util;
29			push our @ISA, 'SuikaWiki::DB::Util::template';
30			require File::Spec;
31			require IO::Dir;
32			use File::Path;
33
34			sub ___open_prop ($$) {
35			shift->{opened} ? "0 but true" : 0;
36			}
37			sub ___close_prop ($$) {
38			"0 but true";
39			}
40
41			sub keys ($$%) {
42			my ($self, $prop, %opt) = @_;
43			report SuikaWiki::DB::Util::Error
44			-type => 'KEY_INVALID_NS_NAME', key => $opt{-ns},
45			-object => $self, method => 'keys'
46			unless $opt{no_key_check} or
47			$self->__check_key (key => $opt{-ns} \|\|= [], allow_empty => 1);
48
49			unless ($self->{opened}->{$prop}) {
50			local $Error::Depth = $Error::Depth + 1;
51			$self->open_prop (prop => $prop);
52			}
53
54			my @result;
55
56			my $dir = $self->__key2dirpath (key => $opt{-ns});
57			tie my %dir, 'IO::Dir', $dir;
58			if (($opt{-type} \|\|= 'key') eq 'key') {
59			for (grep -f File::Spec->rel2abs ($_, $dir),
60			grep /^$self->{option}->{file_prefix}/,
61			grep /$self->{option}->{file_suffix}$/, keys %dir) {
62			my $keyname = $self->__filename2keyname (filename => $_);
63			push @result, [@{$opt{-ns}}, $keyname] if length $keyname;
64			}
65			} else {
66			for (grep -d File::Spec->rel2abs ($_, $dir),
67			grep /^$self->{option}->{directory_prefix}/,
68			grep /$self->{option}->{directory_suffix}$/, keys %dir) {
69			my $keyname = $self->__dirname2keyns (dirname => $_);
70			push @result, [@{$opt{-ns}}, $keyname] if length $keyname;
71			}
72			}
73
74			@result;
75			}
76
77			sub exist ($$$%) {
78			my ($self, $prop, $key, %opt) = @_;
79
80			unless ($self->{opened}->{$prop}) {
81			local $Error::Depth = $Error::Depth + 1;
82			$self->open_prop (prop => $prop);
83			}
84
85			return 0 unless $opt{no_key_check} or $self->__check_key (key => $key);
86
87			if (($opt{-type} \|\|= 'key') eq 'key') {
88			my $path = $self->__key2filepath (key => $key);
89			return -f $path;
90			} else {
91			my $path = $self->__key2dirpath (key => $key);
92			return -d $path;
93			}
94			}
95
96			sub delete ($$%) {
97			my ($self, $prop, $key, %opt) = @_;
98			report SuikaWiki::DB::Util::Error
99			-type => 'KEY_INVALID_NAME', key => $key,
100			-object => $self, method => 'delete'
101			unless $opt{no_key_check} or
102			$self->__check_key (key => $key);
103
104			if ($self->{lock} and not $self->{lock}->writable) {
105			report SuikaWiki::DB::Util::Error
106			-type => 'KEY_SAVE_LOCKED',
107			-object => $self, method => 'delete',
108			key => $key,
109			prop => $prop;
110			return 0;
111			}
112
113			if (($opt{-type} \|\|= 'key') eq 'key') {
114			my $path = $self->__key2filepath (key => $key);
115	wakaba	1.3	return "0 but true" unless -e $path;
116	wakaba	1.1	unlink $path or
117			report SuikaWiki::DB::Util::Error
118			-type => 'FILE_REMOVE_FAILURE',
119			-object => $self, method => 'delete',
120			key => $key,
121			file => $path,
122			msg => $!;
123			return 1;
124			} else {
125			report SuikaWiki::DB::Util::Error
126			-type => 'DB_METHOD_NOT_IMPLEMENTED',
127			method => 'delete',
128			-object => $self;
129			return 0;
130			}
131			}
132
133			=head1 INTERNAL METHODS
134
135			This module provides some internal methods that might be useful
136			in other WikiDatabase module which is derived from this base module.
137
138			Derived modules are able to override these methods as long as
139			method input and output interface is kept.
140
141			=cut
142
143			sub ___init ($%) {
144			my ($self, %opt) = @_;
145			for (qw/base_directory root_file/) {
146			$self->{option}->{$_} = defined $opt{$_} ? $opt{$_} : '';
147			}
148			for (qw/directory_prefix directory_suffix file_prefix file_suffix/) {
149			$self->{option}->{$_} = defined $opt{$_} ? $opt{$_} : '';
150			$self->{option}->{$_.'_reg'} = defined $opt{$_.'_reg'} ? $opt{$_.'_reg'} :
151			qr/\Q$self->{option}->{$_}\E/;
152			}
153	wakaba	1.2	for (qw/root_key auto_mkdir/) {
154	wakaba	1.1	$self->{option}->{$_} = $opt{$_};
155			}
156			}
157
158			=item 1/0 = $db->__check_key (key => $key)
159
160			Check whether given key is valid or not.
161
162			=cut
163
164			sub __check_key ($%) {
165			my ($self, %opt) = @_;
166			return 0 unless ref $opt{key};
167			if (@{$opt{key}} == 0) {
168			return 1 if $opt{allow_empty};
169			return 1 if defined $self->{option}->{root_file} or
170			$self->{option}->{root_key};
171			return 0;
172			}
173			for (@{$opt{key}}) {
174			return 0 unless defined $_ and length $_; # '' or 0 or undef
175			}
176			return 1;
177			}
178
179			=item $path = $db->__key2filepath (key => $key)
180
181			Converts key into file name path. This internal method does not
182			check whether key is valid or not.
183
184			=cut
185
186			sub __key2filepath ($%) {
187			my ($self, %opt) = @_;
188			if (@{$opt{key}} != 0) {
189			File::Spec->catfile (
190			$self->{option}->{base_directory},
191			(map {$self->__keyns2dirname (keyns => $_)}
192			@{$opt{key}}[0..$#{$opt{key}}-1]),
193			$self->__keyname2filename (keyname => $opt{key}->[-1]),
194			);
195			} else {
196			if ($self->{option}->{root_key}) {
197			File::Spec->catfile (
198			$self->{option}->{base_directory},
199			(map {$self->__keyns2dirname (keyns => $_)}
200			@{$self->{option}->{root_key}}[0..$#{$self->{option}->{root_key}}-1]),
201			$self->__keyname2filename (keyname => $self->{option}->{root_key}->[-1]),
202			);
203			} else {
204			File::Spec->rel2abs ($self->{option}->{root_file},
205			$self->{option}->{base_directory});
206			}
207			}
208			}
209
210			=item $path = $db->__key2dirpath (key => $key)
211
212			Converts key (assumed as key namespace) into directory name path.
213			This internal method does not check whether key is valid or not.
214
215			=cut
216
217			sub __key2dirpath ($%) {
218			my ($self, %opt) = @_;
219			my $key = $opt{key} \|\| [@{$opt{fullkey}}[0..$#{$opt{fullkey}}-1]];
220			File::Spec->catdir (
221			$self->{option}->{base_directory},
222			(map {$self->__keyns2dirname (keyns => $_)} @$key),
223			);
224			}
225
226			=item $dirname = $db->__keyns2dirname (keyns => $keyns)
227
228			Converts key namespace (a component in key other than last one) into
229			directory component name.
230
231			=cut
232
233			sub __keyns2dirname ($%) {
234			my ($self, %opt) = @_;
235			$self->{option}->{directory_prefix} .
236			$self->__encode_base16 ($opt{keyns}) .
237			$self->{option}->{directory_suffix};
238			}
239
240			=item $keyns = $db->__dirname2keyns (dirname => $dirname)
241
242			Converts directory component name into key namespace component name.
243			Note that directory name is not validated before converted
244			(ie. directory name that does not match to
245			C<I<prefix>I<base16ed-keyns>I<suffix>> will not raise error).
246
247			=cut
248
249			sub __dirname2keyns ($%) {
250			my ($self, %opt) = @_;
251			my $s = $opt{dirname};
252			$s =~ s/^$self->{option}->{directory_prefix_reg}//;
253			$s =~ s/$self->{option}->{directory_suffix_reg}$//;
254			$self->__decode_base16 ($s);
255			}
256
257			=item $filename = $db->__keyname2filename (keyname => $keyname)
258
259			Converts key name (last component in key) into file name
260			(not including directory path).
261
262			=cut
263
264			sub __keyname2filename ($%) {
265			my ($self, %opt) = @_;
266			$self->{option}->{file_prefix} .
267			$self->__encode_base16 ($opt{keyname}) .
268			$self->{option}->{file_suffix};
269			}
270
271			=item $keyname = $db->__filename2keyname (filename => $filename)
272
273			Converts file name into key name.
274			Note that file name is not validated before converted
275			(ie. file name that does not match to
276			C<I<prefix>I<base16ed-keyname>I<suffix>> will not raise error).
277
278			=cut
279
280			sub __filename2keyname ($%) {
281			my ($self, %opt) = @_;
282			my $s = $opt{filename};
283			$s =~ s/^$self->{option}->{file_prefix_reg}//;
284			$s =~ s/$self->{option}->{file_suffix_reg}$//;
285			$self->__decode_base16 ($s);
286			}
287
288			=item $base16 = $db->__encode_base16 ($string)
289
290			Encodes C<$string> in base 16.
291
292			=cut
293
294			sub __encode_base16 ($$) {
295			my (undef, $s) = @_;
296			## TODO: utf8 support
297			$s =~ s/(.)/sprintf '%02X', ord $1/ges;
298			$s;
299			}
300
301			=item $string = $db->__decode_base16 ($base16)
302
303			Decodes C<$base16> which is encoded in base 16.
304
305			=cut
306
307			sub __decode_base16 ($$) {
308			my (undef, $s) = @_;
309			$s =~ s/([0-9A-Fa-f][0-9A-Fa-f])/pack 'C', hex $1/ge;
310			## TODO: utf8 support
311			$s;
312			}
313
314			sub __make_directory ($%) {
315			my ($self, %opt) = @_;
316			return "0 but true" if -d $opt{directory};
317			eval {
318			mkpath $opt{directory}, 0, $opt{directory_permission};
319			1;
320			} or do {
321			local $Error::Depth = $Error::Depth + 1;
322			report SuikaWiki::DB::Util::Error
323			-type => 'DIR_MAKE_FAILURE',
324			-object => $self, method => '__make_directory',
325			dir => $opt{directory},
326			msg => $@;
327			0;
328			};
329			}
330
331			=head1 LICENSE
332
333			Copyright 2004 Wakaba <[email protected]>. All rights reserved.
334
335			This program is free software; you can redistribute it and/or
336			modify it under the same terms as Perl itself.
337
338			=cut
339
340	wakaba	1.3	1; # $Date: 2004/04/17 04:15:39 $