File Coverage

blib/lib/DBIx/Array/Export.pm
Criterion Covered Total %
statement 9 70 12.8
branch 0 22 0.0
condition 0 4 0.0
subroutine 3 10 30.0
pod 5 5 100.0
total 17 111 15.3


line stmt bran cond sub pod time code
1             package DBIx::Array::Export;
2 1     1   1221 use base qw{DBIx::Array};
  1         2  
  1         150  
3 1     1   15 use strict;
  1         2  
  1         20  
4 1     1   5 use warnings;
  1         1  
  1         915  
5              
6             our $VERSION='0.64';
7             our $PACKAGE=__PACKAGE__;
8              
9             =head1 NAME
10              
11             DBIx::Array::Export - Extends DBIx::Array with convenient export functions
12              
13             =head1 SYNOPSIS
14              
15             use DBIx::Array::Export;
16             my $dbx=DBIx::Array::Export->new;
17             $dbx->connect($connection, $user, $pass, \%opt); #passed to DBI
18              
19             =head1 DESCRIPTION
20              
21             =head1 USAGE
22              
23             =head1 METHODS (Export)
24              
25             =head2 xml_arrayhashname
26              
27             Returns XML given an arrayhashname data structure
28            
29             $dbx->execute(q{ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD"T"HH24:MI:SS"Z"'});
30             my @arrayhashname=$dbx->sqlarrayhashname($sql);
31             my $xml=$dbx->xml_arrayhashname(data => \@arrayhashname,
32             comment => "Text String Comment",
33             uom => {col1=>"min", col2=>"ft"});
34              
35             =cut
36              
37             sub xml_arrayhashname {
38 0     0 1   my $self=shift;
39 0           my $opt={@_};
40 0   0       my $data=$opt->{'data'} || [];
41 0 0         $data=[] unless ref($data) eq "ARRAY";
42 0   0       my $uom=$opt->{'uom'} || {};
43 0 0         $uom={} unless ref($uom) eq "HASH";
44              
45 0           my $header=shift(@$data);
46 0           foreach (@$data) {
47 0           foreach my $key (keys %$_) {
48 0 0         if (defined($_->{$key})) {
49 0           $_->{$key}=[$_->{$key}]; #This is needed for XML::Simple to make pretty XML.
50             } else {
51 0           CORE::delete($_->{$key}); #This is a choice that I made but I'm not sure if it's smart
52             }
53             }
54             }
55 0 0         @$header=map {exists($uom->{$_})? {content=>$_, uom=>$uom->{$_}} : $_} @$header;
  0            
56              
57 0           my $module="XML::Simple";
58 0           eval("use $module;");
59 0 0         if ($@) {
60 0           die("Error: $PACKAGE->xml_arrayhashname method requres $module");
61             } else {
62 0           my $xs=XML::Simple->new(XMLDecl=>1, RootName=>q{document}, ForceArray=>1);
63 0           my $head={};
64 0 0         $head->{'comment'}=[$opt->{'comment'}] if $opt->{'comment'};
65 0           $head->{'columns'}=[{column=>$header}];
66 0           $head->{'counts'}=[{rows=>[scalar(@$data)], columns=>[scalar(@$header)]}];
67 0           return $xs->XMLout({
68             head=>$head,
69             body=>{rows=>[{row=>$data}]},
70             });
71             }
72             }
73              
74             =head2 csv_arrayarrayname
75              
76             Returns CSV given an arrayarrayname data structure
77              
78             my $csv=$dbx->csv_arrayarrayname($data);
79              
80             =cut
81              
82 0           sub csv_arrayarrayname {
83 0     0 1   my $self=shift;
84 0           my $data=shift;
85 0           return join "", map {&_join_csv($self->_csv, @$_)} @$data;
  0            
86              
87             sub _join_csv {
88 0     0     my $csv=shift;
89 0           my $status=$csv->combine(@_);
90 0 0         return $status ? $csv->string."\r\n" : (); #\r\n per RFC 4180
91             }
92             }
93              
94             =head2 csv_cursor
95              
96             Writes CSV to file handle given an executed cursor (with header row from $sth)
97              
98             binmode($fh);
99             $dbx->csv_cursor($fh, $sth);
100              
101             Due to portability issues, I choose not to force the passed file handle into binmode. However, it IS required! For most file handle objects you can run binmode($fh) or $fh->binmode;
102              
103             =cut
104              
105             sub csv_cursor {
106 0     0 1   my $self=shift;
107 0           my $fh=shift;
108 0           my $sth=shift;
109 0           $self->_csv->print($fh, scalar($sth->{'NAME'}));
110 0           print $fh "\r\n";
111 0           $self->csvappend_cursor($fh, $sth);
112             }
113              
114             =head2 csvappend_cursor
115              
116             Appends CSV to file handle given an executed cursor (no header row)
117              
118             binmode($fh);
119             $dbx->csvappend_cursor($fh, $sth);
120              
121             =cut
122              
123             sub csvappend_cursor {
124 0     0 1   my $self=shift;
125 0           my $fh=shift;
126 0           my $sth=shift;
127 0           my $row=[];
128 0           local $|=0;
129 0           while ($row=$sth->fetchrow_arrayref()) {
130 0           $self->_csv->print($fh, $row);
131 0           print $fh "\r\n";
132             }
133 0           $sth->finish;
134             }
135              
136             sub _csv {
137 0     0     my $self=shift;
138 0 0         $self->{"_csv"}=shift if @_;
139 0           eval("use Text::CSV_XS;");
140 0 0         die("Error: CSV Export Methods requre Text::CSV_XS") if $@;
141 0 0         $self->{"_csv"}=Text::CSV_XS->new unless defined $self->{"_csv"};
142 0           return $self->{"_csv"};
143             }
144              
145             =head2 xls_arrayarrayname
146              
147             Returns XLS data blob given an arrayarrayname data structure
148              
149             my $xls=$dbx->xls_arrayarrayname("Tab One"=>$data, "Tab Two"=>$data2, ...);
150              
151             =cut
152              
153             sub xls_arrayarrayname {
154 0     0 1   my $self=shift;
155 0           my $module="Spreadsheet::WriteExcel::Simple::Tabs";
156 0           eval("use $module;");
157 0 0         if ($@) {
158 0           die("Error: $PACKAGE->xls_arrayarrayname method requres $module");
159             } else {
160 0           my $ss=Spreadsheet::WriteExcel::Simple::Tabs->new();
161 0           $ss->add(@_);
162 0           return $ss->content;
163             }
164             }
165              
166             =head1 TODO
167              
168             Switch out L for L
169              
170             =head1 BUGS
171              
172             Send email to author and log on RT.
173              
174             =head1 SUPPORT
175              
176             DavisNetworks.com supports all Perl applications big or small.
177              
178             =head1 AUTHOR
179              
180             Michael R. Davis
181             CPAN ID: MRDVT
182             STOP, LLC
183             domain=>stopllc,tld=>com,account=>mdavis
184             http://www.stopllc.com/
185              
186             =head1 COPYRIGHT
187              
188             This program is free software licensed under the...
189              
190             The BSD License
191              
192             The full text of the license can be found in the LICENSE file included with this module.
193              
194             =head1 SEE ALSO
195              
196             =head2 Building Blocks
197              
198             L, L, L
199              
200             =head2 Similar Capabilities
201              
202             L see csv and tsv methods, L
203              
204             =cut
205              
206             1;