~ubuntu-branches/ubuntu/trusty/horae/trusty

« back to all changes in this revision

Viewing changes to 0CPAN/Tie-IxHash-1.21/lib/Tie/IxHash.pm

  • Committer: Bazaar Package Importer
  • Author(s): Carlo Segre
  • Date: 2008-02-23 23:13:02 UTC
  • mfrom: (2.1.2 hardy)
  • Revision ID: james.westby@ubuntu.com-20080223231302-mnyyxs3icvrus4ke
Tags: 066-3
Apply patch to athena_parts/misc.pl for compatibility with 
perl-tk 804.28.

Show diffs side-by-side

added added

removed removed

Lines of Context:
1
 
#
2
 
# Tie/IxHash.pm
3
 
#
4
 
# Indexed hash implementation for Perl
5
 
#
6
 
# See below for documentation.
7
 
#
8
 
 
9
 
require 5.003;
10
 
 
11
 
package Tie::IxHash;
12
 
use integer;
13
 
require Tie::Hash;
14
 
@ISA = qw(Tie::Hash);
15
 
 
16
 
$VERSION = $VERSION = '1.21';
17
 
 
18
 
#
19
 
# standard tie functions
20
 
#
21
 
 
22
 
sub TIEHASH {
23
 
  my($c) = shift;
24
 
  my($s) = [];
25
 
  $s->[0] = {};   # hashkey index
26
 
  $s->[1] = [];   # array of keys
27
 
  $s->[2] = [];   # array of data
28
 
  $s->[3] = 0;    # iter count
29
 
 
30
 
  bless $s, $c;
31
 
 
32
 
  $s->Push(@_) if @_;
33
 
 
34
 
  return $s;
35
 
}
36
 
 
37
 
#sub DESTROY {}           # costly if there's nothing to do
38
 
 
39
 
sub FETCH {
40
 
  my($s, $k) = (shift, shift);
41
 
  return exists( $s->[0]{$k} ) ? $s->[2][ $s->[0]{$k} ] : undef;
42
 
}
43
 
 
44
 
sub STORE {
45
 
  my($s, $k, $v) = (shift, shift, shift);
46
 
  
47
 
  if (exists $s->[0]{$k}) {
48
 
    my($i) = $s->[0]{$k};
49
 
    $s->[1][$i] = $k;
50
 
    $s->[2][$i] = $v;
51
 
    $s->[0]{$k} = $i;
52
 
  }
53
 
  else {
54
 
    push(@{$s->[1]}, $k);
55
 
    push(@{$s->[2]}, $v);
56
 
    $s->[0]{$k} = $#{$s->[1]};
57
 
  }
58
 
}
59
 
 
60
 
sub DELETE {
61
 
  my($s, $k) = (shift, shift);
62
 
 
63
 
  if (exists $s->[0]{$k}) {
64
 
    my($i) = $s->[0]{$k};
65
 
    for ($i+1..$#{$s->[1]}) {    # reset higher elt indexes
66
 
      $s->[0]{$s->[1][$_]}--;    # timeconsuming, is there is better way?
67
 
    }
68
 
    delete $s->[0]{$k};
69
 
    splice @{$s->[1]}, $i, 1;
70
 
    return (splice(@{$s->[2]}, $i, 1))[0];
71
 
  }
72
 
  return undef;
73
 
}
74
 
 
75
 
sub EXISTS {
76
 
  exists $_[0]->[0]{ $_[1] };
77
 
}
78
 
 
79
 
sub FIRSTKEY {
80
 
  $_[0][3] = 0;
81
 
  &NEXTKEY;
82
 
}
83
 
 
84
 
