This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix pod warning for empty sections.
[perl5.git] / lib / DBM_Filter.pm
CommitLineData
0e9b1cbd
PM
1package DBM_Filter ;
2
3use strict;
4use warnings;
902fde96 5our $VERSION = '0.03';
0e9b1cbd
PM
6
7package Tie::Hash ;
8
9use strict;
10use warnings;
11
12use Carp;
13
14
15our %LayerStack = ();
16our %origDESTROY = ();
17
18our %Filters = map { $_, undef } qw(
19 Fetch_Key
20 Fetch_Value
21 Store_Key
22 Store_Value
23 );
24
25our %Options = map { $_, 1 } qw(
26 fetch
27 store
28 );
29
30#sub Filter_Enable
31#{
32#}
33#
34#sub Filter_Disable
35#{
36#}
37
38sub Filtered
39{
40 my $this = shift;
41 return defined $LayerStack{$this} ;
42}
43
44sub Filter_Pop
45{
46 my $this = shift;
47 my $stack = $LayerStack{$this} || return undef ;
48 my $filter = pop @{ $stack };
49
50 # remove the filter hooks if this is the last filter to pop
51 if ( @{ $stack } == 0 ) {
52 $this->filter_store_key ( undef );
53 $this->filter_store_value( undef );
54 $this->filter_fetch_key ( undef );
55 $this->filter_fetch_value( undef );
56 delete $LayerStack{$this};
57 }
58
59 return $filter;
60}
61
62sub Filter_Key_Push
63{
64 &_do_Filter_Push;
65}
66
67sub Filter_Value_Push
68{
69 &_do_Filter_Push;
70}
71
72
73sub Filter_Push
74{
75 &_do_Filter_Push;
76}
77
78sub _do_Filter_Push
79{
80 my $this = shift;
81 my %callbacks = ();
82 my $caller = (caller(1))[3];
83 $caller =~ s/^.*:://;
84
85 croak "$caller: no parameters present" unless @_ ;
86
87 if ( ! $Options{lc $_[0]} ) {
88 my $class = shift;
89 my @params = @_;
90
91 # if $class already contains "::", don't prefix "DBM_Filter::"
92 $class = "DBM_Filter::$class" unless $class =~ /::/;
93
d9f30342 94 no strict 'refs';
0e9b1cbd 95 # does the "DBM_Filter::$class" exist?
902fde96 96 if ( ! %{ "${class}::"} ) {
0e9b1cbd
PM
97 # Nope, so try to load it.
98 eval " require $class ; " ;
99 croak "$caller: Cannot Load DBM Filter '$class': $@" if $@;
100 }
101
0e9b1cbd
PM
102 my $fetch = *{ "${class}::Fetch" }{CODE};
103 my $store = *{ "${class}::Store" }{CODE};
104 my $filter = *{ "${class}::Filter" }{CODE};
105 use strict 'refs';
106
107 my $count = defined($filter) + defined($store) + defined($fetch) ;
108
109 if ( $count == 0 )
110 { croak "$caller: No methods (Filter, Fetch or Store) found in class '$class'" }
111 elsif ( $count == 1 && ! defined $filter) {
112 my $need = defined($fetch) ? 'Store' : 'Fetch';
113 croak "$caller: Missing method '$need' in class '$class'" ;
114 }
115 elsif ( $count >= 2 && defined $filter)
116 { croak "$caller: Can't mix Filter with Store and Fetch in class '$class'" }
117
118 if (defined $filter) {
119 my $callbacks = &{ $filter }(@params);
120 croak "$caller: '${class}::Filter' did not return a hash reference"
121 unless ref $callbacks && ref $callbacks eq 'HASH';
122 %callbacks = %{ $callbacks } ;
123 }
124 else {
125 $callbacks{Fetch} = $fetch;
126 $callbacks{Store} = $store;
127 }
128 }
129 else {
130 croak "$caller: not even params" unless @_ % 2 == 0;
131 %callbacks = @_;
132 }
133
134 my %filters = %Filters ;
135 my @got = ();
136 while (my ($k, $v) = each %callbacks )
137 {
138 my $key = $k;
139 $k = lc $k;
140 if ($k eq 'fetch') {
141 push @got, 'Fetch';
142 if ($caller eq 'Filter_Push')
143 { $filters{Fetch_Key} = $filters{Fetch_Value} = $v }
144 elsif ($caller eq 'Filter_Key_Push')
145 { $filters{Fetch_Key} = $v }
146 elsif ($caller eq 'Filter_Value_Push')
147 { $filters{Fetch_Value} = $v }
148 }
149 elsif ($k eq 'store') {
150 push @got, 'Store';
151 if ($caller eq 'Filter_Push')
152 { $filters{Store_Key} = $filters{Store_Value} = $v }
153 elsif ($caller eq 'Filter_Key_Push')
154 { $filters{Store_Key} = $v }
155 elsif ($caller eq 'Filter_Value_Push')
156 { $filters{Store_Value} = $v }
157 }
158 else
159 { croak "$caller: Unknown key '$key'" }
160
161 croak "$caller: value associated with key '$key' is not a code reference"
162 unless ref $v && ref $v eq 'CODE';
163 }
164
165 if ( @got != 2 ) {
166 push @got, 'neither' if @got == 0 ;
167 croak "$caller: expected both Store & Fetch - got @got";
168 }
169
170 # remember the class
171 push @{ $LayerStack{$this} }, \%filters ;
172
173 my $str_this = "$this" ; # Avoid a closure with $this in the subs below
174
175 $this->filter_store_key ( sub { store_hook($str_this, 'Store_Key') });
176 $this->filter_store_value( sub { store_hook($str_this, 'Store_Value') });
177 $this->filter_fetch_key ( sub { fetch_hook($str_this, 'Fetch_Key') });
178 $this->filter_fetch_value( sub { fetch_hook($str_this, 'Fetch_Value') });
179
180 # Hijack the callers DESTROY method
181 $this =~ /^(.*)=/;
182 my $type = $1 ;
183 no strict 'refs';
184 if ( *{ "${type}::DESTROY" }{CODE} ne \&MyDESTROY )
185 {
186 $origDESTROY{$type} = *{ "${type}::DESTROY" }{CODE};
187 no warnings 'redefine';
188 *{ "${type}::DESTROY" } = \&MyDESTROY ;
189 }
190}
191
192sub store_hook
193{
194 my $this = shift ;
195 my $type = shift ;
196 foreach my $layer (@{ $LayerStack{$this} })
197 {
198 &{ $layer->{$type} }() if defined $layer->{$type} ;
199 }
200}
201
202sub fetch_hook
203{
204 my $this = shift ;
205 my $type = shift ;
206 foreach my $layer (reverse @{ $LayerStack{$this} })
207 {
208 &{ $layer->{$type} }() if defined $layer->{$type} ;
209 }
210}
211
212sub MyDESTROY
213{
214 my $this = shift ;
215 delete $LayerStack{$this} ;
216
217 # call real DESTROY
218 $this =~ /^(.*)=/;
219 &{ $origDESTROY{$1} }($this);
220}
221
2221;
223
224__END__
225
226=head1 NAME
227
228DBM_Filter -- Filter DBM keys/values
229
230=head1 SYNOPSIS
231
232 use DBM_Filter ;
233 use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
234
235 $db = tie %hash, ...
236
237 $db->Filter_Push(Fetch => sub {...},
238 Store => sub {...});
239
240 $db->Filter_Push('my_filter1');
241 $db->Filter_Push('my_filter2', params...);
242
243 $db->Filter_Key_Push(...) ;
244 $db->Filter_Value_Push(...) ;
245
246 $db->Filter_Pop();
247 $db->Filtered();
248
249 package DBM_Filter::my_filter1;
250
251 sub Store { ... }
252 sub Fetch { ... }
253
254 1;
255
256 package DBM_Filter::my_filter2;
257
258 sub Filter
259 {
260 my @opts = @_;
261 ...
262 return (
263 sub Store { ... },
264 sub Fetch { ... } );
265 }
266
267 1;
268
269=head1 DESCRIPTION
270
271This module provides an interface that allows filters to be applied
272to tied Hashes associated with DBM files. It builds on the DBM Filter
273hooks that are present in all the *DB*_File modules included with the
274standard Perl source distribution from version 5.6.1 onwards. In addition
275to the *DB*_File modules distributed with Perl, the BerkeleyDB module,
276available on CPAN, supports the DBM Filter hooks. See L<perldbmfilter>
277for more details on the DBM Filter hooks.
278
279=head1 What is a DBM Filter?
280
281A DBM Filter allows the keys and/or values in a tied hash to be modified
282by some user-defined code just before it is written to the DBM file and
283just after it is read back from the DBM file. For example, this snippet
284of code
285
286 $some_hash{"abc"} = 42;
287
288could potentially trigger two filters, one for the writing of the key
289"abc" and another for writing the value 42. Similarly, this snippet
290
291 my ($key, $value) = each %some_hash
292
293will trigger two filters, one for the reading of the key and one for
294the reading of the value.
295
296Like the existing DBM Filter functionality, this module arranges for the
297C<$_> variable to be populated with the key or value that a filter will
298check. This usually means that most DBM filters tend to be very short.
299
300=head2 So what's new?
301
302The main enhancements over the standard DBM Filter hooks are:
303
304=over 4
305
306=item *
307
308A cleaner interface.
309
310=item *
311
312The ability to easily apply multiple filters to a single DBM file.
313
314=item *
315
316The ability to create "canned" filters. These allow commonly used filters
317to be packaged into a stand-alone module.
318
319=back
320
321=head1 METHODS
322
323This module will arrange for the following methods to be available via
324the object returned from the C<tie> call.
325
2d51747b 326=head2 $db->Filter_Push() / $db->Filter_Key_Push() / $db->Filter_Value_Push()
0e9b1cbd
PM
327
328Add a filter to filter stack for the database, C<$db>. The three formats
329vary only in whether they apply to the DBM key, the DBM value or both.
330
331=over 5
332
333=item Filter_Push
334
335The filter is applied to I<both> keys and values.
336
337=item Filter_Key_Push
338
339The filter is applied to the key I<only>.
340
341=item Filter_Value_Push
342
343The filter is applied to the value I<only>.
344
345=back
346
347
348=head2 $db->Filter_Pop()
349
350Removes the last filter that was applied to the DBM file associated with
351C<$db>, if present.
352
353=head2 $db->Filtered()
354
355Returns TRUE if there are any filters applied to the DBM associated
356with C<$db>. Otherwise returns FALSE.
357
358
359
360=head1 Writing a Filter
361
362Filters can be created in two main ways
363
364=head2 Immediate Filters
365
366An immediate filter allows you to specify the filter code to be used
367at the point where the filter is applied to a dbm. In this mode the
368Filter_*_Push methods expects to receive exactly two parameters.
369
370 my $db = tie %hash, 'SDBM_File', ...
371 $db->Filter_Push( Store => sub { },
372 Fetch => sub { });
373
374The code reference associated with C<Store> will be called before any
375key/value is written to the database and the code reference associated
376with C<Fetch> will be called after any key/value is read from the
377database.
378
379For example, here is a sample filter that adds a trailing NULL character
380to all strings before they are written to the DBM file, and removes the
381trailing NULL when they are read from the DBM file
382
383 my $db = tie %hash, 'SDBM_File', ...
384 $db->Filter_Push( Store => sub { $_ .= "\x00" ; },
385 Fetch => sub { s/\x00$// ; });
386
387
388Points to note:
389
390=over 5
391
392=item 1.
393
394Both the Store and Fetch filters manipulate C<$_>.
395
396=back
397
398=head2 Canned Filters
399
400Immediate filters are useful for one-off situations. For more generic
401problems it can be useful to package the filter up in its own module.
402
403The usage is for a canned filter is:
404
405 $db->Filter_Push("name", params)
406
407where
408
409=over 5
410
411=item "name"
412
413is the name of the module to load. If the string specified does not
414contain the package separator characters "::", it is assumed to refer to
415the full module name "DBM_Filter::name". This means that the full names
416for canned filters, "null" and "utf8", included with this module are:
417
418 DBM_Filter::null
419 DBM_Filter::utf8
420
421=item params
422
423any optional parameters that need to be sent to the filter. See the
424encode filter for an example of a module that uses parameters.
425
426=back
427
428The module that implements the canned filter can take one of two
429forms. Here is a template for the first
430
431 package DBM_Filter::null ;
432
433 use strict;
434 use warnings;
435
436 sub Store
437 {
438 # store code here
439 }
440
441 sub Fetch
442 {
443 # fetch code here
444 }
445
446 1;
447
448
449Notes:
450
451=over 5
452
453=item 1.
454
455The package name uses the C<DBM_Filter::> prefix.
456
457=item 2.
458
459The module I<must> have both a Store and a Fetch method. If only one is
460present, or neither are present, a fatal error will be thrown.
461
462=back
463
464The second form allows the filter to hold state information using a
465closure, thus:
466
467 package DBM_Filter::encoding ;
468
469 use strict;
470 use warnings;
471
472 sub Filter
473 {
474 my @params = @_ ;
475
476 ...
477 return {
478 Store => sub { $_ = $encoding->encode($_) },
479 Fetch => sub { $_ = $encoding->decode($_) }
480 } ;
481 }
482
483 1;
484
485
486In this instance the "Store" and "Fetch" methods are encapsulated inside a
487"Filter" method.
488
489
490=head1 Filters Included
491
492A number of canned filers are provided with this module. They cover a
493number of the main areas that filters are needed when interfacing with
494DBM files. They also act as templates for your own filters.
495
496The filter included are:
497
498=over 5
499
500=item * utf8
501
502This module will ensure that all data written to the DBM will be encoded
503in UTF-8.
504
505This module needs the Encode module.
506
507=item * encode
508
509Allows you to choose the character encoding will be store in the DBM file.
510
511=item * compress
512
513This filter will compress all data before it is written to the database
514and uncompressed it on reading.
515
516This module needs Compress::Zlib.
517
518=item * int32
519
520This module is used when interoperating with a C/C++ application that
521uses a C int as either the key and/or value in the DBM file.
522
523=item * null
524
525This module ensures that all data written to the DBM file is null
526terminated. This is useful when you have a perl script that needs
527to interoperate with a DBM file that a C program also uses. A fairly
528common issue is for the C application to include the terminating null
529in a string when it writes to the DBM file. This filter will ensure that
530all data written to the DBM file can be read by the C application.
531
532=back
533
534=head1 NOTES
535
536=head2 Maintain Round Trip Integrity
537
538When writing a DBM filter it is I<very> important to ensure that it is
539possible to retrieve all data that you have written when the DBM filter
540is in place. In practice, this means that whatever transformation is
541applied to the data in the Store method, the I<exact> inverse operation
542should be applied in the Fetch method.
543
544If you don't provide an exact inverse transformation, you will find that
545code like this will not behave as you expect.
546
547 while (my ($k, $v) = each %hash)
548 {
549 ...
550 }
551
552Depending on the transformation, you will find that one or more of the
553following will happen
554
555=over 5
556
557=item 1
558
559The loop will never terminate.
560
561=item 2
562
563Too few records will be retrieved.
564
565=item 3
566
567Too many will be retrieved.
568
569=item 4
570
571The loop will do the right thing for a while, but it will unexpectedly fail.
572
573=back
574
575=head2 Don't mix filtered & non-filtered data in the same database file.
576
577This is just a restatement of the previous section. Unless you are
578completely certain you know what you are doing, avoid mixing filtered &
579non-filtered data.
580
581=head1 EXAMPLE
582
583Say you need to interoperate with a legacy C application that stores
584keys as C ints and the values and null terminated UTF-8 strings. Here
585is how you would set that up
586
587 my $db = tie %hash, 'SDBM_File', ...
588
589 $db->Filter_Key_Push('int32') ;
590
591 $db->Filter_Value_Push('utf8');
592 $db->Filter_Value_Push('null');
593
594=head1 SEE ALSO
595
596<DB_File>, L<GDBM_File>, L<NDBM_File>, L<ODBM_File>, L<SDBM_File>, L<perldbmfilter>
597
598=head1 AUTHOR
599
600Paul Marquess <pmqs@cpan.org>
601