File Coverage

blib/lib/SOOT/SQL2Tree.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package SOOT::SQL2Tree;

use 5.008001;
use strict;
use warnings;

our $VERSION = '0.02';

use Carp qw(croak);
use DBI;
use SOOT;
use Scalar::Util qw(blessed);
use File::Temp qw();

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
  sql2tree
);
our @EXPORT_TAGS = (
  'all' => \@EXPORT_OK,
);
our @EXPORT;
if (caller() and (caller())[1] eq '-e') {
  SOOT::Init(1);
  push @EXPORT, @EXPORT_OK;
  SOOT->export_to_level(1, ':all');
}


our %Types = (
  'char' => {
    name => 'char',
    root_type => 'C',
  },
  'int' => {
    name => 'int',
    root_type => 'I',
  },
  'bigint' => {
    name => 'bigint',
    root_type => 'L',
  },
  'uint' => {
    name => 'uint',
    root_type => 'i',
  },
  'ubigint' => {
    name => 'ubigint',
    root_type => 'l',
  },
  'float' => {
    name => 'float',
    root_type => 'F',
  },
  'double' => {
    name => 'double',
    root_type => 'D',
  },
);

our %Typemap = qw(
  char char
  varchar char

  int int
  integer int
  smallint int
  smallinteger int
  tinyint int
  tinyinteger int

  bigint bigint
  biginteger bigint

  float float
  double double
  decimal double
);


use Class::XSAccessor {
  lvalue_accessors => [qw(dbh name title colmaps coltypes)],
};

sub new {
  my $class = shift;
  my %opt = @_;

  foreach my $param (qw(dbh)) {
    ref($opt{$param})
      or croak("Need '$param' parameter");
  }

  my $self = bless {
    colmaps  => {},
    coltypes => {},
    name     => undef,
    title    => undef,
    %opt,
  } => $class;
}

sub make_tree {
  my $self = shift;

  my $sql   = shift;
  croak("Need some SQL to make a tree") if not defined $sql;
  my $binds = shift;
  my $attrs = shift;

  my $colmaps  = $self->colmaps;
  my $coltypes = $self->coltypes;

  my $sth = $self->dbh->prepare($sql);
  $sth->execute(@{$binds||[]});

  my $name = $sth->{NAME};

  my @root_names = map {$_ = lc($_); s/[^a-z_0-9]+//g; $_} @$name;

  my @root_types;
  my $type = $sth->{TYPE};
  foreach my $i (0 .. $#{ $type }) {
    if (exists $coltypes->{ $name->[$i] }) {
      push @root_types, $self->_find_root_type($coltypes->{ $name->[$i] });
    }
    elsif (not ref($type->[$i]) and $type->[$i] =~ /^\d+$/) {
      my $typeinfo = $self->dbh->type_info($type->[$i]);
      push @root_types, $self->_find_root_type($typeinfo->{TYPE_NAME});
    }
    else {
      push @root_types, $self->_find_root_type($type->[$i]);
    }
  }

  my @root_cols;
  foreach my $i (0..$#root_names) {
    push @root_cols, $root_names[$i]."/".$root_types[$i]{root_type};
  }
  my $root_header = join(':', @root_cols);
  my $treename  = $self->name;
  my $treetitle = $self->title;
  $treetitle = $treename if not defined $treetitle;

  my @colmaps = map $colmaps->{$_}, @$name;
  @colmaps = () if not grep defined, @colmaps;

  # FIXME This should be possible to stuff into a TTree directly, but my
  # dynamic ROOT/XS/XS++/CInt fu fails me on that at this point.
  # Python must be better at *something*!
  my $tfh = File::Temp->new(CLEANUP => 1);
  if (@colmaps) {
    while (my $row = $sth->fetchrow_arrayref) {
      print $tfh join("\t", @$row), "\n";
    }
  }
  else {
    while (my $row = $sth->fetchrow_arrayref) {
      for (0..$#colmaps) {
        $row->[$_] = $colmaps[$_]->($row->[$_]) if $colmaps[$_];
      }
      print $tfh join("\t", @$row), "\n";
    }
  }
  $tfh->flush;

  my $tree = TTree->new(defined($treename) ? ($treename, $treetitle) : ());
  $tree->ReadFile($tfh->filename, $root_header);
  return $tree;
}

sub _find_root_type {
  my $self = shift;
  my $sqltype = shift;
  lc($sqltype) =~ /^([a-z0-9_]+)/
    or die "Unrecognized type: $sqltype";
  my $clean = $1;
  my $mapped = $Typemap{$clean};
  die "Cannot find ROOT type for SQL type '$sqltype' (canon: $clean)"
    if not defined $mapped;
  return $Types{$mapped};
}


sub sql2tree {
  my $dbh = shift;
  my $sql = shift;
  my $binds = shift||[];
  my $attrs = shift||{};
  my %opt;
  if (not blessed($dbh)) {
    if (ref($dbh)) {
      $dbh = DBI->connect(@$dbh);
    } else {
      $dbh = DBI->connect($dbh, "", "");
    }
  }

  my $obj = SOOT::SQL2Tree->new(
    %opt,
    dbh => $dbh,
  );
  return $obj->make_tree($sql, $binds, $attrs);
}

1;
__END__