File Coverage

blib/lib/CGI/Application/Plugin/Output/XSV.pm

Criterion	Covered	Total	%
statement	104	108	96.3
branch	62	64	96.8
condition	29	30	96.6
subroutine	10	10	100.0
pod	4	4	100.0
total	209	216	96.7

package CGI::Application::Plugin::Output::XSV;

use strict;
use warnings;

use Carp;
require Text::CSV_XS;
require Exporter;

our @ISA= qw(Exporter);

our @EXPORT= qw(
  xsv_report_web
);

our @EXPORT_OK= qw(
  add_to_xsv
  clean_field_names
  xsv_report
);

our %EXPORT_TAGS= (
  all => [ @EXPORT, @EXPORT_OK ],
);

our $VERSION= '1.02';

##

sub xsv_report {
  my $args = shift || {};

  croak "argument to xsv_report must be a hash reference"
    if ref( $args ) ne 'HASH';

  my %defaults = (
    headers         => undef,
    headers_cb      => \&clean_field_names,
    include_headers => 1,
    fields          => undef,
    values          => undef,
    row_filter      => undef,
    iterator        => undef,
    line_ending     => "\n",
    csv_opts        => {},
    maximum_iters   => 1_000_000, # XXX reasonable default?
    stream          => 0,
  );

  my %opts = ( %defaults, %$args );

  my $was_buffering = $|;
  local $| = $was_buffering;
  $| = 1 if $opts{stream};

  # deprecated option
  if ( $opts{get_row_cb} ) {
    if ( $opts{row_filter} ) {
      carp "ignoring use of deprecated get_row_cb when row_filter specified";
    }
    else {
      $opts{row_filter} = $opts{get_row_cb};
      carp "get_row_cb is deprecated, please use row_filter instead";
    }
  }

  croak "need array reference of values or iterator to do anything"
    if   ! ( $opts{values}   && ref( $opts{values} )   eq 'ARRAY' )
      && ! ( $opts{iterator} && ref( $opts{iterator} ) eq 'CODE'  );

  croak "can't supply both values and iterator"
    if $opts{values} && $opts{iterator};

  # list of fields to include in report
  my $fields = [];

  if ( $opts{fields} ) {
    # user-specified
    $fields = $opts{fields};
  }
  elsif ( $opts{values} ) {
    # try to determine field names from provided values
    if ( @{ $opts{values} } ) {
      my $list_type = ref( $opts{values}[0] );

      # field list from first entry in value list
      if ( $list_type eq 'HASH' ) {
        $fields = [ keys %{ $opts{values}[0] } ];
      }
      # or simply array indices
      elsif ( $list_type eq 'ARRAY' ) {
        $fields = [ 0..$#{$opts{values}[0]} ];
      }
      else {
        croak "unknown list type [$list_type]";
      }
    }
    else {
      croak "can't determine field names (values is an empty list), aborting";
    }
  }
  else {
    # using iterator, empty field list
  }

  # function to filter each row of data from $opts{values}
  my $row_filter;

  if ( $opts{row_filter} ) {
    # user-specified
    $row_filter = $opts{row_filter};
  }
  elsif ( $opts{values} && @{ $opts{values} } ) {
    # simple defaults for slices
    my $list_type = ref( $opts{values}[0] );

    if ( $list_type eq 'HASH' ) {
      $row_filter = sub { my ($row, $fields)= @_; return [ @$row{@$fields} ] };
    }
    elsif ( $list_type eq 'ARRAY' ) {
      $row_filter = sub { my ($row, $fields)= @_; return [ @$row[@$fields] ] };
    }
    else {
      croak "unknown list type [$list_type]";
    }
  }
  else {
    # using iterator, no filter
    $row_filter = sub { $_[0] };
  }

  my $csv = Text::CSV_XS->new( $opts{csv_opts} );
  my $output = '';

  if ( $opts{include_headers} ) {
    if ( ! $opts{headers} ) {
      if ( ! ($opts{headers_cb} && ref( $opts{headers_cb} ) eq 'CODE') ) {
        croak "need headers or headers_cb to include headers";
      }
      elsif ( ! @{$fields} ) {
        carp "passing empty fields list to headers_cb";
      }
    }

    # formatted column headers
    my $readable_headers = $opts{headers} || $opts{headers_cb}->( $fields )
      or croak "can't generate headers";

    croak "return value from headers_cb is not an array reference, aborting"
      if ref ( $readable_headers ) ne 'ARRAY';

    $output .= add_to_xsv( $csv, $readable_headers, $opts{line_ending} );

    if ( $opts{stream} ) {
      print $output;
      $output = '';
    }
  }

  if ( $opts{values} ) {
    foreach my $list_ref ( @{ $opts{values} } ) {
      $output .= add_to_xsv(
        $csv, $row_filter->($list_ref, $fields), $opts{line_ending}
      );

      if ( $opts{stream} ) {
        print $output;
        $output = '';
      }
    }
  }
  # using iterator
  else {
    my $iterations = 0;

    while ( my $list_ref = $opts{iterator}->($fields) ) {
      croak "return value from iterator is not an array reference, aborting"
        if ref( $list_ref ) ne 'ARRAY';

      # XXX infinite loop?
      croak "iterator exceeded maximum iterations ($opts{maximum_iters})"
        if ++$iterations > $opts{maximum_iters};

      $output .= add_to_xsv(
        $csv, $row_filter->($list_ref, $fields), $opts{line_ending}
      );

      if ( $opts{stream} ) {
        print $output;
        $output = '';
      }
    }
  }

  return $output;
}

# send xsv output directly to browser for download
# same params as xsv_report, plus
#   filename => 'download.csv',
sub xsv_report_web {
  my ($self, $args) = @_;
  $args ||= {};

  croak "argument to xsv_report_web must be a hash reference"
    if ref( $args ) ne 'HASH';

  my %defaults = (
    filename => 'download.csv',
  );

  my %opts = ( %defaults, %$args );

  my %headers = (
    -type                  => 'application/x-csv',
    '-content-disposition' => "attachment; filename=$opts{filename}",
  );

  # we're doing our own output
  if ( $opts{stream} ) {
    $self->header_type('none');
    print $self->query->header( %headers );
  }
  else {
    $self->header_props( %headers );
  }

  # consider use of magic goto in case of croak() inside xsv_report
  return xsv_report( \%opts );
}

# default field name generator:
#   underscores to spaces, upper case first letter of each word
sub clean_field_names {
  my $fields = shift;

  # using temp var to avoid modifying $fields
  my @fields_copy = @{$fields};

  return [
    map { tr/_/ /; s/\b(\w+)/\u$1/g; $_ } @fields_copy
  ];
}

sub add_to_xsv {
  my ($csv, $fields, $line_ending) = @_;
  croak "add_to_xsv: fields argument (required) must be an array reference"
    if ! ($fields && ref( $fields ) eq 'ARRAY');

  # XXX redundant for empty string (or 0)
  $line_ending ||= '';

  return $line_ending if ! @{$fields};

  $csv->combine( @{$fields} )
    or croak "Failed to add [@{$fields}] to csv: " . $csv->error_input();

  return $csv->string() . $line_ending;
}

1;

__END__