File Coverage

blib/lib/Querylet.pm
Criterion Covered Total %
statement 49 53 92.4
branch 2 2 100.0
condition 2 2 100.0
subroutine 22 24 91.6
pod 21 21 100.0
total 96 102 94.1


line stmt bran cond sub pod time code
1 15     15   448997 use strict;
  15         65  
  15         557  
2 15     15   79 use warnings;
  15         27  
  15         780  
3             package Querylet;
4             {
5             $Querylet::VERSION = '0.401';
6             }
7 15     15   15766 use Filter::Simple;
  15         509295  
  15         152  
8             # ABSTRACT: simplified queries for the non-programmer
9              
10              
11              
12              
13             sub init { <<'END_CODE'
14             use strict;
15             use warnings;
16             use Querylet::Query;
17             my $q ||= new Querylet::Query;
18             END_CODE
19 15     15 1 53 }
20              
21              
22 14     14 1 27 sub set_dbh { shift; <<"END_CODE"
23             use DBI;
24             my \$dbh = DBI->connect(q|$_[0]|);
25             \$q->set_dbh(\$dbh);
26             END_CODE
27 14         108 }
28              
29              
30 14     14 1 27 sub set_query { shift; "\$q->set_query(q{$_[0]});\n"; }
  14         98  
31              
32              
33 6     6 1 11 sub bind_next_param { shift; <<"END_CODE"
34             {
35             my \$input = \$q->{input};
36             \$q->bind_more($_[0]);
37             }
38             END_CODE
39 6         35 }
40              
41              
42 3     3 1 4 sub set_query_vars { shift; <<"END_CODE"
43             {
44             my \$input = \$q->{input};
45             \$q->set_query_vars({$_[0]});
46             }
47             END_CODE
48 3         16 }
49              
50              
51 3     3 1 5 sub set_option { shift;
52 3         11 my ($option, $value) = @_;
53 3         17 $value =~ s/(^\s+|\s+$)//g;
54 3         21 "\$q->option(q{$option}, q{$value});\n"
55             }
56              
57              
58 2     2 1 3 sub input { shift; "\$q->input(q{$_[0]});\n"; }
  2         13  
59              
60              
61 2     2 1 4 sub set_input_type { shift; "\$q->input_type(q{$_[0]});\n"; }
  2         9  
62              
63              
64 5     5 1 7 sub set_output_filename { shift; "\$q->output_filename(q{$_[0]});\n"; }
  5         32  
65              
66              
67 0     0 1 0 sub set_output_method { shift; "\$q->write_type(q{$_[0]});\n"; }
  0         0  
68              
69              
70 7     7 1 10 sub set_output_type { shift; "\$q->output_type(q{$_[0]});\n"; }
  7         43  
71              
72              
73 5     5 1 7 sub munge_rows { shift; <<"END_CODE";
  5         40  
74             foreach my \$row (\@{\$q->results}) {
75             $_[0]
76             }
77             END_CODE
78             }
79              
80              
81 1     1 1 2 sub delete_rows { shift; <<"END_CODE";
  1         6  
82             my \@new_results;
83             for my \$row (\@{\$q->results}) {
84             push \@new_results, \$row unless ($_[0]);
85             }
86             \$q->set_results([\@new_results]);
87             END_CODE
88             }
89              
90              
91 1     1 1 3 sub munge_col { shift; <<"END_CODE";
  1         14  
92             foreach my \$row (\@{\$q->results}) {
93             foreach my \$value (\$row->{$_[0]}) {
94             $_[1]
95             }
96             }
97             END_CODE
98             }
99              
100              
101 7     7 1 10 sub add_col { shift; <<"END_CODE";
  7         86  
102             if (exists \$q->results->[0]->{$_[0]}) {
103             warn "column $_[0] already exists; ignoring directive\n";
104             } else {
105             push \@{\$q->columns}, '$_[0]';
106             foreach my \$row (\@{\$q->results}) {
107             for my \$value (\$row->{$_[0]}) {
108             $_[1]
109             }
110             }
111             }
112             END_CODE
113             }
114              
115              
116 9     9 1 11 sub delete_col { shift; <<"END_CODE";
  9         66  
117             \$q->set_columns( [ grep { \$_ ne "$_[0]" } \@{\$q->columns} ] );
118             foreach my \$row (\@{\$q->results}) {
119             delete \$row->{$_[0]};
120             }
121             END_CODE
122             }
123              
124              
125 1     1 1 2 sub delete_cols { my $class = shift; qq|
  1         4  
126             for my \$column (\@{\$q->columns}) {
127             my \@values;
128             push \@values, \$_->{\$column} for \@{\$q->results};
129             if ($_[0]) {
130             | . $class->delete_col('$column') . qq|
131             }
132             }
133             |
134              
135             }
136              
137              
138 0     0 1 0 sub column_headers { my $class = shift; "\$q->set_headers({ $_[0] });" }
  0         0  
