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