MLDBM-2.05000755000000000000 012111363752 12623 5ustar00unknownunknown000000000000MLDBM-2.05/Build.PL000444000000000000 121012111363427 14245 0ustar00unknownunknown000000000000use strict; use Module::Build; #created by eumm-migrate.pl my $build = Module::Build->new( 'build_requires' => { 'Test::More' => 0 }, 'module_name' => 'MLDBM', 'requires' => { 'perl' => '5.005', 'Data::Dumper' => '2.08', 'Carp' => 0, }, 'meta_merge' => { 'resources' => { 'repository' => 'http://github.com/chorny/MLDBM/' } }, 'license' => 'perl', 'dist_version_from' => 'lib/MLDBM.pm', 'dist_author' => [ 'Gurusamy Sarathy ', 'Alexandr Ciornii (alexchorny@gmail.com)', ], 'auto_configure_requires' => 0, ); $build->create_build_script(); MLDBM-2.05/Changes000444000000000000 330512111363370 14250 0ustar00unknownunknown000000000000=head1 NAME HISTORY - public release history for MLDBM =head1 DESCRIPTION =over 8 =item 2.05 (21 Feb 2013, by Alexandr Ciornii) Require perl 5.5 Test for pod =item 2.04 (08 Mar 2010, by Alexandr Ciornii) Compatibility with old EU::MM. =item 2.03 (27 Feb 2010, by Alexandr Ciornii) Error in test fixed. =item 2.02 (19 Feb 2010, by Alexandr Ciornii) New tests added. Distribution upgraded =item 2.01 (07 July 2002) New testing method MLDBM::_compare($a, $b) used in t/*.t scripts to verify data structures are identical. In perl 5.8.0 RC2, the order of hashes changed, making the prior hard coded test case string comparisons invalid, so created this more flexible method for testing that should work in future releases, without relying on specific hash ordering. =item 2.00 (10 May 1998) Added support for multiple serializing interfaces. (courtesy Raphael Manfredi ) Split serializer wrappers into multiple files, and regularized the interface some. Underlying TIEHASH object and serializer can now be set at runtime (with care). Miscellaneous pod tweaks. =item 1.25 (7 December 1997) Add RemoveTaint flag. require 5.004. require Data::Dumper 2.08. =item 1.24 (29 October 1997) Version 1.23 was seriously busted, and had \r's. :-( =item 1.23 (26 July 1997) Fixes to avoid 'undefined value' messages. =item 1.22 (26 August 1996) Add EXISTS and CLEAR methods. Add a flag to control which underlying DBM is used. =item 1.21 (9 April 1996) Add flag to control which D::D method is used. =item 1.20 (16 February 1996) Earliest stable version I can remember. =back =cut MLDBM-2.05/Makefile.PL000444000000000000 276612111362552 14742 0ustar00unknownunknown000000000000use 5.005; use ExtUtils::MakeMaker; WriteMakefile1( NAME => "MLDBM", DISTNAME => "MLDBM", VERSION_FROM => 'lib/MLDBM.pm', PREREQ_PM => { 'Data::Dumper' => '2.08', 'Carp' => 0, }, BUILD_REQUIRES => { 'Test::More' => 0, }, 'dist' => {COMPRESS=>'gzip -9f', SUFFIX => 'gz'}, 'LICENSE' => 'perl', MIN_PERL_VERSION => '5.005', META_MERGE => { resources => { repository => 'http://github.com/chorny/MLDBM/', }, }, 'PL_FILES' => {}, ); sub WriteMakefile1 { #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade. my %params=@_; my $eumm_version=$ExtUtils::MakeMaker::VERSION; $eumm_version=eval $eumm_version; die "EXTRA_META is deprecated" if exists $params{EXTRA_META}; die "License not specified" if not exists $params{LICENSE}; if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) { #EUMM 6.5502 has problems with BUILD_REQUIRES $params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} }; delete $params{BUILD_REQUIRES}; } delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52; delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48; delete $params{META_MERGE} if $eumm_version < 6.46; delete $params{META_ADD} if $eumm_version < 6.46; delete $params{LICENSE} if $eumm_version < 6.31; delete $params{AUTHOR} if $] < 5.005; delete $params{ABSTRACT_FROM} if $] < 5.005; delete $params{BINARY_LOCATION} if $] < 5.005; WriteMakefile(%params); } MLDBM-2.05/MANIFEST000444000000000000 41412111363402 14060 0ustar00unknownunknown000000000000Changes README MANIFEST Makefile.PL Build.PL lib/MLDBM.pm lib/MLDBM/Serializer/Data/Dumper.pm lib/MLDBM/Serializer/FreezeThaw.pm lib/MLDBM/Serializer/Storable.pm t/compare.t t/dumper.t t/freezethaw.t t/storable.t t/storable_dbfile.t META.yml META.json MLDBM-2.05/META.json000444000000000000 316312111363752 14404 0ustar00unknownunknown000000000000{ "abstract" : "store multi-level Perl hash structure in single level tied hash", "author" : [ "Gurusamy Sarathy ", "Alexandr Ciornii (alexchorny@gmail.com)" ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4003, CPAN::Meta::Converter version 2.112621", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "MLDBM", "prereqs" : { "build" : { "requires" : { "Test::More" : 0 } }, "runtime" : { "requires" : { "Carp" : 0, "Data::Dumper" : "2.08", "perl" : "5.005" } } }, "provides" : { "MLDBM" : { "file" : "lib/MLDBM.pm", "version" : "2.05" }, "MLDBM::Serializer" : { "file" : "lib/MLDBM.pm", "version" : "2.05" }, "MLDBM::Serializer::Data::Dumper" : { "file" : "lib/MLDBM/Serializer/Data/Dumper.pm", "version" : 0 }, "MLDBM::Serializer::FreezeThaw" : { "file" : "lib/MLDBM/Serializer/FreezeThaw.pm", "version" : 0 }, "MLDBM::Serializer::Storable" : { "file" : "lib/MLDBM/Serializer/Storable.pm", "version" : 0 } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://github.com/chorny/MLDBM/" } }, "version" : "2.05" } MLDBM-2.05/META.yml000444000000000000 200112111363752 14222 0ustar00unknownunknown000000000000--- abstract: store multi-level Perl hash structure in single level tied hash author: - 'Gurusamy Sarathy ' - Alexandr Ciornii (alexchorny@gmail.com) build_requires: Test::More: 0 dynamic_config: 1 generated_by: 'Module::Build version 0.4003, CPAN::Meta::Converter version 2.112621' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: MLDBM provides: MLDBM: file: lib/MLDBM.pm version: 2.05 MLDBM::Serializer: file: lib/MLDBM.pm version: 2.05 MLDBM::Serializer::Data::Dumper: file: lib/MLDBM/Serializer/Data/Dumper.pm version: 0 MLDBM::Serializer::FreezeThaw: file: lib/MLDBM/Serializer/FreezeThaw.pm version: 0 MLDBM::Serializer::Storable: file: lib/MLDBM/Serializer/Storable.pm version: 0 requires: Carp: 0 Data::Dumper: 2.08 perl: 5.005 resources: license: http://dev.perl.org/licenses/ repository: http://github.com/chorny/MLDBM/ version: 2.05 MLDBM-2.05/README000444000000000000 455612111363361 13646 0ustar00unknownunknown000000000000This is the README file for MLDBM, the Perl module that can be used to store multidimensional hash structures in tied hashes (including DBM files). This is version 2.05. It requires Perl Version 5.5 or later. If you were able to install Data::Dumper with its XSUB extension, MLDBM will perform significantly faster. Optionally, you can also switch to other serializing packages such as FreezeThaw and Storable. Storable provides much greater speeds, and the performance of FreezeThaw is comparable to Data::Dumper. Support for this was added by Raphael Manfredi. Many thanks! See the embedded documentation in the module for more details. As always, feedback is very welcome. - Sarathy. gsar@umich.edu ---------------------------------------------------------------------- INSTALLATION You must install the Data::Dumper package first. Optionally, you may want to install one or more of Storable and FreezeThaw as well. (Storable-0.5@8 and FreezeThaw-0.3 have been tested, earlier versions may not work.) From the MLDBM source directory: perl Makefile.PL make test make install is all that will be needed. ---------------------------------------------------------------------- CHANGES 2.05 (21 Feb 2013, by Alexandr Ciornii) Require perl 5.5 Test for pod 2.04 (08 Mar 2010, by Alexandr Ciornii) Compatibility with old EU::MM. 2.03 (27 Feb 2010, by Alexandr Ciornii) Test fixed. 2.02 (19 Feb 2010, by Alexandr Ciornii) New tests added. Distribution upgraded 2.01 (07 July 2002) Fixed t/*.t tests to work under perl 5.8.0 RC2 The core of MLDBM was working, the tests were fixed. (courtesy of Josh Chamas) 2.00 (10 May 1998) Added support for multiple serializing interfaces. (courtesy Raphael Manfredi ) Split serializer wrappers into multiple files, and regularized the interface some. Underlying TIEHASH object and serializer can now be set at runtime (with care). Miscellaneous pod tweaks. 1.25 (7 December 1997) Add RemoveTaint flag. require 5.004. require Data::Dumper 2.08. MLDBM-2.05/lib000755000000000000 012111363752 13371 5ustar00unknownunknown000000000000MLDBM-2.05/lib/MLDBM.pm000444000000000000 4032212111363221 14727 0ustar00unknownunknown000000000000# # MLDBM.pm # # store multi-level hash structure in single level tied hash (read DBM) # # Documentation at the __END__ # # Gurusamy Sarathy # Raphael Manfredi # require 5.005; use strict; #################################################################### package MLDBM::Serializer; ## deferred $MLDBM::Serializer::VERSION = $MLDBM::Serializer::VERSION = '2.05'; use Carp; # # The serialization interface comprises of just three methods: # new(), serialize() and deserialize(). Only the last two are # _required_ to be implemented by any MLDBM serialization wrapper. # sub new { bless {}, shift }; sub serialize { confess "deferred" }; sub deserialize { confess "deferred" }; # # Attributes: # # dumpmeth: # the preferred dumping method. # # removetaint: # untainting flag; when true, data will be untainted after # extraction from the database. # # key: # the magic string used to recognize non-natively stored data. # # Attribute access methods: # # These defaults allow readonly access. Sub-class may override # them to allow write access if any of these attributes # makes sense for it. # sub DumpMeth { my $s = shift; confess "can't set dumpmeth with " . ref($s) if @_; $s->_attrib('dumpmeth'); } sub RemoveTaint { my $s = shift; confess "can't set untaint with " . ref($s) if @_; $s->_attrib('removetaint'); } sub Key { my $s = shift; confess "can't set key with " . ref($s) if @_; $s->_attrib('key'); } sub _attrib { my ($s, $a, $v) = @_; if (ref $s and @_ > 2) { $s->{$a} = $v; return $s; } $s->{$a}; } #################################################################### package MLDBM; $MLDBM::VERSION = $MLDBM::VERSION = '2.05'; require Tie::Hash; @MLDBM::ISA = 'Tie::Hash'; use Carp; # # the DB package to use (we default to SDBM since it comes with perl) # you might want to change this default to something more efficient # like DB_File (you can always override it in the use list) # $MLDBM::UseDB = "SDBM_File" unless $MLDBM::UseDB; $MLDBM::Serializer = 'Data::Dumper' unless $MLDBM::Serializer; $MLDBM::Key = '$MlDbM' unless $MLDBM::Key; $MLDBM::DumpMeth = "" unless $MLDBM::DumpMeth; $MLDBM::RemoveTaint = 0 unless $MLDBM::RemoveTaint; # # A private way to load packages at runtime. my $loadpack = sub { my $pack = shift; $pack =~ s|::|/|g; $pack .= ".pm"; eval { require $pack }; if ($@) { carp "MLDBM error: " . "Please make sure $pack is a properly installed package.\n" . "\tPerl says: \"$@\""; return undef; } 1; }; # # TIEHASH interface methods # sub TIEHASH { my $c = shift; my $s = bless {}, $c; # # Create the right serializer object. my $szr = $MLDBM::Serializer; unless (ref $szr) { $szr = "MLDBM::Serializer::$szr" # allow convenient short names unless $szr =~ /^MLDBM::Serializer::/; $loadpack->($szr) or return undef; $szr = $szr->new($MLDBM::DumpMeth, $MLDBM::RemoveTaint, $MLDBM::Key); } $s->Serializer($szr); # # Create the right TIEHASH object. my $db = $MLDBM::UseDB; unless (ref $db) { $loadpack->($db) or return undef; $db = $db->TIEHASH(@_) or carp "MLDBM error: Second level tie failed, \"$!\"" and return undef; } $s->UseDB($db); return $s; } sub FETCH { my ($s, $k) = @_; my $ret = $s->{DB}->FETCH($k); $s->{SR}->deserialize($ret); } sub STORE { my ($s, $k, $v) = @_; $v = $s->{SR}->serialize($v); $s->{DB}->STORE($k, $v); } sub DELETE { my $s = shift; $s->{DB}->DELETE(@_); } sub FIRSTKEY { my $s = shift; $s->{DB}->FIRSTKEY(@_); } sub NEXTKEY { my $s = shift; $s->{DB}->NEXTKEY(@_); } sub EXISTS { my $s = shift; $s->{DB}->EXISTS(@_); } sub CLEAR { my $s = shift; $s->{DB}->CLEAR(@_); } sub new { &TIEHASH } # # delegate messages to the underlying DBM # sub AUTOLOAD { return if $MLDBM::AUTOLOAD =~ /::DESTROY$/; my $s = shift; if (ref $s) { # twas a method call my $dbname = ref($s->{DB}); # permit inheritance $MLDBM::AUTOLOAD =~ s/^.*::([^:]+)$/$dbname\:\:$1/; $s->{DB}->$MLDBM::AUTOLOAD(@_); } } # # delegate messages to the underlying Serializer # sub DumpMeth { my $s = shift; $s->{SR}->DumpMeth(@_); } sub RemoveTaint { my $s = shift; $s->{SR}->RemoveTaint(@_); } sub Key { my $s = shift; $s->{SR}->Key(@_); } # # get/set the DB object # sub UseDB { my $s = shift; @_ ? ($s->{DB} = shift) : $s->{DB}; } # # get/set the Serializer object # sub Serializer { my $s = shift; @_ ? ($s->{SR} = shift) : $s->{SR}; } # # stuff to do at 'use' time # sub import { my ($pack, $dbpack, $szr, $dumpmeth, $removetaint, $key) = @_; $MLDBM::UseDB = $dbpack if defined $dbpack and $dbpack; $MLDBM::Serializer = $szr if defined $szr and $szr; # undocumented, may change! $MLDBM::DumpMeth = $dumpmeth if defined $dumpmeth; $MLDBM::RemoveTaint = $removetaint if defined $removetaint; $MLDBM::Key = $key if defined $key and $key; } # helper subroutine for tests to compare to arbitrary data structures # for equivalency sub _compare { use vars qw(%compared); local %compared; return _cmp(@_); } sub _cmp { my($a, $b) = @_; # catch circular loops return(1) if $compared{$a.'&*&*&*&*&*'.$b}++; # print "$a $b\n"; # print &Data::Dumper::Dumper($a, $b); if(ref($a) and ref($a) eq ref($b)) { if(eval { @$a }) { # print "HERE ".@$a." ".@$b."\n"; @$a == @$b or return 0; # print @$a, ' ', @$b, "\n"; # print "HERE2\n"; for(0..@$a-1) { &_cmp($a->[$_], $b->[$_]) or return 0; } } elsif(eval { %$a }) { keys %$a == keys %$b or return 0; for (keys %$a) { &_cmp($a->{$_}, $b->{$_}) or return 0; } } elsif(eval { $$a }) { &_cmp($$a, $$b) or return 0; } else { die("data $a $b not handled"); } return 1; } elsif(! ref($a) and ! ref($b)) { return ($a eq $b); } else { return 0; } } 1; __END__ =head1 NAME MLDBM - store multi-level Perl hash structure in single level tied hash =head1 SYNOPSIS use MLDBM; # this gets the default, SDBM #use MLDBM qw(DB_File FreezeThaw); # use FreezeThaw for serializing #use MLDBM qw(DB_File Storable); # use Storable for serializing $dbm = tie %o, 'MLDBM' [..other DBM args..] or die $!; =head1 DESCRIPTION This module can serve as a transparent interface to any TIEHASH package that is required to store arbitrary perl data, including nested references. Thus, this module can be used for storing references and other arbitrary data within DBM databases. It works by serializing the references in the hash into a single string. In the underlying TIEHASH package (usually a DBM database), it is this string that gets stored. When the value is fetched again, the string is deserialized to reconstruct the data structure into memory. For historical and practical reasons, it requires the B package, available at any CPAN site. B gives you really nice-looking dumps of your data structures, in case you wish to look at them on the screen, and it was the only serializing engine before version 2.00. However, as of version 2.00, you can use any of B, B or B to perform the underlying serialization, as hinted at by the L overview above. Using B is usually much faster than the other methods. See the L section for important limitations. =head2 Changing the Defaults B relies on an underlying TIEHASH implementation (usually a DBM package), and an underlying serialization package. The respective defaults are B and B. Both of these defaults can be changed. Changing the B default is strongly recommended. See L below. Three serialization wrappers are currently supported: B, B, and B. Additional serializers can be supported by writing a wrapper that implements the interface required by B. See the supported wrappers and the B source for details. In the following, I<$OBJ> stands for the tied object, as in: $obj = tie %o, .... $obj = tied %o; =over 4 =item $MLDBM::UseDB I I<$OBJ>->UseDB(I<[TIEDOBJECT]>) The global C<$MLDBM::UseDB> can be set to default to something other than C, in case you have a more efficient DBM, or if you want to use this with some other TIEHASH implementation. Alternatively, you can specify the name of the package at C time, as the first "parameter". Nested module names can be specified as "Foo::Bar". The corresponding method call returns the underlying TIEHASH object when called without arguments. It can be called with any object that implements Perl's TIEHASH interface, to set that value. =item $MLDBM::Serializer I I<$OBJ>->Serializer(I<[SZROBJECT]>) The global C<$MLDBM::Serializer> can be set to the name of the serializing package to be used. Currently can be set to one of C, C, or C. Defaults to C. Alternatively, you can specify the name of the serializer package at C time, as the second "parameter". The corresponding method call returns the underlying MLDBM serializer object when called without arguments. It can be called with an object that implements the MLDBM serializer interface, to set that value. =back =head2 Controlling Serializer Properties These methods are meant to supply an interface to the properties of the underlying serializer used. Do B call or set them without understanding the consequences in full. The defaults are usually sensible. Not all of these necessarily apply to all the supplied serializers, so we specify when to apply them. Failure to respect this will usually lead to an exception. =over 4 =item $MLDBM::DumpMeth I I<$OBJ>->DumpMeth(I<[METHNAME]>) If the serializer provides alternative serialization methods, this can be used to set them. With B (which offers a pure Perl and an XS verion of its serializing routine), this is set to C by default if that is supported in your installation. Otherwise, defaults to the slower C method. With B, a value of C requests that serialization be architecture neutral, i.e. the deserialization can later occur on another platform. Of course, this only makes sense if your database files are themselves architecture neutral. By default, native format is used for greater serializing speed in B. Both B and B are always architecture neutral. B does not honor this attribute. =item $MLDBM::Key I I<$OBJ>->Key(I<[KEYSTRING]>) If the serializer only deals with part of the data (perhaps because the TIEHASH object can natively store some types of data), it may need a unique key string to recognize the data it handles. This can be used to set that string. Best left alone. Defaults to the magic string used to recognize MLDBM data. It is a six character wide, unique string. This is best left alone, unless you know what you are doing. B and B do not honor this attribute. =item $MLDBM::RemoveTaint I I<$OBJ>->RemoveTaint(I<[BOOL]>) If the serializer can optionally untaint any retrieved data subject to taint checks in Perl, this can be used to request that feature. Data that comes from external sources (like disk-files) must always be viewed with caution, so use this only when you are sure that that is not an issue. B uses C to deserialize and is therefore subject to taint checks. Can be set to a true value to make the B serializer untaint the data retrieved. It is not enabled by default. Use with care. B and B do not honor this attribute. =back =head1 EXAMPLES Here is a simple example. Note that does not depend upon the underlying serializing package--most real life examples should not, usually. use MLDBM; # this gets SDBM and Data::Dumper #use MLDBM qw(SDBM_File Storable); # SDBM and Storable use Fcntl; # to get 'em constants $dbm = tie %o, 'MLDBM', 'testmldbm', O_CREAT|O_RDWR, 0640 or die $!; $c = [\ 'c']; $b = {}; $a = [1, $b, $c]; $b->{a} = $a; $b->{b} = $a->[1]; $b->{c} = $a->[2]; @o{qw(a b c)} = ($a, $b, $c); # # to see what was stored # use Data::Dumper; print Data::Dumper->Dump([@o{qw(a b c)}], [qw(a b c)]); # # to modify data in a substructure # $tmp = $o{a}; $tmp->[0] = 'foo'; $o{a} = $tmp; # # can access the underlying DBM methods transparently # #print $dbm->fd, "\n"; # DB_File method Here is another small example using Storable, in a portable format: use MLDBM qw(DB_File Storable); # DB_File and Storable tie %o, 'MLDBM', 'testmldbm', O_CREAT|O_RDWR, 0640 or die $!; (tied %o)->DumpMeth('portable'); # Ask for portable binary $o{'ENV'} = \%ENV; # Stores the whole environment =head1 BUGS =over 4 =item 1. Adding or altering substructures to a hash value is not entirely transparent in current perl. If you want to store a reference or modify an existing reference value in the DBM, it must first be retrieved and stored in a temporary variable for further modifications. In particular, something like this will NOT work properly: $mldb{key}{subkey}[3] = 'stuff'; # won't work Instead, that must be written as: $tmp = $mldb{key}; # retrieve value $tmp->{subkey}[3] = 'stuff'; $mldb{key} = $tmp; # store value This limitation exists because the perl TIEHASH interface currently has no support for multidimensional ties. =item 2. The B serializer uses eval(). A lot. Try the B serializer, which is generally the most efficient. =back =head1 WARNINGS =over 4 =item 1. Many DBM implementations have arbitrary limits on the size of records that can be stored. For example, SDBM and many ODBM or NDBM implementations have a default limit of 1024 bytes for the size of a record. MLDBM can easily exceed these limits when storing large data structures, leading to mysterious failures. Although SDBM_File is used by MLDBM by default, it is not a good choice if you're storing large data structures. Berkeley DB and GDBM both do not have these limits, so I recommend using either of those instead. =item 2. MLDBM does well with data structures that are not too deep and not too wide. You also need to be careful about how many Ces your code actually ends up doing. Meaning, you should get the most mileage out of a C by holding on to the highest level value for as long as you need it. Remember that every toplevel access of the tied hash, for example C<$mldb{foo}>, translates to a MLDBM C call. Too often, people end up writing something like this: tie %h, 'MLDBM', ...; for my $k (keys %{$h{something}}) { print $h{something}{$k}[0]{foo}{bar}; # FETCH _every_ time! } when it should be written this for efficiency: tie %h, 'MLDBM', ...; my $root = $h{something}; # FETCH _once_ for my $k (keys %$root) { print $k->[0]{foo}{bar}; } =back =head1 AUTHORS Gurusamy Sarathy >. Support for multiple serializing packages by Raphael Manfredi >. Test suite fixes for perl 5.8.0 done by Josh Chamas. Copyright (c) 1995-98 Gurusamy Sarathy. All rights reserved. Copyright (c) 1998 Raphael Manfredi. Copyright (c) 2002 Josh Chamas, Chamas Enterprises Inc. Copyright (c) 2010-2013 Alexandr Ciornii (alexchorny@gmail.com). This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 VERSION Version 2.05 =head1 SEE ALSO perl(1), perltie(1), perlfunc(1), L, L, L, L, L. =cut MLDBM-2.05/lib/MLDBM000755000000000000 012111363752 14224 5ustar00unknownunknown000000000000MLDBM-2.05/lib/MLDBM/Serializer000755000000000000 012111363752 16335 5ustar00unknownunknown000000000000MLDBM-2.05/lib/MLDBM/Serializer/FreezeThaw.pm000444000000000000 53711330604552 21057 0ustar00unknownunknown000000000000#################################################################### package MLDBM::Serializer::FreezeThaw; BEGIN { @MLDBM::Serializer::FreezeThaw::ISA = qw(MLDBM::Serializer) } use FreezeThaw; sub serialize { return FreezeThaw::freeze($_[1]); } sub deserialize { my ($obj) = FreezeThaw::thaw($_[1]); return $obj; } 1; MLDBM-2.05/lib/MLDBM/Serializer/Storable.pm000444000000000000 163211330604552 20603 0ustar00unknownunknown000000000000#################################################################### package MLDBM::Serializer::Storable; BEGIN { @MLDBM::Serializer::Storable::ISA = qw(MLDBM::Serializer) } use Storable; sub new { my $self = shift->SUPER::new(); $self->DumpMeth(shift); # Storable doesn't honor other attributes $self; } # # Serialize a reference to supplied value # sub serialize { my $self = shift; my $dumpmeth = $self->{'_dumpsub_'}; &$dumpmeth(\$_[0]); } # # Deserialize and de-reference # sub deserialize { my $obj = Storable::thaw($_[1]); # Does not care whether portable defined($obj) ? $$obj : undef; } # # Change dump method when portability is requested # sub DumpMeth { my $self = shift; $self->{'_dumpsub_'} = ($_[0] && $_[0] eq 'portable' ? \&Storable::nfreeze : \&Storable::freeze); $self->_attrib('dumpmeth', @_); } 1; MLDBM-2.05/lib/MLDBM/Serializer/Data000755000000000000 012111363752 17206 5ustar00unknownunknown000000000000MLDBM-2.05/lib/MLDBM/Serializer/Data/Dumper.pm000444000000000000 377311330604552 21145 0ustar00unknownunknown000000000000#################################################################### package MLDBM::Serializer::Data::Dumper; BEGIN { @MLDBM::Serializer::Data::Dumper::ISA = qw(MLDBM::Serializer) } use Data::Dumper '2.08'; # Backward compatibility use Carp; # # Create a Data::Dumper serializer object. # sub new { my $self = shift->SUPER::new(); my $meth = shift || ""; $meth = (defined(&Data::Dumper::Dumpxs) ? 'Dumpxs' : 'Dump') unless $meth =~ /^Dump(xs)?$/; $self->DumpMeth($meth); $self->RemoveTaint(shift); $self->Key(shift); $self; } # # Serialize $val if it is a reference, or if it does begin with our magic # key string, since then at retrieval time we expect a Data::Dumper string. # Otherwise, return the scalar value. # sub serialize { my $self = shift; my ($val) = @_; return undef unless defined $val; return $val unless ref($val) or $val =~ m|^\Q$self->{'key'}|o; my $dumpmeth = $self->{'dumpmeth'}; local $Data::Dumper::Indent = 0; local $Data::Dumper::Purity = 1; local $Data::Dumper::Terse = 1; return $self->{'key'} . Data::Dumper->$dumpmeth([$val], ['M']); } # # If the value is undefined or does not begin with our magic key string, # return it as-is. Otherwise, we need to recover the underlying data structure. # sub deserialize { my $self = shift; my ($val) = @_; return undef unless defined $val; return $val unless $val =~ s|^\Q$self->{'key'}||o; my $M = ""; ($val) = $val =~ /^(.*)$/s if $self->{'removetaint'}; # Disambiguate hashref (perl may treat it as a block) my $N = eval($val =~ /^\{/ ? '+'.$val : $val); return $M ? $M : $N unless $@; carp "MLDBM error: $@\twhile evaluating:\n $val"; } sub DumpMeth { my $s = shift; $s->_attrib('dumpmeth', @_); } sub RemoveTaint { my $s = shift; $s->_attrib('removetaint', @_); } sub Key { my $s = shift; $s->_attrib('key', @_); } # avoid used only once warnings { local $Data::Dumper::Terse; } 1; MLDBM-2.05/t000755000000000000 012111363752 13066 5ustar00unknownunknown000000000000MLDBM-2.05/t/compare.t000444000000000000 154611330604552 15042 0ustar00unknownunknown000000000000 use MLDBM; my $c = 'c'; my $d = 'd'; my $data = { a => 1, b => [0,1], c => \$c }; $data->{recurse} = $data; my $err_array = { a => 1, b => [0,2], c => \$c }; $err_array->{recurse} = $err_array; my $err_hash = { a => 2, b => [0,1], c => \$c }; $err_hash->{recurse} = $err_hash; my $err_scalar = { a => 1, b => [0,1], c => \$d }; $err_scalar->{recurse} = $err_scalar; my $err_recurse = { a => 1, b => [0,1], c => \$c }; $err_recurse->{recurse} = {}; print "1..6\n"; for ($err_array, $err_hash, $err_scalar, $err_recurse) { if(! &MLDBM::_compare($data, $_)) { print "ok\n"; } else { print "not ok\n"; } } my $data_ok = { a => 1, b => [0,1], c => \$c }; $data_ok->{recurse} = $data; for ($data, $data_ok) { if(&MLDBM::_compare($data, $_)) { print "ok\n"; } else { print "not ok\n"; } } MLDBM-2.05/t/dumper.t000444000000000000 140611330604552 14703 0ustar00unknownunknown000000000000#!/usr/bin/perl -w use Fcntl; use MLDBM; use Data::Dumper; use MLDBM; use strict; tie my %o, 'MLDBM', 'testmldbm', O_CREAT|O_RDWR, 0640 or die $!; print "1..4\n"; my $c_scalar = 'c'; my $c = [\$c_scalar]; $b = {}; $a = [1, $b, $c]; $b->{a} = $a; $b->{b} = $a->[1]; $b->{c} = $a->[2]; @o{qw(a b c)} = ($a, $b, $c); $o{d} = "{once upon a time}"; $o{e} = 1024; $o{f} = 1024.1024; my $struct = [@o{qw(a b c)}]; my $first_compare = &MLDBM::_compare([ $a, $b, $c ], $struct); if ($first_compare) { print "ok 1\n" } else { print "not ok\n" } print ($o{d} eq "{once upon a time}" ? "ok 2\n" : "# |$o{d}|\nnot ok 2\n"); print ($o{e} == 1024 ? "ok 3\n" : "# |$o{e}|\nnot ok 3\n"); print ($o{f} eq 1024.1024 ? "ok 4\n" : "# |$o{f}|\nnot ok 4\n"); MLDBM-2.05/t/freezethaw.t000444000000000000 156612110013666 15557 0ustar00unknownunknown000000000000#!/usr/bin/perl -w use Fcntl; use MLDBM qw(SDBM_File FreezeThaw); use Data::Dumper; use strict; eval { require FreezeThaw }; if ($@) { print "1..0 # SKIP Optional module (FreezeThaw) not installed\n"; exit 0; } tie my %o, 'MLDBM', 'testmldbm', O_CREAT|O_RDWR, 0640 or die $!; print "1..4\n"; my $c_scalar = 'c'; my $c = [\$c_scalar]; my $b = {}; my $a = [1, $b, $c]; $b->{a} = $a; $b->{b} = $a->[1]; $b->{c} = $a->[2]; @o{qw(a b c)} = ($a, $b, $c); $o{d} = "{once upon a time}"; $o{e} = 1024; $o{f} = 1024.1024; my $compare_ok = &MLDBM::_compare([ @o{qw(a b c)} ], [ $a, $b, $c ]); if ($compare_ok) { print "ok 1\n" } else { print "not ok 1\n" } print ($o{d} eq "{once upon a time}" ? "ok 2\n" : "# |$o{d}|\nnot ok 2\n"); print ($o{e} == 1024 ? "ok 3\n" : "# |$o{e}|\nnot ok 3\n"); print ($o{f} eq 1024.1024 ? "ok 4\n" : "# |$o{f}|\nnot ok 4\n"); MLDBM-2.05/t/storable.t000444000000000000 307610703450402 15223 0ustar00unknownunknown000000000000#!/usr/bin/perl -w use Fcntl; use MLDBM qw(SDBM_File Storable); use Data::Dumper; use strict; use Test::More tests => 9; plan skip_all => "Optional module (Storable) not installed" unless eval { require Storable; }; tie my %o, 'MLDBM', 'testmldbm', O_CREAT|O_RDWR, 0640 or die $!; my $c_scalar = 'c'; my $c = [\$c_scalar]; my $b = {}; my $a = [1, $b, $c]; $b->{a} = $a; $b->{b} = $a->[1]; $b->{c} = $a->[2]; @o{qw(a b c)} = ($a, $b, $c); $o{d} = "{once upon a time}"; $o{e} = 1024; $o{f} = 1024.1024; my $compare_ok = &MLDBM::_compare([ @o{qw(a b c)} ], [ $a, $b, $c ]); ok($compare_ok); is($o{d},"{once upon a time}"); is($o{e},1024); is($o{f},1024.1024); #print ( ? "ok 2\n" : "# |$o{d}|\nnot ok 2\n"); #print ($o{e} == 1024 ? "ok 3\n" : "# |$o{e}|\nnot ok 3\n"); #print ($o{f} eq 1024.1024 ? "ok 4\n" : "# |$o{f}|\nnot ok 4\n"); # NEW TEST SEQUENCE untie %o; my $obj = tie %o, 'MLDBM', 'testmldbm', O_CREAT|O_RDWR, 0640 or die $!; $obj->DumpMeth('portable'); $c = [\$c_scalar]; $b = {}; $a = [1, $b, $c]; $b->{a} = $a; $b->{b} = $a->[1]; $b->{c} = $a->[2]; @o{qw(a b c)} = ($a, $b, $c); $o{d} = "{once upon a time}"; $o{e} = 1024; $o{f} = 1024.1024; $compare_ok = &MLDBM::_compare([ @o{qw(a b c)} ], [ $a, $b, $c]); ok($compare_ok); is($o{d},"{once upon a time}"); is($o{e},1024); is($o{f},1024.1024); #print ($o{d} eq "{once upon a time}" ? "ok 6\n" : "# |$o{d}|\nnot ok 6\n"); #print ($o{e} == 1024 ? "ok 7\n" : "# |$o{e}|\nnot ok 7\n"); #print ($o{f} eq 1024.1024 ? "ok 8\n" : "# |$o{f}|\nnot ok 8\n"); my $d=[17]; $o{g}=$d; $d=''; is($o{g}->[0],17); MLDBM-2.05/t/storable_dbfile.t000444000000000000 315311342055104 16524 0ustar00unknownunknown000000000000#!/usr/bin/perl -w use Fcntl; use MLDBM qw(DB_File Storable); use Data::Dumper; use strict; use Test::More; plan skip_all => "Optional module (DB_File,Storable) not installed" unless eval { require Storable; require DB_File; }; plan tests => 9; tie my %o, 'MLDBM', 'testmldbm', O_CREAT|O_RDWR, 0640 or die $!; my $c_scalar = 'c'; my $c = [\$c_scalar]; my $b = {}; my $a = [1, $b, $c]; $b->{a} = $a; $b->{b} = $a->[1]; $b->{c} = $a->[2]; @o{qw(a b c)} = ($a, $b, $c); $o{d} = "{once upon a time}"; $o{e} = 1024; $o{f} = 1024.1024; my $compare_ok = &MLDBM::_compare([ @o{qw(a b c)} ], [ $a, $b, $c ]); ok($compare_ok); is($o{d},"{once upon a time}"); is($o{e},1024); is($o{f},1024.1024); #print ( ? "ok 2\n" : "# |$o{d}|\nnot ok 2\n"); #print ($o{e} == 1024 ? "ok 3\n" : "# |$o{e}|\nnot ok 3\n"); #print ($o{f} eq 1024.1024 ? "ok 4\n" : "# |$o{f}|\nnot ok 4\n"); # NEW TEST SEQUENCE untie %o; my $obj = tie %o, 'MLDBM', 'testmldbm', O_CREAT|O_RDWR, 0640 or die $!; $obj->DumpMeth('portable'); $c = [\$c_scalar]; $b = {}; $a = [1, $b, $c]; $b->{a} = $a; $b->{b} = $a->[1]; $b->{c} = $a->[2]; @o{qw(a b c)} = ($a, $b, $c); $o{d} = "{once upon a time}"; $o{e} = 1024; $o{f} = 1024.1024; $compare_ok = &MLDBM::_compare([ @o{qw(a b c)} ], [ $a, $b, $c]); ok($compare_ok); is($o{d},"{once upon a time}"); is($o{e},1024); is($o{f},1024.1024); #print ($o{d} eq "{once upon a time}" ? "ok 6\n" : "# |$o{d}|\nnot ok 6\n"); #print ($o{e} == 1024 ? "ok 7\n" : "# |$o{e}|\nnot ok 7\n"); #print ($o{f} eq 1024.1024 ? "ok 8\n" : "# |$o{f}|\nnot ok 8\n"); my $d=[17]; $o{g}=$d; $d=''; is($o{g}->[0],17);