1 | =pod |
---|
2 | |
---|
3 | Net::OSCAR::TLV -- tied hash for OSCAR TLVs |
---|
4 | |
---|
5 | Keys in hashes tied to this class will be treated as numbers. |
---|
6 | This class also preserves the ordering of its keys. |
---|
7 | |
---|
8 | =cut |
---|
9 | |
---|
10 | package Net::OSCAR::TLV; |
---|
11 | |
---|
12 | $VERSION = '1.925'; |
---|
13 | $REVISION = '$Revision: 1.31 $'; |
---|
14 | |
---|
15 | use strict; |
---|
16 | use vars qw($VERSION @EXPORT @ISA); |
---|
17 | |
---|
18 | require Exporter; |
---|
19 | @ISA = qw(Exporter); |
---|
20 | @EXPORT = qw(tlv); |
---|
21 | |
---|
22 | # Extra arguments: an optional scalar which modifies the behavior of $self->{foo}->{bar} = "baz" |
---|
23 | # Iff foo doesn't exist, the scalar will be evaluated and assigned as the value of foo. |
---|
24 | # So, instead of having foo be {bar => "baz"} , it could be another TLV. |
---|
25 | # It will be given the key bar. |
---|
26 | sub new { |
---|
27 | my $pkg = shift; |
---|
28 | my $self = $pkg->TIEHASH(@_); |
---|
29 | } |
---|
30 | |
---|
31 | |
---|
32 | sub getorder { |
---|
33 | my $self = shift; |
---|
34 | return map { (unpack("n", $_))[0] } @{$self->{ORDER}}; |
---|
35 | } |
---|
36 | |
---|
37 | sub setorder { |
---|
38 | my $self = shift; |
---|
39 | |
---|
40 | # Anything not specified gets shoved at the end |
---|
41 | my @end = grep { my $inbud = $_; not grep { $_ eq $inbud } @_ } @{$self->{ORDER}}; |
---|
42 | |
---|
43 | @{$self->{ORDER}} = map { pack("n", 0+$_) } @_; |
---|
44 | push @{$self->{ORDER}}, @end; |
---|
45 | } |
---|
46 | |
---|
47 | sub TIEHASH { |
---|
48 | my $class = shift; |
---|
49 | my $self = { DATA => {}, ORDER => [], CURRKEY => -1, AUTOVIVIFY => shift}; |
---|
50 | return bless $self, $class; |
---|
51 | } |
---|
52 | |
---|
53 | sub FETCH { |
---|
54 | my($self, $key) = @_; |
---|
55 | $self->{DATA}->{pack("n", 0+$key)}; |
---|
56 | } |
---|
57 | |
---|
58 | sub STORE { |
---|
59 | my($self, $key, $value) = @_; |
---|
60 | my($normalkey) = pack("n", 0+$key); |
---|
61 | |
---|
62 | #print STDERR "Storing: ", Data::Dumper->Dump([$value], ["${self}->{$key}"]); |
---|
63 | if(!exists $self->{DATA}->{$normalkey}) { |
---|
64 | if( |
---|
65 | $self->{AUTOVIVIFY} and |
---|
66 | ref($value) eq "HASH" and |
---|
67 | !tied(%$value) and |
---|
68 | scalar keys %$value == 0 |
---|
69 | ) { |
---|
70 | #print STDERR "Autovivifying $key: $self->{AUTOVIVIFY}\n"; |
---|
71 | eval $self->{AUTOVIVIFY}; |
---|
72 | #print STDERR "New value: ", Data::Dumper->Dump([$self->{DATA}->{$normalkey}], ["${self}->{$key}"]); |
---|
73 | } else { |
---|
74 | #print STDERR "Not autovivifying $key.\n"; |
---|
75 | #print STDERR "No autovivify.\n" unless $self->{AUTOVIVIFY}; |
---|
76 | #printf STDERR "ref(\$value) eq %s\n", ref($value) unless ref($value) eq "HASH"; |
---|
77 | #print STDERR "tied(\%\$value)\n" unless !tied(%$value); |
---|
78 | #printf STDERR "scalar keys \%\$value == %d\n", scalar keys %$value unless scalar keys %$value == 0; |
---|
79 | } |
---|
80 | push @{$self->{ORDER}}, $normalkey; |
---|
81 | } else { |
---|
82 | #print STDERR "Not autovivifying $key: already exists\n"; |
---|
83 | } |
---|
84 | $self->{DATA}->{$normalkey} = $value; |
---|
85 | return $value; |
---|
86 | } |
---|
87 | |
---|
88 | sub DELETE { |
---|
89 | my($self, $key) = @_; |
---|
90 | my($packedkey) = pack("n", 0+$key); |
---|
91 | delete $self->{DATA}->{$packedkey}; |
---|
92 | for(my $i = 0; $i < scalar @{$self->{ORDER}}; $i++) { |
---|
93 | next unless $packedkey eq $self->{ORDER}->[$i]; |
---|
94 | splice(@{$self->{ORDER}}, $i, 1); |
---|
95 | |
---|
96 | # What if the user deletes a key while iterating? We need to correct for the new index. |
---|
97 | if($self->{CURRKEY} != -1 and $i <= $self->{CURRKEY}) { |
---|
98 | $self->{CURRKEY}--; |
---|
99 | } |
---|
100 | |
---|
101 | last; |
---|
102 | } |
---|
103 | } |
---|
104 | |
---|
105 | sub CLEAR { |
---|
106 | my $self = shift; |
---|
107 | $self->{DATA} = {}; |
---|
108 | $self->{ORDER} = []; |
---|
109 | $self->{CURRKEY} = -1; |
---|
110 | return $self; |
---|
111 | } |
---|
112 | |
---|
113 | sub EXISTS { |
---|
114 | my($self, $key) = @_; |
---|
115 | my($packedkey) = pack("n", 0+$key); |
---|
116 | return exists $self->{DATA}->{$packedkey}; |
---|
117 | } |
---|
118 | |
---|
119 | sub FIRSTKEY { |
---|
120 | $_[0]->{CURRKEY} = -1; |
---|
121 | goto &NEXTKEY; |
---|
122 | } |
---|
123 | |
---|
124 | sub NEXTKEY { |
---|
125 | my ($self) = @_; |
---|
126 | |
---|
127 | my $currkey = ++$self->{CURRKEY}; |
---|
128 | if($currkey >= scalar @{$self->{ORDER}}) { |
---|
129 | return wantarray ? () : undef; |
---|
130 | } |
---|
131 | |
---|
132 | my $packedkey = $self->{ORDER}->[$currkey]; |
---|
133 | my($key) = unpack("n", $packedkey); |
---|
134 | return wantarray ? ($key, $self->{DATA}->{$packedkey}) : $key; |
---|
135 | } |
---|
136 | |
---|
137 | |
---|
138 | sub tlv(;@) { |
---|
139 | my %tlv = (); |
---|
140 | tie %tlv, "Net::OSCAR::TLV"; |
---|
141 | while(@_) { my($key, $value) = (shift, shift); $tlv{$key} = $value; } |
---|
142 | return \%tlv; |
---|
143 | } |
---|
144 | |
---|
145 | |
---|
146 | 1; |
---|