File Coverage

blib/lib/Data/All.pm
Criterion Covered Total %
statement 99 150 66.0
branch 26 48 54.1
condition 5 30 16.6
subroutine 17 27 62.9
pod 0 17 0.0
total 147 272 54.0


line stmt bran cond sub pod time code
1             package Data::All;
2              
3             # Data::All - Access to data in many formats source many places
4              
5             # TODO: Create Data::All::IO::Hash for internal storage
6             # TODO: Add checking for output field names that aren't present in input field names
7             # TODO: Auto reset file/db cursors? Call read() then convert() causes error;
8              
9 1     1   23218 use strict;
  1         4  
  1         43  
10 1     1   5 use warnings;
  1         3  
  1         29  
11             #use diagnostics;
12            
13 1     1   1154 use Data::Dumper;
  1         12935  
  1         83  
14 1     1   559 use Data::All::Base;
  1         3  
  1         59  
15 1     1   502 use Data::All::IO;
  1         3  
  1         267  
16              
17             our $VERSION = 0.042;
18             our @EXPORT = qw(collection);
19              
20             ## PUBLIC INTERFACE
21             sub show_fields; # returns an arrayref of field names
22             sub collection; # A shortcut for open() and read()
23             sub getrecord;
24             sub putrecord;
25             sub is_open;
26             sub convert; # Change formats
27             sub store; # save in memory records
28             sub count; # Record count
29             sub close;
30             sub read;
31             sub open;
32              
33             ## PUBLIC ATTRIBUTES
34             ## i.e. $da->source()
35             attribute 'source';
36             attribute 'target';
37             attribute 'print_fields' => 0;
38             attribute 'atomic' => 1;
39              
40              
41             ## PRIVATE ATTRIBUTES
42              
43             # Contains Data::All::IO::* object by moniker
44             internal 'collection' => {};
45              
46             internal 'profile' =>
47             # Hardcoded/commonly used format configs
48             {
49             csv => ['delim', "\n", ',', '"', '\\'],
50             tab => ['delim', "\n", "\t", '', '']
51             };
52              
53             internal 'a2h_template' =>
54             # Templates for converting arrayref configurations to
55             # internally used, easy to handle hashref configs. See _parse_args().
56             # TODO: move this functionality into a generic arg parsing library
57             {
58             'format.delim' => ['type','break','delim','quote','escape'],
59             'format.fixed' => ['type','break','lengths'],
60             'ioconf.file' => ['type','perm','with_original'],
61             'ioconf.ftp' => ['type','perm','with_original'],
62             'ioconf.db' => ['type','perm','with_original']
63             };
64              
65             internal 'default' =>
66             # Default values for configuration variables
67             {
68             profile => 'csv',
69             filters => '',
70             ioconf =>
71             {
72             type => 'file',
73             perm => 'r',
74             with_original => 0
75             },
76             format =>
77             {
78             type => 'delim'
79             }
80             };
81              
82              
83             BEGIN {
84 1     1   9 Data::All::IO->register_factory_type( file => 'Data::All::IO::File');
85             #Data::All::IO->register_factory_type( xml => 'Data::All::IO::XML');
86 1         14 Data::All::IO->register_factory_type( db => 'Data::All::IO::Database');
87             #Data::All::IO->register_factory_type( ftp => 'Data::All::IO::FTP');
88             }
89              
90              
91             # CONSTRUCTOR RELATED
92             sub init()
93             # Rekindle all that we are
94             {
95 1     1 0 3 my $self = shift;
96            
97 1         4 my $args = $self->reinit(@_);
98 1         7 return $self;
99             }
100              
101             sub reinit
102             {
103 2     2 0 4 my $self = shift;
104 2         3 my $args;
105            
106 2 50       8 return undef unless ($_[0]);
107            
108             # Allow for hash or hashref args
109 2 50       21 $args = (ref($_[0]) eq 'HASH') ? $_[0] : { @_ };
110            
111 2         10 populate($self, $args);
112            
113 2         10 $self->prep_collections();
114            
115 2         7 return $args;
116             }
117              
118              
119              
120             sub prep_collections()
121             # Prepare and store an instance of Data::All::IO::* for source and to configs
122             {
123 2     2 0 3 my $self = shift;
124            
125 2         5 foreach (qw(source target))
126             {
127 4 50       15 $self->__collection()->{$_} = $self->_load_IO($self->$_())
128             if (defined($self->$_()));
129             }
130             }
131              
132              
133             sub _load_IO(\%)
134             # Load an instance of Data::All::IO::? to memory
135             {
136 4     4   8 my $self = shift;
137 4         6 my $args = shift;
138              
139 4         16 $self->_parse_args($args);
140 4         7 my ($ioconf, $format, $path, $fields) = @{ $args }{'ioconf','format','path','fields'};
  4         11  
141            
142              
143 4         44 my $IO = Data::All::IO->new($ioconf->{'type'},
144             {
145             ioconf => $ioconf,
146             format => $format,
147             path => $path,
148             fields => $fields
149             });
150            
151 4         68 return $IO;
152             }
153              
154             sub _parse_args()
155             # Convert arrayref args into hashref, process determinable values,
156             # and apply defaults to the rest. We can also through a horrible
157             # error at this point if there isn't enoguh info for Data::All to
158             # continue.
159             {
160 4     4   5 my $self = shift;
161 4         6 my $args = shift;
162            
163             # TODO: Allow collection('filename.csv', 'profile'); usage
164 4         14 $self->_apply_profile_to_args($args);
165            
166             # Make sure path is an array ref
167 4 100       59 $args->{'path'} = [$args->{'path'}] if (ref($args->{'path'}) ne 'ARRAY');
168            
169 4         8 for my $a (keys %{ $self->__default() })
  4         12  
170             # Apply default values to data collection configuration. Amplify arrayref
171             # configs into hashref configs using the a2h_templates where appropriate.
172             {
173 16 50       34 next if $a eq 'path';
174              
175 16 100       38 if (ref($args->{$a}) eq 'ARRAY')
176             {
177 4         4 my (%hash, $templ);
178 4         15 $templ = join '', $a, '.', $args->{$a}->[0];
179            
180 4 50       12 $self->error("Wasn't expecting: $templ"), next unless(exists($self->__a2h_template()->{$templ}));
181            
182 4         5 @hash{@{$self->__a2h_template()->{$templ}}} = @{ $args->{$a} };
  4         12  
  4         8  
183            
184 4         13 $args->{$a} = \%hash;
185             }
186            
187 16         37 $self->_apply_default_to($a, $args);
188             }
189            
190 4 100       14 return if ($args->{'moniker'});
191            
192 2         8 $args->{'moniker'} = ($args->{'ioconf'}->{'type'} ne 'db')
193 2 50       8 ? join('', @{ $args->{'path'} })
194             : '_';
195            
196             }
197              
198              
199             sub _apply_profile_to_args(\%)
200             # Populate format within args based on a preconfigured profile
201             {
202 4     4   5 my $self = shift;
203 4         7 my $args = shift;
204             #print Dumper($args);
205 4   66     21 my $p = $args->{'profile'} || $self->__default()->{'profile'};
206            
207 4 100       16 return if (exists($args->{'format'}));
208            
209 1 50 33     8 die("There is no profile for type $p ")
210             unless ($p && exists($self->__profile()->{$p}));
211            
212             # Set the format using the requested profile
213 1         4 $args->{'format'} = $self->__profile()->{$p};
214 1         9 return;
215             }
216              
217             sub _apply_default_to()
218             # Set a default value to a particular attribute.
219             # TODO: Allow setting of individual attribute fields
220             {
221 16     16   18 my $self = shift;
222 16         23 my ($a, $args) = @_;
223 16 100       47 $args->{$a} = $self->__default()->{$a}
224             unless (exists($args->{$a}));
225            
226 16 100       48 return unless (ref($args->{$a}) eq 'HASH');
227            
228 8         11 foreach my $c (keys %{ $self->__default()->{$a} })
  8         23  
229             {
230 16 100       78 $args->{$a}->{$c} = $self->__default()->{$a}->{$c}
231             unless (defined($args->{$a}->{$c}));
232             }
233              
234             }
235              
236              
237              
238             sub count(;$)
239             # get a record count
240             {
241 0     0 0 0 my $self = shift;
242 0   0     0 my $which = shift || 'source';
243            
244 0 0       0 $self->open() unless ($self->is_open($which));
245 0         0 return $self->__collection()->{$which}->count();
246             }
247              
248              
249             sub count_to(;$)
250             # get a record count for the source config
251             {
252 0     0 0 0 my $self = shift;
253 0         0 return $self->count('target');
254             }
255              
256              
257             sub count_source(;$)
258             # get a record count for the source config
259             {
260 0     0 0 0 my $self = shift;
261 0         0 return $self->count('source');
262             }
263              
264             sub getrecord(;$$)
265             # Get a single, consecutive record
266             {
267 0     0 0 0 my $self = shift;
268 0   0     0 my $type = shift || 'hash';
269 0         0 my $meth = 'getrecord_' . $type;
270 0         0 my $record;
271            
272             # $record = ($self->__collection()->{'source'}->can($meth))
273             # ? $self->__collection()->{'source'}->$meth()
274             # : undef;
275              
276 0         0 return $self->__collection()->{'source'}->getrecord_hash();
277             }
278              
279             sub putrecord()
280             # Put a single, consecutive record
281             {
282 0     0 0 0 my $self = shift;
283 0   0     0 my $record = shift || return undef;
284            
285 0         0 $self->__collection()->{'target'}->putrecord()
286             }
287              
288              
289             sub collection(%)
290             # Shorthand for creating a Data::All instance, openning, reading
291             # and closing the data source
292             {
293 0     0 0 0 my ($conf1, $conf2) = @_;
294 0         0 my ($myself, $rec);
295            
296             # We can accept standard-arg style, but we will also make provisions
297             # for a single hashref arg which we'll assume is the 'source' config
298 0 0       0 $myself = (ref($_[0]) ne 'HASH')
299             ? new('Data::All', @_)
300             : new('Data::All', source => $_[0]);
301            
302 0         0 $myself->open();
303 0         0 $rec = $myself->read();
304 0         0 $myself->close();
305            
306 0 0       0 return (!wantarray) ? $rec : @{ $rec };
  0         0  
307             }
308              
309             sub open(;$)
310             {
311 2     2 0 8 my $self = shift;
312             #my $which = shift || 'source';
313            
314 2         4 foreach my $source (keys %{ $self->__collection() })
  2         8  
315             {
316 4         11 $self->__collection()->{$source}->open();
317            
318 4 50       15 unless ($self->__collection()->{$source}->is_open())
319             {
320 0         0 $self->__ERROR($self->__collection()->{$source}->__ERROR());
321 0         0 die "Cannot open ", $self->__collection()->{$source}->create_path();
322             }
323             }
324            
325 2         6 return;
326             }
327              
328             sub close(;$)
329             {
330 1     1 0 1150 my $self = shift;
331             #my $which = shift || 'source';
332            
333 1         3 foreach my $source (keys %{ $self->__collection() })
  1         5  
334             {
335 2         7 $self->__collection()->{$source}->close();
336             }
337            
338 1         4 return;
339             }
340              
341             sub show_fields(;$)
342             {
343 0     0 0 0 my $self = shift;
344 0   0     0 my $which = shift || 'source';
345 0         0 $self->__collection()->{$which}->fields();
346             }
347              
348             sub read(;$$)
349             {
350 1     1 0 6 my $self = shift;
351 1   50     7 my $which = shift || 'source';
352            
353 1         11 $self->open();
354 1         3 my $records = $self->__collection()->{$which}->getrecords();
355            
356 1 50       6 return !wantarray ? $records : @{ $records };
  0         0  
357             }
358              
359             sub store
360             # Store data source an array ref (of hashes) into a Data::All enabled source
361             # IN: (arrayref) of hashes -- your records
362             # [ standard parameters ]
363             # OUT:
364             {
365 0     0 0 0 my $self = shift;
366 0         0 my $source = shift;
367 0         0 my ($target, $bool);
368            
369 0         0 my $args = $self->reinit(@_);
370            
371 0         0 $target = $self->__collection()->{'target'};
372            
373 0         0 $target->open();
374            
375 0         0 $target->fields([keys %{ $source->[0] }])
  0         0  
376 0 0 0     0 unless ($target->fields() && $#{ $target->fields() });
377            
378 0 0       0 $target->putfields() if ($self->print_fields);
379              
380             # Convert data in a wholesome fashion (rather than piecemeal)
381             # There is no point in doing it record by record b/c the
382             # records we are storing are already in memory.
383 0         0 $bool = $target->putrecords($source, $args) ;
384            
385 0         0 $target->close();
386            
387 0         0 return 1;
388             }
389              
390             sub convert
391             # Move data source one Data::All collection to another, using a simple
392             # source (source) and to (target) metaphor
393             # TODO: need error detection
394             {
395 1     1 0 7 my $self = shift;
396 1         2 my ($source, $target, $bool);
397            
398 1         5 my $args = $self->reinit(@_);
399              
400 1         3 ($source, $target) = @{ $self->__collection() }{'source','target'};
  1         4  
401              
402 1         6 $source->open();
403 1         5 $target->open();
404            
405             # TODO: Get fields source db SELECT before we copy to the $target->fields()
406            
407             # Use the source's field names if the target's has none
408 1 50 33     5 $target->fields($source->fields) unless ($target->fields() && $#{ $target->fields() });
  1         5  
409            
410              
411             # Print the field names into the target
412             # TODO: If the field list is in the source collection, then the
413             # fields will appear twice in the target file.
414 1 50       6 $target->putfields() if ($self->print_fields);
415            
416 1 50       5 if ($self->atomic) {
417             # Convert data in a wholesome fashion (rather than piecemeal)
418 1         7 $bool = $target->putrecords([$source->getrecords()], $args) ;
419             }
420             else {
421             # Convert record by record (great for large family members!!!!!!!)
422 0         0 while (my $rec = $source->getrecord_hash())
423 0         0 { $bool = $target->putrecord($rec, $args) }
424             }
425            
426             # BUG: I commented this out for the extract specifically (delano - May 9)
427             #$target->close();
428             #$source->close();
429            
430 1         8 return $bool;
431             }
432              
433              
434             sub write(;$$)
435             {
436 0     0 0   my $self = shift;
437 0   0       my $which = shift || 'source';
438 0   0       my ($start, $count) = (shift || 0, shift || 0);
      0        
439            
440             }
441              
442              
443             sub is_open(;$)
444             {
445 0     0 0   my $self = shift;
446 0   0       my $which = shift || 'source';
447            
448 0           return $self->__collection()->{'source'}->is_open();
449             }
450              
451              
452              
453              
454              
455              
456              
457              
458              
459              
460             1;
461             __END__