Data-BitMask-1.00/0000755000175000017500000000000014673374240012361 5ustar tobytobyData-BitMask-1.00/Changes0000444000175000017500000000212614673374240013653 0ustar tobytobyRevision history for Perl extension Data::BitMask 1.00 Fri Sep 20 2024 - First release in over 20 years! - Updated the POD to reflect the current options for installation - Update MANIFEST.SKIP file - Added memoization for build_mask, break_mask, and explain_mask This provides significant performance enhancements. 0.91 Sat Mar 20 2004 - Now using create_makefile_pl => 'traditional' because passthrough doesn't seem to work with subclassing (Thanks merlyn for reporting this) 0.90 Sat Mar 20 2004 - Now using Module::Build! - Now generating PPMs as well! - Long live Module::Build! 0.13 Sat Mar 13 2004 - Added support for full_match constants 0.12 Mon Jan 19 2003 - Minor bug fixes with respect to $^W. - Modified break_mask to call build_mask if necessary. - Update directory structure to use lib for pm files. 0.11 Mon Sep 8 2003 - Fixed test bug resulting from varying serialization orders in Data::Dumper. The error was entirely in the test suite. - Minor changes to POD - Change from Artistic License to Standard-Perl 0.10 Sun Sep 7 2003 - First CPAN release Data-BitMask-1.00/MANIFEST0000444000175000017500000000016214673374240013507 0ustar tobytobyBuild.PL Changes lib/Data/BitMask.pm Makefile.PL MANIFEST This list of files META.json META.yml README t/test.t Data-BitMask-1.00/README0000444000175000017500000001701514673374240013243 0ustar tobytobyNAME Data::BitMask - bitmask manipulation SYNOPSIS use Data::BitMask; my $FileMask = Data::BitMask->new( READ => 1, WRITE => 2, EXECUTE => 4, RX => 5, RWX => 7, FULL => 7, ); my $mask = $FileMask->build_mask('READ|WRITE'); print Data::Dumper->Dump([ $FileMask->explain_mask($mask), $FileMask->break_mask($mask) ]); my $mask2 = $FileMask->build_mask({FULL => 1, WRITE => 0}); DESCRIPTION This module allows one to create bitmask manipulator objects that can be used to create bitmask values based on a list of constants, as well as to break apart masks using those constants. The advantages are that you don't have to pollute namespaces to use constants, you can ensure that only appropriate constants are used for specific masks, you can easily break apart and explain masks, and in general it is much easier for the user to interact with masks. The module only interacts with masks that fit in Perl integers. In some places, it presumes that you are using 32 bit integers (i.e. canonicalizing negative values). The module expends a modest amount of overhead in creating the "Data::BitMask" object so as to speed up future mask manipulations. Calls to "build_mask", "break_mask", and "explain_mask" are memoized to speed up repeated calls with the same parameters. Installation instructions There are four options for installing this module: * Using "Module::Build 0.24" or later: Build.PL perl build test perl build install * Using "ExtUtils::MakeMaker" (part of the Perl core): Makefile.PL make test make install * Using the PPM (the file has the extension ".ppm.zip") on CPAN and installing under ActivePerl for Win32 by unzipping the ".ppm.zip" file and then: ppm install Data-BitMask.ppd * Installing manually by copying "lib/Data/Bitmask.pm" to "perl/site/lib/Data/Bitmask.pm". Suggested Module Implementation Here is one suggested approach to using bitmask manipulators in a module. { my $cache; sub SECURITY_INFORMATION { $cache ||= Data::BitMask->new( OWNER_SECURITY_INFORMATION => 0x1, GROUP_SECURITY_INFORMATION => 0x2, DACL_SECURITY_INFORMATION => 0x4, SACL_SECURITY_INFORMATION => 0x8, ); } } The bitmask manipulator can then be accessed as: &SECURITY_INFORMATION->build_mask('DACL_SECURITY_INFORMATION'); Or, if you are outside of the module, as: &Win32::Security::SECURITY_INFORMATION->build_mask('DACL_SECURITY_INFORMATION'); This has several advantages: * Demand creation of the "Data::Bitmask" object. Creating objects with huge numbers of constants (i.e. hundreds or thousands) can be a bit time consuming, so this delays creation until the object actually gets used. At the same time, the created object is cached. * Easy access from within in the module, reasonably easy access from outside the module. * If the user wants even easier access from outside the module, you can support Exporter and let the sub be exported. Method Reference new Creates a new bitmask manipulator. Pass a list of constant and value pairs. The constants do not have to be disjoint, but order does matter. When executing "explain_mask" or "explain_const", constants that are earlier in the list take precedence over those later in the list. Constant names are not allowed to have space or pipes in them, and constant values have to be integers. Constant names are case insensitive but preserving. If the passed value for the constant name is an anonymous array, then it is presumed that the name is the first value and that the remainder consists of name-value pairs of parameters. The only currently supported parameter is "full_match", which implies that the constant should only be returned from "break_mask" or "explain_mask" if it perfectly matches the mask being explained. For example: [qw(FILES_ONLY_NO_INHERIT full_match 1)] => 1, add_constants Adds constants to an existing bitmask manipulator. Pass a list of constant and value pairs as for "new". Constants will be added to the end of the list (see "new" for an explanation of ordering concerns). The main use for "add_constants" is adding aggregate constants created by using "build_mask". build_mask This takes one of three things as a parameter: * scalar - string is split on '"|"' and/or whitespace to generate a list of constants * ARRAY ref - elements are the list of constants * HASH ref - keys with true values are the list of constants; keys with false values are subtracted from the resultant mask In all situations, integers are legal in place of constant names and are treated as the value, after adding 2**32 to any negative integers. break_mask Breaks a mask apart. Pass a mask value as an integer. Returns a hash of all constants whose values are subsets of the passed mask. Values are set to 1 so the result can safely be passed to "build_mask". Commonly used for operations like: if ($MaskManipulator->break_mask($my_mask_value)->{CONSTANT}) { Note that "break_mask" accepts To eliminate a constant from explain_mask or break_mask unless it perfectly matches, use "full_match" constants. explain_mask Explains a mask in terms of a relatively minimal set of constants. Pass either a mask value as an integer or any valid parameter for "build_mask". Returns a hash of constants that will recreate the mask. Many times, this will be the minimum number of constants necessary to describe the mask. Note that creating the true minimum set of constants is somewhat painful (see Knapsack problem). The algorithm used by "explain_mask" is to first test for a constant that perfectly matches the mask. If one is found, this is the obvious answer. In the absence of a perfect match, "break_mask" is used to generate a maximal solution. All simply occluded constants are then eliminated (that is to say, all constants in the list whose values are subsets of another single constant). This means, for instance, that if you had only three constants, AB => 3, BC => 6, and AC => 5, "explain_mask" would return all three when passed the value 7 because no one constant is a subset of any single one of the others. To eliminate a constant from explain_mask or break_mask unless it perfectly matches, use "full_match" constants. build_const This takes one of two things as a parameter: * scalar integer - if a scalar integer is passed, then the value is simply returned, after adding 2**32 to any negative integers * scalar - string is looked up in the list of constants explain_const Looks for a perfect match for the passed mask value. Pass either a mask value as an integer or any valid parameter for "build_mask". If one is not found, it croaks. get_constants Returns all constants passed either to "new" or "add_constants". AUTHOR Toby Ovod-Everett, toby@ovod-everett.org LICENSE Copyright 2003, 2004 Toby Ovod-Everett. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Data-BitMask-1.00/META.json0000444000175000017500000000147014673374240014002 0ustar tobytoby{ "abstract" : "bitmask manipulation", "author" : [ "Toby Ovod-Everett, toby@ovod-everett.org" ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4234", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Data-BitMask", "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0.42" } } }, "provides" : { "Data::BitMask" : { "file" : "lib/Data/BitMask.pm", "version" : "1.00" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "1.00", "x_serialization_backend" : "JSON::PP version 4.16" } Data-BitMask-1.00/Makefile.PL0000444000175000017500000000043214673374240014330 0ustar tobytoby# Note: this file was auto-generated by Module::Build::Compat version 0.4234 use ExtUtils::MakeMaker; WriteMakefile ( 'PL_FILES' => {}, 'NAME' => 'Data::BitMask', 'PREREQ_PM' => {}, 'EXE_FILES' => [], 'INSTALLDIRS' => 'site', 'VERSION_FROM' => 'lib/Data/BitMask.pm' ) ; Data-BitMask-1.00/Build.PL0000444000175000017500000000223314673374240013653 0ustar tobytobyuse Module::Build 0.42; my $class = Module::Build->subclass( class => 'Module::Build::DataBitMask', code => q{ sub ppm_name { my $self = shift; mkdir('MSWin32-x86-multi-thread'); return 'MSWin32-x86-multi-thread/' . $self->dist_dir; } sub ACTION_ppmzip { my $self = shift; $self->depends_on('ppmdist'); my $ppmzip = $self->dist_dir().'.ppm.zip'; my $ppm_name = $self->ppm_name(); unlink($ppmzip); system("zip -9 $ppmzip *.ppd $ppm_name.tar.gz"); } sub ACTION_ppmdist { my ($self) = @_; $self->depends_on('build', 'html', 'ppd'); opendir(TEMPDIR, $self->blib().'/libdoc'); foreach my $i (grep(!/^\.\.?$/, readdir(TEMPDIR))) { unlink($self->blib().'/libdoc/'.$i); } closedir(TEMPDIR); rmdir($self->blib().'/libdoc'); $self->add_to_cleanup($self->ppm_name); $self->make_tarball($self->blib, $self->ppm_name); } }, ); my $build = $class->new( module_name => 'Data::BitMask', license => 'perl', configure_requires => { 'Module::Build' => 0.42 }, requires => { }, create_makefile_pl => 'traditional', create_readme => 1, ); $build->create_build_script; Data-BitMask-1.00/lib/0000755000175000017500000000000014673374240013127 5ustar tobytobyData-BitMask-1.00/lib/Data/0000755000175000017500000000000014673374240014000 5ustar tobytobyData-BitMask-1.00/lib/Data/BitMask.pm0000444000175000017500000003561714673374240015702 0ustar tobytoby############################################################################# # # Data::BitMask - bitmask manipulation # # Author: Toby Ovod-Everett ############################################################################# # Copyright 2003-2024 Toby Ovod-Everett. All rights reserved # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # For comments, questions, bugs or general interest, feel free to # contact Toby Ovod-Everett at toby@ovod-everett.org ############################################################################# =head1 NAME Data::BitMask - bitmask manipulation =head1 SYNOPSIS use Data::BitMask; my $FileMask = Data::BitMask->new( READ => 1, WRITE => 2, EXECUTE => 4, RX => 5, RWX => 7, FULL => 7, ); my $mask = $FileMask->build_mask('READ|WRITE'); print Data::Dumper->Dump([ $FileMask->explain_mask($mask), $FileMask->break_mask($mask) ]); my $mask2 = $FileMask->build_mask({FULL => 1, WRITE => 0}); =head1 DESCRIPTION This module allows one to create bitmask manipulator objects that can be used to create bitmask values based on a list of constants, as well as to break apart masks using those constants. The advantages are that you don't have to pollute namespaces to use constants, you can ensure that only appropriate constants are used for specific masks, you can easily break apart and explain masks, and in general it is much easier for the user to interact with masks. The module only interacts with masks that fit in Perl integers. In some places, it presumes that you are using 32 bit integers (i.e. canonicalizing negative values). The module expends a modest amount of overhead in creating the C object so as to speed up future mask manipulations. Calls to C, C, and C are memoized to speed up repeated calls with the same parameters. =head2 Installation instructions There are four options for installing this module: =over 4 =item * Using C or later: Build.PL perl build test perl build install =item * Using C (part of the Perl core): Makefile.PL make test make install =item * Using the PPM (the file has the extension C<.ppm.zip>) on CPAN and installing under ActivePerl for Win32 by unzipping the C<.ppm.zip> file and then: ppm install Data-BitMask.ppd =item * Installing manually by copying C to C. =back =head1 Suggested Module Implementation Here is one suggested approach to using bitmask manipulators in a module. { my $cache; sub SECURITY_INFORMATION { $cache ||= Data::BitMask->new( OWNER_SECURITY_INFORMATION => 0x1, GROUP_SECURITY_INFORMATION => 0x2, DACL_SECURITY_INFORMATION => 0x4, SACL_SECURITY_INFORMATION => 0x8, ); } } The bitmask manipulator can then be accessed as: &SECURITY_INFORMATION->build_mask('DACL_SECURITY_INFORMATION'); Or, if you are outside of the module, as: &Win32::Security::SECURITY_INFORMATION->build_mask('DACL_SECURITY_INFORMATION'); This has several advantages: =over 4 =item * Demand creation of the C object. Creating objects with huge numbers of constants (i.e. hundreds or thousands) can be a bit time consuming, so this delays creation until the object actually gets used. At the same time, the created object is cached. =item * Easy access from within in the module, reasonably easy access from outside the module. =item * If the user wants even easier access from outside the module, you can support Exporter and let the sub be exported. =back =head1 Method Reference =cut use strict; package Data::BitMask; use vars qw($VERSION $masks); $VERSION = '1.00'; $masks = {}; =head2 new Creates a new bitmask manipulator. Pass a list of constant and value pairs. The constants do not have to be disjoint, but order does matter. When executing C or C, constants that are earlier in the list take precedence over those later in the list. Constant names are not allowed to have space or pipes in them, and constant values have to be integers. Constant names are case insensitive but preserving. If the passed value for the constant name is an anonymous array, then it is presumed that the name is the first value and that the remainder consists of name-value pairs of parameters. The only currently supported parameter is C, which implies that the constant should only be returned from C or C if it perfectly matches the mask being explained. For example: [qw(FILES_ONLY_NO_INHERIT full_match 1)] => 1, =cut sub new { my $class = shift; my(@constants) = @_; scalar(@constants) % 2 and &croak("You have to pass an even number of parameters in \@constants."); my $self = { constants => \@constants, }; bless $self, $class; $self->_check_constants; return $self; } =head2 add_constants Adds constants to an existing bitmask manipulator. Pass a list of constant and value pairs as for C. Constants will be added to the end of the list (see C for an explanation of ordering concerns). The main use for C is adding aggregate constants created by using C. =cut sub add_constants { my $self = shift; my(@constants) = @_; scalar(@constants) % 2 and &croak("You have to pass an even number of parameters in \@constants."); push(@{$self->{constants}}, @constants); $self->_check_constants; } sub _iterate_constants { my $self = shift; my($sub) = @_; foreach my $i (0..@{$self->{constants}}/2-1) { my $name = $self->{constants}->[$i*2]; my $params; if (ref($name) eq 'ARRAY') { my(@temp) = @$name; $name = shift @temp; $params = {@temp}; } $sub->($self, $name, $self->{constants}->[$i*2+1], $params); } } sub _check_constants { my $self = shift; $self->_iterate_constants( sub { local $^W = 0; $_[1] =~ /(\s|\|)/ and &croak("Constant names cannot have spaces or pipes: '$_[1]'."); int($_[1]) eq $_[1] and &croak("Constant names cannot be integers: '$_[1]'."); int($_[2]) eq $_[2] or &croak("Constant values have to be integers: '$_[1]' '$_[2]'."); int($_[2]) < 0 and &croak("Constant values have to be positive integers: '$_[1]' '$_[2]'."); $_[2] = int($_[2]); }); $self->_build_forward_cache; $self->_build_reverse_cache; $self->_build_occlusion_cache; $self->{build_mask_cache} = {}; $self->{break_mask_cache} = {}; $self->{explain_mask_cache} = {}; } sub _build_forward_cache { my $self = shift; $self->{forward_cache} = {}; $self->_iterate_constants( sub { my($self, $name, $value, $params) = @_; $name = uc($name); if (exists $self->{forward_cache}->{$name}) { $self->{forward_cache}->{$name} != $value and &croak("Multiple values for constant '$name'."); } $self->{forward_cache}->{$name} = $value; }); } sub _build_reverse_cache { my $self = shift; $self->{reverse_cache} = {}; $self->{full_match} = {}; $self->_iterate_constants( sub { my($self, $name, $value, $params) = @_; push(@{$self->{reverse_cache}->{$value}}, $name); $self->{full_match}->{$name} = undef if $params->{full_match}; }); } sub _build_occlusion_cache { my $self = shift; $self->{occlusion_cache} = {}; my(@temp) = map {int($_)} keys %{$self->{reverse_cache}}; foreach my $valuer (@temp) { my $namer = $self->{reverse_cache}->{$valuer}->[0]; $self->{occlusion_cache}->{$namer} = []; foreach my $valued (@temp) { foreach my $named (@{$self->{reverse_cache}->{$valued}}) { $namer eq $named and next; if ( $valued == ($valued & $valuer) ) { push(@{$self->{occlusion_cache}->{$namer}}, $named); } } } } } =head2 build_mask This takes one of three things as a parameter: =over 4 =item * scalar - string is split on 'C<|>' and/or whitespace to generate a list of constants =item * ARRAY ref - elements are the list of constants =item * HASH ref - keys with true values are the list of constants; keys with false values are subtracted from the resultant mask =back In all situations, integers are legal in place of constant names and are treated as the value, after adding 2**32 to any negative integers. =cut sub build_mask { my $self = shift; my($struct) = @_; my(@add, @sub); local $^W = 0; my $build_mask_cache_key; if (ref($struct) eq 'ARRAY') { @add = map {uc($_)} @{$struct}; $build_mask_cache_key = 'ARRAY:' . join('|', @add); if (exists $self->{build_mask_cache}->{$build_mask_cache_key}) { return $self->{build_mask_cache}->{$build_mask_cache_key}; } } elsif (ref($struct) eq 'HASH') { $build_mask_cache_key = 'HASH:' . join('|', map {uc($_)} %$struct); if (exists $self->{build_mask_cache}->{$build_mask_cache_key}) { return $self->{build_mask_cache}->{$build_mask_cache_key}; } @add = map {uc($_)} grep {$struct->{$_}} keys %$struct; @sub = map {uc($_)} grep {!$struct->{$_}} keys %$struct; } elsif (int($struct) eq $struct) { return int($struct) < 0 ? int($struct) + 2**31 + 2**31 : int($struct); } else { $build_mask_cache_key = 'STRING:' . uc($struct); if (exists $self->{build_mask_cache}->{$build_mask_cache_key}) { return $self->{build_mask_cache}->{$build_mask_cache_key}; } @add = map {uc($_)} split(/\s*\|\s*|\s+/, $struct); } my $mask = 0; foreach my $i (@add) { if (int($i) eq $i) { $mask |= (int($i) < 0 ? int($i) + 2**31 + 2**31 : int($i)); } else { exists $self->{forward_cache}->{$i} or &croak("Unable to find constant '$i'"); $mask |= $self->{forward_cache}->{$i}; } } foreach my $i (@sub) { if (int($i) eq $i) { $mask &= ~(int($i) < 0 ? int($i) + 2**31 + 2**31 : int($i)); } else { exists $self->{forward_cache}->{$i} or &croak("Unable to find constant '$i'"); $mask &= ~$self->{forward_cache}->{$i}; } } $self->{build_mask_cache}->{$build_mask_cache_key} = $mask; return $mask; } =head2 break_mask Breaks a mask apart. Pass a mask value as an integer. Returns a hash of all constants whose values are subsets of the passed mask. Values are set to 1 so the result can safely be passed to C. Commonly used for operations like: if ($MaskManipulator->break_mask($my_mask_value)->{CONSTANT}) { Note that C accepts To eliminate a constant from explain_mask or break_mask unless it perfectly matches, use C constants. =cut sub break_mask { my $self = shift; my($mask) = @_; local $^W = 0; if (int($mask) eq $mask) { $mask = int($mask) < 0 ? int($mask) + 2**31 + 2**31 : int($mask); } else { $mask = $self->build_mask($mask); } if (exists $self->{break_mask_cache}->{$mask}) { return { %{$self->{break_mask_cache}->{$mask}} }; } my($struct) = {}; my $testmask = 0; $mask = int($mask + ($mask < 0 ? (2**31 + 2**31) : 0)); while (my($value, $names) = each(%{$self->{reverse_cache}})) { if ( int($value) == ($mask & int($value)) ) { my(@names) = grep {!exists $self->{full_match}->{$_}} @$names; scalar(@names) or next; @{$struct}{@names} = (1) x scalar(@names); $testmask |= int($value); } } $testmask == $mask or &croak("Unable to break down mask $mask completely. Found $testmask."); $self->{break_mask_cache}->{$mask} = $struct; return { %$struct }; } =head2 explain_mask Explains a mask in terms of a relatively minimal set of constants. Pass either a mask value as an integer or any valid parameter for C. Returns a hash of constants that will recreate the mask. Many times, this will be the minimum number of constants necessary to describe the mask. Note that creating the true minimum set of constants is somewhat painful (see Knapsack problem). The algorithm used by C is to first test for a constant that perfectly matches the mask. If one is found, this is the obvious answer. In the absence of a perfect match, C is used to generate a maximal solution. All simply occluded constants are then eliminated (that is to say, all constants in the list whose values are subsets of another single constant). This means, for instance, that if you had only three constants, AB => 3, BC => 6, and AC => 5, C would return all three when passed the value 7 because no one constant is a subset of any single one of the others. To eliminate a constant from explain_mask or break_mask unless it perfectly matches, use C constants. =cut sub explain_mask { my $self = shift; my($mask) = @_; local $^W = 0; if (int($mask) eq $mask) { $mask = int($mask) < 0 ? int($mask) + 2**31 + 2**31 : int($mask); } else { $mask = $self->build_mask($mask); } if (exists $self->{reverse_cache}->{$mask}) { return { $self->{reverse_cache}->{$mask}->[0] => 1 }; } if (exists $self->{explain_mask_cache}->{$mask}) { return { %{ $self->{explain_mask_cache}->{$mask} } }; } my $struct = $self->break_mask($mask); my(@temp) = keys(%$struct); foreach my $namer (@temp) { exists $struct->{$namer} or next; foreach my $named (@{$self->{occlusion_cache}->{$namer}}) { delete $struct->{$named} if exists $struct->{$named}; } } $self->{explain_mask_cache}->{$mask} = $struct; return { %$struct }; } =head2 build_const This takes one of two things as a parameter: =over 4 =item * scalar integer - if a scalar integer is passed, then the value is simply returned, after adding 2**32 to any negative integers =item * scalar - string is looked up in the list of constants =back =cut sub build_const { my $self = shift; my($const) = @_; local $^W = 0; if (int($const) eq $const) { return int($const) < 0 ? int($const) + 2**31 + 2**31 : int($const); } else { exists $self->{forward_cache}->{$const} or &croak("Unable to find constant '$const'"); return $self->{forward_cache}->{$const}; } } =head2 explain_const Looks for a perfect match for the passed mask value. Pass either a mask value as an integer or any valid parameter for C. If one is not found, it croaks. =cut sub explain_const { my $self = shift; my($const) = @_; local $^W = 0; if (int($const) eq $const) { $const = int($const) < 0 ? int($const) + 2**31 + 2**31 : int($const); } else { exists $self->{forward_cache}->{$const} or &croak("Unable to find constant '$const'"); $const = $self->{forward_cache}->{$const}; } return $self->{reverse_cache}->{$const}->[0] if exists $self->{reverse_cache}->{$const}; &croak("Unable to lookup $const."); } =head2 get_constants Returns all constants passed either to C or C. =cut sub get_constants { my $self = shift; return @{$self->{constants}}; } ### croak autoload is courtesy of Mark Jason-Dominus, ### http://perl.plover.com/yak/tricks/samples/slide122.html sub croak { require Carp; local $^W = 0; *croak = \&Carp::croak; goto &croak; } =head1 AUTHOR Toby Ovod-Everett, toby@ovod-everett.org =head1 LICENSE Copyright 2003, 2004 Toby Ovod-Everett. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1;Data-BitMask-1.00/t/0000755000175000017500000000000014673374240012624 5ustar tobytobyData-BitMask-1.00/t/test.t0000444000175000017500000002407214673374240013773 0ustar tobytoby# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' $^W++; use strict; use Test; use Data::Dumper; BEGIN { $|++; plan tests => 137, todo => [ ] } use Data::BitMask; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; # Create empty { my $b1 = Data::BitMask->new(); ok( scalar($b1->get_constants()), 0 ); ok( &hash_dump($b1->explain_mask(0)), &hash_dump( {} ) ); eval { $b1->explain_mask(1) }; ok( $@ =~ /^Unable to break down mask 1 completely. Found 0\./ ); eval { $b1->explain_const(0) }; ok( $@ =~ /^Unable to lookup 0\./ ); my(@consts) = ( A => 1, B => 2, AB => 3, BA => 3, C => 4, AC => 5, CA => 5, BC => 6, CB => 6, ABC => 7, ACB => 7, BAC => 7, BCA => 7, CAB => 7, CBA => 7, D => 8, ); $b1->add_constants( @consts ); ok( Data::Dumper->Dump([[$b1->get_constants()]]), Data::Dumper->Dump([\@consts]) ); ok( $b1->build_mask('A|B'), 3); ok( $b1->build_mask('A |B'), 3); ok( $b1->build_mask('A| B'), 3); ok( $b1->build_mask('A B'), 3); ok( $b1->build_mask('A B'), 3); ok( $b1->build_mask('A | B'), 3); ok( $b1->build_mask('5'), 5); ok( $b1->build_mask('-5'), 4294967291); ok( $b1->build_mask('A|2'), 3); ok( $b1->build_mask('1 |B'), 3); ok( $b1->build_mask('A| 2'), 3); ok( $b1->build_mask('1 B'), 3); ok( $b1->build_mask('A 2'), 3); ok( $b1->build_mask('1 | B'), 3); ok( $b1->build_mask('A|5'), 5); ok( $b1->build_mask('A|6'), 7); ok( $b1->build_mask('A|-4'), 4294967293); ok( $b1->build_mask([qw(A B)]), 3); ok( $b1->build_mask({A=>1, B=>1}), 3); ok( $b1->build_mask({A=>1, B=>1, C=>0}), 3); ok( $b1->build_mask({A=>1, 2=>1, C=>0}), 3); ok( $b1->build_mask({A=>1, B=>1, 84=>0}), 3); ok( $b1->build_mask({A=>1, B=>1, 84=>1}), 87); ok( $b1->build_mask({AB=>1}), 3); ok( $b1->build_mask({AB=>1, B=>0}), 1); ok( $b1->build_mask({AB=>1, 2=>0}), 1); ok( $b1->build_mask({Ab=>1}), 3); eval { $b1->build_mask({ABb=>1}) }; ok( $@ =~ /^Unable to find constant \'ABB\'/); ok( $b1->explain_const(7), 'ABC'); ok( &hash_dump($b1->explain_mask(7)), &hash_dump({ABC => 1}) ); ok( &hash_dump($b1->explain_mask(3)), &hash_dump({AB => 1}) ); ok( &hash_dump($b1->explain_mask(15)), &hash_dump({ABC => 1, D => 1}) ); ok( &hash_dump($b1->break_mask(3)), &hash_dump({A => 1, B => 1, AB => 1, BA => 1}) ); ok( &hash_dump($b1->explain_mask(11)), &hash_dump({AB => 1, D => 1}) ); ok( &hash_dump($b1->break_mask(11)), &hash_dump({A => 1, B => 1, AB => 1, BA => 1, D => 1}) ); eval { $b1->break_mask(21) }; ok( $@ =~ /^Unable to break down mask 21 completely. Found 5\./); eval { $b1->explain_mask(21) }; ok( $@ =~ /^Unable to break down mask 21 completely. Found 5\./); my $b2 = Data::BitMask->new(($b1->get_constants())[0..17]); ok( &hash_dump($b2->explain_mask(7)), &hash_dump({AB => 1, AC => 1, BC => 1}) ); my $b3 = Data::BitMask->new('A' => 1, 'b' => 2, 'Ab' => 3, 'c' => 4, [qw(bc full_match 1)] => 6); ok( $b3->build_mask('A|B'), 3 ); ok( &hash_dump($b3->break_mask(3)), &hash_dump({A => 1, b => 1, Ab => 1}) ); ok( &hash_dump($b3->explain_mask(3)), &hash_dump({Ab => 1}) ); ok( &hash_dump($b3->explain_mask(7)), &hash_dump({Ab => 1, c => 1}) ); #Verify build_mask_cache for ARRAY is case insensitive and order sensitive $b1->{build_mask_cache} = {}; ok( scalar(keys %{$b1->{build_mask_cache}}), 0 ); ok( $b1->build_mask([qw(A B)]), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 1 ); ok( $b1->build_mask([qw(A B)]), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 1 ); ok( $b1->build_mask([qw(a B)]), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 1 ); ok( $b1->build_mask([qw(B A)]), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 2 ); #Verify build_mask_cache for HASH is case insensitive, but due to order #sensitivity and HASH ordering behavior it may be case sensitive ok( $b1->build_mask({A => 1}), 1); ok( scalar(keys %{$b1->{build_mask_cache}}), 3 ); ok( $b1->build_mask({A => 1}), 1); ok( scalar(keys %{$b1->{build_mask_cache}}), 3 ); ok( $b1->build_mask({A => 0}), 0); ok( scalar(keys %{$b1->{build_mask_cache}}), 4 ); ok( $b1->build_mask({a => 1}), 1); ok( scalar(keys %{$b1->{build_mask_cache}}), 4 ); ok( $b1->build_mask({A => 1, B => 1}), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 5 ); ok( $b1->build_mask({A => 1, b => 1}), 3); ok( sub { (scalar(keys %{$b1->{build_mask_cache}}) >= 5 ) && (scalar(keys %{$b1->{build_mask_cache}}) <= 6 ) } , 1 ); delete $b1->{build_mask_cache}->{'HASH:A|1|B|1'}; ok( sub { (scalar(keys %{$b1->{build_mask_cache}}) >= 4 ) && (scalar(keys %{$b1->{build_mask_cache}}) <= 5 ) } , 1 ); delete $b1->{build_mask_cache}->{'HASH:B|1|A|1'}; ok( scalar(keys %{$b1->{build_mask_cache}}), 4 ); #Verify build_mask_cache for STRING is case insensitive, order sensitive, and space sensitive ok( $b1->build_mask('A|B'), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 5 ); ok( $b1->build_mask('A|B'), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 5 ); ok( $b1->build_mask('a|B'), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 5 ); ok( $b1->build_mask('B|A'), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 6 ); ok( $b1->build_mask('B |A'), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 7 ); ok( $b1->build_mask('B| A'), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 8 ); #Verify build_mask_cache for ARRAY is return value mutation safe my $foo = $b1->build_mask([qw(A B)]); ok( $foo, 3 ); $foo = 4; ok( $foo, 4 ); ok( $b1->build_mask([qw(A B)]), 3); #Verify build_mask_cache for ARRAY is actually used $b1->{build_mask_cache}->{'ARRAY:A|B'} = 42; ok( $b1->build_mask([qw(A B)]), 42); #Verify build_mask_cache for HASH is return value mutation safe my $foo = $b1->build_mask({A => 1}); ok( $foo, 1 ); $foo = 4; ok( $foo, 4 ); ok( $b1->build_mask({A => 1}), 1); #Verify build_mask_cache for HASH is actually used $b1->{build_mask_cache}->{'HASH:A|1'} = 42; ok( $b1->build_mask({A => 1}), 42); #Verify build_mask_cache for STRING is return value mutation safe my $foo = $b1->build_mask('A|B'); ok( $foo, 3 ); $foo = 4; ok( $foo, 4 ); ok( $b1->build_mask('A|B'), 3); #Verify build_mask_cache for STRING is actually used $b1->{build_mask_cache}->{'STRING:A|B'} = 42; ok( $b1->build_mask('A|B'), 42); #Verify add_constants resets build_mask_cache $b1->add_constants('BMC_Reset', 42); ok( scalar(keys %{$b1->{build_mask_cache}}), 0 ); ok( $b1->build_mask([qw(A B)]), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 1 ); ok( $b1->build_mask({A => 1}), 1); ok( scalar(keys %{$b1->{build_mask_cache}}), 2 ); ok( $b1->build_mask('A|B'), 3); ok( scalar(keys %{$b1->{build_mask_cache}}), 3 ); #Verify break_mask_cache works $b1->{break_mask_cache} = {}; ok( scalar(keys %{$b1->{break_mask_cache}}), 0 ); ok( &hash_dump($b1->break_mask(3)), &hash_dump({A => 1, B => 1, AB => 1, BA => 1}) ); ok( scalar(keys %{$b1->{break_mask_cache}}), 1 ); ok( &hash_dump($b1->break_mask(3)), &hash_dump({A => 1, B => 1, AB => 1, BA => 1}) ); ok( scalar(keys %{$b1->{break_mask_cache}}), 1 ); ok( &hash_dump($b1->break_mask(11)), &hash_dump({A => 1, B => 1, AB => 1, BA => 1, D => 1}) ); ok( scalar(keys %{$b1->{break_mask_cache}}), 2 ); #Verify break_mask_cache is return value mutation safe my $foo = $b1->break_mask(3); ok( &hash_dump($foo), &hash_dump({A => 1, B => 1, AB => 1, BA => 1}) ); $foo->{BMC} = 1; ok( &hash_dump($foo), &hash_dump({A => 1, B => 1, AB => 1, BA => 1, BMC => 1}) ); ok( &hash_dump($b1->break_mask(3)), &hash_dump({A => 1, B => 1, AB => 1, BA => 1}) ); #Verify break_mask_cache is return value mutation safe for first call my $foo = $b1->break_mask(5); ok( &hash_dump($foo), &hash_dump({A => 1, C => 1, AC => 1, CA => 1}) ); $foo->{BMC} = 1; ok( &hash_dump($foo), &hash_dump({A => 1, C => 1, AC => 1, CA => 1, BMC => 1}) ); ok( &hash_dump($b1->break_mask(5)), &hash_dump({A => 1, C => 1, AC => 1, CA => 1}) ); #Verify break_mask_cache is actually used $b1->{break_mask_cache}->{3} = {BMC => 42}; ok( &hash_dump($b1->break_mask(3)), &hash_dump({ BMC => 42 })); #Verify add_constants resets break_mask_cache $b1->add_constants('BRKMC_Reset', 42); ok( scalar(keys %{$b1->{break_mask_cache}}), 0 ); ok( &hash_dump($b1->break_mask(3)), &hash_dump({A => 1, B => 1, AB => 1, BA => 1}) ); ok( scalar(keys %{$b1->{break_mask_cache}}), 1 ); #Verify explain_mask_cache works $b1->{explain_mask_cache} = {}; ok( scalar(keys %{$b1->{explain_mask_cache}}), 0 ); ok( &hash_dump($b1->explain_mask(3)), &hash_dump({AB => 1}) ); ok( scalar(keys %{$b1->{explain_mask_cache}}), 0 ); ok( &hash_dump($b1->explain_mask(11)), &hash_dump({AB => 1, D => 1}) ); ok( scalar(keys %{$b1->{explain_mask_cache}}), 1 ); ok( &hash_dump($b1->explain_mask(11)), &hash_dump({AB => 1, D => 1}) ); ok( scalar(keys %{$b1->{explain_mask_cache}}), 1 ); ok( &hash_dump($b1->explain_mask(15)), &hash_dump({ABC => 1, D => 1}) ); ok( scalar(keys %{$b1->{explain_mask_cache}}), 2 ); #Verify explain_mask_cache is return value mutation safe my $foo = $b1->explain_mask(11); ok( &hash_dump($foo), &hash_dump({AB => 1, D => 1}) ); $foo->{BMC} = 1; ok( &hash_dump($foo), &hash_dump({AB => 1, D => 1, BMC => 1}) ); ok( &hash_dump($b1->explain_mask(11)), &hash_dump({AB => 1, D => 1}) ); #Verify explain_mask_cache is return value mutation safe for first call my $foo = $b1->explain_mask(13); ok( &hash_dump($foo), &hash_dump({AC => 1, D => 1}) ); $foo->{BMC} = 1; ok( &hash_dump($foo), &hash_dump({AC => 1, D => 1, BMC => 1}) ); ok( &hash_dump($b1->explain_mask(13)), &hash_dump({AC => 1, D => 1}) ); #Verify explain_mask_cache is actually used $b1->{explain_mask_cache}->{11} = {BMC => 42}; ok( &hash_dump($b1->explain_mask(11)), &hash_dump({ BMC => 42 })); #Verify add_constants resets explain_mask_cache $b1->add_constants('EMC_Reset', 42); ok( scalar(keys %{$b1->{explain_mask_cache}}), 0 ); ok( &hash_dump($b1->explain_mask(11)), &hash_dump({AB => 1, D => 1}) ); ok( scalar(keys %{$b1->{explain_mask_cache}}), 1 ); } sub hash_dump { return Data::Dumper->Dump([[sort keys %{$_[0]}], [map {$_[0]->{$_}} sort keys %{$_[0]}]]); }Data-BitMask-1.00/META.yml0000444000175000017500000000111114673374240013622 0ustar tobytoby--- abstract: 'bitmask manipulation' author: - 'Toby Ovod-Everett, toby@ovod-everett.org' build_requires: {} configure_requires: Module::Build: '0.42' dynamic_config: 1 generated_by: 'Module::Build version 0.4234, 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: Data-BitMask provides: Data::BitMask: file: lib/Data/BitMask.pm version: '1.00' resources: license: http://dev.perl.org/licenses/ version: '1.00' x_serialization_backend: 'CPAN::Meta::YAML version 0.018'