DB/FileSystem/SuikaWikiMetaInfo09.pm


=head1 NAME

SuikaWiki::DB::FileSystem::SuikaWikiMetaInfo09 --- SuikaWiki WikiDatabase: SuikaWikiMetaInfo/0.9 one-file meta properties database

=head1 DESCRIPTION

This module provides SuikaWiki WikiDatabase interface to SuikaWikiMetaInfo/0.9
format of database.  It can keep keys with multiple properties into
one file.  It is originally implemented as supplemental database of
Yuki::YukiWikiDBMeta.

This module is part of SuikaWiki.

=cut

package SuikaWiki::DB::FileSystem::SuikaWikiMetaInfo09;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require SuikaWiki::DB::Util;
my $Sep = '//';
my $Self = '.';
my $Parent = '..';

sub new ($%) {
  my ($class, %o) = @_;
  my $self = bless {}, $class;
  if ($o{-lock}) {
    $self->{lock} = SuikaWiki::DB::Util->new_lock ($o{-lock});
    #$self->{lock}->lock;
  }
  $self->{directory} = $o{directory};
  $self->{directory} .= '/' unless substr ($self->{directory}, -1, 1) eq '/';
  $self->{prefix} = $o{prefix} || 'mt--';
  $self->{suffix} = $o{suffix} || '.dat';
  $self->{db_hash} = {};
  $self;
}

sub __encode_base16 ($$) {
  my ($self, $s) = @_;
  $s =~ s/(.)/sprintf '%02X', ord $1/ges;
  $s;
}
sub __decode_base16 ($$) {
  my ($self, $s) = @_;
  $s =~ s/([0-9A-Fa-f]{2})/chr hex $1/ge;
  $s;
}

## Open database file
sub __read_meta ($$) {
  my ($self, $prop) = @_;
  if ($self->{lock} && !$self->{lock}->locked) {
    $self->{lock}->lock
      or throw SuikaWiki::DB::Util::Error
           type => 'LOCK_START', -method => '__read_meta';
  }
  my $file = $prop;
  $file = $self->{directory}.$self->{prefix}.$self->__encode_base16 ($file)
         .$self->{suffix};
  unless (-e $file) {
    $self->{db_hash} = {};
  } else {
    open DB, $file or throw SuikaWiki::DB::Util::Error
                        type => 'DB_OPEN', -file => $file,
                        -msg => $!, -method => '__read_meta';
    binmode DB;
    local $/ = undef;
    my $val = <DB>;
    close DB;
    
    if ($val =~ s!^\#\?SuikaWikiMetaInfo/0.9[^\x02]*\x02!!s) {
      $self->{db_hash}->{$prop} = {map {split /\x1F/, $_, 2} split /\x1E/, $val};
    } elsif (length $val) {
      throw SuikaWiki::DB::Util::Error
        type => 'DB_UNSUPPORTED_FORMAT', -file => $file,
        -method => '__read_meta';
    } else {  ## Blank file
      $self->{db_hash}->{$prop} = {};
    }
  }
  $self->{prop_modified}->{$prop} = 0;
}

sub __write_meta ($$) {
  my ($self, $prop) = @_;
  return unless $self->{prop_modified}->{$prop};
  if ($self->{lock} and not $self->{lock}->locked) {
    $self->{lock}->lock
      or throw SuikaWiki::DB::Util::Error
           type => 'LOCK_START', -method => '__write_meta';
  }
  throw SuikaWiki::DB::Util::Error 
    type => 'DB_READ_ONLY', -method => '__write_meta'
    if $self->{lock} and not $self->{lock}->writable;
  my $file = $prop;
  $file = $self->{directory}.$self->{prefix}.$self->__encode_base16 ($file)
         .$self->{suffix};
  
  my $temp = $file.'.'.time.'.tmp';
  open FILE, '>', $temp
    or throw SuikaWiki::DB::Util::Error
         type => 'DB_SAVE', -msg => $!,
         -method => '__write_meta', -file => $file;
  binmode FILE;
  print FILE "#?SuikaWikiMetaInfo/0.9\n\x02"
            .join "\x1E",
             map {
               my ($n, $v) = ($_, $self->{db_hash}->{$prop}->{$_});
               for ($n, $v) {s/([\x02\x1C-\x1F])/sprintf '\\x%02X', ord $1/ge}
               $n."\x1F".$v;
             }
             grep {length $self->{db_hash}->{$prop}->{$_}}
             keys %{$self->{db_hash}->{$prop}};
  close FILE;
  if (-e $file) {
    unlink $file or throw SuikaWiki::DB::Util::Error
                      type => 'DB_SAVE', -file => $file,
                      -method => '__write_meta (unlink)',
                      -msg => $!;
  }
  rename $temp => $file
    or throw SuikaWiki::DB::Util::Error
         type => 'DB_SAVE', -file => $file,
         -method => '__write_meta (rename)',
         -msg => $!;
  throw SuikaWiki::DB::Util::Error
    type => 'DB_WROTE', -method => '__write_meta',
    -file => $file, -prop => $prop;
  $self->{prop_modified}->{$prop} = 0;
}

