File Coverage

blib/lib/Data/Omap.pm
Criterion Covered Total %
statement 216 220 98.1
branch 91 106 85.8
condition 13 15 86.6
subroutine 38 38 100.0
pod 15 17 88.2
total 373 396 94.1


line stmt bran cond sub pod time code
1             #---------------------------------------------------------------------
2             package Data::Omap;
3             #---------------------------------------------------------------------
4              
5             =head1 NAME
6              
7             Data::Omap - Perl module to implement ordered mappings
8              
9             =head1 SYNOPSIS
10              
11             use Data::Omap;
12            
13             # Simple OO style
14            
15             my $omap = Data::Omap->new( [{a=>1},{b=>2},{c=>3}] );
16            
17             $omap->set( a => 0 );
18             $omap->add( b2 => 2.5, 2 ); # insert at position 2 (between b and c)
19            
20             my $value = $omap->get_values( 'c' ); # 3
21             my @keys = $omap->get_keys(); # (a, b, b2, c)
22             my @values = $omap->get_values(); # (0, 2, 2.5, 3)
23             my @subset = $omap->get_values(qw(c b)); # (2, 3) (values are data-ordered)
24            
25             # Tied style
26            
27             my %omap;
28             # recommend saving an object reference, too.
29             my $omap = tie %omap, 'Data::Omap', [{a=>1},{b=>2},{c=>3}];
30            
31             $omap{ a } = 0;
32             $omap->add( b2 => 2.5, 2 ); # there's no tied hash equivalent
33            
34             my $value = $omap{ c };
35             my @keys = keys %omap; # $omap->get_keys() is faster
36             my @values = values %omap; # $omap->get_values() is faster
37             my @slice = @omap{qw(c b)}; # (3, 2) (slice values are parameter-ordered)
38              
39             # Non-OO style
40              
41             use Data::Omap ':ALL';
42            
43             my $omap = [{a=>1},{b=>2},{c=>3}]; # new-ish, but not blessed
44              
45             omap_set( $omap, a => 0 ); # (pass omap as first parameter)
46             omap_add( $omap, b2 => 2.5, 2 ); # insert at position 2 (between b and c)
47            
48             my $value = omap_get_values( $omap, 'c' ); # 3
49             my @keys = omap_get_keys( $omap ); # (a, b, b2, c)
50             my @values = omap_get_values( $omap ); # (0, 2, 2.5, 3)
51             my @subset = omap_get_values( $omap, qw(c b) ); # (2, 3) (values are data-ordered)
52            
53             # There are more methods/options, see below.
54              
55             =head1 DESCRIPTION
56              
57             This module implements the Data::Omap class. Objects in this class
58             are ordered mappings, i.e., they are hashes in which the key/value
59             pairs are in order. This is defined in shorthand as C in the
60             YAML tag repository: http://yaml.org/type/omap.html.
61              
62             The keys in Data::Omap objects are unique, like regular hashes.
63              
64             A closely related class, Data::Pairs, implements the YAML C
65             data type, http://yaml.org/type/pairs.html. Data::Pairs objects are
66             also ordered sequences of key:value pairs but they allow duplicate
67             keys.
68              
69             While ordered mappings are in order, they are not necessarily in a
70             I order, i.e., they are not necessarily sorted in any
71             way. They simply have a predictable set order (unlike regular hashes
72             whose key/value pairs are in no set order).
73              
74             By default, Data::Omap will add new key/value pairs at the end of the
75             mapping, but you may request that they be merged in a particular
76             order with the C class method.
77              
78             However, even though Data::Omap will honor the requested order, it
79             will not attempt to I the mapping in that order. By passing
80             position values to the C and C methods, you may insert
81             new pairs anywhere in the mapping and Data::Omap will not complain.
82              
83             =head1 IMPLEMENTATION
84              
85             Normally, the underlying structure of an OO object is encapsulated
86             and not directly accessible (when you play nice). One key
87             implementation detail of Data::Omap is the desire that the underlying
88             ordered mapping data structure (an array of single-key hashes) be
89             publically maintained as such and directly accessible if desired.
90              
91             To that end, no attributes but the data itself are stored in the
92             objects. In the current version, that is why C is a class
93             method rather than an object method. In the future, inside-out
94             techniques may be used to enable object-level ordering.
95              
96             This data structure is inefficient in several ways as compared to
97             regular hashes: rather than one hash, it contains a separate hash per
98             key/value pair; because it's an array, key lookups (in the current
99             version) have to loop through it.
100              
101             The advantage if using this structure is simply that it "natively"
102             matches the structure defined in YAML. So if the (unblessed)
103             structure is dumped using YAML (or perhaps JSON), it may be read as
104             is by another program, perhaps in another language. It is true that
105             this could be accomplished by passing the object through a formatting
106             routine, but I wanted to see first how this implementation might work.
107              
108             =head1 VERSION
109              
110             Data::Omap version 0.06
111              
112             =cut
113              
114 8     8   332722 use 5.008003;
  8         37  
  8         335  
