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
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	our $VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
28	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	## TODO: -recursive
57	## TODO: ghost (eg. prefix-nonbase16-suffix)
58	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	grep /^$self->{option}->{file_prefix_reg}/,
63	grep /$self->{option}->{file_suffix_reg}$/, keys %dir) {
64	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	grep /^$self->{option}->{directory_prefix_reg}/,
70	grep /$self->{option}->{directory_suffix_reg}$/, keys %dir) {
71	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	return "0 but true" unless -e $path;
118	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	for (qw/root_key auto_mkdir/) {
156	$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	1; # $Date: 2004/05/01 03:52:52 $