sub __name2name ($$) {
  my ($self, $key) = @_;
  join '//', @$key;
}

sub __check_name ($$) {
  my ($self, $key) = @_;
  for (@$key) {
    return 0 unless $_;  # '' or 0 or undef
    return 0 if index ($_, $Sep) > -1;
    return 0 if $_ eq $Self || $_ eq $Parent;
  }
  return 1;  
}

sub get ($$$) {
  my ($self, $prop, $key) = @_;
  $self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
  $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
}

sub set ($$$$) {
  my ($self, $prop, $key => $value) = @_;
  throw SuikaWiki::DB::Util::Error type => 'KEY_INVALID_NAME', -key => $key
    unless $self->__check_name ($key);
  $self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
  $self->{db_hash}->{$prop}->{ $self->__name2name ($key) } = $value;
  $self->{prop_modified}->{$prop} = 1;
}

sub exist ($$$) {
  my ($self, $prop, $key) = @_;
  return 0 unless $self->__check_name ($key);
  $self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
  exist $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
}

sub delete ($$$) {
  my ($self, $prop, $key) = @_;
  $self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
  delete $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
  $self->{prop_modified}->{$prop} = 1;
}

sub keys ($$;%) {
  my ($self, $prop, %opt) = @_;
  $self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
  my $ns = $self->__name2name ($opt{ns}) . $Sep;
  my $ns_l = length $ns;
  my @result;
  for (keys %{$self->{db_hash}->{$prop}}) {
    ## Namespace matchs
    if (substr ($_, 0, $ns_l) eq $ns) {
      ## Child or grandchild in recursive mode
      if ($opt{recursive} || not (index ($_, $Sep) > -1)) {
        push @result, $_;
      }
    }
  }
  return map {[split /\Q$Sep\E/, $_]} @result;
}

sub close ($) {
  my $self = shift;
  for (keys %{$self->{db_hash}}) {
    $self->__write_meta ($_);
  }
  $self->{db_hash} = undef;
  $self->{lock}->unlock if $self->{lock};
  $self->{lock} = undef;
  throw SuikaWiki::DB::Util::Error type => 'DB_CLOSED', -method => 'close';
}
       
sub DESTROY ($) {
  my $self = shift;
  $self->close if $self->{db_hash};
  throw SuikaWiki::DB::Util::Error type => 'DB_DESTROY', -method => 'DESTROY';
}

=head1 METHODS

This module provides common interface of SuikaWiki WikiDatabase
modules. See C<SuikaWiki::DB>.

=head1 AUTHOR

Wakaba <[email protected]>.

=head1 LICENSE