sub NEXTKEY {
85
 
  return $_[0][1][$_[0][3]++] if ($_[0][3] <= $#{$_[0][1]});
86
 
  return undef;
87
 
}
88
 
 
89
 
 
90
 
 
91
 
#
92
 
#
93
 
# class functions that provide additional capabilities
94
 
#
95
 
#
96
 
 
97
 
sub new { TIEHASH(@_) }
98
 
 
99
 
#
100
 
# add pairs to end of indexed hash
101
 
# note that if a supplied key exists, it will not be reordered
102
 
#
103
 
sub Push {
104
 
  my($s) = shift;
105
 
  while (@_) {
106
 
    $s->STORE(shift, shift);
107
 
  }
108
 
  return scalar(@{$s->[1]});
109
 
}
110
 
 
111
 
sub Push2 {
112
 
  my($s) = shift;
113
 
  $s->Splice($#{$s->[1]}+1, 0, @_);
114
 
  return scalar(@{$s->[1]});
115
 
}
116
 
 
117
 
#
118
 
# pop last k-v pair
119
 
#
120
 
sub Pop {
121
 
  my($s) = shift;
122
 
  my($k, $v, $i);
123
 
  $k = pop(@{$s->[1]});
124
 
  $v = pop(@{$s->[2]});
125
 
  if (defined $k) {
126
 
    delete $s->[0]{$k};
127
 
    return ($k, $v);
128
 
  }
129
 
  return undef;
130
 
}
131
 
 
132
 
sub Pop2 {
133
 
  return $_[0]->Splice(-1);
134
 
}
135
 
 
136
 
#
137
 
# shift
138
 
#
139
 
sub Shift {
140
 
  my($s) = shift;
141
 
  my($k, $v, $i);
142
 
  $k = shift(@{$s->[1]});
143
 
  $v = shift(@{$s->[2]});
144
 
  if (defined $k) {
145
 
    delete $s->[0]{$k};
146
 
    for (keys %{$s->[0]}) {
147
 
      $s->[0]{$_}--;
148
 
    }
149
 
    return ($k, $v);
150
 
  }
151
 
  return undef;
152
 
}
153
 
 
154
 
sub Shift2 {
155
 
  return $_[0]->Splice(0, 1);
156
 
}
157
 
 
158
 
#
159
 
# unshift
160
 
# if a supplied key exists, it will not be reordered
161
 
#
162
 
sub Unshift {
163
 
  my($s) = shift;
164
 
  my($k, $v, @k, @v, $len, $i);
165
 
 
166
 
  while (@_) {
167
 
    ($k, $v) = (shift, shift);
168
 
    if (exists $s->[0]{$k}) {
169
 
      $i = $s->[0]{$k};
170
 
      $s->[1][$i] = $k;
171
 
      $s->[2][$i] = $v;
172
 
      $s->[0]{$k} = $i;
173
 
    }
174
 
    else {
175
 
      push(@k, $k);
176
 
      push(@v, $v);
177
 
      $len++;
178
 
    }
179
 
  }
180
 
  if (defined $len) {
181
 
    for (keys %{$s->[0]}) {
182
 
      $s->[0]{$_} += $len;
183
 
    }
184
 
    $i = 0;
185
 
    for (@k) {
186
 
      $s->[0]{$_} = $i++;
187
 
    }
188
 
    unshift(@{$s->[1]}, @k);
189
 
    return unshift(@{$s->[2]}, @v);
190
 
  }
191
 
  return scalar(@{$s->[1]});
192
 
}
193
 
 
194
 
sub Unshift2 {
195
 
  my($s) = shift;
196
 
  $s->Splice(0,0,@_);
197
 
  return scalar(@{$s->[1]});
198
 
}
199
 
 
200
 
#
201
 
# splice 
202
 
#
203
 
# any existing hash key order is preserved. the value is replaced for
204
 
# such keys, and the new keys are spliced in the regular fashion.
205
 
#
206
 
# supports -ve offsets but only +ve lengths
207
 
#
208
 
# always assumes a 0 start offset
209
 
#
210
 
sub Splice {
211
 
  my($s, $start, $len) = (shift, shift, shift);
212
 
  my($k, $v, @k, @v, @r, $i, $siz);
213
 
  my($end);                   # inclusive
214
 
 
215
 
  # XXX  inline this 
216
 
  ($start, $end, $len) = $s->_lrange($start, $len);
217
 
 
218
 
  if (defined $start) {
219
 
    if ($len > 0) {
220
 
      my(@k) = splice(@{$s->[1]}, $start, $len);
221
 
      my(@v) = splice(@{$s->[2]}, $start, $len);
222
 
      while (@k) {
223
 
        $k = shift(@k);
224
 
        delete $s->[0]{$k};
225
 
        push(@r, $k, shift(@v));
226
 
      }
227
 
      for ($start..$#{$s->[1]}) {
228
 
        $s->[0]{$s->[1][$_]} -= $len;
229
 
      }
230
 
    }
231
 
    while (@_) {
232
 
      ($k, $v) = (shift, shift);
233
 
      if (exists $s->[0]{$k}) {
234
 
        #      $s->STORE($k, $v);
235
 
        $i = $s->[0]{$k};
236
 
        $s->[1][$i] = $k;
237
 
        $s->[2][$i] = $v;
238
 
        $s->[0]{$k} = $i;
239
 
      }
240
 
      else {
241
 
        push(@k, $k);
242
 
        push(@v, $v);
243
 
        $siz++;
244
 
      }
245
 
    }
246
 
    if (defined $siz) {
247
 
      for ($start..$#{$s->[1]}) {
248
 
        $s->[0]{$s->[1][$_]} += $siz;
249
 
      }
250
 
      $i = $start;
251
 
      for (@k) {
252
 
        $s->[0]{$_} = $i++;
253
 
      }
254
 
      splice(@{$s->[1]}, $start, 0, @k);
255
 
      splice(@{$s->[2]}, $start, 0, @v);
256
 
    }
257
 
  }
258
 
  return @r;
259
 
}
260
 
 
261
 
#
262
 
# delete elements specified by key
263
 
# other elements higher than the one deleted "slide" down 
264
 
#
265
 
sub Delete {
266
 
  my($s) = shift;
267
 
 
268
 
  for (@_) {
269
 
    #
270
 
    # XXX potential optimization: could do $s->DELETE only if $#_ < 4.
271
 
    #     otherwise, should reset all the hash indices in one loop
272
 
    #
273
 
    $s->DELETE($_);
274
 
  }
275
 
}
276
 
 
277
 
#
278
 
# replace hash element at specified index
279
 
#
280
 
# if the optional key is not supplied the value at index will simply be 
281
 
# replaced without affecting the order.
282
 
#
283
 
# if an element with the supplied key already exists, it will be deleted first.
284
 
#
285
 
# returns the key of replaced value if it succeeds.
286
 
#
287
 
sub Replace {
288
 
  my($s) = shift;
289
 
  my($i, $v, $k) = (shift, shift, shift);
290
 
  if (defined $i and $i <= $#{$s->[1]} and $i >= 0) {
291
 
    if (defined $k) {
292
 
      delete $s->[0]{ $s->[1][$i] };
293
 
      $s->DELETE($k) ; #if exists $s->[0]{$k};
294
 
      $s->[1][$i] = $k;
295
 
      $s->[2][$i] = $v;
296
 
      $s->[0]{$k} = $i;
297
 
      return $k;
298
 
    }
299
 
    else {
300
 
      $s->[2][$i] = $v;
301
 
      return $s->[1][$i];
302
 
    }
303
 
  }
304
 
  return undef;
305
 
}
306
 
 
307
 
#
308
 
# Given an $start and $len, returns a legal start and end (where start <= end)
309
 
# for the current hash. 
310
 
# Legal range is defined as 0 to $#s+1
311
 
# $len defaults to number of elts upto end of list
312
 
#
313
 
#          0   1   2   ...
314
 
#          | X | X | X ... X | X | X |
315
 
#                           -2  -1       (no -0 alas)
316
 
# X's above are the elements 
317
 
#
318
 
sub _lrange {
319
 
  my($s) = shift;
320
 
  my($offset, $len) = @_;
321
 
  my($start, $end);         # both inclusive
322
 
  my($size) = $#{$s->[1]}+1;
323
 
 
324
 
  return undef unless defined $offset;
325
 
  if($offset < 0) {
326
 
    $start = $offset + $size;
327
 
    $start = 0 if $start < 0;
328
 
  }
329
 
  else {
330
 
    ($offset > $size) ? ($start = $size) : ($start = $offset);
331
 
  }
332
 
 
333
 
  if (defined $len) {
334
 
    $len = -$len if $len < 0;
335
 
    $len = $size - $start if $len > $size - $start;
336
 
  }
337
 
  else {
338
 
    $len = $size - $start;
339
 
  }
340
 
  $end = $start + $len - 1;
341
 
 
342
 
  return ($start, $end, $len);
343
 
}
344
 
 
345
 
#
346
 
# Return keys at supplied indices
347
 
# Returns all keys if no args.
348
 
#
349
 
sub Keys   { 
350
 
  my($s) = shift;
351
 
  return ( @_ == 1
352
 
         ? $s->[1][$_[0]]
353
 
         : ( @_
354
 
           ? @{$s->[1]}[@_]
355
 
           : @{$s->[1]} ) );
356
 
}
357
 
 
358
 
#
359
 
# Returns values at supplied indices
360
 
# Returns all values if no args.
361
 
#
362
 
sub Values {
363
 
  my($s) = shift;
364
 
  return ( @_ == 1
365
 
         ? $s->[2][$_[0]]
366
 
         : ( @_
367
 
           ? @{$s->[2]}[@_]
368
 
           : @{$s->[2]} ) );
369
 
}
370
 
 
371
 
#
372
 
# get indices of specified hash keys
373
 
#
374
 
sub Indices { 
375
 
  my($s) = shift;
376
 
  return ( @_ == 1 ? $s->[0]{$_[0]} : @{$s->[0]}{@_} );
377
 
}
378
 
 
379
 
#
380
 
# number of k-v pairs in the ixhash
381
 
# note that this does not equal the highest index
382
 
# owing to preextended arrays
383
 
#
384
 
sub Length {
385
 
 return scalar @{$_[0]->[1]};
386
 
}
387
 
 
388
 
#
389
 
# Reorder the hash in the supplied key order
390
 
#
391
 
# warning: any unsupplied keys will be lost from the hash
392
 
# any supplied keys that dont exist in the hash will be ignored
393
 
#
394
 
sub Reorder {
395
 
  my($s) = shift;
396
 
  my(@k, @v, %x, $i);
397
 
  return unless @_;
398
 
 
399
 
  $i = 0;
400
 
  for (@_) {
401
 
    if (exists $s->[0]{$_}) {
402
 
      push(@k, $_);
403
 
      push(@v, $s->[2][ $s->[0]{$_} ] );
404
 
      $x{$_} = $i++;
405
 
    }
406
 
  }
407
 
  $s->[1] = \@k;
408
 
  $s->[2] = \@v;
409
 
  $s->[0] = \%x;
410
 
  return $s;
411
 
}
412
 
 
413
 
sub SortByKey {
414
 
  my($s) = shift;
415
 
  $s->Reorder(sort $s->Keys);
416
 
}
417
 
 
418
 
sub SortByValue {
419
 
  my($s) = shift;
420
 
  $s->Reorder(sort { $s->FETCH($a) cmp $s->FETCH($b) } $s->Keys)
421
 
}
422
 
 
423
 
1;
424
 
__END__
425
 
 
426
 
=head1 NAME
427
 
 
428
 
Tie::IxHash - ordered associative arrays for Perl
429
 
 
430
 
 
431
 
=head1 SYNOPSIS
432
 
 
433
 
    # simple usage
434
 
    use Tie::IxHash;
435
 
    tie HASHVARIABLE, Tie::IxHash [, LIST];
436
 
    
437
 
    # OO interface with more powerful features
438
 
    use Tie::IxHash;
439
 
    TIEOBJECT = Tie::IxHash->new( [LIST] );
440
 
    TIEOBJECT->Splice( OFFSET [, LENGTH [, LIST]] );
441
 
    TIEOBJECT->Push( LIST );
442
 
    TIEOBJECT->Pop;
443
 
    TIEOBJECT->Shift;
444
 
    TIEOBJECT->Unshift( LIST );
445
 
    TIEOBJECT->Keys( [LIST] );
446
 
    TIEOBJECT->Values( [LIST] );
447
 
    TIEOBJECT->Indices( LIST );
448
 
    TIEOBJECT->Delete( [LIST] );
449
 
    TIEOBJECT->Replace( OFFSET, VALUE, [KEY] );
450
 
    TIEOBJECT->Reorder( LIST );
451
 
    TIEOBJECT->SortByKey;
452
 
    TIEOBJECT->SortByValue;
453
 
    TIEOBJECT->Length;
454
 
 
455
 
 
456
 
=head1 DESCRIPTION
457
 
 
458
 
This Perl module implements Perl hashes that preserve the order in which the
459
 
hash elements were added.  The order is not affected when values
460
 
corresponding to existing keys in the IxHash are changed.  The elements can
461
 
also be set to any arbitrary supplied order.  The familiar perl array
462
 
operations can also be performed on the IxHash.
463
 
 
464
 
 
465
 
=head2 Standard C<TIEHASH> Interface
466
 
 
467
 
The standard C<TIEHASH> mechanism is available. This interface is 
468
 
recommended for simple uses, since the usage is exactly the same as
469
 
regular Perl hashes after the C<tie> is declared.
470
 
 
471
 
 
472
 
=head2 Object Interface
473
 
 
474
 
This module also provides an extended object-oriented interface that can be
475
 
used for more powerful operations with the IxHash.  The following methods
476
 
are available:
477
 
 
478
 
=over 8
479
 
 
480
 
=item FETCH, STORE, DELETE, EXISTS
481
 
 
482
 
These standard C<TIEHASH> methods mandated by Perl can be used directly.
483
 
See the C<tie> entry in perlfunc(1) for details.
484
 
 
485
 
=item Push, Pop, Shift, Unshift, Splice
486
 
 
487
 
These additional methods resembling Perl functions are available for
488
 
operating on key-value pairs in the IxHash. The behavior is the same as the
489
 
corresponding perl functions, except when a supplied hash key already exists
490
 
in the hash. In that case, the existing value is updated but its order is
491
 
not affected.  To unconditionally alter the order of a supplied key-value
492
 
pair, first C<DELETE> the IxHash element.
493
 
 
494
 
=item Keys
495
 
 
496
 
Returns an array of IxHash element keys corresponding to the list of supplied
497
 
indices.  Returns an array of all the keys if called without arguments.
498
 
Note the return value is mostly only useful when used in a list context
499
 
(since perl will convert it to the number of elements in the array when
500
 
used in a scalar context, and that may not be very useful).
501
 
 
502
 
If a single argument is given, returns the single key corresponding to
503
 
the index.  This is usable in either scalar or list context.
504
 
 
505
 
=item Values
506
 
 
507
 
Returns an array of IxHash element values corresponding to the list of supplied
508
 
indices.  Returns an array of all the values if called without arguments.
509
 
Note the return value is mostly only useful when used in a list context
510
 
(since perl will convert it to the number of elements in the array when
511
 
used in a scalar context, and that may not be very useful).
512
 
 
513
 
If a single argument is given, returns the single value corresponding to
514
 
the index.  This is usable in either scalar or list context.
515
 
 
516
 
=item Indices
517
 
 
518
 
Returns an array of indices corresponding to the supplied list of keys.
519
 
Note the return value is mostly only useful when used in a list context
520
 
(since perl will convert it to the number of elements in the array when
521
 
used in a scalar context, and that may not be very useful).
522
 
 
523
 
If a single argument is given, returns the single index corresponding to
524
 
the key.  This is usable in either scalar or list context.
525
 
 
526
 
=item Delete
527
 
 
528
 
Removes elements with the supplied keys from the IxHash.
529
 
 
530
 
=item Replace
531
 
 
532
 
Substitutes the IxHash element at the specified index with the supplied
533
 
value-key pair.  If a key is not supplied, simply substitutes the value at
534
 
index with the supplied value. If an element with the supplied key already
535
 
exists, it will be removed from the IxHash first.
536
 
 
537
 
=item Reorder
538
 
 
539
 
This method can be used to manipulate the internal order of the IxHash
540
 
elements by supplying a list of keys in the desired order.  Note however,
541
 
that any IxHash elements whose keys are not in the list will be removed from
542
 
the IxHash.
543
 
 
544
 
=item Length
545
 
 
546
 
Returns the number of IxHash elements.
547
 
 
548
 
=item SortByKey
549
 
 
550
 
Reorders the IxHash elements by textual comparison of the keys.
551
 
 
552
 
=item SortByValue
553
 
 
554
 
Reorders the IxHash elements by textual comparison of the values.
555
 
 
556
 
=back
557
 
 
558
 
 
559
 
=head1 EXAMPLE
560
 
 
561
 
    use Tie::IxHash;
562
 
 
563
 
    # simple interface
564
 
    $t = tie(%myhash, Tie::IxHash, 'a' => 1, 'b' => 2);
565
 
    %myhash = (first => 1, second => 2, third => 3);
566
 
    $myhash{fourth} = 4;
567
 
    @keys = keys %myhash;
568
 
    @values = values %myhash;
569
 
    print("y") if exists $myhash{third};
570
 
    
571
 
    # OO interface
572
 
    $t = Tie::IxHash->new(first => 1, second => 2, third => 3);
573
 
    $t->Push(fourth => 4); # same as $myhash{'fourth'} = 4;
574
 
    ($k, $v) = $t->Pop;    # $k is 'fourth', $v is 4
575
 
    $t->Unshift(neg => -1, zeroth => 0); 
576
 
    ($k, $v) = $t->Shift;  # $k is 'neg', $v is -1
577
 
    @oneandtwo = $t->Splice(1, 2, foo => 100, bar => 101);
578
 
    
579
 
    @keys = $t->Keys;
580
 
    @values = $t->Values;
581
 
    @indices = $t->Indices('foo', 'zeroth');
582
 
    @itemkeys = $t->Keys(@indices);
583
 
    @itemvals = $t->Values(@indices);
584
 
    $t->Replace(2, 0.3, 'other');
585
 
    $t->Delete('second', 'zeroth');
586
 
    $len = $t->Length;     # number of key-value pairs
587
 
 
588
 
    $t->Reorder(reverse @keys);
589
 
    $t->SortByKey;
590
 
    $t->SortByValue;
591
 
 
592
 
 
593
 
=head1 BUGS
594
 
 
595
 
You cannot specify a negative length to C<Splice>. Negative indexes are OK,
596
 
though.
597
 
 
598
 
Indexing always begins at 0 (despite the current C<$[> setting) for 
599
 
all the functions.
600
 
 
601
 
 
602
 
=head1 TODO
603
 
 
604
 
Addition of elements with keys that already exist to the end of the IxHash
605
 
must be controlled by a switch.
606
 
 
607
 
Provide C<TIEARRAY> interface when it stabilizes in Perl.
608
 
 
609
 
Rewrite using XSUBs for efficiency.
610
 
 
611
 
 
612
 
=head1 AUTHOR
613
 
 
614
 
Gurusamy Sarathy        gsar@umich.edu
615
 
 
616
 
Copyright (c) 1995 Gurusamy Sarathy. All rights reserved.
617
 
This program is free software; you can redistribute it and/or
618
 
modify it under the same terms as Perl itself.
619
 
 
620
 
 
621
 
=head1 VERSION
622
 
 
623
 
Version 1.21    20 Nov 1997
624
 
 
625
 
 
626
 
=head1 SEE ALSO
627
 
 
628
 
perl(1)
629
 
 
630
 
=cut