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.4 $=~/\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;

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