apparently vaguely working store code

diff --git a/lib/App/IdiotBox/DataSet.pm b/lib/App/IdiotBox/DataSet.pm
new file mode 100644 (file)
index 0000000..b238364
--- /dev/null
+++ b/lib/App/IdiotBox/DataSet.pm
@@ -0,0 +1,30 @@
+package App::IdiotBox::DataSet;
+
+use strict;
+use warnings FATAL => 'all';
+use Scalar::Util qw(blessed);
+
+use base qw(DBIx::Data::Collection::Set);
+
+sub _inflate {
+  my ($self, $raw) = @_;
+  my %new;
+  foreach my $k (keys %$raw) {
+    my @parts = split /\./, $k;
+    my $final = pop @parts;
+    @parts or ($new{$k} = $raw->{$k}, next);
+    my $targ = \%new;
+    $targ = $targ->{$_}||={} for @parts;
+    $targ->{$final} = $raw->{$k};
+  }
+  $self->_class->{inflate}->($self, \%new);
+}
+
+sub _deflate {
+  my ($self, $obj) = @_;
+  $self->_class->{deflate}->($self, $obj)
+}
+
+sub _merge { die "no" }
+
+1;

diff --git a/lib/App/IdiotBox/Store/SQLite.pm b/lib/App/IdiotBox/Store/SQLite.pm
new file mode 100644 (file)
index 0000000..2bd60e6
--- /dev/null
+++ b/lib/App/IdiotBox/Store/SQLite.pm
@@ -0,0 +1,163 @@
+package App::IdiotBox::Store::SQLite;
+
+use strict;
+use warnings FATAL => 'all';
+use DBIx::Data::Store;
+use DBIx::Data::Store::CRUD;
+use App::IdiotBox::DataSet;
+use Scalar::Util qw(weaken);
+
+my (%BIND, %SQL);
+
+%BIND = (
+  recent_announcements => {
+    class => {
+      inflate => sub {
+        my ($self, $obj) = @_;
+        bless($obj, 'App::IdiotBox::Announcement');
+        bless($obj->{bucket}, 'App::IdiotBox::Bucket');
+        $obj;
+      },
+      deflate => sub {
+        my ($self, $obj) = @_;
+        my %raw = %$obj;
+        delete $raw{bucket};
+        \%raw;
+      }
+    },
+    set_over => [ 'id' ],
+  },
+  buckets => {
+    class => {
+      inflate => sub {
+        my ($self, $obj) = @_;
+        bless($obj, 'App::IdiotBox::Bucket');
+        weaken (my $weak = $obj);
+        $obj->{videos} = _bind_set('bucket_videos',
+          {
+            raw_store => $self->_store->raw_store,
+            implicit_arguments => { bucket_slug => $obj->{slug} },
+          },
+          {
+            class => {
+              inflate => sub {
+                my ($self, $obj) = @_;
+                bless($obj, 'App::IdiotBox::Video');
+                weaken($obj->{bucket} = $weak);
+                $obj;
+              },
+              deflate => sub {
+                my ($self, $obj) = @_;
+                my %raw = %$obj;
+                delete $raw{bucket};
+                \%raw;
+              },
+            }
+          }
+        );
+        $obj;
+      },
+      deflate => sub {
+        my ($self, $obj) = @_;
+        my %raw = %$obj;
+        delete $raw{videos};
+        \%raw;
+      }
+    },
+    set_over => [ 'slug' ],
+  },
+  bucket_videos => {
+    set_over => [ 'slug' ]
+  },
+);
+
+%SQL = (
+  recent_announcements => {
+    select_column_order => [ qw(
+      id made_at video_count bucket.slug bucket.name bucket.video_count
+    ) ],
+    select_sql => q{
+      SELECT
+        announcement.id, announcement.made_at, COUNT(DISTINCT my_videos.slug),
+        bucket.slug, bucket.name, COUNT(DISTINCT all_videos.slug)
+      FROM
+        announcements announcement
+        JOIN buckets bucket
+          ON bucket.slug = announcement.bucket_slug
+        JOIN videos my_videos
+          ON my_videos.announcement_id = announcement.id
+        JOIN videos all_videos
+          ON all_videos.bucket_slug = announcement.bucket_slug
+        JOIN announcements all_announcements
+          ON all_announcements.bucket_slug = announcement.bucket_slug
+      GROUP BY
+        announcement.made_at, bucket.slug, bucket.name
+      HAVING
+        announcement.made_at = MAX(all_announcements.made_at)
+      ORDER BY
+        announcement.made_at DESC
+    },
+  },
+  buckets => {
+    select_column_order => [ qw(slug name) ],
+    select_single_sql => q{
+      SELECT slug, name
+      FROM buckets
+      WHERE slug = ?
+    },
+    select_single_argument_order => [ 'slug' ],
+  },
+  bucket_videos => {
+    select_column_order => [ qw(slug name author details) ],
+    select_sql => q{
+      SELECT slug, name, author, details
+      FROM videos
+      WHERE bucket_slug = ?
+    },
+    select_argument_order => [ 'bucket_slug' ],
+    select_single_sql => q{
+      SELECT slug, name, author, details
+      FROM videos
+      WHERE bucket_slug = ? AND slug = ?
+    },
+    select_single_argument_order => [ qw(bucket_slug slug) ],
+  },
+);
+
+sub bind {
+  my ($class, $idiotbox) = @_;
+  bless({ idiotbox => $idiotbox }, $class)->_bind;
+}
+
+my $DSN = 'dbi:SQLite:idiotbox.db';
+
+sub _new_db_store {
+  DBIx::Data::Store->connect($DSN);
+}
+
+sub _bind {
+  my $self = shift;
+  my $idiotbox = $self->{idiotbox};
+
+  my $db_store = $self->_new_db_store;
+
+  foreach my $to_bind (qw(recent_announcements buckets)) {
+    $idiotbox->{$to_bind} = _bind_set($to_bind, { raw_store => $db_store });
+  }
+  $idiotbox;
+}
+
+sub _bind_set {
+  my ($type, $store_args, $set_args) = @_;
+  my $store = DBIx::Data::Store::CRUD->new({
+    %{$SQL{$type}},
+    %{$store_args},
+  });
+  return App::IdiotBox::DataSet->new({
+    %{$BIND{$type}},
+    store => $store,
+    %{$set_args||{}},
+  });
+}
+
+1;

diff --git a/t/store/sqlite.t b/t/store/sqlite.t
new file mode 100644 (file)
index 0000000..dca7489
--- /dev/null
+++ b/t/store/sqlite.t
@@ -0,0 +1,17 @@
+use strict;
+use warnings FATAL => 'all';
+
+use App::IdiotBox::Store::SQLite;
+
+use Devel::Dwarn;
+
+my $ib = {};
+
+App::IdiotBox::Store::SQLite->bind($ib);
+
+#Dwarn [ $ib->{recent_announcements}->flatten ];
+my $bucket = DwarnS $ib->{buckets}->get({ slug => 'opw2010'});
+
+#Dwarn [ $bucket->{videos}->flatten ];
+
+Dwarn $bucket->{videos}->get({ slug => 'troll-god-mountain' });