File Coverage

blib/lib/Text/xSV/Slurp.pm
Criterion Covered Total %
statement 199 215 92.5
branch 83 98 84.6
condition 18 20 90.0
subroutine 19 19 100.0
pod 1 1 100.0
total 320 353 90.6


line stmt bran cond sub pod time code
1             package Text::xSV::Slurp;
2              
3 9     9   497299 use warnings;
  9         79  
  9         256  
4 9     9   41 use strict;
  9         13  
  9         180  
5              
6 9     9   34 use Carp 'confess', 'cluck';
  9         14  
  9         400  
7 9     9   5326 use Text::CSV;
  9         148837  
  9         838  
8 9     9   3328 use IO::String;
  9         18779  
  9         279  
9              
10 9     9   57 use constant HOH_HANDLER_KEY => 0;
  9         16  
  9         820  
11 9     9   52 use constant HOH_HANDLER_KEY_VALUE_PATH => 1;
  9         18  
  9         341  
12 9     9   42 use constant HOH_HANDLER_OLD_VALUE => 2;
  9         15  
  9         315  
13 9     9   42 use constant HOH_HANDLER_NEW_VALUE => 3;
  9         15  
  9         300  
14 9     9   45 use constant HOH_HANDLER_LINE_HASH => 4;
  9         14  
  9         383  
15 9     9   48 use constant HOH_HANDLER_HOH => 5;
  9         14  
  9         335  
16 9     9   38 use constant HOH_HANDLER_SCRATCH_PAD => 6;
  9         17  
  9         345  
17              
18 9     9   48 use base 'Exporter';
  9         13  
  9         20686  
