lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir)
lib/DB.pm Debugger API (draft)
lib/DB.t See if DB works
+lib/DBM_Filter.pm DBM Filter module
+lib/DBM_Filter/Changes DBM Filter Change history
+lib/DBM_Filter/compress.pm DBM Filter to compress keys/values
+lib/DBM_Filter/encode.pm DBM Filter for encoding
+lib/DBM_Filter/int32.pm DBM Filter for creating int32 keys/values
+lib/DBM_Filter/null.pm DBM Filter for null termination
+lib/DBM_Filter/t/01error.t test DBM_Filter::null
+lib/DBM_Filter/t/02core.t test DBM_Filter::null
+lib/DBM_Filter/t/compress.t test DBM_Filter::compress
+lib/DBM_Filter/t/encode.t test DBM_Filter::encode
+lib/DBM_Filter/t/int32.t test DBM_Filter::int32
+lib/DBM_Filter/t/null.t test DBM_Filter::null
+lib/DBM_Filter/t/utf8.t test DBM_Filter::utf8
+lib/DBM_Filter/utf8.pm DBM Filter for UTF-8 Encoding
+lib/dbm_filter_util.pl Utility functions used by DBM Filter tests
lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm
lib/Devel/SelfStubber.t See if Devel::SelfStubber works
lib/diagnostics.pm Print verbose diagnostics
--- /dev/null
+package DBM_Filter ;
+
+use strict;
+use warnings;
+our $VERSION = '0.01';
+
+package Tie::Hash ;
+
+use strict;
+use warnings;
+
+use Carp;
+
+
+our %LayerStack = ();
+our %origDESTROY = ();
+
+our %Filters = map { $_, undef } qw(
+ Fetch_Key
+ Fetch_Value
+ Store_Key
+ Store_Value
+ );
+
+our %Options = map { $_, 1 } qw(
+ fetch
+ store
+ );
+
+#sub Filter_Enable
+#{
+#}
+#
+#sub Filter_Disable
+#{
+#}
+
+sub Filtered
+{
+ my $this = shift;
+ return defined $LayerStack{$this} ;
+}
+
+sub Filter_Pop
+{
+ my $this = shift;
+ my $stack = $LayerStack{$this} || return undef ;
+ my $filter = pop @{ $stack };
+
+ # remove the filter hooks if this is the last filter to pop
+ if ( @{ $stack } == 0 ) {
+ $this->filter_store_key ( undef );
+ $this->filter_store_value( undef );
+ $this->filter_fetch_key ( undef );
+ $this->filter_fetch_value( undef );
+ delete $LayerStack{$this};
+ }
+
+ return $filter;
+}
+
+sub Filter_Key_Push
+{
+ &_do_Filter_Push;
+}
+
+sub Filter_Value_Push
+{
+ &_do_Filter_Push;
+}
+
+
+sub Filter_Push
+{
+ &_do_Filter_Push;
+}
+
+sub _do_Filter_Push
+{
+ my $this = shift;
+ my %callbacks = ();
+ my $caller = (caller(1))[3];
+ $caller =~ s/^.*:://;
+
+ croak "$caller: no parameters present" unless @_ ;
+
+ if ( ! $Options{lc $_[0]} ) {
+ my $class = shift;
+ my @params = @_;
+
+ # if $class already contains "::", don't prefix "DBM_Filter::"
+ $class = "DBM_Filter::$class" unless $class =~ /::/;
+
+ # does the "DBM_Filter::$class" exist?
+ if ( ! defined %{ "${class}::"} ) {
+ # Nope, so try to load it.
+ eval " require $class ; " ;
+ croak "$caller: Cannot Load DBM Filter '$class': $@" if $@;
+ }
+
+ no strict 'refs';
+ my $fetch = *{ "${class}::Fetch" }{CODE};
+ my $store = *{ "${class}::Store" }{CODE};
+ my $filter = *{ "${class}::Filter" }{CODE};
+ use strict 'refs';
+
+ my $count = defined($filter) + defined($store) + defined($fetch) ;
+
+ if ( $count == 0 )
+ { croak "$caller: No methods (Filter, Fetch or Store) found in class '$class'" }
+ elsif ( $count == 1 && ! defined $filter) {
+ my $need = defined($fetch) ? 'Store' : 'Fetch';
+ croak "$caller: Missing method '$need' in class '$class'" ;
+ }
+ elsif ( $count >= 2 && defined $filter)
+ { croak "$caller: Can't mix Filter with Store and Fetch in class '$class'" }
+
+ if (defined $filter) {
+ my $callbacks = &{ $filter }(@params);
+ croak "$caller: '${class}::Filter' did not return a hash reference"
+ unless ref $callbacks && ref $callbacks eq 'HASH';
+ %callbacks = %{ $callbacks } ;
+ }
+ else {
+ $callbacks{Fetch} = $fetch;
+ $callbacks{Store} = $store;
+ }
+ }
+ else {
+ croak "$caller: not even params" unless @_ % 2 == 0;
+ %callbacks = @_;
+ }
+
+ my %filters = %Filters ;
+ my @got = ();
+ while (my ($k, $v) = each %callbacks )
+ {
+ my $key = $k;
+ $k = lc $k;
+ if ($k eq 'fetch') {
+ push @got, 'Fetch';
+ if ($caller eq 'Filter_Push')
+ { $filters{Fetch_Key} = $filters{Fetch_Value} = $v }
+ elsif ($caller eq 'Filter_Key_Push')
+ { $filters{Fetch_Key} = $v }
+ elsif ($caller eq 'Filter_Value_Push')
+ { $filters{Fetch_Value} = $v }
+ }
+ elsif ($k eq 'store') {
+ push @got, 'Store';
+ if ($caller eq 'Filter_Push')
+ { $filters{Store_Key} = $filters{Store_Value} = $v }
+ elsif ($caller eq 'Filter_Key_Push')
+ { $filters{Store_Key} = $v }
+ elsif ($caller eq 'Filter_Value_Push')
+ { $filters{Store_Value} = $v }
+ }
+ else
+ { croak "$caller: Unknown key '$key'" }
+
+ croak "$caller: value associated with key '$key' is not a code reference"
+ unless ref $v && ref $v eq 'CODE';
+ }
+
+ if ( @got != 2 ) {
+ push @got, 'neither' if @got == 0 ;
+ croak "$caller: expected both Store & Fetch - got @got";
+ }
+
+ # remember the class
+ push @{ $LayerStack{$this} }, \%filters ;
+
+ my $str_this = "$this" ; # Avoid a closure with $this in the subs below
+
+ $this->filter_store_key ( sub { store_hook($str_this, 'Store_Key') });
+ $this->filter_store_value( sub { store_hook($str_this, 'Store_Value') });
+ $this->filter_fetch_key ( sub { fetch_hook($str_this, 'Fetch_Key') });
+ $this->filter_fetch_value( sub { fetch_hook($str_this, 'Fetch_Value') });
+
+ # Hijack the callers DESTROY method
+ $this =~ /^(.*)=/;
+ my $type = $1 ;
+ no strict 'refs';
+ if ( *{ "${type}::DESTROY" }{CODE} ne \&MyDESTROY )
+ {
+ $origDESTROY{$type} = *{ "${type}::DESTROY" }{CODE};
+ no warnings 'redefine';
+ *{ "${type}::DESTROY" } = \&MyDESTROY ;
+ }
+}
+
+sub store_hook
+{
+ my $this = shift ;
+ my $type = shift ;
+ foreach my $layer (@{ $LayerStack{$this} })
+ {
+ &{ $layer->{$type} }() if defined $layer->{$type} ;
+ }
+}
+
+sub fetch_hook
+{
+ my $this = shift ;
+ my $type = shift ;
+ foreach my $layer (reverse @{ $LayerStack{$this} })
+ {
+ &{ $layer->{$type} }() if defined $layer->{$type} ;
+ }
+}
+
+sub MyDESTROY
+{
+ my $this = shift ;
+ delete $LayerStack{$this} ;
+
+ # call real DESTROY
+ $this =~ /^(.*)=/;
+ &{ $origDESTROY{$1} }($this);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBM_Filter -- Filter DBM keys/values
+
+=head1 SYNOPSIS
+
+ use DBM_Filter ;
+ use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
+
+ $db = tie %hash, ...
+
+ $db->Filter_Push(Fetch => sub {...},
+ Store => sub {...});
+
+ $db->Filter_Push('my_filter1');
+ $db->Filter_Push('my_filter2', params...);
+
+ $db->Filter_Key_Push(...) ;
+ $db->Filter_Value_Push(...) ;
+
+ $db->Filter_Pop();
+ $db->Filtered();
+
+ package DBM_Filter::my_filter1;
+
+ sub Store { ... }
+ sub Fetch { ... }
+
+ 1;
+
+ package DBM_Filter::my_filter2;
+
+ sub Filter
+ {
+ my @opts = @_;
+ ...
+ return (
+ sub Store { ... },
+ sub Fetch { ... } );
+ }
+
+ 1;
+
+=head1 DESCRIPTION
+
+This module provides an interface that allows filters to be applied
+to tied Hashes associated with DBM files. It builds on the DBM Filter
+hooks that are present in all the *DB*_File modules included with the
+standard Perl source distribution from version 5.6.1 onwards. In addition
+to the *DB*_File modules distributed with Perl, the BerkeleyDB module,
+available on CPAN, supports the DBM Filter hooks. See L<perldbmfilter>
+for more details on the DBM Filter hooks.
+
+=head1 What is a DBM Filter?
+
+A DBM Filter allows the keys and/or values in a tied hash to be modified
+by some user-defined code just before it is written to the DBM file and
+just after it is read back from the DBM file. For example, this snippet
+of code
+
+ $some_hash{"abc"} = 42;
+
+could potentially trigger two filters, one for the writing of the key
+"abc" and another for writing the value 42. Similarly, this snippet
+
+ my ($key, $value) = each %some_hash
+
+will trigger two filters, one for the reading of the key and one for
+the reading of the value.
+
+Like the existing DBM Filter functionality, this module arranges for the
+C<$_> variable to be populated with the key or value that a filter will
+check. This usually means that most DBM filters tend to be very short.
+
+=head2 So what's new?
+
+The main enhancements over the standard DBM Filter hooks are:
+
+=over 4
+
+=item *
+
+A cleaner interface.
+
+=item *
+
+The ability to easily apply multiple filters to a single DBM file.
+
+=item *
+
+The ability to create "canned" filters. These allow commonly used filters
+to be packaged into a stand-alone module.
+
+=back
+
+=head1 METHODS
+
+This module will arrange for the following methods to be available via
+the object returned from the C<tie> call.
+
+=head2 $db->Filter_Push()
+
+=head2 $db->Filter_Key_Push()
+
+=head2 $db->Filter_Value_Push()
+
+Add a filter to filter stack for the database, C<$db>. The three formats
+vary only in whether they apply to the DBM key, the DBM value or both.
+
+=over 5
+
+=item Filter_Push
+
+The filter is applied to I<both> keys and values.
+
+=item Filter_Key_Push
+
+The filter is applied to the key I<only>.
+
+=item Filter_Value_Push
+
+The filter is applied to the value I<only>.
+
+=back
+
+
+=head2 $db->Filter_Pop()
+
+Removes the last filter that was applied to the DBM file associated with
+C<$db>, if present.
+
+=head2 $db->Filtered()
+
+Returns TRUE if there are any filters applied to the DBM associated
+with C<$db>. Otherwise returns FALSE.
+
+
+
+=head1 Writing a Filter
+
+Filters can be created in two main ways
+
+=head2 Immediate Filters
+
+An immediate filter allows you to specify the filter code to be used
+at the point where the filter is applied to a dbm. In this mode the
+Filter_*_Push methods expects to receive exactly two parameters.
+
+ my $db = tie %hash, 'SDBM_File', ...
+ $db->Filter_Push( Store => sub { },
+ Fetch => sub { });
+
+The code reference associated with C<Store> will be called before any
+key/value is written to the database and the code reference associated
+with C<Fetch> will be called after any key/value is read from the
+database.
+
+For example, here is a sample filter that adds a trailing NULL character
+to all strings before they are written to the DBM file, and removes the
+trailing NULL when they are read from the DBM file
+
+ my $db = tie %hash, 'SDBM_File', ...
+ $db->Filter_Push( Store => sub { $_ .= "\x00" ; },
+ Fetch => sub { s/\x00$// ; });
+
+
+Points to note:
+
+=over 5
+
+=item 1.
+
+Both the Store and Fetch filters manipulate C<$_>.
+
+=back
+
+=head2 Canned Filters
+
+Immediate filters are useful for one-off situations. For more generic
+problems it can be useful to package the filter up in its own module.
+
+The usage is for a canned filter is:
+
+ $db->Filter_Push("name", params)
+
+where
+
+=over 5
+
+=item "name"
+
+is the name of the module to load. If the string specified does not
+contain the package separator characters "::", it is assumed to refer to
+the full module name "DBM_Filter::name". This means that the full names
+for canned filters, "null" and "utf8", included with this module are:
+
+ DBM_Filter::null
+ DBM_Filter::utf8
+
+=item params
+
+any optional parameters that need to be sent to the filter. See the
+encode filter for an example of a module that uses parameters.
+
+=back
+
+The module that implements the canned filter can take one of two
+forms. Here is a template for the first
+
+ package DBM_Filter::null ;
+
+ use strict;
+ use warnings;
+
+ sub Store
+ {
+ # store code here
+ }
+
+ sub Fetch
+ {
+ # fetch code here
+ }
+
+ 1;
+
+
+Notes:
+
+=over 5
+
+=item 1.
+
+The package name uses the C<DBM_Filter::> prefix.
+
+=item 2.
+
+The module I<must> have both a Store and a Fetch method. If only one is
+present, or neither are present, a fatal error will be thrown.
+
+=back
+
+The second form allows the filter to hold state information using a
+closure, thus:
+
+ package DBM_Filter::encoding ;
+
+ use strict;
+ use warnings;
+
+ sub Filter
+ {
+ my @params = @_ ;
+
+ ...
+ return {
+ Store => sub { $_ = $encoding->encode($_) },
+ Fetch => sub { $_ = $encoding->decode($_) }
+ } ;
+ }
+
+ 1;
+
+
+In this instance the "Store" and "Fetch" methods are encapsulated inside a
+"Filter" method.
+
+
+=head1 Filters Included
+
+A number of canned filers are provided with this module. They cover a
+number of the main areas that filters are needed when interfacing with
+DBM files. They also act as templates for your own filters.
+
+The filter included are:
+
+=over 5
+
+=item * utf8
+
+This module will ensure that all data written to the DBM will be encoded
+in UTF-8.
+
+This module needs the Encode module.
+
+=item * encode
+
+Allows you to choose the character encoding will be store in the DBM file.
+
+=item * compress
+
+This filter will compress all data before it is written to the database
+and uncompressed it on reading.
+
+This module needs Compress::Zlib.
+
+=item * int32
+
+This module is used when interoperating with a C/C++ application that
+uses a C int as either the key and/or value in the DBM file.
+
+=item * null
+
+This module ensures that all data written to the DBM file is null
+terminated. This is useful when you have a perl script that needs
+to interoperate with a DBM file that a C program also uses. A fairly
+common issue is for the C application to include the terminating null
+in a string when it writes to the DBM file. This filter will ensure that
+all data written to the DBM file can be read by the C application.
+
+=back
+
+=head1 NOTES
+
+=head2 Maintain Round Trip Integrity
+
+When writing a DBM filter it is I<very> important to ensure that it is
+possible to retrieve all data that you have written when the DBM filter
+is in place. In practice, this means that whatever transformation is
+applied to the data in the Store method, the I<exact> inverse operation
+should be applied in the Fetch method.
+
+If you don't provide an exact inverse transformation, you will find that
+code like this will not behave as you expect.
+
+ while (my ($k, $v) = each %hash)
+ {
+ ...
+ }
+
+Depending on the transformation, you will find that one or more of the
+following will happen
+
+=over 5
+
+=item 1
+
+The loop will never terminate.
+
+=item 2
+
+Too few records will be retrieved.
+
+=item 3
+
+Too many will be retrieved.
+
+=item 4
+
+The loop will do the right thing for a while, but it will unexpectedly fail.
+
+=back
+
+=head2 Don't mix filtered & non-filtered data in the same database file.
+
+This is just a restatement of the previous section. Unless you are
+completely certain you know what you are doing, avoid mixing filtered &
+non-filtered data.
+
+=head1 EXAMPLE
+
+Say you need to interoperate with a legacy C application that stores
+keys as C ints and the values and null terminated UTF-8 strings. Here
+is how you would set that up
+
+ my $db = tie %hash, 'SDBM_File', ...
+
+ $db->Filter_Key_Push('int32') ;
+
+ $db->Filter_Value_Push('utf8');
+ $db->Filter_Value_Push('null');
+
+=head1 SEE ALSO
+
+<DB_File>, L<GDBM_File>, L<NDBM_File>, L<ODBM_File>, L<SDBM_File>, L<perldbmfilter>
+
+=head1 AUTHOR
+
+Paul Marquess <pmqs@cpan.org>
+
--- /dev/null
+Revision history for Perl extension DBM_Filter.
+
+0.01 Sat, 17 Jan 2004
+
+ * Original version created.
--- /dev/null
+package DBM_Filter::compress ;
+
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = '0.01';
+
+BEGIN
+{
+ eval { require Compress::Zlib; Compress::Zlib->import() };
+
+ croak "Compress::Zlib module not found.\n"
+ if $@;
+}
+
+
+
+sub Store { $_ = compress($_) }
+sub Fetch { $_ = uncompress($_) }
+
+1;
+
+__END__
+
+=head1 DBM_Filter::compress
+
+=head1 SYNOPSIS
+
+ use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
+ use DBM_Filter ;
+
+ $db = tie %hash, ...
+ $db->Filter_Push('compress');
+
+=head1 DESCRIPTION
+
+This DBM filter will compress all data before it is written to the database
+and uncompressed it on reading.
+
+A fatal error will be thrown if the Compress::Zlib module is not
+available.
+
+=head1 SEE ALSO
+
+L<DBM_Filter>, L<perldbmfilter>, L<Compress::Zlib>
+
+=head1 AUTHOR
+
+Paul Marquess pmqs@cpan.org
+
--- /dev/null
+package DBM_Filter::encode ;
+
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = '0.01';
+
+BEGIN
+{
+ eval { require Encode; };
+
+ croak "Encode module not found.\n"
+ if $@;
+}
+
+
+sub Filter
+{
+ my $encoding_name = shift || "utf8";
+
+ my $encoding = Encode::find_encoding($encoding_name) ;
+
+ croak "Encoding '$encoding_name' is not available"
+ unless $encoding;
+
+ return {
+ Store => sub {
+ $_ = $encoding->encode($_)
+ if defined $_ ;
+ },
+ Fetch => sub {
+ $_ = $encoding->decode($_)
+ if defined $_ ;
+ }
+ } ;
+}
+
+1;
+
+__END__
+
+=head1 DBM_Filter::encode
+
+=head1 SYNOPSIS
+
+ use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
+ use DBM_Filter ;
+
+ $db = tie %hash, ...
+ $db->Filter_Push('encode' => 'iso-8859-16');
+
+=head1 DESCRIPTION
+
+This DBM filter allows you to choose the character encoding will be
+store in the DBM file. The usage is
+
+ $db->Filter_Push('encode' => ENCODING);
+
+where "ENCODING" must be a valid encoding name that the Encode module
+recognises.
+
+A fatal error will be thrown if:
+
+=over 5
+
+=item 1
+
+The Encode module is not available.
+
+=item 2
+
+The encoding requested is not supported by the Encode module.
+
+=back
+
+=head1 SEE ALSO
+
+L<DBM_Filter>, L<perldbmfilter>, L<Encode>
+
+=head1 AUTHOR
+
+Paul Marquess pmqs@cpan.org
+
--- /dev/null
+package DBM_Filter::int32 ;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+# todo get Filter to figure endian.
+
+sub Store
+{
+ $_ = 0 if ! defined $_ || $_ eq "" ;
+ $_ = pack("i", $_);
+}
+
+sub Fetch
+{
+ no warnings 'uninitialized';
+ $_ = unpack("i", $_);
+}
+
+1;
+
+__END__
+
+=head1 DBM_Filter::int32
+
+=head1 SYNOPSIS
+
+ use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
+ use DBM_Filter ;
+
+ $db = tie %hash, ...
+ $db->Filter_Push('int32');
+
+=head1 DESCRIPTION
+
+This DBM filter is used when interoperating with a C/C++ application
+that uses a C int as either the key and/or value in the DBM file.
+
+=head1 SEE ALSO
+
+L<DBM_Filter>, L<perldbmfilter>
+
+=head1 AUTHOR
+
+Paul Marquess pmqs@cpan.org
+
--- /dev/null
+package DBM_Filter::null ;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+sub Store
+{
+ no warnings 'uninitialized';
+ $_ .= "\x00" ;
+}
+
+sub Fetch
+{
+ no warnings 'uninitialized';
+ s/\x00$// ;
+}
+
+1;
+
+__END__
+
+=head1 DBM_Filter::null
+
+=head1 SYNOPSIS
+
+ use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
+ use DBM_Filter ;
+
+ $db = tie %hash, ...
+ $db->Filter_Push('null');
+
+=head1 DESCRIPTION
+
+This filter ensures that all data written to the DBM file is null
+terminated. This is useful when you have a perl script that needs
+to interoperate with a DBM file that a C program also uses. A fairly
+common issue is for the C application to include the terminating null
+in a string when it writes to the DBM file. This filter will ensure that
+all data written to the DBM file can be read by the C application.
+
+
+=head1 SEE ALSO
+
+L<DBM_Filter>, L<perldbmfilter>
+
+=head1 AUTHOR
+
+Paul Marquess pmqs@cpan.org
--- /dev/null
+
+use strict;
+use warnings;
+use Carp;
+
+use lib '.';
+our $db ;
+
+{
+ chdir 't' if -d 't';
+ if ( ! -d 'DBM_Filter')
+ {
+ mkdir 'DBM_Filter', 0777
+ || die "Cannot create directory 'DBM_Filter': $!\n" ;
+ }
+}
+
+sub writeFile
+{
+ my $filename = shift ;
+ my $content = shift;
+ open F, ">$filename" || croak "Cannot open $filename: $!" ;
+ print F $content ;
+ close F;
+}
+
+sub runFilter
+{
+ my $name = shift ;
+ my $filter = shift ;
+
+print "# runFilter $name\n" ;
+ my $filename = "DBM_Filter/$name.pm";
+ $filter = "package DBM_Filter::$name ;\n$filter"
+ unless $filter =~ /^\s*package/ ;
+
+ writeFile($filename, $filter);
+ eval { $db->Filter_Push($name) };
+ unlink $filename;
+ return $@;
+}
+
+use Test::More tests => 21;
+
+BEGIN { use_ok('DBM_Filter') };
+BEGIN { use_ok('SDBM_File') };
+BEGIN { use_ok('Fcntl') };
+
+unlink <Op_dbmx*>;
+END { unlink <Op_dbmx*>; }
+
+my %h1 = () ;
+my %h2 = () ;
+$db = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+
+ok $db, "tied to SDBM_File ok";
+
+
+# Error cases
+
+eval { $db->Filter_Push() ; };
+like $@, qr/^Filter_Push: no parameters present/,
+ "croak if not parameters passed to Filter_Push";
+
+eval { $db->Filter_Push("unknown_class") ; };
+like $@, qr/^Filter_Push: Cannot Load DBM Filter 'DBM_Filter::unknown_class'/,
+ "croak on unknown class" ;
+
+eval { $db->Filter_Push("Some::unknown_class") ; };
+like $@, qr/^Filter_Push: Cannot Load DBM Filter 'Some::unknown_class'/,
+ "croak on unknown fully qualified class" ;
+
+eval { $db->Filter_Push('Store') ; };
+like $@, qr/^Filter_Push: not even params/,
+ "croak if not passing even number or params to Filter_Push";
+
+runFilter('bad1', <<'EOM');
+ package DBM_Filter::bad1 ;
+ 1;
+EOM
+
+like $@, qr/^Filter_Push: No methods \(Filter, Fetch or Store\) found in class 'DBM_Filter::bad1'/,
+ "croak if none of Filter/Fetch/Store in filter" ;
+
+
+runFilter('bad2', <<'EOM');
+ package DBM_Filter::bad2 ;
+
+ sub Filter
+ {
+ return 2;
+ }
+
+ 1;
+EOM
+
+like $@, qr/^Filter_Push: 'DBM_Filter::bad2::Filter' did not return a hash reference./,
+ "croak if Filter doesn't return hash reference" ;
+
+runFilter('bad3', <<'EOM');
+ package DBM_Filter::bad3 ;
+
+ sub Filter
+ {
+ return { BadKey => sub { } } ;
+
+ }
+
+ 1;
+EOM
+
+like $@, qr/^Filter_Push: Unknown key 'BadKey'/,
+ "croak if bad keyword returned from Filter";
+
+runFilter('bad4', <<'EOM');
+ package DBM_Filter::bad4 ;
+
+ sub Filter
+ {
+ return { Store => "abc" } ;
+ }
+
+ 1;
+EOM
+
+like $@, qr/^Filter_Push: value associated with key 'Store' is not a code reference/,
+ "croak if not a code reference";
+
+runFilter('bad5', <<'EOM');
+ package DBM_Filter::bad5 ;
+
+ sub Filter
+ {
+ return { } ;
+ }
+
+ 1;
+EOM
+
+like $@, qr/^Filter_Push: expected both Store & Fetch - got neither/,
+ "croak if neither fetch or store is present";
+
+runFilter('bad6', <<'EOM');
+ package DBM_Filter::bad6 ;
+
+ sub Filter
+ {
+ return { Store => sub {} } ;
+ }
+
+ 1;
+EOM
+
+like $@, qr/^Filter_Push: expected both Store & Fetch - got Store/,
+ "croak if store is present but fetch isn't";
+
+runFilter('bad7', <<'EOM');
+ package DBM_Filter::bad7 ;
+
+ sub Filter
+ {
+ return { Fetch => sub {} } ;
+ }
+
+ 1;
+EOM
+
+like $@, qr/^Filter_Push: expected both Store & Fetch - got Fetch/,
+ "croak if fetch is present but store isn't";
+
+runFilter('bad8', <<'EOM');
+ package DBM_Filter::bad8 ;
+
+ sub Filter {}
+ sub Store {}
+ sub Fetch {}
+
+ 1;
+EOM
+
+like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad8'/,
+ "croak if Fetch, Store and Filter";
+
+runFilter('bad9', <<'EOM');
+ package DBM_Filter::bad9 ;
+
+ sub Filter {}
+ sub Store {}
+
+ 1;
+EOM
+
+like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad9'/,
+ "croak if Store and Filter";
+
+runFilter('bad10', <<'EOM');
+ package DBM_Filter::bad10 ;
+
+ sub Filter {}
+ sub Fetch {}
+
+ 1;
+EOM
+
+like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad10'/,
+ "croak if Fetch and Filter";
+
+runFilter('bad11', <<'EOM');
+ package DBM_Filter::bad11 ;
+
+ sub Fetch {}
+
+ 1;
+EOM
+
+like $@, qr/^Filter_Push: Missing method 'Store' in class 'DBM_Filter::bad11'/,
+ "croak if Fetch but no Store";
+
+runFilter('bad12', <<'EOM');
+ package DBM_Filter::bad12 ;
+
+ sub Store {}
+
+ 1;
+EOM
+
+like $@, qr/^Filter_Push: Missing method 'Fetch' in class 'DBM_Filter::bad12'/,
+ "croak if Store but no Fetch";
+
+undef $db;
+{
+ use warnings FATAL => 'untie';
+ eval { untie %h1 };
+ is $@, '', "untie without inner references" ;
+}
+
--- /dev/null
+
+use strict;
+use warnings;
+use Carp;
+
+my %files = ();
+
+use lib '.';
+
+{
+ chdir 't' if -d 't';
+ if ( ! -d 'DBM_Filter')
+ {
+ mkdir 'DBM_Filter', 0777
+ || die "Cannot create directory 'DBM_Filter': $!\n" ;
+ }
+}
+
+
+sub writeFile
+{
+ my $filename = shift ;
+ my $content = shift;
+ open F, ">DBM_Filter/$filename.pm" || croak "Cannot open $filename: $!" ;
+ print F $content ;
+ close F;
+ $files{"DBM_Filter/$filename.pm"} ++;
+}
+
+END { unlink keys %files if keys %files }
+
+use Test::More tests => 189;
+
+BEGIN { use_ok('DBM_Filter') };
+BEGIN { use_ok('SDBM_File') };
+BEGIN { use_ok('Fcntl') };
+
+unlink <Op_dbmx*>;
+END { unlink <Op_dbmx*>; }
+
+writeFile('times_ten', <<'EOM');
+ package DBM_Filter::times_ten;
+ sub Store { $_ *= 10 }
+ sub Fetch { $_ /= 10 }
+ 1;
+EOM
+
+writeFile('append_A', <<'EOM');
+ package DBM_Filter::append_A;
+ sub Store { $_ .= 'A' }
+ sub Fetch { s/A$// }
+ 1;
+EOM
+
+writeFile('append_B', <<'EOM');
+ package DBM_Filter::append_B;
+ sub Store { $_ .= 'B' }
+ sub Fetch { s/B$// }
+ 1;
+EOM
+
+writeFile('append_C', <<'EOM');
+ package DBM_Filter::append_C;
+ sub Store { $_ .= 'C' }
+ sub Fetch { s/C$// }
+ 1;
+EOM
+
+writeFile('append_D', <<'EOM');
+ package DBM_Filter::append_D;
+ sub Store { $_ .= 'D' }
+ sub Fetch { s/D$// }
+ 1;
+EOM
+
+writeFile('append', <<'EOM');
+ package DBM_Filter::append;
+ sub Filter
+ {
+ my $string = shift ;
+ return {
+ Store => sub { $_ .= $string },
+ Fetch => sub { s/${string}$// }
+ }
+ }
+ 1;
+EOM
+
+writeFile('double', <<'EOM');
+ package DBM_Filter::double;
+ sub Store { $_ *= 2 }
+ sub Fetch { $_ /= 2 }
+ 1;
+EOM
+
+writeFile('uc', <<'EOM');
+ package DBM_Filter::uc;
+ sub Store { $_ = uc $_ }
+ sub Fetch { $_ = lc $_ }
+ 1;
+EOM
+
+writeFile('reverse', <<'EOM');
+ package DBM_Filter::reverse;
+ sub Store { $_ = reverse $_ }
+ sub Fetch { $_ = reverse $_ }
+ 1;
+EOM
+
+
+my %PreData = (
+ 'abc' => 'def',
+ '123' => '456',
+ );
+
+my %PostData = (
+ 'alpha' => 'beta',
+ 'green' => 'blue',
+ );
+
+sub doPreData
+{
+ my $h = shift ;
+
+ $$h{"abc"} = "def";
+ $$h{"123"} = "456";
+ ok $$h{"abc"} eq "def", "read eq written" ;
+ ok $$h{"123"} eq "456", "read eq written" ;
+
+}
+
+sub doPostData
+{
+ my $h = shift ;
+
+ no warnings 'uninitialized';
+ $$h{undef()} = undef();
+ $$h{"alpha"} = "beta";
+ $$h{"green"} = "blue";
+ ok $$h{""} eq "", "read eq written" ;
+ ok $$h{"green"} eq "blue", "read eq written" ;
+ ok $$h{"green"} eq "blue", "read eq written" ;
+
+}
+
+sub checkRaw
+{
+ my $filename = shift ;
+ my %expected = @_ ;
+ my %h;
+
+ # read the dbm file without the filter
+ ok tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640), "tied to SDBM_File";
+
+ my %bad = ();
+ while (my ($k, $v) = each %h) {
+ if ( defined $expected{$k} && $expected{$k} eq $v ) {
+ delete $expected{$k} ;
+ }
+ else
+ { $bad{$k} = $v }
+ }
+
+ ok keys(%expected) + keys(%bad) == 0, "Raw hash is ok";
+
+ if ( keys(%expected) + keys(%bad) ) {
+ my $bad = "Expected does not match actual\nExpected:\n" ;
+ while (my ($k, $v) = each %expected) {
+ $bad .= "\t'$k' =>\t'$v'\n";
+ }
+ $bad .= "\nGot:\n" ;
+ while (my ($k, $v) = each %bad) {
+ $bad .= "\t'$k' =>\t'$v'\n";
+ }
+ diag $bad ;
+ }
+
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+ unlink <Op_dbmx*>;
+}
+
+{
+ #diag "Test Set: Key and Value Filter, no stacking, no closure";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval { $db->Filter_Push('append_A') };
+ is $@, '', "push 'append_A' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ 'A' => 'A',
+ 'alphaA' => 'betaA',
+ 'greenA' => 'blueA';
+
+}
+
+{
+ #diag "Test Set: Key Only Filter, no stacking, no closure";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval { $db->Filter_Key_Push('append_A') };
+ is $@, '', "push 'append_A' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ 'A' => '',
+ 'alphaA' => 'beta',
+ 'greenA' => 'blue';
+
+}
+
+{
+ #diag "Test Set: Value Only Filter, no stacking, no closure";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval { $db->Filter_Value_Push('append_A') };
+ is $@, '', "push 'append_A' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ '' => 'A',
+ 'alpha' => 'betaA',
+ 'green' => 'blueA';
+
+}
+
+{
+ #diag "Test Set: Key and Value Filter, with stacking, no closure";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval { $db->Filter_Push('append_A') };
+ is $@, '', "push 'append_A' filter" ;
+
+ eval { $db->Filter_Push('append_B') };
+ is $@, '', "push 'append_B' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ 'AB' => 'AB',
+ 'alphaAB' => 'betaAB',
+ 'greenAB' => 'blueAB';
+
+}
+
+{
+ #diag "Test Set: Key Filter != Value Filter, with stacking, no closure";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval { $db->Filter_Value_Push('append_A') };
+ is $@, '', "push 'append_A' filter" ;
+
+ eval { $db->Filter_Key_Push('append_B') };
+ is $@, '', "push 'append_B' filter" ;
+
+ eval { $db->Filter_Value_Push('append_C') };
+ is $@, '', "push 'append_C' filter" ;
+
+ eval { $db->Filter_Key_Push('append_D') };
+ is $@, '', "push 'append_D' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ 'BD' => 'AC',
+ 'alphaBD' => 'betaAC',
+ 'greenBD' => 'blueAC';
+
+}
+
+{
+ #diag "Test Set: Key only Filter, with stacking, no closure";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval { $db->Filter_Key_Push('append_B') };
+ is $@, '', "push 'append_B' filter" ;
+
+ eval { $db->Filter_Key_Push('append_D') };
+ is $@, '', "push 'append_D' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ 'BD' => '',
+ 'alphaBD' => 'beta',
+ 'greenBD' => 'blue';
+
+}
+
+{
+ #diag "Test Set: Value only Filter, with stacking, no closure";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval { $db->Filter_Value_Push('append_A') };
+ is $@, '', "push 'append_A' filter" ;
+
+ eval { $db->Filter_Value_Push('append_C') };
+ is $@, '', "push 'append_C' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ '' => 'AC',
+ 'alpha' => 'betaAC',
+ 'green' => 'blueAC';
+
+}
+
+{
+ #diag "Test Set: Combination Key/Value + Key Filter != Value Filter, with stacking, no closure";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval { $db->Filter_Push('append_A') };
+ is $@, '', "push 'append_A' filter" ;
+
+ eval { $db->Filter_Value_Push('append_C') };
+ is $@, '', "push 'append_C' filter" ;
+
+ eval { $db->Filter_Key_Push('append_D') };
+ is $@, '', "push 'append_D' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ 'AD' => 'AC',
+ 'alphaAD' => 'betaAC',
+ 'greenAD' => 'blueAC';
+
+}
+
+{
+ #diag "Test Set: Combination Key/Value + Key + Key/Value, no closure";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval { $db->Filter_Push('append_A') };
+ is $@, '', "push 'append_A' filter" ;
+
+ eval { $db->Filter_Key_Push('append_B') };
+ is $@, '', "push 'append_B' filter" ;
+
+ eval { $db->Filter_Push('append_C') };
+ is $@, '', "push 'append_C' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ 'ABC' => 'AC',
+ 'alphaABC' => 'betaAC',
+ 'greenABC' => 'blueAC';
+
+}
+
+{
+ #diag "Test Set: Combination Key/Value + Key + Key/Value, with closure";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval { $db->Filter_Push('append' => 'A') };
+ is $@, '', "push 'append_A' filter" ;
+
+ eval { $db->Filter_Key_Push('append' => 'B') };
+ is $@, '', "push 'append_B' filter" ;
+
+ eval { $db->Filter_Push('append' => 'C') };
+ is $@, '', "push 'append_C' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ 'ABC' => 'AC',
+ 'alphaABC' => 'betaAC',
+ 'greenABC' => 'blueAC';
+
+}
+
+{
+ #diag "Test Set: Combination Key/Value + Key + Key/Value, immediate";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval {
+ $db->Filter_Push(
+ Store => sub { $_ .= 'A' },
+ Fetch => sub { s/A$// }) };
+ is $@, '', "push 'append_A' filter" ;
+
+ eval {
+ $db->Filter_Key_Push(
+ Store => sub { $_ .= 'B' },
+ Fetch => sub { s/B$// }) };
+ is $@, '', "push 'append_B' filter" ;
+
+ eval {
+ $db->Filter_Push(
+ Store => sub { $_ .= 'C' },
+ Fetch => sub { s/C$// }) };
+ is $@, '', "push 'append_C' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ 'ABC' => 'AC',
+ 'alphaABC' => 'betaAC',
+ 'greenABC' => 'blueAC';
+
+}
+
+{
+ #diag "Test Set: Combination Key/Value + Key + Key/Value, immediate, closure";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval {
+ $db->Filter_Push(
+ Store => sub { $_ .= 'A' },
+ Fetch => sub { s/A$// }) };
+ is $@, '', "push 'append_A' filter" ;
+
+ eval { $db->Filter_Key_Push('append_B') };
+ is $@, '', "push 'append_B' filter" ;
+
+ eval { $db->Filter_Push('append' => 'C') };
+ is $@, '', "push 'append_C' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ 'ABC' => 'AC',
+ 'alphaABC' => 'betaAC',
+ 'greenABC' => 'blueAC';
+
+}
+
+{
+ #diag "Test Set: Filtered & Filter_Pop";
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ ok ! $db->Filtered, "not filtered" ;
+
+ eval {
+ $db->Filter_Push(
+ Store => sub { $_ .= 'A' },
+ Fetch => sub { s/A$// }) };
+ is $@, '', "push 'append_A' filter" ;
+
+ ok $db->Filtered, "is filtered" ;
+
+ eval { $db->Filter_Key_Push('append_B') };
+ is $@, '', "push 'append_B' filter" ;
+
+ ok $db->Filtered, "is filtered" ;
+
+ eval { $db->Filter_Push('append' => 'C') };
+ is $@, '', "push 'append_C' filter" ;
+
+ ok $db->Filtered, "is filtered" ;
+
+ doPostData(\%h);
+
+ eval { $db->Filter_Pop() };
+ is $@, '', "Filter_Pop";
+
+ ok $db->Filtered, "is filtered" ;
+
+ $h{'after'} = 'noon';
+ is $h{'after'}, 'noon', "read eq written";
+
+ eval { $db->Filter_Pop() };
+ is $@, '', "Filter_Pop";
+
+ ok $db->Filtered, "is filtered" ;
+
+ $h{'morning'} = 'after';
+ is $h{'morning'}, 'after', "read eq written";
+
+ eval { $db->Filter_Pop() };
+ is $@, '', "Filter_Pop";
+
+ ok ! $db->Filtered, "not filtered" ;
+
+ $h{'and'} = 'finally';
+ is $h{'and'}, 'finally', "read eq written";
+
+ eval { $db->Filter_Pop() };
+ is $@, '', "Filter_Pop";
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ 'ABC' => 'AC',
+ 'alphaABC' => 'betaAC',
+ 'greenABC' => 'blueAC',
+ 'afterAB' => 'noonA',
+ 'morningA' => 'afterA',
+ 'and' => 'finally';
+
+}
+
+{
+ #diag "Test Set: define the filter package in-line";
+
+ {
+ package DBM_Filter::append_X;
+
+ sub Store { $_ .= 'X' }
+ sub Fetch { s/X$// }
+ }
+
+ my %h = () ;
+ my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+ ok $db, "tied to SDBM_File";
+
+ doPreData(\%h);
+
+ eval { $db->Filter_Push('append_X') };
+ is $@, '', "push 'append_X' filter" ;
+
+ doPostData(\%h);
+
+ undef $db;
+ {
+ use warnings FATAL => 'untie';
+ eval { untie %h };
+ is $@, '', "untie without inner references" ;
+ }
+
+ checkRaw 'Op_dbmx',
+ 'abc' => 'def',
+ '123' => '456',
+ 'X' => 'X',
+ 'alphaX' => 'betaX',
+ 'greenX' => 'blueX';
+
+}
+
--- /dev/null
+
+use strict;
+use warnings;
+use Carp;
+
+BEGIN
+{
+ eval { require Compress::Zlib ; };
+ if ($@) {
+ print "1..0 # Skip: Compress::Zlib is not available\n";
+print "# $@\n";
+ exit 0;
+ }
+}
+require "dbm_filter_util.pl";
+
+use Test::More tests => 23;
+
+BEGIN { use_ok('DBM_Filter') };
+BEGIN { use_ok('SDBM_File') };
+BEGIN { use_ok('Fcntl') };
+BEGIN { use_ok('Compress::Zlib') };
+
+unlink <Op_dbmx*>;
+END { unlink <Op_dbmx*>; }
+
+my %h1 = () ;
+my $db1 = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+
+ok $db1, "tied to SDBM_File";
+
+# store before adding the filter
+
+StoreData(\%h1,
+ {
+ 1234 => 5678,
+ -3 => -5,
+ "22" => "88",
+ "-45" => "-88",
+ "fred" => "Joe",
+ "alpha" => "Alpha",
+ "Beta" => "beta",
+ });
+
+VerifyData(\%h1,
+ {
+ 1234 => 5678,
+ -3 => -5,
+ "22" => "88",
+ "-45" => "-88",
+ "fred" => "Joe",
+ "alpha" => "Alpha",
+ "Beta" => "beta",
+ });
+
+
+eval { $db1->Filter_Push('compress') };
+is $@, '', "push a 'compress' filter" ;
+
+{
+ no warnings 'uninitialized';
+ StoreData(\%h1,
+ {
+ undef() => undef(),
+ "400" => "500",
+ 0 => 1,
+ 1 => 0,
+ "abc" => "de0",
+ "\x00\x01" => "\x03\xFF",
+ });
+
+}
+
+undef $db1;
+{
+ use warnings FATAL => 'untie';
+ eval { untie %h1 };
+ is $@, '', "untie without inner references" ;
+}
+
+# read the dbm file without the filter
+my %h2 = () ;
+my $db2 = tie(%h2, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+
+ok $db2, "tied to SDBM_File";
+
+VerifyData(\%h2,
+ {
+ 1234 => 5678,
+ -3 => -5,
+ "22" => "88",
+ "-45" => "-88",
+ "fred" => "Joe",
+ "alpha" => "Alpha",
+ "Beta" => "beta",
+
+ compress("") => compress(""),
+ compress("400") => compress("500"),
+ compress("0") => compress("1"),
+ compress("1") => compress("0"),
+ compress("abc") => compress("de0"),
+ compress("\x00\x01") => compress("\x03\xFF"),
+ });
+
+undef $db2;
+{
+ use warnings FATAL => 'untie';
+ eval { untie %h2 };
+ is $@, '', "untie without inner references" ;
+}
+
--- /dev/null
+
+use strict;
+use warnings;
+use Carp;
+
+
+BEGIN
+{
+
+ eval { require Encode; };
+
+ if ($@) {
+ print "1..0 # Skip: Encode is not available\n";
+ exit 0;
+ }
+}
+
+
+require "dbm_filter_util.pl";
+
+use Test::More tests => 26;
+
+BEGIN { use_ok('DBM_Filter') };
+BEGIN { use_ok('SDBM_File') };
+BEGIN { use_ok('Fcntl') };
+BEGIN { use_ok('charnames', qw{greek})};
+
+use charnames qw{greek};
+
+unlink <Op_dbmx*>;
+END { unlink <Op_dbmx*>; }
+
+my %h1 = () ;
+my $db1 = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+
+ok $db1, "tied to SDBM_File";
+
+eval { $db1->Filter_Push('encode' => 'blah') };
+like $@, qr/^Encoding 'blah' is not available/, "push an illigal filter" ;
+
+eval { $db1->Filter_Push('encode') };
+is $@, '', "push an 'encode' filter (default to utf-8)" ;
+
+
+{
+ no warnings 'uninitialized';
+ StoreData(\%h1,
+ {
+ undef() => undef(),
+ 'alpha' => "\N{alpha}",
+ "\N{gamma}"=> "gamma",
+ "beta" => "\N{beta}",
+ });
+
+}
+
+VerifyData(\%h1,
+ {
+ 'alpha' => "\N{alpha}",
+ "beta" => "\N{beta}",
+ "\N{gamma}"=> "gamma",
+ "" => "",
+ });
+
+eval { $db1->Filter_Pop() };
+is $@, '', "pop the 'utf8' filter" ;
+
+eval { $db1->Filter_Push('encode' => 'iso-8859-16') };
+is $@, '', "push an 'encode' filter (specify iso-8859-16)" ;
+
+use charnames qw{:full};
+StoreData(\%h1,
+ {
+ 'euro' => "\N{EURO SIGN}",
+ });
+
+undef $db1;
+{
+ use warnings FATAL => 'untie';
+ eval { untie %h1 };
+ is $@, '', "untie without inner references" ;
+}
+
+# read the dbm file without the filter
+my %h2 = () ;
+my $db2 = tie(%h2, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+
+ok $db2, "tied to SDBM_File";
+
+VerifyData(\%h2,
+ {
+ 'alpha' => "\xCE\xB1",
+ 'beta' => "\xCE\xB2",
+ "\xCE\xB3"=> "gamma",
+ 'euro' => "\xA4",
+ "" => "",
+ });
+
+undef $db2;
+{
+ use warnings FATAL => 'untie';
+ eval { untie %h2 };
+ is $@, '', "untie without inner references" ;
+}
+
--- /dev/null
+
+use strict;
+use warnings;
+use Carp;
+
+require "dbm_filter_util.pl";
+
+use Test::More tests => 22;
+
+BEGIN { use_ok('DBM_Filter') };
+BEGIN { use_ok('SDBM_File') };
+BEGIN { use_ok('Fcntl') };
+
+unlink <Op_dbmx*>;
+END { unlink <Op_dbmx*>; }
+
+my %h1 = () ;
+my $db1 = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+
+ok $db1, "tied to SDBM_File";
+
+# store before adding the filter
+
+StoreData(\%h1,
+ {
+ 1234 => 5678,
+ -3 => -5,
+ "22" => "88",
+ "-45" => "-88",
+ });
+
+VerifyData(\%h1,
+ {
+ 1234 => 5678,
+ -3 => -5,
+ 22 => 88,
+ -45 => -88,
+ });
+
+
+eval { $db1->Filter_Push('int32') };
+is $@, '', "push an 'int32' filter" ;
+
+{
+ no warnings 'uninitialized';
+ StoreData(\%h1,
+ {
+ undef() => undef(),
+ "400" => "500",
+ 0 => 1,
+ 1 => 0,
+ -47 => -6,
+ });
+
+}
+
+undef $db1;
+{
+ use warnings FATAL => 'untie';
+ eval { untie %h1 };
+ is $@, '', "untie without inner references" ;
+}
+
+# read the dbm file without the filter
+my %h2 = () ;
+my $db2 = tie(%h2, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+
+ok $db2, "tied to SDBM_File";
+
+VerifyData(\%h2,
+ {
+ 1234 => 5678,
+ -3 => -5,
+ 22 => 88,
+ -45 => -88,
+
+ #undef() => undef(),
+ pack("i", 400) => pack("i", 500),
+ pack("i", 0) => pack("i", 1),
+ pack("i", 1) => pack("i", 0),
+ pack("i", -47) => pack("i", -6),
+ });
+
+undef $db2;
+{
+ use warnings FATAL => 'untie';
+ eval { untie %h2 };
+ is $@, '', "untie without inner references" ;
+}
+
--- /dev/null
+
+use strict;
+use warnings;
+use Carp;
+
+require "dbm_filter_util.pl";
+
+use Test::More tests => 26;
+
+BEGIN { use_ok('DBM_Filter') };
+BEGIN { use_ok('SDBM_File') };
+BEGIN { use_ok('Fcntl') };
+
+unlink <Op_dbmx*>;
+END { unlink <Op_dbmx*>; }
+
+my %h1 = () ;
+my $db1 = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+
+ok $db1, "tied to SDBM_File";
+
+# store before adding the filter
+
+StoreData(\%h1,
+ {
+ "abc" => "def",
+ });
+
+VerifyData(\%h1,
+ {
+ "abc" => "def",
+ });
+
+
+eval { $db1->Filter_Push('null') };
+is $@, '', "push a 'null' filter" ;
+
+{
+ no warnings 'uninitialized';
+ StoreData(\%h1,
+ {
+ undef() => undef(),
+ "alpha" => "beta",
+ });
+
+ VerifyData(\%h1,
+ {
+ undef() => undef(),
+ "abc" => "", # not "def", because the filter is in place
+ "alpha" => "beta",
+ });
+}
+
+ while (my ($k, $v) = each %h1) {
+ no warnings 'uninitialized';
+ #diag "After Match [$k][$v]";
+ }
+
+
+undef $db1;
+{
+ use warnings FATAL => 'untie';
+ eval { untie %h1 };
+ is $@, '', "untie without inner references" ;
+}
+
+# read the dbm file without the filter, check for null termination
+my %h2 = () ;
+my $db2 = tie(%h2, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+
+ok $db2, "tied to SDBM_File";
+
+VerifyData(\%h2,
+ {
+ "abc" => "def",
+ "alpha\x00" => "beta\x00",
+ "\x00" => "\x00",
+ });
+
+undef $db2;
+{
+ use warnings FATAL => 'untie';
+ eval { untie %h2 };
+ is $@, '', "untie without inner references" ;
+}
+
--- /dev/null
+
+use strict;
+use warnings;
+use Carp;
+
+BEGIN
+{
+
+ eval { require Encode; };
+
+ if ($@) {
+ print "1..0 # Skip: Encode is not available\n";
+ exit 0;
+ }
+}
+
+require "dbm_filter_util.pl";
+
+use Test::More tests => 20;
+
+BEGIN { use_ok('DBM_Filter') };
+BEGIN { use_ok('SDBM_File') };
+BEGIN { use_ok('Fcntl') };
+BEGIN { use_ok('charnames', qw{greek})};
+
+use charnames qw{greek};
+
+unlink <Op_dbmx*>;
+END { unlink <Op_dbmx*>; }
+
+my %h1 = () ;
+my $db1 = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+
+ok $db1, "tied to SDBM_File";
+
+eval { $db1->Filter_Push('utf8') };
+is $@, '', "push a 'utf8' filter" ;
+
+{
+ no warnings 'uninitialized';
+ StoreData(\%h1,
+ {
+ undef() => undef(),
+ "beta" => "\N{beta}",
+ 'alpha' => "\N{alpha}",
+ "\N{gamma}"=> "gamma",
+ });
+
+}
+
+VerifyData(\%h1,
+ {
+ 'alpha' => "\N{alpha}",
+ "beta" => "\N{beta}",
+ "\N{gamma}"=> "gamma",
+ "" => "",
+ });
+
+undef $db1;
+{
+ use warnings FATAL => 'untie';
+ eval { untie %h1 };
+ is $@, '', "untie without inner references" ;
+}
+
+# read the dbm file without the filter
+my %h2 = () ;
+my $db2 = tie(%h2, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
+
+ok $db2, "tied to SDBM_File";
+
+VerifyData(\%h2,
+ {
+ 'alpha' => "\xCE\xB1",
+ 'beta' => "\xCE\xB2",
+ "\xCE\xB3"=> "gamma",
+ "" => "",
+ });
+
+undef $db2;
+{
+ use warnings FATAL => 'untie';
+ eval { untie %h2 };
+ is $@, '', "untie without inner references" ;
+}
+
--- /dev/null
+package DBM_Filter::utf8 ;
+
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = '0.01';
+
+BEGIN
+{
+ eval { require Encode; };
+
+ croak "Encode module not found.\n"
+ if $@;
+}
+
+sub Store { $_ = Encode::encode_utf8($_) if defined $_ }
+
+sub Fetch { $_ = Encode::decode_utf8($_) if defined $_ }
+
+1;
+
+__END__
+
+=head1 DBM_Filter::utf8
+
+=head1 SYNOPSIS
+
+ use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
+ use DBM_Filter ;
+
+
+ $db = tie %hash, ...
+ $db->Filter_Push('utf8');
+
+=head1 DESCRIPTION
+
+This Filter will ensure that all data written to the DBM will be encoded
+in UTF-8.
+
+This module uses the Encode module.
+
+=head1 SEE ALSO
+
+L<DBM_Filter>, L<perldbmfilter>, L<Encode>
+
+=head1 AUTHOR
+
+Paul Marquess pmqs@cpan.org
+
--- /dev/null
+use strict;
+use warnings;
+
+sub StoreData
+{
+ my $hashref = shift ;
+ my $store = shift ;
+
+ my (undef, $file, $line) = caller;
+ ok 1, "StoreData called from $file, line $line";
+
+ ok ref $store eq 'HASH', "Store Data is a hash reference";
+ ok tied %$hashref, "Storing to tied hash";
+
+ while (my ($k, $v) = each %$store) {
+ no warnings 'uninitialized';
+ #diag "Stored [$k][$v]";
+ $$hashref{$k} = $v ;
+ }
+
+}
+
+sub VerifyData
+{
+ my $hashref = shift ;
+ my $expected = shift ;
+ my %expected = %$expected;
+
+ my (undef, $file, $line) = caller;
+ ok 1, "VerifyData called from $file, line $line";
+
+ ok ref $expected eq 'HASH', "Expected data is a hash reference";
+ ok tied %$hashref, "Verifying a tied hash";
+
+ my %bad = ();
+ while (my ($k, $v) = each %$hashref) {
+ no warnings 'uninitialized';
+ if ($expected{$k} eq $v) {
+ #diag "Match [$k][$v]";
+ delete $expected{$k} ;
+ }
+ else {
+ #diag "No Match [$k][$v]";
+ $bad{$k} = $v;
+ }
+ }
+
+ if( ! ok(keys(%bad) + keys(%expected) == 0, "Expected == Actual") ) {
+ my $bad = "Expected does not match actual\n";
+ if (keys %expected ) {
+ $bad .=" No Match from Expected:\n" ;
+ while (my ($k, $v) = each %expected) {
+ $bad .= "\t'$k' =>\t'$v'\n";
+ }
+ }
+ if (keys %bad ) {
+ $bad .= "\n No Match from Actual:\n" ;
+ while (my ($k, $v) = each %bad) {
+ no warnings 'uninitialized';
+ $bad .= "\t'$k' =>\t'$v'\n";
+ }
+ }
+ diag "${bad}\n" ;
+ }
+}
+
+
+1;
projects / p5sagit/p5-mst-13.2.git / commitdiff