diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm | 145 |
1 files changed, 145 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm new file mode 100644 index 00000000000..f908c9803e4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm @@ -0,0 +1,145 @@ +package CPANPLUS::Internals::Source::SQLite::Tie; + +use strict; +use warnings; + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author::Fake; +use CPANPLUS::Internals::Constants; + + +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + + +use Data::Dumper; +$Data::Dumper::Indent = 1; + +require Tie::Hash; +use vars qw[@ISA]; +push @ISA, 'Tie::StdHash'; + + +sub TIEHASH { + my $class = shift; + my %hash = @_; + + my $tmpl = { + dbh => { required => 1 }, + table => { required => 1 }, + key => { required => 1 }, + cb => { required => 1 }, + offset => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + my $obj = bless { %$args, store => {} } , $class; + + return $obj; +} + +sub FETCH { + my $self = shift; + my $key = shift or return; + my $dbh = $self->{dbh}; + my $cb = $self->{cb}; + my $table = $self->{table}; + + + ### did we look this one up before? + if( my $obj = $self->{store}->{$key} ) { + return $obj; + } + + my $res = $dbh->query( + "SELECT * from $table where $self->{key} = ?", $key + ) or do { + error( $dbh->error ); + return; + }; + + my $href = $res->hash; + + ### get rid of the primary key + delete $href->{'id'}; + + ### no results? + return unless keys %$href; + + ### expand author if needed + ### XXX no longer generic :( + if( $table eq 'module' ) { + $href->{author} = $cb->author_tree( $href->{author } ) or return; + } + + my $class = { + module => 'CPANPLUS::Module', + author => 'CPANPLUS::Module::Author', + }->{ $table }; + + my $obj = $self->{store}->{$key} = $class->new( %$href, _id => $cb->_id ); + + return $obj; +} + +sub STORE { + my $self = shift; + my $key = shift; + my $val = shift; + + $self->{store}->{$key} = $val; +} + +1; + +sub FIRSTKEY { + my $self = shift; + my $dbh = $self->{'dbh'}; + + my $res = $dbh->query( + "select $self->{key} from $self->{table} order by $self->{key} limit 1" + ); + + $self->{offset} = 0; + + my $key = $res->flat->[0]; + + return $key; +} + +sub NEXTKEY { + my $self = shift; + my $dbh = $self->{'dbh'}; + + my $res = $dbh->query( + "select $self->{key} from $self->{table} ". + "order by $self->{key} limit 1 offset $self->{offset}" + ); + + $self->{offset} +=1; + + my $key = $res->flat->[0]; + my $val = $self->FETCH( $key ); + + ### use each() semantics + return wantarray ? ( $key, $val ) : $key; +} + +sub EXISTS { !!$_[0]->FETCH( $_[1] ) } + +sub SCALAR { + my $self = shift; + my $dbh = $self->{'dbh'}; + + my $res = $dbh->query( "select count(*) from $self->{table}" ); + + return $res->flat; +} + +### intentionally left blank +sub DELETE { } +sub CLEAR { } + |