DBM-Deep-2.0013000755001750001750 012641624315 11607 5ustar00robrob000000000000DBM-Deep-2.0013/META.yml000444001750001750 510612641624315 13217 0ustar00robrob000000000000--- abstract: 'A pure perl multi-level hash/array DBM that supports transactions' author: - unknown build_requires: File::Path: '0.01' File::Temp: '0.01' Pod::Usage: '1.3' Test::Deep: '0.095' Test::Exception: '0.21' Test::More: '0.88' Test::Warn: '0.08' configure_requires: Module::Build: '0.42' dynamic_config: 1 generated_by: 'Module::Build version 0.4214, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: DBM-Deep no_index: directory: - utils provides: DBM::Deep: file: lib/DBM/Deep.pm version: '2.0013' DBM::Deep::Array: file: lib/DBM/Deep/Array.pm DBM::Deep::Engine: file: lib/DBM/Deep/Engine.pm DBM::Deep::Engine::DBI: file: lib/DBM/Deep/Engine/DBI.pm DBM::Deep::Engine::File: file: lib/DBM/Deep/Engine/File.pm DBM::Deep::Hash: file: lib/DBM/Deep/Hash.pm DBM::Deep::Iterator: file: lib/DBM/Deep/Iterator.pm DBM::Deep::Iterator::DBI: file: lib/DBM/Deep/Iterator/DBI.pm DBM::Deep::Iterator::File: file: lib/DBM/Deep/Iterator/File.pm DBM::Deep::Iterator::File::BucketList: file: lib/DBM/Deep/Iterator/File/BucketList.pm DBM::Deep::Iterator::File::Index: file: lib/DBM/Deep/Iterator/File/Index.pm DBM::Deep::Null: file: lib/DBM/Deep/Null.pm DBM::Deep::Sector: file: lib/DBM/Deep/Sector.pm DBM::Deep::Sector::DBI: file: lib/DBM/Deep/Sector/DBI.pm DBM::Deep::Sector::DBI::Reference: file: lib/DBM/Deep/Sector/DBI/Reference.pm DBM::Deep::Sector::DBI::Scalar: file: lib/DBM/Deep/Sector/DBI/Scalar.pm DBM::Deep::Sector::File: file: lib/DBM/Deep/Sector/File.pm DBM::Deep::Sector::File::BucketList: file: lib/DBM/Deep/Sector/File/BucketList.pm DBM::Deep::Sector::File::Data: file: lib/DBM/Deep/Sector/File/Data.pm DBM::Deep::Sector::File::Index: file: lib/DBM/Deep/Sector/File/Index.pm DBM::Deep::Sector::File::Null: file: lib/DBM/Deep/Sector/File/Null.pm DBM::Deep::Sector::File::Reference: file: lib/DBM/Deep/Sector/File/Reference.pm DBM::Deep::Sector::File::Scalar: file: lib/DBM/Deep/Sector/File/Scalar.pm DBM::Deep::Storage: file: lib/DBM/Deep/Storage.pm DBM::Deep::Storage::DBI: file: lib/DBM/Deep/Storage/DBI.pm DBM::Deep::Storage::File: file: lib/DBM/Deep/Storage/File.pm requires: Digest::MD5: '1.00' Fcntl: '0.01' Scalar::Util: '1.14' perl: 5.008_004 resources: license: http://dev.perl.org/licenses/ repository: https://github.com/robkinyon/dbm-deep version: '2.0013' x_serialization_backend: 'CPAN::Meta::YAML version 0.016' DBM-Deep-2.0013/Changes000444001750001750 6374612641624315 13277 0ustar00robrob000000000000Revision history for DBM::Deep (ordered by revision number). 2.0013 Jan 01 20:30:00 2016 EDT - Updates to documentation by garu (Thanks!, GH#14, GH#15, GH#16) 2.0012 Jun 17 20:30:00 2015 PDT - Improved transaction validation and warnings (GH#12) 2.0011 Jan 12 16:00:00 2013 PDT - POD fixes by H. Merijn Brandt (The X<> tag - Thanks!) 2.0009 Jun 30 13:00:00 2013 PDT - Can push undefined values onto arrays. 2.0008 Jun 17 13:00:00 2012 PDT - Arrays and hashes retrieved from a database no longer create circular references (RT#77746). 2.0007 May 27 19:35:00 2012 PDT - Include one-line descriptions of each POD page after the name. Thanks to Yves Agostini for the patch and Gregor Herrmann for submitting it (RT#76378). - t/98_pod.t: Skip tests if Pod::Simple 3.21 is installed (RT#77419). 2.0006 Apr 1 17:15:00 2012 PDT - Er, try harder to get t/27_filehandle.t to work under TB2. The extra ‘TAP version 13’ line was causing a TAP parse error. 2.0005 Mar 25 13:05:00 2012 PDT - t/27_filehandle.t has been fixed again. It no longer violates Test::Builder’s encapsulation. 2.0004 Sep 12 18:38:00 2010 PDT - t/27_filehandle.t has been fixed to work with Test::More 2. 2.0003 Sep 12 12:02:00 2010 PDT - t/43_transaction_maximum.t has been fixed. It was broken in the previous release for systems that will only open so many files. 2.0002 Sep 5 12:35:00 2010 PDT - Error messages from DBM::Deep now use the caller’s file name. They used incorrectly to use the name of the program ($0). - begin_work now checks correctly to see whether the new transac- tion exceeds the number the file was created to support. Some- times it would allow a few more transactions, and then proceed to corrupt the database (RT#60903). - The description of the file header in DBM::Deep::Internals has been brought up to date. 2.0001 Aug 22 12:03:00 2010 PDT - Simply reading a hash or array element no longer causes autoviv- ification. (Dereferencing it does still.) This makes DBM::Deep comply with Perl’s behaviour (RT#60391). 2.0000 Jul 18 14:30:00 2010 PDT - THIS VERSION IS NOT FULLY COMPATIBLE WITH 1.002x. - This version is practically identical to the previous dev release. See 1.9999_01, below, for all the hype. - Also, a memory leak caused by misuse of field hashes has been fixed. - perl 5.8.4 is now required. 1.9999_02 Jul 11 13:02:00 2010 PDT (This is the second developer release for 2.0000.) - Fixed a broken test - Fixed compilation and overloading under perl 5.8.x 1.9999_01 Jun 27 14:22:00 2010 PDT (This is the first developer release for 2.0000.) - THIS VERSION CHANGES THE FILE FORMAT. - Databases from DBM::Deep 1.0003 and higher can still be opened. - Newly-created databases automatically use the version 2.x format (numbered 4 internally), which version 1.x cannot open. - The optimize method, since it copies everything to a new database, upgrades it. - There is a new db_version method. - Support for perl 5.6 has been dropped. We now require 5.8. 5.6 users can still use version 1.0025. If anyone really needs 5.6 support in version 2.x, we can add it back again, but would pre- fer not to. Bug fixes may be back-ported to 1.002x if requested. - The File back end now supports Unicode. This is only supported for new databases. Old databases in the DBM::Deep 1.0003 format will have to be upgraded for this to work. - New external_refs mode, which allows objects retrieved from the database to hang on to the corresponding database entries, keep- ing them alive, even after all references to them from the data- base itself have been deleted. - Numeric comparison of DBM::Deep objects now works. Different objects used to compare equal. And there were uninitial- ized warnings. - Deletions now work properly in the DBI back end. Deleting an array or hash referenced by two keys in the database used to be a no-op. 1.0025 Jun 6 12:46:00 2010 PDT (This version is compatible with 1.0024) - Fixed t/39_singletons.t to work on Windows. 1.0024 May 30 14:25:00 2010 PDT (This version is compatible with 1.0023) - Stale references (objects blessed into DBM::Deep::Null), which have always supposed to act like undef, now compare equal to undef, "" and 0. $stale_ref eq "" used to return false, even though "$stale_ref" was the empty string. - If you assign a stale reference to a database location, DBM::Deep now warns and assigns undef, instead of dying with obscure error messages. - Using a stale reference as a hash or array ref now causes an error with a more helpful message. 1.0023 May 9 14:33:00 2010 PDT (This version is compatible with 1.0022) - The DBI back end no longer dies with ‘Use of uninitialized value $_ in lc’ in perl 5.12.0. Thanks to Ansgar Burchardt for finding and fixing this problem. 1.0022 Apr 25 18:40:00 2010 PDT (This version is compatible with 1.0021) - Singleton support has been re-enabled in the File back end. - t/43_transaction_maximum.t was still failing on some systems (see http://www.cpantesters.org/cpan/report/7151810), so now we try to detect the maximum number of files we can open. 1.0021 Apr 18 18:28:00 2010 PDT (This version is compatible with 1.0020) - Correct spelling mistakes in the documentation (thanks to Gregor Herrmann for the corrections and to Ansgar Burchardt for passing them on) (RT#56520) - MANIFEST now lists the test libs so they get included in the distribution (RT#56512) - It no longer crashes in perl 5.6.2. 1.0020 Apr 10 10:50:00 2010 EDT (This version is compatible with 1.0016) - Fixed t/43_transaction_maximum.t so that it doesn't error out on systems which cannot open > 255 files at one time. - Improved code coverage - Added t/96_virtual_functions.t which helps describe what actually needs to be overridden in a new plugin. 1.0019_003 Feb 16 22:00:00 2010 EST (This is the third developer release for 1.0020.) (This version is compatible with 1.0016) - Fixed problem where "./Build test" wouldn't actually -do- anything. - (No-one apparently tried to install this till Steven Lembark. Thanks!) - Fixed speed regression with keys in the File backend. - Introduced in 1.0019_002 to fix #50541 - Thanks, SPROUT! - (RT #53575) Recursion failure in STORE (Thanks, SPROUT) - Merged the rest of the fixes from 1.0015 and 1.0016 - Thanks to our new co-maintainer, SPROUT! :) - Had to turn off singleton support in the File backend because the caching was causing havoc with transactions. Turning on fatal warnings does give apparently important information. - Oh - forgot to mention that fatal warnings are now on in all files. 1.0019_002 Jan 05 22:30:00 2010 EST (This is the second developer release for 1.0020.) (This version is compatible with 1.0014) - Fixed bug where attempting to store a value tied to something other than DBM::Deep would leave the file flocked. - Added support for DBD::SQLite - Build.PL has been extended to support sqlite vs. mysql - Storage::DBI now detects between the two DBDs - (RT #51888) Applied POD patch (Thanks, FWIE!) - (RT #44981) Added VERSION to ::Array, ::Engine, and ::Hash - Removed extraneous slashes from POD links (Thanks ilmari!) - (RT #50541) Fixed bug in clear() for hashes in the File backend. - This has caused a regression in speed for clear() when clearing large hashes using running with the File backend. ->clear() (on my machine) now takes ( N / 40 ) ** (1.66) seconds. So, clearing 4000 keys (as is the test in t/03_bighash.t) would take ~2070 seconds. - (RT #40782) Fixed bug when handling a key of '0' (Thanks Sterling!) - (RT #48031) Fixed bug with localized $, (Thanks, SPROUT!) 1.0019_001 Dec 31 22:00:00 2009 EST (This is the first developer release for 1.0020.) (This version is compatible with 1.0014) - DBM::Deep has been refactored to allow for multiple engines. There are two engines built so far: - File (the original engine) - DBI (an engine based on DBI) - The DBI engine has only been tested on MySQL and isn't transactional. - InnoDB sucks horribly. When run in a sufficient isolation mode, it creates deadlocks. - A custom Build.PL has been written to allow for running tests under CPAN.pm against the various engines. - This also allows running the long tests under CPAN.pm - This has meant a ton of refactoring. Hopefullly, this refactoring will allow finding some of the niggly bugs more easily. Those tests have not been enabled yet. That's the next developer release. - Hopefully, this multi-engine support will allow deprecation of the file format in the future. 1.0016 Feb 05 22:10:00 2010 PST - (This version is compatible with 1.0015) - New caveat in the docs explaining stale references (RT#42129) - All included modules now have the same version in META.yml, so the CPAN shell will no longer try to downgrade. - Fixed bug in clear() for hashes (RT#50541) 1.0015 Jan 25 22:05:00 2010 PST - (This version is compatible with 1.0014) - Fix deep recursion errors (RT#53575) - Avoid leaving temp files lying around (RT#32462) - (RT #48031) Fixed bug with localized $, (Thanks, SPROUT!) - (RT #40782) Fixed bug when handling a key of '0' (Thanks Sterling!) 1.0014 Jun 13 23:15:00 2008 EST - (This version is compatible with 1.0013) - Fix for RT#36781 (t/44 has an unrequired dependency) - lock() has been aliased to lock_exclusive(). There is now a lock_shared() method. The :flock constants are no longer imported into the DBM::Deep namespace. **** THIS IS AN API CHANGE **** 1.0013 Jun 13 23:15:00 2008 EST - (This version is compatible with 1.0012) - Fix for RT#30144 (Optimization failure on Win32) - Fixed a bug in reindex_entry (Thanks, Wulfram Humann!) 1.0012 Jun 09 15:00:00 2008 EST - (This version is compatible with 1.0011) - Fix for RT#30085 (Remove dependency on XS module) - Thank you very much tachyon-II@Perlmonks!! - This also resolves RT#35424 (DBM::Deep breaks XML::Twig). - Updated the POD with fixes that were made, but still on the TODO list. - Bypass for RT#36419 (t/44_upgrade_db.t fails on *BSD) - We're just going to skip that for now. It's a number-of-processes-open issue. Best is to do a port to another module to do the heavy lifting. 1.0011 May 27 15:00:00 2008 EST - (This version is compatible with 1.0010) - A test has the wrong plan. 1.0010 May 27 12:00:00 2008 EST - (This version is compatible with 1.0009) - Fix for RT#35140 (invalid POD links) - Fix for RT#34819 (Cannot assign the same value back to the same location) - Fix for RT#29957 (Cannot assign the same value back to the same location) - Fix for RT#33863 (Cannot shift an arrayref from an array) - When something is deleted from a DB, the value is export()ed, allowing it to be saved. - This exporting is only done if the refcount == 0 after the deletion. 1.0009 Mar 19 12:00:00 2008 EDT - (This version is compatible with 1.0008) - Internal refactorings to prepare for some optimizations. - _fh() has been removed. It was marked as private, so don't complain. - Skip a test that was spuriously failing on Win32 (Thanks, Alias!) 1.0008 Mar 09 20:00:00 2008 EDT - (This version is compatible with 1.0007) - Fixed a number of Win32 issues (Reported by Steven Samelson - thank you!) - Much thanks to Nigel Sandever and David Golden for their help debugging the issues, particularly with DBM::Deep's usage of File::Temp (which removes a number of warnings). - Autovivification now works on Win32. It turns out that when a process takes a shared flock on a file, it's not allowed to write to it under Win32, unlike *nix. This is probably a good catch. - Note: The fix is a hack. All locks are now exclusive until a better fix is found. 1.0007 Jan 10 00:00:00 2008 EDT - (This version is compatible with 1.0006) - Applied a patch+failing test submitted by sprout@cpan.org. Thanks! - Turns out that the case of 17 keys with the same first character in the MD5 hash wasn't being tested for. This was a crashbug. - A fix has been made to upgrade_db.pl (RT# 30067) - The version determinations were in the wrong order or evaluation. This meant that upgrade_db.pl wouldn't work as expected (or at all). - Added a minimum Pod::Usage requirement (RT# 29976) - It's an optional item in Build.PL - utils/upgrade_db.pl now checks for that version, as does the test. 1.0006 Oct 01 23:15:00 2007 EDT - (This version is compatible with 1.0005) - Removed Clone and replaced it with a hand-written datastructure walker. - This greatly reduces the footprint of a large import - This bypasses a failure of Clone under Perl 5.9.5 - Moved t/37_delete_edge_cases.t to t_attic because it wasn't really used - import() has a stricter API now. This is a potentially incompatible API change. Only HASH and ARRAY refs are now allowed and they must match the type of the object being imported into. 1.0005 Oct 01 11:15:00 2007 EDT - (This version is compatible with 1.0004) - Added proper singleton support. This means that the following now works: $db->{foo} = [ 1 .. 3]; my $x = $db->{foo}; my $y = $db->{foo}; is( $x, $y ); # Now passes - This means that Data::Dumper now properly reports when $db->{foo} = $db->{bar} 1.0004 Sep 28 12:15:00 2007 EDT - (This version is compatible with 1.0003) - Fixed the Changes file (wrong version was displayed for 1.0003) - Added filter sugar methods to be more API-compatible with other DBMs - This was added to support a patch provided to IO::All so it can use DBM::Deep as a DBM provider. - Implemented _dump_file in order to display the file structure. As a result, the following bugs were fixed: - Arrays and hashes now clean up after themselves better. - Bucketlists now clean up after themselves better. - Reindexing properly clears the old bucketlist before freeing it. 1.0003 Sep 24 14:00:00 2007 EDT - THIS VERSION IS INCOMPATIBLE WITH FILES FROM ALL OTHER PRIOR VERSIONS. - Further fixes for unshift/shift/splice and references (RT# 29583) - To fix that, I had to put support for real references in. - the 16 and 22 tests are now re-enabled. - Yes, this means that real references work. See t/45_references.t 1.0002 Sep 20 22:00:00 2007 EDT - (This version is compatible with 1.0001) - Expanded _throw_error() so that it provides better information. (Thanks brian d foy!) - Fixed how shift, unshift, and splice work when there are references being moved. It now no longer dies. - Added diag in t/17_import.t to note that the failing tests on blead are due to Clone being broken, not DBM::Deep. The tests will still fail because I don't want users to install something that's broken and deal with those bug reports. 1.0001 Mar 12 16:15:00 2007 EDT - (This version is compatible with 1.0000) - Added a missing dependency on IO::Scalar (RT #25387) - Fixed how t/44_upgrade_db.t and utils/upgrade_db.pl worked - utils/upgrade_db.pl now uses #!perl, not #!/usr/bin/perl - t/44_upgrade_db.t now explicitly calls $^X (Thanks merlyn!) 1.0000 Feb 26 22:30:00 2007 EST - THIS VERSION IS INCOMPATIBLE WITH FILES FROM ALL OTHER PRIOR VERSIONS. - To aid in this form of upgrades, DBM::Deep now checks the file format version to make sure that it knows how to read it. - db_upgrade.pl was added to utils/. This will -NOT- install onto your system. This is deliberate. - db_upgrade.pl will not handle developer release file formats. This is due to the fact that all developer releases in preparation for a given release share the same file version, even though the file format may change. This is deliberate. - Importing no longer takes place within a transaction - The following parameters were added: - data_sector_size - this determines the default size of a data sector. - Correctly handle opening readonly files 0.99_04 Jan 24 22:30:00 2007 EST - Added the missing lib/DBM/Deep.pod file to the MANIFEST - Fixed a poorly-designed test that was failing depending on what Clone::Any was using. - All "use 5.6.0;" lines are now "use 5.006_000;" to avoid warnings about unsupported vstrings in 5.9.x 0.99_03 Jan 23 22:30:00 2007 EST - THIS VERSION IS INCOMPATIBLE WITH FILES FROM ALL OTHER PRIOR VERSIONS. - The fileformat changed completely. I will be writing a converter, but it's not there right now. Do NOT expect that this module will correctly detect older versions and handle them sanely. Sanity will be there for 1.00, but we're not there yet, are we? - Converted to use FileHandle::Fmode to handle filehandle status checks - Fixed bug with deleting already-deleted items on Win32 (reported by Nigel Sandever) - The guts of how transactions work has been rewritten to better handle some edgecases. This required a complete rewrite of the engine. - Freespace management is now in place. It's not perfect, but it's there. - The rewrite of the engine required a rewrite of how first_key/next_key was implemented. This should result in significant speed improvements. - Self-reference has been removed. This means you cannot do: $db->{foo} = { x => 'y' }; $db->{bar} = $db->{foo}; I hope to be able to return this functionality by 1.00, but I cannot promise anything. To do this properly, it requires refcounting in order to correctly handle deletions and transactions. Once you move away from a simple tree, everything becomes really hard. 0.99_02 Apr 28 05:00:00 2006 Pacific - Added missing file to the MANIFEST 0.99_01 Apr 27 18:00:00 2006 Pacific - Added explicit dependency on Perl 5.6.0 - Digest::MD5 requires 5.6.0 - Sub::Uplevel (dep of Test::Exception) requires 5.6.0 - Removed error()/clear_error() - All error-handling is done with die() - Broke out DBM::Deep's code into DBM::Deep::Engine - Tied variables can no longer be assigned to a DBM::Deep object. - This includes cross-file assignments. - Autovivification now works - This is a consequence of the fact that all assignments are tied. - set_pack() and set_digest() have been removed. - Instead, you will now pass the appropriate values into new() - A pack_size parameter has been added to make 64-bit files easier - Transactions now work 0.983 Apr 10 20:00:00 2006 Pacific - Added patch inspired by Jeff Janes (Thanks!) - Autovivification now works correctly - The following now works correctly my %hash = ( a => 1 ); $db->{hash} = \%hash; $hash{b} = 2; cmp_ok( $db->{hash}{b}, '==', 2 ); - (RT#18530) - DBM::Deep now plays nicely with -l 0.982 Mar 08 11:00:00 2006 Pacific - Fixed smoketests that were failing on Win32 - Added restriction for Perl 5.6.0 or higher. - Digest::MD5 and Sub::Uplevel (dep of Test::Exception) require 5.6+ 0.981 Mar 06 11:00:00 2006 Pacific - (RT#17947) - Fixed test that was failing on older Perls 0.98 Feb 28 11:00:00 2006 Pacific - Added in patch by David Cantrell to allow use of DATA filehandle - Fixed bug where attempting to export() a structure that used autobless would die - Fixed arraytest slowness by localizing $SIG{__DIE__} to prevent Test::Builder's $SIG{__DIE__} from being called. (q.v. http://perldoc.perl.org/functions/eval.html) - More methods have been made private: - root() is now _root() - base_offset() is now _base_offset() - fh() is now _fh() - type() is now _type() - precalc_sizes() is now _precalc_sizes() 0.97 Feb 24 10:00:00 2006 Pacific - Reorganization of distribution to a more standard layout - Migration to Module::Build with EU::MM backwards compatibility - Migration of all tests to use Test::More and Test::Exception - Added Devel::Cover report to DBM::Deep POD - Test coverage improved to 89.6% (and climbing) - The following methods have been renamed to reflect their private nature: - init() is now _init() - open() is now _open() - close() is now _close() - load_tag() is now _load_tag() - index_lookup() is now _index_lookup() - add_bucket() is now _add_bucket() - get_bucket_value() is now _get_bucket_value() - delete_bucket() is now _delete_bucket() - bucket_exists() is now _bucket_exists() - find_bucket_list() is now _find_bucket_list() - traverse_index() is now _traverse_index() - get_next_key() is now _get_next_key() - copy_node() is now _copy_node() - throw_error() is now _throw_error() - The various tied classes have been broken out. This means that testing "ref( $obj ) eq 'DBM::Deep'" will now fail. The correct test is "eval { $obj->isa( 'DBM::Deep' ) }". - The various methods like push and delete now have the same return values as the standard builtins. - TIEARRAY and TIEHASH now check their parameters more thoroughly - Negative indices for arrays works as expected, including throwing the appropriate errors. - RT #16877 is fixed (DBM::Deep broken with Perl 5.9.3+). - RT #14893 is fixed (tie() and new() use different parameter lists). - A bug with optimize and threading is fixed. - autobless has received some attention, resulting in a number of bugs fixed. - Removed mode option as it just caused confusion. - Removed volatile option as it is pretty useless (use locking instead) - Locking now implicitly enables autoflush 0.96 Oct 14 09:55:00 2005 Pacific - Fixed build (OS X hidden files killed it) - You can now pass in an optional filehandle to the constructor 0.95 Oct 12 13:58:00 2005 Pacific - Added optional autobless flag to preserve and restore blessed hashes - Fixed bug where 0 could not be fetched using get_next_key - Fixed bug where tie() constructor didn't accept a hash ref for args - optimize() now preserves user/group/permissions - Errors are now FATAL (meaning it calls die()), unless you set debug flag 0.94 Apr 13 19:00:26 2004 Pacific - Fixed bug reported by John Cardenas (corruption at key level when replace of less data was done on bucket) 0.93 Feb 15 19:53:17 2004 Pacific - Fixed optmize() on Win32 where orig file couldn't be overwritten unless filehandle was closed first. This change introduces a potential race condition when using locking and optmize() on Win32, but it can be fixed in the future using a soft copy instead of Perl's rename(). 0.92 Feb 12 19:10:22 2004 Pacific - Fixed bug where passing a reference to a different DBM::Deep object would still result in an internal reference. - Added export() method for recursively extracting hashes/arrays into standard in-memory Perl structures. - Added import() method for recursively importing existing Perl hash/ array structures - Fixed bug where optimize() wouldn't work if base level of DB was an array instead of a hash. 0.91 Feb 12 02:30:22 2004 Pacific - Fixed bug with splice() when length of removed section was 0 - Updated POD re: circular refs and optimize() - Had to jump version numbers to 0.91 because in previous releases I used only a single digit after the decimal which was confusing the CPAN indexer. 0.10 Feb 11 08:58:35 2004 Pacific - Fixed bug where default file mode was CLEARING files (Thanks Rich!) - Added experimental support for circular references - Fixed bugs in shift(), unshift() and splice() where nested objects in array would be recursively re-stored as basic hashes/arrays - Fixed typos in POD docs 0.9 Feb 10 03:25:48 2004 Pacific - Added Filters for storing/fetching keys/values - Added hook for supplying own hashing algorithm - FIxed some typos in POD docs, added new sections 0.8 Feb 8 02:38:22 2004 Pacific - Renamed to DBM::Deep for CPAN - Added optimize() method for rekindling unused space - Now returning hybrid tie()/OO object from new() - Basic error handling introduced - Added debug mode for printing errors to STDERR - Added TYPE_HASH and TYPE_ARRAY constants for "type" param - Added clone() method for safe copying of objects - Wrote POD documentation - Added set_pack() function for manipulating LONG_SIZE / LONG_PACK - Added aliases for most tied functions for public use - Now setting binmode() on FileHandle for Win32 - Added 45 unit tests 0.7 Jan 4 11:31:50 2003 UTC - Renamed to DeepDB - Changed file signature to DPDB (not compatible with older versions) - Converted array length to packed long instead of sprintf()ed string 0.6 Dec 31 15:12:03 2002 UTC - Some misc optimizations for speed 0.5 Oct 18 08:55:29 2002 UTC - support for force_return_next parameter in traverse_index() method for ultra-fast combined key search/removal 0.4 Oct 15 20:07:47 2002 UTC - now making sure filehandle is open for all DB calls 0.3 Oct 3 19:04:13 2002 UTC - fixed bug that could cause corrupted data when using locking 0.2 Aug 6 16:37:32 2002 UTC - Removed base index caching, as it can cause problems when two processes are populating the db at the same time (even with locking) 0.1 Jun 3 08:06:26 2002 UTC - initial release DBM-Deep-2.0013/README000444001750001750 13432012641624315 12667 0ustar00robrob000000000000NAME DBM::Deep - A pure perl multi-level hash/array DBM that supports transactions VERSION 2.0013 SYNOPSIS use DBM::Deep; my $db = DBM::Deep->new( "foo.db" ); $db->{key} = 'value'; print $db->{key}; $db->put('key' => 'value'); print $db->get('key'); # true multi-level support $db->{my_complex} = [ 'hello', { perl => 'rules' }, 42, 99, ]; $db->begin_work; # Do stuff here $db->rollback; $db->commit; tie my %db, 'DBM::Deep', 'foo.db'; $db{key} = 'value'; print $db{key}; tied(%db)->put('key' => 'value'); print tied(%db)->get('key'); DESCRIPTION A unique flat-file database module, written in pure perl. True multi-level hash/array support (unlike MLDBM, which is faked), hybrid OO / tie() interface, cross-platform FTPable files, ACID transactions, and is quite fast. Can handle millions of keys and unlimited levels without significant slow-down. Written from the ground-up in pure perl -- this is NOT a wrapper around a C-based DBM. Out-of-the-box compatibility with Unix, Mac OS X and Windows. VERSION DIFFERENCES NOTE: 2.0000 introduces Unicode support in the File back end. This necessitates a change in the file format. The version 1.0003 format is still supported, though, so we have added a db_version() method. If you are using a database in the old format, you will have to upgrade it to get Unicode support. NOTE: 1.0020 introduces different engines which are backed by different types of storage. There is the original storage (called 'File') and a database storage (called 'DBI'). q.v. "PLUGINS" for more information. NOTE: 1.0000 has significant file format differences from prior versions. There is a backwards-compatibility layer at "utils/upgrade_db.pl". Files created by 1.0000 or higher are NOT compatible with scripts using prior versions. PLUGINS DBM::Deep is a wrapper around different storage engines. These are: File This is the traditional storage engine, storing the data to a custom file format. The parameters accepted are: * file Filename of the DB file to link the handle to. You can pass a full absolute filesystem path, partial path, or a plain filename if the file is in the current working directory. This is a required parameter (though q.v. fh). * fh If you want, you can pass in the fh instead of the file. This is most useful for doing something like: my $db = DBM::Deep->new( { fh => \*DATA } ); You are responsible for making sure that the fh has been opened appropriately for your needs. If you open it read-only and attempt to write, an exception will be thrown. If you open it write-only or append-only, an exception will be thrown immediately as DBM::Deep needs to read from the fh. * file_offset This is the offset within the file that the DBM::Deep db starts. Most of the time, you will not need to set this. However, it's there if you want it. If you pass in fh and do not set this, it will be set appropriately. * locking Specifies whether locking is to be enabled. DBM::Deep uses Perl's flock() function to lock the database in exclusive mode for writes, and shared mode for reads. Pass any true value to enable. This affects the base DB handle *and any child hashes or arrays* that use the same DB file. This is an optional parameter, and defaults to 1 (enabled). See "LOCKING" below for more. When you open an existing database file, the version of the database format will stay the same. But if you are creating a new file, it will be in the latest format. DBI This is a storage engine that stores the data in a relational database. Funnily enough, this engine doesn't work with transactions (yet) as InnoDB doesn't do what DBM::Deep needs it to do. The parameters accepted are: * dbh This is a DBH that's already been opened with "connect" in DBI. * dbi This is a hashref containing: * dsn * username * password * connect_args These correspond to the 4 parameters "connect" in DBI takes. NOTE: This has only been tested with MySQL and SQLite (with disappointing results). I plan on extending this to work with PostgreSQL in the near future. Oracle, Sybase, and other engines will come later. Planned engines There are plans to extend this functionality to (at least) the following: * BDB (and other hash engines like memcached) * NoSQL engines (such as Tokyo Cabinet) * DBIx::Class (and other ORMs) SETUP Construction can be done OO-style (which is the recommended way), or using Perl's tie() function. Both are examined here. OO Construction The recommended way to construct a DBM::Deep object is to use the new() method, which gets you a blessed *and* tied hash (or array) reference. my $db = DBM::Deep->new( "foo.db" ); This opens a new database handle, mapped to the file "foo.db". If this file does not exist, it will automatically be created. DB files are opened in "r+" (read/write) mode, and the type of object returned is a hash, unless otherwise specified (see "Options" below). You can pass a number of options to the constructor to specify things like locking, autoflush, etc. This is done by passing an inline hash (or hashref): my $db = DBM::Deep->new( file => "foo.db", locking => 1, autoflush => 1 ); Notice that the filename is now specified *inside* the hash with the "file" parameter, as opposed to being the sole argument to the constructor. This is required if any options are specified. See "Options" below for the complete list. You can also start with an array instead of a hash. For this, you must specify the "type" parameter: my $db = DBM::Deep->new( file => "foo.db", type => DBM::Deep->TYPE_ARRAY ); Note: Specifying the "type" parameter only takes effect when beginning a new DB file. If you create a DBM::Deep object with an existing file, the "type" will be loaded from the file header, and an error will be thrown if the wrong type is passed in. Tie Construction Alternately, you can create a DBM::Deep handle by using Perl's built-in tie() function. The object returned from tie() can be used to call methods, such as lock() and unlock(). (That object can be retrieved from the tied variable at any time using tied() - please see perltie for more info.) my %hash; my $db = tie %hash, "DBM::Deep", "foo.db"; my @array; my $db = tie @array, "DBM::Deep", "bar.db"; As with the OO constructor, you can replace the DB filename parameter with a hash containing one or more options (see "Options" just below for the complete list). tie %hash, "DBM::Deep", { file => "foo.db", locking => 1, autoflush => 1 }; Options There are a number of options that can be passed in when constructing your DBM::Deep objects. These apply to both the OO- and tie- based approaches. * type This parameter specifies what type of object to create, a hash or array. Use one of these two constants: * "DBM::Deep->TYPE_HASH" * "DBM::Deep->TYPE_ARRAY" This only takes effect when beginning a new file. This is an optional parameter, and defaults to "DBM::Deep->TYPE_HASH". * autoflush Specifies whether autoflush is to be enabled on the underlying filehandle. This obviously slows down write operations, but is required if you may have multiple processes accessing the same DB file (also consider enable *locking*). Pass any true value to enable. This is an optional parameter, and defaults to 1 (enabled). * filter_* See "FILTERS" below. The following parameters may be specified in the constructor the first time the datafile is created. However, they will be stored in the header of the file and cannot be overridden by subsequent openings of the file - the values will be set from the values stored in the datafile's header. * num_txns This is the number of transactions that can be running at one time. The default is one - the HEAD. The minimum is one and the maximum is 255. The more transactions, the larger and quicker the datafile grows. Simple access to a database, regardless of how many processes are doing it, already counts as one transaction (the HEAD). So, if you want, say, 5 processes to be able to call begin_work at the same time, "num_txns" must be at least 6. See "TRANSACTIONS" below. * max_buckets This is the number of entries that can be added before a reindexing. The larger this number is made, the larger a file gets, but the better performance you will have. The default and minimum number this can be is 16. The maximum is 256, but more than 64 isn't recommended. * data_sector_size This is the size in bytes of a given data sector. Data sectors will chain, so a value of any size can be stored. However, chaining is expensive in terms of time. Setting this value to something close to the expected common length of your scalars will improve your performance. If it is too small, your file will have a lot of chaining. If it is too large, your file will have a lot of dead space in it. The default for this is 64 bytes. The minimum value is 32 and the maximum is 256 bytes. Note: There are between 6 and 10 bytes taken up in each data sector for bookkeeping. (It's 4 + the number of bytes in your "pack_size".) This is included within the data_sector_size, thus the effective value is 6-10 bytes less than what you specified. Another note: If your strings contain any characters beyond the byte range, they will be encoded as UTF-8 before being stored in the file. This will make all non-ASCII characters take up more than one byte each. * pack_size This is the size of the file pointer used throughout the file. The valid values are: * small This uses 2-byte offsets, allowing for a maximum file size of 65 KB. * medium (default) This uses 4-byte offsets, allowing for a maximum file size of 4 GB. * large This uses 8-byte offsets, allowing for a maximum file size of 16 XB (exabytes). This can only be enabled if your Perl is compiled for 64-bit. See "LARGEFILE SUPPORT" for more information. * external_refs This is a boolean option. When enabled, it allows external references to database entries to hold on to those entries, even when they are deleted. To illustrate, if you retrieve a hash (or array) reference from the database, $foo_hash = $db->{foo}; the hash reference is still tied to the database. So if you delete $db->{foo}; $foo_hash will point to a location in the DB that is no longer valid (we call this a stale reference). So if you try to retrieve the data from $foo_hash, for(keys %$foo_hash) { you will get an error. The "external_refs" option causes $foo_hash to 'hang on' to the DB entry, so it will not be deleted from the database if there is still a reference to it in a running program. It will be deleted, instead, when the $foo_hash variable no longer exists, or is overwritten. This has the potential to cause database bloat if your program crashes, so it is not enabled by default. (See also the "export" method for an alternative workaround.) TIE INTERFACE With DBM::Deep you can access your databases using Perl's standard hash/array syntax. Because all DBM::Deep objects are *tied* to hashes or arrays, you can treat them as such (but see "external_refs", above, and "Stale References", below). DBM::Deep will intercept all reads/writes and direct them to the right place -- the DB file. This has nothing to do with the "Tie Construction" section above. This simply tells you how to use DBM::Deep using regular hashes and arrays, rather than calling functions like "get()" and "put()" (although those work too). It is entirely up to you how to want to access your databases. Hashes You can treat any DBM::Deep object like a normal Perl hash reference. Add keys, or even nested hashes (or arrays) using standard Perl syntax: my $db = DBM::Deep->new( "foo.db" ); $db->{mykey} = "myvalue"; $db->{myhash} = {}; $db->{myhash}->{subkey} = "subvalue"; print $db->{myhash}->{subkey} . "\n"; You can even step through hash keys using the normal Perl "keys()" function: foreach my $key (keys %$db) { print "$key: " . $db->{$key} . "\n"; } Remember that Perl's "keys()" function extracts *every* key from the hash and pushes them onto an array, all before the loop even begins. If you have an extremely large hash, this may exhaust Perl's memory. Instead, consider using Perl's "each()" function, which pulls keys/values one at a time, using very little memory: while (my ($key, $value) = each %$db) { print "$key: $value\n"; } Please note that when using "each()", you should always pass a direct hash reference, not a lookup. Meaning, you should never do this: # NEVER DO THIS while (my ($key, $value) = each %{$db->{foo}}) { # BAD This causes an infinite loop, because for each iteration, Perl is calling FETCH() on the $db handle, resulting in a "new" hash for foo every time, so it effectively keeps returning the first key over and over again. Instead, assign a temporary variable to "$db->{foo}", then pass that to each(). Arrays As with hashes, you can treat any DBM::Deep object like a normal Perl array reference. This includes inserting, removing and manipulating elements, and the "push()", "pop()", "shift()", "unshift()" and "splice()" functions. The object must have first been created using type "DBM::Deep->TYPE_ARRAY", or simply be a nested array reference inside a hash. Example: my $db = DBM::Deep->new( file => "foo-array.db", type => DBM::Deep->TYPE_ARRAY ); $db->[0] = "foo"; push @$db, "bar", "baz"; unshift @$db, "bah"; my $last_elem = pop @$db; # baz my $first_elem = shift @$db; # bah my $second_elem = $db->[1]; # bar my $num_elements = scalar @$db; OO INTERFACE In addition to the *tie()* interface, you can also use a standard OO interface to manipulate all aspects of DBM::Deep databases. Each type of object (hash or array) has its own methods, but both types share the following common methods: "put()", "get()", "exists()", "delete()" and "clear()". "fetch()" and "store()" are aliases to "put()" and "get()", respectively. * new() / clone() These are the constructor and copy-functions. * put() / store() Stores a new hash key/value pair, or sets an array element value. Takes two arguments, the hash key or array index, and the new value. The value can be a scalar, hash ref or array ref. Returns true on success, false on failure. $db->put("foo", "bar"); # for hashes $db->put(1, "bar"); # for arrays * get() / fetch() Fetches the value of a hash key or array element. Takes one argument: the hash key or array index. Returns a scalar, hash ref or array ref, depending on the data type stored. my $value = $db->get("foo"); # for hashes my $value = $db->get(1); # for arrays * exists() Checks if a hash key or array index exists. Takes one argument: the hash key or array index. Returns true if it exists, false if not. if ($db->exists("foo")) { print "yay!\n"; } # for hashes if ($db->exists(1)) { print "yay!\n"; } # for arrays * delete() Deletes one hash key/value pair or array element. Takes one argument: the hash key or array index. Returns the data that the element used to contain (just like Perl's "delete" function), which is "undef" if it did not exist. For arrays, the remaining elements located after the deleted element are NOT moved over. The deleted element is essentially just undefined, which is exactly how Perl's internal arrays work. $db->delete("foo"); # for hashes $db->delete(1); # for arrays * clear() Deletes all hash keys or array elements. Takes no arguments. No return value. $db->clear(); # hashes or arrays * lock() / unlock() / lock_exclusive() / lock_shared() q.v. "LOCKING" for more info. * optimize() This will compress the datafile so that it takes up as little space as possible. There is a freespace manager so that when space is freed up, it is used before extending the size of the datafile. But, that freespace just sits in the datafile unless "optimize()" is called. "optimize" basically copies everything into a new database, so, if it is in version 1.0003 format, it will be upgraded. * import() Unlike simple assignment, "import()" does not tie the right-hand side. Instead, a copy of your data is put into the DB. "import()" takes either an arrayref (if your DB is an array) or a hashref (if your DB is a hash). "import()" will die if anything else is passed in. * export() This returns a complete copy of the data structure at the point you do the export. This copy is in RAM, not on disk like the DB is. * begin_work() / commit() / rollback() These are the transactional functions. "TRANSACTIONS" for more information. * supports( $option ) This returns a boolean indicating whether this instance of DBM::Deep supports that feature. $option can be one of: * transactions * unicode * db_version() This returns the version of the database format that the current database is in. This is specified as the earliest version of DBM::Deep that supports it. For the File back end, this will be 1.0003 or 2. For the DBI back end, it is currently always 1.0020. Hashes For hashes, DBM::Deep supports all the common methods described above, and the following additional methods: "first_key()" and "next_key()". * first_key() Returns the "first" key in the hash. As with built-in Perl hashes, keys are fetched in an undefined order (which appears random). Takes no arguments, returns the key as a scalar value. my $key = $db->first_key(); * next_key() Returns the "next" key in the hash, given the previous one as the sole argument. Returns undef if there are no more keys to be fetched. $key = $db->next_key($key); Here are some examples of using hashes: my $db = DBM::Deep->new( "foo.db" ); $db->put("foo", "bar"); print "foo: " . $db->get("foo") . "\n"; $db->put("baz", {}); # new child hash ref $db->get("baz")->put("buz", "biz"); print "buz: " . $db->get("baz")->get("buz") . "\n"; my $key = $db->first_key(); while ($key) { print "$key: " . $db->get($key) . "\n"; $key = $db->next_key($key); } if ($db->exists("foo")) { $db->delete("foo"); } Arrays For arrays, DBM::Deep supports all the common methods described above, and the following additional methods: "length()", "push()", "pop()", "shift()", "unshift()" and "splice()". * length() Returns the number of elements in the array. Takes no arguments. my $len = $db->length(); * push() Adds one or more elements onto the end of the array. Accepts scalars, hash refs or array refs. No return value. $db->push("foo", "bar", {}); * pop() Fetches the last element in the array, and deletes it. Takes no arguments. Returns undef if array is empty. Returns the element value. my $elem = $db->pop(); * shift() Fetches the first element in the array, deletes it, then shifts all the remaining elements over to take up the space. Returns the element value. This method is not recommended with large arrays -- see "Large Arrays" below for details. my $elem = $db->shift(); * unshift() Inserts one or more elements onto the beginning of the array, shifting all existing elements over to make room. Accepts scalars, hash refs or array refs. No return value. This method is not recommended with large arrays -- see below for details. $db->unshift("foo", "bar", {}); * splice() Performs exactly like Perl's built-in function of the same name. See "splice" in perlfunc for usage -- it is too complicated to document here. This method is not recommended with large arrays -- see "Large Arrays" below for details. Here are some examples of using arrays: my $db = DBM::Deep->new( file => "foo.db", type => DBM::Deep->TYPE_ARRAY ); $db->push("bar", "baz"); $db->unshift("foo"); $db->put(3, "buz"); my $len = $db->length(); print "length: $len\n"; # 4 for (my $k=0; $k<$len; $k++) { print "$k: " . $db->get($k) . "\n"; } $db->splice(1, 2, "biz", "baf"); while (my $elem = shift @$db) { print "shifted: $elem\n"; } LOCKING Enable or disable automatic file locking by passing a boolean value to the "locking" parameter when constructing your DBM::Deep object (see "SETUP" above). my $db = DBM::Deep->new( file => "foo.db", locking => 1 ); This causes DBM::Deep to "flock()" the underlying filehandle with exclusive mode for writes, and shared mode for reads. This is required if you have multiple processes accessing the same database file, to avoid file corruption. Please note that "flock()" does NOT work for files over NFS. See "DB over NFS" below for more. Explicit Locking You can explicitly lock a database, so it remains locked for multiple actions. This is done by calling the "lock_exclusive()" method (for when you want to write) or the "lock_shared()" method (for when you want to read). This is particularly useful for things like counters, where the current value needs to be fetched, then incremented, then stored again. $db->lock_exclusive(); my $counter = $db->get("counter"); $counter++; $db->put("counter", $counter); $db->unlock(); # or... $db->lock_exclusive(); $db->{counter}++; $db->unlock(); Win32/Cygwin Due to Win32 actually enforcing the read-only status of a shared lock, all locks on Win32 and cygwin are exclusive. This is because of how autovivification currently works. Hopefully, this will go away in a future release. IMPORTING/EXPORTING You can import existing complex structures by calling the "import()" method, and export an entire database into an in-memory structure using the "export()" method. Both are examined here. Importing Say you have an existing hash with nested hashes/arrays inside it. Instead of walking the structure and adding keys/elements to the database as you go, simply pass a reference to the "import()" method. This recursively adds everything to an existing DBM::Deep object for you. Here is an example: my $struct = { key1 => "value1", key2 => "value2", array1 => [ "elem0", "elem1", "elem2" ], hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2" } }; my $db = DBM::Deep->new( "foo.db" ); $db->import( $struct ); print $db->{key1} . "\n"; # prints "value1" This recursively imports the entire $struct object into $db, including all nested hashes and arrays. If the DBM::Deep object contains existing data, keys are merged with the existing ones, replacing if they already exist. The "import()" method can be called on any database level (not just the base level), and works with both hash and array DB types. Note: Make sure your existing structure has no circular references in it. These will cause an infinite loop when importing. There are plans to fix this in a later release. Exporting Calling the "export()" method on an existing DBM::Deep object will return a reference to a new in-memory copy of the database. The export is done recursively, so all nested hashes/arrays are all exported to standard Perl objects. Here is an example: my $db = DBM::Deep->new( "foo.db" ); $db->{key1} = "value1"; $db->{key2} = "value2"; $db->{hash1} = {}; $db->{hash1}->{subkey1} = "subvalue1"; $db->{hash1}->{subkey2} = "subvalue2"; my $struct = $db->export(); print $struct->{key1} . "\n"; # prints "value1" This makes a complete copy of the database in memory, and returns a reference to it. The "export()" method can be called on any database level (not just the base level), and works with both hash and array DB types. Be careful of large databases -- you can store a lot more data in a DBM::Deep object than an in-memory Perl structure. Note: Make sure your database has no circular references in it. These will cause an infinite loop when exporting. There are plans to fix this in a later release. FILTERS DBM::Deep has a number of hooks where you can specify your own Perl function to perform filtering on incoming or outgoing data. This is a perfect way to extend the engine, and implement things like real-time compression or encryption. Filtering applies to the base DB level, and all child hashes / arrays. Filter hooks can be specified when your DBM::Deep object is first constructed, or by calling the "set_filter()" method at any time. There are four available filter hooks. set_filter() This method takes two parameters - the filter type and the filter subreference. The four types are: * filter_store_key This filter is called whenever a hash key is stored. It is passed the incoming key, and expected to return a transformed key. * filter_store_value This filter is called whenever a hash key or array element is stored. It is passed the incoming value, and expected to return a transformed value. * filter_fetch_key This filter is called whenever a hash key is fetched (i.e. via "first_key()" or "next_key()"). It is passed the transformed key, and expected to return the plain key. * filter_fetch_value This filter is called whenever a hash key or array element is fetched. It is passed the transformed value, and expected to return the plain value. Here are the two ways to setup a filter hook: my $db = DBM::Deep->new( file => "foo.db", filter_store_value => \&my_filter_store, filter_fetch_value => \&my_filter_fetch ); # or... $db->set_filter( "store_value", \&my_filter_store ); $db->set_filter( "fetch_value", \&my_filter_fetch ); Your filter function will be called only when dealing with SCALAR keys or values. When nested hashes and arrays are being stored/fetched, filtering is bypassed. Filters are called as static functions, passed a single SCALAR argument, and expected to return a single SCALAR value. If you want to remove a filter, set the function reference to "undef": $db->set_filter( "store_value", undef ); Examples Please read DBM::Deep::Cookbook for examples of filters. ERROR HANDLING Most DBM::Deep methods return a true value for success, and call die() on failure. You can wrap calls in an eval block to catch the die. my $db = DBM::Deep->new( "foo.db" ); # create hash eval { $db->push("foo"); }; # ILLEGAL -- push is array-only call print $@; # prints error message LARGEFILE SUPPORT If you have a 64-bit system, and your Perl is compiled with both LARGEFILE and 64-bit support, you *may* be able to create databases larger than 4 GB. DBM::Deep by default uses 32-bit file offset tags, but these can be changed by specifying the 'pack_size' parameter when constructing the file. DBM::Deep->new( file => $filename, pack_size => 'large', ); This tells DBM::Deep to pack all file offsets with 8-byte (64-bit) quad words instead of 32-bit longs. After setting these values your DB files have a theoretical maximum size of 16 XB (exabytes). You can also use "pack_size => 'small'" in order to use 16-bit file offsets. Note: Changing these values will NOT work for existing database files. Only change this for new files. Once the value has been set, it is stored in the file's header and cannot be changed for the life of the file. These parameters are per-file, meaning you can access 32-bit and 64-bit files, as you choose. Note: We have not personally tested files larger than 4 GB -- all our systems have only a 32-bit Perl. However, we have received user reports that this does indeed work. LOW-LEVEL ACCESS If you require low-level access to the underlying filehandle that DBM::Deep uses, you can call the "_fh()" method, which returns the handle: my $fh = $db->_fh(); This method can be called on the root level of the database, or any child hashes or arrays. All levels share a *root* structure, which contains things like the filehandle, a reference counter, and all the options specified when you created the object. You can get access to this file object by calling the "_storage()" method. my $file_obj = $db->_storage(); This is useful for changing options after the object has already been created, such as enabling/disabling locking. You can also store your own temporary user data in this structure (be wary of name collision), which is then accessible from any child hash or array. CIRCULAR REFERENCES DBM::Deep has full support for circular references. Meaning you can have a nested hash key or array element that points to a parent object. This relationship is stored in the DB file, and is preserved between sessions. Here is an example: my $db = DBM::Deep->new( "foo.db" ); $db->{foo} = "bar"; $db->{circle} = $db; # ref to self print $db->{foo} . "\n"; # prints "bar" print $db->{circle}->{foo} . "\n"; # prints "bar" again This also works as expected with array and hash references. So, the following works as expected: $db->{foo} = [ 1 .. 3 ]; $db->{bar} = $db->{foo}; push @{$db->{foo}}, 42; is( $db->{bar}[-1], 42 ); # Passes This, however, does *not* extend to assignments from one DB file to another. So, the following will throw an error: my $db1 = DBM::Deep->new( "foo.db" ); my $db2 = DBM::Deep->new( "bar.db" ); $db1->{foo} = []; $db2->{foo} = $db1->{foo}; # dies Note: Passing the object to a function that recursively walks the object tree (such as *Data::Dumper* or even the built-in "optimize()" or "export()" methods) will result in an infinite loop. This will be fixed in a future release by adding singleton support. TRANSACTIONS As of 1.0000, DBM::Deep has ACID transactions. Every DBM::Deep object is completely transaction-ready - it is not an option you have to turn on. You do have to specify how many transactions may run simultaneously (q.v. "num_txns"). Three new methods have been added to support them. They are: * begin_work() This starts a transaction. * commit() This applies the changes done within the transaction to the mainline and ends the transaction. * rollback() This discards the changes done within the transaction to the mainline and ends the transaction. Transactions in DBM::Deep are done using a variant of the MVCC method, the same method used by the InnoDB MySQL engine. MIGRATION As of 1.0000, the file format has changed. To aid in upgrades, a migration script is provided within the CPAN distribution, called utils/upgrade_db.pl. NOTE: This script is not installed onto your system because it carries a copy of every version prior to the current version. As of version 2.0000, databases created by old versions back to 1.0003 can be read, but new features may not be available unless the database is upgraded first. TODO The following are items that are planned to be added in future releases. These are separate from the "CAVEATS, ISSUES & BUGS" below. Sub-Transactions Right now, you cannot run a transaction within a transaction. Removing this restriction is technically straightforward, but the combinatorial explosion of possible usecases hurts my head. If this is something you want to see immediately, please submit many testcases. Caching If a client is willing to assert upon opening the file that this process will be the only consumer of that datafile, then there are a number of caching possibilities that can be taken advantage of. This does, however, mean that DBM::Deep is more vulnerable to losing data due to unflushed changes. It also means a much larger in-memory footprint. As such, it's not clear exactly how this should be done. Suggestions are welcome. Ram-only The techniques used in DBM::Deep simply require a seekable contiguous datastore. This could just as easily be a large string as a file. By using substr, the STM capabilities of DBM::Deep could be used within a single-process. I have no idea how I'd specify this, though. Suggestions are welcome. Different contention resolution mechanisms Currently, the only contention resolution mechanism is last-write-wins. This is the mechanism used by most RDBMSes and should be good enough for most uses. For advanced uses of STM, other contention mechanisms will be needed. If you have an idea of how you'd like to see contention resolution in DBM::Deep, please let me know. CAVEATS, ISSUES & BUGS This section describes all the known issues with DBM::Deep. These are issues that are either intractable or depend on some feature within Perl working exactly right. It you have found something that is not listed below, please send an e-mail to bug-DBM-Deep@rt.cpan.org . Likewise, if you think you know of a way around one of these issues, please let me know. References (The following assumes a high level of Perl understanding, specifically of references. Most users can safely skip this section.) Currently, the only references supported are HASH and ARRAY. The other reference types (SCALAR, CODE, GLOB, and REF) cannot be supported for various reasons. * GLOB These are things like filehandles and other sockets. They can't be supported because it's completely unclear how DBM::Deep should serialize them. * SCALAR / REF The discussion here refers to the following type of example: my $x = 25; $db->{key1} = \$x; $x = 50; # In some other process ... my $val = ${ $db->{key1} }; is( $val, 50, "What actually gets stored in the DB file?" ); The problem is one of synchronization. When the variable being referred to changes value, the reference isn't notified, which is kind of the point of references. This means that the new value won't be stored in the datafile for other processes to read. There is no TIEREF. It is theoretically possible to store references to values already within a DBM::Deep object because everything already is synchronized, but the change to the internals would be quite large. Specifically, DBM::Deep would have to tie every single value that is stored. This would bloat the RAM footprint of DBM::Deep at least twofold (if not more) and be a significant performance drain, all to support a feature that has never been requested. * CODE Data::Dump::Streamer provides a mechanism for serializing coderefs, including saving off all closure state. This would allow for DBM::Deep to store the code for a subroutine. Then, whenever the subroutine is read, the code could be "eval()"'ed into being. However, just as for SCALAR and REF, that closure state may change without notifying the DBM::Deep object storing the reference. Again, this would generally be considered a feature. External references and transactions If you do "my $x = $db->{foo};", then start a transaction, $x will be referencing the database from outside the transaction. A fix for this (and other issues with how external references into the database) is being looked into. This is the skipped set of tests in t/39_singletons.t and a related issue is the focus of t/37_delete_edge_cases.t File corruption The current level of error handling in DBM::Deep is minimal. Files *are* checked for a 32-bit signature when opened, but any other form of corruption in the datafile can cause segmentation faults. DBM::Deep may try to "seek()" past the end of a file, or get stuck in an infinite loop depending on the level and type of corruption. File write operations are not checked for failure (for speed), so if you happen to run out of disk space, DBM::Deep will probably fail in a bad way. These things will be addressed in a later version of DBM::Deep. DB over NFS Beware of using DBM::Deep files over NFS. DBM::Deep uses flock(), which works well on local filesystems, but will NOT protect you from file corruption over NFS. I've heard about setting up your NFS server with a locking daemon, then using "lockf()" to lock your files, but your mileage may vary there as well. From what I understand, there is no real way to do it. However, if you need access to the underlying filehandle in DBM::Deep for using some other kind of locking scheme like "lockf()", see the "LOW-LEVEL ACCESS" section above. Copying Objects Beware of copying tied objects in Perl. Very strange things can happen. Instead, use DBM::Deep's "clone()" method which safely copies the object and returns a new, blessed and tied hash or array to the same level in the DB. my $copy = $db->clone(); Note: Since clone() here is cloning the object, not the database location, any modifications to either $db or $copy will be visible to both. Stale References If you take a reference to an array or hash from the database, it is tied to the database itself. This means that if the datum in question is subsequently deleted from the database, the reference to it will point to an invalid location and unpredictable things will happen if you try to use it. So a seemingly innocuous piece of code like this: my %hash = %{ $db->{some_hash} }; can fail if another process deletes or clobbers "$db->{some_hash}" while the data are being extracted, since "%{ ... }" is not atomic. (This actually happened.) The solution is to lock the database before reading the data: $db->lock_exclusive; my %hash = %{ $db->{some_hash} }; $db->unlock; As of version 1.0024, if you assign a stale reference to a location in the database, DBM::Deep will warn, if you have uninitialized warnings enabled, and treat the stale reference as "undef". An attempt to use a stale reference as an array or hash reference will cause an error. Large Arrays Beware of using "shift()", "unshift()" or "splice()" with large arrays. These functions cause every element in the array to move, which can be murder on DBM::Deep, as every element has to be fetched from disk, then stored again in a different location. This will be addressed in a future version. This has been somewhat addressed so that the cost is constant, regardless of what is stored at those locations. So, small arrays with huge data structures in them are faster. But, large arrays are still large. Writeonly Files If you pass in a filehandle to new(), you may have opened it in either a readonly or writeonly mode. STORE will verify that the filehandle is writable. However, there doesn't seem to be a good way to determine if a filehandle is readable. And, if the filehandle isn't readable, it's not clear what will happen. So, don't do that. Assignments Within Transactions The following will *not* work as one might expect: my $x = { a => 1 }; $db->begin_work; $db->{foo} = $x; $db->rollback; is( $x->{a}, 1 ); # This will fail! The problem is that the moment a reference used as the rvalue to a DBM::Deep object's lvalue, it becomes tied itself. This is so that future changes to $x can be tracked within the DBM::Deep file and is considered to be a feature. By the time the rollback occurs, there is no knowledge that there had been an $x or what memory location to assign an "export()" to. NOTE: This does not affect importing because imports do a walk over the reference to be imported in order to explicitly leave it untied. CODE COVERAGE Devel::Cover is used to test the code coverage of the tests. Below is the Devel::Cover report on this distribution's test suite. ---------------------------- ------ ------ ------ ------ ------ ------ ------ File stmt bran cond sub pod time total ---------------------------- ------ ------ ------ ------ ------ ------ ------ blib/lib/DBM/Deep.pm 100.0 89.1 82.9 100.0 100.0 32.5 98.1 blib/lib/DBM/Deep/Array.pm 100.0 94.4 100.0 100.0 100.0 5.2 98.8 blib/lib/DBM/Deep/Engine.pm 100.0 92.9 100.0 100.0 100.0 7.4 100.0 ...ib/DBM/Deep/Engine/DBI.pm 95.0 73.1 100.0 100.0 100.0 1.5 90.4 ...b/DBM/Deep/Engine/File.pm 92.3 78.5 88.9 100.0 100.0 4.9 90.3 blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 100.0 3.8 100.0 .../lib/DBM/Deep/Iterator.pm 100.0 n/a n/a 100.0 100.0 0.0 100.0 .../DBM/Deep/Iterator/DBI.pm 100.0 100.0 n/a 100.0 100.0 1.2 100.0 ...DBM/Deep/Iterator/File.pm 92.5 84.6 n/a 100.0 66.7 0.6 90.0 ...erator/File/BucketList.pm 100.0 75.0 n/a 100.0 66.7 0.4 93.8 ...ep/Iterator/File/Index.pm 100.0 100.0 n/a 100.0 100.0 0.2 100.0 blib/lib/DBM/Deep/Null.pm 87.5 n/a n/a 75.0 n/a 0.0 83.3 blib/lib/DBM/Deep/Sector.pm 91.7 n/a n/a 83.3 0.0 6.7 74.4 ...ib/DBM/Deep/Sector/DBI.pm 96.8 83.3 n/a 100.0 0.0 1.0 89.8 ...p/Sector/DBI/Reference.pm 100.0 95.5 100.0 100.0 0.0 2.2 91.2 ...Deep/Sector/DBI/Scalar.pm 100.0 100.0 n/a 100.0 0.0 1.1 92.9 ...b/DBM/Deep/Sector/File.pm 96.0 87.5 100.0 92.3 25.0 2.2 91.0 ...Sector/File/BucketList.pm 98.2 85.7 83.3 100.0 0.0 3.3 89.4 .../Deep/Sector/File/Data.pm 100.0 n/a n/a 100.0 0.0 0.1 90.9 ...Deep/Sector/File/Index.pm 100.0 80.0 33.3 100.0 0.0 0.8 83.1 .../Deep/Sector/File/Null.pm 100.0 100.0 n/a 100.0 0.0 0.0 91.7 .../Sector/File/Reference.pm 100.0 90.0 80.0 100.0 0.0 1.4 91.5 ...eep/Sector/File/Scalar.pm 98.4 87.5 n/a 100.0 0.0 0.8 91.9 blib/lib/DBM/Deep/Storage.pm 100.0 n/a n/a 100.0 100.0 0.0 100.0 ...b/DBM/Deep/Storage/DBI.pm 97.3 70.8 n/a 100.0 38.5 6.7 87.0 .../DBM/Deep/Storage/File.pm 96.6 77.1 80.0 95.7 100.0 16.0 91.8 Total 99.3 85.2 84.9 99.8 63.3 100.0 97.6 ---------------------------- ------ ------ ------ ------ ------ ------ ------ MORE INFORMATION Check out the DBM::Deep Google Group at or send email to DBM-Deep@googlegroups.com . You can also visit #dbm-deep on irc.perl.org The source code repository is at MAINTAINERS Rob Kinyon, rkinyon@cpan.org Originally written by Joseph Huckaby, jhuckaby@cpan.org SPONSORS Stonehenge Consulting () sponsored the development of transactions and freespace management, leading to the 1.0000 release. A great debt of gratitude goes out to them for their continuing leadership in and support of the Perl community. CONTRIBUTORS The following have contributed greatly to make DBM::Deep what it is today: * Adam Sah and Rich Gaushell for innumerable contributions early on. * Dan Golden and others at YAPC::NA 2006 for helping me design through transactions. * James Stanley for bug fix * David Steinbrunner for fixing typos and adding repository cpan metadata * H. Merijn Brandt for fixing the POD escapes. * Breno G. de Oliveira for minor packaging tweaks SEE ALSO DBM::Deep::Cookbook(3) perltie(1), Tie::Hash(3), Fcntl(3), flock(2), lockf(3), nfs(5) LICENSE Copyright (c) 2007-14 Rob Kinyon. All Rights Reserved. This is free software, you may use it and distribute it under the same terms as Perl itself. DBM-Deep-2.0013/META.json000444001750001750 752212641624315 13373 0ustar00robrob000000000000{ "abstract" : "A pure perl multi-level hash/array DBM that supports transactions", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4214", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "DBM-Deep", "no_index" : { "directory" : [ "utils" ] }, "prereqs" : { "build" : { "requires" : { "File::Path" : "0.01", "File::Temp" : "0.01", "Pod::Usage" : "1.3", "Test::Deep" : "0.095", "Test::Exception" : "0.21", "Test::More" : "0.88", "Test::Warn" : "0.08" } }, "configure" : { "requires" : { "Module::Build" : "0.42" } }, "runtime" : { "requires" : { "Digest::MD5" : "1.00", "Fcntl" : "0.01", "Scalar::Util" : "1.14", "perl" : "5.008_004" } } }, "provides" : { "DBM::Deep" : { "file" : "lib/DBM/Deep.pm", "version" : "2.0013" }, "DBM::Deep::Array" : { "file" : "lib/DBM/Deep/Array.pm" }, "DBM::Deep::Engine" : { "file" : "lib/DBM/Deep/Engine.pm" }, "DBM::Deep::Engine::DBI" : { "file" : "lib/DBM/Deep/Engine/DBI.pm" }, "DBM::Deep::Engine::File" : { "file" : "lib/DBM/Deep/Engine/File.pm" }, "DBM::Deep::Hash" : { "file" : "lib/DBM/Deep/Hash.pm" }, "DBM::Deep::Iterator" : { "file" : "lib/DBM/Deep/Iterator.pm" }, "DBM::Deep::Iterator::DBI" : { "file" : "lib/DBM/Deep/Iterator/DBI.pm" }, "DBM::Deep::Iterator::File" : { "file" : "lib/DBM/Deep/Iterator/File.pm" }, "DBM::Deep::Iterator::File::BucketList" : { "file" : "lib/DBM/Deep/Iterator/File/BucketList.pm" }, "DBM::Deep::Iterator::File::Index" : { "file" : "lib/DBM/Deep/Iterator/File/Index.pm" }, "DBM::Deep::Null" : { "file" : "lib/DBM/Deep/Null.pm" }, "DBM::Deep::Sector" : { "file" : "lib/DBM/Deep/Sector.pm" }, "DBM::Deep::Sector::DBI" : { "file" : "lib/DBM/Deep/Sector/DBI.pm" }, "DBM::Deep::Sector::DBI::Reference" : { "file" : "lib/DBM/Deep/Sector/DBI/Reference.pm" }, "DBM::Deep::Sector::DBI::Scalar" : { "file" : "lib/DBM/Deep/Sector/DBI/Scalar.pm" }, "DBM::Deep::Sector::File" : { "file" : "lib/DBM/Deep/Sector/File.pm" }, "DBM::Deep::Sector::File::BucketList" : { "file" : "lib/DBM/Deep/Sector/File/BucketList.pm" }, "DBM::Deep::Sector::File::Data" : { "file" : "lib/DBM/Deep/Sector/File/Data.pm" }, "DBM::Deep::Sector::File::Index" : { "file" : "lib/DBM/Deep/Sector/File/Index.pm" }, "DBM::Deep::Sector::File::Null" : { "file" : "lib/DBM/Deep/Sector/File/Null.pm" }, "DBM::Deep::Sector::File::Reference" : { "file" : "lib/DBM/Deep/Sector/File/Reference.pm" }, "DBM::Deep::Sector::File::Scalar" : { "file" : "lib/DBM/Deep/Sector/File/Scalar.pm" }, "DBM::Deep::Storage" : { "file" : "lib/DBM/Deep/Storage.pm" }, "DBM::Deep::Storage::DBI" : { "file" : "lib/DBM/Deep/Storage/DBI.pm" }, "DBM::Deep::Storage::File" : { "file" : "lib/DBM/Deep/Storage/File.pm" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/robkinyon/dbm-deep" } }, "version" : "2.0013", "x_serialization_backend" : "JSON::PP version 2.27202" } DBM-Deep-2.0013/MANIFEST000444001750001750 431012641624315 13073 0ustar00robrob000000000000Build.PL Changes lib/DBM/Deep.pm lib/DBM/Deep.pod lib/DBM/Deep/Array.pm lib/DBM/Deep/Cookbook.pod lib/DBM/Deep/Engine.pm lib/DBM/Deep/Engine/DBI.pm lib/DBM/Deep/Engine/File.pm lib/DBM/Deep/Hash.pm lib/DBM/Deep/Internals.pod lib/DBM/Deep/Iterator.pm lib/DBM/Deep/Iterator/DBI.pm lib/DBM/Deep/Iterator/File.pm lib/DBM/Deep/Iterator/File/BucketList.pm lib/DBM/Deep/Iterator/File/Index.pm lib/DBM/Deep/Null.pm lib/DBM/Deep/Sector.pm lib/DBM/Deep/Sector/DBI.pm lib/DBM/Deep/Sector/DBI/Reference.pm lib/DBM/Deep/Sector/DBI/Scalar.pm lib/DBM/Deep/Sector/File.pm lib/DBM/Deep/Sector/File/BucketList.pm lib/DBM/Deep/Sector/File/Data.pm lib/DBM/Deep/Sector/File/Index.pm lib/DBM/Deep/Sector/File/Null.pm lib/DBM/Deep/Sector/File/Reference.pm lib/DBM/Deep/Sector/File/Scalar.pm lib/DBM/Deep/Storage.pm lib/DBM/Deep/Storage/DBI.pm lib/DBM/Deep/Storage/File.pm Makefile.PL MANIFEST META.yml README t/01_basic.t t/02_hash.t t/03_bighash.t t/04_array.t t/05_bigarray.t t/06_error.t t/07_locking.t t/08_deephash.t t/09_deeparray.t t/10_largekeys.t t/11_optimize.t t/12_clone.t t/13_setpack.t t/14_filter.t t/15_digest.t t/16_circular.t t/17_import.t t/18_export.t t/19_crossref.t t/20_tie.t t/21_tie_access.t t/22_internal_copy.t t/23_misc.t t/24_autobless.t t/25_tie_return_value.t t/26_scalar_ref.t t/27_filehandle.t t/28_index_sector.t t/29_largedata.t t/30_already_tied.t t/31_references.t t/32_dash_ell.t t/33_transactions.t t/34_transaction_arrays.t t/35_transaction_multiple.t t/38_data_sector_size.t t/39_singletons.t t/40_freespace.t t/41_transaction_multilevel.t t/42_transaction_indexsector.t t/43_transaction_maximum.t t/44_upgrade_db.t t/45_references.t t/46_blist_reindex.t t/47_odd_reference_behaviors.t t/48_autoexport_after_delete.t t/50_deletes.t t/52_memory_leak.t t/53_misc_transactions.t t/54_output_punct_vars.t t/55_recursion.t t/56_unicode.t t/57_old_db.t t/58_cache.t t/96_virtual_functions.t t/97_dump_file.t t/98_pod.t t/99_pod_coverage.t t/common.pm t/etc/db-0-983 t/etc/db-0-99_04 t/etc/db-1-0000 t/etc/db-1-0003 t/lib/DBM/Deep/Engine/Test.pm t/lib/DBM/Deep/Iterator/Test.pm t/lib/DBM/Deep/Storage/Test.pm etc/mysql_tables.sql etc/sqlite_tables.sql utils/lib/DBM/Deep/09830.pm utils/lib/DBM/Deep/10002.pm utils/upgrade_db.pl META.json DBM-Deep-2.0013/Makefile.PL000444001750001750 134712641624315 13723 0ustar00robrob000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4214 require 5.008_004; use ExtUtils::MakeMaker; WriteMakefile ( 'INSTALLDIRS' => 'site', 'EXE_FILES' => [], 'NAME' => 'DBM::Deep', 'PREREQ_PM' => { 'Test::Warn' => '0.08', 'Test::Deep' => '0.095', 'Pod::Usage' => '1.3', 'Test::Exception' => '0.21', 'Scalar::Util' => '1.14', 'File::Path' => '0.01', 'Digest::MD5' => '1.00', 'Fcntl' => '0.01', 'File::Temp' => '0.01', 'Test::More' => '0.88' }, 'PL_FILES' => {}, 'VERSION_FROM' => 'lib/DBM/Deep.pm' ) ; DBM-Deep-2.0013/Build.PL000444001750001750 641612641624315 13247 0ustar00robrob000000000000use Module::Build 0.28; # for prepare_metadata use strict; use warnings FATAL => 'all'; my $build = Module::Build->subclass( class => "Module::Build::Custom", code => ' sub ACTION_test { my $self = shift; if ( $self->notes(\'TEST_MYSQL_DSN\') ) { $ENV{$_} = $self->notes($_) for qw( TEST_MYSQL_DSN TEST_MYSQL_USER TEST_MYSQL_PASS ); } foreach my $name ( qw( LONG_TESTS TEST_SQLITE ) ) { $ENV{$name} = 1 if $self->notes( $name ); } $self->SUPER::ACTION_test( @_ ); } sub ACTION_dist { my $self = shift; my $v = $self->dist_version; system $^X, "-pi -le", q"$line = $. if ?VERSION?; " . q"$_ = q<" . $v . q"> if $line && $. == $line+2", "lib/DBM/Deep.pod"; $self->SUPER::ACTION_dist( @_ ); } ', )->new( module_name => 'DBM::Deep', license => 'perl', requires => { 'perl' => '5.008_004', 'Fcntl' => '0.01', 'Scalar::Util' => '1.14', 'Digest::MD5' => '1.00', }, build_requires => { 'File::Path' => '0.01', 'File::Temp' => '0.01', 'Pod::Usage' => '1.3', 'Test::Deep' => '0.095', 'Test::Warn' => '0.08', 'Test::More' => '0.88', # done_testing 'Test::Exception' => '0.21', }, create_makefile_pl => 'traditional', create_readme => 1, add_to_cleanup => [ 'META.yml', '*.bak', '*.gz', 'Makefile.PL', 'cover_db', ], test_files => 't/??_*.t', auto_features => { sqlite_engine => { description => 'DBI support via SQLite', requires => { 'DBI' => '1.5', 'DBD::SQLite' => '1.25', }, }, mysql_engine => { description => 'DBI support via MySQL', requires => { 'DBI' => '1.5', 'DBD::mysql' => '4.001', }, }, }, meta_add => { no_index => { directory => [ 'utils' ] } }, meta_merge => { resources => { repository => 'https://github.com/robkinyon/dbm-deep', } }, ); if ( $build->y_n( "Run the long-running tests", 'n' ) ) { $build->notes( 'LONG_TESTS' => 1 ); } if ( $build->features( 'sqlite_engine' ) ) { if ( $build->y_n( "Run the tests against the DBI engine via SQLite?", 'n' ) ) { $build->notes( 'TEST_SQLITE' => 1 ); } } if ( $build->features( 'mysql_engine' ) ) { if ( $build->y_n( "Run the tests against the DBI engine via MySQL?", 'n' ) ) { my ($dsn, $user, $pass) = ('') x 3; $dsn = $build->prompt( "\tWhat is the full DSN (for example 'dbi:mysql:test')" ); if ( $dsn ) { $user = $build->prompt( "\tWhat is the username?" ); if ( $user ) { $pass = $build->prompt( "\tWhat is the password?" ); } } $build->notes( 'TEST_MYSQL_DSN' => $dsn ); $build->notes( 'TEST_MYSQL_USER' => $user ); $build->notes( 'TEST_MYSQL_PASS' => $pass ); } } $build->create_build_script; DBM-Deep-2.0013/utils000755001750001750 012641624315 12747 5ustar00robrob000000000000DBM-Deep-2.0013/utils/upgrade_db.pl000555001750001750 1232212641624315 15560 0ustar00robrob000000000000#!perl use 5.6.0; use strict; use warnings FATAL => 'all'; use FindBin; use File::Spec (); use lib File::Spec->catdir( $FindBin::Bin, 'lib' ); # This is for the latest version. use lib File::Spec->catdir( $FindBin::Bin, '..', 'lib' ); use Getopt::Long qw( GetOptions ); use Pod::Usage 1.3; my %headerver_to_module = ( '0' => 'DBM::Deep::09830', '2' => 'DBM::Deep::10002', '3' => 'DBM::Deep', '4' => 'DBM::Deep', ); my %is_dev = ( '1' => 1, ); my %opts = ( man => 0, help => 0, version => '2', autobless => 1, ); GetOptions( \%opts, 'input=s', 'output=s', 'version:s', 'autobless:i', 'help|?', 'man', ) || pod2man(2); pod2usage(1) if $opts{help}; pod2usage(-exitstatus => 0, -verbose => 2) if $opts{man}; pod2usage(-msg => "Missing required parameters.", verbose => 1) unless $opts{input} && $opts{output}; if ( $opts{input} eq $opts{output} ) { _exit( "Cannot use the same filename for both input and output." ); } unless ( -f $opts{input} ) { _exit( "'$opts{input}' is not a file." ); } my %db; { my $ver = _read_file_header( $opts{input} ); if ( $is_dev{ $ver } ) { _exit( "'$opts{input}' is a dev release and not supported." ); } my $mod = $headerver_to_module{ $ver }; eval "use $mod;"; if ( $@ ) { _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" ); } $db{input} = $mod->new({ file => $opts{input}, locking => 1, autobless => $opts{autobless}, }); $db{input}->lock; } { my $ver = $opts{version}; if ( $ver =~ /^2(?:\.|\z)/ ) { $ver = 4; } elsif ( $ver =~ /^1\.001[0-4]/ ) { $ver = 3; } elsif ( $ver =~ /^1\.000[3-9]/ ) { $ver = 3; } elsif ( $ver eq '1.00' || $ver eq '1.000' || $ver =~ /^1\.000[0-2]/ ) { $ver = 2; } elsif ( $ver =~ /^0\.99/ ) { $ver = 1; } elsif ( $ver =~ /^0\.9[1-8]/ ) { $ver = 0; } else { _exit( "'$ver' is an unrecognized version." ); } if ( $is_dev{ $ver } ) { _exit( "-version '$opts{version}' is a dev release and not supported." ); } # First thing is to destroy the file, in case it's an incompatible version. unlink $opts{output}; my $mod = $headerver_to_module{ $ver }; eval "use $mod;"; if ( $@ ) { _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" ); } $db{output} = $mod->new({ file => $opts{output}, locking => 1, autobless => $opts{autobless}, }); $db{output}->lock; # Hack to write a version 3 file: if($ver == 3) { my $engine = $db{output}->_engine; $engine->{v} = 3; $engine->storage->print_at( 5, pack('N',3) ); } } # Do the actual conversion. This is the code that compress uses. $db{input}->_copy_node( $db{output} ); undef $db{output}; ################################################################################ sub _read_file_header { my ($file) = @_; open my $fh, '<', $file or _exit( "Cannot open '$file' for reading: $!" ); my $buffer = _read_buffer( $fh, 9 ); _exit( "'$file' is not a DBM::Deep file." ) unless length $buffer == 9; my ($file_sig, $header_sig, $header_ver) = unpack( 'A4 A N', $buffer ); # SIG_FILE == 'DPDB' _exit( "'$file' is not a DBM::Deep file." ) unless $file_sig eq 'DPDB'; # SIG_HEADER == 'h' - this means that this is a pre-1.0 file return 0 unless ($header_sig eq 'h'); return $header_ver; } sub _read_buffer { my ($fh, $len) = @_; my $buffer; read( $fh, $buffer, $len ); return $buffer; } sub _exit { my ($msg) = @_; pod2usage( -verbose => 0, -msg => $msg ); } __END__ =head1 NAME upgrade_db.pl =head1 SYNOPSIS upgrade_db.pl -input -output =head1 DESCRIPTION This will attempt to upgrade DB files from one version of DBM::Deep to another. The version of the input file is detected from the file header. The version of the output file defaults to the version of the distro in this file, but can be set, if desired. =head1 OPTIONS =over 4 =item B<-input> (required) This is the name of original DB file. =item B<-output> (required) This is the name of target output DB file. =item B<-version> Optionally, you can specify the version of L for the output file. This can either be an upgrade or a downgrade. The minimum version supported is 0.91. If the version is the same as the input file, this acts like a compressed copy of the database. =item B<-autobless> In pre-1.0000 versions, autoblessing was an optional setting defaulting to false. Autobless in upgrade_db.pl defaults to true. =item B<-help> Prints a brief help message, then exits. =item B<-man> Prints a much longer message, then exits; =back =head1 CAVEATS The following are known issues with this converter. =over 4 =item * Diskspace requirements This will require about twice the diskspace of the input file. =item * Feature support Not all versions support the same features. In particular, internal references were supported in 0.983, removed in 1.000, and re-added in 1.0003. There is no detection of this by upgrade_db.pl. =back =head1 MAINTAINER(S) Rob Kinyon, L Originally written by Rob Kinyon, L =head1 LICENSE Copyright (c) 2007 Rob Kinyon. All Rights Reserved. This is free software, you may use it and distribute it under the same terms as Perl itself. =cut DBM-Deep-2.0013/utils/lib000755001750001750 012641624315 13515 5ustar00robrob000000000000DBM-Deep-2.0013/utils/lib/DBM000755001750001750 012641624315 14117 5ustar00robrob000000000000DBM-Deep-2.0013/utils/lib/DBM/Deep000755001750001750 012641624315 14774 5ustar00robrob000000000000DBM-Deep-2.0013/utils/lib/DBM/Deep/09830.pm000444001750001750 13755412641624315 16231 0ustar00robrob000000000000package DBM::Deep::09830; ## # DBM::Deep # # Description: # Multi-level database module for storing hash trees, arrays and simple # key/value pairs into FTP-able, cross-platform binary database files. # # Type `perldoc DBM::Deep` for complete documentation. # # Usage Examples: # my %db; # tie %db, 'DBM::Deep', 'my_database.db'; # standard tie() method # # my $db = new DBM::Deep( 'my_database.db' ); # preferred OO method # # $db->{my_scalar} = 'hello world'; # $db->{my_hash} = { larry => 'genius', hashes => 'fast' }; # $db->{my_array} = [ 1, 2, 3, time() ]; # $db->{my_complex} = [ 'hello', { perl => 'rules' }, 42, 99 ]; # push @{$db->{my_array}}, 'another value'; # my @key_list = keys %{$db->{my_hash}}; # print "This module " . $db->{my_complex}->[1]->{perl} . "!\n"; # # Copyright: # (c) 2002-2006 Joseph Huckaby. All Rights Reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. ## use strict; use Fcntl qw( :DEFAULT :flock :seek ); use Digest::MD5 (); use Scalar::Util (); use vars qw( $VERSION ); $VERSION = q(0.983); ## # Set to 4 and 'N' for 32-bit offset tags (default). Theoretical limit of 4 GB per file. # (Perl must be compiled with largefile support for files > 2 GB) # # Set to 8 and 'Q' for 64-bit offsets. Theoretical limit of 16 XB per file. # (Perl must be compiled with largefile and 64-bit long support) ## #my $LONG_SIZE = 4; #my $LONG_PACK = 'N'; ## # Set to 4 and 'N' for 32-bit data length prefixes. Limit of 4 GB for each key/value. # Upgrading this is possible (see above) but probably not necessary. If you need # more than 4 GB for a single key or value, this module is really not for you :-) ## #my $DATA_LENGTH_SIZE = 4; #my $DATA_LENGTH_PACK = 'N'; our ($LONG_SIZE, $LONG_PACK, $DATA_LENGTH_SIZE, $DATA_LENGTH_PACK); ## # Maximum number of buckets per list before another level of indexing is done. # Increase this value for slightly greater speed, but larger database files. # DO NOT decrease this value below 16, due to risk of recursive reindex overrun. ## my $MAX_BUCKETS = 16; ## # Better not adjust anything below here, unless you're me :-) ## ## # Setup digest function for keys ## our ($DIGEST_FUNC, $HASH_SIZE); #my $DIGEST_FUNC = \&Digest::MD5::md5; ## # Precalculate index and bucket sizes based on values above. ## #my $HASH_SIZE = 16; my ($INDEX_SIZE, $BUCKET_SIZE, $BUCKET_LIST_SIZE); set_digest(); #set_pack(); #_precalc_sizes(); ## # Setup file and tag signatures. These should never change. ## sub SIG_FILE () { 'DPDB' } sub SIG_HASH () { 'H' } sub SIG_ARRAY () { 'A' } sub SIG_NULL () { 'N' } sub SIG_DATA () { 'D' } sub SIG_INDEX () { 'I' } sub SIG_BLIST () { 'B' } sub SIG_SIZE () { 1 } ## # Setup constants for users to pass to new() ## sub TYPE_HASH () { SIG_HASH } sub TYPE_ARRAY () { SIG_ARRAY } sub _get_args { my $proto = shift; my $args; if (scalar(@_) > 1) { if ( @_ % 2 ) { $proto->_throw_error( "Odd number of parameters to " . (caller(1))[2] ); } $args = {@_}; } elsif ( ref $_[0] ) { unless ( eval { local $SIG{'__DIE__'}; %{$_[0]} || 1 } ) { $proto->_throw_error( "Not a hashref in args to " . (caller(1))[2] ); } $args = $_[0]; } else { $args = { file => shift }; } return $args; } sub new { ## # Class constructor method for Perl OO interface. # Calls tie() and returns blessed reference to tied hash or array, # providing a hybrid OO/tie interface. ## my $class = shift; my $args = $class->_get_args( @_ ); ## # Check if we want a tied hash or array. ## my $self; if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { $class = 'DBM::Deep::09830::Array'; #require DBM::Deep::09830::Array; tie @$self, $class, %$args; } else { $class = 'DBM::Deep::09830::Hash'; #require DBM::Deep::09830::Hash; tie %$self, $class, %$args; } return bless $self, $class; } sub _init { ## # Setup $self and bless into this class. ## my $class = shift; my $args = shift; # These are the defaults to be optionally overridden below my $self = bless { type => TYPE_HASH, base_offset => length(SIG_FILE), }, $class; foreach my $param ( keys %$self ) { next unless exists $args->{$param}; $self->{$param} = delete $args->{$param} } # locking implicitly enables autoflush if ($args->{locking}) { $args->{autoflush} = 1; } $self->{root} = exists $args->{root} ? $args->{root} : DBM::Deep::09830::_::Root->new( $args ); if (!defined($self->_fh)) { $self->_open(); } return $self; } sub TIEHASH { shift; #require DBM::Deep::09830::Hash; return DBM::Deep::09830::Hash->TIEHASH( @_ ); } sub TIEARRAY { shift; #require DBM::Deep::09830::Array; return DBM::Deep::09830::Array->TIEARRAY( @_ ); } #XXX Unneeded now ... #sub DESTROY { #} sub _open { ## # Open a fh to the database, create if nonexistent. # Make sure file signature matches DBM::Deep spec. ## my $self = $_[0]->_get_self; local($/,$\); if (defined($self->_fh)) { $self->_close(); } my $flags = O_RDWR | O_CREAT | O_BINARY; my $fh; sysopen( $fh, $self->_root->{file}, $flags ) or $self->_throw_error( "Cannot sysopen file: " . $self->_root->{file} . ": $!" ); $self->_root->{fh} = $fh; if ($self->_root->{autoflush}) { my $old = select $fh; $|=1; select $old; } seek($fh, 0 + $self->_root->{file_offset}, SEEK_SET); my $signature; my $bytes_read = read( $fh, $signature, length(SIG_FILE)); ## # File is empty -- write signature and master index ## if (!$bytes_read) { seek($fh, 0 + $self->_root->{file_offset}, SEEK_SET); print( $fh SIG_FILE); $self->_create_tag($self->_base_offset, $self->_type, chr(0) x $INDEX_SIZE); my $plain_key = "[base]"; print( $fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key ); # Flush the filehandle my $old_fh = select $fh; my $old_af = $|; $| = 1; $| = $old_af; select $old_fh; my @stats = stat($fh); $self->_root->{inode} = $stats[1]; $self->_root->{end} = $stats[7]; return 1; } ## # Check signature was valid ## unless ($signature eq SIG_FILE) { $self->_close(); return $self->_throw_error("Signature not found -- file is not a Deep DB"); } my @stats = stat($fh); $self->_root->{inode} = $stats[1]; $self->_root->{end} = $stats[7]; ## # Get our type from master index signature ## my $tag = $self->_load_tag($self->_base_offset); #XXX We probably also want to store the hash algorithm name and not assume anything #XXX The cool thing would be to allow a different hashing algorithm at every level if (!$tag) { return $self->_throw_error("Corrupted file, no master index record"); } if ($self->{type} ne $tag->{signature}) { return $self->_throw_error("File type mismatch"); } return 1; } sub _close { ## # Close database fh ## my $self = $_[0]->_get_self; close $self->_root->{fh} if $self->_root->{fh}; $self->_root->{fh} = undef; } sub _create_tag { ## # Given offset, signature and content, create tag and write to disk ## my ($self, $offset, $sig, $content) = @_; my $size = length($content); local($/,$\); my $fh = $self->_fh; seek($fh, $offset + $self->_root->{file_offset}, SEEK_SET); print( $fh $sig . pack($DATA_LENGTH_PACK, $size) . $content ); if ($offset == $self->_root->{end}) { $self->_root->{end} += SIG_SIZE + $DATA_LENGTH_SIZE + $size; } return { signature => $sig, size => $size, offset => $offset + SIG_SIZE + $DATA_LENGTH_SIZE, content => $content }; } sub _load_tag { ## # Given offset, load single tag and return signature, size and data ## my $self = shift; my $offset = shift; local($/,$\); my $fh = $self->_fh; seek($fh, $offset + $self->_root->{file_offset}, SEEK_SET); if (eof $fh) { return undef; } my $b; read( $fh, $b, SIG_SIZE + $DATA_LENGTH_SIZE ); my ($sig, $size) = unpack( "A $DATA_LENGTH_PACK", $b ); my $buffer; read( $fh, $buffer, $size); return { signature => $sig, size => $size, offset => $offset + SIG_SIZE + $DATA_LENGTH_SIZE, content => $buffer }; } sub _index_lookup { ## # Given index tag, lookup single entry in index and return . ## my $self = shift; my ($tag, $index) = @_; my $location = unpack($LONG_PACK, substr($tag->{content}, $index * $LONG_SIZE, $LONG_SIZE) ); if (!$location) { return; } return $self->_load_tag( $location ); } sub _add_bucket { ## # Adds one key/value pair to bucket list, given offset, MD5 digest of key, # plain (undigested) key and value. ## my $self = shift; my ($tag, $md5, $plain_key, $value) = @_; my $keys = $tag->{content}; my $location = 0; my $result = 2; local($/,$\); # This verifies that only supported values will be stored. { my $r = Scalar::Util::reftype( $value ); last if !defined $r; last if $r eq 'HASH'; last if $r eq 'ARRAY'; $self->_throw_error( "Storage of variables of type '$r' is not supported." ); } my $root = $self->_root; my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $value->isa( 'DBM::Deep::09830' ) }; my $internal_ref = $is_dbm_deep && ($value->_root eq $root); my $fh = $self->_fh; ## # Iterate through buckets, seeing if this is a new entry or a replace. ## for (my $i=0; $i<$MAX_BUCKETS; $i++) { my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE)); if (!$subloc) { ## # Found empty bucket (end of list). Populate and exit loop. ## $result = 2; $location = $internal_ref ? $value->_base_offset : $root->{end}; seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET); print( $fh $md5 . pack($LONG_PACK, $location) ); last; } my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE); if ($md5 eq $key) { ## # Found existing bucket with same key. Replace with new value. ## $result = 1; if ($internal_ref) { $location = $value->_base_offset; seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET); print( $fh $md5 . pack($LONG_PACK, $location) ); return $result; } seek($fh, $subloc + SIG_SIZE + $root->{file_offset}, SEEK_SET); my $size; read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size); ## # If value is a hash, array, or raw value with equal or less size, we can # reuse the same content area of the database. Otherwise, we have to create # a new content area at the EOF. ## my $actual_length; my $r = Scalar::Util::reftype( $value ) || ''; if ( $r eq 'HASH' || $r eq 'ARRAY' ) { $actual_length = $INDEX_SIZE; # if autobless is enabled, must also take into consideration # the class name, as it is stored along with key/value. if ( $root->{autobless} ) { my $value_class = Scalar::Util::blessed($value); if ( defined $value_class && !$value->isa('DBM::Deep::09830') ) { $actual_length += length($value_class); } } } else { $actual_length = length($value); } if ($actual_length <= ($size || 0)) { $location = $subloc; } else { $location = $root->{end}; seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $HASH_SIZE + $root->{file_offset}, SEEK_SET); print( $fh pack($LONG_PACK, $location) ); } last; } } ## # If this is an internal reference, return now. # No need to write value or plain key ## if ($internal_ref) { return $result; } ## # If bucket didn't fit into list, split into a new index level ## if (!$location) { seek($fh, $tag->{ref_loc} + $root->{file_offset}, SEEK_SET); print( $fh pack($LONG_PACK, $root->{end}) ); my $index_tag = $self->_create_tag($root->{end}, SIG_INDEX, chr(0) x $INDEX_SIZE); my @offsets = (); $keys .= $md5 . pack($LONG_PACK, 0); for (my $i=0; $i<=$MAX_BUCKETS; $i++) { my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE); if ($key) { my $old_subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE)); my $num = ord(substr($key, $tag->{ch} + 1, 1)); if ($offsets[$num]) { my $offset = $offsets[$num] + SIG_SIZE + $DATA_LENGTH_SIZE; seek($fh, $offset + $root->{file_offset}, SEEK_SET); my $subkeys; read( $fh, $subkeys, $BUCKET_LIST_SIZE); for (my $k=0; $k<$MAX_BUCKETS; $k++) { my $subloc = unpack($LONG_PACK, substr($subkeys, ($k * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE)); if (!$subloc) { seek($fh, $offset + ($k * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET); print( $fh $key . pack($LONG_PACK, $old_subloc || $root->{end}) ); last; } } # k loop } else { $offsets[$num] = $root->{end}; seek($fh, $index_tag->{offset} + ($num * $LONG_SIZE) + $root->{file_offset}, SEEK_SET); print( $fh pack($LONG_PACK, $root->{end}) ); my $blist_tag = $self->_create_tag($root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE); seek($fh, $blist_tag->{offset} + $root->{file_offset}, SEEK_SET); print( $fh $key . pack($LONG_PACK, $old_subloc || $root->{end}) ); } } # key is real } # i loop $location ||= $root->{end}; } # re-index bucket list ## # Seek to content area and store signature, value and plaintext key ## if ($location) { my $content_length; seek($fh, $location + $root->{file_offset}, SEEK_SET); ## # Write signature based on content type, set content length and write actual value. ## my $r = Scalar::Util::reftype($value) || ''; if ($r eq 'HASH') { if ( !$internal_ref && tied %{$value} ) { return $self->_throw_error("Cannot store a tied value"); } print( $fh TYPE_HASH ); print( $fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE ); $content_length = $INDEX_SIZE; } elsif ($r eq 'ARRAY') { if ( !$internal_ref && tied @{$value} ) { return $self->_throw_error("Cannot store a tied value"); } print( $fh TYPE_ARRAY ); print( $fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE ); $content_length = $INDEX_SIZE; } elsif (!defined($value)) { print( $fh SIG_NULL ); print( $fh pack($DATA_LENGTH_PACK, 0) ); $content_length = 0; } else { print( $fh SIG_DATA ); print( $fh pack($DATA_LENGTH_PACK, length($value)) . $value ); $content_length = length($value); } ## # Plain key is stored AFTER value, as keys are typically fetched less often. ## print( $fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key ); ## # If value is blessed, preserve class name ## if ( $root->{autobless} ) { my $value_class = Scalar::Util::blessed($value); if ( defined $value_class && $value_class ne 'DBM::Deep::09830' ) { ## # Blessed ref -- will restore later ## print( $fh chr(1) ); print( $fh pack($DATA_LENGTH_PACK, length($value_class)) . $value_class ); $content_length += 1; $content_length += $DATA_LENGTH_SIZE + length($value_class); } else { print( $fh chr(0) ); $content_length += 1; } } ## # If this is a new content area, advance EOF counter ## if ($location == $root->{end}) { $root->{end} += SIG_SIZE; $root->{end} += $DATA_LENGTH_SIZE + $content_length; $root->{end} += $DATA_LENGTH_SIZE + length($plain_key); } ## # If content is a hash or array, create new child DBM::Deep object and # pass each key or element to it. ## if ($r eq 'HASH') { my %x = %$value; tie %$value, 'DBM::Deep::09830', { type => TYPE_HASH, base_offset => $location, root => $root, }; %$value = %x; } elsif ($r eq 'ARRAY') { my @x = @$value; tie @$value, 'DBM::Deep::09830', { type => TYPE_ARRAY, base_offset => $location, root => $root, }; @$value = @x; } return $result; } return $self->_throw_error("Fatal error: indexing failed -- possibly due to corruption in file"); } sub _get_bucket_value { ## # Fetch single value given tag and MD5 digested key. ## my $self = shift; my ($tag, $md5) = @_; my $keys = $tag->{content}; local($/,$\); my $fh = $self->_fh; ## # Iterate through buckets, looking for a key match ## BUCKET: for (my $i=0; $i<$MAX_BUCKETS; $i++) { my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE); my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE)); if (!$subloc) { ## # Hit end of list, no match ## return; } if ( $md5 ne $key ) { next BUCKET; } ## # Found match -- seek to offset and read signature ## my $signature; seek($fh, $subloc + $self->_root->{file_offset}, SEEK_SET); read( $fh, $signature, SIG_SIZE); ## # If value is a hash or array, return new DBM::Deep object with correct offset ## if (($signature eq TYPE_HASH) || ($signature eq TYPE_ARRAY)) { my $obj = DBM::Deep::09830->new( type => $signature, base_offset => $subloc, root => $self->_root ); if ($self->_root->{autobless}) { ## # Skip over value and plain key to see if object needs # to be re-blessed ## seek($fh, $DATA_LENGTH_SIZE + $INDEX_SIZE, SEEK_CUR); my $size; read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size); if ($size) { seek($fh, $size, SEEK_CUR); } my $bless_bit; read( $fh, $bless_bit, 1); if (ord($bless_bit)) { ## # Yes, object needs to be re-blessed ## my $class_name; read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size); if ($size) { read( $fh, $class_name, $size); } if ($class_name) { $obj = bless( $obj, $class_name ); } } } return $obj; } ## # Otherwise return actual value ## elsif ($signature eq SIG_DATA) { my $size; my $value = ''; read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size); if ($size) { read( $fh, $value, $size); } return $value; } ## # Key exists, but content is null ## else { return; } } # i loop return; } sub _delete_bucket { ## # Delete single key/value pair given tag and MD5 digested key. ## my $self = shift; my ($tag, $md5) = @_; my $keys = $tag->{content}; local($/,$\); my $fh = $self->_fh; ## # Iterate through buckets, looking for a key match ## BUCKET: for (my $i=0; $i<$MAX_BUCKETS; $i++) { my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE); my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE)); if (!$subloc) { ## # Hit end of list, no match ## return; } if ( $md5 ne $key ) { next BUCKET; } ## # Matched key -- delete bucket and return ## seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $self->_root->{file_offset}, SEEK_SET); print( $fh substr($keys, ($i+1) * $BUCKET_SIZE ) ); print( $fh chr(0) x $BUCKET_SIZE ); return 1; } # i loop return; } sub _bucket_exists { ## # Check existence of single key given tag and MD5 digested key. ## my $self = shift; my ($tag, $md5) = @_; my $keys = $tag->{content}; ## # Iterate through buckets, looking for a key match ## BUCKET: for (my $i=0; $i<$MAX_BUCKETS; $i++) { my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE); my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE)); if (!$subloc) { ## # Hit end of list, no match ## return; } if ( $md5 ne $key ) { next BUCKET; } ## # Matched key -- return true ## return 1; } # i loop return; } sub _find_bucket_list { ## # Locate offset for bucket list, given digested key ## my $self = shift; my $md5 = shift; ## # Locate offset for bucket list using digest index system ## my $ch = 0; my $tag = $self->_load_tag($self->_base_offset); if (!$tag) { return; } while ($tag->{signature} ne SIG_BLIST) { $tag = $self->_index_lookup($tag, ord(substr($md5, $ch, 1))); if (!$tag) { return; } $ch++; } return $tag; } sub _traverse_index { ## # Scan index and recursively step into deeper levels, looking for next key. ## my ($self, $offset, $ch, $force_return_next) = @_; $force_return_next = undef unless $force_return_next; local($/,$\); my $tag = $self->_load_tag( $offset ); my $fh = $self->_fh; if ($tag->{signature} ne SIG_BLIST) { my $content = $tag->{content}; my $start; if ($self->{return_next}) { $start = 0; } else { $start = ord(substr($self->{prev_md5}, $ch, 1)); } for (my $index = $start; $index < 256; $index++) { my $subloc = unpack($LONG_PACK, substr($content, $index * $LONG_SIZE, $LONG_SIZE) ); if ($subloc) { my $result = $self->_traverse_index( $subloc, $ch + 1, $force_return_next ); if (defined($result)) { return $result; } } } # index loop $self->{return_next} = 1; } # tag is an index elsif ($tag->{signature} eq SIG_BLIST) { my $keys = $tag->{content}; if ($force_return_next) { $self->{return_next} = 1; } ## # Iterate through buckets, looking for a key match ## for (my $i=0; $i<$MAX_BUCKETS; $i++) { my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE); my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE)); if (!$subloc) { ## # End of bucket list -- return to outer loop ## $self->{return_next} = 1; last; } elsif ($key eq $self->{prev_md5}) { ## # Located previous key -- return next one found ## $self->{return_next} = 1; next; } elsif ($self->{return_next}) { ## # Seek to bucket location and skip over signature ## seek($fh, $subloc + SIG_SIZE + $self->_root->{file_offset}, SEEK_SET); ## # Skip over value to get to plain key ## my $size; read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size); if ($size) { seek($fh, $size, SEEK_CUR); } ## # Read in plain key and return as scalar ## my $plain_key; read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size); if ($size) { read( $fh, $plain_key, $size); } return $plain_key; } } # bucket loop $self->{return_next} = 1; } # tag is a bucket list return; } sub _get_next_key { ## # Locate next key, given digested previous one ## my $self = $_[0]->_get_self; $self->{prev_md5} = $_[1] ? $_[1] : undef; $self->{return_next} = 0; ## # If the previous key was not specifed, start at the top and # return the first one found. ## if (!$self->{prev_md5}) { $self->{prev_md5} = chr(0) x $HASH_SIZE; $self->{return_next} = 1; } return $self->_traverse_index( $self->_base_offset, 0 ); } sub lock { ## # If db locking is set, flock() the db file. If called multiple # times before unlock(), then the same number of unlocks() must # be called before the lock is released. ## my $self = $_[0]->_get_self; my $type = $_[1]; $type = LOCK_EX unless defined $type; if (!defined($self->_fh)) { return; } if ($self->_root->{locking}) { if (!$self->_root->{locked}) { flock($self->_fh, $type); # refresh end counter in case file has changed size my @stats = stat($self->_root->{file}); $self->_root->{end} = $stats[7]; # double-check file inode, in case another process # has optimize()d our file while we were waiting. if ($stats[1] != $self->_root->{inode}) { $self->_open(); # re-open flock($self->_fh, $type); # re-lock $self->_root->{end} = (stat($self->_fh))[7]; # re-end } } $self->_root->{locked}++; return 1; } return; } sub unlock { ## # If db locking is set, unlock the db file. See note in lock() # regarding calling lock() multiple times. ## my $self = $_[0]->_get_self; if (!defined($self->_fh)) { return; } if ($self->_root->{locking} && $self->_root->{locked} > 0) { $self->_root->{locked}--; if (!$self->_root->{locked}) { flock($self->_fh, LOCK_UN); } return 1; } return; } sub _copy_value { my $self = shift->_get_self; my ($spot, $value) = @_; if ( !ref $value ) { ${$spot} = $value; } elsif ( eval { local $SIG{__DIE__}; $value->isa( 'DBM::Deep::09830' ) } ) { my $type = $value->_type; ${$spot} = $type eq TYPE_HASH ? {} : []; $value->_copy_node( ${$spot} ); } else { my $r = Scalar::Util::reftype( $value ); my $c = Scalar::Util::blessed( $value ); if ( $r eq 'ARRAY' ) { ${$spot} = [ @{$value} ]; } else { ${$spot} = { %{$value} }; } ${$spot} = bless ${$spot}, $c if defined $c; } return 1; } sub _copy_node { ## # Copy single level of keys or elements to new DB handle. # Recurse for nested structures ## my $self = shift->_get_self; my ($db_temp) = @_; if ($self->_type eq TYPE_HASH) { my $key = $self->first_key(); while ($key) { my $value = $self->get($key); $self->_copy_value( \$db_temp->{$key}, $value ); $key = $self->next_key($key); } } else { my $length = $self->length(); for (my $index = 0; $index < $length; $index++) { my $value = $self->get($index); $self->_copy_value( \$db_temp->[$index], $value ); } } return 1; } sub export { ## # Recursively export into standard Perl hashes and arrays. ## my $self = $_[0]->_get_self; my $temp; if ($self->_type eq TYPE_HASH) { $temp = {}; } elsif ($self->_type eq TYPE_ARRAY) { $temp = []; } $self->lock(); $self->_copy_node( $temp ); $self->unlock(); return $temp; } sub import { ## # Recursively import Perl hash/array structure ## #XXX This use of ref() seems to be ok if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore my $self = $_[0]->_get_self; my $struct = $_[1]; #XXX This use of ref() seems to be ok if (!ref($struct)) { ## # struct is not a reference, so just import based on our type ## shift @_; if ($self->_type eq TYPE_HASH) { $struct = {@_}; } elsif ($self->_type eq TYPE_ARRAY) { $struct = [@_]; } } my $r = Scalar::Util::reftype($struct) || ''; if ($r eq "HASH" && $self->_type eq TYPE_HASH) { foreach my $key (keys %$struct) { $self->put($key, $struct->{$key}); } } elsif ($r eq "ARRAY" && $self->_type eq TYPE_ARRAY) { $self->push( @$struct ); } else { return $self->_throw_error("Cannot import: type mismatch"); } return 1; } sub optimize { ## # Rebuild entire database into new file, then move # it back on top of original. ## my $self = $_[0]->_get_self; #XXX Need to create a new test for this # if ($self->_root->{links} > 1) { # return $self->_throw_error("Cannot optimize: reference count is greater than 1"); # } my $db_temp = DBM::Deep::09830->new( file => $self->_root->{file} . '.tmp', type => $self->_type ); if (!$db_temp) { return $self->_throw_error("Cannot optimize: failed to open temp file: $!"); } $self->lock(); $self->_copy_node( $db_temp ); undef $db_temp; ## # Attempt to copy user, group and permissions over to new file ## my @stats = stat($self->_fh); my $perms = $stats[2] & 07777; my $uid = $stats[4]; my $gid = $stats[5]; chown( $uid, $gid, $self->_root->{file} . '.tmp' ); chmod( $perms, $self->_root->{file} . '.tmp' ); # q.v. perlport for more information on this variable if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) { ## # Potential race condition when optmizing on Win32 with locking. # The Windows filesystem requires that the filehandle be closed # before it is overwritten with rename(). This could be redone # with a soft copy. ## $self->unlock(); $self->_close(); } if (!rename $self->_root->{file} . '.tmp', $self->_root->{file}) { unlink $self->_root->{file} . '.tmp'; $self->unlock(); return $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!"); } $self->unlock(); $self->_close(); $self->_open(); return 1; } sub clone { ## # Make copy of object and return ## my $self = $_[0]->_get_self; return DBM::Deep::09830->new( type => $self->_type, base_offset => $self->_base_offset, root => $self->_root ); } { my %is_legal_filter = map { $_ => ~~1, } qw( store_key store_value fetch_key fetch_value ); sub set_filter { ## # Setup filter function for storing or fetching the key or value ## my $self = $_[0]->_get_self; my $type = lc $_[1]; my $func = $_[2] ? $_[2] : undef; if ( $is_legal_filter{$type} ) { $self->_root->{"filter_$type"} = $func; return 1; } return; } } ## # Accessor methods ## sub _root { ## # Get access to the root structure ## my $self = $_[0]->_get_self; return $self->{root}; } sub _fh { ## # Get access to the raw fh ## #XXX It will be useful, though, when we split out HASH and ARRAY my $self = $_[0]->_get_self; return $self->_root->{fh}; } sub _type { ## # Get type of current node (TYPE_HASH or TYPE_ARRAY) ## my $self = $_[0]->_get_self; return $self->{type}; } sub _base_offset { ## # Get base_offset of current node (TYPE_HASH or TYPE_ARRAY) ## my $self = $_[0]->_get_self; return $self->{base_offset}; } sub error { ## # Get last error string, or undef if no error ## return $_[0] ? ( $_[0]->_get_self->{root}->{error} or undef ) : $@; } ## # Utility methods ## sub _throw_error { ## # Store error string in self ## my $error_text = $_[1]; if ( Scalar::Util::blessed $_[0] ) { my $self = $_[0]->_get_self; $self->_root->{error} = $error_text; unless ($self->_root->{debug}) { die "DBM::Deep::09830: $error_text\n"; } warn "DBM::Deep::09830: $error_text\n"; return; } else { die "DBM::Deep::09830: $error_text\n"; } } sub clear_error { ## # Clear error state ## my $self = $_[0]->_get_self; undef $self->_root->{error}; } sub _precalc_sizes { ## # Precalculate index, bucket and bucket list sizes ## #XXX I don't like this ... set_pack() unless defined $LONG_SIZE; $INDEX_SIZE = 256 * $LONG_SIZE; $BUCKET_SIZE = $HASH_SIZE + $LONG_SIZE; $BUCKET_LIST_SIZE = $MAX_BUCKETS * $BUCKET_SIZE; } sub set_pack { ## # Set pack/unpack modes (see file header for more) ## my ($long_s, $long_p, $data_s, $data_p) = @_; $LONG_SIZE = $long_s ? $long_s : 4; $LONG_PACK = $long_p ? $long_p : 'N'; $DATA_LENGTH_SIZE = $data_s ? $data_s : 4; $DATA_LENGTH_PACK = $data_p ? $data_p : 'N'; _precalc_sizes(); } sub set_digest { ## # Set key digest function (default is MD5) ## my ($digest_func, $hash_size) = @_; $DIGEST_FUNC = $digest_func ? $digest_func : \&Digest::MD5::md5; $HASH_SIZE = $hash_size ? $hash_size : 16; _precalc_sizes(); } sub _is_writable { my $fh = shift; (O_WRONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0); } #sub _is_readable { # my $fh = shift; # (O_RDONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0); #} ## # tie() methods (hashes and arrays) ## sub STORE { ## # Store single hash key/value or array element in database. ## my $self = $_[0]->_get_self; my $key = $_[1]; local($/,$\); # User may be storing a hash, in which case we do not want it run # through the filtering system my $value = ($self->_root->{filter_store_value} && !ref($_[2])) ? $self->_root->{filter_store_value}->($_[2]) : $_[2]; my $md5 = $DIGEST_FUNC->($key); ## # Make sure file is open ## if (!defined($self->_fh) && !$self->_open()) { return; } if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } ## # Request exclusive lock for writing ## $self->lock( LOCK_EX ); my $fh = $self->_fh; ## # Locate offset for bucket list using digest index system ## my $tag = $self->_load_tag($self->_base_offset); if (!$tag) { $tag = $self->_create_tag($self->_base_offset, SIG_INDEX, chr(0) x $INDEX_SIZE); } my $ch = 0; while ($tag->{signature} ne SIG_BLIST) { my $num = ord(substr($md5, $ch, 1)); my $ref_loc = $tag->{offset} + ($num * $LONG_SIZE); my $new_tag = $self->_index_lookup($tag, $num); if (!$new_tag) { seek($fh, $ref_loc + $self->_root->{file_offset}, SEEK_SET); print( $fh pack($LONG_PACK, $self->_root->{end}) ); $tag = $self->_create_tag($self->_root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE); $tag->{ref_loc} = $ref_loc; $tag->{ch} = $ch; last; } else { $tag = $new_tag; $tag->{ref_loc} = $ref_loc; $tag->{ch} = $ch; } $ch++; } ## # Add key/value to bucket list ## my $result = $self->_add_bucket( $tag, $md5, $key, $value ); $self->unlock(); return $result; } sub FETCH { ## # Fetch single value or element given plain key or array index ## my $self = shift->_get_self; my $key = shift; ## # Make sure file is open ## if (!defined($self->_fh)) { $self->_open(); } my $md5 = $DIGEST_FUNC->($key); ## # Request shared lock for reading ## $self->lock( LOCK_SH ); my $tag = $self->_find_bucket_list( $md5 ); if (!$tag) { $self->unlock(); return; } ## # Get value from bucket list ## my $result = $self->_get_bucket_value( $tag, $md5 ); $self->unlock(); #XXX What is ref() checking here? #YYY Filters only apply on scalar values, so the ref check is making #YYY sure the fetched bucket is a scalar, not a child hash or array. return ($result && !ref($result) && $self->_root->{filter_fetch_value}) ? $self->_root->{filter_fetch_value}->($result) : $result; } sub DELETE { ## # Delete single key/value pair or element given plain key or array index ## my $self = $_[0]->_get_self; my $key = $_[1]; my $md5 = $DIGEST_FUNC->($key); ## # Make sure file is open ## if (!defined($self->_fh)) { $self->_open(); } ## # Request exclusive lock for writing ## $self->lock( LOCK_EX ); my $tag = $self->_find_bucket_list( $md5 ); if (!$tag) { $self->unlock(); return; } ## # Delete bucket ## my $value = $self->_get_bucket_value( $tag, $md5 ); if ($value && !ref($value) && $self->_root->{filter_fetch_value}) { $value = $self->_root->{filter_fetch_value}->($value); } my $result = $self->_delete_bucket( $tag, $md5 ); ## # If this object is an array and the key deleted was on the end of the stack, # decrement the length variable. ## $self->unlock(); return $value; } sub EXISTS { ## # Check if a single key or element exists given plain key or array index ## my $self = $_[0]->_get_self; my $key = $_[1]; my $md5 = $DIGEST_FUNC->($key); ## # Make sure file is open ## if (!defined($self->_fh)) { $self->_open(); } ## # Request shared lock for reading ## $self->lock( LOCK_SH ); my $tag = $self->_find_bucket_list( $md5 ); ## # For some reason, the built-in exists() function returns '' for false ## if (!$tag) { $self->unlock(); return ''; } ## # Check if bucket exists and return 1 or '' ## my $result = $self->_bucket_exists( $tag, $md5 ) || ''; $self->unlock(); return $result; } sub CLEAR { ## # Clear all keys from hash, or all elements from array. ## my $self = $_[0]->_get_self; ## # Make sure file is open ## if (!defined($self->_fh)) { $self->_open(); } ## # Request exclusive lock for writing ## $self->lock( LOCK_EX ); my $fh = $self->_fh; seek($fh, $self->_base_offset + $self->_root->{file_offset}, SEEK_SET); if (eof $fh) { $self->unlock(); return; } $self->_create_tag($self->_base_offset, $self->_type, chr(0) x $INDEX_SIZE); $self->unlock(); return 1; } ## # Public method aliases ## sub put { (shift)->STORE( @_ ) } sub store { (shift)->STORE( @_ ) } sub get { (shift)->FETCH( @_ ) } sub fetch { (shift)->FETCH( @_ ) } sub delete { (shift)->DELETE( @_ ) } sub exists { (shift)->EXISTS( @_ ) } sub clear { (shift)->CLEAR( @_ ) } package DBM::Deep::09830::_::Root; sub new { my $class = shift; my ($args) = @_; my $self = bless { file => undef, fh => undef, file_offset => 0, end => 0, autoflush => undef, locking => undef, debug => undef, filter_store_key => undef, filter_store_value => undef, filter_fetch_key => undef, filter_fetch_value => undef, autobless => undef, locked => 0, %$args, }, $class; if ( $self->{fh} && !$self->{file_offset} ) { $self->{file_offset} = tell( $self->{fh} ); } return $self; } sub DESTROY { my $self = shift; return unless $self; close $self->{fh} if $self->{fh}; return; } package DBM::Deep::09830::Array; use strict; # This is to allow DBM::Deep::Array to handle negative indices on # its own. Otherwise, Perl would intercept the call to negative # indices for us. This was causing bugs for negative index handling. use vars qw( $NEGATIVE_INDICES ); $NEGATIVE_INDICES = 1; use base 'DBM::Deep::09830'; use Scalar::Util (); sub _get_self { eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0] } sub TIEARRAY { ## # Tied array constructor method, called by Perl's tie() function. ## my $class = shift; my $args = $class->_get_args( @_ ); $args->{type} = $class->TYPE_ARRAY; return $class->_init($args); } sub FETCH { my $self = $_[0]->_get_self; my $key = $_[1]; $self->lock( $self->LOCK_SH ); if ( $key =~ /^-?\d+$/ ) { if ( $key < 0 ) { $key += $self->FETCHSIZE; unless ( $key >= 0 ) { $self->unlock; return; } } $key = pack($DBM::Deep::09830::LONG_PACK, $key); } my $rv = $self->SUPER::FETCH( $key ); $self->unlock; return $rv; } sub STORE { my $self = shift->_get_self; my ($key, $value) = @_; $self->lock( $self->LOCK_EX ); my $orig = $key; my $size; my $numeric_idx; if ( $key =~ /^\-?\d+$/ ) { $numeric_idx = 1; if ( $key < 0 ) { $size = $self->FETCHSIZE; $key += $size; if ( $key < 0 ) { die( "Modification of non-creatable array value attempted, subscript $orig" ); } } $key = pack($DBM::Deep::09830::LONG_PACK, $key); } my $rv = $self->SUPER::STORE( $key, $value ); if ( $numeric_idx && $rv == 2 ) { $size = $self->FETCHSIZE unless defined $size; if ( $orig >= $size ) { $self->STORESIZE( $orig + 1 ); } } $self->unlock; return $rv; } sub EXISTS { my $self = $_[0]->_get_self; my $key = $_[1]; $self->lock( $self->LOCK_SH ); if ( $key =~ /^\-?\d+$/ ) { if ( $key < 0 ) { $key += $self->FETCHSIZE; unless ( $key >= 0 ) { $self->unlock; return; } } $key = pack($DBM::Deep::09830::LONG_PACK, $key); } my $rv = $self->SUPER::EXISTS( $key ); $self->unlock; return $rv; } sub DELETE { my $self = $_[0]->_get_self; my $key = $_[1]; my $unpacked_key = $key; $self->lock( $self->LOCK_EX ); my $size = $self->FETCHSIZE; if ( $key =~ /^-?\d+$/ ) { if ( $key < 0 ) { $key += $size; unless ( $key >= 0 ) { $self->unlock; return; } } $key = pack($DBM::Deep::09830::LONG_PACK, $key); } my $rv = $self->SUPER::DELETE( $key ); if ($rv && $unpacked_key == $size - 1) { $self->STORESIZE( $unpacked_key ); } $self->unlock; return $rv; } sub FETCHSIZE { ## # Return the length of the array ## my $self = shift->_get_self; $self->lock( $self->LOCK_SH ); my $SAVE_FILTER = $self->_root->{filter_fetch_value}; $self->_root->{filter_fetch_value} = undef; my $packed_size = $self->FETCH('length'); $self->_root->{filter_fetch_value} = $SAVE_FILTER; $self->unlock; if ($packed_size) { return int(unpack($DBM::Deep::09830::LONG_PACK, $packed_size)); } return 0; } sub STORESIZE { ## # Set the length of the array ## my $self = $_[0]->_get_self; my $new_length = $_[1]; $self->lock( $self->LOCK_EX ); my $SAVE_FILTER = $self->_root->{filter_store_value}; $self->_root->{filter_store_value} = undef; my $result = $self->STORE('length', pack($DBM::Deep::09830::LONG_PACK, $new_length)); $self->_root->{filter_store_value} = $SAVE_FILTER; $self->unlock; return $result; } sub POP { ## # Remove and return the last element on the array ## my $self = $_[0]->_get_self; $self->lock( $self->LOCK_EX ); my $length = $self->FETCHSIZE(); if ($length) { my $content = $self->FETCH( $length - 1 ); $self->DELETE( $length - 1 ); $self->unlock; return $content; } else { $self->unlock; return; } } sub PUSH { ## # Add new element(s) to the end of the array ## my $self = shift->_get_self; $self->lock( $self->LOCK_EX ); my $length = $self->FETCHSIZE(); while (my $content = shift @_) { $self->STORE( $length, $content ); $length++; } $self->unlock; return $length; } sub SHIFT { ## # Remove and return first element on the array. # Shift over remaining elements to take up space. ## my $self = $_[0]->_get_self; $self->lock( $self->LOCK_EX ); my $length = $self->FETCHSIZE(); if ($length) { my $content = $self->FETCH( 0 ); ## # Shift elements over and remove last one. ## for (my $i = 0; $i < $length - 1; $i++) { $self->STORE( $i, $self->FETCH($i + 1) ); } $self->DELETE( $length - 1 ); $self->unlock; return $content; } else { $self->unlock; return; } } sub UNSHIFT { ## # Insert new element(s) at beginning of array. # Shift over other elements to make space. ## my $self = shift->_get_self; my @new_elements = @_; $self->lock( $self->LOCK_EX ); my $length = $self->FETCHSIZE(); my $new_size = scalar @new_elements; if ($length) { for (my $i = $length - 1; $i >= 0; $i--) { $self->STORE( $i + $new_size, $self->FETCH($i) ); } } for (my $i = 0; $i < $new_size; $i++) { $self->STORE( $i, $new_elements[$i] ); } $self->unlock; return $length + $new_size; } sub SPLICE { ## # Splices section of array with optional new section. # Returns deleted section, or last element deleted in scalar context. ## my $self = shift->_get_self; $self->lock( $self->LOCK_EX ); my $length = $self->FETCHSIZE(); ## # Calculate offset and length of splice ## my $offset = shift; $offset = 0 unless defined $offset; if ($offset < 0) { $offset += $length; } my $splice_length; if (scalar @_) { $splice_length = shift; } else { $splice_length = $length - $offset; } if ($splice_length < 0) { $splice_length += ($length - $offset); } ## # Setup array with new elements, and copy out old elements for return ## my @new_elements = @_; my $new_size = scalar @new_elements; my @old_elements = map { $self->FETCH( $_ ) } $offset .. ($offset + $splice_length - 1); ## # Adjust array length, and shift elements to accomodate new section. ## if ( $new_size != $splice_length ) { if ($new_size > $splice_length) { for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) { $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) ); } } else { for (my $i = $offset + $splice_length; $i < $length; $i++) { $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) ); } for (my $i = 0; $i < $splice_length - $new_size; $i++) { $self->DELETE( $length - 1 ); $length--; } } } ## # Insert new elements into array ## for (my $i = $offset; $i < $offset + $new_size; $i++) { $self->STORE( $i, shift @new_elements ); } $self->unlock; ## # Return deleted section, or last element in scalar context. ## return wantarray ? @old_elements : $old_elements[-1]; } sub EXTEND { ## # Perl will call EXTEND() when the array is likely to grow. # We don't care, but include it for compatibility. ## } ## # Public method aliases ## *length = *FETCHSIZE; *pop = *POP; *push = *PUSH; *shift = *SHIFT; *unshift = *UNSHIFT; *splice = *SPLICE; package DBM::Deep::09830::Hash; use strict; use base 'DBM::Deep::09830'; sub _get_self { eval { local $SIG{'__DIE__'}; tied( %{$_[0]} ) } || $_[0] } sub TIEHASH { ## # Tied hash constructor method, called by Perl's tie() function. ## my $class = shift; my $args = $class->_get_args( @_ ); $args->{type} = $class->TYPE_HASH; return $class->_init($args); } sub FETCH { my $self = shift->_get_self; my $key = ($self->_root->{filter_store_key}) ? $self->_root->{filter_store_key}->($_[0]) : $_[0]; return $self->SUPER::FETCH( $key ); } sub STORE { my $self = shift->_get_self; my $key = ($self->_root->{filter_store_key}) ? $self->_root->{filter_store_key}->($_[0]) : $_[0]; my $value = $_[1]; return $self->SUPER::STORE( $key, $value ); } sub EXISTS { my $self = shift->_get_self; my $key = ($self->_root->{filter_store_key}) ? $self->_root->{filter_store_key}->($_[0]) : $_[0]; return $self->SUPER::EXISTS( $key ); } sub DELETE { my $self = shift->_get_self; my $key = ($self->_root->{filter_store_key}) ? $self->_root->{filter_store_key}->($_[0]) : $_[0]; return $self->SUPER::DELETE( $key ); } sub FIRSTKEY { ## # Locate and return first key (in no particular order) ## my $self = $_[0]->_get_self; ## # Make sure file is open ## if (!defined($self->_fh)) { $self->_open(); } ## # Request shared lock for reading ## $self->lock( $self->LOCK_SH ); my $result = $self->_get_next_key(); $self->unlock(); return ($result && $self->_root->{filter_fetch_key}) ? $self->_root->{filter_fetch_key}->($result) : $result; } sub NEXTKEY { ## # Return next key (in no particular order), given previous one ## my $self = $_[0]->_get_self; my $prev_key = ($self->_root->{filter_store_key}) ? $self->_root->{filter_store_key}->($_[1]) : $_[1]; my $prev_md5 = $DBM::Deep::09830::DIGEST_FUNC->($prev_key); ## # Make sure file is open ## if (!defined($self->_fh)) { $self->_open(); } ## # Request shared lock for reading ## $self->lock( $self->LOCK_SH ); my $result = $self->_get_next_key( $prev_md5 ); $self->unlock(); return ($result && $self->_root->{filter_fetch_key}) ? $self->_root->{filter_fetch_key}->($result) : $result; } ## # Public method aliases ## *first_key = *FIRSTKEY; *next_key = *NEXTKEY; 1; __END__ DBM-Deep-2.0013/utils/lib/DBM/Deep/10002.pm000444001750001750 24775112641624315 16211 0ustar00robrob000000000000package DBM::Deep::10002; use 5.006_000; use strict; use warnings; our $VERSION = q(1.0002); use Fcntl qw( :flock ); use Clone (); use Digest::MD5 (); use FileHandle::Fmode (); use Scalar::Util (); #use DBM::Deep::10002::Engine; #use DBM::Deep::10002::File; ## # Setup constants for users to pass to new() ## sub TYPE_HASH () { DBM::Deep::10002::Engine->SIG_HASH } sub TYPE_ARRAY () { DBM::Deep::10002::Engine->SIG_ARRAY } # This is used in all the children of this class in their TIE methods. sub _get_args { my $proto = shift; my $args; if (scalar(@_) > 1) { if ( @_ % 2 ) { $proto->_throw_error( "Odd number of parameters to " . (caller(1))[2] ); } $args = {@_}; } elsif ( ref $_[0] ) { unless ( eval { local $SIG{'__DIE__'}; %{$_[0]} || 1 } ) { $proto->_throw_error( "Not a hashref in args to " . (caller(1))[2] ); } $args = $_[0]; } else { $args = { file => shift }; } return $args; } sub new { ## # Class constructor method for Perl OO interface. # Calls tie() and returns blessed reference to tied hash or array, # providing a hybrid OO/tie interface. ## my $class = shift; my $args = $class->_get_args( @_ ); ## # Check if we want a tied hash or array. ## my $self; if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { $class = 'DBM::Deep::10002::Array'; #require DBM::Deep::10002::Array; tie @$self, $class, %$args; } else { $class = 'DBM::Deep::10002::Hash'; #require DBM::Deep::10002::Hash; tie %$self, $class, %$args; } return bless $self, $class; } # This initializer is called from the various TIE* methods. new() calls tie(), # which allows for a single point of entry. sub _init { my $class = shift; my ($args) = @_; $args->{storage} = DBM::Deep::10002::File->new( $args ) unless exists $args->{storage}; # locking implicitly enables autoflush if ($args->{locking}) { $args->{autoflush} = 1; } # These are the defaults to be optionally overridden below my $self = bless { type => TYPE_HASH, base_offset => undef, staleness => undef, storage => undef, engine => undef, }, $class; $args->{engine} = DBM::Deep::10002::Engine->new( { %{$args}, obj => $self } ) unless exists $args->{engine}; # Grab the parameters we want to use foreach my $param ( keys %$self ) { next unless exists $args->{$param}; $self->{$param} = $args->{$param}; } eval { local $SIG{'__DIE__'}; $self->lock; $self->_engine->setup_fh( $self ); $self->_storage->set_inode; $self->unlock; }; if ( $@ ) { my $e = $@; eval { local $SIG{'__DIE__'}; $self->unlock; }; die $e; } return $self; } sub TIEHASH { shift; #require DBM::Deep::10002::Hash; return DBM::Deep::10002::Hash->TIEHASH( @_ ); } sub TIEARRAY { shift; #require DBM::Deep::10002::Array; return DBM::Deep::10002::Array->TIEARRAY( @_ ); } sub lock { my $self = shift->_get_self; return $self->_storage->lock( $self, @_ ); } sub unlock { my $self = shift->_get_self; return $self->_storage->unlock( $self, @_ ); } sub _copy_value { my $self = shift->_get_self; my ($spot, $value) = @_; if ( !ref $value ) { ${$spot} = $value; } elsif ( eval { local $SIG{__DIE__}; $value->isa( 'DBM::Deep::10002' ) } ) { ${$spot} = $value->_repr; $value->_copy_node( ${$spot} ); } else { my $r = Scalar::Util::reftype( $value ); my $c = Scalar::Util::blessed( $value ); if ( $r eq 'ARRAY' ) { ${$spot} = [ @{$value} ]; } else { ${$spot} = { %{$value} }; } ${$spot} = bless ${$spot}, $c if defined $c; } return 1; } #sub _copy_node { # die "Must be implemented in a child class\n"; #} # #sub _repr { # die "Must be implemented in a child class\n"; #} sub export { ## # Recursively export into standard Perl hashes and arrays. ## my $self = shift->_get_self; my $temp = $self->_repr; $self->lock(); $self->_copy_node( $temp ); $self->unlock(); my $classname = $self->_engine->get_classname( $self ); if ( defined $classname ) { bless $temp, $classname; } return $temp; } sub import { ## # Recursively import Perl hash/array structure ## if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore my $self = shift->_get_self; my ($struct) = @_; # struct is not a reference, so just import based on our type if (!ref($struct)) { $struct = $self->_repr( @_ ); } #XXX This isn't the best solution. Better would be to use Data::Walker, #XXX but that's a lot more thinking than I want to do right now. eval { local $SIG{'__DIE__'}; $self->_import( Clone::clone( $struct ) ); }; if ( my $e = $@ ) { die $e; } return 1; } #XXX Need to keep track of who has a fh to this file in order to #XXX close them all prior to optimize on Win32/cygwin sub optimize { ## # Rebuild entire database into new file, then move # it back on top of original. ## my $self = shift->_get_self; #XXX Need to create a new test for this # if ($self->_storage->{links} > 1) { # $self->_throw_error("Cannot optimize: reference count is greater than 1"); # } #XXX Do we have to lock the tempfile? my $db_temp = DBM::Deep::10002->new( file => $self->_storage->{file} . '.tmp', type => $self->_type, # Bring over all the parameters that we need to bring over num_txns => $self->_engine->num_txns, byte_size => $self->_engine->byte_size, max_buckets => $self->_engine->max_buckets, ); $self->lock(); $self->_copy_node( $db_temp ); undef $db_temp; ## # Attempt to copy user, group and permissions over to new file ## my @stats = stat($self->_fh); my $perms = $stats[2] & 07777; my $uid = $stats[4]; my $gid = $stats[5]; chown( $uid, $gid, $self->_storage->{file} . '.tmp' ); chmod( $perms, $self->_storage->{file} . '.tmp' ); # q.v. perlport for more information on this variable if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) { ## # Potential race condition when optmizing on Win32 with locking. # The Windows filesystem requires that the filehandle be closed # before it is overwritten with rename(). This could be redone # with a soft copy. ## $self->unlock(); $self->_storage->close; } if (!rename $self->_storage->{file} . '.tmp', $self->_storage->{file}) { unlink $self->_storage->{file} . '.tmp'; $self->unlock(); $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!"); } $self->unlock(); $self->_storage->close; $self->_storage->open; $self->lock(); $self->_engine->setup_fh( $self ); $self->unlock(); return 1; } sub clone { ## # Make copy of object and return ## my $self = shift->_get_self; return DBM::Deep::10002->new( type => $self->_type, base_offset => $self->_base_offset, staleness => $self->_staleness, storage => $self->_storage, engine => $self->_engine, ); } #XXX Migrate this to the engine, where it really belongs and go through some # API - stop poking in the innards of someone else.. { my %is_legal_filter = map { $_ => ~~1, } qw( store_key store_value fetch_key fetch_value ); sub set_filter { ## # Setup filter function for storing or fetching the key or value ## my $self = shift->_get_self; my $type = lc shift; my $func = shift; if ( $is_legal_filter{$type} ) { $self->_storage->{"filter_$type"} = $func; return 1; } return; } } sub begin_work { my $self = shift->_get_self; return $self->_engine->begin_work( $self, @_ ); } sub rollback { my $self = shift->_get_self; return $self->_engine->rollback( $self, @_ ); } sub commit { my $self = shift->_get_self; return $self->_engine->commit( $self, @_ ); } ## # Accessor methods ## sub _engine { my $self = $_[0]->_get_self; return $self->{engine}; } sub _storage { my $self = $_[0]->_get_self; return $self->{storage}; } sub _type { my $self = $_[0]->_get_self; return $self->{type}; } sub _base_offset { my $self = $_[0]->_get_self; return $self->{base_offset}; } sub _staleness { my $self = $_[0]->_get_self; return $self->{staleness}; } sub _fh { my $self = $_[0]->_get_self; return $self->_storage->{fh}; } ## # Utility methods ## sub _throw_error { die "DBM::Deep::10002: $_[1]\n"; my $n = 0; while( 1 ) { my @caller = caller( ++$n ); next if $caller[0] =~ m/^DBM::Deep::10002/; die "DBM::Deep::10002: $_[1] at $0 line $caller[2]\n"; last; } } sub STORE { ## # Store single hash key/value or array element in database. ## my $self = shift->_get_self; my ($key, $value) = @_; if ( !FileHandle::Fmode::is_W( $self->_fh ) ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } ## # Request exclusive lock for writing ## $self->lock( LOCK_EX ); # User may be storing a complex value, in which case we do not want it run # through the filtering system. if ( !ref($value) && $self->_storage->{filter_store_value} ) { $value = $self->_storage->{filter_store_value}->( $value ); } $self->_engine->write_value( $self, $key, $value); $self->unlock(); return 1; } sub FETCH { ## # Fetch single value or element given plain key or array index ## my $self = shift->_get_self; my ($key) = @_; ## # Request shared lock for reading ## $self->lock( LOCK_SH ); my $result = $self->_engine->read_value( $self, $key); $self->unlock(); # Filters only apply to scalar values, so the ref check is making # sure the fetched bucket is a scalar, not a child hash or array. return ($result && !ref($result) && $self->_storage->{filter_fetch_value}) ? $self->_storage->{filter_fetch_value}->($result) : $result; } sub DELETE { ## # Delete single key/value pair or element given plain key or array index ## my $self = shift->_get_self; my ($key) = @_; if ( !FileHandle::Fmode::is_W( $self->_fh ) ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } ## # Request exclusive lock for writing ## $self->lock( LOCK_EX ); ## # Delete bucket ## my $value = $self->_engine->delete_key( $self, $key); if (defined $value && !ref($value) && $self->_storage->{filter_fetch_value}) { $value = $self->_storage->{filter_fetch_value}->($value); } $self->unlock(); return $value; } sub EXISTS { ## # Check if a single key or element exists given plain key or array index ## my $self = shift->_get_self; my ($key) = @_; ## # Request shared lock for reading ## $self->lock( LOCK_SH ); my $result = $self->_engine->key_exists( $self, $key ); $self->unlock(); return $result; } sub CLEAR { ## # Clear all keys from hash, or all elements from array. ## my $self = shift->_get_self; if ( !FileHandle::Fmode::is_W( $self->_fh ) ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } ## # Request exclusive lock for writing ## $self->lock( LOCK_EX ); #XXX Rewrite this dreck to do it in the engine as a tight loop vs. # iterating over keys - such a WASTE - is this required for transactional # clearning?! Surely that can be detected in the engine ... if ( $self->_type eq TYPE_HASH ) { my $key = $self->first_key; while ( $key ) { # Retrieve the key before deleting because we depend on next_key my $next_key = $self->next_key( $key ); $self->_engine->delete_key( $self, $key, $key ); $key = $next_key; } } else { my $size = $self->FETCHSIZE; for my $key ( 0 .. $size - 1 ) { $self->_engine->delete_key( $self, $key, $key ); } $self->STORESIZE( 0 ); } $self->unlock(); return 1; } ## # Public method aliases ## sub put { (shift)->STORE( @_ ) } sub store { (shift)->STORE( @_ ) } sub get { (shift)->FETCH( @_ ) } sub fetch { (shift)->FETCH( @_ ) } sub delete { (shift)->DELETE( @_ ) } sub exists { (shift)->EXISTS( @_ ) } sub clear { (shift)->CLEAR( @_ ) } package DBM::Deep::10002::Array; use 5.006_000; use strict; use warnings; our $VERSION = q(1.0002); # This is to allow DBM::Deep::10002::Array to handle negative indices on # its own. Otherwise, Perl would intercept the call to negative # indices for us. This was causing bugs for negative index handling. our $NEGATIVE_INDICES = 1; use base 'DBM::Deep::10002'; use Scalar::Util (); sub _get_self { eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0] } sub _repr { shift;[ @_ ] } sub _import { my $self = shift; my ($struct) = @_; $self->push( @$struct ); return 1; } sub TIEARRAY { my $class = shift; my $args = $class->_get_args( @_ ); $args->{type} = $class->TYPE_ARRAY; return $class->_init($args); } sub FETCH { my $self = shift->_get_self; my ($key) = @_; $self->lock( $self->LOCK_SH ); if ( !defined $key ) { DBM::Deep::10002->_throw_error( "Cannot use an undefined array index." ); } elsif ( $key =~ /^-?\d+$/ ) { if ( $key < 0 ) { $key += $self->FETCHSIZE; unless ( $key >= 0 ) { $self->unlock; return; } } } elsif ( $key ne 'length' ) { $self->unlock; DBM::Deep::10002->_throw_error( "Cannot use '$key' as an array index." ); } my $rv = $self->SUPER::FETCH( $key ); $self->unlock; return $rv; } sub STORE { my $self = shift->_get_self; my ($key, $value) = @_; $self->lock( $self->LOCK_EX ); my $size; my $idx_is_numeric; if ( !defined $key ) { DBM::Deep::10002->_throw_error( "Cannot use an undefined array index." ); } elsif ( $key =~ /^-?\d+$/ ) { $idx_is_numeric = 1; if ( $key < 0 ) { $size = $self->FETCHSIZE; if ( $key + $size < 0 ) { die( "Modification of non-creatable array value attempted, subscript $key" ); } $key += $size } } elsif ( $key ne 'length' ) { $self->unlock; DBM::Deep::10002->_throw_error( "Cannot use '$key' as an array index." ); } my $rv = $self->SUPER::STORE( $key, $value ); if ( $idx_is_numeric ) { $size = $self->FETCHSIZE unless defined $size; if ( $key >= $size ) { $self->STORESIZE( $key + 1 ); } } $self->unlock; return $rv; } sub EXISTS { my $self = shift->_get_self; my ($key) = @_; $self->lock( $self->LOCK_SH ); if ( !defined $key ) { DBM::Deep::10002->_throw_error( "Cannot use an undefined array index." ); } elsif ( $key =~ /^-?\d+$/ ) { if ( $key < 0 ) { $key += $self->FETCHSIZE; unless ( $key >= 0 ) { $self->unlock; return; } } } elsif ( $key ne 'length' ) { $self->unlock; DBM::Deep::10002->_throw_error( "Cannot use '$key' as an array index." ); } my $rv = $self->SUPER::EXISTS( $key ); $self->unlock; return $rv; } sub DELETE { my $self = shift->_get_self; my ($key) = @_; $self->lock( $self->LOCK_EX ); my $size = $self->FETCHSIZE; if ( !defined $key ) { DBM::Deep::10002->_throw_error( "Cannot use an undefined array index." ); } elsif ( $key =~ /^-?\d+$/ ) { if ( $key < 0 ) { $key += $size; unless ( $key >= 0 ) { $self->unlock; return; } } } elsif ( $key ne 'length' ) { $self->unlock; DBM::Deep::10002->_throw_error( "Cannot use '$key' as an array index." ); } my $rv = $self->SUPER::DELETE( $key ); if ($rv && $key == $size - 1) { $self->STORESIZE( $key ); } $self->unlock; return $rv; } # Now that we have a real Reference sector, we should store arrayzize there. However, # arraysize needs to be transactionally-aware, so a simple location to store it isn't # going to work. sub FETCHSIZE { my $self = shift->_get_self; $self->lock( $self->LOCK_SH ); my $SAVE_FILTER = $self->_storage->{filter_fetch_value}; $self->_storage->{filter_fetch_value} = undef; my $size = $self->FETCH('length') || 0; $self->_storage->{filter_fetch_value} = $SAVE_FILTER; $self->unlock; return $size; } sub STORESIZE { my $self = shift->_get_self; my ($new_length) = @_; $self->lock( $self->LOCK_EX ); my $SAVE_FILTER = $self->_storage->{filter_store_value}; $self->_storage->{filter_store_value} = undef; my $result = $self->STORE('length', $new_length, 'length'); $self->_storage->{filter_store_value} = $SAVE_FILTER; $self->unlock; return $result; } sub POP { my $self = shift->_get_self; $self->lock( $self->LOCK_EX ); my $length = $self->FETCHSIZE(); if ($length) { my $content = $self->FETCH( $length - 1 ); $self->DELETE( $length - 1 ); $self->unlock; return $content; } else { $self->unlock; return; } } sub PUSH { my $self = shift->_get_self; $self->lock( $self->LOCK_EX ); my $length = $self->FETCHSIZE(); while (my $content = shift @_) { $self->STORE( $length, $content ); $length++; } $self->unlock; return $length; } # XXX This really needs to be something more direct within the file, not a # fetch and re-store. -RobK, 2007-09-20 sub _move_value { my $self = shift; my ($old_key, $new_key) = @_; my $val = $self->FETCH( $old_key ); if ( eval { local $SIG{'__DIE__'}; $val->isa( 'DBM::Deep::10002::Hash' ) } ) { $self->STORE( $new_key, { %$val } ); } elsif ( eval { local $SIG{'__DIE__'}; $val->isa( 'DBM::Deep::10002::Array' ) } ) { $self->STORE( $new_key, [ @$val ] ); } else { $self->STORE( $new_key, $val ); } } sub SHIFT { my $self = shift->_get_self; $self->lock( $self->LOCK_EX ); my $length = $self->FETCHSIZE(); if ($length) { my $content = $self->FETCH( 0 ); for (my $i = 0; $i < $length - 1; $i++) { $self->_move_value( $i+1, $i ); } $self->DELETE( $length - 1 ); $self->unlock; return $content; } else { $self->unlock; return; } } sub UNSHIFT { my $self = shift->_get_self; my @new_elements = @_; $self->lock( $self->LOCK_EX ); my $length = $self->FETCHSIZE(); my $new_size = scalar @new_elements; if ($length) { for (my $i = $length - 1; $i >= 0; $i--) { $self->_move_value( $i, $i+$new_size ); } } for (my $i = 0; $i < $new_size; $i++) { $self->STORE( $i, $new_elements[$i] ); } $self->unlock; return $length + $new_size; } sub SPLICE { my $self = shift->_get_self; $self->lock( $self->LOCK_EX ); my $length = $self->FETCHSIZE(); ## # Calculate offset and length of splice ## my $offset = shift; $offset = 0 unless defined $offset; if ($offset < 0) { $offset += $length; } my $splice_length; if (scalar @_) { $splice_length = shift; } else { $splice_length = $length - $offset; } if ($splice_length < 0) { $splice_length += ($length - $offset); } ## # Setup array with new elements, and copy out old elements for return ## my @new_elements = @_; my $new_size = scalar @new_elements; my @old_elements = map { $self->FETCH( $_ ) } $offset .. ($offset + $splice_length - 1); ## # Adjust array length, and shift elements to accomodate new section. ## if ( $new_size != $splice_length ) { if ($new_size > $splice_length) { for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) { $self->_move_value( $i, $i + ($new_size - $splice_length) ); } } else { for (my $i = $offset + $splice_length; $i < $length; $i++) { $self->_move_value( $i, $i + ($new_size - $splice_length) ); } for (my $i = 0; $i < $splice_length - $new_size; $i++) { $self->DELETE( $length - 1 ); $length--; } } } ## # Insert new elements into array ## for (my $i = $offset; $i < $offset + $new_size; $i++) { $self->STORE( $i, shift @new_elements ); } $self->unlock; ## # Return deleted section, or last element in scalar context. ## return wantarray ? @old_elements : $old_elements[-1]; } # We don't need to populate it, yet. # It will be useful, though, when we split out HASH and ARRAY sub EXTEND { ## # Perl will call EXTEND() when the array is likely to grow. # We don't care, but include it because it gets called at times. ## } sub _copy_node { my $self = shift; my ($db_temp) = @_; my $length = $self->length(); for (my $index = 0; $index < $length; $index++) { my $value = $self->get($index); $self->_copy_value( \$db_temp->[$index], $value ); } return 1; } ## # Public method aliases ## sub length { (shift)->FETCHSIZE(@_) } sub pop { (shift)->POP(@_) } sub push { (shift)->PUSH(@_) } sub unshift { (shift)->UNSHIFT(@_) } sub splice { (shift)->SPLICE(@_) } # This must be last otherwise we have to qualify all other calls to shift # as calls to CORE::shift sub shift { (CORE::shift)->SHIFT(@_) } package DBM::Deep::10002::Hash; use 5.006_000; use strict; use warnings; our $VERSION = q(1.0002); use base 'DBM::Deep::10002'; sub _get_self { eval { local $SIG{'__DIE__'}; tied( %{$_[0]} ) } || $_[0] } #XXX Need to add a check here for @_ % 2 sub _repr { shift;return { @_ } } sub _import { my $self = shift; my ($struct) = @_; foreach my $key (keys %$struct) { $self->put($key, $struct->{$key}); } return 1; } sub TIEHASH { ## # Tied hash constructor method, called by Perl's tie() function. ## my $class = shift; my $args = $class->_get_args( @_ ); $args->{type} = $class->TYPE_HASH; return $class->_init($args); } sub FETCH { my $self = shift->_get_self; DBM::Deep::10002->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; my $key = ($self->_storage->{filter_store_key}) ? $self->_storage->{filter_store_key}->($_[0]) : $_[0]; return $self->SUPER::FETCH( $key, $_[0] ); } sub STORE { my $self = shift->_get_self; DBM::Deep::10002->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; my $key = ($self->_storage->{filter_store_key}) ? $self->_storage->{filter_store_key}->($_[0]) : $_[0]; my $value = $_[1]; return $self->SUPER::STORE( $key, $value, $_[0] ); } sub EXISTS { my $self = shift->_get_self; DBM::Deep::10002->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; my $key = ($self->_storage->{filter_store_key}) ? $self->_storage->{filter_store_key}->($_[0]) : $_[0]; return $self->SUPER::EXISTS( $key ); } sub DELETE { my $self = shift->_get_self; DBM::Deep::10002->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; my $key = ($self->_storage->{filter_store_key}) ? $self->_storage->{filter_store_key}->($_[0]) : $_[0]; return $self->SUPER::DELETE( $key, $_[0] ); } sub FIRSTKEY { ## # Locate and return first key (in no particular order) ## my $self = shift->_get_self; ## # Request shared lock for reading ## $self->lock( $self->LOCK_SH ); my $result = $self->_engine->get_next_key( $self ); $self->unlock(); return ($result && $self->_storage->{filter_fetch_key}) ? $self->_storage->{filter_fetch_key}->($result) : $result; } sub NEXTKEY { ## # Return next key (in no particular order), given previous one ## my $self = shift->_get_self; my $prev_key = ($self->_storage->{filter_store_key}) ? $self->_storage->{filter_store_key}->($_[0]) : $_[0]; ## # Request shared lock for reading ## $self->lock( $self->LOCK_SH ); my $result = $self->_engine->get_next_key( $self, $prev_key ); $self->unlock(); return ($result && $self->_storage->{filter_fetch_key}) ? $self->_storage->{filter_fetch_key}->($result) : $result; } ## # Public method aliases ## sub first_key { (shift)->FIRSTKEY(@_) } sub next_key { (shift)->NEXTKEY(@_) } sub _copy_node { my $self = shift; my ($db_temp) = @_; my $key = $self->first_key(); while ($key) { my $value = $self->get($key); $self->_copy_value( \$db_temp->{$key}, $value ); $key = $self->next_key($key); } return 1; } package DBM::Deep::10002::File; use 5.006_000; use strict; use warnings; our $VERSION = q(1.0002); use Fcntl qw( :DEFAULT :flock :seek ); sub new { my $class = shift; my ($args) = @_; my $self = bless { autobless => 1, autoflush => 1, end => 0, fh => undef, file => undef, file_offset => 0, locking => 1, locked => 0, #XXX Migrate this to the engine, where it really belongs. filter_store_key => undef, filter_store_value => undef, filter_fetch_key => undef, filter_fetch_value => undef, }, $class; # Grab the parameters we want to use foreach my $param ( keys %$self ) { next unless exists $args->{$param}; $self->{$param} = $args->{$param}; } if ( $self->{fh} && !$self->{file_offset} ) { $self->{file_offset} = tell( $self->{fh} ); } $self->open unless $self->{fh}; return $self; } sub open { my $self = shift; # Adding O_BINARY should remove the need for the binmode below. However, # I'm not going to remove it because I don't have the Win32 chops to be # absolutely certain everything will be ok. my $flags = O_CREAT | O_BINARY; if ( !-e $self->{file} || -w _ ) { $flags |= O_RDWR; } else { $flags |= O_RDONLY; } my $fh; sysopen( $fh, $self->{file}, $flags ) or die "DBM::Deep::10002: Cannot sysopen file '$self->{file}': $!\n"; $self->{fh} = $fh; # Even though we use O_BINARY, better be safe than sorry. binmode $fh; if ($self->{autoflush}) { my $old = select $fh; $|=1; select $old; } return 1; } sub close { my $self = shift; if ( $self->{fh} ) { close $self->{fh}; $self->{fh} = undef; } return 1; } sub set_inode { my $self = shift; unless ( defined $self->{inode} ) { my @stats = stat($self->{fh}); $self->{inode} = $stats[1]; $self->{end} = $stats[7]; } return 1; } sub print_at { my $self = shift; my $loc = shift; local ($/,$\); my $fh = $self->{fh}; if ( defined $loc ) { seek( $fh, $loc + $self->{file_offset}, SEEK_SET ); } print( $fh @_ ); return 1; } sub read_at { my $self = shift; my ($loc, $size) = @_; local ($/,$\); my $fh = $self->{fh}; if ( defined $loc ) { seek( $fh, $loc + $self->{file_offset}, SEEK_SET ); } my $buffer; read( $fh, $buffer, $size); return $buffer; } sub DESTROY { my $self = shift; return unless $self; $self->close; return; } sub request_space { my $self = shift; my ($size) = @_; #XXX Do I need to reset $self->{end} here? I need a testcase my $loc = $self->{end}; $self->{end} += $size; return $loc; } ## # If db locking is set, flock() the db file. If called multiple # times before unlock(), then the same number of unlocks() must # be called before the lock is released. ## sub lock { my $self = shift; my ($obj, $type) = @_; $type = LOCK_EX unless defined $type; if (!defined($self->{fh})) { return; } if ($self->{locking}) { if (!$self->{locked}) { flock($self->{fh}, $type); # refresh end counter in case file has changed size my @stats = stat($self->{fh}); $self->{end} = $stats[7]; # double-check file inode, in case another process # has optimize()d our file while we were waiting. if (defined($self->{inode}) && $stats[1] != $self->{inode}) { $self->close; $self->open; #XXX This needs work $obj->{engine}->setup_fh( $obj ); flock($self->{fh}, $type); # re-lock # This may not be necessary after re-opening $self->{end} = (stat($self->{fh}))[7]; # re-end } } $self->{locked}++; return 1; } return; } ## # If db locking is set, unlock the db file. See note in lock() # regarding calling lock() multiple times. ## sub unlock { my $self = shift; if (!defined($self->{fh})) { return; } if ($self->{locking} && $self->{locked} > 0) { $self->{locked}--; if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); } return 1; } return; } sub flush { my $self = shift; # Flush the filehandle my $old_fh = select $self->{fh}; my $old_af = $|; $| = 1; $| = $old_af; select $old_fh; return 1; } package DBM::Deep::10002::Engine; use 5.006_000; use strict; use warnings; our $VERSION = q(1.0002); use Scalar::Util (); # File-wide notes: # * Every method in here assumes that the storage has been appropriately # safeguarded. This can be anything from flock() to some sort of manual # mutex. But, it's the caller's responsability to make sure that this has # been done. # Setup file and tag signatures. These should never change. sub SIG_FILE () { 'DPDB' } sub SIG_HEADER () { 'h' } sub SIG_HASH () { 'H' } sub SIG_ARRAY () { 'A' } sub SIG_NULL () { 'N' } sub SIG_DATA () { 'D' } sub SIG_INDEX () { 'I' } sub SIG_BLIST () { 'B' } sub SIG_FREE () { 'F' } sub SIG_SIZE () { 1 } my $STALE_SIZE = 2; # Please refer to the pack() documentation for further information my %StP = ( 1 => 'C', # Unsigned char value (no order needed as it's just one byte) 2 => 'n', # Unsigned short in "network" (big-endian) order 4 => 'N', # Unsigned long in "network" (big-endian) order 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) ); ################################################################################ sub new { my $class = shift; my ($args) = @_; my $self = bless { byte_size => 4, digest => undef, hash_size => 16, # In bytes hash_chars => 256, # Number of chars the algorithm uses per byte max_buckets => 16, num_txns => 1, # The HEAD trans_id => 0, # Default to the HEAD data_sector_size => 64, # Size in bytes of each data sector entries => {}, # This is the list of entries for transactions storage => undef, }, $class; # Never allow byte_size to be set directly. delete $args->{byte_size}; if ( defined $args->{pack_size} ) { if ( lc $args->{pack_size} eq 'small' ) { $args->{byte_size} = 2; } elsif ( lc $args->{pack_size} eq 'medium' ) { $args->{byte_size} = 4; } elsif ( lc $args->{pack_size} eq 'large' ) { $args->{byte_size} = 8; } else { DBM::Deep::10002->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" ); } } # Grab the parameters we want to use foreach my $param ( keys %$self ) { next unless exists $args->{$param}; $self->{$param} = $args->{$param}; } my %validations = ( max_buckets => { floor => 16, ceil => 256 }, num_txns => { floor => 1, ceil => 255 }, data_sector_size => { floor => 32, ceil => 256 }, ); while ( my ($attr, $c) = each %validations ) { if ( !defined $self->{$attr} || !length $self->{$attr} || $self->{$attr} =~ /\D/ || $self->{$attr} < $c->{floor} ) { $self->{$attr} = '(undef)' if !defined $self->{$attr}; warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n"; $self->{$attr} = $c->{floor}; } elsif ( $self->{$attr} > $c->{ceil} ) { warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n"; $self->{$attr} = $c->{ceil}; } } if ( !$self->{digest} ) { require Digest::MD5; $self->{digest} = \&Digest::MD5::md5; } return $self; } ################################################################################ sub read_value { my $self = shift; my ($obj, $key) = @_; # This will be a Reference sector my $sector = $self->_load_sector( $obj->_base_offset ) or return; if ( $sector->staleness != $obj->_staleness ) { return; } my $key_md5 = $self->_apply_digest( $key ); my $value_sector = $sector->get_data_for({ key_md5 => $key_md5, allow_head => 1, }); unless ( $value_sector ) { $value_sector = DBM::Deep::10002::Engine::Sector::Null->new({ engine => $self, data => undef, }); $sector->write_data({ key_md5 => $key_md5, key => $key, value => $value_sector, }); } return $value_sector->data; } sub get_classname { my $self = shift; my ($obj) = @_; # This will be a Reference sector my $sector = $self->_load_sector( $obj->_base_offset ) or DBM::Deep::10002->_throw_error( "How did get_classname fail (no sector for '$obj')?!" ); if ( $sector->staleness != $obj->_staleness ) { return; } return $sector->get_classname; } sub key_exists { my $self = shift; my ($obj, $key) = @_; # This will be a Reference sector my $sector = $self->_load_sector( $obj->_base_offset ) or return ''; if ( $sector->staleness != $obj->_staleness ) { return ''; } my $data = $sector->get_data_for({ key_md5 => $self->_apply_digest( $key ), allow_head => 1, }); # exists() returns 1 or '' for true/false. return $data ? 1 : ''; } sub delete_key { my $self = shift; my ($obj, $key) = @_; my $sector = $self->_load_sector( $obj->_base_offset ) or return; if ( $sector->staleness != $obj->_staleness ) { return; } return $sector->delete_key({ key_md5 => $self->_apply_digest( $key ), allow_head => 0, }); } sub write_value { my $self = shift; my ($obj, $key, $value) = @_; my $r = Scalar::Util::reftype( $value ) || ''; { last if $r eq ''; last if $r eq 'HASH'; last if $r eq 'ARRAY'; DBM::Deep::10002->_throw_error( "Storage of references of type '$r' is not supported." ); } my ($class, $type); if ( !defined $value ) { $class = 'DBM::Deep::10002::Engine::Sector::Null'; } elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) { if ( $r eq 'ARRAY' && tied(@$value) ) { DBM::Deep::10002->_throw_error( "Cannot store something that is tied." ); } if ( $r eq 'HASH' && tied(%$value) ) { DBM::Deep::10002->_throw_error( "Cannot store something that is tied." ); } $class = 'DBM::Deep::10002::Engine::Sector::Reference'; $type = substr( $r, 0, 1 ); } else { $class = 'DBM::Deep::10002::Engine::Sector::Scalar'; } # This will be a Reference sector my $sector = $self->_load_sector( $obj->_base_offset ) or DBM::Deep::10002->_throw_error( "Cannot write to a deleted spot in DBM::Deep::10002." ); if ( $sector->staleness != $obj->_staleness ) { DBM::Deep::10002->_throw_error( "Cannot write to a deleted spot in DBM::Deep::10002.n" ); } # Create this after loading the reference sector in case something bad happens. # This way, we won't allocate value sector(s) needlessly. my $value_sector = $class->new({ engine => $self, data => $value, type => $type, }); $sector->write_data({ key => $key, key_md5 => $self->_apply_digest( $key ), value => $value_sector, }); # This code is to make sure we write all the values in the $value to the disk # and to make sure all changes to $value after the assignment are reflected # on disk. This may be counter-intuitive at first, but it is correct dwimmery. # NOTE - simply tying $value won't perform a STORE on each value. Hence, the # copy to a temp value. if ( $r eq 'ARRAY' ) { my @temp = @$value; tie @$value, 'DBM::Deep::10002', { base_offset => $value_sector->offset, staleness => $value_sector->staleness, storage => $self->storage, engine => $self, }; @$value = @temp; bless $value, 'DBM::Deep::10002::Array' unless Scalar::Util::blessed( $value ); } elsif ( $r eq 'HASH' ) { my %temp = %$value; tie %$value, 'DBM::Deep::10002', { base_offset => $value_sector->offset, staleness => $value_sector->staleness, storage => $self->storage, engine => $self, }; %$value = %temp; bless $value, 'DBM::Deep::10002::Hash' unless Scalar::Util::blessed( $value ); } return 1; } # XXX Add staleness here sub get_next_key { my $self = shift; my ($obj, $prev_key) = @_; # XXX Need to add logic about resetting the iterator if any key in the reference has changed unless ( $prev_key ) { $obj->{iterator} = DBM::Deep::10002::Iterator->new({ base_offset => $obj->_base_offset, engine => $self, }); } return $obj->{iterator}->get_next_key( $obj ); } ################################################################################ sub setup_fh { my $self = shift; my ($obj) = @_; # We're opening the file. unless ( $obj->_base_offset ) { my $bytes_read = $self->_read_file_header; # Creating a new file unless ( $bytes_read ) { $self->_write_file_header; # 1) Create Array/Hash entry my $initial_reference = DBM::Deep::10002::Engine::Sector::Reference->new({ engine => $self, type => $obj->_type, }); $obj->{base_offset} = $initial_reference->offset; $obj->{staleness} = $initial_reference->staleness; $self->storage->flush; } # Reading from an existing file else { $obj->{base_offset} = $bytes_read; my $initial_reference = DBM::Deep::10002::Engine::Sector::Reference->new({ engine => $self, offset => $obj->_base_offset, }); unless ( $initial_reference ) { DBM::Deep::10002->_throw_error("Corrupted file, no master index record"); } unless ($obj->_type eq $initial_reference->type) { DBM::Deep::10002->_throw_error("File type mismatch"); } $obj->{staleness} = $initial_reference->staleness; } } return 1; } sub begin_work { my $self = shift; my ($obj) = @_; if ( $self->trans_id ) { DBM::Deep::10002->_throw_error( "Cannot begin_work within an active transaction" ); } my @slots = $self->read_txn_slots; my $found; for my $i ( 0 .. $#slots ) { next if $slots[$i]; $slots[$i] = 1; $self->set_trans_id( $i + 1 ); $found = 1; last; } unless ( $found ) { DBM::Deep::10002->_throw_error( "Cannot allocate transaction ID" ); } $self->write_txn_slots( @slots ); if ( !$self->trans_id ) { DBM::Deep::10002->_throw_error( "Cannot begin_work - no available transactions" ); } return; } sub rollback { my $self = shift; my ($obj) = @_; if ( !$self->trans_id ) { DBM::Deep::10002->_throw_error( "Cannot rollback without an active transaction" ); } # Each entry is the file location for a bucket that has a modification for # this transaction. The entries need to be expunged. foreach my $entry (@{ $self->get_entries } ) { # Remove the entry here my $read_loc = $entry + $self->hash_size + $self->byte_size + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE ); my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size ); $data_loc = unpack( $StP{$self->byte_size}, $data_loc ); $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) ); if ( $data_loc > 1 ) { $self->_load_sector( $data_loc )->free; } } $self->clear_entries; my @slots = $self->read_txn_slots; $slots[$self->trans_id-1] = 0; $self->write_txn_slots( @slots ); $self->inc_txn_staleness_counter( $self->trans_id ); $self->set_trans_id( 0 ); return 1; } sub commit { my $self = shift; my ($obj) = @_; if ( !$self->trans_id ) { DBM::Deep::10002->_throw_error( "Cannot commit without an active transaction" ); } foreach my $entry (@{ $self->get_entries } ) { # Overwrite the entry in head with the entry in trans_id my $base = $entry + $self->hash_size + $self->byte_size; my $head_loc = $self->storage->read_at( $base, $self->byte_size ); $head_loc = unpack( $StP{$self->byte_size}, $head_loc ); my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE ); my $trans_loc = $self->storage->read_at( $spot, $self->byte_size, ); $self->storage->print_at( $base, $trans_loc ); $self->storage->print_at( $spot, pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ), ); if ( $head_loc > 1 ) { $self->_load_sector( $head_loc )->free; } } $self->clear_entries; my @slots = $self->read_txn_slots; $slots[$self->trans_id-1] = 0; $self->write_txn_slots( @slots ); $self->inc_txn_staleness_counter( $self->trans_id ); $self->set_trans_id( 0 ); return 1; } sub read_txn_slots { my $self = shift; my $bl = $self->txn_bitfield_len; my $num_bits = $bl * 8; return split '', unpack( 'b'.$num_bits, $self->storage->read_at( $self->trans_loc, $bl, ) ); } sub write_txn_slots { my $self = shift; my $num_bits = $self->txn_bitfield_len * 8; $self->storage->print_at( $self->trans_loc, pack( 'b'.$num_bits, join('', @_) ), ); } sub get_running_txn_ids { my $self = shift; my @transactions = $self->read_txn_slots; my @trans_ids = map { $_+1} grep { $transactions[$_] } 0 .. $#transactions; } sub get_txn_staleness_counter { my $self = shift; my ($trans_id) = @_; # Hardcode staleness of 0 for the HEAD return 0 unless $trans_id; return unpack( $StP{$STALE_SIZE}, $self->storage->read_at( $self->trans_loc + 4 + $STALE_SIZE * ($trans_id - 1), 4, ) ); } sub inc_txn_staleness_counter { my $self = shift; my ($trans_id) = @_; # Hardcode staleness of 0 for the HEAD return unless $trans_id; $self->storage->print_at( $self->trans_loc + 4 + $STALE_SIZE * ($trans_id - 1), pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ), ); } sub get_entries { my $self = shift; return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ]; } sub add_entry { my $self = shift; my ($trans_id, $loc) = @_; $self->{entries}{$trans_id} ||= {}; $self->{entries}{$trans_id}{$loc} = undef; } # If the buckets are being relocated because of a reindexing, the entries # mechanism needs to be made aware of it. sub reindex_entry { my $self = shift; my ($old_loc, $new_loc) = @_; TRANS: while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) { foreach my $orig_loc ( keys %{ $locs } ) { if ( $orig_loc == $old_loc ) { delete $locs->{orig_loc}; $locs->{$new_loc} = undef; next TRANS; } } } } sub clear_entries { my $self = shift; delete $self->{entries}{$self->trans_id}; } ################################################################################ { my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4; my $this_file_version = 2; sub _write_file_header { my $self = shift; my $nt = $self->num_txns; my $bl = $self->txn_bitfield_len; my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size; my $loc = $self->storage->request_space( $header_fixed + $header_var ); $self->storage->print_at( $loc, SIG_FILE, SIG_HEADER, pack('N', $this_file_version), # At this point, we're at 9 bytes pack('N', $header_var), # header size # --- Above is $header_fixed. Below is $header_var pack('C', $self->byte_size), # These shenanigans are to allow a 256 within a C pack('C', $self->max_buckets - 1), pack('C', $self->data_sector_size - 1), pack('C', $nt), pack('C' . $bl, 0 ), # Transaction activeness bitfield pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters pack($StP{$self->byte_size}, 0), # Start of free chain (blist size) pack($StP{$self->byte_size}, 0), # Start of free chain (data size) pack($StP{$self->byte_size}, 0), # Start of free chain (index size) ); #XXX Set these less fragilely $self->set_trans_loc( $header_fixed + 4 ); $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) ); return; } sub _read_file_header { my $self = shift; my $buffer = $self->storage->read_at( 0, $header_fixed ); return unless length($buffer); my ($file_signature, $sig_header, $file_version, $size) = unpack( 'A4 A N N', $buffer ); unless ( $file_signature eq SIG_FILE ) { $self->storage->close; DBM::Deep::10002->_throw_error( "Signature not found -- file is not a Deep DB" ); } unless ( $sig_header eq SIG_HEADER ) { $self->storage->close; DBM::Deep::10002->_throw_error( "Pre-1.00 file version found" ); } unless ( $file_version == $this_file_version ) { $self->storage->close; DBM::Deep::10002->_throw_error( "Wrong file version found - " . $file_version . " - expected " . $this_file_version ); } my $buffer2 = $self->storage->read_at( undef, $size ); my @values = unpack( 'C C C C', $buffer2 ); if ( @values != 4 || grep { !defined } @values ) { $self->storage->close; DBM::Deep::10002->_throw_error("Corrupted file - bad header"); } #XXX Add warnings if values weren't set right @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values; # These shenangians are to allow a 256 within a C $self->{max_buckets} += 1; $self->{data_sector_size} += 1; my $bl = $self->txn_bitfield_len; my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size; unless ( $size == $header_var ) { $self->storage->close; DBM::Deep::10002->_throw_error( "Unexpected size found ($size <-> $header_var)." ); } $self->set_trans_loc( $header_fixed + scalar(@values) ); $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) ); return length($buffer) + length($buffer2); } } sub _load_sector { my $self = shift; my ($offset) = @_; # Add a catch for offset of 0 or 1 return if $offset <= 1; my $type = $self->storage->read_at( $offset, 1 ); return if $type eq chr(0); if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) { return DBM::Deep::10002::Engine::Sector::Reference->new({ engine => $self, type => $type, offset => $offset, }); } # XXX Don't we need key_md5 here? elsif ( $type eq $self->SIG_BLIST ) { return DBM::Deep::10002::Engine::Sector::BucketList->new({ engine => $self, type => $type, offset => $offset, }); } elsif ( $type eq $self->SIG_INDEX ) { return DBM::Deep::10002::Engine::Sector::Index->new({ engine => $self, type => $type, offset => $offset, }); } elsif ( $type eq $self->SIG_NULL ) { return DBM::Deep::10002::Engine::Sector::Null->new({ engine => $self, type => $type, offset => $offset, }); } elsif ( $type eq $self->SIG_DATA ) { return DBM::Deep::10002::Engine::Sector::Scalar->new({ engine => $self, type => $type, offset => $offset, }); } # This was deleted from under us, so just return and let the caller figure it out. elsif ( $type eq $self->SIG_FREE ) { return; } DBM::Deep::10002->_throw_error( "'$offset': Don't know what to do with type '$type'" ); } sub _apply_digest { my $self = shift; return $self->{digest}->(@_); } sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) } sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) } sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) } sub _add_free_sector { my $self = shift; my ($multiple, $offset, $size) = @_; my $chains_offset = $multiple * $self->byte_size; my $storage = $self->storage; # Increment staleness. # XXX Can this increment+modulo be done by "&= 0x1" ? my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + SIG_SIZE, $STALE_SIZE ) ); $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) ); $storage->print_at( $offset + SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) ); my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); $storage->print_at( $self->chains_loc + $chains_offset, pack( $StP{$self->byte_size}, $offset ), ); # Record the old head in the new sector after the signature and staleness counter $storage->print_at( $offset + SIG_SIZE + $STALE_SIZE, $old_head ); } sub _request_blist_sector { shift->_request_sector( 0, @_ ) } sub _request_data_sector { shift->_request_sector( 1, @_ ) } sub _request_index_sector { shift->_request_sector( 2, @_ ) } sub _request_sector { my $self = shift; my ($multiple, $size) = @_; my $chains_offset = $multiple * $self->byte_size; my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); my $loc = unpack( $StP{$self->byte_size}, $old_head ); # We don't have any free sectors of the right size, so allocate a new one. unless ( $loc ) { my $offset = $self->storage->request_space( $size ); # Zero out the new sector. This also guarantees correct increases # in the filesize. $self->storage->print_at( $offset, chr(0) x $size ); return $offset; } # Read the new head after the signature and the staleness counter my $new_head = $self->storage->read_at( $loc + SIG_SIZE + $STALE_SIZE, $self->byte_size ); $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head ); $self->storage->print_at( $loc + SIG_SIZE + $STALE_SIZE, pack( $StP{$self->byte_size}, 0 ), ); return $loc; } ################################################################################ sub storage { $_[0]{storage} } sub byte_size { $_[0]{byte_size} } sub hash_size { $_[0]{hash_size} } sub hash_chars { $_[0]{hash_chars} } sub num_txns { $_[0]{num_txns} } sub max_buckets { $_[0]{max_buckets} } sub blank_md5 { chr(0) x $_[0]->hash_size } sub data_sector_size { $_[0]{data_sector_size} } # This is a calculated value sub txn_bitfield_len { my $self = shift; unless ( exists $self->{txn_bitfield_len} ) { my $temp = ($self->num_txns) / 8; if ( $temp > int( $temp ) ) { $temp = int( $temp ) + 1; } $self->{txn_bitfield_len} = $temp; } return $self->{txn_bitfield_len}; } sub trans_id { $_[0]{trans_id} } sub set_trans_id { $_[0]{trans_id} = $_[1] } sub trans_loc { $_[0]{trans_loc} } sub set_trans_loc { $_[0]{trans_loc} = $_[1] } sub chains_loc { $_[0]{chains_loc} } sub set_chains_loc { $_[0]{chains_loc} = $_[1] } ################################################################################ package DBM::Deep::10002::Iterator; sub new { my $class = shift; my ($args) = @_; my $self = bless { breadcrumbs => [], engine => $args->{engine}, base_offset => $args->{base_offset}, }, $class; Scalar::Util::weaken( $self->{engine} ); return $self; } sub reset { $_[0]{breadcrumbs} = [] } sub get_sector_iterator { my $self = shift; my ($loc) = @_; my $sector = $self->{engine}->_load_sector( $loc ) or return; if ( $sector->isa( 'DBM::Deep::10002::Engine::Sector::Index' ) ) { return DBM::Deep::10002::Iterator::Index->new({ iterator => $self, sector => $sector, }); } elsif ( $sector->isa( 'DBM::Deep::10002::Engine::Sector::BucketList' ) ) { return DBM::Deep::10002::Iterator::BucketList->new({ iterator => $self, sector => $sector, }); } DBM::Deep::10002->_throw_error( "get_sector_iterator(): Why did $loc make a $sector?" ); } sub get_next_key { my $self = shift; my ($obj) = @_; my $crumbs = $self->{breadcrumbs}; my $e = $self->{engine}; unless ( @$crumbs ) { # This will be a Reference sector my $sector = $e->_load_sector( $self->{base_offset} ) # If no sector is found, thist must have been deleted from under us. or return; if ( $sector->staleness != $obj->_staleness ) { return; } my $loc = $sector->get_blist_loc or return; push @$crumbs, $self->get_sector_iterator( $loc ); } FIND_NEXT_KEY: { # We're at the end. unless ( @$crumbs ) { $self->reset; return; } my $iterator = $crumbs->[-1]; # This level is done. if ( $iterator->at_end ) { pop @$crumbs; redo FIND_NEXT_KEY; } if ( $iterator->isa( 'DBM::Deep::10002::Iterator::Index' ) ) { # If we don't have any more, it will be caught at the # prior check. if ( my $next = $iterator->get_next_iterator ) { push @$crumbs, $next; } redo FIND_NEXT_KEY; } unless ( $iterator->isa( 'DBM::Deep::10002::Iterator::BucketList' ) ) { DBM::Deep::10002->_throw_error( "Should have a bucketlist iterator here - instead have $iterator" ); } # At this point, we have a BucketList iterator my $key = $iterator->get_next_key; if ( defined $key ) { return $key; } #XXX else { $iterator->set_to_end() } ? # We hit the end of the bucketlist iterator, so redo redo FIND_NEXT_KEY; } DBM::Deep::10002->_throw_error( "get_next_key(): How did we get here?" ); } package DBM::Deep::10002::Iterator::Index; sub new { my $self = bless $_[1] => $_[0]; $self->{curr_index} = 0; return $self; } sub at_end { my $self = shift; return $self->{curr_index} >= $self->{iterator}{engine}->hash_chars; } sub get_next_iterator { my $self = shift; my $loc; while ( !$loc ) { return if $self->at_end; $loc = $self->{sector}->get_entry( $self->{curr_index}++ ); } return $self->{iterator}->get_sector_iterator( $loc ); } package DBM::Deep::10002::Iterator::BucketList; sub new { my $self = bless $_[1] => $_[0]; $self->{curr_index} = 0; return $self; } sub at_end { my $self = shift; return $self->{curr_index} >= $self->{iterator}{engine}->max_buckets; } sub get_next_key { my $self = shift; return if $self->at_end; my $idx = $self->{curr_index}++; my $data_loc = $self->{sector}->get_data_location_for({ allow_head => 1, idx => $idx, }) or return; #XXX Do we want to add corruption checks here? return $self->{sector}->get_key_for( $idx )->data; } package DBM::Deep::10002::Engine::Sector; sub new { my $self = bless $_[1], $_[0]; Scalar::Util::weaken( $self->{engine} ); $self->_init; return $self; } #sub _init {} #sub clone { DBM::Deep::10002->_throw_error( "Must be implemented in the child class" ); } sub engine { $_[0]{engine} } sub offset { $_[0]{offset} } sub type { $_[0]{type} } sub base_size { my $self = shift; return $self->engine->SIG_SIZE + $STALE_SIZE; } sub free { my $self = shift; my $e = $self->engine; $e->storage->print_at( $self->offset, $e->SIG_FREE ); # Skip staleness counter $e->storage->print_at( $self->offset + $self->base_size, chr(0) x ($self->size - $self->base_size), ); my $free_meth = $self->free_meth; $e->$free_meth( $self->offset, $self->size ); return; } package DBM::Deep::10002::Engine::Sector::Data; our @ISA = qw( DBM::Deep::10002::Engine::Sector ); # This is in bytes sub size { $_[0]{engine}->data_sector_size } sub free_meth { return '_add_free_data_sector' } sub clone { my $self = shift; return ref($self)->new({ engine => $self->engine, type => $self->type, data => $self->data, }); } package DBM::Deep::10002::Engine::Sector::Scalar; our @ISA = qw( DBM::Deep::10002::Engine::Sector::Data ); sub free { my $self = shift; my $chain_loc = $self->chain_loc; $self->SUPER::free(); if ( $chain_loc ) { $self->engine->_load_sector( $chain_loc )->free; } return; } sub type { $_[0]{engine}->SIG_DATA } sub _init { my $self = shift; my $engine = $self->engine; unless ( $self->offset ) { my $data_section = $self->size - $self->base_size - $engine->byte_size - 1; $self->{offset} = $engine->_request_data_sector( $self->size ); my $data = delete $self->{data}; my $dlen = length $data; my $continue = 1; my $curr_offset = $self->offset; while ( $continue ) { my $next_offset = 0; my ($leftover, $this_len, $chunk); if ( $dlen > $data_section ) { $leftover = 0; $this_len = $data_section; $chunk = substr( $data, 0, $this_len ); $dlen -= $data_section; $next_offset = $engine->_request_data_sector( $self->size ); $data = substr( $data, $this_len ); } else { $leftover = $data_section - $dlen; $this_len = $dlen; $chunk = $data; $continue = 0; } $engine->storage->print_at( $curr_offset, $self->type ); # Sector type # Skip staleness $engine->storage->print_at( $curr_offset + $self->base_size, pack( $StP{$engine->byte_size}, $next_offset ), # Chain loc pack( $StP{1}, $this_len ), # Data length $chunk, # Data to be stored in this sector chr(0) x $leftover, # Zero-fill the rest ); $curr_offset = $next_offset; } return; } } sub data_length { my $self = shift; my $buffer = $self->engine->storage->read_at( $self->offset + $self->base_size + $self->engine->byte_size, 1 ); return unpack( $StP{1}, $buffer ); } sub chain_loc { my $self = shift; return unpack( $StP{$self->engine->byte_size}, $self->engine->storage->read_at( $self->offset + $self->base_size, $self->engine->byte_size, ), ); } sub data { my $self = shift; my $data; while ( 1 ) { my $chain_loc = $self->chain_loc; $data .= $self->engine->storage->read_at( $self->offset + $self->base_size + $self->engine->byte_size + 1, $self->data_length, ); last unless $chain_loc; $self = $self->engine->_load_sector( $chain_loc ); } return $data; } package DBM::Deep::10002::Engine::Sector::Null; our @ISA = qw( DBM::Deep::10002::Engine::Sector::Data ); sub type { $_[0]{engine}->SIG_NULL } sub data_length { 0 } sub data { return } sub _init { my $self = shift; my $engine = $self->engine; unless ( $self->offset ) { my $leftover = $self->size - $self->base_size - 1 * $engine->byte_size - 1; $self->{offset} = $engine->_request_data_sector( $self->size ); $engine->storage->print_at( $self->offset, $self->type ); # Sector type # Skip staleness counter $engine->storage->print_at( $self->offset + $self->base_size, pack( $StP{$engine->byte_size}, 0 ), # Chain loc pack( $StP{1}, $self->data_length ), # Data length chr(0) x $leftover, # Zero-fill the rest ); return; } } package DBM::Deep::10002::Engine::Sector::Reference; our @ISA = qw( DBM::Deep::10002::Engine::Sector::Data ); sub _init { my $self = shift; my $e = $self->engine; unless ( $self->offset ) { my $classname = Scalar::Util::blessed( delete $self->{data} ); my $leftover = $self->size - $self->base_size - 2 * $e->byte_size; my $class_offset = 0; if ( defined $classname ) { my $class_sector = DBM::Deep::10002::Engine::Sector::Scalar->new({ engine => $e, data => $classname, }); $class_offset = $class_sector->offset; } $self->{offset} = $e->_request_data_sector( $self->size ); $e->storage->print_at( $self->offset, $self->type ); # Sector type # Skip staleness counter $e->storage->print_at( $self->offset + $self->base_size, pack( $StP{$e->byte_size}, 0 ), # Index/BList loc pack( $StP{$e->byte_size}, $class_offset ), # Classname loc chr(0) x $leftover, # Zero-fill the rest ); } else { $self->{type} = $e->storage->read_at( $self->offset, 1 ); } $self->{staleness} = unpack( $StP{$STALE_SIZE}, $e->storage->read_at( $self->offset + $e->SIG_SIZE, $STALE_SIZE ), ); return; } sub free { my $self = shift; my $blist_loc = $self->get_blist_loc; $self->engine->_load_sector( $blist_loc )->free if $blist_loc; my $class_loc = $self->get_class_offset; $self->engine->_load_sector( $class_loc )->free if $class_loc; $self->SUPER::free(); } sub staleness { $_[0]{staleness} } sub get_data_for { my $self = shift; my ($args) = @_; # Assume that the head is not allowed unless otherwise specified. $args->{allow_head} = 0 unless exists $args->{allow_head}; # Assume we don't create a new blist location unless otherwise specified. $args->{create} = 0 unless exists $args->{create}; my $blist = $self->get_bucket_list({ key_md5 => $args->{key_md5}, key => $args->{key}, create => $args->{create}, }); return unless $blist && $blist->{found}; # At this point, $blist knows where the md5 is. What it -doesn't- know yet # is whether or not this transaction has this key. That's part of the next # function call. my $location = $blist->get_data_location_for({ allow_head => $args->{allow_head}, }) or return; return $self->engine->_load_sector( $location ); } sub write_data { my $self = shift; my ($args) = @_; my $blist = $self->get_bucket_list({ key_md5 => $args->{key_md5}, key => $args->{key}, create => 1, }) or DBM::Deep::10002->_throw_error( "How did write_data fail (no blist)?!" ); # Handle any transactional bookkeeping. if ( $self->engine->trans_id ) { if ( ! $blist->has_md5 ) { $blist->mark_deleted({ trans_id => 0, }); } } else { my @trans_ids = $self->engine->get_running_txn_ids; if ( $blist->has_md5 ) { if ( @trans_ids ) { my $old_value = $blist->get_data_for; foreach my $other_trans_id ( @trans_ids ) { next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0, }); $blist->write_md5({ trans_id => $other_trans_id, key => $args->{key}, key_md5 => $args->{key_md5}, value => $old_value->clone, }); } } } else { if ( @trans_ids ) { foreach my $other_trans_id ( @trans_ids ) { #XXX This doesn't seem to possible to ever happen . . . next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); $blist->mark_deleted({ trans_id => $other_trans_id, }); } } } } #XXX Is this safe to do transactionally? # Free the place we're about to write to. if ( $blist->get_data_location_for({ allow_head => 0 }) ) { $blist->get_data_for({ allow_head => 0 })->free; } $blist->write_md5({ key => $args->{key}, key_md5 => $args->{key_md5}, value => $args->{value}, }); } sub delete_key { my $self = shift; my ($args) = @_; # XXX What should happen if this fails? my $blist = $self->get_bucket_list({ key_md5 => $args->{key_md5}, }) or DBM::Deep::10002->_throw_error( "How did delete_key fail (no blist)?!" ); # Save the location so that we can free the data my $location = $blist->get_data_location_for({ allow_head => 0, }); my $old_value = $location && $self->engine->_load_sector( $location ); my @trans_ids = $self->engine->get_running_txn_ids; if ( $self->engine->trans_id == 0 ) { if ( @trans_ids ) { foreach my $other_trans_id ( @trans_ids ) { next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); $blist->write_md5({ trans_id => $other_trans_id, key => $args->{key}, key_md5 => $args->{key_md5}, value => $old_value->clone, }); } } } my $data; if ( @trans_ids ) { $blist->mark_deleted( $args ); if ( $old_value ) { $data = $old_value->data; $old_value->free; } } else { $data = $blist->delete_md5( $args ); } return $data; } sub get_blist_loc { my $self = shift; my $e = $self->engine; my $blist_loc = $e->storage->read_at( $self->offset + $self->base_size, $e->byte_size ); return unpack( $StP{$e->byte_size}, $blist_loc ); } sub get_bucket_list { my $self = shift; my ($args) = @_; $args ||= {}; # XXX Add in check here for recycling? my $engine = $self->engine; my $blist_loc = $self->get_blist_loc; # There's no index or blist yet unless ( $blist_loc ) { return unless $args->{create}; my $blist = DBM::Deep::10002::Engine::Sector::BucketList->new({ engine => $engine, key_md5 => $args->{key_md5}, }); $engine->storage->print_at( $self->offset + $self->base_size, pack( $StP{$engine->byte_size}, $blist->offset ), ); return $blist; } my $sector = $engine->_load_sector( $blist_loc ) or DBM::Deep::10002->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" ); my $i = 0; my $last_sector = undef; while ( $sector->isa( 'DBM::Deep::10002::Engine::Sector::Index' ) ) { $blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) ); $last_sector = $sector; if ( $blist_loc ) { $sector = $engine->_load_sector( $blist_loc ) or DBM::Deep::10002->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" ); } else { $sector = undef; last; } } # This means we went through the Index sector(s) and found an empty slot unless ( $sector ) { return unless $args->{create}; DBM::Deep::10002->_throw_error( "No last_sector when attempting to build a new entry" ) unless $last_sector; my $blist = DBM::Deep::10002::Engine::Sector::BucketList->new({ engine => $engine, key_md5 => $args->{key_md5}, }); $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset ); return $blist; } $sector->find_md5( $args->{key_md5} ); # See whether or not we need to reindex the bucketlist if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) { my $new_index = DBM::Deep::10002::Engine::Sector::Index->new({ engine => $engine, }); my %blist_cache; #XXX q.v. the comments for this function. foreach my $entry ( $sector->chopped_up ) { my ($spot, $md5) = @{$entry}; my $idx = ord( substr( $md5, $i, 1 ) ); # XXX This is inefficient my $blist = $blist_cache{$idx} ||= DBM::Deep::10002::Engine::Sector::BucketList->new({ engine => $engine, }); $new_index->set_entry( $idx => $blist->offset ); my $new_spot = $blist->write_at_next_open( $md5 ); $engine->reindex_entry( $spot => $new_spot ); } # Handle the new item separately. { my $idx = ord( substr( $args->{key_md5}, $i, 1 ) ); my $blist = $blist_cache{$idx} ||= DBM::Deep::10002::Engine::Sector::BucketList->new({ engine => $engine, }); $new_index->set_entry( $idx => $blist->offset ); #XXX THIS IS HACKY! $blist->find_md5( $args->{key_md5} ); $blist->write_md5({ key => $args->{key}, key_md5 => $args->{key_md5}, value => DBM::Deep::10002::Engine::Sector::Null->new({ engine => $engine, data => undef, }), }); } if ( $last_sector ) { $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ), $new_index->offset, ); } else { $engine->storage->print_at( $self->offset + $self->base_size, pack( $StP{$engine->byte_size}, $new_index->offset ), ); } $sector->free; $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) }; $sector->find_md5( $args->{key_md5} ); } return $sector; } sub get_class_offset { my $self = shift; my $e = $self->engine; return unpack( $StP{$e->byte_size}, $e->storage->read_at( $self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size, ), ); } sub get_classname { my $self = shift; my $class_offset = $self->get_class_offset; return unless $class_offset; return $self->engine->_load_sector( $class_offset )->data; } #XXX Add singleton handling here sub data { my $self = shift; my $new_obj = DBM::Deep::10002->new({ type => $self->type, base_offset => $self->offset, staleness => $self->staleness, storage => $self->engine->storage, engine => $self->engine, }); if ( $self->engine->storage->{autobless} ) { my $classname = $self->get_classname; if ( defined $classname ) { bless $new_obj, $classname; } } return $new_obj; } package DBM::Deep::10002::Engine::Sector::BucketList; our @ISA = qw( DBM::Deep::10002::Engine::Sector ); sub _init { my $self = shift; my $engine = $self->engine; unless ( $self->offset ) { my $leftover = $self->size - $self->base_size; $self->{offset} = $engine->_request_blist_sector( $self->size ); $engine->storage->print_at( $self->offset, $engine->SIG_BLIST ); # Sector type # Skip staleness counter $engine->storage->print_at( $self->offset + $self->base_size, chr(0) x $leftover, # Zero-fill the data ); } if ( $self->{key_md5} ) { $self->find_md5; } return $self; } sub size { my $self = shift; unless ( $self->{size} ) { my $e = $self->engine; # Base + numbuckets * bucketsize $self->{size} = $self->base_size + $e->max_buckets * $self->bucket_size; } return $self->{size}; } sub free_meth { return '_add_free_blist_sector' } sub bucket_size { my $self = shift; unless ( $self->{bucket_size} ) { my $e = $self->engine; # Key + head (location) + transactions (location + staleness-counter) my $location_size = $e->byte_size + $e->byte_size + ($e->num_txns - 1) * ($e->byte_size + $STALE_SIZE); $self->{bucket_size} = $e->hash_size + $location_size; } return $self->{bucket_size}; } # XXX This is such a poor hack. I need to rethink this code. sub chopped_up { my $self = shift; my $e = $self->engine; my @buckets; foreach my $idx ( 0 .. $e->max_buckets - 1 ) { my $spot = $self->offset + $self->base_size + $idx * $self->bucket_size; my $md5 = $e->storage->read_at( $spot, $e->hash_size ); #XXX If we're chopping, why would we ever have the blank_md5? last if $md5 eq $e->blank_md5; my $rest = $e->storage->read_at( undef, $self->bucket_size - $e->hash_size ); push @buckets, [ $spot, $md5 . $rest ]; } return @buckets; } sub write_at_next_open { my $self = shift; my ($entry) = @_; #XXX This is such a hack! $self->{_next_open} = 0 unless exists $self->{_next_open}; my $spot = $self->offset + $self->base_size + $self->{_next_open}++ * $self->bucket_size; $self->engine->storage->print_at( $spot, $entry ); return $spot; } sub has_md5 { my $self = shift; unless ( exists $self->{found} ) { $self->find_md5; } return $self->{found}; } sub find_md5 { my $self = shift; $self->{found} = undef; $self->{idx} = -1; if ( @_ ) { $self->{key_md5} = shift; } # If we don't have an MD5, then what are we supposed to do? unless ( exists $self->{key_md5} ) { DBM::Deep::10002->_throw_error( "Cannot find_md5 without a key_md5 set" ); } my $e = $self->engine; foreach my $idx ( 0 .. $e->max_buckets - 1 ) { my $potential = $e->storage->read_at( $self->offset + $self->base_size + $idx * $self->bucket_size, $e->hash_size, ); if ( $potential eq $e->blank_md5 ) { $self->{idx} = $idx; return; } if ( $potential eq $self->{key_md5} ) { $self->{found} = 1; $self->{idx} = $idx; return; } } return; } sub write_md5 { my $self = shift; my ($args) = @_; DBM::Deep::10002->_throw_error( "write_md5: no key" ) unless exists $args->{key}; DBM::Deep::10002->_throw_error( "write_md5: no key_md5" ) unless exists $args->{key_md5}; DBM::Deep::10002->_throw_error( "write_md5: no value" ) unless exists $args->{value}; my $engine = $self->engine; $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; $engine->add_entry( $args->{trans_id}, $spot ); unless ($self->{found}) { my $key_sector = DBM::Deep::10002::Engine::Sector::Scalar->new({ engine => $engine, data => $args->{key}, }); $engine->storage->print_at( $spot, $args->{key_md5}, pack( $StP{$engine->byte_size}, $key_sector->offset ), ); } my $loc = $spot + $engine->hash_size + $engine->byte_size; if ( $args->{trans_id} ) { $loc += $engine->byte_size + ($args->{trans_id} - 1) * ( $engine->byte_size + $STALE_SIZE ); $engine->storage->print_at( $loc, pack( $StP{$engine->byte_size}, $args->{value}->offset ), pack( $StP{$STALE_SIZE}, $engine->get_txn_staleness_counter( $args->{trans_id} ) ), ); } else { $engine->storage->print_at( $loc, pack( $StP{$engine->byte_size}, $args->{value}->offset ), ); } } sub mark_deleted { my $self = shift; my ($args) = @_; $args ||= {}; my $engine = $self->engine; $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; $engine->add_entry( $args->{trans_id}, $spot ); my $loc = $spot + $engine->hash_size + $engine->byte_size; if ( $args->{trans_id} ) { $loc += $engine->byte_size + ($args->{trans_id} - 1) * ( $engine->byte_size + $STALE_SIZE ); $engine->storage->print_at( $loc, pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted pack( $StP{$STALE_SIZE}, $engine->get_txn_staleness_counter( $args->{trans_id} ) ), ); } else { $engine->storage->print_at( $loc, pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted ); } } sub delete_md5 { my $self = shift; my ($args) = @_; my $engine = $self->engine; return undef unless $self->{found}; # Save the location so that we can free the data my $location = $self->get_data_location_for({ allow_head => 0, }); my $key_sector = $self->get_key_for; my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; $engine->storage->print_at( $spot, $engine->storage->read_at( $spot + $self->bucket_size, $self->bucket_size * ( $engine->max_buckets - $self->{idx} - 1 ), ), chr(0) x $self->bucket_size, ); $key_sector->free; my $data_sector = $self->engine->_load_sector( $location ); my $data = $data_sector->data; $data_sector->free; return $data; } sub get_data_location_for { my $self = shift; my ($args) = @_; $args ||= {}; $args->{allow_head} = 0 unless exists $args->{allow_head}; $args->{trans_id} = $self->engine->trans_id unless exists $args->{trans_id}; $args->{idx} = $self->{idx} unless exists $args->{idx}; my $e = $self->engine; my $spot = $self->offset + $self->base_size + $args->{idx} * $self->bucket_size + $e->hash_size + $e->byte_size; if ( $args->{trans_id} ) { $spot += $e->byte_size + ($args->{trans_id} - 1) * ( $e->byte_size + $STALE_SIZE ); } my $buffer = $e->storage->read_at( $spot, $e->byte_size + $STALE_SIZE, ); my ($loc, $staleness) = unpack( $StP{$e->byte_size} . ' ' . $StP{$STALE_SIZE}, $buffer ); if ( $args->{trans_id} ) { # We have found an entry that is old, so get rid of it if ( $staleness != (my $s = $e->get_txn_staleness_counter( $args->{trans_id} ) ) ) { $e->storage->print_at( $spot, pack( $StP{$e->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ), ); $loc = 0; } } # If we're in a transaction and we never wrote to this location, try the # HEAD instead. if ( $args->{trans_id} && !$loc && $args->{allow_head} ) { return $self->get_data_location_for({ trans_id => 0, allow_head => 1, idx => $args->{idx}, }); } return $loc <= 1 ? 0 : $loc; } sub get_data_for { my $self = shift; my ($args) = @_; $args ||= {}; return unless $self->{found}; my $location = $self->get_data_location_for({ allow_head => $args->{allow_head}, }); return $self->engine->_load_sector( $location ); } sub get_key_for { my $self = shift; my ($idx) = @_; $idx = $self->{idx} unless defined $idx; if ( $idx >= $self->engine->max_buckets ) { DBM::Deep::10002->_throw_error( "get_key_for(): Attempting to retrieve $idx" ); } my $location = $self->engine->storage->read_at( $self->offset + $self->base_size + $idx * $self->bucket_size + $self->engine->hash_size, $self->engine->byte_size, ); $location = unpack( $StP{$self->engine->byte_size}, $location ); DBM::Deep::10002->_throw_error( "get_key_for: No location?" ) unless $location; return $self->engine->_load_sector( $location ); } package DBM::Deep::10002::Engine::Sector::Index; our @ISA = qw( DBM::Deep::10002::Engine::Sector ); sub _init { my $self = shift; my $engine = $self->engine; unless ( $self->offset ) { my $leftover = $self->size - $self->base_size; $self->{offset} = $engine->_request_index_sector( $self->size ); $engine->storage->print_at( $self->offset, $engine->SIG_INDEX ); # Sector type # Skip staleness counter $engine->storage->print_at( $self->offset + $self->base_size, chr(0) x $leftover, # Zero-fill the rest ); } return $self; } #XXX Change here sub size { my $self = shift; unless ( $self->{size} ) { my $e = $self->engine; $self->{size} = $self->base_size + $e->byte_size * $e->hash_chars; } return $self->{size}; } sub free_meth { return '_add_free_index_sector' } sub free { my $self = shift; my $e = $self->engine; for my $i ( 0 .. $e->hash_chars - 1 ) { my $l = $self->get_entry( $i ) or next; $e->_load_sector( $l )->free; } $self->SUPER::free(); } sub _loc_for { my $self = shift; my ($idx) = @_; return $self->offset + $self->base_size + $idx * $self->engine->byte_size; } sub get_entry { my $self = shift; my ($idx) = @_; my $e = $self->engine; DBM::Deep::10002->_throw_error( "get_entry: Out of range ($idx)" ) if $idx < 0 || $idx >= $e->hash_chars; return unpack( $StP{$e->byte_size}, $e->storage->read_at( $self->_loc_for( $idx ), $e->byte_size ), ); } sub set_entry { my $self = shift; my ($idx, $loc) = @_; my $e = $self->engine; DBM::Deep::10002->_throw_error( "set_entry: Out of range ($idx)" ) if $idx < 0 || $idx >= $e->hash_chars; $self->engine->storage->print_at( $self->_loc_for( $idx ), pack( $StP{$e->byte_size}, $loc ), ); } 1; __END__ DBM-Deep-2.0013/etc000755001750001750 012641624315 12362 5ustar00robrob000000000000DBM-Deep-2.0013/etc/sqlite_tables.sql000444001750001750 102012641624315 16064 0ustar00robrob000000000000DROP TABLE IF EXISTS datas; DROP TABLE IF EXISTS refs; CREATE TABLE refs ( id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT ,ref_type STRING NOT NULL DEFAULT 'H' ,refcount INTEGER NOT NULL DEFAULT 1 ,classname STRING ); CREATE TABLE datas ( id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT ,ref_id INTEGER NOT NULL ,data_type STRING DEFAULT 'S' ,`key` STRING NOT NULL ,value STRING ,FOREIGN KEY (ref_id) REFERENCES refs (id) ON DELETE CASCADE ON UPDATE CASCADE ,UNIQUE (ref_id, `key` ) ); DBM-Deep-2.0013/etc/mysql_tables.sql000444001750001750 116412641624315 15741 0ustar00robrob000000000000DROP TABLE IF EXISTS datas; DROP TABLE IF EXISTS refs; CREATE TABLE refs ( id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY ,ref_type ENUM( 'H', 'A' ) NOT NULL DEFAULT 'H' ,refcount BIGINT UNSIGNED NOT NULL DEFAULT 1 ,classname LONGTEXT ) ENGINE=MyISAM; CREATE TABLE datas ( id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY ,ref_id BIGINT UNSIGNED NOT NULL ,data_type ENUM( 'S', 'R' ) DEFAULT 'S' ,`key` LONGTEXT NOT NULL ,value LONGTEXT ,FOREIGN KEY (ref_id) REFERENCES refs (id) ON DELETE CASCADE ON UPDATE CASCADE ,UNIQUE INDEX (ref_id, `key` (700) ) ) ENGINE=MyISAM; DBM-Deep-2.0013/lib000755001750001750 012641624315 12355 5ustar00robrob000000000000DBM-Deep-2.0013/lib/DBM000755001750001750 012641624315 12757 5ustar00robrob000000000000DBM-Deep-2.0013/lib/DBM/Deep.pod000444001750001750 12664312641624315 14551 0ustar00robrob000000000000=head1 NAME DBM::Deep - A pure perl multi-level hash/array DBM that supports transactions =head1 VERSION 2.0013 =head1 SYNOPSIS use DBM::Deep; my $db = DBM::Deep->new( "foo.db" ); $db->{key} = 'value'; print $db->{key}; $db->put('key' => 'value'); print $db->get('key'); # true multi-level support $db->{my_complex} = [ 'hello', { perl => 'rules' }, 42, 99, ]; $db->begin_work; # Do stuff here $db->rollback; $db->commit; tie my %db, 'DBM::Deep', 'foo.db'; $db{key} = 'value'; print $db{key}; tied(%db)->put('key' => 'value'); print tied(%db)->get('key'); =head1 DESCRIPTION A unique flat-file database module, written in pure perl. True multi-level hash/array support (unlike MLDBM, which is faked), hybrid OO / tie() interface, cross-platform FTPable files, ACID transactions, and is quite fast. Can handle millions of keys and unlimited levels without significant slow-down. Written from the ground-up in pure perl -- this is NOT a wrapper around a C-based DBM. Out-of-the-box compatibility with Unix, Mac OS X and Windows. =head1 VERSION DIFFERENCES B: 2.0000 introduces Unicode support in the File back end. This necessitates a change in the file format. The version 1.0003 format is still supported, though, so we have added a L method. If you are using a database in the old format, you will have to upgrade it to get Unicode support. B: 1.0020 introduces different engines which are backed by different types of storage. There is the original storage (called 'File') and a database storage (called 'DBI'). q.v. L for more information. B: 1.0000 has significant file format differences from prior versions. There is a backwards-compatibility layer at C. Files created by 1.0000 or higher are B compatible with scripts using prior versions. =head1 PLUGINS DBM::Deep is a wrapper around different storage engines. These are: =head2 File This is the traditional storage engine, storing the data to a custom file format. The parameters accepted are: =over 4 =item * file Filename of the DB file to link the handle to. You can pass a full absolute filesystem path, partial path, or a plain filename if the file is in the current working directory. This is a required parameter (though q.v. fh). =item * fh If you want, you can pass in the fh instead of the file. This is most useful for doing something like: my $db = DBM::Deep->new( { fh => \*DATA } ); You are responsible for making sure that the fh has been opened appropriately for your needs. If you open it read-only and attempt to write, an exception will be thrown. If you open it write-only or append-only, an exception will be thrown immediately as DBM::Deep needs to read from the fh. =item * file_offset This is the offset within the file that the DBM::Deep db starts. Most of the time, you will not need to set this. However, it's there if you want it. If you pass in fh and do not set this, it will be set appropriately. =item * locking Specifies whether locking is to be enabled. DBM::Deep uses Perl's flock() function to lock the database in exclusive mode for writes, and shared mode for reads. Pass any true value to enable. This affects the base DB handle I that use the same DB file. This is an optional parameter, and defaults to 1 (enabled). See L below for more. =back When you open an existing database file, the version of the database format will stay the same. But if you are creating a new file, it will be in the latest format. =head2 DBI This is a storage engine that stores the data in a relational database. Funnily enough, this engine doesn't work with transactions (yet) as InnoDB doesn't do what DBM::Deep needs it to do. The parameters accepted are: =over 4 =item * dbh This is a DBH that's already been opened with L. =item * dbi This is a hashref containing: =over 4 =item * dsn =item * username =item * password =item * connect_args =back These correspond to the 4 parameters L takes. =back B: This has only been tested with MySQL and SQLite (with disappointing results). I plan on extending this to work with PostgreSQL in the near future. Oracle, Sybase, and other engines will come later. =head2 Planned engines There are plans to extend this functionality to (at least) the following: =over 4 =item * BDB (and other hash engines like memcached) =item * NoSQL engines (such as Tokyo Cabinet) =item * DBIx::Class (and other ORMs) =back =head1 SETUP Construction can be done OO-style (which is the recommended way), or using Perl's tie() function. Both are examined here. =head2 OO Construction The recommended way to construct a DBM::Deep object is to use the new() method, which gets you a blessed I tied hash (or array) reference. my $db = DBM::Deep->new( "foo.db" ); This opens a new database handle, mapped to the file "foo.db". If this file does not exist, it will automatically be created. DB files are opened in "r+" (read/write) mode, and the type of object returned is a hash, unless otherwise specified (see L below). You can pass a number of options to the constructor to specify things like locking, autoflush, etc. This is done by passing an inline hash (or hashref): my $db = DBM::Deep->new( file => "foo.db", locking => 1, autoflush => 1 ); Notice that the filename is now specified I the hash with the "file" parameter, as opposed to being the sole argument to the constructor. This is required if any options are specified. See L below for the complete list. You can also start with an array instead of a hash. For this, you must specify the C parameter: my $db = DBM::Deep->new( file => "foo.db", type => DBM::Deep->TYPE_ARRAY ); B Specifying the C parameter only takes effect when beginning a new DB file. If you create a DBM::Deep object with an existing file, the C will be loaded from the file header, and an error will be thrown if the wrong type is passed in. =head2 Tie Construction Alternately, you can create a DBM::Deep handle by using Perl's built-in tie() function. The object returned from tie() can be used to call methods, such as lock() and unlock(). (That object can be retrieved from the tied variable at any time using tied() - please see L for more info.) my %hash; my $db = tie %hash, "DBM::Deep", "foo.db"; my @array; my $db = tie @array, "DBM::Deep", "bar.db"; As with the OO constructor, you can replace the DB filename parameter with a hash containing one or more options (see L just below for the complete list). tie %hash, "DBM::Deep", { file => "foo.db", locking => 1, autoflush => 1 }; =head2 Options There are a number of options that can be passed in when constructing your DBM::Deep objects. These apply to both the OO- and tie- based approaches. =over =item * type This parameter specifies what type of object to create, a hash or array. Use one of these two constants: =over 4 =item * C<< DBM::Deep->TYPE_HASH >> =item * C<< DBM::Deep->TYPE_ARRAY >> =back This only takes effect when beginning a new file. This is an optional parameter, and defaults to C<< DBM::Deep->TYPE_HASH >>. =item * autoflush Specifies whether autoflush is to be enabled on the underlying filehandle. This obviously slows down write operations, but is required if you may have multiple processes accessing the same DB file (also consider enable I). Pass any true value to enable. This is an optional parameter, and defaults to 1 (enabled). =item * filter_* See L below. =back The following parameters may be specified in the constructor the first time the datafile is created. However, they will be stored in the header of the file and cannot be overridden by subsequent openings of the file - the values will be set from the values stored in the datafile's header. =over 4 =item * num_txns This is the number of transactions that can be running at one time. The default is one - the HEAD. The minimum is one and the maximum is 255. The more transactions, the larger and quicker the datafile grows. Simple access to a database, regardless of how many processes are doing it, already counts as one transaction (the HEAD). So, if you want, say, 5 processes to be able to call begin_work at the same time, C must be at least 6. See L below. =item * max_buckets This is the number of entries that can be added before a reindexing. The larger this number is made, the larger a file gets, but the better performance you will have. The default and minimum number this can be is 16. The maximum is 256, but more than 64 isn't recommended. =item * data_sector_size This is the size in bytes of a given data sector. Data sectors will chain, so a value of any size can be stored. However, chaining is expensive in terms of time. Setting this value to something close to the expected common length of your scalars will improve your performance. If it is too small, your file will have a lot of chaining. If it is too large, your file will have a lot of dead space in it. The default for this is 64 bytes. The minimum value is 32 and the maximum is 256 bytes. B There are between 6 and 10 bytes taken up in each data sector for bookkeeping. (It's 4 + the number of bytes in your L.) This is included within the data_sector_size, thus the effective value is 6-10 bytes less than what you specified. B If your strings contain any characters beyond the byte range, they will be encoded as UTF-8 before being stored in the file. This will make all non-ASCII characters take up more than one byte each. =item * pack_size This is the size of the file pointer used throughout the file. The valid values are: =over 4 =item * small This uses 2-byte offsets, allowing for a maximum file size of 65 KB. =item * medium (default) This uses 4-byte offsets, allowing for a maximum file size of 4 GB. =item * large This uses 8-byte offsets, allowing for a maximum file size of 16 XB (exabytes). This can only be enabled if your Perl is compiled for 64-bit. =back See L for more information. =item * external_refs This is a boolean option. When enabled, it allows external references to database entries to hold on to those entries, even when they are deleted. To illustrate, if you retrieve a hash (or array) reference from the database, $foo_hash = $db->{foo}; the hash reference is still tied to the database. So if you delete $db->{foo}; C<$foo_hash> will point to a location in the DB that is no longer valid (we call this a stale reference). So if you try to retrieve the data from C<$foo_hash>, for(keys %$foo_hash) { you will get an error. The C option causes C<$foo_hash> to 'hang on' to the DB entry, so it will not be deleted from the database if there is still a reference to it in a running program. It will be deleted, instead, when the C<$foo_hash> variable no longer exists, or is overwritten. This has the potential to cause database bloat if your program crashes, so it is not enabled by default. (See also the L method for an alternative workaround.) =back =head1 TIE INTERFACE With DBM::Deep you can access your databases using Perl's standard hash/array syntax. Because all DBM::Deep objects are I to hashes or arrays, you can treat them as such (but see L, above, and L, below). DBM::Deep will intercept all reads/writes and direct them to the right place -- the DB file. This has nothing to do with the L section above. This simply tells you how to use DBM::Deep using regular hashes and arrays, rather than calling functions like C and C (although those work too). It is entirely up to you how to want to access your databases. =head2 Hashes You can treat any DBM::Deep object like a normal Perl hash reference. Add keys, or even nested hashes (or arrays) using standard Perl syntax: my $db = DBM::Deep->new( "foo.db" ); $db->{mykey} = "myvalue"; $db->{myhash} = {}; $db->{myhash}->{subkey} = "subvalue"; print $db->{myhash}->{subkey} . "\n"; You can even step through hash keys using the normal Perl C function: foreach my $key (keys %$db) { print "$key: " . $db->{$key} . "\n"; } Remember that Perl's C function extracts I key from the hash and pushes them onto an array, all before the loop even begins. If you have an extremely large hash, this may exhaust Perl's memory. Instead, consider using Perl's C function, which pulls keys/values one at a time, using very little memory: while (my ($key, $value) = each %$db) { print "$key: $value\n"; } Please note that when using C, you should always pass a direct hash reference, not a lookup. Meaning, you should B do this: # NEVER DO THIS while (my ($key, $value) = each %{$db->{foo}}) { # BAD This causes an infinite loop, because for each iteration, Perl is calling FETCH() on the $db handle, resulting in a "new" hash for foo every time, so it effectively keeps returning the first key over and over again. Instead, assign a temporary variable to C<< $db->{foo} >>, then pass that to each(). =head2 Arrays As with hashes, you can treat any DBM::Deep object like a normal Perl array reference. This includes inserting, removing and manipulating elements, and the C, C, C, C and C functions. The object must have first been created using type C<< DBM::Deep->TYPE_ARRAY >>, or simply be a nested array reference inside a hash. Example: my $db = DBM::Deep->new( file => "foo-array.db", type => DBM::Deep->TYPE_ARRAY ); $db->[0] = "foo"; push @$db, "bar", "baz"; unshift @$db, "bah"; my $last_elem = pop @$db; # baz my $first_elem = shift @$db; # bah my $second_elem = $db->[1]; # bar my $num_elements = scalar @$db; =head1 OO INTERFACE In addition to the I interface, you can also use a standard OO interface to manipulate all aspects of DBM::Deep databases. Each type of object (hash or array) has its own methods, but both types share the following common methods: C, C, C, C and C. C and C are aliases to C and C, respectively. =over =item * new() / clone() X X These are the constructor and copy-functions. =item * put() / store() X X Stores a new hash key/value pair, or sets an array element value. Takes two arguments, the hash key or array index, and the new value. The value can be a scalar, hash ref or array ref. Returns true on success, false on failure. $db->put("foo", "bar"); # for hashes $db->put(1, "bar"); # for arrays =item * get() / fetch() X X Fetches the value of a hash key or array element. Takes one argument: the hash key or array index. Returns a scalar, hash ref or array ref, depending on the data type stored. my $value = $db->get("foo"); # for hashes my $value = $db->get(1); # for arrays =item * exists() X Checks if a hash key or array index exists. Takes one argument: the hash key or array index. Returns true if it exists, false if not. if ($db->exists("foo")) { print "yay!\n"; } # for hashes if ($db->exists(1)) { print "yay!\n"; } # for arrays =item * delete() X Deletes one hash key/value pair or array element. Takes one argument: the hash key or array index. Returns the data that the element used to contain (just like Perl's C function), which is C if it did not exist. For arrays, the remaining elements located after the deleted element are NOT moved over. The deleted element is essentially just undefined, which is exactly how Perl's internal arrays work. $db->delete("foo"); # for hashes $db->delete(1); # for arrays =item * clear() X Deletes B hash keys or array elements. Takes no arguments. No return value. $db->clear(); # hashes or arrays =item * lock() / unlock() / lock_exclusive() / lock_shared() X X X X q.v. L for more info. =item * optimize() X This will compress the datafile so that it takes up as little space as possible. There is a freespace manager so that when space is freed up, it is used before extending the size of the datafile. But, that freespace just sits in the datafile unless C is called. C basically copies everything into a new database, so, if it is in version 1.0003 format, it will be upgraded. =item * import() X Unlike simple assignment, C does not tie the right-hand side. Instead, a copy of your data is put into the DB. C takes either an arrayref (if your DB is an array) or a hashref (if your DB is a hash). C will die if anything else is passed in. =item * export() X This returns a complete copy of the data structure at the point you do the export. This copy is in RAM, not on disk like the DB is. =item * begin_work() / commit() / rollback() These are the transactional functions. L for more information. =item * supports( $option ) X This returns a boolean indicating whether this instance of DBM::Deep supports that feature. C<$option> can be one of: =over 4 =item * transactions X =item * unicode X =back =item * db_version() X This returns the version of the database format that the current database is in. This is specified as the earliest version of DBM::Deep that supports it. For the File back end, this will be 1.0003 or 2. For the DBI back end, it is currently always 1.0020. =back =head2 Hashes For hashes, DBM::Deep supports all the common methods described above, and the following additional methods: C and C. =over =item * first_key() X Returns the "first" key in the hash. As with built-in Perl hashes, keys are fetched in an undefined order (which appears random). Takes no arguments, returns the key as a scalar value. my $key = $db->first_key(); =item * next_key() X Returns the "next" key in the hash, given the previous one as the sole argument. Returns undef if there are no more keys to be fetched. $key = $db->next_key($key); =back Here are some examples of using hashes: my $db = DBM::Deep->new( "foo.db" ); $db->put("foo", "bar"); print "foo: " . $db->get("foo") . "\n"; $db->put("baz", {}); # new child hash ref $db->get("baz")->put("buz", "biz"); print "buz: " . $db->get("baz")->get("buz") . "\n"; my $key = $db->first_key(); while ($key) { print "$key: " . $db->get($key) . "\n"; $key = $db->next_key($key); } if ($db->exists("foo")) { $db->delete("foo"); } =head2 Arrays For arrays, DBM::Deep supports all the common methods described above, and the following additional methods: C, C, C, C, C and C. =over =item * length() X Returns the number of elements in the array. Takes no arguments. my $len = $db->length(); =item * push() X Adds one or more elements onto the end of the array. Accepts scalars, hash refs or array refs. No return value. $db->push("foo", "bar", {}); =item * pop() X Fetches the last element in the array, and deletes it. Takes no arguments. Returns undef if array is empty. Returns the element value. my $elem = $db->pop(); =item * shift() X Fetches the first element in the array, deletes it, then shifts all the remaining elements over to take up the space. Returns the element value. This method is not recommended with large arrays -- see L below for details. my $elem = $db->shift(); =item * unshift() X Inserts one or more elements onto the beginning of the array, shifting all existing elements over to make room. Accepts scalars, hash refs or array refs. No return value. This method is not recommended with large arrays -- see below for details. $db->unshift("foo", "bar", {}); =item * splice() X Performs exactly like Perl's built-in function of the same name. See L for usage -- it is too complicated to document here. This method is not recommended with large arrays -- see L below for details. =back Here are some examples of using arrays: my $db = DBM::Deep->new( file => "foo.db", type => DBM::Deep->TYPE_ARRAY ); $db->push("bar", "baz"); $db->unshift("foo"); $db->put(3, "buz"); my $len = $db->length(); print "length: $len\n"; # 4 for (my $k=0; $k<$len; $k++) { print "$k: " . $db->get($k) . "\n"; } $db->splice(1, 2, "biz", "baf"); while (my $elem = shift @$db) { print "shifted: $elem\n"; } =head1 LOCKING Enable or disable automatic file locking by passing a boolean value to the C parameter when constructing your DBM::Deep object (see L above). my $db = DBM::Deep->new( file => "foo.db", locking => 1 ); This causes DBM::Deep to C the underlying filehandle with exclusive mode for writes, and shared mode for reads. This is required if you have multiple processes accessing the same database file, to avoid file corruption. Please note that C does NOT work for files over NFS. See L below for more. =head2 Explicit Locking You can explicitly lock a database, so it remains locked for multiple actions. This is done by calling the C method (for when you want to write) or the C method (for when you want to read). This is particularly useful for things like counters, where the current value needs to be fetched, then incremented, then stored again. $db->lock_exclusive(); my $counter = $db->get("counter"); $counter++; $db->put("counter", $counter); $db->unlock(); # or... $db->lock_exclusive(); $db->{counter}++; $db->unlock(); =head2 Win32/Cygwin Due to Win32 actually enforcing the read-only status of a shared lock, all locks on Win32 and cygwin are exclusive. This is because of how autovivification currently works. Hopefully, this will go away in a future release. =head1 IMPORTING/EXPORTING You can import existing complex structures by calling the C method, and export an entire database into an in-memory structure using the C method. Both are examined here. =head2 Importing Say you have an existing hash with nested hashes/arrays inside it. Instead of walking the structure and adding keys/elements to the database as you go, simply pass a reference to the C method. This recursively adds everything to an existing DBM::Deep object for you. Here is an example: my $struct = { key1 => "value1", key2 => "value2", array1 => [ "elem0", "elem1", "elem2" ], hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2" } }; my $db = DBM::Deep->new( "foo.db" ); $db->import( $struct ); print $db->{key1} . "\n"; # prints "value1" This recursively imports the entire C<$struct> object into C<$db>, including all nested hashes and arrays. If the DBM::Deep object contains existing data, keys are merged with the existing ones, replacing if they already exist. The C method can be called on any database level (not just the base level), and works with both hash and array DB types. B Make sure your existing structure has no circular references in it. These will cause an infinite loop when importing. There are plans to fix this in a later release. =head2 Exporting Calling the C method on an existing DBM::Deep object will return a reference to a new in-memory copy of the database. The export is done recursively, so all nested hashes/arrays are all exported to standard Perl objects. Here is an example: my $db = DBM::Deep->new( "foo.db" ); $db->{key1} = "value1"; $db->{key2} = "value2"; $db->{hash1} = {}; $db->{hash1}->{subkey1} = "subvalue1"; $db->{hash1}->{subkey2} = "subvalue2"; my $struct = $db->export(); print $struct->{key1} . "\n"; # prints "value1" This makes a complete copy of the database in memory, and returns a reference to it. The C method can be called on any database level (not just the base level), and works with both hash and array DB types. Be careful of large databases -- you can store a lot more data in a DBM::Deep object than an in-memory Perl structure. B Make sure your database has no circular references in it. These will cause an infinite loop when exporting. There are plans to fix this in a later release. =head1 FILTERS DBM::Deep has a number of hooks where you can specify your own Perl function to perform filtering on incoming or outgoing data. This is a perfect way to extend the engine, and implement things like real-time compression or encryption. Filtering applies to the base DB level, and all child hashes / arrays. Filter hooks can be specified when your DBM::Deep object is first constructed, or by calling the C method at any time. There are four available filter hooks. =head2 set_filter() This method takes two parameters - the filter type and the filter subreference. The four types are: =over =item * filter_store_key This filter is called whenever a hash key is stored. It is passed the incoming key, and expected to return a transformed key. =item * filter_store_value This filter is called whenever a hash key or array element is stored. It is passed the incoming value, and expected to return a transformed value. =item * filter_fetch_key This filter is called whenever a hash key is fetched (i.e. via C or C). It is passed the transformed key, and expected to return the plain key. =item * filter_fetch_value This filter is called whenever a hash key or array element is fetched. It is passed the transformed value, and expected to return the plain value. =back Here are the two ways to setup a filter hook: my $db = DBM::Deep->new( file => "foo.db", filter_store_value => \&my_filter_store, filter_fetch_value => \&my_filter_fetch ); # or... $db->set_filter( "store_value", \&my_filter_store ); $db->set_filter( "fetch_value", \&my_filter_fetch ); Your filter function will be called only when dealing with SCALAR keys or values. When nested hashes and arrays are being stored/fetched, filtering is bypassed. Filters are called as static functions, passed a single SCALAR argument, and expected to return a single SCALAR value. If you want to remove a filter, set the function reference to C: $db->set_filter( "store_value", undef ); =head2 Examples Please read L for examples of filters. =head1 ERROR HANDLING Most DBM::Deep methods return a true value for success, and call die() on failure. You can wrap calls in an eval block to catch the die. my $db = DBM::Deep->new( "foo.db" ); # create hash eval { $db->push("foo"); }; # ILLEGAL -- push is array-only call print $@; # prints error message =head1 LARGEFILE SUPPORT If you have a 64-bit system, and your Perl is compiled with both LARGEFILE and 64-bit support, you I be able to create databases larger than 4 GB. DBM::Deep by default uses 32-bit file offset tags, but these can be changed by specifying the 'pack_size' parameter when constructing the file. DBM::Deep->new( file => $filename, pack_size => 'large', ); This tells DBM::Deep to pack all file offsets with 8-byte (64-bit) quad words instead of 32-bit longs. After setting these values your DB files have a theoretical maximum size of 16 XB (exabytes). You can also use C<< pack_size => 'small' >> in order to use 16-bit file offsets. B Changing these values will B work for existing database files. Only change this for new files. Once the value has been set, it is stored in the file's header and cannot be changed for the life of the file. These parameters are per-file, meaning you can access 32-bit and 64-bit files, as you choose. B We have not personally tested files larger than 4 GB -- all our systems have only a 32-bit Perl. However, we have received user reports that this does indeed work. =head1 LOW-LEVEL ACCESS If you require low-level access to the underlying filehandle that DBM::Deep uses, you can call the C<_fh()> method, which returns the handle: my $fh = $db->_fh(); This method can be called on the root level of the database, or any child hashes or arrays. All levels share a I structure, which contains things like the filehandle, a reference counter, and all the options specified when you created the object. You can get access to this file object by calling the C<_storage()> method. my $file_obj = $db->_storage(); This is useful for changing options after the object has already been created, such as enabling/disabling locking. You can also store your own temporary user data in this structure (be wary of name collision), which is then accessible from any child hash or array. =head1 CIRCULAR REFERENCES DBM::Deep has full support for circular references. Meaning you can have a nested hash key or array element that points to a parent object. This relationship is stored in the DB file, and is preserved between sessions. Here is an example: my $db = DBM::Deep->new( "foo.db" ); $db->{foo} = "bar"; $db->{circle} = $db; # ref to self print $db->{foo} . "\n"; # prints "bar" print $db->{circle}->{foo} . "\n"; # prints "bar" again This also works as expected with array and hash references. So, the following works as expected: $db->{foo} = [ 1 .. 3 ]; $db->{bar} = $db->{foo}; push @{$db->{foo}}, 42; is( $db->{bar}[-1], 42 ); # Passes This, however, does I extend to assignments from one DB file to another. So, the following will throw an error: my $db1 = DBM::Deep->new( "foo.db" ); my $db2 = DBM::Deep->new( "bar.db" ); $db1->{foo} = []; $db2->{foo} = $db1->{foo}; # dies B: Passing the object to a function that recursively walks the object tree (such as I or even the built-in C or C methods) will result in an infinite loop. This will be fixed in a future release by adding singleton support. =head1 TRANSACTIONS As of 1.0000, DBM::Deep has ACID transactions. Every DBM::Deep object is completely transaction-ready - it is not an option you have to turn on. You do have to specify how many transactions may run simultaneously (q.v. L). Three new methods have been added to support them. They are: =over 4 =item * begin_work() This starts a transaction. =item * commit() This applies the changes done within the transaction to the mainline and ends the transaction. =item * rollback() This discards the changes done within the transaction to the mainline and ends the transaction. =back Transactions in DBM::Deep are done using a variant of the MVCC method, the same method used by the InnoDB MySQL engine. =head1 MIGRATION As of 1.0000, the file format has changed. To aid in upgrades, a migration script is provided within the CPAN distribution, called F. B This script is not installed onto your system because it carries a copy of every version prior to the current version. As of version 2.0000, databases created by old versions back to 1.0003 can be read, but new features may not be available unless the database is upgraded first. =head1 TODO The following are items that are planned to be added in future releases. These are separate from the L below. =head2 Sub-Transactions Right now, you cannot run a transaction within a transaction. Removing this restriction is technically straightforward, but the combinatorial explosion of possible usecases hurts my head. If this is something you want to see immediately, please submit many testcases. =head2 Caching If a client is willing to assert upon opening the file that this process will be the only consumer of that datafile, then there are a number of caching possibilities that can be taken advantage of. This does, however, mean that DBM::Deep is more vulnerable to losing data due to unflushed changes. It also means a much larger in-memory footprint. As such, it's not clear exactly how this should be done. Suggestions are welcome. =head2 Ram-only The techniques used in DBM::Deep simply require a seekable contiguous datastore. This could just as easily be a large string as a file. By using substr, the STM capabilities of DBM::Deep could be used within a single-process. I have no idea how I'd specify this, though. Suggestions are welcome. =head2 Different contention resolution mechanisms Currently, the only contention resolution mechanism is last-write-wins. This is the mechanism used by most RDBMSes and should be good enough for most uses. For advanced uses of STM, other contention mechanisms will be needed. If you have an idea of how you'd like to see contention resolution in DBM::Deep, please let me know. =head1 CAVEATS, ISSUES & BUGS This section describes all the known issues with DBM::Deep. These are issues that are either intractable or depend on some feature within Perl working exactly right. It you have found something that is not listed below, please send an e-mail to L. Likewise, if you think you know of a way around one of these issues, please let me know. =head2 References (The following assumes a high level of Perl understanding, specifically of references. Most users can safely skip this section.) Currently, the only references supported are HASH and ARRAY. The other reference types (SCALAR, CODE, GLOB, and REF) cannot be supported for various reasons. =over 4 =item * GLOB These are things like filehandles and other sockets. They can't be supported because it's completely unclear how DBM::Deep should serialize them. =item * SCALAR / REF The discussion here refers to the following type of example: my $x = 25; $db->{key1} = \$x; $x = 50; # In some other process ... my $val = ${ $db->{key1} }; is( $val, 50, "What actually gets stored in the DB file?" ); The problem is one of synchronization. When the variable being referred to changes value, the reference isn't notified, which is kind of the point of references. This means that the new value won't be stored in the datafile for other processes to read. There is no TIEREF. It is theoretically possible to store references to values already within a DBM::Deep object because everything already is synchronized, but the change to the internals would be quite large. Specifically, DBM::Deep would have to tie every single value that is stored. This would bloat the RAM footprint of DBM::Deep at least twofold (if not more) and be a significant performance drain, all to support a feature that has never been requested. =item * CODE L provides a mechanism for serializing coderefs, including saving off all closure state. This would allow for DBM::Deep to store the code for a subroutine. Then, whenever the subroutine is read, the code could be C'ed into being. However, just as for SCALAR and REF, that closure state may change without notifying the DBM::Deep object storing the reference. Again, this would generally be considered a feature. =back =head2 External references and transactions If you do C<< my $x = $db->{foo}; >>, then start a transaction, $x will be referencing the database from outside the transaction. A fix for this (and other issues with how external references into the database) is being looked into. This is the skipped set of tests in t/39_singletons.t and a related issue is the focus of t/37_delete_edge_cases.t =head2 File corruption The current level of error handling in DBM::Deep is minimal. Files I checked for a 32-bit signature when opened, but any other form of corruption in the datafile can cause segmentation faults. DBM::Deep may try to C past the end of a file, or get stuck in an infinite loop depending on the level and type of corruption. File write operations are not checked for failure (for speed), so if you happen to run out of disk space, DBM::Deep will probably fail in a bad way. These things will be addressed in a later version of DBM::Deep. =head2 DB over NFS Beware of using DBM::Deep files over NFS. DBM::Deep uses flock(), which works well on local filesystems, but will NOT protect you from file corruption over NFS. I've heard about setting up your NFS server with a locking daemon, then using C to lock your files, but your mileage may vary there as well. From what I understand, there is no real way to do it. However, if you need access to the underlying filehandle in DBM::Deep for using some other kind of locking scheme like C, see the L section above. =head2 Copying Objects Beware of copying tied objects in Perl. Very strange things can happen. Instead, use DBM::Deep's C method which safely copies the object and returns a new, blessed and tied hash or array to the same level in the DB. my $copy = $db->clone(); B: Since clone() here is cloning the object, not the database location, any modifications to either $db or $copy will be visible to both. =head2 Stale References If you take a reference to an array or hash from the database, it is tied to the database itself. This means that if the datum in question is subsequently deleted from the database, the reference to it will point to an invalid location and unpredictable things will happen if you try to use it. So a seemingly innocuous piece of code like this: my %hash = %{ $db->{some_hash} }; can fail if another process deletes or clobbers C<< $db->{some_hash} >> while the data are being extracted, since S> is not atomic. (This actually happened.) The solution is to lock the database before reading the data: $db->lock_exclusive; my %hash = %{ $db->{some_hash} }; $db->unlock; As of version 1.0024, if you assign a stale reference to a location in the database, DBM::Deep will warn, if you have uninitialized warnings enabled, and treat the stale reference as C. An attempt to use a stale reference as an array or hash reference will cause an error. =head2 Large Arrays Beware of using C, C or C with large arrays. These functions cause every element in the array to move, which can be murder on DBM::Deep, as every element has to be fetched from disk, then stored again in a different location. This will be addressed in a future version. This has been somewhat addressed so that the cost is constant, regardless of what is stored at those locations. So, small arrays with huge data structures in them are faster. But, large arrays are still large. =head2 Writeonly Files If you pass in a filehandle to new(), you may have opened it in either a readonly or writeonly mode. STORE will verify that the filehandle is writable. However, there doesn't seem to be a good way to determine if a filehandle is readable. And, if the filehandle isn't readable, it's not clear what will happen. So, don't do that. =head2 Assignments Within Transactions The following will I work as one might expect: my $x = { a => 1 }; $db->begin_work; $db->{foo} = $x; $db->rollback; is( $x->{a}, 1 ); # This will fail! The problem is that the moment a reference used as the rvalue to a DBM::Deep object's lvalue, it becomes tied itself. This is so that future changes to C<$x> can be tracked within the DBM::Deep file and is considered to be a feature. By the time the rollback occurs, there is no knowledge that there had been an C<$x> or what memory location to assign an C to. B This does not affect importing because imports do a walk over the reference to be imported in order to explicitly leave it untied. =head1 CODE COVERAGE L is used to test the code coverage of the tests. Below is the L report on this distribution's test suite. ---------------------------- ------ ------ ------ ------ ------ ------ ------ File stmt bran cond sub pod time total ---------------------------- ------ ------ ------ ------ ------ ------ ------ blib/lib/DBM/Deep.pm 100.0 89.1 82.9 100.0 100.0 32.5 98.1 blib/lib/DBM/Deep/Array.pm 100.0 94.4 100.0 100.0 100.0 5.2 98.8 blib/lib/DBM/Deep/Engine.pm 100.0 92.9 100.0 100.0 100.0 7.4 100.0 ...ib/DBM/Deep/Engine/DBI.pm 95.0 73.1 100.0 100.0 100.0 1.5 90.4 ...b/DBM/Deep/Engine/File.pm 92.3 78.5 88.9 100.0 100.0 4.9 90.3 blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 100.0 3.8 100.0 .../lib/DBM/Deep/Iterator.pm 100.0 n/a n/a 100.0 100.0 0.0 100.0 .../DBM/Deep/Iterator/DBI.pm 100.0 100.0 n/a 100.0 100.0 1.2 100.0 ...DBM/Deep/Iterator/File.pm 92.5 84.6 n/a 100.0 66.7 0.6 90.0 ...erator/File/BucketList.pm 100.0 75.0 n/a 100.0 66.7 0.4 93.8 ...ep/Iterator/File/Index.pm 100.0 100.0 n/a 100.0 100.0 0.2 100.0 blib/lib/DBM/Deep/Null.pm 87.5 n/a n/a 75.0 n/a 0.0 83.3 blib/lib/DBM/Deep/Sector.pm 91.7 n/a n/a 83.3 0.0 6.7 74.4 ...ib/DBM/Deep/Sector/DBI.pm 96.8 83.3 n/a 100.0 0.0 1.0 89.8 ...p/Sector/DBI/Reference.pm 100.0 95.5 100.0 100.0 0.0 2.2 91.2 ...Deep/Sector/DBI/Scalar.pm 100.0 100.0 n/a 100.0 0.0 1.1 92.9 ...b/DBM/Deep/Sector/File.pm 96.0 87.5 100.0 92.3 25.0 2.2 91.0 ...Sector/File/BucketList.pm 98.2 85.7 83.3 100.0 0.0 3.3 89.4 .../Deep/Sector/File/Data.pm 100.0 n/a n/a 100.0 0.0 0.1 90.9 ...Deep/Sector/File/Index.pm 100.0 80.0 33.3 100.0 0.0 0.8 83.1 .../Deep/Sector/File/Null.pm 100.0 100.0 n/a 100.0 0.0 0.0 91.7 .../Sector/File/Reference.pm 100.0 90.0 80.0 100.0 0.0 1.4 91.5 ...eep/Sector/File/Scalar.pm 98.4 87.5 n/a 100.0 0.0 0.8 91.9 blib/lib/DBM/Deep/Storage.pm 100.0 n/a n/a 100.0 100.0 0.0 100.0 ...b/DBM/Deep/Storage/DBI.pm 97.3 70.8 n/a 100.0 38.5 6.7 87.0 .../DBM/Deep/Storage/File.pm 96.6 77.1 80.0 95.7 100.0 16.0 91.8 Total 99.3 85.2 84.9 99.8 63.3 100.0 97.6 ---------------------------- ------ ------ ------ ------ ------ ------ ------ =head1 MORE INFORMATION Check out the DBM::Deep Google Group at L or send email to L. You can also visit #dbm-deep on irc.perl.org The source code repository is at L =head1 MAINTAINERS Rob Kinyon, L Originally written by Joseph Huckaby, L =head1 SPONSORS Stonehenge Consulting (L) sponsored the development of transactions and freespace management, leading to the 1.0000 release. A great debt of gratitude goes out to them for their continuing leadership in and support of the Perl community. =head1 CONTRIBUTORS The following have contributed greatly to make DBM::Deep what it is today: =over 4 =item * Adam Sah and Rich Gaushell for innumerable contributions early on. =item * Dan Golden and others at YAPC::NA 2006 for helping me design through transactions. =item * James Stanley for bug fix =item * David Steinbrunner for fixing typos and adding repository cpan metadata =item * H. Merijn Brandt for fixing the POD escapes. =item * Breno G. de Oliveira for minor packaging tweaks =back =head1 SEE ALSO L L, L, L, L, L, L =head1 LICENSE Copyright (c) 2007-14 Rob Kinyon. All Rights Reserved. This is free software, you may use it and distribute it under the same terms as Perl itself. =cut DBM-Deep-2.0013/lib/DBM/Deep.pm000444001750001750 4234012641624315 14352 0ustar00robrob000000000000package DBM::Deep; use 5.008_004; use strict; use warnings FATAL => 'all'; no warnings 'recursion'; our $VERSION = q(2.0013); use Scalar::Util (); use overload ( '""' => '0+' => sub { $_[0] }, )[0,2,1,2], # same sub for both fallback => 1; use constant DEBUG => 0; use DBM::Deep::Engine; sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH } sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY } my %obj_cache; # In external_refs mode, all objects are registered here, # and dealt with in the END block at the bottom. use constant HAVE_HUFH => scalar eval{ require Hash::Util::FieldHash }; HAVE_HUFH and Hash::Util::FieldHash::fieldhash(%obj_cache); # This is used in all the children of this class in their TIE methods. sub _get_args { my $proto = shift; my $args; if (scalar(@_) > 1) { if ( @_ % 2 ) { $proto->_throw_error( "Odd number of parameters to " . (caller(1))[2] ); } $args = {@_}; } elsif ( ref $_[0] ) { unless ( eval { local $SIG{'__DIE__'}; %{$_[0]} || 1 } ) { $proto->_throw_error( "Not a hashref in args to " . (caller(1))[2] ); } $args = $_[0]; } else { $args = { file => shift }; } return $args; } # Class constructor method for Perl OO interface. # Calls tie() and returns blessed reference to tied hash or array, # providing a hybrid OO/tie interface. sub new { my $class = shift; my $args = $class->_get_args( @_ ); my $self; if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { $class = 'DBM::Deep::Array'; require DBM::Deep::Array; tie @$self, $class, %$args; } else { $class = 'DBM::Deep::Hash'; require DBM::Deep::Hash; tie %$self, $class, %$args; } return bless $self, $class; } # This initializer is called from the various TIE* methods. new() calls tie(), # which allows for a single point of entry. sub _init { my $class = shift; my ($args) = @_; # locking implicitly enables autoflush if ($args->{locking}) { $args->{autoflush} = 1; } # These are the defaults to be optionally overridden below my $self = bless { type => TYPE_HASH, base_offset => undef, staleness => undef, engine => undef, }, $class; unless ( exists $args->{engine} ) { my $class = exists $args->{dbi} ? 'DBM::Deep::Engine::DBI' : exists $args->{_test} ? 'DBM::Deep::Engine::Test' : 'DBM::Deep::Engine::File' ; eval "use $class"; die $@ if $@; $args->{engine} = $class->new({ %{$args}, obj => $self, }); } # Grab the parameters we want to use foreach my $param ( keys %$self ) { next unless exists $args->{$param}; $self->{$param} = $args->{$param}; } eval { local $SIG{'__DIE__'}; $self->lock_exclusive; $self->_engine->setup( $self ); $self->unlock; }; if ( $@ ) { my $e = $@; eval { local $SIG{'__DIE__'}; $self->unlock; }; die $e; } if( $self->{engine}->{external_refs} and my $sector = $self->{engine}->load_sector( $self->{base_offset} ) ) { $sector->increment_refcount; Scalar::Util::weaken( my $feeble_ref = $self ); $obj_cache{ $self } = \$feeble_ref; # Make sure this cache is not a memory hog if(!HAVE_HUFH) { for(keys %obj_cache) { delete $obj_cache{$_} if not ${$obj_cache{$_}}; } } } return $self; } sub TIEHASH { shift; require DBM::Deep::Hash; return DBM::Deep::Hash->TIEHASH( @_ ); } sub TIEARRAY { shift; require DBM::Deep::Array; return DBM::Deep::Array->TIEARRAY( @_ ); } sub lock_exclusive { my $self = shift->_get_self; return $self->_engine->lock_exclusive( $self, @_ ); } *lock = \&lock_exclusive; sub lock_shared { my $self = shift->_get_self; # cluck() the problem with cached File objects. unless ( $self->_engine ) { require Carp; require Data::Dumper; Carp::cluck( Data::Dumper->Dump( [$self], ['self'] ) ); } return $self->_engine->lock_shared( $self, @_ ); } sub unlock { my $self = shift->_get_self; return $self->_engine->unlock( $self, @_ ); } sub _copy_value { my $self = shift->_get_self; my ($spot, $value) = @_; if ( !ref $value ) { ${$spot} = $value; } else { my $r = Scalar::Util::reftype( $value ); my $tied; if ( $r eq 'ARRAY' ) { $tied = tied(@$value); } elsif ( $r eq 'HASH' ) { $tied = tied(%$value); } else { __PACKAGE__->_throw_error( "Unknown type for '$value'" ); } if ( eval { local $SIG{'__DIE__'}; $tied->isa( __PACKAGE__ ) } ) { ${$spot} = $tied->_repr; $tied->_copy_node( ${$spot} ); } else { if ( $r eq 'ARRAY' ) { ${$spot} = [ @{$value} ]; } else { ${$spot} = { %{$value} }; } } my $c = Scalar::Util::blessed( $value ); if ( defined $c && !$c->isa( __PACKAGE__ ) ) { ${$spot} = bless ${$spot}, $c } } return 1; } sub export { my $self = shift->_get_self; my $temp = $self->_repr; $self->lock_exclusive; $self->_copy_node( $temp ); $self->unlock; my $classname = $self->_engine->get_classname( $self ); if ( defined $classname ) { bless $temp, $classname; } return $temp; } sub _check_legality { my $self = shift; my ($val) = @_; my $r = Scalar::Util::reftype( $val ); return $r if !defined $r || '' eq $r; return $r if 'HASH' eq $r; return $r if 'ARRAY' eq $r; __PACKAGE__->_throw_error( "Storage of references of type '$r' is not supported." ); } sub import { return if !ref $_[0]; # Perl calls import() on use -- ignore my $self = shift->_get_self; my ($struct) = @_; my $type = $self->_check_legality( $struct ); if ( !$type ) { __PACKAGE__->_throw_error( "Cannot import a scalar" ); } if ( substr( $type, 0, 1 ) ne $self->_type ) { __PACKAGE__->_throw_error( "Cannot import " . ('HASH' eq $type ? 'a hash' : 'an array') . " into " . ('HASH' eq $type ? 'an array' : 'a hash') ); } my %seen; my $recurse; $recurse = sub { my ($db, $val) = @_; my $obj = 'HASH' eq Scalar::Util::reftype( $db ) ? tied(%$db) : tied(@$db); $obj ||= $db; my $r = $self->_check_legality( $val ); if ( 'HASH' eq $r ) { while ( my ($k, $v) = each %$val ) { my $r = $self->_check_legality( $v ); if ( $r ) { my $temp = 'HASH' eq $r ? {} : []; if ( my $c = Scalar::Util::blessed( $v ) ) { bless $temp, $c; } $obj->put( $k, $temp ); $recurse->( $temp, $v ); } else { $obj->put( $k, $v ); } } } elsif ( 'ARRAY' eq $r ) { foreach my $k ( 0 .. $#$val ) { my $v = $val->[$k]; my $r = $self->_check_legality( $v ); if ( $r ) { my $temp = 'HASH' eq $r ? {} : []; if ( my $c = Scalar::Util::blessed( $v ) ) { bless $temp, $c; } $obj->put( $k, $temp ); $recurse->( $temp, $v ); } else { $obj->put( $k, $v ); } } } }; $recurse->( $self, $struct ); return 1; } #XXX Need to keep track of who has a fh to this file in order to #XXX close them all prior to optimize on Win32/cygwin # Rebuild entire database into new file, then move # it back on top of original. sub optimize { my $self = shift->_get_self; # Optimizing is only something we need to do when we're working with our # own file format. Otherwise, let the other guy do the optimizations. return unless $self->_engine->isa( 'DBM::Deep::Engine::File' ); #XXX Need to create a new test for this # if ($self->_engine->storage->{links} > 1) { # $self->_throw_error("Cannot optimize: reference count is greater than 1"); # } #XXX Do we have to lock the tempfile? #XXX Should we use tempfile() here instead of a hard-coded name? my $temp_filename = $self->_engine->storage->{file} . '.tmp'; my $db_temp = __PACKAGE__->new( file => $temp_filename, type => $self->_type, # Bring over all the parameters that we need to bring over ( map { $_ => $self->_engine->$_ } qw( byte_size max_buckets data_sector_size num_txns )), ); $self->lock_exclusive; $self->_engine->clear_cache; $self->_copy_node( $db_temp ); $self->unlock; $db_temp->_engine->storage->close; undef $db_temp; ## # Attempt to copy user, group and permissions over to new file ## $self->_engine->storage->copy_stats( $temp_filename ); # q.v. perlport for more information on this variable if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) { ## # Potential race condition when optimizing on Win32 with locking. # The Windows filesystem requires that the filehandle be closed # before it is overwritten with rename(). This could be redone # with a soft copy. ## $self->unlock; $self->_engine->storage->close; } if (!rename $temp_filename, $self->_engine->storage->{file}) { unlink $temp_filename; $self->unlock; $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!"); } $self->unlock; $self->_engine->storage->close; $self->_engine->storage->open; $self->lock_exclusive; $self->_engine->setup( $self ); $self->unlock; return 1; } sub clone { my $self = shift->_get_self; return __PACKAGE__->new( type => $self->_type, base_offset => $self->_base_offset, staleness => $self->_staleness, engine => $self->_engine, ); } sub supports { my $self = shift->_get_self; return $self->_engine->supports( @_ ); } sub db_version { shift->_get_self->_engine->db_version; } #XXX Migrate this to the engine, where it really belongs and go through some # API - stop poking in the innards of someone else.. { my %is_legal_filter = map { $_ => ~~1, } qw( store_key store_value fetch_key fetch_value ); sub set_filter { my $self = shift->_get_self; my $type = lc shift; my $func = shift; if ( $is_legal_filter{$type} ) { $self->_engine->storage->{"filter_$type"} = $func; return 1; } return; } sub filter_store_key { $_[0]->set_filter( store_key => $_[1] ); } sub filter_store_value { $_[0]->set_filter( store_value => $_[1] ); } sub filter_fetch_key { $_[0]->set_filter( fetch_key => $_[1] ); } sub filter_fetch_value { $_[0]->set_filter( fetch_value => $_[1] ); } } sub begin_work { my $self = shift->_get_self; $self->lock_exclusive; my $rv = eval { local $SIG{'__DIE__'}; $self->_engine->begin_work( $self, @_ ); }; my $e = $@; $self->unlock; die $e if $e; return $rv; } sub rollback { my $self = shift->_get_self; $self->lock_exclusive; my $rv = eval { local $SIG{'__DIE__'}; $self->_engine->rollback( $self, @_ ); }; my $e = $@; $self->unlock; die $e if $e; return $rv; } sub commit { my $self = shift->_get_self; $self->lock_exclusive; my $rv = eval { local $SIG{'__DIE__'}; $self->_engine->commit( $self, @_ ); }; my $e = $@; $self->unlock; die $e if $e; return $rv; } # Accessor methods sub _engine { my $self = $_[0]->_get_self; return $self->{engine}; } sub _type { my $self = $_[0]->_get_self; return $self->{type}; } sub _base_offset { my $self = $_[0]->_get_self; return $self->{base_offset}; } sub _staleness { my $self = $_[0]->_get_self; return $self->{staleness}; } # Utility methods sub _throw_error { my $n = 0; while( 1 ) { my @caller = caller( ++$n ); next if $caller[0] =~ m/^DBM::Deep/; die "DBM::Deep: $_[1] at $caller[1] line $caller[2]\n"; } } # Store single hash key/value or array element in database. sub STORE { my $self = shift->_get_self; my ($key, $value) = @_; warn "STORE($self, '$key', '@{[defined$value?$value:'undef']}')\n" if DEBUG; unless ( $self->_engine->storage->is_writable ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } $self->lock_exclusive; # User may be storing a complex value, in which case we do not want it run # through the filtering system. if ( !ref($value) && $self->_engine->storage->{filter_store_value} ) { $value = $self->_engine->storage->{filter_store_value}->( $value ); } eval { local $SIG{'__DIE__'}; $self->_engine->write_value( $self, $key, $value ); }; if ( my $e = $@ ) { $self->unlock; die $e; } $self->unlock; return 1; } # Fetch single value or element given plain key or array index sub FETCH { my $self = shift->_get_self; my ($key) = @_; warn "FETCH($self, '$key')\n" if DEBUG; $self->lock_shared; my $result = $self->_engine->read_value( $self, $key ); $self->unlock; # Filters only apply to scalar values, so the ref check is making # sure the fetched bucket is a scalar, not a child hash or array. return ($result && !ref($result) && $self->_engine->storage->{filter_fetch_value}) ? $self->_engine->storage->{filter_fetch_value}->($result) : $result; } # Delete single key/value pair or element given plain key or array index sub DELETE { my $self = shift->_get_self; my ($key) = @_; warn "DELETE($self, '$key')\n" if DEBUG; unless ( $self->_engine->storage->is_writable ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } $self->lock_exclusive; ## # Delete bucket ## my $value = $self->_engine->delete_key( $self, $key); if (defined $value && !ref($value) && $self->_engine->storage->{filter_fetch_value}) { $value = $self->_engine->storage->{filter_fetch_value}->($value); } $self->unlock; return $value; } # Check if a single key or element exists given plain key or array index sub EXISTS { my $self = shift->_get_self; my ($key) = @_; warn "EXISTS($self, '$key')\n" if DEBUG; $self->lock_shared; my $result = $self->_engine->key_exists( $self, $key ); $self->unlock; return $result; } # Clear all keys from hash, or all elements from array. sub CLEAR { my $self = shift->_get_self; warn "CLEAR($self)\n" if DEBUG; my $engine = $self->_engine; unless ( $engine->storage->is_writable ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } $self->lock_exclusive; eval { local $SIG{'__DIE__'}; $engine->clear( $self ); }; my $e = $@; warn "$e\n" if $e && DEBUG; $self->unlock; die $e if $e; return 1; } # Public method aliases sub put { (shift)->STORE( @_ ) } sub get { (shift)->FETCH( @_ ) } sub store { (shift)->STORE( @_ ) } sub fetch { (shift)->FETCH( @_ ) } sub delete { (shift)->DELETE( @_ ) } sub exists { (shift)->EXISTS( @_ ) } sub clear { (shift)->CLEAR( @_ ) } sub _dump_file {shift->_get_self->_engine->_dump_file;} sub _warnif { # There is, unfortunately, no way to avoid this hack. warnings.pm does not # allow us to specify exactly the call frame we want. So, for now, we just # look at the bitmask ourselves. my $level; { my($pack, $file, $line, $bitmask) = (caller $level++)[0..2,9]; redo if $pack =~ /^DBM::Deep(?:::|\z)/; if( vec $bitmask, $warnings'Offsets{$_[0]}, 1, || vec $bitmask, $warnings'Offsets{all}, 1, ) { my $msg = $_[1] =~ /\n\z/ ? $_[1] : "$_[1] at $file line $line.\n"; die $msg if vec $bitmask, $warnings'Offsets{$_[0]}+1, 1, || vec $bitmask, $warnings'Offsets{all}+1, 1; warn $msg; } } } sub _free { my $self = shift; if(my $sector = $self->{engine}->load_sector( $self->{base_offset} )) { $sector->free; } } sub DESTROY { my $self = shift; my $alter_ego = $self->_get_self; if( !$alter_ego || $self != $alter_ego ) { return; # Don’t run the destructor twice! (What follows only applies to } # the inner object, not the tie.) # If the engine is gone, the END block has beaten us to it. return if !$self->{engine}; if( $self->{engine}->{external_refs} ) { $self->_free; } } # Relying on the destructor alone is problematic, as the order in which # objects are discarded is random in global destruction. So we do the # clean-up here before preemptively before global destruction. END { defined $$_ and $$_->_free, delete $$_->{engine} for(values %obj_cache); } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep000755001750001750 012641624315 13634 5ustar00robrob000000000000DBM-Deep-2.0013/lib/DBM/Deep/Hash.pm000444001750001750 666212641624315 15224 0ustar00robrob000000000000package DBM::Deep::Hash; use 5.008_004; use strict; use warnings FATAL => 'all'; no warnings 'recursion'; use base 'DBM::Deep'; sub _get_self { # See the note in Array.pm as to why this is commented out. # eval { local $SIG{'__DIE__'}; tied( %{$_[0]} ) } || $_[0] # During global destruction %{$_[0]} might get tied to undef, so we # need to check that case if tied returns false. tied %{$_[0]} or local *@, eval { exists $_[0]{_}; 1 } ? $_[0] : undef } sub _repr { return {} } sub TIEHASH { my $class = shift; my $args = $class->_get_args( @_ ); $args->{type} = $class->TYPE_HASH; return $class->_init($args); } sub FETCH { my $self = shift->_get_self; DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; my $key = ($self->_engine->storage->{filter_store_key}) ? $self->_engine->storage->{filter_store_key}->($_[0]) : $_[0]; return $self->SUPER::FETCH( $key, $_[0] ); } sub STORE { my $self = shift->_get_self; DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; my $key = ($self->_engine->storage->{filter_store_key}) ? $self->_engine->storage->{filter_store_key}->($_[0]) : $_[0]; my $value = $_[1]; return $self->SUPER::STORE( $key, $value, $_[0] ); } sub EXISTS { my $self = shift->_get_self; DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; my $key = ($self->_engine->storage->{filter_store_key}) ? $self->_engine->storage->{filter_store_key}->($_[0]) : $_[0]; return $self->SUPER::EXISTS( $key ); } sub DELETE { my $self = shift->_get_self; DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; my $key = ($self->_engine->storage->{filter_store_key}) ? $self->_engine->storage->{filter_store_key}->($_[0]) : $_[0]; return $self->SUPER::DELETE( $key, $_[0] ); } # Locate and return first key (in no particular order) sub FIRSTKEY { my $self = shift->_get_self; $self->lock_shared; my $result = $self->_engine->get_next_key( $self ); $self->unlock; return ($result && $self->_engine->storage->{filter_fetch_key}) ? $self->_engine->storage->{filter_fetch_key}->($result) : $result; } # Return next key (in no particular order), given previous one sub NEXTKEY { my $self = shift->_get_self; my $prev_key = ($self->_engine->storage->{filter_store_key}) ? $self->_engine->storage->{filter_store_key}->($_[0]) : $_[0]; $self->lock_shared; my $result = $self->_engine->get_next_key( $self, $prev_key ); $self->unlock; return ($result && $self->_engine->storage->{filter_fetch_key}) ? $self->_engine->storage->{filter_fetch_key}->($result) : $result; } sub first_key { (shift)->FIRSTKEY(@_) } sub next_key { (shift)->NEXTKEY(@_) } sub _clear { my $self = shift; while ( defined(my $key = $self->first_key) ) { do { $self->_engine->delete_key( $self, $key, $key ); } while defined($key = $self->next_key($key)); } return; } sub _copy_node { my $self = shift; my ($db_temp) = @_; my $key = $self->first_key(); while (defined $key) { my $value = $self->get($key); $self->_copy_value( \$db_temp->{$key}, $value ); $key = $self->next_key($key); } return 1; } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Iterator.pm000444001750001750 226412641624315 16124 0ustar00robrob000000000000package DBM::Deep::Iterator; use 5.008_004; use strict; use warnings FATAL => 'all'; =head1 NAME DBM::Deep::Iterator - iterator for FIRSTKEY() and NEXTKEY() =head1 PURPOSE This is an internal-use-only object for L. It is the iterator for FIRSTKEY() and NEXTKEY(). =head1 OVERVIEW This object =head1 METHODS =head2 new(\%params) The constructor takes a hashref of params. The hashref is assumed to have the following elements: =over 4 =item * engine (of type L =item * base_offset (the base_offset of the invoking DBM::Deep object) =back =cut sub new { my $class = shift; my ($args) = @_; my $self = bless { engine => $args->{engine}, base_offset => $args->{base_offset}, }, $class; Scalar::Util::weaken( $self->{engine} ); $self->reset; return $self; } =head2 reset() This method takes no arguments. It will reset the iterator so that it will start from the beginning again. This method returns nothing. =cut sub reset { die "reset must be implemented in a child class" } =head2 get_next_key( $obj ) =cut sub get_next_key { die "get_next_key must be implemented in a child class" } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Sector.pm000444001750001750 115112641624315 15564 0ustar00robrob000000000000package DBM::Deep::Sector; use 5.008_004; use strict; use warnings FATAL => 'all'; use Scalar::Util (); sub new { my $self = bless $_[1], $_[0]; Scalar::Util::weaken( $self->{engine} ); $self->_init; return $self; } sub _init {} sub clone { my $self = shift; return ref($self)->new({ engine => $self->engine, type => $self->type, data => $self->data, }); } sub engine { $_[0]{engine} } sub offset { $_[0]{offset} } sub type { $_[0]{type} } sub staleness { $_[0]{staleness} } sub load { die "load must be implemented in a child class" } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Storage.pm000444001750001750 313312641624315 15733 0ustar00robrob000000000000package DBM::Deep::Storage; use 5.008_004; use strict; use warnings FATAL => 'all'; =head1 NAME DBM::Deep::Storage - abstract base class for storage =head2 flush() This flushes the filehandle. This takes no parameters and returns nothing. =cut sub flush { die "flush must be implemented in a child class" } =head2 is_writable() This takes no parameters. It returns a boolean saying if this filehandle is writable. Taken from L. =cut sub is_writable { die "is_writable must be implemented in a child class" } =head1 LOCKING This is where the actual locking of the storage medium is performed. Nested locking is supported. B: It is unclear what will happen if a read lock is taken, then a write lock is taken as a nested lock, then the write lock is released. Currently, the only locking method supported is flock(1). This is a whole-file lock. In the future, more granular locking may be supported. The API for that is unclear right now. The following methods manage the locking status. In all cases, they take a L object and returns nothing. =over 4 =item * lock_exclusive( $obj ) Take a lock usable for writing. =item * lock_shared( $obj ) Take a lock usable for reading. =item * unlock( $obj ) Releases the last lock taken. If this is the outermost lock, then the object is actually unlocked. =back =cut sub lock_exclusive { die "lock_exclusive must be implemented in a child class" } sub lock_shared { die "lock_shared must be implemented in a child class" } sub unlock { die "unlock must be implemented in a child class" } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Cookbook.pod000444001750001750 1477712641624315 16303 0ustar00robrob000000000000=head1 NAME DBM::Deep::Cookbook - Cookbook for DBM::Deep =head1 DESCRIPTION This is the Cookbook for L. It contains useful tips and tricks, plus some examples of how to do common tasks. =head1 RECIPES =head2 Unicode data If possible, it is highly recommended that you upgrade your database to version 2 (using the F script in the CPAN distribution), in order to use Unicode. If your databases are still shared by perl installations with older DBM::Deep versions, you can use filters to encode strings on the fly: my $db = DBM::Deep->new( ... ); my $encode_sub = sub { my $s = shift; utf8::encode($s); $s }; my $decode_sub = sub { my $s = shift; utf8::decode($s); $s }; $db->set_filter( 'store_value' => $encode_sub ); $db->set_filter( 'fetch_value' => $decode_sub ); $db->set_filter( 'store_key' => $encode_sub ); $db->set_filter( 'fetch_key' => $decode_sub ); A previous version of this cookbook recommended using C_fh, ":utf8">, but that is I a good idea, as it could easily corrupt the database. =head2 Real-time Encryption Example B: This is just an example of how to write a filter. This most definitely should B be taken as a proper way to write a filter that does encryption. (Furthermore, it fails to take Unicode into account.) Here is a working example that uses the I module to do real-time encryption / decryption of keys & values with DBM::Deep Filters. Please visit L for more on I. You'll also need the I module. use DBM::Deep; use Crypt::Blowfish; use Crypt::CBC; my $cipher = Crypt::CBC->new({ 'key' => 'my secret key', 'cipher' => 'Blowfish', 'iv' => '$KJh#(}q', 'regenerate_key' => 0, 'padding' => 'space', 'prepend_iv' => 0 }); my $db = DBM::Deep->new( file => "foo-encrypt.db", filter_store_key => \&my_encrypt, filter_store_value => \&my_encrypt, filter_fetch_key => \&my_decrypt, filter_fetch_value => \&my_decrypt, ); $db->{key1} = "value1"; $db->{key2} = "value2"; print "key1: " . $db->{key1} . "\n"; print "key2: " . $db->{key2} . "\n"; undef $db; exit; sub my_encrypt { return $cipher->encrypt( $_[0] ); } sub my_decrypt { return $cipher->decrypt( $_[0] ); } =head2 Real-time Compression Example Here is a working example that uses the I module to do real-time compression / decompression of keys & values with DBM::Deep Filters. Please visit L for more on I. use DBM::Deep; use Compress::Zlib; my $db = DBM::Deep->new( file => "foo-compress.db", filter_store_key => \&my_compress, filter_store_value => \&my_compress, filter_fetch_key => \&my_decompress, filter_fetch_value => \&my_decompress, ); $db->{key1} = "value1"; $db->{key2} = "value2"; print "key1: " . $db->{key1} . "\n"; print "key2: " . $db->{key2} . "\n"; undef $db; exit; sub my_compress { my $s = shift; utf8::encode($s); return Compress::Zlib::memGzip( $s ) ; } sub my_decompress { my $s = Compress::Zlib::memGunzip( shift ) ; utf8::decode($s); return $s; } B Filtering of keys only applies to hashes. Array "keys" are actually numerical index numbers, and are not filtered. =head1 Custom Digest Algorithm DBM::Deep by default uses the I (MD5) algorithm for hashing keys. However you can override this, and use another algorithm (such as SHA-256) or even write your own. But please note that DBM::Deep currently expects zero collisions, so your algorithm has to be I, so to speak. Collision detection may be introduced in a later version. You can specify a custom digest algorithm by passing it into the parameter list for new(), passing a reference to a subroutine as the 'digest' parameter, and the length of the algorithm's hashes (in bytes) as the 'hash_size' parameter. Here is a working example that uses a 256-bit hash from the I module. Please see L for more information. The value passed to your digest function will be encoded as UTF-8 if the database is in version 2 format or higher. use DBM::Deep; use Digest::SHA256; my $context = Digest::SHA256::new(256); my $db = DBM::Deep->new( filename => "foo-sha.db", digest => \&my_digest, hash_size => 32, ); $db->{key1} = "value1"; $db->{key2} = "value2"; print "key1: " . $db->{key1} . "\n"; print "key2: " . $db->{key2} . "\n"; undef $db; exit; sub my_digest { return substr( $context->hash($_[0]), 0, 32 ); } B Your returned digest strings must be B the number of bytes you specify in the hash_size parameter (in this case 32). Undefined behavior will occur otherwise. B If you do choose to use a custom digest algorithm, you must set it every time you access this file. Otherwise, the default (MD5) will be used. =head1 PERFORMANCE Because DBM::Deep is a conncurrent datastore, every change is flushed to disk immediately and every read goes to disk. This means that DBM::Deep functions at the speed of disk (generally 10-20ms) vs. the speed of RAM (generally 50-70ns), or at least 150-200x slower than the comparable in-memory datastructure in Perl. There are several techniques you can use to speed up how DBM::Deep functions. =over 4 =item * Put it on a ramdisk The easiest and quickest mechanism to making DBM::Deep run faster is to create a ramdisk and locate the DBM::Deep file there. Doing this as an option may become a feature of DBM::Deep, assuming there is a good ramdisk wrapper on CPAN. =item * Work at the tightest level possible It is much faster to assign the level of your db that you are working with to an intermediate variable than to re-look it up every time. Thus # BAD while ( my ($k, $v) = each %{$db->{foo}{bar}{baz}} ) { ... } # GOOD my $x = $db->{foo}{bar}{baz}; while ( my ($k, $v) = each %$x ) { ... } =item * Make your file as tight as possible If you know that you are not going to use more than 65K in your database, consider using the C 'small'> option. This will instruct DBM::Deep to use 16bit addresses, meaning that the seek times will be less. =back =head1 SEE ALSO L, L, L, L, L =cut DBM-Deep-2.0013/lib/DBM/Deep/Internals.pod000444001750001750 2675212641624315 16470 0ustar00robrob000000000000=head1 NAME DBM::Deep::Internals - Out of date documentation on DBM::Deep internals =head1 OUT OF DATE This document is out-of-date. It describes an intermediate file format used during the development from 0.983 to 1.0000. It will be rewritten soon. So far, the description of the header format has been updated. =head1 DESCRIPTION This is a document describing the internal workings of L. It is not necessary to read this document if you only intend to be a user. This document is intended for people who either want a deeper understanding of specifics of how L works or who wish to help program L. =head1 CLASS LAYOUT L is broken up into five classes in three inheritance hierarchies. =over 4 =item * L is the parent of L and L. These classes form the immediate interface to the outside world. They are the classes that provide the TIE mechanisms as well as the OO methods. =item * L is the layer that deals with the mechanics of reading and writing to the file. This is where the logic of the file layout is handled. =item * L is the layer that deals with the physical file. As a singleton that every other object has a reference to, it also provides a place to handle datastructure-wide items, such as transactions. =back =head1 FILE LAYOUT This describes the 1.0003 and 2.0000 formats, which internally are numbered 3 and 4, respectively. The internal numbers are used in this section. These two formats are almost identical. DBM::Deep uses a tagged file layout. Every section has a tag, a size, and then the data. =head2 File header The file header consists of two parts. The first part is a fixed length of 13 bytes: DPDB h VVVV SSSS \ / | \ \ \/ '---. \ '--- size of the second part of the header file \ '--- version signature tag =over 4 =item * File Signature The first four bytes are 'DPDB' in network byte order, signifying that this is a DBM::Deep file. =item * File tag A literal ASCII 'h', indicating that this is the header. The file used by versions prior to 1.00 had a different fifth byte, allowing the difference to be determined. =item * Version This is four bytes containing the file version. This lets the file format change over time. It is packed in network order, so version 4 is stored as "\0\0\0\cD". =item * Header size The size of the second part of the header, in bytes. This number is also packed in network order. =back The second part of the header is as follows: S B S T T(TTTTTTTTT...) (SS SS SS SS ...) (continued...) | | | | \ | | | | '----------. \ staleness counters | | '--------. \ txn bitfield | '------. \ number of transactions byte size \ data sector size max buckets (continuation...) BB(BBBBBB) DD(DDDDDD) II(IIIIII) | | | | free data | free blist free index =over =item * Constants These are the file-wide constants that determine how the file is laid out. They can only be set upon file creation. The byte size is the number of bytes used to point to an offset elsewhere in the file. This corresponds to the C option. This and the next three values are stored as packed 8-bit integers (chars), so 2 is represented by "\cB". C and C are documented in the main L man page. The number stored is actually one less than what is passed to the constructor, to allow for a range of 1-256. The number of transactions corresponds to the C value passed to the constructor. =item * Transaction information The transaction bitfield consists of one bit for every available transaction ID. It is therefore anywhere from 1 byte to 32 bytes long. The staleness counters each take two bytes (packed 32-bit integers), one for each transaction, not including the so-called HEAD (the main transaction that all processes share I calling C). So these take up 0 to 508 bytes. Staleness is explained in L. =item * Freespace information Pointers into the first free sectors of the various sector sizes (Index, Bucketlist, and Data) are stored here. These are called chains internally, as each free sector points to the next one. The number of bytes is determined by the byte size, ranging from 2 to 8. =back =head2 Index The Index parts can be tagged either as Hash, Array, or Index. The latter is if there was a reindexing due to a bucketlist growing too large. The others are the root index for their respective datatypes. The index consists of a tag, a size, and then 256 sections containing file locations. Each section corresponds to each value representable in a byte. The index is used as follows - whenever a hashed key is being looked up, the first byte is used to determine which location to go to from the root index. Then, if that's also an index, the second byte is used, and so forth until a bucketlist is found. =head2 Bucketlist This is the part that contains the link to the data section. A bucketlist defaults to being 16 buckets long (modifiable by the I parameter used when creating a new file). Each bucket contains an MD5 and a location of the appropriate key section. =head2 Key area This is the part that handles transactional awareness. There are I sections. Each section contains the location to the data section, a transaction ID, and whether that transaction considers this key to be deleted or not. =head2 Data area This is the part that actual stores the key, value, and class (if appropriate). The layout is: =over 4 =item * tag =item * length of the value =item * the actual value =item * keylength =item * the actual key =item * a byte indicating if this value has a classname =item * the classname (if one is there) =back The key is stored after the value because the value is requested more often than the key. =head1 PERFORMANCE L is written completely in Perl. It also is a multi-process DBM that uses the datafile as a method of synchronizing between multiple processes. This is unlike most RDBMSes like MySQL and Oracle. Furthermore, unlike all RDBMSes, L stores both the data and the structure of that data as it would appear in a Perl program. =head2 CPU DBM::Deep attempts to be CPU-light. As it stores all the data on disk, DBM::Deep is I/O-bound, not CPU-bound. =head2 RAM DBM::Deep uses extremely little RAM relative to the amount of data you can access. You can iterate through a million keys (using C) without increasing your memory usage at all. =head2 DISK DBM::Deep is I/O-bound, pure and simple. The faster your disk, the faster DBM::Deep will be. Currently, when performing C{foo}>, there are a minimum of 4 seeks and 1332 + N bytes read (where N is the length of your data). (All values assume a medium filesize.) The actions taken are: =over 4 =item 1 Lock the file =item 1 Perform a stat() to determine if the inode has changed =item 1 Go to the primary index for the $db (1 seek) =item 1 Read the tag/size of the primary index (5 bytes) =item 1 Read the body of the primary index (1024 bytes) =item 1 Go to the bucketlist for this MD5 (1 seek) =item 1 Read the tag/size of the bucketlist (5 bytes) =item 1 Read the body of the bucketlist (144 bytes) =item 1 Go to the keys location for this MD5 (1 seek) =item 1 Read the tag/size of the keys section (5 bytes) =item 1 Read the body of the keys location (144 bytes) =item 1 Go to the data section that corresponds to this transaction ID. (1 seek) =item 1 Read the tag/size of the data section (5 bytes) =item 1 Read the value for this data (N bytes) =item 1 Unlock the file =back Every additional level of indexing (if there are enough keys) requires an additional seek and the reading of 1029 additional bytes. If the value is blessed, an additional 1 seek and 9 + M bytes are read (where M is the length of the classname). Arrays are (currently) even worse because they're considered "funny hashes" with the length stored as just another key. This means that if you do any sort of lookup with a negative index, this entire process is performed twice - once for the length and once for the value. =head1 ACTUAL TESTS =head2 SPEED Obviously, DBM::Deep isn't going to be as fast as some C-based DBMs, such as the almighty I. But it makes up for it in features like true multi-level hash/array support, and cross-platform FTPable files. Even so, DBM::Deep is still pretty fast, and the speed stays fairly consistent, even with huge databases. Here is some test data: Adding 1,000,000 keys to new DB file... At 100 keys, avg. speed is 2,703 keys/sec At 200 keys, avg. speed is 2,642 keys/sec At 300 keys, avg. speed is 2,598 keys/sec At 400 keys, avg. speed is 2,578 keys/sec At 500 keys, avg. speed is 2,722 keys/sec At 600 keys, avg. speed is 2,628 keys/sec At 700 keys, avg. speed is 2,700 keys/sec At 800 keys, avg. speed is 2,607 keys/sec At 900 keys, avg. speed is 2,190 keys/sec At 1,000 keys, avg. speed is 2,570 keys/sec At 2,000 keys, avg. speed is 2,417 keys/sec At 3,000 keys, avg. speed is 1,982 keys/sec At 4,000 keys, avg. speed is 1,568 keys/sec At 5,000 keys, avg. speed is 1,533 keys/sec At 6,000 keys, avg. speed is 1,787 keys/sec At 7,000 keys, avg. speed is 1,977 keys/sec At 8,000 keys, avg. speed is 2,028 keys/sec At 9,000 keys, avg. speed is 2,077 keys/sec At 10,000 keys, avg. speed is 2,031 keys/sec At 20,000 keys, avg. speed is 1,970 keys/sec At 30,000 keys, avg. speed is 2,050 keys/sec At 40,000 keys, avg. speed is 2,073 keys/sec At 50,000 keys, avg. speed is 1,973 keys/sec At 60,000 keys, avg. speed is 1,914 keys/sec At 70,000 keys, avg. speed is 2,091 keys/sec At 80,000 keys, avg. speed is 2,103 keys/sec At 90,000 keys, avg. speed is 1,886 keys/sec At 100,000 keys, avg. speed is 1,970 keys/sec At 200,000 keys, avg. speed is 2,053 keys/sec At 300,000 keys, avg. speed is 1,697 keys/sec At 400,000 keys, avg. speed is 1,838 keys/sec At 500,000 keys, avg. speed is 1,941 keys/sec At 600,000 keys, avg. speed is 1,930 keys/sec At 700,000 keys, avg. speed is 1,735 keys/sec At 800,000 keys, avg. speed is 1,795 keys/sec At 900,000 keys, avg. speed is 1,221 keys/sec At 1,000,000 keys, avg. speed is 1,077 keys/sec This test was performed on a PowerMac G4 1gHz running Mac OS X 10.3.2 & Perl 5.8.1, with an 80GB Ultra ATA/100 HD spinning at 7200RPM. The hash keys and values were between 6 - 12 chars in length. The DB file ended up at 210MB. Run time was 12 min 3 sec. =head2 MEMORY USAGE One of the great things about L is that it uses very little memory. Even with huge databases (1,000,000+ keys) you will not see much increased memory on your process. L relies solely on the filesystem for storing and fetching data. Here is output from I before even opening a database handle: PID USER PRI NI SIZE RSS SHARE STAT %CPU %MEM TIME COMMAND 22831 root 11 0 2716 2716 1296 R 0.0 0.2 0:07 perl Basically the process is taking 2,716K of memory. And here is the same process after storing and fetching 1,000,000 keys: PID USER PRI NI SIZE RSS SHARE STAT %CPU %MEM TIME COMMAND 22831 root 14 0 2772 2772 1328 R 0.0 0.2 13:32 perl Notice the memory usage increased by only 56K. Test was performed on a 700mHz x86 box running Linux RedHat 7.2 & Perl 5.6.1. =cut DBM-Deep-2.0013/lib/DBM/Deep/Engine.pm000444001750001750 2607612641624315 15567 0ustar00robrob000000000000package DBM::Deep::Engine; use 5.008_004; use strict; use warnings FATAL => 'all'; no warnings 'recursion'; use DBM::Deep::Iterator (); # File-wide notes: # * Every method in here assumes that the storage has been appropriately # safeguarded. This can be anything from flock() to some sort of manual # mutex. But, it's the caller's responsibility to make sure that this has # been done. sub SIG_HASH () { 'H' } sub SIG_ARRAY () { 'A' } =head1 NAME DBM::Deep::Engine - mediate mapping between DBM::Deep objects and storage medium =head1 PURPOSE This is an internal-use-only object for L. It mediates the low-level mapping between the L objects and the storage medium. The purpose of this documentation is to provide low-level documentation for developers. It is B intended to be used by the general public. This documentation and what it documents can and will change without notice. =head1 OVERVIEW The engine exposes an API to the DBM::Deep objects (DBM::Deep, DBM::Deep::Array, and DBM::Deep::Hash) for their use to access the actual stored values. This API is the following: =over 4 =item * new =item * read_value =item * get_classname =item * make_reference =item * key_exists =item * delete_key =item * write_value =item * get_next_key =item * setup =item * clear =item * begin_work =item * commit =item * rollback =item * lock_exclusive =item * lock_shared =item * unlock =back They are explained in their own sections below. These methods, in turn, may provide some bounds-checking, but primarily act to instantiate objects in the Engine::Sector::* hierarchy and dispatch to them. =head1 TRANSACTIONS Transactions in DBM::Deep are implemented using a variant of MVCC. This attempts to keep the amount of actual work done against the file low while still providing Atomicity, Consistency, and Isolation. Durability, unfortunately, cannot be done with only one file. =head2 STALENESS If another process uses a transaction slot and writes stuff to it, then terminates, the data that process wrote is still within the file. In order to address this, there is also a transaction staleness counter associated within every write. Each time a transaction is started, that process increments that transaction's staleness counter. If, when it reads a value, the staleness counters aren't identical, DBM::Deep will consider the value on disk to be stale and discard it. =head2 DURABILITY The fourth leg of ACID is Durability, the guarantee that when a commit returns, the data will be there the next time you read from it. This should be regardless of any crashes or powerdowns in between the commit and subsequent read. DBM::Deep does provide that guarantee; once the commit returns, all of the data has been transferred from the transaction shadow to the HEAD. The issue arises with partial commits - a commit that is interrupted in some fashion. In keeping with DBM::Deep's "tradition" of very light error-checking and non-existent error-handling, there is no way to recover from a partial commit. (This is probably a failure in Consistency as well as Durability.) Other DBMSes use transaction logs (a separate file, generally) to achieve Durability. As DBM::Deep is a single-file, we would have to do something similar to what SQLite and BDB do in terms of committing using synchronized writes. To do this, we would have to use a much higher RAM footprint and some serious programming that makes my head hurt just to think about it. =cut =head1 METHODS =head2 read_value( $obj, $key ) This takes an object that provides _base_offset() and a string. It returns the value stored in the corresponding Sector::Value's data section. =cut sub read_value { die "read_value must be implemented in a child class" } =head2 get_classname( $obj ) This takes an object that provides _base_offset() and returns the classname (if any) associated with it. It delegates to Sector::Reference::get_classname() for the heavy lifting. It performs a staleness check. =cut sub get_classname { die "get_classname must be implemented in a child class" } =head2 make_reference( $obj, $old_key, $new_key ) This takes an object that provides _base_offset() and two strings. The strings correspond to the old key and new key, respectively. This operation is equivalent to (given C<< $db->{foo} = []; >>) C<< $db->{bar} = $db->{foo} >>. This returns nothing. =cut sub make_reference { die "make_reference must be implemented in a child class" } =head2 key_exists( $obj, $key ) This takes an object that provides _base_offset() and a string for the key to be checked. This returns 1 for true and "" for false. =cut sub key_exists { die "key_exists must be implemented in a child class" } =head2 delete_key( $obj, $key ) This takes an object that provides _base_offset() and a string for the key to be deleted. This returns the result of the Sector::Reference delete_key() method. =cut sub delete_key { die "delete_key must be implemented in a child class" } =head2 write_value( $obj, $key, $value ) This takes an object that provides _base_offset(), a string for the key, and a value. This value can be anything storable within L. This returns 1 upon success. =cut sub write_value { die "write_value must be implemented in a child class" } =head2 setup( $obj ) This takes an object that provides _base_offset(). It will do everything needed in order to properly initialize all values for necessary functioning. If this is called upon an already initialized object, this will also reset the inode. This returns 1. =cut sub setup { die "setup must be implemented in a child class" } =head2 begin_work( $obj ) This takes an object that provides _base_offset(). It will set up all necessary bookkeeping in order to run all work within a transaction. If $obj is already within a transaction, an error will be thrown. If there are no more available transactions, an error will be thrown. This returns undef. =cut sub begin_work { die "begin_work must be implemented in a child class" } =head2 rollback( $obj ) This takes an object that provides _base_offset(). It will revert all actions taken within the running transaction. If $obj is not within a transaction, an error will be thrown. This returns 1. =cut sub rollback { die "rollback must be implemented in a child class" } =head2 commit( $obj ) This takes an object that provides _base_offset(). It will apply all actions taken within the transaction to the HEAD. If $obj is not within a transaction, an error will be thrown. This returns 1. =cut sub commit { die "commit must be implemented in a child class" } =head2 get_next_key( $obj, $prev_key ) This takes an object that provides _base_offset() and an optional string representing the prior key returned via a prior invocation of this method. This method delegates to C<< DBM::Deep::Iterator->get_next_key() >>. =cut # XXX Add staleness here sub get_next_key { my $self = shift; my ($obj, $prev_key) = @_; # XXX Need to add logic about resetting the iterator if any key in the # reference has changed unless ( defined $prev_key ) { eval "use " . $self->iterator_class; die $@ if $@; $obj->{iterator} = $self->iterator_class->new({ base_offset => $obj->_base_offset, engine => $self, }); } return $obj->{iterator}->get_next_key( $obj ); } =head2 lock_exclusive() This takes an object that provides _base_offset(). It will guarantee that the storage has taken precautions to be safe for a write. This returns nothing. =cut sub lock_exclusive { my $self = shift; my ($obj) = @_; return $self->storage->lock_exclusive( $obj ); } =head2 lock_shared() This takes an object that provides _base_offset(). It will guarantee that the storage has taken precautions to be safe for a read. This returns nothing. =cut sub lock_shared { my $self = shift; my ($obj) = @_; return $self->storage->lock_shared( $obj ); } =head2 unlock() This takes an object that provides _base_offset(). It will guarantee that the storage has released the most recently-taken lock. This returns nothing. =cut sub unlock { my $self = shift; my ($obj) = @_; my $rv = $self->storage->unlock( $obj ); $self->flush if $rv; return $rv; } =head1 INTERNAL METHODS The following methods are internal-use-only to DBM::Deep::Engine and its child classes. =cut =head2 flush() This takes no arguments. It will do everything necessary to flush all things to disk. This is usually called during unlock() and setup(). This returns nothing. =cut sub flush { my $self = shift; # Why do we need to have the storage flush? Shouldn't autoflush take care of # things? -RobK, 2008-06-26 $self->storage->flush; return; } =head2 load_sector( $loc ) This takes an id/location/offset and loads the sector based on the engine's defined sector type. =cut sub load_sector { $_[0]->sector_type->load( @_ ) } =head2 clear( $obj ) This takes an object that provides _base_offset() and deletes all its elements, returning nothing. =cut sub clear { die "clear must be implemented in a child class" } =head2 cache / clear_cache This is the cache of loaded Reference sectors. =cut sub cache { $_[0]{cache} ||= {} } sub clear_cache { %{$_[0]->cache} = () } =head2 supports( $option ) This returns a boolean depending on if this instance of DBM::Dep supports that feature. C<$option> can be one of: =over 4 =item * transactions =item * singletons =back Any other value will return false. =cut sub supports { die "supports must be implemented in a child class" } =head1 ACCESSORS The following are readonly attributes. =over 4 =item * storage =item * sector_type =item * iterator_class =back =cut sub storage { $_[0]{storage} } sub sector_type { die "sector_type must be implemented in a child class" } sub iterator_class { die "iterator_class must be implemented in a child class" } # This code is to make sure we write all the values in the $value to the # disk and to make sure all changes to $value after the assignment are # reflected on disk. This may be counter-intuitive at first, but it is # correct dwimmery. # NOTE - simply tying $value won't perform a STORE on each value. Hence, # the copy to a temp value. sub _descend { my $self = shift; my ($value, $value_sector) = @_; my $r = Scalar::Util::reftype( $value ) || ''; if ( $r eq 'ARRAY' ) { my @temp = @$value; tie @$value, 'DBM::Deep', { base_offset => $value_sector->offset, staleness => $value_sector->staleness, storage => $self->storage, engine => $self, }; @$value = @temp; bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value ); } elsif ( $r eq 'HASH' ) { my %temp = %$value; tie %$value, 'DBM::Deep', { base_offset => $value_sector->offset, staleness => $value_sector->staleness, storage => $self->storage, engine => $self, }; %$value = %temp; bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value ); } return; } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Array.pm000444001750001750 2341312641624315 15430 0ustar00robrob000000000000package DBM::Deep::Array; use 5.008_004; use strict; use warnings FATAL => 'all'; no warnings 'recursion'; # This is to allow DBM::Deep::Array to handle negative indices on # its own. Otherwise, Perl would intercept the call to negative # indices for us. This was causing bugs for negative index handling. our $NEGATIVE_INDICES = 1; use base 'DBM::Deep'; use Scalar::Util (); sub _get_self { # We used to have # eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0] # but this does not always work during global destruction (DBM::Deep’s # destructor calls this method), but will return $_[0] even when $_[0] # is tied, if it’s tied to undef. In those cases it’s better to return # undef, so the destructor can tell not to do anything, and, if any- # thing else calls us, it will fail with a more helpful error message. Scalar::Util::reftype $_[0] eq 'ARRAY' ? tied @{$_[0]} : $_[0]; } sub _repr { [] } sub TIEARRAY { my $class = shift; my $args = $class->_get_args( @_ ); $args->{type} = $class->TYPE_ARRAY; return $class->_init($args); } sub FETCH { my $self = shift->_get_self; my ($key) = @_; $self->lock_shared; if ( !defined $key ) { $self->unlock; DBM::Deep->_throw_error( "Cannot use an undefined array index." ); } elsif ( $key =~ /^-?\d+$/ ) { if ( $key < 0 ) { $key += $self->FETCHSIZE; unless ( $key >= 0 ) { $self->unlock; return; } } } elsif ( $key ne 'length' ) { $self->unlock; DBM::Deep->_throw_error( "Cannot use '$key' as an array index." ); } my $rv = $self->SUPER::FETCH( $key ); $self->unlock; return $rv; } sub STORE { my $self = shift->_get_self; my ($key, $value) = @_; $self->lock_exclusive; my $size; my $idx_is_numeric; if ( !defined $key ) { $self->unlock; DBM::Deep->_throw_error( "Cannot use an undefined array index." ); } elsif ( $key =~ /^-?\d+$/ ) { $idx_is_numeric = 1; if ( $key < 0 ) { $size = $self->FETCHSIZE; if ( $key + $size < 0 ) { die( "Modification of non-creatable array value attempted, subscript $key" ); } $key += $size } } elsif ( $key ne 'length' ) { $self->unlock; DBM::Deep->_throw_error( "Cannot use '$key' as an array index." ); } my $rv = $self->SUPER::STORE( $key, $value ); if ( $idx_is_numeric ) { $size = $self->FETCHSIZE unless defined $size; if ( $key >= $size ) { $self->STORESIZE( $key + 1 ); } } $self->unlock; return $rv; } sub EXISTS { my $self = shift->_get_self; my ($key) = @_; $self->lock_shared; if ( !defined $key ) { $self->unlock; DBM::Deep->_throw_error( "Cannot use an undefined array index." ); } elsif ( $key =~ /^-?\d+$/ ) { if ( $key < 0 ) { $key += $self->FETCHSIZE; unless ( $key >= 0 ) { $self->unlock; return; } } } elsif ( $key ne 'length' ) { $self->unlock; DBM::Deep->_throw_error( "Cannot use '$key' as an array index." ); } my $rv = $self->SUPER::EXISTS( $key ); $self->unlock; return $rv; } sub DELETE { my $self = shift->_get_self; my ($key) = @_; warn "ARRAY::DELETE($self,$key)\n" if DBM::Deep::DEBUG; $self->lock_exclusive; my $size = $self->FETCHSIZE; if ( !defined $key ) { $self->unlock; DBM::Deep->_throw_error( "Cannot use an undefined array index." ); } elsif ( $key =~ /^-?\d+$/ ) { if ( $key < 0 ) { $key += $size; unless ( $key >= 0 ) { $self->unlock; return; } } } elsif ( $key ne 'length' ) { $self->unlock; DBM::Deep->_throw_error( "Cannot use '$key' as an array index." ); } my $rv = $self->SUPER::DELETE( $key ); if ($rv && $key == $size - 1) { $self->STORESIZE( $key ); } $self->unlock; return $rv; } # Now that we have a real Reference sector, we should store arrayzize there. # However, arraysize needs to be transactionally-aware, so a simple location to # store it isn't going to work. sub FETCHSIZE { my $self = shift->_get_self; $self->lock_shared; my $SAVE_FILTER = $self->_engine->storage->{filter_fetch_value}; $self->_engine->storage->{filter_fetch_value} = undef; my $size = $self->FETCH('length') || 0; $self->_engine->storage->{filter_fetch_value} = $SAVE_FILTER; $self->unlock; return $size; } sub STORESIZE { my $self = shift->_get_self; my ($new_length) = @_; $self->lock_exclusive; my $SAVE_FILTER = $self->_engine->storage->{filter_store_value}; $self->_engine->storage->{filter_store_value} = undef; my $result = $self->STORE('length', $new_length, 'length'); $self->_engine->storage->{filter_store_value} = $SAVE_FILTER; $self->unlock; return $result; } sub POP { my $self = shift->_get_self; $self->lock_exclusive; my $length = $self->FETCHSIZE(); if ($length) { my $content = $self->FETCH( $length - 1 ); $self->DELETE( $length - 1 ); $self->unlock; return $content; } else { $self->unlock; return; } } sub PUSH { my $self = shift->_get_self; $self->lock_exclusive; my $length = $self->FETCHSIZE(); for my $content (@_) { $self->STORE( $length, $content ); $length++; } $self->unlock; return $length; } # XXX This really needs to be something more direct within the file, not a # fetch and re-store. -RobK, 2007-09-20 sub _move_value { my $self = shift; my ($old_key, $new_key) = @_; return $self->_engine->make_reference( $self, $old_key, $new_key ); } sub SHIFT { my $self = shift->_get_self; warn "SHIFT($self)\n" if DBM::Deep::DEBUG; $self->lock_exclusive; my $length = $self->FETCHSIZE(); if ( !$length ) { $self->unlock; return; } my $content = $self->DELETE( 0 ); # Unless the deletion above has cleared the array ... if ( $length > 1 ) { for (my $i = 0; $i < $length - 1; $i++) { $self->_move_value( $i+1, $i ); } $self->DELETE( $length - 1 ); } $self->unlock; return $content; } sub UNSHIFT { my $self = shift->_get_self; my @new_elements = @_; $self->lock_exclusive; my $length = $self->FETCHSIZE(); my $new_size = scalar @new_elements; if ($length) { for (my $i = $length - 1; $i >= 0; $i--) { $self->_move_value( $i, $i+$new_size ); } $self->STORESIZE( $length + $new_size ); } for (my $i = 0; $i < $new_size; $i++) { $self->STORE( $i, $new_elements[$i] ); } $self->unlock; return $length + $new_size; } sub SPLICE { my $self = shift->_get_self; $self->lock_exclusive; my $length = $self->FETCHSIZE(); ## # Calculate offset and length of splice ## my $offset = shift; $offset = 0 unless defined $offset; if ($offset < 0) { $offset += $length; } my $splice_length; if (scalar @_) { $splice_length = shift; } else { $splice_length = $length - $offset; } if ($splice_length < 0) { $splice_length += ($length - $offset); } ## # Setup array with new elements, and copy out old elements for return ## my @new_elements = @_; my $new_size = scalar @new_elements; my @old_elements = map { $self->FETCH( $_ ) } $offset .. ($offset + $splice_length - 1); ## # Adjust array length, and shift elements to accommodate new section. ## if ( $new_size != $splice_length ) { if ($new_size > $splice_length) { for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) { $self->_move_value( $i, $i + ($new_size - $splice_length) ); } $self->STORESIZE( $length + $new_size - $splice_length ); } else { for (my $i = $offset + $splice_length; $i < $length; $i++) { $self->_move_value( $i, $i + ($new_size - $splice_length) ); } for (my $i = 0; $i < $splice_length - $new_size; $i++) { $self->DELETE( $length - 1 ); $length--; } } } ## # Insert new elements into array ## for (my $i = $offset; $i < $offset + $new_size; $i++) { $self->STORE( $i, shift @new_elements ); } $self->unlock; ## # Return deleted section, or last element in scalar context. ## return wantarray ? @old_elements : $old_elements[-1]; } # We don't need to populate it, yet. # It will be useful, though, when we split out HASH and ARRAY # Perl will call EXTEND() when the array is likely to grow. # We don't care, but include it because it gets called at times. sub EXTEND {} sub _copy_node { my $self = shift; my ($db_temp) = @_; my $length = $self->length(); for (my $index = 0; $index < $length; $index++) { $self->_copy_value( \$db_temp->[$index], $self->get($index) ); } return 1; } sub _clear { my $self = shift; my $size = $self->FETCHSIZE; for my $key ( 0 .. $size - 1 ) { $self->_engine->delete_key( $self, $key, $key ); } $self->STORESIZE( 0 ); return; } sub length { (shift)->FETCHSIZE(@_) } sub pop { (shift)->POP(@_) } sub push { (shift)->PUSH(@_) } sub unshift { (shift)->UNSHIFT(@_) } sub splice { (shift)->SPLICE(@_) } # This must be last otherwise we have to qualify all other calls to shift # as calls to CORE::shift sub shift { (CORE::shift)->SHIFT(@_) } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Null.pm000444001750001750 222112641624315 15236 0ustar00robrob000000000000package DBM::Deep::Null; use 5.008_004; use strict; use warnings FATAL => 'all'; =head1 NAME DBM::Deep::Null - NULL object =head1 PURPOSE This is an internal-use-only object for L. It acts as a NULL object in the same vein as MARCEL's L. I couldn't use L because DBM::Deep needed an object that always evaluated as undef, not an implementation of the Null Class pattern. =head1 OVERVIEW It is used to represent null sectors in DBM::Deep. =cut use overload 'bool' => sub { undef }, '""' => sub { undef }, '0+' => sub { 0 }, ('cmp' => '<=>' => sub { return 0 if !defined $_[1] || !length $_[1]; return $_[2] ? 1 : -1; } )[0,2,1,2], # same sub for both ops '%{}' => sub { require Carp; Carp::croak("Can't use a stale reference as a HASH"); }, '@{}' => sub { require Carp; Carp::croak("Can't use a stale reference as an ARRAY"); }, fallback => 1, nomethod => 'AUTOLOAD'; sub AUTOLOAD { return; } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Iterator000755001750001750 012641624315 15425 5ustar00robrob000000000000DBM-Deep-2.0013/lib/DBM/Deep/Iterator/File.pm000444001750001750 524112641624315 17001 0ustar00robrob000000000000package DBM::Deep::Iterator::File; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Iterator ); use DBM::Deep::Iterator::File::BucketList (); use DBM::Deep::Iterator::File::Index (); sub reset { $_[0]{breadcrumbs} = []; return } sub get_sector_iterator { my $self = shift; my ($loc) = @_; my $sector = $self->{engine}->load_sector( $loc ) or return; if ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) { return DBM::Deep::Iterator::File::Index->new({ iterator => $self, sector => $sector, }); } elsif ( $sector->isa( 'DBM::Deep::Sector::File::BucketList' ) ) { return DBM::Deep::Iterator::File::BucketList->new({ iterator => $self, sector => $sector, }); } DBM::Deep->_throw_error( "get_sector_iterator(): Why did $loc make a $sector?" ); } sub get_next_key { my $self = shift; my ($obj) = @_; my $crumbs = $self->{breadcrumbs}; my $e = $self->{engine}; unless ( @$crumbs ) { # This will be a Reference sector my $sector = $e->load_sector( $self->{base_offset} ) # If no sector is found, this must have been deleted from under us. or return; if ( $sector->staleness != $obj->_staleness ) { return; } my $loc = $sector->get_blist_loc or return; push @$crumbs, $self->get_sector_iterator( $loc ); } FIND_NEXT_KEY: { # We're at the end. unless ( @$crumbs ) { $self->reset; return; } my $iterator = $crumbs->[-1]; # This level is done. if ( $iterator->at_end ) { pop @$crumbs; redo FIND_NEXT_KEY; } if ( $iterator->isa( 'DBM::Deep::Iterator::File::Index' ) ) { # If we don't have any more, it will be caught at the # prior check. if ( my $next = $iterator->get_next_iterator ) { push @$crumbs, $next; } redo FIND_NEXT_KEY; } unless ( $iterator->isa( 'DBM::Deep::Iterator::File::BucketList' ) ) { DBM::Deep->_throw_error( "Should have a bucketlist iterator here - instead have $iterator" ); } # At this point, we have a BucketList iterator my $key = $iterator->get_next_key; if ( defined $key ) { return $key; } #XXX else { $iterator->set_to_end() } ? # We hit the end of the bucketlist iterator, so redo redo FIND_NEXT_KEY; } DBM::Deep->_throw_error( "get_next_key(): How did we get here?" ); } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Iterator/DBI.pm000444001750001750 137712641624315 16526 0ustar00robrob000000000000package DBM::Deep::Iterator::DBI; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Iterator ); sub reset { my $self = shift; eval { $self->{sth}->finish; }; delete $self->{sth}; return; } sub get_next_key { my $self = shift; my ($obj) = @_; unless ( exists $self->{sth} ) { # For mysql, this needs to be RAND() # For sqlite, this needs to be random() my $storage = $self->{engine}->storage; $self->{sth} = $storage->{dbh}->prepare( "SELECT `key` FROM datas WHERE ref_id = ? ORDER BY " . $storage->rand_function, ); $self->{sth}->execute( $self->{base_offset} ); } my ($key) = $self->{sth}->fetchrow_array; return $key; } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Iterator/File000755001750001750 012641624315 16304 5ustar00robrob000000000000DBM-Deep-2.0013/lib/DBM/Deep/Iterator/File/BucketList.pm000444001750001750 371712641624315 21060 0ustar00robrob000000000000package DBM::Deep::Iterator::File::BucketList; use 5.008_004; use strict; use warnings FATAL => 'all'; =head1 NAME DBM::Deep::Iterator::BucketList - mediate between DBM::Deep::Iterator and DBM::Deep::Engine::Sector::BucketList =head1 PURPOSE This is an internal-use-only object for L. It acts as the mediator between the L object and a L sector. =head1 OVERVIEW This object, despite the implied class hierarchy, does B inherit from L. Instead, it delegates to it, essentially acting as a facade over it. L will instantiate one of these objects as needed to handle an BucketList sector. =head1 METHODS =head2 new(\%params) The constructor takes a hashref of params and blesses it into the invoking class. The hashref is assumed to have the following elements: =over 4 =item * iterator (of type L =item * sector (of type L =back =cut sub new { my $self = bless $_[1] => $_[0]; $self->{curr_index} = 0; return $self; } =head2 at_end() This takes no arguments. This returns true/false indicating whether this sector has any more elements that can be iterated over. =cut sub at_end { my $self = shift; return $self->{curr_index} >= $self->{iterator}{engine}->max_buckets; } =head2 get_next_iterator() This takes no arguments. This returns the next key pointed to by this bucketlist. This value is suitable for returning by FIRSTKEY or NEXTKEY(). If the bucketlist is exhausted, it returns nothing. =cut sub get_next_key { my $self = shift; return if $self->at_end; my $idx = $self->{curr_index}++; my $data_loc = $self->{sector}->get_data_location_for({ allow_head => 1, idx => $idx, }) or return; #XXX Do we want to add corruption checks here? return $self->{sector}->get_key_for( $idx )->data; } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Iterator/File/Index.pm000444001750001750 355412641624315 20055 0ustar00robrob000000000000package DBM::Deep::Iterator::File::Index; use 5.008_004; use strict; use warnings FATAL => 'all'; =head1 NAME DBM::Deep::Iterator::Index - mediate between DBM::Deep::Iterator and DBM::Deep::Engine::Sector::Index =head1 PURPOSE This is an internal-use-only object for L. It acts as the mediator between the L object and a L sector. =head1 OVERVIEW This object, despite the implied class hierarchy, does B inherit from L. Instead, it delegates to it, essentially acting as a facade over it. L will instantiate one of these objects as needed to handle an Index sector. =head1 METHODS =head2 new(\%params) The constructor takes a hashref of params and blesses it into the invoking class. The hashref is assumed to have the following elements: =over 4 =item * iterator (of type L =item * sector (of type L =back =cut sub new { my $self = bless $_[1] => $_[0]; $self->{curr_index} = 0; return $self; } =head2 at_end() This takes no arguments. This returns true/false indicating whether this sector has any more elements that can be iterated over. =cut sub at_end { my $self = shift; return $self->{curr_index} >= $self->{iterator}{engine}->hash_chars; } =head2 get_next_iterator() This takes no arguments. This returns an iterator (built by L) based on the sector pointed to by the next occupied location in this index. If the sector is exhausted, it returns nothing. =cut sub get_next_iterator { my $self = shift; my $loc; while ( !$loc ) { return if $self->at_end; $loc = $self->{sector}->get_entry( $self->{curr_index}++ ); } return $self->{iterator}->get_sector_iterator( $loc ); } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Storage000755001750001750 012641624315 15240 5ustar00robrob000000000000DBM-Deep-2.0013/lib/DBM/Deep/Storage/File.pm000444001750001750 2046712641624315 16643 0ustar00robrob000000000000package DBM::Deep::Storage::File; use 5.008_004; use strict; use warnings FATAL => 'all'; use Fcntl qw( :DEFAULT :flock :seek ); use constant DEBUG => 0; use base 'DBM::Deep::Storage'; =head1 NAME DBM::Deep::Storage::File - mediate low-level interaction with storage mechanism =head1 PURPOSE This is an internal-use-only object for L. It mediates the low-level interaction with the storage mechanism. Currently, the only storage mechanism supported is the file system. =head1 OVERVIEW This class provides an abstraction to the storage mechanism so that the Engine (the only class that uses this class) doesn't have to worry about that. =head1 METHODS =head2 new( \%args ) =cut sub new { my $class = shift; my ($args) = @_; my $self = bless { autobless => 1, autoflush => 1, end => 0, fh => undef, file => undef, file_offset => 0, locking => 1, locked => 0, #XXX Migrate this to the engine, where it really belongs. filter_store_key => undef, filter_store_value => undef, filter_fetch_key => undef, filter_fetch_value => undef, }, $class; # Grab the parameters we want to use foreach my $param ( keys %$self ) { next unless exists $args->{$param}; $self->{$param} = $args->{$param}; } if ( $self->{fh} && !$self->{file_offset} ) { $self->{file_offset} = tell( $self->{fh} ); } $self->open unless $self->{fh}; return $self; } =head2 open() This method opens the filehandle for the filename in C< file >. There is no return value. =cut # TODO: What happens if we ->open when we already have a $fh? sub open { my $self = shift; # Adding O_BINARY should remove the need for the binmode below. However, # I'm not going to remove it because I don't have the Win32 chops to be # absolutely certain everything will be ok. my $flags = O_CREAT | O_BINARY; if ( !-e $self->{file} || -w _ ) { $flags |= O_RDWR; } else { $flags |= O_RDONLY; } my $fh; sysopen( $fh, $self->{file}, $flags ) or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n"; $self->{fh} = $fh; # Even though we use O_BINARY, better be safe than sorry. binmode $fh; if ($self->{autoflush}) { my $old = select $fh; $|=1; select $old; } return 1; } =head2 close() If the filehandle is opened, this will close it. There is no return value. =cut sub close { my $self = shift; if ( $self->{fh} ) { close $self->{fh}; $self->{fh} = undef; } return 1; } =head2 size() This will return the size of the DB. If file_offset is set, this will take that into account. B: This function isn't used internally anywhere. =cut sub size { my $self = shift; return 0 unless $self->{fh}; return( (-s $self->{fh}) - $self->{file_offset} ); } =head2 set_inode() This will set the inode value of the underlying file object. This is only needed to handle some obscure Win32 bugs. It really shouldn't be needed outside this object. There is no return value. =cut sub set_inode { my $self = shift; unless ( defined $self->{inode} ) { my @stats = stat($self->{fh}); $self->{inode} = $stats[1]; $self->{end} = $stats[7]; } return 1; } =head2 print_at( $offset, @data ) This takes an optional offset and some data to print. C< $offset >, if defined, will be used to seek into the file. If file_offset is set, it will be used as the zero location. If it is undefined, no seeking will occur. Then, C< @data > will be printed to the current location. There is no return value. =cut sub print_at { my $self = shift; my $loc = shift; local ($,,$\); my $fh = $self->{fh}; if ( defined $loc ) { seek( $fh, $loc + $self->{file_offset}, SEEK_SET ); } if ( DEBUG ) { my $caller = join ':', (caller)[0,2]; my $len = length( join '', @_ ); warn "($caller) print_at( " . (defined $loc ? $loc : '') . ", $len )\n"; } print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n"; return 1; } =head2 read_at( $offset, $length ) This takes an optional offset and a length. C< $offset >, if defined, will be used to seek into the file. If file_offset is set, it will be used as the zero location. If it is undefined, no seeking will occur. Then, C< $length > bytes will be read from the current location. The data read will be returned. =cut sub read_at { my $self = shift; my ($loc, $size) = @_; my $fh = $self->{fh}; if ( defined $loc ) { seek( $fh, $loc + $self->{file_offset}, SEEK_SET ); } if ( DEBUG ) { my $caller = join ':', (caller)[0,2]; warn "($caller) read_at( " . (defined $loc ? $loc : '') . ", $size )\n"; } my $buffer; read( $fh, $buffer, $size); return $buffer; } =head2 DESTROY When the ::Storage::File object goes out of scope, it will be closed. =cut sub DESTROY { my $self = shift; return unless $self; $self->close; return; } =head2 request_space( $size ) This takes a size and adds that much space to the DBM. This returns the offset for the new location. =cut sub request_space { my $self = shift; my ($size) = @_; #XXX Do I need to reset $self->{end} here? I need a testcase my $loc = $self->{end}; $self->{end} += $size; return $loc; } =head2 copy_stats( $target_filename ) This will take the stats for the current filehandle and apply them to C< $target_filename >. The stats copied are: =over 4 =item * Onwer UID and GID =item * Permissions =back =cut sub copy_stats { my $self = shift; my ($temp_filename) = @_; my @stats = stat( $self->{fh} ); my $perms = $stats[2] & 07777; my $uid = $stats[4]; my $gid = $stats[5]; chown( $uid, $gid, $temp_filename ); chmod( $perms, $temp_filename ); } sub flush { my $self = shift; # Flush the filehandle my $old_fh = select $self->{fh}; my $old_af = $|; $| = 1; $| = $old_af; select $old_fh; return 1; } sub is_writable { my $self = shift; my $fh = $self->{fh}; return unless defined $fh; return unless defined fileno $fh; local $\ = ''; # just in case no warnings; # temporarily disable warnings local $^W; # temporarily disable warnings return print $fh ''; } sub lock_exclusive { my $self = shift; my ($obj) = @_; return $self->_lock( $obj, LOCK_EX ); } sub lock_shared { my $self = shift; my ($obj) = @_; return $self->_lock( $obj, LOCK_SH ); } sub _lock { my $self = shift; my ($obj, $type) = @_; $type = LOCK_EX unless defined $type; #XXX This is a temporary fix for Win32 and autovivification. It # needs to improve somehow. -RobK, 2008-03-09 if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) { $type = LOCK_EX; } if (!defined($self->{fh})) { return; } #XXX This either needs to allow for upgrading a shared lock to an # exclusive lock or something else with autovivification. # -RobK, 2008-03-09 if ($self->{locking}) { if (!$self->{locked}) { flock($self->{fh}, $type); # refresh end counter in case file has changed size my @stats = stat($self->{fh}); $self->{end} = $stats[7]; # double-check file inode, in case another process # has optimize()d our file while we were waiting. if (defined($self->{inode}) && $stats[1] != $self->{inode}) { $self->close; $self->open; #XXX This needs work $obj->{engine}->setup( $obj ); flock($self->{fh}, $type); # re-lock # This may not be necessary after re-opening $self->{end} = (stat($self->{fh}))[7]; # re-end } } $self->{locked}++; return 1; } return; } sub unlock { my $self = shift; if (!defined($self->{fh})) { return; } if ($self->{locking} && $self->{locked} > 0) { $self->{locked}--; if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); return 1; } return; } return; } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Storage/DBI.pm000444001750001750 657712641624315 16350 0ustar00robrob000000000000package DBM::Deep::Storage::DBI; use 5.008_004; use strict; use warnings FATAL => 'all'; use base 'DBM::Deep::Storage'; use DBI; sub new { my $class = shift; my ($args) = @_; my $self = bless { autobless => 1, dbh => undef, dbi => undef, }, $class; # Grab the parameters we want to use foreach my $param ( keys %$self ) { next unless exists $args->{$param}; $self->{$param} = $args->{$param}; } if ( $self->{dbh} ) { $self->{driver} = lc $self->{dbh}->{Driver}->{Name}; } else { $self->open; } # Foreign keys are turned off by default in SQLite3 (for now) #q.v. http://search.cpan.org/~adamk/DBD-SQLite-1.27/lib/DBD/SQLite.pm#Foreign_Keys # for more info. if ( $self->driver eq 'sqlite' ) { $self->{dbh}->do( 'PRAGMA foreign_keys = ON' ); } return $self; } sub open { my $self = shift; return if $self->{dbh}; $self->{dbh} = DBI->connect( $self->{dbi}{dsn}, $self->{dbi}{username}, $self->{dbi}{password}, { AutoCommit => 1, PrintError => 0, RaiseError => 1, %{ $self->{dbi}{connect_args} || {} }, }, ) or die $DBI::error; # Should we use the same method as done in new() if passed a $dbh? (undef, $self->{driver}) = map defined($_) ? lc($_) : undef, DBI->parse_dsn( $self->{dbi}{dsn} ); return 1; } sub close { my $self = shift; $self->{dbh}->disconnect if $self->{dbh}; return 1; } sub DESTROY { my $self = shift; $self->close if ref $self; } # Is there a portable way of determining writability to a DBH? sub is_writable { my $self = shift; return 1; } sub lock_exclusive { my $self = shift; } sub lock_shared { my $self = shift; } sub unlock { my $self = shift; # $self->{dbh}->commit; } #sub begin_work { # my $self = shift; # $self->{dbh}->begin_work; #} # #sub commit { # my $self = shift; # $self->{dbh}->commit; #} # #sub rollback { # my $self = shift; # $self->{dbh}->rollback; #} sub read_from { my $self = shift; my ($table, $cond, @cols) = @_; $cond = { id => $cond } unless ref $cond; my @keys = keys %$cond; my $where = join ' AND ', map { "`$_` = ?" } @keys; return $self->{dbh}->selectall_arrayref( "SELECT `@{[join '`,`', @cols ]}` FROM $table WHERE $where", { Slice => {} }, @{$cond}{@keys}, ); } sub flush {} sub write_to { my $self = shift; my ($table, $id, %args) = @_; my @keys = keys %args; my $sql = "REPLACE INTO $table ( `id`, " . join( ',', map { "`$_`" } @keys ) . ") VALUES (" . join( ',', ('?') x (@keys + 1) ) . ")"; $self->{dbh}->do( $sql, undef, $id, @args{@keys} ); return $self->{dbh}->last_insert_id("", "", "", ""); } sub delete_from { my $self = shift; my ($table, $cond) = @_; $cond = { id => $cond } unless ref $cond; my @keys = keys %$cond; my $where = join ' AND ', map { "`$_` = ?" } @keys; $self->{dbh}->do( "DELETE FROM $table WHERE $where", undef, @{$cond}{@keys}, ); } sub driver { $_[0]{driver} } sub rand_function { my $self = shift; my $driver = $self->driver; $driver eq 'sqlite' and return 'random()'; $driver eq 'mysql' and return 'RAND()'; die "rand_function undefined for $driver\n"; } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Engine000755001750001750 012641624315 15041 5ustar00robrob000000000000DBM-Deep-2.0013/lib/DBM/Deep/Engine/File.pm000444001750001750 10121412641624315 16452 0ustar00robrob000000000000package DBM::Deep::Engine::File; use 5.008_004; use strict; use warnings FATAL => 'all'; no warnings 'recursion'; use base qw( DBM::Deep::Engine ); use Scalar::Util (); use DBM::Deep::Null (); use DBM::Deep::Sector::File (); use DBM::Deep::Storage::File (); sub sector_type { 'DBM::Deep::Sector::File' } sub iterator_class { 'DBM::Deep::Iterator::File' } my $STALE_SIZE = 2; # Setup file and tag signatures. These should never change. sub SIG_FILE () { 'DPDB' } sub SIG_HEADER () { 'h' } sub SIG_NULL () { 'N' } sub SIG_DATA () { 'D' } sub SIG_UNIDATA () { 'U' } sub SIG_INDEX () { 'I' } sub SIG_BLIST () { 'B' } sub SIG_FREE () { 'F' } sub SIG_SIZE () { 1 } # SIG_HASH and SIG_ARRAY are defined in DBM::Deep::Engine # Please refer to the pack() documentation for further information my %StP = ( 1 => 'C', # Unsigned char value (no order needed as it's just one byte) 2 => 'n', # Unsigned short in "network" (big-endian) order 4 => 'N', # Unsigned long in "network" (big-endian) order 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) ); =head1 NAME DBM::Deep::Engine::File - engine for use with DBM::Deep::Storage::File =head1 PURPOSE This is the engine for use with L. =head1 EXTERNAL METHODS =head2 new() This takes a set of args. These args are described in the documentation for L. =cut sub new { my $class = shift; my ($args) = @_; $args->{storage} = DBM::Deep::Storage::File->new( $args ) unless exists $args->{storage}; my $self = bless { byte_size => 4, digest => undef, hash_size => 16, # In bytes hash_chars => 256, # Number of chars the algorithm uses per byte max_buckets => 16, num_txns => 1, # The HEAD trans_id => 0, # Default to the HEAD data_sector_size => 64, # Size in bytes of each data sector entries => {}, # This is the list of entries for transactions storage => undef, external_refs => undef, }, $class; # Never allow byte_size to be set directly. delete $args->{byte_size}; if ( defined $args->{pack_size} ) { if ( lc $args->{pack_size} eq 'small' ) { $args->{byte_size} = 2; } elsif ( lc $args->{pack_size} eq 'medium' ) { $args->{byte_size} = 4; } elsif ( lc $args->{pack_size} eq 'large' ) { $args->{byte_size} = 8; } else { DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" ); } } # Grab the parameters we want to use foreach my $param ( keys %$self ) { next unless exists $args->{$param}; $self->{$param} = $args->{$param}; } my %validations = ( max_buckets => { floor => 16, ceil => 256 }, num_txns => { floor => 1, ceil => 255 }, data_sector_size => { floor => 32, ceil => 256 }, ); while ( my ($attr, $c) = each %validations ) { if ( !defined $self->{$attr} || !length $self->{$attr} || $self->{$attr} =~ /\D/ || $self->{$attr} < $c->{floor} ) { $self->{$attr} = '(undef)' if !defined $self->{$attr}; warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n"; $self->{$attr} = $c->{floor}; } elsif ( $self->{$attr} > $c->{ceil} ) { warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n"; $self->{$attr} = $c->{ceil}; } } if ( !$self->{digest} ) { require Digest::MD5; $self->{digest} = \&Digest::MD5::md5; } return $self; } sub read_value { my $self = shift; my ($obj, $key) = @_; # This will be a Reference sector my $sector = $self->load_sector( $obj->_base_offset ) or return; if ( $sector->staleness != $obj->_staleness ) { return; } my $key_md5 = $self->_apply_digest( $key ); my $value_sector = $sector->get_data_for({ key_md5 => $key_md5, allow_head => 1, }); unless ( $value_sector ) { return undef } return $value_sector->data; } sub get_classname { my $self = shift; my ($obj) = @_; # This will be a Reference sector my $sector = $self->load_sector( $obj->_base_offset ) or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" ); if ( $sector->staleness != $obj->_staleness ) { return; } return $sector->get_classname; } sub make_reference { my $self = shift; my ($obj, $old_key, $new_key) = @_; # This will be a Reference sector my $sector = $self->load_sector( $obj->_base_offset ) or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" ); if ( $sector->staleness != $obj->_staleness ) { return; } my $old_md5 = $self->_apply_digest( $old_key ); my $value_sector = $sector->get_data_for({ key_md5 => $old_md5, allow_head => 1, }); unless ( $value_sector ) { $value_sector = DBM::Deep::Sector::File::Null->new({ engine => $self, data => undef, }); $sector->write_data({ key_md5 => $old_md5, key => $old_key, value => $value_sector, }); } if ( $value_sector->isa( 'DBM::Deep::Sector::File::Reference' ) ) { $sector->write_data({ key => $new_key, key_md5 => $self->_apply_digest( $new_key ), value => $value_sector, }); $value_sector->increment_refcount; } else { $sector->write_data({ key => $new_key, key_md5 => $self->_apply_digest( $new_key ), value => $value_sector->clone, }); } return; } # exists returns '', not undefined. sub key_exists { my $self = shift; my ($obj, $key) = @_; # This will be a Reference sector my $sector = $self->load_sector( $obj->_base_offset ) or return ''; if ( $sector->staleness != $obj->_staleness ) { return ''; } my $data = $sector->get_data_for({ key_md5 => $self->_apply_digest( $key ), allow_head => 1, }); # exists() returns 1 or '' for true/false. return $data ? 1 : ''; } sub delete_key { my $self = shift; my ($obj, $key) = @_; my $sector = $self->load_sector( $obj->_base_offset ) or return; if ( $sector->staleness != $obj->_staleness ) { return; } return $sector->delete_key({ key_md5 => $self->_apply_digest( $key ), allow_head => 0, }); } sub write_value { my $self = shift; my ($obj, $key, $value) = @_; my $r = Scalar::Util::reftype( $value ) || ''; { last if $r eq ''; last if $r eq 'HASH'; last if $r eq 'ARRAY'; DBM::Deep->_throw_error( "Storage of references of type '$r' is not supported." ); } # This will be a Reference sector my $sector = $self->load_sector( $obj->_base_offset ) or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." ); if ( $sector->staleness != $obj->_staleness ) { DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." ); } my ($class, $type); if ( !defined $value ) { $class = 'DBM::Deep::Sector::File::Null'; } elsif ( ref $value eq 'DBM::Deep::Null' ) { DBM::Deep::_warnif( 'uninitialized', 'Assignment of stale reference' ); $class = 'DBM::Deep::Sector::File::Null'; $value = undef; } elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) { my $tmpvar; if ( $r eq 'ARRAY' ) { $tmpvar = tied @$value; } elsif ( $r eq 'HASH' ) { $tmpvar = tied %$value; } if ( $tmpvar ) { my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); }; unless ( $is_dbm_deep ) { DBM::Deep->_throw_error( "Cannot store something that is tied." ); } unless ( $tmpvar->_engine->storage == $self->storage ) { DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." ); } # First, verify if we're storing the same thing to this spot. If we # are, then this should be a no-op. -EJS, 2008-05-19 my $loc = $sector->get_data_location_for({ key_md5 => $self->_apply_digest( $key ), allow_head => 1, }); if ( defined($loc) && $loc == $tmpvar->_base_offset ) { return 1; } #XXX Can this use $loc? my $value_sector = $self->load_sector( $tmpvar->_base_offset ); $sector->write_data({ key => $key, key_md5 => $self->_apply_digest( $key ), value => $value_sector, }); $value_sector->increment_refcount; return 1; } $class = 'DBM::Deep::Sector::File::Reference'; $type = substr( $r, 0, 1 ); } else { if ( tied($value) ) { DBM::Deep->_throw_error( "Cannot store something that is tied." ); } $class = 'DBM::Deep::Sector::File::Scalar'; } # Create this after loading the reference sector in case something bad # happens. This way, we won't allocate value sector(s) needlessly. my $value_sector = $class->new({ engine => $self, data => $value, type => $type, }); $sector->write_data({ key => $key, key_md5 => $self->_apply_digest( $key ), value => $value_sector, }); $self->_descend( $value, $value_sector ); return 1; } sub setup { my $self = shift; my ($obj) = @_; # We're opening the file. unless ( $obj->_base_offset ) { my $bytes_read = $self->_read_file_header; # Creating a new file unless ( $bytes_read ) { $self->_write_file_header; # 1) Create Array/Hash entry my $initial_reference = DBM::Deep::Sector::File::Reference->new({ engine => $self, type => $obj->_type, }); $obj->{base_offset} = $initial_reference->offset; $obj->{staleness} = $initial_reference->staleness; $self->storage->flush; } # Reading from an existing file else { $obj->{base_offset} = $bytes_read; my $initial_reference = DBM::Deep::Sector::File::Reference->new({ engine => $self, offset => $obj->_base_offset, }); unless ( $initial_reference ) { DBM::Deep->_throw_error("Corrupted file, no master index record"); } unless ($obj->_type eq $initial_reference->type) { DBM::Deep->_throw_error("File type mismatch"); } $obj->{staleness} = $initial_reference->staleness; } } $self->storage->set_inode; return 1; } sub begin_work { my $self = shift; my ($obj) = @_; unless ($self->supports('transactions')) { DBM::Deep->_throw_error( "Cannot begin_work unless transactions are supported" ); } if ( $self->trans_id ) { DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" ); } my @slots = $self->read_txn_slots; my $found; for my $i ( 0 .. $self->num_txns-2 ) { next if $slots[$i]; $slots[$i] = 1; $self->set_trans_id( $i + 1 ); $found = 1; last; } unless ( $found ) { DBM::Deep->_throw_error( "Cannot allocate transaction ID" ); } $self->write_txn_slots( @slots ); if ( !$self->trans_id ) { DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" ); } return; } sub rollback { my $self = shift; my ($obj) = @_; unless ($self->supports('transactions')) { DBM::Deep->_throw_error( "Cannot rollback unless transactions are supported" ); } if ( !$self->trans_id ) { DBM::Deep->_throw_error( "Cannot rollback without an active transaction" ); } # Each entry is the file location for a bucket that has a modification for # this transaction. The entries need to be expunged. foreach my $entry (@{ $self->get_entries } ) { # Remove the entry here my $read_loc = $entry + $self->hash_size + $self->byte_size + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE ); my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size ); $data_loc = unpack( $StP{$self->byte_size}, $data_loc ); $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) ); if ( $data_loc > 1 ) { $self->load_sector( $data_loc )->free; } } $self->clear_entries; my @slots = $self->read_txn_slots; $slots[$self->trans_id-1] = 0; $self->write_txn_slots( @slots ); $self->inc_txn_staleness_counter( $self->trans_id ); $self->set_trans_id( 0 ); return 1; } sub commit { my $self = shift; my ($obj) = @_; unless ($self->supports('transactions')) { DBM::Deep->_throw_error( "Cannot commit unless transactions are supported" ); } if ( !$self->trans_id ) { DBM::Deep->_throw_error( "Cannot commit without an active transaction" ); } foreach my $entry (@{ $self->get_entries } ) { # Overwrite the entry in head with the entry in trans_id my $base = $entry + $self->hash_size + $self->byte_size; my $head_loc = $self->storage->read_at( $base, $self->byte_size ); $head_loc = unpack( $StP{$self->byte_size}, $head_loc ); my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE ); my $trans_loc = $self->storage->read_at( $spot, $self->byte_size, ); $self->storage->print_at( $base, $trans_loc ); $self->storage->print_at( $spot, pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ), ); if ( $head_loc > 1 ) { $self->load_sector( $head_loc )->free; } } $self->clear_entries; my @slots = $self->read_txn_slots; $slots[$self->trans_id-1] = 0; $self->write_txn_slots( @slots ); $self->inc_txn_staleness_counter( $self->trans_id ); $self->set_trans_id( 0 ); return 1; } =head1 INTERNAL METHODS The following methods are internal-use-only to DBM::Deep::Engine::File. =cut =head2 read_txn_slots() This takes no arguments. This will return an array with a 1 or 0 in each slot. Each spot represents one available transaction. If the slot is 1, that transaction is taken. If it is 0, the transaction is available. =cut sub read_txn_slots { my $self = shift; my $bl = $self->txn_bitfield_len; my $num_bits = $bl * 8; return split '', unpack( 'b'.$num_bits, $self->storage->read_at( $self->trans_loc, $bl, ) ); } =head2 write_txn_slots( @slots ) This takes an array of 1's and 0's. This array represents the transaction slots returned by L. In other words, the following is true: @x = read_txn_slots( write_txn_slots( @x ) ); (With the obviously missing object referents added back in.) =cut sub write_txn_slots { my $self = shift; my $num_bits = $self->txn_bitfield_len * 8; $self->storage->print_at( $self->trans_loc, pack( 'b'.$num_bits, join('', @_) ), ); } =head2 get_running_txn_ids() This takes no arguments. This will return an array of taken transaction IDs. This wraps L. =cut sub get_running_txn_ids { my $self = shift; my @transactions = $self->read_txn_slots; my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions; } =head2 get_txn_staleness_counter( $trans_id ) This will return the staleness counter for the given transaction ID. Please see L for more information. =cut sub get_txn_staleness_counter { my $self = shift; my ($trans_id) = @_; # Hardcode staleness of 0 for the HEAD return 0 unless $trans_id; return unpack( $StP{$STALE_SIZE}, $self->storage->read_at( $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1), $STALE_SIZE, ) ); } =head2 inc_txn_staleness_counter( $trans_id ) This will increment the staleness counter for the given transaction ID. Please see L for more information. =cut sub inc_txn_staleness_counter { my $self = shift; my ($trans_id) = @_; # Hardcode staleness of 0 for the HEAD return 0 unless $trans_id; $self->storage->print_at( $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1), pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ), ); } =head2 get_entries() This takes no arguments. This returns a list of all the sectors that have been modified by this transaction. =cut sub get_entries { my $self = shift; return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ]; } =head2 add_entry( $trans_id, $location ) This takes a transaction ID and a file location and marks the sector at that location as having been modified by the transaction identified by $trans_id. This returns nothing. B: Unlike all the other _entries() methods, there are several cases where C<< $trans_id != $self->trans_id >> for this method. =cut sub add_entry { my $self = shift; my ($trans_id, $loc) = @_; $self->{entries}{$trans_id} ||= {}; $self->{entries}{$trans_id}{$loc} = undef; } =head2 reindex_entry( $old_loc, $new_loc ) This takes two locations (old and new, respectively). If a location that has been modified by this transaction is subsequently reindexed due to a bucketlist overflowing, then the entries hash needs to be made aware of this change. This returns nothing. =cut sub reindex_entry { my $self = shift; my ($old_loc, $new_loc) = @_; TRANS: while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) { if ( exists $locs->{$old_loc} ) { delete $locs->{$old_loc}; $locs->{$new_loc} = undef; next TRANS; } } } =head2 clear_entries() This takes no arguments. It will clear the entries list for the running transaction. This returns nothing. =cut sub clear_entries { my $self = shift; delete $self->{entries}{$self->trans_id}; } =head2 _write_file_header() This writes the file header for a new file. This will write the various settings that set how the file is interpreted. =head2 _read_file_header() This reads the file header from an existing file. This will read the various settings that set how the file is interpreted. =cut { my $header_fixed = length( __PACKAGE__->SIG_FILE ) + 1 + 4 + 4; my $this_file_version = 4; my $min_file_version = 3; sub _write_file_header { my $self = shift; my $nt = $self->num_txns; my $bl = $self->txn_bitfield_len; my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size; my $loc = $self->storage->request_space( $header_fixed + $header_var ); $self->storage->print_at( $loc, $self->SIG_FILE, $self->SIG_HEADER, pack('N', $this_file_version), # At this point, we're at 9 bytes pack('N', $header_var), # header size # --- Above is $header_fixed. Below is $header_var pack('C', $self->byte_size), # These shenanigans are to allow a 256 within a C pack('C', $self->max_buckets - 1), pack('C', $self->data_sector_size - 1), pack('C', $nt), pack('C' . $bl, 0 ), # Transaction activeness bitfield pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters pack($StP{$self->byte_size}, 0), # Start of free chain (blist size) pack($StP{$self->byte_size}, 0), # Start of free chain (data size) pack($StP{$self->byte_size}, 0), # Start of free chain (index size) ); #XXX Set these less fragilely $self->set_trans_loc( $header_fixed + 4 ); $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) ); $self->{v} = $this_file_version; return; } sub _read_file_header { my $self = shift; my $buffer = $self->storage->read_at( 0, $header_fixed ); return unless length($buffer); my ($file_signature, $sig_header, $file_version, $size) = unpack( 'A4 A N N', $buffer ); unless ( $file_signature eq $self->SIG_FILE ) { $self->storage->close; DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" ); } unless ( $sig_header eq $self->SIG_HEADER ) { $self->storage->close; DBM::Deep->_throw_error( "Pre-1.00 file version found" ); } if ( $file_version < $min_file_version ) { $self->storage->close; DBM::Deep->_throw_error( "This file version is too old - " . _guess_version($file_version) . " - expected " . _guess_version($min_file_version) . " to " . _guess_version($this_file_version) ); } if ( $file_version > $this_file_version ) { $self->storage->close; DBM::Deep->_throw_error( "This file version is too new - probably " . _guess_version($file_version) . " - expected " . _guess_version($min_file_version) . " to " . _guess_version($this_file_version) ); } $self->{v} = $file_version; my $buffer2 = $self->storage->read_at( undef, $size ); my @values = unpack( 'C C C C', $buffer2 ); if ( @values != 4 || grep { !defined } @values ) { $self->storage->close; DBM::Deep->_throw_error("Corrupted file - bad header"); } if ($values[3] != $self->{num_txns}) { warn "num_txns ($self->{num_txns}) is different from the file ($values[3])\n"; } #XXX Add warnings if values weren't set right @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values; # These shenanigans are to allow a 256 within a C $self->{max_buckets} += 1; $self->{data_sector_size} += 1; my $bl = $self->txn_bitfield_len; my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size; unless ( $size == $header_var ) { $self->storage->close; DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." ); } $self->set_trans_loc( $header_fixed + scalar(@values) ); $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) ); return length($buffer) + length($buffer2); } sub _guess_version { $_[0] == 4 and return 2; $_[0] == 3 and return '1.0003'; $_[0] == 2 and return '1.00'; $_[0] == 1 and return '0.99'; $_[0] == 0 and return '0.91'; return $_[0]-2; } } =head2 _apply_digest( @stuff ) This will apply the digest method (default to Digest::MD5::md5) to the arguments passed in and return the result. =cut sub _apply_digest { my $self = shift; my $victim = shift; utf8::encode $victim if $self->{v} >= 4; return $self->{digest}->($victim); } =head2 _add_free_blist_sector( $offset, $size ) =head2 _add_free_data_sector( $offset, $size ) =head2 _add_free_index_sector( $offset, $size ) These methods are all wrappers around _add_free_sector(), providing the proper chain offset ($multiple) for the sector type. =cut sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) } sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) } sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) } =head2 _add_free_sector( $multiple, $offset, $size ) _add_free_sector() takes the offset into the chains location, the offset of the sector, and the size of that sector. It will mark the sector as a free sector and put it into the list of sectors that are free of this type for use later. This returns nothing. B: $size is unused? =cut sub _add_free_sector { my $self = shift; my ($multiple, $offset, $size) = @_; my $chains_offset = $multiple * $self->byte_size; my $storage = $self->storage; # Increment staleness. # XXX Can this increment+modulo be done by "&= 0x1" ? my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + $self->SIG_SIZE, $STALE_SIZE ) ); $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) ); $storage->print_at( $offset + $self->SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) ); my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); $storage->print_at( $self->chains_loc + $chains_offset, pack( $StP{$self->byte_size}, $offset ), ); # Record the old head in the new sector after the signature and staleness counter $storage->print_at( $offset + $self->SIG_SIZE + $STALE_SIZE, $old_head ); } =head2 _request_blist_sector( $size ) =head2 _request_data_sector( $size ) =head2 _request_index_sector( $size ) These methods are all wrappers around _request_sector(), providing the proper chain offset ($multiple) for the sector type. =cut sub _request_blist_sector { shift->_request_sector( 0, @_ ) } sub _request_data_sector { shift->_request_sector( 1, @_ ) } sub _request_index_sector { shift->_request_sector( 2, @_ ) } =head2 _request_sector( $multiple $size ) This takes the offset into the chains location and the size of that sector. This returns the object with the sector. If there is an available free sector of that type, then it will be reused. If there isn't one, then a new one will be allocated. =cut sub _request_sector { my $self = shift; my ($multiple, $size) = @_; my $chains_offset = $multiple * $self->byte_size; my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); my $loc = unpack( $StP{$self->byte_size}, $old_head ); # We don't have any free sectors of the right size, so allocate a new one. unless ( $loc ) { my $offset = $self->storage->request_space( $size ); # Zero out the new sector. This also guarantees correct increases # in the filesize. $self->storage->print_at( $offset, chr(0) x $size ); return $offset; } # Read the new head after the signature and the staleness counter my $new_head = $self->storage->read_at( $loc + $self->SIG_SIZE + $STALE_SIZE, $self->byte_size ); $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head ); $self->storage->print_at( $loc + $self->SIG_SIZE + $STALE_SIZE, pack( $StP{$self->byte_size}, 0 ), ); return $loc; } =head2 ACCESSORS The following are readonly attributes. =over 4 =item * byte_size =item * hash_size =item * hash_chars =item * num_txns =item * max_buckets =item * blank_md5 =item * data_sector_size =item * txn_bitfield_len =back =cut sub byte_size { $_[0]{byte_size} } sub hash_size { $_[0]{hash_size} } sub hash_chars { $_[0]{hash_chars} } sub num_txns { $_[0]{num_txns} } sub max_buckets { $_[0]{max_buckets} } sub blank_md5 { chr(0) x $_[0]->hash_size } sub data_sector_size { $_[0]{data_sector_size} } # This is a calculated value sub txn_bitfield_len { my $self = shift; unless ( exists $self->{txn_bitfield_len} ) { my $temp = ($self->num_txns) / 8; if ( $temp > int( $temp ) ) { $temp = int( $temp ) + 1; } $self->{txn_bitfield_len} = $temp; } return $self->{txn_bitfield_len}; } =pod The following are read/write attributes. =over 4 =item * trans_id / set_trans_id( $new_id ) =item * trans_loc / set_trans_loc( $new_loc ) =item * chains_loc / set_chains_loc( $new_loc ) =back =cut sub trans_id { $_[0]{trans_id} } sub set_trans_id { $_[0]{trans_id} = $_[1] } sub trans_loc { $_[0]{trans_loc} } sub set_trans_loc { $_[0]{trans_loc} = $_[1] } sub chains_loc { $_[0]{chains_loc} } sub set_chains_loc { $_[0]{chains_loc} = $_[1] } sub supports { my $self = shift; my ($feature) = @_; if ( $feature eq 'transactions' ) { return $self->num_txns > 1; } return 1 if $feature eq 'singletons'; return 1 if $feature eq 'unicode'; return; } sub db_version { return $_[0]{v} == 3 ? '1.0003' : 2; } sub clear { my $self = shift; my $obj = shift; my $sector = $self->load_sector( $obj->_base_offset ) or return; return unless $sector->staleness == $obj->_staleness; $sector->clear; return; } =head2 _dump_file() This method takes no arguments. It's used to print out a textual representation of the DBM::Deep DB file. It assumes the file is not-corrupted. =cut sub _dump_file { my $self = shift; # Read the header my $spot = $self->_read_file_header(); my %types = ( 0 => 'B', 1 => 'D', 2 => 'I', ); my %sizes = ( 'D' => $self->data_sector_size, 'B' => DBM::Deep::Sector::File::BucketList->new({engine=>$self,offset=>1})->size, 'I' => DBM::Deep::Sector::File::Index->new({engine=>$self,offset=>1})->size, ); my $return = ""; # Header values $return .= "NumTxns: " . $self->num_txns . $/; # Read the free sector chains my %sectors; foreach my $multiple ( 0 .. 2 ) { $return .= "Chains($types{$multiple}):"; my $old_loc = $self->chains_loc + $multiple * $self->byte_size; while ( 1 ) { my $loc = unpack( $StP{$self->byte_size}, $self->storage->read_at( $old_loc, $self->byte_size ), ); # We're now out of free sectors of this kind. unless ( $loc ) { last; } $sectors{ $types{$multiple} }{ $loc } = undef; $old_loc = $loc + $self->SIG_SIZE + $STALE_SIZE; $return .= " $loc"; } $return .= $/; } SECTOR: while ( $spot < $self->storage->{end} ) { # Read each sector in order. my $sector = $self->load_sector( $spot ); if ( !$sector ) { # Find it in the free-sectors that were found already foreach my $type ( keys %sectors ) { if ( exists $sectors{$type}{$spot} ) { my $size = $sizes{$type}; $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size; $spot += $size; next SECTOR; } } die "********\n$return\nDidn't find free sector for $spot in chains\n********\n"; } else { $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size; if ( $sector->type =~ /^[DU]\z/ ) { $return .= ' ' . $sector->data; } elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) { $return .= ' REF: ' . $sector->get_refcount; } elsif ( $sector->type eq 'B' ) { foreach my $bucket ( $sector->chopped_up ) { $return .= "\n "; $return .= sprintf "%08d", unpack($StP{$self->byte_size}, substr( $bucket->[-1], $self->hash_size, $self->byte_size), ); my $l = unpack( $StP{$self->byte_size}, substr( $bucket->[-1], $self->hash_size + $self->byte_size, $self->byte_size, ), ); $return .= sprintf " %08d", $l; foreach my $txn ( 0 .. $self->num_txns - 2 ) { my $l = unpack( $StP{$self->byte_size}, substr( $bucket->[-1], $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE), $self->byte_size, ), ); $return .= sprintf " %08d", $l; } } } $return .= $/; $spot += $sector->size; } } return $return; } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Engine/DBI.pm000444001750001750 2062512641624315 16157 0ustar00robrob000000000000package DBM::Deep::Engine::DBI; use 5.008_004; use strict; use warnings FATAL => 'all'; no warnings 'recursion'; use base 'DBM::Deep::Engine'; use DBM::Deep::Sector::DBI (); use DBM::Deep::Storage::DBI (); sub sector_type { 'DBM::Deep::Sector::DBI' } sub iterator_class { 'DBM::Deep::Iterator::DBI' } sub new { my $class = shift; my ($args) = @_; $args->{storage} = DBM::Deep::Storage::DBI->new( $args ) unless exists $args->{storage}; my $self = bless { storage => undef, external_refs => undef, }, $class; # Grab the parameters we want to use foreach my $param ( keys %$self ) { next unless exists $args->{$param}; $self->{$param} = $args->{$param}; } return $self; } sub setup { my $self = shift; my ($obj) = @_; # Default the id to 1. This means that we will be creating a row if there # isn't one. The assumption is that the row_id=1 cannot never be deleted. I # don't know if this is a good assumption. $obj->{base_offset} ||= 1; my ($rows) = $self->storage->read_from( refs => $obj->_base_offset, qw( ref_type ), ); # We don't have a row yet. unless ( @$rows ) { $self->storage->write_to( refs => $obj->_base_offset, ref_type => $obj->_type, ); } my $sector = DBM::Deep::Sector::DBI::Reference->new({ engine => $self, offset => $obj->_base_offset, }); } sub read_value { my $self = shift; my ($obj, $key) = @_; my $sector = $self->load_sector( $obj->_base_offset, 'refs' ) or return; # if ( $sector->staleness != $obj->_staleness ) { # return; # } # my $key_md5 = $self->_apply_digest( $key ); my $value_sector = $sector->get_data_for({ key => $key, # key_md5 => $key_md5, allow_head => 1, }); unless ( $value_sector ) { return undef } return $value_sector->data; } sub get_classname { my $self = shift; my ($obj) = @_; my $sector = $self->load_sector( $obj->_base_offset, 'refs' ) or return; return $sector->get_classname; } sub make_reference { my $self = shift; my ($obj, $old_key, $new_key) = @_; my $sector = $self->load_sector( $obj->_base_offset, 'refs' ) or return; # if ( $sector->staleness != $obj->_staleness ) { # return; # } my $value_sector = $sector->get_data_for({ key => $old_key, allow_head => 1, }); unless ( $value_sector ) { $value_sector = DBM::Deep::Sector::DBI::Scalar->new({ engine => $self, data => undef, }); $sector->write_data({ key => $old_key, value => $value_sector, }); } if ( $value_sector->isa( 'DBM::Deep::Sector::DBI::Reference' ) ) { $sector->write_data({ key => $new_key, value => $value_sector, }); $value_sector->increment_refcount; } else { $sector->write_data({ key => $new_key, value => $value_sector->clone, }); } return; } # exists returns '', not undefined. sub key_exists { my $self = shift; my ($obj, $key) = @_; my $sector = $self->load_sector( $obj->_base_offset, 'refs' ) or return ''; # if ( $sector->staleness != $obj->_staleness ) { # return ''; # } my $data = $sector->get_data_for({ # key_md5 => $self->_apply_digest( $key ), key => $key, allow_head => 1, }); # exists() returns 1 or '' for true/false. return $data ? 1 : ''; } sub delete_key { my $self = shift; my ($obj, $key) = @_; my $sector = $self->load_sector( $obj->_base_offset, 'refs' ) or return ''; # if ( $sector->staleness != $obj->_staleness ) { # return ''; # } return $sector->delete_key({ # key_md5 => $self->_apply_digest( $key ), key => $key, allow_head => 0, }); } sub write_value { my $self = shift; my ($obj, $key, $value) = @_; my $r = Scalar::Util::reftype( $value ) || ''; { last if $r eq ''; last if $r eq 'HASH'; last if $r eq 'ARRAY'; DBM::Deep->_throw_error( "Storage of references of type '$r' is not supported." ); } # Load the reference entry # Determine if the row was deleted under us # my $sector = $self->load_sector( $obj->_base_offset, 'refs' ) or die "Cannot load sector at '@{[$obj->_base_offset]}'\n";; my ($type, $class); if ( $r eq 'ARRAY' || $r eq 'HASH' and ref $value ne 'DBM::Deep::Null' ) { my $tmpvar; if ( $r eq 'ARRAY' ) { $tmpvar = tied @$value; } elsif ( $r eq 'HASH' ) { $tmpvar = tied %$value; } if ( $tmpvar ) { my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); }; unless ( $is_dbm_deep ) { DBM::Deep->_throw_error( "Cannot store something that is tied." ); } unless ( $tmpvar->_engine->storage == $self->storage ) { DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." ); } # Load $tmpvar's sector # First, verify if we're storing the same thing to this spot. If we # are, then this should be a no-op. -EJS, 2008-05-19 # See whether or not we are storing ourselves to ourself. # Write the sector as data in this reference (keyed by $key) my $value_sector = $self->load_sector( $tmpvar->_base_offset, 'refs' ); $sector->write_data({ key => $key, # key_md5 => $self->_apply_digest( $key ), value => $value_sector, }); $value_sector->increment_refcount; return 1; } $type = substr( $r, 0, 1 ); $class = 'DBM::Deep::Sector::DBI::Reference'; } else { if ( tied($value) ) { DBM::Deep->_throw_error( "Cannot store something that is tied." ); } if ( ref $value eq 'DBM::Deep::Null' ) { DBM::Deep::_warnif( 'uninitialized', 'Assignment of stale reference' ); $value = undef; } $class = 'DBM::Deep::Sector::DBI::Scalar'; $type = 'S'; } # Create this after loading the reference sector in case something bad # happens. This way, we won't allocate value sector(s) needlessly. my $value_sector = $class->new({ engine => $self, data => $value, type => $type, }); $sector->write_data({ key => $key, # key_md5 => $self->_apply_digest( $key ), value => $value_sector, }); $self->_descend( $value, $value_sector ); return 1; } #sub begin_work { # my $self = shift; # die "Transactions are not supported by this engine" # unless $self->supports('transactions'); # # if ( $self->in_txn ) { # DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" ); # } # # $self->storage->begin_work; # # $self->in_txn( 1 ); # # return 1; #} # #sub rollback { # my $self = shift; # die "Transactions are not supported by this engine" # unless $self->supports('transactions'); # # if ( !$self->in_txn ) { # DBM::Deep->_throw_error( "Cannot rollback without an active transaction" ); # } # # $self->storage->rollback; # # $self->in_txn( 0 ); # # return 1; #} # #sub commit { # my $self = shift; # die "Transactions are not supported by this engine" # unless $self->supports('transactions'); # # if ( !$self->in_txn ) { # DBM::Deep->_throw_error( "Cannot commit without an active transaction" ); # } # # $self->storage->commit; # # $self->in_txn( 0 ); # # return 1; #} # #sub in_txn { # my $self = shift; # $self->{in_txn} = shift if @_; # $self->{in_txn}; #} sub supports { my $self = shift; my ($feature) = @_; return if $feature eq 'transactions'; return 1 if $feature eq 'singletons'; return; } sub db_version { return '1.0020' } sub clear { my $self = shift; my $obj = shift; my $sector = $self->load_sector( $obj->_base_offset, 'refs' ) or return; $sector->clear; return; } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Sector000755001750001750 012641624315 15073 5ustar00robrob000000000000DBM-Deep-2.0013/lib/DBM/Deep/Sector/File.pm000444001750001750 512112641624315 16444 0ustar00robrob000000000000package DBM::Deep::Sector::File; use 5.008_004; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Sector ); use DBM::Deep::Sector::File::BucketList (); use DBM::Deep::Sector::File::Index (); use DBM::Deep::Sector::File::Null (); use DBM::Deep::Sector::File::Reference (); use DBM::Deep::Sector::File::Scalar (); my $STALE_SIZE = 2; sub base_size { my $self = shift; return $self->engine->SIG_SIZE + $STALE_SIZE; } sub free_meth { die "free_meth must be implemented in a child class" } sub free { my $self = shift; my $e = $self->engine; $e->storage->print_at( $self->offset, $e->SIG_FREE ); # Skip staleness counter $e->storage->print_at( $self->offset + $self->base_size, chr(0) x ($self->size - $self->base_size), ); my $free_meth = $self->free_meth; $e->$free_meth( $self->offset, $self->size ); return; } #=head2 load( $offset ) # #This will instantiate and return the sector object that represents the data #found at $offset. # #=cut sub load { my $self = shift; my ($engine, $offset) = @_; # Add a catch for offset of 0 or 1 return if !$offset || $offset <= 1; my $type = $engine->storage->read_at( $offset, 1 ); return if $type eq chr(0); if ( $type eq $engine->SIG_ARRAY || $type eq $engine->SIG_HASH ) { return DBM::Deep::Sector::File::Reference->new({ engine => $engine, type => $type, offset => $offset, }); } # XXX Don't we need key_md5 here? elsif ( $type eq $engine->SIG_BLIST ) { return DBM::Deep::Sector::File::BucketList->new({ engine => $engine, type => $type, offset => $offset, }); } elsif ( $type eq $engine->SIG_INDEX ) { return DBM::Deep::Sector::File::Index->new({ engine => $engine, type => $type, offset => $offset, }); } elsif ( $type eq $engine->SIG_NULL ) { return DBM::Deep::Sector::File::Null->new({ engine => $engine, type => $type, offset => $offset, }); } elsif ( $type eq $engine->SIG_DATA || $type eq $engine->SIG_UNIDATA ) { return DBM::Deep::Sector::File::Scalar->new({ engine => $engine, type => $type, offset => $offset, }); } # This was deleted from under us, so just return and let the caller figure it out. elsif ( $type eq $engine->SIG_FREE ) { return; } DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" ); } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Sector/DBI.pm000444001750001750 210512641624315 16162 0ustar00robrob000000000000package DBM::Deep::Sector::DBI; use 5.008_004; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Sector ); use DBM::Deep::Sector::DBI::Reference (); use DBM::Deep::Sector::DBI::Scalar (); sub free { my $self = shift; $self->engine->storage->delete_from( $self->table, $self->offset, ); } sub reload { my $self = shift; $self->_init; } sub load { my $self = shift; my ($engine, $offset, $type) = @_; if ( !defined $type || $type eq 'refs' ) { return DBM::Deep::Sector::DBI::Reference->new({ engine => $engine, offset => $offset, }); } elsif ( $type eq 'datas' ) { my $sector = DBM::Deep::Sector::DBI::Scalar->new({ engine => $engine, offset => $offset, }); if ( $sector->{data_type} eq 'R' ) { return $self->load( $engine, $sector->{value}, 'refs', ); } return $sector; } DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" ); } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Sector/File000755001750001750 012641624315 15752 5ustar00robrob000000000000DBM-Deep-2.0013/lib/DBM/Deep/Sector/File/Reference.pm000444001750001750 3747212641624315 20400 0ustar00robrob000000000000package DBM::Deep::Sector::File::Reference; use 5.008_004; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Sector::File::Data ); use Scalar::Util; my $STALE_SIZE = 2; # Please refer to the pack() documentation for further information my %StP = ( 1 => 'C', # Unsigned char value (no order needed as it's just one byte) 2 => 'n', # Unsigned short in "network" (big-endian) order 4 => 'N', # Unsigned long in "network" (big-endian) order 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) ); sub _init { my $self = shift; my $e = $self->engine; unless ( $self->offset ) { my $classname = Scalar::Util::blessed( delete $self->{data} ); my $leftover = $self->size - $self->base_size - 3 * $e->byte_size; my $class_offset = 0; if ( defined $classname ) { my $class_sector = DBM::Deep::Sector::File::Scalar->new({ engine => $e, data => $classname, }); $class_offset = $class_sector->offset; } $self->{offset} = $e->_request_data_sector( $self->size ); $e->storage->print_at( $self->offset, $self->type ); # Sector type # Skip staleness counter $e->storage->print_at( $self->offset + $self->base_size, pack( $StP{$e->byte_size}, 0 ), # Index/BList loc pack( $StP{$e->byte_size}, $class_offset ), # Classname loc pack( $StP{$e->byte_size}, 1 ), # Initial refcount chr(0) x $leftover, # Zero-fill the rest ); } else { $self->{type} = $e->storage->read_at( $self->offset, 1 ); } $self->{staleness} = unpack( $StP{$STALE_SIZE}, $e->storage->read_at( $self->offset + $e->SIG_SIZE, $STALE_SIZE ), ); return; } sub get_data_location_for { my $self = shift; my ($args) = @_; # Assume that the head is not allowed unless otherwise specified. $args->{allow_head} = 0 unless exists $args->{allow_head}; # Assume we don't create a new blist location unless otherwise specified. $args->{create} = 0 unless exists $args->{create}; my $blist = $self->get_bucket_list({ key_md5 => $args->{key_md5}, key => $args->{key}, create => $args->{create}, }); return unless $blist && $blist->{found}; # At this point, $blist knows where the md5 is. What it -doesn't- know yet # is whether or not this transaction has this key. That's part of the next # function call. my $location = $blist->get_data_location_for({ allow_head => $args->{allow_head}, }) or return; return $location; } sub get_data_for { my $self = shift; my ($args) = @_; my $location = $self->get_data_location_for( $args ) or return; return $self->engine->load_sector( $location ); } sub write_data { my $self = shift; my ($args) = @_; my $blist = $self->get_bucket_list({ key_md5 => $args->{key_md5}, key => $args->{key}, create => 1, }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" ); # Handle any transactional bookkeeping. if ( $self->engine->trans_id ) { if ( ! $blist->has_md5 ) { $blist->mark_deleted({ trans_id => 0, }); } } else { my @trans_ids = $self->engine->get_running_txn_ids; if ( $blist->has_md5 ) { if ( @trans_ids ) { my $old_value = $blist->get_data_for; foreach my $other_trans_id ( @trans_ids ) { next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0, }); $blist->write_md5({ trans_id => $other_trans_id, key => $args->{key}, key_md5 => $args->{key_md5}, value => $old_value->clone, }); } } } else { if ( @trans_ids ) { foreach my $other_trans_id ( @trans_ids ) { #XXX This doesn't seem to possible to ever happen . . . next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); $blist->mark_deleted({ trans_id => $other_trans_id, }); } } } } #XXX Is this safe to do transactionally? # Free the place we're about to write to. if ( $blist->get_data_location_for({ allow_head => 0 }) ) { $blist->get_data_for({ allow_head => 0 })->free; } $blist->write_md5({ key => $args->{key}, key_md5 => $args->{key_md5}, value => $args->{value}, }); } sub delete_key { my $self = shift; my ($args) = @_; # This can return nothing if we are deleting an entry in a hashref that was # auto-vivified as part of the delete process. For example: # my $x = {}; # delete $x->{foo}{bar}; my $blist = $self->get_bucket_list({ key_md5 => $args->{key_md5}, }) or return; # Save the location so that we can free the data my $location = $blist->get_data_location_for({ allow_head => 0, }); my $old_value = $location && $self->engine->load_sector( $location ); my @trans_ids = $self->engine->get_running_txn_ids; # If we're the HEAD and there are running txns, then we need to clone this # value to the other transactions to preserve Isolation. if ( $self->engine->trans_id == 0 ) { if ( @trans_ids ) { foreach my $other_trans_id ( @trans_ids ) { next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); $blist->write_md5({ trans_id => $other_trans_id, key => $args->{key}, key_md5 => $args->{key_md5}, value => $old_value->clone, }); } } } my $data; if ( @trans_ids ) { $blist->mark_deleted( $args ); if ( $old_value ) { #XXX Is this export => 1 actually doing anything? $data = $old_value->data({ export => 1 }); $old_value->free; } } else { $data = $blist->delete_md5( $args ); } return $data; } sub write_blist_loc { my $self = shift; my ($loc) = @_; my $engine = $self->engine; $engine->storage->print_at( $self->offset + $self->base_size, pack( $StP{$engine->byte_size}, $loc ), ); } sub get_blist_loc { my $self = shift; my $e = $self->engine; my $blist_loc = $e->storage->read_at( $self->offset + $self->base_size, $e->byte_size ); return unpack( $StP{$e->byte_size}, $blist_loc ); } sub get_bucket_list { my $self = shift; my ($args) = @_; $args ||= {}; # XXX Add in check here for recycling? my $engine = $self->engine; my $blist_loc = $self->get_blist_loc; # There's no index or blist yet unless ( $blist_loc ) { return unless $args->{create}; my $blist = DBM::Deep::Sector::File::BucketList->new({ engine => $engine, key_md5 => $args->{key_md5}, }); $self->write_blist_loc( $blist->offset ); # $engine->storage->print_at( $self->offset + $self->base_size, # pack( $StP{$engine->byte_size}, $blist->offset ), # ); return $blist; } my $sector = $engine->load_sector( $blist_loc ) or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" ); my $i = 0; my $last_sector = undef; while ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) { $blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) ); $last_sector = $sector; if ( $blist_loc ) { $sector = $engine->load_sector( $blist_loc ) or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" ); } else { $sector = undef; last; } } # This means we went through the Index sector(s) and found an empty slot unless ( $sector ) { return unless $args->{create}; DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" ) unless $last_sector; my $blist = DBM::Deep::Sector::File::BucketList->new({ engine => $engine, key_md5 => $args->{key_md5}, }); $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset ); return $blist; } $sector->find_md5( $args->{key_md5} ); # See whether or not we need to reindex the bucketlist # Yes, the double-braces are there for a reason. if() doesn't create a # redo-able block, so we have to create a bare block within the if() for # redo-purposes. # Patch and idea submitted by sprout@cpan.org. -RobK, 2008-01-09 if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {{ my $redo; my $new_index = DBM::Deep::Sector::File::Index->new({ engine => $engine, }); my %blist_cache; #XXX q.v. the comments for this function. foreach my $entry ( $sector->chopped_up ) { my ($spot, $md5) = @{$entry}; my $idx = ord( substr( $md5, $i, 1 ) ); # XXX This is inefficient my $blist = $blist_cache{$idx} ||= DBM::Deep::Sector::File::BucketList->new({ engine => $engine, }); $new_index->set_entry( $idx => $blist->offset ); my $new_spot = $blist->write_at_next_open( $md5 ); $engine->reindex_entry( $spot => $new_spot ); } # Handle the new item separately. { my $idx = ord( substr( $args->{key_md5}, $i, 1 ) ); # If all the previous blist's items have been thrown into one # blist and the new item belongs in there too, we need # another index. if ( keys %blist_cache == 1 and each %blist_cache == $idx ) { ++$i, ++$redo; } else { my $blist = $blist_cache{$idx} ||= DBM::Deep::Sector::File::BucketList->new({ engine => $engine, }); $new_index->set_entry( $idx => $blist->offset ); #XXX THIS IS HACKY! $blist->find_md5( $args->{key_md5} ); $blist->write_md5({ key => $args->{key}, key_md5 => $args->{key_md5}, value => DBM::Deep::Sector::File::Null->new({ engine => $engine, data => undef, }), }); } } if ( $last_sector ) { $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ), $new_index->offset, ); } else { $engine->storage->print_at( $self->offset + $self->base_size, pack( $StP{$engine->byte_size}, $new_index->offset ), ); } $sector->wipe; $sector->free; if ( $redo ) { (undef, $sector) = %blist_cache; $last_sector = $new_index; redo; } $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) }; $sector->find_md5( $args->{key_md5} ); }} return $sector; } sub get_class_offset { my $self = shift; my $e = $self->engine; return unpack( $StP{$e->byte_size}, $e->storage->read_at( $self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size, ), ); } sub get_classname { my $self = shift; my $class_offset = $self->get_class_offset; return unless $class_offset; return $self->engine->load_sector( $class_offset )->data; } # Look to hoist this method into a ::Reference trait sub data { my $self = shift; my ($args) = @_; $args ||= {}; my $engine = $self->engine; my $cache_entry = $engine->cache->{ $self->offset } ||= {}; my $trans_id = $engine->trans_id; my $obj; if ( !defined $$cache_entry{ $trans_id } ) { $obj = DBM::Deep->new({ type => $self->type, base_offset => $self->offset, staleness => $self->staleness, storage => $engine->storage, engine => $engine, }); $$cache_entry{ $trans_id } = $obj; Scalar::Util::weaken($$cache_entry{ $trans_id }); } else { $obj = $$cache_entry{ $trans_id }; } # We're not exporting, so just return. unless ( $args->{export} ) { if ( $engine->storage->{autobless} ) { my $classname = $self->get_classname; if ( defined $classname ) { bless $obj, $classname; } } return $obj; } # We shouldn't export if this is still referred to. if ( $self->get_refcount > 1 ) { return $obj; } return $obj->export; } sub free { my $self = shift; # We're not ready to be removed yet. return if $self->decrement_refcount > 0; my $e = $self->engine; # Rebless the object into DBM::Deep::Null. # In external_refs mode, this will already have been removed from # the cache, so we can skip this. if(!$e->{external_refs}) { # eval { %{ $e->cache->{ $self->offset }{ $e->trans_id } } = (); }; # eval { @{ $e->cache->{ $self->offset }{ $e->trans_id } } = (); }; my $cache = $e->cache; my $off = $self->offset; if( exists $cache->{ $off } and exists $cache->{ $off }{ my $trans_id = $e->trans_id } ) { bless $cache->{ $off }{ $trans_id }, 'DBM::Deep::Null' if defined $cache->{ $off }{ $trans_id }; delete $cache->{ $off }{ $trans_id }; } } my $blist_loc = $self->get_blist_loc; $e->load_sector( $blist_loc )->free if $blist_loc; my $class_loc = $self->get_class_offset; $e->load_sector( $class_loc )->free if $class_loc; $self->SUPER::free(); } sub increment_refcount { my $self = shift; my $refcount = $self->get_refcount; $refcount++; $self->write_refcount( $refcount ); return $refcount; } sub decrement_refcount { my $self = shift; my $refcount = $self->get_refcount; $refcount--; $self->write_refcount( $refcount ); return $refcount; } sub get_refcount { my $self = shift; my $e = $self->engine; return unpack( $StP{$e->byte_size}, $e->storage->read_at( $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size, ), ); } sub write_refcount { my $self = shift; my ($num) = @_; my $e = $self->engine; $e->storage->print_at( $self->offset + $self->base_size + 2 * $e->byte_size, pack( $StP{$e->byte_size}, $num ), ); } sub clear { my $self = shift; my $blist_loc = $self->get_blist_loc or return; my $engine = $self->engine; # This won't work with autoblessed items. if ($engine->get_running_txn_ids) { # ~~~ Temporary; the code below this block needs to be modified to # take transactions into account. $self->data->_get_self->_clear; return; } my $sector = $engine->load_sector( $blist_loc ) or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in clear()" ); # Set blist offset to 0 $engine->storage->print_at( $self->offset + $self->base_size, pack( $StP{$engine->byte_size}, 0 ), ); # Free the blist $sector->free; return; } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Sector/File/Scalar.pm000444001750001750 730212641624315 17654 0ustar00robrob000000000000package DBM::Deep::Sector::File::Scalar; use 5.008_004; use strict; use warnings FATAL => 'all'; no warnings 'recursion'; use base qw( DBM::Deep::Sector::File::Data ); my $STALE_SIZE = 2; # Please refer to the pack() documentation for further information my %StP = ( 1 => 'C', # Unsigned char value (no order needed as it's just one byte) 2 => 'n', # Unsigned short in "network" (big-endian) order 4 => 'N', # Unsigned long in "network" (big-endian) order 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) ); sub free { my $self = shift; my $chain_loc = $self->chain_loc; $self->SUPER::free(); if ( $chain_loc ) { $self->engine->load_sector( $chain_loc )->free; } return; } sub _init { my $self = shift; my $engine = $self->engine; unless ( $self->offset ) { my $data_section = $self->size - $self->base_size - $engine->byte_size - 1; $self->{offset} = $engine->_request_data_sector( $self->size ); my $data = delete $self->{data}; my $utf8 = do { no warnings 'utf8'; $data !~ /^[\0-\xff]*\z/ }; if($utf8){ if($engine->{v} < 4) { DBM::Deep->_throw_error( "This database format version is too old for Unicode" ); } utf8::encode $data; $self->{type} = $engine->SIG_UNIDATA; } else { $self->{type} = $engine->SIG_DATA; } my $dlen = length $data; my $continue = 1; my $curr_offset = $self->offset; while ( $continue ) { my $next_offset = 0; my ($leftover, $this_len, $chunk); if ( $dlen > $data_section ) { $leftover = 0; $this_len = $data_section; $chunk = substr( $data, 0, $this_len ); $dlen -= $data_section; $next_offset = $engine->_request_data_sector( $self->size ); $data = substr( $data, $this_len ); } else { $leftover = $data_section - $dlen; $this_len = $dlen; $chunk = $data; $continue = 0; } $engine->storage->print_at( $curr_offset, $self->type ); # Sector type # Skip staleness $engine->storage->print_at( $curr_offset + $self->base_size, pack( $StP{$engine->byte_size}, $next_offset ), # Chain loc pack( $StP{1}, $this_len ), # Data length $chunk, # Data to be stored in this sector chr(0) x $leftover, # Zero-fill the rest ); $curr_offset = $next_offset; } return; } } sub data_length { my $self = shift; my $buffer = $self->engine->storage->read_at( $self->offset + $self->base_size + $self->engine->byte_size, 1 ); return unpack( $StP{1}, $buffer ); } sub chain_loc { my $self = shift; return unpack( $StP{$self->engine->byte_size}, $self->engine->storage->read_at( $self->offset + $self->base_size, $self->engine->byte_size, ), ); } sub data { my $self = shift; my $engine = $self->engine; my $data; while ( 1 ) { my $chain_loc = $self->chain_loc; $data .= $engine->storage->read_at( $self->offset + $self->base_size + $engine->byte_size + 1, $self->data_length, ); last unless $chain_loc; $self = $engine->load_sector( $chain_loc ); } utf8::decode $data if $self->type eq $engine->SIG_UNIDATA; return $data; } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Sector/File/Data.pm000444001750001750 41012641624315 17271 0ustar00robrob000000000000package DBM::Deep::Sector::File::Data; use 5.008_004; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Sector::File ); # This is in bytes sub size { $_[0]{engine}->data_sector_size } sub free_meth { return '_add_free_data_sector' } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Sector/File/BucketList.pm000444001750001750 2455312641624315 20547 0ustar00robrob000000000000package DBM::Deep::Sector::File::BucketList; use 5.008_004; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Sector::File ); my $STALE_SIZE = 2; # Please refer to the pack() documentation for further information my %StP = ( 1 => 'C', # Unsigned char value (no order needed as it's just one byte) 2 => 'n', # Unsigned short in "network" (big-endian) order 4 => 'N', # Unsigned long in "network" (big-endian) order 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) ); sub _init { my $self = shift; my $engine = $self->engine; unless ( $self->offset ) { my $leftover = $self->size - $self->base_size; $self->{offset} = $engine->_request_blist_sector( $self->size ); $engine->storage->print_at( $self->offset, $engine->SIG_BLIST ); # Sector type # Skip staleness counter $engine->storage->print_at( $self->offset + $self->base_size, chr(0) x $leftover, # Zero-fill the data ); } if ( $self->{key_md5} ) { $self->find_md5; } return $self; } sub wipe { my $self = shift; $self->engine->storage->print_at( $self->offset + $self->base_size, chr(0) x ($self->size - $self->base_size), # Zero-fill the data ); } sub size { my $self = shift; unless ( $self->{size} ) { my $e = $self->engine; # Base + numbuckets * bucketsize $self->{size} = $self->base_size + $e->max_buckets * $self->bucket_size; } return $self->{size}; } sub free_meth { '_add_free_blist_sector' } sub free { my $self = shift; my $e = $self->engine; foreach my $bucket ( $self->chopped_up ) { my $rest = $bucket->[-1]; # Delete the keysector my $l = unpack( $StP{$e->byte_size}, substr( $rest, $e->hash_size, $e->byte_size ) ); my $s = $e->load_sector( $l ); $s->free if $s; # Delete the HEAD sector $l = unpack( $StP{$e->byte_size}, substr( $rest, $e->hash_size + $e->byte_size, $e->byte_size, ), ); $s = $e->load_sector( $l ); $s->free if $s; foreach my $txn ( 0 .. $e->num_txns - 2 ) { my $l = unpack( $StP{$e->byte_size}, substr( $rest, $e->hash_size + 2 * $e->byte_size + $txn * ($e->byte_size + $STALE_SIZE), $e->byte_size, ), ); my $s = $e->load_sector( $l ); $s->free if $s; } } $self->SUPER::free(); } sub bucket_size { my $self = shift; unless ( $self->{bucket_size} ) { my $e = $self->engine; # Key + head (location) + transactions (location + staleness-counter) my $location_size = $e->byte_size + $e->byte_size + ($e->num_txns - 1) * ($e->byte_size + $STALE_SIZE); $self->{bucket_size} = $e->hash_size + $location_size; } return $self->{bucket_size}; } # XXX This is such a poor hack. I need to rethink this code. sub chopped_up { my $self = shift; my $e = $self->engine; my @buckets; foreach my $idx ( 0 .. $e->max_buckets - 1 ) { my $spot = $self->offset + $self->base_size + $idx * $self->bucket_size; my $md5 = $e->storage->read_at( $spot, $e->hash_size ); #XXX If we're chopping, why would we ever have the blank_md5? last if $md5 eq $e->blank_md5; my $rest = $e->storage->read_at( undef, $self->bucket_size - $e->hash_size ); push @buckets, [ $spot, $md5 . $rest ]; } return @buckets; } sub write_at_next_open { my $self = shift; my ($entry) = @_; #XXX This is such a hack! $self->{_next_open} = 0 unless exists $self->{_next_open}; my $spot = $self->offset + $self->base_size + $self->{_next_open}++ * $self->bucket_size; $self->engine->storage->print_at( $spot, $entry ); return $spot; } sub has_md5 { my $self = shift; unless ( exists $self->{found} ) { $self->find_md5; } return $self->{found}; } sub find_md5 { my $self = shift; $self->{found} = undef; $self->{idx} = -1; if ( @_ ) { $self->{key_md5} = shift; } # If we don't have an MD5, then what are we supposed to do? unless ( exists $self->{key_md5} ) { DBM::Deep->_throw_error( "Cannot find_md5 without a key_md5 set" ); } my $e = $self->engine; foreach my $idx ( 0 .. $e->max_buckets - 1 ) { my $potential = $e->storage->read_at( $self->offset + $self->base_size + $idx * $self->bucket_size, $e->hash_size, ); if ( $potential eq $e->blank_md5 ) { $self->{idx} = $idx; return; } if ( $potential eq $self->{key_md5} ) { $self->{found} = 1; $self->{idx} = $idx; return; } } return; } sub write_md5 { my $self = shift; my ($args) = @_; DBM::Deep->_throw_error( "write_md5: no key" ) unless exists $args->{key}; DBM::Deep->_throw_error( "write_md5: no key_md5" ) unless exists $args->{key_md5}; DBM::Deep->_throw_error( "write_md5: no value" ) unless exists $args->{value}; my $engine = $self->engine; $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; $engine->add_entry( $args->{trans_id}, $spot ); unless ($self->{found}) { my $key_sector = DBM::Deep::Sector::File::Scalar->new({ engine => $engine, data => $args->{key}, }); $engine->storage->print_at( $spot, $args->{key_md5}, pack( $StP{$engine->byte_size}, $key_sector->offset ), ); } my $loc = $spot + $engine->hash_size + $engine->byte_size; if ( $args->{trans_id} ) { $loc += $engine->byte_size + ($args->{trans_id} - 1) * ( $engine->byte_size + $STALE_SIZE ); $engine->storage->print_at( $loc, pack( $StP{$engine->byte_size}, $args->{value}->offset ), pack( $StP{$STALE_SIZE}, $engine->get_txn_staleness_counter( $args->{trans_id} ) ), ); } else { $engine->storage->print_at( $loc, pack( $StP{$engine->byte_size}, $args->{value}->offset ), ); } } sub mark_deleted { my $self = shift; my ($args) = @_; $args ||= {}; my $engine = $self->engine; $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; $engine->add_entry( $args->{trans_id}, $spot ); my $loc = $spot + $engine->hash_size + $engine->byte_size; if ( $args->{trans_id} ) { $loc += $engine->byte_size + ($args->{trans_id} - 1) * ( $engine->byte_size + $STALE_SIZE ); $engine->storage->print_at( $loc, pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted pack( $StP{$STALE_SIZE}, $engine->get_txn_staleness_counter( $args->{trans_id} ) ), ); } else { $engine->storage->print_at( $loc, pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted ); } } sub delete_md5 { my $self = shift; my ($args) = @_; my $engine = $self->engine; return undef unless $self->{found}; # Save the location so that we can free the data my $location = $self->get_data_location_for({ allow_head => 0, }); my $key_sector = $self->get_key_for; my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; $engine->storage->print_at( $spot, $engine->storage->read_at( $spot + $self->bucket_size, $self->bucket_size * ( $engine->max_buckets - $self->{idx} - 1 ), ), chr(0) x $self->bucket_size, ); $key_sector->free; my $data_sector = $self->engine->load_sector( $location ); my $data = $data_sector->data({ export => 1 }); $data_sector->free; return $data; } sub get_data_location_for { my $self = shift; my ($args) = @_; $args ||= {}; $args->{allow_head} = 0 unless exists $args->{allow_head}; $args->{trans_id} = $self->engine->trans_id unless exists $args->{trans_id}; $args->{idx} = $self->{idx} unless exists $args->{idx}; my $e = $self->engine; my $spot = $self->offset + $self->base_size + $args->{idx} * $self->bucket_size + $e->hash_size + $e->byte_size; if ( $args->{trans_id} ) { $spot += $e->byte_size + ($args->{trans_id} - 1) * ( $e->byte_size + $STALE_SIZE ); } my $buffer = $e->storage->read_at( $spot, $e->byte_size + $STALE_SIZE, ); my ($loc, $staleness) = unpack( $StP{$e->byte_size} . ' ' . $StP{$STALE_SIZE}, $buffer ); # XXX Merge the two if-clauses below if ( $args->{trans_id} ) { # We have found an entry that is old, so get rid of it if ( $staleness != (my $s = $e->get_txn_staleness_counter( $args->{trans_id} ) ) ) { $e->storage->print_at( $spot, pack( $StP{$e->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ), ); $loc = 0; } } # If we're in a transaction and we never wrote to this location, try the # HEAD instead. if ( $args->{trans_id} && !$loc && $args->{allow_head} ) { return $self->get_data_location_for({ trans_id => 0, allow_head => 1, idx => $args->{idx}, }); } return $loc <= 1 ? 0 : $loc; } sub get_data_for { my $self = shift; my ($args) = @_; $args ||= {}; return unless $self->{found}; my $location = $self->get_data_location_for({ allow_head => $args->{allow_head}, }); return $self->engine->load_sector( $location ); } sub get_key_for { my $self = shift; my ($idx) = @_; $idx = $self->{idx} unless defined $idx; if ( $idx >= $self->engine->max_buckets ) { DBM::Deep->_throw_error( "get_key_for(): Attempting to retrieve $idx" ); } my $location = $self->engine->storage->read_at( $self->offset + $self->base_size + $idx * $self->bucket_size + $self->engine->hash_size, $self->engine->byte_size, ); $location = unpack( $StP{$self->engine->byte_size}, $location ); DBM::Deep->_throw_error( "get_key_for: No location?" ) unless $location; return $self->engine->load_sector( $location ); } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Sector/File/Index.pm000444001750001750 442612641624315 17522 0ustar00robrob000000000000package DBM::Deep::Sector::File::Index; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Sector::File ); my $STALE_SIZE = 2; # Please refer to the pack() documentation for further information my %StP = ( 1 => 'C', # Unsigned char value (no order needed as it's just one byte) 2 => 'n', # Unsigned short in "network" (big-endian) order 4 => 'N', # Unsigned long in "network" (big-endian) order 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) ); sub _init { my $self = shift; my $engine = $self->engine; unless ( $self->offset ) { my $leftover = $self->size - $self->base_size; $self->{offset} = $engine->_request_index_sector( $self->size ); $engine->storage->print_at( $self->offset, $engine->SIG_INDEX ); # Sector type # Skip staleness counter $engine->storage->print_at( $self->offset + $self->base_size, chr(0) x $leftover, # Zero-fill the rest ); } return $self; } #XXX Change here sub size { my $self = shift; unless ( $self->{size} ) { my $e = $self->engine; $self->{size} = $self->base_size + $e->byte_size * $e->hash_chars; } return $self->{size}; } sub free_meth { return '_add_free_index_sector' } sub free { my $self = shift; my $e = $self->engine; for my $i ( 0 .. $e->hash_chars - 1 ) { my $l = $self->get_entry( $i ) or next; $e->load_sector( $l )->free; } $self->SUPER::free(); } sub _loc_for { my $self = shift; my ($idx) = @_; return $self->offset + $self->base_size + $idx * $self->engine->byte_size; } sub get_entry { my $self = shift; my ($idx) = @_; my $e = $self->engine; DBM::Deep->_throw_error( "get_entry: Out of range ($idx)" ) if $idx < 0 || $idx >= $e->hash_chars; return unpack( $StP{$e->byte_size}, $e->storage->read_at( $self->_loc_for( $idx ), $e->byte_size ), ); } sub set_entry { my $self = shift; my ($idx, $loc) = @_; my $e = $self->engine; DBM::Deep->_throw_error( "set_entry: Out of range ($idx)" ) if $idx < 0 || $idx >= $e->hash_chars; $self->engine->storage->print_at( $self->_loc_for( $idx ), pack( $StP{$e->byte_size}, $loc ), ); } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Sector/File/Null.pm000444001750001750 241612641624315 17362 0ustar00robrob000000000000package DBM::Deep::Sector::File::Null; use 5.008_004; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Sector::File::Data ); my $STALE_SIZE = 2; # Please refer to the pack() documentation for further information my %StP = ( 1 => 'C', # Unsigned char value (no order needed as it's just one byte) 2 => 'n', # Unsigned short in "network" (big-endian) order 4 => 'N', # Unsigned long in "network" (big-endian) order 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) ); sub type { $_[0]{engine}->SIG_NULL } sub data_length { 0 } sub data { return } sub _init { my $self = shift; my $engine = $self->engine; unless ( $self->offset ) { my $leftover = $self->size - $self->base_size - 1 * $engine->byte_size - 1; $self->{offset} = $engine->_request_data_sector( $self->size ); $engine->storage->print_at( $self->offset, $self->type ); # Sector type # Skip staleness counter $engine->storage->print_at( $self->offset + $self->base_size, pack( $StP{$engine->byte_size}, 0 ), # Chain loc pack( $StP{1}, $self->data_length ), # Data length chr(0) x $leftover, # Zero-fill the rest ); return; } } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Sector/DBI000755001750001750 012641624315 15471 5ustar00robrob000000000000DBM-Deep-2.0013/lib/DBM/Deep/Sector/DBI/Reference.pm000444001750001750 1226512641624315 20110 0ustar00robrob000000000000package DBM::Deep::Sector::DBI::Reference; use 5.008_004; use strict; use warnings FATAL => 'all'; use base 'DBM::Deep::Sector::DBI'; use Scalar::Util; sub table { 'refs' } sub _init { my $self = shift; my $e = $self->engine; unless ( $self->offset ) { my $classname = Scalar::Util::blessed( delete $self->{data} ); $self->{offset} = $self->engine->storage->write_to( refs => undef, ref_type => $self->type, classname => $classname, ); } else { my ($rows) = $self->engine->storage->read_from( refs => $self->offset, qw( ref_type ), ); $self->{type} = $rows->[0]{ref_type}; } return; } sub get_data_for { my $self = shift; my ($args) = @_; my ($rows) = $self->engine->storage->read_from( datas => { ref_id => $self->offset, key => $args->{key} }, qw( id ), ); return unless $rows->[0]{id}; $self->load( $self->engine, $rows->[0]{id}, 'datas', ); } sub write_data { my $self = shift; my ($args) = @_; if ( ( $args->{value}->type || 'S' ) eq 'S' ) { $args->{value}{offset} = $self->engine->storage->write_to( datas => $args->{value}{offset}, ref_id => $self->offset, data_type => 'S', key => $args->{key}, value => $args->{value}{data}, ); $args->{value}->reload; } else { # Write the Scalar of the Reference $self->engine->storage->write_to( datas => undef, ref_id => $self->offset, data_type => 'R', key => $args->{key}, value => $args->{value}{offset}, ); } } sub delete_key { my $self = shift; my ($args) = @_; my $old_value = $self->get_data_for({ key => $args->{key}, }); my $data; if ( $old_value ) { $data = $old_value->data({ export => 1 }); $self->engine->storage->delete_from( 'datas', { ref_id => $self->offset, key => $args->{key}, }, ); $old_value->free; } return $data; } sub get_classname { my $self = shift; my ($rows) = $self->engine->storage->read_from( 'refs', $self->offset, qw( classname ), ); return unless @$rows; return $rows->[0]{classname}; } # Look to hoist this method into a ::Reference trait sub data { my $self = shift; my ($args) = @_; $args ||= {}; my $engine = $self->engine; my $cache = $engine->cache; my $off = $self->offset; my $obj; if ( !defined $cache->{ $off } ) { $obj = DBM::Deep->new({ type => $self->type, base_offset => $self->offset, storage => $engine->storage, engine => $engine, }); $cache->{$off} = $obj; Scalar::Util::weaken($cache->{$off}); } else { $obj = $cache->{$off}; } # We're not exporting, so just return. unless ( $args->{export} ) { if ( $engine->storage->{autobless} ) { my $classname = $self->get_classname; if ( defined $classname ) { bless $obj, $classname; } } return $obj; } # We shouldn't export if this is still referred to. if ( $self->get_refcount > 1 ) { return $obj; } return $obj->export; } sub free { my $self = shift; # We're not ready to be removed yet. return if $self->decrement_refcount > 0; # Rebless the object into DBM::Deep::Null. # In external_refs mode, this will already have been removed from # the cache, so we can skip this. my $e = $self->engine; if(!$e->{external_refs}) { eval { %{ $e->cache->{ $self->offset } } = (); }; eval { @{ $e->cache->{ $self->offset } } = (); }; bless $e->cache->{ $self->offset }, 'DBM::Deep::Null'; delete $e->cache->{ $self->offset }; } $e->storage->delete_from( 'datas', { ref_id => $self->offset }, ); $e->storage->delete_from( 'datas', { value => $self->offset, data_type => 'R' }, ); $self->SUPER::free( @_ ); } sub increment_refcount { my $self = shift; my $refcount = $self->get_refcount; $refcount++; $self->write_refcount( $refcount ); return $refcount; } sub decrement_refcount { my $self = shift; my $refcount = $self->get_refcount; $refcount--; $self->write_refcount( $refcount ); return $refcount; } sub get_refcount { my $self = shift; my ($rows) = $self->engine->storage->read_from( 'refs', $self->offset, qw( refcount ), ); return $rows->[0]{refcount}; } sub write_refcount { my $self = shift; my ($num) = @_; $self->engine->storage->{dbh}->do( "UPDATE refs SET refcount = ? WHERE id = ?", undef, $num, $self->offset, ); } sub clear { my $self = shift; DBM::Deep->new({ type => $self->type, base_offset => $self->offset, storage => $self->engine->storage, engine => $self->engine, })->_clear; return; } 1; __END__ DBM-Deep-2.0013/lib/DBM/Deep/Sector/DBI/Scalar.pm000444001750001750 77712641624315 17364 0ustar00robrob000000000000package DBM::Deep::Sector::DBI::Scalar; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Sector::DBI ); sub table { 'datas' } sub _init { my $self = shift; if ( $self->offset ) { my ($rows) = $self->engine->storage->read_from( datas => $self->offset, qw( id data_type key value ), ); $self->{$_} = $rows->[0]{$_} for qw( data_type key value ); } return; } sub data { my $self = shift; $self->{value}; } 1; __END__ DBM-Deep-2.0013/t000755001750001750 012641624315 12052 5ustar00robrob000000000000DBM-Deep-2.0013/t/44_upgrade_db.t000444001750001750 1351012641624315 15017 0ustar00robrob000000000000$|++; use strict; use Test::More; plan skip_all => "upgrade_db.pl doesn't actually do anything correct."; # Add skips here BEGIN { plan skip_all => "Skipping the upgrade_db.pl tests on Win32/cygwin for now." if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ); plan skip_all => "Skipping the upgrade_db.pl tests on *bsd for now." if ( $^O =~ /bsd/i ); my @failures; eval "use Pod::Usage 1.3;"; push @failures, 'Pod::Usage' if $@; eval "use FileHandle::Fmode;"; push @failures, 'FileHandle::Fmode' if $@; if ( @failures ) { my $missing = join ',', @failures; plan skip_all => "'$missing' must be installed to run these tests"; } } plan tests => 351; use t::common qw( new_fh ); use File::Spec; use Test::Deep; my $PROG = File::Spec->catfile( qw( utils upgrade_db.pl ) ); my $short = get_pod( $PROG, 0 ); my $long = get_pod( $PROG, 1 ); is( run_prog( $PROG ), "Missing required parameters.\n$long", "Failed no params" ); is( run_prog( $PROG, '-input foo' ), "Missing required parameters.\n$long", "Failed only -input" ); is( run_prog( $PROG, '-output foo' ), "Missing required parameters.\n$long", "Failed only -output" ); is( run_prog( $PROG, '-input foo', '-output foo' ), "Cannot use the same filename for both input and output.\n$short", "Failed same name", ); is( run_prog( $PROG, '-input foo', '-output bar' ), "'foo' is not a file.\n$short", "Failed input does not exist", ); my (undef, $input_filename) = new_fh(); my (undef, $output_filename) = new_fh(); is( run_prog( $PROG, "-input $input_filename", "-output $output_filename" ), "'$input_filename' is not a DBM::Deep file.\n$short", "Input is not a DBM::Deep file", ); unlink $input_filename;unlink $output_filename; # All files are of the form: # $db->{foo} = [ 1 .. 3 ]; my @input_files = ( '0-983', '0-99_04', '1-0000', '1-0003', ); my @output_versions = ( '0.91', '0.92', '0.93', '0.94', '0.95', '0.96', '0.97', '0.98', '0.981', '0.982', '0.983', '0.99_01', '0.99_02', '0.99_03', '0.99_04', '1.00', '1.000', '1.0000', '1.0001', '1.0002', '1.0003', '1.0004', '1.0005', '1.0006', '1.0007', '1.0008', '1.0009', '1.0010', '1.0011', '1.0012', '1.0013', '1.0014', '2.0000' ); foreach my $input_filename ( map { File::Spec->catfile( qw( t etc ), "db-$_" ) } @input_files ) { # chmod it writable because old DBM::Deep versions don't handle readonly # files correctly. This is fixed in DBM::Deep 1.0000 chmod 0600, $input_filename; foreach my $v ( @output_versions ) { my (undef, $output_filename) = new_fh(); my $output = run_prog( $PROG, "-input $input_filename", "-output $output_filename", "-version $v", ); #warn "Testing $input_filename against $v\n"; # Clone was removed as a requirement in 1.0006 if ( $output =~ /Can\'t locate Clone\.pm in \@INC/ ) { ok( 1 ); unless ( $input_filename =~ /_/ || $v =~ /_/ ) { ok( 1 ); ok( 1 ); } next; } if ( $input_filename =~ /_/ ) { is( $output, "'$input_filename' is a dev release and not supported.\n$short", "Input file is a dev release - not supported", ); next; } if ( $v =~ /_/ ) { is( $output, "-version '$v' is a dev release and not supported.\n$short", "Output version is a dev release - not supported", ); next; } # Now, read the output file with the right version. ok( !$output, "A successful run produces no output" ); die "'$input_filename' -> '$v' : $output\n" if $output; my $db; my $db_version; if ( $v =~ /^2(?:\.|\z)/ ) { push @INC, 'lib'; eval "use DBM::Deep 1.9999"; die $@ if $@; $db = DBM::Deep->new( $output_filename ); $db_version = 2; } elsif( $v =~ /^1\.001[0-4]/ || $v =~ /^1\.000[3-9]/ ) { push @INC, 'lib'; eval "use DBM::Deep $v"; die $@ if $@; $db = DBM::Deep->new( $output_filename ); $db_version = '1.0003'; } elsif ( $v =~ /^1\.000?[0-2]?/ ) { push @INC, File::Spec->catdir( 'utils', 'lib' ); eval "use DBM::Deep::10002"; $db = DBM::Deep::10002->new( $output_filename ); } elsif ( $v =~ /^0/ ) { push @INC, File::Spec->catdir( 'utils', 'lib' ); eval "use DBM::Deep::09830"; $db = DBM::Deep::09830->new( $output_filename ); } else { die "How did we get here?!\n"; } ok( $db, "Writing to version $v made a file" ); cmp_deeply( $db->export, { foo => [ 1 .. 3 ] }, "We can read the output file", ); if($db_version) { is $db->db_version, $db_version, "db_version is $db_version"; } } } ################################################################################ #XXX This needs to be made OS-portable sub run_prog { open( my $fh, '-|', "$^X @_ 2>&1" ) or die "Cannot launch '@_' as a piped filehandle: $!\n"; return join '', <$fh>; } # In 5.8, we could use in-memory filehandles and have done: # open( my $fh, '>', \my $pod ) or die "Cannot open in-memory filehandle: $!\n"; # ... # return $pod; # However, DBM::Deep requires 5.6, so this set of contortions will have to do. sub get_pod { my ($p,$v) = @_; my ($fh, $fn) = new_fh(); close $fh; open $fh, '>', $fn; pod2usage({ -input => $p, -output => $fh, -verbose => $v, -exitval => 'NOEXIT', }); close $fh; open $fh, '<', $fn; return join '', <$fh>; } DBM-Deep-2.0013/t/40_freespace.t000444001750001750 434012641624315 14635 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); { my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new({ file => $filename, autoflush => 1, }); $db->{foo} = '1234'; $db->{foo} = '2345'; my $size = -s $filename; $db->{foo} = '3456'; cmp_ok( $size, '==', -s $filename, "A second overwrite doesn't change size" ); $size = -s $filename; delete $db->{foo}; cmp_ok( $size, '==', -s $filename, "Deleted space isn't released" ); $db->{bar} = '2345'; cmp_ok( $size, '==', -s $filename, "Added a new key after a delete reuses space" ); $db->{baz} = {}; $size = -s $filename; delete $db->{baz}; $db->{baz} = {}; cmp_ok( $size, '==', -s $filename, "delete and rewrite reuses space" ); $db->{baz} = {}; $size = -s $filename; $db->{baz} = {}; cmp_ok( $size, '==', -s $filename, "delete and rewrite reuses space" ); my $x = { foo => 'bar' }; $db->{floober} = $x; delete $db->{floober}; ok( !exists $x->{foo}, "Deleting floober makes \$x empty (exists)" ); is( $x->{foo}, undef, "Deleting floober makes \$x empty (read)" ); is( delete $x->{foo}, undef, "Deleting floober makes \$x empty (delete)" ); eval { $x->{foo} = 'bar'; }; like( $@, qr/Cannot write to a deleted spot in DBM::Deep/, "Exception thrown when writing" ); cmp_ok( scalar( keys %$x ), '==', 0, "Keys returns nothing after deletion" ); } { my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new({ file => $filename, autoflush => 1, }); $db->{ $_ } = undef for 1 .. 4; delete $db->{ $_ } for 1 .. 4; cmp_ok( keys %{ $db }, '==', 0, "We added and removed 4 keys" ); # So far, we've written 4 keys. Let's write 13 more keys. This should -not- # trigger a reindex. This requires knowing how much space is taken. Good thing # we wrote this dreck ... my $size = -s $filename; my $data_sector_size = $db->_engine->data_sector_size; my $expected = $size + 9 * ( 2 * $data_sector_size ); $db->{ $_ } = undef for 5 .. 17; cmp_ok( $expected, '==', -s $filename, "No reindexing after deletion" ); } done_testing; DBM-Deep-2.0013/t/12_clone.t000444001750001750 207312641624315 14000 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { { my $clone; { my $db = $dbm_maker->(); $db->{key1} = "value1"; ## # clone db handle, make sure both are usable ## $clone = $db->clone(); is($clone->{key1}, "value1"); $clone->{key2} = "value2"; $db->{key3} = "value3"; is($db->{key1}, "value1"); is($db->{key2}, "value2"); is($db->{key3}, "value3"); is($clone->{key1}, "value1"); is($clone->{key2}, "value2"); is($clone->{key3}, "value3"); } is($clone->{key1}, "value1"); is($clone->{key2}, "value2"); is($clone->{key3}, "value3"); } { my $db = $dbm_maker->(); is($db->{key1}, "value1"); is($db->{key2}, "value2"); is($db->{key3}, "value3"); } } done_testing; DBM-Deep-2.0013/t/02_hash.t000444001750001750 1430712641624315 13645 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_dbm ); use Scalar::Util qw( reftype ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); ## # put/get key ## $db->{key1} = "value1"; is( $db->get("key1"), "value1", "get() works with hash assignment" ); is( $db->fetch("key1"), "value1", "... fetch() works with hash assignment" ); is( $db->{key1}, "value1", "... and hash-access also works" ); $db->put("key2", undef); is( $db->get("key2"), undef, "get() works with put()" ); is( $db->fetch("key2"), undef, "... fetch() works with put()" ); is( $db->{key2}, undef, "... and hash-access also works" ); $db->store( "0", "value3" ); is( $db->get("0"), "value3", "get() works with store()" ); is( $db->fetch("0"), "value3", "... fetch() works with put()" ); is( $db->{0}, 'value3', "... and hash-access also works" ); # Verify that the keyval pairs are still correct. is( $db->{key1}, "value1", "Key1 is still correct" ); is( $db->{key2}, undef, "Key2 is still correct" ); is( $db->{0}, 'value3', "Key3 is still correct" ); ok( $db->exists("key1"), "exists() function works" ); ok( exists $db->{key2}, "exists() works against tied hash" ); ok( !exists $db->{key4}, "exists() function works for keys that aren't there" ); is( $db->{key4}, undef, "Nonexistent key4 is undef" ); ok( !exists $db->{key4}, "Simply reading key4 does not autovivify" ); # Keys will be done via an iterator that keeps a breadcrumb trail of the last # key it provided. There will also be an "edit revision number" on the # reference so that resetting the iterator can be done. # # Q: How do we make sure that the iterator is unique? Is it supposed to be? ## # count keys ## is( scalar keys %$db, 3, "keys() works against tied hash" ); ## # step through keys ## my $temphash = {}; while ( my ($key, $value) = each %$db ) { $temphash->{$key} = $value; } is( $temphash->{key1}, 'value1', "First key copied successfully using tied interface" ); is( $temphash->{key2}, undef, "Second key copied successfully" ); is( $temphash->{0}, 'value3', "Third key copied successfully" ); $temphash = {}; my $key = $db->first_key(); while (defined $key) { $temphash->{$key} = $db->get($key); $key = $db->next_key($key); } is( $temphash->{key1}, 'value1', "First key copied successfully using OO interface" ); is( $temphash->{key2}, undef, "Second key copied successfully" ); is( $temphash->{0}, 'value3', "Third key copied successfully" ); ## # delete keys ## is( delete $db->{key2}, undef, "delete through tied inteface works" ); is( $db->delete("key1"), 'value1', "delete through OO inteface works" ); is( $db->{0}, 'value3', "The other key is still there" ); ok( !exists $db->{key1}, "key1 doesn't exist" ); ok( !exists $db->{key2}, "key2 doesn't exist" ); is( scalar keys %$db, 1, "After deleting two keys, 1 remains" ); ## # delete all keys ## ok( $db->clear(), "clear() returns true" ); is( scalar keys %$db, 0, "After clear(), everything is removed" ); ## # replace key ## $db->put("key1", "value1"); is( $db->get("key1"), "value1", "Assignment still works" ); $db->put("key1", "value2"); is( $db->get("key1"), "value2", "... and replacement works" ); $db->put("key1", "value222222222222222222222222"); is( $db->get("key1"), "value222222222222222222222222", "We set a value before closing the file" ); ## # Make sure DB still works after closing / opening ## undef $db; $db = $dbm_maker->(); is( $db->get("key1"), "value222222222222222222222222", "The value we set is still there after closure" ); ## # Make sure keys are still fetchable after replacing values # with smaller ones (bug found by John Cardenas, DBM::Deep 0.93) ## $db->clear(); $db->put("key1", "long value here"); $db->put("key2", "longer value here"); $db->put("key1", "short value"); $db->put("key2", "shorter v"); my $first_key = $db->first_key(); my $next_key = $db->next_key($first_key); ok( (($first_key eq "key1") || ($first_key eq "key2")) && (($next_key eq "key1") || ($next_key eq "key2")) && ($first_key ne $next_key) ,"keys() still works if you replace long values with shorter ones" ); # Test autovivification $db->{unknown}{bar} = 1; ok( $db->{unknown}, 'Autovivified hash exists' ); is( reftype($db->{unknown}), 'HASH', "... and it's a HASH" ); cmp_ok( $db->{unknown}{bar}, '==', 1, 'And the value stored is there' ); # Test failures throws_ok { $db->fetch(); } qr/Cannot use an undefined hash key/, "FETCH fails on an undefined key"; throws_ok { $db->fetch(undef); } qr/Cannot use an undefined hash key/, "FETCH fails on an undefined key"; throws_ok { $db->store(); } qr/Cannot use an undefined hash key/, "STORE fails on an undefined key"; throws_ok { $db->store(undef, undef); } qr/Cannot use an undefined hash key/, "STORE fails on an undefined key"; throws_ok { $db->delete(); } qr/Cannot use an undefined hash key/, "DELETE fails on an undefined key"; throws_ok { $db->delete(undef); } qr/Cannot use an undefined hash key/, "DELETE fails on an undefined key"; throws_ok { $db->exists(); } qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key"; throws_ok { $db->exists(undef); } qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key"; } { # RT# 50541 (reported by Peter Scott) # clear() leaves one key unless there's only one my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); $db->{block} = { }; $db->{critical} = { }; $db->{minor} = { }; cmp_ok( scalar(keys( %$db )), '==', 3, "Have 3 keys" ); $db->clear; cmp_ok( scalar(keys( %$db )), '==', 0, "clear clears everything" ); } } done_testing; DBM-Deep-2.0013/t/31_references.t000444001750001750 250312641624315 15020 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use Test::Exception; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); my %hash = ( foo => 1, bar => [ 1 .. 3 ], baz => { a => 42 }, ); $db->{hash} = \%hash; isa_ok( tied(%hash), 'DBM::Deep::Hash' ); is( $db->{hash}{foo}, 1 ); cmp_deeply( $db->{hash}{bar}, noclass([ 1 .. 3 ]) ); cmp_deeply( $db->{hash}{baz}, noclass({ a => 42 }) ); $hash{foo} = 2; is( $db->{hash}{foo}, 2 ); $hash{bar}[1] = 90; is( $db->{hash}{bar}[1], 90 ); $hash{baz}{b} = 33; is( $db->{hash}{baz}{b}, 33 ); my @array = ( 1, [ 1 .. 3 ], { a => 42 }, ); $db->{array} = \@array; isa_ok( tied(@array), 'DBM::Deep::Array' ); is( $db->{array}[0], 1 ); cmp_deeply( $db->{array}[1], noclass([ 1 .. 3 ]) ); cmp_deeply( $db->{array}[2], noclass({ a => 42 }) ); $array[0] = 2; is( $db->{array}[0], 2 ); $array[1][2] = 9; is( $db->{array}[1][2], 9 ); $array[2]{b} = 'floober'; is( $db->{array}[2]{b}, 'floober' ); my %hash2 = ( abc => [ 1 .. 3 ] ); $array[3] = \%hash2; $hash2{ def } = \%hash; is( $array[3]{def}{foo}, 2 ); } done_testing; DBM-Deep-2.0013/t/03_bighash.t000444001750001750 314112641624315 14302 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests" unless $ENV{LONG_TESTS}; use Test::Deep; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); diag "This test can take up to several minutes to run. Please be patient."; my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_HASH ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); $db->{foo} = {}; my $foo = $db->{foo}; ## # put/get many keys ## my $max_keys = 4000; for ( 0 .. $max_keys ) { $foo->put( "hello $_" => "there " . $_ * 2 ); } my $count = -1; for ( 0 .. $max_keys ) { $count = $_; unless ( $foo->get( "hello $_" ) eq "there " . $_ * 2 ) { last; }; } is( $count, $max_keys, "We read $count keys" ); my @keys = sort keys %$foo; cmp_ok( scalar(@keys), '==', $max_keys + 1, "Number of keys is correct" ); my @control = sort map { "hello $_" } 0 .. $max_keys; cmp_deeply( \@keys, \@control, "Correct keys are there" ); ok( !exists $foo->{does_not_exist}, "EXISTS works on large hashes for non-existent keys" ); $foo->{does_not_exist}{ling} = undef; ok( $foo->{does_not_exist}, "autovivification works on large hashes" ); ok( exists $foo->{does_not_exist}, "EXISTS works on large hashes for newly-existent keys" ); cmp_ok( scalar(keys %$foo), '==', $max_keys + 2, "Number of keys after autovivify is correct" ); $db->clear; cmp_ok( scalar(keys %$db), '==', 0, "Number of keys after clear() is correct" ); } done_testing; DBM-Deep-2.0013/t/17_import.t000444001750001750 1020712641624315 14235 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use Test::Exception; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); # Failure cases to make sure that things are caught right. foreach my $type ( DBM::Deep->TYPE_HASH, DBM::Deep->TYPE_ARRAY ) { my $dbm_factory = new_dbm( type => $type ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); # Load a scalar throws_ok { $db->import( 'foo' ); } qr/Cannot import a scalar/, "Importing a scalar to type '$type' fails"; # Load a ref of the wrong type # Load something with bad stuff in it my $x = 3; if ( $type eq 'A' ) { throws_ok { $db->import( { foo => 'bar' } ); } qr/Cannot import a hash into an array/, "Wrong type fails"; throws_ok { $db->import( [ \$x ] ); } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails"; } else { throws_ok { $db->import( [ 1 .. 3 ] ); } qr/Cannot import an array into a hash/, "Wrong type fails"; throws_ok { $db->import( { foo => \$x } ); } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails"; } } } my $dbm_factory = new_dbm( autobless => 1 ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); ## # Create structure in memory ## my $struct = { key1 => "value1", key2 => "value2", array1 => [ "elem0", "elem1", "elem2" ], hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2", subkey3 => bless( { a => 'b' }, 'Foo' ), } }; $db->import( $struct ); cmp_deeply( $db, noclass({ key1 => 'value1', key2 => 'value2', array1 => [ 'elem0', 'elem1', 'elem2', ], hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2", subkey3 => useclass( bless { a => 'b' }, 'Foo' ), }, }), "Everything matches", ); $struct->{foo} = 'bar'; is( $struct->{foo}, 'bar', "\$struct has foo and it's 'bar'" ); ok( !exists $db->{foo}, "\$db doesn't have the 'foo' key, so \$struct is not tied" ); $struct->{hash1}->{foo} = 'bar'; is( $struct->{hash1}->{foo}, 'bar', "\$struct->{hash1} has foo and it's 'bar'" ); ok( !exists $db->{hash1}->{foo}, "\$db->{hash1} doesn't have the 'foo' key, so \$struct->{hash1} is not tied" ); } $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); my $struct = [ 1 .. 3, [ 2, 4, 6 ], bless( [], 'Bar' ), { foo => [ 2 .. 4 ] }, ]; $db->import( $struct ); cmp_deeply( $db, noclass([ 1 .. 3, [ 2, 4, 6 ], useclass( bless( [], 'Bar' ) ), { foo => [ 2 .. 4 ] }, ]), "Everything matches", ); push @$struct, 'bar'; is( $struct->[-1], 'bar', "\$struct has 'bar' at the end" ); ok( $db->[-1], "\$db doesn't have the 'bar' value at the end, so \$struct is not tied" ); } # Failure case to verify that rollback occurs $dbm_factory = new_dbm( autobless => 1 ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); $db->{foo} = 'bar'; my $x; my $struct = { key1 => [ 2, \$x, 3, ], }; eval { $db->import( $struct ); }; like( $@, qr/Storage of references of type 'SCALAR' is not supported/, 'Error message correct' ); TODO: { local $TODO = "Importing cannot occur within a transaction yet."; cmp_deeply( $db, noclass({ foo => 'bar', }), "Everything matches", ); } } done_testing; __END__ Need to add tests for: - Failure case (have something tied or a glob or something like that) - Where we already have $db->{hash1} to make sure that it's not overwritten DBM-Deep-2.0013/t/07_locking.t000444001750001750 130612641624315 14330 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm( locking => 1 ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); lives_ok { $db->unlock; } "Can call unlock on an unlocked DB."; ## # basic put/get ## $db->{key1} = "value1"; is( $db->{key1}, "value1", "key1 is set" ); $db->{key2} = [ 1 .. 3 ]; is( $db->{key2}[1], 2, "The value is set properly" ); ## # explicit lock ## $db->lock_exclusive; $db->{key1} = "value2"; $db->unlock(); is( $db->{key1}, "value2", "key1 is overridden" ); } done_testing; DBM-Deep-2.0013/t/97_dump_file.t000444001750001750 172512641624315 14664 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use t::common qw( new_fh ); use utf8; use_ok( 'DBM::Deep' ); my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new( $filename ); is( $db->_dump_file, <<"__END_DUMP__", "Dump of initial file correct" ); NumTxns: 1 Chains(B): Chains(D): Chains(I): 00000030: H 0064 REF: 1 __END_DUMP__ $db->{foo} = 'bar'; is( $db->_dump_file, <<"__END_DUMP__", "Dump of file after single assignment" ); NumTxns: 1 Chains(B): Chains(D): Chains(I): 00000030: H 0064 REF: 1 00000094: D 0064 bar 00000158: B 0387 00000545 00000094 00000545: D 0064 foo __END_DUMP__ $db->{ḟoo} = 'bār'; is( $db->_dump_file, <<"__END_DUMP__", "Dump after Unicode assignment" ); NumTxns: 1 Chains(B): Chains(D): Chains(I): 00000030: H 0064 REF: 1 00000094: D 0064 bar 00000158: B 0387 00000545 00000094 00000673 00000609 00000545: D 0064 foo 00000609: U 0064 bār 00000673: U 0064 ḟoo __END_DUMP__ done_testing; DBM-Deep-2.0013/t/15_digest.t000444001750001750 360312641624315 14162 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $salt = 38473827; # Warning: This digest function is for testing ONLY. # It is NOT intended for actual use. If you do so, I will laugh at you. sub my_digest { my $key = shift; my $num = $salt; for (my $k=0; $k \&my_digest, hash_size => 8 ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); ## # put/get key ## $db->{key1} = "value1"; ok( $db->{key1} eq "value1" ); $db->put("key2", "value2"); ok( $db->get("key2") eq "value2" ); ## # key exists ## ok( $db->exists("key1") ); ok( exists $db->{key2} ); ## # count keys ## ok( scalar keys %$db == 2 ); ## # step through keys ## my $temphash = {}; while ( my ($key, $value) = each %$db ) { $temphash->{$key} = $value; } ok( ($temphash->{key1} eq "value1") && ($temphash->{key2} eq "value2") ); $temphash = {}; my $key = $db->first_key(); while ($key) { $temphash->{$key} = $db->get($key); $key = $db->next_key($key); } ok( ($temphash->{key1} eq "value1") && ($temphash->{key2} eq "value2") ); ## # delete keys ## ok( delete $db->{key1} ); ok( $db->delete("key2") ); ok( scalar keys %$db == 0 ); ## # delete all keys ## $db->put("another", "value"); $db->clear(); ok( scalar keys %$db == 0 ); ## # replace key ## $db->put("key1", "value1"); $db->put("key1", "value2"); ok( $db->get("key1") eq "value2" ); $db->put("key1", "value222222222222222222222222"); ok( $db->get("key1") eq "value222222222222222222222222" ); } done_testing; DBM-Deep-2.0013/t/05_bigarray.t000444001750001750 170412641624315 14502 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests" unless $ENV{LONG_TESTS}; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); diag "This test can take up to several minutes to run. Please be patient."; my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); ## # put/get many keys ## my $max_keys = 4000; for ( 0 .. $max_keys ) { $db->put( $_ => $_ * 2 ); } my $count = -1; for ( 0 .. $max_keys ) { $count = $_; unless ( $db->get( $_ ) == $_ * 2 ) { last; }; } is( $count, $max_keys, "We read $count keys" ); cmp_ok( scalar(@$db), '==', $max_keys + 1, "Number of elements is correct" ); $db->clear; cmp_ok( scalar(@$db), '==', 0, "Number of elements after clear() is correct" ); } done_testing; DBM-Deep-2.0013/t/11_optimize.t000444001750001750 601012641624315 14532 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; plan skip_all => "Skipping the optimize tests on Win32/cygwin for now." if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ); use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new( file => $filename, autoflush => 1, ); ## # create some unused space ## $db->{key1} = "value1"; $db->{key2} = "value2"; $db->{a} = {}; $db->{a}{b} = []; $db->{a}{c} = 'value2'; my $b = $db->{a}->{b}; $b->[0] = 1; $b->[1] = 2; $b->[2] = {}; $b->[2]->{c} = []; my $c = $b->[2]->{c}; $c->[0] = 'd'; $c->[1] = {}; $c->[1]->{e} = 'f'; undef $c; undef $b; delete $db->{key2}; delete $db->{a}{b}; ## # take byte count readings before, and after optimize ## my $before = (stat($filename))[7]; my $result = $db->optimize(); my $after = (stat($filename))[7]; ok( $result, "optimize succeeded" ); cmp_ok( $after, '<', $before, "file size has shrunk" ); # make sure file shrunk is( $db->{key1}, 'value1', "key1's value is still there after optimize" ); is( $db->{a}{c}, 'value2', "key2's value is still there after optimize" ); $db->_get_self->_engine->storage->close( $db->_get_self ); ## # now for the tricky one -- try to store a new key while file is being # optimized and locked by another process. filehandle should be invalidated, # and automatically re-opened transparently. Cannot test on Win32, due to # problems with fork()ing, flock()ing, etc. Win32 very bad. ## SKIP: { skip "Fork tests skipped until fh/filename question solved.", 4; skip "Fork tests skipped on Win32", 4 if $^O eq 'MSWin32' || $^O eq 'cygwin'; ## # first things first, get us about 1000 keys so the optimize() will take # at least a few seconds on any machine, and re-open db with locking ## for (1..1000) { $db->STORE( $_, $_ +1 ); } undef $db; ## # now, fork a process for the optimize() ## my $pid = fork(); unless ( $pid ) { # child fork # re-open db $db = DBM::Deep->new( file => $filename, autoflush => 1, locking => 1 ); # optimize and exit $db->optimize(); exit( 0 ); } # parent fork ok( defined($pid), "fork was successful" ); # make sure fork was successful # re-open db $db = DBM::Deep->new( file => $filename, autoflush => 1, locking => 1 ); # sleep for 1 second to make sure optimize() is running in the other fork sleep(1); # now, try to get a lock and store a key $db->{parentfork} = "hello"; # see if it was stored successfully is( $db->{parentfork}, "hello", "stored key while optimize took place" ); undef $db; $db = DBM::Deep->new( file => $filename, autoflush => 1, locking => 1 ); # now check some existing values from before is( $db->{key1}, 'value1', "key1's value is still there after optimize" ); is( $db->{a}{c}, 'value2', "key2's value is still there after optimize" ); } done_testing; DBM-Deep-2.0013/t/52_memory_leak.t000444001750001750 405512641624315 15212 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use_ok( 'DBM::Deep' ); use t::common qw( new_dbm ); # RT #77746 my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); $db->{foo} = {}; my $data = $db->{foo}; use Scalar::Util 'weaken'; weaken $db; weaken $data; is $db, undef, 'no $db after weakening'; is $data, undef, 'hashes returned from db contain no circular refs'; } # This was discussed here: # http://groups.google.com/group/DBM-Deep/browse_thread/thread/a6b8224ffec21bab # brought up by Alex Gallichotte SKIP: { skip "Need to figure out what platforms this runs on", 1; } done_testing; exit; $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); my $todo = 1000; my $allow = $todo*0.02; # NOTE: a 2% fail rate is hardly a failure $db->{randkey()} = 1 for 1 .. 1000; my $error_count = 0; my @mem = (mem(0), mem(1)); for my $i (1 .. $todo) { $db->{randkey()} = [@mem]; ## DEBUG ## print STDERR " @mem \r"; my @tm = (mem(0), mem(1)); skip( not($mem[0]), ($tm[0] <= $mem[0] or --$allow>0) ); skip( not($mem[1]), ($tm[1] <= $mem[1] or --$allow>0) ); $error_count ++ if $tm[0] > $mem[0] or $tm[1] > $mem[1]; die " ERROR: that's enough failures to prove the point ... " if $error_count > 20; @mem = @tm; } } sub randkey { our $i ++; my @k = map { int rand 100 } 1 .. 10; local $" = "-"; return "$i-@k"; } sub mem { open my $in, "/proc/$$/statm" or return 0; my $line = [ split m/\s+/, <$in> ]; close $in; return $line->[shift]; } __END__ /proc/[number]/statm Provides information about memory status in pages. The columns are: size total program size resident resident set size share shared pages text text (code) lib library data data/stack dt dirty pages (unused in Linux 2.6) DBM-Deep-2.0013/t/53_misc_transactions.t000444001750001750 150112641624315 16423 0ustar00robrob000000000000# This was discussed here: # http://groups.google.com/group/DBM-Deep/browse_thread/thread/a6b8224ffec21bab # brought up by Alex Gallichotte use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); eval { $db->{randkey()} = randkey() for 1 .. 10; }; ok(!$@, "No eval failures"); eval { #$db->begin_work; $db->{randkey()} = randkey() for 1 .. 10; #$db->commit; }; ok(!$@, "No eval failures from the transaction"); eval { $db->{randkey()} = randkey() for 1 .. 10; }; ok(!$@, "No eval failures"); } done_testing; sub randkey { our $i++; my @k = map { int rand 100 } 1 .. 10; local $" = "-"; return "$i-@k"; } DBM-Deep-2.0013/t/06_error.t000444001750001750 775512641624315 14050 0ustar00robrob000000000000 $|++; use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use Test::Warn; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); # test a corrupted file { my ($fh, $filename) = new_fh(); open FH, ">$filename"; print FH 'DPDB'; close FH; throws_ok { DBM::Deep->new( $filename ); } qr/DBM::Deep: Pre-1.00 file version found/, "Fail if there's a bad header"; } { my ($fh, $filename) = new_fh(); my %hash; tie %hash, 'DBM::Deep', $filename; undef %hash; my @array; throws_ok { tie @array, 'DBM::Deep', $filename; } qr/DBM::Deep: File type mismatch/, "Fail if we try and tie a hash file with an array"; throws_ok { DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_ARRAY ) } qr/DBM::Deep: File type mismatch/, "Fail if we try and open a hash file with an array"; } { my ($fh, $filename) = new_fh(); my @array; tie @array, 'DBM::Deep', $filename; undef @array; my %hash; throws_ok { tie %hash, 'DBM::Deep', $filename; } qr/DBM::Deep: File type mismatch/, "Fail if we try and tie an array file with a hash"; throws_ok { DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_HASH ) } qr/DBM::Deep: File type mismatch/, "Fail if we try and open an array file with a hash"; } { my %floors = ( max_buckets => 16, num_txns => 1, data_sector_size => 32, ); while ( my ($attr, $floor) = each %floors ) { { my ($fh, $filename) = new_fh(); warning_like { my $db = DBM::Deep->new( file => $filename, $attr => undef, ); } qr{Floor of $attr is $floor\. Setting it to $floor from '\Q(undef)\E'}, "Warning for $attr => undef is correct"; } { my ($fh, $filename) = new_fh(); warning_like { my $db = DBM::Deep->new( file => $filename, $attr => '', ); } qr{Floor of $attr is $floor\. Setting it to $floor from ''}, "Warning for $attr => '' is correct"; } { my ($fh, $filename) = new_fh(); warning_like { my $db = DBM::Deep->new( file => $filename, $attr => 'abcd', ); } qr{Floor of $attr is $floor\. Setting it to $floor from 'abcd'}, "Warning for $attr => 'abcd' is correct"; } { my ($fh, $filename) = new_fh(); my $val = $floor - 1; warning_like { my $db = DBM::Deep->new( file => $filename, $attr => $val, ); } qr{Floor of $attr is $floor\. Setting it to $floor from '$val'}, "Warning for $attr => $val is correct"; } } my %ceilings = ( max_buckets => 256, num_txns => 255, data_sector_size => 256, ); while ( my ($attr, $ceiling) = each %ceilings ) { my ($fh, $filename) = new_fh(); warning_like { my $db = DBM::Deep->new( file => $filename, $attr => 1000, ); } qr{Ceiling of $attr is $ceiling\. Setting it to $ceiling from '1000'}, "Warning for $attr => 1000 is correct"; } } { throws_ok { DBM::Deep->new( 't/etc/db-0-983' ); } qr/DBM::Deep: Pre-1.00 file version found/, "Fail if opening a pre-1.00 file"; } { throws_ok { DBM::Deep->new( 't/etc/db-0-99_04' ); } qr/DBM::Deep: This file version is too old - 0\.99 - expected (?x: )1\.0003 to \d/, "Fail if opening a file version 1"; } { # Make sure we get the right file name in the error message. throws_ok { eval "#line 1 gneen\nDBM::Deep->new( 't/etc/db-0-99_04' )" or die $@ } qr/ at gneen line 1\b/, "File name in error message is correct"; } done_testing; DBM-Deep-2.0013/t/28_index_sector.t000444001750001750 173712641624315 15403 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm( locking => 1, autoflush => 1, ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); for ( 1 .. 17 ) { $db->{ $_ } = $_; is( $db->{$_}, $_, "Addition of $_ is still $_" ); } for ( 1 .. 17 ) { is( $db->{$_}, $_, "Verification of $_ is still $_" ); } my @keys = keys %$db; cmp_ok( scalar(@keys), '==', 17, "Right number of keys returned" ); ok( !exists $db->{does_not_exist}, "EXISTS works on large hashes for non-existent keys" ); $db->{does_not_exist}{ling} = undef; ok( $db->{does_not_exist}, "autovivification works on large hashes" ); ok( exists $db->{does_not_exist}, "EXISTS works on large hashes for newly-existent keys" ); cmp_ok( scalar(keys %$db), '==', 18, "Number of keys after autovivify is correct" ); } done_testing; DBM-Deep-2.0013/t/98_pod.t000444001750001750 37612641624315 13464 0ustar00robrob000000000000use strict; use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; eval { require Pod::Simple }; plan skip_all => "Pod::Simple 3.21 has bugs" if $Pod::Simple::VERSION == 3.21; all_pod_files_ok(); DBM-Deep-2.0013/t/99_pod_coverage.t000444001750001750 125312641624315 15353 0ustar00robrob000000000000# Only DBM::Deep has any POD to test. All the other classes are private # classes. Hence, they have no POD outside of DBM::Deep::Internals use strict; use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; plan tests => 1; # I don't know why TYPE_ARRAY isn't being caught and TYPE_HASH is. my @private_methods = qw( TYPE_ARRAY ); # These are method names that have been commented out, for now # max_of total_of # begin_page end_page my $private_regex = do { local $"='|'; qr/^(?:@private_methods)$/ }; pod_coverage_ok( 'DBM::Deep' => { also_private => [ $private_regex ], }); DBM-Deep-2.0013/t/27_filehandle.t000444001750001750 664412641624315 15011 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_fh ); # Need to have an explicit plan in order for the sub-testing to work right. #XXX Figure out how to use subtests for that. my $pre_fork_tests = 14; plan tests => $pre_fork_tests + 2; use_ok( 'DBM::Deep' ); { my ($fh, $filename) = new_fh(); # Create the datafile to be used { my $db = DBM::Deep->new( $filename ); $db->{hash} = { foo => [ 'a' .. 'c' ] }; } { open(my $fh, '<', $filename) || die("Can't open '$filename' for reading: $!\n"); # test if we can open and read a db using its filehandle my $db; ok( ($db = DBM::Deep->new( fh => $fh )), "open db in filehandle" ); ok( $db->{hash}{foo}[1] eq 'b', "and get at stuff in the database" ); throws_ok { $db->{foo} = 1; } qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle"; ok( !$db->exists( 'foo' ), "foo doesn't exist" ); throws_ok { delete $db->{foo}; } qr/Cannot write to a readonly filehandle/, "Can't delete from a read-only filehandle"; throws_ok { %$db = (); } qr/Cannot write to a readonly filehandle/, "Can't clear from a read-only filehandle"; SKIP: { skip( "No inode tests on Win32", 1 ) if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ); my $db_obj = $db->_get_self; ok( $db_obj->_engine->storage->{inode}, "The inode has been set" ); } close($fh); } } # now the same, but with an offset into the file. Use the database that's # embedded in the test for the DATA filehandle. First, find the database ... { my ($fh,$filename) = new_fh(); print $fh "#!$^X\n"; print $fh <<"__END_FH__"; my \$t = $pre_fork_tests; print "not " unless eval { require DBM::Deep }; print "ok ", ++\$t, " - use DBM::Deep\n"; my \$db = DBM::Deep->new({ fh => *DATA, }); print "not " unless \$db->{x} eq 'b'; print "ok ", ++\$t, " - and get at stuff in the database\n"; __END_FH__ # The exec below prevents END blocks from doing this. (my $esc_dir = $t::common::dir) =~ s/(.)/sprintf "\\x{%x}", ord $1/egg; print $fh <<__END_FH_AGAIN__; use File::Path 'rmtree'; rmtree "$esc_dir"; __END_FH_AGAIN__ print $fh "__DATA__\n"; close $fh; my $offset = do { open my $fh, '<', $filename; while(my $line = <$fh>) { last if($line =~ /^__DATA__/); } tell($fh); }; { my $db = DBM::Deep->new({ file => $filename, file_offset => $offset, #XXX For some reason, this is needed to make the test pass. Figure #XXX out why later. locking => 0, }); $db->{x} = 'b'; is( $db->{x}, 'b', 'and it was stored' ); } { open my $fh, '<', $filename; my $db = DBM::Deep->new({ fh => $fh, file_offset => $offset, }); is($db->{x}, 'b', "and get at stuff in the database"); ok( !$db->exists( 'foo' ), "foo doesn't exist yet" ); throws_ok { $db->{foo} = 1; } qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle"; ok( !$db->exists( 'foo' ), "foo still doesn't exist" ); is( $db->{x}, 'b' ); } exec( "$^X -Iblib/lib $filename" ); } DBM-Deep-2.0013/t/42_transaction_indexsector.t000444001750001750 570312641624315 17642 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); # This testfile is in sections because the goal is to verify the behavior # when a reindex occurs during an active transaction, both as a result of the # transaction's actions as well as the result of the HEAD's actions. In order # to keep this test quick, it's easier to restart and hit the known # reindexing at 17 keys vs. attempting to hit the second-level reindex which # can occur as early as 18 keys and as late as 4097 (256*16+1) keys. { my $dbm_factory = new_dbm( locking => 1, autoflush => 1, num_txns => 16, ); while ( my $dbm_maker = $dbm_factory->() ) { my $db1 = $dbm_maker->(); next unless $db1->supports( 'transactions' ); my $db2 = $dbm_maker->(); $db1->{x} = 'y'; is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" ); is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" ); $db1->begin_work; cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); # Add enough keys to force a reindex $db1->{"K$_"} = "V$_" for 1 .. 16; cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); $db1->rollback; cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); ok( !exists $db1->{"K$_"}, "DB1: Key K$_ doesn't exist" ) for 1 .. 16; ok( !exists $db2->{"K$_"}, "DB2: Key K$_ doesn't exist" ) for 1 .. 16; } } { my $dbm_factory = new_dbm( locking => 1, autoflush => 1, num_txns => 16, ); while ( my $dbm_maker = $dbm_factory->() ) { my $db1 = $dbm_maker->(); next unless $db1->supports( 'transactions' ); my $db2 = $dbm_maker->(); $db1->{x} = 'y'; is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" ); is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" ); $db1->begin_work; cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); # Add enough keys to force a reindex $db1->{"K$_"} = "V$_" for 1 .. 16; cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); $db1->commit; cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], ['x', (map { "K$_" } 1 .. 16)], "DB2 keys correct" ); ok( exists $db1->{"K$_"}, "DB1: Key K$_ doesn't exist" ) for 1 .. 16; ok( exists $db2->{"K$_"}, "DB2: Key K$_ doesn't exist" ) for 1 .. 16; } } done_testing; DBM-Deep-2.0013/t/46_blist_reindex.t000444001750001750 410012641624315 15533 0ustar00robrob000000000000# This test (and accompanying patch) was submitted by Father Chrysostomos (sprout@cpan.org) use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); { my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); ok eval { for ( # the checksums of all these begin with ^@: qw/ s340l 1970 thronos /, "\320\277\320\276\320\262\320\265\320\273\320\265\320\275". "\320\275\320\276\320\265", qw/ mr094 despite geographically binding bed handmaiden infer lela infranarii lxv evtropia recognizes maladies / ) { $db->{$_} = undef; } 1; }, '2 indices can be created at once'; is_deeply [sort keys %$db], [ sort qw/ s340l 1970 thronos /, "\320\277\320\276\320\262\320\265\320\273\320\265\320\275". "\320\275\320\276\320\265", qw/ mr094 despite geographically binding bed handmaiden infer lela infranarii lxv evtropia recognizes maladies / ], 'and the keys were stored correctly'; } } { my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); ok eval { for ( # the checksums of all these begin with ^@^@^@: qw/ dzqtz aqkdqz cxzysd czclmy ktajsi kvlybo kyxowd lvlsda lyzfdi mbethb mcoqeq VMPJC ATZMZZ AXXJDX BXUUFN EIVTII FMOKOI HITVDG JSSJSZ JXQPFK LCVVXW / ) { $db->{$_} = undef; } 1; }, 'multiple nested indices can be created at once'; is_deeply [sort keys %$db], [ sort qw/ dzqtz aqkdqz cxzysd czclmy ktajsi kvlybo kyxowd lvlsda lyzfdi mbethb mcoqeq VMPJC ATZMZZ AXXJDX BXUUFN EIVTII FMOKOI HITVDG JSSJSZ JXQPFK LCVVXW / ], 'and the keys were stored correctly'; } } done_testing; DBM-Deep-2.0013/t/47_odd_reference_behaviors.t000444001750001750 357512641624315 17546 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use Test::Deep; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); # This is bug #34819, reported by EJS { my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); my $bar = bless { foo => 'ope' }, 'Foo'; eval { $db->{bar} = $bar; $db->{bar} = $bar; }; if ( $@ ) { warn $@ } ok(!$@, "repeated object assignment"); isa_ok($db->{bar}, 'Foo'); } } done_testing; __END__ # This is bug #29957, reported by HANENKAMP { my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); $db->{foo} = []; for my $value ( 1 .. 3 ) { lives_ok { my $ref = $db->{foo}; push @$ref, $value; $db->{foo} = $ref; } "Successfully added value $value"; } cmp_deeply( [1,2,3], noclass($db->{foo}), "Everything looks ok" ); } } # This is bug #33863, reported by PJS { my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); $db->{foo} = [ 42 ]; my $foo = shift @{ $db->{foo} }; cmp_ok( @{ $db->{foo} }, '==', 0, "Shifting a scalar leaves no values" ); cmp_ok( $foo, '==', 42, "... And the value is correct." ); $db->{bar} = [ [] ]; my $bar = shift @{ $db->{bar} }; cmp_ok( @{ $db->{bar} }, '==', 0, "Shifting an arrayref leaves no values" ); $db->{baz} = { foo => [ 1 .. 3 ] }; $db->{baz2} = [ $db->{baz} ]; my $baz2 = shift @{ $db->{baz2} }; cmp_ok( @{ $db->{baz2} }, '==', 0, "Shifting an arrayref leaves no values" ); ok( exists $db->{baz}{foo} ); ok( exists $baz2->{foo} ); } } done_testing; DBM-Deep-2.0013/t/14_filter.t000444001750001750 440612641624315 14171 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); sub my_filter_store_key { return 'MYFILTER' . $_[0]; } sub my_filter_store_value { return 'MYFILTER' . $_[0]; } sub my_filter_fetch_key { $_[0] =~ s/^MYFILTER//; return $_[0]; } sub my_filter_fetch_value { $_[0] =~ s/^MYFILTER//; return $_[0]; } my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); ok( !$db->set_filter( 'floober', sub {} ), "floober isn't a value filter key" ); ## # First try store filters only (values will be unfiltered) ## ok( $db->set_filter( 'store_key', \&my_filter_store_key ), "set the store_key filter" ); ok( $db->set_filter( 'store_value', \&my_filter_store_value ), "set the store_value filter" ); $db->{key1} = "value1"; $db->{key2} = "value2"; is($db->{key1}, "MYFILTERvalue1", "The value for key1 was filtered correctly" ); is($db->{key2}, "MYFILTERvalue2", "The value for key2 was filtered correctly" ); ## # Now try fetch filters as well ## ok( $db->set_filter( 'fetch_key', \&my_filter_fetch_key ), "Set the fetch_key filter" ); ok( $db->set_filter( 'fetch_value', \&my_filter_fetch_value), "Set the fetch_value filter" ); is($db->{key1}, "value1", "Fetchfilters worked right"); is($db->{key2}, "value2", "Fetchfilters worked right"); ## # Try fetching keys as well as values ## cmp_bag( [ keys %$db ], [qw( key1 key2 )], "DB keys correct" ); # Exists and delete tests ok( exists $db->{key1}, "Key1 exists" ); ok( exists $db->{key2}, "Key2 exists" ); is( delete $db->{key1}, 'value1', "Delete returns the right value" ); ok( !exists $db->{key1}, "Key1 no longer exists" ); ok( exists $db->{key2}, "Key2 exists" ); ## # Now clear all filters, and make sure all is unfiltered ## ok( $db->filter_store_key( undef ), "Unset store_key filter" ); ok( $db->filter_store_value( undef ), "Unset store_value filter" ); ok( $db->filter_fetch_key( undef ), "Unset fetch_key filter" ); ok( $db->filter_fetch_value( undef ), "Unset fetch_value filter" ); is( $db->{MYFILTERkey2}, "MYFILTERvalue2", "We get the right unfiltered value" ); } done_testing; DBM-Deep-2.0013/t/96_virtual_functions.t000444001750001750 737212641624315 16501 0ustar00robrob000000000000#vim: ft=perl use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use lib 't/lib'; use_ok( 'DBM::Deep' ); throws_ok { DBM::Deep->new({ _test => 1 }); } qr/lock_exclusive must be implemented in a child class/, 'Must define lock_exclusive in Storage'; { no strict 'refs'; *{"DBM::Deep::Storage::Test::lock_exclusive"} = sub { 1 }; } throws_ok { DBM::Deep->new({ _test => 1 }); } qr/setup must be implemented in a child class/, 'Must define setup in Engine'; { no strict 'refs'; *{"DBM::Deep::Engine::Test::setup"} = sub { 1 }; } throws_ok { DBM::Deep->new({ _test => 1 }); } qr/unlock must be implemented in a child class/, 'Must define unlock in Storage'; { no strict 'refs'; *{"DBM::Deep::Storage::Test::unlock"} = sub { 1 }; } throws_ok { DBM::Deep->new({ _test => 1 }); } qr/flush must be implemented in a child class/, 'Must define flush in Storage'; { no strict 'refs'; *{"DBM::Deep::Storage::Test::flush"} = sub { 1 }; } my $db; lives_ok { $db = DBM::Deep->new({ _test => 1 }); } "We finally have enough defined to instantiate"; throws_ok { $db->lock_shared; } qr/lock_shared must be implemented in a child class/, 'Must define lock_shared in Storage'; { no strict 'refs'; *{"DBM::Deep::Storage::Test::lock_shared"} = sub { 1 }; } lives_ok { $db->lock_shared; } 'We have lock_shared defined'; # Yes, this is ordered for good reason. Think about it. my @methods = ( 'begin_work' => [ Engine => 'begin_work', ], 'rollback' => [ Engine => 'rollback', ], 'commit' => [ Engine => 'commit', ], 'supports' => [ Engine => 'supports', ], 'store' => [ Storage => 'is_writable', Engine => 'write_value', ], 'fetch' => [ Engine => 'read_value', ], 'delete' => [ Engine => 'delete_key', ], 'exists' => [ Engine => 'key_exists', ], # Why is this one's error message bleeding through? 'clear' => [ Engine => 'clear', ], ); # Add the following: # in_txn # If only I could use natatime(). *sighs* while ( @methods ) { my ($entry, $requirements) = splice @methods, 0, 2; while ( @$requirements ) { my ($class, $child_method) = splice @$requirements, 0, 2; throws_ok { $db->$entry( 1 ); } qr/$child_method must be implemented in a child class/, "'$entry' requires '$child_method' to be defined in the '$class'"; { no strict 'refs'; *{"DBM::Deep::${class}::Test::${child_method}"} = sub { 1 }; } } lives_ok { $db->$entry( 1 ); } "Finally have enough for '$entry' to work"; } throws_ok { $db->_engine->sector_type; } qr/sector_type must be implemented in a child class/, 'Must define sector_type in Storage'; { no strict 'refs'; *{"DBM::Deep::Engine::Test::sector_type"} = sub { 'DBM::Deep::Iterator::Test' }; } lives_ok { $db->_engine->sector_type; } 'We have sector_type defined'; throws_ok { $db->first_key; } qr/iterator_class must be implemented in a child class/, 'Must define iterator_class in Iterator'; { no strict 'refs'; *{"DBM::Deep::Engine::Test::iterator_class"} = sub { 'DBM::Deep::Iterator::Test' }; } throws_ok { $db->first_key; } qr/reset must be implemented in a child class/, 'Must define reset in Iterator'; { no strict 'refs'; *{"DBM::Deep::Iterator::Test::reset"} = sub { 1 }; } throws_ok { $db->first_key; } qr/get_next_key must be implemented in a child class/, 'Must define get_next_key in Iterator'; { no strict 'refs'; *{"DBM::Deep::Iterator::Test::get_next_key"} = sub { 1 }; } lives_ok { $db->first_key; } 'Finally have enough for first_key to work.'; done_testing; DBM-Deep-2.0013/t/10_largekeys.t000444001750001750 347712641624315 14675 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); ## # large keys ## my $key1 = "Now is the time for all good men to come to the aid of their country." x 100; my $key2 = "The quick brown fox jumped over the lazy, sleeping dog." x 1000; my $key3 = "Lorem dolor ipsum latinum suckum causum Ium cannotum rememberum squatum." x 1000; $db->put($key1, "value1"); $db->store($key2, "value2"); $db->{$key3} = "value3"; is( $db->{$key1}, 'value1', "Hash retrieval of put()" ); is( $db->{$key2}, 'value2', "Hash retrieval of store()" ); is( $db->{$key3}, 'value3', "Hash retrieval of hashstore" ); is( $db->get($key1), 'value1', "get() retrieval of put()" ); is( $db->get($key2), 'value2', "get() retrieval of store()" ); is( $db->get($key3), 'value3', "get() retrieval of hashstore" ); is( $db->fetch($key1), 'value1', "fetch() retrieval of put()" ); is( $db->fetch($key2), 'value2', "fetch() retrieval of store()" ); is( $db->fetch($key3), 'value3', "fetch() retrieval of hashstore" ); my $test_key = $db->first_key(); ok( ($test_key eq $key1) || ($test_key eq $key2) || ($test_key eq $key3), "First key found", ); $test_key = $db->next_key($test_key); ok( ($test_key eq $key1) || ($test_key eq $key2) || ($test_key eq $key3), "Second key found", ); $test_key = $db->next_key($test_key); ok( ($test_key eq $key1) || ($test_key eq $key2) || ($test_key eq $key3), "Third key found", ); $test_key = $db->next_key($test_key); ok( !$test_key, "No fourth key" ); } done_testing; DBM-Deep-2.0013/t/21_tie_access.t000444001750001750 262312641624315 15003 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); my ($fh, $filename) = new_fh(); { my %hash; tie %hash, 'DBM::Deep', $filename; $hash{key1} = 'value'; is( $hash{key1}, 'value', 'Set and retrieved key1' ); tied( %hash )->_get_self->_engine->storage->close( tied( %hash )->_get_self ); } { my %hash; tie %hash, 'DBM::Deep', $filename; is( $hash{key1}, 'value', 'Set and retrieved key1' ); is( keys %hash, 1, "There's one key so far" ); ok( exists $hash{key1}, "... and it's key1" ); tied( %hash )->_get_self->_engine->storage->close( tied( %hash )->_get_self ); } { throws_ok { tie my @array, 'DBM::Deep', { file => $filename, type => DBM::Deep->TYPE_ARRAY, }; tied( @array )->_get_self->_engine->storage->close( tied( @array )->_get_self ); } qr/DBM::Deep: File type mismatch/, "\$SIG_TYPE doesn't match file's type"; } { my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_ARRAY ); throws_ok { tie my %hash, 'DBM::Deep', { file => $filename, type => DBM::Deep->TYPE_HASH, }; } qr/DBM::Deep: File type mismatch/, "\$SIG_TYPE doesn't match file's type"; $db->_get_self->_engine->storage->close( $db->_get_self ); } done_testing; DBM-Deep-2.0013/t/20_tie.t000444001750001750 312312641624315 13455 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); # testing the various modes of opening a file { my ($fh, $filename) = new_fh(); my %hash; my $db = tie %hash, 'DBM::Deep', $filename; ok(1, "Tied an hash with an array for params" ); } { my ($fh, $filename) = new_fh(); my %hash; my $db = tie %hash, 'DBM::Deep', { file => $filename, }; ok(1, "Tied a hash with a hashref for params" ); } { my ($fh, $filename) = new_fh(); my @array; my $db = tie @array, 'DBM::Deep', $filename; ok(1, "Tied an array with an array for params" ); is( $db->{type}, DBM::Deep->TYPE_ARRAY, "TIE_ARRAY sets the correct type" ); } { my ($fh, $filename) = new_fh(); my @array; my $db = tie @array, 'DBM::Deep', { file => $filename, }; ok(1, "Tied an array with a hashref for params" ); is( $db->{type}, DBM::Deep->TYPE_ARRAY, "TIE_ARRAY sets the correct type" ); } my ($fh, $filename) = new_fh(); throws_ok { tie my %hash, 'DBM::Deep', [ file => $filename ]; } qr/Not a hashref/, "Passing an arrayref to TIEHASH fails"; throws_ok { tie my @array, 'DBM::Deep', [ file => $filename ]; } qr/Not a hashref/, "Passing an arrayref to TIEARRAY fails"; throws_ok { tie my %hash, 'DBM::Deep', undef, file => $filename; } qr/Odd number of parameters/, "Odd number of params to TIEHASH fails"; throws_ok { tie my @array, 'DBM::Deep', undef, file => $filename; } qr/Odd number of parameters/, "Odd number of params to TIEARRAY fails"; done_testing; DBM-Deep-2.0013/t/39_singletons.t000444001750001750 1673012641624315 15123 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use t::common qw( new_dbm new_fh ); sub is_undef { ok(!defined $_[0] || ref $_[0] eq 'DBM::Deep::Null', $_[1]) } use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm( locking => 1, autoflush => 1, ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); SKIP: { skip "This engine doesn't support singletons", 8 unless $db->supports( 'singletons' ); $db->{a} = 1; $db->{foo} = { a => 'b' }; my $x = $db->{foo}; my $y = $db->{foo}; is( $x, $y, "The references are the same" ); delete $db->{foo}; is_undef( $x, "After deleting the DB location, external references are also undef (\$x)" ); is_undef( $y, "After deleting the DB location, external references are also undef (\$y)" ); is( eval { $x + 0 }, undef, "DBM::Deep::Null can be added to." ); is( eval { $y + 0 }, undef, "DBM::Deep::Null can be added to." ); is_undef( $db->{foo}, "The {foo} location is also undef." ); # These shenanigans work to get another hashref # into the same data location as $db->{foo} was. $db->{foo} = {}; delete $db->{foo}; $db->{foo} = {}; $db->{bar} = {}; is_undef( $x, "After re-assigning to {foo}, external references to old values are still undef (\$x)" ); is_undef( $y, "After re-assigning to {foo}, external references to old values are still undef (\$y)" ); my($w,$line); my $file = __FILE__; local $SIG{__WARN__} = sub { $w = $_[0] }; eval { $line = __LINE__; $db->{stext} = $x; }; is $@, "Assignment of stale reference at $file line $line.\n", 'assigning a stale reference to the DB dies w/FATAL warnings'; { no warnings FATAL => "all"; use warnings 'uninitialized'; # non-FATAL $db->{stext} = $x; $line = __LINE__; is $w, "Assignment of stale reference at $file line $line.\n", 'assigning a stale reference back to the DB warns'; } { no warnings 'uninitialized'; $w = undef; $db->{stext} = $x; is $w, undef, 'stale ref assignment warnings can be suppressed'; } eval { $line = __LINE__+1; () = $x->{stit}; }; like $@, qr/^Can't use a stale reference as a HASH at \Q$file\E line(?x: ) $line\.?\n\z/, 'Using a stale reference as a hash dies'; eval { $line = __LINE__+1; () = $x->[28]; }; like $@, qr/^Can't use a stale reference as an ARRAY at \Q$file\E line(?x: ) $line\.?\n\z/, 'Using a stale reference as an array dies'; } } { my $null = bless {}, 'DBM::Deep::Null'; cmp_ok $null, 'eq', undef, 'DBM::Deep::Null compares equal to undef'; cmp_ok $null, '==', undef, 'DBM::Deep::Null compares ==ual to undef'; } SKIP: { skip "What do we do with external references and txns?", 2; my $dbm_factory = new_dbm( locking => 1, autoflush => 1, num_txns => 2, ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); $db->{foo} = { a => 'b' }; my $x = $db->{foo}; $db->begin_work; $db->{foo} = { c => 'd' }; my $y = $db->{foo}; # XXX What should happen here with $x and $y? is( $x, $y ); is( $x->{c}, 'd' ); $db->rollback; } } $dbm_factory = new_dbm( locking => 1, autoflush => 1, external_refs => 1, ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); SKIP: { # Should this feature rely on singleton support? (This question is cur- # ently irrelevant, as all back ends support it.) # skip "This engine doesn't support singletons", 8 # unless $db->supports( 'singletons' ); $db->{a} = 1; $db->{foo} = { a => 'b' }; my $x = $db->{foo}; my $y = $db->{foo}; my $x_str = "$x"; is( $x, $y, "The references are the same in e_r mode" ); delete $db->{foo}; is( $x, $x_str, 'After deletion, external refs still stringify the same way ($x)' ); is( $y, $x_str, 'After deletion, external refs still stringify the same way ($y)' ); is $x->{a}, 'b', 'external refs still point to live data'; undef $x; is $y->{a}, 'b', 'ext refs are still live after other ext refs have gone'; is( $db->{foo}, undef, "The ref in the DB was actually deleted." ); # These shenanigans work to get another hashref # into the same data location as $db->{foo} was. # Or they would if external_refs mode were off. $db->{foo} = {}; delete $db->{foo}; $db->{foo} = {}; $db->{bar} = {}; is( $y->{a}, 'b', "After re-assigning to the DB loc, external refs styll live" ); $db->{stext} = $y; undef $y; is $db->{stext}{a}, 'b', 'assigning a zombie hash to the DB wholly revives it'; # Now we must redo all those tests with arrays $db->{foo} = [ 'swew','squor' ]; $x = $db->{foo}; $y = $db->{foo}; $x_str = "$x"; is( $x, $y, "The references are the same in e_r mode (arrays)" ); delete $db->{foo}; is( $x, $x_str, 'After deletion, ext ary refs still stringify the same way ($x)' ); is( $y, $x_str, 'After deletion, ext ary refs still stringify the same way ($y)' ); is $x->[0], 'swew', 'external ary refs still point to live data'; undef $x; is $y->[0], 'swew', 'ext ary refs are still live after other ext refs have gone'; is( $db->{foo}, undef, "The ary ref in the DB was actually deleted." ); # These shenanigans work to get another ref # into the same data location as $db->{foo} was. # Or they would if external_refs mode were off. $db->{foo} = []; delete $db->{foo}; $db->{foo} = []; $db->{bar} = []; is( $y->[1], 'squor', "After re-assigning to the DB loc, ext ary refs styll live" ); $db->{stext} = $y; undef $y; is $db->{stext}[1], 'squor', 'assigning a zombie array to the DB wholly revives it'; } } # Make sure that global destruction triggers the freeing of externally ref- # erenced aggregates. { my ($fh, $filename) = new_fh(); (my $esc_filename = $filename) =~ s/([\\'])/\\$1/g; system $^X, '-Mblib', # We must use package variables here, to avoid freeing them before # global destruction. '-e use DBM::Deep;', "-e tie %db, 'DBM::Deep', file => '$esc_filename', external_refs => 1;", '-e $db{foo} = ["hello"];', '-e $db{bar} = {"olleh"=>1};', '-e $a = $db{foo};', '-e $b = $db{bar};', '-e delete $db{foo};', '-e delete $db{bar};', ; # And in case a future version does not write over freed sectors: system $^X, '-Mblib', '-e use DBM::Deep;', "-e tie %db, 'DBM::Deep', file => '$esc_filename', external_refs => 1;", '-e $db{foo} = ["goodybpe", 1,2,3,5,56];', ; local $/; my $db = <$fh>; unlike $db, qr/hello/, 'global destruction frees externally referenced arrays'; unlike $db, qr/olleh/, 'global destruction frees externally referenced hashes'; } done_testing; DBM-Deep-2.0013/t/04_array.t000444001750001750 2532212641624315 14041 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); ## # basic put/get/push ## $db->[0] = "elem1"; $db->push( "elem2" ); $db->put(2, "elem3"); $db->store(3, "elem4"); $db->unshift("elem0"); is( $db->[0], 'elem0', "Array get for shift works" ); is( $db->[1], 'elem1', "Array get for array set works" ); is( $db->[2], 'elem2', "Array get for push() works" ); is( $db->[3], 'elem3', "Array get for put() works" ); is( $db->[4], 'elem4', "Array get for store() works" ); is( $db->get(0), 'elem0', "get() for shift() works" ); is( $db->get(1), 'elem1', "get() for array set works" ); is( $db->get(2), 'elem2', "get() for push() works" ); is( $db->get(3), 'elem3', "get() for put() works" ); is( $db->get(4), 'elem4', "get() for store() works" ); is( $db->fetch(0), 'elem0', "fetch() for shift() works" ); is( $db->fetch(1), 'elem1', "fetch() for array set works" ); is( $db->fetch(2), 'elem2', "fetch() for push() works" ); is( $db->fetch(3), 'elem3', "fetch() for put() works" ); is( $db->fetch(4), 'elem4', "fetch() for store() works" ); is( $db->length, 5, "... and we have five elements" ); is( $db->[-1], $db->[4], "-1st index is 4th index" ); is( $db->[-2], $db->[3], "-2nd index is 3rd index" ); is( $db->[-3], $db->[2], "-3rd index is 2nd index" ); is( $db->[-4], $db->[1], "-4th index is 1st index" ); is( $db->[-5], $db->[0], "-5th index is 0th index" ); # This is for Perls older than 5.8.0 because of is()'s prototype { my $v = $db->[-6]; is( $v, undef, "-6th index is undef" ); } is( $db->length, 5, "... and we have five elements after abortive -6 index lookup" ); $db->[-1] = 'elem4.1'; is( $db->[-1], 'elem4.1' ); is( $db->[4], 'elem4.1' ); is( $db->get(4), 'elem4.1' ); is( $db->fetch(4), 'elem4.1' ); throws_ok { $db->[-6] = 'whoops!'; } qr/Modification of non-creatable array value attempted, subscript -6/, "Correct error thrown"; my $popped = $db->pop; is( $db->length, 4, "... and we have four after popping" ); is( $db->[0], 'elem0', "0th element still there after popping" ); is( $db->[1], 'elem1', "1st element still there after popping" ); is( $db->[2], 'elem2', "2nd element still there after popping" ); is( $db->[3], 'elem3', "3rd element still there after popping" ); is( $popped, 'elem4.1', "Popped value is correct" ); my $shifted = $db->shift; is( $db->length, 3, "... and we have three after shifting" ); is( $db->[0], 'elem1', "0th element still there after shifting" ); is( $db->[1], 'elem2', "1st element still there after shifting" ); is( $db->[2], 'elem3', "2nd element still there after shifting" ); is( $db->[3], undef, "There is no third element now" ); is( $shifted, 'elem0', "Shifted value is correct" ); ## # delete ## my $deleted = $db->delete(0); is( $db->length, 3, "... and we still have three after deleting" ); is( $db->[0], undef, "0th element now undef" ); is( $db->[1], 'elem2', "1st element still there after deleting" ); is( $db->[2], 'elem3', "2nd element still there after deleting" ); is( $deleted, 'elem1', "Deleted value is correct" ); is( $db->delete(99), undef, 'delete on an element not in the array returns undef' ); is( $db->length, 3, "... and we still have three after a delete on an out-of-range index" ); is( delete $db->[99], undef, 'DELETE on an element not in the array returns undef' ); is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range index" ); is( $db->delete(-99), undef, 'delete on an element (neg) not in the array returns undef' ); is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" ); is( delete $db->[-99], undef, 'DELETE on an element (neg) not in the array returns undef' ); is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" ); $deleted = $db->delete(-2); is( $db->length, 3, "... and we still have three after deleting" ); is( $db->[0], undef, "0th element still undef" ); is( $db->[1], undef, "1st element now undef" ); is( $db->[2], 'elem3', "2nd element still there after deleting" ); is( $deleted, 'elem2', "Deleted value is correct" ); $db->[1] = 'elem2'; ## # exists ## ok( $db->exists(1), "The 1st value exists" ); ok( !$db->exists(0), "The 0th value doesn't exist" ); ok( !$db->exists(22), "The 22nd value doesn't exists" ); ok( $db->exists(-1), "The -1st value does exists" ); ok( !$db->exists(-22), "The -22nd value doesn't exists" ); ## # clear ## ok( $db->clear(), "clear() returns true if the file was ever non-empty" ); is( $db->length(), 0, "After clear(), no more elements" ); is( $db->pop, undef, "pop on an empty array returns undef" ); is( $db->length(), 0, "After pop() on empty array, length is still 0" ); is( $db->shift, undef, "shift on an empty array returns undef" ); is( $db->length(), 0, "After shift() on empty array, length is still 0" ); is( $db->unshift( 1, 2, 3 ), 3, "unshift returns the number of elements in the array" ); is( $db->unshift( 1, 2, 3 ), 6, "unshift returns the number of elements in the array" ); is( $db->push( 1, 2, 3 ), 9, "push returns the number of elements in the array" ); is( $db->length(), 9, "After unshift and push on empty array, length is now 9" ); $db->clear; ## # push with non-true values ## $db->push( 'foo', 0, 'bar', undef, 'baz', '', 'quux' ); is( $db->length, 7, "7-element push results in seven elements" ); is( $db->[0], 'foo', "First element is 'foo'" ); is( $db->[1], 0, "Second element is 0" ); is( $db->[2], 'bar', "Third element is 'bar'" ); is( $db->[3], undef, "Fourth element is undef" ); is( $db->[4], 'baz', "Fifth element is 'baz'" ); is( $db->[5], '', "Sixth element is ''" ); is( $db->[6], 'quux', "Seventh element is 'quux'" ); $db->clear; ## # multi-push ## $db->push( 'elem first', "elem middle", "elem last" ); is( $db->length, 3, "3-element push results in three elements" ); is($db->[0], "elem first", "First element is 'elem first'"); is($db->[1], "elem middle", "Second element is 'elem middle'"); is($db->[2], "elem last", "Third element is 'elem last'"); ## # splice with length 1 ## my @returned = $db->splice( 1, 1, "middle A", "middle B" ); is( scalar(@returned), 1, "One element was removed" ); is( $returned[0], 'elem middle', "... and it was correctly removed" ); is($db->length(), 4); is($db->[0], "elem first"); is($db->[1], "middle A"); is($db->[2], "middle B"); is($db->[3], "elem last"); ## # splice with length of 0 ## @returned = $db->splice( -1, 0, "middle C" ); is( scalar(@returned), 0, "No elements were removed" ); is($db->length(), 5); is($db->[0], "elem first"); is($db->[1], "middle A"); is($db->[2], "middle B"); is($db->[3], "middle C"); is($db->[4], "elem last"); ## # splice with length of 3 ## my $returned = $db->splice( 1, 3, "middle ABC" ); is( $returned, 'middle C', "Just the last element was returned" ); is($db->length(), 3); is($db->[0], "elem first"); is($db->[1], "middle ABC"); is($db->[2], "elem last"); @returned = $db->splice( 1 ); is($db->length(), 1); is($db->[0], "elem first"); is($returned[0], "middle ABC"); is($returned[1], "elem last"); $db->push( @returned ); @returned = $db->splice( 1, -1 ); is($db->length(), 2); is($db->[0], "elem first"); is($db->[1], "elem last"); is($returned[0], "middle ABC"); @returned = $db->splice; is( $db->length, 0 ); is( $returned[0], "elem first" ); is( $returned[1], "elem last" ); $db->[0] = [ 1 .. 3 ]; $db->[1] = { a => 'foo' }; is( $db->[0]->length, 3, "Reuse of same space with array successful" ); is( $db->[1]->fetch('a'), 'foo', "Reuse of same space with hash successful" ); # Test autovivification $db->[9999]{bar} = 1; ok( $db->[9999] ); cmp_ok( $db->[9999]{bar}, '==', 1 ); # Test failures throws_ok { $db->fetch( 'foo' ); } qr/Cannot use 'foo' as an array index/, "FETCH fails on an illegal key"; throws_ok { $db->fetch(); } qr/Cannot use an undefined array index/, "FETCH fails on an undefined key"; throws_ok { $db->store( 'foo', 'bar' ); } qr/Cannot use 'foo' as an array index/, "STORE fails on an illegal key"; throws_ok { $db->store(); } qr/Cannot use an undefined array index/, "STORE fails on an undefined key"; throws_ok { $db->delete( 'foo' ); } qr/Cannot use 'foo' as an array index/, "DELETE fails on an illegal key"; throws_ok { $db->delete(); } qr/Cannot use an undefined array index/, "DELETE fails on an undefined key"; throws_ok { $db->exists( 'foo' ); } qr/Cannot use 'foo' as an array index/, "EXISTS fails on an illegal key"; throws_ok { $db->exists(); } qr/Cannot use an undefined array index/, "EXISTS fails on an undefined key"; } # Bug reported by Mike Schilli # Also, RT #29583 reported by HANENKAMP $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); push @{$db}, 3, { foo => 1 }; lives_ok { shift @{$db}; } "Shift doesn't die moving references around"; is( $db->[0]{foo}, 1, "Right hashref there" ); lives_ok { unshift @{$db}, [ 1 .. 3, [ 1 .. 3 ] ]; unshift @{$db}, 1; } "Unshift doesn't die moving references around"; is( $db->[1][3][1], 2, "Right arrayref there" ); is( $db->[2]{foo}, 1, "Right hashref there" ); # Add test for splice moving references around lives_ok { splice @{$db}, 0, 0, 1 .. 3; } "Splice doesn't die moving references around"; is( $db->[4][3][1], 2, "Right arrayref there" ); is( $db->[5]{foo}, 1, "Right hashref there" ); } done_testing; __END__ { # Make sure we do not trigger a deep recursion warning [RT #53575] my $w; local $SIG{__WARN__} = sub { $w = shift }; my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new( file => $filename, fh => $fh, ); my $a = []; my $tmp = $a; for(1..100) { ($tmp) = @$tmp = []; } ok eval { $db->{""} = $a; }, 'deep recursion in array assignment' or diag $@; is $w, undef, 'no warnings with deep recursion in array assignment'; } done_testing; DBM-Deep-2.0013/t/56_unicode.t000444001750001750 216212641624315 14335 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_dbm ); use utf8; use DBM::Deep; my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); SKIP: { skip "This engine does not support Unicode", 1 unless $db->supports( 'unicode' ); my $quote = 'Ἐγένετο δὲ λόγῳ μὲν δημοκρατία, λόγῳ δὲ τοῦ πρώτου ἀνδρὸς ἀρχή.' .' —Θουκυδίδης'; $db->{'тэкст'} = $quote; is join("-", keys %$db), 'тэкст', 'Unicode keys'; is $db->{'тэкст'}, $quote, 'Unicode values'; { no warnings 'utf8'; # extra stress test $db->{"\x{d800}"} = "\x{dc00}"; is join("-", sort keys %$db), "тэкст-\x{d800}", 'Surrogate keys'; is $db->{"\x{d800}"}, "\x{dc00}", 'Surrogate values'; } $db->{feen} = "plare\xff"; $db->{feen} = 'płare'; is $db->{feen}, 'płare', 'values can be upgraded to Unicode'; } } done_testing; DBM-Deep-2.0013/t/25_tie_return_value.t000444001750001750 114212641624315 16254 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); use Scalar::Util qw( reftype ); { my ($fh, $filename) = new_fh(); my %hash; my $obj = tie %hash, 'DBM::Deep', $filename; isa_ok( $obj, 'DBM::Deep' ); is( reftype( $obj ), 'HASH', "... and its underlying representation is an HASH" ); } { my ($fh, $filename) = new_fh(); my @array; my $obj = tie @array, 'DBM::Deep', $filename; isa_ok( $obj, 'DBM::Deep' ); is( reftype( $obj ), 'HASH', "... and its underlying representation is an HASH" ); } done_testing; DBM-Deep-2.0013/t/01_basic.t000444001750001750 106212641624315 13754 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_fh ); diag "Testing DBM::Deep against Perl $] located at $^X"; use_ok( 'DBM::Deep' ); ## # basic file open ## my ($fh, $filename) = new_fh(); my $db = eval { local $SIG{__DIE__}; DBM::Deep->new( $filename ); }; if ( $@ ) { diag "ERROR: $@"; Test::More->builder->BAIL_OUT( "Opening a new file fails." ); } isa_ok( $db, 'DBM::Deep' ); ok(1, "We can successfully open a file!" ); $db->{foo} = 'bar'; is( $db->{foo}, 'bar', 'We can write and read.' ); done_testing; DBM-Deep-2.0013/t/57_old_db.t000444001750001750 76212641624315 14117 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use File::Spec::Functions 'catfile'; use Test::More; use t::common qw( new_fh ); use DBM::Deep; tie my %db, "DBM::Deep", catfile(< t etc db-1-0003 >); is join("-", keys %db), "foo", '1.0003 db has one key'; is "@{$db{foo}}", "1 2 3", 'values in 1.0003 db'; is tied(%db)->db_version, '1.0003', 'db_version on old db'; my ($fh, $filename) = new_fh; is new DBM::Deep file => $filename, fh=>$fh =>->db_version, '2', 'db_version on new db'; done_testing; DBM-Deep-2.0013/t/26_scalar_ref.t000444001750001750 326712641624315 15014 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_dbm new_fh ); use_ok( 'DBM::Deep' ); my $x = 25; my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { { my $db = $dbm_maker->(); throws_ok { $db->{scalarref} = \$x; } qr/Storage of references of type 'SCALAR' is not supported/, 'Storage of scalar refs not supported'; throws_ok { $db->{scalarref} = \\$x; } qr/Storage of references of type 'REF' is not supported/, 'Storage of ref refs not supported'; throws_ok { $db->{scalarref} = sub { 1 }; } qr/Storage of references of type 'CODE' is not supported/, 'Storage of code refs not supported'; throws_ok { my ($fh, $filename) = new_fh; $db->{scalarref} = $fh; } qr/Storage of references of type 'GLOB' is not supported/, 'Storage of glob refs not supported'; $db->{scalar} = $x; TODO: { todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2; lives_ok { $db->{selfref} = \$db->{scalar}; } "Refs to DBM::Deep objects are ok"; is( ${$db->{selfref}}, $x, "A ref to a DBM::Deep object is ok" ); } } { my $db = $dbm_maker->(); is( $db->{scalar}, $x, "Scalar retrieved ok" ); TODO: { todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2; is( ${$db->{scalarref}}, 30, "Scalarref retrieved ok" ); is( ${$db->{selfref}}, 26, "Scalarref to stored scalar retrieved ok" ); } } } done_testing; DBM-Deep-2.0013/t/13_setpack.t000444001750001750 522212641624315 14332 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Config; use Test::More; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); my ($default, $small, $medium, $large); { my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new( file => $filename, autoflush => 1, ); $db->{key1} = "value1"; $db->{key2} = "value2"; $default = (stat($filename))[7]; } { my ($fh, $filename) = new_fh(); { my $db = DBM::Deep->new( file => $filename, autoflush => 1, pack_size => 'medium', ); $db->{key1} = "value1"; $db->{key2} = "value2"; $medium = (stat($filename))[7]; } # This tests the header to verify that the pack_size is really there { my $db = DBM::Deep->new( file => $filename, ); is( $db->{key1}, 'value1', 'Can read key1' ); is( $db->{key2}, 'value2', 'Can read key2' ); } cmp_ok( $medium, '==', $default, "The default is medium" ); } { my ($fh, $filename) = new_fh(); { my $db = DBM::Deep->new( file => $filename, autoflush => 1, pack_size => 'small', ); $db->{key1} = "value1"; $db->{key2} = "value2"; $small = (stat($filename))[7]; } # This tests the header to verify that the pack_size is really there { my $db = DBM::Deep->new( file => $filename, ); is( $db->{key1}, 'value1', 'Can read key1' ); is( $db->{key2}, 'value2', 'Can read key2' ); } cmp_ok( $medium, '>', $small, "medium is greater than small" ); } eval "pack('Q', 0);"; my $haveQ = !$@; SKIP: { skip "Largefile support is not compiled into $^X", 3 unless $haveQ; my ($fh, $filename) = new_fh(); { my $db = DBM::Deep->new( file => $filename, autoflush => 1, pack_size => 'large', ); $db->{key1} = "value1"; $db->{key2} = "value2"; $large = (stat($filename))[7]; } # This tests the header to verify that the pack_size is really there { my $db = DBM::Deep->new( file => $filename, ); is( $db->{key1}, 'value1', 'Can read key1' ); is( $db->{key2}, 'value2', 'Can read key2' ); } cmp_ok( $medium, '<', $large, "medium is smaller than large" ); } #SKIP: { # skip "Largefile support is compiled into $^X", 3 # if $haveQ; # # my ($fh, $filename) = new_fh(); # { # my $db = DBM::Deep->new( # file => $filename, # autoflush => 1, # pack_size => 'large', # ); # } # #} done_testing; DBM-Deep-2.0013/t/38_data_sector_size.t000444001750001750 377612641624315 16245 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_fh ); sub do_stuff { my ($db) = @_; $db->{foo}{bar} = [ 1 .. 3 ]; } sub verify { my ($db) = @_; cmp_ok( $db->{foo}{bar}[2], '==', 3, "Correct value found" ); } use_ok( 'DBM::Deep' ); my %sizes; { my ($fh, $filename) = new_fh(); { my $db = DBM::Deep->new( file => $filename, data_sector_size => 32, ); do_stuff( $db ); } $sizes{32} = -s $filename; { my $db = DBM::Deep->new( file => $filename ); verify( $db ); $db->_get_self->_engine->storage->close( $db->_get_self ); } } { my ($fh, $filename) = new_fh(); { my $db = DBM::Deep->new( file => $filename, data_sector_size => 64, ); do_stuff( $db ); } $sizes{64} = -s $filename; { my $db = DBM::Deep->new( $filename ); verify( $db ); $db->_get_self->_engine->storage->close( $db->_get_self ); } } { my ($fh, $filename) = new_fh(); { my $db = DBM::Deep->new( file => $filename, data_sector_size => 128, ); do_stuff( $db ); } $sizes{128} = -s $filename; { my $db = DBM::Deep->new( $filename ); verify( $db ); $db->_get_self->_engine->storage->close( $db->_get_self ); } } { my ($fh, $filename) = new_fh(); { my $db = DBM::Deep->new( file => $filename, data_sector_size => 256, ); do_stuff( $db ); } $sizes{256} = -s $filename; { my $db = DBM::Deep->new( $filename ); verify( $db ); $db->_get_self->_engine->storage->close( $db->_get_self ); } } cmp_ok( $sizes{256}, '>', $sizes{128}, "Filesize for 256 > filesize for 128" ); cmp_ok( $sizes{128}, '>', $sizes{64}, "Filesize for 128 > filesize for 64" ); cmp_ok( $sizes{64}, '>', $sizes{32}, "Filesize for 64 > filesize for 32" ); done_testing; DBM-Deep-2.0013/t/22_internal_copy.t000444001750001750 415012641624315 15545 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_dbm new_fh ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); $db->import({ hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2", }, hash2 => { subkey3 => 'subvalue3', }, }); is( $db->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" ); is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" ); $db->{copy} = $db->{hash1}; is( $db->{copy}{subkey1}, 'subvalue1', "Value copied correctly" ); is( $db->{copy}{subkey2}, 'subvalue2', "Value copied correctly" ); $db->{copy}{subkey1} = "another value"; is( $db->{copy}{subkey1}, 'another value', "New value is set correctly" ); is( $db->{hash1}{subkey1}, 'another value', "Old value is set to the new one" ); is( scalar(keys %{$db->{hash1}}), 2, "Start with 2 keys in the original" ); is( scalar(keys %{$db->{copy}}), 2, "Start with 2 keys in the copy" ); delete $db->{copy}{subkey2}; is( scalar(keys %{$db->{copy}}), 1, "Now only have 1 key in the copy" ); is( scalar(keys %{$db->{hash1}}), 1, "... and only 1 key in the original" ); $db->{copy} = $db->{hash2}; is( $db->{copy}{subkey3}, 'subvalue3', "After the second copy, we're still good" ); } { my $max_keys = 1000; my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { { my $db = $dbm_maker->(); $db->{foo} = [ 1 .. 3 ]; for ( 0 .. $max_keys ) { $db->{'foo' . $_} = $db->{foo}; } } { my $db = $dbm_maker->(); my $base_offset = $db->{foo}->_base_offset; my $count = -1; for ( 0 .. $max_keys ) { $count = $_; unless ( $base_offset == $db->{'foo'.$_}->_base_offset ) { last; } } is( $count, $max_keys, "We read $count keys" ); } } } done_testing; DBM-Deep-2.0013/t/29_largedata.t000444001750001750 107112641624315 14631 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); my $val1 = "a" x 6000; $db->{foo} = $val1; is( $db->{foo}, $val1, "6000 char value stored and retrieved" ); # delete $db->{foo}; # my $size = -s $filename; # $db->{bar} = "a" x 300; # is( $db->{bar}, 'a' x 300, "New 256 char value is stored" ); # cmp_ok( $size, '==', -s $filename, "Freespace is reused" ); } done_testing; DBM-Deep-2.0013/t/34_transaction_arrays.t000444001750001750 750012641624315 16612 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm( locking => 1, autoflush => 1, num_txns => 16, type => DBM::Deep->TYPE_ARRAY, ); while ( my $dbm_maker = $dbm_factory->() ) { my $db1 = $dbm_maker->(); next unless $db1->supports( 'transactions' ); my $db2 = $dbm_maker->(); $db1->[0] = 'y'; is( $db1->[0], 'y', "Before transaction, DB1's 0 is Y" ); is( $db2->[0], 'y', "Before transaction, DB2's 0 is Y" ); $db1->begin_work; is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" ); is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" ); $db1->[0] = 'z'; is( $db1->[0], 'z', "Within DB1 transaction, DB1's 0 is Z" ); is( $db2->[0], 'y', "Within DB1 transaction, DB2's 0 is still Y" ); $db2->[1] = 'foo'; is( $db2->[1], 'foo', "DB2 set 1 within DB1's transaction, so DB2 can see it" ); ok( !exists $db1->[1], "Since 1 was added after the transaction began, DB1 doesn't see it." ); cmp_ok( scalar(@$db1), '==', 1, "DB1 has 1 element" ); cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" ); $db1->rollback; is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" ); is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" ); is( $db1->[1], 'foo', "After DB1 transaction is over, DB1 can see 1" ); is( $db2->[1], 'foo', "After DB1 transaction is over, DB2 can still see 1" ); cmp_ok( scalar(@$db1), '==', 2, "DB1 now has 2 elements" ); cmp_ok( scalar(@$db2), '==', 2, "DB2 still has 2 elements" ); $db1->begin_work; is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" ); is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" ); $db1->[2] = 'z'; is( $db1->[2], 'z', "Within DB1 transaction, DB1's 2 is Z" ); ok( !exists $db2->[2], "Within DB1 transaction, DB2 cannot see 2" ); cmp_ok( scalar(@$db1), '==', 3, "DB1 has 3 elements" ); cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" ); $db1->commit; is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" ); is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" ); is( $db1->[2], 'z', "After DB1 transaction is over, DB1 can still see 2" ); is( $db2->[2], 'z', "After DB1 transaction is over, DB2 can now see 2" ); cmp_ok( scalar(@$db1), '==', 3, "DB1 now has 2 elements" ); cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 2 elements" ); $db1->begin_work; push @$db1, 'foo'; unshift @$db1, 'bar'; cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" ); cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" ); is( $db1->[0], 'bar' ); is( $db1->[-1], 'foo' ); $db1->rollback; cmp_ok( scalar(@$db1), '==', 3, "DB1 is back to 3 elements" ); cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" ); $db1->begin_work; push @$db1, 'foo'; unshift @$db1, 'bar'; cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" ); cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" ); $db1->commit; cmp_ok( scalar(@$db1), '==', 5, "DB1 is still at 5 elements" ); cmp_ok( scalar(@$db2), '==', 5, "DB2 now has 5 elements" ); is( $db1->[0], 'bar' ); is( $db1->[-1], 'foo' ); is( $db2->[0], 'bar' ); is( $db2->[-1], 'foo' ); $db1->begin_work; @$db1 = (); # clear() cmp_ok( scalar(@$db1), '==', 0, "DB1 now has 0 elements" ); cmp_ok( scalar(@$db2), '==', 5, "DB2 still has 5 elements" ); $db1->rollback; cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" ); cmp_ok( scalar(@$db2), '==', 5, "DB2 still has 5 elements" ); } done_testing; DBM-Deep-2.0013/t/48_autoexport_after_delete.t000444001750001750 263012641624315 17625 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); # Add a self-referencing connection to test export my %struct = ( key1 => "value1", key2 => "value2", array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ], bless( [], 'Apple' ) ], hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2", subkey3 => bless( { sub_obj => bless([ bless([], 'Foo'), ], 'Foo'), sub_obj3 => bless([],'Foo'), }, 'Foo' ), }, ); $db->{foo} = \%struct; my $x = delete $db->{foo}; cmp_deeply( $x, { key1 => "value1", key2 => "value2", array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ], bless( [], 'Apple' ) ], hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2", subkey3 => bless( { sub_obj => bless([ bless([], 'Foo'), ], 'Foo'), sub_obj3 => bless([],'Foo'), }, 'Foo' ), }, }, "Everything matches", ); } done_testing; DBM-Deep-2.0013/t/45_references.t000444001750001750 336212641624315 15031 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm( locking => 1, autoflush => 1, num_txns => 16, ); while ( my $dbm_maker = $dbm_factory->() ) { my $db1 = $dbm_maker->(); next unless $db1->supports( 'transactions' ); my $db2 = $dbm_maker->(); $db1->{foo} = 5; $db1->{bar} = $db1->{foo}; is( $db1->{foo}, 5, "Foo is still 5" ); is( $db1->{bar}, 5, "Bar is now 5" ); $db1->{foo} = 6; is( $db1->{foo}, 6, "Foo is now 6" ); is( $db1->{bar}, 5, "Bar is still 5" ); $db1->{foo} = [ 1 .. 3 ]; $db1->{bar} = $db1->{foo}; is( $db1->{foo}[1], 2, "Foo[1] is still 2" ); is( $db1->{bar}[1], 2, "Bar[1] is now 2" ); $db1->{foo}[3] = 42; is( $db1->{foo}[3], 42, "Foo[3] is now 42" ); is( $db1->{bar}[3], 42, "Bar[3] is also 42" ); delete $db1->{foo}; is( $db1->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" ); $db1->{foo} = $db1->{bar}; $db2->begin_work; delete $db2->{bar}; delete $db2->{foo}; is( $db2->{bar}, undef, "It's deleted in the transaction" ); is( $db1->{bar}[3], 42, "... but not in the main" ); $db2->rollback; # Why hasn't this failed!? Is it because stuff isn't getting deleted as # expected? I need a test that walks the sectors is( $db1->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" ); is( $db2->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" ); delete $db1->{foo}; is( $db1->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" ); } done_testing; __END__ $db2->begin_work; delete $db2->{bar}; $db2->commit; ok( !exists $db1->{bar}, "After commit, bar is gone" ); DBM-Deep-2.0013/t/35_transaction_multiple.t000444001750001750 1043012641624315 17161 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm( locking => 1, autoflush => 1, num_txns => 16, ); while ( my $dbm_maker = $dbm_factory->() ) { my $db1 = $dbm_maker->(); next unless $db1->supports( 'transactions' ); my $db2 = $dbm_maker->(); my $db3 = $dbm_maker->(); $db1->{foo} = 'bar'; is( $db1->{foo}, 'bar', "Before transaction, DB1's foo is bar" ); is( $db2->{foo}, 'bar', "Before transaction, DB2's foo is bar" ); is( $db3->{foo}, 'bar', "Before transaction, DB3's foo is bar" ); $db1->begin_work; is( $db1->{foo}, 'bar', "Before transaction work, DB1's foo is bar" ); is( $db2->{foo}, 'bar', "Before transaction work, DB2's foo is bar" ); is( $db3->{foo}, 'bar', "Before transaction work, DB3's foo is bar" ); $db1->{foo} = 'bar2'; is( $db1->{foo}, 'bar2', "After DB1 foo to bar2, DB1's foo is bar2" ); is( $db2->{foo}, 'bar', "After DB1 foo to bar2, DB2's foo is bar" ); is( $db3->{foo}, 'bar', "After DB1 foo to bar2, DB3's foo is bar" ); $db1->{bar} = 'foo'; ok( exists $db1->{bar}, "After DB1 set bar to foo, DB1's bar exists" ); ok( !exists $db2->{bar}, "After DB1 set bar to foo, DB2's bar doesn't exist" ); ok( !exists $db3->{bar}, "After DB1 set bar to foo, DB3's bar doesn't exist" ); $db2->begin_work; is( $db1->{foo}, 'bar2', "After DB2 transaction begin, DB1's foo is still bar2" ); is( $db2->{foo}, 'bar', "After DB2 transaction begin, DB2's foo is still bar" ); is( $db3->{foo}, 'bar', "After DB2 transaction begin, DB3's foo is still bar" ); ok( exists $db1->{bar}, "After DB2 transaction begin, DB1's bar exists" ); ok( !exists $db2->{bar}, "After DB2 transaction begin, DB2's bar doesn't exist" ); ok( !exists $db3->{bar}, "After DB2 transaction begin, DB3's bar doesn't exist" ); $db2->{foo} = 'bar333'; is( $db1->{foo}, 'bar2', "After DB2 foo to bar2, DB1's foo is bar2" ); is( $db2->{foo}, 'bar333', "After DB2 foo to bar2, DB2's foo is bar333" ); is( $db3->{foo}, 'bar', "After DB2 foo to bar2, DB3's foo is bar" ); $db2->{bar} = 'mybar'; ok( exists $db1->{bar}, "After DB2 set bar to mybar, DB1's bar exists" ); ok( exists $db2->{bar}, "After DB2 set bar to mybar, DB2's bar exists" ); ok( !exists $db3->{bar}, "After DB2 set bar to mybar, DB3's bar doesn't exist" ); is( $db1->{bar}, 'foo', "DB1's bar is still foo" ); is( $db2->{bar}, 'mybar', "DB2's bar is now mybar" ); $db2->{mykey} = 'myval'; ok( !exists $db1->{mykey}, "After DB2 set mykey to myval, DB1's mykey doesn't exist" ); ok( exists $db2->{mykey}, "After DB2 set mykey to myval, DB2's mykey exists" ); ok( !exists $db3->{mykey}, "After DB2 set mykey to myval, DB3's mykey doesn't exist" ); cmp_bag( [ keys %$db1 ], [qw( foo bar )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" ); cmp_bag( [ keys %$db3 ], [qw( foo )], "DB3 keys correct" ); $db1->commit; is( $db1->{foo}, 'bar2', "After DB1 commit, DB1's foo is bar2" ); is( $db2->{foo}, 'bar333', "After DB1 commit, DB2's foo is bar333" ); is( $db3->{foo}, 'bar2', "After DB1 commit, DB3's foo is bar2" ); is( $db1->{bar}, 'foo', "DB1's bar is still foo" ); is( $db2->{bar}, 'mybar', "DB2's bar is still mybar" ); is( $db3->{bar}, 'foo', "DB3's bar is now foo" ); cmp_bag( [ keys %$db1 ], [qw( foo bar )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" ); cmp_bag( [ keys %$db3 ], [qw( foo bar )], "DB3 keys correct" ); $db2->commit; is( $db1->{foo}, 'bar333', "After DB2 commit, DB1's foo is bar333" ); is( $db2->{foo}, 'bar333', "After DB2 commit, DB2's foo is bar333" ); is( $db3->{foo}, 'bar333', "After DB2 commit, DB3's foo is bar333" ); is( $db1->{bar}, 'mybar', "DB1's bar is now mybar" ); is( $db2->{bar}, 'mybar', "DB2's bar is still mybar" ); is( $db3->{bar}, 'mybar', "DB3's bar is now mybar" ); cmp_bag( [ keys %$db1 ], [qw( foo bar mykey )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" ); cmp_bag( [ keys %$db3 ], [qw( foo bar mykey )], "DB3 keys correct" ); } done_testing; DBM-Deep-2.0013/t/common.pm000444001750001750 567512641624315 14052 0ustar00robrob000000000000package # Hide from PAUSE t::common; use strict; use warnings FATAL => 'all'; use base 'Exporter'; our @EXPORT_OK = qw( new_dbm new_fh ); use File::Spec (); use File::Temp qw( tempfile tempdir ); use Fcntl qw( :flock ); my $parent = $ENV{WORK_DIR} || File::Spec->tmpdir; our $dir = tempdir( CLEANUP => 1, DIR => $parent ); sub new_fh { my ($fh, $filename) = tempfile( 'tmpXXXX', DIR => $dir, UNLINK => 1 ); # This is because tempfile() returns a flock'ed $fh on MacOSX. flock $fh, LOCK_UN; return ($fh, $filename); } sub new_dbm { my @args = @_; my ($fh, $filename) = new_fh(); my (@names, @reset_funcs, @extra_args); unless ( $ENV{NO_TEST_FILE} ) { push @names, 'File'; push @reset_funcs, undef; push @extra_args, [ file => $filename, ]; } if ( $ENV{TEST_SQLITE} ) { (undef, my $filename) = new_fh(); push @names, 'SQLite'; push @reset_funcs, sub { require 'DBI.pm'; my $dbh = DBI->connect( "dbi:SQLite:dbname=$filename", '', '', ); my $sql = do { my $filename = 'etc/sqlite_tables.sql'; open my $fh, '<', $filename or die "Cannot open '$filename' for reading: $!\n"; local $/; <$fh> }; foreach my $line ( split ';', $sql ) { $dbh->do( "$line" ) if $line =~ /\S/; } }; push @extra_args, [ dbi => { dsn => "dbi:SQLite:dbname=$filename", user => '', password => '', }, ]; } if ( $ENV{TEST_MYSQL_DSN} ) { push @names, 'MySQL'; push @reset_funcs, sub { require 'DBI.pm'; my $dbh = DBI->connect( $ENV{TEST_MYSQL_DSN}, $ENV{TEST_MYSQL_USER}, $ENV{TEST_MYSQL_PASS}, ); my $sql = do { my $filename = 'etc/mysql_tables.sql'; open my $fh, '<', $filename or die "Cannot open '$filename' for reading: $!\n"; local $/; <$fh> }; foreach my $line ( split ';', $sql ) { $dbh->do( "$line" ) if $line =~ /\S/; } }; push @extra_args, [ dbi => { dsn => $ENV{TEST_MYSQL_DSN}, user => $ENV{TEST_MYSQL_USER}, password => $ENV{TEST_MYSQL_PASS}, }, ]; } return sub { return unless @extra_args; my @these_args = @{ shift @extra_args }; if ( my $reset = shift @reset_funcs ) { $reset->(); } Test::More::diag( "Testing '@{[shift @names]}'\n" ) if $ENV{TEST_VERBOSE}; return sub { DBM::Deep->new( @these_args, @args, @_ ) }; }; } 1; __END__ DBM-Deep-2.0013/t/58_cache.t000444001750001750 63412641624315 13736 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_dbm ); use utf8; use DBM::Deep; my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); $db->{h} = {1,2}; my $h = $db->{h}; undef $h; # now no longer cached $h = $db->{h}; # cached again ok $h, 'stale cache entries are not mistakenly reused'; } done_testing; DBM-Deep-2.0013/t/50_deletes.t000444001750001750 120512641624315 14323 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_dbm ); my $max = 10; use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); my $x = 1; while( $x <= $max ) { eval { delete $db->{borked}{test}; $db->{borked}{test} = 1; }; ok(!$@, "No eval failure after ${x}th iteration"); $x++; } $$db{foo} = []; $$db{bar} = $$db{foo}; delete $$db{foo}; is $$db{foo}, undef, 'deleting a key containing a reference that two keys point two works'; } done_testing; DBM-Deep-2.0013/t/54_output_punct_vars.t000444001750001750 122112641624315 16504 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); my ($fh, $filename) = new_fh(); ok eval { local $,="\t"; my $db = DBM::Deep->new( file => $filename, fh => $fh, ); $db->{34808} = "BVA/DIVISO"; $db->{34887} = "PRIMARYVEN"; }, '$, causes no hiccoughs or 150MB files'; ($fh, $filename) = new_fh(); ok eval { local $\="\n"; my $db = DBM::Deep->new( file => $filename, fh => $fh, ); $db->{foo} = ""; $db->{baz} = "11111"; $db->{foo} = "counterpneumonoultramicroscopicsilicovolcanoconiotically"; $db->{baz}; }, '$\ causes no problems'; done_testing; DBM-Deep-2.0013/t/43_transaction_maximum.t000444001750001750 260712641624315 16771 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use Test::Exception; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $max_txns = 255; my $dbm_factory = new_dbm( num_txns => $max_txns, ); while ( my $dbm_maker = $dbm_factory->() ) { my @dbs = ( $dbm_maker->() ); next unless $dbs[0]->supports('transactions'); my $reached_max; push @dbs, grep { $_ } map { eval { $dbm_maker->() } || # A sysopen failure indicates a problem beyond DBM::Deep’s control, # probably a ‘Too many files open’ error, so it’s no use failing # our test because of that. scalar( $@ =~ /Cannot sysopen file/ && ( $reached_max++ or $max_txns = $_ ), () ) } 2 .. $max_txns-1; # -1 because the head is included in the number if($reached_max) { # of transactions diag "This OS apparently can open only $max_txns files."; } cmp_ok( scalar(@dbs), '==', $max_txns-1, "We could open enough DB handles" ); my %trans_ids; for my $n (0 .. $#dbs) { lives_ok { $dbs[$n]->begin_work } "DB $n can begin_work"; my $trans_id = $dbs[$n]->_engine->trans_id; ok( !exists $trans_ids{ $trans_id }, "DB $n has a unique transaction ID ($trans_id)" ); $trans_ids{ $trans_id } = $n; } } done_testing; DBM-Deep-2.0013/t/32_dash_ell.t000444001750001750 104112641624315 14447 0ustar00robrob000000000000#!/usr/bin/perl -l # Test for interference from -l on the commandline. use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new( $filename ); ## # put/get key ## $db->{key1} = "value1"; is( $db->get("key1"), "value1", "get() works with hash assignment" ); is( $db->fetch("key1"), "value1", "... fetch() works with hash assignment" ); is( $db->{key1}, "value1", "... and hash-access also works" ); done_testing; DBM-Deep-2.0013/t/16_circular.t000444001750001750 625012641624315 14511 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); ## # put/get simple keys ## $db->{key1} = "value1"; $db->{key2} = "value2"; my @keys_1 = sort keys %$db; $db->{key3} = $db->{key1}; my @keys_2 = sort keys %$db; is( @keys_2 + 0, @keys_1 + 1, "Correct number of keys" ); is_deeply( [ @keys_1, 'key3' ], [ @keys_2 ], "Keys still match after circular reference is added", ); $db->{key4} = { 'foo' => 'bar' }; $db->{key5} = $db->{key4}; $db->{key6} = $db->{key5}; my @keys_3 = sort keys %$db; is( @keys_3 + 0, @keys_2 + 3, "Correct number of keys" ); is_deeply( [ @keys_2, 'key4', 'key5', 'key6', ], [ @keys_3 ], "Keys still match after circular reference is added (@keys_3)", ); ## # Insert circular reference ## $db->{circle} = $db; my @keys_4 = sort keys %$db; is( @keys_4 + 0, @keys_3 + 1, "Correct number of keys" ); is_deeply( [ 'circle', @keys_3 ], [ @keys_4 ], "Keys still match after circular reference is added", ); ## # Make sure keys exist in both places ## is( $db->{key1}, 'value1', "The value is there directly" ); is( $db->{circle}{key1}, 'value1', "The value is there in one loop of the circle" ); is( $db->{circle}{circle}{key1}, 'value1', "The value is there in two loops of the circle" ); is( $db->{circle}{circle}{circle}{key1}, 'value1', "The value is there in three loops of the circle" ); ## # Make sure changes are reflected in both places ## $db->{key1} = "another value"; isnt( $db->{key3}, 'another value', "Simple scalars are copied by value" ); is( $db->{key1}, 'another value', "The value is there directly" ); is( $db->{circle}{key1}, 'another value', "The value is there in one loop of the circle" ); is( $db->{circle}{circle}{key1}, 'another value', "The value is there in two loops of the circle" ); is( $db->{circle}{circle}{circle}{key1}, 'another value', "The value is there in three loops of the circle" ); $db->{circle}{circle}{circle}{circle}{key1} = "circles"; is( $db->{key1}, 'circles', "The value is there directly" ); is( $db->{circle}{key1}, 'circles', "The value is there in one loop of the circle" ); is( $db->{circle}{circle}{key1}, 'circles', "The value is there in two loops of the circle" ); is( $db->{circle}{circle}{circle}{key1}, 'circles', "The value is there in three loops of the circle" ); is( $db->{key4}{foo}, 'bar' ); is( $db->{key5}{foo}, 'bar' ); is( $db->{key6}{foo}, 'bar' ); $db->{key4}{foo2} = 'bar2'; is( $db->{key4}{foo2}, 'bar2' ); is( $db->{key5}{foo2}, 'bar2' ); is( $db->{key6}{foo2}, 'bar2' ); $db->{key4}{foo3} = 'bar3'; is( $db->{key4}{foo3}, 'bar3' ); is( $db->{key5}{foo3}, 'bar3' ); is( $db->{key6}{foo3}, 'bar3' ); $db->{key4}{foo4} = 'bar4'; is( $db->{key4}{foo4}, 'bar4' ); is( $db->{key5}{foo4}, 'bar4' ); is( $db->{key6}{foo4}, 'bar4' ); } done_testing; DBM-Deep-2.0013/t/24_autobless.t000444001750001750 1163112641624315 14724 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; { package Foo; sub export { 'export' }; sub foo { 'foo' }; } use Test::More; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm( autobless => 1 ); while ( my $dbm_maker = $dbm_factory->() ) { { my $db = $dbm_maker->(); my $obj = bless { a => 1, b => [ 1 .. 3 ], }, 'Foo'; $db->{blessed} = $obj; is( $db->{blessed}{a}, 1 ); is( $db->{blessed}{b}[0], 1 ); is( $db->{blessed}{b}[1], 2 ); is( $db->{blessed}{b}[2], 3 ); my $obj2 = bless [ { a => 'foo' }, 2, ], 'Foo'; $db->{blessed2} = $obj2; is( $db->{blessed2}[0]{a}, 'foo' ); is( $db->{blessed2}[1], '2' ); $db->{unblessed} = {}; $db->{unblessed}{a} = 1; $db->{unblessed}{b} = []; $db->{unblessed}{b}[0] = 1; $db->{unblessed}{b}[1] = 2; $db->{unblessed}{b}[2] = 3; is( $db->{unblessed}{a}, 1 ); is( $db->{unblessed}{b}[0], 1 ); is( $db->{unblessed}{b}[1], 2 ); is( $db->{unblessed}{b}[2], 3 ); $db->{blessed_long} = bless {}, 'a' x 1000; $db->_get_self->_engine->storage->close( $db->_get_self ); } { my $db = $dbm_maker->(); my $obj = $db->{blessed}; isa_ok( $obj, 'Foo' ); can_ok( $obj, 'export', 'foo' ); ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" ); is( $obj->{a}, 1 ); is( $obj->{b}[0], 1 ); is( $obj->{b}[1], 2 ); is( $obj->{b}[2], 3 ); my $obj2 = $db->{blessed2}; isa_ok( $obj2, 'Foo' ); can_ok( $obj2, 'export', 'foo' ); ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" ); is( $obj2->[0]{a}, 'foo' ); is( $obj2->[1], '2' ); is( $db->{unblessed}{a}, 1 ); is( $db->{unblessed}{b}[0], 1 ); is( $db->{unblessed}{b}[1], 2 ); is( $db->{unblessed}{b}[2], 3 ); $obj->{c} = 'new'; is( $db->{blessed}{c}, 'new' ); isa_ok( $db->{blessed_long}, 'a' x 1000 ); $db->_get_self->_engine->storage->close( $db->_get_self ); } { my $db = $dbm_maker->(); is( $db->{blessed}{c}, 'new' ); my $structure = $db->export(); use Data::Dumper;print Dumper $structure; my $obj = $structure->{blessed}; isa_ok( $obj, 'Foo' ); can_ok( $obj, 'export', 'foo' ); ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" ); is( $obj->{a}, 1 ); is( $obj->{b}[0], 1 ); is( $obj->{b}[1], 2 ); is( $obj->{b}[2], 3 ); my $obj2 = $structure->{blessed2}; isa_ok( $obj2, 'Foo' ); can_ok( $obj2, 'export', 'foo' ); ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" ); is( $obj2->[0]{a}, 'foo' ); is( $obj2->[1], '2' ); is( $structure->{unblessed}{a}, 1 ); is( $structure->{unblessed}{b}[0], 1 ); is( $structure->{unblessed}{b}[1], 2 ); is( $structure->{unblessed}{b}[2], 3 ); $db->_get_self->_engine->storage->close( $db->_get_self ); } { my $db = $dbm_maker->( autobless => 0 ); my $obj = $db->{blessed}; isa_ok( $obj, 'DBM::Deep' ); can_ok( $obj, 'export', 'STORE' ); ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" ); is( $obj->{a}, 1 ); is( $obj->{b}[0], 1 ); is( $obj->{b}[1], 2 ); is( $obj->{b}[2], 3 ); my $obj2 = $db->{blessed2}; isa_ok( $obj2, 'DBM::Deep' ); can_ok( $obj2, 'export', 'STORE' ); ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" ); is( $obj2->[0]{a}, 'foo' ); is( $obj2->[1], '2' ); is( $db->{unblessed}{a}, 1 ); is( $db->{unblessed}{b}[0], 1 ); is( $db->{unblessed}{b}[1], 2 ); is( $db->{unblessed}{b}[2], 3 ); $db->_get_self->_engine->storage->close( $db->_get_self ); } } $dbm_factory = new_dbm( autobless => 1 ); while ( my $dbm_maker = $dbm_factory->() ) { { my $db = $dbm_maker->(); my $obj = bless { a => 1, b => [ 1 .. 3 ], }, 'Foo'; $db->import( { blessed => $obj } ); } { my $db = $dbm_maker->(); my $blessed = $db->{blessed}; isa_ok( $blessed, 'Foo' ); is( $blessed->{a}, 1 ); } } # test blessing hash into short named class (Foo), then re-blessing into # longer named class (FooFoo) and replacing key in db file, then validating # content after that point in file to check for corruption. $dbm_factory = new_dbm( autobless => 1 ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); my $obj = bless {}, 'Foo'; $db->{blessed} = $obj; $db->{after} = "hello"; my $obj2 = bless {}, 'FooFoo'; $db->{blessed} = $obj2; is( $db->{after}, "hello" ); } done_testing; DBM-Deep-2.0013/t/30_already_tied.t000444001750001750 321512641624315 15325 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); { { package My::Tie::Hash; sub TIEHASH { my $class = shift; return bless { }, $class; } } my %hash; tie %hash, 'My::Tie::Hash'; isa_ok( tied(%hash), 'My::Tie::Hash' ); throws_ok { $db->{foo} = \%hash; } qr/Cannot store something that is tied/, "Cannot store tied hashes"; } { { package My::Tie::Array; sub TIEARRAY { my $class = shift; return bless { }, $class; } sub FETCHSIZE { 0 } } my @array; tie @array, 'My::Tie::Array'; isa_ok( tied(@array), 'My::Tie::Array' ); throws_ok { $db->{foo} = \@array; } qr/Cannot store something that is tied/, "Cannot store tied arrays"; } { { package My::Tie::Scalar; sub TIESCALAR { my $class = shift; return bless { }, $class; } } my $scalar; tie $scalar, 'My::Tie::Scalar'; isa_ok( tied($scalar), 'My::Tie::Scalar' ); throws_ok { $db->{foo} = \$scalar; } qr/Storage of references of type 'SCALAR' is not supported/, "Cannot store scalar references, let alone tied scalars"; } } done_testing; DBM-Deep-2.0013/t/19_crossref.t000444001750001750 417012641624315 14535 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); SKIP: { skip "Apparently, we cannot detect a tied scalar?", 1; tie my $foo, 'Tied::Scalar'; throws_ok { $db->{failure} = $foo; } qr/Cannot store something that is tied\./, "tied scalar storage fails"; } { tie my @foo, 'Tied::Array'; throws_ok { $db->{failure} = \@foo; } qr/Cannot store something that is tied\./, "tied array storage fails"; } { tie my %foo, 'Tied::Hash'; throws_ok { $db->{failure} = \%foo; } qr/Cannot store something that is tied\./, "tied hash storage fails"; } # Need to create a second instance of a dbm here, but only of the type # being tested. if(0){ my $db2 = $dbm_maker->(); $db2->import({ hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2", } }); is( $db2->{hash1}{subkey1}, 'subvalue1', "Value1 imported correctly" ); is( $db2->{hash1}{subkey2}, 'subvalue2', "Value2 imported correctly" ); # Test cross-ref nested hash across DB objects throws_ok { $db->{copy} = $db2->{hash1}; } qr/Cannot store values across DBM::Deep files\. Please use export\(\) instead\./, "cross-ref fails"; # This error text is for when internal cross-refs are implemented: # qr/Cannot cross-reference\. Use export\(\) instead\./ my $x = $db2->{hash1}->export; $db->{copy} = $x; } ## # Make sure $db has copy of $db2's hash structure ## # is( $db->{copy}{subkey1}, 'subvalue1', "Value1 copied correctly" ); # is( $db->{copy}{subkey2}, 'subvalue2', "Value2 copied correctly" ); } done_testing; package Tied::Scalar; sub TIESCALAR { bless {}, $_[0]; } sub FETCH{} package Tied::Array; sub TIEARRAY { bless {}, $_[0]; } package Tied::Hash; sub TIEHASH { bless {}, $_[0]; } DBM-Deep-2.0013/t/41_transaction_multilevel.t000444001750001750 771312641624315 17477 0ustar00robrob000000000000use strict; use Test::More; use Test::Deep; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm( locking => 1, autoflush => 1, num_txns => 2, ); while ( my $dbm_maker = $dbm_factory->() ) { my $db1 = $dbm_maker->(); next unless $db1->supports('transactions'); my $db2 = $dbm_maker->(); $db1->{x} = { xy => { foo => 'y' } }; is( $db1->{x}{xy}{foo}, 'y', "Before transaction, DB1's X is Y" ); is( $db2->{x}{xy}{foo}, 'y', "Before transaction, DB2's X is Y" ); cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" ); cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" ); cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" ); cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" ); $db1->begin_work; cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" ); cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" ); cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" ); cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" ); is( $db1->{x}{xy}{foo}, 'y', "After transaction, DB1's X is Y" ); is( $db2->{x}{xy}{foo}, 'y', "After transaction, DB2's X is Y" ); $db1->{x} = { yz => { bar => 30 } }; ok( !exists $db1->{x}{xy}, "DB1: After reassignment of X, X->XY is gone" ); is( $db2->{x}{xy}{foo}, 'y', "DB2: After reassignment of DB1 X, X is Y" ); cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" ); cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" ); $db1->rollback; cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" ); cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" ); cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" ); cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" ); is( $db1->{x}{xy}{foo}, 'y', "Before transaction, DB1's X is Y" ); is( $db2->{x}{xy}{foo}, 'y', "Before transaction, DB2's X is Y" ); $db1->begin_work; cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" ); cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" ); cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" ); cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" ); is( $db1->{x}{xy}{foo}, 'y', "After transaction, DB1's X is Y" ); is( $db2->{x}{xy}{foo}, 'y', "After transaction, DB2's X is Y" ); $db1->{x} = { yz => { bar => 30 } }; ok( !exists $db1->{x}{xy}, "DB1: After reassignment of X, X->XY is gone" ); is( $db2->{x}{xy}{foo}, 'y', "DB2: After reassignment of DB1 X, X->YZ is Y" ); cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" ); cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" ); $db1->commit; cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" ); cmp_bag( [ keys %{$db2->{x}} ], [qw( yz )], "DB2->X keys correct" ); cmp_bag( [ keys %{$db1->{x}{yz}} ], [qw( bar )], "DB1->X->XY keys correct" ); cmp_bag( [ keys %{$db2->{x}{yz}} ], [qw( bar )], "DB2->X->XY keys correct" ); } done_testing; DBM-Deep-2.0013/t/23_misc.t000444001750001750 267312641624315 13643 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); { my ($fh, $filename) = new_fh(); print $fh "Not a DBM::Deep file"; my $old_fh = select $fh; my $old_af = $|; $| = 1; $| = $old_af; select $old_fh; throws_ok { my $db = DBM::Deep->new( $filename ); } qr/^DBM::Deep: Signature not found -- file is not a Deep DB/, "Only DBM::Deep DB files will be opened"; } my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new( $filename ); $db->{key1} = "value1"; is( $db->{key1}, "value1", "Value set correctly" ); # Testing to verify that the close() will occur if open is called on an open DB. #XXX WOW is this hacky ... $db->_get_self->_engine->storage->open; is( $db->{key1}, "value1", "Value still set after re-open" ); throws_ok { my $db = DBM::Deep->new( 't' ); } qr/^DBM::Deep: Cannot sysopen file 't': /, "Can't open a file we aren't allowed to touch"; { my $db = DBM::Deep->new( file => $filename, locking => 1, ); $db->_get_self->_engine->storage->close( $db->_get_self ); ok( !$db->lock, "Calling lock() on a closed database returns false" ); } { my $db = DBM::Deep->new( file => $filename, locking => 1, ); $db->lock; $db->_get_self->_engine->storage->close( $db->_get_self ); ok( !$db->unlock, "Calling unlock() on a closed database returns false" ); } done_testing; DBM-Deep-2.0013/t/18_export.t000444001750001750 317312641624315 14231 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my %struct = ( key1 => "value1", key2 => "value2", array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ] ], hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2", subkey3 => bless( { sub_obj => bless([ bless([], 'Foo'), ], 'Foo'), sub_obj2 => bless([], 'Foo'), }, 'Foo' ), }, ); my $dbm_factory = new_dbm( autobless => 1 ); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); ## # Create structure in DB ## $db->import( \%struct ); ## # Export entire thing ## my $compare = $db->export(); cmp_deeply( $compare, { key1 => "value1", key2 => "value2", array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ] ], hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2", subkey3 => bless( { sub_obj => bless([ bless([], 'Foo'), ], 'Foo'), sub_obj2 => bless([], 'Foo'), }, 'Foo' ), }, }, "Everything matches", ); isa_ok( tied(%{$db->{hash1}{subkey3}})->export, 'Foo' ); isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj}})->export, 'Foo' ); isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj}[0]})->export, 'Foo' ); isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj2}})->export, 'Foo' ); } done_testing; DBM-Deep-2.0013/t/33_transactions.t000444001750001750 2112312641624315 15430 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Deep; use Test::Exception; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm( locking => 1, autoflush => 1, num_txns => 16, ); while ( my $dbm_maker = $dbm_factory->() ) { my $db1 = $dbm_maker->(); next unless $db1->supports( 'transactions' ); my $db2 = $dbm_maker->(); $db1->{x} = 'y'; is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" ); is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" ); cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); throws_ok { $db1->rollback; } qr/Cannot rollback without an active transaction/, "Attempting to rollback without a transaction throws an error"; throws_ok { $db1->commit; } qr/Cannot commit without an active transaction/, "Attempting to commit without a transaction throws an error"; $db1->begin_work; throws_ok { $db1->begin_work; } qr/Cannot begin_work within an active transaction/, "Attempting to begin_work within a transaction throws an error"; lives_ok { $db1->rollback; } "Rolling back an empty transaction is ok."; cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); $db1->begin_work; lives_ok { $db1->commit; } "Committing an empty transaction is ok."; cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); $db1->begin_work; cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" ); is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" ); $db2->{x} = 'a'; is( $db1->{x}, 'y', "Within DB1 transaction, DB1's X is still Y" ); is( $db2->{x}, 'a', "Within DB1 transaction, DB2's X is now A" ); $db1->{x} = 'z'; is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is Z" ); is( $db2->{x}, 'a', "Within DB1 transaction, DB2's X is still A" ); $db1->{z} = 'a'; is( $db1->{z}, 'a', "Within DB1 transaction, DB1's Z is A" ); ok( !exists $db2->{z}, "Since z was added after the transaction began, DB2 doesn't see it." ); $db2->{other_x} = 'foo'; is( $db2->{other_x}, 'foo', "DB2 set other_x within DB1's transaction, so DB2 can see it" ); ok( !exists $db1->{other_x}, "Since other_x was added after the transaction began, DB1 doesn't see it." ); # Reset to an expected value $db2->{x} = 'y'; is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is istill Z" ); is( $db2->{x}, 'y', "Within DB1 transaction, DB2's X is now Y" ); cmp_bag( [ keys %$db1 ], [qw( x z )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" ); $db1->rollback; is( $db1->{x}, 'y', "After rollback, DB1's X is Y" ); is( $db2->{x}, 'y', "After rollback, DB2's X is Y" ); is( $db1->{other_x}, 'foo', "After DB1 transaction is over, DB1 can see other_x" ); is( $db2->{other_x}, 'foo', "After DB1 transaction is over, DB2 can still see other_x" ); $db1->begin_work; cmp_bag( [ keys %$db1 ], [qw( x other_x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" ); is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" ); is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" ); $db1->{x} = 'z'; is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is Z" ); is( $db2->{x}, 'y', "Within DB1 transaction, DB2's X is still Y" ); $db2->{other_x} = 'bar'; is( $db2->{other_x}, 'bar', "DB2 set other_x within DB1's transaction, so DB2 can see it" ); is( $db1->{other_x}, 'foo', "Since other_x was modified after the transaction began, DB1 doesn't see the change." ); $db1->{z} = 'a'; is( $db1->{z}, 'a', "Within DB1 transaction, DB1's Z is A" ); ok( !exists $db2->{z}, "Since z was added after the transaction began, DB2 doesn't see it." ); cmp_bag( [ keys %$db1 ], [qw( x other_x z )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" ); $db1->commit; is( $db1->{x}, 'z', "After commit, DB1's X is Z" ); is( $db2->{x}, 'z', "After commit, DB2's X is Z" ); is( $db1->{z}, 'a', "After commit, DB1's Z is A" ); is( $db2->{z}, 'a', "After commit, DB2's Z is A" ); is( $db1->{other_x}, 'bar', "After commit, DB1's other_x is bar" ); is( $db2->{other_x}, 'bar', "After commit, DB2's other_x is bar" ); $db1->begin_work; cmp_bag( [ keys %$db1 ], [qw( x z other_x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x z other_x )], "DB2 keys correct" ); is( $db1->{x}, 'z', "After commit, DB1's X is Z" ); is( $db2->{x}, 'z', "After commit, DB2's X is Z" ); is( $db1->{z}, 'a', "After commit, DB1's Z is A" ); is( $db2->{z}, 'a', "After commit, DB2's Z is A" ); is( $db1->{other_x}, 'bar', "After begin_work, DB1's other_x is still bar" ); is( $db2->{other_x}, 'bar', "After begin_work, DB2's other_x is still bar" ); delete $db2->{other_x}; ok( !exists $db2->{other_x}, "DB2 deleted other_x in DB1's transaction, so it can't see it anymore" ); is( $db1->{other_x}, 'bar', "Since other_x was deleted after the transaction began, DB1 still sees it." ); cmp_bag( [ keys %$db1 ], [qw( x z other_x )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" ); delete $db1->{x}; ok( !exists $db1->{x}, "DB1 deleted X in a transaction, so it can't see it anymore" ); is( $db2->{x}, 'z', "But, DB2 can still see it" ); cmp_bag( [ keys %$db1 ], [qw( other_x z )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" ); $db1->rollback; ok( !exists $db2->{other_x}, "It's still deleted for DB2" ); ok( !exists $db1->{other_x}, "And now DB1 sees the deletion" ); is( $db1->{x}, 'z', "The transaction was rolled back, so DB1 can see X now" ); is( $db2->{x}, 'z', "DB2 can still see it" ); cmp_bag( [ keys %$db1 ], [qw( x z )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" ); $db1->begin_work; delete $db1->{x}; ok( !exists $db1->{x}, "DB1 deleted X in a transaction, so it can't see it anymore" ); is( $db2->{x}, 'z', "But, DB2 can still see it" ); cmp_bag( [ keys %$db1 ], [qw( z )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" ); $db1->commit; ok( !exists $db1->{x}, "The transaction was committed, so DB1 still deleted X" ); ok( !exists $db2->{x}, "DB2 can now see the deletion of X" ); $db1->{foo} = 'bar'; is( $db1->{foo}, 'bar', "Set foo to bar in DB1" ); is( $db2->{foo}, 'bar', "Set foo to bar in DB2" ); cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" ); $db1->begin_work; %$db1 = (); # clear() ok( !exists $db1->{foo}, "Cleared foo" ); is( $db2->{foo}, 'bar', "But in DB2, we can still see it" ); cmp_bag( [ keys %$db1 ], [qw()], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" ); $db1->rollback; is( $db1->{foo}, 'bar', "Rollback means 'foo' is still there" ); is( $db2->{foo}, 'bar', "Rollback means 'foo' is still there" ); cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" ); SKIP: { skip "Optimize tests skipped on Win32", 7 if $^O eq 'MSWin32' || $^O eq 'cygwin'; $db1->optimize; is( $db1->{foo}, 'bar', 'After optimize, everything is ok' ); is( $db2->{foo}, 'bar', 'After optimize, everything is ok' ); is( $db1->{z}, 'a', 'After optimize, everything is ok' ); is( $db2->{z}, 'a', 'After optimize, everything is ok' ); cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" ); cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" ); $db1->begin_work; cmp_ok( $db1->_engine->trans_id, '==', 1, "Transaction ID has been reset after optimize" ); $db1->rollback; } } done_testing; DBM-Deep-2.0013/t/09_deeparray.t000444001750001750 222512641624315 14661 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests" unless $ENV{LONG_TESTS}; use t::common qw( new_dbm ); diag "This test can take up to several minutes to run. Please be patient."; use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY ); while ( my $dbm_maker = $dbm_factory->() ) { my $max_levels = 1000; { my $db = $dbm_maker->(); $db->[0] = []; my $temp_db = $db->[0]; for my $k ( 0 .. $max_levels ) { $temp_db->[$k] = []; $temp_db = $temp_db->[$k]; } $temp_db->[0] = "deepvalue"; } { my $db = $dbm_maker->(); my $cur_level = -1; my $temp_db = $db->[0]; for my $k ( 0 .. $max_levels ) { $cur_level = $k; $temp_db = $temp_db->[$k]; eval { $temp_db->isa( 'DBM::Deep' ) } or last; } is( $cur_level, $max_levels, "We read all the way down to level $cur_level" ); is( $temp_db->[0], "deepvalue", "And we retrieved the value at the bottom of the ocean" ); } } done_testing; DBM-Deep-2.0013/t/55_recursion.t000444001750001750 72612641624315 14703 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; use Test::Exception; use t::common qw( new_dbm ); use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm(); while ( my $dbm_maker = $dbm_factory->() ) { my $db = $dbm_maker->(); my $h = {}; my $tmp = $h; for (1..99) { # 98 is ok, 99 is bad. %$tmp = ("" => {}); $tmp = $tmp->{""}; } lives_ok { $db->{""} = $h; } 'deep recursion causes no errors'; } done_testing; DBM-Deep-2.0013/t/08_deephash.t000444001750001750 340012641624315 14461 0ustar00robrob000000000000use strict; use warnings FATAL => 'all'; use Test::More; plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests" unless $ENV{LONG_TESTS}; use t::common qw( new_dbm ); diag "This test can take up to several minutes to run. Please be patient."; use_ok( 'DBM::Deep' ); my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_HASH ); while ( my $dbm_maker = $dbm_factory->() ) { my $max_levels = 1000; { my $db = $dbm_maker->(); ## # basic deep hash ## $db->{company} = {}; $db->{company}->{name} = "My Co."; $db->{company}->{employees} = {}; $db->{company}->{employees}->{"Henry Higgins"} = {}; $db->{company}->{employees}->{"Henry Higgins"}->{salary} = 90000; is( $db->{company}->{name}, "My Co.", "Set and retrieved a second-level value" ); is( $db->{company}->{employees}->{"Henry Higgins"}->{salary}, 90000, "Set and retrieved a fourth-level value" ); ## # super deep hash ## $db->{base_level} = {}; my $temp_db = $db->{base_level}; for my $k ( 0 .. $max_levels ) { $temp_db->{"level$k"} = {}; $temp_db = $temp_db->{"level$k"}; } $temp_db->{deepkey} = "deepvalue"; } { my $db = $dbm_maker->(); my $cur_level = -1; my $temp_db = $db->{base_level}; for my $k ( 0 .. $max_levels ) { $cur_level = $k; $temp_db = $temp_db->{"level$k"}; eval { $temp_db->isa( 'DBM::Deep' ) } or last; } is( $cur_level, $max_levels, "We read all the way down to level $cur_level" ); is( $temp_db->{deepkey}, "deepvalue", "And we retrieved the value at the bottom of the ocean" ); } } done_testing; DBM-Deep-2.0013/t/etc000755001750001750 012641624315 12625 5ustar00robrob000000000000DBM-Deep-2.0013/t/etc/db-1-0000000444001750001750 304412641624315 14006 0ustar00robrob000000000000DPDBh?dHABL\eOĤ!^DfooD1B/|ecr^8D$ efdaB8# Pou$drL/co,DlengthD2D0D3D1FD2D3DBM-Deep-2.0013/t/etc/db-0-99_04000444001750001750 45012641624315 14150 0ustar00robrob000000000000DPDBhHDBM-Deep-2.0013/t/etc/db-1-0003000444001750001750 304412641624315 14011 0ustar00robrob000000000000DPDBh?dHABL\eOĤ!^DfooD1B/|ecr^8D$ efdaB8# Pou$drL/co,DlengthD2D0D3D1FD2D3DBM-Deep-2.0013/t/etc/db-0-983000444001750001750 605312641624315 13754 0ustar00robrob000000000000DPDBH[base]B@L\eOĤXA dfooB@C)w2-rb EQv$~Y wcٕJ(ׂ D1B@/|ecr^8D DlengthD2D3DBM-Deep-2.0013/t/lib000755001750001750 012641624315 12620 5ustar00robrob000000000000DBM-Deep-2.0013/t/lib/DBM000755001750001750 012641624315 13222 5ustar00robrob000000000000DBM-Deep-2.0013/t/lib/DBM/Deep000755001750001750 012641624315 14077 5ustar00robrob000000000000DBM-Deep-2.0013/t/lib/DBM/Deep/Iterator000755001750001750 012641624315 15670 5ustar00robrob000000000000DBM-Deep-2.0013/t/lib/DBM/Deep/Iterator/Test.pm000444001750001750 17612641624315 17266 0ustar00robrob000000000000package DBM::Deep::Iterator::Test; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Iterator ); 1; __END__ DBM-Deep-2.0013/t/lib/DBM/Deep/Storage000755001750001750 012641624315 15503 5ustar00robrob000000000000DBM-Deep-2.0013/t/lib/DBM/Deep/Storage/Test.pm000444001750001750 25212641624315 17074 0ustar00robrob000000000000package DBM::Deep::Storage::Test; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Storage ); sub new { return bless { }, shift; } 1; __END__ DBM-Deep-2.0013/t/lib/DBM/Deep/Engine000755001750001750 012641624315 15304 5ustar00robrob000000000000DBM-Deep-2.0013/t/lib/DBM/Deep/Engine/Test.pm000444001750001750 37112641624315 16677 0ustar00robrob000000000000package DBM::Deep::Engine::Test; use strict; use warnings FATAL => 'all'; use base qw( DBM::Deep::Engine ); use DBM::Deep::Storage::Test; sub new { return bless { storage => DBM::Deep::Storage::Test->new, }, shift; } 1; __END__