Commit | Line | Data |
4443dd53 |
1 | package CPANPLUS::Internals::Source::SQLite::Tie; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use CPANPLUS::Error; |
7 | use CPANPLUS::Module; |
8 | use CPANPLUS::Module::Fake; |
9 | use CPANPLUS::Module::Author::Fake; |
10 | use CPANPLUS::Internals::Constants; |
11 | |
12 | |
13 | use Params::Check qw[check]; |
14 | use Module::Load::Conditional qw[can_load]; |
15 | use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
16 | |
17 | |
18 | use Data::Dumper; |
19 | $Data::Dumper::Indent = 1; |
20 | |
21 | require Tie::Hash; |
22 | use vars qw[@ISA]; |
23 | push @ISA, 'Tie::StdHash'; |
24 | |
25 | |
26 | sub TIEHASH { |
27 | my $class = shift; |
28 | my %hash = @_; |
29 | |
30 | my $tmpl = { |
31 | dbh => { required => 1 }, |
32 | table => { required => 1 }, |
33 | key => { required => 1 }, |
34 | cb => { required => 1 }, |
35 | offset => { default => 0 }, |
36 | }; |
37 | |
38 | my $args = check( $tmpl, \%hash ) or return; |
39 | my $obj = bless { %$args, store => {} } , $class; |
40 | |
41 | return $obj; |
42 | } |
43 | |
44 | sub FETCH { |
45 | my $self = shift; |
46 | my $key = shift or return; |
47 | my $dbh = $self->{dbh}; |
48 | my $cb = $self->{cb}; |
49 | my $table = $self->{table}; |
50 | |
51 | |
52 | ### did we look this one up before? |
53 | if( my $obj = $self->{store}->{$key} ) { |
54 | return $obj; |
55 | } |
56 | |
57 | my $res = $dbh->query( |
58 | "SELECT * from $table where $self->{key} = ?", $key |
59 | ) or do { |
60 | error( $dbh->error ); |
61 | return; |
62 | }; |
63 | |
64 | my $href = $res->hash; |
65 | |
66 | ### get rid of the primary key |
67 | delete $href->{'id'}; |
68 | |
69 | ### no results? |
70 | return unless keys %$href; |
71 | |
72 | ### expand author if needed |
73 | ### XXX no longer generic :( |
74 | if( $table eq 'module' ) { |
75 | $href->{author} = $cb->author_tree( $href->{author } ) or return; |
76 | } |
77 | |
78 | my $class = { |
79 | module => 'CPANPLUS::Module', |
80 | author => 'CPANPLUS::Module::Author', |
81 | }->{ $table }; |
82 | |
83 | my $obj = $self->{store}->{$key} = $class->new( %$href, _id => $cb->_id ); |
84 | |
85 | return $obj; |
86 | } |
87 | |
88 | sub STORE { |
89 | my $self = shift; |
90 | my $key = shift; |
91 | my $val = shift; |
92 | |
93 | $self->{store}->{$key} = $val; |
94 | } |
95 | |
96 | 1; |
97 | |
98 | sub FIRSTKEY { |
99 | my $self = shift; |
100 | my $dbh = $self->{'dbh'}; |
101 | |
102 | my $res = $dbh->query( |
103 | "select $self->{key} from $self->{table} order by $self->{key} limit 1" |
104 | ); |
105 | |
106 | $self->{offset} = 0; |
107 | |
108 | my $key = $res->flat->[0]; |
109 | |
110 | return $key; |
111 | } |
112 | |
113 | sub NEXTKEY { |
114 | my $self = shift; |
115 | my $dbh = $self->{'dbh'}; |
116 | |
117 | my $res = $dbh->query( |
118 | "select $self->{key} from $self->{table} ". |
119 | "order by $self->{key} limit 1 offset $self->{offset}" |
120 | ); |
121 | |
122 | $self->{offset} +=1; |
123 | |
124 | my $key = $res->flat->[0]; |
125 | my $val = $self->FETCH( $key ); |
126 | |
127 | ### use each() semantics |
128 | return wantarray ? ( $key, $val ) : $key; |
129 | } |
130 | |
131 | sub EXISTS { !!$_[0]->FETCH( $_[1] ) } |
132 | |
133 | sub SCALAR { |
134 | my $self = shift; |
135 | my $dbh = $self->{'dbh'}; |
136 | |
137 | my $res = $dbh->query( "select count(*) from $self->{table}" ); |
138 | |
139 | return $res->flat; |
140 | } |
141 | |
142 | ### intentionally left blank |
143 | sub DELETE { } |
144 | sub CLEAR { } |
145 | |