139              
140              
141 1     1 1 2 sub munge_values { shift; <<"END_CODE";
  1         7  
142             foreach my \$row (\@{\$q->results}) {
143             foreach my \$value (values \%\$row) {
144             $_[0]
145             }
146             }
147             END_CODE
148             }
149              
150              
151 30     30 1 101 sub output { shift; <<'END_CODE'
152             $q->write_output;
153             END_CODE
154 30         111 }
155              
156              
157             my %ran;
158              
159             sub once {
160 57     57 1 91 my ($id, $text) = @_;
161 57 100       341 return q{} if $ran{$id}++;
162 30   100     388 return $text || '';
163             }
164              
165             my $to_next = qr/(?=^\S|\Z)/sm;
166              
167             FILTER {
168             my ($class) = @_;
169              
170             s/\r//g;
171             s/\A/"\n" . once('init',init)/egms;
172              
173             s/^ database:\s*([^\n]+)
174             / $class->set_dbh($1)
175             /egmsx;
176              
177             s/^ query:\s*(.+?)
178             $to_next
179             / $class->set_query($1)
180             /egmsx;
181              
182             s/^ query\s+parameter:\s*(.+?)
183             $to_next
184             / $class->bind_next_param($1);
185             /egmsx;
186              
187             s/^ munge\s+query:\s*(.+?)
188             $to_next
189             / $class->set_query_vars($1);
190             /egmsx;
191              
192             s/^ set\s+option\s+([\/A-Za-z0-9_]+):\s*(.+?)
193             $to_next
194             / $class->set_option($1,$2);
195             /egmsx;
196              
197             s/^ input:\s*([^\n]+)
198             / $class->input($1)
199             /egmsx;
200              
201             s/^ input\s+type:\s+(\w+)$
202             / $class->set_input_type($1);
203             /egmsx;
204              
205             s/^ munge\s+rows:\s*(.+?)
206             $to_next
207             / $class->munge_rows($1);
208             /egmsx;
209              
210             s/^ delete\s+rows\s+where:\s*(.+?)
211             $to_next
212             / $class->delete_rows($1);
213             /egmsx;
214              
215             s/^ munge\s+all\s+values:\s*(.+?)
216             $to_next
217             / $class->munge_values($1);
218             /egmsx;
219              
220             s/^ munge\s+column\s+(\w+):\s*(.+?)
221             $to_next
222             / $class->munge_col($1, $2);
223             /egmsx;
224              
225             s/^ add\s+column\s+(\w+):\s*(.+?)
226             $to_next
227             / $class->add_col($1, $2);
228             /egmsx;
229              
230             s/^ delete\s+column\s+(\w+)$
231             / $class->delete_col($1);
232             /egmsx;
233              
234             s/^ delete\s+columns\s+where:\s*(.+?)
235             $to_next
236             / $class->delete_cols($1);
237             /egmsx;
238              
239             s/^ column\s+headers?:\s*(.+?)
240             $to_next
241             / $class->column_headers($1);
242             /egmsx;
243              
244             s/^ output\s+format:\s+(\w+)$
245             / $class->set_output_type($1);
246             /egmsx;
247              
248             s/^ output\s+method:\s+(\w+)$
249             / $class->set_output_method($1);
250             /egmsx;
251              
252             s/^ output\s+file:\s+([_.A-Za-z0-9]+)$
253             / $class->set_output_filename($1);
254             /egmsx;
255              
256             s/^ no\s+output$
257             / once('output', q{})
258             /egmsx;
259              
260             s/\Z
261             /once('output',output)
262             /egmsx;
263             }
264              
265              
266             "I do endeavor to give satisfaction, sir.";
267              
268             __END__