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