Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # -*- perl -*- |
2 | # | |
3 | # DBI::Format - a package for displaying result tables | |
4 | # | |
5 | # Copyright (c) 1998 Jochen Wiedmann | |
6 | # Copyright (c) 1998 Tim Bunce | |
7 | # | |
8 | # The DBI::Shell:Result module is free software; you can redistribute | |
9 | # it and/or modify it under the same terms as Perl itself. | |
10 | # | |
11 | # Author: Jochen Wiedmann | |
12 | # Am Eisteich 9 | |
13 | # 72555 Metzingen | |
14 | # Germany | |
15 | # | |
16 | # Email: joe@ispsoft.de | |
17 | # Phone: +49 7123 14881 | |
18 | # | |
19 | ||
20 | use strict; | |
21 | ||
22 | package DBI::Format; | |
23 | ||
24 | use Text::Abbrev; | |
25 | ||
26 | $DBI::Format::VERSION = $DBI::Format::VERSION = substr(q$Revision: 1.3 $, 10)+0; | |
27 | ||
28 | ||
29 | sub available_formatters { | |
30 | my ($use_abbrev) = @_; | |
31 | my @fmt; | |
32 | my @dir = grep { -d "$_/DBI/Format" } @INC; | |
33 | foreach my $dir (@dir) { | |
34 | opendir DIR, "$dir/DBI/Format" or warn "Unable to read $dir/DBI: $!\n"; | |
35 | push @fmt, map { m/^(\w+)\.pm$/i ? ($1) : () } readdir DIR; | |
36 | closedir DIR; | |
37 | } | |
38 | my %fmt = map { (lc($_) => "DBI::Format::$_") } @fmt; | |
39 | $fmt{box} = "DBI::Format::Box"; | |
40 | $fmt{neat} = "DBI::Format::Neat"; | |
41 | $fmt{raw} = "DBI::Format::Raw"; | |
42 | $fmt{string} = "DBI::Format::String"; | |
43 | my $formatters = \%fmt; | |
44 | if ($use_abbrev) { | |
45 | $formatters = abbrev(keys %fmt); | |
46 | foreach my $abbrev (keys %$formatters) { | |
47 | $formatters->{$abbrev} = $fmt{ $formatters->{$abbrev} } || die; | |
48 | } | |
49 | } | |
50 | return $formatters; | |
51 | } | |
52 | ||
53 | ||
54 | sub formatter { | |
55 | my ($class, $mode, $use_abbrev) = @_; | |
56 | $mode = lc($mode); | |
57 | my $formatters = available_formatters($use_abbrev); | |
58 | my $fmt = $formatters->{$mode}; | |
59 | if (!$fmt) { | |
60 | $formatters = available_formatters(0); | |
61 | die "Format '$mode' unavailable. Available formats: ". | |
62 | join(", ", sort keys %$formatters)."\n"; | |
63 | } | |
64 | no strict 'refs'; | |
65 | unless (%{$class."::"}) { | |
66 | eval "require $fmt"; | |
67 | die "$@\n" if $@; | |
68 | } | |
69 | return $fmt; | |
70 | } | |
71 | ||
72 | ||
73 | package DBI::Format::Base; | |
74 | ||
75 | sub new { | |
76 | my $class = shift; | |
77 | my $self = (@_ == 1) ? { %{shift()} } : { @_ }; | |
78 | bless ($self, (ref($class) || $class)); | |
79 | $self; | |
80 | } | |
81 | ||
82 | sub setup_fh { | |
83 | my ($self, $fh) = @_; | |
84 | return $fh if ref($fh) =~ m/GLOB\(/; | |
85 | $fh ||= \*STDOUT; | |
86 | if ($fh !~ /=/) { # not blessed | |
87 | require FileHandle; | |
88 | bless $fh => "FileHandle"; | |
89 | } | |
90 | return $fh; | |
91 | } | |
92 | ||
93 | ||
94 | sub trailer { | |
95 | my($self) = @_; | |
96 | my $fh = delete $self->{'fh'}; | |
97 | my $sth = delete $self->{'sth'}; | |
98 | my $rows = delete $self->{'rows'}; | |
99 | print $fh ("[$rows rows of $sth->{NUM_OF_FIELDS} fields returned]\n"); | |
100 | delete $self->{'sep'}; | |
101 | } | |
102 | ||
103 | ||
104 | package DBI::Format::Neat; | |
105 | ||
106 | @DBI::Format::Neat::ISA = qw(DBI::Format::Base); | |
107 | ||
108 | sub header { | |
109 | my($self, $sth, $fh, $sep) = @_; | |
110 | $self->{'fh'} = $self->setup_fh($fh); | |
111 | $self->{'sth'} = $sth; | |
112 | $self->{'rows'} = 0; | |
113 | $self->{sep} = $sep if defined $sep; | |
114 | print $fh (join($self->{sep}, @{$sth->{'NAME'}}), "\n"); | |
115 | } | |
116 | ||
117 | sub row { | |
118 | my($self, $rowref) = @_; | |
119 | my @row = @$rowref; | |
120 | # XXX note that neat/neat_list output is *not* ``safe'' | |
121 | # in the sense the it does not escape any chars and | |
122 | # may truncate the string and may translate non-printable chars. | |
123 | # We only deal with simple escaping here. | |
124 | foreach(@row) { | |
125 | next unless defined; | |
126 | s/'/\\'/g; | |
127 | s/\n/ /g; | |
128 | } | |
129 | my $fh = $self->{'fh'}; | |
130 | print $fh (DBI::neat_list(\@row, 9999, $self->{sep}),"\n"); | |
131 | ++$self->{'rows'}; | |
132 | } | |
133 | ||
134 | ||
135 | ||
136 | package DBI::Format::Box; | |
137 | ||
138 | @DBI::Format::Box::ISA = qw(DBI::Format::Base); | |
139 | ||
140 | sub header { | |
141 | my($self, $sth, $fh, $sep) = @_; | |
142 | $self->{'fh'} = $self->setup_fh($fh); | |
143 | $self->{'sth'} = $sth; | |
144 | $self->{'data'} = []; | |
145 | $self->{sep} = $sep if defined $sep; | |
146 | my $types = $sth->{'TYPE'}; | |
147 | my @right_justify; | |
148 | my @widths; | |
149 | my $names = $sth->{'NAME'}; | |
150 | my $type; | |
151 | for (my $i = 0; $i < $sth->{'NUM_OF_FIELDS'}; $i++) { | |
152 | push(@widths, defined($names->[$i]) ? length($names->[$i]) : 0); | |
153 | $type = $types->[$i]; | |
154 | push(@right_justify, | |
155 | ($type == DBI::SQL_NUMERIC() || | |
156 | $type == DBI::SQL_DECIMAL() || | |
157 | $type == DBI::SQL_INTEGER() || | |
158 | $type == DBI::SQL_SMALLINT() || | |
159 | $type == DBI::SQL_FLOAT() || | |
160 | $type == DBI::SQL_REAL() || | |
161 | $type == DBI::SQL_BIGINT() || | |
162 | $type == DBI::SQL_TINYINT())); | |
163 | } | |
164 | $self->{'widths'} = \@widths; | |
165 | $self->{'right_justify'} = \@right_justify; | |
166 | } | |
167 | ||
168 | ||
169 | sub row { | |
170 | my($self, $orig_row) = @_; | |
171 | my $i = 0; | |
172 | my $col; | |
173 | my $widths = $self->{'widths'}; | |
174 | my @row = @$orig_row; # don't mess with the original row | |
175 | map { | |
176 | if (!defined($_)) { | |
177 | $_ = ' (NULL) '; | |
178 | } else { | |
179 | $_ =~ s/\n/\\n/g; | |
180 | $_ =~ s/\t/\\t/g; | |
181 | $_ =~ s/[\000-\037\177-\237]/./g; | |
182 | } | |
183 | if (length($_) > $widths->[$i]) { | |
184 | $widths->[$i] = length($_); | |
185 | } | |
186 | ++$i; | |
187 | } @row; | |
188 | push @{$self->{data}}, \@row; | |
189 | } | |
190 | ||
191 | ||
192 | sub trailer { | |
193 | my $self = shift; | |
194 | my $widths = delete $self->{'widths'}; | |
195 | my $right_justify = delete $self->{'right_justify'}; | |
196 | my $sth = $self->{'sth'}; | |
197 | my $data = $self->{'data'}; | |
198 | $self->{'rows'} = @$data; | |
199 | ||
200 | my $format_sep = '+'; | |
201 | my $format_names = '|'; | |
202 | my $format_rows = '|'; | |
203 | for (my $i = 0; $i < $sth->{'NUM_OF_FIELDS'}; $i++) { | |
204 | $format_sep .= ('-' x $widths->[$i]) . '+'; | |
205 | $format_names .= sprintf("%%-%ds|", $widths->[$i]); | |
206 | $format_rows .= sprintf("%%" | |
207 | . ($right_justify->[$i] ? "" : "-") . "%ds|", | |
208 | $widths->[$i]); | |
209 | } | |
210 | $format_sep .= "\n"; | |
211 | $format_names .= "\n"; | |
212 | $format_rows .= "\n"; | |
213 | ||
214 | my $fh = $self->{'fh'}; | |
215 | print $fh ($format_sep); | |
216 | print $fh (sprintf($format_names, @{$sth->{'NAME'}})); | |
217 | foreach my $row (@$data) { | |
218 | print $fh ($format_sep); | |
219 | print $fh (sprintf($format_rows, @$row)); | |
220 | } | |
221 | print $fh ($format_sep); | |
222 | ||
223 | $self->SUPER::trailer(@_); | |
224 | } | |
225 | ||
226 | package DBI::Format::Raw; | |
227 | ||
228 | @DBI::Format::Raw::ISA = qw(DBI::Format::Base); | |
229 | ||
230 | sub header { | |
231 | my($self, $sth, $fh, $sep) = @_; | |
232 | $self->{'fh'} = $self->setup_fh($fh); | |
233 | $self->{'sth'} = $sth; | |
234 | $self->{'rows'} = 0; | |
235 | $self->{sep} = $sep if defined $sep; | |
236 | print $fh (join($self->{sep}, @{$sth->{'NAME'}}), "\n"); | |
237 | } | |
238 | ||
239 | sub row { | |
240 | my($self, $rowref) = @_; | |
241 | local( $^W = 0 ); | |
242 | my @row = @$rowref; | |
243 | my $fh = $self->{'fh'}; | |
244 | print $fh (join($self->{sep}, @row), "\n"); | |
245 | ++$self->{'rows'}; | |
246 | } | |
247 | ||
248 | package DBI::Format::String; | |
249 | ||
250 | @DBI::Format::String::ISA = qw(DBI::Format::Base); | |
251 | ||
252 | sub header { | |
253 | my($self, $sth, $fh, $sep) = @_; | |
254 | $self->{'fh'} = $self->setup_fh($fh); | |
255 | $self->{'sth'} = $sth; | |
256 | $self->{'data'} = []; | |
257 | $self->{sep} = $sep if defined $sep; | |
258 | my $types = $sth->{'TYPE'}; | |
259 | my @right_justify; | |
260 | my @widths; | |
261 | my $names = $sth->{'NAME'}; | |
262 | my $type; | |
263 | for (my $i = 0; $i < $sth->{'NUM_OF_FIELDS'}; $i++) { | |
264 | $type = $types->[$i]; | |
265 | push(@widths, | |
266 | ($type == DBI::SQL_DATE)? 8 : | |
267 | ($type == DBI::SQL_INTEGER and $sth->{PRECISION}->[$i] > 15 )? 10 : | |
268 | ($type == DBI::SQL_NUMERIC and $sth->{PRECISION}->[$i] > 15 )? 10 : | |
269 | defined($sth->{PRECISION}->[$i]) ? | |
270 | $sth->{PRECISION}->[$i]: 0); | |
271 | push(@right_justify, | |
272 | ($type == DBI::SQL_NUMERIC() || | |
273 | $type == DBI::SQL_DECIMAL() || | |
274 | $type == DBI::SQL_INTEGER() || | |
275 | $type == DBI::SQL_SMALLINT() || | |
276 | $type == DBI::SQL_FLOAT() || | |
277 | $type == DBI::SQL_REAL() || | |
278 | $type == DBI::SQL_BIGINT() || | |
279 | $type == DBI::SQL_TINYINT())); | |
280 | my $format_names; | |
281 | $format_names .= sprintf("%%-%ds ", $widths[$i]); | |
282 | print $fh (sprintf($format_names, $names->[$i])); | |
283 | } | |
284 | $self->{'widths'} = \@widths; | |
285 | $self->{'right_justify'} = \@right_justify; | |
286 | print $fh "\n"; | |
287 | ||
288 | } | |
289 | ||
290 | ||
291 | sub row { | |
292 | my($self, $orig_row) = @_; | |
293 | my $i = 0; | |
294 | my $col; | |
295 | my $widths = $self->{'widths'}; | |
296 | my $right_justify = $self->{'right_justify'}; | |
297 | my @row = @$orig_row; # don't mess with the original row | |
298 | map { | |
299 | if (!defined($_)) { | |
300 | $_ = ' (NULL) '; | |
301 | } else { | |
302 | $_ =~ s/\n/\\n/g; | |
303 | $_ =~ s/\t/\\t/g; | |
304 | $_ =~ s/[\000-\037\177-\237]/./g; | |
305 | } | |
306 | ++$i; | |
307 | } @row; | |
308 | ||
309 | my $sth = $self->{'sth'}; | |
310 | my $data = $self->{'data'}; | |
311 | my $format_rows = ' '; | |
312 | for (my $i = 0; $i < $sth->{'NUM_OF_FIELDS'}; $i++) { | |
313 | $format_rows .= sprintf("%%" | |
314 | . ($right_justify->[$i] ? "" : "-") . "%ds ", | |
315 | $widths->[$i]); | |
316 | } | |
317 | $format_rows .= "\n"; | |
318 | ||
319 | my $fh = $self->{'fh'}; | |
320 | print $fh (sprintf($format_rows, @row)); | |
321 | ++$self->{'rows'}; | |
322 | } | |
323 | ||
324 | ||
325 | sub trailer { | |
326 | my $self = shift; | |
327 | my $widths = delete $self->{'widths'}; | |
328 | my $right_justify = delete $self->{'right_justify'}; | |
329 | $self->SUPER::trailer(@_); | |
330 | } | |
331 | ||
332 | ||
333 | 1; | |
334 | ||
335 | =head1 NAME | |
336 | ||
337 | DBI::Format - A package for displaying result tables | |
338 | ||
339 | =head1 SYNOPSIS | |
340 | ||
341 | # create a new result object | |
342 | $r = DBI::Format->new('var1' => 'val1', ...); | |
343 | ||
344 | # Prepare it for output by creating a header | |
345 | $r->header($sth, $fh); | |
346 | ||
347 | # In a loop, display rows | |
348 | while ($ref = $sth->fetchrow_arrayref()) { | |
349 | $r->row($ref); | |
350 | } | |
351 | ||
352 | # Finally create a trailer | |
353 | $r->trailer(); | |
354 | ||
355 | ||
356 | =head1 DESCRIPTION | |
357 | ||
358 | THIS PACKAGE IS STILL VERY EXPERIMENTAL. THINGS WILL CHANGE. | |
359 | ||
360 | This package is used for making the output of DBI::Shell configurable. | |
361 | The idea is to derive a subclass for any kind of output table you might | |
362 | create. Examples are | |
363 | ||
364 | =over 8 | |
365 | ||
366 | =item * | |
367 | ||
368 | a very simple output format as offered by DBI::neat_list(). | |
369 | L<"AVAILABLE SUBCLASSES">. | |
370 | ||
371 | =item * | |
372 | ||
373 | a box format, as offered by the Data::ShowTable module. | |
374 | ||
375 | =item * | |
376 | ||
377 | HTML format, as used in CGI binaries | |
378 | ||
379 | =item * | |
380 | ||
381 | postscript, to be piped into lpr or something similar | |
382 | ||
383 | =back | |
384 | ||
385 | In the future the package should also support interactive methods, for | |
386 | example tab completion. | |
387 | ||
388 | These are the available methods: | |
389 | ||
390 | =over 8 | |
391 | ||
392 | =item new(@attr) | |
393 | ||
394 | =item new(\%attr) | |
395 | ||
396 | (Class method) This is the constructor. You'd rather call a subclass | |
397 | constructor. The construcor is accepting either a list of key/value | |
398 | pairs or a hash ref. | |
399 | ||
400 | =item header($sth, $fh) | |
401 | ||
402 | (Instance method) This is called when a new result table should be | |
403 | created to display the results of the statement handle B<$sth>. The | |
404 | (optional) argument B<$fh> is an IO handle (or any object supporting | |
405 | a I<print> method), usually you use an IO::Wrap object for STDIN. | |
406 | ||
407 | The method will query the B<$sth> for its I<NAME>, I<NUM_OF_FIELDS>, | |
408 | I<TYPE>, I<SCALE> and I<PRECISION> attributes and typically print a | |
409 | header. In general you should not assume that B<$sth> is indeed a DBI | |
410 | statement handle and better treat it as a hash ref with the above | |
411 | attributes. | |
412 | ||
413 | =item row($ref) | |
414 | ||
415 | (Instance method) Prints the contents of the array ref B<$ref>. Usually | |
416 | you obtain this array ref by calling B<$sth-E<gt>fetchrow_arrayref()>. | |
417 | ||
418 | =item trailer | |
419 | ||
420 | (Instance method) Once you have passed all result rows to the result | |
421 | package, you should call the I<trailer> method. This method can, for | |
422 | example print the number of result rows. | |
423 | ||
424 | =back | |
425 | ||
426 | ||
427 | =head1 AVAILABLE SUBCLASSES | |
428 | ||
429 | First of all, you can use the DBI::Format package itself: It's | |
430 | not an abstract base class, but a very simple default using | |
431 | DBI::neat_list(). | |
432 | ||
433 | ||
434 | =head2 Ascii boxes | |
435 | ||
436 | This subclass is using the I<Box> mode of the I<Data::ShowTable> module | |
437 | internally. L<Data::ShowTable(3)>. | |
438 | ||
439 | =head2 Raw | |
440 | ||
441 | Row is written without formating. Columns returned in comma or user defined | |
442 | separated list. | |
443 | ||
444 | =head2 String | |
445 | ||
446 | Row is written using a string format. Future releases may include the ability | |
447 | set the string format, if someone contributes it. | |
448 | ||
449 | ||
450 | =head1 AUTHOR AND COPYRIGHT | |
451 | ||
452 | This module is Copyright (c) 1997, 1998 | |
453 | ||
454 | Jochen Wiedmann | |
455 | Am Eisteich 9 | |
456 | 72555 Metzingen | |
457 | Germany | |
458 | ||
459 | Email: joe@ispsoft.de | |
460 | Phone: +49 7123 14887 | |
461 | ||
462 | The DBD::Proxy module is free software; you can redistribute it and/or | |
463 | modify it under the same terms as Perl itself. | |
464 | ||
465 | ||
466 | =head1 SEE ALSO | |
467 | ||
468 | L<DBI::Shell(3)>, L<DBI(3)>, L<dbish(1)> | |
469 |