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


line stmt bran cond sub pod time code
1             package SOOT::SQL2Tree;
2              
3 1     1   22907 use 5.008001;
  1         5  
  1         44  
4 1     1   6 use strict;
  1         2  
  1         58  
5 1     1   5 use warnings;
  1         7  
  1         47  
6              
7             our $VERSION = '0.02';
8              
9 1     1   14 use Carp qw(croak);
  1         3  
  1         103  
10 1     1   2490 use DBI;
  1         20157  
  1         59  
11 1     1   1768 use SOOT;
  0            
  0            
12             use Scalar::Util qw(blessed);
13             use File::Temp qw();
14              
15             require Exporter;
16             our @ISA = qw(Exporter);
17             our @EXPORT_OK = qw(
18             sql2tree
19             );
20             our @EXPORT_TAGS = (
21             'all' => \@EXPORT_OK,
22             );
23             our @EXPORT;
24             if (caller() and (caller())[1] eq '-e') {
25             SOOT::Init(1);
26             push @EXPORT, @EXPORT_OK;
27             SOOT->export_to_level(1, ':all');
28             }
29              
30              
31             our %Types = (
32             'char' => {
33             name => 'char',
34             root_type => 'C',
35             },
36             'int' => {
37             name => 'int',
38             root_type => 'I',
39             },
40             'bigint' => {
41             name => 'bigint',
42             root_type => 'L',
43             },
44             'uint' => {
45             name => 'uint',
46             root_type => 'i',
47             },
48             'ubigint' => {
49             name => 'ubigint',
50             root_type => 'l',
51             },
52             'float' => {
53             name => 'float',
54             root_type => 'F',
55             },
56             'double' => {
57             name => 'double',
58             root_type => 'D',
59             },
60             );
61              
62             our %Typemap = qw(
63             char char
64             varchar char
65              
66             int int
67             integer int
68             smallint int
69             smallinteger int
70             tinyint int
71             tinyinteger int
72              
73             bigint bigint
74             biginteger bigint
75              
76             float float
77             double double
78             decimal double
79             );
80              
81              
82             use Class::XSAccessor {
83             lvalue_accessors => [qw(dbh name title colmaps coltypes)],
84             };
85              
86             sub new {
87             my $class = shift;
88             my %opt = @_;
89              
90             foreach my $param (qw(dbh)) {
91             ref($opt{$param})
92             or croak("Need '$param' parameter");
93             }
94              
95             my $self = bless {
96             colmaps => {},
97             coltypes => {},
98             name => undef,
99             title => undef,
100             %opt,
101             } => $class;
102             }
103              
104             sub make_tree {
105             my $self = shift;
106            
107             my $sql = shift;
108             croak("Need some SQL to make a tree") if not defined $sql;
109             my $binds = shift;
110             my $attrs = shift;
111              
112             my $colmaps = $self->colmaps;
113             my $coltypes = $self->coltypes;
114              
115             my $sth = $self->dbh->prepare($sql);
116             $sth->execute(@{$binds||[]});
117              
118             my $name = $sth->{NAME};
119              
120             my @root_names = map {$_ = lc($_); s/[^a-z_0-9]+//g; $_} @$name;
121              
122             my @root_types;
123             my $type = $sth->{TYPE};
124             foreach my $i (0 .. $#{ $type }) {
125             if (exists $coltypes->{ $name->[$i] }) {
126             push @root_types, $self->_find_root_type($coltypes->{ $name->[$i] });
127             }
128             elsif (not ref($type->[$i]) and $type->[$i] =~ /^\d+$/) {
129             my $typeinfo = $self->dbh->type_info($type->[$i]);
130             push @root_types, $self->_find_root_type($typeinfo->{TYPE_NAME});
131             }
132             else {
133             push @root_types, $self->_find_root_type($type->[$i]);
134             }
135             }
136              
137             my @root_cols;
138             foreach my $i (0..$#root_names) {
139             push @root_cols, $root_names[$i]."/".$root_types[$i]{root_type};
140             }
141             my $root_header = join(':', @root_cols);
142             my $treename = $self->name;
143             my $treetitle = $self->title;
144             $treetitle = $treename if not defined $treetitle;
145              
146             my @colmaps = map $colmaps->{$_}, @$name;
147             @colmaps = () if not grep defined, @colmaps;
148              
149             # FIXME This should be possible to stuff into a TTree directly, but my
150             # dynamic ROOT/XS/XS++/CInt fu fails me on that at this point.
151             # Python must be better at *something*!
152             my $tfh = File::Temp->new(CLEANUP => 1);
153             if (@colmaps) {
154             while (my $row = $sth->fetchrow_arrayref) {
155             print $tfh join("\t", @$row), "\n";
156             }
157             }
158             else {
159             while (my $row = $sth->fetchrow_arrayref) {
160             for (0..$#colmaps) {
161             $row->[$_] = $colmaps[$_]->($row->[$_]) if $colmaps[$_];
162             }
163             print $tfh join("\t", @$row), "\n";
164             }
165             }
166             $tfh->flush;
167              
168             my $tree = TTree->new(defined($treename) ? ($treename, $treetitle) : ());
169             $tree->ReadFile($tfh->filename, $root_header);
170             return $tree;
171             }
172              
173             sub _find_root_type {
174             my $self = shift;
175             my $sqltype = shift;
176             lc($sqltype) =~ /^([a-z0-9_]+)/
177             or die "Unrecognized type: $sqltype";
178             my $clean = $1;
179             my $mapped = $Typemap{$clean};
180             die "Cannot find ROOT type for SQL type '$sqltype' (canon: $clean)"
181             if not defined $mapped;
182             return $Types{$mapped};
183             }
184              
185              
186             sub sql2tree {
187             my $dbh = shift;
188             my $sql = shift;
189             my $binds = shift||[];
190             my $attrs = shift||{};
191             my %opt;
192             if (not blessed($dbh)) {
193             if (ref($dbh)) {
194             $dbh = DBI->connect(@$dbh);
195             } else {
196             $dbh = DBI->connect($dbh, "", "");
197             }
198             }
199              
200             my $obj = SOOT::SQL2Tree->new(
201             %opt,
202             dbh => $dbh,
203             );
204             return $obj->make_tree($sql, $binds, $attrs);
205             }
206              
207             1;
208             __END__