File Coverage

blib/lib/Perl6/Pod/Block/table.pm
Criterion Covered Total %
statement 24 128 18.7
branch 0 16 0.0
condition n/a
subroutine 8 17 47.0
pod 1 6 16.6
total 33 167 19.7


line stmt bran cond sub pod time code
1             package Perl6::Pod::Block::table;
2              
3             =pod
4              
5             =head1 NAME
6              
7             Perl6::Pod::Block::table - Simple tables
8              
9             =head1 SYNOPSIS
10              
11             =table
12             The Shoveller Eddie Stevens King Arthur's singing shovel
13             Blue Raja Geoffrey Smith Master of cutlery
14             Mr Furious Roy Orson Ticking time bomb of fury
15             The Bowler Carol Pinnsler Haunted bowling ball
16              
17              
18             =for table :caption('Tales in verse')
19             Year | Name
20             ======+==========================================
21             1830 | The Tale of the Priest and of His Workman Balda
22             1830 | The Tale of the Female Bear
23             1831 | The Tale of Tsar Saltan
24             1833 | The Tale of the Fisherman and the Fish
25             1833 | The Tale of the Dead Princess
26             1834 | The Tale of the Golden Cockerel
27              
28             =head1 DESCRIPTION
29              
30             Simple tables can be specified in Perldoc using a =table block. The table may be given an associated description or title using the :caption option.
31              
32             Each individual table cell is separately formatted, as if it were a nested =para.
33              
34             Columns are separated by whitespace (by regex {2,}), vertical lines (|), or border intersections (+). Rows can be specified in one of two ways: either one row per line, with no separators; or multiple lines per row with explicit horizontal separators (whitespace, intersections (+), or horizontal lines: -, =, _) between every row. Either style can also have an explicitly separated header row at the top.
35              
36             Each individual table cell is separately formatted, as if it were a nested =para.
37              
38             This means you can create tables compactly, line-by-line:
39              
40             =table
41             The Shoveller Eddie Stevens King Arthur's singing shovel
42             Blue Raja Geoffrey Smith Master of cutlery
43             Mr Furious Roy Orson Ticking time bomb of fury
44             The Bowler Carol Pinnsler Haunted bowling ball
45              
46              
47             or line-by-line with multi-line headers:
48              
49             =table
50             Superhero | Secret |
51             | Identity | Superpower
52             ==============|=================+================================
53             The Shoveller | Eddie Stevens | King Arthur's singing shovel
54             Blue Raja | Geoffrey Smith | Master of cutlery
55             Mr Furious | Roy Orson | Ticking time bomb of fury
56             The Bowler | Carol Pinnsler | Haunted bowling ball
57             =cut
58              
59 3     3   14 use warnings;
  3         6  
  3         85  
60 3     3   15 use strict;
  3         5  
  3         57  
61 3     3   14 use Data::Dumper;
  3         6  
  3         118  
62 3     3   14 use Perl6::Pod::Utl;
  3         6  
  3         55  
63 3     3   20 use Perl6::Pod::Block;
  3         6  
  3         81  
64 3     3   13 use base 'Perl6::Pod::Block';
  3         5  
  3         593  
65             our $VERSION = '0.01';
66              
67             use constant {
68 3         682 NEW_LINE => qr/^ \s* $/xms,
69             COLUMNS_SEPARATE => qr/\s*\|\s*|[\ ]{2,}/xms,
70             COLUMNS_FORMAT_ROW => qr/(\s+)?[\=\-]+[\=\-\+\n]+(\s+)?/xms,
71             COLUMNS_FORMAT_ROW_SEPARATE => qr/\s*\|\s*|\+|[\ ]{2,}/xms,
72 3     3   18 };
  3         5  
