File Coverage

blib/lib/No/Worries/String.pm
Criterion Covered Total %
statement 33 120 27.5
branch 10 54 18.5
condition 0 10 0.0
subroutine 8 15 53.3
pod 6 6 100.0
total 57 205 27.8


line stmt bran cond sub pod time code
1             #+##############################################################################
2             # #
3             # File: No/Worries/String.pm #
4             # #
5             # Description: string handling without worries #
6             # #
7             #-##############################################################################
8              
9             #
10             # module definition
11             #
12              
13             package No::Worries::String;
14 20     20   75748 use strict;
  20         64  
  20         611  
15 20     20   101 use warnings;
  20         38  
  20         1658  
16             our $VERSION = "1.7";
17             our $REVISION = sprintf("%d.%02d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/);
18              
19             #
20             # used modules
21             #
22              
23 20     20   623 use No::Worries::Export qw(export_control);
  20         38  
  20         118  
24 20     20   125 use Params::Validate qw(validate validate_pos :types);
  20         52  
  20         44223  
25              
26             #
27             # global variables
28             #
29              
30             our(
31             @_ByteSuffix, # byte suffixes used by bytefmt
32             @_Map, # mapping of characters to escaped strings
33             %_Plural, # pluralization cache
34             );
35              
36             #
37             # format a number of bytes
38             #
39              
40             sub string_bytefmt ($;$) {
41 0     0 1 0 my($number, $precision) = @_;
42 0         0 my($index);
43              
44 0 0       0 $precision = 2 unless defined($precision);
45 0         0 $index = 0;
46 0   0     0 while ($_ByteSuffix[$index] and $number > 1024) {
47 0         0 $index++;
48 0         0 $number /= 1024.0;
49             }
50 0 0       0 return("$number $_ByteSuffix[$index]") if $number =~ /^\d+$/;
51 0         0 return(sprintf("%.${precision}f %s", $number, $_ByteSuffix[$index]));
52             }
53              
54             #
55             # escape a string (quite compact, human friendly but not Perl eval()'able)
56             #
57              
58             sub string_escape ($) {
59 6     6 1 106 my($string) = @_;
60 6         11 my(@list);
61              
62 6         90 validate_pos(@_, { type => SCALAR });
63 6         44 foreach my $ord (map(ord($_), split(//, $string))) {
64 23 100       65 push(@list, $ord < 256 ? $_Map[$ord] : sprintf("\\x{%04x}", $ord));
65             }
66 6         43 return(join("", @list));
67             }
68              
69             #
70             # return the plural form of the given noun
71             #
72              
73             sub string_plural ($) {
74 3     3 1 8 my($noun) = @_;
75              
76 3 100       13 unless ($_Plural{$noun}) {
77 2 50       26 if ($noun =~ /(ch|s|sh|x|z)$/) {
    100          
    50          
    50          
    50          
78 0         0 $_Plural{$noun} = $noun . "es";
79             } elsif ($noun =~ /[bcdfghjklmnpqrstvwxz]y$/) {
80 1         7 $_Plural{$noun} = substr($noun, 0, -1) . "ies";
81             } elsif ($noun =~ /f$/) {
82 0         0 $_Plural{$noun} = substr($noun, 0, -1) . "ves";
83             } elsif ($noun =~ /fe$/) {
84 0         0 $_Plural{$noun} = substr($noun, 0, -2) . "ves";
85             } elsif ($noun =~ /[bcdfghjklmnpqrstvwxz]o$/) {
86 0         0 $_Plural{$noun} = $noun . "es";
87             } else {
88 1         5 $_Plural{$noun} = $noun . "s";
89             }
90             }
91 3         14 return($_Plural{$noun});
92             }
93              
94             #
95             # quantify the given (count, noun) pair
96             #
97              
98             sub string_quantify ($$) {
99 0     0 1 0 my($count, $noun) = @_;
100              
101 0 0       0 return($count . " " . ($count == 1 ? $noun : string_plural($noun)));
102             }
103              
104             #
105             # return the real length of a string (removing ANSI Escape sequences)
106             #
107              
108             sub _strlen ($) {
109 0     0   0 my($string) = @_;
110              
111 0 0       0 return(0) unless defined($string);
112 0         0 $string =~ s/\x1b\[[0-9;]*[mGKH]//g;
113 0         0 return(length($string));
114             }
115              
116             #
117             # return an aligned and padded string
118             #
119              
120             sub _strpad ($$$) {
121 0     0   0 my($string, $length, $align) = @_;
122 0         0 my($strlen, $before, $after);
123              
124 0 0       0 $string = "" unless defined($string);
125 0         0 $strlen = _strlen($string);
126 0   0     0 $align ||= "left";
127 0 0       0 if ($align eq "left") {
    0          
    0          
128 0         0 $before = 0;
129 0         0 $after = $length - $strlen;
130             } elsif ($align eq "right") {
131 0         0 $before = $length - $strlen;
132 0         0 $after = 0;
133             } elsif ($align eq "center") {
134 0         0 $before = ($length - $strlen) >> 1;
135 0         0 $after = $length - $strlen - $before;
136             } else {
137 0         0 die("unexpected alignment: $align\n");
138             }
139 0         0 return((" " x $before) . $string . (" " x $after));
140             }
141              
142             #
143             # return a string generated from a repeated pattern
144             #
145              
146             sub _strgen ($$) {
147 0     0   0 my($pattern, $length) = @_;
148              
149 0         0 return(substr($pattern x $length, 0, $length));
150             }
151              
152             #
153             # return a formatted table line
154             #
155              
156             sub _tblfmt ($$) {
157 0     0   0 my($column, $option) = @_;
158 0         0 my($line, $index);
159              
160 0         0 $line = $option->{indent};
161 0         0 $line .= $option->{lsep};
162 0         0 $index = 0;
163 0         0 while ($index < @{ $option->{collen} }) {
  0         0  
164 0 0       0 $line .= $option->{colsep} if $index;
165             $line .= _strpad($column->[$index],
166             $option->{collen}[$index],
167 0         0 $option->{align}[$index]);
168 0         0 $index++;
169             }
170 0         0 $line .= $option->{rsep};
171 0         0 $line .= "\n";
172 0         0 return($line);
173             }
174              
175             #
176             # transform a table into a string
177             #
178              
179             my %string_table_options = (
180             align => { optional => 1, type => ARRAYREF },
181             colsep => { optional => 1, type => SCALAR },
182             header => { optional => 1, type => ARRAYREF },
183             headsep => { optional => 1, type => SCALAR },
184             indent => { optional => 1, type => SCALAR },
185             markdown => { optional => 1, type => BOOLEAN },
186             );
187              
188             sub string_table ($@) {
189 0     0 1 0 my($lines, %option, @collen, @headsep, $index, $length, $result);
190              
191             # handle options
192 0         0 $lines = shift(@_);
193 0 0       0 %option = validate(@_, \%string_table_options) if @_;
194 0   0     0 $option{align} ||= [];
195             $option{colsep} = " | "
196 0 0       0 unless defined($option{colsep});
197             $option{headsep} = $option{markdown} ? "-" : "="
198 0 0       0 unless defined($option{headsep});
    0          
199             $option{indent} = ""
200 0 0       0 unless defined($option{indent});
201 0 0       0 if ($option{markdown}) {
202 0         0 $option{lsep} = $option{rsep} = $option{colsep};
203 0         0 $option{lsep} =~ s/^\s+//;
204 0         0 $option{rsep} =~ s/\s+$//;
205             } else {
206 0         0 $option{lsep} = "";
207 0         0 $option{rsep} = "";
208             }
209             # compute column lengths
210 0 0       0 foreach my $line ($option{header} ? ($option{header}) : (), @{ $lines }) {
  0         0  
211 0         0 $index = 0;
212 0         0 foreach my $entry (@{ $line }) {
  0         0  
213 0         0 $length = _strlen($entry);
214 0 0 0     0 $collen[$index] = $length
215             unless defined($collen[$index]) and $collen[$index] >= $length;
216 0         0 $index++;
217             }
218             }
219             # compute total length
220 0         0 $length = length($option{lsep}) + length($option{rsep});
221 0         0 $length += length($option{colsep}) * (@collen - 1);
222 0         0 foreach my $collen (@collen) {
223 0         0 $length += $collen;
224             }
225 0         0 $option{collen} = \@collen;
226 0         0 $result = "";
227             # format header
228 0 0       0 if ($option{header}) {
229 0         0 $result .= _tblfmt($option{header}, \%option);
230 0 0       0 if (length($option{headsep})) {
231 0 0       0 if ($option{markdown}) {
232 0         0 @headsep = map(_strgen($option{headsep}, $_), @collen);
233 0         0 $result .= _tblfmt(\@headsep, \%option);
234             } else {
235 0         0 $result .= $option{indent};
236 0         0 $result .= _strgen($option{headsep}, $length) . "\n";
237             }
238             }
239             }
240             # format lines
241 0         0 foreach my $line (@{ $lines }) {
  0         0  
242 0         0 $result .= _tblfmt($line, \%option);
243             }
244 0         0 return($result);
245             }
246              
247             #
248             # remove leading and trailing spaces
249             #
250              
251             sub string_trim ($) {
252 37     37 1 81 my($string) = @_;
253              
254 37         471 validate_pos(@_, { type => SCALAR });
255 37         188 $string =~ s/^\s+//;
256 37         145 $string =~ s/\s+$//;
257 37         252 return($string);
258             }
259              
260             #
261             # module initialization
262             #
263              
264             @_ByteSuffix = qw(B kB MB GB TB PB EB ZB YB);
265             foreach my $ord (0 .. 255) {
266             $_Map[$ord] = 32 <= $ord && $ord < 127 ?
267             chr($ord) : sprintf("\\x%02x", $ord);
268             }
269             $_Map[ord("\t")] = "\\t";
270             $_Map[ord("\n")] = "\\n";
271             $_Map[ord("\r")] = "\\r";
272             $_Map[ord("\e")] = "\\e";
273             $_Map[ord("\\")] = "\\\\";
274             %_Plural = (
275             "child" => "children",
276             "data" => "data",
277             "foot" => "feet",
278             "index" => "indices",
279             "man" => "men",
280             "tooth" => "teeth",
281             "woman" => "women",
282             );
283              
284             #
285             # export control
286             #
287              
288             sub import : method {
289 21     21   67 my($pkg, %exported);
290              
291 21         47 $pkg = shift(@_);
292 21         293 grep($exported{$_}++, map("string_$_",
293             qw(bytefmt escape plural quantify table trim)));
294 21         142 export_control(scalar(caller()), $pkg, \%exported, @_);
295             }
296              
297             1;
298              
299             __DATA__