Hash-SharedMem-0.005000755001750001750 013143376061 14203 5ustar00zeframzefram000000000000Hash-SharedMem-0.005/.gitignore000444001750001750 52213143376054 16311 0ustar00zeframzefram000000000000/Build /Makefile /_build /blib /META.json /META.yml /MYMETA.json /MYMETA.yml /Makefile.PL /SIGNATURE /Hash-SharedMem-* /lib/Hash/callchecker0.h /lib/Hash/conftest?.c /lib/Hash/conftest?.o /lib/Hash/conftest??.c /lib/Hash/conftest??.o /lib/Hash/conftest? /lib/Hash/conftest?? /lib/Hash/features /lib/Hash/SharedMem.c /lib/Hash/SharedMem.o Hash-SharedMem-0.005/Build.PL000444001750001750 775413143376054 15653 0ustar00zeframzefram000000000000{ use 5.006; } use warnings; use strict; use Module::Build; Module::Build->subclass(code => q{ unless(__PACKAGE__->can("cbuilder")) { *cbuilder = sub { $_[0]->_cbuilder or die "no C support" }; } sub compile_xs { my($self, $file, %args) = @_; require ExtUtils::ParseXS; ExtUtils::ParseXS->VERSION(3.30); return $self->SUPER::compile_xs($file, %args); } sub probed_info { my($self) = @_; my $feat_file = $self->localize_file_path("lib/Hash/features"); my $probe_file = $self->localize_file_path( "lib/Hash/features.probe"); unless($self->up_to_date($probe_file, $feat_file)) { require IO::File; require Data::Dumper; my $probe = do("./$probe_file") or die $@ || "can't read $probe_file: $!"; my $feat_defs = $probe->($self); $self->add_to_cleanup($feat_file); my $feat_fh = IO::File->new($feat_file, "w") or die "can't write $feat_file: $!"; local $Data::Dumper::Terse = 1; $feat_fh->printflush(Data::Dumper::Dumper($feat_defs)) or die "can't write $feat_file: $!"; } my $probed_info = do("./$feat_file") or die $@ || "can't read $feat_file: $!"; return ($probed_info, $feat_file); } sub compile_c { my($self, $file, %args) = @_; my $cc0_h = $self->localize_file_path("lib/Hash/callchecker0.h"); unless(-f $cc0_h) { my $content = eval { local $SIG{__DIE__}; require Devel::CallChecker; Devel::CallChecker->VERSION(0.003); &Devel::CallChecker::callchecker0_h(); } || ""; $self->add_to_cleanup($cc0_h); require IO::File; my $fh = IO::File->new($cc0_h, "w") or die $!; $fh->printflush($content) or die $!; $fh->close or die $!; } unless($args{no_feature_defs}) { my($probed, $probed_file) = $self->probed_info; $args{defines} = { %{$args{defines} || {}}, %{$probed->{defs}}, QWITH_TALLY => 1, }; $obj_file = $self->cbuilder->object_file($file); unless($self->up_to_date($probed_file, $obj_file)) { unlink $obj_file; } } return $self->SUPER::compile_c($file, %args); } sub link_c { no strict "refs"; my($self, $spec) = @_; my($probed, $probed_file) = $self->probed_info; unless($self->up_to_date($probed_file, $spec->{lib_file})) { unlink $spec->{lib_file}; } my $cb = $self->cbuilder; my $cbclass = ref($cb); my $orig_cb_link = $cb->can("link"); local *{"${cbclass}::link"} = sub { my($self, %args) = @_; if($args{module_name} eq "Hash::SharedMem") { my $cc_linkables = eval { local $SIG{__DIE__}; require Devel::CallChecker; Devel::CallChecker->VERSION(0.003); [&Devel::CallChecker::callchecker_linkable]; } || []; $args{objects} = [ @{$args{objects}}, @$cc_linkables, ]; } $args{extra_linker_flags} = [ @{$args{extra_linker_flags} || []}, @{$probed->{libs}}, ]; @_ = ($self, %args); goto &$orig_cb_link; }; $self->SUPER::link_c($spec); } })->new( module_name => "Hash::SharedMem", license => "perl", configure_requires => { "Module::Build" => 0, "perl" => "5.006", "strict" => 0, "warnings" => 0, }, build_requires => { "Data::Dumper" => 0, "Errno" => "1.00", "ExtUtils::CBuilder" => "0.15", "ExtUtils::ParseXS" => "3.30", "File::Temp" => "0.22", "IO::File" => 0, "Module::Build" => 0, "POSIX" => 0, "Scalar::String" => 0, "Test::Builder" => "0.03", "Test::More" => "0.40", "if" => 0, "perl" => "5.006", "strict" => 0, "utf8" => 0, "warnings" => 0, }, build_recommends => { "Devel::CallChecker" => "0.003", }, requires => { "Exporter" => 0, "XSLoader" => 0, "parent" => 0, "perl" => "5.006", "strict" => 0, "warnings" => 0, }, recommends => { "Devel::CallChecker" => "0.003", }, dynamic_config => 0, meta_add => { distribution_type => "module" }, meta_merge => { "meta-spec" => { version => "2" }, resources => { bugtracker => { mailto => "bug-Hash-SharedMem\@rt.cpan.org", web => "https://rt.cpan.org/Public/Dist/". "Display.html?Name=Hash-SharedMem", }, }, }, sign => 1, )->create_build_script; 1; Hash-SharedMem-0.005/Changes000444001750001750 2673113143376054 15666 0ustar00zeframzefram000000000000version 0.005; 2017-08-11 * update to accommodate PERL_OP_PARENT builds of Perl 5.21.11 or later (which is the default from Perl 5.25.1) * on Perl 5.25.3 and later, where a regular hash in scalar context yields the count of items in the hash, make the tied scalar(%shash) behave equivalently * update automatic configuration to not rely on . in @INC, which is no longer necessarily there from Perl 5.25.7 * update for changed S_croak_xs_usage() prototype in ExtUtils::ParseXS 3.30, requiring the new version of that module * skip t/taint.t if the perl empirically doesn't perform taint checks but the script got run anyway (which happens with an unsupported configuration of the Perl core which some people are using in the absence of a supported no-taint configuration) * test that all modules have matching version numbers * in documentation, update the stated Perl version beyond which the Unicode bug in the treatment of filenames might be fixed * no longer include a Makefile.PL in the distribution * in documentation, use four-column indentation for all verbatim material * in META.{yml,json}, point to public bug tracker * rewrite some internal recursive functions to use the cursor system * to perform static assertion in C, rather than a hand-crafted formulation, use Perl's STATIC_ASSERT_DECL() macro (from Perl 5.27.1 onwards) or STATIC_ASSERT_GLOBAL() macro (from Perl 5.21.7 until it was renamed to STATIC_ASSERT_DECL()), with a reserve definition for older Perls * avoid some compiler warnings that arise on Perl 5.6 * use cBOOL() where appropriate * remove a duplicated assignment statement version 0.004; 2015-01-28 * port to Perl 5.21.1, where errno-based error messages (as seen in $!) depend on the state of the locale pragma * port to Perl 5.21.8, where it is necessary to work around bug [perl #123558] to test deparsing * new functions shash_key_min(), shash_key_max(), shash_key_ge(), shash_key_gt(), shash_key_le(), and shash_key_lt(), to iterate over the content of a shared hash, and corresponding ability to iterate a tied hash via each(%shash) and to enumerate it via keys(%shash) et al * new functions shash_keys_array() and shash_keys_hash() to enumerate the keys in a shared hash * new function shash_group_get_hash() to retrieve the full content of a shared hash * new function shash_occupied() to check whether a shared hash is non-empty, and corresponding ability to check occupancy of a tied hash via scalar(%shash) * new function shash_count() to count the items in a shared hash * new function shash_size() to determine approximate size of the content of a shared hash * new function shash_length() to get the length of a value without reifying the value as a string SV * add clearer name shash_exists() for the existing function shash_getd() * make returned reference scalars and tally value scalars unwritable * test that keys and values can contain NULs * test unwritability of returned mode strings * in documentation, clarify that shash_tidy() counts as a write operation * in documentation, correct grammar in the description of shash_open() and the equivalent constructor method version 0.003; 2014-05-05 * bugfix: on Perl 5.6, repair a dodgy workaround that could cause magical (e.g., tainted) arguments to lose their magic flags * bugfix: build custom ops in a way that satisfies an unnecessary assertion in debugging Perl builds * new function shash_idle() to prevent an idle handle keeping an obsolete data file around * when tidying, include a non-zero constant term in the computation of the new file size, to avoid cycling data files very rapidly when the shared hash contains little data * count events for profiling and debugging, counters accessed through new functions shash_tally_get(), shash_tally_zero(), and shash_tally_gzero() * make the constant shash_referential_handle also available as a class method on Hash::SharedMem::Handle * when attempting to unlink a file, other than for cleanup of an operation that died, if unlinking fails for reasons other than ENOENT or EBUSY, report the error, rather than silently ignoring it * cooperate in the tainting system, mainly imitating the taint behaviour of regular file handles * support using the module in multiple threads simultaneously, including, on Perl 5.8.9 and later, duplicating handles for thread spawning * cope on Cygwin, which offers a fraudulent openat(2) et al * avoid a C99 declaration-after-statement construction * avoid using "NULL" for null function pointers, for C compiler portability * be cleverer about the asymmetry of key ranges in the B-tree structure, saving about one key comparison per data operation * use cursors internally, so that the key has to be resolved only once for each combined read-and-write operation (shash_gset() and shash_cset()) * when attempting a data file rollover, if the attempt fails due to a conflicting update from another process, unmap the abortive data file before attempting to unlink it, so that the unlink will succeed on OSes that need a mapped file to remain linked * in documentation, comment on the inefficiency that occurs when the shared hash doesn't fit into RAM * in documentation, comment on the Unicode bug in the treatment of filenames * don't uselessly attempt to hook into B::Deparse on Perls where custom ops aren't registered and so the hook can't work * don't uselessly attempt to hook into B::Deparse for the shash_referential_handle constant which isn't a custom op type * test concurrency with real concurrent racing processes * test that a forked handle works correctly * include magic(5) file, describing the identifying part of the format of shared hash files, in the distribution * manage destruction of shared hash handles through magic rather than a DESTROY method, for a small speedup * restructure the internal representation of directory references, for a small simplification of uses of the references * in test suite, extend to shash_tidy() some patterns of tests that cover most operators and which were missed when shash_tidy() was added to the module * slight refactoring of C code * on systems that lack mmap(2), detect the problem cleanly and report it in a way that CPAN Testers understand * in design document and code, use the more standard term "fanout" instead of "splay" * take todo notes out of code comments version 0.002; 2014-03-25 * new function shash_tidy() to make data file rollover happen at a convenient time * in many error messages, state more specifically and consistently what kind of action has failed * in documentation, consistently describe the content of a shared hash as "content" rather than "contents" version 0.001; 2014-03-23 * bugfix: avoid overflowing a directory entry buffer on OSes where struct dirent is not a suitable size for a buffer * bugfix: avoid overflowing a filename buffer when time exceeds the 32-bit range (a year 2038 problem) or PIDs are larger than 32 bits * ensure reliable behaviour across fork(2), by not holding on to allocated data file space between write operations * create all data files with the same permission bits as the master file, so that the permissions set when the shash was created stick, and the umask at the time of shash operations doesn't matter * attempt to give all data files the same group and owner as the master file, so that permissions behave as consistently as possible * new exported constant shash_referential_handle to indicate whether shared hash handles constitute first-class references to the underlying files * detect non-octet string values for key and value parameters reliably and early, consistently signalling the error * detect non-string values for filename parameters, signalling the error * process get magic on each parameter exactly once per hash operation (though users of the tied interface are at the mercy of the tying infrastructure, which doesn't have such clean behaviour) * when attempting to clean a shash directory, if listing the directory fails, report the error, rather than silently abandoning the cleaning attempt * when attempting to generate a new data file, if the size is so large as to cast to a negative off_t value, detect it early and report EFBIG, rather than going ahead to create the file and detect the error at ftruncate(2) time * if ftruncate(2) reports that a requested file size is too big using errno EINVAL, report it as the more enlightening EFBIG * when attempting to iterate a shash directory, if opening the directory fails, detect it and report the real error, rather than going ahead to fdopendir(3) and detecting its EBADF * when reporting an error including the name of a shash, to match user expectations use the characters of the filename scalar that was supplied upon opening, even though the octets of the scalar's internal representation are what are actually used as the filename * automatically detect and adapt to the machine architecture's line and page size, to improve performance on architectures other than IA32/AMD64 * port to pre-5.14 Perls, back to 5.6 * automatically use the -lrt library on systems where it is required in order to get access to clock_gettime(2) * cope on systems where openat(2) et al are not available, either not defined by the headers, or defined but not functioning * cope on systems where clock_gettime(2) is not available, either not defined by the headers, or defined but not functioning * cope on systems where O_CLOEXEC is not available, either not defined by the headers, or defined but not honoured (or not accepted) by the kernel * when iterating a shash directory, open a new file descriptor rather than duplicate the existing one, avoiding portability problems with F_DUPFD_CLOEXEC * use symbolic constants for file permission bits, for portability to systems where they have non-traditional values * cope on systems where the headers don't define MAP_FAILED * check at compile time that the word data type is of exactly the required size * on Perls that support it, hook into B::Deparse to make the custom ops deparse nicely * many new tests * document the effects of file-level operations on shared hash directories * document the tied(%shash) operator as part of the tied interface * clarify documentation about permitted keys and values * in documentation, mention serialisation and refer to Sereal * perform string equality comparisons more efficiently by specific code separate from ordering comparisons * use more efficient variants of Perl API functions where available * use the Perl-version-dependent matching data type to save PL_tmps_floor, rather than an invariant sufficiently-large type * declare C functions as inline where it'll help for compilers that need the hint * make some printf operations cheaper by taking advantage of Perl's requirement that the C int type is at least 32 bits * shuffle C struct members for better packing on 32-bit systems * small clarifications to design document * slight refactoring of C code * avoid some C compiler warnings version 0.000; 2014-02-27 * initial released version Hash-SharedMem-0.005/DESIGN000444001750001750 4554013143376054 15266 0ustar00zeframzefram000000000000requirements ------------ Objective: key-value store (hash, in Perl terms), with keys and values all being strings, in memory shared between user processes, with no reliance on user processes not hanging/crashing. Keys and values may be restricted to octet strings, but handling arbitrary Unicode strings would be a bonus. The shared hash must not require explicit initialisation. If a user process crashes or hangs, other processes must continue to operate correctly. A user process that has write permission can be trusted to write correctly (although not to complete its write operations). Read and write operations must be atomic. The shared hash must not occupy many times more memory than necessary for the data stored. Read operations must be fast. The shared hash must be efficient when it contains a large number of small items. The shared hash must be capable of handling large values. principles ---------- A shared hash will be referred to as a "shash". There should be no requirement to lock anything in order to read from the shash. This implies that all data representations larger than a word must be functionally immutable: data written and published is never overwritten. This implies that memory cannot be reclaimed by overwriting. Memory can only be reclaimed by being unlinked from the filesystem and unmapped by all user processes. The shash must periodically migrate from one file to another, in the manner of copying gc. Writes must be completed by means of atomically replacing a root pointer, using a conditional-set instruction. Writers must be prepared to retry, in case another writer got in first. This mode of writing makes it easy to implement high-level conditional setting, with a write occurring only if some subset of the shash (up to all of it) is in an expected state. A snapshot of the root pointer acts as a snapshot of the entire shash, permitting reading of a consistent state. ACI semantics are readily achieved. For nice behaviour on SMP systems, data that will be frequently read should where possible be separated from physically-mutable data, in order to go in a separate cache line. (Physically-mutable data can occur within functionally-immutable data structures.) design ------ The whole shash should be encapsulated as a single file. Since it can't actually be just a single file (see below), it should be encapsulated as a directory, which contains all the constituent files. Encapsulation as a directory means that the shash can be referenced as a single filesystem entity, can be renamed as a whole, and generally basic filesystem operations work as desired. Provided that users of the shash keep a file handle open on the directory and use openat(2) et al on the constituent files, rather than repeatedly using a pathname referring to the directory, open handles on the shash will continue to work across the shash being renamed. By having only regular files within the directory, other aspects of filesystem regularity are achieved. The entire shash can live on essentially any kind of filesystem, and deletion of a shash can be accomplished by a standard means (rm -r). However, by virtue of being a directory, the shash cannot be directly unlinked, nor can it be multiply linked, or at least doing either of these would result in filesystem irregularities. Renaming a shash cannot atomically replace either a regular file or another shash. There should be a single master file. It can be a single page and never grow. It must contain a reference to the current data file. Normally there will be only one data file active. The shash's root pointer is contained in the current data file. Periodically the shash content will be migrated from one data file to another, and during the transition two data files will be active. The root pointer in one data file can take a special form to indicate that handoff is in progress. Within each data file, any user (being a potential writer) must be able to allocate lines, which can be easily arranged as atomic modification of a next-line counter. Allocating a line doesn't imply that it is, or will be, usefully filled: the writer might crash or need to abort the write attempt. After an abort, an allocated line can be reused by the same writer for a later write attempt. It is only when data is published, by changing the root pointer to point (directly or indirectly) at it, that it must be well-formed and becomes immutable. Structures are designed for 64-bit systems, and rely on having a 64-bit conditional-set instruction. All sizes are inherently limited by 64-bit addressing. The size terms that matter are: * byte = octet = 8 bits * word = 8 bytes = 64 bits * line is some power of two number of bytes, at least one word * page is some power of two number of bytes, at least one line The line size is meant to match the native cache line size, and the page size is meant to match the native memory page size. These are 64 bytes and 4096 bytes on current amd64 machines. These sizes are parameters to the design. All users of a particular shash must agree on these parameters. All word quantities are in native byte order, and must be word-aligned. They are to be treated as unsigned integers unless otherwise specified. A pointer to a data object is represented as a word quantity. A pointer can only be stored in a data file, and points to a word-aligned object in the same file. It is represented as a byte offset from the start of the data file, and so necessarily has its lowest three bits all zero. A string (key or value) is represented as a structure consisting of a word count of bytes in the string, immediately followed by the string's bytes, followed by a NUL byte. (The terminating NUL is not part of the string, but included to satisfy Perl's requirements for an SV buffer, so that an SV can be constructed to represent the string without needing to copy the string.) The string can contain octets of any value, including NUL; the explicit length is the canonical way to determine where the string ends. A string in the data file cannot contain anything that's not an octet (or, via Perl's aliasing, a Latin-1 character). A collection of keys and values is represented as a btree (actually a B+-tree), in which the keys are sorted lexicographically. The maximum number of entries in a btree node is a parameter to the design, called MAXFANOUT, on which all users of a shash must agree. It must be odd, and between 3 and 255 inclusive. (Lower limit is inherent in btree structure; upper limit is to fit in a byte.) A suggested value for it is 15. Each btree node except for the root node contains between (MAXFANOUT+1)/2 and MAXFANOUT (inclusive) entries. The root node contains between 2 and MAXFANOUT (inclusive) entries if there is at least one layer of btree nodes below it, or between 0 and MAXFANOUT (inclusive) entries if its entries are individual key/value pairs. A btree node begins with a word header, in which bits are allocated thus: 0-5 layer (0 = pointing directly to key/value pairs) 6-7 zero padding 8-15 fanout (range 0 to MAXFANOUT inclusive) 16-63 zero padding (Note: six bits for the layer number is enough to accommodate the maximum possible number of addressable nodes in a btree with the minimum possible fanout. Trees in practice are unlikely to get anywhere near this height.) The node header is immediately followed by an array of entries, as many as indicated by the header. Each entry consists of two words. The first word is a pointer to a string object representing the first (lexicographically earliest) key in the collection represented by the entry. The second word is a pointer to either a btree node of the next layer down (if this node is not level zero) or a string representing a value (if this node is level zero). The key to which the entry refers is either the first key in the collection represented by the subnode, or the key under which the value is stored, respectively. String and btree node objects are permitted to be multiply referenced. (The key arrangement implies that a btree node cannot appear more than once in a single tree, but it is expected that nodes will appear in multiple trees.) It is also permitted for their representations to overlap, with each other or even with the file header, provided that they do not use lines that contain mutable data. (Overlapping isn't very useful, except that the empty btree node and empty string, whose representations are all-bits-zero, can sensibly be aliased to padding in the header.) For compatibility checking purposes, the design parameters (other than endianness) are encapsulated as a word quantity, in which bits are allocated thus: 0-7 log2(line/byte) 8-15 log2(page/byte) 16-23 MAXFANOUT 24-63 zero padding If, in the future, there is any change in the file formats, it should be indicated by setting bits in what is currently zero padding. This might be formulated as setting bit flags, or as changing a version number. ext2's concept of readonly-compatible changes may be useful, but comprehensibility of a shash to old code is not generally a priority. A data file begins with this header: * word: magic number 0xc693dac5ed5e47c2 * word: design parameters * word: total file length in bytes (must be page-aligned, and must match physical file length) * zero pad to line alignment * word: offset of next point in file that may be allocated (must be line-aligned; if equal to total file length then the file is full) * zero pad to line alignment * word: root pointer and handoff flag (see notes below) * zero pad to line alignment The earliest point at which the next-allocation word can point is the end of the header. A process wishing to write data into the file must allocate space for it by (atomically) moving the next-allocation pointer. It owns the lines located between the old and new positions of the pointer. It may initially write arbitrarily to lines that it owns. However, once a line has been made reachable from the root pointer (by containing (part of) a reachable object), that line must not be written to again, even if it later becomes unreachable from the root. (It remains reachable to anyone who read the root pointer when it was reachable.) A process may give back allocated lines, by moving the next-allocation pointer backwards. Such lines must not have been made reachable (i.e., must still be legal to write to), and (due to the single allocation pointer arrangement) can only be given back when they immediately precede the current next-allocation position. There are no restrictions on the content of file space that is neither part of the header nor has ever been part of a reachable object. This includes parts of reachable lines that don't form objects, lines owned by some process that have not been made reachable, and the unowned lines following the next-allocation position. A data file is identified, among the data files in a single shash, by a word quantity. Identifier zero has special significance, and identifiers are otherwise assigned sequentially by means described below. Data file identifiers are permitted to wrap. This design does not protect against race conditions that span a large fraction of a data file identifier cycle. The root pointer word contains both a pointer and a one-bit flag to control handoff. The handoff flag is bit 0, and the rest of the word must be a valid pointer (with bits 1 and 2 necessarily zero). The pointer is read by masking off the handoff flag from the word. The shash's root is pointed to by the pointer part of the root pointer word in the current data file. The handoff flag governs how a root can be superseded. When the handoff flag is clear, a process wishing to replace the shash root does so by atomically modifying the root pointer word to point to the new root node in the same data file. If a process finds that there is insufficient space in the data file for the data it wants to write, it must initiate handoff, by atomically setting the handoff flag (without changing the root pointer). When the handoff flag has been set, the root pointer word in this data file must not be changed again; the root can then only be replaced by superseding the data file with a new data file. The master file has this form: * word: magic number 0xa58afd185cbf5af7 * word: design parameters * zero pad to line alignment * word: last-allocated data file identifier * zero pad to line alignment * word: identifier of current data file * zero pad to page alignment The data files and master file are arranged in a directory. The directory provides the identity of the shash. The master file is named "iNmv0,m\$%3". The data files are each named "&\"JBLMEgGm" followed by their identifier as 16 lowercase hexadecimal digits. Temporary files created during shash creation can exist in the directory with names beginning "DNaM6okQi;". Files whose names begin with "." may also exist in the directory, and are not part of shash operations: they may be created by revision control systems and the like. No other filenames may exist in the directory. When the handoff flag in the current data file is clear, the choice of current data file referenced by the master file cannot be changed. The shash root can then only be changed by modifying the root pointer word in the current data file. To supersede the current data file, the handoff flag in its root pointer word must first be set. When the handoff flag in the current data file is set, the choice of current data file referenced by the master file may be atomically changed. When the handoff flag in the current data file is set, a process wishing to replace the shash root does so by creating a new data file with the new data and atomically changing the master file to refer to it as the current data file. The process that does this successfully is expected to then unlink the old data file. A process that creates a new data file and fails to install it is expected to unlink its failed data file. The data file identifier zero has a special meaning. Rather than referring to a real data file, if it is current it means that the shash is empty. The zero data file can always be superseded by atomically changing the current file identifier to refer to a real file. Effectively, the zero data file is one in which the root pointer always refers to an empty btree and the handoff flag is always set. When a process wishes to create a new data file, as a prospective replacement for the current data file, it must first assign an identifier for it. This is done by atomically adding one to the "last-allocated data file identifier" word in the master file. This word should initially be zero in a new shash. After incrementing the word, the incremented value is the assigned identifier owned by the incrementing process. If the word reaches all-bits-one (2^63 - 1), the next process wanting a data file identifier must `increment' it to 1, skipping the special identifier 0. Allocating a data file identifier only grants permission to create a file with the allocated identifier; it does not inherently put the file into use, and does not mean that the file will necessarily ever be the shash's current data file. A new data file should be created directly with its proper data file name. This means that it will initially not have the format of a complete data file. This is permitted. A data file (file with data-style filename) is required to be well-formed if and only if it is, or has previously been, current. A process other than the data file's creator cannot allocate space in the file, and must not write to it, unless it is, or has been, current. When superseding the current data file, the current file identifier must only be increased, aside from when the file identifiers wrap. The current file identifier does not have to increase only to the next possible identifier; it is permitted to skip identifiers. It is normal to skip identifiers where concurrent processes are each attempting to switch data file, so that they have competing new files of which only one will be installed. It is never permitted to switch to the special data file identifier zero; that can only be current in a new shash to which content has never been written. Creation of a shash is unavoidably non-atomic, but by following a protocol it can pretend to be atomic. A writer that wants to create a shash must be willing not only to create from scratch, but also to resume an incomplete creation, and to cooperate with simultaneous creators. To create a shash, it is necessary to create the directory, then the master file. The master file must be written as a temporary file and then atomically moved into place (using link(2) semantics to avoid replacing a file already in place). Any file in place with the master filename must be a well-formed master file. The master file must initially use the special data file identifier zero as the current data file identifier. Creators must accept directory creation having already happened. The creator that is credited with creating the shash is the one that put the master file into place, which must be the last step of creation. Data files must not be created until the master file is in place to manage data file identifier allocation. It follows from the above protocol that certain files in the shash directory can be identified as obsolete. Specifically, any temporary file is obsolete once the master file exists, and any data file whose identifier (modulo wrapping) is below that of the current data file is obsolete. Normally these files should be cleaned up by the process that created them or (in the case of a formerly-current data file) the process that superseded them. However, if a process gets interrupted, an obsolete file might persist. Any writer may unlink any identifiably obsolete file, and it is encouraged to periodically do this. If a process wishes to allocate space for temporary data as part of a shash, it can create a file in the shash directory and immediately unlink it. It should be unlinked as soon as it no longer needs to have a name. There are two options for the filename. Firstly, a data file identifier can be allocated, and the resulting data filename used. It is not necessary that the file at all resemble a shash data file in its format or usage. Secondly, a temporary filename can be used, at the risk of collision with other processes. A temporary filename is always interpreted as obsolete in a fully-created shash, and so is liable to be unlinked immediately by another process. compatibility ------------- The design inherently requires that the OS support mmap(2), and that the CPU support atomic reading and conditional writing of 64-bit quantities. When implementing in C, the compiler must provide a 64-bit data type, and must support the atomic operations on it. The Intel-specified built-in __sync_bool_compare_and_swap() suffices for conditional setting; inline assembler and library functions are other possible approaches. Clean filename resolution semantics for shared hashes requires that the OS support openat(2) et al. Hash-SharedMem-0.005/MANIFEST000444001750001750 106113143376054 15471 0ustar00zeframzefram000000000000.gitignore Build.PL Changes DESIGN MANIFEST META.json META.yml README lib/Hash/SharedMem.pm lib/Hash/SharedMem.xs lib/Hash/SharedMem/Handle.pm lib/Hash/features.probe magic t/arg_error.t t/bad_dir.t t/bad_master.t t/chdir.t t/concurrent.t t/deparse.t t/empty.t t/filename.t t/fork.t t/function.t t/get_string.t t/huge.t t/locale.t t/long.t t/magic.t t/many.t t/method.t t/mode.t t/octet.t t/op.t t/perm.t t/pod_cvg.t t/pod_syn.t t/rename.t t/snapshot.t t/taint.t t/tally.t t/threads.t t/tidy.t t/tie.t t/version_synch.t SIGNATURE Added here by Module::Build Hash-SharedMem-0.005/META.json000444001750001750 411213143376054 15761 0ustar00zeframzefram000000000000{ "abstract" : "efficient shared mutable hash", "author" : [ "Andrew Main (Zefram) " ], "dynamic_config" : 0, "generated_by" : "Module::Build version 0.4224", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Hash-SharedMem", "prereqs" : { "build" : { "requires" : { "Data::Dumper" : "0", "Errno" : "1.00", "ExtUtils::CBuilder" : "0.15", "ExtUtils::ParseXS" : "3.30", "File::Temp" : "0.22", "IO::File" : "0", "Module::Build" : "0", "POSIX" : "0", "Scalar::String" : "0", "Test::Builder" : "0.03", "Test::More" : "0.40", "if" : "0", "perl" : "5.006", "strict" : "0", "utf8" : "0", "warnings" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0" } }, "runtime" : { "recommends" : { "Devel::CallChecker" : "0.003" }, "requires" : { "Exporter" : "0", "XSLoader" : "0", "parent" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0" } } }, "provides" : { "Hash::SharedMem" : { "file" : "lib/Hash/SharedMem.pm", "version" : "0.005" }, "Hash::SharedMem::Handle" : { "file" : "lib/Hash/SharedMem/Handle.pm", "version" : "0.005" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Hash-SharedMem@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Hash-SharedMem" }, "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.005", "x_serialization_backend" : "JSON::PP version 2.93" } Hash-SharedMem-0.005/META.yml000444001750001750 234113143376054 15613 0ustar00zeframzefram000000000000--- abstract: 'efficient shared mutable hash' author: - 'Andrew Main (Zefram) ' build_requires: Data::Dumper: '0' Errno: '1.00' ExtUtils::CBuilder: '0.15' ExtUtils::ParseXS: '3.30' File::Temp: '0.22' IO::File: '0' Module::Build: '0' POSIX: '0' Scalar::String: '0' Test::Builder: '0.03' Test::More: '0.40' if: '0' perl: '5.006' strict: '0' utf8: '0' warnings: '0' configure_requires: Module::Build: '0' perl: '5.006' strict: '0' warnings: '0' dynamic_config: 0 generated_by: 'Module::Build version 0.4224, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Hash-SharedMem provides: Hash::SharedMem: file: lib/Hash/SharedMem.pm version: '0.005' Hash::SharedMem::Handle: file: lib/Hash/SharedMem/Handle.pm version: '0.005' recommends: Devel::CallChecker: '0.003' requires: Exporter: '0' XSLoader: '0' parent: '0' perl: '5.006' strict: '0' warnings: '0' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Hash-SharedMem license: http://dev.perl.org/licenses/ version: '0.005' x_serialization_backend: 'CPAN::Meta::YAML version 0.012' Hash-SharedMem-0.005/README000444001750001750 314413143376054 15224 0ustar00zeframzefram000000000000NAME Hash::SharedMem - efficient shared mutable hash DESCRIPTION This module provides a facility for efficiently sharing mutable data between processes on one host. Data is organised as a key/value store, resembling a Perl hash. The keys and values are restricted to octet (Latin-1) strings. Structured objects may be stored by serialising them using a mechanism such as Sereal. The data is represented in files that are mapped into each process's memory space, which for interprocess communication amounts to the processes sharing memory. Processes are never blocked waiting for each other. The use of files means that there is some persistence, with the data continuing to exist when there are no processes with it mapped. The data structure is optimised for the case where all the data fits into RAM. This happens either via buffering of a disk-based filesystem, or as the normal operation of a memory-backed filesystem, in either case as long as there isn't much swapping activity. If RAM isn't large enough, such that the data has to reside mainly on disk and parts of it have to be frequently reread from disk, speed will seriously suffer. The data structure exhibits poor locality of reference, and is not designed to play nicely with filesystem block sizes. INSTALLATION perl Build.PL ./Build ./Build test ./Build install AUTHOR Andrew Main (Zefram) COPYRIGHT Copyright (C) 2014, 2015 PhotoBox Ltd Copyright (C) 2014, 2015, 2017 Andrew Main (Zefram) LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Hash-SharedMem-0.005/SIGNATURE000644001750001750 627313143376061 15636 0ustar00zeframzefram000000000000This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.81. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 577d7e9d65e9863cb69ad9749d773dd6b9b3f618 .gitignore SHA1 dba6b02cd52c2e688d38200246caddd2e53e89cd Build.PL SHA1 9ceea39c5dad108bc019fd70c99d4fa85f02c42e Changes SHA1 e16e3ea134108f3d582235364324e5bb205ac430 DESIGN SHA1 e34010bd58059bf5c28cfc5e82cd3af945fe606f MANIFEST SHA1 1eeb8fdbb3d42e4e19ebe02ddf9da42ca871a8b3 META.json SHA1 6c470e6070250d88f506a762dafe07abcb104a82 META.yml SHA1 c45b047a42165fd7f5d0bf623458ed226a4b7d0a README SHA1 1607fa5f4c664139b13858e568817e9f7436c741 lib/Hash/SharedMem.pm SHA1 114c8eb779cc96aa1749befea76f104a8457a448 lib/Hash/SharedMem.xs SHA1 bc1cee2962e54981ca761d57b9fe7ecdf0c25191 lib/Hash/SharedMem/Handle.pm SHA1 852d4366083afd883c9dc972e139622850948481 lib/Hash/features.probe SHA1 4ac90c7be5579dd9007e8e975352e469cadb6783 magic SHA1 32d46212ff3c6ac27dc3600614a84400aef34d22 t/arg_error.t SHA1 54f8d7ff9d095932684705346a5ca6e1fe735e82 t/bad_dir.t SHA1 5dce241e86219ea896cc17543d3e826af4468d3f t/bad_master.t SHA1 6851f9ff563c3fed5342073fb64089529cd80ed0 t/chdir.t SHA1 1f5ddfe58d4bb6426778141c26dfe99319d0ccd8 t/concurrent.t SHA1 9b1e4e3640a9cb4af685db00c6c788979f6a2ac2 t/deparse.t SHA1 c00104e322b527d90bdb51af1b13f880b44fdc2b t/empty.t SHA1 3ba5f42584e74d6d9736c2e556b34474287a3690 t/filename.t SHA1 84630b104b579ea4b7c193406080792e6de79637 t/fork.t SHA1 4eba3ebab9fcb37e630064eb92bc84b45f05ef85 t/function.t SHA1 62eeccdc1b4f5f465ada6fa144695fc0e8633e26 t/get_string.t SHA1 442c4595003937ba355bf42ba52c4be5f1cf2fb3 t/huge.t SHA1 1c68da91f9b597596f56f9b66e4d5dd829c0ce49 t/locale.t SHA1 9682d98b9c3a395d384c8cd88c7ea105d006ada9 t/long.t SHA1 ced682f263cc05350a3218945cf4f33d660d6307 t/magic.t SHA1 71bbd98b6aea56c25ba2aee72121a96ccce89e33 t/many.t SHA1 6db62f2d6f423219ceec366cba8ce1e8da8df70a t/method.t SHA1 0ee05efbd4a45268ea8d462ccbfb4419b105f52d t/mode.t SHA1 4c8d46235980c06a7040f38035dd97aa92d9e5a6 t/octet.t SHA1 487070bf6c58a82e48b956abccb844aff35fb59b t/op.t SHA1 92d1866993c63b4574e848739081855986010534 t/perm.t SHA1 904d9a4f76525e2303e4b0c168c68230f223c8de t/pod_cvg.t SHA1 65c75abdef6f01a5d1588a307f2ddfe2333dc961 t/pod_syn.t SHA1 773a97fc7cb8a5aa4b577da712fc5fa3db5f0423 t/rename.t SHA1 e2755d1ce1287206536ff8fa632c4cbe33f11505 t/snapshot.t SHA1 d667d1a7ecbb47bc700479c1413944148ee678b0 t/taint.t SHA1 ed32f4e502d404159de502b873fdf18c9c3fa487 t/tally.t SHA1 5fe5aec5c906d730c092db1a9b8ed37e85060391 t/threads.t SHA1 286d642b3b3ec0e6873e0c061a09c54b9dccb9ef t/tidy.t SHA1 8c5df2c17c74e534c730312b6e7fd2a2f1cdd84a t/tie.t SHA1 2226972111b01b83ab605eedb5a3d8c8b41c5a8b t/version_synch.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1 iEYEARECAAYFAlmN/CwACgkQOV9mt2VyAVGyGACfV/7Y8vLayBMc9Z9BtAJ/NDts ZUQAnR1oj7B/kR8yttwqAvn9RVkhBuMT =n9DY -----END PGP SIGNATURE----- Hash-SharedMem-0.005/magic000444001750001750 170013143376054 15343 0ustar00zeframzefram000000000000# This is magic(5) data to let the file(1) utility recognise shared hash # files created by the Hash::SharedMem Perl module. 0 bequad =0xa58afd185cbf5af7 Hash::SharedMem master file, big-endian >8 bequad <0x1000000 >>15 byte >2 \b, line size 2^%d byte >>14 byte >2 \b, page size 2^%d byte >>13 byte &1 >>>13 byte >1 \b, max fanout %d 0 lequad =0xa58afd185cbf5af7 Hash::SharedMem master file, little-endian >8 lequad <0x1000000 >>8 byte >2 \b, line size 2^%d byte >>9 byte >2 \b, page size 2^%d byte >>10 byte &1 >>>10 byte >1 \b, max fanout %d 0 bequad =0xc693dac5ed5e47c2 Hash::SharedMem data file, big-endian >8 bequad <0x1000000 >>15 byte >2 \b, line size 2^%d byte >>14 byte >2 \b, page size 2^%d byte >>13 byte &1 >>>13 byte >1 \b, max fanout %d 0 lequad =0xc693dac5ed5e47c2 Hash::SharedMem data file, little-endian >8 lequad <0x1000000 >>8 byte >2 \b, line size 2^%d byte >>9 byte >2 \b, page size 2^%d byte >>10 byte &1 >>>10 byte >1 \b, max fanout %d Hash-SharedMem-0.005/lib000755001750001750 013143376054 14753 5ustar00zeframzefram000000000000Hash-SharedMem-0.005/lib/Hash000755001750001750 013143376054 15636 5ustar00zeframzefram000000000000Hash-SharedMem-0.005/lib/Hash/SharedMem.pm000444001750001750 11024613143376054 20242 0ustar00zeframzefram000000000000=head1 NAME Hash::SharedMem - efficient shared mutable hash =head1 SYNOPSIS use Hash::SharedMem qw(shash_referential_handle); if(shash_referential_handle) { ... use Hash::SharedMem qw(is_shash check_shash); if(is_shash($arg)) { ... check_shash($arg); use Hash::SharedMem qw(shash_open); $shash = shash_open($filename, "rwc"); use Hash::SharedMem qw( shash_is_readable shash_is_writable shash_mode); if(shash_is_readable($shash)) { ... if(shash_is_writable($shash)) { ... $mode = shash_mode($shash); use Hash::SharedMem qw( shash_exists shash_length shash_get shash_set shash_gset shash_cset); if(shash_exists($shash, $key)) { ... $length = shash_length($shash, $key); $value = shash_get($shash, $key); shash_set($shash, $key, $newvalue); $oldvalue = shash_gset($shash, $key, $newvalue); if(shash_cset($shash, $key, $chkvalue, $newvalue)) { ... use Hash::SharedMem qw( shash_occupied shash_count shash_size shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash); if(shash_occupied($shash)) { ... $count = shash_count($shash); $size = shash_size($shash); $key = shash_key_min($shash); $key = shash_key_max($shash); $key = shash_key_ge($shash, $key); $key = shash_key_gt($shash, $key); $key = shash_key_le($shash, $key); $key = shash_key_lt($shash, $key); $keys = shash_keys_array($shash); $keys = shash_keys_hash($shash); $group = shash_group_get_hash($shash); use Hash::SharedMem qw(shash_snapshot shash_is_snapshot); $snap_shash = shash_snapshot($shash); if(shash_is_snapshot($shash)) { ... use Hash::SharedMem qw(shash_idle shash_tidy); shash_idle($shash); shash_tidy($shash); use Hash::SharedMem qw( shash_tally_get shash_tally_zero shash_tally_gzero); $tally = shash_tally_get($shash); shash_tally_zero($shash); $tally = shash_tally_gzero($shash); =head1 DESCRIPTION This module provides a facility for efficiently sharing mutable data between processes on one host. Data is organised as a key/value store, resembling a Perl hash. The keys and values are restricted to octet (Latin-1) strings. Structured objects may be stored by serialising them using a mechanism such as L. The data is represented in files that are mapped into each process's memory space, which for interprocess communication amounts to the processes sharing memory. Processes are never blocked waiting for each other. The use of files means that there is some persistence, with the data continuing to exist when there are no processes with it mapped. The data structure is optimised for the case where all the data fits into RAM. This happens either via buffering of a disk-based filesystem, or as the normal operation of a memory-backed filesystem, in either case as long as there isn't much swapping activity. If RAM isn't large enough, such that the data has to reside mainly on disk and parts of it have to be frequently reread from disk, speed will seriously suffer. The data structure exhibits poor locality of reference, and is not designed to play nicely with filesystem block sizes. =head2 Consistency and synchronisation A shared hash is held in regular files, grouped in a directory. At all times, the OS-visible state of the files provides a consistent view of the hash's content, from which read and write operations can proceed. It is no problem for a process using the shared hash to crash; other processes, running concurrently or later, will be unimpeded in using the shared hash. It is mainly intended that the shared hash should be held on a memory-backed filesystem, and will therefore only last as long as the machine stays up. However, it can use any filesystem that supports L, including conventional disk filesystems such as ext2. In this case, as long as the OS shuts down cleanly (synching all file writes to the underlying disk), a consistent state of the shared hash will persist between boots, and usage of the shared hash can continue after the OS boots again. Note that only the OS is required to shut down cleanly; it still doesn't matter if user processes crash. Because the OS is likely to reorder file writes when writing them to disk, the instantaneous state of the shared hash's files on disk is generally I guaranteed to be consistent. So if the OS crashes, upon reboot the files are liable to be in an inconsistent state (corrupted). Maintaining consistency across an OS crash is a feature likely to be added to this module in the future. Durability of writes, for which that is a prerequisite, is another likely future addition. =head2 File permissions To read normally from a shared hash requires read and search (execute) permission on the shared hash directory and read permission on all the regular files in the directory. To write normally requires read, write, and search permissions on the directory and read and write permissions on all the regular files. For security purposes, some information about shared hash content can be gleaned by anyone who has read or search permission on the directory, and content can be modified by anyone who has search permission on the directory and write permission on either the directory or any of the regular files. The file permission bits on a shared hash are determined by the circumstances in which it was created, specifically by the umask in effect at the point of creation. As shared hash creation is unavoidably non-atomic, competing creation attempts can cause trouble, and the resulting permissions are only guaranteed if all competing attempts at creation use the same umask. After the shared hash is fully created, subsequently opening it with the create flag set doesn't affect permissions. The directory gets permissions C modified by the creation umask, and the regular files in it get permissions C modified by the creation umask. All the regular files that contain any part of the shared hash content will get the same permission bits. This includes files created long after initial creation of the shared hash, which are created as part of shared hash write operations; the umask in effect at the point of those operations is insignificant. File ownership and group assignment are not so controlled. An attempt is made to give all files the same group assignment and ownership, determined by the creation of the shared hash, but the ability to do so is limited by OS semantics. Typically, users other than the superuser cannot affect ownership, and can only assign files to groups of which they are members. Also, as with permission bits, competing creation attempts can make ownerships and group assignments inconsistent, even if they are generally controllable. Where they can't be freely set, each regular file gets whatever ownership and group assignment arise naturally from the circumstances in which it was created. If multiple users write to a single shared hash, it is to be expected that the constituent files will end up having different owners. It is up to the user to ensure that the varying ownerships combined with the consistent permission bits yield compatible permissions for all intended users of the shared hash. Group-based permissions should work provided that all writers are members of the relevant group. =head2 Filesystem referential integrity If the system calls L et al are supported by the kernel and the C library, then an open shared hash handle contains an OS-supported first-class reference to the shared hash to which it refers. (Specifically, it has a file descriptor referring to the shared hash directory.) In this situation, the reference remains valid regardless of filename changes. The shared hash can be renamed or moved arbitrarily, within the filesystem, or the process can change its current directory or root directory, and the handle remains valid. If these modern system calls are not available, then an open shared hash handle cannot contain a first-class reference to the shared hash directory. Instead it must repeatedly refer to the directory by name. The name supplied to L is resolved to an absolute pathname, so the handle will continue to work if the process changes its current directory. But any renaming of the shared hash, or the process changing its root directory, will cause the handle to fail at the next operation that requires the use of filenames. (This is unlikely to be the very next operation after the pathname becomes invalid.) An attempt is made to ensure that the stored pathname is still correct each time it is used, but there is unavoidably a race condition, whereby some very unluckily timed renaming could cause an operation to be applied to the wrong directory. The means by which shared hash handles reference their directories is indicated by the constant L. When a shared hash is being opened, if it already exists then the name passed to L is resolved just once to determine to what shared hash it refers. If the modern system calls are supported, this yields perfectly clean name resolution semantics. However, if a shared hash does not already exist, its creation cannot currently be so perfectly clean. The name passed to L must be resolved at least twice, once to create the shared hash directory and once to acquire a reference to it (of whichever type). There is unavoidably a race condition here. =head2 File operations Because a shared hash is encapsulated in a directory, rather than being a single non-directory file, the ability to perform file operations on it is limited. Although it can be renamed or moved, under POSIX semantics such a rename can't atomically replace any file other than an empty directory. In particular, it can't atomically replace another shared hash. It also can't be hard-linked to have multiple names. (However, a major use case for L, non-overwriting renaming, can be achieved through L due to the latter's limitations for directories.) Finally, it can't be unlinked. (Linking and unlinking directories are possible for root on some systems, but cause undesirable filesystem irregularities.) A shared hash can be disposed of by applying C to its directory. This is not equivalent to L (C) on a regular file, because it not only removes the object's name but also disrupts its internal structure. If a process has an open handle referring to the shared hash at the time of C, the use of the shared hash through that handle is likely to fail, although probably not immediately. If a process is writing to the shared hash at the time of C, there is a race condition that could prevent the removal from completing. C should therefore only be applied after all processes have finished using the shared hash. A shared hash can be copied by means of C (not mere C), C, or similar means. It is safe to do this while processes have open handles referring to the shared hash, and while processes are reading from it. However, as with most forms of database file, if a process is writing to the shared hash then the file copier is liable to pick up an inconsistent (corrupted) view of the shared hash. Copying should therefore only be attempted at a time when no write operations are being performed. It is acceptable for processes to have the shared hash open in write mode, provided that they do not actually perform any write operation while the copy is being made. A file-level copying operation applied to a shared hash is likely to result in a copy that occupies much more filesystem space than the original. This occurs because most of the time a large part of the main data file is a filesystem hole, not occupying any actual storage. Some copying mechanisms (such as GNU C) can recognise this and avoid allocating unnecessary storage for the copy, but others (such as GNU C) will blindly fill space with a lot of zeroes. If the copy is subsequently used in shared hash write operations, ultimately it will recover from this inefficient block allocation. =head2 Forking If a process is duplicated by L while it holds a shared hash handle, the handle is duplicated with the rest of the process, so both resulting processes have handles referring to the same underlying shared hash. Provided that the duplication did not happen during a shared hash operation, both processes' handles will subsequently work normally, and can be used independently. Things are more difficult if a L happens while a shared hash operation is in progress. This should not normally be possible to achieve from Perl code: arbitrary Perl code should not run during the critical part of an operation. If a shared hash operator is given a tied variable as a parameter, the magic method call for access to that parameter occurs before the critical part, so a L in that method is safe. If a signal is received during a shared hash operation, any signal handler installed in L<%SIG|perlvar/%SIG> will be deferred until the operation is complete, so a L in such a signal handler is also safe. A problematic L should only be achievable by XS code. If a L does happen during the critical part of a shared hash operation, the two resulting handles are liable to interfere if the operation is resumed in both processes. In this case, it is safe for at most one process (which may be either of them) to resume the operation. The other process must neither resume the operation in progress nor make any further use of the handle. It is safe for the non-resuming process to chain a new program with L, to terminate with L<_exit(2)>, or generally to make use of the C library before doing either of those. Attempting to run Perl code would be unwise. On platforms lacking a native L, the Perl function L actually creates a Perl L. In that case the behaviour should be similar to that seen with a real L, as described in the next section. =head2 Threads This module can be used in multiple Perl L simultaneously. The module may be loaded by multiple threads separately, or from Perl 5.8.9 onwards may be loaded by a thread that spawns new threads. (Prior to Perl 5.8.9, limitations of the threading system mean that module data can't be correctly cloned upon thread spawning. Any but the most trivial cases of thread spawning with this module loaded will crash the interpreter. The rest of this section only applies to Perls that fully support cloning.) If a thread is spawned while the parent thread has an open shared hash handle, the handle is duplicated, so that both resulting threads have handles referring to the same underlying shared hash. Provided that the duplication did not happen during a shared hash operation, both threads' handles will subsequently work normally, and can be used independently. =head2 Tainting If L is enabled, taintedness is relevant to some operations on shared hashes. Shared hash handles mostly behave like regular file handles for tainting purposes. Where the following description says that a result is "not tainted", that means it does not get the taint flag set merely by virtue of the operation performed; it may still be marked as tainted if other tainted data is part of the same expression, due to Perl's conservative taint tracking. The classification functions are happy to operate on tainted arguments. Their results are not tainted. When opening a shared hash, if the shared hash filename or the mode string is tainted then it is not permitted to open for writing or with the possibility of creating. It is permitted to open non-creatingly for reading regardless of taint status. Of course, any kind of opening is permitted in an untainted expression. A shared hash handle per se is never tainted. The results of the mode checking functions are not tainted. The content of a shared hash is always treated as tainted. It is permitted to write tainted data to a shared hash. The data operations all accept tainted arguments. When reading from a shared hash, the keys existing in the hash and the values referenced by them are always tainted, but an absent item is treated as clean. So where a data operation returns a key or value from the shared hash, the result will be tainted if it is a string, but C representing an absent item will not be tainted. The count of keys existing in the hash, size of the hash, and the length of an existing value are also tainted, being derived from tainted content. However, the truth values returned by some operations are not tainted, even if they are derived entirely from tainted data. =cut package Hash::SharedMem; { use 5.006; } use warnings; use strict; our $VERSION = "0.005"; use parent "Exporter"; our @EXPORT_OK = qw( shash_referential_handle is_shash check_shash shash_open shash_is_readable shash_is_writable shash_mode shash_exists shash_getd shash_length shash_get shash_set shash_gset shash_cset shash_occupied shash_count shash_size shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash shash_snapshot shash_is_snapshot shash_idle shash_tidy shash_tally_get shash_tally_zero shash_tally_gzero ); eval { local $SIG{__DIE__}; require Devel::CallChecker; Devel::CallChecker->VERSION(0.003); }; require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); sub _deparse_shash_unop { my($self, $op, $name) = @_; my @k; for(my $k = $op->first; !$k->isa("B::NULL"); $k = $k->sibling) { push @k, $k; } return __PACKAGE__."::".$name. "(".join(", ", map { $self->deparse($_, 6) } @k).")"; } if("$]" >= 5.013007) { foreach my $name (@EXPORT_OK) { next if $name eq "shash_referential_handle"; no strict "refs"; *{"B::Deparse::pp_$name"} = sub { _deparse_shash_unop($_[0], $_[1], $name) }; } } =head1 CONSTANTS =over =item shash_referential_handle Truth value indicating whether each shared hash handle contains a first-class reference to the shared hash to which it refers. See L above for discussion of the significance of this. =back =head1 FUNCTIONS The I parameter that most of these functions take must be a handle referring to a shared hash object. =head2 Classification =over =item is_shash(ARG) Returns a truth value indicating whether I is a handle referring to a shared hash object. =item check_shash(ARG) Checks whether I is a handle referring to a shared hash object. Returns normally if it is, or Cs if it is not. =back =head2 Opening =over =item shash_open(FILENAME, MODE) Opens and returns a handle referring to a shared hash object, or Cs if the shared hash can't be opened as specified. I must refer to the directory that encapsulates the shared hash. If the filename string contains non-ASCII characters, then the filename actually used consists of the octets of the internal encoding of the string, which does not necessarily match the ostensible characters of the string. This gives inconsistent behaviour for the same character sequence represented in the two different ways that Perl uses internally. This is consistent with the treatment of filenames in Perl's built-in operators such as L; see L. This may change in future versions of Perl (beyond 5.26). I is a string controlling how the shared hash will be used. It can contain these characters: =over =item B The shared hash is to be readable. If this is not specified then read operations through the handle will be denied. Beware that at the system-call level the files are necessarily opened readably. Thus read permission on the files is required even if one will only be writing. =item B The shared hash is to be writable. If this is not specified then write operations through the handle will be denied. This flag also determines in what mode the files are opened at the system-call level, so write permission on the files operates as expected. =item B The shared hash will be created if it does not already exist. The permission bits on the shared hash will be controlled by the creating process's umask. If this flag is not specified then the shared hash must already exist. =item B The shared hash must not already exist. If this is not specified and the shared hash already exists then it will be opened normally. This flag is meant to be used with B; it means that a successful open implies that this process, rather than any other, is the one that created the shared hash. =back When a shared hash is created, some of its constituent files will be opened in read/write mode even if read-only mode was requested. Shared hash creation is not an atomic process, so if a creation attempt is interrupted it may leave a half-created shared hash behind. This does not prevent a subsequent creation attempt on the same shared hash from succeeding: creation will continue from whatever stage it had reached. Likewise, multiple simultaneous creation attempts may each do part of the job. This can result in ownerships and permissions being inconsistent; see L above. Regardless of the combination of efforts leading to the creation of a shared hash, completion of the process is atomic. Non-creating open attempts will either report that there is no shared hash or open the created shared hash. Exactly one creation attempt will be judged to have created the shared hash, and this is detectable through the B flag. =back =head2 Mode checking =over =item shash_is_readable(SHASH) Returns a truth value indicating whether the shared hash can be read from through this handle. =item shash_is_writable(SHASH) Returns a truth value indicating whether the shared hash can be written to through this handle. =item shash_mode(SHASH) Returns a string in which characters indicate the mode of this handle. It matches the form of the I parameter to L, but mode flags that are only relevant during the opening process (B and B) are not included. The returned string can therefore contain these characters: =over =item B The shared hash can be read from through this handle. =item B The shared hash can be written to through this handle. =back =back =head2 Single-key data operations For all of these functions, the key of interest (I parameter) can be any octet (Latin-1) string, and values (I parameters and some return values) can be any octet string or C. The C value represents the absence of a key from the hash; there is no present-but-undefined state. Strings containing non-octets (Unicode characters above U+FF) and items other than strings cannot be used as keys or values. If a dualvar (scalar with independent string and numeric values) is supplied, only its string value will be used. =over =item shash_exists(SHASH, KEY) Returns a truth value indicating whether the specified key currently references a defined value in the shared hash. =item shash_getd(SHASH, KEY) Deprecated alias for L. =item shash_length(SHASH, KEY) Returns the length (in octets) of the value currently referenced by the specified key in the shared hash, or C if the key is absent. =item shash_get(SHASH, KEY) Returns the value currently referenced by the specified key in the shared hash. =item shash_set(SHASH, KEY, NEWVALUE) Modifies the shared hash so that the specified key henceforth references the specified value. =item shash_gset(SHASH, KEY, NEWVALUE) Modifies the shared hash so that the specified key henceforth references the value I, and returns the value that the key previously referenced. This swap is performed atomically. =item shash_cset(SHASH, KEY, CHKVALUE, NEWVALUE) Examines the value currently referenced by the specified key in the shared hash. If it is identical to I, the function modifies the shared hash so that the specified key henceforth references the value I, and returns true. If the current value is not identical to I, the function leaves it unmodified and returns false. This conditional modification is performed atomically. This function can be used as a core on which to build arbitrarily complex kinds of atomic operation (on a single key). For example, an atomic increment can be implemented as do { $ov = shash_get($shash, $key); $nv = $ov + 1; } until shash_cset($shash, $key, $ov, $nv); =back =head2 Whole-hash data operations =over =item shash_occupied(SHASH) Returns a truth value indicating whether there are currently any items in the shared hash. =item shash_count(SHASH) Returns the number of items that are currently in the shared hash. =item shash_size(SHASH) Returns the approximate size (in octets) of the entire content of the shared hash. The size of a hash is not a well-defined quantity, so the return value of this function should be interpreted with care. It aims specifically to indicate how much space is required in a shared hash data file to represent this content. It is affected by details of the file format (which may differ between shared hashes on one system) and by accidents of how the content is laid out in a particular shared hash. Calling this function twice on identical content will not necessarily produce identical results. The details of the size estimation may also change in the future. Although this function computes size specifically with respect to the file format used by this module, this function does not directly indicate the amount of space occupied by a shared hash. There is some non-content overhead, and, more importantly, the process by which content is modified requires space to store multiple versions of the content. It is normal for the amount of space actually occupied to fluctuate over the cycle of data file rewriting. If L is being used appropriately, the space occupied can be expected to vary up to a little over five times the size of the nominal content, and if L is not used then the normal maximum will be more than ten times the content size. Occasional spikes above these levels can be expected in any case, and fixed overheads make these multipliers inapplicable if the content is very small. =item shash_key_min(SHASH) Returns the lexicographically least of the keys that are currently in the shared hash, or C if there are none. =item shash_key_max(SHASH) Returns the lexicographically greatest of the keys that are currently in the shared hash, or C if there are none. =item shash_key_ge(SHASH, KEY) Returns the least of the keys currently in the shared hash that are lexicographically no less than the specified key, or C if there are none. =item shash_key_gt(SHASH, KEY) Returns the least of the keys currently in the shared hash that are lexicographically greater than the specified key, or C if there are none. =item shash_key_le(SHASH, KEY) Returns the greatest of the keys currently in the shared hash that are lexicographically no greater than the specified key, or C if there are none. =item shash_key_lt(SHASH, KEY) Returns the greatest of the keys currently in the shared hash that are lexicographically less than the specified key, or C if there are none. =item shash_keys_array(SHASH) Returns a reference to a plain array containing all the keys currently in the shared hash in lexicographical order. The array and the key scalars in it are unwritable. =item shash_keys_hash(SHASH) Returns a reference to a plain hash in which the keys are all the keys currently in the shared hash and all the values are C. The value scalars are unwritable. Writability of the hash is not guaranteed: currently in practice it is writable, but this may change in the future. =item shash_group_get_hash(SHASH) Returns a reference to a plain hash representing the entire current content of the shared hash. The value scalars are unwritable. Writability of the hash is not guaranteed: currently in practice it is writable, but this may change in the future. =back =head2 Snapshots =over =item shash_snapshot(SHASH) Returns a shared hash handle that encapsulates the current content of the shared hash. The entire state of the shared hash is captured atomically, and the returned handle can be used to perform arbitrarily many read operations on that state: it will never reflect later modifications to the shared hash. The snapshot handle cannot be used for writing. =item shash_is_snapshot(SHASH) Returns a truth value indicating whether this handle refers to a snapshot (as opposed to a live shared hash). =back =head2 Maintenance =over =item shash_idle(SHASH) Puts the shared hash handle into a state where it occupies less resources, at the expense of making the next operation through the handle more expensive. This doesn't change the visible behaviour of the handle, and doesn't affect the state of the shared hash itself at all. The invisible operations performed by this function may vary between versions of this module. This function should be called when the handle is going to be unused for a lengthy period. For example, if a long-running daemon uses a shared hash in brief bursts once an hour, it should idle its handle at the end of each burst of activity. Currently the effect of this operation is to discard the handle's memory mapping of the shared hash data file. The next operation has to reestablish the mapping. The benefit of discarding the mapping is that periodically the data file has to be replaced with a new one, but the old data file continues to exist as long as some process has it mapped. A process that is actively using the shared hash will quickly notice that the data file has been replaced and will unmap the old one. A process with a handle that it's not using, however, could keep the old data file in existence, occupying storage, long after it has no further use. A handle that has been put into the idle state won't perpetuate the existence of an obsolete data file. =item shash_tidy(SHASH) Rearranges the storage of the shared hash if it seems useful to do so, to avoid tidying work having to be performed by other processes. This doesn't change the visible content of the shared hash, but the handle must be open for writing, and this counts as a write operation for purposes concerned with the state of the underlying files. The invisible operations performed by this function may vary between versions of this module. This function should be called in circumstances where it is acceptable to incur some delay for this maintenance work to complete. For example, it could be called periodically by a cron job. Essentially, calling this function signals that this is a convenient time at which (and process in which) to perform maintenance. If this maintenance work is not carried out by means of this function, then ultimately it will be performed anyway, but less predictably and possibly less conveniently. Eventually it will become necessary to perform maintenance in order to continue using the shared hash, at which point the next process that attempts to write to it will carry out the work and incur the cost. The shared hash will still work properly in that case, but the unlucky writer will experience a disproportionately large delay in the completion of its write operation. This could well be a problem if the shared hash is large. =back =head2 Event counters =over =item shash_tally_get(SHASH) Returns a reference to a hash of counts of events that have occurred with this shared hash handle. These counts may be of interest for profiling and debugging purposes, but should not be relied upon for semantic purposes. The event types may vary between versions of this module. Few of the event types make sense in terms of the API supplied by this module: most of them are internal implementation details. Events are counted separately for each handle. The events counted are associated specifically with the handle, rather than with the shared hash as a whole. Generally, an idle handle will accumulate no events, even if the shared hash to which it refers is active. The event counters start at zero when a handle is opened, and can be reset to zero by L or L. In the returned hash, each key identifies a type of event, and the corresponding value is (unless wrapped) the number of times events of that type have occurred on the handle since the counters were last zeroed. Currently the event counters are held in fixed-size variables and can wrap, so if event counts might get as high as 2^64 then they can't be relied upon to be accurate. Wrapping will not occur at less than 2^64; in other respects, wrapping behaviour may change in the future. The event types that are currently counted are: =over =item B Parse an octet string representation in a shared hash data file. =item B Write an octet string representation into a shared hash data file. =item B Parse a B-tree node representation in a shared hash data file. =item B Write a B-tree node representation into a shared hash data file. =item B Compare two strings as shared hash keys. =item B Attempt to replace the root pointer in a shared hash data file. This may be done to change the content of the shared hash, or as part of the process of switching to a new data file. =item B Succeed in replacing the root pointer in a shared hash data file. An attempt will fail if another process changed the root pointer during the operation that required this process to change the root pointer. =item B Attempt to replace the data file in a shared hash. This is necessary from time to time as data files fill up. =item B Succeed in replacing the data file in a shared hash. An attempt will fail if another process replaced the data file while this process was initialising its new one. =item B Perform a high-level data operation that purely reads from the shared hash: L, L, L, L, L, L, L, L, L, L, L, L, L, L, or L. =item B Perform a high-level data operation that writes, or at least may write, to the shared hash: L, L, or L. =back The value scalars in the returned hash are unwritable. Writability of the hash is not guaranteed: currently in practice it is writable, but this may change in the future. =item shash_tally_zero(SHASH) Zero the event counters that can be read by L. =item shash_tally_gzero(SHASH) Zero the event counters that can be read by L, and return the values the event counters previously had, in the same form as L. This swap is performed atomically. =back =head1 BUGS As explained for L, creation of a shared hash is not atomic. This is an unavoidable consequence of the need for the shared hash to consist of multiple files in a directory. Multi-party creation can result in the files having different permission bits; to avoid this, all creators should use the same umask. Multiple users writing to a shared hash can result in the files having different ownerships, so the permission bits must be chosen to work appropriately with the chimeric ownership. When calls to the functions supplied by this module are compiled down to custom ops (which is attempted for performance reasons), the ability to deparse the resulting code with L is limited. Prior to Perl 5.13.7, deparsing will generate very incorrect code. From Perl 5.13.7 onwards, deparsing should normally work, but will break if another module defines a separate type of custom op that happens to have the same short name (though these ops do not clash in other respects). =head1 SEE ALSO L, L =head1 AUTHOR Andrew Main (Zefram) =head1 COPYRIGHT Copyright (C) 2014, 2015 PhotoBox Ltd Copyright (C) 2014, 2015, 2017 Andrew Main (Zefram) =head1 LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Hash-SharedMem-0.005/lib/Hash/SharedMem.xs000444001750001750 40610613143376054 20263 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "callchecker0.h" #include /* Perl compatibility */ #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) #define PERL_DECIMAL_VERSION \ PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #define PERL_VERSION_GE(r,v,s) \ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) #if !PERL_VERSION_GE(5,7,2) # undef dNOOP # define dNOOP extern int Perl___notused_func(void) #endif /* <5.7.2 */ #ifndef cBOOL # define cBOOL(x) ((bool)!!(x)) #endif /* !cBOOL */ #ifndef EXPECT # ifdef __GNUC__ # define EXPECT(e, v) __builtin_expect(e, v) # else /* !__GNUC__ */ # define EXPECT(e, v) (e) # endif /* !__GNUC__ */ #endif /* !EXPECT */ #define likely(t) EXPECT(cBOOL(t), 1) #define unlikely(t) EXPECT(cBOOL(t), 0) #ifndef __attribute__noreturn__ # ifdef __GNUC__ # define __attribute__noreturn__ __attribute__((noreturn)) # else /* !__GNUC__ */ # define __attribute__noreturn__ /**/ # endif /* !__GNUC__ */ #endif /* !__attribute__noreturn__ */ #ifndef C_ARRAY_LENGTH # define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof(*(a))) #endif /* !C_ARRAY_LENGTH */ #ifndef PERL_STATIC_INLINE # define PERL_STATIC_INLINE static #endif /* !PERL_STATIC_INLINE */ #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif /* !PERL_UNUSED_VAR */ #ifndef PERL_UNUSED_ARG # define PERL_UNUSED_ARG(x) PERL_UNUSED_VAR(x) #endif /* !PERL_UNUSED_ARG */ #ifndef STATIC_ASSERT_DECL # ifdef STATIC_ASSERT_GLOBAL # define STATIC_ASSERT_DECL STATIC_ASSERT_GLOBAL # else /* !STATIC_ASSERT_GLOBAL */ # define STATIC_ASSERT_2(COND, SUFFIX) \ enum { STATIC_ASSERT_ENUM_##SUFFIX = 1/(cBOOL(COND)) } # define STATIC_ASSERT_1(COND, SUFFIX) STATIC_ASSERT_2(COND, SUFFIX) # define STATIC_ASSERT_DECL(COND) STATIC_ASSERT_1(COND, __LINE__) # endif /* !STATIC_ASSERT_GLOBAL */ #endif /* !STATIC_ASSERT_DECL */ #ifndef DPTR2FPTR # define DPTR2FPTR(t,x) ((t)(UV)(x)) #endif /* !DPTR2FPTR */ #ifndef FPTR2DPTR # define FPTR2DPTR(t,x) ((t)(UV)(x)) #endif /* !FPTR2DPTR */ #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif /* !Newx */ #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif /* !Newxz */ #ifndef newSVpv_share # ifdef newSVpvn_share # define newSVpv_share(pv, hash) THX_newSVpv_share(aTHX_ pv, hash) PERL_STATIC_INLINE SV *THX_newSVpv_share(pTHX_ char const *pv, U32 hash) { return newSVpvn_share(pv, strlen(pv), hash); } # else /* !newSVpvn_share */ # define newSVpv_share(pv, hash) newSVpv(pv, 0) # define SvSHARED_HASH(sv) 0 # endif /* !newSVpvn_share */ #endif /* !newSVpv_share */ #ifndef SvSHARED_HASH # define SvSHARED_HASH(sv) SvUVX(sv) #endif /* !SvSHARED_HASH */ #ifndef SvREFCNT_inc_NN # define SvREFCNT_inc_NN SvREFCNT_inc #endif /* !SvREFCNT_inc_NN */ #ifndef SvREFCNT_inc_simple # define SvREFCNT_inc_simple SvREFCNT_inc #endif /* !SvREFCNT_inc_simple */ #ifndef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_NN SvREFCNT_inc_NN #endif /* !SvREFCNT_inc_simple_NN */ #ifndef SvREFCNT_inc_void # define SvREFCNT_inc_void(sv) ((void) SvREFCNT_inc(sv)) #endif /* !SvREFCNT_inc_void */ #ifndef SvREFCNT_inc_void_NN # define SvREFCNT_inc_void_NN(sv) ((void) SvREFCNT_inc_NN(sv)) #endif /* !SvREFCNT_inc_void_NN */ #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) ((void) SvREFCNT_inc_simple(sv)) #endif /* !SvREFCNT_inc_simple_void */ #ifndef SvREFCNT_inc_simple_void_NN # define SvREFCNT_inc_simple_void_NN(sv) ((void) SvREFCNT_inc_simple_NN(sv)) #endif /* !SvREFCNT_inc_simple_void_NN */ #ifndef SvREFCNT_dec_NN # define SvREFCNT_dec_NN SvREFCNT_dec #endif /* !SvREFCNT_dec_NN */ #ifndef SvUV_set # define SvUV_set(sv, uv) (SvUVX(sv) = (uv)) #endif /* !SvUV_set */ #ifndef CvPROTO # define CvPROTO(cv) SvPVX((SV*)(cv)) # define CvPROTOLEN(cv) SvCUR((SV*)(cv)) #endif /* !CvPROTO */ #if PERL_VERSION_GE(5,7,3) # define PERL_UNUSED_THX() NOOP #else /* <5.7.3 */ # define PERL_UNUSED_THX() ((void)(aTHX+0)) #endif /* <5.7.3 */ #ifndef SvMAGIC_set # define SvMAGIC_set(sv, mg) (SvMAGIC(sv) = (mg)) #endif /* !SvMAGIC_set */ #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif /* !PERL_MAGIC_ext */ #ifndef sv_magicext # define sv_magicext(sv, obj, type, vtbl, name, namlen) \ THX_sv_magicext(aTHX_ sv, obj, type, vtbl, name, namlen) static MAGIC *THX_sv_magicext(pTHX_ SV *sv, SV *obj, int type, MGVTBL const *vtbl, char const *name, I32 namlen) { MAGIC *mg; PERL_UNUSED_ARG(namlen); Newxz(mg, 1, MAGIC); mg->mg_virtual = (MGVTBL*)vtbl; mg->mg_type = type; mg->mg_obj = obj; if(likely(obj && obj != sv)) { SvREFCNT_inc_simple_void_NN(obj); mg->mg_flags |= MGf_REFCOUNTED; } mg->mg_ptr = (char*)name; (void) SvUPGRADE(sv, SVt_PVMG); mg->mg_moremagic = SvMAGIC(sv); SvMAGIC_set(sv, mg); SvMAGICAL_off(sv); mg_magical(sv); return mg; } #endif /* !sv_magicext */ #ifndef sv_unmagicext # define sv_unmagicext(sv, type, vtbl) THX_sv_unmagicext(aTHX_ sv, type, vtbl) PERL_STATIC_INLINE int THX_sv_unmagicext(pTHX_ SV *sv, int type, MGVTBL const *vtbl) { MAGIC *mg, **mgp; if(unlikely(SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))) return 0; mgp = NULL; for(mg = SvMAGIC(sv); mg; mg = unlikely(mgp) ? *mgp : SvMAGIC(sv)) { if(likely(mg->mg_type == type && mg->mg_virtual == vtbl)) { if(unlikely(mgp)) *mgp = mg->mg_moremagic; else SvMAGIC_set(sv, mg->mg_moremagic); if(likely(vtbl->svt_free)) vtbl->svt_free(aTHX_ sv, mg); if(unlikely(mg->mg_flags & MGf_REFCOUNTED)) SvREFCNT_dec(mg->mg_obj); Safefree(mg); } else { mgp = &mg->mg_moremagic; } } SvMAGICAL_off(sv); mg_magical(sv); return 0; } #endif /* !sv_unmagicext */ #ifndef newSV_type # define newSV_type(type) THX_newSV_type(aTHX_ type) static SV *THX_newSV_type(pTHX_ svtype type) { SV *sv = newSV(0); (void) SvUPGRADE(sv, type); return sv; } #endif /* !newSV_type */ #ifndef gv_stashpvs # define gv_stashpvs(name, flags) gv_stashpvn(""name"", sizeof(name)-1, flags) #endif /* !gv_stashpvs */ #ifndef hv_fetchs # define hv_fetchs(hv, keystr, lval) \ hv_fetch(hv, ""keystr"", sizeof(keystr)-1, lval) #endif /* !hv_fetchs */ #ifndef hv_stores # define hv_stores(hv, keystr, val) \ hv_store(hv, ""keystr"", sizeof(keystr)-1, val, 0) #endif /* !hv_stores */ #if defined(USE_ITHREADS) && !defined(sv_dup_inc) # define sv_dup_inc(sv, param) SvREFCNT_inc(sv_dup(sv, param)) #endif /* USE_ITHREADS && !sv_dup_inc */ #if !PERL_VERSION_GE(5,9,3) typedef OP *(*Perl_ppaddr_t)(pTHX); #endif /* <5.9.3 */ #ifndef SvPV_nomg # define SvPV_nomg(sv, len) \ (unlikely(SvGMAGICAL(sv)) ? THX_SvPV_nomg_magical(aTHX_ sv, &(len)) : \ SvPV(sv, len)) struct remagic { SV *sv; MAGIC *mg; U32 flags; }; static void THX_remagic_cleanup(pTHX_ void *remagic_v) { struct remagic remagic = *(struct remagic *)remagic_v; Safefree(remagic_v); if(unlikely(remagic.sv)) { SvMAGIC(remagic.sv) = remagic.mg; SvFLAGS(remagic.sv) |= remagic.flags; SvREFCNT_dec_NN(remagic.sv); } } static char *THX_SvPV_nomg_magical(pTHX_ SV *sv, STRLEN *len_p) { char *pv; struct remagic *remagic; Newx(remagic, 1, struct remagic); remagic->sv = sv; remagic->mg = SvMAGIC(sv); remagic->flags = SvMAGICAL(sv); SAVEDESTRUCTOR_X(THX_remagic_cleanup, remagic); SvREFCNT_inc_simple_void_NN(sv); SvMAGIC(sv) = NULL; pv = SvPV(sv, *len_p); SvMAGIC(sv) = remagic->mg; SvFLAGS(sv) |= remagic->flags; SvREFCNT_dec_NN(sv); remagic->sv = NULL; return pv; } #endif /* !SvPV_nomg */ #ifndef START_MY_CXT # ifdef PERL_IMPLICIT_CONTEXT # define START_MY_CXT # define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, \ MY_CXT_KEY, sizeof(MY_CXT_KEY)-1, 1) # define dMY_CXT \ dMY_CXT_SV; my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)) # define MY_CXT_INIT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) # define MY_CXT (*my_cxtp) # define pMY_CXT my_cxt_t *my_cxtp # define pMY_CXT_ pMY_CXT, # define _pMY_CXT ,pMY_CXT # define aMY_CXT my_cxtp # define aMY_CXT_ aMY_CXT, # define _aMY_CXT ,aMY_CXT # else /* !PERL_IMPLICIT_CONTEXT */ # define START_MY_CXT static my_cxt_t my_cxt; # define dMY_CXT dNOOP # define MY_CXT_INIT NOOP # define MY_CXT my_cxt # define pMY_CXT void # define pMY_CXT_ /**/ # define _pMY_CXT /**/ # define aMY_CXT /**/ # define aMY_CXT_ /**/ # define _aMY_CXT /**/ # endif /* !PERL_IMPLICIT_CONTEXT */ #endif /* !START_MY_CXT */ #ifndef MY_CXT_CLONE # ifdef PERL_IMPLICIT_CONTEXT # define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) # else /* !PERL_IMPLICIT_CONTEXT */ # define MY_CXT_CLONE NOOP # endif /* !PERL_IMPLICIT_CONTEXT */ #endif /* !MY_CXT_CLONE */ #if PERL_VERSION_GE(5,19,4) typedef SSize_t tmps_ix_t; #else /* <5.19.4 */ typedef I32 tmps_ix_t; #endif /* <5.19.4 */ #if PERL_VERSION_GE(5,19,4) typedef SSize_t array_ix_t; #else /* <5.19.4 */ typedef I32 array_ix_t; #endif /* <5.19.4 */ #ifdef newSVpvn_flags # define newSVpvn_mortal(pv, len) newSVpvn_flags(pv, len, SVs_TEMP) #else /* !newSVpvn_flags */ # define newSVpvn_mortal(pv, len) sv_2mortal(newSVpvn(pv, len)) #endif /* !newSVpvn_flags */ #ifndef my_strerror # define my_strerror Strerror #endif /* !my_strerror */ #ifndef OpMORESIB_set # define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) # define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) # define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) #endif /* !OpMORESIB_set */ #ifndef OpSIBLING # define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) # define OpSIBLING(o) (0 + (o)->op_sibling) #endif /* !OpSIBLING */ /* Perl additions */ typedef U64TYPE U64; #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV) #if PERL_VERSION_GE(5,11,0) # define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP) #else /* <5.11.0 */ # define sv_is_regexp(sv) 0 #endif /* <5.11.0 */ #define sv_is_undef(sv) (!sv_is_glob(sv) && !sv_is_regexp(sv) && !SvOK(sv)) #define sv_is_string(sv) \ (!sv_is_glob(sv) && !sv_is_regexp(sv) && \ (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK))) /* we need mg_dup to be invoked *after* duplicating a scalar's PV */ #define QCORE_MG_DUP_WORKS \ ((PERL_VERSION_GE(5,8,9) && !PERL_VERSION_GE(5,9,0)) || \ PERL_VERSION_GE(5,9,3)) #ifndef QWITH_DUP # if QCORE_MG_DUP_WORKS && defined(USE_ITHREADS) # define QWITH_DUP 1 # else /* !(QCORE_MG_DUP_WORKS && USE_ITHREADS) */ # define QWITH_DUP 0 # endif /* !(QCORE_MG_DUP_WORKS && USE_ITHREADS) */ #endif /* !QWITH_DUP */ #define newRV_ro_mortal_noinc(r) THX_newRV_ro_mortal_noinc(aTHX_ r) PERL_STATIC_INLINE SV *THX_newRV_ro_mortal_noinc(pTHX_ SV *referent) { SV *rv = newRV_noinc(referent); SvREADONLY_on(rv); return sv_2mortal(rv); } #define newRV_ro_mortal_inc(r) THX_newRV_ro_mortal_inc(aTHX_ r) PERL_STATIC_INLINE SV *THX_newRV_ro_mortal_inc(pTHX_ SV *referent) { SV *rv = newRV_inc(referent); SvREADONLY_on(rv); return sv_2mortal(rv); } /* system call compatibility */ #ifndef MAP_FAILED # define MAP_FAILED ((void*)-1) #endif /* !MAP_FAILED */ #ifndef FD_CLOEXEC # define FD_CLOEXEC 1 #endif /* !FD_CLOEXEC */ /* byte definition */ #define BYTE_NBIT 8 typedef U8 byte; #define BYTE_MAX 0xff /* word definition */ #define WORD_SZ_LOG2 3 #define WORD_SZ (1< LONGLONGSIZE */ typedef UV dirref_t; #endif /* PTRSIZE > LONGLONGSIZE */ #if QMAY_DIRREF_BY_FD # if QWITH_DUP # define DIRREF_BYFD_FD(dr) (NUM2PTR(struct dirref_by_fd *, (dr)))->fd # else /* !QWITH_DUP */ # define DIRREF_BYFD_FD(dr) ((int)(dr)) # endif /* !QWITH_DUP */ #endif /* QMAY_DIRREF_BY_FD */ #if QMAY_DIRREF_BY_FD enum { DIRREF_EXPERIMENT, DIRREF_BY_FD, DIRREF_BY_NAME }; static int dirref_strategy = DIRREF_EXPERIMENT; #endif /* QMAY_DIRREF_BY_FD */ PERL_STATIC_INLINE void dirref_ensure_strategy(void) { #if QMAY_DIRREF_BY_FD # if AT_FDCWD == -1 # define QAT_BADFD (-2) # else /* AT_FDCWD != -1 */ # define QAT_BADFD (-1) # endif /* AT_FDCWD != -1 */ int res; struct stat st; if(unlikely(dirref_strategy != DIRREF_EXPERIMENT)) return; res = openat_cloexec(QAT_BADFD, "", O_RDONLY, 0); if(unlikely(res != -1)) { (void) close(res); } else if(unlikely(errno == ENOSYS)) { by_name: dirref_strategy = DIRREF_BY_NAME; return; } res = fstatat(QAT_BADFD, "", &st, 0); if(likely(res == -1) && unlikely(errno == ENOSYS)) goto by_name; res = linkat(QAT_BADFD, "", QAT_BADFD, "", 0); if(likely(res == -1) && unlikely(errno == ENOSYS)) goto by_name; res = unlinkat(QAT_BADFD, "", 0); if(likely(res == -1) && unlikely(errno == ENOSYS)) goto by_name; dirref_strategy = DIRREF_BY_FD; #endif /* QMAY_DIRREF_BY_FD */ } PERL_STATIC_INLINE bool dirref_referential(void) { #if QMAY_DIRREF_BY_FD return likely(dirref_strategy == DIRREF_BY_FD); #else /* !QMAY_DIRREF_BY_FD */ return 0; #endif /* !QMAY_DIRREF_BY_FD */ } #define dirref_null() ((dirref_t)0) PERL_STATIC_INLINE bool dirref_is_null(dirref_t dirref) { return dirref == dirref_null(); } static char *dirref_path_concat(char const *base, char const *rel) { size_t blen = strlen(base), rlen = strlen(rel); size_t tlen = blen + rlen; char *full; if(unlikely(tlen < blen)) goto enomem; tlen += 2; if(unlikely(tlen < 2)) goto enomem; full = malloc(tlen); if(!likely(full)) { enomem: errno = ENOMEM; return NULL; } (void) memcpy(full, base, blen); if(unlikely(blen == 0) || likely(base[blen-1] != '/')) full[blen++] = '/'; (void) memcpy(full + blen, rel, rlen+1); return full; } static dirref_t dirref_open(char const *origname, struct stat *st) { #if QMAY_DIRREF_BY_FD if(likely(dirref_strategy == DIRREF_BY_FD)) { int fd = open_cloexec(origname, O_RDONLY, 0); if(likely(fd != -1) && unlikely(fstat(fd, st) == -1)) { int er = errno; (void) close(fd); errno = er; fd = -1; } # if QWITH_DUP if(unlikely(fd == -1)) { return dirref_null(); } else { struct dirref_by_fd *byfd; byfd = malloc(sizeof(struct dirref_by_fd)); if(!likely(byfd)) { (void) close(fd); errno = ENOMEM; return dirref_null(); } byfd->rc = 0; byfd->fd = fd; return NUM2PTR(dirref_t, byfd); } # else /* !QWITH_DUP */ if(unlikely(fd == 0)) { int er; fd = dup_cloexec(fd); er = errno; (void) close(0); errno = er; } return unlikely(fd == -1) ? dirref_null() : (dirref_t)fd; # endif /* !QWITH_DUP */ } else #endif /* QMAY_DIRREF_BY_FD */ { char *fullname; size_t fullname_len, byname_len; bool free_fullname; struct dirref_by_name *byname; #if QHAVE_REALPATH long pmax; #endif /* QHAVE_REALPATH */ if(unlikely(stat(origname, st) == -1)) return dirref_null(); #if QHAVE_REALPATH # if QHAVE_PATHCONF && defined(_PC_PATH_MAX) pmax = pathconf(".", _PC_PATH_MAX); if(unlikely(pmax == -1)) # endif /* QHAVE_PATHCONF && _PC_PATH_MAX */ { # ifdef PATH_MAX pmax = PATH_MAX; # else /* !PATH_MAX */ pmax = 4096; # endif /* !PATH_MAX */ } if(unlikely((long)(size_t)pmax != pmax || ((size_t)pmax)+1 == 0)) goto enomem; fullname = malloc(((size_t)pmax) + 1); if(!likely(fullname)) goto enomem; if(!likely(realpath(origname, fullname))) { int er = errno; free(fullname); errno = er; return dirref_null(); } free_fullname = 1; #elif QHAVE_GETCWD size_t origname_len = strlen(origname); if(likely(origname[0] == '/')) { fullname = (char*)origname; fullname_len = origname_len; free_fullname = 0; } else { size_t bufsz = 256; char *cwd; cwd = malloc(bufsz); if(!likely(cwd)) goto enomem; while(1) { char *newbuf; if(likely(getcwd(cwd, bufsz))) break; if(unlikely(errno != ERANGE)) { int er = errno; free(cwd); errno = er; return dirref_null(); } bufsz <<= 2; if(!likely(bufsz)) goto enomem_free_cwd; newbuf = realloc(cwd, bufsz); if(!likely(newbuf)) { enomem_free_cwd: free(cwd); goto enomem; } cwd = newbuf; } fullname = dirref_path_concat(cwd, origname); free(cwd); if(!likely(fullname)) goto enomem; free_fullname = 1; } #else /* !QHAVE_REALPATH && !QHAVE_GETCWD */ #error neither realpath nor getcwd available #endif /* !QHAVE_REALPATH && !QHAVE_GETCWD */ fullname_len = strlen(fullname); byname_len = offsetof(struct dirref_by_name, name) + 1 + fullname_len; if(unlikely(byname_len < fullname_len)) { enomem_maybe_free_fullname: if(free_fullname) free(fullname); enomem: errno = ENOMEM; return dirref_null(); } byname = malloc(byname_len); if(!likely(byname)) goto enomem_maybe_free_fullname; #if QWITH_DUP byname->rc = 0; #endif /* QWITH_DUP */ byname->dev = st->st_dev; byname->ino = st->st_ino; (void) memcpy(byname->name, fullname, fullname_len+1); if(free_fullname) free(fullname); return NUM2PTR(dirref_t, byname); } } #if QWITH_DUP PERL_STATIC_INLINE dirref_t dirref_dup(dirref_t dirref) { if(unlikely(dirref_is_null(dirref))) return dirref; /* * This code doesn't look at whether the directory reference is * by fd or by name. It relies on the reference count being * in the same place in both structures, which is achieved by * putting it at the beginning of both. */ threadrc_inc(&(NUM2PTR(struct dirref_by_name *, dirref))->rc); return dirref; } #endif /* QWITH_DUP */ PERL_STATIC_INLINE void dirref_close(dirref_t dirref) { #if QWITH_DUP /* * Like dirref_dup(), this doesn't distinguish the types of * directory reference when manipulating the reference count. */ if(unlikely(threadrc_dec( &(NUM2PTR(struct dirref_by_name *, dirref))->rc))) return; #endif /* QWITH_DUP */ #if QMAY_DIRREF_BY_FD if(likely(dirref_strategy == DIRREF_BY_FD)) { # if QWITH_DUP struct dirref_by_fd *byfd = NUM2PTR(struct dirref_by_fd *, dirref); (void) close(byfd->fd); free(byfd); # else /* !QWITH_DUP */ (void) close((int)dirref); # endif /* !QWITH_DUP */ } else #endif /* QMAY_DIRREF_BY_FD */ { free(NUM2PTR(struct dirref_by_name *, dirref)); } } static bool dirref_byname_ok(struct dirref_by_name *byname) { struct stat st; if(unlikely(stat(byname->name, &st) == -1)) { if(likely(errno == ENOENT) || likely(errno == ENOTDIR)) errno = EIO; return 0; } else if(likely(st.st_dev == byname->dev && st.st_ino == byname->ino)) { return 1; } else { errno = EIO; return 0; } } PERL_STATIC_INLINE DIR *dirref_dir_opendir(dirref_t dirref) { #if QMAY_DIRREF_BY_FD if(likely(dirref_strategy == DIRREF_BY_FD)) { DIR *dirh; int fd = openat_cloexec(DIRREF_BYFD_FD(dirref), ".", O_RDONLY, 0); if(unlikely(fd == -1)) return NULL; dirh = fdopendir(fd); if(!likely(dirh)) { int er = errno; (void) close(fd); errno = er; } return dirh; } else #endif /* QMAY_DIRREF_BY_FD */ { struct dirref_by_name *byname = NUM2PTR(struct dirref_by_name *, dirref); if(!likely(dirref_byname_ok(byname))) return NULL; return opendir(byname->name); } } static int dirref_rel_open_cloexec(dirref_t dirref, char const *rel, int flags, mode_t mode) { #if QMAY_DIRREF_BY_FD if(likely(dirref_strategy == DIRREF_BY_FD)) { return openat_cloexec(DIRREF_BYFD_FD(dirref), rel, flags, mode); } else #endif /* QMAY_DIRREF_BY_FD */ { struct dirref_by_name *byname = NUM2PTR(struct dirref_by_name *, dirref); char *path; int res, er; path = dirref_path_concat(byname->name, rel); if(!likely(path)) return -1; res = !likely(dirref_byname_ok(byname)) ? -1 : open_cloexec(path, flags, mode); er = errno; free(path); errno = er; return res; } } PERL_STATIC_INLINE int dirref_rel_stat(dirref_t dirref, char const *rel, struct stat *st) { #if QMAY_DIRREF_BY_FD if(likely(dirref_strategy == DIRREF_BY_FD)) { return fstatat(DIRREF_BYFD_FD(dirref), rel, st, 0); } else #endif /* QMAY_DIRREF_BY_FD */ { struct dirref_by_name *byname = NUM2PTR(struct dirref_by_name *, dirref); char *path; int res, er; path = dirref_path_concat(byname->name, rel); if(!likely(path)) return -1; res = !likely(dirref_byname_ok(byname)) ? -1 : stat(path, st); er = errno; free(path); errno = er; return res; } } PERL_STATIC_INLINE int dirref_rel_link(dirref_t dirref, char const *oldrel, char const *newrel) { #if QMAY_DIRREF_BY_FD if(likely(dirref_strategy == DIRREF_BY_FD)) { return linkat(DIRREF_BYFD_FD(dirref), oldrel, DIRREF_BYFD_FD(dirref), newrel, 0); } else #endif /* QMAY_DIRREF_BY_FD */ { struct dirref_by_name *byname = NUM2PTR(struct dirref_by_name *, dirref); char *oldpath, *newpath; int res, er; oldpath = dirref_path_concat(byname->name, oldrel); if(!likely(oldpath)) return -1; newpath = dirref_path_concat(byname->name, newrel); if(!likely(newpath)) { free(oldpath); errno = ENOMEM; return -1; } res = !likely(dirref_byname_ok(byname)) ? -1 : link(oldpath, newpath); er = errno; free(oldpath); free(newpath); errno = er; return res; } } static int dirref_rel_unlink(dirref_t dirref, char const *rel) { #if QMAY_DIRREF_BY_FD if(likely(dirref_strategy == DIRREF_BY_FD)) { return unlinkat(DIRREF_BYFD_FD(dirref), rel, 0); } else #endif /* QMAY_DIRREF_BY_FD */ { struct dirref_by_name *byname = NUM2PTR(struct dirref_by_name *, dirref); char *path; int res, er; path = dirref_path_concat(byname->name, rel); if(!likely(path)) return -1; res = !likely(dirref_byname_ok(byname)) ? -1 : unlink(path); er = errno; free(path); errno = er; return res; } } /* fd closing on scope stack */ static void THX_closefd_cleanup(pTHX_ void *fd_p_v) { int fd = *(int*)fd_p_v; PERL_UNUSED_THX(); Safefree(fd_p_v); if(unlikely(fd != -1)) close(fd); } #define closefd_save(fd) THX_closefd_save(aTHX_ fd) static int *THX_closefd_save(pTHX_ int fd) { int *fd_p; Newx(fd_p, 1, int); *fd_p = fd; SAVEDESTRUCTOR_X(THX_closefd_cleanup, fd_p); return fd_p; } #define closefd_early(fdp) THX_closefd_early(aTHX_ fdp) static void THX_closefd_early(pTHX_ int *fd_p) { int fd = *fd_p; PERL_UNUSED_THX(); if(likely(fd != -1)) { *fd_p = -1; (void) close(fd); } } typedef int *closefd_ref_t; /* directory stream closing on scope stack */ static void THX_closedirh_cleanup(pTHX_ void *dirh_p_v) { DIR *dirh = *(DIR**)dirh_p_v; PERL_UNUSED_THX(); Safefree(dirh_p_v); if(unlikely(dirh)) closedir(dirh); } #define closedirh_save(dirh) THX_closedirh_save(aTHX_ dirh) PERL_STATIC_INLINE DIR **THX_closedirh_save(pTHX_ DIR *dirh) { DIR **dirh_p; Newx(dirh_p, 1, DIR*); *dirh_p = dirh; SAVEDESTRUCTOR_X(THX_closedirh_cleanup, dirh_p); return dirh_p; } #define closedirh_early(dirhp) THX_closedirh_early(aTHX_ dirhp) PERL_STATIC_INLINE void THX_closedirh_early(pTHX_ DIR **dirh_p) { DIR *dirh = *dirh_p; PERL_UNUSED_THX(); if(likely(dirh)) { *dirh_p = NULL; (void) closedir(dirh); } } typedef DIR **closedirh_ref_t; /* file removal on scope stack */ struct unlinkfile_cleanup_par { dirref_t dir; char filename[1]; /* struct hack */ }; static void THX_unlinkfile_cleanup(pTHX_ void *par_p_v) { struct unlinkfile_cleanup_par *par_p = par_p_v; dirref_t dir = par_p->dir; PERL_UNUSED_THX(); if(!likely(dirref_is_null(dir))) (void) dirref_rel_unlink(dir, par_p->filename); Safefree(par_p_v); } #define unlinkfile_save(dir, fn) THX_unlinkfile_save(aTHX_ dir, fn) static struct unlinkfile_cleanup_par *THX_unlinkfile_save(pTHX_ dirref_t dir, char const *filename) { struct unlinkfile_cleanup_par *par_p; char *par_p_c; size_t fnlen = strlen(filename) + 1; Newx(par_p_c, offsetof(struct unlinkfile_cleanup_par, filename) + fnlen, char); par_p = (struct unlinkfile_cleanup_par *)par_p_c; par_p->dir = dir; (void) memcpy(par_p->filename, filename, fnlen); SAVEDESTRUCTOR_X(THX_unlinkfile_cleanup, par_p); return par_p; } #define unlinkfile_cancel(par_p) THX_unlinkfile_cancel(aTHX_ par_p) PERL_STATIC_INLINE void THX_unlinkfile_cancel(pTHX_ struct unlinkfile_cleanup_par *par_p) { PERL_UNUSED_THX(); par_p->dir = dirref_null(); } #define unlinkfile_early(par_p) THX_unlinkfile_early(aTHX_ par_p) PERL_STATIC_INLINE int THX_unlinkfile_early(pTHX_ struct unlinkfile_cleanup_par *par_p) { dirref_t dir = par_p->dir; PERL_UNUSED_THX(); if(unlikely(dirref_is_null(dir))) return 0; par_p->dir = dirref_null(); return dirref_rel_unlink(dir, par_p->filename); } typedef struct unlinkfile_cleanup_par *unlinkfile_ref_t; /* * string unwrapping * * A struct pvl encapsulates an octet string held as octets in memory. * The memory's allocation is independent of this structure; the memory * must have sufficient lifetime for the use to which the pvl will be put. * pvl.pv may therefore point into an SV's buffer, or into separate * mortally-allocated memory, or into a file mapping. The octet string * is not necessarily NUL-terminated; pvl.len must be used to determine * the length. * * A null value (representing the absence of a string) can be represented * as a pvl with pvl.pv null. * * pvl_from_arg() handles taking an octet string argument supplied * by a user of this module. It processes get magic exactly once. * The pvl that it returns points either into the argument's buffer or * to mortally-allocated memory. */ struct pvl { char *pv; size_t len; }; PERL_STATIC_INLINE struct pvl pvl_null(void) { struct pvl pvl; pvl.pv = NULL; pvl.len = 0; return pvl; } PERL_STATIC_INLINE bool pvl_is_null(struct pvl pvl) { return !pvl.pv; } #define pvl_from_arg(role, au, arg) THX_pvl_from_arg(aTHX_ role, au, arg) static struct pvl THX_pvl_from_arg(pTHX_ char const *role, bool allow_undef, SV *arg) { STRLEN len; size_t d; char *p, *q, *e; struct pvl pvl; SvGETMAGIC(arg); if(unlikely(sv_is_glob(arg) || sv_is_regexp(arg))) goto invalid; if(allow_undef && !SvOK(arg)) return pvl_null(); if(!likely(SvFLAGS(arg) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK))) { invalid: croak("%s is %s", role, allow_undef ? "neither an octet string nor undef" : "not an octet string"); } pvl.pv = SvPV_nomg(arg, len); pvl.len = len; if(!unlikely(SvUTF8(arg))) return pvl; e = pvl.pv + pvl.len; for(d = 0, p = pvl.pv; p != e; ) { U8 c = (U8)*p++; if(unlikely(c & 0x80)) { if(unlikely(c < 0xc2 || c > 0xc3 || p == e)) goto invalid; c = (U8)*p++; if(!likely(c >= 0x80 && c <= 0xbf)) goto invalid; d++; } } if(likely(d == 0)) return pvl; p = pvl.pv; pvl.len -= d; Newx(pvl.pv, pvl.len, char); SAVEFREEPV(pvl.pv); for(q = pvl.pv; p != e; q++) { U8 c = (U8)*p++; if(unlikely(c & 0x80)) c = ((c & 0x03) << 6) | (((U8)*p++) & 0x3f); *q = (char)c; } return pvl; } /* * event counter enumeration * * See the "event counters" section below. These need to be defined * early to feed into the MY_CXT definition below. */ #if QWITH_TALLY enum { K_STRING_READ, K_STRING_WRITE, K_BNODE_READ, K_BNODE_WRITE, K_KEY_COMPARE, K_ROOT_CHANGE_ATTEMPT, K_ROOT_CHANGE_SUCCESS, K_FILE_CHANGE_ATTEMPT, K_FILE_CHANGE_SUCCESS, K_DATA_READ_OP, K_DATA_WRITE_OP, K_SZ }; static char const * const tally_name_pv[K_SZ] = { "string_read", "string_write", "bnode_read", "bnode_write", "key_compare", "root_change_attempt", "root_change_success", "file_change_attempt", "file_change_success", "data_read_op", "data_write_op", }; #endif /* QWITH_TALLY */ /* * per-thread data */ #define MY_CXT_KEY "Hash::SharedMem::_guts"XS_VERSION typedef struct { SV *safe_undef; HV *sizes_table; HV *shash_handle_stash; #if QWITH_TALLY SV *tally_name_sv[K_SZ]; #endif /* QWITH_TALLY */ } my_cxt_t; START_MY_CXT /* * fanout limit * * This parameter is currently fixed at compile time. The value 15 is the * result of an experiment with an amd64 system. (Perhaps it is a sweet * spot due to node buffers coming in just under a power of two size.) */ #define MAXFANOUT 15 /* * parameter word * * Variable aspects of the file format are encapsulated in a word quantity * that is included in file headers. Some of the parameters are currently * fixed at compile time, and others are runtime variable. */ #if MAXFANOUT < 3 || MAXFANOUT >= BYTE_MAX || !(MAXFANOUT & 1) #error bad parameter: fanout limit unacceptable #endif /* MAXFANOUT < 3 || MAXFANOUT >= BYTE_MAX || !(MAXFANOUT & 1) */ #define PARAMETER_WORD_FIXED_PART_VALUE (MAXFANOUT<<16) #define PARAMETER_WORD(lsl, psl) \ (((word)(lsl)) | (((word)psl)<<8) | PARAMETER_WORD_FIXED_PART_VALUE) #define PARAMETER_WORD_LINE_SZ_LOG2(par) ((int)((par) & 0xff)) #define PARAMETER_WORD_PAGE_SZ_LOG2(par) ((int)(((par) >> 8) & 0xff)) #define PARAMETER_WORD_FIXED_PART(par) ((par) & ~(word)0xffff) PERL_STATIC_INLINE int llog2(long v) { int g; if(unlikely(v <= 0)) return -1; for(g = 0; !(v & 1); g++) v >>= 1; return likely(v == 1) ? g : -1; } PERL_STATIC_INLINE int parameter_known_line_size_log2(void) { #if QHAVE_SYSCONF int h = -1, l; # ifdef _SC_LEVEL1_DCACHE_LINESIZE l = llog2(sysconf(_SC_LEVEL1_DCACHE_LINESIZE)); if(likely(l > h)) h = l; # endif /* _SC_LEVEL1_DCACHE_LINESIZE */ # ifdef _SC_LEVEL2_CACHE_LINESIZE l = llog2(sysconf(_SC_LEVEL2_CACHE_LINESIZE)); if(unlikely(l > h)) h = l; # endif /* _SC_LEVEL2_DCACHE_LINESIZE */ # ifdef _SC_LEVEL3_CACHE_LINESIZE l = llog2(sysconf(_SC_LEVEL3_CACHE_LINESIZE)); if(unlikely(l > h)) h = l; # endif /* _SC_LEVEL3_DCACHE_LINESIZE */ # ifdef _SC_LEVEL4_CACHE_LINESIZE l = llog2(sysconf(_SC_LEVEL4_CACHE_LINESIZE)); if(unlikely(l > h)) h = l; # endif /* _SC_LEVEL4_DCACHE_LINESIZE */ return h; #else /* !QHAVE_SYSCONF */ return -1; #endif /* !QHAVE_SYSCONF */ } PERL_STATIC_INLINE int parameter_known_page_size_log2(void) { int l; PERL_UNUSED_VAR(l); #if QHAVE_SYSCONF # ifdef _SC_PAGESIZE l = llog2(sysconf(_SC_PAGESIZE)); if(likely(l != -1)) return l; # endif /* _SC_PAGESIZE */ # ifdef _SC_PAGE_SIZE # ifdef _SC_PAGESIZE if(_SC_PAGE_SIZE != _SC_PAGESIZE) # endif /* _SC_PAGESIZE */ { l = llog2(sysconf(_SC_PAGE_SIZE)); if(likely(l != -1)) return l; } # endif /* _SC_PAGE_SIZE */ #endif /* QHAVE_SYSCONF */ #if QHAVE_GETPAGESIZE l = llog2(getpagesize()); if(likely(l != -1)) return l; #endif /* QHAVE_GETPAGESIZE */ return -1; } PERL_STATIC_INLINE word parameter_preferred(void) { int lsl = parameter_known_line_size_log2(); int psl = parameter_known_page_size_log2(); /* * Where line/page sizes are not definitively known, guess. * The standard guesses are line size 2^6 bytes and page size * 2^12 bytes, matching the ia32/amd64 processors that are common * in 2013. If one size is known and the other is not, the guess * for the unknown parameter will be modified if necessary such * that the guessed page size is no smaller than the guessed * line size. Known line and page sizes could nevertheless be * the other way round. */ if(unlikely(psl == -1)) psl = unlikely(lsl > 12) ? lsl : 12; if(unlikely(lsl == -1)) lsl = unlikely(psl < 6) ? psl : 6; /* * Having determined (our best guess of) the system's actual * line and page size, these must now be modified to conform to * the requirements of the shash format. The shash line size * must be at least word size, and the shash page size must be * at least the line size. Sizes that are too big to deal with, * such that intra-page pointers wouldn't fit into a word, will * be reduced to a size that's still too bit to deal with but * at least is sure not to overflow the fields they have to fit. */ if(unlikely(lsl < WORD_SZ_LOG2)) lsl = WORD_SZ_LOG2; if(unlikely(psl < lsl)) psl = lsl; if(unlikely(psl > WORD_NBIT)) psl = WORD_NBIT; if(unlikely(lsl > WORD_NBIT)) lsl = WORD_NBIT; return PARAMETER_WORD(lsl, psl); } /* * size parameters * * A notional line and page size must be chosen for each shash, and should * preferably (for performance) match the target machine architecture. * Variable aspects of file layout depend on the chosen line and page * size. File offsets are precomputed and stored in struct sizes. * * In the data file header, the zero padding after the initial immutable * words (filling the remainder of the first line, unless lines are * very small) is picked out as a feature of the header so that it can * be used to represent the empty btree node and the empty string. */ #define DHD_MAGIC 0 #define DHD_PARAM (DHD_MAGIC+WORD_SZ) #define DHD_LENGTH (DHD_PARAM+WORD_SZ) #define DHD_ZEROPAD (DHD_LENGTH+WORD_SZ) #define MFL_MAGIC 0 #define MFL_PARAM (MFL_MAGIC+WORD_SZ) struct sizes { word line_align_bits, page_align_bits; word dhd_nextalloc_space, dhd_current_root, dhd_sz; word dhd_zeropad_sz; word mfl_lastalloc_datafileid, mfl_current_datafileid, mfl_sz; #if QWITH_DUP char margin; /* to be clobbered by SV duplication */ #endif /* QWITH_DUP */ }; #define IS_LINE_ALIGNED(sizes, v) (!((v) & (sizes)->line_align_bits)) #define LINE_ALIGN(sizes, v) ((((v)-1) | (sizes)->line_align_bits) + 1) #define IS_PAGE_ALIGNED(sizes, v) (!((v) & (sizes)->page_align_bits)) #define PAGE_ALIGN(sizes, v) ((((v)-1) | (sizes)->page_align_bits) + 1) #define sizes_construct(lsl, psl) THX_sizes_construct(aTHX_ lsl, psl) PERL_STATIC_INLINE struct sizes const *THX_sizes_construct(pTHX_ int line_sz_log2, int page_sz_log2) { struct sizes *sizes; PERL_UNUSED_THX(); Newx(sizes, 1, struct sizes); if(unlikely(line_sz_log2 < WORD_SZ_LOG2 || page_sz_log2 < line_sz_log2 || line_sz_log2 >= WORD_NBIT || page_sz_log2 >= WORD_NBIT)) { bad_parameters: Safefree(sizes); return NULL; } sizes->line_align_bits = (((word)1) << line_sz_log2) - 1; sizes->page_align_bits = (((word)1) << page_sz_log2) - 1; sizes->dhd_nextalloc_space = LINE_ALIGN(sizes, DHD_ZEROPAD); if(!likely(sizes->dhd_nextalloc_space)) goto bad_parameters; sizes->dhd_current_root = LINE_ALIGN(sizes, sizes->dhd_nextalloc_space + WORD_SZ); if(!likely(sizes->dhd_current_root)) goto bad_parameters; sizes->dhd_sz = LINE_ALIGN(sizes, sizes->dhd_current_root + WORD_SZ); if(!likely(sizes->dhd_sz)) goto bad_parameters; sizes->dhd_zeropad_sz = sizes->dhd_nextalloc_space - DHD_ZEROPAD; sizes->mfl_lastalloc_datafileid = LINE_ALIGN(sizes, MFL_PARAM + WORD_SZ); if(!likely(sizes->mfl_lastalloc_datafileid)) goto bad_parameters; sizes->mfl_current_datafileid = LINE_ALIGN(sizes, sizes->mfl_lastalloc_datafileid + WORD_SZ); if(!likely(sizes->mfl_current_datafileid)) goto bad_parameters; sizes->mfl_sz = PAGE_ALIGN(sizes, sizes->mfl_current_datafileid + WORD_SZ); if(!likely(sizes->mfl_sz)) goto bad_parameters; return sizes; } #define sizes_lookup(par) THX_sizes_lookup(aTHX_ aMY_CXT_ par) static SV *THX_sizes_lookup(pTHX_ pMY_CXT_ word par) { int line_sz_log2 = PARAMETER_WORD_LINE_SZ_LOG2(par); int page_sz_log2 = PARAMETER_WORD_PAGE_SZ_LOG2(par); char key[2]; SV **sizes_svp; key[0] = line_sz_log2; key[1] = page_sz_log2; sizes_svp = hv_fetch(MY_CXT.sizes_table, key, 2, 0); if(likely(sizes_svp)) { return *sizes_svp; } else { struct sizes const *sizes = sizes_construct(line_sz_log2, page_sz_log2); SV *sizes_sv; if(!likely(sizes)) return NULL; sizes_sv = newSV_type(SVt_PV); SvPV_set(sizes_sv, (char *)sizes); SvLEN_set(sizes_sv, sizeof(struct sizes)); SvREADONLY_on(sizes_sv); (void) hv_store(MY_CXT.sizes_table, key, 2, sizes_sv, 0); return sizes_sv; } } /* * magic numbers */ #define DATA_FILE_MAGIC WORD_C(0xc693dac5ed5e47c2) #define MASTER_FILE_MAGIC WORD_C(0xa58afd185cbf5af7) /* * reference-counted handling of mmaps * * We can have several objects referring to a single mapping, and those * objects' need for the mapping have largely unrelated lifetimes. * We want to keep the mapping as long as at least one object needs it. * We therefore reify mappings as SVs, so that ordinary Perl reference * counting is applied. * * However, in threaded builds we can end up needing to share a mapping * between threads. (The alternative is to duplicate the mapping, for * which there is no convenient technique.) SVs are not shared between * threads, and are duplicated across thread cloning, so each thread * has its own reference count. We therefore require a second layer of * reference counting, maintained using thread-safe atomic operators, * to manage the sharing between threads. (We could alternatively * have had objects that need the mapping directly own a thread-safe * counted reference, but presumably the intra-thread reference counting * is cheaper.) */ static int THX_mmap_mg_free(pTHX_ SV *sv, MAGIC *mg) { void *addr; PERL_UNUSED_THX(); #if QWITH_DUP if(unlikely(threadrc_dec((word*)mg->mg_ptr))) return 0; Safefree(mg->mg_ptr); #endif /* QWITH_DUP */ PERL_UNUSED_ARG(mg); addr = SvPVX(sv); if(likely(addr)) (void) munmap(addr, SvUVX(sv)); return 0; } #if QWITH_DUP static int THX_mmap_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { PERL_UNUSED_ARG(param); threadrc_inc((word*)mg->mg_ptr); return 0; } #endif /* QWITH_DUP */ static MGVTBL const mmap_mgvtbl = { 0, /* get */ 0, /* set */ 0, /* len */ 0, /* clear */ THX_mmap_mg_free, /* free */ #ifdef MGf_COPY 0, /* copy */ #endif /* MGf_COPY */ #ifdef MGf_DUP # if QWITH_DUP THX_mmap_mg_dup, /* dup */ # else /* !QWITH_DUP */ 0, /* dup */ # endif /* !QWITH_DUP */ #endif /* MGf_DUP */ #ifdef MGf_LOCAL 0, /* local */ #endif /* MGf_LOCAL */ }; #define mmap_early_unmap(mapsv) THX_mmap_early_unmap(aTHX_ mapsv) PERL_STATIC_INLINE void THX_mmap_early_unmap(pTHX_ SV *mapsv) { (void) sv_unmagicext(mapsv, PERL_MAGIC_ext, (MGVTBL*)&mmap_mgvtbl); } #define mmap_as_sv(fd, len, wr) THX_mmap_as_sv(aTHX_ fd, len, wr) static SV *THX_mmap_as_sv(pTHX_ int fd, word len, bool writable) { SV *mapsv; void *addr; if(unlikely((word)(size_t)len != len || (word)(UV)len != len)) { errno = ENOMEM; return NULL; } mapsv = sv_2mortal(newSV_type(SVt_PVMG)); #if QWITH_DUP { word *rcp; MAGIC *mg; Newxz(rcp, 1, word); mg = sv_magicext(mapsv, NULL, PERL_MAGIC_ext, (MGVTBL*)&mmap_mgvtbl, (char*)rcp, 0); mg->mg_flags |= MGf_DUP; } #else /* !QWITH_DUP */ (void) sv_magicext(mapsv, NULL, PERL_MAGIC_ext, (MGVTBL*)&mmap_mgvtbl, NULL, 0); #endif /* !QWITH_DUP */ addr = mmap(NULL, len, likely(writable) ? (PROT_READ|PROT_WRITE) : PROT_READ, MAP_SHARED, fd, 0); if(unlikely(addr == MAP_FAILED)) return NULL; SvPV_set(mapsv, (char *)addr); SvUV_set(mapsv, len); return mapsv; } /* * event counters * * To make these cheap to use, each counter is just a word quantity. * It is possible for these to wrap. */ #if QWITH_TALLY # define tally_boot() THX_tally_boot(aTHX_ aMY_CXT) PERL_STATIC_INLINE void THX_tally_boot(pTHX_ pMY_CXT) { int i; for(i = 0; i != K_SZ; i++) MY_CXT.tally_name_sv[i] = newSVpv_share(tally_name_pv[i], 0); } struct tally { word k[K_SZ]; }; # define tally_event(st, type) ((void) ((st)->k[type]++)) # define tally_zero(st) THX_tally_zero(aTHX_ st) PERL_STATIC_INLINE void THX_tally_zero(pTHX_ struct tally *tally) { PERL_UNUSED_THX(); Zero(tally, 1, struct tally); } PERL_STATIC_INLINE void tally_add(struct tally *a, struct tally const *b) { int i; for(i = 0; i != K_SZ; i++) a->k[i] += b->k[i]; } # define tally_newSVword(v) THX_tally_newSVword(aTHX_ v) PERL_STATIC_INLINE SV *THX_tally_newSVword(pTHX_ word v) { if(likely((word)(UV)v == v)) { return newSVuv((UV)v); } else { /* * UV isn't big enough. To represent the word value * exactly, generate a string in decimal. The exact * numerical value can be recovered from that if the user * tries hard, and if not then conversion to the default * numeric types will at least have familiar behaviour. * * There might be a printf format that can decimalise a * word, but there also might not be. As it won't make a * huge difference to performance, rather than have two * versions of the code, we just take the DIY approach. * We know unsigned int is at least 32 bits (because the * Perl core requires that) and we have a printf format * for it. */ char buf[21], *p; (void) sprintf(buf, "%08u%06u%06u", (unsigned) (v / WORD_C(1000000000000)), (unsigned) ((v / WORD_C(1000000)) % WORD_C(1000000)), (unsigned) (v % WORD_C(1000000))); for(p = buf; p[0] == '0'; p++) ; return newSVpvn(p, buf+20 - p); } } # define tally_as_hvref(st) THX_tally_as_hvref(aTHX_ st) PERL_STATIC_INLINE SV *THX_tally_as_hvref(pTHX_ struct tally const *tally) { dMY_CXT; HV *hv = newHV(); SV *hvref = newRV_ro_mortal_noinc((SV*)hv); int i; for(i = 0; i != K_SZ; i++) { SV *v = tally_newSVword(tally->k[i]); SvREADONLY_on(v); (void) hv_store_ent(hv, MY_CXT.tally_name_sv[i], v, SvSHARED_HASH(MY_CXT.tally_name_sv[i])); } return hvref; } #else /* !QWITH_TALLY */ # define tally_boot() ((void) 0) # define tally_event(st, type) ((void) 0) # define tally_zero(st) ((void) 0) # define tally_add(a, b) ((void) 0) # define tally_as_hvref(st) newRV_ro_mortal_noinc((SV*)newHV()) #endif /* !QWITH_TALLY */ /* * top-level shash representation * * The same structure is used both for live shash handles that can * update and for snapshot handles. Where a live shash has a memory * mapping of the master file, a snapshot has a frozen root pointer. * Both types of handle have a memory mapping of the data file. A live * shash also has a file descriptor pointing at the directory. * * The same mode flag set is used for opening modes and for handle modes, * because of the overlap. */ #define STOREMODE_READ 0x01 #define STOREMODE_WRITE 0x02 #define STOREMODE_CREATE 0x04 #define STOREMODE_EXCLUDE 0x08 #define STOREMODE_SNAPSHOT 0x10 struct shash { unsigned mode; word data_size; word parameter; #if QWITH_TALLY struct tally tally; #endif /* QWITH_TALLY */ union { struct { word data_file_id; dirref_t dir; SV *master_mmap_sv; void *master_mmap; } live; struct { word root; } snapshot; } u; SV *top_pathname_sv; SV *data_mmap_sv; void *data_mmap; #if QWITH_DUP SV *sizes_sv; #endif /* QWITH_DUP */ struct sizes const *sizes; /* * The last member of this structure must be one that can * be reconstructed from others, because the default scalar * duplication code doesn't quite copy the scalar's entire * allocated buffer. It expects a scalar's buffer to contain * a nul-terminated string, meaning that the last byte of the * buffer is either the terminating nul or junk past the end of * the string, so it doesn't actually copy that byte, but sets * it to nul. So when this structure is stored in a scalar's * buffer, with no nul terminator, the last member will be * clobbered in the process of duplication, before our custom * duplication code gets to run. */ }; static int THX_shash_mg_free(pTHX_ SV *sv, MAGIC *mg) { struct shash *sh = (struct shash *)SvPVX(sv); PERL_UNUSED_ARG(mg); if(!(sh->mode & STOREMODE_SNAPSHOT)) { if(likely(sh->u.live.master_mmap_sv)) SvREFCNT_dec_NN(sh->u.live.master_mmap_sv); if(likely(!dirref_is_null(sh->u.live.dir))) dirref_close(sh->u.live.dir); } if(likely(sh->top_pathname_sv)) SvREFCNT_dec_NN(sh->top_pathname_sv); if(likely(sh->data_mmap_sv)) SvREFCNT_dec_NN(sh->data_mmap_sv); return 0; } #if QWITH_DUP static int THX_shash_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { struct shash *sh = (struct shash *)SvPVX(mg->mg_obj); if(!(sh->mode & STOREMODE_SNAPSHOT)) { if(likely(sh->u.live.master_mmap_sv)) { sh->u.live.master_mmap_sv = sv_dup_inc(sh->u.live.master_mmap_sv, param); sh->u.live.master_mmap = SvPVX(sh->u.live.master_mmap_sv); } sh->u.live.dir = dirref_dup(sh->u.live.dir); } sh->top_pathname_sv = sv_dup_inc(sh->top_pathname_sv, param); if(likely(sh->data_mmap_sv)) { sh->data_mmap_sv = sv_dup_inc(sh->data_mmap_sv, param); sh->data_mmap = SvPVX(sh->data_mmap_sv); } if(likely(sh->sizes_sv)) { sh->sizes_sv = sv_dup_inc(sh->sizes_sv, param); sh->sizes = (struct sizes const *)SvPVX(sh->sizes_sv); } return 0; } #endif /* QWITH_DUP */ static MGVTBL const shash_mgvtbl = { 0, /* get */ 0, /* set */ 0, /* len */ 0, /* clear */ THX_shash_mg_free, /* free */ #ifdef MGf_COPY 0, /* copy */ #endif /* MGf_COPY */ #ifdef MGf_DUP # if QWITH_DUP THX_shash_mg_dup, /* dup */ # else /* !QWITH_DUP */ 0, /* dup */ # endif /* !QWITH_DUP */ #endif /* MGf_DUP */ #ifdef MGf_LOCAL 0, /* local */ #endif /* MGf_LOCAL */ }; #define shash_apply_magic(shsv) THX_shash_apply_magic(aTHX_ shsv) PERL_STATIC_INLINE void THX_shash_apply_magic(pTHX_ SV *shsv) { MAGIC *mg = sv_magicext(shsv, shsv, PERL_MAGIC_ext, (MGVTBL*)&shash_mgvtbl, NULL, 0); PERL_UNUSED_VAR(mg); #if QWITH_DUP mg->mg_flags |= MGf_DUP; #endif /* QWITH_DUP */ } #define shash_or_null_from_svref(shsvref) \ THX_shash_or_null_from_svref(aTHX_ shsvref) static struct shash *THX_shash_or_null_from_svref(pTHX_ SV *shsvref) { dMY_CXT; SV *shsv; SvGETMAGIC(shsvref); return likely(SvROK(shsvref) && (shsv = SvRV(shsvref)) && SvOBJECT(shsv) && SvSTASH(shsv) == MY_CXT.shash_handle_stash) ? (struct shash *)SvPVX(shsv) : NULL; } #define arg_error_notshash() THX_arg_error_notshash(aTHX) PERL_STATIC_INLINE void THX_arg_error_notshash(pTHX) __attribute__noreturn__; PERL_STATIC_INLINE void THX_arg_error_notshash(pTHX) { PERL_UNUSED_THX(); croak("handle is not a shared hash handle"); } #define shash_from_svref(shsvref) THX_shash_from_svref(aTHX_ shsvref) static struct shash *THX_shash_from_svref(pTHX_ SV *shsvref) { struct shash *sh = shash_or_null_from_svref(shsvref); if(!likely(sh)) arg_error_notshash(); return sh; } #define arg_is_shash(arg) THX_arg_is_shash(aTHX_ arg) PERL_STATIC_INLINE bool THX_arg_is_shash(pTHX_ SV *arg) { return cBOOL(shash_or_null_from_svref(arg)); } #define arg_check_shash(arg) THX_arg_check_shash(aTHX_ arg) static void THX_arg_check_shash(pTHX_ SV *arg) { if(!likely(arg_is_shash(arg))) arg_error_notshash(); } #define shash_error(sh, act, msg) THX_shash_error(aTHX_ sh, act, msg) static void THX_shash_error(pTHX_ struct shash *sh, char const *action, char const *message) __attribute__noreturn__; static void THX_shash_error(pTHX_ struct shash *sh, char const *action, char const *message) { #if !PERL_VERSION_GE(5,8,1) SV *m = mess("can't %s shared hash %"SVf": %s", action, sh->top_pathname_sv, message); sv_setsv(ERRSV, m); croak(NULL); #else /* >=5.8.1 */ # if !PERL_VERSION_GE(5,10,1) SvUTF8_off(ERRSV); # endif /* <5.10.1 */ croak("can't %s shared hash %"SVf": %s", action, sh->top_pathname_sv, message); #endif /* >=5.8.1 */ } #define shash_error_data(sh) THX_shash_error_data(aTHX_ sh) static void THX_shash_error_data(pTHX_ struct shash *sh) __attribute__noreturn__; static void THX_shash_error_data(pTHX_ struct shash *sh) { shash_error(sh, "use", "shared hash is corrupted"); } #define shash_error_errnum(sh, act, en) \ THX_shash_error_errnum(aTHX_ sh, act, en) static void THX_shash_error_errnum(pTHX_ struct shash *sh, char const *action, int errnum) __attribute__noreturn__; static void THX_shash_error_errnum(pTHX_ struct shash *sh, char const *action, int errnum) { shash_error(sh, action, my_strerror(errnum)); } #define shash_unlinkfile_early(sh, act, par_p) \ THX_shash_unlinkfile_early(aTHX_ sh, act, par_p) static void THX_shash_unlinkfile_early(pTHX_ struct shash *sh, char const *action, struct unlinkfile_cleanup_par *par_p) { int e; if(likely(unlinkfile_early(par_p) != -1)) return; e = errno; if(likely(e == ENOENT) || likely(e == EBUSY)) return; shash_error_errnum(sh, action, e); } #define shash_error_errno(sh, act) THX_shash_error_errno(aTHX_ sh, act) static void THX_shash_error_errno(pTHX_ struct shash *sh, char const *action) __attribute__noreturn__; static void THX_shash_error_errno(pTHX_ struct shash *sh, char const *action) { shash_error_errnum(sh, action, errno); } #define shash_check_readable(sh, act) THX_shash_check_readable(aTHX_ sh, act) static void THX_shash_check_readable(pTHX_ struct shash *sh, char const *action) { if(!likely(sh->mode & STOREMODE_READ)) shash_error(sh, action, "shared hash was opened in unreadable mode"); } #define shash_check_writable(sh, act) THX_shash_check_writable(aTHX_ sh, act) static void THX_shash_check_writable(pTHX_ struct shash *sh, char const *action) { if(unlikely(sh->mode & STOREMODE_SNAPSHOT)) shash_error(sh, action, "shared hash handle is a snapshot"); if(!likely(sh->mode & STOREMODE_WRITE)) shash_error(sh, action, "shared hash was opened in unwritable mode"); } /* shash file handling */ #define FILENAME_PREFIX_LEN 10 #define MASTER_FILENAME "iNmv0,m$%3" #define DATA_FILENAME_PREFIX "&\"JBLMEgGm" #define DATA_FILENAME_SUFFIX_LEN (WORD_SZ<<1) #define TEMP_FILENAME_PREFIX "DNaM6okQi;" #define DATA_FILENAME_BUFSIZE (FILENAME_PREFIX_LEN+DATA_FILENAME_SUFFIX_LEN+1) #define dir_make_data_filename(buf, fid) \ THX_dir_make_data_filename(aTHX_ buf, fid) static void THX_dir_make_data_filename(pTHX_ char *buf, word fileid) { PERL_UNUSED_THX(); (void) sprintf(buf, "%s%08x%08x", DATA_FILENAME_PREFIX, (unsigned)(fileid >> 32), (unsigned)(fileid & WORD_C(0xffffffff))); } #define TEMP_FILENAME_BUFSIZE (FILENAME_PREFIX_LEN+8+8+8+1) #define dir_make_temp_filename(buf) THX_dir_make_temp_filename(aTHX_ buf) PERL_STATIC_INLINE void THX_dir_make_temp_filename(pTHX_ char *buf) { unsigned s, ns; PERL_UNUSED_THX(); #if QHAVE_CLOCK_GETTIME && defined(CLOCK_REALTIME) { struct timespec ts; if(likely(clock_gettime(CLOCK_REALTIME, &ts) == 0)) { s = ts.tv_sec; ns = ts.tv_nsec; goto got_time; } } #endif /* QHAVE_CLOCK_GETTIME && CLOCK_REALTIME */ #if QHAVE_GETTIMEOFDAY { struct timeval tv; if(likely(gettimeofday(&tv, NULL) == 0)) { s = tv.tv_sec; ns = tv.tv_usec * 1000; goto got_time; } } #endif /* QHAVE_GETTIMEOFDAY */ { s = time(NULL); ns = 0; goto got_time; } got_time: (void) sprintf(buf, "%s%08x%08x%08x", TEMP_FILENAME_PREFIX, s & 0xffffffffU, ns & 0xffffffffU, ((unsigned)getpid()) & 0xffffffffU); } enum { FILENAME_CLASS_BOGUS, FILENAME_CLASS_MASTER, FILENAME_CLASS_TEMP, FILENAME_CLASS_DATA }; #define dir_filename_class(fn, id_p) THX_dir_filename_class(aTHX_ fn, id_p) static int THX_dir_filename_class(pTHX_ char const *filename, word *id_p) { size_t fnlen; PERL_UNUSED_THX(); if(filename[0] == '.') return FILENAME_CLASS_MASTER; fnlen = strlen(filename); if(fnlen == FILENAME_PREFIX_LEN && memcmp(filename, MASTER_FILENAME, FILENAME_PREFIX_LEN) == 0) return FILENAME_CLASS_MASTER; if(fnlen >= FILENAME_PREFIX_LEN && memcmp(filename, TEMP_FILENAME_PREFIX, FILENAME_PREFIX_LEN) == 0) return FILENAME_CLASS_TEMP; if(likely(fnlen == FILENAME_PREFIX_LEN+DATA_FILENAME_SUFFIX_LEN && memcmp(filename, DATA_FILENAME_PREFIX, FILENAME_PREFIX_LEN) == 0)) { char const *p; word id = 0; for(p = filename+FILENAME_PREFIX_LEN; ; p++) { char c = *p; word v; if(!c) break; if(likely(c >= '0' && c <= '9')) { v = c - '0'; } else if(likely(c >= 'a' && c <= 'f')) { v = c - 'a' + 10; } else { return FILENAME_CLASS_BOGUS; } id = (id << 4) | v; } if(likely(id != 0)) { *id_p = id; return FILENAME_CLASS_DATA; } } return FILENAME_CLASS_BOGUS; } typedef void (*iterate_fn_t)(pTHX_ struct shash *sh, char const *action, char const *fn, word arg); #define dir_iterate(sh, act, iter, arg) \ THX_dir_iterate(aTHX_ sh, act, iter, arg) static void THX_dir_iterate(pTHX_ struct shash *sh, char const *action, iterate_fn_t THX_iterate, word arg) { DIR *dirh; closedirh_ref_t dirhr; int old_errno = errno; dirh = dirref_dir_opendir(sh->u.live.dir); if(!likely(dirh)) shash_error_errno(sh, action); dirhr = closedirh_save(dirh); while(1) { struct dirent *de; errno = 0; de = readdir(dirh); if(!likely(de)) break; THX_iterate(aTHX_ sh, action, de->d_name, arg); } if(unlikely(errno)) shash_error_errno(sh, action); errno = old_errno; closedirh_early(dirhr); } static void THX_dir_clean_file(pTHX_ struct shash *sh, char const *action, char const *fn, word curfileid) { word fileid; int cls = dir_filename_class(fn, &fileid); int e; if(!unlikely(cls == FILENAME_CLASS_TEMP || (cls == FILENAME_CLASS_DATA && unlikely((curfileid - fileid - 1) < (((word)1) << 62))))) return; if(!unlikely(dirref_rel_unlink(sh->u.live.dir, fn) == -1)) return; e = errno; if(likely(e == ENOENT) || likely(e == EBUSY)) return; shash_error_errnum(sh, action, e); } #define dir_clean(sh, act, curfileid) THX_dir_clean(aTHX_ sh, act, curfileid) PERL_STATIC_INLINE void THX_dir_clean(pTHX_ struct shash *sh, char const *action, word curfileid) { dir_iterate(sh, action, THX_dir_clean_file, curfileid); } /* * shash operation fundamentals * * Allocation of space in the shash is slightly complexified in order to * use space efficiently, because at the low level allocation must be of * integral lines, but objects only need to be word-aligned. Allocation * of word-aligned space is performed by shash_alloc(). Where possible, * this allocates from a line already owned by this process. If it * needs to acquire a new line, and the new line happens to abut one * already owned (which happens if no other process allocated space in * the intervening time), it will take advantage of the contiguous region. * * Allocation is managed separately for each write operation. The state * of allocation is managed in a struct shash_alloc, which must be created * (on the stack) by the top-level mutation function. Principally this * structure records any partial line that is owned by this process * and available for allocation. When a write operation is complete, * the allocation state (and any unused partial line) is discarded. */ #define NULL_PTR (~(word)0) #define ZEROPAD_PTR ((word)DHD_ZEROPAD) #define PTR_FLAG_ROLLOVER ((word)1) #define unchecked_pointer_loc(sh, ptr) (&WORD_AT(sh->data_mmap, ptr)) #define pointer_loc(sh, ptr, sp) THX_pointer_loc(aTHX_ sh, ptr, sp) static word *THX_pointer_loc(pTHX_ struct shash *sh, word ptr, word *spc_p) { word ds = sh->data_size; if(!likely(IS_WORD_ALIGNED(ptr))) shash_error_data(sh); if(unlikely(ptr >= ds)) shash_error_data(sh); *spc_p = ds - ptr; return unchecked_pointer_loc(sh, ptr); } #define shash_ensure_data_file(sh) THX_shash_ensure_data_file(aTHX_ sh) static void THX_shash_ensure_data_file(pTHX_ struct shash *sh) { word datafileid; char data_filename[DATA_FILENAME_BUFSIZE]; int data_fd; closefd_ref_t fdr; struct stat statbuf; SV *mapsv; tmps_ix_t old_tmps_floor; datafileid = word_get(&WORD_AT(sh->u.live.master_mmap, sh->sizes->mfl_current_datafileid)); if(likely(mapsv = sh->data_mmap_sv)) { if(likely(datafileid == sh->u.live.data_file_id)) return; sh->data_mmap_sv = NULL; SvREFCNT_dec_NN(mapsv); } attempt_to_open_data: if(unlikely(datafileid == 0)) { word dsz = PAGE_ALIGN(sh->sizes, sh->sizes->dhd_sz + WORD_SZ); char *map; if(unlikely(!dsz || (word)(size_t)dsz != dsz || (word)(STRLEN)dsz != dsz)) shash_error_errnum(sh, "use", ENOMEM); Newxz(map, dsz, char); WORD_AT(map, DHD_MAGIC) = DATA_FILE_MAGIC; WORD_AT(map, DHD_PARAM) = sh->parameter; WORD_AT(map, DHD_LENGTH) = dsz; WORD_AT(map, sh->sizes->dhd_nextalloc_space) = dsz; WORD_AT(map, sh->sizes->dhd_current_root) = sh->sizes->dhd_sz | PTR_FLAG_ROLLOVER; mapsv = newSV_type(SVt_PV); SvPV_set(mapsv, map); SvLEN_set(mapsv, dsz); sh->data_mmap = map; sh->data_mmap_sv = mapsv; sh->data_size = dsz; sh->u.live.data_file_id = 0; return; } dir_make_data_filename(data_filename, datafileid); data_fd = dirref_rel_open_cloexec(sh->u.live.dir, data_filename, likely(sh->mode & STOREMODE_WRITE) ? O_RDWR : O_RDONLY, 0); if(unlikely(data_fd == -1)) { word newdatafileid; if(unlikely(errno != ENOENT)) shash_error_errno(sh, "use"); newdatafileid = word_get(&WORD_AT(sh->u.live.master_mmap, sh->sizes->mfl_current_datafileid)); if(likely(newdatafileid != datafileid)) { datafileid = newdatafileid; goto attempt_to_open_data; } shash_error_data(sh); } fdr = closefd_save(data_fd); if(unlikely(fstat(data_fd, &statbuf) == -1)) shash_error_errno(sh, "use"); if(!likely(S_ISREG(statbuf.st_mode) && (off_t)(word)statbuf.st_size == statbuf.st_size && (word)statbuf.st_size >= sh->sizes->dhd_sz && IS_PAGE_ALIGNED(sh->sizes, (word)statbuf.st_size))) shash_error_data(sh); sh->data_size = statbuf.st_size; old_tmps_floor = PL_tmps_floor; SAVETMPS; mapsv = mmap_as_sv(data_fd, sh->data_size, cBOOL(sh->mode & STOREMODE_WRITE)); if(!likely(mapsv)) shash_error_errno(sh, "use"); sh->u.live.data_file_id = datafileid; sh->data_mmap_sv = SvREFCNT_inc_simple_NN(mapsv); sh->data_mmap = SvPVX(mapsv); FREETMPS; PL_tmps_floor = old_tmps_floor; closefd_early(fdr); if(!likely(WORD_AT(sh->data_mmap, DHD_MAGIC) == DATA_FILE_MAGIC && WORD_AT(sh->data_mmap, DHD_PARAM) == sh->parameter && WORD_AT(sh->data_mmap, DHD_LENGTH) == sh->data_size)) shash_error_data(sh); } #define shash_error_toobig(sh, act) THX_shash_error_toobig(aTHX_ sh, act) static void THX_shash_error_toobig(pTHX_ struct shash *sh, char const *action) __attribute__noreturn__; static void THX_shash_error_toobig(pTHX_ struct shash *sh, char const *action) { shash_error(sh, action, "data too large for a shared hash"); } struct shash_alloc { word prealloc_len; byte *prealloc_loc; char const *action; jmp_buf fulljb; }; #define shash_alloc(sh, alloc, len, pp) \ THX_shash_alloc(aTHX_ sh, alloc, len, pp) static word *THX_shash_alloc(pTHX_ struct shash *sh, struct shash_alloc *alloc, word len, word *ptr_p) { byte *prealloc_end, *loc; word *nextalloc_p, data_size, pos, epos; word wlen = WORD_ALIGN(len), llen; if(!likely(wlen) && unlikely(len)) shash_error_toobig(sh, alloc->action); if(unlikely(wlen <= alloc->prealloc_len)) goto got_prealloc; prealloc_end = alloc->prealloc_loc + alloc->prealloc_len; nextalloc_p = &WORD_AT(sh->data_mmap, sh->sizes->dhd_nextalloc_space); data_size = sh->data_size; pos = word_get(nextalloc_p); if(unlikely(!IS_LINE_ALIGNED(sh->sizes, pos) || pos > data_size)) shash_error_data(sh); if(likely(&BYTE_AT(sh->data_mmap, pos) == prealloc_end)) { llen = LINE_ALIGN(sh->sizes, wlen - alloc->prealloc_len); if(!likely(llen)) shash_error_toobig(sh, alloc->action); epos = pos + llen; if(unlikely(epos < pos || epos > data_size)) longjmp(alloc->fulljb, 1); if(likely(word_cset(nextalloc_p, pos, epos))) { alloc->prealloc_len += llen; goto got_prealloc; } } llen = LINE_ALIGN(sh->sizes, wlen); if(!likely(llen)) shash_error_toobig(sh, alloc->action); while(1) { pos = word_get(nextalloc_p); if(unlikely(!IS_LINE_ALIGNED(sh->sizes, pos) || pos > data_size)) shash_error_data(sh); epos = pos + llen; if(unlikely(epos < pos || epos > data_size)) longjmp(alloc->fulljb, 1); if(likely(word_cset(nextalloc_p, pos, epos))) { byte *newalloc_loc = &BYTE_AT(sh->data_mmap, pos); alloc->prealloc_loc = newalloc_loc; alloc->prealloc_len = llen; break; } } got_prealloc: loc = alloc->prealloc_loc; alloc->prealloc_loc += wlen; alloc->prealloc_len -= wlen; *ptr_p = loc - (byte*)sh->data_mmap; return (word*)loc; } /* strings in the shash */ #define string_as_pvl(sh, ptr) THX_string_as_pvl(aTHX_ sh, ptr) static struct pvl THX_string_as_pvl(pTHX_ struct shash *sh, word ptr) { word len, *loc, spc, alloclen; struct pvl pvl; loc = pointer_loc(sh, ptr, &spc); len = loc[0]; alloclen = len + WORD_SZ+1; if(unlikely(alloclen < WORD_SZ+1 || alloclen > spc)) shash_error_data(sh); if(unlikely((word)(size_t)len != len)) shash_error_errnum(sh, "use", ENOMEM); pvl.pv = (char*)&loc[1]; pvl.len = len; if(unlikely(pvl.pv[pvl.len])) shash_error_data(sh); tally_event(&sh->tally, K_STRING_READ); return pvl; } static MGVTBL const string_mmapref_mgvtbl; #define string_as_sv(sh, act, ptr) THX_string_as_sv(aTHX_ sh, act, ptr) static SV *THX_string_as_sv(pTHX_ struct shash *sh, char const *action, word ptr) { struct pvl pvl = string_as_pvl(sh, ptr); SV *sv; if(unlikely((size_t)(STRLEN)pvl.len != pvl.len)) shash_error_errnum(sh, action, ENOMEM); TAINT; /* * There are two strategies available for returning the string * as an SV. We can copy into a plain string SV, or we can point * into the mmaped space. In the latter case the result SV needs * magic to keep a reference to the object representing the mmap, * to keep it mapped. In both time and memory, the overhead of * pointing into the mmap is pretty much fixed, but the overhead * of copying is roughly linear in the length of the string. * The base overhead for copying is much less than the fixed * overhead of mapping. * * We therefore want to copy short strings and map long strings. * Choosing the threshold at which to switch is a black art. * * Empirical result for perl 5.16 on amd64 with glibc 2.11 * is that 119-octet strings are better copied and 120-octet * strings are better mapped, with a sharp step in the cost of * copying at that length. This is presumably due to the memory * allocator switching strategy when allocating 128 octets or more * (rounded up from 120+1). * * The memory allocations of interest are one XPV and the * buffer for copying, and one XPVMG and one MAGIC for mapping. * The ugly expression here tries to compare the two sets of * allocations. The XPVMG+MAGIC - XPV difference is compared * against the potential buffer size. It is presumed that the * buffer length will be rounded up to a word-aligned size. * The structure size difference is rounded up in an attempt to * find a threshold likely to be used by the memory allocator. * Ideally this would be rounded to the next power of 2, but we * can't implement that in a constant expression, so it's actually * rounded to the next multiple of the XPVMG size. The formula * is slightly contrived so as to achieve the exact 120-octet * threshold on the amd64 system used for speed trials (where * MAGIC is 40 octets, XPV is 32 octets, and XPVMG is 64 octets). */ if(pvl.len < sizeof(XPVMG) * ((sizeof(MAGIC)+sizeof(XPVMG)*2-1) / sizeof(XPVMG)) - sizeof(size_t)) { sv = newSVpvn_mortal(pvl.pv, pvl.len); } else { sv = sv_2mortal(newSV_type(SVt_PVMG)); (void) sv_magicext(sv, sh->data_mmap_sv, PERL_MAGIC_ext, (MGVTBL*)&string_mmapref_mgvtbl, NULL, 0); SvPV_set(sv, pvl.pv); SvCUR_set(sv, pvl.len); SvPOK_on(sv); SvTAINTED_on(sv); } SvREADONLY_on(sv); return sv; } #define string_cmp_pvl(sh, aptr, bpvl) THX_string_cmp_pvl(aTHX_ sh, aptr, bpvl) static int THX_string_cmp_pvl(pTHX_ struct shash *sh, word aptr, struct pvl bpvl) { struct pvl apvl = string_as_pvl(sh, aptr); int r; tally_event(&sh->tally, K_KEY_COMPARE); r = memcmp(apvl.pv, bpvl.pv, apvl.len < bpvl.len ? apvl.len : bpvl.len); return r ? r : apvl.len == bpvl.len ? 0 : apvl.len < bpvl.len ? -1 : 1; } #define string_eq_pvl(sh, aptr, bpvl) THX_string_eq_pvl(aTHX_ sh, aptr, bpvl) PERL_STATIC_INLINE int THX_string_eq_pvl(pTHX_ struct shash *sh, word aptr, struct pvl bpvl) { struct pvl apvl = string_as_pvl(sh, aptr); return apvl.len == bpvl.len && memcmp(apvl.pv, bpvl.pv, apvl.len) == 0; } #define string_write_from_pvl(sh, alloc, pvl) \ THX_string_write_from_pvl(aTHX_ sh, alloc, pvl) static word THX_string_write_from_pvl(pTHX_ struct shash *sh, struct shash_alloc *alloc, struct pvl pvl) { word alloclen, ptr, *loc; if(unlikely((size_t)(word)pvl.len != pvl.len)) shash_error_toobig(sh, alloc->action); if(unlikely(pvl.len == 0) && likely(sh->sizes->dhd_zeropad_sz >= WORD_SZ+1)) return ZEROPAD_PTR; alloclen = ((word)pvl.len) + WORD_SZ + 1; if(unlikely(alloclen < WORD_SZ+1)) shash_error_toobig(sh, alloc->action); loc = shash_alloc(sh, alloc, alloclen, &ptr); loc[0] = pvl.len; (void) memcpy(&loc[1], pvl.pv, pvl.len); ((byte*)&loc[1])[pvl.len] = 0; tally_event(&sh->tally, K_STRING_WRITE); return ptr; } #define string_size(sh, ptr) THX_string_size(aTHX_ sh, ptr) PERL_STATIC_INLINE word THX_string_size(pTHX_ struct shash *sh, word ptr) { word spc; word len = pointer_loc(sh, ptr, &spc)[0]; if(unlikely(len == 0) && likely(sh->sizes->dhd_zeropad_sz >= WORD_SZ+1)) return 0; return WORD_ALIGN(len + WORD_SZ+1); } #define string_migrate(shf, ptrf, sht, alloct) \ THX_string_migrate(aTHX_ shf, ptrf, sht, alloct) PERL_STATIC_INLINE word THX_string_migrate(pTHX_ struct shash *shf, word ptrf, struct shash *sht, struct shash_alloc *alloct) { return string_write_from_pvl(sht, alloct, string_as_pvl(shf, ptrf)); } /* * btrees in the shash * * Things are a bit asymmetric because we're only caching lower bound * keys in the btree nodes. For the most part, the first key in each * node is ignored, because it isn't needed in order to decide where * to descend. The other keys (numbering one less than the number of * subnodes) are treated as boundaries between the subnodes. Thus for * descent purposes the leftmost nodes are treated as if ther lower * bound key is the empty string (the leftmost possible key). * * The first key in a node is only interesting at the leaf layer, where * ordering relative to the target key needs to be fully resolved. * However, when descending to a non-leftmost node, the comparison * against the node's first key has already been made in the parent node. * So the node's first key only needs to be fully included in the search * process for the leftmost leaf node. * * When inserting into the btree, by using the same search mechanism we * always end up inserting subnodes after some existing subnode, except * in the necessary special case where the key of interest precedes the * first key in the shash. * * A cursor points to a location in a btree, keeping track of all of * its ancestor nodes and the relevant index in each node. It can be * used as if it points to an item in the btree, or as if it points to a * gap (either between items or to the left or right of all the items). * The cursor structure doesn't record which way it's being used; that's * a matter of interpretation. A cursor structure pointing at an item * is identical to the cursor structure pointing at the gap immediately * to the right of that item. In order to represent pointing at the gap * immediately to the left of the leftmost item, the cursor structure * may point to a notional item just to the left of the leftmost item, * in which case the index in each node is 0, except in the leaf layer, * where the index is -1. */ #define MINFANOUT ((MAXFANOUT+1)>>1) #define LAYER_MAX 0x3f #define bnode_header_layer(h) ((h) & LAYER_MAX) #define bnode_header_fanout(h) (((h) >> 8) & BYTE_MAX) #define bnode_header_pad(h) ((h) & WORD_C(0xffffffffffff00c0)) #define bnode_body_loc(loc) (&(loc)[1]) #define bnode_check(sh, np, el, lp, fo) \ THX_bnode_check(aTHX_ sh, np, el, lp, fo) static word const *THX_bnode_check(pTHX_ struct shash *sh, word ptr, int expect_layer, int *layer_p, int *fanout_p) { word header, spc; word const *loc; int layer, fanout; loc = pointer_loc(sh, ptr, &spc); header = loc[0]; layer = bnode_header_layer(header); fanout = bnode_header_fanout(header); if(unlikely(bnode_header_pad(header) || fanout > MAXFANOUT || spc < WORD_SZ + (((size_t)fanout) << (WORD_SZ_LOG2+1)))) shash_error_data(sh); if(unlikely(expect_layer == -1)) { if(unlikely(fanout < 2 && layer != 0)) shash_error_data(sh); } else { if(unlikely(layer != expect_layer || fanout < MINFANOUT)) shash_error_data(sh); } *layer_p = layer; *fanout_p = fanout; tally_event(&sh->tally, K_BNODE_READ); return loc; } #define BNODE_SEARCH_EXACT INT_MIN #define bnode_search(sh, nl, fo, lm, kpvl) \ THX_bnode_search(aTHX_ sh, nl, fo, lm, kpvl) static int THX_bnode_search(pTHX_ struct shash *sh, word const *loc, int fanout, bool leftmost, struct pvl keypvl) { int l, r; word const *nodebody = bnode_body_loc(loc); for(l = unlikely(leftmost) ? -1 : 0, r = fanout - 1; l != r; ) { /* binary search invariant: * search key > lower bount of subnode [l] * search key < upper bound of subnode [r] */ int m = (l+r+1) >> 1; int cmpm = string_cmp_pvl(sh, nodebody[m << 1], keypvl); if(unlikely(cmpm == 0)) { return BNODE_SEARCH_EXACT | (m + 1); } else if(cmpm > 0) { r = m-1; } else { l = m; } } return l + 1; } #define bnode_write(sh, alloc, nh, ne, nb) \ THX_bnode_write(aTHX_ sh, alloc, nh, ne, nb) static word THX_bnode_write(pTHX_ struct shash *sh, struct shash_alloc *alloc, int layer, int fanout, word const *nodebody) { word ptr, *loc; if(unlikely(fanout == 0) && likely(layer == 0) && likely(sh->sizes->dhd_zeropad_sz >= WORD_SZ)) return ZEROPAD_PTR; loc = shash_alloc(sh, alloc, WORD_SZ + (fanout << (WORD_SZ_LOG2+1)), &ptr); loc[0] = layer | (fanout << 8); (void) memcpy(&loc[1], nodebody, fanout << (WORD_SZ_LOG2+1)); tally_event(&sh->tally, K_BNODE_WRITE); return ptr; } struct cursor_entry { word nodeptr; short index; byte fanout; }; struct cursor { byte root_layer; struct cursor_entry ent[LAYER_MAX+1]; }; #define btree_seek_key(sh, cs, rt, keypvl) \ THX_btree_seek_key(aTHX_ sh, cs, rt, keypvl) static bool THX_btree_seek_key(pTHX_ struct shash *sh, struct cursor *cursor, word root, struct pvl keypvl) { bool leftmost = 1; int layer, pos, fanout; word ptr; word const *ndloc; ndloc = bnode_check(sh, root, -1, &layer, &fanout); cursor->root_layer = layer; cursor->ent[layer].nodeptr = root; while(1) { cursor->ent[layer].fanout = fanout; pos = bnode_search(sh, ndloc, fanout, leftmost && layer == 0, keypvl); cursor->ent[layer].index = (pos & ~BNODE_SEARCH_EXACT) - 1; if(unlikely(pos & BNODE_SEARCH_EXACT)) goto exact_match; if(unlikely(layer == 0)) return 0; if(likely(pos != 1)) leftmost = 0; ptr = bnode_body_loc(ndloc)[(pos<<1)-1]; layer--; cursor->ent[layer].nodeptr = ptr; ndloc = bnode_check(sh, ptr, layer, &layer, &fanout); } exact_match: if(likely(layer == 0)) return 1; ptr = bnode_body_loc(ndloc)[((pos&~BNODE_SEARCH_EXACT)<<1)-1]; while(1) { layer--; cursor->ent[layer].nodeptr = ptr; ndloc = bnode_check(sh, ptr, layer, &layer, &fanout); cursor->ent[layer].fanout = fanout; cursor->ent[layer].index = 0; if(likely(layer == 0)) break; ptr = bnode_body_loc(ndloc)[1]; } return 1; } #define btree_seek_min(sh, cs, rt) THX_btree_seek_min(aTHX_ sh, cs, rt) static bool THX_btree_seek_min(pTHX_ struct shash *sh, struct cursor *cursor, word root) { int layer, fanout; word const *ndloc; ndloc = bnode_check(sh, root, -1, &layer, &fanout); cursor->root_layer = layer; cursor->ent[layer].nodeptr = root; while(1) { word ptr; cursor->ent[layer].fanout = fanout; cursor->ent[layer].index = 0; if(unlikely(layer == 0)) return likely(fanout != 0); ptr = bnode_body_loc(ndloc)[1]; layer--; cursor->ent[layer].nodeptr = ptr; ndloc = bnode_check(sh, ptr, layer, &layer, &fanout); } } #define btree_seek_max(sh, cs, rt) THX_btree_seek_max(aTHX_ sh, cs, rt) PERL_STATIC_INLINE bool THX_btree_seek_max(pTHX_ struct shash *sh, struct cursor *cursor, word root) { int layer, fanout; word const *ndloc; ndloc = bnode_check(sh, root, -1, &layer, &fanout); cursor->root_layer = layer; cursor->ent[layer].nodeptr = root; while(1) { word ptr; cursor->ent[layer].fanout = fanout; cursor->ent[layer].index = fanout - 1; if(unlikely(layer == 0)) return likely(fanout != 0); ptr = bnode_body_loc(ndloc)[(fanout<<1)-1]; layer--; cursor->ent[layer].nodeptr = ptr; ndloc = bnode_check(sh, ptr, layer, &layer, &fanout); } } #define btree_seek_inc(sh, cs) THX_btree_seek_inc(aTHX_ sh, cs) static bool THX_btree_seek_inc(pTHX_ struct shash *sh, struct cursor *cursor) { int layer = 0, pos; while(1) { pos = cursor->ent[layer].index + 1; if(likely(pos != cursor->ent[layer].fanout)) break; if(unlikely(layer == cursor->root_layer)) return 0; layer++; } cursor->ent[layer].index = pos; if(unlikely(layer != 0)) { word ptr = bnode_body_loc( unchecked_pointer_loc(sh, cursor->ent[layer].nodeptr)) [(pos<<1)+1]; while(1) { int fanout; word const *ndloc; layer--; cursor->ent[layer].nodeptr = ptr; ndloc = bnode_check(sh, ptr, layer, &layer, &fanout); cursor->ent[layer].fanout = fanout; cursor->ent[layer].index = 0; if(likely(layer == 0)) break; ptr = bnode_body_loc(ndloc)[1]; } } return 1; } #define btree_seek_dec(sh, cs) THX_btree_seek_dec(aTHX_ sh, cs) PERL_STATIC_INLINE bool THX_btree_seek_dec(pTHX_ struct shash *sh, struct cursor *cursor) { int layer = 0, pos; while(1) { pos = cursor->ent[layer].index - 1; if(likely(pos != -1)) break; if(unlikely(layer == cursor->root_layer)) return 0; layer++; } cursor->ent[layer].index = pos; if(unlikely(layer != 0)) { word ptr = bnode_body_loc( unchecked_pointer_loc(sh, cursor->ent[layer].nodeptr)) [(pos<<1)+1]; while(1) { int fanout; word const *ndloc; layer--; cursor->ent[layer].nodeptr = ptr; ndloc = bnode_check(sh, ptr, layer, &layer, &fanout); cursor->ent[layer].fanout = fanout; cursor->ent[layer].index = fanout - 1; if(likely(layer == 0)) break; ptr = bnode_body_loc(ndloc)[(fanout<<1)-1]; } } return 1; } #define btree_cursor_key(sh, cs) THX_btree_cursor_key(aTHX_ sh, cs) PERL_STATIC_INLINE word THX_btree_cursor_key(pTHX_ struct shash *sh, struct cursor *cursor) { PERL_UNUSED_THX(); return bnode_body_loc(unchecked_pointer_loc(sh, cursor->ent[0].nodeptr)) [(cursor->ent[0].index << 1)]; } #define btree_cursor_get(sh, cs) THX_btree_cursor_get(aTHX_ sh, cs) PERL_STATIC_INLINE word THX_btree_cursor_get(pTHX_ struct shash *sh, struct cursor *cursor) { PERL_UNUSED_THX(); return bnode_body_loc(unchecked_pointer_loc(sh, cursor->ent[0].nodeptr)) [(cursor->ent[0].index << 1) + 1]; } #define btree_cursor_modify(sh, alloc, ocs, repl, ik, iv) \ THX_btree_cursor_modify(aTHX_ sh, alloc, ocs, repl, ik, iv) static word THX_btree_cursor_modify(pTHX_ struct shash *sh, struct shash_alloc *alloc, struct cursor *oldcursor, bool replace, word inskeyptr, word insvalptr) { int ntorm, ntoin, layer = 0, posadj; word inakey = NULL_PTR, inaval = NULL_PTR; word inbkey = NULL_PTR, inbval = NULL_PTR; word nodebody[(MAXFANOUT+MINFANOUT-1)*2]; ntorm = replace ? 1 : 0; posadj = replace ? 0 : 1; if(inskeyptr == NULL_PTR) { ntoin = 0; } else { ntoin = 1; inakey = inskeyptr; inaval = insvalptr; } do { int nfanout = oldcursor->ent[layer].fanout; int modpos = oldcursor->ent[layer].index + posadj; word *ndloc = unchecked_pointer_loc(sh, oldcursor->ent[layer].nodeptr); posadj = 0; (void) memcpy(nodebody, bnode_body_loc(ndloc), modpos << (WORD_SZ_LOG2+1)); if(likely(ntoin)) { nodebody[modpos<<1] = inakey; nodebody[(modpos<<1)+1] = inaval; if(unlikely(ntoin > 1)) { nodebody[(modpos<<1)+2] = inbkey; nodebody[(modpos<<1)+3] = inbval; } } (void) memcpy(nodebody + ((modpos+ntoin)<<1), bnode_body_loc(ndloc) + ((modpos+ntorm)<<1), (nfanout-(modpos+ntorm)) << (WORD_SZ_LOG2+1)); nfanout = nfanout - ntorm + ntoin; if(likely(nfanout >= MINFANOUT)) { ntorm = 1; } else { word const *upndloc; int uppos; if(likely(layer == oldcursor->root_layer)) { if(unlikely(nfanout == 1) && likely(layer != 0)) return nodebody[1]; return bnode_write(sh, alloc, layer, nfanout, nodebody); } ntorm = 2; upndloc = unchecked_pointer_loc(sh, oldcursor->ent[layer+1].nodeptr); uppos = oldcursor->ent[layer+1].index; if(likely(uppos + 1 != oldcursor->ent[layer+1].fanout)) { int adjnlayer, adjnfanout; word adjndptr = bnode_body_loc(upndloc)[(uppos<<1) + 3]; word const *adjndloc = bnode_check(sh, adjndptr, layer, &adjnlayer, &adjnfanout); (void) memcpy(nodebody + (nfanout<<1), bnode_body_loc(adjndloc), adjnfanout << (WORD_SZ_LOG2+1)); nfanout += adjnfanout; } else { int adjnlayer, adjnfanout; word adjndptr; word const *adjndloc; posadj = -1; adjndptr = bnode_body_loc(upndloc)[(uppos<<1) - 1]; adjndloc = bnode_check(sh, adjndptr, layer, &adjnlayer, &adjnfanout); (void) memmove(nodebody + (adjnfanout<<1), nodebody, nfanout << (WORD_SZ_LOG2+1)); (void) memcpy(nodebody, bnode_body_loc(adjndloc), adjnfanout << (WORD_SZ_LOG2+1)); nfanout += adjnfanout; } } if(unlikely(nfanout > MAXFANOUT)) { int splitpos = nfanout >> 1; inakey = nodebody[0]; inaval = bnode_write(sh, alloc, layer, splitpos, nodebody); inbkey = nodebody[splitpos << 1]; inbval = bnode_write(sh, alloc, layer, nfanout-splitpos, nodebody + (splitpos<<1)); ntoin = 2; } else { inakey = nodebody[0]; inaval = bnode_write(sh, alloc, layer, nfanout, nodebody); ntoin = 1; } } while(layer++ != oldcursor->root_layer); if(likely(ntoin == 1)) return inaval; if(unlikely(layer == LAYER_MAX+1)) shash_error_toobig(sh, alloc->action); nodebody[0] = inakey; nodebody[1] = inaval; nodebody[2] = inbkey; nodebody[3] = inbval; return bnode_write(sh, alloc, layer, 2, nodebody); } #define btree_cursor_set(sh, alloc, ocs, repl, keypvl, valpvl) \ THX_btree_cursor_set(aTHX_ sh, alloc, ocs, repl, keypvl, valpvl) static word THX_btree_cursor_set(pTHX_ struct shash *sh, struct shash_alloc *alloc, struct cursor *oldcursor, bool replace, struct pvl keypvl, struct pvl valpvl) { if(pvl_is_null(valpvl)) { if(!replace) return oldcursor->ent[oldcursor->root_layer].nodeptr; return btree_cursor_modify(sh, alloc, oldcursor, 1, NULL_PTR, NULL_PTR); } else { word keyptr; if(replace) { if(string_eq_pvl(sh, btree_cursor_get(sh, oldcursor), valpvl)) return oldcursor->ent[oldcursor->root_layer] .nodeptr; keyptr = btree_cursor_key(sh, oldcursor); } else { keyptr = string_write_from_pvl(sh, alloc, keypvl); } return btree_cursor_modify(sh, alloc, oldcursor, replace, keyptr, string_write_from_pvl(sh, alloc, valpvl)); } } #define btree_count(sh, rt) THX_btree_count(aTHX_ sh, rt) static word THX_btree_count(pTHX_ struct shash *sh, word root) { struct cursor cur; word cnt = 0; if(!likely(btree_seek_min(sh, &cur, root))) return 0; do { cnt += cur.ent[0].fanout; cur.ent[0].index = cur.ent[0].fanout - 1; } while(btree_seek_inc(sh, &cur)); return cnt; } #define btree_size(sh, rt) THX_btree_size(aTHX_ sh, rt) static word THX_btree_size(pTHX_ struct shash *sh, word root) { struct cursor cur; word sz; if(!likely(btree_seek_min(sh, &cur, root))) { if(likely(sh->sizes->dhd_zeropad_sz >= WORD_SZ)) return 0; sz = WORD_SZ; } else { sz = 0; do { int i; word asz; word *loc = bnode_body_loc( unchecked_pointer_loc(sh, cur.ent[0].nodeptr)); for(i = cur.ent[0].fanout << 1; i--; ) { asz = string_size(sh, *loc++); sz += asz; if(unlikely(sz < asz)) return ~(word)0; } /* * To account for all the space occupied by the * btree nodes, we allow a certain number of * bytes per entry, such that there is space for * an arbitrarily high btree of minimal fanout. * The objective is to allow enough space * per entry that for each minimally-filled * layer-0 node we allocate space for that node * and have one entry's allocation left over. * That one-entry-per-node excess then accounts * for the size of the layer-1 nodes with one * entry's allocation per layer-1 node left * over, and so on recursively. The space to * allow per entry is theoretically the size * of the minimally-filled node (WORD_SZ * * (1+2*MINFANOUT)) divided by MINFANOUT-1; * we round this up to an integral number of * bytes per entry. * * Nodes that are more than minimally filled lead * to this being an overestimate, because they * are more space-efficient both in themselves * and by using fewer higher-layer entries. * An underfilled root node can lead to needing * more bytes than this formula allows, but the * space allowed for the node will always be * strictly greater than the two words per entry * required by the node body. Because the size * is ultimately rounded up to word alignment * (actually to line alignment), it is rounded * up sufficiently to account for the single-word * header of the root node. */ asz = cur.ent[0].fanout * ((WORD_SZ*(1+2*MINFANOUT) + MINFANOUT-2) / (MINFANOUT-1)); sz += asz; if(unlikely(sz < asz)) return ~(word)0; cur.ent[0].index = cur.ent[0].fanout - 1; } while(btree_seek_inc(sh, &cur)); } sz = LINE_ALIGN(sh->sizes, sz); return likely(sz) ? sz : ~(word)0; } #define btree_migrate_at_layer(shf, ptrf, el, sht, alloct) \ THX_btree_migrate_at_layer(aTHX_ shf, ptrf, el, sht, alloct) static word THX_btree_migrate_at_layer(pTHX_ struct shash *shf, word ptrf, int expect_layer, struct shash *sht, struct shash_alloc *alloct) { int layer, fanout, i; word nodebody[MAXFANOUT*2]; word const *locf = bnode_body_loc(bnode_check(shf, ptrf, expect_layer, &layer, &fanout)); word *loct = nodebody; if(likely(layer == 0)) { for(i = fanout << 1; i--; ) { *loct++ = string_migrate(shf, *locf++, sht, alloct); } } else { for(i = fanout; i--; ) { word spc; word ptrt = btree_migrate_at_layer(shf, locf[1], layer-1, sht, alloct); locf += 2; *loct++ = bnode_body_loc(pointer_loc(sht, ptrt, &spc))[0]; *loct++ = ptrt; } } return bnode_write(sht, alloct, layer, fanout, nodebody); } #define btree_migrate(shf, ptrf, sht, act) \ THX_btree_migrate(aTHX_ shf, ptrf, sht, act) static word THX_btree_migrate(pTHX_ struct shash *shf, word ptrf, struct shash *sht, char const *action) { struct shash_alloc new_alloc; if(unlikely(setjmp(new_alloc.fulljb))) shash_error_errnum(sht, action, ENOSPC); new_alloc.action = action; new_alloc.prealloc_len = 0; return btree_migrate_at_layer(shf, ptrf, -1, sht, &new_alloc); } /* mechanism for reading from shash */ #define shash_root_for_read(sh) THX_shash_root_for_read(aTHX_ sh) PERL_STATIC_INLINE word THX_shash_root_for_read(pTHX_ struct shash *sh) { if(sh->mode & STOREMODE_SNAPSHOT) { return sh->u.snapshot.root; } else { shash_ensure_data_file(sh); return word_get(&WORD_AT(sh->data_mmap, sh->sizes->dhd_current_root)) & ~PTR_FLAG_ROLLOVER; } } /* mechanism for writing to shash */ PERL_STATIC_INLINE bool shash_change_root(struct shash *sh, word old, word new) { tally_event(&sh->tally, K_ROOT_CHANGE_ATTEMPT); if(likely(word_cset( &WORD_AT(sh->data_mmap, sh->sizes->dhd_current_root), old, new))) { tally_event(&sh->tally, K_ROOT_CHANGE_SUCCESS); return 1; } else { return 0; } } PERL_STATIC_INLINE bool shash_change_file(struct shash *sh, word old, word new) { tally_event(&sh->tally, K_FILE_CHANGE_ATTEMPT); if(likely(word_cset(&WORD_AT(sh->u.live.master_mmap, sh->sizes->mfl_current_datafileid), old, new))) { tally_event(&sh->tally, K_FILE_CHANGE_SUCCESS); return 1; } else { return 0; } } PERL_STATIC_INLINE void shash_initiate_rollover(struct shash *sh) { word *root_p = &WORD_AT(sh->data_mmap, sh->sizes->dhd_current_root); while(1) { word root = word_get(root_p); if(unlikely(root & PTR_FLAG_ROLLOVER)) break; if(likely(shash_change_root(sh, root, root | PTR_FLAG_ROLLOVER))) break; } } #define shash_try_rollover(sh, act, addsz) \ THX_shash_try_rollover(aTHX_ sh, act, addsz) PERL_STATIC_INLINE word THX_shash_try_rollover(pTHX_ struct shash *sh, char const *action, word addsz) { char filename[DATA_FILENAME_BUFSIZE]; word *allocfileid_p; word old_file_id, old_root_word, old_root; word new_file_id, new_root, new_sz; struct stat statbuf; int new_fd; unlinkfile_ref_t new_ulr; closefd_ref_t new_fdr; struct shash new_sh; SV *old_mmap_sv; tmps_ix_t old_tmps_floor; old_root_word = word_get(&WORD_AT(sh->data_mmap, sh->sizes->dhd_current_root)); old_root = old_root_word & ~PTR_FLAG_ROLLOVER; new_sz = sh->sizes->dhd_sz + btree_size(sh, old_root); if(unlikely(new_sz < sh->sizes->dhd_sz || (new_sz & (((word)7) << 61)))) shash_error_toobig(sh, action); new_sz <<= 3; new_sz += addsz; if(unlikely(new_sz < addsz)) shash_error_toobig(sh, action); new_sz = PAGE_ALIGN(sh->sizes, new_sz); if(unlikely(!new_sz)) shash_error_toobig(sh, action); if(unlikely((off_t)new_sz < 0 || (word)(off_t)new_sz != new_sz)) shash_error_errnum(sh, action, EFBIG); tally_zero(&new_sh.tally); new_sh.sizes = sh->sizes; new_sh.parameter = sh->parameter; new_sh.top_pathname_sv = sh->top_pathname_sv; allocfileid_p = &WORD_AT(sh->u.live.master_mmap, sh->sizes->mfl_lastalloc_datafileid); do { old_file_id = word_get(allocfileid_p); new_file_id = old_file_id + 1; if(unlikely(new_file_id == 0)) new_file_id = 1; } while(!likely(word_cset(allocfileid_p, old_file_id, new_file_id))); if(unlikely(dirref_rel_stat(sh->u.live.dir, MASTER_FILENAME, &statbuf) == -1)) shash_error_errno(sh, action); dir_make_data_filename(filename, new_file_id); new_fd = dirref_rel_open_cloexec(sh->u.live.dir, filename, O_RDWR|O_CREAT|O_EXCL, 0); if(unlikely(new_fd == -1)) shash_error_errno(sh, action); new_ulr = unlinkfile_save(sh->u.live.dir, filename); if(unlikely(fchown(new_fd, -1, statbuf.st_gid) == -1) && unlikely(errno != EPERM)) shash_error_errno(sh, action); if(unlikely(fchmod(new_fd, statbuf.st_mode & (S_IRUSR|S_IWUSR|S_IRGRP|S_IWGRP|S_IROTH|S_IWOTH)) == -1)) shash_error_errno(sh, action); if(unlikely(fchown(new_fd, statbuf.st_uid, -1) == -1) && unlikely(errno != EPERM)) shash_error_errno(sh, action); new_fdr = closefd_save(new_fd); if(unlikely(ftruncate(new_fd, new_sz) == -1)) { /* * A file-too-big error may be reported as either * EFBIG or EINVAL depending on OS. The former is more * enlightening to the user, so always report it that way. */ int e = errno; shash_error_errnum(sh, action, e == EINVAL ? EFBIG : e); } old_tmps_floor = PL_tmps_floor; SAVETMPS; new_sh.data_mmap_sv = mmap_as_sv(new_fd, new_sz, 1); if(!likely(new_sh.data_mmap_sv)) shash_error_errno(sh, action); new_sh.data_mmap = SvPVX(new_sh.data_mmap_sv); new_sh.data_size = new_sz; closefd_early(new_fdr); WORD_AT(new_sh.data_mmap, DHD_MAGIC) = DATA_FILE_MAGIC; WORD_AT(new_sh.data_mmap, DHD_PARAM) = sh->parameter; WORD_AT(new_sh.data_mmap, DHD_LENGTH) = new_sz; WORD_AT(new_sh.data_mmap, sh->sizes->dhd_nextalloc_space) = sh->sizes->dhd_sz; WORD_AT(new_sh.data_mmap, sh->sizes->dhd_current_root) = new_root = btree_migrate(sh, old_root, &new_sh, action); tally_add(&sh->tally, &new_sh.tally); old_file_id = sh->u.live.data_file_id; if((!(old_root_word & PTR_FLAG_ROLLOVER) && !likely(shash_change_root(sh, old_root_word, old_root_word | PTR_FLAG_ROLLOVER))) || !likely(shash_change_file(sh, old_file_id, new_file_id))) { FREETMPS; PL_tmps_floor = old_tmps_floor; shash_unlinkfile_early(sh, action, new_ulr); return NULL_PTR; } unlinkfile_cancel(new_ulr); old_mmap_sv = sh->data_mmap_sv; sh->data_mmap_sv = NULL; SvREFCNT_dec_NN(old_mmap_sv); sh->data_mmap_sv = SvREFCNT_inc_simple_NN(new_sh.data_mmap_sv); sh->data_mmap = new_sh.data_mmap; sh->data_size = new_sh.data_size; sh->u.live.data_file_id = new_file_id; FREETMPS; PL_tmps_floor = old_tmps_floor; if(likely(old_file_id != 0)) { dir_make_data_filename(filename, old_file_id); if(unlikely(dirref_rel_unlink(sh->u.live.dir, filename) == -1)) { int e = errno; if(!(likely(e == ENOENT) || likely(e == EBUSY))) shash_error_errnum(sh, action, e); } } return new_root; } typedef word (*mutate_fn_t)(pTHX_ struct shash *sh, struct shash_alloc *alloc, word oldroot, void *mutate_arg); #define shash_mutate(sh, act, mut, marg) \ THX_shash_mutate(aTHX_ sh, act, mut, marg) static void THX_shash_mutate(pTHX_ struct shash *sh, char const *action, mutate_fn_t THX_mutate, void *mutate_arg) { struct shash_alloc alloc; volatile word addsz = PAGE_ALIGN(sh->sizes, 1<<20); volatile bool just_rolled_over = 0; alloc.action = action; if(unlikely(setjmp(alloc.fulljb))) { if(unlikely(just_rolled_over)) { word newaddsz = addsz <<= 1; if(!likely(newaddsz)) shash_error_toobig(sh, action); } shash_initiate_rollover(sh); } while(1) { word old_root, new_root; just_rolled_over = 0; shash_ensure_data_file(sh); old_root = word_get(&WORD_AT(sh->data_mmap, sh->sizes->dhd_current_root)); if(unlikely(old_root & PTR_FLAG_ROLLOVER)) { old_root = shash_try_rollover(sh, action, addsz); if(unlikely(old_root == NULL_PTR)) continue; dir_clean(sh, action, sh->u.live.data_file_id); just_rolled_over = 1; } alloc.prealloc_len = 0; new_root = THX_mutate(aTHX_ sh, &alloc, old_root, mutate_arg); if(likely(new_root == old_root) || likely(shash_change_root(sh, old_root, new_root))) break; } tally_event(&sh->tally, K_DATA_WRITE_OP); } /* shash opening and creation */ #define mode_from_sv(sv) THX_mode_from_sv(aTHX_ sv) PERL_STATIC_INLINE unsigned THX_mode_from_sv(pTHX_ SV *modesv) { char const *modepv, *modeend, *p; STRLEN modelen; unsigned mode = 0; SvGETMAGIC(modesv); if(!likely(sv_is_string(modesv))) croak("mode is not a string"); modepv = SvPV_nomg(modesv, modelen); modeend = modepv + modelen; for(p = modepv; p != modeend; p++) { char c = *p; unsigned f; switch(c) { case 'r': f = STOREMODE_READ; break; case 'w': f = STOREMODE_WRITE; break; case 'c': f = STOREMODE_CREATE; break; case 'e': f = STOREMODE_EXCLUDE; break; default: { f = 0; if(likely(c >= ' ' && c <= '~')) croak("unknown open mode flag `%c'", c); else croak("unknown open mode flag"); } } if(unlikely(mode & f)) croak("duplicate open mode flag `%c'", c); mode |= f; } return mode; } #define mode_as_sv(m) THX_mode_as_sv(aTHX_ m) PERL_STATIC_INLINE SV *THX_mode_as_sv(pTHX_ unsigned mode) { char buf[4], *p; SV *modesv; p = buf; if(likely(mode & STOREMODE_READ)) *p++ = 'r'; if(likely(mode & STOREMODE_WRITE)) *p++ = 'w'; if(unlikely(mode & STOREMODE_CREATE)) *p++ = 'c'; if(unlikely(mode & STOREMODE_EXCLUDE)) *p++ = 'e'; modesv = newSVpvn_mortal(buf, p - buf); SvREADONLY_on(modesv); return modesv; } #define shash_open_error_magic(sh) THX_shash_open_error_magic(aTHX_ sh) static void THX_shash_open_error_magic(pTHX_ struct shash *sh) __attribute__noreturn__; static void THX_shash_open_error_magic(pTHX_ struct shash *sh) { shash_error(sh, "open", "not a shared hash"); } static void THX_shash_open_check_file(pTHX_ struct shash *sh, char const *action, char const *fn, word arg) { word id; PERL_UNUSED_ARG(action); PERL_UNUSED_ARG(arg); if(unlikely(dir_filename_class(fn, &id) == FILENAME_CLASS_BOGUS)) shash_open_error_magic(sh); } #define shash_open(psv, msv) THX_shash_open(aTHX_ psv, msv) static SV *THX_shash_open(pTHX_ SV *top_pathname_sv, SV *mode_sv) { dMY_CXT; char const *top_pathname_pv; unsigned mode; struct shash *sh; SV *shsv, *shsvref, *mapsv, *sizes_sv; dirref_t dir; int master_fd; struct stat statbuf; unlinkfile_ref_t ulr; char temp_filename[TEMP_FILENAME_BUFSIZE]; closefd_ref_t fdr; void *map; shsv = newSV_type(SVt_PVMG); shsvref = newRV_ro_mortal_noinc(shsv); Newxz(sh, 1, struct shash); SvPV_set(shsv, (char *)sh); SvLEN_set(shsv, sizeof(struct shash)); shash_apply_magic(shsv); (void) sv_bless(shsvref, MY_CXT.shash_handle_stash); SvGETMAGIC(top_pathname_sv); if(!likely(sv_is_string(top_pathname_sv))) croak("filename is not a string"); { STRLEN len; char *pv = SvPV_nomg(top_pathname_sv, len); sh->top_pathname_sv = newSVpvn(pv, len); if(unlikely(SvUTF8(top_pathname_sv))) SvUTF8_on(sh->top_pathname_sv); } mode = mode_from_sv(mode_sv); if(likely(mode & (STOREMODE_WRITE|STOREMODE_CREATE))) TAINT_PROPER("shash_open"); sh->mode = mode & (STOREMODE_READ|STOREMODE_WRITE); top_pathname_pv = SvPV_nolen(sh->top_pathname_sv); sh->u.live.dir = dir = dirref_open(top_pathname_pv, &statbuf); if(unlikely(dirref_is_null(dir))) { if(!likely(errno == ENOENT && (mode & STOREMODE_CREATE))) shash_error_errno(sh, "open"); if(unlikely(mkdir(top_pathname_pv, S_IRWXU|S_IRWXG|S_IRWXO) == -1) && errno != EEXIST) shash_error_errno(sh, "open"); sh->u.live.dir = dir = dirref_open(top_pathname_pv, &statbuf); if(unlikely(dirref_is_null(dir))) shash_error_errno(sh, "open"); } if(!likely(S_ISDIR(statbuf.st_mode))) shash_open_error_magic(sh); dir_iterate(sh, "open", THX_shash_open_check_file, 0); master_fd = dirref_rel_open_cloexec(dir, MASTER_FILENAME, likely(mode & STOREMODE_WRITE) ? O_RDWR : O_RDONLY, 0); if(likely(master_fd != -1)) { opened_master: fdr = closefd_save(master_fd); if(unlikely(mode & STOREMODE_EXCLUDE)) shash_error_errnum(sh, "open", EEXIST); if(unlikely(fstat(master_fd, &statbuf) == -1)) shash_error_errno(sh, "open"); if(!likely(S_ISREG(statbuf.st_mode) && (off_t)(word)statbuf.st_size == statbuf.st_size && statbuf.st_size >= MFL_PARAM+WORD_SZ)) shash_open_error_magic(sh); mapsv = mmap_as_sv(master_fd, MFL_PARAM+WORD_SZ, 0); if(!likely(mapsv)) shash_error_errno(sh, "open"); map = SvPVX(mapsv); if(!likely(WORD_AT(map, MFL_MAGIC) == MASTER_FILE_MAGIC)) shash_open_error_magic(sh); sh->parameter = WORD_AT(map, MFL_PARAM); if(unlikely(PARAMETER_WORD_FIXED_PART(sh->parameter) != PARAMETER_WORD_FIXED_PART_VALUE)) { bad_parameter: shash_error(sh, "open", "unsupported format"); } sizes_sv = sizes_lookup(sh->parameter); if(!likely(sizes_sv)) goto bad_parameter; #if QWITH_DUP sh->sizes_sv = sizes_sv; #endif /* QWITH_DUP */ sh->sizes = (struct sizes const *)SvPVX(sizes_sv); mmap_early_unmap(mapsv); if(!likely((word)statbuf.st_size == sh->sizes->mfl_sz)) shash_open_error_magic(sh); mapsv = mmap_as_sv(master_fd, sh->sizes->mfl_sz, cBOOL(mode & STOREMODE_WRITE)); if(!likely(mapsv)) shash_error_errno(sh, "open"); sh->u.live.master_mmap_sv = SvREFCNT_inc_simple_NN(mapsv); sh->u.live.master_mmap = SvPVX(mapsv); closefd_early(fdr); if(likely(mode & STOREMODE_WRITE)) dir_clean(sh, "open", word_get(&WORD_AT(sh->u.live.master_mmap, sh->sizes->mfl_current_datafileid))); return shsvref; } if(!likely(errno == ENOENT && (mode & STOREMODE_CREATE))) shash_error_errno(sh, "open"); sh->parameter = parameter_preferred(); sizes_sv = sizes_lookup(sh->parameter); if(!likely(sizes_sv)) shash_error_errnum(sh, "open", ENOMEM); #if QWITH_DUP sh->sizes_sv = sizes_sv; #endif /* QWITH_DUP */ sh->sizes = (struct sizes const *)SvPVX(sizes_sv); if(unlikely((off_t)sh->sizes->mfl_sz < 0 || (word)(off_t)sh->sizes->mfl_sz != sh->sizes->mfl_sz)) shash_error_errnum(sh, "open", EFBIG); dir_make_temp_filename(temp_filename); master_fd = dirref_rel_open_cloexec(dir, temp_filename, O_RDWR|O_CREAT|O_EXCL, S_IRUSR|S_IWUSR|S_IRGRP|S_IWGRP|S_IROTH|S_IWOTH); if(unlikely(master_fd == -1)) shash_error_errno(sh, "open"); ulr = unlinkfile_save(dir, temp_filename); fdr = closefd_save(master_fd); if(unlikely(ftruncate(master_fd, sh->sizes->mfl_sz) == -1)) shash_error_errno(sh, "open"); mapsv = mmap_as_sv(master_fd, sh->sizes->mfl_sz, 1); if(!likely(mapsv)) shash_error_errno(sh, "open"); sh->u.live.master_mmap_sv = SvREFCNT_inc_simple_NN(mapsv); sh->u.live.master_mmap = map = SvPVX(mapsv); closefd_early(fdr); WORD_AT(map, MFL_MAGIC) = MASTER_FILE_MAGIC; WORD_AT(map, MFL_PARAM) = sh->parameter; if(unlikely(dirref_rel_link(dir, temp_filename, MASTER_FILENAME) == -1)) { if(unlikely(errno != EEXIST)) shash_error_errno(sh, "open"); mmap_early_unmap(mapsv); sh->u.live.master_mmap_sv = NULL; SvREFCNT_dec_NN(mapsv); shash_unlinkfile_early(sh, "open", ulr); master_fd = dirref_rel_open_cloexec(dir, MASTER_FILENAME, likely(mode & STOREMODE_WRITE) ? O_RDWR : O_RDONLY, 0); if(unlikely(master_fd == -1)) shash_error_errno(sh, "open"); goto opened_master; } shash_unlinkfile_early(sh, "open", ulr); dir_clean(sh, "open", 0); return shsvref; } /* * API operations in base pp form * * These functions take a fixed number of arguments from the Perl stack, * and put their mortal result on the stack. At the C level they take no * arguments other than the Perl context and return no value. This is not * the format used for actual pp_ functions, which implement ops, as those * interact with PL_op. Nor is it the format used for XS function bodies, * which take a variable number of arguments delimited by a stack mark. * These pp1_ functions are the parts of the operations that are common * to ops and XS functions. */ #define pp1_is_shash() THX_pp1_is_shash(aTHX) static void THX_pp1_is_shash(pTHX) { dSP; SETs(boolSV(arg_is_shash(TOPs))); } #define pp1_check_shash() THX_pp1_check_shash(aTHX) static void THX_pp1_check_shash(pTHX) { dSP; arg_check_shash(POPs); if(unlikely(GIMME_V == G_SCALAR)) PUSHs(&PL_sv_undef); PUTBACK; } #define pp1_shash_open() THX_pp1_shash_open(aTHX) static void THX_pp1_shash_open(pTHX) { SV *sh; dSP; SV *mode_sv = POPs; SV *top_pathname_sv = TOPs; PUTBACK; sh = shash_open(top_pathname_sv, mode_sv); SPAGAIN; SETs(sh); } #define pp1_shash_is_readable() THX_pp1_shash_is_readable(aTHX) static void THX_pp1_shash_is_readable(pTHX) { dSP; SETs(boolSV(likely(shash_from_svref(TOPs)->mode & STOREMODE_READ))); } #define pp1_shash_is_writable() THX_pp1_shash_is_writable(aTHX) static void THX_pp1_shash_is_writable(pTHX) { dSP; SETs(boolSV(likely(shash_from_svref(TOPs)->mode & STOREMODE_WRITE))); } #define pp1_shash_mode() THX_pp1_shash_mode(aTHX) static void THX_pp1_shash_mode(pTHX) { dSP; SETs(mode_as_sv(shash_from_svref(TOPs)->mode)); } #define pp1_shash_exists() THX_pp1_shash_exists(aTHX) static void THX_pp1_shash_exists(pTHX) { struct shash *sh; struct pvl keypvl; struct cursor cur; SV *resultsv; dSP; SV *keysv = POPs; PUTBACK; sh = shash_from_svref(TOPs); keypvl = pvl_from_arg("key", 0, keysv); shash_check_readable(sh, "read"); resultsv = boolSV(btree_seek_key(sh, &cur, shash_root_for_read(sh), keypvl)); tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(resultsv); } #define pp1_shash_length() THX_pp1_shash_length(aTHX) static void THX_pp1_shash_length(pTHX) { struct shash *sh; struct pvl keypvl; struct cursor cur; SV *resultsv; dSP; SV *keysv = POPs; PUTBACK; sh = shash_from_svref(TOPs); keypvl = pvl_from_arg("key", 0, keysv); shash_check_readable(sh, "read"); if(likely(btree_seek_key(sh, &cur, shash_root_for_read(sh), keypvl))) { struct pvl valpvl = string_as_pvl(sh, btree_cursor_get(sh, &cur)); if(unlikely((size_t)(UV)valpvl.len != valpvl.len)) shash_error_errnum(sh, "read", ENOMEM); TAINT; resultsv = sv_2mortal(newSVuv((UV)valpvl.len)); SvREADONLY_on(resultsv); } else { resultsv = &PL_sv_undef; } tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(resultsv); } #define pp1_shash_get() THX_pp1_shash_get(aTHX) static void THX_pp1_shash_get(pTHX) { struct shash *sh; struct pvl keypvl; struct cursor cur; SV *valsv; dSP; SV *keysv = POPs; PUTBACK; sh = shash_from_svref(TOPs); keypvl = pvl_from_arg("key", 0, keysv); shash_check_readable(sh, "read"); valsv = btree_seek_key(sh, &cur, shash_root_for_read(sh), keypvl) ? string_as_sv(sh, "read", btree_cursor_get(sh, &cur)) : &PL_sv_undef; tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(valsv); } struct mutateargs_set { struct pvl keypvl; struct pvl newvalpvl; }; static word THX_mutate_set(pTHX_ struct shash *sh, struct shash_alloc *alloc, word oldroot, void *mutate_arg) { struct mutateargs_set *args = (struct mutateargs_set *)mutate_arg; struct cursor oldcur; bool match; match = btree_seek_key(sh, &oldcur, oldroot, args->keypvl); return btree_cursor_set(sh, alloc, &oldcur, match, args->keypvl, args->newvalpvl); } #define pp1_shash_settish(au) THX_pp1_shash_settish(aTHX_ au) static void THX_pp1_shash_settish(pTHX_ bool allow_undef) { SV *keysv, *newvalsv; struct mutateargs_set args; struct shash *sh; dSP; newvalsv = POPs; keysv = POPs; sh = shash_from_svref(POPs); if(unlikely(GIMME_V == G_SCALAR)) PUSHs(&PL_sv_undef); PUTBACK; args.keypvl = pvl_from_arg("key", 0, keysv); args.newvalpvl = pvl_from_arg("new value", allow_undef, newvalsv); shash_check_writable(sh, "write"); shash_mutate(sh, "write", THX_mutate_set, &args); } #define pp1_shash_set() THX_pp1_shash_set(aTHX) PERL_STATIC_INLINE void THX_pp1_shash_set(pTHX) { pp1_shash_settish(1); } #define pp1_shash_tied_store() THX_pp1_shash_tied_store(aTHX) PERL_STATIC_INLINE void THX_pp1_shash_tied_store(pTHX) { pp1_shash_settish(0); } struct mutateargs_gset { struct pvl keypvl; struct pvl newvalpvl; word oldvalptr; }; static word THX_mutate_gset(pTHX_ struct shash *sh, struct shash_alloc *alloc, word oldroot, void *mutate_arg) { struct mutateargs_gset *args = (struct mutateargs_gset *)mutate_arg; struct cursor oldcur; bool match; match = btree_seek_key(sh, &oldcur, oldroot, args->keypvl); args->oldvalptr = match ? btree_cursor_get(sh, &oldcur) : NULL_PTR; return btree_cursor_set(sh, alloc, &oldcur, match, args->keypvl, args->newvalpvl); } #define pp1_shash_gset() THX_pp1_shash_gset(aTHX) static void THX_pp1_shash_gset(pTHX) { SV *keysv, *newvalsv, *oldvalsv; struct mutateargs_gset args; struct shash *sh; dSP; newvalsv = POPs; keysv = POPs; PUTBACK; sh = shash_from_svref(TOPs); args.keypvl = pvl_from_arg("key", 0, keysv); args.newvalpvl = pvl_from_arg("new value", 1, newvalsv); shash_check_readable(sh, "update"); shash_check_writable(sh, "update"); shash_mutate(sh, "update", THX_mutate_gset, &args); oldvalsv = args.oldvalptr == NULL_PTR ? &PL_sv_undef : string_as_sv(sh, "update", args.oldvalptr); SPAGAIN; SETs(oldvalsv); } #define pp1_shash_tied_delete() THX_pp1_shash_tied_delete(aTHX) PERL_STATIC_INLINE void THX_pp1_shash_tied_delete(pTHX) { dSP; XPUSHs(&PL_sv_undef); PUTBACK; pp1_shash_gset(); } struct mutateargs_cset { struct pvl keypvl; struct pvl chkvalpvl; struct pvl newvalpvl; bool result; }; static word THX_mutate_cset(pTHX_ struct shash *sh, struct shash_alloc *alloc, word oldroot, void *mutate_arg) { struct mutateargs_cset *args = (struct mutateargs_cset *)mutate_arg; struct cursor oldcur; bool match; match = btree_seek_key(sh, &oldcur, oldroot, args->keypvl); if(!likely(pvl_is_null(args->chkvalpvl) ? !match : match && string_eq_pvl(sh, btree_cursor_get(sh, &oldcur), args->chkvalpvl))) { args->result = 0; return oldroot; } args->result = 1; return btree_cursor_set(sh, alloc, &oldcur, match, args->keypvl, args->newvalpvl); } #define pp1_shash_cset() THX_pp1_shash_cset(aTHX) static void THX_pp1_shash_cset(pTHX) { SV *keysv, *chkvalsv, *newvalsv; struct mutateargs_cset args; struct shash *sh; dSP; newvalsv = POPs; chkvalsv = POPs; keysv = POPs; PUTBACK; sh = shash_from_svref(TOPs); args.keypvl = pvl_from_arg("key", 0, keysv); args.chkvalpvl = pvl_from_arg("check value", 1, chkvalsv); args.newvalpvl = pvl_from_arg("new value", 1, newvalsv); shash_check_readable(sh, "update"); shash_check_writable(sh, "update"); shash_mutate(sh, "update", THX_mutate_cset, &args); SPAGAIN; SETs(boolSV(likely(args.result))); } #define pp1_shash_occupied() THX_pp1_shash_occupied(aTHX) static void THX_pp1_shash_occupied(pTHX) { int layer, fanout; dSP; struct shash *sh = shash_from_svref(TOPs); shash_check_readable(sh, "read"); (void) bnode_check(sh, shash_root_for_read(sh), -1, &layer, &fanout); tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(boolSV(fanout != 0)); } #define pp1_shash_count() THX_pp1_shash_count(aTHX) static void THX_pp1_shash_count(pTHX) { word count; SV *resultsv; dSP; struct shash *sh = shash_from_svref(TOPs); shash_check_readable(sh, "read"); count = btree_count(sh, shash_root_for_read(sh)); if(unlikely((word)(UV)count != count)) shash_error_errnum(sh, "read", ENOMEM); TAINT; resultsv = sv_2mortal(newSVuv((UV)count)); SvREADONLY_on(resultsv); tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(resultsv); } #define pp1_shash_size() THX_pp1_shash_size(aTHX) static void THX_pp1_shash_size(pTHX) { word size; SV *resultsv; dSP; struct shash *sh = shash_from_svref(TOPs); shash_check_readable(sh, "read"); size = btree_size(sh, shash_root_for_read(sh)); if(unlikely((word)(UV)size != size)) shash_error_errnum(sh, "read", ENOMEM); TAINT; resultsv = sv_2mortal(newSVuv((UV)size)); SvREADONLY_on(resultsv); tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(resultsv); } #define pp1_shash_key_min() THX_pp1_shash_key_min(aTHX) static void THX_pp1_shash_key_min(pTHX) { int layer, fanout; word const *ndloc; SV *keysv; dSP; struct shash *sh = shash_from_svref(TOPs); shash_check_readable(sh, "read"); ndloc = bnode_check(sh, shash_root_for_read(sh), -1, &layer, &fanout); keysv = likely(fanout != 0) ? string_as_sv(sh, "read", bnode_body_loc(ndloc)[0]) : &PL_sv_undef; tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(keysv); } #define pp1_shash_key_max() THX_pp1_shash_key_max(aTHX) static void THX_pp1_shash_key_max(pTHX) { struct cursor cur; SV *keysv; dSP; struct shash *sh = shash_from_svref(TOPs); shash_check_readable(sh, "read"); keysv = likely(btree_seek_max(sh, &cur, shash_root_for_read(sh))) ? string_as_sv(sh, "read", btree_cursor_key(sh, &cur)) : &PL_sv_undef; tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(keysv); } #define pp1_shash_key_ge() THX_pp1_shash_key_ge(aTHX) static void THX_pp1_shash_key_ge(pTHX) { struct shash *sh; struct pvl keypvl; struct cursor cur; SV *resultsv; dSP; SV *keysv = POPs; PUTBACK; sh = shash_from_svref(TOPs); keypvl = pvl_from_arg("key", 0, keysv); shash_check_readable(sh, "read"); resultsv = btree_seek_key(sh, &cur, shash_root_for_read(sh), keypvl) || likely(btree_seek_inc(sh, &cur)) ? string_as_sv(sh, "read", btree_cursor_key(sh, &cur)) : &PL_sv_undef; tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(resultsv); } #define pp1_shash_key_gt() THX_pp1_shash_key_gt(aTHX) static void THX_pp1_shash_key_gt(pTHX) { struct shash *sh; struct pvl keypvl; struct cursor cur; SV *resultsv; dSP; SV *keysv = POPs; PUTBACK; sh = shash_from_svref(TOPs); keypvl = pvl_from_arg("key", 0, keysv); shash_check_readable(sh, "read"); (void) btree_seek_key(sh, &cur, shash_root_for_read(sh), keypvl); resultsv = likely(btree_seek_inc(sh, &cur)) ? string_as_sv(sh, "read", btree_cursor_key(sh, &cur)) : &PL_sv_undef; tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(resultsv); } #define pp1_shash_key_le() THX_pp1_shash_key_le(aTHX) static void THX_pp1_shash_key_le(pTHX) { struct shash *sh; struct pvl keypvl; struct cursor cur; SV *resultsv; dSP; SV *keysv = POPs; PUTBACK; sh = shash_from_svref(TOPs); keypvl = pvl_from_arg("key", 0, keysv); shash_check_readable(sh, "read"); (void) btree_seek_key(sh, &cur, shash_root_for_read(sh), keypvl); resultsv = likely(cur.ent[0].index != -1) ? string_as_sv(sh, "read", btree_cursor_key(sh, &cur)) : &PL_sv_undef; tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(resultsv); } #define pp1_shash_key_lt() THX_pp1_shash_key_lt(aTHX) static void THX_pp1_shash_key_lt(pTHX) { struct shash *sh; struct pvl keypvl; struct cursor cur; SV *resultsv; dSP; SV *keysv = POPs; PUTBACK; sh = shash_from_svref(TOPs); keypvl = pvl_from_arg("key", 0, keysv); shash_check_readable(sh, "read"); resultsv = (btree_seek_key(sh, &cur, shash_root_for_read(sh), keypvl) ? likely(btree_seek_dec(sh, &cur)) : likely(cur.ent[0].index != -1)) ? string_as_sv(sh, "read", btree_cursor_key(sh, &cur)) : &PL_sv_undef; tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(resultsv); } #define pp1_shash_keys_array() THX_pp1_shash_keys_array(aTHX) static void THX_pp1_shash_keys_array(pTHX) { word root, count; AV *ar; SV *aref; dSP; struct shash *sh = shash_from_svref(TOPs); shash_check_readable(sh, "read"); root = shash_root_for_read(sh); count = btree_count(sh, root); if(unlikely((array_ix_t)count < 0 || (word)(array_ix_t)count != count)) shash_error_errnum(sh, "read", ENOMEM); ar = newAV(); aref = newRV_ro_mortal_noinc((SV*)ar); if(likely(count != 0)) { SV **abody; struct cursor cur; word i; av_fill(ar, count-1); abody = AvARRAY(ar); if(!likely(btree_seek_min(sh, &cur, root))) shash_error_data(sh); for(i = 0; ; ) { abody[i] = SvREFCNT_inc_NN(string_as_sv(sh, "read", btree_cursor_key(sh, &cur))); i++; if(unlikely(i == count)) break; if(!likely(btree_seek_inc(sh, &cur))) shash_error_data(sh); } } SvREADONLY_on((SV*)ar); tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(aref); } #define pp1_shash_keys_hash() THX_pp1_shash_keys_hash(aTHX) static void THX_pp1_shash_keys_hash(pTHX) { HV *h; SV *href; struct cursor cur; dSP; struct shash *sh = shash_from_svref(TOPs); shash_check_readable(sh, "read"); h = newHV(); href = newRV_ro_mortal_noinc((SV*)h); if(likely(btree_seek_min(sh, &cur, shash_root_for_read(sh)))) { dMY_CXT; SV *safe_undef = MY_CXT.safe_undef; do { struct pvl pvl = string_as_pvl(sh, btree_cursor_key(sh, &cur)); if(unlikely((I32)pvl.len < 0 || (size_t)(I32)pvl.len != pvl.len)) shash_error_errnum(sh, "read", ENOMEM); (void) hv_store(h, pvl.pv, (I32)pvl.len, SvREFCNT_inc_simple_NN(safe_undef), 0); } while(btree_seek_inc(sh, &cur)); } tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(href); } #define pp1_shash_group_get_hash() THX_pp1_shash_group_get_hash(aTHX) static void THX_pp1_shash_group_get_hash(pTHX) { HV *h; SV *href; struct cursor cur; dSP; struct shash *sh = shash_from_svref(TOPs); shash_check_readable(sh, "read"); h = newHV(); href = newRV_ro_mortal_noinc((SV*)h); if(likely(btree_seek_min(sh, &cur, shash_root_for_read(sh)))) { do { struct pvl keypvl = string_as_pvl(sh, btree_cursor_key(sh, &cur)); SV *valsv; if(unlikely((I32)keypvl.len < 0 || (size_t)(I32)keypvl.len != keypvl.len)) shash_error_errnum(sh, "read", ENOMEM); valsv = string_as_sv(sh, "read", btree_cursor_get(sh, &cur)); (void) hv_store(h, keypvl.pv, (I32)keypvl.len, SvREFCNT_inc_simple_NN(valsv), 0); } while(btree_seek_inc(sh, &cur)); } tally_event(&sh->tally, K_DATA_READ_OP); SPAGAIN; SETs(href); } #define pp1_shash_snapshot() THX_pp1_shash_snapshot(aTHX) static void THX_pp1_shash_snapshot(pTHX) { SV *snapshsvref; dSP; SV *shsvref = TOPs; struct shash *sh = shash_from_svref(shsvref); if(unlikely(sh->mode & STOREMODE_SNAPSHOT)) { snapshsvref = newRV_ro_mortal_inc(SvRV(shsvref)); } else { dMY_CXT; word root = shash_root_for_read(sh); struct shash *snapsh; SV *snapshsv; snapshsv = newSV_type(SVt_PVMG); snapshsvref = newRV_ro_mortal_noinc(snapshsv); Newxz(snapsh, 1, struct shash); SvPV_set(snapshsv, (char *)snapsh); SvLEN_set(snapshsv, sizeof(struct shash)); shash_apply_magic(snapshsv); (void) sv_bless(snapshsvref, MY_CXT.shash_handle_stash); #if QWITH_DUP snapsh->sizes_sv = sh->sizes_sv; #endif /* QWITH_DUP */ snapsh->sizes = sh->sizes; snapsh->parameter = sh->parameter; snapsh->top_pathname_sv = SvREFCNT_inc_NN(sh->top_pathname_sv); snapsh->mode = (sh->mode & ~STOREMODE_WRITE) | STOREMODE_SNAPSHOT; snapsh->data_mmap_sv = SvREFCNT_inc_NN(sh->data_mmap_sv); snapsh->data_mmap = sh->data_mmap; snapsh->data_size = sh->data_size; snapsh->u.snapshot.root = root; } SETs(snapshsvref); } #define pp1_shash_is_snapshot() THX_pp1_shash_is_snapshot(aTHX) static void THX_pp1_shash_is_snapshot(pTHX) { dSP; SETs(boolSV(shash_from_svref(TOPs)->mode & STOREMODE_SNAPSHOT)); } #define pp1_shash_idle() THX_pp1_shash_idle(aTHX) static void THX_pp1_shash_idle(pTHX) { dSP; struct shash *sh = shash_from_svref(POPs); if(unlikely(GIMME_V == G_SCALAR)) PUSHs(&PL_sv_undef); PUTBACK; if(!unlikely(sh->mode & STOREMODE_SNAPSHOT)) { SV *mapsv = sh->data_mmap_sv; if(likely(mapsv)) { sh->data_mmap_sv = NULL; SvREFCNT_dec_NN(mapsv); } } } #define pp1_shash_tidy() THX_pp1_shash_tidy(aTHX) static void THX_pp1_shash_tidy(pTHX) { int tries; dSP; struct shash *sh = shash_from_svref(POPs); if(unlikely(GIMME_V == G_SCALAR)) PUSHs(&PL_sv_undef); PUTBACK; shash_check_writable(sh, "tidy"); for(tries = 3; tries--; ) { shash_ensure_data_file(sh); if(!likely(sh->u.live.data_file_id)) break; if(likely(word_get(&WORD_AT(sh->data_mmap, sh->sizes->dhd_nextalloc_space)) < (sh->data_size >> 1))) break; if(likely(shash_try_rollover(sh, "tidy", 1<<20) != NULL_PTR)) break; } dir_clean(sh, "tidy", sh->u.live.data_file_id); } #define pp1_shash_tally_get() THX_pp1_shash_tally_get(aTHX) static void THX_pp1_shash_tally_get(pTHX) { dSP; struct shash *sh = shash_from_svref(TOPs); PERL_UNUSED_VAR(sh); SETs(tally_as_hvref(&sh->tally)); } #define pp1_shash_tally_zero() THX_pp1_shash_tally_zero(aTHX) static void THX_pp1_shash_tally_zero(pTHX) { dSP; struct shash *sh = shash_from_svref(POPs); if(unlikely(GIMME_V == G_SCALAR)) PUSHs(&PL_sv_undef); PUTBACK; PERL_UNUSED_VAR(sh); tally_zero(&sh->tally); } #define pp1_shash_tally_gzero() THX_pp1_shash_tally_gzero(aTHX) static void THX_pp1_shash_tally_gzero(pTHX) { dSP; struct shash *sh = shash_from_svref(TOPs); PERL_UNUSED_VAR(sh); SETs(tally_as_hvref(&sh->tally)); tally_zero(&sh->tally); } /* API operations in pp form for ops */ #ifdef cv_set_call_checker # define HSM_MAKE_PP(name) \ static OP *THX_pp_##name(pTHX) \ { \ pp1_##name(); \ return NORMAL; \ } HSM_MAKE_PP(is_shash) HSM_MAKE_PP(check_shash) HSM_MAKE_PP(shash_open) HSM_MAKE_PP(shash_is_readable) HSM_MAKE_PP(shash_is_writable) HSM_MAKE_PP(shash_mode) HSM_MAKE_PP(shash_exists) HSM_MAKE_PP(shash_length) HSM_MAKE_PP(shash_get) HSM_MAKE_PP(shash_set) HSM_MAKE_PP(shash_gset) HSM_MAKE_PP(shash_cset) HSM_MAKE_PP(shash_occupied) HSM_MAKE_PP(shash_count) HSM_MAKE_PP(shash_size) HSM_MAKE_PP(shash_key_min) HSM_MAKE_PP(shash_key_max) HSM_MAKE_PP(shash_key_ge) HSM_MAKE_PP(shash_key_gt) HSM_MAKE_PP(shash_key_le) HSM_MAKE_PP(shash_key_lt) HSM_MAKE_PP(shash_keys_array) HSM_MAKE_PP(shash_keys_hash) HSM_MAKE_PP(shash_group_get_hash) HSM_MAKE_PP(shash_snapshot) HSM_MAKE_PP(shash_is_snapshot) HSM_MAKE_PP(shash_idle) HSM_MAKE_PP(shash_tidy) HSM_MAKE_PP(shash_tally_get) HSM_MAKE_PP(shash_tally_zero) HSM_MAKE_PP(shash_tally_gzero) #endif /* cv_set_call_checker */ /* API operations as XS function bodies */ #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE static void S_croak_xs_usage(const CV *, const char *); # define croak_xs_usage(cv, params) S_croak_xs_usage(cv, params) #endif /* !PERL_ARGS_ASSERT_CROAK_XS_USAGE */ #define HSM_MAKE_XSFUNC(name, arity, argnames) \ static void THX_xsfunc_##name(pTHX_ CV *cv) \ { \ dMARK; dSP; \ if(unlikely(SP - MARK != arity)) croak_xs_usage(cv, argnames); \ pp1_##name(); \ } HSM_MAKE_XSFUNC(is_shash, 1, "arg") HSM_MAKE_XSFUNC(check_shash, 1, "arg") HSM_MAKE_XSFUNC(shash_open, 2, "filename, mode") HSM_MAKE_XSFUNC(shash_is_readable, 1, "shash") HSM_MAKE_XSFUNC(shash_is_writable, 1, "shash") HSM_MAKE_XSFUNC(shash_mode, 1, "shash") HSM_MAKE_XSFUNC(shash_exists, 2, "shash, key") HSM_MAKE_XSFUNC(shash_length, 2, "shash, key") HSM_MAKE_XSFUNC(shash_get, 2, "shash, key") HSM_MAKE_XSFUNC(shash_set, 3, "shash, key, newvalue") HSM_MAKE_XSFUNC(shash_tied_store, 3, "shash, key, newvalue") HSM_MAKE_XSFUNC(shash_gset, 3, "shash, key, newvalue") HSM_MAKE_XSFUNC(shash_tied_delete, 2, "shash, key") HSM_MAKE_XSFUNC(shash_cset, 4, "shash, key, chkvalue, newvalue") HSM_MAKE_XSFUNC(shash_occupied, 1, "shash") HSM_MAKE_XSFUNC(shash_count, 1, "shash") HSM_MAKE_XSFUNC(shash_size, 1, "shash") HSM_MAKE_XSFUNC(shash_key_min, 1, "shash") HSM_MAKE_XSFUNC(shash_key_max, 1, "shash") HSM_MAKE_XSFUNC(shash_key_ge, 2, "shash, key") HSM_MAKE_XSFUNC(shash_key_gt, 2, "shash, key") HSM_MAKE_XSFUNC(shash_key_le, 2, "shash, key") HSM_MAKE_XSFUNC(shash_key_lt, 2, "shash, key") HSM_MAKE_XSFUNC(shash_keys_array, 1, "shash") HSM_MAKE_XSFUNC(shash_keys_hash, 1, "shash") HSM_MAKE_XSFUNC(shash_group_get_hash, 1, "shash") HSM_MAKE_XSFUNC(shash_snapshot, 1, "shash") HSM_MAKE_XSFUNC(shash_is_snapshot, 1, "shash") HSM_MAKE_XSFUNC(shash_idle, 1, "shash") HSM_MAKE_XSFUNC(shash_tidy, 1, "shash") HSM_MAKE_XSFUNC(shash_tally_get, 1, "shash") HSM_MAKE_XSFUNC(shash_tally_zero, 1, "shash") HSM_MAKE_XSFUNC(shash_tally_gzero, 1, "shash") #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE # undef croak_xs_usage #endif /* !PERL_ARGS_ASSERT_CROAK_XS_USAGE */ /* checker to turn function calls into custom ops */ #ifdef cv_set_call_checker static OP *THX_ck_entersub_args_hsm(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) { CV *cv = (CV*)ckobj; OP *pushop, *firstargop, *cvop, *lastargop, *argop, *newop; int nargs; entersubop = ck_entersub_args_proto(entersubop, namegv, (SV*)cv); pushop = cUNOPx(entersubop)->op_first; if(!OpHAS_SIBLING(pushop)) pushop = cUNOPx(pushop)->op_first; firstargop = OpSIBLING(pushop); for (cvop = firstargop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; for (nargs = 0, lastargop = pushop, argop = firstargop; argop != cvop; lastargop = argop, argop = OpSIBLING(argop)) nargs++; if(unlikely(nargs != (int)CvPROTOLEN(cv))) return entersubop; OpMORESIB_set(pushop, cvop); OpLASTSIB_set(lastargop, NULL); op_free(entersubop); newop = newUNOP(OP_NULL, 0, lastargop); cUNOPx(newop)->op_first = firstargop; # ifdef XopENTRY_set newop->op_type = OP_CUSTOM; # else /* !XopENTRY_set */ newop->op_type = OP_DOFILE; # endif /* !XopENTRY_set */ newop->op_ppaddr = DPTR2FPTR(Perl_ppaddr_t, CvXSUBANY(cv).any_ptr); return newop; } #endif /* cv_set_call_checker */ MODULE = Hash::SharedMem PACKAGE = Hash::SharedMem PROTOTYPES: DISABLE BOOT: { dirref_ensure_strategy(); (void) newCONSTSUB(NULL, "Hash::SharedMem::shash_referential_handle", boolSV(likely(dirref_referential()))); } BOOT: { MY_CXT_INIT; MY_CXT.safe_undef = newSV(0); SvREADONLY_on(MY_CXT.safe_undef); MY_CXT.sizes_table = newHV(); MY_CXT.shash_handle_stash = gv_stashpvs("Hash::SharedMem::Handle", 1); tally_boot(); } #if QWITH_DUP void CLONE(...) CODE: PERL_UNUSED_VAR(items); { MY_CXT_CLONE; MY_CXT.safe_undef = newSV(0); SvREADONLY_on(MY_CXT.safe_undef); MY_CXT.sizes_table = newHV(); MY_CXT.shash_handle_stash = gv_stashpvs("Hash::SharedMem::Handle", 1); tally_boot(); } #endif /* QWITH_DUP */ BOOT: { #ifdef cv_set_call_checker # define PPFUNC_(name) THX_pp_##name, #else /* !cv_set_call_checker */ # define PPFUNC_(name) /**/ #endif /* !cv_set_call_checker */ #define HSM_FUNC_TO_INSTALL(name, arity) \ { \ "Hash::SharedMem::"#name, \ PPFUNC_(name) \ THX_xsfunc_##name, \ (arity), \ } struct { char const *fqsubname; #ifdef cv_set_call_checker Perl_ppaddr_t THX_pp; #endif /* cv_set_call_checker */ XSUBADDR_t THX_xsfunc; int arity; } const funcs_to_install[] = { HSM_FUNC_TO_INSTALL(is_shash, 1), HSM_FUNC_TO_INSTALL(check_shash, 1), HSM_FUNC_TO_INSTALL(shash_open, 2), HSM_FUNC_TO_INSTALL(shash_is_readable, 1), HSM_FUNC_TO_INSTALL(shash_is_writable, 1), HSM_FUNC_TO_INSTALL(shash_mode, 1), HSM_FUNC_TO_INSTALL(shash_exists, 2), HSM_FUNC_TO_INSTALL(shash_length, 2), HSM_FUNC_TO_INSTALL(shash_get, 2), HSM_FUNC_TO_INSTALL(shash_set, 3), HSM_FUNC_TO_INSTALL(shash_gset, 3), HSM_FUNC_TO_INSTALL(shash_cset, 4), HSM_FUNC_TO_INSTALL(shash_occupied, 1), HSM_FUNC_TO_INSTALL(shash_count, 1), HSM_FUNC_TO_INSTALL(shash_size, 1), HSM_FUNC_TO_INSTALL(shash_key_min, 1), HSM_FUNC_TO_INSTALL(shash_key_max, 1), HSM_FUNC_TO_INSTALL(shash_key_ge, 2), HSM_FUNC_TO_INSTALL(shash_key_gt, 2), HSM_FUNC_TO_INSTALL(shash_key_le, 2), HSM_FUNC_TO_INSTALL(shash_key_lt, 2), HSM_FUNC_TO_INSTALL(shash_keys_array, 1), HSM_FUNC_TO_INSTALL(shash_keys_hash, 1), HSM_FUNC_TO_INSTALL(shash_group_get_hash, 1), HSM_FUNC_TO_INSTALL(shash_snapshot, 1), HSM_FUNC_TO_INSTALL(shash_is_snapshot, 1), HSM_FUNC_TO_INSTALL(shash_idle, 1), HSM_FUNC_TO_INSTALL(shash_tidy, 1), HSM_FUNC_TO_INSTALL(shash_tally_get, 1), HSM_FUNC_TO_INSTALL(shash_tally_zero, 1), HSM_FUNC_TO_INSTALL(shash_tally_gzero, 1), }, *fti; int i; for(i = C_ARRAY_LENGTH(funcs_to_install); i--; ) { CV *fcv; #if defined(cv_set_call_checker) && defined(XopENTRY_set) XOP *xop; char const *shortname; #endif /* cv_set_call_checker && XopENTRY_set */ fti = &funcs_to_install[i]; fcv = newXSproto_portable((char*)fti->fqsubname, fti->THX_xsfunc, __FILE__, "$$$$"+4-fti->arity); #ifdef cv_set_call_checker # ifdef XopENTRY_set Newxz(xop, 1, XOP); shortname = fti->fqsubname + sizeof("Hash::SharedMem::")-1; XopENTRY_set(xop, xop_name, shortname); XopENTRY_set(xop, xop_desc, shortname); XopENTRY_set(xop, xop_class, OA_UNOP); Perl_custom_op_register(aTHX_ fti->THX_pp, xop); # endif /* XopENTRY_set */ CvXSUBANY(fcv).any_ptr = FPTR2DPTR(void*, fti->THX_pp); cv_set_call_checker(fcv, THX_ck_entersub_args_hsm, (SV*)fcv); #else /* !cv_set_call_checker */ PERL_UNUSED_VAR(fcv); #endif /* !cv_set_call_checker */ } } BOOT: { HV *fstash = gv_stashpvs("Hash::SharedMem", 0); (void) hv_stores(fstash, "shash_getd", SvREFCNT_inc_NN(*hv_fetchs(fstash, "shash_exists", 0))); } MODULE = Hash::SharedMem PACKAGE = Hash::SharedMem::Handle PROTOTYPES: DISABLE SV * referential_handle(SV *classname) CODE: PERL_UNUSED_VAR(classname); RETVAL = boolSV(likely(dirref_referential())); OUTPUT: RETVAL SV * open(SV *classname, SV *filename, SV *mode) CODE: PERL_UNUSED_VAR(classname); PUTBACK; RETVAL = shash_open(filename, mode); SvREFCNT_inc_simple_void_NN(RETVAL); SPAGAIN; OUTPUT: RETVAL BOOT: { HV *fstash = gv_stashpvs("Hash::SharedMem", 0); HV *mstash = gv_stashpvs("Hash::SharedMem::Handle", 0); HE *he; for(hv_iterinit(fstash); (he = hv_iternext(fstash)); ) { STRLEN klen; char const *kpv = HePV(he, klen); if(klen > 6 && memcmp(kpv, "shash_", 6) == 0 && !(klen == 24 && memcmp(kpv+6, "referential_handle", 18) == 0) && !(klen == 10 && memcmp(kpv+6, "open", 4) == 0)) (void) hv_store(mstash, kpv+6, klen-6, SvREFCNT_inc_NN(HeVAL(he)), 0); } } SV * TIEHASH(SV *classname, SV *arg0, SV *arg1 = NULL) CODE: PERL_UNUSED_VAR(classname); if(!arg1) { arg_check_shash(arg0); RETVAL = newRV_ro_mortal_inc(SvRV(arg0)); } else { PUTBACK; RETVAL = shash_open(arg0, arg1); SPAGAIN; } SvREFCNT_inc_simple_void_NN(RETVAL); OUTPUT: RETVAL void CLEAR(SV *shash) PPCODE: arg_check_shash(shash); croak("can't clear shared hash"); BOOT: { HV *mstash = gv_stashpvs("Hash::SharedMem::Handle", 0); (void) hv_stores(mstash, "EXISTS", SvREFCNT_inc_NN(*hv_fetchs(mstash, "exists", 0))); (void) hv_stores(mstash, "FETCH", SvREFCNT_inc_NN(*hv_fetchs(mstash, "get", 0))); (void) newXSproto_portable("Hash::SharedMem::Handle::STORE", THX_xsfunc_shash_tied_store, __FILE__, "$$$"); (void) newXSproto_portable("Hash::SharedMem::Handle::DELETE", THX_xsfunc_shash_tied_delete, __FILE__, "$$"); #if PERL_VERSION_GE(5,25,3) (void) hv_stores(mstash, "SCALAR", SvREFCNT_inc_NN(*hv_fetchs(mstash, "count", 0))); #else /* <5.25.3 */ (void) hv_stores(mstash, "SCALAR", SvREFCNT_inc_NN(*hv_fetchs(mstash, "occupied", 0))); #endif /* <5.25.3 */ (void) hv_stores(mstash, "FIRSTKEY", SvREFCNT_inc_NN(*hv_fetchs(mstash, "key_min", 0))); (void) hv_stores(mstash, "NEXTKEY", SvREFCNT_inc_NN(*hv_fetchs(mstash, "key_gt", 0))); } Hash-SharedMem-0.005/lib/Hash/features.probe000444001750001750 1027313143376054 20665 0ustar00zeframzefram000000000000my $testnum = 0; my $compile_ok = sub { my($builder, $hdrs, $code, $link_ctl) = @_; use IO::File; my $conftest_base = $builder->localize_file_path( "lib/Hash/conftest$testnum"); my $conftest_file = $builder->localize_file_path( "lib/Hash/conftest$testnum.c"); $testnum++; $builder->add_to_cleanup($conftest_file); my $src_fh = IO::File->new($conftest_file, "w") or die "can't write $conftest_file: $!"; $src_fh->printflush("#include \"EXTERN.h\"\n". "#include \"perl.h\"\n". "#include \"XSUB.h\"\n". join("", map { "#include <$_>\n" } @$hdrs). "int main(void) {$code}\n") or die "can't write $conftest_file: $!"; $src_fh = undef; return eval { my $obj_file = $builder->compile_c($conftest_file, no_feature_defs => 1); my $cbuilder = $builder->cbuilder; if($link_ctl) { $builder->add_to_cleanup( $cbuilder->exe_file($obj_file)); $cbuilder->link_executable( objects => $obj_file, extra_linker_flags => [ @{$builder->extra_linker_flags || []}, (exists($link_ctl->{extra}) ? @{$link_ctl->{extra}} : ()), ], ); } 1; } || 0; }; sub { my($builder) = @_; my %defs; my @libs; $compile_ok->($builder, ["stdio.h"], q{ char buf[5]; return sprintf(buf, "%d", 0) + 1; }, {}) or die "probe system failed: can't compile innocuous program"; $compile_ok->($builder, [], q{ extern int HLBNzorFAJMYbPEjiEKkMFBaKqZMkqq(void); return HLBNzorFAJMYbPEjiEKkMFBaKqZMkqq() + 1; }, {}) and die "probe system failed: non-existent function usable"; $compile_ok->($builder, ["sys/mman.h"], q{ int res; res = mmap(NULL, 4096, PROT_READ, MAP_SHARED, 3, 0) == (void*)-1; return res; }, {}) or die "OS unsupported: mmap(2) not available"; $defs{QHAVE_GETPAGESIZE} = $compile_ok->($builder, [], q{ int res; res = getpagesize(); return res; }, {}); $defs{QHAVE_SYSCONF} = $compile_ok->($builder, [], q{ int res; res = sysconf(0); return res; }, {}); $defs{QHAVE_PATHCONF} = $compile_ok->($builder, [], q{ int res; res = pathconf("/", 0); return res; }, {}); $defs{QHAVE_CLOCK_GETTIME} = $compile_ok->($builder, [], q{ struct timespec ts; int res; res = clock_gettime(CLOCK_REALTIME, &ts); return res; }, {}); if(!$defs{QHAVE_CLOCK_GETTIME} && $compile_ok->($builder, [], q{ struct timespec ts; int res; res = clock_gettime(CLOCK_REALTIME, &ts); return res; }, {extra=>["-lrt"]})) { push @libs, "-lrt"; $defs{QHAVE_CLOCK_GETTIME} = 1; } $defs{QHAVE_GETTIMEOFDAY} = $compile_ok->($builder, [], q{ struct timeval tv; int res; res = gettimeofday(&tv, NULL); return res; }, {}); # Cygwin declares openat(2) et al functions, and they # superficially appear to work, but they're frauds. They don't # actually use a reference to the directory, as a fd would appear # to supply. Instead the directory fd encapsulates the absolute # pathname under which the directory was opened, and openat(2) # et al use the saved pathname. They therefore fail if the # directory is renamed. # # We therefore reject Cygwin's versions of these functions, # in favour of our own fakery that we don't mistake for the # real thing. $defs{QHAVE_OPENAT} = $^O eq "cygwin" ? 0 : $compile_ok->($builder, [], q{ int res; res = openat(0, ".", 0, 0); return res; }, {}); $defs{QHAVE_FSTATAT} = $^O eq "cygwin" ? 0 : $compile_ok->($builder, [], q{ struct stat st; int res; res = fstatat(0, ".", &st, 0); return res; }, {}); $defs{QHAVE_LINKAT} = $^O eq "cygwin" ? 0 : $compile_ok->($builder, [], q{ int res; res = linkat(0, ".", 0, ".", 0); return res; }, {}); $defs{QHAVE_UNLINKAT} = $^O eq "cygwin" ? 0 : $compile_ok->($builder, [], q{ int res; res = unlinkat(0, ".", 0); return res; }, {}); $defs{QHAVE_FDOPENDIR} = $compile_ok->($builder, [], q{ DIR *dirh; dirh = fdopendir(0); return !dirh; }, {}); $defs{QHAVE_REALPATH} = $compile_ok->($builder, [], q{ char *res, buf[4096]; res = realpath(".", buf); return !res; }, {}); $defs{QHAVE_GETCWD} = $compile_ok->($builder, [], q{ char *res, buf[4096]; res = getcwd(buf, sizeof(buf)); return !res; }, {}); return { defs => \%defs, libs => \@libs }; } Hash-SharedMem-0.005/lib/Hash/SharedMem000755001750001750 013143376054 17503 5ustar00zeframzefram000000000000Hash-SharedMem-0.005/lib/Hash/SharedMem/Handle.pm000444001750001750 2456413143376054 21424 0ustar00zeframzefram000000000000=head1 NAME Hash::SharedMem::Handle - handle for efficient shared mutable hash =head1 SYNOPSIS use Hash::SharedMem::Handle; if(Hash::SharedMem::Handle->referential_handle) { ... $shash = Hash::SharedMem::Handle->open($filename, "rwc"); if($shash->is_readable) { ... if($shash->is_writable) { ... $mode = $shash->mode; if($shash->exists($key)) { ... $length = $shash->length($key); $value = $shash->get($key); $shash->set($key, $newvalue); $oldvalue = $shash->gset($key, $newvalue); if($shash->cset($key, $chkvalue, $newvalue)) { ... if($shash->occupied) { ... $count = $shash->count; $size = $shash->size; $key = $shash->key_min; $key = $shash->key_max; $key = $shash->key_ge($key); $key = $shash->key_gt($key); $key = $shash->key_le($key); $key = $shash->key_lt($key); $keys = $shash->keys_array; $keys = $shash->keys_hash; $group = $shash->group_get_hash; $snap_shash = $shash->snapshot; if($shash->is_snapshot) { ... $shash->idle; $shash->tidy; $tally = $shash->tally_get; $shash->tally_zero; $tally = $shash->tally_gzero; tie %shash, "Hash::SharedMem::Handle", $shash; tie %shash, "Hash::SharedMem::Handle", $filename, "rwc"; $shash = tied(%shash); if(exists($shash{$key})) { ... $value = $shash{$key}; $shash{$key} = $newvalue; $oldvalue = delete($shash{$key}); =head1 DESCRIPTION An object of this class is a handle referring to a memory-mapped shared hash object of the kind described in L. It can be passed to the functions of that module, or the same operations can be performed by calling the methods described below. Uses of the function and method interfaces may be intermixed arbitrarily; they are completely equivalent in function. They are not equivalent in performance, however, with the method interface being somewhat slower. This class also supplies a tied-hash interface to shared hashes. The tied interface is much slower than the function and method interfaces. The behaviour of a tied hash more resembles the function and method interfaces to shared hashes than it resembles the syntactically-similar use of ordinary Perl hashes. Using a non-string as a key will result in an exception, rather than stringification of the key. Using a string containing a non-octet codepoint as a key will also result in an exception, rather than merely referring to an absent hash element. =cut package Hash::SharedMem::Handle; { use 5.006; } use warnings; use strict; use Hash::SharedMem (); our $VERSION = "0.005"; =head1 CLASS METHODS =over =item Hash::SharedMem::Handle->referential_handle Returns a truth value indicating whether each shared hash handle contains a first-class reference to the shared hash to which it refers. See L for discussion of the significance of this. =back =head1 CONSTRUCTOR =over =item Hash::SharedMem::Handle->open(FILENAME, MODE) Opens and returns a handle referring to a shared hash object, or Cs if the shared hash can't be opened as specified. See L for details. =back =head1 METHODS =over =item $shash->is_readable =item $shash->is_writable =item $shash->mode =item $shash->exists(KEY) =item $shash->getd(KEY) =item $shash->length(KEY) =item $shash->get(KEY) =item $shash->set(KEY, NEWVALUE) =item $shash->gset(KEY, NEWVALUE) =item $shash->cset(KEY, CHKVALUE, NEWVALUE) =item $shash->occupied =item $shash->count =item $shash->size =item $shash->key_min =item $shash->key_max =item $shash->key_ge(KEY) =item $shash->key_gt(KEY) =item $shash->key_le(KEY) =item $shash->key_lt(KEY) =item $shash->keys_array =item $shash->keys_hash =item $shash->group_get_hash =item $shash->snapshot =item $shash->is_snapshot =item $shash->idle =item $shash->tidy =item $shash->tally_get =item $shash->tally_zero =item $shash->tally_gzero These methods are each equivalent to the corresponding "C"-prefixed function in L. See that document for details. =back =head1 TIE CONSTRUCTORS =over =item tie(VARIABLE, "Hash::SharedMem::Handle", SHASH) I must be a hash variable, and I must be a handle referring to a shared hash object. The call binds the variable to the shared hash, so that the variable provides a view of the shared hash that resembles an ordinary Perl hash. The shared hash handle is returned. =item tie(VARIABLE, "Hash::SharedMem::Handle", FILENAME, MODE) I must be a hash variable. The call opens a handle referring to a shared hash object, as described in L, and binds the variable to the shared hash, so that the variable provides a view of the shared hash that resembles an ordinary Perl hash. The shared hash handle is returned. =back =head1 TIED OPERATORS For all of these operators, the key of interest (I parameter) and values can each be any octet (Latin-1) string. Strings containing non-octets (Unicode characters above U+FF) and items other than strings cannot be used as keys or values. If a dualvar (scalar with independent string and numeric values) is supplied, only its string value will be used. =over =item tied(%SHASH) Returns the handle via which I<%SHASH> is bound to the shared hash. This is a shared hash handle that can be used by calling the methods described above or by passing it to the functions of L. =item exists($SHASH{KEY}) Returns a truth value indicating whether the specified key is currently present in the shared hash. =item $SHASH{KEY} Returns the value currently referenced by the specified key in the shared hash, or C if the key is absent. =item $SHASH{KEY} = NEWVALUE Modifies the shared hash so that the specified key henceforth references the specified value. The new value must be a string. =item delete($SHASH{KEY}) Modifies the shared hash so that the specified key is henceforth absent, and returns the value that the key previously referenced, or C if the key was already absent. This swap is performed atomically. =item scalar(%SHASH) From Perl 5.25.3 onwards, returns the number of items that are currently in the shared hash. This matches the behaviour of untied hashes on these Perl versions. Prior to Perl 5.25.3, from Perl 5.8.3 onwards, returns a truth value indicating whether there are currently any items in the shared hash. Does not supply any additional information corresponding to the hash bucket usage information that untied hashes supply in this situation. Prior to Perl 5.8.3, returns a meaningless value, due to a limitation of the tying system. If the hash is evaluated in a truth value context, with the expectation of this testing whether the shared hash is occupied, there is a performance concern. Prior to Perl 5.25.3 only the truth value would be determined, quite cheaply. From Perl 5.25.3 onwards, a more expensive operation is performed, counting all the keys. If this is a problem, one can evaluate C<< tied(%SHASH)->occupied >> to explicitly invoke the truth-value-only operation. However, if performance is a concern then the tied interface is best entirely avoided. =item scalar(keys(%SHASH)) =item scalar(values(%SHASH)) Returns the number of items that are currently in the shared hash. Due to a limitation of the tying system, the item count is not extracted atomically, but is derived by means equivalent to a loop using C. If the set of keys in the shared hash changes during this process, the count of keys visited (which is what is actually returned) does not necessarily match any state that the shared hash has ever been in. =item each(%SHASH) Iterates over the shared hash. On each call, returns either the next key (in scalar context) or the next key and the value that it references (in list context). The iterator state, preserved between calls, is attached to C<%SHASH>. The iteration process always visits the keys in lexicographical order. Unlike iteration of untied hashes, it is safe to make any changes at all to the shared hash content between calls to C. Subsequent calls see the new content, and the iteration process resumes with whatever key (in the new content) follows the key most recently visited (from the old content). When using C in list context, the fetching of the next key and its corresponding value is not an atomic operation, due to a limitation of the tying system. The key and value are fetched as two separate operations (each one individually atomic), and it is possible for the shared hash content to change between them. This is noticeable if the key that was fetched gets deleted before the value is fetched: it will appear that the value is C, which is not a permitted value in a shared hash. =item keys(%SHASH) =item values(%SHASH) =item %SHASH Enumerates the shared hash's content (keys alone, values alone, or keys with values), and as a side effect resets the iterator state used by C. Always returns the content in lexicographical order of key. Due to a limitation of the tying system, the content is not extracted atomically, and so the content returned as a whole does not necessarily match any state that the shared hash has ever been in. The content is extracted by means equivalent to a loop using C, and the inconsistencies that may be seen follow therefrom. =item %SHASH = LIST Setting the entire content of the shared hash (throwing away the previous content) is not supported. =back =head1 BUGS Due to details of the Perl implementation, this object-oriented interface to the shared hash mechanism is somewhat slower than the function interface, and the tied interface is much slower. The functions in L are the recommended interface. Limitations of the tying system mean that whole-hash operations (including iteration and enumeration) performed on shared hashes via the tied interface are not as atomic as they appear. If it is necessary to see a consistent state of a shared hash, one must create and use a snapshot handle. A snapshot may be iterated over or enumerated at leisure via any of the interfaces. =head1 SEE ALSO L =head1 AUTHOR Andrew Main (Zefram) =head1 COPYRIGHT Copyright (C) 2014, 2015 PhotoBox Ltd Copyright (C) 2014, 2015, 2017 Andrew Main (Zefram) =head1 LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Hash-SharedMem-0.005/t000755001750001750 013143376054 14450 5ustar00zeframzefram000000000000Hash-SharedMem-0.005/t/arg_error.t000444001750001750 1534613143376054 17005 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Scalar::String 0.000 qw(sclstr_downgraded sclstr_upgraded); use Test::More tests => 816; BEGIN { use_ok "Hash::SharedMem", qw( is_shash check_shash shash_open shash_is_readable shash_is_writable shash_mode shash_exists shash_getd shash_length shash_get shash_set shash_gset shash_cset shash_occupied shash_count shash_size shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash shash_snapshot shash_is_snapshot shash_idle shash_tidy shash_tally_get shash_tally_zero shash_tally_gzero ); } foreach( undef, 1, sclstr_downgraded("foo"), sclstr_upgraded("foo"), sclstr_downgraded("\x{e9}foo"), sclstr_upgraded("\x{e9}foo"), sclstr_upgraded("\x{2603}foo"), ${qr/foo/}, *foo, \1, [], {}, sub{}, qr/foo/, \*foo, bless({}), ) { ok !is_shash($_); eval { check_shash($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_is_readable($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_is_writable($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_mode($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_exists($_, "x") }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_getd($_, "x") }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_length($_, "x") }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_get($_, "x") }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_set($_, "x", "y") }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_gset($_, "x", "y") }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_cset($_, "x", "y", "z") }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_occupied($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_count($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_size($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_key_min($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_key_max($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_key_ge($_, "x") }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_key_gt($_, "x") }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_key_le($_, "x") }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_key_lt($_, "x") }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_keys_array($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_keys_hash($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_group_get_hash($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_snapshot($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_is_snapshot($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_idle($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_tidy($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_tally_get($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_tally_zero($_) }; like $@, qr/\Ahandle is not a shared hash handle /; eval { shash_tally_gzero($_) }; like $@, qr/\Ahandle is not a shared hash handle /; } my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); eval { check_shash($sh) }; is $@, ""; require_ok "Hash::SharedMem::Handle"; my %sh; tie %sh, "Hash::SharedMem::Handle", $sh; ok is_shash(tied(%sh)); foreach( undef, sclstr_upgraded("\x{2603}foo"), ${qr/foo/}, *foo, \1, [], {}, sub{}, qr/foo/, \*foo, bless({}), ) { eval { shash_exists($sh, $_) }; like $@, qr/\Akey is not an octet string at /; eval { shash_getd($sh, $_) }; like $@, qr/\Akey is not an octet string at /; eval { shash_length($sh, $_) }; like $@, qr/\Akey is not an octet string at /; eval { shash_get($sh, $_) }; like $@, qr/\Akey is not an octet string at /; eval { shash_set($sh, $_, "y") }; like $@, qr/\Akey is not an octet string at /; eval { shash_gset($sh, $_, "y") }; like $@, qr/\Akey is not an octet string at /; eval { shash_cset($sh, $_, "y", "z") }; like $@, qr/\Akey is not an octet string at /; eval { shash_key_ge($sh, $_) }; like $@, qr/\Akey is not an octet string at /; eval { shash_key_gt($sh, $_) }; like $@, qr/\Akey is not an octet string at /; eval { shash_key_le($sh, $_) }; like $@, qr/\Akey is not an octet string at /; eval { shash_key_lt($sh, $_) }; like $@, qr/\Akey is not an octet string at /; SKIP: { skip "copying mangles regexps on this Perl", 4 if "$]" >= 5.011000 && "$]" < 5.011002 && ref(\$_) eq "Regexp"; no warnings "uninitialized"; eval { my $e = exists $sh{$_} }; like $@, qr/\Akey is not an octet string at /; eval { my $v = $sh{$_} }; like $@, qr/\Akey is not an octet string at /; eval { $sh{$_} = "y" }; like $@, qr/\Akey is not an octet string at /; eval { delete $sh{$_} }; like $@, qr/\Akey is not an octet string at /; } } foreach( sclstr_upgraded("\x{2603}foo"), defined(${qr/foo/}) ? ${qr/foo/} : \1, *foo, \1, [], {}, sub{}, qr/foo/, \*foo, bless({}), ) { eval { shash_set($sh, "x", $_) }; like $@, qr/\Anew value is neither an octet string nor undef at /; eval { shash_gset($sh, "x", $_) }; like $@, qr/\Anew value is neither an octet string nor undef at /; eval { shash_cset($sh, "x", $_, "z") }; like $@, qr/\Acheck value is neither an octet string nor undef at /; eval { shash_cset($sh, "x", "y", $_) }; like $@, qr/\Anew value is neither an octet string nor undef at /; } foreach( # These tests for tied hash values must omit the glob and regexp # test values that were used above, because per [perl #121477] # such values get mangled by the tying infrastructure. undef, sclstr_upgraded("\x{2603}foo"), \1, [], {}, sub{}, qr/foo/, \*foo, bless({}), ) { eval { $sh{x} = $_ }; like $@, qr/\Anew value is not an octet string at /; } my $i = 1; foreach( undef, ${qr/foo/}, *foo, \1, [], {}, sub{}, qr/foo/, \*foo, bless({}), ) { is eval { shash_open($_, "r") }, undef; like $@, qr/\Afilename is not a string at /; is eval { shash_open("$tmpdir/t".$i++, $_) }, undef; like $@, qr/\Amode is not a string at /; is eval { Hash::SharedMem::Handle->open($_, "r") }, undef; like $@, qr/\Afilename is not a string at /; is eval { Hash::SharedMem::Handle->open("$tmpdir/t".$i++, $_) }, undef; like $@, qr/\Amode is not a string at /; my %h; eval { tie %h, "Hash::SharedMem::Handle", $_, "r" }; like $@, qr/\Afilename is not a string at /; eval { tie %h, "Hash::SharedMem::Handle", "$tmpdir/t".$i++, $_ }; like $@, qr/\Amode is not a string at /; } 1; Hash-SharedMem-0.005/t/bad_dir.t000444001750001750 137313143376054 16362 0ustar00zeframzefram000000000000use warnings; use strict; use Errno 1.00 qw(ENOENT); use File::Temp 0.22 qw(tempdir); use Test::More tests => 7; BEGIN { use_ok "Hash::SharedMem", qw(is_shash shash_open shash_set); } my $enoent = do { local $! = ENOENT; "$!" }; my $tmpdir = tempdir(CLEANUP => 1); sub touch($) { my($fn) = @_; open(my $fh, ">", $fn) or die "can't create $fn: $!"; } is eval { shash_open("$tmpdir/t0", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: \Q$enoent\E at #; touch("$tmpdir/t1"); is eval { shash_open("$tmpdir/t1", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t1: not a shared hash at #; is eval { shash_open("$tmpdir/t1", "rwc") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t1: not a shared hash at #; 1; Hash-SharedMem-0.005/t/bad_master.t000444001750001750 520213143376054 17072 0ustar00zeframzefram000000000000use warnings; use strict; use Errno 1.00 qw(EISDIR); use File::Temp 0.22 qw(tempdir); use Test::More tests => 28; my $eisdir = do { local $! = EISDIR; "$!" }; BEGIN { use_ok "Hash::SharedMem", qw(is_shash shash_open); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); $sh = undef; my $master_file = "$tmpdir/t0/iNmv0,m\$%3"; my $size = -s $master_file; $size or die; ok is_shash(eval { shash_open("$tmpdir/t0", "rw") }); open(my $fh, ">>", $master_file) or die "can't enlarge $master_file: $!"; print {$fh} ("\0" x $size) or die "can't enlarge $master_file: $!"; close $fh or die "can't enlarge $master_file: $!"; is eval { shash_open("$tmpdir/t0", "r") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: not a shared hash at #; is eval { shash_open("$tmpdir/t0", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: not a shared hash at #; is eval { shash_open("$tmpdir/t0", "rwc") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: not a shared hash at #; truncate $master_file, $size>>1 or die "can't reduce $master_file: $!"; is eval { shash_open("$tmpdir/t0", "r") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: not a shared hash at #; is eval { shash_open("$tmpdir/t0", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: not a shared hash at #; is eval { shash_open("$tmpdir/t0", "rwc") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: not a shared hash at #; open($fh, ">", $master_file) or die "can't rewrite $master_file: $!"; print {$fh} ("\0" x $size) or die "can't rewrite $master_file: $!"; close $fh or die "can't rewrite $master_file: $!"; is eval { shash_open("$tmpdir/t0", "r") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: not a shared hash at #; is eval { shash_open("$tmpdir/t0", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: not a shared hash at #; is eval { shash_open("$tmpdir/t0", "rwc") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: not a shared hash at #; unlink $master_file or die "can't remove $master_file: $!"; mkdir $master_file or die "can't create $master_file: $!"; is eval { shash_open("$tmpdir/t0", "r") }, undef; like $@, qr#\Acan't\ open\ shared\ hash\ \Q$tmpdir\E/t0: \ (?:\Q$eisdir\E|not\ a\ shared\ hash)\ at\ #x; is eval { shash_open("$tmpdir/t0", "rw") }, undef; like $@, qr#\Acan't\ open\ shared\ hash\ \Q$tmpdir\E/t0: \ (?:\Q$eisdir\E|not\ a\ shared\ hash)\ at\ #x; is eval { shash_open("$tmpdir/t0", "rwc") }, undef; like $@, qr#\Acan't\ open\ shared\ hash\ \Q$tmpdir\E/t0: \ (?:\Q$eisdir\E|not\ a\ shared\ hash)\ at\ #x; 1; Hash-SharedMem-0.005/t/chdir.t000444001750001750 353213143376054 16066 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 109; BEGIN { use_ok "Hash::SharedMem", qw(is_shash shash_open shash_set shash_get); } my $tmpdir = tempdir(CLEANUP => 1); sub mkd($) { my($fn) = @_; mkdir $fn or die "can't create $fn: $!"; } sub chd($) { my($fn) = @_; chdir $fn or die "can't chdir to $fn: $!"; } sub test_chdir($$$$$) { my($absloc, $firstdir, $relloc, $seconddir, $aval) = @_; ok !-e $absloc; chd $firstdir; my $sh = shash_open($relloc, "rwce"); ok $sh; ok is_shash($sh); chd $seconddir; shash_set($sh, "a", $aval); $sh = undef; chd "/"; ok -d $absloc; ok -f "$absloc/iNmv0,m\$%3"; ok -f "$absloc/&\"JBLMEgGm0000000000000001"; $sh = shash_open($absloc, "r"); ok $sh; ok is_shash($sh); is shash_get($sh, "a"), $aval; } mkd "$tmpdir/t0"; mkd "$tmpdir/t0/t1"; mkd "$tmpdir/t2"; mkd "$tmpdir/t2/t3"; test_chdir "$tmpdir/t2/t4", "$tmpdir/t0", "$tmpdir/t2/t4", "$tmpdir/t0/t1", "a4"; test_chdir "$tmpdir/t2/t5", "$tmpdir/t0", "../t2/t5", "$tmpdir/t0/t1", "a5"; test_chdir "$tmpdir/t2/t6", "$tmpdir/t0/t1", "$tmpdir/t2/t6", "$tmpdir/t0", "a6"; test_chdir "$tmpdir/t2/t7", "$tmpdir/t0/t1", "../../t2/t7", "$tmpdir/t0", "a7"; test_chdir "$tmpdir/t2/t3/t8", "$tmpdir/t0", "$tmpdir/t2/t3/t8", "$tmpdir/t0/t1", "a8"; test_chdir "$tmpdir/t2/t3/t9", "$tmpdir/t0", "../t2/t3/t9", "$tmpdir/t0/t1", "a9"; test_chdir "$tmpdir/t2/t3/t10", "$tmpdir/t0/t1", "$tmpdir/t2/t3/t10", "$tmpdir/t0", "a10"; test_chdir "$tmpdir/t2/t3/t11", "$tmpdir/t0/t1", "../../t2/t3/t11", "$tmpdir/t0", "a11"; test_chdir "$tmpdir/t2/t12", "$tmpdir", "$tmpdir/t2/t12", "$tmpdir/t0/t1", "a12"; test_chdir "$tmpdir/t2/t13", "$tmpdir", "t2/t13", "$tmpdir/t0/t1", "a13"; test_chdir "$tmpdir/t2/t14", "$tmpdir/t0/t1", "$tmpdir/t2/t14", "$tmpdir", "a14"; test_chdir "$tmpdir/t2/t15", "$tmpdir/t0/t1", "../../t2/t15", "$tmpdir", "a15"; 1; Hash-SharedMem-0.005/t/concurrent.t000444001750001750 1033213143376054 17173 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::Builder 0.03 (); use Test::More 0.40 tests => 145; BEGIN { use_ok "Hash::SharedMem", qw( is_shash shash_open shash_exists shash_get shash_set shash_gset shash_cset shash_count ); } my $tmpdir = tempdir(CLEANUP => 1); my @sh; $sh[0] = shash_open("$tmpdir/t0", "rwc"); ok $sh[0]; ok is_shash($sh[0]); $sh[1] = shash_open("$tmpdir/t0", "rwc"); ok $sh[1]; ok is_shash($sh[1]); $sh[2] = shash_open("$tmpdir/t0", "rw"); ok $sh[2]; ok is_shash($sh[2]); $sh[3] = shash_open("$tmpdir/t0", "r"); ok $sh[3]; ok is_shash($sh[3]); is shash_get($_, "a"), undef foreach @sh; is shash_get($_, "b"), undef foreach @sh; is shash_get($_, "c"), undef foreach @sh; is shash_get($_, "d"), undef foreach @sh; shash_set($sh[0], "a", "aa"); is shash_get($_, "a"), "aa" foreach @sh; is shash_get($_, "b"), undef foreach @sh; is shash_get($_, "c"), undef foreach @sh; is shash_get($_, "d"), undef foreach @sh; shash_set($sh[1], "b", "bb"); is shash_get($_, "a"), "aa" foreach @sh; is shash_get($_, "b"), "bb" foreach @sh; is shash_get($_, "c"), undef foreach @sh; is shash_get($_, "d"), undef foreach @sh; shash_set($sh[2], "c", "cc"); is shash_get($_, "a"), "aa" foreach @sh; is shash_get($_, "b"), "bb" foreach @sh; is shash_get($_, "c"), "cc" foreach @sh; is shash_get($_, "d"), undef foreach @sh; is shash_gset($sh[0], "a", "xx"), "aa"; is shash_get($_, "a"), "xx" foreach @sh; is shash_get($_, "b"), "bb" foreach @sh; is shash_get($_, "c"), "cc" foreach @sh; is shash_get($_, "d"), undef foreach @sh; is shash_gset($sh[1], "b", "yy"), "bb"; is shash_get($_, "a"), "xx" foreach @sh; is shash_get($_, "b"), "yy" foreach @sh; is shash_get($_, "c"), "cc" foreach @sh; is shash_get($_, "d"), undef foreach @sh; ok !shash_cset($sh[2], "c", "pp", "qq"); is shash_get($_, "a"), "xx" foreach @sh; is shash_get($_, "b"), "yy" foreach @sh; is shash_get($_, "c"), "cc" foreach @sh; is shash_get($_, "d"), undef foreach @sh; ok shash_cset($sh[2], "c", "cc", "zz"); is shash_get($_, "a"), "xx" foreach @sh; is shash_get($_, "b"), "yy" foreach @sh; is shash_get($_, "c"), "zz" foreach @sh; is shash_get($_, "d"), undef foreach @sh; @sh = (); my($rp0, $wp0, $rp1, $wp1, $pid); alarm 0; $SIG{ALRM} = "DEFAULT"; pipe($rp0, $wp0) or die "pipe: $!"; pipe($rp1, $wp1) or die "pipe: $!"; alarm 1000; $pid = fork(); defined $pid or die "fork: $!"; if($pid == 0) { Test::More->builder->no_ending(1); $File::Temp::KEEP_ALL = 1; close $wp0; close $rp1; my $sh = shash_open("$tmpdir/t0", "rw"); close $wp1; scalar <$rp0>; my $x = 5; for(my $j = 0; $j != 50000; $j++) { $x = ($x*21+7) % 100000; shash_set($sh, sprintf("%05dx", $x), "a$x"); } exit 0; } else { close $rp0; close $wp1; my $sh = shash_open("$tmpdir/t0", "rw"); close $wp0; scalar <$rp1>; my $y = 5; for(my $j = 0; $j != 50000; $j++) { $y = ($y*61+19) % 100000; shash_set($sh, sprintf("%05dy", $y), "b$y"); } close $rp1; waitpid $pid, 0; } alarm 0; { my %ph; my $x = 5; my $y = 5; for(my $j = 0; $j != 50000; $j++) { $x = ($x*21+7) % 100000; $y = ($y*61+19) % 100000; $ph{sprintf("%05dx", $x)} = "a$x"; $ph{sprintf("%05dy", $y)} = "b$y"; } my $sh = shash_open("$tmpdir/t0", "r"); is shash_count($sh), 100003; is_deeply +{ map { (shash_exists($sh, $_) ? ($_ => shash_get($sh, $_)) : ()) } map { $_."x", $_."y" } "00000".."99999" }, \%ph; } shash_set(shash_open("$tmpdir/t0", "rw"), "k", 0); pipe($rp0, $wp0) or die "pipe: $!"; pipe($rp1, $wp1) or die "pipe: $!"; alarm 1000; $pid = fork(); defined $pid or die "fork: $!"; if($pid == 0) { Test::More->builder->no_ending(1); $File::Temp::KEEP_ALL = 1; close $wp0; close $rp1; my $sh = shash_open("$tmpdir/t0", "rw"); close $wp1; scalar <$rp0>; for(my $i = 0; $i != 100000; $i++) { my($ov, $nv); do { $ov = shash_get($sh, "k"); $nv = $ov + 1; } until shash_cset($sh, "k", $ov, $nv); } exit 0; } else { close $rp0; close $wp1; my $sh = shash_open("$tmpdir/t0", "rw"); close $wp0; scalar <$rp1>; for(my $i = 0; $i != 100000; $i++) { my($ov, $nv); do { $ov = shash_get($sh, "k"); $nv = $ov + 1; } until shash_cset($sh, "k", $ov, $nv); } close $rp1; waitpid $pid, 0; } alarm 0; { my $sh = shash_open("$tmpdir/t0", "r"); is shash_count($sh), 100004; is shash_get($sh, "k"), 200000; } 1; Hash-SharedMem-0.005/t/deparse.t000444001750001750 745413143376054 16427 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More; BEGIN { unless("$]" >= 5.013007) { plan skip_all => "custom ops not registered on this Perl"; } unless(eval { require B::Deparse; B::Deparse->VERSION(1.01); 1 }) { plan skip_all => "B::Deparse unavailable"; } } use warnings; # declaing this again works around [perl #123558] BEGIN { plan tests => 33; } BEGIN { use_ok "Hash::SharedMem", qw( is_shash check_shash shash_open shash_is_readable shash_is_writable shash_mode shash_exists shash_getd shash_length shash_get shash_set shash_gset shash_cset shash_occupied shash_count shash_size shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash shash_snapshot shash_is_snapshot shash_idle shash_tidy shash_tally_get shash_tally_zero shash_tally_gzero ); } my $deparse = B::Deparse->new; $deparse->ambient_pragmas(strict => "all", warnings => "all"); sub canon_code($) { my($s) = @_; $s =~ s/[ \t\n]//g; $s =~ s#\{BEGIN\{(?:\$\^H\{'[a-z/]+'\}=undef;)*\}#{#; return $s; } sub depok($$) { is canon_code($deparse->coderef2text($_[0])), $_[1]; } my($a0, $a1, $a2, $a3); depok sub { 1 + is_shash($a0) }, "{1+Hash::SharedMem::is_shash(\$a0);}"; depok sub { check_shash($a1); 123 }, "{Hash::SharedMem::check_shash(\$a1);123;}"; depok sub { shash_open($a0, (rand($a1), $a2)) }, "{Hash::SharedMem::shash_open(\$a0,(rand\$a1,\$a2));}"; depok sub { shash_is_readable($a0) + 1 }, "{Hash::SharedMem::shash_is_readable(\$a0)+1;}"; depok sub { shash_is_writable($a3) }, "{Hash::SharedMem::shash_is_writable(\$a3);}"; depok sub { shash_mode($a0) }, "{Hash::SharedMem::shash_mode(\$a0);}"; depok sub { shash_exists($a0, $a1 = 123) }, "{Hash::SharedMem::shash_exists(\$a0,\$a1=123);}"; depok sub { shash_getd($a0, $a1 = 123) }, "{Hash::SharedMem::shash_exists(\$a0,\$a1=123);}"; depok sub { shash_length($a0, $a1) }, "{Hash::SharedMem::shash_length(\$a0,\$a1);}"; depok sub { shash_get($a0, $a1 && $a2) }, "{Hash::SharedMem::shash_get(\$a0,\$a1&&\$a2);}"; depok sub { shash_set($a0, $a1, $a2) }, "{Hash::SharedMem::shash_set(\$a0,\$a1,\$a2);}"; depok sub { shash_gset($a0, $a1, $a2) }, "{Hash::SharedMem::shash_gset(\$a0,\$a1,\$a2);}"; depok sub { shash_cset($a0, $a1, $a2, $a3) }, "{Hash::SharedMem::shash_cset(\$a0,\$a1,\$a2,\$a3);}"; depok sub { shash_occupied($a0) }, "{Hash::SharedMem::shash_occupied(\$a0);}"; depok sub { shash_count($a0) }, "{Hash::SharedMem::shash_count(\$a0);}"; depok sub { shash_size($a0) }, "{Hash::SharedMem::shash_size(\$a0);}"; depok sub { shash_key_min($a0) }, "{Hash::SharedMem::shash_key_min(\$a0);}"; depok sub { shash_key_max($a0) }, "{Hash::SharedMem::shash_key_max(\$a0);}"; depok sub { shash_key_ge($a0, $a1) }, "{Hash::SharedMem::shash_key_ge(\$a0,\$a1);}"; depok sub { shash_key_gt($a0, $a1) }, "{Hash::SharedMem::shash_key_gt(\$a0,\$a1);}"; depok sub { shash_key_le($a0, $a1) }, "{Hash::SharedMem::shash_key_le(\$a0,\$a1);}"; depok sub { shash_key_lt($a0, $a1) }, "{Hash::SharedMem::shash_key_lt(\$a0,\$a1);}"; depok sub { shash_keys_array($a0) }, "{Hash::SharedMem::shash_keys_array(\$a0);}"; depok sub { shash_keys_hash($a0) }, "{Hash::SharedMem::shash_keys_hash(\$a0);}"; depok sub { shash_group_get_hash($a0) }, "{Hash::SharedMem::shash_group_get_hash(\$a0);}"; depok sub { shash_snapshot($a0) }, "{Hash::SharedMem::shash_snapshot(\$a0);}"; depok sub { shash_is_snapshot($a0) }, "{Hash::SharedMem::shash_is_snapshot(\$a0);}"; depok sub { shash_idle($a0) }, "{Hash::SharedMem::shash_idle(\$a0);}"; depok sub { shash_tidy($a0) }, "{Hash::SharedMem::shash_tidy(\$a0);}"; depok sub { shash_tally_get($a0) }, "{Hash::SharedMem::shash_tally_get(\$a0);}"; depok sub { shash_tally_zero($a0) }, "{Hash::SharedMem::shash_tally_zero(\$a0);}"; depok sub { shash_tally_gzero($a0) }, "{Hash::SharedMem::shash_tally_gzero(\$a0);}"; 1; Hash-SharedMem-0.005/t/empty.t000444001750001750 4241213143376054 16153 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Scalar::String 0.000 qw(sclstr_is_downgraded sclstr_downgraded sclstr_upgraded); use Test::More tests => 471; BEGIN { use_ok "Hash::SharedMem", qw( is_shash shash_open shash_exists shash_length shash_get shash_set shash_gset shash_cset shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash ); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); sub is_dg($$) { ok sclstr_is_downgraded($_[0]); is sclstr_downgraded($_[0]), sclstr_downgraded($_[1]); } is shash_exists($sh, sclstr_downgraded("")), !!0; is shash_exists($sh, sclstr_upgraded("")), !!0; is shash_length($sh, sclstr_downgraded("")), undef; is shash_length($sh, sclstr_upgraded("")), undef; is shash_get($sh, sclstr_downgraded("")), undef; is shash_get($sh, sclstr_upgraded("")), undef; is shash_key_ge($sh, sclstr_downgraded("")), undef; is shash_key_ge($sh, sclstr_upgraded("")), undef; is shash_key_gt($sh, sclstr_downgraded("")), undef; is shash_key_gt($sh, sclstr_upgraded("")), undef; is shash_key_le($sh, sclstr_downgraded("")), undef; is shash_key_le($sh, sclstr_upgraded("")), undef; is shash_key_lt($sh, sclstr_downgraded("")), undef; is shash_key_lt($sh, sclstr_upgraded("")), undef; shash_set($sh, sclstr_downgraded(""), "b0"); is_dg shash_key_min($sh), ""; is_dg shash_key_max($sh), ""; shash_set($sh, sclstr_downgraded("a1"), "b1"); is_dg shash_key_min($sh), ""; is_dg shash_key_max($sh), "a1"; is_dg shash_key_ge($sh, sclstr_downgraded("")), ""; is_dg shash_key_ge($sh, sclstr_upgraded("")), ""; is_dg shash_key_gt($sh, sclstr_downgraded("")), "a1"; is_dg shash_key_gt($sh, sclstr_upgraded("")), "a1"; is_dg shash_key_le($sh, sclstr_downgraded("")), ""; is_dg shash_key_le($sh, sclstr_upgraded("")), ""; is shash_key_lt($sh, sclstr_downgraded("")), undef; is shash_key_lt($sh, sclstr_upgraded("")), undef; is shash_key_ge($sh, sclstr_downgraded("z")), undef; is shash_key_ge($sh, sclstr_upgraded("z")), undef; is shash_key_gt($sh, sclstr_downgraded("z")), undef; is shash_key_gt($sh, sclstr_upgraded("z")), undef; is_dg shash_key_le($sh, sclstr_downgraded("z")), "a1"; is_dg shash_key_le($sh, sclstr_upgraded("z")), "a1"; is_dg shash_key_lt($sh, sclstr_downgraded("z")), "a1"; is_dg shash_key_lt($sh, sclstr_upgraded("z")), "a1"; is_deeply shash_keys_array($sh), ["", "a1"]; is_deeply shash_keys_hash($sh), { ""=>undef, "a1"=>undef }; is_deeply shash_group_get_hash($sh), { ""=>"b0", "a1"=>"b1" }; is shash_exists($sh, sclstr_downgraded("")), !!1; is shash_exists($sh, sclstr_upgraded("")), !!1; is shash_length($sh, sclstr_downgraded("")), 2; is shash_length($sh, sclstr_upgraded("")), 2; is_dg shash_get($sh, sclstr_downgraded("")), "b0"; is_dg shash_get($sh, sclstr_upgraded("")), "b0"; is shash_exists($sh, sclstr_downgraded("a1")), !!1; is shash_exists($sh, sclstr_upgraded("a1")), !!1; is shash_length($sh, sclstr_downgraded("a1")), 2; is shash_length($sh, sclstr_upgraded("a1")), 2; is_dg shash_get($sh, sclstr_downgraded("a1")), "b1"; is_dg shash_get($sh, sclstr_upgraded("a1")), "b1"; shash_set($sh, sclstr_downgraded(""), undef); is_dg shash_key_min($sh), "a1"; is_dg shash_key_max($sh), "a1"; is shash_exists($sh, sclstr_downgraded("")), !!0; is shash_exists($sh, sclstr_upgraded("")), !!0; is shash_length($sh, sclstr_downgraded("")), undef; is shash_length($sh, sclstr_upgraded("")), undef; is shash_get($sh, sclstr_downgraded("")), undef; is shash_get($sh, sclstr_upgraded("")), undef; shash_set($sh, sclstr_upgraded(""), "b2"); shash_set($sh, sclstr_upgraded("a3"), "b3"); is_dg shash_key_min($sh), ""; is_dg shash_key_max($sh), "a3"; is_dg shash_key_ge($sh, sclstr_downgraded("")), ""; is_dg shash_key_ge($sh, sclstr_upgraded("")), ""; is_dg shash_key_gt($sh, sclstr_downgraded("")), "a1"; is_dg shash_key_gt($sh, sclstr_upgraded("")), "a1"; is_dg shash_key_le($sh, sclstr_downgraded("")), ""; is_dg shash_key_le($sh, sclstr_upgraded("")), ""; is shash_key_lt($sh, sclstr_downgraded("")), undef; is shash_key_lt($sh, sclstr_upgraded("")), undef; is shash_key_ge($sh, sclstr_downgraded("z")), undef; is shash_key_ge($sh, sclstr_upgraded("z")), undef; is shash_key_gt($sh, sclstr_downgraded("z")), undef; is shash_key_gt($sh, sclstr_upgraded("z")), undef; is_dg shash_key_le($sh, sclstr_downgraded("z")), "a3"; is_dg shash_key_le($sh, sclstr_upgraded("z")), "a3"; is_dg shash_key_lt($sh, sclstr_downgraded("z")), "a3"; is_dg shash_key_lt($sh, sclstr_upgraded("z")), "a3"; is shash_exists($sh, sclstr_downgraded("")), !!1; is shash_exists($sh, sclstr_upgraded("")), !!1; is shash_length($sh, sclstr_downgraded("")), 2; is shash_length($sh, sclstr_upgraded("")), 2; is_dg shash_get($sh, sclstr_downgraded("")), "b2"; is_dg shash_get($sh, sclstr_upgraded("")), "b2"; is shash_exists($sh, sclstr_downgraded("a3")), !!1; is shash_exists($sh, sclstr_upgraded("a3")), !!1; is shash_length($sh, sclstr_downgraded("a3")), 2; is shash_length($sh, sclstr_upgraded("a3")), 2; is_dg shash_get($sh, sclstr_downgraded("a3")), "b3"; is_dg shash_get($sh, sclstr_upgraded("a3")), "b3"; shash_set($sh, sclstr_upgraded(""), undef); is_dg shash_key_min($sh), "a1"; is_dg shash_key_max($sh), "a3"; is shash_exists($sh, sclstr_downgraded("")), !!0; is shash_exists($sh, sclstr_upgraded("")), !!0; is shash_length($sh, sclstr_downgraded("")), undef; is shash_length($sh, sclstr_upgraded("")), undef; is shash_get($sh, sclstr_downgraded("")), undef; is shash_get($sh, sclstr_upgraded("")), undef; shash_set($sh, "c0", sclstr_downgraded("")); shash_set($sh, "c1", sclstr_downgraded("d1")); is shash_exists($sh, "c0"), !!1; is shash_length($sh, "c0"), 0; is_dg shash_get($sh, "c0"), ""; is shash_exists($sh, "c1"), !!1; is shash_length($sh, "c1"), 2; is_dg shash_get($sh, "c1"), "d1"; shash_set($sh, "c2", sclstr_upgraded("")); shash_set($sh, "c3", sclstr_upgraded("d3")); is shash_exists($sh, "c2"), !!1; is shash_length($sh, "c2"), 0; is_dg shash_get($sh, "c2"), ""; is shash_exists($sh, "c3"), !!1; is shash_length($sh, "c3"), 2; is_dg shash_get($sh, "c3"), "d3"; is shash_gset($sh, sclstr_downgraded(""), undef), undef; is shash_get($sh, sclstr_downgraded("")), undef; is shash_gset($sh, sclstr_downgraded(""), "e0a"), undef; is_dg shash_get($sh, sclstr_downgraded("")), "e0a"; is_dg shash_gset($sh, sclstr_downgraded(""), "e0b"), "e0a"; is_dg shash_get($sh, sclstr_downgraded("")), "e0b"; is_dg shash_gset($sh, sclstr_downgraded(""), undef), "e0b"; is shash_get($sh, sclstr_downgraded("")), undef; is shash_gset($sh, sclstr_upgraded(""), undef), undef; is shash_get($sh, sclstr_downgraded("")), undef; is shash_gset($sh, sclstr_upgraded(""), "e1a"), undef; is_dg shash_get($sh, sclstr_downgraded("")), "e1a"; is_dg shash_gset($sh, sclstr_upgraded(""), "e1b"), "e1a"; is_dg shash_get($sh, sclstr_downgraded("")), "e1b"; is_dg shash_gset($sh, sclstr_upgraded(""), undef), "e1b"; is shash_get($sh, sclstr_downgraded("")), undef; is shash_gset($sh, "f0", sclstr_downgraded("")), undef; is_dg shash_get($sh, "f0"), ""; is_dg shash_gset($sh, "f0", sclstr_downgraded("g0a")), ""; is_dg shash_get($sh, "f0"), "g0a"; is_dg shash_gset($sh, "f0", sclstr_downgraded("")), "g0a"; is_dg shash_get($sh, "f0"), ""; is_dg shash_gset($sh, "f0", undef), ""; is shash_get($sh, "f0"), undef; is shash_gset($sh, "f1", sclstr_upgraded("")), undef; is_dg shash_get($sh, "f1"), ""; is_dg shash_gset($sh, "f1", sclstr_upgraded("g1a")), ""; is_dg shash_get($sh, "f1"), "g1a"; is_dg shash_gset($sh, "f1", sclstr_upgraded("")), "g1a"; is_dg shash_get($sh, "f1"), ""; is_dg shash_gset($sh, "f1", undef), ""; is shash_get($sh, "f1"), undef; is shash_cset($sh, sclstr_downgraded(""), undef, undef), !!1; is shash_get($sh, sclstr_downgraded("")), undef; is shash_cset($sh, sclstr_downgraded(""), "h0a", undef), !!0; is shash_get($sh, sclstr_downgraded("")), undef; is shash_cset($sh, sclstr_downgraded(""), "h0b", "h0c"), !!0; is shash_get($sh, sclstr_downgraded("")), undef; is shash_cset($sh, sclstr_downgraded(""), undef, "h0d"), !!1; is_dg shash_get($sh, sclstr_downgraded("")), "h0d"; is shash_cset($sh, sclstr_downgraded(""), undef, undef), !!0; is_dg shash_get($sh, sclstr_downgraded("")), "h0d"; is shash_cset($sh, sclstr_downgraded(""), undef, "h0e"), !!0; is_dg shash_get($sh, sclstr_downgraded("")), "h0d"; is shash_cset($sh, sclstr_downgraded(""), "h0f", undef), !!0; is_dg shash_get($sh, sclstr_downgraded("")), "h0d"; is shash_cset($sh, sclstr_downgraded(""), "h0f", "h0g"), !!0; is_dg shash_get($sh, sclstr_downgraded("")), "h0d"; is shash_cset($sh, sclstr_downgraded(""), "h0d", "h0h"), !!1; is_dg shash_get($sh, sclstr_downgraded("")), "h0h"; is shash_cset($sh, sclstr_downgraded(""), "h0h", undef), !!1; is shash_get($sh, sclstr_downgraded("")), undef; is shash_cset($sh, sclstr_upgraded(""), undef, undef), !!1; is shash_get($sh, sclstr_downgraded("")), undef; is shash_cset($sh, sclstr_upgraded(""), "h1a", undef), !!0; is shash_get($sh, sclstr_downgraded("")), undef; is shash_cset($sh, sclstr_upgraded(""), "h1b", "h1c"), !!0; is shash_get($sh, sclstr_downgraded("")), undef; is shash_cset($sh, sclstr_upgraded(""), undef, "h1d"), !!1; is_dg shash_get($sh, sclstr_downgraded("")), "h1d"; is shash_cset($sh, sclstr_upgraded(""), undef, undef), !!0; is_dg shash_get($sh, sclstr_downgraded("")), "h1d"; is shash_cset($sh, sclstr_upgraded(""), undef, "h1e"), !!0; is_dg shash_get($sh, sclstr_downgraded("")), "h1d"; is shash_cset($sh, sclstr_upgraded(""), "h1f", undef), !!0; is_dg shash_get($sh, sclstr_downgraded("")), "h1d"; is shash_cset($sh, sclstr_upgraded(""), "h1f", "h1g"), !!0; is_dg shash_get($sh, sclstr_downgraded("")), "h1d"; is shash_cset($sh, sclstr_upgraded(""), "h1d", "h1h"), !!1; is_dg shash_get($sh, sclstr_downgraded("")), "h1h"; is shash_cset($sh, sclstr_upgraded(""), "h1h", undef), !!1; is shash_get($sh, sclstr_downgraded("")), undef; is shash_cset($sh, "i", sclstr_downgraded(""), undef), !!0; is shash_get($sh, "i"), undef; is shash_cset($sh, "i", sclstr_downgraded(""), sclstr_downgraded("")), !!0; is shash_get($sh, "i"), undef; is shash_cset($sh, "i", sclstr_downgraded(""), sclstr_downgraded("j0")), !!0; is shash_get($sh, "i"), undef; is shash_cset($sh, "i", sclstr_downgraded("j1"), sclstr_downgraded("")), !!0; is shash_get($sh, "i"), undef; is shash_cset($sh, "i", sclstr_downgraded("j1"), sclstr_downgraded("j0")), !!0; is shash_get($sh, "i"), undef; is shash_cset($sh, "i", sclstr_downgraded("j1"), undef), !!0; is shash_get($sh, "i"), undef; is shash_cset($sh, "i", undef, undef), !!1; is shash_get($sh, "i"), undef; is shash_cset($sh, "i", undef, sclstr_downgraded("")), !!1; is_dg shash_get($sh, "i"), ""; is shash_cset($sh, "i", undef, undef), !!0; is_dg shash_get($sh, "i"), ""; is shash_cset($sh, "i", undef, sclstr_downgraded("")), !!0; is_dg shash_get($sh, "i"), ""; is shash_cset($sh, "i", undef, sclstr_downgraded("j2")), !!0; is_dg shash_get($sh, "i"), ""; is shash_cset($sh, "i", sclstr_downgraded("j3"), undef), !!0; is_dg shash_get($sh, "i"), ""; is shash_cset($sh, "i", sclstr_downgraded("j3"), sclstr_downgraded("")), !!0; is_dg shash_get($sh, "i"), ""; is shash_cset($sh, "i", sclstr_downgraded("j3"), sclstr_downgraded("j6")), !!0; is_dg shash_get($sh, "i"), ""; is shash_cset($sh, "i", sclstr_downgraded(""), sclstr_downgraded("j7")), !!1; is_dg shash_get($sh, "i"), "j7"; is shash_cset($sh, "i", undef, undef), !!0; is_dg shash_get($sh, "i"), "j7"; is shash_cset($sh, "i", undef, sclstr_downgraded("")), !!0; is_dg shash_get($sh, "i"), "j7"; is shash_cset($sh, "i", undef, sclstr_downgraded("j4")), !!0; is_dg shash_get($sh, "i"), "j7"; is shash_cset($sh, "i", sclstr_downgraded(""), undef), !!0; is_dg shash_get($sh, "i"), "j7"; is shash_cset($sh, "i", sclstr_downgraded(""), sclstr_downgraded("")), !!0; is_dg shash_get($sh, "i"), "j7"; is shash_cset($sh, "i", sclstr_downgraded(""), sclstr_downgraded("j5")), !!0; is_dg shash_get($sh, "i"), "j7"; is shash_cset($sh, "i", sclstr_downgraded("j3"), undef), !!0; is_dg shash_get($sh, "i"), "j7"; is shash_cset($sh, "i", sclstr_downgraded("j3"), sclstr_downgraded("")), !!0; is_dg shash_get($sh, "i"), "j7"; is shash_cset($sh, "i", sclstr_downgraded("j3"), sclstr_downgraded("j6")), !!0; is_dg shash_get($sh, "i"), "j7"; is shash_cset($sh, "i", sclstr_downgraded("j7"), undef), !!1; is shash_get($sh, "i"), undef; is shash_cset($sh, "i", undef, sclstr_downgraded("j8")), !!1; is_dg shash_get($sh, "i"), "j8"; is shash_cset($sh, "i", sclstr_downgraded("j8"), sclstr_downgraded("j9")), !!1; is_dg shash_get($sh, "i"), "j9"; is shash_cset($sh, "i", sclstr_downgraded("j9"), sclstr_downgraded("")), !!1; is_dg shash_get($sh, "i"), ""; is shash_cset($sh, "i", sclstr_downgraded(""), sclstr_downgraded("")), !!1; is_dg shash_get($sh, "i"), ""; is shash_cset($sh, "i", sclstr_downgraded(""), undef), !!1; is shash_get($sh, "i"), undef; is shash_cset($sh, "k", sclstr_upgraded(""), undef), !!0; is shash_get($sh, "k"), undef; is shash_cset($sh, "k", sclstr_upgraded(""), sclstr_upgraded("")), !!0; is shash_get($sh, "k"), undef; is shash_cset($sh, "k", sclstr_upgraded(""), sclstr_upgraded("l0")), !!0; is shash_get($sh, "k"), undef; is shash_cset($sh, "k", sclstr_upgraded("l1"), sclstr_upgraded("")), !!0; is shash_get($sh, "k"), undef; is shash_cset($sh, "k", sclstr_upgraded("l1"), sclstr_upgraded("l0")), !!0; is shash_get($sh, "k"), undef; is shash_cset($sh, "k", sclstr_upgraded("l1"), undef), !!0; is shash_get($sh, "k"), undef; is shash_cset($sh, "k", undef, undef), !!1; is shash_get($sh, "k"), undef; is shash_cset($sh, "k", undef, sclstr_upgraded("")), !!1; is_dg shash_get($sh, "k"), ""; is shash_cset($sh, "k", undef, undef), !!0; is_dg shash_get($sh, "k"), ""; is shash_cset($sh, "k", undef, sclstr_upgraded("")), !!0; is_dg shash_get($sh, "k"), ""; is shash_cset($sh, "k", undef, sclstr_upgraded("l2")), !!0; is_dg shash_get($sh, "k"), ""; is shash_cset($sh, "k", sclstr_upgraded("l3"), undef), !!0; is_dg shash_get($sh, "k"), ""; is shash_cset($sh, "k", sclstr_upgraded("l3"), sclstr_upgraded("")), !!0; is_dg shash_get($sh, "k"), ""; is shash_cset($sh, "k", sclstr_upgraded("l3"), sclstr_upgraded("l6")), !!0; is_dg shash_get($sh, "k"), ""; is shash_cset($sh, "k", sclstr_upgraded(""), sclstr_upgraded("l7")), !!1; is_dg shash_get($sh, "k"), "l7"; is shash_cset($sh, "k", undef, undef), !!0; is_dg shash_get($sh, "k"), "l7"; is shash_cset($sh, "k", undef, sclstr_upgraded("")), !!0; is_dg shash_get($sh, "k"), "l7"; is shash_cset($sh, "k", undef, sclstr_upgraded("l4")), !!0; is_dg shash_get($sh, "k"), "l7"; is shash_cset($sh, "k", sclstr_upgraded(""), undef), !!0; is_dg shash_get($sh, "k"), "l7"; is shash_cset($sh, "k", sclstr_upgraded(""), sclstr_upgraded("")), !!0; is_dg shash_get($sh, "k"), "l7"; is shash_cset($sh, "k", sclstr_upgraded(""), sclstr_upgraded("l5")), !!0; is_dg shash_get($sh, "k"), "l7"; is shash_cset($sh, "k", sclstr_upgraded("l3"), undef), !!0; is_dg shash_get($sh, "k"), "l7"; is shash_cset($sh, "k", sclstr_upgraded("l3"), sclstr_upgraded("")), !!0; is_dg shash_get($sh, "k"), "l7"; is shash_cset($sh, "k", sclstr_upgraded("l3"), sclstr_upgraded("l6")), !!0; is_dg shash_get($sh, "k"), "l7"; is shash_cset($sh, "k", sclstr_upgraded("l7"), undef), !!1; is shash_get($sh, "k"), undef; is shash_cset($sh, "k", undef, sclstr_upgraded("l8")), !!1; is_dg shash_get($sh, "k"), "l8"; is shash_cset($sh, "k", sclstr_upgraded("l8"), sclstr_upgraded("l9")), !!1; is_dg shash_get($sh, "k"), "l9"; is shash_cset($sh, "k", sclstr_upgraded("l9"), sclstr_upgraded("")), !!1; is_dg shash_get($sh, "k"), ""; is shash_cset($sh, "k", sclstr_upgraded(""), sclstr_upgraded("")), !!1; is_dg shash_get($sh, "k"), ""; is shash_cset($sh, "k", sclstr_upgraded(""), undef), !!1; is shash_get($sh, "k"), undef; require_ok "Hash::SharedMem::Handle"; my %sh; tie %sh, "Hash::SharedMem::Handle", $sh; ok is_shash(tied(%sh)); ok tied(%sh) == $sh; is exists($sh{sclstr_downgraded("")}), !!0; is exists($sh{sclstr_upgraded("")}), !!0; is $sh{sclstr_downgraded("")}, undef; is $sh{sclstr_upgraded("")}, undef; $sh{sclstr_downgraded("")} = "n0"; $sh{sclstr_downgraded("m1")} = "n1"; is exists($sh{sclstr_downgraded("")}), !!1; is exists($sh{sclstr_upgraded("")}), !!1; is_dg $sh{sclstr_downgraded("")}, "n0"; is_dg $sh{sclstr_upgraded("")}, "n0"; is exists($sh{sclstr_downgraded("m1")}), !!1; is exists($sh{sclstr_upgraded("m1")}), !!1; is_dg $sh{sclstr_downgraded("m1")}, "n1"; is_dg $sh{sclstr_upgraded("m1")}, "n1"; is_dg delete($sh{sclstr_downgraded("")}), "n0"; is exists($sh{sclstr_downgraded("")}), !!0; is exists($sh{sclstr_upgraded("")}), !!0; is $sh{sclstr_downgraded("")}, undef; is $sh{sclstr_upgraded("")}, undef; $sh{sclstr_upgraded("")} = "n2"; $sh{sclstr_upgraded("m3")} = "n3"; is exists($sh{sclstr_downgraded("")}), !!1; is exists($sh{sclstr_upgraded("")}), !!1; is_dg $sh{sclstr_downgraded("")}, "n2"; is_dg $sh{sclstr_upgraded("")}, "n2"; is exists($sh{sclstr_downgraded("m3")}), !!1; is exists($sh{sclstr_upgraded("m3")}), !!1; is_dg $sh{sclstr_downgraded("m3")}, "n3"; is_dg $sh{sclstr_upgraded("m3")}, "n3"; is_dg delete($sh{sclstr_upgraded("")}), "n2"; is exists($sh{sclstr_downgraded("")}), !!0; is exists($sh{sclstr_upgraded("")}), !!0; is $sh{sclstr_downgraded("")}, undef; is $sh{sclstr_upgraded("")}, undef; is delete($sh{sclstr_downgraded("")}), undef; is delete($sh{sclstr_upgraded("")}), undef; $sh{o0} = sclstr_downgraded(""); $sh{o1} = sclstr_downgraded("p1"); is_dg shash_get($sh, "o0"), ""; is_dg shash_get($sh, "o1"), "p1"; $sh{o2} = sclstr_upgraded(""); $sh{o3} = sclstr_upgraded("p3"); is_dg shash_get($sh, "o2"), ""; is_dg shash_get($sh, "o3"), "p3"; 1; Hash-SharedMem-0.005/t/filename.t000444001750001750 762613143376054 16565 0ustar00zeframzefram000000000000use warnings; use strict; use Errno 1.00 qw(ENOENT); use File::Temp 0.22 qw(tempdir); use Test::More tests => 42; BEGIN { use_ok "Hash::SharedMem", qw(is_shash shash_open shash_set); } my $enoent = do { local $! = ENOENT; "$!" }; my $tmpdir = tempdir(CLEANUP => 1); sub mkd($) { my($fn) = @_; mkdir $fn or die "can't create $fn: $!"; } sub touch($) { my($fn) = @_; open(my $fh, ">", $fn) or die "can't create $fn: $!"; } sub rm_existing($) { my($fn) = @_; if(-f $fn) { ok 1; unlink($fn) or die "can't remove $fn: $!"; } else { ok 0; } } sub rm_nonexisting($) { my($fn) = @_; if(-f $fn) { ok 0; unlink($fn) or die "can't remove $fn: $!"; } else { ok 1; } } my $sh = shash_open("$tmpdir/t12", "rwc"); ok $sh; ok is_shash($sh); shash_set($sh, "a", "b"); $sh = undef; ok is_shash(eval { shash_open("$tmpdir/t12", "rw") }); mkd("$tmpdir/t0"); is eval { shash_open("$tmpdir/t0", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: \Q$enoent\E at #; mkd("$tmpdir/t1"); ok is_shash(eval { shash_open("$tmpdir/t1", "rwc") }); touch "$tmpdir/t12/.wibble"; ok is_shash(eval { shash_open("$tmpdir/t12", "rw") }); rm_existing "$tmpdir/t12/.wibble"; mkd("$tmpdir/t2"); touch "$tmpdir/t2/.wibble"; is eval { shash_open("$tmpdir/t2", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t2: \Q$enoent\E at #; mkd("$tmpdir/t3"); touch "$tmpdir/t3/.wibble"; ok is_shash(eval { shash_open("$tmpdir/t3", "rwc") }); touch "$tmpdir/t12/&\"JBLMEgGm0000000000000010"; ok is_shash(eval { shash_open("$tmpdir/t12", "rw") }); rm_existing "$tmpdir/t12/&\"JBLMEgGm0000000000000010"; touch "$tmpdir/t12/&\"JBLMEgGmfffffffffffffff0"; ok is_shash(eval { shash_open("$tmpdir/t12", "rw") }); rm_nonexisting "$tmpdir/t12/&\"JBLMEgGmfffffffffffffff0"; touch "$tmpdir/t12/DNaM6okQi;wibble"; ok is_shash(eval { shash_open("$tmpdir/t12", "rw") }); rm_nonexisting "$tmpdir/t12/DNaM6okQi;wibble"; mkd("$tmpdir/t4"); touch "$tmpdir/t4/DNaM6okQi;wibble"; is eval { shash_open("$tmpdir/t4", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t4: \Q$enoent\E at #; mkd("$tmpdir/t5"); touch "$tmpdir/t5/DNaM6okQi;wibble"; ok is_shash(eval { shash_open("$tmpdir/t5", "rwc") }); touch "$tmpdir/t12/&\"JBLMEgGm0000000000000000"; is eval { shash_open("$tmpdir/t12", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t12: not a shared hash at #; rm_existing "$tmpdir/t12/&\"JBLMEgGm0000000000000000"; mkd("$tmpdir/t6"); touch "$tmpdir/t6/&\"JBLMEgGm0000000000000000"; is eval { shash_open("$tmpdir/t6", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t6: not a shared hash at #; mkd("$tmpdir/t7"); touch "$tmpdir/t7/&\"JBLMEgGm0000000000000000"; is eval { shash_open("$tmpdir/t7", "rwc") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t7: not a shared hash at #; touch "$tmpdir/t12/&\"JBLMEgGmwibble"; is eval { shash_open("$tmpdir/t12", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t12: not a shared hash at #; rm_existing "$tmpdir/t12/&\"JBLMEgGmwibble"; mkd("$tmpdir/t8"); touch "$tmpdir/t8/&\"JBLMEgGmwibble"; is eval { shash_open("$tmpdir/t8", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t8: not a shared hash at #; mkd("$tmpdir/t9"); touch "$tmpdir/t9/&\"JBLMEgGmwibble"; is eval { shash_open("$tmpdir/t9", "rwc") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t9: not a shared hash at #; touch "$tmpdir/t12/wibble"; is eval { shash_open("$tmpdir/t12", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t12: not a shared hash at #; rm_existing "$tmpdir/t12/wibble"; mkd("$tmpdir/t10"); touch "$tmpdir/t10/wibble"; is eval { shash_open("$tmpdir/t10", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t10: not a shared hash at #; mkd("$tmpdir/t11"); touch "$tmpdir/t11/wibble"; is eval { shash_open("$tmpdir/t11", "rwc") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t11: not a shared hash at #; 1; Hash-SharedMem-0.005/t/fork.t000444001750001750 264613143376054 15743 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::Builder 0.03 (); use Test::More 0.40 tests => 4; BEGIN { use_ok "Hash::SharedMem", qw( is_shash shash_open shash_exists shash_get shash_set shash_count ); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok is_shash($sh); shash_set($sh, $_, $_) foreach "a0".."a3"; my($rp0, $wp0, $rp1, $wp1, $pid); alarm 0; $SIG{ALRM} = "DEFAULT"; pipe($rp0, $wp0) or die "pipe: $!"; pipe($rp1, $wp1) or die "pipe: $!"; alarm 1000; $pid = fork(); defined $pid or die "fork: $!"; if($pid == 0) { Test::More->builder->no_ending(1); $File::Temp::KEEP_ALL = 1; close $wp0; close $rp1; close $wp1; scalar <$rp0>; my $x = 5; for(my $j = 0; $j != 50000; $j++) { $x = ($x*21+7) % 100000; shash_set($sh, sprintf("%05dx", $x), "a$x"); } exit 0; } else { close $rp0; close $wp1; close $wp0; scalar <$rp1>; my $y = 5; for(my $j = 0; $j != 50000; $j++) { $y = ($y*61+19) % 100000; shash_set($sh, sprintf("%05dy", $y), "b$y"); } close $rp1; waitpid $pid, 0; } alarm 0; { my %ph; my $x = 5; my $y = 5; for(my $j = 0; $j != 50000; $j++) { $x = ($x*21+7) % 100000; $y = ($y*61+19) % 100000; $ph{sprintf("%05dx", $x)} = "a$x"; $ph{sprintf("%05dy", $y)} = "b$y"; } is shash_count($sh), 100004; is_deeply +{ map { (shash_exists($sh, $_) ? ($_ => shash_get($sh, $_)) : ()) } map { $_."x", $_."y" } "00000".."99999" }, \%ph; } 1; Hash-SharedMem-0.005/t/function.t000444001750001750 4665513143376054 16657 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 389; BEGIN { use_ok "Hash::SharedMem", qw( is_shash check_shash shash_open shash_is_readable shash_is_writable shash_mode shash_exists shash_getd shash_length shash_get shash_set shash_gset shash_cset shash_occupied shash_count shash_size shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash shash_snapshot shash_is_snapshot shash_idle shash_tidy shash_tally_get shash_tally_zero shash_tally_gzero ); } is \&shash_getd, \&shash_exists; is scalar(&is_shash("foo")), !!0; is_deeply [&is_shash("foo")], [!!0]; eval { &check_shash("foo") }; like $@, qr/\Ahandle is not a shared hash handle /; my $tmpdir = tempdir(CLEANUP => 1); my $sh = &shash_open("$tmpdir/t0", "rwc"); ok $sh; is scalar(&is_shash($sh)), !!1; is_deeply [&is_shash($sh)], [!!1]; eval { &check_shash($sh) }; is $@, ""; is scalar(&check_shash($sh)), undef; is_deeply [&check_shash($sh)], []; is scalar(&shash_is_snapshot($sh)), !!0; is_deeply [&shash_is_snapshot($sh)], [!!0]; is scalar(&shash_is_readable($sh)), !!1; is_deeply [&shash_is_readable($sh)], [!!1]; is scalar(&shash_is_writable($sh)), !!1; is_deeply [&shash_is_writable($sh)], [!!1]; is scalar(&shash_mode($sh)), "rw"; is_deeply [&shash_mode($sh)], ["rw"]; eval { ${\(&shash_mode($sh))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar(&shash_exists($sh, "a100")), !!0; is_deeply [&shash_exists($sh, "a100")], [!!0]; is scalar(&shash_getd($sh, "a100")), !!0; is_deeply [&shash_getd($sh, "a100")], [!!0]; is scalar(&shash_length($sh, "a100")), undef; is_deeply [&shash_length($sh, "a100")], [undef]; is scalar(&shash_get($sh, "a100")), undef; is_deeply [&shash_get($sh, "a100")], [undef]; is scalar(&shash_occupied($sh)), !!0; is_deeply [&shash_occupied($sh)], [!!0]; is scalar(&shash_count($sh)), 0; is_deeply [&shash_count($sh)], [0]; eval { ${\(&shash_count($sh))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; like scalar(&shash_size($sh)), qr/\A[0-9]+\z/; like join(",", &shash_size($sh)), qr/\A[0-9]+\z/; eval { ${\(&shash_size($sh))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar(&shash_key_min($sh)), undef; is_deeply [&shash_key_min($sh)], [undef]; is scalar(&shash_key_max($sh)), undef; is_deeply [&shash_key_max($sh)], [undef]; is scalar(&shash_key_ge($sh, "a110")), undef; is_deeply [&shash_key_ge($sh, "a110")], [undef]; is scalar(&shash_key_gt($sh, "a110")), undef; is_deeply [&shash_key_gt($sh, "a110")], [undef]; is scalar(&shash_key_le($sh, "a110")), undef; is_deeply [&shash_key_le($sh, "a110")], [undef]; is scalar(&shash_key_lt($sh, "a110")), undef; is_deeply [&shash_key_lt($sh, "a110")], [undef]; is_deeply scalar(&shash_keys_array($sh)), []; is_deeply [&shash_keys_array($sh)], [[]]; eval { ${\(&shash_keys_array($sh))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply scalar(&shash_keys_hash($sh)), {}; is_deeply [&shash_keys_hash($sh)], [{}]; eval { ${\(&shash_keys_hash($sh))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply scalar(&shash_group_get_hash($sh)), {}; is_deeply [&shash_group_get_hash($sh)], [{}]; eval { ${\(&shash_group_get_hash($sh))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; &shash_set($sh, "a110", "b110"); is scalar(&shash_set($sh, "a100", "b100")), undef; is_deeply [&shash_set($sh, "a120", "b120")], []; is scalar(&shash_exists($sh, "a100")), !!1; is_deeply [&shash_exists($sh, "a100")], [!!1]; is scalar(&shash_getd($sh, "a100")), !!1; is_deeply [&shash_getd($sh, "a100")], [!!1]; is scalar(&shash_length($sh, "a100")), 4; is_deeply [&shash_length($sh, "a100")], [4]; eval { ${\(&shash_length($sh, "a100"))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar(&shash_get($sh, "a100")), "b100"; is_deeply [&shash_get($sh, "a100")], ["b100"]; is scalar(&shash_occupied($sh)), !!1; is_deeply [&shash_occupied($sh)], [!!1]; is scalar(&shash_count($sh)), 3; is_deeply [&shash_count($sh)], [3]; eval { ${\(&shash_count($sh))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; like scalar(&shash_size($sh)), qr/\A[0-9]+\z/; like join(",", &shash_size($sh)), qr/\A[0-9]+\z/; eval { ${\(&shash_size($sh))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar(&shash_key_min($sh)), "a100"; is_deeply [&shash_key_min($sh)], ["a100"]; is scalar(&shash_key_max($sh)), "a120"; is_deeply [&shash_key_max($sh)], ["a120"]; is scalar(&shash_key_ge($sh, "a110")), "a110"; is_deeply [&shash_key_ge($sh, "a110")], ["a110"]; is scalar(&shash_key_gt($sh, "a110")), "a120"; is_deeply [&shash_key_gt($sh, "a110")], ["a120"]; is scalar(&shash_key_le($sh, "a110")), "a110"; is_deeply [&shash_key_le($sh, "a110")], ["a110"]; is scalar(&shash_key_lt($sh, "a110")), "a100"; is_deeply [&shash_key_lt($sh, "a110")], ["a100"]; is_deeply scalar(&shash_keys_array($sh)), [qw(a100 a110 a120)]; is_deeply [&shash_keys_array($sh)], [[qw(a100 a110 a120)]]; eval { ${\(&shash_keys_array($sh))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply scalar(&shash_keys_hash($sh)), { a100=>undef, a110=>undef, a120=>undef }; is_deeply [&shash_keys_hash($sh)], [{ a100=>undef, a110=>undef, a120=>undef }]; eval { ${\(&shash_keys_hash($sh))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply scalar(&shash_group_get_hash($sh)), { a100=>"b100", a110=>"b110", a120=>"b120" }; is_deeply [&shash_group_get_hash($sh)], [{ a100=>"b100", a110=>"b110", a120=>"b120" }]; eval { ${\(&shash_group_get_hash($sh))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar(&shash_exists($sh, "a000")), !!0; is scalar(&shash_length($sh, "a000")), undef; is scalar(&shash_get($sh, "a000")), undef; is scalar(&shash_exists($sh, "a105")), !!0; is scalar(&shash_length($sh, "a105")), undef; is scalar(&shash_get($sh, "a105")), undef; is scalar(&shash_exists($sh, "a110")), !!1; is scalar(&shash_length($sh, "a110")), 4; is scalar(&shash_get($sh, "a110")), "b110"; is scalar(&shash_exists($sh, "a115")), !!0; is scalar(&shash_length($sh, "a115")), undef; is scalar(&shash_get($sh, "a115")), undef; is scalar(&shash_exists($sh, "a120")), !!1; is scalar(&shash_length($sh, "a120")), 4; is scalar(&shash_get($sh, "a120")), "b120"; is scalar(&shash_exists($sh, "a130")), !!0; is scalar(&shash_length($sh, "a130")), undef; is scalar(&shash_get($sh, "a130")), undef; my $sn = &shash_snapshot($sh); is scalar(&is_shash($sn)), !!1; is_deeply [&is_shash($sn)], [!!1]; eval { &check_shash($sn) }; is $@, ""; is scalar(&check_shash($sn)), undef; is_deeply [&check_shash($sn)], []; is scalar(&shash_is_snapshot($sn)), !!1; is_deeply [&shash_is_snapshot($sn)], [!!1]; is scalar(&shash_is_readable($sn)), !!1; is_deeply [&shash_is_readable($sn)], [!!1]; is scalar(&shash_is_writable($sn)), !!0; is_deeply [&shash_is_writable($sn)], [!!0]; is scalar(&shash_mode($sn)), "r"; is_deeply [&shash_mode($sn)], ["r"]; is &shash_exists($sn, "a000"), !!0; is &shash_length($sn, "a000"), undef; is &shash_get($sn, "a000"), undef; is &shash_exists($sn, "a100"), !!1; is &shash_length($sn, "a100"), 4; is &shash_get($sn, "a100"), "b100"; is &shash_exists($sn, "a105"), !!0; is &shash_length($sn, "a105"), undef; is &shash_get($sn, "a105"), undef; is &shash_exists($sn, "a110"), !!1; is &shash_length($sn, "a110"), 4; is &shash_get($sn, "a110"), "b110"; is &shash_exists($sn, "a115"), !!0; is &shash_length($sn, "a115"), undef; is &shash_get($sn, "a115"), undef; is &shash_exists($sn, "a120"), !!1; is &shash_length($sn, "a120"), 4; is &shash_get($sn, "a120"), "b120"; is &shash_exists($sn, "a130"), !!0; is &shash_length($sn, "a130"), undef; is &shash_get($sn, "a130"), undef; is &shash_occupied($sn), !!1; is &shash_count($sn), 3; is &shash_key_min($sn), "a100"; is &shash_key_max($sn), "a120"; is &shash_key_ge($sn, "a110"), "a110"; is &shash_key_gt($sn, "a110"), "a120"; is &shash_key_le($sn, "a110"), "a110"; is &shash_key_lt($sn, "a110"), "a100"; is_deeply &shash_keys_array($sn), [qw(a100 a110 a120)]; is_deeply &shash_keys_hash($sn), { a100=>undef, a110=>undef, a120=>undef }; is_deeply &shash_group_get_hash($sn), { a100=>"b100", a110=>"b110", a120=>"b120" }; &shash_set($sh, "a105", "b105"); &shash_set($sh, "a110", undef); is &shash_exists($sh, "a000"), !!0; is &shash_length($sh, "a000"), undef; is &shash_get($sh, "a000"), undef; is &shash_exists($sh, "a100"), !!1; is &shash_length($sh, "a100"), 4; is &shash_get($sh, "a100"), "b100"; is &shash_exists($sh, "a105"), !!1; is &shash_length($sh, "a105"), 4; is &shash_get($sh, "a105"), "b105"; is &shash_exists($sh, "a110"), !!0; is &shash_length($sh, "a110"), undef; is &shash_get($sh, "a110"), undef; is &shash_exists($sh, "a115"), !!0; is &shash_length($sh, "a115"), undef; is &shash_get($sh, "a115"), undef; is &shash_exists($sh, "a120"), !!1; is &shash_length($sh, "a120"), 4; is &shash_get($sh, "a120"), "b120"; is &shash_exists($sh, "a130"), !!0; is &shash_length($sh, "a130"), undef; is &shash_get($sh, "a130"), undef; is &shash_occupied($sh), !!1; is &shash_count($sh), 3; is &shash_key_min($sh), "a100"; is &shash_key_max($sh), "a120"; is &shash_key_ge($sh, "a110"), "a120"; is &shash_key_gt($sh, "a110"), "a120"; is &shash_key_le($sh, "a110"), "a105"; is &shash_key_lt($sh, "a110"), "a105"; is_deeply &shash_keys_array($sh), [qw(a100 a105 a120)]; is_deeply &shash_keys_hash($sh), { a100=>undef, a105=>undef, a120=>undef }; is_deeply &shash_group_get_hash($sh), { a100=>"b100", a105=>"b105", a120=>"b120" }; is &shash_exists($sn, "a000"), !!0; is &shash_length($sn, "a000"), undef; is &shash_get($sn, "a000"), undef; is &shash_exists($sn, "a100"), !!1; is &shash_length($sn, "a100"), 4; is &shash_get($sn, "a100"), "b100"; is &shash_exists($sn, "a105"), !!0; is &shash_length($sn, "a105"), undef; is &shash_get($sn, "a105"), undef; is &shash_exists($sn, "a110"), !!1; is &shash_length($sn, "a110"), 4; is &shash_get($sn, "a110"), "b110"; is &shash_exists($sn, "a115"), !!0; is &shash_length($sn, "a115"), undef; is &shash_get($sn, "a115"), undef; is &shash_exists($sn, "a120"), !!1; is &shash_length($sn, "a120"), 4; is &shash_get($sn, "a120"), "b120"; is &shash_exists($sn, "a130"), !!0; is &shash_length($sn, "a130"), undef; is &shash_get($sn, "a130"), undef; is &shash_occupied($sn), !!1; is &shash_count($sn), 3; is &shash_key_min($sn), "a100"; is &shash_key_max($sn), "a120"; is &shash_key_ge($sn, "a110"), "a110"; is &shash_key_gt($sn, "a110"), "a120"; is &shash_key_le($sn, "a110"), "a110"; is &shash_key_lt($sn, "a110"), "a100"; is_deeply &shash_keys_array($sn), [qw(a100 a110 a120)]; is_deeply &shash_keys_hash($sn), { a100=>undef, a110=>undef, a120=>undef }; is_deeply &shash_group_get_hash($sn), { a100=>"b100", a110=>"b110", a120=>"b120" }; eval { &shash_set($sn, "a115", "b115") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ handle\ is\ a\ snapshot\ #x; is &shash_exists($sh, "a115"), !!0; is &shash_length($sh, "a115"), undef; is &shash_get($sh, "a115"), undef; is &shash_occupied($sh), !!1; is &shash_count($sh), 3; is &shash_key_min($sh), "a100"; is &shash_key_max($sh), "a120"; is &shash_key_ge($sh, "a110"), "a120"; is &shash_key_gt($sh, "a110"), "a120"; is &shash_key_le($sh, "a110"), "a105"; is &shash_key_lt($sh, "a110"), "a105"; is_deeply &shash_keys_array($sh), [qw(a100 a105 a120)]; is_deeply &shash_keys_hash($sh), { a100=>undef, a105=>undef, a120=>undef }; is_deeply &shash_group_get_hash($sh), { a100=>"b100", a105=>"b105", a120=>"b120" }; is &shash_exists($sn, "a115"), !!0; is &shash_length($sn, "a115"), undef; is &shash_get($sn, "a115"), undef; is &shash_occupied($sn), !!1; is &shash_count($sn), 3; is &shash_key_min($sn), "a100"; is &shash_key_max($sn), "a120"; is &shash_key_ge($sn, "a110"), "a110"; is &shash_key_gt($sn, "a110"), "a120"; is &shash_key_le($sn, "a110"), "a110"; is &shash_key_lt($sn, "a110"), "a100"; is_deeply &shash_keys_array($sn), [qw(a100 a110 a120)]; is_deeply &shash_keys_hash($sn), { a100=>undef, a110=>undef, a120=>undef }; is_deeply &shash_group_get_hash($sn), { a100=>"b100", a110=>"b110", a120=>"b120" }; &shash_gset($sh, "a115", "c115"); is &shash_get($sh, "a115"), "c115"; &shash_gset($sh, "a115", "d115"); is &shash_get($sh, "a115"), "d115"; &shash_gset($sh, "a115", "d115"); is &shash_get($sh, "a115"), "d115"; &shash_gset($sh, "a115", undef); is &shash_get($sh, "a115"), undef; &shash_gset($sh, "a115", undef); is &shash_get($sh, "a115"), undef; is scalar(&shash_gset($sh, "a115", "e115")), undef; is &shash_get($sh, "a115"), "e115"; is scalar(&shash_gset($sh, "a115", "f115")), "e115"; is &shash_get($sh, "a115"), "f115"; is scalar(&shash_gset($sh, "a115", "f115")), "f115"; is &shash_get($sh, "a115"), "f115"; is scalar(&shash_gset($sh, "a115", undef)), "f115"; is &shash_get($sh, "a115"), undef; is scalar(&shash_gset($sh, "a115", undef)), undef; is &shash_get($sh, "a115"), undef; is_deeply [&shash_gset($sh, "a115", "g115")], [undef]; is &shash_get($sh, "a115"), "g115"; is_deeply [&shash_gset($sh, "a115", "h115")], ["g115"]; is &shash_get($sh, "a115"), "h115"; is_deeply [&shash_gset($sh, "a115", "h115")], ["h115"]; is &shash_get($sh, "a115"), "h115"; is_deeply [&shash_gset($sh, "a115", undef)], ["h115"]; is &shash_get($sh, "a115"), undef; is_deeply [&shash_gset($sh, "a115", undef)], [undef]; is &shash_get($sh, "a115"), undef; &shash_cset($sh, "a115", "z", "i115"); is &shash_get($sh, "a115"), undef; &shash_cset($sh, "a115", undef, "j115"); is &shash_get($sh, "a115"), "j115"; &shash_cset($sh, "a115", "z", "k115"); is &shash_get($sh, "a115"), "j115"; &shash_cset($sh, "a115", undef, "l115"); is &shash_get($sh, "a115"), "j115"; &shash_cset($sh, "a115", "j115", "m115"); is &shash_get($sh, "a115"), "m115"; &shash_cset($sh, "a115", "z", "m115"); is &shash_get($sh, "a115"), "m115"; &shash_cset($sh, "a115", undef, "m115"); is &shash_get($sh, "a115"), "m115"; &shash_cset($sh, "a115", "m115", "m115"); is &shash_get($sh, "a115"), "m115"; &shash_cset($sh, "a115", "z", undef); is &shash_get($sh, "a115"), "m115"; &shash_cset($sh, "a115", undef, undef); is &shash_get($sh, "a115"), "m115"; &shash_cset($sh, "a115", "m115", undef); is &shash_get($sh, "a115"), undef; &shash_cset($sh, "a115", "z", undef); is &shash_get($sh, "a115"), undef; &shash_cset($sh, "a115", undef, undef); is &shash_get($sh, "a115"), undef; is scalar(&shash_cset($sh, "a115", "z", "i115")), !!0; is &shash_get($sh, "a115"), undef; is scalar(&shash_cset($sh, "a115", undef, "j115")), !!1; is &shash_get($sh, "a115"), "j115"; is scalar(&shash_cset($sh, "a115", "z", "k115")), !!0; is &shash_get($sh, "a115"), "j115"; is scalar(&shash_cset($sh, "a115", undef, "l115")), !!0; is &shash_get($sh, "a115"), "j115"; is scalar(&shash_cset($sh, "a115", "j115", "m115")), !!1; is &shash_get($sh, "a115"), "m115"; is scalar(&shash_cset($sh, "a115", "z", "m115")), !!0; is &shash_get($sh, "a115"), "m115"; is scalar(&shash_cset($sh, "a115", undef, "m115")), !!0; is &shash_get($sh, "a115"), "m115"; is scalar(&shash_cset($sh, "a115", "m115", "m115")), !!1; is &shash_get($sh, "a115"), "m115"; is scalar(&shash_cset($sh, "a115", "z", undef)), !!0; is &shash_get($sh, "a115"), "m115"; is scalar(&shash_cset($sh, "a115", undef, undef)), !!0; is &shash_get($sh, "a115"), "m115"; is scalar(&shash_cset($sh, "a115", "m115", undef)), !!1; is &shash_get($sh, "a115"), undef; is scalar(&shash_cset($sh, "a115", "z", undef)), !!0; is &shash_get($sh, "a115"), undef; is scalar(&shash_cset($sh, "a115", undef, undef)), !!1; is &shash_get($sh, "a115"), undef; is_deeply [&shash_cset($sh, "a115", "z", "i115")], [!!0]; is &shash_get($sh, "a115"), undef; is_deeply [&shash_cset($sh, "a115", undef, "j115")], [!!1]; is &shash_get($sh, "a115"), "j115"; is_deeply [&shash_cset($sh, "a115", "z", "k115")], [!!0]; is &shash_get($sh, "a115"), "j115"; is_deeply [&shash_cset($sh, "a115", undef, "l115")], [!!0]; is &shash_get($sh, "a115"), "j115"; is_deeply [&shash_cset($sh, "a115", "j115", "m115")], [!!1]; is &shash_get($sh, "a115"), "m115"; is_deeply [&shash_cset($sh, "a115", "z", "m115")], [!!0]; is &shash_get($sh, "a115"), "m115"; is_deeply [&shash_cset($sh, "a115", undef, "m115")], [!!0]; is &shash_get($sh, "a115"), "m115"; is_deeply [&shash_cset($sh, "a115", "m115", "m115")], [!!1]; is &shash_get($sh, "a115"), "m115"; is_deeply [&shash_cset($sh, "a115", "z", undef)], [!!0]; is &shash_get($sh, "a115"), "m115"; is_deeply [&shash_cset($sh, "a115", undef, undef)], [!!0]; is &shash_get($sh, "a115"), "m115"; is_deeply [&shash_cset($sh, "a115", "m115", undef)], [!!1]; is &shash_get($sh, "a115"), undef; is_deeply [&shash_cset($sh, "a115", "z", undef)], [!!0]; is &shash_get($sh, "a115"), undef; is_deeply [&shash_cset($sh, "a115", undef, undef)], [!!1]; is &shash_get($sh, "a115"), undef; &shash_idle($sh); is scalar(&shash_idle($sh)), undef; is_deeply [&shash_idle($sh)], []; &shash_tidy($sh); is scalar(&shash_tidy($sh)), undef; is_deeply [&shash_tidy($sh)], []; my $h; &shash_tally_get($sh); $h = &shash_tally_get($sh); is ref($h), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %$h; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %$h; $h = [&shash_tally_get($sh)]; is @$h, 1; is ref($h->[0]), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %{$h->[0]}; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %{$h->[0]}; &shash_tally_zero($sh); is scalar(&shash_tally_zero($sh)), undef; is_deeply [&shash_tally_zero($sh)], []; &shash_tally_gzero($sh); $h = &shash_tally_gzero($sh); is ref($h), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %$h; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %$h; $h = [&shash_tally_gzero($sh)]; is @$h, 1; is ref($h->[0]), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %{$h->[0]}; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %{$h->[0]}; my $nx = &shash_open("$tmpdir/t1", "c"); ok $nx; is scalar(&is_shash($nx)), !!1; is_deeply [&is_shash($nx)], [!!1]; eval { &check_shash($nx) }; is $@, ""; is scalar(&check_shash($nx)), undef; is_deeply [&check_shash($nx)], []; is scalar(&shash_is_snapshot($nx)), !!0; is_deeply [&shash_is_snapshot($nx)], [!!0]; is scalar(&shash_is_readable($nx)), !!0; is_deeply [&shash_is_readable($nx)], [!!0]; is scalar(&shash_is_writable($nx)), !!0; is_deeply [&shash_is_writable($nx)], [!!0]; is scalar(&shash_mode($nx)), ""; is_deeply [&shash_mode($nx)], [""]; eval { &shash_exists($nx, "a100") }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { &shash_length($nx, "a100") }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { &shash_get($nx, "a100") }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { &shash_set($nx, "a100", "b100") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; eval { &shash_gset($nx, "a100", "b100") }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { &shash_cset($nx, "a100", "b100", "c100") }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { &shash_open("$tmpdir/t1", "c") }; is $@, ""; my @sh = &shash_open("$tmpdir/t1", "c"); is scalar(@sh), 1; ok &is_shash($sh[0]); eval { ${\(&shash_open("$tmpdir/t1", "c"))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; eval { ${\(&shash_snapshot($sh))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; eval { ${\(&shash_snapshot($sn))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; 1; Hash-SharedMem-0.005/t/get_string.t000444001750001750 475213143376054 17147 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 30014; BEGIN { use_ok "Hash::SharedMem", qw( is_shash shash_open shash_get shash_set shash_key_min shash_key_max shash_keys_array shash_keys_hash shash_group_get_hash ); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); my $keys_a = shash_keys_array($sh); is_deeply $keys_a, []; eval { push @$keys_a, "zzz"; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply shash_keys_hash($sh), {}; is_deeply shash_group_get_hash($sh), {}; my $genstr = join("x", 0..1222); my %orig; for(my $i = 0; $i != 5000; $i++) { my $s = substr($i."_".$genstr, 0, $i); shash_set($sh, $i, $s); $orig{$i} = \$s; } my %get; for(my $i = 0; $i != 5000; $i++) { $get{$i} = \shash_get($sh, $i); } is_deeply \%get, \%orig; $keys_a = shash_keys_array($sh); my $keys_h = shash_keys_hash($sh); my $group_h = shash_group_get_hash($sh); is_deeply $keys_a, [sort keys %orig]; is_deeply $keys_h, { map { ($_ => undef) } keys %orig }; is_deeply $group_h, { map { ($_ => ${$orig{$_}}) } keys %orig }; $sh = undef; is_deeply \%get, \%orig; is_deeply $keys_a, [sort keys %orig]; is_deeply $keys_h, { map { ($_ => undef) } keys %orig }; for(my $i = 0; $i != 5000; $i++) { eval { ${$get{$i}} = undef; }; like $@, qr/\AModification of a read-only value attempted /; eval { $keys_a->[$i] = undef; }; like $@, qr/\AModification of a read-only value attempted /; eval { $keys_h->{$i} = undef; }; like $@, qr/\AModification of a read-only value attempted /; eval { $group_h->{$i} = undef; }; like $@, qr/\AModification of a read-only value attempted /; } eval { push @$keys_a, "zzz"; }; like $@, qr/\AModification of a read-only value attempted /; $sh = shash_open("$tmpdir/t0", "rw"); ok $sh; ok is_shash($sh); my(@orig, @key); for(my $i = 5000; $i--; ) { my $k = substr(sprintf("-%04d_%s", $i, $genstr), 0, $i); $orig[$i] = \$k; shash_set($sh, $k, $i); $key[$i] = \shash_key_min($sh); } is_deeply \@key, \@orig; for(my $i = 0; $i != 5000; $i++) { eval { ${$key[$i]} = undef; }; like $@, qr/\AModification of a read-only value attempted /; } @orig = (); @key = (); for(my $i = 5; $i != 5000; $i++) { my $k = substr(sprintf("l%04d_%s", $i, $genstr), 0, $i); $orig[$i] = \$k; shash_set($sh, $k, $i); $key[$i] = \shash_key_max($sh); } is_deeply \@key, \@orig; for(my $i = 5; $i != 5000; $i++) { eval { ${$key[$i]} = undef; }; like $@, qr/\AModification of a read-only value attempted /; } 1; Hash-SharedMem-0.005/t/huge.t000444001750001750 156413143376054 15730 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 13; BEGIN { use_ok "Hash::SharedMem", qw( is_shash shash_open shash_length shash_get shash_set shash_occupied shash_count shash_size shash_key_min shash_key_max shash_keys_array shash_keys_hash shash_group_get_hash ); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); my $tstr = join("", map { sprintf("abcd%6d", $_) } 0..999_999); shash_set($sh, "xyz", $tstr); is shash_occupied($sh), !!1; is shash_count($sh), 1; ok shash_size($sh) > length($tstr); is shash_key_min($sh), "xyz"; is shash_key_max($sh), "xyz"; is_deeply shash_keys_array($sh), ["xyz"]; is_deeply shash_keys_hash($sh), { xyz=>undef }; is_deeply shash_group_get_hash($sh), { xyz=>$tstr }; is shash_length($sh, "xyz"), length($tstr); is shash_get($sh, "xyz"), $tstr; 1; Hash-SharedMem-0.005/t/locale.t000444001750001750 157013143376054 16234 0ustar00zeframzefram000000000000use warnings; use strict; use Errno 1.00 qw(ENOENT); use File::Temp 0.22 qw(tempdir); use Test::More; BEGIN { unless("$]" >= 5.021001) { plan skip_all => "locale doesn't affect messages on this Perl"; } } my($enoent_nolocale, $enoent_uselocale); BEGIN { $enoent_nolocale = do { local $! = ENOENT; "$!" }; $enoent_uselocale = do { use locale; local $! = ENOENT; "$!" }; if($enoent_uselocale eq $enoent_nolocale) { plan skip_all => "current locale doesn't affect messages"; } } BEGIN { plan tests => 5; } BEGIN { use_ok "Hash::SharedMem", qw(shash_open); } my $tmpdir = tempdir(CLEANUP => 1); is eval { shash_open("$tmpdir/t0", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: \Q$enoent_nolocale\E at #; is eval { use locale; shash_open("$tmpdir/t0", "rw") }, undef; like $@, qr#\Acan't open shared hash \Q$tmpdir\E/t0: \Q$enoent_uselocale\E at #; 1; Hash-SharedMem-0.005/t/long.t000444001750001750 423113143376054 15731 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 53; BEGIN { use_ok "Hash::SharedMem", qw( is_shash shash_open shash_length shash_get shash_set shash_occupied shash_count shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash ); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); my %ph; sub doru($) { defined($_[0]) ? $_[0] : "u" } sub dorm1($) { defined($_[0]) ? $_[0] : -1 } sub check_hash_state() { is shash_occupied($sh), !!keys(%ph); is shash_count($sh), keys(%ph); my @sk = sort keys %ph; is shash_key_min($sh), $sk[0]; is shash_key_max($sh), @sk ? $sk[-1] : undef; my $ok = 1; foreach my $k (@sk) { $ok &&= dorm1(shash_length($sh, $k)) == length($ph{$k}); $ok &&= doru(shash_get($sh, $k)) eq $ph{$k}; } ok $ok; $ok = 1; for(my $i = 0; $i != @sk; $i++) { $ok &&= doru(shash_key_ge($sh, $sk[$i])) eq $sk[$i]; $ok &&= doru(shash_key_gt($sh, $sk[$i])) eq doru($sk[$i+1]); $ok &&= doru(shash_key_le($sh, $sk[$i])) eq $sk[$i]; $ok &&= doru(shash_key_lt($sh, $sk[$i])) eq ($i != 0 ? $sk[$i-1] : "u"); } ok $ok; $ok = 1; $ok &&= doru(shash_key_ge($sh, "-")) eq doru($sk[0]); $ok &&= doru(shash_key_gt($sh, "-")) eq doru($sk[0]); $ok &&= doru(shash_key_le($sh, "-")) eq "u"; $ok &&= doru(shash_key_lt($sh, "-")) eq "u"; for(my $i = 0; $i < $#sk; $i++) { $ok &&= doru(shash_key_ge($sh, $sk[$i]."-")) eq doru($sk[$i+1]); $ok &&= doru(shash_key_gt($sh, $sk[$i]."-")) eq doru($sk[$i+1]); $ok &&= doru(shash_key_le($sh, $sk[$i]."-")) eq $sk[$i]; $ok &&= doru(shash_key_lt($sh, $sk[$i]."-")) eq $sk[$i]; } ok $ok; is_deeply shash_keys_array($sh), \@sk; is_deeply shash_keys_hash($sh), { map { ($_ => undef) } @sk }; is_deeply shash_group_get_hash($sh), \%ph; } my $p = 5; my $q = 5; for(my $i = 0; $i != 5; $i++) { for(my $j = 0; $j != 100; $j++) { $p = ($p*21+7) % 100000; $q = ($q*41+17) % 100000; my $k = join("x", map { $p.$_ } 0..($p % 1000)); my $v = join("x", map { $q.$_ } 0..($q % 1000)); shash_set($sh, $k, $v); $ph{$k} = $v; } check_hash_state(); } 1; Hash-SharedMem-0.005/t/magic.t000444001750001750 5573713143376054 16113 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 678; BEGIN { use_ok "Hash::SharedMem", qw( is_shash check_shash shash_open shash_is_readable shash_is_writable shash_mode shash_exists shash_length shash_get shash_set shash_gset shash_cset shash_occupied shash_count shash_size shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash shash_snapshot shash_is_snapshot shash_idle shash_tidy shash_tally_get shash_tally_zero shash_tally_gzero ); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); my $magic; my $fetched; { package t::TiedScalar; sub TIESCALAR { bless({ value => $_[1] }, $_[0]) } sub FETCH { $fetched++; $_[0]->{value} } } sub tm1(&$;$) { untie $magic; $magic = $_[2]; tie $magic, "t::TiedScalar", $_[1]; $fetched = 0; $_[0]->(); is $fetched, 1; } foreach my $cval ("a19", [], undef, $sh) { foreach my $rval ("a20", [], undef) { tm1 { ok !is_shash($magic) } $rval, $cval; tm1 { eval { check_shash($magic) }; like $@, qr/\Ahandle is not a shared hash handle /; } $rval, $cval; } tm1 { ok is_shash($magic) } $sh, $cval; tm1 { eval { check_shash($magic) }; is $@, ""; } $sh, $cval; } tm1 { is eval { shash_is_readable($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_is_readable($magic), !!1 } $sh; tm1 { is shash_is_readable($magic), !!1 } $sh, []; tm1 { is eval { shash_is_writable($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_is_writable($magic), !!1 } $sh; tm1 { is shash_is_writable($magic), !!1 } $sh, []; tm1 { is eval { shash_mode($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_mode($magic), "rw" } $sh; tm1 { is shash_mode($magic), "rw" } $sh, []; tm1 { is shash_exists($sh, $magic), !!0 } "b0"; tm1 { is shash_length($sh, $magic), undef } "b0"; tm1 { is shash_get($sh, $magic), undef } "b0"; tm1 { is shash_exists($sh, $magic), !!0 } "b1", "b2"; tm1 { is shash_length($sh, $magic), undef } "b1", "b2"; tm1 { is shash_get($sh, $magic), undef } "b1", "b2"; tm1 { is shash_exists($sh, $magic), !!0 } "b3", []; tm1 { is shash_length($sh, $magic), undef } "b3", []; tm1 { is shash_get($sh, $magic), undef } "b3", []; shash_set($sh, "b".$_, "a".$_) foreach 0..20; tm1 { is eval { shash_exists($magic, "b30") }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is eval { shash_length($magic, "b30") }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is eval { shash_get($magic, "b30") }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_exists($magic, "b30"), !!0 } $sh; tm1 { is shash_length($magic, "b30"), undef } $sh; tm1 { is shash_get($magic, "b30"), undef } $sh; tm1 { is shash_exists($magic, "b30"), !!0 } $sh, []; tm1 { is shash_length($magic, "b30"), undef } $sh, []; tm1 { is shash_get($magic, "b30"), undef } $sh, []; tm1 { is shash_exists($magic, "b30"), !!0 } $sh, "b8"; tm1 { is shash_length($magic, "b30"), undef } $sh, "b8"; tm1 { is shash_get($magic, "b30"), undef } $sh, "b8"; tm1 { is shash_exists($magic, "b9"), !!1 } $sh; tm1 { is shash_length($magic, "b9"), 2 } $sh; tm1 { is shash_get($magic, "b9"), "a9" } $sh; tm1 { is shash_exists($magic, "b9"), !!1 } $sh, []; tm1 { is shash_length($magic, "b9"), 2 } $sh, []; tm1 { is shash_get($magic, "b9"), "a9" } $sh, []; tm1 { is shash_exists($magic, "b9"), !!1 } $sh, "b8"; tm1 { is shash_length($magic, "b9"), 2 } $sh, "b8"; tm1 { is shash_get($magic, "b9"), "a9" } $sh, "b8"; tm1 { is eval { shash_exists($sh, $magic) }, undef; like $@, qr/\Akey is not an octet string at /; } undef, "a21"; tm1 { is eval { shash_length($sh, $magic) }, undef; like $@, qr/\Akey is not an octet string at /; } undef, "a21"; tm1 { is eval { shash_get($sh, $magic) }, undef; like $@, qr/\Akey is not an octet string at /; } undef, "a21"; tm1 { is shash_exists($sh, $magic), !!0 } "b30"; tm1 { is shash_length($sh, $magic), undef } "b30"; tm1 { is shash_get($sh, $magic), undef } "b30"; tm1 { is shash_exists($sh, $magic), !!0 } "b31", "b32"; tm1 { is shash_length($sh, $magic), undef } "b31", "b32"; tm1 { is shash_get($sh, $magic), undef } "b31", "b32"; tm1 { is shash_exists($sh, $magic), !!0 } "b33", []; tm1 { is shash_length($sh, $magic), undef } "b33", []; tm1 { is shash_get($sh, $magic), undef } "b33", []; tm1 { is shash_exists($sh, $magic), !!0 } "b34", "b5"; tm1 { is shash_length($sh, $magic), undef } "b34", "b5"; tm1 { is shash_get($sh, $magic), undef } "b34", "b5"; tm1 { is shash_exists($sh, $magic), !!1 } "b0"; tm1 { is shash_length($sh, $magic), 2 } "b0"; tm1 { is shash_get($sh, $magic), "a0" } "b0"; tm1 { is shash_exists($sh, $magic), !!1 } "b1", "b2"; tm1 { is shash_length($sh, $magic), 2 } "b1", "b2"; tm1 { is shash_get($sh, $magic), "a1" } "b1", "b2"; tm1 { is shash_exists($sh, $magic), !!1 } "b3", []; tm1 { is shash_length($sh, $magic), 2 } "b3", []; tm1 { is shash_get($sh, $magic), "a3" } "b3", []; tm1 { is shash_exists($sh, $magic), !!1 } "b4", "a5"; tm1 { is shash_length($sh, $magic), 2 } "b4", "a5"; tm1 { is shash_get($sh, $magic), "a4" } "b4", "a5"; tm1 { is shash_exists($sh, $magic), !!0 } "a6", "b7"; tm1 { is shash_length($sh, $magic), undef } "a6", "b7"; tm1 { is shash_get($sh, $magic), undef } "a6", "b7"; tm1 { is eval { shash_occupied($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_occupied($magic), !!1 } $sh; tm1 { is shash_occupied($magic), !!1 } $sh, []; tm1 { is eval { shash_count($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_count($magic), 21 } $sh; tm1 { is shash_count($magic), 21 } $sh, []; tm1 { is eval { shash_size($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { like shash_size($magic), qr/\A[0-9]+\z/ } $sh; tm1 { like shash_size($magic), qr/\A[0-9]+\z/ } $sh, []; tm1 { is eval { shash_key_min($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_key_min($magic), "b0" } $sh; tm1 { is shash_key_min($magic), "b0" } $sh, []; tm1 { is eval { shash_key_max($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_key_max($magic), "b9" } $sh; tm1 { is shash_key_max($magic), "b9" } $sh, []; tm1 { is eval { shash_key_ge($magic, "b3") }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_key_ge($magic, "b3"), "b3" } $sh; tm1 { is shash_key_ge($magic, "b3"), "b3" } $sh, []; tm1 { is shash_key_ge($sh, $magic), "b3" } "b3"; tm1 { is shash_key_ge($sh, $magic), "b3" } "b3", "b7"; tm1 { is shash_key_ge($sh, $magic), "b3" } "b3", []; tm1 { is eval { shash_key_gt($magic, "b3") }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_key_gt($magic, "b3"), "b4" } $sh; tm1 { is shash_key_gt($magic, "b3"), "b4" } $sh, []; tm1 { is shash_key_gt($sh, $magic), "b4" } "b3"; tm1 { is shash_key_gt($sh, $magic), "b4" } "b3", "b7"; tm1 { is shash_key_gt($sh, $magic), "b4" } "b3", []; tm1 { is eval { shash_key_le($magic, "b3") }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_key_le($magic, "b3"), "b3" } $sh; tm1 { is shash_key_le($magic, "b3"), "b3" } $sh, []; tm1 { is shash_key_le($sh, $magic), "b3" } "b3"; tm1 { is shash_key_le($sh, $magic), "b3" } "b3", "b7"; tm1 { is shash_key_le($sh, $magic), "b3" } "b3", []; tm1 { is eval { shash_key_lt($magic, "b3") }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_key_lt($magic, "b3"), "b20" } $sh; tm1 { is shash_key_lt($magic, "b3"), "b20" } $sh, []; tm1 { is shash_key_lt($sh, $magic), "b20" } "b3"; tm1 { is shash_key_lt($sh, $magic), "b20" } "b3", "b7"; tm1 { is shash_key_lt($sh, $magic), "b20" } "b3", []; tm1 { is eval { shash_keys_array($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is_deeply shash_keys_array($magic), [sort map { "b$_" } 0..20] } $sh; tm1 { is_deeply shash_keys_array($magic), [sort map { "b$_" } 0..20] } $sh, []; tm1 { is eval { shash_keys_hash($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is_deeply shash_keys_hash($magic), { map { ("b$_" => undef) } 0..20 }; } $sh; tm1 { is_deeply shash_keys_hash($magic), { map { ("b$_" => undef) } 0..20 }; } $sh, []; tm1 { is eval { shash_group_get_hash($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is_deeply shash_group_get_hash($magic), { map { ("b$_" => "a$_") } 0..20 }; } $sh; tm1 { is_deeply shash_group_get_hash($magic), { map { ("b$_" => "a$_") } 0..20 }; } $sh, []; tm1 { is eval { shash_set($magic, "c3", "d3a") }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { shash_set($magic, "c2", "d2a") } $sh; is shash_get($sh, "c2"), "d2a"; tm1 { shash_set($magic, "c2", "d2b") } $sh, []; is shash_get($sh, "c2"), "d2b"; tm1 { shash_set($magic, "c2", undef) } $sh, "a16"; is shash_get($sh, "c2"), undef; tm1 { shash_set($magic, "c2", undef) } $sh; is shash_get($sh, "c2"), undef; tm1 { eval { shash_set($sh, $magic, "a23") }; like $@, qr/\Akey is not an octet string at /; } undef, "a22"; tm1 { shash_set($sh, $magic, "d0a") } "c0"; is shash_get($sh, "c0"), "d0a"; tm1 { shash_set($sh, $magic, "d0b") } "c0", "a8"; is shash_get($sh, "c0"), "d0b"; tm1 { shash_set($sh, $magic, undef) } "c0", []; is shash_get($sh, "c0"), undef; tm1 { shash_set($sh, $magic, undef) } "c0"; is shash_get($sh, "c0"), undef; tm1 { eval { shash_set($sh, "a30", $magic) }; like $@, qr/\Anew value is neither an octet string nor undef at /; } [], "a29"; tm1 { shash_set($sh, "c1", $magic) } "d1a"; is shash_get($sh, "c1"), "d1a"; tm1 { shash_set($sh, "c1", $magic) } "d1b", []; is shash_get($sh, "c1"), "d1b"; tm1 { shash_set($sh, "c1", $magic) } "d1c", "d1d"; is shash_get($sh, "c1"), "d1c"; tm1 { shash_set($sh, "c1", $magic) } undef, "d1e"; is shash_get($sh, "c1"), undef; tm1 { shash_set($sh, "c1", $magic) } undef, []; is shash_get($sh, "c1"), undef; tm1 { is eval { shash_gset($magic, "e3", "f3a") }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_gset($magic, "e2", "f2a"), undef } $sh; is shash_get($sh, "e2"), "f2a"; tm1 { is shash_gset($magic, "e2", "f2b"), "f2a" } $sh, []; is shash_get($sh, "e2"), "f2b"; tm1 { is shash_gset($magic, "e2", undef), "f2b" } $sh, "a17"; is shash_get($sh, "e2"), undef; tm1 { is shash_gset($magic, "e2", undef), undef } $sh; is shash_get($sh, "e2"), undef; tm1 { is eval { shash_gset($sh, $magic, "a25") }, undef; like $@, qr/\Akey is not an octet string at /; } undef, "a24"; tm1 { is shash_gset($sh, $magic, "f0a"), undef } "e0"; is shash_get($sh, "e0"), "f0a"; tm1 { is shash_gset($sh, $magic, "f0b"), "f0a" } "e0", "a9"; is shash_get($sh, "e0"), "f0b"; tm1 { is shash_gset($sh, $magic, undef), "f0b" } "e0", []; is shash_get($sh, "e0"), undef; tm1 { is shash_gset($sh, $magic, undef), undef } "e0"; is shash_get($sh, "e0"), undef; tm1 { is eval { shash_gset($sh, "a32", $magic) }, undef; like $@, qr/\Anew value is neither an octet string nor undef at /; } [], "a31"; tm1 { is shash_gset($sh, "e1", $magic), undef } "f1a"; is shash_get($sh, "e1"), "f1a"; tm1 { is shash_gset($sh, "e1", $magic), "f1a" } "f1b"; is shash_get($sh, "e1"), "f1b"; tm1 { is shash_gset($sh, "e1", $magic), "f1b" } undef, []; is shash_get($sh, "e1"), undef; tm1 { is shash_gset($sh, "e1", $magic), undef } undef, "f1c"; is shash_get($sh, "e1"), undef; tm1 { is eval { shash_cset($magic, "g4", "h4a", "h4b") }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_cset($magic, "g3", undef, undef), !!1 } $sh; is shash_get($sh, "g3"), undef; tm1 { is shash_cset($magic, "g3", "h3a", undef), !!0 } $sh; is shash_get($sh, "g3"), undef; tm1 { is shash_cset($magic, "g3", "h3b", "h3c"), !!0 } $sh; is shash_get($sh, "g3"), undef; tm1 { is shash_cset($magic, "g3", undef, "h3d"), !!1 } $sh, []; is shash_get($sh, "g3"), "h3d"; tm1 { is shash_cset($magic, "g3", undef, undef), !!0 } $sh; is shash_get($sh, "g3"), "h3d"; tm1 { is shash_cset($magic, "g3", undef, "h3e"), !!0 } $sh; is shash_get($sh, "g3"), "h3d"; tm1 { is shash_cset($magic, "g3", "h3f", undef), !!0 } $sh; is shash_get($sh, "g3"), "h3d"; tm1 { is shash_cset($magic, "g3", "h3g", "h3h"), !!0 } $sh; is shash_get($sh, "g3"), "h3d"; tm1 { is shash_cset($magic, "g3", "h3d", "h3i"), !!1 } $sh, "a18"; is shash_get($sh, "g3"), "h3i"; tm1 { is shash_cset($magic, "g3", "h3i", undef), !!1 } $sh; is shash_get($sh, "g3"), undef; tm1 { is eval { shash_cset($sh, $magic, "a27", "a28") }, undef; like $@, qr/\Akey is not an octet string at /; } undef, "a26"; tm1 { is shash_cset($sh, $magic, undef, undef), !!1 } "g0"; is shash_get($sh, "g0"), undef; tm1 { is shash_cset($sh, $magic, "h0a", undef), !!0 } "g0"; is shash_get($sh, "g0"), undef; tm1 { is shash_cset($sh, $magic, "h0b", "h0c"), !!0 } "g0"; is shash_get($sh, "g0"), undef; tm1 { is shash_cset($sh, $magic, undef, "h0d"), !!1 } "g0"; is shash_get($sh, "g0"), "h0d"; tm1 { is shash_cset($sh, $magic, undef, undef), !!0 } "g0", "a9"; is shash_get($sh, "g0"), "h0d"; tm1 { is shash_cset($sh, $magic, undef, "h0e"), !!0 } "g0"; is shash_get($sh, "g0"), "h0d"; tm1 { is shash_cset($sh, $magic, "h0f", undef), !!0 } "g0"; is shash_get($sh, "g0"), "h0d"; tm1 { is shash_cset($sh, $magic, "h0g", "h0h"), !!0 } "g0"; is shash_get($sh, "g0"), "h0d"; tm1 { is shash_cset($sh, $magic, "h0d", "h0i"), !!1 } "g0"; is shash_get($sh, "g0"), "h0i"; tm1 { is shash_cset($sh, $magic, "h0i", undef), !!1 } "g0"; is shash_get($sh, "g0"), undef; tm1 { is eval { shash_cset($sh, "a34", $magic, "a35") }, undef; like $@, qr/\Acheck value is neither an octet string nor undef at /; } [], "a33"; tm1 { is shash_cset($sh, "g1", $magic, undef), !!1 } undef, "a10"; is shash_get($sh, "g1"), undef; tm1 { is shash_cset($sh, "g1", $magic, undef), !!0 } "h1a"; is shash_get($sh, "g1"), undef; tm1 { is shash_cset($sh, "g1", $magic, "h1c"), !!0 } "h1b", []; is shash_get($sh, "g1"), undef; tm1 { is shash_cset($sh, "g1", $magic, "h1d"), !!1 } undef, []; is shash_get($sh, "g1"), "h1d"; tm1 { is shash_cset($sh, "g1", $magic, undef), !!0 } undef, "a11"; is shash_get($sh, "g1"), "h1d"; tm1 { is shash_cset($sh, "g1", $magic, "h1e"), !!0 } undef, "a12"; is shash_get($sh, "g1"), "h1d"; tm1 { is shash_cset($sh, "g1", $magic, undef), !!0 } "h1f"; is shash_get($sh, "g1"), "h1d"; tm1 { is shash_cset($sh, "g1", $magic, "h1h"), !!0 } "h1g"; is shash_get($sh, "g1"), "h1d"; tm1 { is shash_cset($sh, "g1", $magic, "h1i"), !!1 } "h1d", []; is shash_get($sh, "g1"), "h1i"; tm1 { is shash_cset($sh, "g1", $magic, undef), !!1 } "h1i"; is shash_get($sh, "g1"), undef; tm1 { is eval { shash_cset($sh, "a37", "a38", $magic) }, undef; like $@, qr/\Anew value is neither an octet string nor undef at /; } [], "a36"; tm1 { is shash_cset($sh, "g2", undef, $magic), !!1 } undef, "a13"; is shash_get($sh, "g2"), undef; tm1 { is shash_cset($sh, "g2", "h2a", $magic), !!0 } undef, []; is shash_get($sh, "g2"), undef; tm1 { is shash_cset($sh, "g2", "h2b", $magic), !!0 } "h2c"; is shash_get($sh, "g2"), undef; tm1 { is shash_cset($sh, "g2", undef, $magic), !!1 } "h2d", []; is shash_get($sh, "g2"), "h2d"; tm1 { is shash_cset($sh, "g2", undef, $magic), !!0 } undef, "a14"; is shash_get($sh, "g2"), "h2d"; tm1 { is shash_cset($sh, "g2", undef, $magic), !!0 } "h2e", []; is shash_get($sh, "g2"), "h2d"; tm1 { is shash_cset($sh, "g2", "h2f", $magic), !!0 } undef, []; is shash_get($sh, "g2"), "h2d"; tm1 { is shash_cset($sh, "g2", "h2g", $magic), !!0 } "h2h"; is shash_get($sh, "g2"), "h2d"; tm1 { is shash_cset($sh, "g2", "h2d", $magic), !!1 } "h2i"; is shash_get($sh, "g2"), "h2i"; tm1 { is shash_cset($sh, "g2", "h2i", $magic), !!1 } undef, "a15"; is shash_get($sh, "g2"), undef; my $sn = shash_snapshot($sh); ok $sn; ok is_shash($sn); tm1 { is eval { shash_snapshot($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { my $t = shash_snapshot($magic); ok is_shash($t); ok shash_is_snapshot($t); } $sh; tm1 { my $t = shash_snapshot($magic); ok is_shash($t); ok shash_is_snapshot($t); } $sn; tm1 { is eval { shash_is_snapshot($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { is shash_is_snapshot($magic), !!0 } $sh; tm1 { is shash_is_snapshot($magic), !!0 } $sh, []; tm1 { is shash_is_snapshot($magic), !!1 } $sn; tm1 { is shash_is_snapshot($magic), !!1 } $sn, []; tm1 { is eval { shash_idle($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { shash_idle($magic) } $sh; tm1 { is eval { shash_tidy($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { shash_tidy($magic) } $sh; tm1 { is eval { shash_tally_get($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { my $h = shash_tally_get($magic); is ref($h), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %$h; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %$h; } $sh; tm1 { is eval { shash_tally_zero($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { my $v = shash_tally_zero($magic); is $v, undef; } $sh; tm1 { is eval { shash_tally_gzero($magic) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { my $h = shash_tally_gzero($magic); is ref($h), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %$h; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %$h; } $sh; require_ok "Hash::SharedMem::Handle"; tm1 { my %h; eval { tie %h, "Hash::SharedMem::Handle", $magic }; like $@, qr/\Ahandle is not a shared hash handle /; } [], $sh; tm1 { my %h; tie %h, "Hash::SharedMem::Handle", $magic; my $h = tied(%h); ok is_shash($h); $h{i0} = "j0"; is $h{i1}, undef; is $h{i0}, "j0"; } $sh; tm1 { my $s = shash_open($magic, "r"); ok is_shash($s); is shash_get($s, "b11"), "a11"; eval { shash_set($s, "k0", "l0") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; } "$tmpdir/t0", "$tmpdir/t1"; tm1 { my $s = shash_open($magic, "r"); ok is_shash($s); is shash_get($s, "b11"), "a11"; eval { shash_set($s, "k0", "l0") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; } "$tmpdir/t0"; tm1 { my $s = shash_open($magic, "wc"); ok is_shash($s); eval { shash_set($s, "k3", "l3") }; is $@, ""; is eval { shash_get($s, "b11") }, undef; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t2: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; } "$tmpdir/t2", "$tmpdir/t3"; tm1 { my $s = shash_open($magic, "wc"); ok is_shash($s); eval { shash_set($s, "k3", "l3") }; is $@, ""; is eval { shash_get($s, "b11") }, undef; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t8: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; } "$tmpdir/t8"; tm1 { my $s = shash_open("$tmpdir/t0", $magic); ok is_shash($s); ok shash_is_readable($s); ok !shash_is_writable($s); is shash_get($s, "b11"), "a11"; eval { shash_set($s, "k6", "l6") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; } "r", "w"; tm1 { my $s = shash_open("$tmpdir/t0", $magic); ok is_shash($s); ok shash_is_readable($s); ok !shash_is_writable($s); is shash_get($s, "b11"), "a11"; eval { shash_set($s, "k6", "l6") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; } "r"; tm1 { my $s = Hash::SharedMem::Handle->open($magic, "r"); ok is_shash($s); is shash_get($s, "b11"), "a11"; eval { shash_set($s, "k1", "l1") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; } "$tmpdir/t0", "$tmpdir/t1"; tm1 { my $s = Hash::SharedMem::Handle->open($magic, "r"); ok is_shash($s); is shash_get($s, "b11"), "a11"; eval { shash_set($s, "k1", "l1") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; } "$tmpdir/t0"; tm1 { my $s = Hash::SharedMem::Handle->open($magic, "wc"); ok is_shash($s); eval { shash_set($s, "k4", "l4") }; is $@, ""; is eval { shash_get($s, "b11") }, undef; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t4: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; } "$tmpdir/t4", "$tmpdir/t5"; tm1 { my $s = Hash::SharedMem::Handle->open($magic, "wc"); ok is_shash($s); eval { shash_set($s, "k4", "l4") }; is $@, ""; is eval { shash_get($s, "b11") }, undef; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t9: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; } "$tmpdir/t9"; tm1 { my $s = Hash::SharedMem::Handle->open("$tmpdir/t0", $magic); ok is_shash($s); ok shash_is_readable($s); ok !shash_is_writable($s); is shash_get($s, "b11"), "a11"; eval { shash_set($s, "k7", "l7") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; } "r", "w"; tm1 { my $s = Hash::SharedMem::Handle->open("$tmpdir/t0", $magic); ok is_shash($s); ok shash_is_readable($s); ok !shash_is_writable($s); is shash_get($s, "b11"), "a11"; eval { shash_set($s, "k7", "l7") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; } "r"; tm1 { my %s; tie %s, "Hash::SharedMem::Handle", $magic, "r"; ok is_shash(tied(%s)); is $s{b11}, "a11"; eval { $s{k2} = "l2" }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; } "$tmpdir/t0", "$tmpdir/t1"; tm1 { my %s; tie %s, "Hash::SharedMem::Handle", $magic, "r"; ok is_shash(tied(%s)); is $s{b11}, "a11"; eval { $s{k2} = "l2" }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; } "$tmpdir/t0"; tm1 { my %s; tie %s, "Hash::SharedMem::Handle", $magic, "wc"; ok is_shash(tied(%s)); eval { $s{k5} = "l5" }; is $@, ""; is eval { $s{b11} }, undef; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t6: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; } "$tmpdir/t6", "$tmpdir/t7"; tm1 { my %s; tie %s, "Hash::SharedMem::Handle", $magic, "wc"; ok is_shash(tied(%s)); eval { $s{k5} = "l5" }; is $@, ""; is eval { $s{b11} }, undef; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t10: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; } "$tmpdir/t10"; tm1 { my %s; tie %s, "Hash::SharedMem::Handle", "$tmpdir/t0", $magic; ok is_shash(tied(%s)); ok shash_is_readable(tied(%s)); ok !shash_is_writable(tied(%s)); is $s{b11}, "a11"; eval { $s{k8} = "l8" }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; } "r", "w"; tm1 { my %s; tie %s, "Hash::SharedMem::Handle", "$tmpdir/t0", $magic; ok is_shash(tied(%s)); ok shash_is_readable(tied(%s)); ok !shash_is_writable(tied(%s)); is $s{b11}, "a11"; eval { $s{k8} = "l8" }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; } "r"; 1; Hash-SharedMem-0.005/t/many.t000444001750001750 466213143376054 15746 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 1803; BEGIN { use_ok "Hash::SharedMem", qw( is_shash shash_open shash_length shash_get shash_set shash_occupied shash_count shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash ); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); my %ph; sub doru($) { defined($_[0]) ? $_[0] : "u" } sub dorm1($) { defined($_[0]) ? $_[0] : -1 } sub check_hash_state() { is shash_occupied($sh), !!keys(%ph); is shash_count($sh), keys(%ph); my @sk = sort keys %ph; is shash_key_min($sh), $sk[0]; is shash_key_max($sh), @sk ? $sk[-1] : undef; my $ok = 1; for(my $v = 0; $v != 100000; $v++) { $ok &&= dorm1(shash_length($sh, $v)) == exists($ph{$v}) ? length($ph{$v}) : -1; $ok &&= doru(shash_get($sh, $v)) eq doru($ph{$v}); } ok $ok; $ok = 1; for(my $i = 0; $i != @sk; $i++) { $ok &&= doru(shash_key_ge($sh, $sk[$i])) eq $sk[$i]; $ok &&= doru(shash_key_gt($sh, $sk[$i])) eq doru($sk[$i+1]); $ok &&= doru(shash_key_le($sh, $sk[$i])) eq $sk[$i]; $ok &&= doru(shash_key_lt($sh, $sk[$i])) eq ($i != 0 ? $sk[$i-1] : "u"); } ok $ok; $ok = 1; $ok &&= doru(shash_key_ge($sh, "-")) eq doru($sk[0]); $ok &&= doru(shash_key_gt($sh, "-")) eq doru($sk[0]); $ok &&= doru(shash_key_le($sh, "-")) eq "u"; $ok &&= doru(shash_key_lt($sh, "-")) eq "u"; for(my $i = 0; $i < $#sk; $i++) { $ok &&= doru(shash_key_ge($sh, $sk[$i]."-")) eq doru($sk[$i+1]); $ok &&= doru(shash_key_gt($sh, $sk[$i]."-")) eq doru($sk[$i+1]); $ok &&= doru(shash_key_le($sh, $sk[$i]."-")) eq $sk[$i]; $ok &&= doru(shash_key_lt($sh, $sk[$i]."-")) eq $sk[$i]; } ok $ok; is_deeply shash_keys_array($sh), \@sk; is_deeply shash_keys_hash($sh), { map { ($_ => undef) } @sk }; is_deeply shash_group_get_hash($sh), \%ph; } my $v = 5; for(my $i = 0; $i != 40; $i++) { for(my $j = 0; $j != 1000; $j++) { $v = ($v*21+7) % 100000; shash_set($sh, $v, "a".$v); $ph{$v} = "a".$v; } check_hash_state(); } $v = 5; for(my $i = 0; $i != 40; $i++) { for(my $j = 0; $j != 1000; $j++) { $v = ($v*61+19) % 100000; shash_set($sh, $v, "b".$v); $ph{$v} = "b".$v; } check_hash_state(); } $v = 5; for(my $i = 0; $i != 100; $i++) { for(my $j = 0; $j != 1000; $j++) { $v = ($v*41+17) % 100000; shash_set($sh, $v, undef); delete $ph{$v}; } check_hash_state(); } 1; Hash-SharedMem-0.005/t/method.t000444001750001750 3763313143376054 16306 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 375; BEGIN { use_ok "Hash::SharedMem::Handle"; } BEGIN { use_ok "Hash::SharedMem", qw(is_shash); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = Hash::SharedMem::Handle->open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); is scalar($sh->is_snapshot), !!0; is_deeply [$sh->is_snapshot], [!!0]; is scalar($sh->is_readable), !!1; is_deeply [$sh->is_readable], [!!1]; is scalar($sh->is_writable), !!1; is_deeply [$sh->is_writable], [!!1]; is scalar($sh->mode), "rw"; is_deeply [$sh->mode], ["rw"]; eval { ${\($sh->mode)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is $sh->can("getd"), $sh->can("exists"); is scalar($sh->exists("a100")), !!0; is_deeply [$sh->exists("a100")], [!!0]; is scalar($sh->getd("a100")), !!0; is_deeply [$sh->getd("a100")], [!!0]; is scalar($sh->length("a100")), undef; is_deeply [$sh->length("a100")], [undef]; is scalar($sh->get("a100")), undef; is_deeply [$sh->get("a100")], [undef]; is scalar($sh->occupied), !!0; is_deeply [$sh->occupied], [!!0]; is scalar($sh->count), 0; is_deeply [$sh->count], [0]; eval { ${\($sh->count)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; like scalar($sh->size), qr/\A[0-9]+\z/; like join(",", $sh->size), qr/\A[0-9]+\z/; eval { ${\($sh->size)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar($sh->key_min), undef; is_deeply [$sh->key_min], [undef]; is scalar($sh->key_max), undef; is_deeply [$sh->key_max], [undef]; is scalar($sh->key_ge("a110")), undef; is_deeply [$sh->key_ge("a110")], [undef]; is scalar($sh->key_gt("a110")), undef; is_deeply [$sh->key_gt("a110")], [undef]; is scalar($sh->key_le("a110")), undef; is_deeply [$sh->key_le("a110")], [undef]; is scalar($sh->key_lt("a110")), undef; is_deeply [$sh->key_lt("a110")], [undef]; is_deeply scalar($sh->keys_array), []; is_deeply [$sh->keys_array], [[]]; eval { ${\($sh->keys_array)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply scalar($sh->keys_hash), {}; is_deeply [$sh->keys_hash], [{}]; eval { ${\($sh->keys_hash)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply scalar($sh->group_get_hash), {}; is_deeply [$sh->group_get_hash], [{}]; eval { ${\($sh->group_get_hash)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; $sh->set("a110", "b110"); is scalar($sh->set("a100", "b100")), undef; is_deeply [$sh->set("a120", "b120")], []; is scalar($sh->exists("a100")), !!1; is_deeply [$sh->exists("a100")], [!!1]; is scalar($sh->getd("a100")), !!1; is_deeply [$sh->getd("a100")], [!!1]; is scalar($sh->length("a100")), 4; is_deeply [$sh->length("a100")], [4]; eval { ${\($sh->length("a100"))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar($sh->get("a100")), "b100"; is_deeply [$sh->get("a100")], ["b100"]; is scalar($sh->occupied), !!1; is_deeply [$sh->occupied], [!!1]; is scalar($sh->count), 3; is_deeply [$sh->count], [3]; eval { ${\($sh->count)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; like scalar($sh->size), qr/\A[0-9]+\z/; like join(",", $sh->size), qr/\A[0-9]+\z/; eval { ${\($sh->size)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar($sh->key_min), "a100"; is_deeply [$sh->key_min], ["a100"]; is scalar($sh->key_max), "a120"; is_deeply [$sh->key_max], ["a120"]; is scalar($sh->key_ge("a110")), "a110"; is_deeply [$sh->key_ge("a110")], ["a110"]; is scalar($sh->key_gt("a110")), "a120"; is_deeply [$sh->key_gt("a110")], ["a120"]; is scalar($sh->key_le("a110")), "a110"; is_deeply [$sh->key_le("a110")], ["a110"]; is scalar($sh->key_lt("a110")), "a100"; is_deeply [$sh->key_lt("a110")], ["a100"]; is_deeply scalar($sh->keys_array), [qw(a100 a110 a120)]; is_deeply [$sh->keys_array], [[qw(a100 a110 a120)]]; eval { ${\($sh->keys_array)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply scalar($sh->keys_hash), { a100=>undef, a110=>undef, a120=>undef }; is_deeply [$sh->keys_hash], [{ a100=>undef, a110=>undef, a120=>undef }]; eval { ${\($sh->keys_hash)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply scalar($sh->group_get_hash), { a100=>"b100", a110=>"b110", a120=>"b120" }; is_deeply [$sh->group_get_hash], [{ a100=>"b100", a110=>"b110", a120=>"b120" }]; eval { ${\($sh->group_get_hash)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar($sh->exists("a000")), !!0; is scalar($sh->length("a000")), undef; is scalar($sh->get("a000")), undef; is scalar($sh->exists("a105")), !!0; is scalar($sh->length("a105")), undef; is scalar($sh->get("a105")), undef; is scalar($sh->exists("a110")), !!1; is scalar($sh->length("a110")), 4; is scalar($sh->get("a110")), "b110"; is scalar($sh->exists("a115")), !!0; is scalar($sh->length("a115")), undef; is scalar($sh->get("a115")), undef; is scalar($sh->exists("a120")), !!1; is scalar($sh->length("a120")), 4; is scalar($sh->get("a120")), "b120"; is scalar($sh->exists("a130")), !!0; is scalar($sh->length("a130")), undef; is scalar($sh->get("a130")), undef; my $sn = $sh->snapshot; ok is_shash($sn); is scalar($sn->is_snapshot), !!1; is_deeply [$sn->is_snapshot], [!!1]; is scalar($sn->is_readable), !!1; is_deeply [$sn->is_readable], [!!1]; is scalar($sn->is_writable), !!0; is_deeply [$sn->is_writable], [!!0]; is scalar($sn->mode), "r"; is_deeply [$sn->mode], ["r"]; is $sn->exists("a000"), !!0; is $sn->length("a000"), undef; is $sn->get("a000"), undef; is $sn->exists("a100"), !!1; is $sn->length("a100"), 4; is $sn->get("a100"), "b100"; is $sn->exists("a105"), !!0; is $sn->length("a105"), undef; is $sn->get("a105"), undef; is $sn->exists("a110"), !!1; is $sn->length("a110"), 4; is $sn->get("a110"), "b110"; is $sn->exists("a115"), !!0; is $sn->length("a115"), undef; is $sn->get("a115"), undef; is $sn->exists("a120"), !!1; is $sn->length("a120"), 4; is $sn->get("a120"), "b120"; is $sn->exists("a130"), !!0; is $sn->length("a130"), undef; is $sn->get("a130"), undef; is $sn->occupied, !!1; is $sn->count, 3; is $sn->key_min, "a100"; is $sn->key_max, "a120"; is $sn->key_ge("a110"), "a110"; is $sn->key_gt("a110"), "a120"; is $sn->key_le("a110"), "a110"; is $sn->key_lt("a110"), "a100"; is_deeply $sn->keys_array, [qw(a100 a110 a120)]; is_deeply $sn->keys_hash, { a100=>undef, a110=>undef, a120=>undef }; is_deeply $sn->group_get_hash, { a100=>"b100", a110=>"b110", a120=>"b120" }; $sh->set("a105", "b105"); $sh->set("a110", undef); is $sh->exists("a000"), !!0; is $sh->length("a000"), undef; is $sh->get("a000"), undef; is $sh->exists("a100"), !!1; is $sh->length("a100"), 4; is $sh->get("a100"), "b100"; is $sh->exists("a105"), !!1; is $sh->length("a105"), 4; is $sh->get("a105"), "b105"; is $sh->exists("a110"), !!0; is $sh->length("a110"), undef; is $sh->get("a110"), undef; is $sh->exists("a115"), !!0; is $sh->length("a115"), undef; is $sh->get("a115"), undef; is $sh->exists("a120"), !!1; is $sh->length("a120"), 4; is $sh->get("a120"), "b120"; is $sh->exists("a130"), !!0; is $sh->length("a130"), undef; is $sh->get("a130"), undef; is $sh->occupied, !!1; is $sh->count, 3; is $sh->key_min, "a100"; is $sh->key_max, "a120"; is $sh->key_ge("a110"), "a120"; is $sh->key_gt("a110"), "a120"; is $sh->key_le("a110"), "a105"; is $sh->key_lt("a110"), "a105"; is_deeply $sh->keys_array, [qw(a100 a105 a120)]; is_deeply $sh->keys_hash, { a100=>undef, a105=>undef, a120=>undef }; is_deeply $sh->group_get_hash, { a100=>"b100", a105=>"b105", a120=>"b120" }; is $sn->exists("a000"), !!0; is $sn->length("a000"), undef; is $sn->get("a000"), undef; is $sn->exists("a100"), !!1; is $sn->length("a100"), 4; is $sn->get("a100"), "b100"; is $sn->exists("a105"), !!0; is $sn->length("a105"), undef; is $sn->get("a105"), undef; is $sn->exists("a110"), !!1; is $sn->length("a110"), 4; is $sn->get("a110"), "b110"; is $sn->exists("a115"), !!0; is $sn->length("a115"), undef; is $sn->get("a115"), undef; is $sn->exists("a120"), !!1; is $sn->length("a120"), 4; is $sn->get("a120"), "b120"; is $sn->exists("a130"), !!0; is $sn->length("a130"), undef; is $sn->get("a130"), undef; is $sn->occupied, !!1; is $sn->count, 3; is $sn->key_min, "a100"; is $sn->key_max, "a120"; is $sn->key_ge("a110"), "a110"; is $sn->key_gt("a110"), "a120"; is $sn->key_le("a110"), "a110"; is $sn->key_lt("a110"), "a100"; is_deeply $sn->keys_array, [qw(a100 a110 a120)]; is_deeply $sn->keys_hash, { a100=>undef, a110=>undef, a120=>undef }; is_deeply $sn->group_get_hash, { a100=>"b100", a110=>"b110", a120=>"b120" }; eval { $sn->set("a115", "b115") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ handle\ is\ a\ snapshot\ #x; is $sh->exists("a115"), !!0; is $sh->length("a115"), undef; is $sh->get("a115"), undef; is $sh->occupied, !!1; is $sh->count, 3; is $sh->key_min, "a100"; is $sh->key_max, "a120"; is $sh->key_ge("a110"), "a120"; is $sh->key_gt("a110"), "a120"; is $sh->key_le("a110"), "a105"; is $sh->key_lt("a110"), "a105"; is_deeply $sh->keys_array, [qw(a100 a105 a120)]; is_deeply $sh->keys_hash, { a100=>undef, a105=>undef, a120=>undef }; is_deeply $sh->group_get_hash, { a100=>"b100", a105=>"b105", a120=>"b120" }; is $sn->exists("a115"), !!0; is $sn->length("a115"), undef; is $sn->get("a115"), undef; is $sn->occupied, !!1; is $sn->count, 3; is $sn->key_min, "a100"; is $sn->key_max, "a120"; is $sn->key_ge("a110"), "a110"; is $sn->key_gt("a110"), "a120"; is $sn->key_le("a110"), "a110"; is $sn->key_lt("a110"), "a100"; is_deeply $sn->keys_array, [qw(a100 a110 a120)]; is_deeply $sn->keys_hash, { a100=>undef, a110=>undef, a120=>undef }; is_deeply $sn->group_get_hash, { a100=>"b100", a110=>"b110", a120=>"b120" }; $sh->gset("a115", "c115"); is $sh->get("a115"), "c115"; $sh->gset("a115", "d115"); is $sh->get("a115"), "d115"; $sh->gset("a115", "d115"); is $sh->get("a115"), "d115"; $sh->gset("a115", undef); is $sh->get("a115"), undef; $sh->gset("a115", undef); is $sh->get("a115"), undef; is scalar($sh->gset("a115", "e115")), undef; is $sh->get("a115"), "e115"; is scalar($sh->gset("a115", "f115")), "e115"; is $sh->get("a115"), "f115"; is scalar($sh->gset("a115", "f115")), "f115"; is $sh->get("a115"), "f115"; is scalar($sh->gset("a115", undef)), "f115"; is $sh->get("a115"), undef; is scalar($sh->gset("a115", undef)), undef; is $sh->get("a115"), undef; is_deeply [$sh->gset("a115", "g115")], [undef]; is $sh->get("a115"), "g115"; is_deeply [$sh->gset("a115", "h115")], ["g115"]; is $sh->get("a115"), "h115"; is_deeply [$sh->gset("a115", "h115")], ["h115"]; is $sh->get("a115"), "h115"; is_deeply [$sh->gset("a115", undef)], ["h115"]; is $sh->get("a115"), undef; is_deeply [$sh->gset("a115", undef)], [undef]; is $sh->get("a115"), undef; $sh->cset("a115", "z", "i115"); is $sh->get("a115"), undef; $sh->cset("a115", undef, "j115"); is $sh->get("a115"), "j115"; $sh->cset("a115", "z", "k115"); is $sh->get("a115"), "j115"; $sh->cset("a115", undef, "l115"); is $sh->get("a115"), "j115"; $sh->cset("a115", "j115", "m115"); is $sh->get("a115"), "m115"; $sh->cset("a115", "z", "m115"); is $sh->get("a115"), "m115"; $sh->cset("a115", undef, "m115"); is $sh->get("a115"), "m115"; $sh->cset("a115", "m115", "m115"); is $sh->get("a115"), "m115"; $sh->cset("a115", "z", undef); is $sh->get("a115"), "m115"; $sh->cset("a115", undef, undef); is $sh->get("a115"), "m115"; $sh->cset("a115", "m115", undef); is $sh->get("a115"), undef; $sh->cset("a115", "z", undef); is $sh->get("a115"), undef; $sh->cset("a115", undef, undef); is $sh->get("a115"), undef; is scalar($sh->cset("a115", "z", "i115")), !!0; is $sh->get("a115"), undef; is scalar($sh->cset("a115", undef, "j115")), !!1; is $sh->get("a115"), "j115"; is scalar($sh->cset("a115", "z", "k115")), !!0; is $sh->get("a115"), "j115"; is scalar($sh->cset("a115", undef, "l115")), !!0; is $sh->get("a115"), "j115"; is scalar($sh->cset("a115", "j115", "m115")), !!1; is $sh->get("a115"), "m115"; is scalar($sh->cset("a115", "z", "m115")), !!0; is $sh->get("a115"), "m115"; is scalar($sh->cset("a115", undef, "m115")), !!0; is $sh->get("a115"), "m115"; is scalar($sh->cset("a115", "m115", "m115")), !!1; is $sh->get("a115"), "m115"; is scalar($sh->cset("a115", "z", undef)), !!0; is $sh->get("a115"), "m115"; is scalar($sh->cset("a115", undef, undef)), !!0; is $sh->get("a115"), "m115"; is scalar($sh->cset("a115", "m115", undef)), !!1; is $sh->get("a115"), undef; is scalar($sh->cset("a115", "z", undef)), !!0; is $sh->get("a115"), undef; is scalar($sh->cset("a115", undef, undef)), !!1; is $sh->get("a115"), undef; is_deeply [$sh->cset("a115", "z", "i115")], [!!0]; is $sh->get("a115"), undef; is_deeply [$sh->cset("a115", undef, "j115")], [!!1]; is $sh->get("a115"), "j115"; is_deeply [$sh->cset("a115", "z", "k115")], [!!0]; is $sh->get("a115"), "j115"; is_deeply [$sh->cset("a115", undef, "l115")], [!!0]; is $sh->get("a115"), "j115"; is_deeply [$sh->cset("a115", "j115", "m115")], [!!1]; is $sh->get("a115"), "m115"; is_deeply [$sh->cset("a115", "z", "m115")], [!!0]; is $sh->get("a115"), "m115"; is_deeply [$sh->cset("a115", undef, "m115")], [!!0]; is $sh->get("a115"), "m115"; is_deeply [$sh->cset("a115", "m115", "m115")], [!!1]; is $sh->get("a115"), "m115"; is_deeply [$sh->cset("a115", "z", undef)], [!!0]; is $sh->get("a115"), "m115"; is_deeply [$sh->cset("a115", undef, undef)], [!!0]; is $sh->get("a115"), "m115"; is_deeply [$sh->cset("a115", "m115", undef)], [!!1]; is $sh->get("a115"), undef; is_deeply [$sh->cset("a115", "z", undef)], [!!0]; is $sh->get("a115"), undef; is_deeply [$sh->cset("a115", undef, undef)], [!!1]; is $sh->get("a115"), undef; $sh->idle; is scalar($sh->idle), undef; is_deeply [$sh->idle], []; $sh->tidy; is scalar($sh->tidy), undef; is_deeply [$sh->tidy], []; my $h; $sh->tally_get; $h = $sh->tally_get; is ref($h), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %$h; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %$h; $h = [$sh->tally_get]; is @$h, 1; is ref($h->[0]), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %{$h->[0]}; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %{$h->[0]}; $sh->tally_zero; is scalar($sh->tally_zero), undef; is_deeply [$sh->tally_zero], []; $sh->tally_gzero; $h = $sh->tally_gzero; is ref($h), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %$h; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %$h; $h = [$sh->tally_gzero]; is @$h, 1; is ref($h->[0]), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %{$h->[0]}; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %{$h->[0]}; my $nx = Hash::SharedMem::Handle->open("$tmpdir/t1", "c"); ok $nx; ok is_shash($nx); is scalar($nx->is_snapshot), !!0; is_deeply [$nx->is_snapshot], [!!0]; is scalar($nx->is_readable), !!0; is_deeply [$nx->is_readable], [!!0]; is scalar($nx->is_writable), !!0; is_deeply [$nx->is_writable], [!!0]; is scalar($nx->mode), ""; is_deeply [$nx->mode], [""]; eval { $nx->exists("a100") }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { $nx->length("a100") }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { $nx->get("a100") }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { $nx->set("a100", "b100") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; eval { $nx->gset("a100", "b100") }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { $nx->cset("a100", "b100", "c100") }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { Hash::SharedMem::Handle->open("$tmpdir/t1", "c") }; is $@, ""; my @sh = Hash::SharedMem::Handle->open("$tmpdir/t1", "c"); is scalar(@sh), 1; ok is_shash($sh[0]); eval { ${\(Hash::SharedMem::Handle->open("$tmpdir/t1", "c"))} = undef; }; like $@, qr/\AModification of a read-only value attempted /; eval { ${\($sh->snapshot)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; eval { ${\($sn->snapshot)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; 1; Hash-SharedMem-0.005/t/mode.t000444001750001750 4457113143376054 15751 0ustar00zeframzefram000000000000use warnings; use strict; use Errno 1.00 qw(ENOENT EEXIST); use File::Temp 0.22 qw(tempdir); use Test::More tests => 2323; BEGIN { use_ok "Hash::SharedMem", qw( is_shash shash_open shash_is_readable shash_is_writable shash_mode shash_exists shash_length shash_get shash_set shash_gset shash_cset shash_occupied shash_count shash_size shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash shash_snapshot shash_is_snapshot shash_idle shash_tidy shash_tally_get shash_tally_zero shash_tally_gzero ); } require_ok "Hash::SharedMem::Handle"; my $enoent = do { local $! = ENOENT; "$!" }; my $eexist = do { local $! = EEXIST; "$!" }; my $tmpdir = tempdir(CLEANUP => 1); my $i = 0; for(my $v = ord(" "); $v <= ord("~"); $v++) { my $c = chr($v); next if $c =~ /\A[rwce]\z/; eval { shash_open("$tmpdir/t".$i++, $c) }; like $@, qr/\Aunknown open mode flag `\Q$c\E' at /; } for(my $v = 0; $v <= 0x200; $v++) { my $c = chr($v); next if $c =~ /\A[ -~]\z/; eval { shash_open("$tmpdir/t".$i++, $c) }; like $@, qr/\Aunknown open mode flag at /; } foreach my $c (qw(r w c e)) { eval { shash_open("$tmpdir/t".$i++, $c.$c) }; like $@, qr/\Aduplicate open mode flag `$c' at /; eval { shash_open("$tmpdir/t".$i++, $c."r".$c) }; like $@, qr/\Aduplicate open mode flag `$c' at /; } sub test_shash_ops($$$) { my($sh, $name, $iomode) = @_; ok !shash_is_snapshot($sh); is shash_is_readable($sh), scalar($iomode =~ /r/); is shash_is_writable($sh), scalar($iomode =~ /w/); is shash_mode($sh), $iomode; my $v = eval { shash_exists($sh, $i++) }; if($iomode =~ /r/) { is $@, ""; is $v, !!0; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_length($sh, $i++) }; if($iomode =~ /r/) { is $@, ""; is $v, undef; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_get($sh, $i++) }; if($iomode =~ /r/) { is $@, ""; is $v, undef; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } eval { shash_set($sh, $i++, $i++) }; if($iomode =~ /w/) { is $@, ""; } else { like $@, qr#\Acan't\ write\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unwritable\ mode\ #x; } $v = eval { shash_gset($sh, $i++, $i++) }; if($iomode =~ /rw/) { is $@, ""; is $v, undef; } elsif($iomode =~ /r/) { like $@, qr#\Acan't\ update\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unwritable\ mode\ #x; } else { like $@, qr#\Acan't\ update\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_cset($sh, $i++, $i++, $i++) }; if($iomode =~ /rw/) { is $@, ""; is $v, !!0; } elsif($iomode =~ /r/) { like $@, qr#\Acan't\ update\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unwritable\ mode\ #x; } else { like $@, qr#\Acan't\ update\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } my $occupied = $iomode =~ /w/; $v = eval { shash_occupied($sh) }; if($iomode =~ /r/) { is $@, ""; is $v, !!$occupied; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_count($sh) }; if($iomode =~ /r/) { is $@, ""; like $v, $occupied ? qr/\A[1-9][0-9]*\z/ : qr/\A0\z/; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_size($sh) }; if($iomode =~ /r/) { is $@, ""; like $v, qr/\A[0-9]+\z/; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_key_min($sh) }; if($iomode =~ /r/) { is $@, ""; if($occupied) { like $v, qr/\A[0-9]+\z/; } else { is $v, undef; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_key_max($sh) }; if($iomode =~ /r/) { is $@, ""; if($occupied) { like $v, qr/\A[0-9]+\z/; } else { is $v, undef; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_key_ge($sh, "-") }; if($iomode =~ /r/) { is $@, ""; if($occupied) { like $v, qr/\A[0-9]+\z/; } else { is $v, undef; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_key_gt($sh, "-") }; if($iomode =~ /r/) { is $@, ""; if($occupied) { like $v, qr/\A[0-9]+\z/; } else { is $v, undef; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_key_le($sh, "~") }; if($iomode =~ /r/) { is $@, ""; if($occupied) { like $v, qr/\A[0-9]+\z/; } else { is $v, undef; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_key_lt($sh, "~") }; if($iomode =~ /r/) { is $@, ""; if($occupied) { like $v, qr/\A[0-9]+\z/; } else { is $v, undef; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_keys_array($sh) }; if($iomode =~ /r/) { is $@, ""; is ref($v), "ARRAY"; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_keys_hash($sh) }; if($iomode =~ /r/) { is $@, ""; is ref($v), "HASH"; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_group_get_hash($sh) }; if($iomode =~ /r/) { is $@, ""; is ref($v), "HASH"; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } eval { shash_idle($sh) }; is $@, ""; eval { shash_tidy($sh) }; if($iomode =~ /w/) { is $@, ""; } else { like $@, qr#\Acan't\ tidy\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unwritable\ mode\ #x; } $v = eval { shash_tally_get($sh) }; is $@, ""; is ref($v), "HASH"; $v = eval { shash_tally_zero($sh) }; is $@, ""; is $v, undef; $v = eval { shash_tally_gzero($sh) }; is $@, ""; is ref($v), "HASH"; my %sh; tie %sh, "Hash::SharedMem::Handle", $sh; ok is_shash(tied(%sh)); ok tied(%sh) == $sh; $v = eval { exists($sh{$i++}) }; if($iomode =~ /r/) { is $@, ""; is $v, !!0; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { $sh{$i++} }; if($iomode =~ /r/) { is $@, ""; is $v, undef; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } eval { $sh{$i++} = $i++ }; if($iomode =~ /w/) { is $@, ""; } else { like $@, qr#\Acan't\ write\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unwritable\ mode\ #x; } $v = eval { delete($sh{$i++}) }; if($iomode =~ /rw/) { is $@, ""; is $v, undef; } elsif($iomode =~ /r/) { like $@, qr#\Acan't\ update\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unwritable\ mode\ #x; } else { like $@, qr#\Acan't\ update\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } SKIP: { skip "tied hash in scalar context not supported on this Perl", 2 unless ("$]" >= 5.008003 && "$]" < 5.009000) || "$]" >= 5.009001; $v = eval { scalar(%sh) }; if($iomode =~ /r/) { is $@, ""; if("$]" >= 5.025003) { like $v, $occupied ? qr/\A[1-9][0-9]*\z/ : qr/\A0\z/; } else { is $v, !!$occupied; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; ok 1; } } $v = eval { scalar(keys(%sh)) }; if($iomode =~ /r/) { is $@, ""; like $v, $occupied ? qr/\A[1-9][0-9]*\z/ : qr/\A0\z/; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { scalar(values(%sh)) }; if($iomode =~ /r/) { is $@, ""; like $v, $occupied ? qr/\A[1-9][0-9]*\z/ : qr/\A0\z/; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { scalar(each(%sh)) }; if($iomode =~ /r/) { is $@, ""; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { [each(%sh)] }; if($iomode =~ /r/) { is $@, ""; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { [keys(%sh)] }; if($iomode =~ /r/) { is $@, ""; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { [values(%sh)] }; if($iomode =~ /r/) { is $@, ""; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { [%sh] }; if($iomode =~ /r/) { is $@, ""; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $sh = shash_snapshot($sh); $iomode =~ s/w//; ok shash_is_snapshot($sh); is shash_is_readable($sh), scalar($iomode =~ /r/); is shash_is_writable($sh), !!0; is shash_mode($sh), $iomode; $v = eval { shash_exists($sh, $i++) }; if($iomode =~ /r/) { is $@, ""; is $v, !!0; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_length($sh, $i++) }; if($iomode =~ /r/) { is $@, ""; is $v, undef; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_get($sh, $i++) }; if($iomode =~ /r/) { is $@, ""; is $v, undef; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } eval { shash_set($sh, $i++, $i++) }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$name\E: \ shared\ hash\ handle\ is\ a\ snapshot\ #x; $v = eval { shash_gset($sh, $i++, $i++) }; if($iomode =~ /r/) { like $@, qr#\Acan't\ update\ shared\ hash\ \Q$name\E: \ shared\ hash\ handle\ is\ a\ snapshot\ #x; } else { like $@, qr#\Acan't\ update\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_cset($sh, $i++, $i++, $i++) }; if($iomode =~ /r/) { like $@, qr#\Acan't\ update\ shared\ hash\ \Q$name\E: \ shared\ hash\ handle\ is\ a\ snapshot\ #x; } else { like $@, qr#\Acan't\ update\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_occupied($sh) }; if($iomode =~ /r/) { is $@, ""; is $v, !!$occupied; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_count($sh) }; if($iomode =~ /r/) { is $@, ""; like $v, $occupied ? qr/\A[1-9][0-9]*\z/ : qr/\A0\z/; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_size($sh) }; if($iomode =~ /r/) { is $@, ""; like $v, qr/\A[0-9]+\z/; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_key_min($sh) }; if($iomode =~ /r/) { is $@, ""; if($occupied) { like $v, qr/\A[0-9]+\z/; } else { is $v, undef; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_key_max($sh) }; if($iomode =~ /r/) { is $@, ""; if($occupied) { like $v, qr/\A[0-9]+\z/; } else { is $v, undef; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_key_ge($sh, "-") }; if($iomode =~ /r/) { is $@, ""; if($occupied) { like $v, qr/\A[0-9]+\z/; } else { is $v, undef; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_key_gt($sh, "-") }; if($iomode =~ /r/) { is $@, ""; if($occupied) { like $v, qr/\A[0-9]+\z/; } else { is $v, undef; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_key_le($sh, "~") }; if($iomode =~ /r/) { is $@, ""; if($occupied) { like $v, qr/\A[0-9]+\z/; } else { is $v, undef; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_key_lt($sh, "~") }; if($iomode =~ /r/) { is $@, ""; if($occupied) { like $v, qr/\A[0-9]+\z/; } else { is $v, undef; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_keys_array($sh) }; if($iomode =~ /r/) { is $@, ""; is ref($v), "ARRAY"; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_keys_hash($sh) }; if($iomode =~ /r/) { is $@, ""; is ref($v), "HASH"; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { shash_group_get_hash($sh) }; if($iomode =~ /r/) { is $@, ""; is ref($v), "HASH"; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } eval { shash_idle($sh) }; is $@, ""; eval { shash_tidy($sh) }; like $@, qr#\Acan't\ tidy\ shared\ hash\ \Q$name\E: \ shared\ hash\ handle\ is\ a\ snapshot\ #x; $v = eval { shash_tally_get($sh) }; is $@, ""; is ref($v), "HASH"; $v = eval { shash_tally_zero($sh) }; is $@, ""; is $v, undef; $v = eval { shash_tally_gzero($sh) }; is $@, ""; is ref($v), "HASH"; tie %sh, "Hash::SharedMem::Handle", $sh; ok is_shash(tied(%sh)); ok tied(%sh) == $sh; $v = eval { exists($sh{$i++}) }; if($iomode =~ /r/) { is $@, ""; is $v, !!0; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { $sh{$i++} }; if($iomode =~ /r/) { is $@, ""; is $v, undef; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } eval { $sh{$i++} = $i++ }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$name\E: \ shared\ hash\ handle\ is\ a\ snapshot\ #x; $v = eval { delete($sh{$i++}) }; if($iomode =~ /r/) { like $@, qr#\Acan't\ update\ shared\ hash\ \Q$name\E: \ shared\ hash\ handle\ is\ a\ snapshot\ #x; } else { like $@, qr#\Acan't\ update\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } SKIP: { skip "tied hash in scalar context not supported on this Perl", 2 unless ("$]" >= 5.008003 && "$]" < 5.009000) || "$]" >= 5.009001; $v = eval { scalar(%sh) }; if($iomode =~ /r/) { is $@, ""; if("$]" >= 5.025003) { like $v, $occupied ? qr/\A[1-9][0-9]*\z/ : qr/\A0\z/; } else { is $v, !!$occupied; } } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; ok 1; } } $v = eval { scalar(keys(%sh)) }; if($iomode =~ /r/) { is $@, ""; like $v, $occupied ? qr/\A[1-9][0-9]*\z/ : qr/\A0\z/; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { scalar(values(%sh)) }; if($iomode =~ /r/) { is $@, ""; like $v, $occupied ? qr/\A[1-9][0-9]*\z/ : qr/\A0\z/; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { scalar(each(%sh)) }; if($iomode =~ /r/) { is $@, ""; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { [each(%sh)] }; if($iomode =~ /r/) { is $@, ""; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { [keys(%sh)] }; if($iomode =~ /r/) { is $@, ""; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { [values(%sh)] }; if($iomode =~ /r/) { is $@, ""; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } $v = eval { [%sh] }; if($iomode =~ /r/) { is $@, ""; } else { like $@, qr#\Acan't\ read\ shared\ hash\ \Q$name\E: \ shared\ hash\ was\ opened \ in\ unreadable\ mode\ #x; } } foreach my $iomode ("", qw(r w rw)) { my $name = "$tmpdir/t".$i++; my $sh = eval { shash_open($name, $iomode) }; like $@, qr/\Acan't open shared hash \Q$name\E: \Q$enoent\E at /; $sh = eval { shash_open($name, $iomode."c") }; ok $sh; ok is_shash($sh); test_shash_ops($sh, $name, $iomode); $sh = eval { shash_open($name, $iomode."c") }; ok $sh; ok is_shash($sh); test_shash_ops($sh, $name, $iomode); $sh = eval { shash_open($name, $iomode) }; ok $sh; ok is_shash($sh); test_shash_ops($sh, $name, $iomode); $sh = eval { shash_open($name, $iomode."e") }; like $@, qr/\Acan't open shared hash \Q$name\E: \Q$eexist\E at /; $sh = eval { shash_open($name, $iomode."ce") }; like $@, qr/\Acan't open shared hash \Q$name\E: \Q$eexist\E at /; $name = "$tmpdir/t".$i++; $sh = eval { shash_open($name, $iomode."e") }; like $@, qr/\Acan't open shared hash \Q$name\E: \Q$enoent\E at /; $sh = eval { shash_open($name, $iomode."ce") }; ok $sh; ok is_shash($sh); test_shash_ops($sh, $name, $iomode); } 1; Hash-SharedMem-0.005/t/octet.t000444001750001750 11105613143376054 16154 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Scalar::String 0.000 qw( sclstr_is_downgraded sclstr_is_upgraded sclstr_downgraded sclstr_upgraded ); use Test::More tests => 756; BEGIN { use_ok "Hash::SharedMem", qw( is_shash shash_open shash_exists shash_length shash_get shash_set shash_gset shash_cset shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash ); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); sub is_dg($$) { ok sclstr_is_downgraded($_[0]); is sclstr_downgraded($_[0]), sclstr_downgraded($_[1]); } shash_set($sh, sclstr_downgraded("a0foo"), "b0"); is shash_exists($sh, sclstr_downgraded("a0foo")), !!1; is shash_exists($sh, sclstr_upgraded("a0foo")), !!1; is shash_length($sh, sclstr_downgraded("a0foo")), 2; is shash_length($sh, sclstr_upgraded("a0foo")), 2; is_dg shash_get($sh, sclstr_downgraded("a0foo")), "b0"; is_dg shash_get($sh, sclstr_upgraded("a0foo")), "b0"; shash_set($sh, sclstr_upgraded("a1foo"), "b1"); is shash_exists($sh, sclstr_downgraded("a1foo")), !!1; is shash_exists($sh, sclstr_upgraded("a1foo")), !!1; is shash_length($sh, sclstr_downgraded("a1foo")), 2; is shash_length($sh, sclstr_upgraded("a1foo")), 2; is_dg shash_get($sh, sclstr_downgraded("a1foo")), "b1"; is_dg shash_get($sh, sclstr_upgraded("a1foo")), "b1"; shash_set($sh, sclstr_downgraded("a2\x{e9}foo"), "b2"); is shash_exists($sh, sclstr_downgraded("a2\x{e9}foo")), !!1; is shash_exists($sh, sclstr_upgraded("a2\x{e9}foo")), !!1; is shash_length($sh, sclstr_downgraded("a2\x{e9}foo")), 2; is shash_length($sh, sclstr_upgraded("a2\x{e9}foo")), 2; is_dg shash_get($sh, sclstr_downgraded("a2\x{e9}foo")), "b2"; is_dg shash_get($sh, sclstr_upgraded("a2\x{e9}foo")), "b2"; shash_set($sh, sclstr_upgraded("a3\x{e9}foo"), "b3"); is shash_exists($sh, sclstr_downgraded("a3\x{e9}foo")), !!1; is shash_exists($sh, sclstr_upgraded("a3\x{e9}foo")), !!1; is shash_length($sh, sclstr_downgraded("a3\x{e9}foo")), 2; is shash_length($sh, sclstr_upgraded("a3\x{e9}foo")), 2; is_dg shash_get($sh, sclstr_downgraded("a3\x{e9}foo")), "b3"; is_dg shash_get($sh, sclstr_upgraded("a3\x{e9}foo")), "b3"; eval { shash_set($sh, sclstr_upgraded("a4\x{2603}foo"), "b4") }; like $@, qr/\Akey is not an octet string at /; is eval { shash_exists($sh, sclstr_upgraded("a4\x{2603}foo")) }, undef; like $@, qr/\Akey is not an octet string at /; is eval { shash_length($sh, sclstr_upgraded("a4\x{2603}foo")) }, undef; like $@, qr/\Akey is not an octet string at /; is eval { shash_get($sh, sclstr_upgraded("a4\x{2603}foo")) }, undef; like $@, qr/\Akey is not an octet string at /; shash_set($sh, sclstr_downgraded("a5foo\x{0}"), "b5"); is shash_exists($sh, sclstr_downgraded("a5foo\x{0}")), !!1; is shash_exists($sh, sclstr_upgraded("a5foo\x{0}")), !!1; is shash_length($sh, sclstr_downgraded("a5foo\x{0}")), 2; is shash_length($sh, sclstr_upgraded("a5foo\x{0}")), 2; is_dg shash_get($sh, sclstr_downgraded("a5foo\x{0}")), "b5"; is_dg shash_get($sh, sclstr_upgraded("a5foo\x{0}")), "b5"; is shash_exists($sh, sclstr_downgraded("a5foo")), !!0; is shash_length($sh, sclstr_downgraded("a5foo")), undef; is shash_get($sh, sclstr_downgraded("a5foo")), undef; shash_set($sh, sclstr_upgraded("a6foo\x{0}"), "b6"); is shash_exists($sh, sclstr_downgraded("a6foo\x{0}")), !!1; is shash_exists($sh, sclstr_upgraded("a6foo\x{0}")), !!1; is shash_length($sh, sclstr_downgraded("a6foo\x{0}")), 2; is shash_length($sh, sclstr_upgraded("a6foo\x{0}")), 2; is_dg shash_get($sh, sclstr_downgraded("a6foo\x{0}")), "b6"; is_dg shash_get($sh, sclstr_upgraded("a6foo\x{0}")), "b6"; is shash_exists($sh, sclstr_downgraded("a6foo")), !!0; is shash_length($sh, sclstr_downgraded("a6foo")), undef; is shash_get($sh, sclstr_downgraded("a6foo")), undef; shash_set($sh, sclstr_downgraded("a7\x{0}foo"), "b7"); is shash_exists($sh, sclstr_downgraded("a7\x{0}foo")), !!1; is shash_exists($sh, sclstr_upgraded("a7\x{0}foo")), !!1; is shash_length($sh, sclstr_downgraded("a7\x{0}foo")), 2; is shash_length($sh, sclstr_upgraded("a7\x{0}foo")), 2; is_dg shash_get($sh, sclstr_downgraded("a7\x{0}foo")), "b7"; is_dg shash_get($sh, sclstr_upgraded("a7\x{0}foo")), "b7"; is shash_exists($sh, sclstr_downgraded("a7")), !!0; is shash_length($sh, sclstr_downgraded("a7")), undef; is shash_get($sh, sclstr_downgraded("a7")), undef; shash_set($sh, sclstr_upgraded("a8\x{0}foo"), "b8"); is shash_exists($sh, sclstr_downgraded("a8\x{0}foo")), !!1; is shash_exists($sh, sclstr_upgraded("a8\x{0}foo")), !!1; is shash_length($sh, sclstr_downgraded("a8\x{0}foo")), 2; is shash_length($sh, sclstr_upgraded("a8\x{0}foo")), 2; is_dg shash_get($sh, sclstr_downgraded("a8\x{0}foo")), "b8"; is_dg shash_get($sh, sclstr_upgraded("a8\x{0}foo")), "b8"; is shash_exists($sh, sclstr_downgraded("a8")), !!0; is shash_length($sh, sclstr_downgraded("a8")), undef; is shash_get($sh, sclstr_downgraded("a8")), undef; is_deeply shash_keys_array($sh), [ "a0foo", "a1foo", "a2\x{e9}foo", "a3\x{e9}foo", "a5foo\x{0}", "a6foo\x{0}", "a7\x{0}foo", "a8\x{0}foo", ]; is_deeply shash_keys_hash($sh), { map { (sclstr_downgraded($_) => undef) } "a0foo", "a1foo", "a2\x{e9}foo", "a3\x{e9}foo", "a5foo\x{0}", "a6foo\x{0}", "a7\x{0}foo", "a8\x{0}foo", }; is_deeply shash_group_get_hash($sh), { "a0foo" => "b0", "a1foo" => "b1", sclstr_downgraded("a2\x{e9}foo") => "b2", sclstr_downgraded("a3\x{e9}foo") => "b3", sclstr_downgraded("a5foo\x{0}") => "b5", sclstr_downgraded("a6foo\x{0}") => "b6", sclstr_downgraded("a7\x{0}foo") => "b7", sclstr_downgraded("a8\x{0}foo") => "b8", }; is shash_exists($sh, sclstr_downgraded("e0foo")), !!0; is shash_exists($sh, sclstr_upgraded("e0foo")), !!0; is shash_length($sh, sclstr_downgraded("e0foo")), undef; is shash_length($sh, sclstr_upgraded("e0foo")), undef; is shash_get($sh, sclstr_downgraded("e0foo")), undef; is shash_get($sh, sclstr_upgraded("e0foo")), undef; is shash_exists($sh, sclstr_downgraded("e1\x{e9}foo")), !!0; is shash_exists($sh, sclstr_upgraded("e1\x{e9}foo")), !!0; is shash_length($sh, sclstr_downgraded("e1\x{e9}foo")), undef; is shash_length($sh, sclstr_upgraded("e1\x{e9}foo")), undef; is shash_get($sh, sclstr_downgraded("e1\x{e9}foo")), undef; is shash_get($sh, sclstr_upgraded("e1\x{e9}foo")), undef; is eval { shash_exists($sh, sclstr_upgraded("e2\x{2603}foo")) }, undef; like $@, qr/\Akey is not an octet string at /; is eval { shash_length($sh, sclstr_upgraded("e2\x{2603}foo")) }, undef; like $@, qr/\Akey is not an octet string at /; is eval { shash_get($sh, sclstr_upgraded("e2\x{2603}foo")) }, undef; like $@, qr/\Akey is not an octet string at /; is shash_exists($sh, sclstr_downgraded("e3foo\x{0}")), !!0; is shash_exists($sh, sclstr_upgraded("e3foo\x{0}")), !!0; is shash_length($sh, sclstr_downgraded("e3foo\x{0}")), undef; is shash_length($sh, sclstr_upgraded("e3foo\x{0}")), undef; is shash_get($sh, sclstr_downgraded("e3foo\x{0}")), undef; is shash_get($sh, sclstr_upgraded("e3foo\x{0}")), undef; is shash_exists($sh, sclstr_downgraded("e4\x{0}foo")), !!0; is shash_exists($sh, sclstr_upgraded("e4\x{0}foo")), !!0; is shash_length($sh, sclstr_downgraded("e4\x{0}foo")), undef; is shash_length($sh, sclstr_upgraded("e4\x{0}foo")), undef; is shash_get($sh, sclstr_downgraded("e4\x{0}foo")), undef; is shash_get($sh, sclstr_upgraded("e4\x{0}foo")), undef; shash_set($sh, "c0", sclstr_downgraded("d0foo")); is shash_exists($sh, "c0"), !!1; is shash_length($sh, "c0"), 5; is_dg shash_get($sh, "c0"), "d0foo"; shash_set($sh, "c1", sclstr_upgraded("d1foo")); is shash_exists($sh, "c1"), !!1; is shash_length($sh, "c1"), 5; is_dg shash_get($sh, "c1"), "d1foo"; shash_set($sh, "c2", sclstr_downgraded("d2\x{e9}foo")); is shash_exists($sh, "c2"), !!1; is shash_length($sh, "c2"), 6; is_dg shash_get($sh, "c2"), "d2\x{e9}foo"; shash_set($sh, "c3", sclstr_upgraded("d3\x{e9}foo")); is shash_exists($sh, "c3"), !!1; is shash_length($sh, "c3"), 6; is_dg shash_get($sh, "c3"), "d3\x{e9}foo"; eval { shash_set($sh, "c4", sclstr_upgraded("d4\x{2603}foo")) }; like $@, qr/\Anew value is neither an octet string nor undef at /; is eval { shash_exists($sh, "c4") }, !!0; is $@, ""; is eval { shash_length($sh, "c4") }, undef; is $@, ""; is eval { shash_get($sh, "c4") }, undef; is $@, ""; shash_set($sh, "c5", sclstr_downgraded("d5foo\x{0}")); is shash_exists($sh, "c5"), !!1; is shash_length($sh, "c5"), 6; is_dg shash_get($sh, "c5"), "d5foo\x{0}"; shash_set($sh, "c6", sclstr_upgraded("d6foo\x{0}")); is shash_exists($sh, "c6"), !!1; is shash_length($sh, "c6"), 6; is_dg shash_get($sh, "c6"), "d6foo\x{0}"; shash_set($sh, "c7", sclstr_downgraded("d7\x{0}foo")); is shash_exists($sh, "c7"), !!1; is shash_length($sh, "c7"), 6; is_dg shash_get($sh, "c7"), "d7\x{0}foo"; shash_set($sh, "c8", sclstr_upgraded("d8\x{0}foo")); is shash_exists($sh, "c8"), !!1; is shash_length($sh, "c8"), 6; is_dg shash_get($sh, "c8"), "d8\x{0}foo"; is_deeply shash_group_get_hash($sh), { "a0foo" => "b0", "a1foo" => "b1", sclstr_downgraded("a2\x{e9}foo") => "b2", sclstr_downgraded("a3\x{e9}foo") => "b3", sclstr_downgraded("a5foo\x{0}") => "b5", sclstr_downgraded("a6foo\x{0}") => "b6", sclstr_downgraded("a7\x{0}foo") => "b7", sclstr_downgraded("a8\x{0}foo") => "b8", "c0" => "d0foo", "c1" => "d1foo", "c2" => "d2\x{e9}foo", "c3" => "d3\x{e9}foo", "c5" => "d5foo\x{0}", "c6" => "d6foo\x{0}", "c7" => "d7\x{0}foo", "c8" => "d8\x{0}foo", }; is shash_gset($sh, sclstr_downgraded("f0foo"), undef), undef; is shash_get($sh, sclstr_downgraded("f0foo")), undef; is shash_gset($sh, sclstr_downgraded("f0foo"), "g0a"), undef; is_dg shash_get($sh, sclstr_downgraded("f0foo")), "g0a"; is_dg shash_gset($sh, sclstr_downgraded("f0foo"), "g0b"), "g0a"; is_dg shash_get($sh, sclstr_downgraded("f0foo")), "g0b"; is_dg shash_gset($sh, sclstr_downgraded("f0foo"), undef), "g0b"; is shash_get($sh, sclstr_downgraded("f0foo")), undef; is shash_gset($sh, sclstr_upgraded("f1foo"), undef), undef; is shash_get($sh, sclstr_downgraded("f1foo")), undef; is shash_gset($sh, sclstr_upgraded("f1foo"), "g1a"), undef; is_dg shash_get($sh, sclstr_downgraded("f1foo")), "g1a"; is_dg shash_gset($sh, sclstr_downgraded("f1foo"), "g1b"), "g1a"; is_dg shash_get($sh, sclstr_downgraded("f1foo")), "g1b"; is_dg shash_gset($sh, sclstr_upgraded("f1foo"), "g1c"), "g1b"; is_dg shash_get($sh, sclstr_downgraded("f1foo")), "g1c"; is_dg shash_gset($sh, sclstr_upgraded("f1foo"), "g1d"), "g1c"; is_dg shash_get($sh, sclstr_downgraded("f1foo")), "g1d"; is_dg shash_gset($sh, sclstr_upgraded("f1foo"), undef), "g1d"; is shash_gset($sh, sclstr_downgraded("f2\x{e9}foo"), undef), undef; is shash_get($sh, sclstr_downgraded("f2\x{e9}foo")), undef; is shash_gset($sh, sclstr_downgraded("f2\x{e9}foo"), "g2a"), undef; is_dg shash_get($sh, sclstr_downgraded("f2\x{e9}foo")), "g2a"; is_dg shash_gset($sh, sclstr_downgraded("f2\x{e9}foo"), "g2b"), "g2a"; is_dg shash_get($sh, sclstr_downgraded("f2\x{e9}foo")), "g2b"; is_dg shash_gset($sh, sclstr_downgraded("f2\x{e9}foo"), undef), "g2b"; is shash_get($sh, sclstr_downgraded("f2\x{e9}foo")), undef; is shash_gset($sh, sclstr_upgraded("f3\x{e9}foo"), undef), undef; is shash_get($sh, sclstr_downgraded("f3\x{e9}foo")), undef; is shash_gset($sh, sclstr_upgraded("f3\x{e9}foo"), "g3a"), undef; is_dg shash_get($sh, sclstr_downgraded("f3\x{e9}foo")), "g3a"; is_dg shash_gset($sh, sclstr_downgraded("f3\x{e9}foo"), "g3b"), "g3a"; is_dg shash_get($sh, sclstr_downgraded("f3\x{e9}foo")), "g3b"; is_dg shash_gset($sh, sclstr_upgraded("f3\x{e9}foo"), "g3c"), "g3b"; is_dg shash_get($sh, sclstr_downgraded("f3\x{e9}foo")), "g3c"; is_dg shash_gset($sh, sclstr_upgraded("f3\x{e9}foo"), "g3d"), "g3c"; is_dg shash_get($sh, sclstr_downgraded("f3\x{e9}foo")), "g3d"; is_dg shash_gset($sh, sclstr_upgraded("f3\x{e9}foo"), undef), "g3d"; is eval { shash_gset($sh, sclstr_upgraded("f4\x{2603}foo"), undef) }, undef; like $@, qr/\Akey is not an octet string at /; is eval { shash_gset($sh, sclstr_upgraded("f4\x{2603}foo"), "g4a") }, undef; like $@, qr/\Akey is not an octet string at /; is shash_gset($sh, "h0", sclstr_downgraded("i0afoo")), undef; is_dg shash_get($sh, "h0"), "i0afoo"; is_dg shash_gset($sh, "h0", sclstr_downgraded("i0bfoo")), "i0afoo"; is_dg shash_get($sh, "h0"), "i0bfoo"; is_dg shash_gset($sh, "h0", undef), "i0bfoo"; is shash_get($sh, "h0"), undef; is shash_gset($sh, "h1", sclstr_upgraded("i1afoo")), undef; is_dg shash_get($sh, "h1"), "i1afoo"; is_dg shash_gset($sh, "h1", sclstr_downgraded("i1bfoo")), "i1afoo"; is_dg shash_get($sh, "h1"), "i1bfoo"; is_dg shash_gset($sh, "h1", sclstr_upgraded("i1cfoo")), "i1bfoo"; is_dg shash_get($sh, "h1"), "i1cfoo"; is_dg shash_gset($sh, "h1", sclstr_upgraded("i1dfoo")), "i1cfoo"; is_dg shash_get($sh, "h1"), "i1dfoo"; is_dg shash_gset($sh, "h1", undef), "i1dfoo"; is shash_get($sh, "h1"), undef; is shash_gset($sh, "h2", sclstr_downgraded("i2a\x{e9}foo")), undef; is_dg shash_get($sh, "h2"), "i2a\x{e9}foo"; is_dg shash_gset($sh, "h2", sclstr_downgraded("i2b\x{e9}foo")), "i2a\x{e9}foo"; is_dg shash_get($sh, "h2"), "i2b\x{e9}foo"; is_dg shash_gset($sh, "h2", undef), "i2b\x{e9}foo"; is shash_get($sh, "h2"), undef; is shash_gset($sh, "h3", sclstr_upgraded("i3a\x{e9}foo")), undef; is_dg shash_get($sh, "h3"), "i3a\x{e9}foo"; is_dg shash_gset($sh, "h3", sclstr_downgraded("i3b\x{e9}foo")), "i3a\x{e9}foo"; is_dg shash_get($sh, "h3"), "i3b\x{e9}foo"; is_dg shash_gset($sh, "h3", sclstr_upgraded("i3c\x{e9}foo")), "i3b\x{e9}foo"; is_dg shash_get($sh, "h3"), "i3c\x{e9}foo"; is_dg shash_gset($sh, "h3", sclstr_upgraded("i3d\x{e9}foo")), "i3c\x{e9}foo"; is_dg shash_get($sh, "h3"), "i3d\x{e9}foo"; is_dg shash_gset($sh, "h3", undef), "i3d\x{e9}foo"; is shash_get($sh, "h3"), undef; is eval { shash_gset($sh, "h4", sclstr_upgraded("i4a\x{2603}foo")) }, undef; like $@, qr/\Anew value is neither an octet string nor undef at /; is shash_get($sh, "h4"), undef; is shash_gset($sh, "h4", "i4bfoo"), undef; is eval { shash_gset($sh, "h4", sclstr_upgraded("i4c\x{2603}foo")) }, undef; like $@, qr/\Anew value is neither an octet string nor undef at /; is_dg shash_get($sh, "h4"), "i4bfoo"; shash_set($sh, "h5", "i5a\x{0}"); is shash_cset($sh, "h5", "i5a", "i5b"), !!0; is shash_get($sh, "h5"), "i5a\x{0}"; is shash_cset($sh, "h5", "i5a\x{0}", "i5c"), !!1; is shash_get($sh, "h5"), "i5c"; is shash_cset($sh, "h5", "i5c\x{0}", "i5d"), !!0; is shash_get($sh, "h5"), "i5c"; is shash_cset($sh, "h5", "i5c", "i5e\x{0}"), !!1; is shash_get($sh, "h5"), "i5e\x{0}"; is shash_cset($sh, sclstr_downgraded("j0foo"), undef, undef), !!1; is shash_get($sh, sclstr_downgraded("j0foo")), undef; is shash_cset($sh, sclstr_downgraded("j0foo"), "k0a", undef), !!0; is shash_get($sh, sclstr_downgraded("j0foo")), undef; is shash_cset($sh, sclstr_downgraded("j0foo"), "k0b", "k0c"), !!0; is shash_get($sh, sclstr_downgraded("j0foo")), undef; is shash_cset($sh, sclstr_downgraded("j0foo"), undef, "k0d"), !!1; is_dg shash_get($sh, sclstr_downgraded("j0foo")), "k0d"; is shash_cset($sh, sclstr_downgraded("j0foo"), undef, undef), !!0; is_dg shash_get($sh, sclstr_downgraded("j0foo")), "k0d"; is shash_cset($sh, sclstr_downgraded("j0foo"), undef, "k0e"), !!0; is_dg shash_get($sh, sclstr_downgraded("j0foo")), "k0d"; is shash_cset($sh, sclstr_downgraded("j0foo"), "k0f", undef), !!0; is_dg shash_get($sh, sclstr_downgraded("j0foo")), "k0d"; is shash_cset($sh, sclstr_downgraded("j0foo"), "k0f", "k0g"), !!0; is_dg shash_get($sh, sclstr_downgraded("j0foo")), "k0d"; is shash_cset($sh, sclstr_downgraded("j0foo"), "k0d", "k0h"), !!1; is_dg shash_get($sh, sclstr_downgraded("j0foo")), "k0h"; is shash_cset($sh, sclstr_downgraded("j0foo"), "k0h", undef), !!1; is shash_get($sh, sclstr_downgraded("j0foo")), undef; is shash_cset($sh, sclstr_upgraded("j1foo"), undef, undef), !!1; is shash_get($sh, sclstr_downgraded("j1foo")), undef; is shash_cset($sh, sclstr_upgraded("j1foo"), "k1a", undef), !!0; is shash_get($sh, sclstr_downgraded("j1foo")), undef; is shash_cset($sh, sclstr_upgraded("j1foo"), "k1b", "k1c"), !!0; is shash_get($sh, sclstr_downgraded("j1foo")), undef; is shash_cset($sh, sclstr_upgraded("j1foo"), undef, "k1d"), !!1; is_dg shash_get($sh, sclstr_downgraded("j1foo")), "k1d"; is shash_cset($sh, sclstr_upgraded("j1foo"), undef, undef), !!0; is_dg shash_get($sh, sclstr_downgraded("j1foo")), "k1d"; is shash_cset($sh, sclstr_upgraded("j1foo"), undef, "k1e"), !!0; is_dg shash_get($sh, sclstr_downgraded("j1foo")), "k1d"; is shash_cset($sh, sclstr_upgraded("j1foo"), "k1f", undef), !!0; is_dg shash_get($sh, sclstr_downgraded("j1foo")), "k1d"; is shash_cset($sh, sclstr_upgraded("j1foo"), "k1f", "k1g"), !!0; is_dg shash_get($sh, sclstr_downgraded("j1foo")), "k1d"; is shash_cset($sh, sclstr_upgraded("j1foo"), "k1d", "k1h"), !!1; is_dg shash_get($sh, sclstr_downgraded("j1foo")), "k1h"; is shash_cset($sh, sclstr_upgraded("j1foo"), "k1h", undef), !!1; is shash_get($sh, sclstr_downgraded("j1foo")), undef; is shash_cset($sh, sclstr_downgraded("j2\x{e9}foo"), undef, undef), !!1; is shash_get($sh, sclstr_downgraded("j2\x{e9}foo")), undef; is shash_cset($sh, sclstr_downgraded("j2\x{e9}foo"), "k2a", undef), !!0; is shash_get($sh, sclstr_downgraded("j2\x{e9}foo")), undef; is shash_cset($sh, sclstr_downgraded("j2\x{e9}foo"), "k2b", "k2c"), !!0; is shash_get($sh, sclstr_downgraded("j2\x{e9}foo")), undef; is shash_cset($sh, sclstr_downgraded("j2\x{e9}foo"), undef, "k2d"), !!1; is_dg shash_get($sh, sclstr_downgraded("j2\x{e9}foo")), "k2d"; is shash_cset($sh, sclstr_downgraded("j2\x{e9}foo"), undef, undef), !!0; is_dg shash_get($sh, sclstr_downgraded("j2\x{e9}foo")), "k2d"; is shash_cset($sh, sclstr_downgraded("j2\x{e9}foo"), undef, "k2e"), !!0; is_dg shash_get($sh, sclstr_downgraded("j2\x{e9}foo")), "k2d"; is shash_cset($sh, sclstr_downgraded("j2\x{e9}foo"), "k2f", undef), !!0; is_dg shash_get($sh, sclstr_downgraded("j2\x{e9}foo")), "k2d"; is shash_cset($sh, sclstr_downgraded("j2\x{e9}foo"), "k2f", "k2g"), !!0; is_dg shash_get($sh, sclstr_downgraded("j2\x{e9}foo")), "k2d"; is shash_cset($sh, sclstr_downgraded("j2\x{e9}foo"), "k2d", "k2h"), !!1; is_dg shash_get($sh, sclstr_downgraded("j2\x{e9}foo")), "k2h"; is shash_cset($sh, sclstr_downgraded("j2\x{e9}foo"), "k2h", undef), !!1; is shash_get($sh, sclstr_downgraded("j2\x{e9}foo")), undef; is shash_cset($sh, sclstr_upgraded("j3\x{e9}foo"), undef, undef), !!1; is shash_get($sh, sclstr_downgraded("j3\x{e9}foo")), undef; is shash_cset($sh, sclstr_upgraded("j3\x{e9}foo"), "k3a", undef), !!0; is shash_get($sh, sclstr_downgraded("j3\x{e9}foo")), undef; is shash_cset($sh, sclstr_upgraded("j3\x{e9}foo"), "k3b", "k3c"), !!0; is shash_get($sh, sclstr_downgraded("j3\x{e9}foo")), undef; is shash_cset($sh, sclstr_upgraded("j3\x{e9}foo"), undef, "k3d"), !!1; is_dg shash_get($sh, sclstr_downgraded("j3\x{e9}foo")), "k3d"; is shash_cset($sh, sclstr_upgraded("j3\x{e9}foo"), undef, undef), !!0; is_dg shash_get($sh, sclstr_downgraded("j3\x{e9}foo")), "k3d"; is shash_cset($sh, sclstr_upgraded("j3\x{e9}foo"), undef, "k3e"), !!0; is_dg shash_get($sh, sclstr_downgraded("j3\x{e9}foo")), "k3d"; is shash_cset($sh, sclstr_upgraded("j3\x{e9}foo"), "k3f", undef), !!0; is_dg shash_get($sh, sclstr_downgraded("j3\x{e9}foo")), "k3d"; is shash_cset($sh, sclstr_upgraded("j3\x{e9}foo"), "k3f", "k3g"), !!0; is_dg shash_get($sh, sclstr_downgraded("j3\x{e9}foo")), "k3d"; is shash_cset($sh, sclstr_upgraded("j3\x{e9}foo"), "k3d", "k3h"), !!1; is_dg shash_get($sh, sclstr_downgraded("j3\x{e9}foo")), "k3h"; is shash_cset($sh, sclstr_upgraded("j3\x{e9}foo"), "k3h", undef), !!1; is shash_get($sh, sclstr_downgraded("j3\x{e9}foo")), undef; is eval { shash_cset($sh, sclstr_upgraded("j4\x{2603}foo"), undef, undef) }, undef; like $@, qr/\Akey is not an octet string at /; is eval { shash_cset($sh, sclstr_upgraded("j4\x{2603}foo"), "k4a", undef) }, undef; like $@, qr/\Akey is not an octet string at /; is eval { shash_cset($sh, sclstr_upgraded("j4\x{2603}foo"), "k4b", "k4c") }, undef; like $@, qr/\Akey is not an octet string at /; is eval { shash_cset($sh, sclstr_upgraded("j4\x{2603}foo"), undef, "k4d") }, undef; like $@, qr/\Akey is not an octet string at /; is shash_cset($sh, "l0", undef, undef), !!1; is shash_get($sh, "l0"), undef; is shash_cset($sh, "l0", sclstr_downgraded("m0afoo"), undef), !!0; is shash_get($sh, "l0"), undef; is shash_cset($sh, "l0", sclstr_downgraded("m0bfoo"), sclstr_downgraded("m0cfoo")), !!0; is shash_get($sh, "l0"), undef; is shash_cset($sh, "l0", undef, sclstr_downgraded("m0dfoo")), !!1; is_dg shash_get($sh, "l0"), "m0dfoo"; is shash_cset($sh, "l0", undef, undef), !!0; is_dg shash_get($sh, "l0"), "m0dfoo"; is shash_cset($sh, "l0", undef, sclstr_downgraded("m0efoo")), !!0; is_dg shash_get($sh, "l0"), "m0dfoo"; is shash_cset($sh, "l0", sclstr_downgraded("m0ffoo"), undef), !!0; is_dg shash_get($sh, "l0"), "m0dfoo"; is shash_cset($sh, "l0", sclstr_downgraded("m0ffoo"), sclstr_downgraded("m0gfoo")), !!0; is_dg shash_get($sh, "l0"), "m0dfoo"; is shash_cset($sh, "l0", sclstr_downgraded("m0dfoo"), sclstr_downgraded("m0hfoo")), !!1; is_dg shash_get($sh, "l0"), "m0hfoo"; is shash_cset($sh, "l0", sclstr_downgraded("m0hfoo"), undef), !!1; is shash_get($sh, "l0"), undef; is shash_cset($sh, "l1", undef, undef), !!1; is shash_get($sh, "l1"), undef; is shash_cset($sh, "l1", sclstr_upgraded("m1afoo"), undef), !!0; is shash_get($sh, "l1"), undef; is shash_cset($sh, "l1", sclstr_upgraded("m1bfoo"), sclstr_upgraded("m1cfoo")), !!0; is shash_get($sh, "l1"), undef; is shash_cset($sh, "l1", undef, sclstr_upgraded("m1dfoo")), !!1; is_dg shash_get($sh, "l1"), "m1dfoo"; is shash_cset($sh, "l1", undef, undef), !!0; is_dg shash_get($sh, "l1"), "m1dfoo"; is shash_cset($sh, "l1", undef, sclstr_upgraded("m1efoo")), !!0; is_dg shash_get($sh, "l1"), "m1dfoo"; is shash_cset($sh, "l1", sclstr_upgraded("m1ffoo"), undef), !!0; is_dg shash_get($sh, "l1"), "m1dfoo"; is shash_cset($sh, "l1", sclstr_upgraded("m1ffoo"), sclstr_upgraded("m1gfoo")), !!0; is_dg shash_get($sh, "l1"), "m1dfoo"; is shash_cset($sh, "l1", sclstr_upgraded("m1dfoo"), sclstr_upgraded("m1hfoo")), !!1; is_dg shash_get($sh, "l1"), "m1hfoo"; is shash_cset($sh, "l1", sclstr_upgraded("m1hfoo"), undef), !!1; is shash_get($sh, "l1"), undef; is shash_cset($sh, "l2", undef, undef), !!1; is shash_get($sh, "l2"), undef; is shash_cset($sh, "l2", sclstr_downgraded("m2a\x{e9}foo"), undef), !!0; is shash_get($sh, "l2"), undef; is shash_cset($sh, "l2", sclstr_downgraded("m2b\x{e9}foo"), sclstr_downgraded("m2c\x{e9}foo")), !!0; is shash_get($sh, "l2"), undef; is shash_cset($sh, "l2", undef, sclstr_downgraded("m2d\x{e9}foo")), !!1; is_dg shash_get($sh, "l2"), "m2d\x{e9}foo"; is shash_cset($sh, "l2", undef, undef), !!0; is_dg shash_get($sh, "l2"), "m2d\x{e9}foo"; is shash_cset($sh, "l2", undef, sclstr_downgraded("m2e\x{e9}foo")), !!0; is_dg shash_get($sh, "l2"), "m2d\x{e9}foo"; is shash_cset($sh, "l2", sclstr_downgraded("m2f\x{e9}foo"), undef), !!0; is_dg shash_get($sh, "l2"), "m2d\x{e9}foo"; is shash_cset($sh, "l2", sclstr_downgraded("m2f\x{e9}foo"), sclstr_downgraded("m2g\x{e9}foo")), !!0; is_dg shash_get($sh, "l2"), "m2d\x{e9}foo"; is shash_cset($sh, "l2", sclstr_downgraded("m2d\x{e9}foo"), sclstr_downgraded("m2h\x{e9}foo")), !!1; is_dg shash_get($sh, "l2"), "m2h\x{e9}foo"; is shash_cset($sh, "l2", sclstr_downgraded("m2h\x{e9}foo"), undef), !!1; is shash_get($sh, "l2"), undef; is shash_cset($sh, "l3", undef, undef), !!1; is shash_get($sh, "l3"), undef; is shash_cset($sh, "l3", sclstr_upgraded("m3a\x{e9}foo"), undef), !!0; is shash_get($sh, "l3"), undef; is shash_cset($sh, "l3", sclstr_upgraded("m3b\x{e9}foo"), sclstr_upgraded("m3c\x{e9}foo")), !!0; is shash_get($sh, "l3"), undef; is shash_cset($sh, "l3", undef, sclstr_upgraded("m3d\x{e9}foo")), !!1; is_dg shash_get($sh, "l3"), "m3d\x{e9}foo"; is shash_cset($sh, "l3", undef, undef), !!0; is_dg shash_get($sh, "l3"), "m3d\x{e9}foo"; is shash_cset($sh, "l3", undef, sclstr_upgraded("m3e\x{e9}foo")), !!0; is_dg shash_get($sh, "l3"), "m3d\x{e9}foo"; is shash_cset($sh, "l3", sclstr_upgraded("m3f\x{e9}foo"), undef), !!0; is_dg shash_get($sh, "l3"), "m3d\x{e9}foo"; is shash_cset($sh, "l3", sclstr_upgraded("m3f\x{e9}foo"), sclstr_upgraded("m3g\x{e9}foo")), !!0; is_dg shash_get($sh, "l3"), "m3d\x{e9}foo"; is shash_cset($sh, "l3", sclstr_upgraded("m3d\x{e9}foo"), sclstr_upgraded("m3h\x{e9}foo")), !!1; is_dg shash_get($sh, "l3"), "m3h\x{e9}foo"; is shash_cset($sh, "l3", sclstr_upgraded("m3h\x{e9}foo"), undef), !!1; is shash_get($sh, "l3"), undef; is eval { shash_cset($sh, "l4", undef, sclstr_upgraded("m4a\x{2603}foo")) }, undef; like $@, qr/\Anew value is neither an octet string nor undef at /; is shash_get($sh, "l4"), undef; is eval { shash_cset($sh, "l4", "m4bfoo", sclstr_upgraded("m4c\x{2603}foo")) }, undef; like $@, qr/\Anew value is neither an octet string nor undef at /; is shash_get($sh, "l4"), undef; is shash_cset($sh, "l4", undef, "m4dfoo"), !!1; is shash_get($sh, "l4"), "m4dfoo"; is eval { shash_cset($sh, "l4", undef, sclstr_upgraded("m4e\x{2603}foo")) }, undef; like $@, qr/\Anew value is neither an octet string nor undef at /; is shash_get($sh, "l4"), "m4dfoo"; is eval { shash_cset($sh, "l4", "m4ffoo", sclstr_upgraded("m4g\x{2603}foo")) }, undef; like $@, qr/\Anew value is neither an octet string nor undef at /; is shash_get($sh, "l4"), "m4dfoo"; is eval { shash_cset($sh, "l4", "m4dfoo", sclstr_upgraded("m4h\x{2603}foo")) }, undef; like $@, qr/\Anew value is neither an octet string nor undef at /; is shash_get($sh, "l4"), "m4dfoo"; shash_set($sh, sclstr_downgraded("-u9foo"), "v9"); is_dg shash_key_min($sh), "-u9foo"; shash_set($sh, sclstr_upgraded("-u8foo"), "v8"); is_dg shash_key_min($sh), "-u8foo"; shash_set($sh, sclstr_downgraded("-u7\x{e9}foo"), "v7"); is_dg shash_key_min($sh), "-u7\x{e9}foo"; shash_set($sh, sclstr_upgraded("-u6\x{e9}foo"), "v6"); is_dg shash_key_min($sh), "-u6\x{e9}foo"; shash_set($sh, sclstr_downgraded("~u0foo"), "v0"); is_dg shash_key_max($sh), "~u0foo"; shash_set($sh, sclstr_upgraded("~u1foo"), "v1"); is_dg shash_key_max($sh), "~u1foo"; shash_set($sh, sclstr_downgraded("~u2\x{e9}foo"), "v2"); is_dg shash_key_max($sh), "~u2\x{e9}foo"; shash_set($sh, sclstr_upgraded("~u3\x{e9}foo"), "v3"); is_dg shash_key_max($sh), "~u3\x{e9}foo"; is_dg shash_key_ge($sh, "~u0"), "~u0foo"; is_dg shash_key_ge($sh, "~u1"), "~u1foo"; is_dg shash_key_ge($sh, "~u2"), "~u2\x{e9}foo"; is_dg shash_key_ge($sh, "~u3"), "~u3\x{e9}foo"; is_dg shash_key_gt($sh, "~u0"), "~u0foo"; is_dg shash_key_gt($sh, "~u1"), "~u1foo"; is_dg shash_key_gt($sh, "~u2"), "~u2\x{e9}foo"; is_dg shash_key_gt($sh, "~u3"), "~u3\x{e9}foo"; is_dg shash_key_le($sh, "~u1"), "~u0foo"; is_dg shash_key_le($sh, "~u2"), "~u1foo"; is_dg shash_key_le($sh, "~u3"), "~u2\x{e9}foo"; is_dg shash_key_le($sh, "~u4"), "~u3\x{e9}foo"; is_dg shash_key_lt($sh, "~u1"), "~u0foo"; is_dg shash_key_lt($sh, "~u2"), "~u1foo"; is_dg shash_key_lt($sh, "~u3"), "~u2\x{e9}foo"; is_dg shash_key_lt($sh, "~u4"), "~u3\x{e9}foo"; require_ok "Hash::SharedMem::Handle"; my %sh; tie %sh, "Hash::SharedMem::Handle", $sh; ok is_shash(tied(%sh)); ok tied(%sh) == $sh; $sh{sclstr_downgraded("n0foo")} = "o0"; is exists($sh{sclstr_downgraded("n0foo")}), !!1; is exists($sh{sclstr_upgraded("n0foo")}), !!1; is_dg $sh{sclstr_downgraded("n0foo")}, "o0"; is_dg $sh{sclstr_upgraded("n0foo")}, "o0"; is_dg delete($sh{sclstr_downgraded("n0foo")}), "o0"; is shash_exists($sh, sclstr_downgraded("n0foo")), !!0; is delete($sh{sclstr_downgraded("n0foo")}), undef; is shash_exists($sh, sclstr_downgraded("n0foo")), !!0; $sh{sclstr_upgraded("n1foo")} = "o1"; is exists($sh{sclstr_downgraded("n1foo")}), !!1; is exists($sh{sclstr_upgraded("n1foo")}), !!1; is_dg $sh{sclstr_downgraded("n1foo")}, "o1"; is_dg $sh{sclstr_upgraded("n1foo")}, "o1"; is_dg delete($sh{sclstr_upgraded("n1foo")}), "o1"; is shash_exists($sh, sclstr_downgraded("n1foo")), !!0; is delete($sh{sclstr_upgraded("n1foo")}), undef; is shash_exists($sh, sclstr_downgraded("n1foo")), !!0; $sh{sclstr_downgraded("n2\x{e9}foo")} = "o2"; is exists($sh{sclstr_downgraded("n2\x{e9}foo")}), !!1; is exists($sh{sclstr_upgraded("n2\x{e9}foo")}), !!1; is_dg $sh{sclstr_downgraded("n2\x{e9}foo")}, "o2"; is_dg $sh{sclstr_upgraded("n2\x{e9}foo")}, "o2"; is_dg delete($sh{sclstr_downgraded("n2\x{e9}foo")}), "o2"; is shash_exists($sh, sclstr_downgraded("n2\x{e9}foo")), !!0; is delete($sh{sclstr_downgraded("n2\x{e9}foo")}), undef; is shash_exists($sh, sclstr_downgraded("n2\x{e9}foo")), !!0; $sh{sclstr_upgraded("n3\x{e9}foo")} = "o3"; is exists($sh{sclstr_downgraded("n3\x{e9}foo")}), !!1; is exists($sh{sclstr_upgraded("n3\x{e9}foo")}), !!1; is_dg $sh{sclstr_downgraded("n3\x{e9}foo")}, "o3"; is_dg $sh{sclstr_upgraded("n3\x{e9}foo")}, "o3"; is_dg delete($sh{sclstr_upgraded("n3\x{e9}foo")}), "o3"; is shash_exists($sh, sclstr_downgraded("n3\x{e9}foo")), !!0; is delete($sh{sclstr_upgraded("n3\x{e9}foo")}), undef; is shash_exists($sh, sclstr_downgraded("n3\x{e9}foo")), !!0; eval { $sh{sclstr_upgraded("n4\x{2603}foo")} = "o4" }; like $@, qr/\Akey is not an octet string at /; is eval { delete($sh{sclstr_upgraded("n5\x{2603}foo")}) }, undef; like $@, qr/\Akey is not an octet string at /; is eval { exists($sh{sclstr_upgraded("n6\x{2603}foo")}) }, undef; like $@, qr/\Akey is not an octet string at /; is eval { $sh{sclstr_upgraded("n6\x{2603}foo")} }, undef; like $@, qr/\Akey is not an octet string at /; $sh{sclstr_downgraded("n5foo\x{0}")} = "o5"; is exists($sh{sclstr_downgraded("n5foo\x{0}")}), !!1; is exists($sh{sclstr_upgraded("n5foo\x{0}")}), !!1; is_dg $sh{sclstr_downgraded("n5foo\x{0}")}, "o5"; is_dg $sh{sclstr_upgraded("n5foo\x{0}")}, "o5"; is_dg delete($sh{sclstr_upgraded("n5foo\x{0}")}), "o5"; is shash_exists($sh, sclstr_downgraded("n5foo\x{0}")), !!0; is delete($sh{sclstr_upgraded("n5foo\x{0}")}), undef; is shash_exists($sh, sclstr_downgraded("n5foo\x{0}")), !!0; $sh{sclstr_upgraded("n6foo\x{0}")} = "o6"; is exists($sh{sclstr_downgraded("n6foo\x{0}")}), !!1; is exists($sh{sclstr_upgraded("n6foo\x{0}")}), !!1; is_dg $sh{sclstr_downgraded("n6foo\x{0}")}, "o6"; is_dg $sh{sclstr_upgraded("n6foo\x{0}")}, "o6"; is_dg delete($sh{sclstr_upgraded("n6foo\x{0}")}), "o6"; is shash_exists($sh, sclstr_downgraded("n6foo\x{0}")), !!0; is delete($sh{sclstr_upgraded("n6foo\x{0}")}), undef; is shash_exists($sh, sclstr_downgraded("n6foo\x{0}")), !!0; $sh{sclstr_downgraded("n7\x{0}foo")} = "o7"; is exists($sh{sclstr_downgraded("n7\x{0}foo")}), !!1; is exists($sh{sclstr_upgraded("n7\x{0}foo")}), !!1; is_dg $sh{sclstr_downgraded("n7\x{0}foo")}, "o7"; is_dg $sh{sclstr_upgraded("n7\x{0}foo")}, "o7"; is_dg delete($sh{sclstr_upgraded("n7\x{0}foo")}), "o7"; is shash_exists($sh, sclstr_downgraded("n7\x{0}foo")), !!0; is delete($sh{sclstr_upgraded("n7\x{0}foo")}), undef; is shash_exists($sh, sclstr_downgraded("n7\x{0}foo")), !!0; $sh{sclstr_upgraded("n8\x{0}foo")} = "o8"; is exists($sh{sclstr_downgraded("n8\x{0}foo")}), !!1; is exists($sh{sclstr_upgraded("n8\x{0}foo")}), !!1; is_dg $sh{sclstr_downgraded("n8\x{0}foo")}, "o8"; is_dg $sh{sclstr_upgraded("n8\x{0}foo")}, "o8"; is_dg delete($sh{sclstr_upgraded("n8\x{0}foo")}), "o8"; is shash_exists($sh, sclstr_downgraded("n8\x{0}foo")), !!0; is delete($sh{sclstr_upgraded("n8\x{0}foo")}), undef; is shash_exists($sh, sclstr_downgraded("n8\x{0}foo")), !!0; $sh{p0} = sclstr_downgraded("q0foo"); is_dg $sh{p0}, "q0foo"; $sh{p1} = sclstr_upgraded("q1foo"); is_dg $sh{p1}, "q1foo"; $sh{p2} = sclstr_downgraded("q2\x{e9}foo"); is_dg $sh{p2}, "q2\x{e9}foo"; $sh{p3} = sclstr_upgraded("q3\x{e9}foo"); is_dg $sh{p3}, "q3\x{e9}foo"; eval { $sh{p4} = sclstr_upgraded("q4\x{2603}foo") }; like $@, qr/\Anew value is not an octet string at /; is eval { $sh{p4} }, undef; is $@, ""; $sh{p5} = sclstr_downgraded("q5foo\x{0}"); is_dg $sh{p5}, "q5foo\x{0}"; $sh{p6} = sclstr_upgraded("q6foo\x{0}"); is_dg $sh{p6}, "q6foo\x{0}"; $sh{p7} = sclstr_downgraded("q7\x{0}foo"); is_dg $sh{p7}, "q7\x{0}foo"; $sh{p8} = sclstr_upgraded("q8\x{0}foo"); is_dg $sh{p8}, "q8\x{0}foo"; like $tmpdir, qr/\A[\x01-\x7f]+\z/; my $fn; use if "$]" < 5.008, "utf8"; $fn = sclstr_downgraded("$tmpdir/t1foo"); $sh = shash_open($fn, "wc"); ok -f sclstr_downgraded("$tmpdir/t1foo/iNmv0,m\$%3"); ok sclstr_is_downgraded($fn); is eval { shash_get($sh, "a0") }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t1foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_upgraded("$tmpdir/t2foo"); $sh = shash_open($fn, "wc"); ok -f sclstr_downgraded("$tmpdir/t2foo/iNmv0,m\$%3"); ok sclstr_is_upgraded($fn); is eval { shash_get($sh, "a0") }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t2foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_downgraded("$tmpdir/t3\x{e9}foo"); $sh = shash_open($fn, "wc"); ok -f sclstr_downgraded("$tmpdir/t3\x{e9}foo/iNmv0,m\$%3"); ok sclstr_is_downgraded($fn); is eval { shash_get($sh, "a0") }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t3\x{e9}foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_upgraded("$tmpdir/t4\x{e9}foo"); $sh = shash_open($fn, "wc"); ok -f sclstr_downgraded("$tmpdir/t4\x{c3}\x{a9}foo/iNmv0,m\$%3"); ok sclstr_is_upgraded($fn); is eval { shash_get($sh, "a0") }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t4\x{e9}foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_upgraded("$tmpdir/t5\x{2603}foo"); $sh = shash_open($fn, "wc"); ok -f sclstr_downgraded("$tmpdir/t5\x{e2}\x{98}\x{83}foo/iNmv0,m\$%3"); ok sclstr_is_upgraded($fn); is eval { shash_get($sh, "a0") }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t5\x{2603}foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_downgraded("$tmpdir/t6foo"); $sh = Hash::SharedMem::Handle->open($fn, "wc"); ok -f sclstr_downgraded("$tmpdir/t6foo/iNmv0,m\$%3"); ok sclstr_is_downgraded($fn); is eval { shash_get($sh, "a0") }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t6foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_upgraded("$tmpdir/t7foo"); $sh = Hash::SharedMem::Handle->open($fn, "wc"); ok -f sclstr_downgraded("$tmpdir/t7foo/iNmv0,m\$%3"); ok sclstr_is_upgraded($fn); is eval { shash_get($sh, "a0") }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t7foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_downgraded("$tmpdir/t8\x{e9}foo"); $sh = Hash::SharedMem::Handle->open($fn, "wc"); ok -f sclstr_downgraded("$tmpdir/t8\x{e9}foo/iNmv0,m\$%3"); ok sclstr_is_downgraded($fn); is eval { shash_get($sh, "a0") }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t8\x{e9}foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_upgraded("$tmpdir/t9\x{e9}foo"); $sh = Hash::SharedMem::Handle->open($fn, "wc"); ok -f sclstr_downgraded("$tmpdir/t9\x{c3}\x{a9}foo/iNmv0,m\$%3"); ok sclstr_is_upgraded($fn); is eval { shash_get($sh, "a0") }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t9\x{e9}foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_upgraded("$tmpdir/t10\x{2603}foo"); $sh = Hash::SharedMem::Handle->open($fn, "wc"); ok -f sclstr_downgraded("$tmpdir/t10\x{e2}\x{98}\x{83}foo/iNmv0,m\$%3"); ok sclstr_is_upgraded($fn); is eval { shash_get($sh, "a0") }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t10\x{2603}foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_downgraded("$tmpdir/t11foo"); tie %sh, "Hash::SharedMem::Handle", $fn, "wc"; ok -f sclstr_downgraded("$tmpdir/t11foo/iNmv0,m\$%3"); ok sclstr_is_downgraded($fn); is eval { $sh{a0} }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t11foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_upgraded("$tmpdir/t12foo"); tie %sh, "Hash::SharedMem::Handle", $fn, "wc"; ok -f sclstr_downgraded("$tmpdir/t12foo/iNmv0,m\$%3"); ok sclstr_is_upgraded($fn); is eval { $sh{a0} }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t12foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_downgraded("$tmpdir/t13\x{e9}foo"); tie %sh, "Hash::SharedMem::Handle", $fn, "wc"; ok -f sclstr_downgraded("$tmpdir/t13\x{e9}foo/iNmv0,m\$%3"); ok sclstr_is_downgraded($fn); is eval { $sh{a0} }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t13\x{e9}foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_upgraded("$tmpdir/t14\x{e9}foo"); tie %sh, "Hash::SharedMem::Handle", $fn, "wc"; ok -f sclstr_downgraded("$tmpdir/t14\x{c3}\x{a9}foo/iNmv0,m\$%3"); ok sclstr_is_upgraded($fn); is eval { $sh{a0} }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t14\x{e9}foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; $fn = sclstr_upgraded("$tmpdir/t15\x{2603}foo"); tie %sh, "Hash::SharedMem::Handle", $fn, "wc"; ok -f sclstr_downgraded("$tmpdir/t15\x{e2}\x{98}\x{83}foo/iNmv0,m\$%3"); ok sclstr_is_upgraded($fn); is eval { $sh{a0} }, undef; like sclstr_upgraded($@), qr#\Acan't\ read\ shared\ hash \ \Q$tmpdir\E/t15\x{2603}foo: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; 1; Hash-SharedMem-0.005/t/op.t000444001750001750 4573113143376054 15442 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 388; BEGIN { use_ok "Hash::SharedMem", qw( is_shash check_shash shash_open shash_is_readable shash_is_writable shash_mode shash_exists shash_getd shash_length shash_get shash_set shash_gset shash_cset shash_occupied shash_count shash_size shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash shash_snapshot shash_is_snapshot shash_idle shash_tidy shash_tally_get shash_tally_zero shash_tally_gzero ); } is scalar(is_shash("foo")), !!0; is_deeply [is_shash("foo")], [!!0]; eval { check_shash("foo") }; like $@, qr/\Ahandle is not a shared hash handle /; my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; is scalar(is_shash($sh)), !!1; is_deeply [is_shash($sh)], [!!1]; eval { check_shash($sh) }; is $@, ""; is scalar(check_shash($sh)), undef; is_deeply [check_shash($sh)], []; is scalar(shash_is_snapshot($sh)), !!0; is_deeply [shash_is_snapshot($sh)], [!!0]; is scalar(shash_is_readable($sh)), !!1; is_deeply [shash_is_readable($sh)], [!!1]; is scalar(shash_is_writable($sh)), !!1; is_deeply [shash_is_writable($sh)], [!!1]; is scalar(shash_mode($sh)), "rw"; is_deeply [shash_mode($sh)], ["rw"]; eval { ${\shash_mode($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar(shash_exists($sh, "a100")), !!0; is_deeply [shash_exists($sh, "a100")], [!!0]; is scalar(shash_getd($sh, "a100")), !!0; is_deeply [shash_getd($sh, "a100")], [!!0]; is scalar(shash_length($sh, "a100")), undef; is_deeply [shash_length($sh, "a100")], [undef]; is scalar(shash_get($sh, "a100")), undef; is_deeply [shash_get($sh, "a100")], [undef]; is scalar(shash_occupied($sh)), !!0; is_deeply [shash_occupied($sh)], [!!0]; is scalar(shash_count($sh)), 0; is_deeply [shash_count($sh)], [0]; eval { ${\shash_count($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; like scalar(shash_size($sh)), qr/\A[0-9]+\z/; like join(",", shash_size($sh)), qr/\A[0-9]+\z/; eval { ${\shash_size($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar(shash_key_min($sh)), undef; is_deeply [shash_key_min($sh)], [undef]; is scalar(shash_key_max($sh)), undef; is_deeply [shash_key_max($sh)], [undef]; is scalar(shash_key_ge($sh, "a110")), undef; is_deeply [shash_key_ge($sh, "a110")], [undef]; is scalar(shash_key_gt($sh, "a110")), undef; is_deeply [shash_key_gt($sh, "a110")], [undef]; is scalar(shash_key_le($sh, "a110")), undef; is_deeply [shash_key_le($sh, "a110")], [undef]; is scalar(shash_key_lt($sh, "a110")), undef; is_deeply [shash_key_lt($sh, "a110")], [undef]; is_deeply scalar(shash_keys_array($sh)), []; is_deeply [shash_keys_array($sh)], [[]]; eval { ${\shash_keys_array($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply scalar(shash_keys_hash($sh)), {}; is_deeply [shash_keys_hash($sh)], [{}]; eval { ${\shash_keys_hash($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply scalar(shash_group_get_hash($sh)), {}; is_deeply [shash_group_get_hash($sh)], [{}]; eval { ${\shash_group_get_hash($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; shash_set($sh, "a110", "b110"); is scalar(shash_set($sh, "a100", "b100")), undef; is_deeply [shash_set($sh, "a120", "b120")], []; is scalar(shash_exists($sh, "a100")), !!1; is_deeply [shash_exists($sh, "a100")], [!!1]; is scalar(shash_getd($sh, "a100")), !!1; is_deeply [shash_getd($sh, "a100")], [!!1]; is scalar(shash_length($sh, "a100")), 4; is_deeply [shash_length($sh, "a100")], [4]; eval { ${\shash_length($sh, "a100")} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar(shash_get($sh, "a100")), "b100"; is_deeply [shash_get($sh, "a100")], ["b100"]; is scalar(shash_occupied($sh)), !!1; is_deeply [shash_occupied($sh)], [!!1]; is scalar(shash_count($sh)), 3; is_deeply [shash_count($sh)], [3]; eval { ${\shash_count($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; like scalar(shash_size($sh)), qr/\A[0-9]+\z/; like join(",", shash_size($sh)), qr/\A[0-9]+\z/; eval { ${\shash_size($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar(shash_key_min($sh)), "a100"; is_deeply [shash_key_min($sh)], ["a100"]; is scalar(shash_key_max($sh)), "a120"; is_deeply [shash_key_max($sh)], ["a120"]; is scalar(shash_key_ge($sh, "a110")), "a110"; is_deeply [shash_key_ge($sh, "a110")], ["a110"]; is scalar(shash_key_gt($sh, "a110")), "a120"; is_deeply [shash_key_gt($sh, "a110")], ["a120"]; is scalar(shash_key_le($sh, "a110")), "a110"; is_deeply [shash_key_le($sh, "a110")], ["a110"]; is scalar(shash_key_lt($sh, "a110")), "a100"; is_deeply [shash_key_lt($sh, "a110")], ["a100"]; is_deeply scalar(shash_keys_array($sh)), [qw(a100 a110 a120)]; is_deeply [shash_keys_array($sh)], [[qw(a100 a110 a120)]]; eval { ${\shash_keys_array($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply scalar(shash_keys_hash($sh)), { a100=>undef, a110=>undef, a120=>undef }; is_deeply [shash_keys_hash($sh)], [{ a100=>undef, a110=>undef, a120=>undef }]; eval { ${\shash_keys_hash($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is_deeply scalar(shash_group_get_hash($sh)), { a100=>"b100", a110=>"b110", a120=>"b120" }; is_deeply [shash_group_get_hash($sh)], [{ a100=>"b100", a110=>"b110", a120=>"b120" }]; eval { ${\shash_group_get_hash($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; is scalar(shash_exists($sh, "a000")), !!0; is scalar(shash_length($sh, "a000")), undef; is scalar(shash_get($sh, "a000")), undef; is scalar(shash_exists($sh, "a105")), !!0; is scalar(shash_length($sh, "a105")), undef; is scalar(shash_get($sh, "a105")), undef; is scalar(shash_exists($sh, "a110")), !!1; is scalar(shash_length($sh, "a110")), 4; is scalar(shash_get($sh, "a110")), "b110"; is scalar(shash_exists($sh, "a115")), !!0; is scalar(shash_length($sh, "a115")), undef; is scalar(shash_get($sh, "a115")), undef; is scalar(shash_exists($sh, "a120")), !!1; is scalar(shash_length($sh, "a120")), 4; is scalar(shash_get($sh, "a120")), "b120"; is scalar(shash_exists($sh, "a130")), !!0; is scalar(shash_length($sh, "a130")), undef; is scalar(shash_get($sh, "a130")), undef; my $sn = shash_snapshot($sh); is scalar(is_shash($sn)), !!1; is_deeply [is_shash($sn)], [!!1]; eval { check_shash($sn) }; is $@, ""; is scalar(check_shash($sn)), undef; is_deeply [check_shash($sn)], []; is scalar(shash_is_snapshot($sn)), !!1; is_deeply [shash_is_snapshot($sn)], [!!1]; is scalar(shash_is_readable($sn)), !!1; is_deeply [shash_is_readable($sn)], [!!1]; is scalar(shash_is_writable($sn)), !!0; is_deeply [shash_is_writable($sn)], [!!0]; is scalar(shash_mode($sn)), "r"; is_deeply [shash_mode($sn)], ["r"]; is shash_exists($sn, "a000"), !!0; is shash_length($sn, "a000"), undef; is shash_get($sn, "a000"), undef; is shash_exists($sn, "a100"), !!1; is shash_length($sn, "a100"), 4; is shash_get($sn, "a100"), "b100"; is shash_exists($sn, "a105"), !!0; is shash_length($sn, "a105"), undef; is shash_get($sn, "a105"), undef; is shash_exists($sn, "a110"), !!1; is shash_length($sn, "a110"), 4; is shash_get($sn, "a110"), "b110"; is shash_exists($sn, "a115"), !!0; is shash_length($sn, "a115"), undef; is shash_get($sn, "a115"), undef; is shash_exists($sn, "a120"), !!1; is shash_length($sn, "a120"), 4; is shash_get($sn, "a120"), "b120"; is shash_exists($sn, "a130"), !!0; is shash_length($sn, "a130"), undef; is shash_get($sn, "a130"), undef; is shash_occupied($sn), !!1; is shash_count($sn), 3; is shash_key_min($sn), "a100"; is shash_key_max($sn), "a120"; is shash_key_ge($sn, "a110"), "a110"; is shash_key_gt($sn, "a110"), "a120"; is shash_key_le($sn, "a110"), "a110"; is shash_key_lt($sn, "a110"), "a100"; is_deeply shash_keys_array($sn), [qw(a100 a110 a120)]; is_deeply shash_keys_hash($sn), { a100=>undef, a110=>undef, a120=>undef }; is_deeply shash_group_get_hash($sn), { a100=>"b100", a110=>"b110", a120=>"b120" }; shash_set($sh, "a105", "b105"); shash_set($sh, "a110", undef); is shash_exists($sh, "a000"), !!0; is shash_length($sh, "a000"), undef; is shash_get($sh, "a000"), undef; is shash_exists($sh, "a100"), !!1; is shash_length($sh, "a100"), 4; is shash_get($sh, "a100"), "b100"; is shash_exists($sh, "a105"), !!1; is shash_length($sh, "a105"), 4; is shash_get($sh, "a105"), "b105"; is shash_exists($sh, "a110"), !!0; is shash_length($sh, "a110"), undef; is shash_get($sh, "a110"), undef; is shash_exists($sh, "a115"), !!0; is shash_length($sh, "a115"), undef; is shash_get($sh, "a115"), undef; is shash_exists($sh, "a120"), !!1; is shash_length($sh, "a120"), 4; is shash_get($sh, "a120"), "b120"; is shash_exists($sh, "a130"), !!0; is shash_length($sh, "a130"), undef; is shash_get($sh, "a130"), undef; is shash_occupied($sh), !!1; is shash_count($sh), 3; is shash_key_min($sh), "a100"; is shash_key_max($sh), "a120"; is shash_key_ge($sh, "a110"), "a120"; is shash_key_gt($sh, "a110"), "a120"; is shash_key_le($sh, "a110"), "a105"; is shash_key_lt($sh, "a110"), "a105"; is_deeply shash_keys_array($sh), [qw(a100 a105 a120)]; is_deeply shash_keys_hash($sh), { a100=>undef, a105=>undef, a120=>undef }; is_deeply shash_group_get_hash($sh), { a100=>"b100", a105=>"b105", a120=>"b120" }; is shash_exists($sn, "a000"), !!0; is shash_length($sn, "a000"), undef; is shash_get($sn, "a000"), undef; is shash_exists($sn, "a100"), !!1; is shash_length($sn, "a100"), 4; is shash_get($sn, "a100"), "b100"; is shash_exists($sn, "a105"), !!0; is shash_length($sn, "a105"), undef; is shash_get($sn, "a105"), undef; is shash_exists($sn, "a110"), !!1; is shash_length($sn, "a110"), 4; is shash_get($sn, "a110"), "b110"; is shash_exists($sn, "a115"), !!0; is shash_length($sn, "a115"), undef; is shash_get($sn, "a115"), undef; is shash_exists($sn, "a120"), !!1; is shash_length($sn, "a120"), 4; is shash_get($sn, "a120"), "b120"; is shash_exists($sn, "a130"), !!0; is shash_length($sn, "a130"), undef; is shash_get($sn, "a130"), undef; is shash_occupied($sn), !!1; is shash_count($sn), 3; is shash_key_min($sn), "a100"; is shash_key_max($sn), "a120"; is shash_key_ge($sn, "a110"), "a110"; is shash_key_gt($sn, "a110"), "a120"; is shash_key_le($sn, "a110"), "a110"; is shash_key_lt($sn, "a110"), "a100"; is_deeply shash_keys_array($sn), [qw(a100 a110 a120)]; is_deeply shash_keys_hash($sn), { a100=>undef, a110=>undef, a120=>undef }; is_deeply shash_group_get_hash($sn), { a100=>"b100", a110=>"b110", a120=>"b120" }; eval { shash_set($sn, "a115", "b115") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ handle\ is\ a\ snapshot\ #x; is shash_exists($sh, "a115"), !!0; is shash_length($sh, "a115"), undef; is shash_get($sh, "a115"), undef; is shash_occupied($sh), !!1; is shash_count($sh), 3; is shash_key_min($sh), "a100"; is shash_key_max($sh), "a120"; is shash_key_ge($sh, "a110"), "a120"; is shash_key_gt($sh, "a110"), "a120"; is shash_key_le($sh, "a110"), "a105"; is shash_key_lt($sh, "a110"), "a105"; is_deeply shash_keys_array($sh), [qw(a100 a105 a120)]; is_deeply shash_keys_hash($sh), { a100=>undef, a105=>undef, a120=>undef }; is_deeply shash_group_get_hash($sh), { a100=>"b100", a105=>"b105", a120=>"b120" }; is shash_exists($sn, "a115"), !!0; is shash_length($sn, "a115"), undef; is shash_get($sn, "a115"), undef; is shash_occupied($sn), !!1; is shash_count($sn), 3; is shash_key_min($sn), "a100"; is shash_key_max($sn), "a120"; is shash_key_ge($sn, "a110"), "a110"; is shash_key_gt($sn, "a110"), "a120"; is shash_key_le($sn, "a110"), "a110"; is shash_key_lt($sn, "a110"), "a100"; is_deeply shash_keys_array($sn), [qw(a100 a110 a120)]; is_deeply shash_keys_hash($sn), { a100=>undef, a110=>undef, a120=>undef }; is_deeply shash_group_get_hash($sn), { a100=>"b100", a110=>"b110", a120=>"b120" }; shash_gset($sh, "a115", "c115"); is shash_get($sh, "a115"), "c115"; shash_gset($sh, "a115", "d115"); is shash_get($sh, "a115"), "d115"; shash_gset($sh, "a115", "d115"); is shash_get($sh, "a115"), "d115"; shash_gset($sh, "a115", undef); is shash_get($sh, "a115"), undef; shash_gset($sh, "a115", undef); is shash_get($sh, "a115"), undef; is scalar(shash_gset($sh, "a115", "e115")), undef; is shash_get($sh, "a115"), "e115"; is scalar(shash_gset($sh, "a115", "f115")), "e115"; is shash_get($sh, "a115"), "f115"; is scalar(shash_gset($sh, "a115", "f115")), "f115"; is shash_get($sh, "a115"), "f115"; is scalar(shash_gset($sh, "a115", undef)), "f115"; is shash_get($sh, "a115"), undef; is scalar(shash_gset($sh, "a115", undef)), undef; is shash_get($sh, "a115"), undef; is_deeply [shash_gset($sh, "a115", "g115")], [undef]; is shash_get($sh, "a115"), "g115"; is_deeply [shash_gset($sh, "a115", "h115")], ["g115"]; is shash_get($sh, "a115"), "h115"; is_deeply [shash_gset($sh, "a115", "h115")], ["h115"]; is shash_get($sh, "a115"), "h115"; is_deeply [shash_gset($sh, "a115", undef)], ["h115"]; is shash_get($sh, "a115"), undef; is_deeply [shash_gset($sh, "a115", undef)], [undef]; is shash_get($sh, "a115"), undef; shash_cset($sh, "a115", "z", "i115"); is shash_get($sh, "a115"), undef; shash_cset($sh, "a115", undef, "j115"); is shash_get($sh, "a115"), "j115"; shash_cset($sh, "a115", "z", "k115"); is shash_get($sh, "a115"), "j115"; shash_cset($sh, "a115", undef, "l115"); is shash_get($sh, "a115"), "j115"; shash_cset($sh, "a115", "j115", "m115"); is shash_get($sh, "a115"), "m115"; shash_cset($sh, "a115", "z", "m115"); is shash_get($sh, "a115"), "m115"; shash_cset($sh, "a115", undef, "m115"); is shash_get($sh, "a115"), "m115"; shash_cset($sh, "a115", "m115", "m115"); is shash_get($sh, "a115"), "m115"; shash_cset($sh, "a115", "z", undef); is shash_get($sh, "a115"), "m115"; shash_cset($sh, "a115", undef, undef); is shash_get($sh, "a115"), "m115"; shash_cset($sh, "a115", "m115", undef); is shash_get($sh, "a115"), undef; shash_cset($sh, "a115", "z", undef); is shash_get($sh, "a115"), undef; shash_cset($sh, "a115", undef, undef); is shash_get($sh, "a115"), undef; is scalar(shash_cset($sh, "a115", "z", "i115")), !!0; is shash_get($sh, "a115"), undef; is scalar(shash_cset($sh, "a115", undef, "j115")), !!1; is shash_get($sh, "a115"), "j115"; is scalar(shash_cset($sh, "a115", "z", "k115")), !!0; is shash_get($sh, "a115"), "j115"; is scalar(shash_cset($sh, "a115", undef, "l115")), !!0; is shash_get($sh, "a115"), "j115"; is scalar(shash_cset($sh, "a115", "j115", "m115")), !!1; is shash_get($sh, "a115"), "m115"; is scalar(shash_cset($sh, "a115", "z", "m115")), !!0; is shash_get($sh, "a115"), "m115"; is scalar(shash_cset($sh, "a115", undef, "m115")), !!0; is shash_get($sh, "a115"), "m115"; is scalar(shash_cset($sh, "a115", "m115", "m115")), !!1; is shash_get($sh, "a115"), "m115"; is scalar(shash_cset($sh, "a115", "z", undef)), !!0; is shash_get($sh, "a115"), "m115"; is scalar(shash_cset($sh, "a115", undef, undef)), !!0; is shash_get($sh, "a115"), "m115"; is scalar(shash_cset($sh, "a115", "m115", undef)), !!1; is shash_get($sh, "a115"), undef; is scalar(shash_cset($sh, "a115", "z", undef)), !!0; is shash_get($sh, "a115"), undef; is scalar(shash_cset($sh, "a115", undef, undef)), !!1; is shash_get($sh, "a115"), undef; is_deeply [shash_cset($sh, "a115", "z", "i115")], [!!0]; is shash_get($sh, "a115"), undef; is_deeply [shash_cset($sh, "a115", undef, "j115")], [!!1]; is shash_get($sh, "a115"), "j115"; is_deeply [shash_cset($sh, "a115", "z", "k115")], [!!0]; is shash_get($sh, "a115"), "j115"; is_deeply [shash_cset($sh, "a115", undef, "l115")], [!!0]; is shash_get($sh, "a115"), "j115"; is_deeply [shash_cset($sh, "a115", "j115", "m115")], [!!1]; is shash_get($sh, "a115"), "m115"; is_deeply [shash_cset($sh, "a115", "z", "m115")], [!!0]; is shash_get($sh, "a115"), "m115"; is_deeply [shash_cset($sh, "a115", undef, "m115")], [!!0]; is shash_get($sh, "a115"), "m115"; is_deeply [shash_cset($sh, "a115", "m115", "m115")], [!!1]; is shash_get($sh, "a115"), "m115"; is_deeply [shash_cset($sh, "a115", "z", undef)], [!!0]; is shash_get($sh, "a115"), "m115"; is_deeply [shash_cset($sh, "a115", undef, undef)], [!!0]; is shash_get($sh, "a115"), "m115"; is_deeply [shash_cset($sh, "a115", "m115", undef)], [!!1]; is shash_get($sh, "a115"), undef; is_deeply [shash_cset($sh, "a115", "z", undef)], [!!0]; is shash_get($sh, "a115"), undef; is_deeply [shash_cset($sh, "a115", undef, undef)], [!!1]; is shash_get($sh, "a115"), undef; shash_idle($sh); is scalar(shash_idle($sh)), undef; is_deeply [shash_idle($sh)], []; shash_tidy($sh); is scalar(shash_tidy($sh)), undef; is_deeply [shash_tidy($sh)], []; my $h; shash_tally_get($sh); $h = shash_tally_get($sh); is ref($h), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %$h; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %$h; $h = [shash_tally_get($sh)]; is @$h, 1; is ref($h->[0]), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %{$h->[0]}; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %{$h->[0]}; shash_tally_zero($sh); is scalar(shash_tally_zero($sh)), undef; is_deeply [shash_tally_zero($sh)], []; shash_tally_gzero($sh); $h = shash_tally_gzero($sh); is ref($h), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %$h; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %$h; $h = [shash_tally_gzero($sh)]; is @$h, 1; is ref($h->[0]), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %{$h->[0]}; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %{$h->[0]}; my $nx = shash_open("$tmpdir/t1", "c"); ok $nx; is scalar(is_shash($nx)), !!1; is_deeply [is_shash($nx)], [!!1]; eval { check_shash($nx) }; is $@, ""; is scalar(check_shash($nx)), undef; is_deeply [check_shash($nx)], []; is scalar(shash_is_snapshot($nx)), !!0; is_deeply [shash_is_snapshot($nx)], [!!0]; is scalar(shash_is_readable($nx)), !!0; is_deeply [shash_is_readable($nx)], [!!0]; is scalar(shash_is_writable($nx)), !!0; is_deeply [shash_is_writable($nx)], [!!0]; is scalar(shash_mode($nx)), ""; is_deeply [shash_mode($nx)], [""]; eval { shash_exists($nx, "a100") }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { shash_length($nx, "a100") }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { shash_get($nx, "a100") }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { shash_set($nx, "a100", "b100") }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; eval { shash_gset($nx, "a100", "b100") }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { shash_cset($nx, "a100", "b100", "c100") }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { shash_open("$tmpdir/t1", "c") }; is $@, ""; my @sh = shash_open("$tmpdir/t1", "c"); is scalar(@sh), 1; ok is_shash($sh[0]); eval { ${\shash_open("$tmpdir/t1", "c")} = undef; }; like $@, qr/\AModification of a read-only value attempted /; eval { ${\shash_snapshot($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; eval { ${\shash_snapshot($sn)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; 1; Hash-SharedMem-0.005/t/perm.t000444001750001750 1373613143376054 15767 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use POSIX qw( S_IRUSR S_IWUSR S_IXUSR S_IRGRP S_IWGRP S_IXGRP S_IROTH S_IWOTH S_IXOTH ); use Test::More tests => 91; BEGIN { use_ok "Hash::SharedMem", qw(is_shash shash_open shash_set); } my $tmpdir = tempdir(CLEANUP => 1); sub perm_to_trad($) { my($p) = @_; my $t = 0; $t |= 0400 if $p & S_IRUSR; $t |= 0200 if $p & S_IWUSR; $t |= 0100 if $p & S_IXUSR; $t |= 0040 if $p & S_IRGRP; $t |= 0020 if $p & S_IWGRP; $t |= 0010 if $p & S_IXGRP; $t |= 0004 if $p & S_IROTH; $t |= 0002 if $p & S_IWOTH; $t |= 0001 if $p & S_IXOTH; return $t; } sub perm_from_trad($) { my($t) = @_; my $p = 0; $p |= S_IRUSR if $t & 0400; $p |= S_IWUSR if $t & 0200; $p |= S_IXUSR if $t & 0100; $p |= S_IRGRP if $t & 0040; $p |= S_IWGRP if $t & 0020; $p |= S_IXGRP if $t & 0010; $p |= S_IROTH if $t & 0004; $p |= S_IWOTH if $t & 0002; $p |= S_IXOTH if $t & 0001; return $p; } sub mkd($) { my($fn) = @_; mkdir $fn or die "can't create $fn: $!"; } sub chm($$) { my($mode, $fn) = @_; chmod $mode, $fn or die "can't chmod $fn: $!"; } sub file_perm_trad($) { my($fn) = @_; my @st = stat $fn; @st or die "can't stat $fn: $!"; return perm_to_trad($st[2]); } umask(perm_from_trad(0000)); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); is file_perm_trad("$tmpdir/t0"), 0777; is file_perm_trad("$tmpdir/t0/iNmv0,m\$%3"), 0666; ok !-f "$tmpdir/t0/&\"JBLMEgGm0000000000000001"; shash_set($sh, "a", "b"); $sh = undef; is file_perm_trad("$tmpdir/t0"), 0777; is file_perm_trad("$tmpdir/t0/iNmv0,m\$%3"), 0666; is file_perm_trad("$tmpdir/t0/&\"JBLMEgGm0000000000000001"), 0666; umask(perm_from_trad(0000)); $sh = shash_open("$tmpdir/t1", "rwc"); ok $sh; ok is_shash($sh); $sh = undef; is file_perm_trad("$tmpdir/t1"), 0777; is file_perm_trad("$tmpdir/t1/iNmv0,m\$%3"), 0666; ok !-f "$tmpdir/t1/&\"JBLMEgGm0000000000000001"; $sh = shash_open("$tmpdir/t1", "rw"); ok $sh; ok is_shash($sh); shash_set($sh, "a", "b"); $sh = undef; is file_perm_trad("$tmpdir/t1"), 0777; is file_perm_trad("$tmpdir/t1/iNmv0,m\$%3"), 0666; is file_perm_trad("$tmpdir/t1/&\"JBLMEgGm0000000000000001"), 0666; umask(perm_from_trad(0000)); $sh = shash_open("$tmpdir/t2", "rwc"); ok $sh; ok is_shash($sh); $sh = undef; is file_perm_trad("$tmpdir/t2"), 0777; is file_perm_trad("$tmpdir/t2/iNmv0,m\$%3"), 0666; ok !-f "$tmpdir/t2/&\"JBLMEgGm0000000000000001"; umask(perm_from_trad(0077)); $sh = shash_open("$tmpdir/t2", "rw"); ok $sh; ok is_shash($sh); shash_set($sh, "a", "b"); $sh = undef; is file_perm_trad("$tmpdir/t2"), 0777; is file_perm_trad("$tmpdir/t2/iNmv0,m\$%3"), 0666; is file_perm_trad("$tmpdir/t2/&\"JBLMEgGm0000000000000001"), 0666; umask(perm_from_trad(0000)); $sh = shash_open("$tmpdir/t3", "rwc"); ok $sh; ok is_shash($sh); $sh = undef; is file_perm_trad("$tmpdir/t3"), 0777; is file_perm_trad("$tmpdir/t3/iNmv0,m\$%3"), 0666; ok !-f "$tmpdir/t3/&\"JBLMEgGm0000000000000001"; umask(perm_from_trad(0777)); $sh = shash_open("$tmpdir/t3", "rw"); ok $sh; ok is_shash($sh); shash_set($sh, "a", "b"); $sh = undef; is file_perm_trad("$tmpdir/t3"), 0777; is file_perm_trad("$tmpdir/t3/iNmv0,m\$%3"), 0666; is file_perm_trad("$tmpdir/t3/&\"JBLMEgGm0000000000000001"), 0666; umask(perm_from_trad(0077)); $sh = shash_open("$tmpdir/t4", "rwc"); ok $sh; ok is_shash($sh); $sh = undef; is file_perm_trad("$tmpdir/t4"), 0700; is file_perm_trad("$tmpdir/t4/iNmv0,m\$%3"), 0600; ok !-f "$tmpdir/t4/&\"JBLMEgGm0000000000000001"; umask(perm_from_trad(0000)); $sh = shash_open("$tmpdir/t4", "rw"); ok $sh; ok is_shash($sh); shash_set($sh, "a", "b"); $sh = undef; is file_perm_trad("$tmpdir/t4"), 0700; is file_perm_trad("$tmpdir/t4/iNmv0,m\$%3"), 0600; is file_perm_trad("$tmpdir/t4/&\"JBLMEgGm0000000000000001"), 0600; umask(perm_from_trad(0022)); $sh = shash_open("$tmpdir/t5", "rwc"); ok $sh; ok is_shash($sh); $sh = undef; is file_perm_trad("$tmpdir/t5"), 0755; is file_perm_trad("$tmpdir/t5/iNmv0,m\$%3"), 0644; ok !-f "$tmpdir/t5/&\"JBLMEgGm0000000000000001"; umask(perm_from_trad(0000)); $sh = shash_open("$tmpdir/t5", "rw"); ok $sh; ok is_shash($sh); shash_set($sh, "a", "b"); $sh = undef; is file_perm_trad("$tmpdir/t5"), 0755; is file_perm_trad("$tmpdir/t5/iNmv0,m\$%3"), 0644; is file_perm_trad("$tmpdir/t5/&\"JBLMEgGm0000000000000001"), 0644; umask(perm_from_trad(0027)); $sh = shash_open("$tmpdir/t6", "rwc"); ok $sh; ok is_shash($sh); $sh = undef; is file_perm_trad("$tmpdir/t6"), 0750; is file_perm_trad("$tmpdir/t6/iNmv0,m\$%3"), 0640; ok !-f "$tmpdir/t6/&\"JBLMEgGm0000000000000001"; umask(perm_from_trad(0750)); $sh = shash_open("$tmpdir/t6", "rw"); ok $sh; ok is_shash($sh); shash_set($sh, "a", "b"); $sh = undef; is file_perm_trad("$tmpdir/t6"), 0750; is file_perm_trad("$tmpdir/t6/iNmv0,m\$%3"), 0640; is file_perm_trad("$tmpdir/t6/&\"JBLMEgGm0000000000000001"), 0640; umask(perm_from_trad(0077)); mkd "$tmpdir/t7"; is file_perm_trad("$tmpdir/t7"), 0700; umask(perm_from_trad(0000)); $sh = shash_open("$tmpdir/t7", "rwc"); ok $sh; ok is_shash($sh); $sh = undef; is file_perm_trad("$tmpdir/t7"), 0700; is file_perm_trad("$tmpdir/t7/iNmv0,m\$%3"), 0666; ok !-f "$tmpdir/t7/&\"JBLMEgGm0000000000000001"; umask(perm_from_trad(0007)); $sh = shash_open("$tmpdir/t7", "rw"); ok $sh; ok is_shash($sh); shash_set($sh, "a", "b"); $sh = undef; is file_perm_trad("$tmpdir/t7"), 0700; is file_perm_trad("$tmpdir/t7/iNmv0,m\$%3"), 0666; is file_perm_trad("$tmpdir/t7/&\"JBLMEgGm0000000000000001"), 0666; umask(perm_from_trad(0000)); $sh = shash_open("$tmpdir/t8", "rwc"); ok $sh; ok is_shash($sh); $sh = undef; is file_perm_trad("$tmpdir/t8"), 0777; is file_perm_trad("$tmpdir/t8/iNmv0,m\$%3"), 0666; ok !-f "$tmpdir/t8/&\"JBLMEgGm0000000000000001"; chm perm_from_trad(0770), "$tmpdir/t8/iNmv0,m\$%3"; is file_perm_trad("$tmpdir/t8/iNmv0,m\$%3"), 0770; umask(perm_from_trad(0077)); $sh = shash_open("$tmpdir/t8", "rw"); ok $sh; ok is_shash($sh); shash_set($sh, "a", "b"); $sh = undef; is file_perm_trad("$tmpdir/t8"), 0777; is file_perm_trad("$tmpdir/t8/iNmv0,m\$%3"), 0770; is file_perm_trad("$tmpdir/t8/&\"JBLMEgGm0000000000000001"), 0660; 1; Hash-SharedMem-0.005/t/pod_cvg.t000444001750001750 27313143376054 16375 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More; plan skip_all => "Test::Pod::Coverage not available" unless eval "use Test::Pod::Coverage; 1"; Test::Pod::Coverage::all_pod_coverage_ok(); 1; Hash-SharedMem-0.005/t/pod_syn.t000444001750001750 23613143376054 16426 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More; plan skip_all => "Test::Pod not available" unless eval "use Test::Pod 1.00; 1"; Test::Pod::all_pod_files_ok(); 1; Hash-SharedMem-0.005/t/rename.t000444001750001750 346413143376054 16250 0ustar00zeframzefram000000000000use warnings; use strict; use Errno 1.00 qw(EIO); use File::Temp 0.22 qw(tempdir); use Test::More tests => 44; BEGIN { use_ok "Hash::SharedMem", qw( shash_referential_handle is_shash shash_open shash_set shash_get ); } my $eio = do { local $! = EIO; "$!" }; is shash_referential_handle(), !!shash_referential_handle; is &shash_referential_handle(), !!shash_referential_handle; is_deeply [shash_referential_handle()], [!!shash_referential_handle]; is_deeply [&shash_referential_handle()], [!!shash_referential_handle]; require_ok "Hash::SharedMem::Handle"; is "Hash::SharedMem::Handle"->referential_handle, shash_referential_handle; is_deeply ["Hash::SharedMem::Handle"->referential_handle], [shash_referential_handle]; my $tmpdir = tempdir(CLEANUP => 1); sub mkd($) { my($fn) = @_; mkdir $fn or die "can't create $fn: $!"; } sub rmd($) { my($fn) = @_; rmdir $fn or die "can't delete $fn: $!"; } sub touch($) { my($fn) = @_; open(my $fh, ">", $fn) or die "can't create $fn: $!"; } my $i = 0; sub test_rename($) { my($extra) = @_; mkd "$tmpdir/a$i"; my $sh = shash_open("$tmpdir/a$i/b$i", "rwce"); ok $sh; ok is_shash($sh); rename "$tmpdir/a$i/b$i", "$tmpdir/c$i" or die "can't rename: $!"; $extra->(); eval { shash_set($sh, "a", "bcd") }; if(shash_referential_handle) { is $@, ""; } else { like $@, qr#\Acan't write shared hash \Q$tmpdir/a$i/b$i\E: \Q$eio\E at #; } $sh = undef; $sh = shash_open("$tmpdir/c$i", "rw"); ok $sh; ok is_shash($sh); is shash_get($sh, "a"), shash_referential_handle ? "bcd" : undef; $i++; } test_rename(sub {}); test_rename(sub { touch "$tmpdir/a$i/b$i"; }); test_rename(sub { mkd "$tmpdir/a$i/b$i"; }); test_rename(sub { rmd "$tmpdir/a$i"; }); test_rename(sub { rmd "$tmpdir/a$i"; touch "$tmpdir/a$i"; }); test_rename(sub { rmd "$tmpdir/a$i"; mkd "$tmpdir/a$i"; }); 1; Hash-SharedMem-0.005/t/snapshot.t000444001750001750 607713143376054 16643 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 89; BEGIN { use_ok "Hash::SharedMem", qw( is_shash shash_open shash_get shash_set shash_snapshot shash_is_snapshot shash_idle ); } my $tmpdir = tempdir(CLEANUP => 1); my $s0 = shash_open("$tmpdir/t0", "rwc"); ok $s0; ok is_shash($s0); ok !shash_is_snapshot($s0); shash_set($s0, "a", "aa"); shash_set($s0, "b", "bb"); is shash_get($s0, "a"), "aa"; is shash_get($s0, "b"), "bb"; is shash_get($s0, "c"), undef; is shash_get($s0, "d"), undef; my $s1 = shash_snapshot($s0); ok $s1; ok is_shash($s1); ok shash_is_snapshot($s1); is shash_get($s1, "a"), "aa"; is shash_get($s1, "b"), "bb"; is shash_get($s1, "c"), undef; is shash_get($s1, "d"), undef; shash_set($s0, "c", "cc"); is shash_get($s0, "a"), "aa"; is shash_get($s0, "b"), "bb"; is shash_get($s0, "c"), "cc"; is shash_get($s0, "d"), undef; is shash_get($s1, "a"), "aa"; is shash_get($s1, "b"), "bb"; is shash_get($s1, "c"), undef; is shash_get($s1, "d"), undef; my $s2 = shash_snapshot($s0); ok $s2; ok is_shash($s2); ok shash_is_snapshot($s2); is shash_get($s2, "a"), "aa"; is shash_get($s2, "b"), "bb"; is shash_get($s2, "c"), "cc"; is shash_get($s2, "d"), undef; shash_set($s0, "d", "dd"); is shash_get($s0, "a"), "aa"; is shash_get($s0, "b"), "bb"; is shash_get($s0, "c"), "cc"; is shash_get($s0, "d"), "dd"; is shash_get($s1, "a"), "aa"; is shash_get($s1, "b"), "bb"; is shash_get($s1, "c"), undef; is shash_get($s1, "d"), undef; is shash_get($s2, "a"), "aa"; is shash_get($s2, "b"), "bb"; is shash_get($s2, "c"), "cc"; is shash_get($s2, "d"), undef; shash_idle($s0); shash_idle($s1); my $s3 = shash_snapshot($s1); ok $s3; ok is_shash($s3); ok shash_is_snapshot($s3); is shash_get($s3, "a"), "aa"; is shash_get($s3, "b"), "bb"; is shash_get($s3, "c"), undef; is shash_get($s3, "d"), undef; shash_set($s0, "a", undef); is shash_get($s0, "a"), undef; is shash_get($s0, "b"), "bb"; is shash_get($s0, "c"), "cc"; is shash_get($s0, "d"), "dd"; is shash_get($s1, "a"), "aa"; is shash_get($s1, "b"), "bb"; is shash_get($s1, "c"), undef; is shash_get($s1, "d"), undef; is shash_get($s2, "a"), "aa"; is shash_get($s2, "b"), "bb"; is shash_get($s2, "c"), "cc"; is shash_get($s2, "d"), undef; is shash_get($s3, "a"), "aa"; is shash_get($s3, "b"), "bb"; is shash_get($s3, "c"), undef; is shash_get($s3, "d"), undef; $s0 = undef; is shash_get($s1, "a"), "aa"; is shash_get($s1, "b"), "bb"; is shash_get($s1, "c"), undef; is shash_get($s1, "d"), undef; is shash_get($s2, "a"), "aa"; is shash_get($s2, "b"), "bb"; is shash_get($s2, "c"), "cc"; is shash_get($s2, "d"), undef; is shash_get($s3, "a"), "aa"; is shash_get($s3, "b"), "bb"; is shash_get($s3, "c"), undef; is shash_get($s3, "d"), undef; $s1 = undef; is shash_get($s2, "a"), "aa"; is shash_get($s2, "b"), "bb"; is shash_get($s2, "c"), "cc"; is shash_get($s2, "d"), undef; is shash_get($s3, "a"), "aa"; is shash_get($s3, "b"), "bb"; is shash_get($s3, "c"), undef; is shash_get($s3, "d"), undef; $s2 = undef; is shash_get($s3, "a"), "aa"; is shash_get($s3, "b"), "bb"; is shash_get($s3, "c"), undef; is shash_get($s3, "d"), undef; 1; Hash-SharedMem-0.005/t/taint.t000444001750001750 4253013143376054 16135 0ustar00zeframzefram000000000000#!perl -T # above line is required to enable taint mode use warnings; use strict; BEGIN { if(eval { eval("1".substr($^X,0,0)) }) { require Test::More; Test::More::plan(skip_all => "tainting not supported on this Perl"); } } use File::Temp 0.22 qw(tempdir); use Test::More tests => 834; my($pr, $pw); pipe($pr, $pw) or die "pipe: $!"; close $pw; my $tainted_undef = <$pr>; close $pr; sub tainted($) { if(defined $_[0]) { return $_[0].substr($^X, 0, 0); } else { return $tainted_undef; } } sub untainted($) { if(defined $_[0]) { $_[0] =~ /\A(.*)\z/s; return "$1"; } else { return undef; } } sub is_tainted($) { no warnings "uninitialized"; return !eval { eval("1;#".substr($_[0], 0, 0)); 1 }; } ok !is_tainted("wibble"); is tainted("wibble"), "wibble"; ok is_tainted(tainted("wibble")); is tainted(tainted("wibble")), "wibble"; ok is_tainted(tainted(tainted("wibble"))); is untainted("wibble"), "wibble"; ok !is_tainted(untainted("wibble")); is untainted(tainted("wibble")), "wibble"; ok !is_tainted(untainted(tainted("wibble"))); ok !is_tainted(undef); is tainted(undef), undef; ok is_tainted(tainted(undef)); is tainted(tainted(undef)), undef; ok is_tainted(tainted(tainted(undef))); is untainted(undef), undef; ok !is_tainted(untainted(undef)); is untainted(tainted(undef)), undef; ok !is_tainted(untainted(tainted(undef))); sub is_tnt(&$) { my $v = eval { $_[0]->() }; is $@, ""; ok is_tainted($v); is $v, $_[1]; } sub is_unt(&$) { my $v = eval { $_[0]->() }; is $@, ""; ok !is_tainted($v); is $v, $_[1]; } sub is_mbt(&$) { my $v = eval { $_[0]->() }; is $@, ""; is $v, $_[1]; } BEGIN { $ENV{$_} = untainted($ENV{$_}) foreach keys %ENV; } BEGIN { use_ok "Hash::SharedMem", qw( shash_referential_handle is_shash check_shash shash_open shash_is_readable shash_is_writable shash_mode shash_exists shash_length shash_get shash_set shash_gset shash_cset shash_occupied shash_count shash_size shash_key_min shash_key_max shash_key_ge shash_key_gt shash_key_le shash_key_lt shash_keys_array shash_keys_hash shash_group_get_hash shash_snapshot shash_is_snapshot shash_idle shash_tidy shash_tally_get shash_tally_zero shash_tally_gzero ); } is_unt { @{[ shash_referential_handle ]} } 1; ok !is_tainted(eval { shash_referential_handle }); is_mbt { @{[ substr($^X, 0, 0), shash_referential_handle ]} } 2; my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); is_unt { shash_occupied($sh) } !!0; is_mbt { [ substr($^X, 0, 0), shash_occupied($sh) ]->[1] } !!0; is_tnt { shash_count($sh) } 0; is_tnt { [ substr($^X, 0, 0), shash_count($sh) ]->[1] } 0; ok is_tainted(shash_size($sh)); ok is_tainted([ substr($^X, 0, 0), shash_size($sh) ]->[1]); is_unt { shash_key_min($sh) } undef; is_mbt { [ substr($^X, 0, 0), shash_key_min($sh) ]->[1] } undef; is_unt { shash_key_max($sh) } undef; is_mbt { [ substr($^X, 0, 0), shash_key_max($sh) ]->[1] } undef; is_unt { join("", @{shash_keys_array($sh)}) } ""; is_mbt { [ substr($^X, 0, 0), join("", @{shash_keys_array($sh)}) ]->[1] } ""; is_unt { join("", sort keys %{shash_keys_hash($sh)}) } ""; is_mbt { [ substr($^X, 0, 0), join("", sort keys %{shash_keys_hash($sh)}) ]->[1] } ""; is_unt { join("", sort %{shash_group_get_hash($sh)}) } ""; is_mbt { [ substr($^X, 0, 0), join("", sort %{shash_group_get_hash($sh)}) ]->[1] } ""; shash_set($sh, "a$_", "b$_") foreach 0..19; my $a20 = join("abcdef", 0..999); my $a20len = length($a20); shash_set($sh, "a20", $a20); is_unt { is_shash($sh) } !!1; is_mbt { [ substr($^X, 0, 0), is_shash($sh) ]->[1] } !!1; is_unt { is_shash("wibble") } !!0; is_mbt { [ substr($^X, 0, 0), is_shash("wibble") ]->[1] } !!0; is_mbt { is_shash(tainted("wibble")) } !!0; is_mbt { [ substr($^X, 0, 0), is_shash(tainted("wibble")) ]->[1] } !!0; is_unt { check_shash($sh) } undef; is_mbt { [ substr($^X, 0, 0), check_shash($sh) ]->[1] } undef; is eval { scalar(check_shash("wibble")) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; is eval { [ substr($^X, 0, 0), scalar(check_shash("wibble")) ] }, undef; like $@, qr/\Ahandle is not a shared hash handle /; is eval { check_shash(tainted("wibble")) }, undef; like $@, qr/\Ahandle is not a shared hash handle /; is eval { [ substr($^X, 0, 0), scalar(check_shash(tainted("wibble"))) ] }, undef; like $@, qr/\Ahandle is not a shared hash handle /; $sh = undef; foreach my $iomode ("", qw(r w rw c rc wc rwc)) { my $fn = "$tmpdir/t0"; my $md = $iomode; $sh = eval { shash_open($fn, $md) }; is $@, ""; ok is_shash($sh); $md = tainted($md); $sh = eval { shash_open($fn, $md) }; if($iomode =~ /[wc]/) { like $@, qr/\AInsecure dependency in shash_open /; is $sh, undef; } else { is $@, ""; ok is_shash($sh); } $fn = tainted($fn); $sh = eval { shash_open($fn, $md) }; if($iomode =~ /[wc]/) { like $@, qr/\AInsecure dependency in shash_open /; is $sh, undef; } else { is $@, ""; ok is_shash($sh); } $md = untainted($md); $sh = eval { shash_open($fn, $md) }; if($iomode =~ /[wc]/) { like $@, qr/\AInsecure dependency in shash_open /; is $sh, undef; } else { is $@, ""; ok is_shash($sh); } } $sh = undef; $sh = shash_open(tainted("$tmpdir/t0"), tainted("r")); is_unt { shash_is_readable($sh) } !!1; is_mbt { [ substr($^X, 0, 0), shash_is_readable($sh) ]->[1] } !!1; is_unt { shash_is_writable($sh) } !!0; is_mbt { [ substr($^X, 0, 0), shash_is_writable($sh) ]->[1] } !!0; is_unt { shash_mode($sh) } "r"; is_mbt { [ substr($^X, 0, 0), shash_mode($sh) ]->[1] } "r"; is_tnt { join("", @{shash_keys_array($sh)}) } join("", sort map { "a$_" } 0..20); is_tnt { [ substr($^X, 0, 0), join("", @{shash_keys_array($sh)}) ]->[1] } join("", sort map { "a$_" } 0..20); is_unt { join("", sort keys %{shash_keys_hash($sh)}) } join("", sort map { "a$_" } 0..20); is_mbt { [ substr($^X, 0, 0), join("", sort keys %{shash_keys_hash($sh)}) ]->[1] } join("", sort map { "a$_" } 0..20); is_tnt { join("", sort %{shash_group_get_hash($sh)}) } join("", sort((map { ("a$_", "b$_") } 0..19), "a20", $a20)); is_tnt { [ substr($^X, 0, 0), join("", sort %{shash_group_get_hash($sh)}) ]->[1] } join("", sort((map { ("a$_", "b$_") } 0..19), "a20", $a20)); foreach( sub { shash_open("$tmpdir/t0", "r") }, sub { shash_open("$tmpdir/t0", "rw") }, sub { shash_open(tainted("$tmpdir/t0"), tainted("r")) }, ) { $sh = $_->(); is_unt { shash_exists($sh, "a0") } !!1; is_mbt { shash_exists($sh, tainted("a0")) } !!1; is_mbt { [ substr($^X, 0, 0), shash_exists($sh, "a0") ]->[1] } !!1; is_unt { shash_exists($sh, "a20") } !!1; is_mbt { shash_exists($sh, tainted("a20")) } !!1; is_mbt { [ substr($^X, 0, 0), shash_exists($sh, "a20") ]->[1] } !!1; is_unt { shash_exists($sh, "c0") } !!0; is_mbt { shash_exists($sh, tainted("c0")) } !!0; is_mbt { [ substr($^X, 0, 0), shash_exists($sh, "c0") ]->[1] } !!0; is_tnt { shash_length($sh, "a1") } 2; is_tnt { shash_length($sh, tainted("a1")) } 2; is_tnt { [ substr($^X, 0, 0), shash_length($sh, "a1") ]->[1] } 2; is_tnt { shash_length($sh, "a20") } $a20len; is_tnt { shash_length($sh, tainted("a20")) } $a20len; is_tnt { [ substr($^X, 0, 0), shash_length($sh, "a20") ]->[1] } $a20len; is_unt { shash_length($sh, "c1") } undef; is_mbt { shash_length($sh, tainted("c1")) } undef; is_mbt { [ substr($^X, 0, 0), shash_length($sh, "c1") ]->[1] } undef; is_tnt { shash_get($sh, "a2") } "b2"; is_tnt { shash_get($sh, tainted("a2")) } "b2"; is_tnt { [ substr($^X, 0, 0), shash_get($sh, "a2") ]->[1] } "b2"; is_tnt { shash_get($sh, "a20") } $a20; is_tnt { shash_get($sh, tainted("a20")) } $a20; is_tnt { [ substr($^X, 0, 0), shash_get($sh, "a20") ]->[1] } $a20; is_unt { shash_get($sh, "c2") } undef; is_mbt { shash_get($sh, tainted("c2")) } undef; is_mbt { [ substr($^X, 0, 0), shash_get($sh, "c2") ]->[1] } undef; } $sh = shash_open("$tmpdir/t0", "rw"); is_unt { shash_set($sh, "d0", "e0a") } undef; is_mbt { shash_set($sh, "d1", tainted("e1a")) } undef; is_mbt { shash_set($sh, tainted("d2"), "e2a") } undef; is_mbt { [ substr($^X, 0, 0), shash_set($sh, "d3", "e3a") ]->[1] } undef; is shash_get($sh, "d$_"), "e${_}a" foreach 0..3; is_unt { shash_set($sh, "d0", "e0b") } undef; is_mbt { shash_set($sh, "d1", tainted("e1b")) } undef; is_mbt { shash_set($sh, tainted("d2"), "e2b") } undef; is_mbt { [ substr($^X, 0, 0), shash_set($sh, "d3", "e3b") ]->[1] } undef; is shash_get($sh, "d$_"), "e${_}b" foreach 0..3; is_unt { shash_set($sh, "d0", undef) } undef; is_mbt { shash_set($sh, "d1", tainted(undef)) } undef; is_mbt { shash_set($sh, tainted("d2"), undef) } undef; is_mbt { [ substr($^X, 0, 0), shash_set($sh, "d3", undef) ]->[1] } undef; is shash_get($sh, "d$_"), undef foreach 0..3; is_unt { shash_set($sh, "d0", undef) } undef; is_mbt { shash_set($sh, "d1", tainted(undef)) } undef; is_mbt { shash_set($sh, tainted("d2"), undef) } undef; is_mbt { [ substr($^X, 0, 0), shash_set($sh, "d3", undef) ]->[1] } undef; is shash_get($sh, "d$_"), undef foreach 0..3; is_unt { shash_gset($sh, "f0", "g0a") } undef; is_mbt { shash_gset($sh, "f1", tainted("g1a")) } undef; is_mbt { shash_gset($sh, tainted("f2"), "g2a") } undef; is_mbt { [ substr($^X, 0, 0), shash_gset($sh, "f3", "g3a") ]->[1] } undef; is shash_get($sh, "f$_"), "g${_}a" foreach 0..3; is_tnt { shash_gset($sh, "f0", "g0b") } "g0a"; is_tnt { shash_gset($sh, "f1", tainted("g1b")) } "g1a"; is_tnt { shash_gset($sh, tainted("f2"), "g2b") } "g2a"; is_tnt { [ substr($^X, 0, 0), shash_gset($sh, "f3", "g3b") ]->[1] } "g3a"; is shash_get($sh, "f$_"), "g${_}b" foreach 0..3; is_tnt { shash_gset($sh, "f0", undef) } "g0b"; is_tnt { shash_gset($sh, "f1", tainted(undef)) } "g1b"; is_tnt { shash_gset($sh, tainted("f2"), undef) } "g2b"; is_tnt { [ substr($^X, 0, 0), shash_gset($sh, "f3", undef) ]->[1] } "g3b"; is shash_get($sh, "f$_"), undef foreach 0..3; is_unt { shash_gset($sh, "f0", undef) } undef; is_mbt { shash_gset($sh, "f1", tainted(undef)) } undef; is_mbt { shash_gset($sh, tainted("f2"), undef) } undef; is_mbt { [ substr($^X, 0, 0), shash_gset($sh, "f3", undef) ]->[1] } undef; is shash_get($sh, "f$_"), undef foreach 0..3; is_unt { shash_gset($sh, "f0", "g0c$a20") } undef; is_mbt { shash_gset($sh, "f1", tainted("g1c$a20")) } undef; is_mbt { shash_gset($sh, tainted("f2"), "g2c$a20") } undef; is_mbt { [ substr($^X, 0, 0), shash_gset($sh, "f3", "g3c$a20") ]->[1] } undef; is shash_get($sh, "f$_"), "g${_}c$a20" foreach 0..3; is_tnt { shash_gset($sh, "f0", "g0d$a20") } "g0c$a20"; is_tnt { shash_gset($sh, "f1", tainted("g1d$a20")) } "g1c$a20"; is_tnt { shash_gset($sh, tainted("f2"), "g2d$a20") } "g2c$a20"; is_tnt { [ substr($^X, 0, 0), shash_gset($sh, "f3", "g3d$a20") ]->[1] } "g3c$a20"; is shash_get($sh, "f$_"), "g${_}d$a20" foreach 0..3; is_tnt { shash_gset($sh, "f0", undef) } "g0d$a20"; is_tnt { shash_gset($sh, "f1", tainted(undef)) } "g1d$a20"; is_tnt { shash_gset($sh, tainted("f2"), undef) } "g2d$a20"; is_tnt { [ substr($^X, 0, 0), shash_gset($sh, "f3", undef) ]->[1] } "g3d$a20"; is shash_get($sh, "f$_"), undef foreach 0..3; is_unt { shash_cset($sh, "h0", undef, undef) } !!1; is_mbt { shash_cset($sh, "h1", undef, tainted(undef)) } !!1; is_mbt { shash_cset($sh, "h2", tainted(undef), undef) } !!1; is_mbt { shash_cset($sh, tainted("h3"), undef, undef) } !!1; is_mbt { [ substr($^X, 0, 0), shash_cset($sh, "h4", undef, undef) ]->[1] } !!1; is shash_get($sh, "h$_"), undef foreach 0..4; is_unt { shash_cset($sh, "h0", "i0a", undef) } !!0; is_mbt { shash_cset($sh, "h1", "i1a", tainted(undef)) } !!0; is_mbt { shash_cset($sh, "h2", tainted("i2a"), undef) } !!0; is_mbt { shash_cset($sh, tainted("h3"), "i3a", undef) } !!0; is_mbt { [ substr($^X, 0, 0), shash_cset($sh, "h4", "i4a", undef) ]->[1] } !!0; is shash_get($sh, "h$_"), undef foreach 0..4; is_unt { shash_cset($sh, "h0", "i0b", "i0c") } !!0; is_mbt { shash_cset($sh, "h1", "i1b", tainted("i1c")) } !!0; is_mbt { shash_cset($sh, "h2", tainted("i2b"), "i2c") } !!0; is_mbt { shash_cset($sh, tainted("h3"), "i3b", "i3c") } !!0; is_mbt { [ substr($^X, 0, 0), shash_cset($sh, "h4", "i4b", "i4c") ]->[1] } !!0; is shash_get($sh, "h$_"), undef foreach 0..4; is_unt { shash_cset($sh, "h0", undef, "i0d") } !!1; is_mbt { shash_cset($sh, "h1", undef, tainted("i1d")) } !!1; is_mbt { shash_cset($sh, "h2", tainted(undef), "i2d") } !!1; is_mbt { shash_cset($sh, tainted("h3"), undef, "i3d") } !!1; is_mbt { [ substr($^X, 0, 0), shash_cset($sh, "h4", undef, "i4d") ]->[1] } !!1; is shash_get($sh, "h$_"), "i${_}d" foreach 0..4; is_unt { shash_cset($sh, "h0", undef, undef) } !!0; is_mbt { shash_cset($sh, "h1", undef, tainted(undef)) } !!0; is_mbt { shash_cset($sh, "h2", tainted(undef), undef) } !!0; is_mbt { shash_cset($sh, tainted("h3"), undef, undef) } !!0; is_mbt { [ substr($^X, 0, 0), shash_cset($sh, "h4", undef, undef) ]->[1] } !!0; is shash_get($sh, "h$_"), "i${_}d" foreach 0..4; is_unt { shash_cset($sh, "h0", undef, "i0e") } !!0; is_mbt { shash_cset($sh, "h1", undef, tainted("i1e")) } !!0; is_mbt { shash_cset($sh, "h2", tainted(undef), "i2e") } !!0; is_mbt { shash_cset($sh, tainted("h3"), undef, "i3e") } !!0; is_mbt { [ substr($^X, 0, 0), shash_cset($sh, "h4", undef, "i4e") ]->[1] } !!0; is shash_get($sh, "h$_"), "i${_}d" foreach 0..4; is_unt { shash_cset($sh, "h0", "i0f", undef) } !!0; is_mbt { shash_cset($sh, "h1", "i1f", tainted(undef)) } !!0; is_mbt { shash_cset($sh, "h2", tainted("i2f"), undef) } !!0; is_mbt { shash_cset($sh, tainted("h3"), "i3f", undef) } !!0; is_mbt { [ substr($^X, 0, 0), shash_cset($sh, "h4", "i4f", undef) ]->[1] } !!0; is shash_get($sh, "h$_"), "i${_}d" foreach 0..4; is_unt { shash_cset($sh, "h0", "i0g", "i0h") } !!0; is_mbt { shash_cset($sh, "h1", "i1g", tainted("i1h")) } !!0; is_mbt { shash_cset($sh, "h2", tainted("i2g"), "i2h") } !!0; is_mbt { shash_cset($sh, tainted("h3"), "i3g", "i3h") } !!0; is_mbt { [ substr($^X, 0, 0), shash_cset($sh, "h4", "i4g", "i4h") ]->[1] } !!0; is shash_get($sh, "h$_"), "i${_}d" foreach 0..4; is_unt { shash_cset($sh, "h0", "i0d", "i0i") } !!1; is_mbt { shash_cset($sh, "h1", "i1d", tainted("i1i")) } !!1; is_mbt { shash_cset($sh, "h2", tainted("i2d"), "i2i") } !!1; is_mbt { shash_cset($sh, tainted("h3"), "i3d", "i3i") } !!1; is_mbt { [ substr($^X, 0, 0), shash_cset($sh, "h4", "i4d", "i4i") ]->[1] } !!1; is shash_get($sh, "h$_"), "i${_}i" foreach 0..4; is_unt { shash_cset($sh, "h0", "i0i", undef) } !!1; is_mbt { shash_cset($sh, "h1", "i1i", tainted(undef)) } !!1; is_mbt { shash_cset($sh, "h2", tainted("i2i"), undef) } !!1; is_mbt { shash_cset($sh, tainted("h3"), "i3i", undef) } !!1; is_mbt { [ substr($^X, 0, 0), shash_cset($sh, "h4", "i4i", undef) ]->[1] } !!1; is shash_get($sh, "h$_"), undef foreach 0..4; is_unt { shash_occupied($sh) } !!1; is_mbt { [ substr($^X, 0, 0), shash_occupied($sh) ]->[1] } !!1; is_tnt { shash_count($sh) } 21; is_tnt { [ substr($^X, 0, 0), shash_count($sh) ]->[1] } 21; ok is_tainted(shash_size($sh)); ok is_tainted([ substr($^X, 0, 0), shash_size($sh) ]->[1]); is_tnt { shash_key_min($sh) } "a0"; is_tnt { [ substr($^X, 0, 0), shash_key_min($sh) ]->[1] } "a0"; is_tnt { shash_key_max($sh) } "a9"; is_tnt { [ substr($^X, 0, 0), shash_key_max($sh) ]->[1] } "a9"; is_unt { shash_key_ge($sh, "~") } undef; is_mbt { [ substr($^X, 0, 0), shash_key_ge($sh, "~") ]->[1] } undef; is_tnt { shash_key_ge($sh, "a3") } "a3"; is_tnt { [ substr($^X, 0, 0), shash_key_ge($sh, "a3") ]->[1] } "a3"; is_unt { shash_key_gt($sh, "~") } undef; is_mbt { [ substr($^X, 0, 0), shash_key_gt($sh, "~") ]->[1] } undef; is_tnt { shash_key_gt($sh, "a3") } "a4"; is_tnt { [ substr($^X, 0, 0), shash_key_gt($sh, "a3") ]->[1] } "a4"; is_unt { shash_key_le($sh, "-") } undef; is_mbt { [ substr($^X, 0, 0), shash_key_le($sh, "-") ]->[1] } undef; is_tnt { shash_key_le($sh, "a3") } "a3"; is_tnt { [ substr($^X, 0, 0), shash_key_le($sh, "a3") ]->[1] } "a3"; is_unt { shash_key_lt($sh, "-") } undef; is_mbt { [ substr($^X, 0, 0), shash_key_lt($sh, "-") ]->[1] } undef; is_tnt { shash_key_lt($sh, "a3") } "a20"; is_tnt { [ substr($^X, 0, 0), shash_key_lt($sh, "a3") ]->[1] } "a20"; is_unt { shash_idle($sh) } undef; is_mbt { [ substr($^X, 0, 0), shash_idle($sh) ]->[1] } undef; is_unt { shash_tidy($sh) } undef; is_mbt { [ substr($^X, 0, 0), shash_tidy($sh) ]->[1] } undef; my $h; $h = eval { shash_tally_get($sh) }; is $@, ""; is ref($h), "HASH"; ok !grep { is_tainted($_) } keys %$h; ok !grep { is_tainted($_) } values %$h; ok !grep { !/\A[a-z_]+\z/ } keys %$h; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %$h; $h = eval { [ substr($^X, 0, 0), shash_tally_get($sh) ]->[1] }; is $@, ""; is ref($h), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %$h; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %$h; is_unt { shash_tally_zero($sh) } undef; is_mbt { [ substr($^X, 0, 0), shash_tally_zero($sh) ]->[1] } undef; $h = eval { shash_tally_gzero($sh) }; is $@, ""; is ref($h), "HASH"; ok !grep { is_tainted($_) } keys %$h; ok !grep { is_tainted($_) } values %$h; ok !grep { !/\A[a-z_]+\z/ } keys %$h; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %$h; $h = eval { [ substr($^X, 0, 0), shash_tally_gzero($sh) ]->[1] }; is $@, ""; is ref($h), "HASH"; ok !grep { !/\A[a-z_]+\z/ } keys %$h; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %$h; is_unt { shash_is_snapshot($sh) } !!0; is_mbt { [ substr($^X, 0, 0), shash_is_snapshot($sh) ]->[1] } !!0; $sh = eval { [ substr($^X, 0, 0), shash_snapshot($sh) ]->[1] }; is $@, ""; ok is_shash($sh); is_unt { shash_is_snapshot($sh) } !!1; is_mbt { [ substr($^X, 0, 0), shash_is_snapshot($sh) ]->[1] } !!1; is eval { shash_tidy($sh) }, undef; like $@, qr#\Acan't\ tidy\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ handle\ is\ a\ snapshot\ #x; is eval { [ substr($^X, 0, 0), shash_tidy($sh) ]->[1] }, undef; like $@, qr#\Acan't\ tidy\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ handle\ is\ a\ snapshot\ #x; 1; Hash-SharedMem-0.005/t/tally.t000444001750001750 1164713143376054 16150 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 149; BEGIN { use_ok "Hash::SharedMem", qw( is_shash shash_open shash_get shash_set shash_gset shash_tally_get shash_tally_zero shash_tally_gzero ); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); my $t; sub ok_tally($) { is ref($_[0]), "HASH"; is_deeply [ sort keys %{$_[0]} ], [sort qw( string_read string_write bnode_read bnode_write key_compare root_change_attempt root_change_success file_change_attempt file_change_success data_read_op data_write_op )]; ok !grep { ref($_) ne "" } values %{$_[0]}; ok !grep { !/\A(?:0|[1-9][0-9]*)\z/ } values %{$_[0]}; } $t = shash_tally_get($sh); ok_tally $t; ok !grep { $_ ne "0" } values %$t; is shash_get($sh, "a0"), undef; $t = shash_tally_get($sh); ok_tally $t; is $t->{string_read}, 0; is $t->{string_write}, 0; is $t->{bnode_read}, 1; is $t->{bnode_write}, 0; is $t->{key_compare}, 0; is $t->{root_change_attempt}, 0; is $t->{root_change_success}, 0; is $t->{file_change_attempt}, 0; is $t->{file_change_success}, 0; is $t->{data_read_op}, 1; is $t->{data_write_op}, 0; is shash_get($sh, "a1"), undef; $t = shash_tally_get($sh); ok_tally $t; is $t->{string_read}, 0; is $t->{string_write}, 0; is $t->{bnode_read}, 2; is $t->{bnode_write}, 0; is $t->{key_compare}, 0; is $t->{root_change_attempt}, 0; is $t->{root_change_success}, 0; is $t->{file_change_attempt}, 0; is $t->{file_change_success}, 0; is $t->{data_read_op}, 2; is $t->{data_write_op}, 0; shash_set($sh, "a2", "b2"); $t = shash_tally_get($sh); ok_tally $t; SKIP: { skip "surprisingly early file rollover", 11 if $t->{file_change_attempt} > 1; is $t->{string_read}, 0; is $t->{string_write}, 2; is $t->{bnode_read}, 5; is $t->{bnode_write}, 1; is $t->{key_compare}, 0; is $t->{root_change_attempt}, 1; is $t->{root_change_success}, 1; is $t->{file_change_attempt}, 1; is $t->{file_change_success}, 1; is $t->{data_read_op}, 2; is $t->{data_write_op}, 1; } shash_set($sh, "a3", "b3"); $t = shash_tally_get($sh); ok_tally $t; SKIP: { skip "surprisingly early file rollover", 11 if $t->{file_change_attempt} > 1; is $t->{string_read}, 1; is $t->{string_write}, 4; is $t->{bnode_read}, 6; is $t->{bnode_write}, 2; is $t->{key_compare}, 1; is $t->{root_change_attempt}, 2; is $t->{root_change_success}, 2; is $t->{file_change_attempt}, 1; is $t->{file_change_success}, 1; is $t->{data_read_op}, 2; is $t->{data_write_op}, 2; } is shash_get($sh, "a2"), "b2"; $t = shash_tally_get($sh); ok_tally $t; SKIP: { skip "surprisingly early file rollover", 11 if $t->{file_change_attempt} > 1; ok $t->{string_read} >= 2; is $t->{string_write}, 4; is $t->{bnode_read}, 7; is $t->{bnode_write}, 2; ok $t->{key_compare} >= 2; is $t->{root_change_attempt}, 2; is $t->{root_change_success}, 2; is $t->{file_change_attempt}, 1; is $t->{file_change_success}, 1; is $t->{data_read_op}, 3; is $t->{data_write_op}, 2; } shash_tally_zero($sh); $t = shash_tally_get($sh); ok_tally $t; ok !grep { $_ ne "0" } values %$t; is shash_get($sh, "a0"), undef; $t = shash_tally_get($sh); ok_tally $t; ok $t->{string_read} >= 1; is $t->{string_write}, 0; is $t->{bnode_read}, 1; is $t->{bnode_write}, 0; ok $t->{key_compare} >= 1; is $t->{root_change_attempt}, 0; is $t->{root_change_success}, 0; is $t->{file_change_attempt}, 0; is $t->{file_change_success}, 0; is $t->{data_read_op}, 1; is $t->{data_write_op}, 0; is_deeply shash_tally_get($sh), $t; is shash_gset($sh, "a2", "b2b"), "b2"; $t = shash_tally_gzero($sh); ok_tally $t; SKIP: { skip "surprisingly early file rollover", 11 if $t->{file_change_attempt} > 0; ok $t->{string_read} >= 3; is $t->{string_write}, 1; is $t->{bnode_read}, 2; is $t->{bnode_write}, 1; ok $t->{key_compare} >= 2; is $t->{root_change_attempt}, 1; is $t->{root_change_success}, 1; is $t->{file_change_attempt}, 0; is $t->{file_change_success}, 0; is $t->{data_read_op}, 1; is $t->{data_write_op}, 1; } eval { $t->{string_read} = undef; }; like $@, qr/\AModification of a read-only value attempted /; $t = shash_tally_get($sh); ok_tally $t; ok !grep { $_ ne "0" } values %$t; is shash_gset($sh, "a2", "b2b"), "b2b"; $t = shash_tally_get($sh); ok_tally $t; SKIP: { skip "surprisingly early file rollover", 11 if $t->{file_change_attempt} > 0; ok $t->{string_read} >= 2; is $t->{string_write}, 0; is $t->{bnode_read}, 1; is $t->{bnode_write}, 0; ok $t->{key_compare} >= 1; is $t->{root_change_attempt}, 0; is $t->{root_change_success}, 0; is $t->{file_change_attempt}, 0; is $t->{file_change_success}, 0; is $t->{data_read_op}, 0; is $t->{data_write_op}, 1; } eval { $t->{string_read} = undef; }; like $@, qr/\AModification of a read-only value attempted /; eval { ${\shash_tally_get($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; eval { ${\shash_tally_gzero($sh)} = undef; }; like $@, qr/\AModification of a read-only value attempted /; 1; Hash-SharedMem-0.005/t/threads.t000444001750001750 1715313143376054 16453 0ustar00zeframzefram000000000000use warnings; use strict; BEGIN { eval { require threads; }; if($@ =~ /\AThis Perl not built to support threads/) { require Test::More; Test::More::plan(skip_all => "non-threading perl build"); } if($@ ne "") { require Test::More; Test::More::plan(skip_all => "threads unavailable"); } eval { require Thread::Semaphore; }; if($@ ne "") { require Test::More; Test::More::plan(skip_all => "Thread::Semaphore unavailable"); } eval { require threads::shared; }; if($@ ne "") { require Test::More; Test::More::plan(skip_all => "threads::shared unavailable"); } } use threads; use File::Temp 0.22 qw(tempdir); use Test::More tests => 44; use Thread::Semaphore (); use threads::shared; our $tmpdir = tempdir(CLEANUP => 1); alarm 1000; our $ping1 = Thread::Semaphore->new(0); our $pong1 = Thread::Semaphore->new(0); our $ping2 = Thread::Semaphore->new(0); our $pong2 = Thread::Semaphore->new(0); my $ok1 :shared; my $thread1 = threads->create(sub { my $ok = 1; our $sh; eval(q{ use Hash::SharedMem qw(shash_open check_shash); $sh = shash_open("$tmpdir/t0", "rwc"); check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; 1; }) or $ok = 0; $pong1->up; $ping1->down; eval(q{ check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; 1; }) or $ok = 0; $ok1 = $ok; $pong1->up; $ping1->down; }); my $ok2 :shared; my $thread2 = threads->create(sub { my $ok = 1; our $sh; $ping2->down; eval(q{ use Hash::SharedMem qw(shash_open check_shash); $sh = shash_open("$tmpdir/t0", "rwc"); check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; 1; }) or $ok = 0; $pong2->up; $ping2->down; eval(q{ check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; 1; }) or $ok = 0; $ok2 = $ok; $pong2->up; $ping2->down; }); $pong1->down; $ping2->up; $pong2->down; $ping1->up; $pong1->down; $ping2->up; $pong2->down; ok $ok1; ok $ok2; $ping1->up; $ping2->up; $thread1->join; $thread2->join; ok 1; SKIP: { skip "this perl doesn't fully support cloning", 41 unless ("$]" >= 5.008009 && "$]" < 5.009) || "$]" >= 5.009003; our $ping3 = Thread::Semaphore->new(0); our $pong3 = Thread::Semaphore->new(0); our $ping4 = Thread::Semaphore->new(0); our $pong4 = Thread::Semaphore->new(0); my $ok3 :shared; my $ok4 :shared; my $thread3 = threads->create(sub { my $ok = 1; eval(q{ use Hash::SharedMem qw(shash_open check_shash); my $sh = shash_open("$tmpdir/t0", "rwc"); check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; 1; }) or $ok = 0; threads->create(sub { my $ok = 1; our $sh; $ping4->down; eval(q{ $sh = shash_open("$tmpdir/t0", "rwc"); check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; 1; }) or $ok = 0; $pong4->up; $ping4->down; eval(q{ check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; 1; }) or $ok = 0; $ok4 = $ok; $pong4->up; $ping4->down; })->detach; $ok3 = $ok; $pong3->up; $ping3->down; }); $pong3->down; $ping4->up; $pong4->down; $ping3->up; $thread3->join; $ping4->up; $pong4->down; ok $ok3; ok $ok4; $ping4->up; ok 1; ok eval(q{ use Hash::SharedMem qw( shash_open is_shash check_shash shash_set shash_get ); 1; }); our $ping5 = Thread::Semaphore->new(0); our $pong5 = Thread::Semaphore->new(0); our $ping6 = Thread::Semaphore->new(0); our $pong6 = Thread::Semaphore->new(0); my $ok5 :shared; my $thread5 = threads->create(sub { my $ok = 1; our $sh; eval(q{ $sh = shash_open("$tmpdir/t0", "rwc"); check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; 1; }) or $ok = 0; $pong5->up; $ping5->down; eval(q{ check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; 1; }) or $ok = 0; $ok5 = $ok; $pong5->up; $ping5->down; }); my $ok6 :shared; my $thread6 = threads->create(sub { my $ok = 1; our $sh; $ping6->down; eval(q{ $sh = shash_open("$tmpdir/t0", "rwc"); check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; 1; }) or $ok = 0; $pong6->up; $ping6->down; eval(q{ check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; 1; }) or $ok = 0; $ok6 = $ok; $pong6->up; $ping6->down; }); $pong5->down; $ping6->up; $pong6->down; $ping5->up; $pong5->down; $ping6->up; $pong6->down; ok $ok5; ok $ok6; $ping5->up; $ping6->up; $thread5->join; $thread6->join; ok 1; my $a20 = join("abcdef", 0..999); my $r; ok eval(q{ my $sh = shash_open("$tmpdir/t0", "rwc"); check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; shash_set($sh, "a20", $a20); shash_get($sh, "a20") eq $a20 or die; 1; }); ok eval(q{ my $sh = shash_open("$tmpdir/t0", "rwc"); check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; $r = \shash_get($sh, "a20"); 1; }); is $$r, $a20; our $ping7 = Thread::Semaphore->new(0); our $pong7 = Thread::Semaphore->new(0); my $ok7 :shared; my $thread7 = threads->create(sub { $ping7->down; $ok7 = $$r eq $a20; $r = undef; $pong7->up; $ping7->down; }); is $$r, $a20; $ping7->up; $pong7->down; is $$r, $a20; $r = undef; ok $ok7; $ping7->up; $thread7->join; ok 1; ok eval(q{ my $sh = shash_open("$tmpdir/t0", "rwc"); check_shash($sh); ref($sh) eq "Hash::SharedMem::Handle" or die; $r = \shash_get($sh, "a20"); 1; }); is $$r, $a20; our $ping8 = Thread::Semaphore->new(0); our $pong8 = Thread::Semaphore->new(0); my $ok8 :shared; my $thread8 = threads->create(sub { my $ok = 1; $ping8->down; $ok &&= $$r eq $a20; $pong8->up; $ping8->down; $ok &&= $$r eq $a20; $r = undef; $ok8 = $ok; $pong8->up; $ping8->down; }); is $$r, $a20; $ping8->up; $pong8->down; is $$r, $a20; $r = undef; $ping8->up; $pong8->down; ok $ok8; $ping8->up; $thread8->join; ok 1; my $sh; shash_set(shash_open("$tmpdir/t0", "rwc"), "b0", "c0"); $sh = shash_open("$tmpdir/t0", "rwc"); ok is_shash($sh); is ref($sh),"Hash::SharedMem::Handle"; is shash_get($sh, "b0"), "c0"; our $ping9 = Thread::Semaphore->new(0); our $pong9 = Thread::Semaphore->new(0); my $ok9 :shared; my $thread9 = threads->create(sub { my $ok = 1; $ping9->down; eval(q{ shash_get($sh, "b0") eq "c0" or die; 1; }) or $ok = 0; $sh = undef; $ok9 = $ok; $pong9->up; $ping9->down; }); is shash_get($sh, "b0"), "c0"; $ping9->up; $pong9->down; is shash_get($sh, "b0"), "c0"; $sh = undef; ok $ok9; $ping9->up; $thread9->join; ok 1; $sh = shash_open("$tmpdir/t0", "rwc"); ok is_shash($sh); is ref($sh),"Hash::SharedMem::Handle"; is shash_get($sh, "b0"), "c0"; our $ping0 = Thread::Semaphore->new(0); our $pong0 = Thread::Semaphore->new(0); my $ok0 :shared; my $thread0 = threads->create(sub { my $ok = 1; $ping0->down; eval(q{ shash_get($sh, "b0") eq "c0" or die; 1; }) or $ok = 0; $pong0->up; $ping0->down; eval(q{ shash_get($sh, "b0") eq "c0" or die; 1; }) or $ok = 0; $sh = undef; $ok0 = $ok; $pong0->up; $ping0->down; }); is shash_get($sh, "b0"), "c0"; $ping0->up; $pong0->down; is shash_get($sh, "b0"), "c0"; $sh = undef; $ping0->up; $pong0->down; ok $ok0; $ping0->up; $thread0->join; ok 1; $sh = shash_open("$tmpdir/t1", "rwc"); ok is_shash($sh); is ref($sh),"Hash::SharedMem::Handle"; is shash_get($sh, "d0"), undef; our $ping10 = Thread::Semaphore->new(0); our $pong10 = Thread::Semaphore->new(0); my $ok10 :shared; my $thread10 = threads->create(sub { my $ok = 1; $ping10->down; eval(q{ !defined(shash_get($sh, "d0")) or die; 1; }) or $ok = 0; $pong10->up; $ping10->down; eval(q{ !defined(shash_get($sh, "d0")) or die; 1; }) or $ok = 0; $sh = undef; $ok10 = $ok; $pong10->up; $ping10->down; }); is shash_get($sh, "d0"), undef; $ping10->up; $pong10->down; is shash_get($sh, "d0"), undef; $sh = undef; my @z = ("b" x 200) x 10; # to overwrite space that held synthetic data file $ping10->up; $pong10->down; ok $ok10; $ping10->up; $thread10->join; ok 1; } 1; Hash-SharedMem-0.005/t/tidy.t000444001750001750 247413143376054 15752 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 12; BEGIN { use_ok "Hash::SharedMem", qw( is_shash shash_open shash_get shash_set shash_tidy ); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = shash_open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); my %ph; ok !-f "$tmpdir/t0/&\"JBLMEgGm0000000000000001"; ok !-f "$tmpdir/t0/&\"JBLMEgGm0000000000000002"; shash_tidy($sh); ok !-f "$tmpdir/t0/&\"JBLMEgGm0000000000000001"; ok !-f "$tmpdir/t0/&\"JBLMEgGm0000000000000002"; shash_set($sh, 0, "y"); $ph{0} = "y"; ok -f "$tmpdir/t0/&\"JBLMEgGm0000000000000001"; ok !-f "$tmpdir/t0/&\"JBLMEgGm0000000000000002"; FILL: for(my $p = 7; ; $p += 2 ) { my $v = 5; for(my $j = 0; $j != 50000; $j++) { $v = ($v*21+$p) % 100000; my $x = "$v/$p"; shash_set($sh, $v, $x); $ph{$v} = $x; shash_tidy($sh); last FILL if !-f "$tmpdir/t0/&\"JBLMEgGm0000000000000001" || -f "$tmpdir/t0/&\"JBLMEgGm0000000000000002"; } } ok !-f "$tmpdir/t0/&\"JBLMEgGm0000000000000001"; ok -f "$tmpdir/t0/&\"JBLMEgGm0000000000000002"; my $v = 5; for(my $j = 0; $j != 1000; $j++) { $v = ($v*61+19) % 100000; shash_set($sh, $v, "b".$v); $ph{$v} = "b".$v; } sub doru($) { defined($_[0]) ? $_[0] : "u" } my $ok = 1; for(my $v = 0; $v != 100000; $v++) { $ok &&= doru(shash_get($sh, $v)) eq doru($ph{$v}); } ok $ok; 1; Hash-SharedMem-0.005/t/tie.t000444001750001750 1702413143376054 15577 0ustar00zeframzefram000000000000use warnings; use strict; use File::Temp 0.22 qw(tempdir); use Test::More tests => 134; BEGIN { use_ok "Hash::SharedMem::Handle"; } BEGIN { use_ok "Hash::SharedMem", qw(is_shash); } my $tmpdir = tempdir(CLEANUP => 1); my $sh = Hash::SharedMem::Handle->open("$tmpdir/t0", "rwc"); ok $sh; ok is_shash($sh); my %sh; sub keys_via_scalar_each() { my @k; while(defined(my $k = each(%sh))) { push @k, $k; } return @k; } sub content_via_scalar_each() { my @c; while(defined(my $k = each(%sh))) { push @c, $k, $sh{$k}; } return @c; } sub content_via_list_each() { my @c; while(my($k, $v) = each(%sh)) { push @c, $k, $v; } return @c; } sub try_scalar_success($) { SKIP: { skip "tied hash in scalar context not supported on this Perl", 1 unless ("$]" >= 5.008003 && "$]" < 5.009000) || "$]" >= 5.009001; is scalar(%sh), "$]" >= 5.025003 ? $_[0] : !!$_[0]; } } sub try_scalar_exception($) { SKIP: { skip "tied hash in scalar context not supported on this Perl", 1 unless ("$]" >= 5.008003 && "$]" < 5.009000) || "$]" >= 5.009001; eval { my $z = scalar(%sh) }; like $@, $_[0]; } } eval { tie %sh, "Hash::SharedMem::Handle" }; isnt $@, ""; eval { tie %sh, "Hash::SharedMem::Handle", "x", "y", "z" }; isnt $@, ""; eval { tie %sh, "Hash::SharedMem::Handle", 2 }; like $@, qr/\Ahandle is not a shared hash handle /; eval { tie %sh, "Hash::SharedMem::Handle", $sh }; is $@, ""; ok is_shash(tied(%sh)); ok tied(%sh) == $sh; ok !exists($sh{a100}); is $sh{a100}, undef; try_scalar_success 0; is scalar(keys(%sh)), 0; is scalar(values(%sh)), 0; is_deeply [keys_via_scalar_each()], []; is_deeply [content_via_scalar_each()], []; is_deeply [content_via_list_each()], []; is_deeply [keys(%sh)], []; is_deeply [values(%sh)], []; is_deeply [%sh], []; $sh{a110} = "b110"; $sh{a100} = "b100"; $sh{a120} = "b120"; ok !exists($sh{a000}); is $sh{a000}, undef; ok exists($sh{a100}); is $sh{a100}, "b100"; ok !exists($sh{a105}); is $sh{a105}, undef; ok exists($sh{a110}); is $sh{a110}, "b110"; ok !exists($sh{a115}); is $sh{a115}, undef; ok exists($sh{a120}); is $sh{a120}, "b120"; ok !exists($sh{a130}); is $sh{a130}, undef; try_scalar_success 3; is scalar(keys(%sh)), 3; is scalar(values(%sh)), 3; is_deeply [keys_via_scalar_each()], [qw(a100 a110 a120)]; is_deeply [content_via_scalar_each()], [qw(a100 b100 a110 b110 a120 b120)]; is_deeply [content_via_list_each()], [qw(a100 b100 a110 b110 a120 b120)]; is_deeply [keys(%sh)], [qw(a100 a110 a120)]; is_deeply [values(%sh)], [qw(b100 b110 b120)]; is_deeply [%sh], [qw(a100 b100 a110 b110 a120 b120)]; eval { $sh{a150} = undef }; like $@, qr/\Anew value is not an octet string /; ok !exists($sh{a150}); is $sh{a150}, undef; $sh{a105} = "b105"; delete $sh{a110}; ok !exists($sh{a000}); is $sh{a000}, undef; ok exists($sh{a100}); is $sh{a100}, "b100"; ok exists($sh{a105}); is $sh{a105}, "b105"; ok !exists($sh{a110}); is $sh{a110}, undef; ok !exists($sh{a115}); is $sh{a115}, undef; ok exists($sh{a120}); is $sh{a120}, "b120"; ok !exists($sh{a130}); is $sh{a130}, undef; try_scalar_success 3; is scalar(keys(%sh)), 3; is scalar(values(%sh)), 3; is_deeply [keys_via_scalar_each()], [qw(a100 a105 a120)]; is_deeply [content_via_scalar_each()], [qw(a100 b100 a105 b105 a120 b120)]; is_deeply [content_via_list_each()], [qw(a100 b100 a105 b105 a120 b120)]; is_deeply [keys(%sh)], [qw(a100 a105 a120)]; is_deeply [values(%sh)], [qw(b100 b105 b120)]; is_deeply [%sh], [qw(a100 b100 a105 b105 a120 b120)]; is delete($sh{a115}), undef; is delete($sh{a120}), "b120"; is delete($sh{a120}), undef; ok !exists($sh{a115}); is $sh{a115}, undef; ok !exists($sh{a120}); is $sh{a120}, undef; try_scalar_success 2; $sh{a120} = "b120"; $sh = undef; untie %sh; ok !exists($sh{a120}); eval { tie %sh, "Hash::SharedMem::Handle", "$tmpdir/t0", "rwc" }; is $@, ""; ok !exists($sh{a000}); is $sh{a000}, undef; ok exists($sh{a100}); is $sh{a100}, "b100"; ok exists($sh{a105}); is $sh{a105}, "b105"; ok !exists($sh{a110}); is $sh{a110}, undef; ok !exists($sh{a115}); is $sh{a115}, undef; ok exists($sh{a120}); is $sh{a120}, "b120"; ok !exists($sh{a130}); is $sh{a130}, undef; try_scalar_success 3; is scalar(keys(%sh)), 3; is scalar(values(%sh)), 3; is_deeply [keys_via_scalar_each()], [qw(a100 a105 a120)]; is_deeply [content_via_scalar_each()], [qw(a100 b100 a105 b105 a120 b120)]; is_deeply [content_via_list_each()], [qw(a100 b100 a105 b105 a120 b120)]; is_deeply [keys(%sh)], [qw(a100 a105 a120)]; is_deeply [values(%sh)], [qw(b100 b105 b120)]; is_deeply [%sh], [qw(a100 b100 a105 b105 a120 b120)]; untie %sh; ok !exists($sh{a120}); eval { tie %sh, "Hash::SharedMem::Handle", "$tmpdir/t0", "r" }; is $@, ""; ok exists($sh{a120}); is $sh{a120}, "b120"; try_scalar_success 3; eval { $sh{a100} = "b100" }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; eval { $sh{a101} = "b101" }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; eval { my $z = delete $sh{a100} }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; eval { my $z = delete $sh{a101} }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; eval { delete $sh{a100} }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; eval { delete $sh{a101} }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t0: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; untie %sh; ok !exists($sh{a120}); eval { tie %sh, "Hash::SharedMem::Handle", "$tmpdir/t1", "c" }; is $@, ""; eval { my $z = exists($sh{a100}) }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { my $z = $sh{a100} }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; try_scalar_exception qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { $sh{a100} = "b100" }; like $@, qr#\Acan't\ write\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unwritable\ mode\ #x; eval { my $z = delete $sh{a100} }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { delete $sh{a100} }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; untie %sh; ok !exists($sh{a120}); eval { tie %sh, "Hash::SharedMem::Handle", "$tmpdir/t1", "wc" }; is $@, ""; eval { my $z = exists($sh{a100}) }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { my $z = $sh{a100} }; like $@, qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; try_scalar_exception qr#\Acan't\ read\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { $sh{a100} = "b100" }; is $@, ""; eval { my $z = delete $sh{a100} }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; eval { delete $sh{a100} }; like $@, qr#\Acan't\ update\ shared\ hash\ \Q$tmpdir\E/t1: \ shared\ hash\ was\ opened\ in\ unreadable\ mode\ #x; untie %sh; ok !exists($sh{a120}); eval { tie %sh, "Hash::SharedMem::Handle", "$tmpdir/t2", "rwc" }; is $@, ""; eval { %sh = () }; like $@, qr/\Acan't clear shared hash at/; eval { %sh = ( abc => "def" ) }; like $@, qr/\Acan't clear shared hash at/; 1; Hash-SharedMem-0.005/t/version_synch.t000444001750001750 56513143376054 17651 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 4; BEGIN { require_ok "Hash::SharedMem"; } my $main_ver = $Hash::SharedMem::VERSION; ok defined($main_ver), "have main version number"; foreach my $submod (qw(Handle)) { my $mod = "Hash::SharedMem::$submod"; require_ok $mod; no strict "refs"; is ${"${mod}::VERSION"}, $main_ver, "$mod version number matches"; } 1;