73              
74             sub new {
75 0     0 0   my $class = shift;
76 0           my $self = $class->SUPER::new(@_);
77 0           my $content = $self->{content}->[0];
78 0           my $count = $self->_get_count_cols($content);
79 0           $self->{tree} = &parse_table($content, $count);
80 0           $self->{col_count} = $count;
81 0           $self
82              
83             }
84              
85             sub parse_table {
86 0     0 0   my $text = shift;
87 0           my $count_cols = shift;
88 0           my $DEFER_REGEX_COMPILATION = "";
89 0           my $qr = do {
90 3     3   15 use Regexp::Grammars;
  3         6  
  3         19  
  0            
91             qr{
92             \A \Z
93              
94             ( [^\n]*? )
95            
96             ^ \s* <[content=col_content]>+ % \s*
97            
98 0           $count_cols == scalar(@{ $MATCH{content} })
  0            
99             })>
100             ( \s+[\|\+]\s+ | \ {2,} | \t+ )
101             (
102             \s* \n* <[header_row_delims=([=-_]+)]>+ % (\+|\s+|\|) \s* \n
103             |
104             )
105            
106             <[row]>+ % <[row_delims]>
107             $DEFER_REGEX_COMPILATION
108             }xms
109 0           };
110 0 0         if ($text =~ $qr ) {
111             return $/{Table}
112 0           } else {
113 0           die "can't parse"
114             }
115             }
116              
117             =head2 is_header_row
118              
119             Flag id header row exists
120              
121             =cut
122              
123             sub is_header_row {
124 0     0 1   my $self = shift;
125             exists $self->{tree}->{row_delims}->[0]->{header_row_delims}
126 0           }
127              
128             sub get_rows {
129 0     0 0   my $self = shift;
130 0           my $rows = $self->{tree}->{row};
131             }
132              
133              
134             sub _get_count_cols {
135 0     0     my $self = shift;
136 0           my $txt = shift;
137 0           my $row_count = 1;
138              
139             # calculate count of fields
140 0           foreach my $line ( split /\n/, $txt ) {
141              
142             # clean begin and end of line
143 0           $line =~ s/^\s*//;
144 0           $line =~ s/\s*$//;
145 0           my @columns = split( /${\( COLUMNS_SEPARATE )}/, $line );
  0            
146              
147             #try find format line
148             # ---------|-----------, =====+=======
149 0 0         if ( $line =~ /${\( COLUMNS_FORMAT_ROW )}/ ) {
  0            
150 0           @columns = split( /${\( COLUMNS_FORMAT_ROW_SEPARATE )}/, $line );
  0            
151 0           $row_count = scalar(@columns);
152 0           $self->{NEED_NEAD}++;
153 0           last;
154             }
155              
156             #update max row_column
157             $row_count =
158 0 0         scalar(@columns) > $row_count ? scalar(@columns) : $row_count;
159             }
160 0           return $row_count;
161             }
162              
163             sub _make_row {
164 0     0     my $self = shift;
165 0           my $rows = shift;
166 0 0         for (@$rows) { $_ = join " ", @{ $_ || [] } }
  0            
  0            
167 0           return { data => [@$rows], type => 'row' };
168              
169             }
170              
171             sub _make_head_row {
172 0     0     my $self = shift;
173 0           my $res = $self->_make_row(@_);
174 0           $res->{type} = 'head';
175 0           delete $self->{NEED_NEAD};
176 0           return $res;
177             }
178              
179             sub to_xhtml {
180 0     0 0   my ( $self, $to ) = @_;
181 0           my $w = $to->w;
182 0           $w->raw(''); ') '); '); '); '); ');
183 0 0         if ( my $caption = $self->get_attr->{caption}) {
184 0           $w->raw('
')->print($caption)->raw('
185             }
186 0           my @rows = @{ $self->get_rows };
  0            
187 0 0         if ( $self->is_header_row) {
188 0           my $header = shift @rows;
189 0           $w->raw('
190 0           foreach my $h (@{ $header->{content} }) {
  0            
191 0           $w->raw('');
192 0           $to->visit(Perl6::Pod::Utl::parse_para($h));
193 0           $w->raw('');
194             }
195 0           $w->raw('
196             }
197             #render content
198 0           foreach my $r ( @rows ) {
199 0           $w->raw('
200 0           foreach my $cnt ( @{$r->{content}} ) {
  0            
201 0           $w->raw('');
202 0           $to->visit(Perl6::Pod::Utl::parse_para($cnt));
203 0           $w->raw('
204             }
205 0           $w->raw('
206             }
207 0           $w->raw('
');
208             }
209              
210             sub to_docbook {
211 0     0 0   my ( $self, $to ) = @_;
212 0           my $w = $to->w;
213 0           $w->raw(''); '); '); '); ');
214 0 0         if ( my $caption = $self->get_attr->{caption}) {
215 0           $w->raw('')->print($caption)->raw('')
216             }
217 0           $w->raw(qq!');
218 0           my @rows = @{ $self->get_rows };
  0            
219 0 0         if ( $self->is_header_row) {
220 0           my $header = shift @rows;
221 0           $w->raw('
222 0           foreach my $h (@{ $header->{content} }) {
  0            
223 0           $w->raw('');
224 0           $to->visit(Perl6::Pod::Utl::parse_para($h));
225 0           $w->raw('');
226             }
227 0           $w->raw('
228             }
229             #render content
230 0           $w->raw('
231 0           foreach my $r ( @rows ) {
232 0           $w->raw('');
233 0           foreach my $cnt ( @{$r->{content}} ) {
  0            
234 0           $w->raw('');
235 0           $to->visit(Perl6::Pod::Utl::parse_para($cnt));
236 0           $w->raw('');
237             }
238 0           $w->raw('');
239             }
240 0           $w->raw('
241 0           $w->raw('');
242 0           $w->raw('
');
243              
244             }
245              
246             1;
247             __END__