Lines 17-26
Link Here
|
17 |
# with Koha; if not, write to the Free Software Foundation, Inc., |
17 |
# with Koha; if not, write to the Free Software Foundation, Inc., |
18 |
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
18 |
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
19 |
|
19 |
|
20 |
|
20 |
use Modern::Perl; |
21 |
use CGI qw/-utf8/; |
21 |
use CGI qw/-utf8/; |
22 |
use Text::CSV; |
22 |
use Text::CSV::Encoded; |
23 |
use URI::Escape; |
23 |
use URI::Escape; |
|
|
24 |
use File::Temp; |
25 |
use File::Basename qw( dirname ); |
24 |
use C4::Reports::Guided; |
26 |
use C4::Reports::Guided; |
25 |
use C4::Auth qw/:DEFAULT get_session/; |
27 |
use C4::Auth qw/:DEFAULT get_session/; |
26 |
use C4::Output; |
28 |
use C4::Output; |
Lines 764-800
elsif ($phase eq 'Run this report'){
Link Here
|
764 |
} |
766 |
} |
765 |
|
767 |
|
766 |
elsif ($phase eq 'Export'){ |
768 |
elsif ($phase eq 'Export'){ |
767 |
binmode STDOUT, ':encoding(UTF-8)'; |
|
|
768 |
|
769 |
|
769 |
# export results to tab separated text or CSV |
770 |
# export results to tab separated text or CSV |
770 |
my $sql = $input->param('sql'); # FIXME: use sql from saved report ID#, not new user-supplied SQL! |
771 |
my $sql = $input->param('sql'); # FIXME: use sql from saved report ID#, not new user-supplied SQL! |
771 |
my $format = $input->param('format'); |
772 |
my $format = $input->param('format'); |
772 |
my ($sth, $q_errors) = execute_query($sql); |
773 |
my ($sth, $q_errors) = execute_query($sql); |
773 |
unless ($q_errors and @$q_errors) { |
774 |
unless ($q_errors and @$q_errors) { |
774 |
print $input->header( -type => 'application/octet-stream', |
775 |
my ( $type, $content ); |
775 |
-attachment=>"reportresults.$format" |
|
|
776 |
); |
777 |
if ($format eq 'tab') { |
776 |
if ($format eq 'tab') { |
778 |
print join("\t", header_cell_values($sth)), "\n"; |
777 |
$type = 'application/octet-stream'; |
|
|
778 |
$content .= join("\t", header_cell_values($sth)) . "\n"; |
779 |
while (my $row = $sth->fetchrow_arrayref()) { |
779 |
while (my $row = $sth->fetchrow_arrayref()) { |
780 |
print join("\t", @$row), "\n"; |
780 |
$content .= join("\t", @$row) . "\n"; |
781 |
} |
781 |
} |
782 |
} else { |
782 |
} else { |
783 |
my $csv = Text::CSV->new({binary => 1}); |
783 |
my $delimiter = C4::Context->preference('delimiter') || ','; |
784 |
$csv or die "Text::CSV->new({binary => 1}) FAILED: " . Text::CSV->error_diag(); |
784 |
if ( $format eq 'csv' ) { |
785 |
if ($csv->combine(header_cell_values($sth))) { |
785 |
$type = 'application/csv'; |
786 |
print $csv->string(), "\n"; |
786 |
my $csv = Text::CSV::Encoded->new({ encoding_out => 'utf8', sep_char => $delimiter}); |
787 |
} else { |
787 |
$csv or die "Text::CSV::Encoded->new({binary => 1}) FAILED: " . Text::CSV::Encoded->error_diag(); |
788 |
push @$q_errors, { combine => 'HEADER ROW: ' . $csv->error_diag() } ; |
788 |
if ($csv->combine(header_cell_values($sth))) { |
789 |
} |
789 |
$content .= $csv->string(). "\n"; |
790 |
while (my $row = $sth->fetchrow_arrayref()) { |
|
|
791 |
if ($csv->combine(@$row)) { |
792 |
print $csv->string(), "\n"; |
793 |
} else { |
790 |
} else { |
794 |
push @$q_errors, { combine => $csv->error_diag() } ; |
791 |
push @$q_errors, { combine => 'HEADER ROW: ' . $csv->error_diag() } ; |
|
|
792 |
} |
793 |
while (my $row = $sth->fetchrow_arrayref()) { |
794 |
if ($csv->combine(@$row)) { |
795 |
$content .= $csv->string() . "\n"; |
796 |
} else { |
797 |
push @$q_errors, { combine => $csv->error_diag() } ; |
798 |
} |
795 |
} |
799 |
} |
796 |
} |
800 |
} |
|
|
801 |
elsif ( $format eq 'ods' ) { |
802 |
$type = 'application/vnd.oasis.opendocument.spreadsheet'; |
803 |
my $ods_fh = File::Temp->new( UNLINK => 0 ); |
804 |
my $ods_filepath = $ods_fh->filename; |
805 |
|
806 |
use OpenOffice::OODoc; |
807 |
my $tmpdir = dirname $ods_filepath; |
808 |
odfWorkingDirectory( $tmpdir ); |
809 |
my $container = odfContainer( $ods_filepath, create => 'spreadsheet' ); |
810 |
my $doc = odfDocument ( |
811 |
container => $container, |
812 |
part => 'content' |
813 |
); |
814 |
my $table = $doc->getTable(0); |
815 |
my @headers = header_cell_values( $sth ); |
816 |
my $rows = $sth->fetchall_arrayref(); |
817 |
my ( $nb_rows, $nb_cols ) = ( scalar(@$rows), scalar(@{$rows->[0]}) ); |
818 |
$doc->expandTable( $table, $nb_rows, $nb_cols ); |
819 |
|
820 |
my $row = $doc->getRow( $table, 0 ); |
821 |
my $j = 0; |
822 |
for my $header ( @headers ) { |
823 |
$doc->cellValue( $row, $j, $header ); |
824 |
$j++; |
825 |
} |
826 |
for ( my $i = 1; $i < $nb_rows +1 ; $i++ ) { |
827 |
$row = $doc->getRow( $table, $i ); |
828 |
for ( my $j = 0 ; $j < $nb_cols ; $j++ ) { |
829 |
# FIXME Bug 11944 |
830 |
my $value = Encode::encode( 'UTF8', $rows->[$i - 1][$j] ); |
831 |
$doc->cellValue( $row, $j, $value ); |
832 |
} |
833 |
} |
834 |
$doc->save(); |
835 |
binmode(STDOUT); |
836 |
open $ods_fh, '<', $ods_filepath; |
837 |
$content .= $_ while <$ods_fh>; |
838 |
unlink $ods_filepath; |
839 |
} |
797 |
} |
840 |
} |
|
|
841 |
print $input->header( |
842 |
-type => $type, |
843 |
-attachment=>"reportresults.$format" |
844 |
); |
845 |
print $content; |
846 |
|
798 |
foreach my $err (@$q_errors, @errors) { |
847 |
foreach my $err (@$q_errors, @errors) { |
799 |
print "# ERROR: " . (map {$_ . ": " . $err->{$_}} keys %$err) . "\n"; |
848 |
print "# ERROR: " . (map {$_ . ": " . $err->{$_}} keys %$err) . "\n"; |
800 |
} # here we print all the non-fatal errors at the end. Not super smooth, but better than nothing. |
849 |
} # here we print all the non-fatal errors at the end. Not super smooth, but better than nothing. |
Lines 852-857
sub header_cell_values {
Link Here
|
852 |
my $sth = shift or return (); |
901 |
my $sth = shift or return (); |
853 |
my @cols; |
902 |
my @cols; |
854 |
foreach my $c (@{$sth->{NAME}}) { |
903 |
foreach my $c (@{$sth->{NAME}}) { |
|
|
904 |
# TODO in Bug 11944 |
855 |
#FIXME apparently DBI still needs a utf8 fix for this? |
905 |
#FIXME apparently DBI still needs a utf8 fix for this? |
856 |
utf8::decode($c); |
906 |
utf8::decode($c); |
857 |
push @cols, $c; |
907 |
push @cols, $c; |
858 |
- |
|
|