19              
20             our @EXPORT = qw/ xsv_slurp /;
21              
22             =head1 NAME
23              
24             Text::xSV::Slurp - Convert xSV data to common data shapes.
25              
26             =head1 VERSION
27              
28             Version 0.23
29              
30             =cut
31              
32             our $VERSION = '0.23';
33              
34             =head1 SYNOPSIS
35              
36             C converts xSV (typically CSV) data to nested data structures
37             of various shapes. It allows both column and row filtering using user defined
38             functions.
39              
40             This brief example creates an array of hashes from a file, where each array
41             record corresponds to a line of the file, and each line is represented as a hash
42             of header-to-value pairs.
43              
44             use Text::xSV::Slurp 'xsv_slurp';
45            
46             my $aoh = xsv_slurp( 'foo.csv' );
47            
48             ## if foo.csv contains:
49             ##
50             ## uid,name
51             ## 342,tim
52             ## 939,danboo
53             ##
54             ## then $aoh contains:
55             ##
56             ## [
57             ## { uid => '342', name => 'tim' },
58             ## { uid => '939', name => 'danboo' },
59             ## ]
60            
61             =head1 FUNCTIONS
62              
63             =head2 C
64              
65             C converts xSV (typically CSV) data to nested data structures of
66             various shapes. It allows both column and row filtering using user defined
67             functions.
68              
69             Option summary:
70              
71             =over
72              
73             =item * C - file name to be opened
74              
75             =item * C - file handle to be iterated
76              
77             =item * C - string to be parsed
78              
79             =item * C - target data structure (C, C, C or C)
80              
81             =item * C - skip a subset of columns based on user callback
82              
83             =item * C - skip a subset of rows based on user callback
84              
85             =item * C - xSV string or ARRAY used to build the keys of the C shape
86              
87             =item * C - redefine how the C shape should store values
88              
89             =item * C - redefine how the C shape should handle key collisions
90              
91             =item * C - option hash for L/L constructor
92              
93             =back
94              
95             The C, C and C options are mutually exclusive. Only one
96             source parameter may be passed in each call to C, otherwise a fatal
97             exception will be raised.
98              
99             The source can also be provided implicitly, without the associated key, and the
100             source type will be guessed by examining the first item in the option list. If
101             the item is a reference type, it is treated as a C source. If the item
102             contains a newline or carriage return, it is treated as a C source. If
103             the item passes none of the prior tests, it is treated as a C source.
104              
105             ## implicit C source
106             my $aoa = xsv_slurp( \*STDIN, shape => 'aoa' );
107              
108             ## implicit C source
109             my $aoh = xsv_slurp( "h1,h2\n" . "d1,d2\n" );
110              
111             ## implicit C source
112             my $aoh = xsv_slurp( 'foo.csv' );
113              
114             The C parameter supports values of C, C, C or C. The
115             default shape is C. Each shape affects certain parameters differently (see
116             below).
117              
118             The C option can be used to control L/L
119             parsing. The given HASH reference is passed to the L constructor. If
120             the C option is undefined, the default L constructor is
121             called. For example, to change the separator to a colon, you could do the
122             following:
123              
124             my $aoh = xsv_slurp( file => 'foo.csv',
125             text_csv => { sep_char => ':' } );
126              
127             =head3 aoa
128              
129             =over
130              
131             example input:
132              
133             h1,h2,h3
134             l,m,n
135             p,q,r
136              
137              
138             example data structure:
139              
140             [
141             [ qw/ h1 h2 h3 / ],
142             [ qw/ l m n / ],
143             [ qw/ p q r / ],
144             ]
145              
146             shape specifics:
147              
148             =over
149              
150             =item * C - passed an ARRAY reference of indexes, should return a
151             list of indexes to be included
152              
153             =item * C - passed an ARRAY reference of values, should return true or
154             false whether the row should be included or not
155              
156             =back
157              
158             full example:
159              
160             ## - convert xSV example to an array of arrays
161             ## - include only rows containing values matching /[nr]/
162             ## - include only the first and last columns
163              
164             my $aoa = xsv_slurp( string => $xsv_data,
165             shape => 'aoa',
166             col_grep => sub { return @( shift() }[0,-1] },
167             row_grep => sub { return grep /[nr]/, @{ $_[0] } },
168             );
169              
170             ## $aoa contains:
171             ##
172             ## [
173             ## [ 'l', 'n' ],
174             ## [ 'p', 'r' ],
175             ## ]
176              
177             =back
178              
179             =head3 aoh
180              
181             =over
182              
183             example input:
184              
185             h1,h2,h3
186             l,m,n
187             p,q,r
188              
189             example data structure:
190              
191             [
192             { h1 => 'l', h2 => 'm', h3 => 'n' },
193             { h1 => 'p', h2 => 'q', h3 => 'r' },
194             ]
195              
196             shape specifics:
197              
198             =over
199              
200             =item * C - passed an ARRAY reference of column names, should return a
201             list of column names to be included
202              
203             =item * C - passed a HASH reference of column name / value pairs,
204             should return true or false whether the row should be
205             included or not
206              
207             =back
208              
209             full example:
210              
211             ## - convert xSV example to an array of hashes
212             ## - include only rows containing values matching /n/
213             ## - include only the h3 column
214              
215             my $aoh = xsv_slurp( string => $xsv_data,
216             shape => 'aoh',
217             col_grep => sub { return 'h3' },
218             row_grep => sub { return grep /n/, values %{ $_[0] } },
219             );
220              
221             ## $aoh contains:
222             ##
223             ## [
224             ## { h3 => 'n' },
225             ## ]
226              
227             =back
228              
229             =head3 hoa
230              
231             =over
232              
233             example input:
234              
235             h1,h2,h3
236             l,m,n
237             p,q,r
238              
239             example data structure:
240              
241             {
242             h1 => [ qw/ l p / ],
243             h2 => [ qw/ m q / ],
244             h3 => [ qw/ n r / ],
245             }
246              
247             shape specifics:
248              
249             =over
250              
251             =item * C - passed an ARRAY reference of column names, should return a
252             list of column names to be included
253              
254             =item * C - passed a HASH reference of column name / value pairs,
255             should return true or false whether the row should be
256             included or not
257              
258             =back
259              
260             full example:
261              
262             ## - convert xSV example to a hash of arrays
263             ## - include only rows containing values matching /n/
264             ## - include only the h3 column
265              
266             my $hoa = xsv_slurp( string => $xsv_data,
267             shape => 'hoa',
268             col_grep => sub { return 'h3' },
269             row_grep => sub { return grep /n/, values %{ $_[0] } },
270             );
271              
272             ## $hoa contains:
273             ##
274             ## {
275             ## h3 => [ qw/ n r / ],
276             ## }
277              
278             =back
279              
280             =head3 hoh
281              
282             =over
283              
284             example input:
285              
286             h1,h2,h3
287             l,m,n
288             p,q,r
289              
290             example data structure (assuming a C of C<'h2,h3'>):
291              
292             {
293             m => { n => { h1 => 'l' } },
294             q => { r => { h1 => 'p' } },
295             }
296              
297             shape specifics:
298              
299             =over
300              
301             =item * C - an xSV string or ARRAY specifying the indexing column names
302              
303             =item * C - passed an ARRAY reference of column names, should return a
304             list of column names to be included
305              
306             =item * C - passed a HASH reference of column name / value pairs,
307             should return true or false whether the row should be
308             included or not
309              
310             =item * C - specify how key collisions should be handled (see
311             L)
312              
313             =back
314              
315             full example:
316              
317             ## - convert xSV example to a hash of hashes
318             ## - index using h1 values
319             ## - include only rows containing values matching /n/
320             ## - include only the h3 column
321              
322             my $hoh = xsv_slurp( string => $xsv_data,
323             shape => 'hoh',
324             key => 'h1',
325             col_grep => sub { return 'h3' },
326             row_grep => sub { return grep /n/, values %{ $_[0] } },
327             );
328              
329             ## $hoh contains:
330             ##
331             ## {
332             ## l => { h3 => 'n' },
333             ## p => { h3 => 'r' },
334             ## }
335              
336             =back
337              
338             =head1 HoH storage handlers
339              
340             Using the C shape can result in non-unique C combinations. The default
341             action is to simply assign the values to the given slot as they are encountered,
342             resulting in any prior values being lost.
343              
344             For example, using C as the indexing key with the default collision
345             handler:
346              
347             $xsv_data = <
348             h1,h2,h3
349             1,2,3
350             1,2,5
351             EOXSV
352              
353             $hoh = xsv_slurp( string => $xsv_data,
354             shape => 'hoh',
355             key => 'h1,h2'
356             );
357            
358             would result in the initial value in the C

