File Coverage

blib/lib/Script/Toolbox/TableO.pm
Criterion Covered Total %
statement 51 66 77.2
branch 20 30 66.6
condition 4 6 66.6
subroutine 11 13 84.6
pod 0 3 0.0
total 86 118 72.8


line stmt bran cond sub pod time code
1             package Script::Toolbox::TableO;
2             # vim: ts=4 sw=4 ai
3              
4 10     10   57 use strict;
  10         17  
  10         278  
5 10     10   41 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  10         14  
  10         6939  
6              
7             require Exporter;
8              
9             @ISA = qw(Exporter);
10             # Items to export into callers namespace by default. Note: do not export
11             # names by default without a very good reason. Use EXPORT_OK instead.
12             # Do not simply export all your public functions/methods/constants.
13             @EXPORT = qw(
14            
15             );
16             #$VERSION = '0.03';
17              
18              
19             # Preloaded methods go here.
20              
21             #-----------------------------------------------------------------------------
22             #-----------------------------------------------------------------------------
23             sub new
24             {
25 10     10 0 19 my $classname = shift;
26 10         16 my $self = {};
27 10         23 bless( $self, $classname );
28 10         25 $self->_init( @_ );
29 10         28 return $self;
30             }
31              
32             #-----------------------------------------------------------------------------
33             #-----------------------------------------------------------------------------
34             sub _init
35             {
36 10     10   17 my ($self, $param, $separator) = @_;
37              
38 10 50       14 return undef if( _noData( $param ) );
39 10         24 my $para = _normParam($param, $separator);
40              
41 10         71 my $form = Script::Toolbox::Util::Formatter->new( $para );
42 10         25 my $result= $form->matrix();
43 10 50 66     46 if( ref $param eq 'ARRAY' || !defined $param->{'sumCols'} ){
44 10         71 $self->{'result'} = $result;
45             }else{
46             $self->{'result'} = $form->sumBy($result, $param->{'sumCols'},
47 0         0 $param->{'notGroupBy'});
48             }
49             }
50              
51             #------------------------------------------------------------------------------
52             # $param must be a hash reference. This Hash must have a key "data".
53             # This key may point to:
54             # arrayref
55             # hashref
56             #------------------------------------------------------------------------------
57             sub _noData($)
58             {
59 10     10   14 my ($param) = @_;
60              
61 10 100       28 return 0 if( ref $param ne 'HASH' );
62 6 100       18 return 0 if( ref $param->{'data'} eq 'HASH' );
63 5 50       23 return 0 if( ref $param->{'data'} eq 'ARRAY');
64              
65 0 0       0 if( !defined $param->{'data'}[0] )
66             {
67 0         0 Log( "WARNING: no input data for Table()." );
68 0         0 return 1;
69             }
70 0         0 return 0;
71             }
72              
73             #------------------------------------------------------------------------------
74             # Valid Calls:
75             # [ "csvString", "csvString",...], undef
76             # [ "csvString", "csvString",...], separatorString
77             # [ "TitelString", [headArray], [dataArray],...], undef
78             # [ [dataArray],...], undef
79             # {title=>"", head=>[], data=>[[],[],...] }, undef
80             # {title=>"", head=>[], data=>[{},{},...] }, undef
81             # {title=>"", head=>[], data=>{r1=>{c1=>,c2=>,},r2=>{c1=>,c2=>,},}, undef
82             #------------------------------------------------------------------------------
83             sub _normParam($$)
84             {
85 10     10   17 my ($param, $separator) = @_;
86              
87 10 100       25 if( ref $param eq 'HASH' )
88             {
89             # keine Ahnung wozu: return _sepHash($param, $separator) if( _isCSV($param->{'data'}) );
90 6         11 return $param;
91             }
92 4 100       18 return _sepTitleHead($param) if( _isTitleHead($param) );
93 3 50       12 return _sepCSV($param, $separator) if( _isCSV($param, $separator) );
94 0         0 return { 'data' => $param };
95             }
96              
97             #------------------------------------------------------------------------------
98             #------------------------------------------------------------------------------
99             sub _sepHash($$)
100             {
101 0     0   0 my ($param,$separator) = @_;
102              
103 0         0 my $d = _sepCSV($param->{'data'}, $separator);
104 0         0 $param->{'data'} = $d->{'data'};
105 0         0 return $param;
106             }
107              
108             # ------------------------------------------------------------------------------
109             # Check if we found the special data array format.
110             # ["TitleString", [headString,headString,...],[data,...],...]
111             #------------------------------------------------------------------------------
112             sub _isTitleHead($)
113             {
114 4     4   9 my ($param) = @_;
115              
116 4 100 66     37 return 1 if( ref \$param->[0] eq 'SCALAR' && ref $param->[1] eq 'ARRAY' );
117 3         11 return 0;
118             }
119              
120             #------------------------------------------------------------------------------
121             # Transform the special data array
122             # ["TitleString", [headString,headString,...],[data,...],...]
123             # into hash format.
124             #------------------------------------------------------------------------------
125             sub _sepTitleHead($)
126             {
127 1     1   5 my ($param) = @_;
128              
129 1         7 my $title= splice @{$param}, 0,1;
  1         6  
130 1         6 my $head = splice @{$param}, 0,1;
  1         7  
131              
132             return {
133 1         6 'title' => $title,
134             'head' => $head,
135             'data' => $param
136             };
137             }
138              
139              
140             #------------------------------------------------------------------------------
141             # [[],[],...]
142             # [{},{},...]
143             # {r1=>{c1=>,c2=>,},r2=>{c1=>,c2=>,},}
144             #------------------------------------------------------------------------------
145             sub _isCSV($$)
146             {
147 3     3   11 my ($param, $separator) = @_;
148              
149 3 50       12 return 0 if( ref $param ne 'ARRAY' );
150              
151 3 100       10 $separator = ';' unless defined $separator; #FIXME default sep
152 3 50       53 return 1 if( $param->[0] =~ /$separator/ ); #assume it's a CSV record
153 0         0 return 0;
154             }
155              
156             #------------------------------------------------------------------------------
157             # Convert an array of CSV strings into an array of arrays.
158             #
159             # [ "a;b","c,d"] becomes
160             # [[a,b], [c,d]]
161             #------------------------------------------------------------------------------
162             sub _sepCSV($$)
163             {
164 3     3   7 my ($param, $separator) = @_;
165              
166 3 100       8 $separator = ';' if( !defined $separator);
167 3         6 my @R;
168 3         4 foreach my $l ( @{$param} )
  3         6  
169             {
170 9         32 my @r = split /$separator/, $l;
171 9         19 push @R, \@r;
172             }
173              
174 3         11 return { 'data' => \@R };
175             }
176              
177             #------------------------------------------------------------------------------
178             #------------------------------------------------------------------------------
179             sub asArray($){
180 10     10 0 43 my ($self) = @_;
181              
182 10         11 return @{$self->{'result'}};
  10         34  
183             }
184              
185             #------------------------------------------------------------------------------
186             #------------------------------------------------------------------------------
187             sub asString($$){
188 0     0 0   my ($self,$sep) = @_;
189              
190 0 0         $sep = defined $sep ? $sep : "\n";
191 0           return sprintf "%s", join $sep, @{$self->{'result'}};
  0            
192             }
193              
194             1;
195             __END__