File Coverage

blib/lib/Table/Readable.pm
Criterion Covered Total %
statement 96 97 98.9
branch 40 46 86.9
condition 3 3 100.0
subroutine 7 7 100.0
pod 2 3 66.6
total 148 156 94.8


line stmt bran cond sub pod time code
1             package Table::Readable;
2 4     4   270426 use warnings;
  4         41  
  4         133  
3 4     4   21 use strict;
  4         6  
  4         361  
4             require Exporter;
5             our @ISA = qw(Exporter);
6             our @EXPORT_OK = qw/read_table write_table/;
7             our %EXPORT_TAGS = (all => \@EXPORT_OK);
8             our $VERSION = '0.03';
9 4     4   25 use Carp;
  4         13  
  4         4456  
10              
11             sub read_file
12             {
13 10     10 0 15 my ($file) = @_;
14 10         17 my @rv;
15 10 100   2   352 open my $in, "<:encoding(utf8)", $file or die "Error opening '$file': $!";
  2         14  
  2         4  
  2         9  
16 9         1321 while (<$in>) {
17 91         338 push @rv, $_;
18             }
19 9 50       112 close $in or die $!;
20 9         70 return @rv;
21             }
22              
23             sub read_table
24             {
25 16     16 1 44374 my ($list_file, %options) = @_;
26 16         52 my @table;
27 16         33 my $row = {};
28 16         37 push @table, $row;
29 16         23 my $mode = "single-line";
30 16         32 my $mkey;
31              
32             my @lines;
33 16 100       42 if ($options{scalar}) {
34 6         25 @lines = split /\n/, $list_file;
35 6         14 for (@lines) {
36 12         22 $_ .= "\n";
37             }
38 6         34 $lines[-1] =~ s/\n$//;
39             }
40             else {
41 10         27 @lines = read_file ($list_file);
42             }
43 15         32 my $count = 0;
44 15         34 for (@lines) {
45              
46 102         126 $count++;
47              
48             # Detect the first line of a cell of the table whose
49             # information spans several lines of the input file.
50              
51 102 100       243 if (/^%%\s*([^:]+):\s*$/) {
52 5         11 $mode = "multi-line";
53 5         12 $mkey = $1;
54 5         12 next;
55             }
56              
57             # Continue to process a table cell whose information spans
58             # several lines of the input file.
59              
60 97 100       170 if ($mode eq "multi-line") {
61 38 100       73 if (/^%%\s*$/) {
62 5         12 $mode = "single-line";
63 5 50       15 if ($row->{$mkey}) {
64             # Strip leading and trailing whitespace
65 5         104 $row->{$mkey} =~ s/^\s+|\s+$//g;
66             # Strip leading and trailing slashes
67 5         78 $row->{$mkey} =~ s/^\\|\\$//g;
68             }
69 5         9 $mkey = undef;
70             }
71             else {
72 33         60 $row->{$mkey} .= $_;
73             }
74 38         55 next;
75             }
76 59 100       294 if (/^\s*#.*/) {
    100          
    100          
77              
78             # Skip comments.
79              
80 2         4 next;
81             }
82             elsif (/([^:]+):\s*(.*?)\s*$/) {
83              
84             # Key / value pair on a single line.
85              
86 41         94 my $key = $1;
87 41         66 my $value = $2;
88              
89             # If there are any spaces in the key, substitute them with
90             # underscores.
91              
92 41         82 $key =~ s/\s/_/g;
93 41 100       91 if ($row->{$key}) {
94 1         106 croak "$list_file:$count: duplicate for key $key\n";
95             }
96             # Strip leading and trailing slashes
97 40         99 $value =~ s/^\\|\\$//g;
98 40         101 $row->{$key} = $value;
99             }
100             elsif (/^\s*$/) {
101              
102             # A blank line signifies the end of a row.
103              
104 15 100       47 if (keys %$row > 0) {
105 11         22 $row = {};
106 11         23 push @table, $row;
107             }
108 15         28 next;
109             }
110             else {
111 1         4 my $file_line = "$list_file:$count:";
112 1 50       4 if ($options{scalar}) {
113 1         3 $file_line = "$count:";
114             }
115 1         10 warn "$file_line unmatched line '$_'\n";
116             }
117             }
118             # Deal with the case of whitespace at the end of the file.
119 14         30 my $last_row = $table[-1];
120 14 100       45 if (keys %$last_row == 0) {
121 4         7 pop @table;
122             }
123 14 100       334 croak "read_table returns an array" unless wantarray ();
124 12         70 return @table;
125             }
126              
127             # Maximum length of a single-line entry.
128              
129             our $maxlen = 75;
130              
131             sub write_table
132             {
133 6     6 1 15659 my ($list, $file) = @_;
134 6 100       55 if (ref $list ne 'ARRAY') {
135 1         189 carp "First argument to 'write_table' must be array reference";
136 1         10 return;
137             }
138 5         8 my $n = 0;
139 5         12 for my $i (@$list) {
140 6 100       16 if (ref $i ne 'HASH') {
141 1         119 carp "Elements of first argument to 'write_table' must be hash references";
142 1         31 return;
143             }
144 5         16 for my $k (keys %$i) {
145 11 100       25 if (ref $i->{$k}) {
146 1         91 carp "Non-scalar value in key $k of element $n";
147 1         27 return;
148             }
149             }
150 4         9 $n++;
151             }
152 3         7 my $text = '';
153 3         7 for (@$list) {
154 4         13 for my $k (sort keys %$_) {
155 10         17 my $v = $_->{$k};
156 10 100 100     42 if (length ($v) + length ($k) > $maxlen ||
157             $v =~ /\n/) {
158 2         9 $text .= "%%$k:\n$v\n%%\n";
159             }
160             else {
161 8         21 $text .= "$k: $v\n";
162             }
163             }
164 4         8 $text .= "\n";
165             }
166 3 100       11 if ($file) {
    50          
167 2 50       150 open my $out, ">:encoding(utf8)", $file or croak "Can't open $file for writing: $!";
168 2         136 print $out $text;
169 2 50       144 close $out or die $!;
170             }
171             elsif (defined (wantarray ())) {
172 1         4 return $text;
173             }
174             else {
175 0         0 print $text;
176             }
177             }
178              
179             1;