DB/File/StructCache.pm


=head1 NAME

SuikaWiki::DB::File::StructCache - 

=head1 DESCRIPTION

This module wrappes perl's hash with WikiDatabase common interface of
SuikaWiki.  It is useful for tied hash.

This module is part of SuikaWiki.

=cut

package SuikaWiki::DB::Hash;
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';

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->{db_hash} = &{$o{constructor} || sub {return {}}} ($self, \%o);
  unless ($self->{db_hash}) {
    report SuikaWiki::DB::Util::Error 
      -type => 'DB_OPEN',
      -object => $self, method => 'new';
  }
  $self->{has_exist} = defined $o{has_exist} ? $o{has_exist} : 1;
  $self;
}

sub get ($$$) {
  my ($self, $prop, $key) = @_;
  $self->___validate_name ($key);
  $self->{db_hash}->{join $;, @$key};
}

sub set ($$$$) {
  my ($self, $prop, $key => $value) = @_;
  $self->___validate_name ($key);
  $self->{db_hash}->{join $;, @$key} = $value;
}

sub exist ($$$) {
  my ($self, $prop, $key) = @_;
  $self->___validate_name ($key);
  if ($self->{has_exist}) {
    return CORE::exists $self->{db_hash}->{join $;, @$key};
  } else {
    return CORE::defined $self->{db_hash}->{join $;, @$key} ? 1 : 0;
  }
}

sub delete ($$$) {
  my ($self, $prop, $key) = @_;
  $self->___validate_name ($key);
  CORE::delete $self->{db_hash}->{join $;, @$key};
}

sub keys ($$;%) {
  my ($self, $prop, %opt) = @_;
  $self->___validate_name ($opt{ns}, error_type => 'KEY_INVALID_NS_NAME');
  my $prefix = join $;, @{$opt{ns}};
  my $prefix_length = length $prefix;
  $prefix .= $; if $prefix_length;
  return CORE::map {[$_]} 
         CORE::grep {substr ($_, 0, $prefix_length) eq $prefix}
         CORE::keys %{$self->{db_hash}};
}

sub close ($) {
  my $self = shift;
  ($self->{destructor} or sub { 1 })->($self)
    or report SuikaWiki::DB::Util::Error 
         -type => 'DB_CLOSE',
         -object => $self, method => 'close';
  $self->{db_hash} = undef;
  $self->{lock}->unlock if $self->{lock};
  $self->{lock} = undef;
}
           
sub DESTROY ($) {
  my $self = shift;
  $self->close if $self->{db_hash};
}

sub ___validate_name ($$;%) {
  my ($self, $key, %opt) = @_;
  if (ref $key) {
    my $ok = 1;
    for (@$key) {
      if (index ($key, $;) > -1) {
        $ok = 0;
        last;
      }
    }
    return if $ok;
  }
  local $Error::Depth = $Error::Depth + 1;
  report SuikaWiki::DB::Util::Error
    -type => $opt{error_type} || 'KEY_INVALID_NAME',
    -object => $self, method => '___validate_name',
    key => $key;
}

=head1 METHODS

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

=head1 SEE ALSO

C<SuikaWiki::DB>.

=head1 AUTHOR

Wakaba <w@suika.fam.cx>.

=head1 LICENSE

Copyright AUTHOR 2003.

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

=cut