115 8     8   49 use strict;
  8         14  
  8         289  
116 8     8   42 use warnings;
  8         19  
  8         421  
117              
118             our $VERSION = '0.06';
119              
120 8     8   48 use Scalar::Util qw( reftype looks_like_number );
  8         13  
  8         1037  
121 8     8   77 use Carp;
  8         99  
  8         508  
122 8     8   43 use Exporter qw( import );
  8         888  
  8         23828  
123             our @EXPORT_OK = qw(
124             omap_set omap_get_values omap_get_keys
125             omap_exists omap_delete omap_clear
126             omap_add omap_order omap_get_pos
127             omap_get_pos_hash omap_get_array
128             omap_is_valid omap_errstr
129             );
130             our %EXPORT_TAGS = (
131             STD => [qw(
132             omap_set omap_get_values omap_get_keys
133             omap_exists omap_delete omap_clear )],
134             ALL => [qw(
135             omap_set omap_get_values omap_get_keys
136             omap_exists omap_delete omap_clear
137             omap_add omap_order omap_get_pos
138             omap_get_pos_hash omap_get_array
139             omap_is_valid omap_errstr )],
140             );
141              
142             my $order; # package global, see order() accessor
143             our $errstr; # error message
144              
145             #---------------------------------------------------------------------
146              
147             =head1 CLASS METHODS
148              
149             =head2 Data::Omap->new();
150              
151             Constructs a new Data::Omap object.
152              
153             Accepts array ref containing single-key hash refs, e.g.,
154              
155             my $omap = Data::Omap->new( [ { a => 1 }, { b => 2 }, { c => 3 } ] );
156              
157             When provided, this data will be loaded into the object.
158              
159             Returns a reference to the Data::Omap object.
160              
161             =cut
162              
163             sub new {
164 22     22 1 12285 my( $class, $aref ) = @_;
165 22 100       90 return bless [], $class unless $aref;
166              
167 19 100       49 croak omap_errstr() unless omap_is_valid( $aref );
168 12         71 bless $aref, $class;
169             }
170              
171             sub omap_is_valid {
172 19     19 0 31 my( $aref ) = @_;
173 19 100 66     248 unless( $aref and ref( $aref ) and reftype( $aref ) eq 'ARRAY' ) {
      100        
174 2         3 $errstr = "Invalid omap: Not an array reference";
175 2         10 return;
176             }
177 17         24 my %seen;
178 17         43 for my $href ( @$aref ) {
179 40 100       124 unless( ref( $href ) eq 'HASH' ) {
180 3         5 $errstr = "Invalid omap: Not a hash reference";
181 3         12 return;
182             }
183 37         109 my @keys = keys %$href;
184 37 100       94 if( @keys > 1 ) {
185 1         2 $errstr = "Invalid omap: Not a single-key hash";
186 1         4 return;
187             }
188 36 100       163 if( $seen{ $keys[0] }++ ) {
189 1         4 $errstr = "Invalid omap: Duplicate key: '$keys[0]'";
190 1         4 return;
191             }
192             }
193 12         51 return 1; # is valid
194             }
195              
196             sub omap_errstr {
197 7     7 0 10 my $msg = $errstr;
198 7         10 $errstr = "";
199 7         778 $msg; # returned
200             }
201              
202             #---------------------------------------------------------------------
203              
204             =head2 Data::Omap->order( [$predefined_ordering | coderef] );
205              
206             When ordering is ON, new key/value pairs will be added in the
207             specified order. When ordering is OFF (the default), new pairs
208             will be added to the end of the mapping.
209              
210             When called with no parameters, C returns the current code
211             reference (if ordering is ON) or a false value (if ordering is OFF);
212             it does not change the ordering.
213              
214             Data::Omap->order(); # leaves ordering as is
215              
216             When called with the null string, C<''>, ordering is turned OFF.
217              
218             Data::Omap->order( '' ); # turn ordering OFF (the default)
219              
220             Otherwise, accepts the predefined orderings: 'na', 'nd', 'sa', 'sd',
221             'sna', and 'snd', or a custom code reference, e.g.
222              
223             Data::Omap->order( 'na' ); # numeric ascending
224             Data::Omap->order( 'nd' ); # numeric descending
225             Data::Omap->order( 'sa' ); # string ascending
226             Data::Omap->order( 'sd' ); # string descending
227             Data::Omap->order( 'sna' ); # string/numeric ascending
228             Data::Omap->order( 'snd' ); # string/numeric descending
229             Data::Omap->order( sub{ int($_[0]/100) < int($_[1]/100) } ); # code
230              
231             The predefined orderings, 'na' and 'nd', compare keys as numbers.
232             The orderings, 'sa' and 'sd', compare keys as strings. The
233             orderings, 'sna' and 'snd', compare keys as numbers when they are
234             both numbers, as strings otherwise.
235              
236             When defining a custom ordering, the convention is to use the
237             operators C<< < >> or C between (functions of) C<$_[0]> and
238             C<$_[1]> for ascending and between C<$_[1]> and C<$_[0]> for
239             descending.
240              
241             Returns the code reference if ordering is ON, a false value if OFF.
242              
243             Note, when object-level ordering is implemented, it is expected that
244             the class-level option will still be available. In that case, any
245             new objects will inherit the class-level ordering unless overridden
246             at the object level.
247              
248             =cut
249              
250             *omap_order = \ℴ
251             sub order {
252 48     48 1 2366 my( $class, $spec ) = @_; # class not actually used ...
253 48 100       189 return $order unless defined $spec;
254              
255 36 100       90 if( ref( $spec ) eq 'CODE' ) {
256 4         11 $order = $spec;
257             }
258             else {
259             $order = {
260             '' => '', # turn off ordering
261 18     18   62 na => sub{ $_[0] < $_[1] }, # number ascending
262 15     15   45 nd => sub{ $_[1] < $_[0] }, # number descending
263 33     33   95 sa => sub{ $_[0] lt $_[1] }, # string ascending
264 30     30   86 sd => sub{ $_[1] lt $_[0] }, # string descending
265             sna => sub{ # either ascending
266 30 100 100 30   214 looks_like_number($_[0])&&looks_like_number($_[1])?
267             $_[0] < $_[1]: $_[0] lt $_[1] },
268             snd => sub{ # either descending
269 45 100 100 45   308 looks_like_number($_[0])&&looks_like_number($_[1])?
270             $_[1] < $_[0]: $_[1] lt $_[0] },
271 32         454 }->{ $spec };
272 32 50       409 croak "\$spec($spec) not recognized" unless defined $order;
273             }
274 36         98 return $order;
275             }
276              
277             #---------------------------------------------------------------------
278              
279             =head1 OBJECT METHODS
280              
281             =head2 $omap->set( $key => $value[, $pos] );
282              
283             Sets the value if C<$key> exists; adds a new key/value pair if not.
284              
285             Accepts C<$key>, C<$value>, and optionally, C<$pos>.
286              
287             If C<$pos> is given, and there is a key/value pair at that position,
288             it will be set to C<$key> and C<$value>, I
289             different>. For example:
290              
291             my $omap = Data::Omap->new( [{a=>1},{b=>2}] );
292             $omap->set( c => 3, 0 ); # omap is now [{c=>3},{b=>2}]
293              
294             (As implied by the example, positions start at 0.)
295              
296             If C<$pos> is given, and there isn't a pair there, a new pair is
297             added there (perhaps overriding a defined ordering).
298              
299             If C<$pos> is not given, the key will be located and if found,
300             the value set. If the key is not found, a new pair is added to the
301             end or merged according to the defined C.
302              
303             Note that C will croak if a duplicate key would result. This
304             would only happen if C<$pos> is given and the C<$key> is found--but
305             not at that position.
306              
307             Returns C<$value> (as a nod toward $hash{$key}=$value, which
308             "returns" $value).
309              
310             =cut
311              
312             *omap_set = \&set;
313             sub set {
314 131     131 1 7363 my( $self, $key, $value, $pos ) = @_;
315 131 50       297 return unless defined $key;
316              
317             # you can give a $pos to change a member including changing its key
318             # ... but not if doing so would duplicate a key in the object
319              
320             # pos found action
321             # ----- ----- ------
322             # def def -> set key/value at pos (if pos == found)
323             # def undef -> set key/value at pos
324             # undef def -> set key/value at found
325             # undef undef -> add key/value (according to order)
326              
327 131         227 my $found = omap_get_pos( $self, $key );
328 131         299 my $elem = { $key => $value };
329              
330 131 50 66     525 if( defined $pos and defined $found ) {
    100          
    100          
331 0 0       0 croak "\$pos($pos) too large" if $pos > $#$self+1;
332 0 0       0 croak "\$key($key) found, but not at \$pos($pos): duplicate keys not allowed"
333             if $found != $pos;
334 0         0 $self->[ $pos ] = $elem; # pos == found
335             }
336             elsif( defined $pos ) {
337 6 100       571 croak "\$pos($pos) too large" if $pos > $#$self+1;
338 4         10 $self->[ $pos ] = $elem;
339             }
340 7         15 elsif( defined $found ) { $self->[ $found ] = $elem }
341 118         200 else { omap_add_ordered( $self, $key, $value ) }
342              
343 129         472 $value; # returned
344             }
345              
346             #---------------------------------------------------------------------
347              
348             =head2 $omap->get_values( [$key[, @keys]] );
349              
350             Get a value or values.
351              
352             Regardless of parameters, if the object is empty, undef is returned in
353             scalar context, an empty list in list context.
354              
355             If no parameters, gets all the values. In scalar context, gives
356             number of values in the object.
357              
358             my $omap = Data::Omap->new( [{a=>1},{b=>2},{c=>3}] );
359             my @values = $omap->get_values(); # (1, 2, 3)
360             my $howmany = $omap->get_values(); # 3
361              
362             If one key is given, that value is returned--regardless of
363             context--or if not found, C.
364              
365             @values = $omap->get_values( 'b' ); # (2)
366             my $value = $omap->get_values( 'b' ); # 2
367              
368             If multiple keys given, their values are returned in the order found
369             in the object, not the order of the given keys (unlike hash slices
370             which return values in the order requested).
371              
372             In scalar context, gives the number of values found, e.g.,
373              
374             @values = $omap->get_values( 'c', 'b', 'A' ); # (2, 3)
375             $howmany = $omap->get_values( 'c', 'b', 'A' ); # 2
376              
377             The hash slice behavior is available if you use C, see below.
378              
379             =cut
380              
381             *omap_get_values = \&get_values;
382             sub get_values {
383 51     51 1 11585 my( $self, @keys ) = @_;
384 51 100       139 return unless @$self;
385              
386 50 100       146 if( @keys == 1 ) { # most common case
    100          
387 26         32 my $wantkey = $keys[0];
388 26         43 for my $href ( @$self ) {
389 62         103 my ( $key ) = keys %$href;
390 62 100       138 if( $key eq $wantkey ) {
391 26         34 my ( $value ) = values %$href;
392 26         110 return $value;
393             }
394             }
395 0         0 return; # key not found
396             }
397              
398             elsif( @keys ) {
399 16         24 my @ret;
400 16         32 for my $href ( @$self ) {
401 56         90 my ( $key ) = keys %$href;
402 56         87 for ( @keys ) {
403 124 100       235 if( $key eq $_ ) {
404 48         62 my ( $value ) = values %$href;
405 48         53 push @ret, $value;
406 48         81 last;
407             }
408             }
409             }
410 16         74 return @ret;
411             }
412              
413             else {
414 8         11 my @ret;
415 8         18 for my $href ( @$self ) {
416 26         41 my ( $value ) = values %$href;
417 26         45 push @ret, $value;
418             }
419 8         35 return @ret;
420             }
421             }
422              
423             #---------------------------------------------------------------------
424              
425             =head2 $omap->add( $key => $value[, $pos] );
426              
427             Adds a key/value pair to the object.
428              
429             Accepts C<$key>, C<$value>, and optionally, C<$pos>.
430              
431             If C<$pos> is given, the key/value pair will be added (inserted)
432             there (possibly overriding a defined order), e.g.,
433              
434             my $omap = Data::Omap->new( [{a=>1},{b=>2}] );
435             $omap->add( c => 3, 1 ); # omap is now [{a=>1},{c=>3},{b=>2}]
436              
437             (Positions start at 0.)
438              
439             If C<$pos> is not given, a new pair is added to the end or merged
440             according to the defined C.
441              
442             Note that C will croak if a duplicate key would result, i.e.,
443             if the key being added is already in the object.
444              
445             Returns C<$value>.
446              
447             =cut
448              
449             *omap_add = \&add;
450             sub add {
451 33     33 1 12509 my( $self, $key, $value, $pos ) = @_;
452 33 50       92 return unless defined $key;
453              
454 33         67 my $found = omap_get_pos( $self, $key );
455 33 50       71 croak "\$key($key) found: duplicate keys not allowed" if defined $found;
456              
457 33         79 my $elem = { $key => $value };
458 33 100       65 if( defined $pos ) {
459 9 100       220 croak "\$pos($pos) too large" if $pos > $#$self+1;
460 7         108 splice @$self, $pos, 0, $elem;
461             }
462             else {
463 24         49 omap_add_ordered( $self, $key, $value );
464             }
465              
466 31         84 $value; # returned
467             }
468              
469             #---------------------------------------------------------------------
470              
471             =head2 omap_add_ordered( $omap, $key => $value );
472              
473             Private routine used by C and C.
474              
475             Accepts C<$key> and C<$value>.
476              
477             Adds a new key/value pair to the end or merged according to the
478             defined C.
479              
480             This routine should not be called directly, because it does not
481             check for duplicates.
482              
483             Has no defined return value.
484              
485             =cut
486              
487             sub omap_add_ordered {
488 142     142 1 187 my( $self, $key, $value ) = @_;
489 142         256 my $elem = { $key => $value };
490              
491 142 100       317 unless( $order ) { push @$self, $elem; return }
  10         24  
  10         24  
492              
493             # optimization for when members are added in order
494 132 100       236 if( @$self ) {
495 105         97 my ( $key2 ) = keys %{$self->[-1]}; # at the end
  105         203  
496 105 100       198 unless( $order->( $key, $key2 ) ) {
497 33         107 push @$self, $elem;
498 33         61 return;
499             }
500             }
501              
502             # else start comparing at the beginning
503 99         242 for my $i ( 0 .. $#$self ) {
504 93         98 my ( $key2 ) = keys %{$self->[ $i ]};
  93         170  
505 93 100       164 if( $order->( $key, $key2 ) ) { # XXX can we memoize $key in $order->()?
506 72         144 splice @$self, $i, 0, $elem;
507 72         137 return;
508             }
509             }
510              
511 27         62 push @$self, $elem;
512             }
513              
514             #---------------------------------------------------------------------
515              
516             =head2 $omap->get_pos( $key );
517              
518             Gets position where a key is found.
519              
520             Accepts one key (any extras are silently ignored).
521              
522             Returns the position or undef (if key not found), regardless of context, e.g.,
523              
524             my $omap = Data::Omap->new( [{a=>1},{b=>2},{c=>3}] );
525             my @pos = $omap->get_pos( 'b' ); # (1)
526             my $pos = $omap->get_pos( 'b' ); # 1
527              
528             Returns C if no key given or object is empty.
529              
530             =cut
531              
532             *omap_get_pos = \&get_pos;
533             sub get_pos {
534 180     180 1 2893 my( $self, $wantkey ) = @_;
535 180 50       339 return unless $wantkey;
536 180 100       359 return unless @$self;
537 152         326 for my $i ( 0 .. $#$self ) {
538 398         386 my ( $key ) = keys %{$self->[ $i ]};
  398         840  
539 398 100       1060 if( $key eq $wantkey ) {
540 21         86 return $i;
541             }
542             }
543 131         257 return; # key not found
544             }
545              
546             #---------------------------------------------------------------------
547              
548             =head2 $omap->get_pos_hash( @keys );
549              
550             Gets positions where keys are found.
551              
552             Accepts zero or more keys.
553              
554             In list context, returns a hash of keys/positions found. In scalar
555             context, returns a hash ref to this hash. If no keys given, all the
556             positions are mapped in the hash.
557              
558             my $omap = Data::Omap->new( [{a=>1},{b=>2},{c=>3}] );
559             my %pos = $omap->get_pos_hash( 'c', 'b' ); # %pos is (b=>1,c=>2)
560             my $pos_href = $omap->get_pos_hash( 'c', 'b' ); # $pos_href is {b=>1,c=>2}
561              
562             If a given key is not found, it will not appear in the returned hash.
563              
564             Returns C if object is empty.
565              
566             =cut
567              
568             *omap_get_pos_hash = \&get_pos_hash;
569             sub get_pos_hash {
570 10     10 1 5906 my( $self, @keys ) = @_;
571 10 50       32 return unless @$self;
572 10         15 my %ret;
573 10 100       28 if( @keys ) {
574 8         26 for my $i ( 0 .. $#$self ) {
575 24         29 my ( $key ) = keys %{$self->[ $i ]};
  24         52  
576 24         38 for ( @keys ) {
577 36 100       89 if( $key eq $_ ) {
578 14         24 $ret{ $key } = $i;
579 14         30 last;
580             }
581             }
582             }
583             }
584             else {
585 2         7 for my $i ( 0 .. $#$self ) {
586 6         9 my ( $key ) = keys %{$self->[ $i ]};
  6         13  
587 6         17 $ret{ $key } = $i;
588             }
589             }
590 10 100       65 return %ret if wantarray;
591 2         6 \%ret; # returned
592             }
593              
594             #---------------------------------------------------------------------
595              
596             =head2 $omap->get_keys( @keys );
597              
598             Gets keys.
599              
600             Accepts zero or more keys. If no keys are given, returns all the
601             keys in the object (list context) or the number of keys (scalar
602             context), e.g.,
603              
604             my $omap = Data::Omap->new( [{a=>1},{b=>2},{c=>3}] );
605             my @keys = $omap->get_keys(); # @keys is (a, b, c)
606             my $howmany = $omap->get_keys(); # $howmany is 3
607              
608             If one or more keys are given, returns all the keys that are found
609             (list) or the number found (scalar). Keys returned are listed in the
610             order found in the object, e.g.,
611              
612             @keys = $omap->get_keys( 'c', 'b', 'A' ); # @keys is (b, c)
613             $howmany = $omap->get_keys( 'c', 'b', 'A' ); # $howmany is 2
614              
615             =cut
616              
617             *omap_get_keys = \&get_keys;
618             sub get_keys {
619 16     16 1 6984 my( $self, @keys ) = @_;
620 16 100       54 return unless @$self;
621 15         21 my @ret;
622 15 100       36 if( @keys ) {
623 6         46 for my $href ( @$self ) {
624 18         33 my ( $key ) = keys %$href;
625 18         23 for ( @keys ) {
626 36 100       81 if( $key eq $_ ) {
627 14         17 push @ret, $key;
628 14         30 last;
629             }
630             }
631             }
632             }
633             else {
634 9         53 for my $href ( @$self ) {
635 30         70 my ( $key ) = keys %$href;
636 30         109 push @ret, $key;
637             }
638             }
639 15         62 @ret; # returned
640             }
641              
642             #---------------------------------------------------------------------
643              
644             =head2 $omap->get_array( @keys );
645              
646             Gets an array of key/value pairs.
647              
648             Accepts zero or more keys. If no keys are given, returns a list of
649             all the key/value pairs in the object (list context) or an array
650             reference to that list (scalar context), e.g.,
651              
652             my $omap = Data::Omap->new( [{a=>1},{b=>2},{c=>3}] );
653             my @array = $omap->get_array(); # @array is ({a=>1}, {b=>2}, {c=>3})
654             my $aref = $omap->get_array(); # $aref is [{a=>1}, {b=>2}, {c=>3}]
655              
656             If one or more keys are given, returns a list of key/value pairs for
657             all the keys that are found (list) or an aref to that list (scalar).
658             Pairs returned are in the order found in the object, e.g.,
659              
660             @array = $omap->get_array( 'c', 'b', 'A' ); # @array is ({b->2}, {c=>3})
661             $aref = $omap->get_array( 'c', 'b', 'A' ); # @aref is [{b->2}, {c=>3}]
662              
663             Note, conceivably this method might be used to make a copy
664             (unblessed) of the object, but it would not be a deep copy (if values
665             are references, the references would be copied, not the referents).
666              
667             =cut
668              
669             *omap_get_array = \&get_array;
670             sub get_array {
671 14     14 1 13884 my( $self, @keys ) = @_;
672 14 50       552 return unless @$self;
673 14         23 my @ret;
674 14 100       39 if( @keys ) {
675 6         16 for my $href ( @$self ) {
676 18         43 my ( $key ) = keys %$href;
677 18         36 for ( @keys ) {
678 34 100       159 if( $key eq $_ ) {
679 12         36 push @ret, { %$href };
680 12         36 last;
681             }
682             }
683             }
684             }
685             else {
686 8         20 for my $href ( @$self ) {
687 24         57 my ( $key ) = keys %$href;
688 24         92 push @ret, { %$href };
689             }
690             }
691 14 100       89 return wantarray? @ret: [ @ret ];
692             }
693              
694             #---------------------------------------------------------------------
695              
696             =head2 $omap->firstkey();
697              
698             Expects no parameters. Returns the first key in the object (or undef
699             if object is empty).
700              
701             This routine supports the tied hash FIRSTKEY method.
702              
703             =cut
704              
705             sub firstkey {
706 8     8 1 366 my( $self ) = @_;
707 8 100       34 return unless @$self;
708 6         9 my ( $firstkey ) = keys %{$self->[0]};
  6         16  
709 6         29 $firstkey; # returned
710             }
711              
712             #---------------------------------------------------------------------
713              
714             =head2 $omap->nextkey( $lastkey );
715              
716             Accepts one parameter, the last key gotten from FIRSTKEY or NEXTKEY.
717              
718             Returns the next key in the object.
719              
720             This routine supports the tied hash NEXTKEY method.
721              
722             =cut
723              
724             # XXX want a more efficient solution, always loops through the array
725              
726             sub nextkey {
727 22     22 1 28 my( $self, $lastkey ) = @_;
728 22 50       44 return unless @$self;
729 22         39 for my $i ( 0 .. $#$self ) {
730 55         52 my ( $key ) = keys %{$self->[ $i ]};
  55         96  
731 55 100       120 if( $key eq $lastkey ) {
732 22 100       65 return unless defined $self->[ $i+1 ];
733 17         19 my ( $nextkey ) = keys %{$self->[ $i+1 ]};
  17         33  
734 17         66 return $nextkey;
735             }
736             }
737             }
738              
739             #---------------------------------------------------------------------
740              
741             =head2 $omap->exists( $key );
742              
743             Accepts one key.
744              
745             Returns true if key is found in object, false if not.
746              
747             This routine supports the tied hash EXISTS method, but may reasonably
748             be called directly, too.
749              
750             =cut
751              
752             *omap_exists = \&exists;
753             sub exists {
754 7     7 1 1879 my( $self, $key ) = @_;
755 7 100       25 return unless @$self;
756 6         16 return defined omap_get_pos( $self, $key );
757             }
758              
759             #---------------------------------------------------------------------
760              
761             =head2 $omap->delete( $key );
762              
763             Accepts one key. If key is found, removes the key/value pair from
764             the object.
765              
766             Returns the value from the deleted pair.
767              
768             This routine supports the tied hash DELETE method, but may be called
769             directly, too.
770              
771             =cut
772              
773             *omap_delete = \&delete;
774             sub delete {
775 5     5 1 619 my( $self, $key ) = @_;
776 5 50       18 return unless defined $key;
777 5 100       20 return unless @$self;
778              
779 4         12 my $found = omap_get_pos( $self, $key );
780 4 50       16 return unless defined $found;
781              
782 4         10 my $value = $self->[ $found ]->{ $key };
783 4         11 splice @$self, $found, 1; # delete it
784              
785 4         16 $value; # returned
786             }
787              
788             #---------------------------------------------------------------------
789              
790             =head2 $omap->clear();
791              
792             Expects no parameters. Removes all key/value pairs from the object.
793              
794             Returns an empty list.
795              
796             This routine supports the tied hash CLEAR method, but may be called
797             directly, too.
798              
799             =cut
800              
801             *omap_clear = \&clear;
802             sub clear {
803 29     29 1 9611 my( $self ) = @_;
804 29         156 @$self = ();
805             }
806              
807             #---------------------------------------------------------------------
808             # perltie methods
809             #---------------------------------------------------------------------
810              
811             # XXX Because of the inefficiencies in nextkey(), keys %hash and
812             # values %hash # may be very slow.
813             # Consider using (tied %hash)->get_keys() or ->get_values() instead
814              
815             # TIEHASH classname, LIST
816             # This is the constructor for the class. That means it is expected to
817             # return a blessed reference through which the new object (probably but
818             # not necessarily an anonymous hash) will be accessed.
819              
820             sub TIEHASH {
821 3     3   563 my $class = shift;
822 3         19 $class->new( @_ );
823             }
824              
825             #---------------------------------------------------------------------
826             # FETCH this, key
827             # This method will be triggered every time an element in the tied hash
828             # is accessed (read).
829              
830             sub FETCH {
831 20     20   2902 my $self = shift;
832 20         62 $self->get_values( @_ );
833             }
834              
835             #---------------------------------------------------------------------
836             # STORE this, key, value
837             # This method will be triggered every time an element in the tied hash
838             # is set (written).
839              
840             sub STORE {
841 53     53   6642 my $self = shift;
842 53         123 $self->set( @_ );
843             }
844              
845             #---------------------------------------------------------------------
846             # DELETE this, key
847             # This method is triggered when we remove an element from the hash,
848             # typically by using the delete() function.
849             # If you want to emulate the normal behavior of delete(), you should
850             # return whatever FETCH would have returned for this key.
851              
852             sub DELETE {
853 2     2   1196 my $self = shift;
854 2         10 $self->delete( @_ );
855             }
856              
857             #---------------------------------------------------------------------
858             # CLEAR this
859             # This method is triggered when the whole hash is to be cleared,
860             # usually by assigning the empty list to it.
861              
862             sub CLEAR {
863 10     10   6008 my $self = shift;
864 10         27 $self->clear();
865             }
866              
867             #---------------------------------------------------------------------
868             # EXISTS this, key
869             # This method is triggered when the user uses the exists() function
870             # on a particular hash.
871              
872             sub EXISTS {
873 2     2   1241 my $self = shift;
874 2         9 $self->exists( @_ );
875             }
876              
877             #---------------------------------------------------------------------
878             # FIRSTKEY this
879             # This method will be triggered when the user is going to iterate
880             # through the hash, such as via a keys() or each() call.
881              
882             sub FIRSTKEY {
883 7     7   3982 my $self = shift;
884 7         21 $self->firstkey();
885             }
886              
887             #---------------------------------------------------------------------
888             # NEXTKEY this, lastkey
889             # This method gets triggered during a keys() or each() iteration.
890             # It has a second argument which is the last key that had been accessed.
891              
892             sub NEXTKEY {
893 20     20   43 my $self = shift;
894 20         39 $self->nextkey( @_ );
895             }
896              
897             #---------------------------------------------------------------------
898             # SCALAR this
899             # This is called when the hash is evaluated in scalar context.
900             # In order to mimic the behavior of untied hashes, this method should
901             # return a false value when the tied hash is considered empty.
902              
903             sub SCALAR {
904 2     2   981 my $self = shift;
905 2         8 $self->get_keys(); # number of keys or undef (scalar context)
906             }
907              
908             #---------------------------------------------------------------------
909             # UNTIE this
910             # This is called when untie occurs. See "The untie Gotcha".
911              
912             # sub UNTIE {
913             # }
914              
915             #---------------------------------------------------------------------
916             # DESTROY this
917             # This method is triggered when a tied hash is about to go out of scope.
918              
919             # sub DESTROY {
920             # }
921              
922             #---------------------------------------------------------------------
923              
924             1; # 'use module' return value
925              
926             __END__