File Coverage

blib/lib/Bitmask/Data.pm
Criterion Covered Total %
statement 242 242 100.0
branch 49 50 98.0
condition 18 23 78.2
subroutine 50 50 100.0
pod 25 26 96.1
total 384 391 98.2


line stmt bran cond sub pod time code
1             # ============================================================================
2             package Bitmask::Data;
3             # ============================================================================
4 9     9   105514 use strict;
  9         21  
  9         298  
5 9     9   46 use warnings;
  9         16  
  9         380  
6              
7 9     9   1107 use parent qw(Class::Data::Inheritable);
  9         432  
  9         77  
8 9     9   11760 use 5.010;
  9         32  
  9         340  
9              
10 9     9   81 use Carp;
  9         20  
  9         651  
11 9     9   46 use Config;
  9         18  
  9         475  
12 9     9   56 use List::Util qw(reduce);
  9         20  
  9         1250  
13 9     9   62 use Scalar::Util qw(blessed);
  9         18  
  9         11831  
14              
15             our $VERSION = version->new('2.04');
16             our $AUTHORITY = 'cpan:MAROS';
17              
18             our $ZERO = chr(0);
19             our $ONE = chr(1);
20              
21             =encoding utf8
22              
23             =head1 NAME
24              
25             Bitmask::Data - Handle unlimited length bitmasks in an easy and flexible way
26              
27             =head1 SYNOPSIS
28              
29             # Create a simple bitmask class
30             package MyBitmask;
31             use base qw(Bitmask::Data);
32             __PACKAGE__->bitmask_length(18);
33             __PACKAGE__->bitmask_default('0b000000000000000011');
34             __PACKAGE__->init(
35             'value1' => '0b000000000000000001',
36             'value2' => '0b000000000000000010',
37             'value2' => '0b000000000000000100',
38             'value4' => '0b000000000000001000',
39             'value5' => '0b000000000000010000',
40             ...
41             );
42            
43             ## Somewhere else in your code
44             use MyBitmask;
45             my $bm1 = MyBitmask->new('value1','value3');
46             my $bm2 = MyBitmask->new('0b000000000000010010');
47             $bm1->add('value3');
48             my $bm3 = $bm1 | $bm2;
49             $bm3->string;
50              
51             =head1 DESCRIPTION
52              
53             This package helps you dealing with bitmasks. First you need to subclass
54             Bitmask::Data and set the bitmask values and length. (If you are only working
55             with a single bitmask in a simple application you might also initialize
56             the bitmask directly in the Bitmask::Data module).
57              
58             After the initialization you can create an arbitrary number of bitmask
59             objects which can be accessed and manipulated with convenient methods and
60             overloaded arithmetic and bit operators.
61              
62             Bitmask::Data does not store bitmasks as integers internally, but as
63             strings conststing of \0 and \1, hence makinging unlimited length bitmasks
64             possible (32-bit perl can handle integer bitmasks only up to 40 bits).
65              
66             =head1 METHODS
67              
68             =head2 Class Methods
69              
70             =head3 bitmask_length
71              
72             Set/Get the length of the bitmask. Do not change this value after the
73             initialization.
74              
75             Bitmask length is unlimited.
76              
77             Default: 16
78              
79             =head3 bitmask_default
80              
81             Set/Get the default bitmask for empty Bitmask::Data objects.
82              
83             Default: undef
84              
85             =head3 bitmask_lazyinit
86              
87             If true value that disables warnings for lazy initialization. (Lazy
88             initialization = call of init without bitmask bit values).
89              
90             Default: 0
91              
92             __PACKAGE__->bitmask_lazyinit(1);
93             __PACKAGE__->bitmask_length(6);
94             __PACKAGE__->init(
95             'value1', # will be 0b000001
96             'value2', # will be 0b000010
97             'value3' # will be 0b000100
98             );
99            
100             If bitmask_lazyinit is 2 then bit values will be filled from left to right,
101             otherwise from right to left
102            
103             __PACKAGE__->bitmask_lazyinit(2);
104             __PACKAGE__->bitmask_length(6);
105             __PACKAGE__->init(
106             'value1', # will be 0b100000
107             'value2', # will be 0b010000
108             'value3' # will be 0b001000
109             );
110              
111             =head3 bitmask_items
112              
113             HASHREF of all bitmask items, with values as keys and bitmask as values.
114              
115             =head3 init
116              
117             CLASS->init(LIST of VALUES);
118              
119             Initializes the bitmask class. You can supply a list of possible values.
120             Optionally you can also specify the bits for the mask by adding bit values
121             after the value.
122            
123             CLASS->init(
124             'value1' => 0b000001,
125             'value2' => 0b000010,
126             'value3' => 0b001000,
127             'value4' => 0b010000,
128             );
129            
130             With C enabled you can also skip the bitmask bit values
131              
132             CLASS->bitmask_lazyinit(1);
133             CLASS->init(
134             'value1',
135             'value2',
136             'value3',
137             'value4',
138             );
139              
140             Bits may be supplied as integers, strings or Math::BigInt objects
141             (not recommended).
142              
143             CLASS->init(
144             'value1' => 0b000001, # integer
145             'value2' => 2, # integer
146             'value3' => '0b000100' # string starting with '0b'
147             'value4' => '0B001000' # string starting with '0B'
148             'value5' => '\0\1\0\0\0\0' # string consisting of \0 and \1
149             'value6' => Math::BigInt->new("32") # Math::BigInt object
150             );
151              
152             =cut
153              
154             __PACKAGE__->mk_classdata( bitmask_length => 16 );
155             __PACKAGE__->mk_classdata( bitmask_items => {} );
156             __PACKAGE__->mk_classdata( bitmask_default => undef );
157             __PACKAGE__->mk_classdata( bitmask_lazyinit => 0 );
158             __PACKAGE__->mk_classdata( bitmask_empty => undef );
159             __PACKAGE__->mk_classdata( bitmask_full => undef );
160              
161             use overload
162             '<=>' => '_compare',
163             'cmp' => '_compare',
164             '==' => '_equals',
165             'eq' => '_equals',
166             '~~' => sub {
167 9     9   25 my ($self,$value) = @_;
168 9         20 my $bitmask = $self->any2bitmask($value);
169 9 100       32 return (($bitmask & $self->{bitmask}) ne $self->bitmask_empty) ? 1:0;
170             },
171             'bool' => sub {
172 9     9   437 my ($self) = @_;
173 9 100       24 return ($self->{bitmask} ne $self->bitmask_empty) ? 1:0;
174             },
175             '0+' => 'integer',
176             '""' => 'string',
177             '+=' => 'add',
178             '-=' => 'remove',
179             '+' => sub {
180 2     2   603 my ($self,$value) = @_;
181 2         9 return $self->clone->add($value);
182             },
183             '-' => sub {
184 1     1   11 my ($self,$value) = @_;
185 1         4 return $self->clone->remove($value);
186             },
187             '&' => sub {
188 1     1   305 my ($self,$value) = @_;
189 1         4 my $bitmask = $self->any2bitmask($value);
190 1         4 return $self->new_from_bitmask($self->{bitmask} & $bitmask);
191             },
192             '^' => sub {
193 1     1   2 my ($self,$value) = @_;
194 1         4 my $bitmask = $self->any2bitmask($value);
195 1         4 return $self->new_from_bitmask($self->{bitmask} ^ $bitmask);
196             },
197             '|' => sub {
198 1     1   3 my ($self,$value) = @_;
199 1         4 my $bitmask = $self->any2bitmask($value);
200 1         5 return $self->new_from_bitmask($self->{bitmask} | $bitmask);
201             },
202             '&=' => sub {
203 1     1   2 my ($self,$value) = @_;
204 1         3 my $bitmask = $self->any2bitmask($value);
205 1         3 $self->{bitmask} &= $bitmask;
206             #$self->{cache} = undef;
207 1         2 return $self;
208             },
209             '^=' => sub {
210 1     1   3 my ($self,$value) = @_;
211 1         4 my $bitmask = $self->any2bitmask($value);
212 1         2 $self->{bitmask} ^= $bitmask;
213             #$self->{cache} = undef;
214 1         3 return $self;
215             },
216             '|=' => sub {
217 1     1   2 my ($self,$value) = @_;
218 1         3 my $bitmask = $self->any2bitmask($value);
219 1         3 $self->{bitmask} |= $bitmask;
220             #$self->{cache} = undef;
221 1         34 return $self;
222             },
223             "~" => sub {
224 1     1   12 my ($self) = @_;
225 1         6 return $self->clone->neg();
226 9     9   4175 };
  9         2668  
  9         308  
