source: perl/modules/AIM/lib/Net/OSCAR/TLV.pm @ 3dcccba

barnowl_perlaim
Last change on this file since 3dcccba was 7a1c90d, checked in by Geoffrey Thomas <geofft@mit.edu>, 14 years ago
Skeleton AIM module, and Net::OSCAR 1.925
  • Property mode set to 100644
File size: 3.4 KB
Line 
1=pod
2
3Net::OSCAR::TLV -- tied hash for OSCAR TLVs
4
5Keys in hashes tied to this class will be treated as numbers.
6This class also preserves the ordering of its keys.
7
8=cut
9
10package Net::OSCAR::TLV;
11
12$VERSION = '1.925';
13$REVISION = '$Revision: 1.31 $';
14
15use strict;
16use vars qw($VERSION @EXPORT @ISA);
17
18require 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.
26sub new {
27        my $pkg = shift;
28        my $self = $pkg->TIEHASH(@_);
29}
30
31
32sub getorder {
33        my $self = shift;
34        return map { (unpack("n", $_))[0] } @{$self->{ORDER}};
35}
36
37sub 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
47sub TIEHASH {
48        my $class = shift;
49        my $self = { DATA => {}, ORDER => [], CURRKEY => -1, AUTOVIVIFY => shift};
50        return bless $self, $class;
51}
52
53sub FETCH {
54        my($self, $key) = @_;
55        $self->{DATA}->{pack("n", 0+$key)};
56}
57
58sub 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
88sub 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
105sub CLEAR {
106        my $self = shift;
107        $self->{DATA} = {};
108        $self->{ORDER} = [];
109        $self->{CURRKEY} = -1;
110        return $self;
111}
112
113sub EXISTS {
114        my($self, $key) = @_;
115        my($packedkey) = pack("n", 0+$key);
116        return exists $self->{DATA}->{$packedkey};
117}
118
119sub FIRSTKEY {
120        $_[0]->{CURRKEY} = -1;
121        goto &NEXTKEY;
122}
123
124sub 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
138sub 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
1461;
Note: See TracBrowser for help on using the repository browser.