Having fun nesting DBI results

hand_coded_nester.pl

#!/usr/bin/env perl

use strict;
use warnings;
use Test::More;
use Test::Deep;

## The ouput of a DBI querie with multiple nested join's
my @raw = (
  { p1_id => 1, p1_n => 'a', p2_pa => 1, p2_pb => 1, p2_pn => 'p1', p3_s => 1, p3_sn => 's1' },
  { p1_id => 1, p1_n => 'a', p2_pa => 1, p2_pb => 1, p2_pn => 'p1', p3_s => 2, p3_sn => 's2' },
  { p1_id => 1, p1_n => 'a', p2_pa => 1, p2_pb => 1, p2_pn => 'p1', p3_s => 3, p3_sn => 's3' },

  { p1_id => 1, p1_n => 'a', p2_pa => 2, p2_pb => 2, p2_pn => 'p2', p3_s => 1, p3_sn => 's1' },
  { p1_id => 1, p1_n => 'a', p2_pa => 2, p2_pb => 2, p2_pn => 'p2', p3_s => 2, p3_sn => 's2' },

  { p1_id => 2, p1_n => 'b', p2_pa => 1, p2_pb => 1, p2_pn => 'p1', p3_s => 1, p3_sn => 's1' },
  { p1_id => 2, p1_n => 'b', p2_pa => 1, p2_pb => 1, p2_pn => 'p1', p3_s => 2, p3_sn => 's2' },
  { p1_id => 2, p1_n => 'b', p2_pa => 1, p2_pb => 1, p2_pn => 'p1', p3_s => 3, p3_sn => 's3' },

  { p1_id => 3, p1_n => 'c', p2_pa => 3, p2_pb => 3, p2_pn => 'p3', p3_s => 4, p3_sn => 's4' },
  { p1_id => 3, p1_n => 'c', p2_pa => 3, p2_pb => 3, p2_pn => 'p3', p3_s => 5, p3_sn => 's5' },
  { p1_id => 3, p1_n => 'c', p2_pa => 3, p2_pb => 3, p2_pn => 'p3', p3_s => 6, p3_sn => 's6' },
);

my %seen;
my @rows;

## Code to re-organize the previous flat list into tree structure:
##  - like DBIC DBIx::Class _construct_object/_collapse_result
##  - the following code will be generated and eval'ed (and cached) key'ed
##    on the SQL string
##
## Q: Are structures representing the same "row" shared/reused in the tree?
## A1: I need to think this through, I don't think it works sometimes, need to check.
## A2: No. Teoretically in the input above, we could have one HashRed for
##    pa=1,pb=1 reused in p1_id=1 and p1_id=2, but each of those instances
##    could have a different p3 set. Eg. with this WHERE clause:
##        (p1_id = 1 AND p3_s < 2) OR (p1_id = 2 AND p3_s >= 2)
##    With this WHERE clause, the set ss inside the p2 with id pa=1,pb=2
##    will be different between p1_id1 and p1_id2
##
for my $r (@raw) {
  my $o1;
  my $s1 = $seen{o1}{ $r->{p1_id} } ||= {};
  unless (%$s1) {
    push @rows, $o1 = $s1->{o} = {
      id => $r->{p1_id},
      n  => $r->{p1_n},
    };
  }
  $o1 = $s1->{o};

  my $o2;
  my $s2 = $s1->{o2}{ $r->{p2_pa} }{ $r->{p2_pb} } ||= {};
  unless (%$s2) {
    push @{ $o1->{ps} }, $s2->{o} = $o2 = {
      pa => $r->{p2_pa},
      pb => $r->{p2_pb},
      pn => $r->{p2_pn},
    };
  }
  $o2 = $s2->{o};

  my $o3;
  my $s3 = $s2->{o3}{ $r->{p3_s} } ||= {};
  unless (%$s3) {
    push @{ $o2->{ss} }, $s3->{o} = $o3 = {
      s  => $r->{p3_s},
      sn => $r->{p3_sn},
    };
  }
}

cmp_deeply(
  \@rows,
  [ { id => 1,
      n  => "a",
      ps => [
        { pa => 1,
          pb => 1,
          pn => "p1",
          ss => [{ s => 1, sn => "s1" }, { s => 2, sn => "s2" }, { s => 3, sn => "s3" },],
        },
        { pa => 2,
          pb => 2,
          pn => "p2",
          ss => [{ s => 1, sn => "s1" }, { s => 2, sn => "s2" }],
        },
      ],
    },
    { id => 2,
      n  => "b",
      ps => [
        { pa => 1,
          pb => 1,
          pn => "p1",
          ss => [{ s => 1, sn => "s1" }, { s => 2, sn => "s2" }, { s => 3, sn => "s3" },],
        },
      ],
    },
    { id => 3,
      n  => "c",
      ps => [
        { pa => 3,
          pb => 3,
          pn => "p3",
          ss => [{ s => 4, sn => "s4" }, { s => 5, sn => "s5" }, { s => 6, sn => "s6" },],
        },
      ],
    },
  ],
  'Yay!'
);

done_testing();

See this https://github.com/melo/dbix-nesting as a module that implements the concepts in this gist.