cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm

   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