diff options
| -rw-r--r-- | MANIFEST | 15 | ||||
| -rw-r--r-- | lib/DBM_Filter.pm | 605 | ||||
| -rw-r--r-- | lib/DBM_Filter/Changes | 5 | ||||
| -rw-r--r-- | lib/DBM_Filter/compress.pm | 51 | ||||
| -rw-r--r-- | lib/DBM_Filter/encode.pm | 84 | ||||
| -rw-r--r-- | lib/DBM_Filter/int32.pm | 48 | ||||
| -rw-r--r-- | lib/DBM_Filter/null.pm | 50 | ||||
| -rw-r--r-- | lib/DBM_Filter/t/01error.t | 236 | ||||
| -rw-r--r-- | lib/DBM_Filter/t/02core.t | 719 | ||||
| -rw-r--r-- | lib/DBM_Filter/t/compress.t | 111 | ||||
| -rw-r--r-- | lib/DBM_Filter/t/encode.t | 105 | ||||
| -rw-r--r-- | lib/DBM_Filter/t/int32.t | 90 | ||||
| -rw-r--r-- | lib/DBM_Filter/t/null.t | 86 | ||||
| -rw-r--r-- | lib/DBM_Filter/t/utf8.t | 86 | ||||
| -rw-r--r-- | lib/DBM_Filter/utf8.pm | 50 | ||||
| -rw-r--r-- | lib/dbm_filter_util.pl | 68 |
16 files changed, 2409 insertions, 0 deletions
@@ -1083,6 +1083,21 @@ lib/ctime.pl A ctime workalike 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 diff --git a/lib/DBM_Filter.pm b/lib/DBM_Filter.pm new file mode 100644 index 0000000000..7385ddd3a3 --- /dev/null +++ b/lib/DBM_Filter.pm @@ -0,0 +1,605 @@ +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> + diff --git a/lib/DBM_Filter/Changes b/lib/DBM_Filter/Changes new file mode 100644 index 0000000000..3f0841f664 --- /dev/null +++ b/lib/DBM_Filter/Changes @@ -0,0 +1,5 @@ +Revision history for Perl extension DBM_Filter. + +0.01 Sat, 17 Jan 2004 + + * Original version created. diff --git a/lib/DBM_Filter/compress.pm b/lib/DBM_Filter/compress.pm new file mode 100644 index 0000000000..4c3356c3fc --- /dev/null +++ b/lib/DBM_Filter/compress.pm @@ -0,0 +1,51 @@ +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 + diff --git a/lib/DBM_Filter/encode.pm b/lib/DBM_Filter/encode.pm new file mode 100644 index 0000000000..f5ca7a97b7 --- /dev/null +++ b/lib/DBM_Filter/encode.pm @@ -0,0 +1,84 @@ +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 + diff --git a/lib/DBM_Filter/int32.pm b/lib/DBM_Filter/int32.pm new file mode 100644 index 0000000000..76d4a11e7d --- /dev/null +++ b/lib/DBM_Filter/int32.pm @@ -0,0 +1,48 @@ +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 + diff --git a/lib/DBM_Filter/null.pm b/lib/DBM_Filter/null.pm new file mode 100644 index 0000000000..1eb9556629 --- /dev/null +++ b/lib/DBM_Filter/null.pm @@ -0,0 +1,50 @@ +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 diff --git a/lib/DBM_Filter/t/01error.t b/lib/DBM_Filter/t/01error.t new file mode 100644 index 0000000000..4ebbfd8495 --- /dev/null +++ b/lib/DBM_Filter/t/01error.t @@ -0,0 +1,236 @@ + +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" ; +} + diff --git a/lib/DBM_Filter/t/02core.t b/lib/DBM_Filter/t/02core.t new file mode 100644 index 0000000000..fe1dc8c73c --- /dev/null +++ b/lib/DBM_Filter/t/02core.t @@ -0,0 +1,719 @@ + +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'; + +} + diff --git a/lib/DBM_Filter/t/compress.t b/lib/DBM_Filter/t/compress.t new file mode 100644 index 0000000000..b7f04bb57b --- /dev/null +++ b/lib/DBM_Filter/t/compress.t @@ -0,0 +1,111 @@ + +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" ; +} + diff --git a/lib/DBM_Filter/t/encode.t b/lib/DBM_Filter/t/encode.t new file mode 100644 index 0000000000..7b71a98b2e --- /dev/null +++ b/lib/DBM_Filter/t/encode.t @@ -0,0 +1,105 @@ + +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" ; +} + diff --git a/lib/DBM_Filter/t/int32.t b/lib/DBM_Filter/t/int32.t new file mode 100644 index 0000000000..5cdadde057 --- /dev/null +++ b/lib/DBM_Filter/t/int32.t @@ -0,0 +1,90 @@ + +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" ; +} + diff --git a/lib/DBM_Filter/t/null.t b/lib/DBM_Filter/t/null.t new file mode 100644 index 0000000000..2d1c22a8af --- /dev/null +++ b/lib/DBM_Filter/t/null.t @@ -0,0 +1,86 @@ + +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" ; +} + diff --git a/lib/DBM_Filter/t/utf8.t b/lib/DBM_Filter/t/utf8.t new file mode 100644 index 0000000000..e37afa2d4a --- /dev/null +++ b/lib/DBM_Filter/t/utf8.t @@ -0,0 +1,86 @@ + +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" ; +} + diff --git a/lib/DBM_Filter/utf8.pm b/lib/DBM_Filter/utf8.pm new file mode 100644 index 0000000000..89d8238568 --- /dev/null +++ b/lib/DBM_Filter/utf8.pm @@ -0,0 +1,50 @@ +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 + diff --git a/lib/dbm_filter_util.pl b/lib/dbm_filter_util.pl new file mode 100644 index 0000000000..2f8af209e2 --- /dev/null +++ b/lib/dbm_filter_util.pl @@ -0,0 +1,68 @@ +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; |