227            
228             sub _equals {
229 3     3   163 my ($self,$value) = @_;
230 3         8 my $bitmask = $self->any2bitmask($value);
231 3         25 return ($self->{bitmask} eq $bitmask);
232             }
233            
234             sub _compare {
235 6     6   15 my ($self,$value) = @_;
236              
237 6         27 my $bitmask = $self->any2bitmask($value);
238            
239 6         35 return $self->{bitmask} cmp $bitmask;
240             }
241              
242             sub init {
243 17     17 1 125388 my ($class,@params) = @_;
244              
245 17         66 my $length = $class->bitmask_length;
246              
247 17 100 100     239 croak('Bitmask length not set')
248             unless $length && $length > 0;
249            
250 15         102 $class->bitmask_empty($ZERO x $length);
251              
252 15         281 my $items = {};
253 15         29 my $count = 0;
254 15         67 my $bitmask_full = $class->bitmask_empty();
255            
256             # Take first element from @params
257 15         147 while (my $name = shift(@params)) {
258 225         238 my ($bit,$bit_readable);
259              
260 225         221 $count++;
261            
262 225 100       601 croak(sprintf('Too many values in bitmask: max <%i>',$class->bitmask_length))
263             if $count > $class->bitmask_length;
264              
265 224   100     1878 given ( $params[0] // '' ) {
266 224   66     695 when (blessed $_ && $_->isa('Math::BigInt')) {
267 2         10 $bit = $class->string2bit(shift(@params)->as_bin());
268             }
269 222         690 when (m/^\d+$/) {
270 32         109 $bit = $class->int2bit(shift(@params));
271             }
272 190         249 when (m/^0[bB][01]+$/) {
273 3         23 $bit = $class->string2bit(shift(@params));
274             }
275 187         625 when (m/^[$ZERO$ONE]+$/) {
276 2         12 $bit = $class->bit2bit(shift(@params));
277             }
278 185         223 default {
279 185 100       535 carp( "Lazy bitmask initialization detected: Please enable"
280             . " or change init parameters" )
281             unless ( $class->bitmask_lazyinit );
282 185         4188 $bit = $class->bitmask_empty;
283            
284 185 100       1201 if ($class->bitmask_lazyinit == 2) {
285 5         46 substr($bit,($count-1),1,$ONE);
286             } else {
287 180         1464 substr($bit,($length-$count),1,$ONE);
288             }
289            
290             }
291             }
292            
293 224         341 $bit_readable = $bit;
294 224         301 $bit_readable =~ tr/\0\1/01/;
295            
296 224 100       1293 croak(sprintf('Invalid bit value <%s>',$bit_readable))
297             unless $bit =~ /^[$ZERO$ONE]{$length}$/;
298              
299 223 100       512 croak(sprintf('Duplicate value <%s> in bitmask',$name))
300             if exists $items->{$name};
301              
302 7095         52528 croak(sprintf('Duplicate bit <%s> in bitmask',$bit_readable))
303 222 100       308 if grep { ($_ & $bit) ne $class->bitmask_empty } values %{$items};
  222         2541  
304              
305 220         1617 $bitmask_full |= $bit;
306 220         1030 $items->{$name} = $bit;
307             }
308              
309 10         90 $class->bitmask_full($bitmask_full);
310 10         334 $class->bitmask_items($items);
311 10 100       288 $class->bitmask_default($class->any2bitmask($class->bitmask_default))
312             if defined $class->bitmask_default;
313 9         117 return;
314             }
315              
316             =head3 int2bit
317              
318             my $bitmask_string = CLASS->int2bit(INTEGER);
319              
320             Helper method that turns an integer into the internal bitmask representation
321              
322             =cut
323              
324             sub int2bit {
325 53     53 1 83 my ($class,$integer) = @_;
326            
327 53         141 my $bit = sprintf( '%0' . $class->bitmask_length . 'b', $integer );
328 53         488 $bit =~ tr/01/\0\1/;
329 53         159 return $bit;
330             }
331              
332             =head3 string2bit
333              
334             my $bitmask_string = CLASS->string2bit(STRING);
335              
336             Helper method that takes a string like '0B001010' or '0b010101' and turns it
337             into the internal bitmask representation
338              
339             =cut
340              
341             sub string2bit {
342 13     13 1 320 my ($class,$string) = @_;
343              
344 13         48 $string =~ s/^0[bB]//;
345 13         41 $string = sprintf( '%0' . $class->bitmask_length . 's', $string );
346 13         124 $string =~ tr/01/\0\1/;
347 13         45 return $string;
348             }
349              
350             sub bit2bit {
351 21     21 0 38 my ($class,$bit) = @_;
352            
353 21         67 $bit = $ZERO x ($class->bitmask_length - length($bit)) . $bit;
354 21         195 return $bit;
355             }
356              
357             =head3 any2bitmask
358              
359             my $bitmask_string = CLASS->any2bitmask(ANYTHING);
360              
361             Helper method that tries to turn a data into the internal bitmask
362             representation. This method can hanle
363              
364             =over
365              
366             =item * any Bitmask::Data object
367              
368             =item * Math::BigInt object
369              
370             =item * a string matching on of the bitmask values
371              
372             =item * a bitmask string consisting of \0 and \1 characters
373              
374             =item * a bitmask string starting with '0b' or '0B' and containing only 0 and 1
375              
376             =item * an integer
377              
378             =back
379              
380             =cut
381              
382             sub any2bitmask {
383 104     104 1 232 my ($class,$param) = @_;
384              
385 104 50       225 croak "Bitmask, Item or integer expected"
386             unless defined $param;
387              
388 104         341 my $length = $class->bitmask_length;
389 104         588 my $bit;
390 104         147 given ($param) {
391 104   100     458 when (blessed $param && $param->isa('Bitmask::Data')) {
392 18         55 $bit = $class->bit2bit($param->{bitmask});
393             }
394 86   66     236 when (blessed $param && $param->isa('Math::BigInt')) {
395 2         11 $bit = $class->string2bit($param->as_bin());
396             }
397 84         201 when ($param ~~ $class->bitmask_items) {
398 54         605 $bit = $class->bitmask_items->{$param};
399             }
400 30         410 when (m/^[$ZERO$ONE]+$/) {
401 1         8 $bit = $class->bit2bit($param);
402             }
403 29         169 when (m/^[01]{$length}$/) {
404 2         11 $bit = $class->string2bit($param);
405             }
406 27         54 when (m/^0[bB][01]+$/) {
407 4         23 $bit = $class->string2bit($param);
408             }
409 23         80 when (m/^\d+$/) {
410 21         60 $bit = $class->int2bit($param);
411             }
412 2         4 default {
413 2         41 croak sprintf('Could not turn <%s> into something meaningful',$param);
414             }
415             }
416            
417 102 100       609 if (length $bit > $class->bitmask_length) {
418 4         29 croak sprintf('<%s> exceeds maximum lenth of %i',$param,$class->bitmask_length);
419             }
420            
421 98 100       729 if (($class->bitmask_full | $bit) ne $class->bitmask_full) {
422 1         20 croak sprintf('<%s> tries to set undefined bits',$param);
423             }
424              
425 97         1124 return $bit;
426             }
427              
428             =head3 _parse_params
429              
430             my $bitmask_string = CLASS->_parse_params(LIST)
431              
432             Helper method for parsing params passed to various methods.
433              
434             =cut
435              
436             sub _parse_params {
437 77     77   125 my ($class,@params) = @_;
438            
439 77         255 my $result_bitmask = $class->bitmask_empty;
440            
441 77         525 foreach my $param (@params) {
442             next
443 94 100       221 unless defined $param;
444            
445 82         96 my $bitmask;
446 82 100       166 if ( ref $param eq 'ARRAY' ) {
447 4         15 $bitmask = $class->_parse_params(@$param);
448             }
449             else {
450 78         199 $bitmask = $class->any2bitmask($param);
451             }
452              
453 75         199 $result_bitmask = $result_bitmask | $bitmask;
454             }
455              
456 70         169 return $result_bitmask;
457             }
458              
459             # TODO : method to return ordered bitmask items
460              
461             =head2 Overloaded operators
462              
463             Bitmask::Data uses overload by default.
464              
465             =over
466              
467             =item * Numeric context
468              
469             Returns bitmask integer value (see L method). For large bitmasks
470             (> 40 bits) this will allways be a L object (hence using this
471             method is not recommended).
472              
473             =item * Scalar context
474              
475             Returns bitmask string representation (see L method)
476              
477             =item * ==, eq, <=>, cmp
478              
479             Works like 'has_any'
480              
481             =item * Smartmatch
482              
483             Works like L.
484              
485             $bm = new Somebitmask->new('v1','v2');
486             $bm ~~ ['v1','v3'] # true, because 'v1' matches even if 'v3' is not set
487              
488             =item * +, -
489              
490             Adds/Removes bits to/from the bitmask without changing the current object.
491             The result is returned as a new Bitmask::Data object.
492              
493             =item * -=, +=
494              
495             Adds/Removes bits to/from the current bitmask object.
496              
497             =item * ~, ^, &, |
498              
499             Performs the bitwise operations without changing the current object.
500             The result is returned as a new Bitmask::Data object.
501              
502             =item * ^=, &=, |=
503              
504             Performs the bitwise operations on the current bitmask object.
505              
506             =back
507              
508             =head2 Constructors
509              
510             =head3 new
511              
512             my $bm = MyBitmask->new();
513             my $bm = MyBitmask->new('value1');
514             my $bm = MyBitmask->new('0b00010000010000');
515             my $bm = MyBitmask->new(124);
516             my $bm = MyBitmask->new(0b00010000010000);
517             my $bm = MyBitmask->new(0x2);
518             my $bm = MyBitmask->new($another_bm_object);
519             my $bm = MyBitmask->new("\0\1\0\0\1");
520             my $bm = MyBitmask->new('value2', 'value3');
521             my $bm = MyBitmask->new([32, 'value1', 0b00010000010000]);
522              
523             Create a new bitmask object. You can supply almost any combination of
524             ARRAYREFS, bits, Bitmask::Data objects, Math::BigInt objects, bitmasks and
525             values, even mix different types. See L for details on possible
526             formats.
527              
528             =cut
529              
530             sub new {
531 27     27 1 26071 my ( $class, @args ) = @_;
532              
533 27         102 croak('Bitmask not initialized')
534 27 100       48 unless scalar keys %{ $class->bitmask_items };
535              
536 26         286 my $self = $class->new_from_bitmask($class->bitmask_empty);
537              
538 26 100       135 if (scalar @args) {
539 17         68 $self->set( @args );
540             } else {
541 9         41 $self->set( $class->bitmask_default );
542             }
543              
544 26         77 return $self;
545             }
546              
547             =head3 new_from_bitmask
548              
549             my $bm = MyBitmask->new_from_bitmask($bitmask_string);
550              
551             Create a new bitmask object from a bitmask string (as returned by many
552             helper methods).
553              
554             =cut
555              
556             sub new_from_bitmask {
557 35     35 1 246 my ( $class, $bitmask ) = @_;
558            
559 35 100       100 $class = ref($class)
560             if ref($class);
561            
562 35         127 my $self = bless {
563             #cache => undef,
564             bitmask => $bitmask,
565             },$class;
566            
567 35         79 return $self;
568             }
569              
570             =head2 Public Methods
571              
572             =head3 clone
573              
574             my $bm_new = $bm->clone();
575              
576             Clones an existing Bitmask::Data object and.
577              
578             =cut
579              
580             sub clone {
581 6     6 1 11 my ( $self ) = @_;
582            
583 6         24 my $new = $self->new_from_bitmask($self->{bitmask});
584             #$new->{cache} = $self->{cache};
585 6         30 return $new;
586             }
587              
588             =head3 set
589              
590             $bm->set(PARAMS);
591            
592             This methpd resets the current bitmask and sets the supplied arguments.
593             Takes the same arguments as C.
594              
595             Returns the object.
596              
597             =cut
598              
599             sub set {
600 27     27 1 118 my ( $self, @args ) = @_;
601              
602 27         77 $self->{bitmask} = $self->bitmask_empty;
603 27         1265 $self->add( @args );
604              
605 27         48 return $self;
606             }
607              
608             =head3 remove
609              
610             $bm->remove(PARAMS)
611            
612             Removes the given values/bits from the bitmask. Takes the same arguments
613             as C.
614              
615             Returns the object.
616              
617             =cut
618              
619             sub remove {
620 7     7 1 18 my ( $self, @args ) = @_;
621              
622 7         18 my $bitmask = $self->_parse_params(@args);
623              
624 7         26 $self->{bitmask} = $self->{bitmask} ^ ($self->{bitmask} & $bitmask);
625             #$self->{cache} = undef;
626            
627 7         27 return $self;
628             }
629              
630              
631             =head3 add
632              
633             $bm->add(PARAMS)
634            
635             Adds the given values/bits to the bitmask. Takes the same arguments
636             as C.
637              
638             Returns the object.
639              
640             =cut
641              
642             sub add {
643 50     50 1 5184 my ( $self, @args ) = @_;
644              
645 50         146 my $bitmask = $self->_parse_params(@args);
646            
647 44         112 $self->{bitmask} = $self->{bitmask} | $bitmask;
648             #$self->{cache} = undef;
649              
650 44         102 return $self;
651             }
652              
653             =head3 reset
654              
655             $bm->reset()
656            
657             Resets the bitmask to the default (or empty) bitmask.
658              
659             Returns the object.
660              
661             =cut
662              
663             sub reset {
664 3     3 1 295 my ($self) = @_;
665            
666 3   66     12 $self->{bitmask} = $self->bitmask_default || $self->bitmask_empty;
667             #$self->{cache} = undef;
668            
669 3         42 return $self;
670             }
671              
672              
673             =head3 set_all
674              
675             $bm->set_all()
676            
677             Sets all defined bits in the bitmask.
678              
679             Returns the object.
680              
681             =cut
682              
683             sub set_all {
684 3     3 1 16 my ($self) = @_;
685            
686 3         10 $self->{bitmask} = $self->bitmask_full;
687             #$self->{cache} = undef;
688            
689 3         32 return $self;
690             }
691             *setall = \&set_all;
692              
693             =head3 neg
694              
695             $bm->neg()
696            
697             Negates/Inverts the bitmask
698              
699             Returns the object.
700              
701             =cut
702              
703             sub neg {
704 2     2 1 5 my ( $self ) = @_;
705              
706 2         8 $self->{bitmask} =~ tr/\0\1/\1\0/;
707 2         11 $self->{bitmask} = $self->{bitmask} & $self->bitmask_full;
708             #$self->{cache} = undef;
709            
710 2         23 return $self;
711             }
712              
713             =head3 list
714              
715             my @values = $bm->list();
716             OR
717             my $values = $bm->list();
718              
719             In list context, this returns a list of the set values in scalar context,
720             this returns an array reference to the list of values.
721              
722             =cut
723              
724             sub list {
725 26     26 1 35 my ($self) = @_;
726            
727             #return (wantarray ? @{$self->{cache}} : $self->{cache})
728             # if defined $self->{cache};
729            
730 26         41 my @data;
731 26         36 while (my ($value,$bit) = each %{$self->bitmask_items()}) {
  228         1489  
732 202 100       1512 push @data,$value
733             if (($bit & $self->{bitmask}) ne $self->bitmask_empty);
734             }
735            
736             #$self->{cache} = \@data;
737            
738 26 100       242 return wantarray ? @data : \@data;
739             }
740              
741             =head3 length
742              
743             my $length = $bm->length();
744              
745             Number of set bitmask values.
746              
747             =cut
748              
749             sub length {
750 21     21 1 9309 my ($self) = @_;
751            
752 21         60 my @list = $self->list;
753 21         94 return scalar @list;
754             }
755              
756             =head3 first
757              
758             my $value = $bm->first()
759            
760             Returns the first set value. The order is determined by the bit value.
761              
762             =cut
763              
764             sub first {
765 3     3 1 9 my ($self) = @_;
766            
767 3         7 my $bitmask_items = $self->bitmask_items();
768 3         15 foreach my $key (sort { $bitmask_items->{$a} cmp $bitmask_items->{$b} } keys %{$bitmask_items}) {
  60         78  
  3         16  
769 14 100       98 return $key
770             if (($bitmask_items->{$key} & $self->{bitmask}) ne $self->bitmask_empty);
771             }
772 1         12 return;
773             }
774              
775             =head3 integer
776              
777             my $integer = $bm->integer();
778              
779             Returns the bitmask as an integer. For bitmasks with a length > 40 this will
780             always be a L object.
781              
782             =cut
783              
784             *mask = \&integer;
785             sub integer {
786 15     15 1 5295 my ($self) = @_;
787            
788 15         30 my $bitmask = $self->{bitmask};
789 15         33 $bitmask =~ tr/\0\1/01/;
790            
791 15 100 66     49 if ($self->bitmask_length > 64 || ($self->bitmask_length > 32 && ! $Config{use64bitint})) {
      66        
792 1         2227 require Math::BigInt;
793 1         24007 return Math::BigInt->from_bin("0b".$bitmask);
794             } else {
795 9     9   107182 no warnings 'portable';
  9         22  
  9         15713  
796 14         384 return oct("0b".$bitmask);
797             }
798             }
799              
800             =head3 string
801              
802             my $string = $bm->string();
803              
804             Returns the bitmask as a string of 0 and 1.
805              
806             =cut
807              
808             sub string {
809 33     33 1 1106 my ($self) = @_;
810 33         56 my $bitmask = $self->{bitmask};
811 33         59 $bitmask =~ tr/\0\1/01/;
812 33         128 return $bitmask;
813             }
814              
815             =head3 bitmask
816              
817             my $string = $bm->bitmask();
818              
819             Returns the bitmask in the internal representation: A string of \0 and \1
820              
821             =cut
822              
823             sub bitmask {
824 1     1 1 1192 my ($self) = @_;
825 1         6 return $self->{bitmask};
826             }
827              
828             =head3 sqlfilter_all
829              
830             This method can be used for database searches in conjunction with
831             L an POSTGRESQL (SQL::Abstract is used by L for
832             generating searches). The search will find all database rows
833             with bitmask that have at least the given values set. (use
834             the C method for an exact match)
835              
836             Example how to use sqlfilter with SQL::Abstract:
837              
838             my($stmt, @bind) = $sql->select(
839             'mytable',
840             \@fields,
841             {
842             $bm->sqlfilter_all('mytable.bitmaskfield'),
843             }
844             );
845              
846             Example how to use sqlfilter with DBIx::Class:
847            
848             my $list = $resultset->search(
849             {
850             $bm->sqlfilter_all('me.bitmaskfield'),
851             },
852             );
853              
854              
855             =cut
856              
857             sub sqlfilter_all {
858 1     1 1 2 my ( $self, $field ) = @_;
859              
860 1         3 my $sql_mask = $self->string();
861 1         4 my $format = "bitand( $field, B'$sql_mask' )";
862 1         4 return ( $format, \" = B'$sql_mask'" );
863             }
864             *sqlfilter = \&sqlfilter_all;
865              
866             =head3 sqlfilter_any
867              
868             Works like C but checks for any bit matching
869              
870             =cut
871              
872             sub sqlfilter_any {
873 1     1 1 611 my ( $self, $field ) = @_;
874              
875 1         8 my $sql_mask = $self->string();
876 1         4 my $format = "bitand( $field, B'$sql_mask' )";
877 1         3 my $empty_mask = $self->bitmask_empty;
878 1         7 $empty_mask =~ tr/\0\1/01/;
879 1         4 return ( $format, \" <> B'$empty_mask'" );
880             }
881              
882             =head3 sqlstring
883              
884             Returns the bitmask as a quoted string as needed by PostgreSQL:
885              
886             B'0000000000000001'::bit(16)
887              
888             =cut
889              
890             sub sqlstring {
891 1     1 1 588 my ( $self ) = @_;
892 1         3 return sprintf("B'%s'::bit(%i)",$self->string,$self->bitmask_length);
893             }
894              
895             =head3 has_all
896              
897             if ($bm->has_all(PARAMS)) {
898             # Do something
899             }
900              
901             Checks if all requestes bits/values are set and returns true or false.
902             This method takes the same arguments as C.
903              
904             =cut
905              
906             sub has_all {
907 4     4 1 10 my ( $self, @args ) = @_;
908              
909 4         8 my $bitmask = $self->_parse_params(@args);
910            
911 4 100       22 return (($bitmask & $self->{bitmask}) eq $bitmask) ? 1:0;
912             }
913             *hasall = \&has_all;
914              
915             =head3 has_exact
916              
917             if ($bm->has_exact(PARAMS)) {
918             # Do something
919             }
920              
921             Checks if the set bits/values excactly match the supplied bits/values and
922             returns true or false.
923             This method takes the same arguments as C.
924              
925             =cut
926              
927             sub has_exact {
928 6     6 1 16 my ( $self, @args ) = @_;
929              
930 6         12 my $bitmask = $self->_parse_params(@args);
931              
932 6 100       36 return ($bitmask eq $self->{bitmask}) ? 1:0;
933             }
934             *hasexact = \&has_exact;
935              
936             =head3 has_any
937              
938             if ($bm->has_any(PARAMS)) {
939             # Do something
940             }
941              
942             Checks if at least one set value/bit matches the supplied bits/values and
943             returns true or false.
944             This method takes the same arguments as C.
945              
946             =cut
947              
948             sub has_any {
949 6     6 1 13 my ( $self, @args ) = @_;
950              
951 6         12 my $bitmask = $self->_parse_params(@args);
952            
953 6 100       21 return (($bitmask & $self->{bitmask}) ne $self->bitmask_empty) ? 1:0;
954             }
955             *hasany = \&has_any;
956              
957             1;
958              
959             =head1 CAVEATS
960              
961             Since Bitmask::Data is very liberal with input data you cannot use numbers
962             as bitmask values. (It would think that you are supplying an integer
963             bitmask and not a value)
964              
965             Bitmask::Data adds a considerable processing overhead to bitmask
966             manipulations. If you either don't need the extra comfort or use
967             bitmasks with less that 40 bits that you should consider using just the perl
968             built in bit operators on simple integer values.
969              
970             =head1 SUBCLASSING
971              
972             Bitmask::Data was designed to be subclassed.
973            
974             package MyBitmask;
975             use parent qw(Bitmask::Data);
976             __PACKAGE__->bitmask_length(20); # Default length is 16
977             __PACKAGE__->init(
978             'value1' => 0b000000000000000001,
979             'value2' => 0x2,
980             'value2' => 4,
981             'value4', # lazy initlialization
982             'value5', # lazy initlialization
983             );
984              
985             =head1 WORKING WITH DATABASES
986              
987             This module comes with support for POSTGRESQL databases (patches for other
988             database vendors are welcome).
989              
990             First you need to create the correct column types:
991              
992             CREATE TABLE bitmaskexample (
993             id integer DEFAULT nextval('pkey_seq'::regclass) NOT NULL,
994             bitmask bit(14),
995             otherfields character varying
996             );
997              
998             The length of the bitmask field must match Cbitmask_length>.
999              
1000             This module provides three convenient methods to work with databases:
1001              
1002             =over
1003              
1004             =item * L: Search for matching bitmasks
1005              
1006             =item * L: Search for bitmasks with matching bits
1007              
1008             =item * L: Print the bitmask string as used by the database
1009              
1010             =back
1011              
1012             If you are working with l you might also install de- and
1013             inflators for Bitmask::Data objects:
1014              
1015             __PACKAGE__->inflate_column('fieldname',{
1016             inflate => sub {
1017             my $value = shift;
1018             return MyBitmask->new($value);
1019             },
1020             deflate => sub {
1021             my $value = shift;
1022             undef $value
1023             unless ref($value) && $value->isa('MyBitmask');
1024             $value //= MyBitmask->new();
1025             return $value->string;
1026             },
1027             });
1028              
1029             =head1 SUPPORT
1030              
1031             Please report any bugs or feature requests to
1032             C, or through the web interface at
1033             L.
1034             I will be notified and then you'll automatically be notified of the progress
1035             on your report as I make changes.
1036              
1037             =head1 AUTHOR
1038              
1039             Klaus Ita
1040             koki [at] worstofall.com
1041              
1042             Maroš Kollár
1043             CPAN ID: MAROS
1044             maros [at] k-1.com
1045            
1046             L
1047              
1048             =head1 ACKNOWLEDGEMENTS
1049              
1050             This module was originally written by Klaus Ita (Koki) for Revdev
1051             L, a nice litte software company I (Maros) run with
1052             Koki and Domm (L).
1053              
1054             =head1 COPYRIGHT & LICENSE
1055              
1056             Bitmask::Data is Copyright (c) 2008 Klaus Ita, Maroš Kollár
1057             - L
1058              
1059             This program is free software; you can redistribute it and/or modify it under
1060             the same terms as Perl itself.
1061              
1062             The full text of the license can be found in the
1063             LICENSE file included with this module.
1064              
1065             =cut