File Coverage

blib/lib/Data/TableData/Object/aoaos.pm
Criterion Covered Total %
statement 175 175 100.0
branch 62 72 86.1
condition 5 6 83.3
subroutine 19 19 100.0
pod 14 15 93.3
total 275 287 95.8


line stmt bran cond sub pod time code
1             package Data::TableData::Object::aoaos;
2              
3 4     4   107 use 5.010001;
  4         17  
4 4     4   25 use strict;
  4         8  
  4         100  
5 4     4   21 use warnings;
  4         9  
  4         168  
6              
7 4     4   463 use parent 'Data::TableData::Object::Base';
  4         313  
  4         26  
8              
9             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
10             our $DATE = '2021-11-17'; # DATE
11             our $DIST = 'Data-TableData-Object'; # DIST
12             our $VERSION = '0.115'; # VERSION
13              
14             sub new {
15 27     27 1 5269 my ($class, $data, $spec) = @_;
16 27         88 my $self = bless {
17             data => $data,
18             spec => $spec,
19             }, $class;
20 27 100       72 if ($spec) {
21 17         40 $self->{cols_by_idx} = [];
22 17         52 my $ff = $spec->{fields};
23 17         68 for (keys %$ff) {
24 36         90 $self->{cols_by_idx}[ $ff->{$_}{pos} ] = $_;
25             }
26             $self->{cols_by_name} = {
27 17         46 map { $_ => $ff->{$_}{pos} }
  36         108  
28             keys %$ff
29             };
30             } else {
31 10 100       31 if (@$data) {
32 8         14 my $ncols = @{ $data->[0] };
  8         19  
33 8         29 $self->{cols_by_idx} = [ map {"column$_"} 0 .. $ncols-1 ];
  19         82  
34 8         24 $self->{cols_by_name} = { map {("column$_" => $_)} 0..$ncols-1 };
  19         63  
35             } else {
36 2         4 $self->{cols_by_idx} = [];
37 2         6 $self->{cols_by_name} = {};
38             }
39             }
40 27         217 $self;
41             }
42              
43             sub row_count {
44 7     7 1 15 my $self = shift;
45 7         7 scalar @{ $self->{data} };
  7         22  
46             }
47              
48             sub row {
49 4     4 1 2436 my ($self, $idx) = @_;
50 4         17 $self->{data}[$idx];
51             }
52              
53             sub row_as_aos {
54 22     22 1 2379 my ($self, $idx) = @_;
55 22         52 $self->{data}[$idx];
56             }
57              
58             sub row_as_hos {
59 4     4 1 2498 my ($self, $idx) = @_;
60 4         9 my $row_aos = $self->{data}[$idx];
61 4 100       14 return undef unless $row_aos; ## no critic: Subroutines::ProhibitExplicitReturnUndef
62 3         4 my $cols = $self->{cols_by_idx};
63 3         6 my $row_hos = {};
64 3         6 for my $i (0..$#{$cols}) {
  3         9  
65 6         15 $row_hos->{$cols->[$i]} = $row_aos->[$i];
66             }
67 3         18 $row_hos;
68             }
69              
70             sub rows {
71 1     1 1 2272 my $self = shift;
72 1         6 $self->{data};
73             }
74              
75             sub rows_as_aoaos {
76 17     17 1 2990 my $self = shift;
77 17         154 $self->{data};
78             }
79              
80             sub rows_as_aohos {
81 7     7 1 2916 my $self = shift;
82 7         13 my $data = $self->{data};
83              
84 7         10 my $cols = $self->{cols_by_idx};
85 7         13 my $rows = [];
86 7         11 for my $aos (@{$self->{data}}) {
  7         16  
87 21         32 my $row = {};
88 21         30 for my $i (0..$#{$cols}) {
  21         63  
89 42         118 $row->{$cols->[$i]} = $aos->[$i];
90             }
91 21         39 push @$rows, $row;
92             }
93 7         29 $rows;
94             }
95              
96             sub uniq_col_names {
97 2     2 1 5 my ($self, $which) = @_;
98              
99 2         3 my @res;
100             COL:
101 2         4 for my $colname (sort keys %{$self->{cols_by_name}}) {
  2         9  
102 3         4 my $colidx = $self->{cols_by_name}{$colname};
103 3         6 my %mem;
104 3         4 for my $row (@{$self->{data}}) {
  3         6  
105 7 50       9 next COL unless $#{$row} >= $colidx;
  7         16  
106 7 100       16 next COL unless defined $row->[$colidx];
107 6 100       19 next COL if $mem{ $row->[$colidx] }++;
108             }
109 1         4 push @res, $colname;
110             }
111              
112 2         9 @res;
113             }
114              
115             sub const_col_names {
116 2     2 1 4 my ($self, $which) = @_;
117              
118 2         4 my @res;
119             COL:
120 2         4 for my $colname (sort keys %{$self->{cols_by_name}}) {
  2         8  
121 3         6 my $colidx = $self->{cols_by_name}{$colname};
122 3         5 my $i = -1;
123 3         5 my $val;
124             my $val_undef;
125 3         5 for my $row (@{$self->{data}}) {
  3         6  
126 8 50       12 next COL unless $#{$row} >= $colidx;
  8         18  
127 8         10 $i++;
128 8 100       16 if ($i == 0) {
129 3         5 $val = $row->[$colidx];
130 3 100       8 $val_undef = 1 unless defined $val;
131             } else {
132 5 100       9 if ($val_undef) {
133 2 50       17 next COL if defined;
134             } else {
135 3 50       7 next COL unless defined $row->[$colidx];
136 3 100       8 next COL unless $val eq $row->[$colidx];
137             }
138             }
139             }
140 2         6 push @res, $colname;
141             }
142              
143 2         12 @res;
144             }
145              
146             sub del_col {
147 4     4 1 13 my ($self, $name_or_idx) = @_;
148              
149 4         14 my $idx = $self->col_idx($name_or_idx);
150 4 100       15 return undef unless defined $idx; ## no critic: Subroutines::ProhibitExplicitReturnUndef
151              
152 3         8 my $name = $self->{cols_by_idx}[$idx];
153              
154 3         4 for my $row (@{$self->{data}}) {
  3         8  
155 9         17 splice @$row, $idx, 1;
156             }
157              
158             # adjust cols_by_{name,idx}
159 3         5 for my $i (reverse 0..$#{$self->{cols_by_idx}}) {
  3         8  
160 6         9 my $name = $self->{cols_by_idx}[$i];
161 6 100       17 if ($i > $idx) {
    100          
162 2         5 $self->{cols_by_name}{$name}--;
163             } elsif ($i == $idx) {
164 3         4 splice @{ $self->{cols_by_idx} }, $i, 1;
  3         6  
165 3         6 delete $self->{cols_by_name}{$name};
166             }
167             }
168              
169             # adjust spec
170 3 50       9 if ($self->{spec}) {
171 3         5 my $ff = $self->{spec}{fields};
172 3         19 for my $name (keys %$ff) {
173 6 100       16 if (!exists $self->{cols_by_name}{$name}) {
174 3         8 delete $ff->{$name};
175             } else {
176 3         7 $ff->{$name}{pos} = $self->{cols_by_name}{$name};
177             }
178             }
179             }
180              
181 3         14 $name;
182             }
183              
184             sub rename_col {
185 4     4 1 1135 my ($self, $old_name_or_idx, $new_name) = @_;
186              
187 4         13 my $idx = $self->col_idx($old_name_or_idx);
188 4 100       21 die "Unknown column '$old_name_or_idx'" unless defined($idx);
189 3         7 my $old_name = $self->{cols_by_idx}[$idx];
190 3 50       8 die "Please specify new column name" unless length($new_name);
191 3 100       12 return if $new_name eq $old_name;
192 2 100       17 die "New column name must not be a number" if $new_name =~ /\A\d+\z/;
193              
194 1         3 $self->{cols_by_idx}[$idx] = $new_name;
195 1         7 $self->{cols_by_name}{$new_name} = delete($self->{cols_by_name}{$old_name});
196 1 50       4 if ($self->{spec}) {
197 1         3 my $ff = $self->{spec}{fields};
198 1         4 $ff->{$new_name} = delete($ff->{$old_name});
199             }
200             }
201              
202             sub switch_cols {
203 4     4 1 1121 my ($self, $name_or_idx1, $name_or_idx2) = @_;
204              
205 4         14 my $idx1 = $self->col_idx($name_or_idx1);
206 4 100       21 die "Unknown first column '$name_or_idx1'" unless defined($idx1);
207 3         9 my $idx2 = $self->col_idx($name_or_idx2);
208 3 100       15 die "Unknown second column '$name_or_idx2'" unless defined($idx2);
209 2 100       8 return if $idx1 == $idx2;
210              
211 1         5 my $name1 = $self->col_name($name_or_idx1);
212 1         3 my $name2 = $self->col_name($name_or_idx2);
213              
214             ($self->{cols_by_idx}[$idx1], $self->{cols_by_idx}[$idx2]) =
215 1         4 ($self->{cols_by_idx}[$idx2], $self->{cols_by_idx}[$idx1]);
216             ($self->{cols_by_name}{$name1}, $self->{cols_by_name}{$name2}) =
217 1         4 ($self->{cols_by_name}{$name2}, $self->{cols_by_name}{$name1});
218 1 50       5 if ($self->{spec}) {
219 1         2 my $ff = $self->{spec}{fields};
220 1         4 ($ff->{$name1}, $ff->{$name2}) = ($ff->{$name2}, $ff->{$name1});
221             }
222             }
223              
224             sub add_col {
225 6     6 1 6048 my ($self, $name, $idx, $spec, $data) = @_;
226              
227 6 100       20 die "Column '$name' already exists" if defined $self->col_name($name);
228 5         14 my $col_count = $self->col_count;
229 5 100       13 if (defined $idx) {
230 3 100 100     31 die "Index must be between 0..$col_count"
231             unless $idx >= 0 && $idx <= $col_count;
232             } else {
233 2         4 $idx = $col_count;
234             }
235              
236 3         7 for (keys %{ $self->{cols_by_name} }) {
  3         11  
237 12 100       28 $self->{cols_by_name}{$_}++ if $self->{cols_by_name}{$_} >= $idx;
238             }
239 3         8 $self->{cols_by_name}{$name} = $idx;
240 3         5 splice @{ $self->{cols_by_idx} }, $idx, 0, $name;
  3         9  
241 3 50       8 if ($self->{spec}) {
242 3         6 my $ff = $self->{spec}{fields};
243 3         6 for my $f (values %$ff) {
244 12 100 66     56 $f->{pos}++ if defined($f->{pos}) && $f->{pos} >= $idx;
245             }
246 3 50       8 $ff->{$name} = defined($spec) ? {%$spec} : {};
247 3         9 $ff->{$name}{pos} = $idx;
248             }
249              
250 3         4 my $i = 0;
251 3         5 for my $row (@{ $self->{data} }) {
  3         7  
252 9 100       18 splice @$row, $idx, 0, ($data ? $data->[$i] : undef);
253 9         19 $i++;
254             }
255             }
256              
257             sub set_col_val {
258 2     2 0 392 my ($self, $name_or_idx, $value_sub) = @_;
259              
260 2         8 my $col_name = $self->col_name($name_or_idx);
261 2         7 my $col_idx = $self->col_idx($name_or_idx);
262              
263 2 100       71 die "Column '$name_or_idx' does not exist" unless defined $col_name;
264              
265 1         4 for my $i (0..$#{ $self->{data} }) {
  1         5  
266 2         50 my $row = $self->{data}[$i];
267 2         10 $row->[$col_idx] = $value_sub->(
268             table => $self,
269             row_idx => $i,
270             col_name => $col_name,
271             col_idx => $col_idx,
272             value => $row->[$col_idx],
273             );
274             }
275             }
276              
277             1;
278             # ABSTRACT: Manipulate array of arrays-of-scalars via table object
279              
280             __END__