1; # $Date: 2003/12/06 02:19:09 $
1
2	=head1 NAME
3
4	SuikaWiki::DB::File::StructCache -
5
6	=head1 DESCRIPTION
7
8	This module wrappes perl's hash with WikiDatabase common interface of
9	SuikaWiki. It is useful for tied hash.
10
11	This module is part of SuikaWiki.
12
13	=cut
14
15	package SuikaWiki::DB::Hash;
16	use strict;
17	our $VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18	require SuikaWiki::DB::Util;
19	push our @ISA, 'SuikaWiki::DB::Util::template';
20
21	sub new ($%) {
22
23	my ($class, %o) = @_;
24	my $self = bless {}, $class;
25	if ($o{-lock}) {
26	$self->{lock} = SuikaWiki::DB::Util->new_lock ($o{-lock});
27	$self->{lock}->lock;
28	}
29	$self->{db_hash} = &{$o{constructor} \|\| sub {return {}}} ($self, \%o);
30	unless ($self->{db_hash}) {
31	report SuikaWiki::DB::Util::Error
32	-type => 'DB_OPEN',
33	-object => $self, method => 'new';
34	}
35	$self->{has_exist} = defined $o{has_exist} ? $o{has_exist} : 1;
36	$self;
37	}
38
39	sub get ($$$) {
40	my ($self, $prop, $key) = @_;
41	$self->___validate_name ($key);
42	$self->{db_hash}->{join $;, @$key};
43	}
44
45	sub set ($$$$) {
46	my ($self, $prop, $key => $value) = @_;
47	$self->___validate_name ($key);
48	$self->{db_hash}->{join $;, @$key} = $value;
49	}
50
51	sub exist ($$$) {
52	my ($self, $prop, $key) = @_;
53	$self->___validate_name ($key);
54	if ($self->{has_exist}) {
55	return CORE::exists $self->{db_hash}->{join $;, @$key};
56	} else {
57	return CORE::defined $self->{db_hash}->{join $;, @$key} ? 1 : 0;
58	}
59	}
60
61	sub delete ($$$) {
62	my ($self, $prop, $key) = @_;
63	$self->___validate_name ($key);
64	CORE::delete $self->{db_hash}->{join $;, @$key};
65	}
66
67	sub keys ($$;%) {
68	my ($self, $prop, %opt) = @_;
69	$self->___validate_name ($opt{ns}, error_type => 'KEY_INVALID_NS_NAME');
70	my $prefix = join $;, @{$opt{ns}};
71	my $prefix_length = length $prefix;
72	$prefix .= $; if $prefix_length;
73	return CORE::map {[$_]}
74	CORE::grep {substr ($_, 0, $prefix_length) eq $prefix}
75	CORE::keys %{$self->{db_hash}};
76	}
77
78	sub close ($) {
79	my $self = shift;
80	($self->{destructor} or sub { 1 })->($self)
81	or report SuikaWiki::DB::Util::Error
82	-type => 'DB_CLOSE',
83	-object => $self, method => 'close';
84	$self->{db_hash} = undef;
85	$self->{lock}->unlock if $self->{lock};
86	$self->{lock} = undef;
87	}
88
89	sub DESTROY ($) {
90	my $self = shift;
91	$self->close if $self->{db_hash};
92	}
93
94	sub ___validate_name ($$;%) {
95	my ($self, $key, %opt) = @_;
96	if (ref $key) {
97	my $ok = 1;
98	for (@$key) {
99	if (index ($key, $;) > -1) {
100	$ok = 0;
101	last;
102	}
103	}
104	return if $ok;
105	}
106	local $Error::Depth = $Error::Depth + 1;
107	report SuikaWiki::DB::Util::Error
108	-type => $opt{error_type} \|\| 'KEY_INVALID_NAME',
109	-object => $self, method => '___validate_name',
110	key => $key;
111	}
112
113	=head1 METHODS
114
115	This module provides common interface of SuikaWiki WikiDatabase
116	modules. See C<SuikaWiki::DB>.
117
118	=head1 SEE ALSO
119
120	C<SuikaWiki::DB>.
121
122	=head1 AUTHOR
123
124	Wakaba <w@suika.fam.cx>.
125
126	=head1 LICENSE
127
128	Copyright AUTHOR 2003.
129
130	This program is free software; you can redistribute it and/or
131	modify it under the same terms as Perl itself.
132
133	=cut
134
135	1; # $Date: 2003/12/06 02:19:09 $