package DBIx::Class::Helper::ResultSet::CrossTab;

# ABSTRACT: helper to simulate crosstab

use strict;
use warnings;

use parent 'DBIx::Class::ResultSet';
{
    package DBIx::Class::ResultSet;

    use Data::Dump qw/dump/;

    my $quote = sub { return "'" . $_[0] . "'" };
    
    sub crosstab {
	my $self  = shift;
	my $query = shift;
	my $opts  = shift;

	$quote = sub { return $self->result_source->storage->dbh->quote( $_[0]) };
	my @values;

	if ($opts->{in} && scalar @{$opts->{in}}) {
	    @values = map {
		my %h;
		@h{@{$opts->{on}}} = ref $_ ? @{$_} : ($_);
		\%h;
	    } @{$opts->{in}};
	} else {
	    my $v = $self->search($query, { columns => $opts->{on}, group_by => $opts->{on}, order_by => $opts->{on} });
	    $v->result_class('DBIx::Class::ResultClass::HashRefInflator');
	    @values = map {
		my %h;
		@h{@{$opts->{on}}} = @{$_}{@{$opts->{on}}};
		\%h;
	    } $v->all;
	}

	my @funcs = @{ $opts->{pivot}};

	my @cross_select = map { my $f = $_; map { $self->_ref_to_cross($f, $_) } @values } @funcs;
	my @cross_as     = map { $self->_ref_to_as($_) } @cross_select;
	
	my $re = quotemeta($opts->{on}->[0]);
	my (@as, @select);
	@select = map { ref $_ ? $self->_ref_to_literal($_) : $_ } grep { !/$re/ } @{$self->_resolved_attrs->{select}};
	@as     = map { ref $_ ? $self->_ref_to_as($_) : $_ } @select;

	my $cross = $self
	    ->search($query, {
			  'select' => [ @select, @cross_select ],
			  'as'     => [ @as, @cross_as ],
			  group_by => $opts->{group_by}
			 });
	my ($sql, @bind) = @{${$cross->as_query}};
	$sql =~ s/^\s*\((.*)\)\s*$/($1)/;

	my $alias = \[ $sql , @bind ];
	return $self->result_source->resultset->search(undef, {
							       alias => $self->current_source_alias,
							       from => [{
									 $self->current_source_alias => $alias,
									 -alias                      => $self->current_source_alias,
									 -source_handle              => $self->result_source->handle,
									}],
							       result_class => $self->result_class,
							       'as'     => [ @as, @cross_as ],
							       'select' => [ @as, @cross_as ],
							      })
    }

    use String::SQLColumnName qw/fix_name/;

    sub _ref_to_cross {
	my $self = shift;
	my $function = shift;
	my $value    = shift;

	my $when = join ' AND ', map { $_ . '=' . $quote->($value->{$_}) } keys %$value;
	my $pivot = join '_', map { $value->{$_} } sort keys %$value;
	
	for (ref $function) {
	    my $res;
	    /HASH/ && do {
		my ($func, $arg) = (%{$function});
		my $as = fix_name(join '_', $func, $arg, $pivot);
		my $res = sprintf "%s (CASE WHEN %s then %s ELSE NULL END) as %s",        $func, $when, $arg, $as;
		return \$res;
	    };
	    /SCALAR/ && do {
		my ($func, $distinct, $arg, $as) = parse_statement($$function);
		$as = fix_name(join '_', $as, $pivot);
		my $res = sprintf "%s ( %s (CASE WHEN %s then %s ELSE NULL END) ) as %s", $func, $distinct, $when, $arg, $as;
		return \$res;
	    };
	};
    }

    sub parse_statement {
	local $_ = shift;
	
	my ($distinct, $as);

	# get 'distinct' or 'all' in function
	if (s/\((distinct)\s/\(/i) { $distinct = $1 }
	if (s/\((all)\s/\(/i)      { $distinct = $1 }
	$distinct ||= 'all';
	
	# get 'as' part
	if (s/\sas\s+(.+)//i) { $as = $1 }

	# get function (word followed by round bracket)
	# and arguments (the part between the first and last brackets)
	my ($func, $arg) = ($_ =~ /\s*(\w+)\s*\(\s*(.+?)\s*\)\s*$/i);

	# eliminate the me.something from as to make a good
	# string for the as part
	my $arg_as = $arg;
	for ($arg_as) { s/\w+?\.//g; s/\W+/_/g;  };
	
	$as ||= join '_', $func, $distinct, $arg_as;
	for ($as) { s/__+/_/g; s/_+$//; }
	
	return $func, $distinct, $arg, $as;
    }

    
    sub _ref_to_literal {
	my $self = shift;
	my $function = shift;
	for (ref $function) {
	    /HASH/ && do {
		my ($func, $field) = (%{$function});
		my $as = fix_name(join '_', $func, $field);
		my $res = sprintf "%s (%s) as %s", $func, $field, $as;
		return \$res;
	    };
	    /SCALAR/ && do {
		my ($func, $distinct, $arg, $as) = parse_statement($$function);
		my $res = sprintf "%s ( %s %s ) as %s", $func, $distinct, $arg, $as;
		return \$res;
	    };
	};
    };

    sub _ref_to_as {
	my $self = shift;
	my $function = shift;
	for (ref $function) {
	    /HASH/ && do {
		my ($func, $field) = (%{$function});
		return join '_', $func, $field;
	    };
	    /SCALAR/ && do {
		my ($as) = ($$function =~ /\sas\s(.+)/);
		return $as;
	    };
	}
    }
}

1;

#################### pod generated by Pod::Autopod - keep this line to make pod updates possible ####################

=head1 NAME

DBIx::Class::Helper::ResultSet::CrossTab

=head1 DESCRIPTION

ABSTRACT: helper to simulate crosstab

=head1 REQUIRES

L<String::SQLColumnName> 

L<Data::Dump> 

L<parent> 


=head1 METHODS

=head2 crosstab

     my $r = $s->search({}, { columns => [qw/fruit channel/], } )
               ->crosstab({}, { 
                                select  => [qw/fruit/], 
                                on => [qw/channel/], 
                                pivot => [ { sum => 'units' } ], 
                                group_by => [qw/fruit/] 
                              });

     $r->result_class('DBIx::Class::ResultClass::HashRefInflator');  # to inflate rows

=head2 ATTRIBUTES

=head3 pivot

This includes all functions and fields that must be summarized as an arrayref, in the same way as data can be aggregated in DBIx::Class.

these:

     pivot => [ { sum => 'units' } ]  # aggregate function and field
 
     pivot => [ \"sum(units)" ]       # literal SQL

will both provide a sum of units as the result of the crosstab, while this:

     pivot => [ \"sum(units)", { avg => 'units }, \"count(distinct country)"  ]  # mixed, multiple fields

will generate a total of units, the average and the number of distinct countries

=head3 on

This is the field (or function thereof) that will generate the column headers

     on => [qw/channel/]

will generate columns by channel

     on => [qw/channel country/]

will have one column per channel and country combination. It's not possible yet to pivot on a function of a field.

=head3 others

All other attributes work as documented in DBIx::Class::ResultSet

=head2 COPYRIGHT AND LICENSE

Copyright 2016-2017 Simone Cesano

This library is free software; you may redistribute it and/or modify it under the same terms as Perl itself.

=head2 CREDITS

I owe the general idea to Giuseppe Maxia, and I re-used a couple of code snippets from Arthur Axel "fREW" Schmidt.

=cut