Copyright 2003 Wakaba <[email protected]>

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1; # $Date: 2003/10/05 11:54:03 $
1	wakaba	1.1
2			=head1 NAME
3
4			SuikaWiki::DB::FileSystem::SuikaWikiMetaInfo09 --- SuikaWiki WikiDatabase: SuikaWikiMetaInfo/0.9 one-file meta properties database
5
6			=head1 DESCRIPTION
7
8			This module provides SuikaWiki WikiDatabase interface to SuikaWikiMetaInfo/0.9
9			format of database. It can keep keys with multiple properties into
10			one file. It is originally implemented as supplemental database of
11			Yuki::YukiWikiDBMeta.
12
13			This module is part of SuikaWiki.
14
15			=cut
16
17			package SuikaWiki::DB::FileSystem::SuikaWikiMetaInfo09;
18	wakaba	1.2	use strict;
19	wakaba	1.4	our $VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
20	wakaba	1.1	require SuikaWiki::DB::Util;
21			my $Sep = '//';
22			my $Self = '.';
23			my $Parent = '..';
24
25			sub new ($%) {
26			my ($class, %o) = @_;
27			my $self = bless {}, $class;
28			if ($o{-lock}) {
29	wakaba	1.3	$self->{lock} = SuikaWiki::DB::Util->new_lock ($o{-lock});
30			#$self->{lock}->lock;
31	wakaba	1.1	}
32			$self->{directory} = $o{directory};
33	wakaba	1.3	$self->{directory} .= '/' unless substr ($self->{directory}, -1, 1) eq '/';
34	wakaba	1.1	$self->{prefix} = $o{prefix} \|\| 'mt--';
35			$self->{suffix} = $o{suffix} \|\| '.dat';
36			$self->{db_hash} = {};
37			$self;
38			}
39
40			sub __encode_base16 ($$) {
41			my ($self, $s) = @_;
42	wakaba	1.3	$s =~ s/(.)/sprintf '%02X', ord $1/ges;
43	wakaba	1.1	$s;
44			}
45			sub __decode_base16 ($$) {
46			my ($self, $s) = @_;
47	wakaba	1.3	$s =~ s/([0-9A-Fa-f]{2})/chr hex $1/ge;
48	wakaba	1.1	$s;
49			}
50
51			## Open database file
52			sub __read_meta ($$) {
53			my ($self, $prop) = @_;
54	wakaba	1.3	if ($self->{lock} && !$self->{lock}->locked) {
55			$self->{lock}->lock
56	wakaba	1.4	or throw SuikaWiki::DB::Util::Error
57			type => 'LOCK_START', -method => '__read_meta';
58	wakaba	1.3	}
59	wakaba	1.1	my $file = $prop;
60			$file = $self->{directory}.$self->{prefix}.$self->__encode_base16 ($file)
61			.$self->{suffix};
62			unless (-e $file) {
63			$self->{db_hash} = {};
64			} else {
65	wakaba	1.4	open DB, $file or throw SuikaWiki::DB::Util::Error
66			type => 'DB_OPEN', -file => $file,
67			-msg => $!, -method => '__read_meta';
68	wakaba	1.1	binmode DB;
69			local $/ = undef;
70			my $val = <DB>;
71			close DB;
72
73			if ($val =~ s!^\#\?SuikaWikiMetaInfo/0.9[^\x02]*\x02!!s) {
74			$self->{db_hash}->{$prop} = {map {split /\x1F/, $_, 2} split /\x1E/, $val};
75			} elsif (length $val) {
76	wakaba	1.4	throw SuikaWiki::DB::Util::Error
77			type => 'DB_UNSUPPORTED_FORMAT', -file => $file,
78			-method => '__read_meta';
79	wakaba	1.1	} else { ## Blank file
80			$self->{db_hash}->{$prop} = {};
81			}
82			}
83			$self->{prop_modified}->{$prop} = 0;
84			}
85
86			sub __write_meta ($$) {
87			my ($self, $prop) = @_;
88			return unless $self->{prop_modified}->{$prop};
89	wakaba	1.4	if ($self->{lock} and not $self->{lock}->locked) {
90	wakaba	1.3	$self->{lock}->lock
91	wakaba	1.4	or throw SuikaWiki::DB::Util::Error
92			type => 'LOCK_START', -method => '__write_meta';
93	wakaba	1.3	}
94	wakaba	1.4	throw SuikaWiki::DB::Util::Error
95			type => 'DB_READ_ONLY', -method => '__write_meta'
96			if $self->{lock} and not $self->{lock}->writable;
97	wakaba	1.1	my $file = $prop;
98			$file = $self->{directory}.$self->{prefix}.$self->__encode_base16 ($file)
99			.$self->{suffix};
100
101			my $temp = $file.'.'.time.'.tmp';
102			open FILE, '>', $temp
103	wakaba	1.4	or throw SuikaWiki::DB::Util::Error
104			type => 'DB_SAVE', -msg => $!,
105			-method => '__write_meta', -file => $file;
106	wakaba	1.1	binmode FILE;
107			print FILE "#?SuikaWikiMetaInfo/0.9\n\x02"
108			.join "\x1E",
109			map {
110			my ($n, $v) = ($_, $self->{db_hash}->{$prop}->{$_});
111			for ($n, $v) {s/([\x02\x1C-\x1F])/sprintf '\\x%02X', ord $1/ge}
112			$n."\x1F".$v;
113			}
114			grep {length $self->{db_hash}->{$prop}->{$_}}
115			keys %{$self->{db_hash}->{$prop}};
116			close FILE;
117			if (-e $file) {
118	wakaba	1.4	unlink $file or throw SuikaWiki::DB::Util::Error
119			type => 'DB_SAVE', -file => $file,
120			-method => '__write_meta (unlink)',
121			-msg => $!;
122	wakaba	1.1	}
123			rename $temp => $file
124	wakaba	1.4	or throw SuikaWiki::DB::Util::Error
125			type => 'DB_SAVE', -file => $file,
126			-method => '__write_meta (rename)',
127			-msg => $!;
128			throw SuikaWiki::DB::Util::Error
129			type => 'DB_WROTE', -method => '__write_meta',
130			-file => $file, -prop => $prop;
131	wakaba	1.1	$self->{prop_modified}->{$prop} = 0;
132			}
133
134			sub __name2name ($$) {
135			my ($self, $key) = @_;
136			join '//', @$key;
137			}
138
139			sub __check_name ($$) {
140			my ($self, $key) = @_;
141			for (@$key) {
142			return 0 unless $_; # '' or 0 or undef
143			return 0 if index ($_, $Sep) > -1;
144			return 0 if $_ eq $Self \|\| $_ eq $Parent;
145			}
146			return 1;
147			}
148
149			sub get ($$$) {
150			my ($self, $prop, $key) = @_;
151			$self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
152			$self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
153			}
154
155			sub set ($$$$) {
156			my ($self, $prop, $key => $value) = @_;
157	wakaba	1.4	throw SuikaWiki::DB::Util::Error type => 'KEY_INVALID_NAME', -key => $key
158	wakaba	1.1	unless $self->__check_name ($key);
159			$self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
160			$self->{db_hash}->{$prop}->{ $self->__name2name ($key) } = $value;
161			$self->{prop_modified}->{$prop} = 1;
162			}
163
164			sub exist ($$$) {
165			my ($self, $prop, $key) = @_;
166			return 0 unless $self->__check_name ($key);
167			$self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
168			exist $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
169			}
170
171			sub delete ($$$) {
172			my ($self, $prop, $key) = @_;
173			$self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
174			delete $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
175			$self->{prop_modified}->{$prop} = 1;
176			}
177
178			sub keys ($$;%) {
179			my ($self, $prop, %opt) = @_;
180			$self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
181	wakaba	1.2	my $ns = $self->__name2name ($opt{ns}) . $Sep;
182	wakaba	1.1	my $ns_l = length $ns;
183			my @result;
184			for (keys %{$self->{db_hash}->{$prop}}) {
185	wakaba	1.4	## Namespace matchs
186	wakaba	1.1	if (substr ($_, 0, $ns_l) eq $ns) {
187			## Child or grandchild in recursive mode
188			if ($opt{recursive} \|\| not (index ($_, $Sep) > -1)) {
189			push @result, $_;
190			}
191			}
192			}
193			return map {[split /\Q$Sep\E/, $_]} @result;
194			}
195
196			sub close ($) {
197			my $self = shift;
198			for (keys %{$self->{db_hash}}) {
199			$self->__write_meta ($_);
200			}
201			$self->{db_hash} = undef;
202	wakaba	1.3	$self->{lock}->unlock if $self->{lock};
203			$self->{lock} = undef;
204	wakaba	1.4	throw SuikaWiki::DB::Util::Error type => 'DB_CLOSED', -method => 'close';
205	wakaba	1.1	}
206	wakaba	1.3
207	wakaba	1.1	sub DESTROY ($) {
208			my $self = shift;
209			$self->close if $self->{db_hash};
210	wakaba	1.4	throw SuikaWiki::DB::Util::Error type => 'DB_DESTROY', -method => 'DESTROY';
211	wakaba	1.1	}
212
213			=head1 METHODS
214
215			This module provides common interface of SuikaWiki WikiDatabase
216			modules. See C<SuikaWiki::DB>.
217
218			=head1 AUTHOR
219
220			Wakaba <[email protected]>.
221
222			=head1 LICENSE
223
224			Copyright 2003 Wakaba <[email protected]>
225
226			This program is free software; you can redistribute it and/or
227			modify it under the same terms as Perl itself.
228
229			=cut
230
231	wakaba	1.4	1; # $Date: 2003/10/05 11:54:03 $