File Coverage

blib/lib/Text/ANSITable/SQLStyleSheet.pm
Criterion Covered Total %
statement 90 96 93.7
branch 17 26 65.3
condition 1 3 33.3
subroutine 15 15 100.0
pod 1 1 100.0
total 124 141 87.9


line stmt bran cond sub pod time code
1             package Text::ANSITable::SQLStyleSheet;
2 2     2   68525 use 5.018000;
  2         13  
3 2     2   10 use strict;
  2         5  
  2         39  
4 2     2   10 use warnings;
  2         3  
  2         46  
5 2     2   885 use version;
  2         3954  
  2         12  
6 2     2   1729 use Text::ANSITable;
  2         199208  
  2         88  
7 2     2   1358 use JSON;
  2         20888  
  2         15  
8 2     2   3743 use DBI;
  2         35488  
  2         222  
9 2     2   1762 use DBD::SQLite;
  2         18832  
  2         1998  
10              
11             our $VERSION = '0.02';
12              
13             our $Json = JSON->new;
14              
15             sub _sqlite_type_from_sth_ix {
16              
17 1     1   4 my ($dbh, $sth, $ix) = @_;
18              
19 1         17 my $sth_type = $sth->{TYPE}[ $ix ];
20              
21             # NOTE: It seems that as of 2018-10-06 DBD::SQLite returns the
22             # wrong kind of value for TYPE. It also does not implement the
23             # type_info method.
24             #
25             # Worse, for something like `SELECT 1, TYPEOF(1)` SQLite itself
26             # considers the first to be an `integer`, but DBD::SQLite returns
27             # `VARCHAR` in $sth->{TYPE}.
28             #
29             # Reported in .
30             #
31             # Other drivers may have similar issues, so this is best-effort
32             # guesswork.
33             #
34             # SQLite will do further guesswork on the type we pass to it, per
35             # .
36              
37 1 50       5 if (defined $sth_type) {
38              
39 1         11 my $type_info = $dbh->type_info($sth_type);
40              
41 1 50 33     34 if ( $type_info and exists $type_info->{TYPE_NAME} ) {
    50          
42              
43 0         0 return $type_info->{TYPE_NAME};
44              
45             } elsif ($sth_type !~ /^\d+$/) {
46              
47 1         14 return $sth_type;
48              
49             }
50              
51             }
52              
53 0         0 return 'TEXT';
54              
55             }
56              
57             sub _from_sth_sql {
58              
59 1     1   4 my ($class, $sth, $sql) = @_;
60              
61 1         5 my $dbh = DBI->connect('dbi:SQLite:dbname=:memory:');
62              
63 1         445 local $dbh->{sqlite_allow_multiple_statements} = 1;
64              
65 1         28 $dbh->do(q{
66             PRAGMA synchronous = OFF;
67             PRAGMA journal_mode = OFF;
68             PRAGMA locking_mode = EXCLUSIVE;
69             });
70              
71             my $fields = join(',', map {
72             sprintf(
73             'CAST(NULL AS %s) AS %s',
74             _sqlite_type_from_sth_ix($dbh, $sth, $_),
75 1         24 $dbh->quote_identifier(undef, undef, $sth->{NAME}[$_]))
76 1         444 } 0 .. @{ $sth->{NAME} } - 1);
  1         24  
77              
78 1         113 my $create_sth = $dbh->prepare(sprintf(q{
79             CREATE TABLE data AS SELECT %s LIMIT 0
80             }, $fields));
81              
82 1         202 $create_sth->execute();
83              
84             my $insert_sth = $dbh->prepare(sprintf(q{
85             INSERT INTO data VALUES(%s)
86 1         12 }, join(',', map { '?' } 0 .. @{ $sth->{NAME} } - 1)));
  1         12  
  1         12  
87              
88 1         64 $dbh->begin_work;
89              
90 1         36 while (my $row = $sth->fetchrow_arrayref()) {
91 10         109 $insert_sth->execute(@$row);
92             }
93              
94 1         12 $dbh->commit;
95              
96             # $dbh->sqlite_backup_to_file('DEBUG.sqlite');
97              
98 1         5 my $final_sth = $dbh->prepare( $sql );
99              
100 1         212 $final_sth->execute();
101              
102 1         12 return $class->from_sth( $final_sth );
103              
104             }
105              
106             sub from_sth {
107              
108 2     2 1 2146 my ($class, $sth, $sql) = @_;
109              
110 2 100       12 return _from_sth_sql(@_) if defined $sql;
111              
112 1         3 my %col2ix;
113             $col2ix{$_} = keys %col2ix
114 1         3 for @{ $sth->{NAME} };
  1         16  
115              
116             # filter out __*_style columns
117             my @wanted = map {
118 1 100       6 /^__(\w+)_style$/ ? () : $col2ix{$_}
  3         35  
119             } keys %col2ix;
120              
121 1         11 my $t = Text::ANSITable->new;
122              
123 1         101464 $t->columns([ map { $sth->{NAME}[$_] } @wanted ]);
  1         82  
124              
125 1         34 my $nth = 0;
126            
127 1         94 while (my $row = $sth->fetchrow_arrayref) {
128              
129 10         23 $t->add_row([ @{ $row }[ @wanted ] ]);
  10         61  
130            
131 10 100       144 if ( $nth == 0 ) {
132 1         17 _column_style( $t, $row, \%col2ix, $col2ix{__column_style} );
133             }
134            
135 10         34 _row_style( $t, $nth, $row, \%col2ix, $col2ix{__row_style} );
136 10         195 _cell_styles( $t, $nth, $row, \%col2ix, $col2ix{__cell_style} );
137            
138 10         299 $nth += 1;
139              
140             }
141            
142 1         283 return $t;
143              
144             }
145              
146             sub _get_hashref {
147 21     21   38 my ($row, $ix) = @_;
148              
149 21 100       48 return unless defined $ix;
150 20 50       36 return unless defined $row->[ $ix ];
151              
152 20         124 my $h = $Json->decode( $row->[ $ix ] );
153              
154 20 50       45 return unless 'HASH' eq ref( $h );
155              
156 20         68 delete @$h{ grep !defined($h->{$_}), keys %$h };
157            
158 20         51 return $h;
159              
160             }
161              
162             sub _column_style {
163            
164 1     1   12 my ($t, $row, $col2ix, $ix) = @_;
165              
166 1 50       9 return unless my $style = _get_hashref( $row, $ix );
167              
168 0         0 for my $column ( grep { exists $col2ix->{$_} } keys %$style ) {
  0         0  
169 0         0 $t->set_column_style( $column, %{ $style->{ $column } } );
  0         0  
170             }
171              
172             }
173              
174             sub _row_style {
175            
176 10     10   21 my ($t, $nth_row, $row, $col2ix, $ix) = @_;
177              
178 10 50       21 return unless my $style = _get_hashref( $row, $ix );
179              
180 10         39 $t->set_row_style( $nth_row, %$style );
181              
182             }
183              
184             sub _cell_styles {
185            
186 10     10   25 my ($t, $nth_row, $row, $col2ix, $ix) = @_;
187              
188 10 50       15 return unless my $style = _get_hashref( $row, $ix );
189              
190 10         22 for my $column ( grep { exists $col2ix->{$_} } keys %$style ) {
  10         33  
191              
192 10         16 my %cell_style = %{ $style->{ $column } };
  10         34  
193              
194             # override cell contents if pseudo-style `text` is specified
195 10 50       27 if ( exists $cell_style{value} ) {
196 10         40 $t->set_cell( $nth_row, $column, $cell_style{value} );
197 10         199 delete $cell_style{value};
198             }
199              
200             $t->set_cell_style(
201 10         26 $nth_row,
202             $column,
203             %cell_style
204             );
205              
206             }
207              
208             }
209              
210             1;
211              
212             __END__