File Coverage

lib/Docbook/Table.pm
Criterion Covered Total %
statement 89 121 73.5
branch 6 16 37.5
condition 3 7 42.8
subroutine 16 22 72.7
pod 3 11 27.2
total 117 177 66.1


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2              
3              
4             package Docbook::Table;
5              
6             require v5.6.0;
7 1     1   4 use strict;
  1         1  
  1         28  
8 1     1   3 use warnings;
  1         1  
  1         22  
9 1     1   5 use Carp;
  1         5  
  1         596  
10              
11             our $VERSION = '1.00';
12              
13             =head1 NAME
14              
15             Docbook::Table -- create Docbook tables from Perl data structures
16              
17             =head1 SYNOPSIS
18              
19             use Docbook::Table;
20             my $t = Docbook::Table->new();
21             $t->title("Pet names");
22             $t->headings("Pet type", "Pet name");
23              
24             my %pets = (
25             dog => "Rover",
26             cat => "Garfield",
27             bird => "Tweetie"
28             );
29              
30             $t->body(\%pets);
31             $t->generate;
32              
33             $t->sort(\&backwards);
34              
35             =head1 DESCRIPTION
36              
37             This module generates Docbook SGML/XML tables from Perl data structures.
38             Its main purpose is to simplify automatic document generation.
39              
40             =head2 Starting your table
41              
42             use Docbook::Table;
43             my $t = Docbook::Table->new();
44              
45             =begin testing
46              
47             BEGIN {
48 1         32 use lib "./lib";
49 1     1   21898 use_ok('Docbook::Table');
  1         943  
  1         6  
50 1     1   4 use vars qw($t);
  1     1   169  
  1         2  
  1         1  
  1         13  
51 1     1   120 }
  1         2  
  1         49  
52             $t = Docbook::Table->new();
53 1         8 isa_ok($t, 'Docbook::Table');
54 1         8  
55             =end testing
56              
57             =cut
58              
59             sub new {
60 1     1 0 2 my $self = {};
61 1         7 $self->{calling_package} = (caller)[0];
62 1         2 bless $self;
63 1         4 return $self;
64             }
65              
66             =head2 Specifying the title
67              
68             Docbook tables must have a title. You can set the title by passing a
69             string to the title() method.
70              
71             $t->title("This is the title");
72              
73             =for testing
74 1         439 $t->title("foo");
  1         5  
75 1         14 is($t->{title}, "foo", "Setting title");
76              
77             =cut
78              
79             sub title {
80 1     1 1 3 my ($self, $title) = @_;
81 1         7 $self->{title} = $title;
82             }
83              
84             =head2 Specifying the headings
85              
86             Simply pass a list of headings to the headings() method.
87              
88             $t->headings(@headings);
89              
90             Note that the number of columns (a required attribute of the C
91             element) is generated by counting the number of elements in the list
92             passed to headings().
93              
94             =for testing
95 1         304 is($t->headings(), undef, "Set headings fails for empty list");
  1         5  
96 1         228 $t->headings(qw(foo bar baz));
97 1         4 is(ref($t->{headings}), "ARRAY", "Setting headings");
98 1         243 is($t->{headings}[0], "foo", "Setting headings");
99              
100             =cut
101              
102             sub headings {
103 2     2 1 4 my ($self, @headings) = @_;
104 2 100       13 unless (@headings) {
105 1         203 carp "No headings specified";
106 1         68 return undef;
107             }
108 1         3 $self->{headings} = \@headings;
109             }
110              
111             =head2 Specifying the body
112              
113             Accepted data types for the body of the table are:
114              
115             =over 4
116              
117             =item Simple hash
118              
119             Used to generate a simple 2-column table.
120              
121             =item List of lists
122              
123             Used to generate multi-column tables.
124              
125             =item Hash of lists
126              
127             Used to generate multi-column tables.
128              
129             =item Hash of hashes and other structures
130              
131             Not supported (yet).
132              
133             =back
134              
135             All data structures for the body should be passed by reference to the
136             body() method.
137              
138             $t->body(\%hash);
139             $t->body(\@list);
140              
141             If you pass it the wrong sort of thing, it will emit a warning and
142             return undef.
143              
144             =for testing
145 1         255 is($t->body("foo"), undef, "body fails on non hash/arrayref");
  1         3  
146 1         217 $t->body({ a => "apple", b => "banana" });
147 1         4 is(ref($t->{body}), "HASH", "body sets hashref");
148 1         239 $t->body([ [1,2,3], [4,5,6], [7,8,9] ]);
149 1         5 is(ref($t->{body}), "ARRAY", "body sets arrayref");
150              
151             =cut
152              
153             sub body {
154 3     3 1 4 my ($self, $bodyref) = @_;
155 3 100 100     16 unless (ref $bodyref eq 'HASH' or ref $bodyref eq 'ARRAY') {
156 1         84 carp "Body must be an arrayref or hashref";
157 1         45 return undef;
158             }
159 2         3 $self->{body} = $bodyref;
160             }
161              
162             =head2 Sorting
163              
164             By default, hashes are sorted asciibetically by key, and lists are left
165             in their original order. If you wish to specify a different sort order,
166             pass a subroutine reference to the sort() method.
167              
168             $t->sort(\&backwards);
169             $t->sort( sub { $b cmp $a } );
170              
171             If you pass it anything other than a subroutine reference, it will emit
172             a warning and return undef.
173              
174             =for testing
175 1         235 is($t->sort("foo"), undef, "sort fails on non-subref");
  1         4  