column being lost. The resulting

359             data structure would only record the C<5> value:
360              
361             {
362             1 => { 2 => { h3 => 5 } }, ## 3 sir!
363             }
364              
365             Typically this is not very useful. The user probably wanted to aggregate the
366             values in some way. This is where the C and C handlers
367             come in, allowing the caller to specify how these assignments should be
368             handled.
369              
370             The C handler is called for each assignment action, while the
371             C handler is only called when an actual collision occurs (i.e.,
372             the nested value path for the current line is the same as a prior line).
373              
374             If instead we wanted to push the values onto an array, we could use the built-in
375             C handler for the C event as follows:
376              
377             $hoh = xsv_slurp( string => $xsv_data,
378             shape => 'hoh',
379             key => 'h1,h2',
380             on_store => 'push',
381             );
382              
383             the resulting C, using the same data as above, would instead look like:
384              
385             {
386             1 => { 2 => { h3 => [3,5] } }, ## 3 sir!
387             }
388              
389             Or if we wanted to sum the values we could us the C handler for the
390             C event:
391              
392             $hoh = xsv_slurp( string => $xsv_data,
393             shape => 'hoh',
394             key => 'h1,h2',
395             on_collide => 'sum',
396             );
397            
398             resulting in the summation of the values:
399              
400             {
401             1 => { 2 => { h3 => 8 } },
402             }
403              
404             =head2 builtin C handlers
405              
406             A number of builtin C handlers are provided and can be specified
407             by name.
408              
409             The example data structures below use the following data.
410              
411             h1,h2,h3
412             1,2,3
413             1,2,5
414              
415             =head3 count
416              
417             Count the times a key occurs.
418              
419             { 1 => { 2 => { h3 => 2 } } }
420              
421             =head3 frequency
422              
423             Create a frequency count of values.
424              
425             { 1 => { 2 => { h3 => { 3 => 1, 5 => 1 } } } }
426              
427             =head3 push
428              
429             C values onto an array *always*.
430              
431             { 1 => { 2 => { h3 => [ 3, 5 ] } } }
432              
433             =head3 unshift
434              
435             C values onto an array *always*.
436              
437             { 1 => { 2 => { h3 => [ 5, 3 ] } } }
438              
439             =head2 builtin C handlers
440              
441             A number of builtin C handlers are provided and can be specified
442             by name.
443              
444             The example data structures below use the following data.
445              
446             h1,h2,h3
447             1,2,3
448             1,2,5
449              
450             =head3 sum
451              
452             Sum the values.
453              
454             { 1 => { 2 => { h3 => 8 } } }
455              
456             =head3 average
457              
458             Average the values.
459              
460             { 1 => { 2 => { h3 => 4 } } }
461              
462             =head3 push
463              
464             C values onto an array *only on colliding*.
465              
466             { 1 => { 2 => { h3 => [ 3, 5 ] } } }
467              
468             =head3 unshift
469              
470             C values onto an array *only on colliding*.
471              
472             { 1 => { 2 => { h3 => [ 5, 3 ] } } }
473              
474             =head3 die
475              
476             Carp::confess if a collision occurs.
477              
478             Error: key collision in HoH construction (key-value path was: { 'h1' => '1' }, { 'h2' => '2' })
479              
480             =head3 warn
481              
482             Carp::cluck if a collision occurs.
483              
484             Warning: key collision in HoH construction (key-value path was: { 'h1' => '1' }, { 'h2' => '2' })
485              
486             =cut
487              
488             my %shape_map =
489             (
490             'aoa' => \&_as_aoa,
491             'aoh' => \&_as_aoh,
492             'hoa' => \&_as_hoa,
493             'hoh' => \&_as_hoh,
494             );
495              
496             sub xsv_slurp
497             {
498 53     53 1 36400 my @o = @_;
499              
500             ## guess the source if there is an odd number of args
501 53 100       151 if ( @o % 2 )
502             {
503 1         2 my $src = shift @o;
504 1 50       7 if ( ref $src )
    50          
505             {
506 0         0 @o = ( handle => $src, @o );
507             }
508             elsif ( $src =~ /[\r\n]/ )
509             {
510 1         4 @o = ( string => $src, @o );
511             }
512             else
513             {
514 0         0 @o = ( file => $src, @o );
515             }
516             }
517              
518             ## convert argument list to option hash
519 53         151 my %o = @o;
520              
521             ## validate the source type
522 53         104 my @all_srcs = qw/ file handle string /;
523 53         87 my @given_srcs = grep { defined $o{$_} } @all_srcs;
  159         309  
524            
525 53 100       158 if ( ! @given_srcs )
    50          
526             {
527 2         217 confess "Error: no source given, specify one of: @all_srcs.";
528             }
529             elsif ( @given_srcs > 1 )
530             {
531 0         0 confess "Error: too many sources given (@given_srcs), specify only one.";
532             }
533              
534             ## validate the shape
535 51 100       132 my $shape = defined $o{'shape'} ? lc $o{'shape'} : 'aoh';
536 51         89 my $shaper = $shape_map{ $shape };
537            
538 51 100       95 if ( ! $shaper )
539             {
540 1         3 my @all_shapes = keys %shape_map;
541 1         209 confess "Error: unrecognized shape given ($shape). Must be one of: @all_shapes"
542             }
543            
544             ## check various global options for expectations
545 50 100 100     120 if ( defined $o{'col_grep'} && ref $o{'col_grep'} ne 'CODE' )
546             {
547 1         125 confess 'Error: col_grep must be a CODE ref';
548             }
549            
550 49 100 100     126 if ( defined $o{'row_grep'} && ref $o{'row_grep'} ne 'CODE' )
551             {
552 1         125 confess 'Error: row_grep must be a CODE ref';
553             }
554              
555             ## isolate the source
556 48         64 my $src = $given_srcs[0];
557            
558             ## convert the source to a handle
559 48         95 my $handle = _get_handle( $src => $o{$src} );
560            
561             ## create the CSV parser
562 47   66     259 my $csv = Text::CSV->new( $o{'text_csv'} || () );
563            
564             ## run the data conversion
565 47         4484 my $data = $shaper->( $handle, $csv, \%o );
566              
567             ## cleanup
568 42         137 close $handle;
569            
570 42         567 return $data;
571             }
572              
573             ## arguments:
574             ## $handle - file handle
575             ## $csv - the Text::CSV parser object
576             ## $o - the user options passed to xsv_slurp
577             sub _as_aoa
578             {
579 7     7   19 my ( $handle, $csv, $o ) = @_;
580            
581 7         17 my @aoa;
582              
583             my @cols;
584 7         0 my $col_grep;
585            
586 7         102 while ( my $line = $csv->getline($handle) )
587             {
588            
589             ## skip unwanted rows
590 14 100       387 if ( defined $o->{'row_grep'} )
591             {
592 6 100       14 next if ! $o->{'row_grep'}->( $line );
593             }
594            
595             ## remove unwanted cols
596 10 100       30 if ( defined $o->{'col_grep'} )
597             {
598 3 100       5 if ( ! $col_grep )
599             {
600 1         1 $col_grep++;
601 1         2 @cols = $o->{'col_grep'}->( 0 .. $#{ $line } );
  1         11  
602             }
603 3         21 @{ $line } = @{ $line }[@cols];
  3         5  
  3         6  
604             }
605              
606 10         41 push @aoa, $line;
607            
608             }
609            
610 7 50       106 if ( ! $csv->eof )
611             {
612 0         0 confess 'Error: ' . $csv->error_diag;
613             }
614            
615 7         58 return \@aoa;
616             }
617            
618             ## arguments:
619             ## $handle - file handle
620             ## $csv - the Text::CSV parser object
621             ## $o - the user options passed to xsv_slurp
622             sub _as_aoh
623             {
624 9     9   21 my ( $handle, $csv, $o ) = @_;
625              
626 9         11 my @aoh;
627            
628 9         112 my $headers = $csv->getline($handle);
629            
630 9 100       198 return \@aoh if $csv->eof;
631            
632 7 50       53 if ( ! defined $headers )
633             {
634 0         0 confess 'Error: ' . $csv->error_diag;
635             }
636            
637 7         11 my @headers = @{ $headers };
  7         29  
638              
639 7         12 my @grep_headers;
640            
641 7 100       19 if ( defined $o->{'col_grep'} )
642             {
643 1         4 @grep_headers = $o->{'col_grep'}->( @headers );
644             }
645            
646 7         37 while ( my $line = $csv->getline($handle) )
647             {
648            
649 7         147 my %line;
650            
651 7         11 @line{ @headers } = @{ $line };
  7         31  
652              
653             ## skip unwanted rows
654 7 100       20 if ( defined $o->{'row_grep'} )
655             {
656 2 100       5 next if ! $o->{'row_grep'}->( \%line );
657             }
658              
659             ## remove unwanted cols
660 6 100       25 if ( defined $o->{'col_grep'} )
661             {
662 2         5 %line = map { $_ => $line{$_} } @grep_headers;
  4         11  
663             }
664            
665 6         30 push @aoh, \%line;
666            
667             }
668            
669 7 50       76 if ( ! $csv->eof )
670             {
671 0         0 confess 'Error: ' . $csv->error_diag;
672             }
673            
674 7         43 return \@aoh;
675             }
676              
677             ## arguments:
678             ## $handle - file handle
679             ## $csv - the Text::CSV parser object
680             ## $o - the user options passed to xsv_slurp
681             sub _as_hoa
682             {
683 6     6   14 my ( $handle, $csv, $o ) = @_;
684              
685 6         7 my %hoa;
686            
687 6         63 my $headers = $csv->getline($handle);
688            
689 6 100       121 return \%hoa if $csv->eof;
690            
691 5 50       45 if ( ! defined $headers )
692             {
693 0         0 confess 'Error: ' . $csv->error_diag;
694             }
695            
696 5         9 my @headers = @{ $headers };
  5         15  
697            
698 5         8 my @grep_headers;
699            
700 5 100       16 if ( defined $o->{'col_grep'} )
701             {
702 1         3 @grep_headers = $o->{'col_grep'}->( @headers );
703 1         12 @hoa{ @grep_headers } = map { [] } @grep_headers;
  2         5  
704             }
705             else
706             {
707 4         7 @hoa{ @headers } = map { [] } @headers;
  11         25  
708             }
709            
710 5         52 while ( my $line = $csv->getline($handle) )
711             {
712 6         151 my %line;
713            
714 6         14 @line{ @headers } = @{ $line };
  6         27  
715              
716             ## skip unwanted rows
717 6 100       24 if ( defined $o->{'row_grep'} )
718             {
719 2 100       6 next if ! $o->{'row_grep'}->( \%line );
720             }
721              
722             ## remove unwanted cols
723 5 100       20 if ( defined $o->{'col_grep'} )
724             {
725 2         3 %line = map { $_ => $line{$_} } @grep_headers;
  4         10  
726             }
727              
728 5         19 for my $k ( keys %line )
729             {
730 12         18 push @{ $hoa{$k} }, $line{$k};
  12         63  
731             }
732            
733             }
734            
735 5 50       60 if ( ! $csv->eof )
736             {
737 0         0 confess 'Error: ' . $csv->error_diag;
738             }
739            
740 5         31 return \%hoa;
741             }
742              
743             my %named_handlers =
744             (
745            
746             ## predefined methods for handling hoh storage
747             on_store =>
748             {
749              
750             ## count
751             'count' => sub
752             {
753             return ( $_[HOH_HANDLER_OLD_VALUE] || 0 ) + 1;
754             },
755              
756             ## value histogram (count occurences of each value)
757             'frequency' => sub
758             {
759             my $ref = $_[HOH_HANDLER_OLD_VALUE] || {};
760             $ref->{ $_[HOH_HANDLER_NEW_VALUE] } ++;
761             return $ref;
762             },
763            
764             ## push to array
765             'push' => sub
766             {
767             my $ref = $_[HOH_HANDLER_OLD_VALUE] || [];
768             push @{ $ref }, $_[HOH_HANDLER_NEW_VALUE];
769             return $ref;
770             },
771              
772             ## unshift to array
773             'unshift' => sub
774             {
775             my $ref = $_[HOH_HANDLER_OLD_VALUE] || [];
776             unshift @{ $ref }, $_[HOH_HANDLER_NEW_VALUE];
777             return $ref;
778             },
779            
780             },
781              
782             ## predefined methods for handling hoh collisions
783             on_collide =>
784             {
785            
786             ## sum
787             'sum' => sub
788             {
789             return ( $_[HOH_HANDLER_OLD_VALUE] || 0 ) + ( $_[HOH_HANDLER_NEW_VALUE] || 0 );
790             },
791              
792             ## average
793             'average' => sub
794             {
795             if ( ! exists $_[HOH_HANDLER_SCRATCH_PAD]{'count'} )
796             {
797             $_[HOH_HANDLER_SCRATCH_PAD]{'count'} = 1;
798             $_[HOH_HANDLER_SCRATCH_PAD]{'sum'} = $_[HOH_HANDLER_OLD_VALUE];
799             }
800             $_[HOH_HANDLER_SCRATCH_PAD]{'count'}++;
801             $_[HOH_HANDLER_SCRATCH_PAD]{'sum'} += $_[HOH_HANDLER_NEW_VALUE];
802             return $_[HOH_HANDLER_SCRATCH_PAD]{'sum'} / $_[HOH_HANDLER_SCRATCH_PAD]{'count'};
803             },
804              
805             ## die
806             'die' => sub
807             {
808             if ( defined $_[HOH_HANDLER_OLD_VALUE] )
809             {
810             my @kv_pairs = @{ $_[HOH_HANDLER_KEY_VALUE_PATH] };
811             my @kv_strings = map { "{ '$_->[0]' => '$_->[1]' }" } @kv_pairs;
812             my $kv_path = join ', ', @kv_strings;
813             confess "Error: key collision in HoH construction (key-value path was: $kv_path)";
814             }
815             },
816              
817             ## warn
818             'warn' => sub
819             {
820             if ( defined $_[HOH_HANDLER_OLD_VALUE] )
821             {
822             my @kv_pairs = @{ $_[HOH_HANDLER_KEY_VALUE_PATH] };
823             my @kv_strings = map { "{ '$_->[0]' => '$_->[1]' }" } @kv_pairs;
824             my $kv_path = join ', ', @kv_strings;
825             cluck "Warning: key collision in HoH construction (key-value path was: $kv_path)";
826             }
827             return $_[HOH_HANDLER_NEW_VALUE];
828             },
829              
830             ## push to array
831             'push' => sub
832             {
833             my $ref = ref $_[HOH_HANDLER_OLD_VALUE]
834             ? $_[HOH_HANDLER_OLD_VALUE]
835             : [ $_[HOH_HANDLER_OLD_VALUE] ];
836             push @{ $ref }, $_[HOH_HANDLER_NEW_VALUE];
837             return $ref;
838             },
839              
840             ## unshift to array
841             'unshift' => sub
842             {
843             my $ref = ref $_[HOH_HANDLER_OLD_VALUE]
844             ? $_[HOH_HANDLER_OLD_VALUE]
845             : [ $_[HOH_HANDLER_OLD_VALUE] ];
846             unshift @{ $ref }, $_[HOH_HANDLER_NEW_VALUE];
847             return $ref;
848             },
849            
850             },
851              
852             );
853              
854             ## arguments:
855             ## $handle - file handle
856             ## $csv - the Text::CSV parser object
857             ## $o - the user options passed to xsv_slurp
858             sub _as_hoh
859             {
860 25     25   49 my ( $handle, $csv, $o ) = @_;
861              
862 25         34 my %hoh;
863            
864 25         336 my $headers = $csv->getline($handle);
865            
866 25 100       613 return \%hoh if $csv->eof;
867            
868 24 50       147 if ( ! defined $headers )
869             {
870 0         0 confess 'Error: ' . $csv->error_diag;
871             }
872            
873 24         29 my @headers = @{ $headers };
  24         77  
874            
875 24         32 my @grep_headers;
876            
877 24 100       66 if ( defined $o->{'col_grep'} )
878             {
879 1         5 @grep_headers = $o->{'col_grep'}->( @headers );
880             }
881              
882 24         53 my @key;
883            
884 24 50       76 if ( ref $o->{'key'} )
    100          
885             {
886            
887 0         0 @key = @{ $o->{'key'} };
  0         0  
888            
889             }
890             elsif ( defined $o->{'key'} )
891             {
892            
893 23 50       87 if ( ! $csv->parse( $o->{'key'} ) )
894             {
895 0         0 confess 'Error: ' . $csv->error_diag;
896             }
897            
898 23         493 @key = $csv->fields;
899              
900             }
901             else
902             {
903 1         88 confess 'Error: no key given for hoh shape';
904             }
905              
906             ## set the on_collide handler at the default level and by header
907 23         153 my %storage_handlers;
908              
909 23         48 for my $header ( @headers )
910             {
911            
912 66         93 for my $type ( qw/ on_store on_collide / )
913             {
914            
915 131         156 my $handler = $o->{$type};
916              
917 131 100       210 next if ! $handler;
918            
919 51 100       92 if ( ref $handler eq 'HASH' )
920             {
921 14         17 $handler = $handler->{$header};
922             }
923            
924 51 100       72 next if ! $handler;
925              
926 47 100       67 if ( ! ref $handler )
927             {
928              
929 44 100       73 if ( ! exists $named_handlers{$type}{$handler} )
930             {
931 2         3 my $all_names = join ', ', sort keys %{ $named_handlers{$type} };
  2         14  
932 2         223 confess "Error: invalid '$type' handler given ($handler). Must be one of: $all_names."
933             }
934              
935 42         55 $handler = $named_handlers{$type}{$handler};
936             }
937            
938             confess "Error: cannot set multiple storage handlers for '$header'"
939 45 100       164 if $storage_handlers{$header};
940              
941 44         100 $storage_handlers{$header}{$type} = $handler;
942            
943             }
944              
945             }
946            
947             ## per-header scratch-pads used in collision functions
948 20         33 my %scratch_pads = map { $_ => {} } @headers;
  63         128  
949              
950 20         89 while ( my $line = $csv->getline($handle) )
951             {
952            
953 55         1092 my %line;
954            
955 55         79 @line{ @headers } = @{ $line };
  55         179  
956            
957             ## skip unwanted rows
958 55 100       130 if ( defined $o->{'row_grep'} )
959             {
960 2 100       6 next if ! $o->{'row_grep'}->( \%line );
961             }
962              
963             ## step through the nested keys
964 54         89 my $leaf = \%hoh;
965            
966 54         60 my @val;
967            
968 54         68 for my $k ( @key )
969             {
970            
971 101         132 my $v = $line{$k};
972 101   100     281 $leaf->{$v} ||= {};
973 101         110 $leaf = $leaf->{$v};
974            
975 101         155 push @val, $v;
976            
977             }
978            
979             ## remove key headers from the line
980 54         97 delete @line{ @key };
981            
982             ## remove unwanted cols
983 54 100       91 if ( defined $o->{'col_grep'} )
984             {
985 2         3 %line = map { $_ => $line{$_} } @grep_headers;
  2         23  
986             }
987              
988             ## perform the aggregation if applicable
989 54         146 for my $key ( keys %line )
990             {
991              
992 73         93 my $new_value = $line{$key};
993              
994 73         89 my $on_collide = $storage_handlers{$key}{'on_collide'};
995 73         80 my $on_store = $storage_handlers{$key}{'on_store'};
996            
997 73 100 100     199 if ( $on_store || $on_collide && exists $leaf->{$key} )
      100        
998             {
999            
1000 47   66     89 my $handler = $on_collide || $on_store;
1001              
1002             $new_value = $handler->(
1003             $key, ## HOH_HANDLER_KEY
1004             [ map [ $key[$_] => $val[$_] ], 0 .. $#key ], ## HOH_HANDLER_KEY_VALUE_PATH
1005             $leaf->{$key}, ## HOH_HANDLER_OLD_VALUE
1006             $new_value, ## HOH_HANDLER_NEW_VALUE
1007             \%line, ## HOH_HANDLER_LINE_HASH
1008             \%hoh, ## HOH_HANDLER_HOH
1009 47         208 $scratch_pads{$key}, ## HOH_HANDLER_SCRATCH_PAD
1010             );
1011              
1012             }
1013              
1014 72         372 $leaf->{$key} = $new_value;
1015              
1016             }
1017            
1018             }
1019            
1020 19 50       212 if ( ! $csv->eof )
1021             {
1022 0         0 confess 'Error: ' . $csv->error_diag;
1023             }
1024            
1025 19         155 return \%hoh;
1026             }
1027              
1028             ## arguments:
1029             ## $src_type - type of data source, handle, string or file
1030             ## $src_value - the file name, file handle or xSV string
1031             sub _get_handle
1032             {
1033 48     48   83 my ( $src_type, $src_value ) = @_;
1034              
1035 48 50       102 if ( $src_type eq 'handle' )
1036             {
1037 0         0 return $src_value;
1038             }
1039              
1040 48 100       121 if ( $src_type eq 'string' )
1041             {
1042 47         217 my $handle = IO::String->new( $src_value );
1043 47         1850 return $handle;
1044             }
1045              
1046 1 50       3 if ( $src_type eq 'file' )
1047             {
1048 1 50       197 open( my $handle, '<', $src_value ) || confess "Error: could not open '$src_value': $!";
1049 0           return $handle;
1050             }
1051              
1052 0           confess "Error: could not determine source type";
1053             }
1054              
1055             =head1 AUTHOR
1056              
1057             Dan Boorstein, C<< >>
1058              
1059             =head1 TODO
1060              
1061             =over
1062              
1063             =item * add xsv_eruct() to dump shapes to xsv data
1064              
1065             =item * add weighted-average collide keys and tests
1066              
1067             =item * document hoh 'on_store/on_collide' custom keys
1068              
1069             =item * add a recipes/examples section to cover grep and on_collide examples
1070              
1071             =back
1072              
1073             =head1 BUGS
1074              
1075             Please report any bugs or feature requests to C, or through
1076             the web interface at L. I will be notified, and then you'll
1077             automatically be notified of progress on your bug as I make changes.
1078              
1079              
1080             =head1 SUPPORT
1081              
1082             You can find documentation for this module with the perldoc command.
1083              
1084             perldoc Text::xSV::Slurp
1085              
1086              
1087             You can also look for information at:
1088              
1089             =over 4
1090              
1091             =item * RT: CPAN's request tracker
1092              
1093             L
1094              
1095             =item * AnnoCPAN: Annotated CPAN documentation
1096              
1097             L
1098              
1099             =item * CPAN Ratings
1100              
1101             L
1102              
1103             =item * Search CPAN
1104              
1105             L
1106              
1107             =back
1108              
1109              
1110             =head1 ACKNOWLEDGEMENTS
1111              
1112              
1113             =head1 COPYRIGHT & LICENSE
1114              
1115             Copyright 2009 Dan Boorstein.
1116              
1117             This program is free software; you can redistribute it and/or modify it
1118             under the terms of either: the GNU General Public License as published
1119             by the Free Software Foundation; or the Artistic License.
1120              
1121             See http://dev.perl.org/licenses/ for more information.
1122              
1123              
1124             =cut
1125              
1126             1; # End of Text::xSV::Slurp