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.10 $=~/\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 ($self->{-lock});
    $self->{lock}->lock;
  }
  $self->{error} = SuikaWiki::DB::Util->error_handler;
  $self->{directory} = $o{directory};
  $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/gs;
  $s;
}
sub __decode_base16 ($$) {
  my ($self, $s) = @_;
  $s =~ s/([0-9A-Fa-f]{2})/chr hex $1/g;
  $s;
}

## Open database file
sub __read_meta ($$) {
  my ($self, $prop) = @_;
  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 $self->{error}->raise (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) {
      $self->{error}->raise (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};
  $self->{error}->raise (type => 'DB_READ_ONLY', method => '__write_meta')
    unless $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 $self->{error}->raise (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 $self->{error}->raise (type => 'DB_SAVE', file => $file,
                                           method => '__write_meta (unlink)',
                                           msg => $!);
  }
  rename $temp => $file
    or $self->{error}->raise (type => 'DB_SAVE', file => $file,
                              method => '__write_meta (rename)',
                              msg => $!);
  $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) = @_;
  $self->{error}->raise (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 is match
    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;
}
           
sub DESTROY ($) {
  my $self = shift;
  $self->close if $self->{db_hash};
}

=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/08/06 01:26:14 $
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			our $VERSION=do{my @r=(q$Revision: 1.10 $=~/\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			$self->{lock} = SuikaWiki::DB::Util->new_lock ($self->{-lock});
30			$self->{lock}->lock;
31			}
32			$self->{error} = SuikaWiki::DB::Util->error_handler;
33			$self->{directory} = $o{directory};
34			$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			$s =~ s/(.)/sprintf '%02X', ord $1/gs;
43			$s;
44			}
45			sub __decode_base16 ($$) {
46			my ($self, $s) = @_;
47			$s =~ s/([0-9A-Fa-f]{2})/chr hex $1/g;
48			$s;
49			}
50
51			## Open database file
52			sub __read_meta ($$) {
53			my ($self, $prop) = @_;
54			my $file = $prop;
55			$file = $self->{directory}.$self->{prefix}.$self->__encode_base16 ($file)
56			.$self->{suffix};
57			unless (-e $file) {
58			$self->{db_hash} = {};
59			} else {
60			open DB, $file or $self->{error}->raise (type => 'DB_OPEN', file => $file,
61			msg => $!, method => '__read_meta');
62			binmode DB;
63			local $/ = undef;
64			my $val = <DB>;
65			close DB;
66
67			if ($val =~ s!^\#\?SuikaWikiMetaInfo/0.9[^\x02]*\x02!!s) {
68			$self->{db_hash}->{$prop} = {map {split /\x1F/, $_, 2} split /\x1E/, $val};
69			} elsif (length $val) {
70			$self->{error}->raise (type => 'DB_UNSUPPORTED_FORMAT', file => $file,
71			method => '__read_meta');
72			} else { ## Blank file
73			$self->{db_hash}->{$prop} = {};
74			}
75			}
76			$self->{prop_modified}->{$prop} = 0;
77			}
78
79			sub __write_meta ($$) {
80			my ($self, $prop) = @_;
81			return unless $self->{prop_modified}->{$prop};
82			$self->{error}->raise (type => 'DB_READ_ONLY', method => '__write_meta')
83			unless $self->{lock}->writable;
84			my $file = $prop;
85			$file = $self->{directory}.$self->{prefix}.$self->__encode_base16 ($file)
86			.$self->{suffix};
87
88			my $temp = $file.'.'.time.'.tmp';
89			open FILE, '>', $temp
90			or $self->{error}->raise (type => 'DB_SAVE', msg => $!,
91			method => '__write_meta', file => $file);
92			binmode FILE;
93			print FILE "#?SuikaWikiMetaInfo/0.9\n\x02"
94			.join "\x1E",
95			map {
96			my ($n, $v) = ($_, $self->{db_hash}->{$prop}->{$_});
97			for ($n, $v) {s/([\x02\x1C-\x1F])/sprintf '\\x%02X', ord $1/ge}
98			$n."\x1F".$v;
99			}
100			grep {length $self->{db_hash}->{$prop}->{$_}}
101			keys %{$self->{db_hash}->{$prop}};
102			close FILE;
103			if (-e $file) {
104			unlink $file or $self->{error}->raise (type => 'DB_SAVE', file => $file,
105			method => '__write_meta (unlink)',
106			msg => $!);
107			}
108			rename $temp => $file
109			or $self->{error}->raise (type => 'DB_SAVE', file => $file,
110			method => '__write_meta (rename)',
111			msg => $!);
112			$self->{prop_modified}->{$prop} = 0;
113			}
114
115			sub __name2name ($$) {
116			my ($self, $key) = @_;
117			join '//', @$key;
118			}
119
120			sub __check_name ($$) {
121			my ($self, $key) = @_;
122			for (@$key) {
123			return 0 unless $_; # '' or 0 or undef
124			return 0 if index ($_, $Sep) > -1;
125			return 0 if $_ eq $Self \|\| $_ eq $Parent;
126			}
127			return 1;
128			}
129
130			sub get ($$$) {
131			my ($self, $prop, $key) = @_;
132			$self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
133			$self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
134			}
135
136			sub set ($$$$) {
137			my ($self, $prop, $key => $value) = @_;
138			$self->{error}->raise (type => 'KEY_INVALID_NAME', key => $key)
139			unless $self->__check_name ($key);
140			$self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
141			$self->{db_hash}->{$prop}->{ $self->__name2name ($key) } = $value;
142			$self->{prop_modified}->{$prop} = 1;
143			}
144
145			sub exist ($$$) {
146			my ($self, $prop, $key) = @_;
147			return 0 unless $self->__check_name ($key);
148			$self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
149			exist $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
150			}
151
152			sub delete ($$$) {
153			my ($self, $prop, $key) = @_;
154			$self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
155			delete $self->{db_hash}->{$prop}->{ $self->__name2name ($key) };
156			$self->{prop_modified}->{$prop} = 1;
157			}
158
159			sub keys ($$;%) {
160			my ($self, $prop, %opt) = @_;
161			$self->__read_meta ($prop) unless $self->{db_hash}->{$prop};
162	wakaba	1.2	my $ns = $self->__name2name ($opt{ns}) . $Sep;
163	wakaba	1.1	my $ns_l = length $ns;
164			my @result;
165			for (keys %{$self->{db_hash}->{$prop}}) {
166			## Namespace is match
167			if (substr ($_, 0, $ns_l) eq $ns) {
168			## Child or grandchild in recursive mode
169			if ($opt{recursive} \|\| not (index ($_, $Sep) > -1)) {
170			push @result, $_;
171			}
172			}
173			}
174			return map {[split /\Q$Sep\E/, $_]} @result;
175			}
176
177			sub close ($) {
178			my $self = shift;
179			for (keys %{$self->{db_hash}}) {
180			$self->__write_meta ($_);
181			}
182			$self->{db_hash} = undef;
183			}
184
185			sub DESTROY ($) {
186			my $self = shift;
187			$self->close if $self->{db_hash};
188			}
189
190			=head1 METHODS
191
192			This module provides common interface of SuikaWiki WikiDatabase
193			modules. See C<SuikaWiki::DB>.
194
195			=head1 AUTHOR
196
197			Wakaba <[email protected]>.
198
199			=head1 LICENSE
200
201			Copyright 2003 Wakaba <[email protected]>
202
203			This program is free software; you can redistribute it and/or
204			modify it under the same terms as Perl itself.
205
206			=cut
207
208	wakaba	1.2	1; # $Date: 2003/08/06 01:26:14 $