176 1     0   230 {
  0         0  
177 1         4 no warnings 'once';
178             $t->sort( sub { $b cmp $a } );
179             is(ref($t->{sortsub}), "CODE", "sort sets a subroutine ref");
180             }
181              
182             =cut
183              
184              
185             sub sort {
186 2     2 0 3 my ($self, $sortsub) = @_;
187 2 100       6 unless (ref $sortsub eq 'CODE') {
188 1         80 carp "Sort must be a subroutine reference";
189 1         47 return undef;
190             }
191 1         3 $self->{sortsub} = $sortsub;
192             }
193              
194             =head2 Generating the table
195              
196             The generate() method actually generates the table for you and returns
197             it as a string. It will emit warnings and return undef if you haven't
198             specified a title, headings and a body.
199              
200             =cut
201              
202             sub generate {
203 0     0 0 0 my ($self) = @_;
204              
205 0         0 foreach (qw(title headings body)) {
206 0 0       0 unless ($self->{$_}) {
207 0         0 warn "No $_ specified\n";
208 0         0 return undef;
209             }
210             }
211              
212 0         0 return $self->table_opening()
213             . $self->table_head()
214             . $self->table_body()
215             . $self->table_close;
216 1         344 }
  1         5  
217              
218             =for testing
219             like($t->table_opening(), qr//, "Open table");
220              
221             =cut
222              
223             sub table_opening {
224 1     1 0 2 my $self = shift;
225 1         2 my $cols = @{$self->{headings}};
  1         546  
226              
227 1         14 return qq(/, "table heading"); \n); \n); \n"; \n";
228             $self->{title}
229            
230             );
231              
232 1         254 }
  1         5  
233 1         353  
234             =for testing
235             like($t->table_head(), qr/
236             like($t->table_head(), qr/baz/, "table heading");
237              
238             =cut
239              
240             sub table_head {
241 2     2 0 4 my $self = shift;
242 2         3 my @headings = @{$self->{headings}};
  2         7  
243              
244 2         3 my $out = qq(
245 2         6 $out .= $self->row(@headings);
246 2         16 $out .= qq(
247             }
248              
249             sub table_body {
250 0     0 0 0 my $self = shift;
251 0         0 my $bodyref = $self->{body};
252              
253 0         0 my $out = "
254              
255              
256             # note to self and others:
257             # this is a little funky. If we don't alias $a and $b across
258             # from the calling package, we can't sort properly. A side
259             # effect of this is that we'll also end up with the calling
260             # package's @a, %a and &a (and b, too) so D::T has to be
261             # careful not to use them.
262             {
263 1     1   6 no strict 'refs';
  1         31  
  1         364  
  0         0  
264 0         0 *Docbook::Table::a = *{$self->{calling_package} . "::a"};
  0         0  
265 0         0 *Docbook::Table::b = *{$self->{calling_package} . "::b"};
  0         0  
266             }
267              
268 0 0       0 if (ref $bodyref eq 'HASH') {
    0          
269 0   0 0   0 my $sort = $self->{sortsub} || sub { $a cmp $b };
  0         0  
270 0         0 foreach my $key (sort $sort keys %$bodyref) {
271 0 0       0 if (ref $bodyref->{$key} eq 'ARRAY') {
    0          
272 0         0 $out .= $self->row($key, @{$bodyref->{key}});
  0         0  
273             } elsif (ref $bodyref->{$key}) {
274 0         0 carp "Unsupported data structure. Looks like you've got something other than scalars or arrayrefs in the values of the hash you're using for the body.";
275 0         0 return undef;
276             } else {
277 0         0 $out .= $self->row($key, $bodyref->{key});
278             }
279             }
280             } elsif (ref $bodyref eq 'ARRAY') {
281 0   0 0   0 my $sort = $self->{sortsub} || sub { 1 };
  0         0  
282             # sub { 1 } just leaves the list alone
283 0         0 foreach my $row (sort $sort @$bodyref) {
284 0         0 $out .= $self->row(@$row);
285             }
286             }
287              
288 0         0 $out .= "/
289              
290 0         0 return $out;
291              
292             }
293              
294 1         319 =begin testing
  1         3  
295 1         4  
296             my $expected = "\t\n\t\tfoo\n\t\n";
297             is($t->row("foo"), $expected, "generate a row");
298              
299             =end testing
300              
301             =cut
302              
303             sub row {
304 3     3 0 4 shift;
305 3         6 my @entries = @_;
306 3         4 my $row = "\t\n";
307 3         24 $row .= "\t\t$_\n" foreach @entries;
308 3         7 $row .= "\t\n";
309 3         12 return $row;
310             }
311              
312             sub table_close {
313 0     0 0   return qq(
\n);
314             }
315              
316             return "FALSE"; # true value ;)
317              
318             =head1 AUTHOR
319              
320             Kirrily Robert
321              
322             =head1 COPYING
323              
324             Docbook::Table (c) 2001 Kirrily Robert
325             This software is distributed under the same licenses as Perl itself.
326              
327             =head1 SEE ALSO
328              
329             L
330              
331             =cut