From e6145015a347c908faf5d3f79afd874c3959a5fe Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Wed, 30 Aug 2017 21:05:42 +0100 Subject: [PATCH 01/26] Warn not error on unchanged unmatched regex string --- lib/GADS/Datum/String.pm | 10 ++++++++-- t/006_invalid_values.t | 10 ++++++++-- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/lib/GADS/Datum/String.pm b/lib/GADS/Datum/String.pm index a30cb1546..cb2b119f0 100644 --- a/lib/GADS/Datum/String.pm +++ b/lib/GADS/Datum/String.pm @@ -31,8 +31,14 @@ sub set_value $value =~ /\h+$/ if !ref $value && $value; if (my $regex = !ref $value && $self->column->force_regex) { - error __x"Invalid value \"{value}\" for {field}", value => $value, field => $self->column->name - if $value && $value !~ /^$regex$/; + my $msg = __x"Invalid value \"{value}\" for {field}", value => $value, field => $self->column->name; + # Empty values are not checked - these should be done in optional value for field + if ($value && $value !~ /^$regex$/) + { + # Changed code repeated below, but don't want to flag changed if + # resulting error + ($self->value || '') ne ($value || '') ? error($msg) : warning($msg); + } } $self->changed(1) if ($self->value || '') ne ($value || ''); diff --git a/t/006_invalid_values.t b/t/006_invalid_values.t index 1eda232b6..3f9e1aab4 100644 --- a/t/006_invalid_values.t +++ b/t/006_invalid_values.t @@ -13,7 +13,7 @@ use t::lib::DataSheet; my $data = [ { - string1 => '', + string1 => 'foobar', integer1 => '', enum1 => '', tree1 => '', @@ -42,8 +42,14 @@ my ($record) = @$results; my $string1 = $columns->{'string1'}; $string1->force_regex('[0-9]+'); +# Try unchanged - should only result in warning +try { $record->fields->{$string1->id}->set_value("foobar") } hide => 'ALL'; +ok(!$@, "No exception writing unchanged bad string value for force_regex settings" ); +my ($warning) = $@->exceptions; +like($warning, qr/Invalid value/, "Correct warning writing unchanged bad string value for force_regex settings" ); +# Error with normal changed try { $record->fields->{$string1->id}->set_value("foo") }; -ok( $@, "Failed to write bad string value for force_regex settings" ); +like($@, qr/Invalid value/, "Failed to write bad string value for force_regex settings" ); my $integer1 = $columns->{'integer1'}; try { $record->fields->{$integer1->id}->set_value("bar") }; From fd502939c6afdbcb43e669ef5b32d55a7eecf778 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Wed, 30 Aug 2017 23:41:34 +0100 Subject: [PATCH 02/26] Add script to dump and update layout --- bin/move-layout.pl | 132 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 132 insertions(+) create mode 100755 bin/move-layout.pl diff --git a/bin/move-layout.pl b/bin/move-layout.pl new file mode 100755 index 000000000..a8bb3c756 --- /dev/null +++ b/bin/move-layout.pl @@ -0,0 +1,132 @@ +#!/usr/bin/perl + +=pod +GADS - Globally Accessible Data Store +Copyright (C) 2017 Ctrl O Ltd + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU Affero General Public License as +published by the Free Software Foundation, either version 3 of the +License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Affero General Public License for more details. + +You should have received a copy of the GNU Affero General Public License +along with this program. If not, see . +=cut + +use FindBin; +use lib "$FindBin::Bin/../lib"; + +use Dancer2; +use Dancer2::Plugin::DBIC; +use Getopt::Long qw(:config pass_through); +use YAML::XS qw/LoadFile DumpFile/; + +GADS::Config->instance( + config => config, +); + +my ($instance_id, $site_id, $load_file, $dump_file); +GetOptions ( + 'instance-id=s' => \$instance_id, + 'site-id=s' => \$site_id, + 'load-file=s' => \$load_file, + 'dump-file=s' => \$dump_file, +) or exit; + +$instance_id or die "Need --instance-id"; +$site_id or die "Need --site-id"; +$load_file || $dump_file or die "Need either --load-file or --dump-file"; + +schema->site_id($site_id); + +my $layout = GADS::Layout->new( + user_permission_override => 1, + user => undef, + instance_id => $instance_id, + config => config, + schema => schema, +); + +if ($load_file) +{ + my %loaded; + my $array = LoadFile $load_file; + $loaded{$_->{id}} = $_ foreach @$array; + + foreach my $field ($layout->all) + { + if (my $new = $loaded{$field->id}) + { + $field->name ($new->{name}); + $field->name_short ($new->{name_short}); + $field->type ($new->{type}); + $field->optional ($new->{optional}); + $field->remember ($new->{remember}); + $field->isunique ($new->{isunique}); + $field->textbox ($new->{textbox}) + if $field->can('textbox'); + $field->typeahead ($new->{typeahead}) + if $field->can('typeahead'); + $field->force_regex ($new->{force_regex} || '') + if $field->can('force_regex'); + $field->position ($new->{position}); + $field->ordering ($new->{ordering}); + $field->end_node_only ($new->{end_node_only}) + if $field->can('end_node_only'); + $field->multivalue ($new->{multivalue}); + $field->description ($new->{description}); + $field->helptext ($new->{helptext}); + $field->display_field ($new->{display_field}); + $field->display_regex ($new->{display_regex}); + $field->link_parent_id($new->{link_parent_id}); + $field->filter->as_json($new->{filter}); + $field->_set_options ($new->{options}); + $field->enumvals ($new->{enumvals}) + if $field->type eq 'enum'; + + $field->write(no_cache_update => 1); + } + else { + say STDERR "Field ".$field->name." (ID ".$field->id.") not in updated layout - needs manual deletion"; + } + } +} +else { + + my @out; + foreach my $field ($layout->all) + { + my $hash = { + id => $field->id, + name => $field->name, + name_short => $field->name_short, + type => $field->type, + optional => $field->optional, + remember => $field->remember, + isunique => $field->isunique, + textbox => $field->can('textbox') ? $field->textbox : 0, + typeahead => $field->can('typeahead') ? $field->typeahead : 0, + force_regex => $field->can('force_regex') ? $field->force_regex : '', + position => $field->position, + ordering => $field->ordering, + end_node_only => $field->can('end_node_only') ? $field->end_node_only : 0, + multivalue => $field->multivalue, + description => $field->description, + helptext => $field->helptext, + display_field => $field->display_field, + display_regex => $field->display_regex, + link_parent_id => $field->link_parent_id, + filter => $field->filter->as_json, + options => $field->options, + }; + $hash->{enumvals} = $field->enumvals if $field->type eq 'enum'; + push @out, $hash; + } + DumpFile $dump_file, [@out]; +} + From 5b6b7c0658876369c97ab65d8f6f53011e36981a Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Wed, 30 Aug 2017 23:42:49 +0100 Subject: [PATCH 03/26] Add missing dep to move layout script --- bin/move-layout.pl | 1 + 1 file changed, 1 insertion(+) diff --git a/bin/move-layout.pl b/bin/move-layout.pl index a8bb3c756..353b0e12e 100755 --- a/bin/move-layout.pl +++ b/bin/move-layout.pl @@ -23,6 +23,7 @@ use Dancer2; use Dancer2::Plugin::DBIC; +use GADS::Config; use Getopt::Long qw(:config pass_through); use YAML::XS qw/LoadFile DumpFile/; From 340218b952e444d53514d9a55db1e5d8fbbcd5a7 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Wed, 30 Aug 2017 23:48:57 +0100 Subject: [PATCH 04/26] Also move curval field IDs in layout move --- bin/move-layout.pl | 3 +++ 1 file changed, 3 insertions(+) diff --git a/bin/move-layout.pl b/bin/move-layout.pl index 353b0e12e..dfb3c37c2 100755 --- a/bin/move-layout.pl +++ b/bin/move-layout.pl @@ -89,6 +89,8 @@ $field->_set_options ($new->{options}); $field->enumvals ($new->{enumvals}) if $field->type eq 'enum'; + $field->curval_field_ids($new->{curval_field_ids}) + if $field->type eq 'curval'; $field->write(no_cache_update => 1); } @@ -126,6 +128,7 @@ options => $field->options, }; $hash->{enumvals} = $field->enumvals if $field->type eq 'enum'; + $hash->{curval_field_ids} = $field->curval_field_ids if $field->type eq 'curval'; push @out, $hash; } DumpFile $dump_file, [@out]; From 73479dab66fc5ccc8175d4c423a0cbee908b4f7d Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Thu, 31 Aug 2017 00:09:28 +0100 Subject: [PATCH 05/26] Also create new fields in layout move --- bin/move-layout.pl | 79 +++++++++++++++++++++++++++++----------------- lib/GADS/Column.pm | 10 ++++-- 2 files changed, 58 insertions(+), 31 deletions(-) diff --git a/bin/move-layout.pl b/bin/move-layout.pl index dfb3c37c2..c42cf684f 100755 --- a/bin/move-layout.pl +++ b/bin/move-layout.pl @@ -25,6 +25,7 @@ use Dancer2::Plugin::DBIC; use GADS::Config; use Getopt::Long qw(:config pass_through); +use String::CamelCase qw(camelize); use YAML::XS qw/LoadFile DumpFile/; GADS::Config->instance( @@ -53,45 +54,65 @@ schema => schema, ); +sub set_props +{ my ($field, $new) = @_; + $field->name ($new->{name}); + $field->name_short ($new->{name_short}); + $field->type ($new->{type}); + $field->optional ($new->{optional}); + $field->remember ($new->{remember}); + $field->isunique ($new->{isunique}); + $field->textbox ($new->{textbox}) + if $field->can('textbox'); + $field->typeahead ($new->{typeahead}) + if $field->can('typeahead'); + $field->force_regex ($new->{force_regex} || '') + if $field->can('force_regex'); + $field->position ($new->{position}); + $field->ordering ($new->{ordering}); + $field->end_node_only ($new->{end_node_only}) + if $field->can('end_node_only'); + $field->multivalue ($new->{multivalue}); + $field->description ($new->{description}); + $field->helptext ($new->{helptext}); + $field->display_field ($new->{display_field}); + $field->display_regex ($new->{display_regex}); + $field->link_parent_id($new->{link_parent_id}); + $field->filter->as_json($new->{filter}); + $field->_set_options ($new->{options}); + $field->enumvals ($new->{enumvals}) + if $field->type eq 'enum'; + $field->curval_field_ids($new->{curval_field_ids}) + if $field->type eq 'curval'; +} + if ($load_file) { my %loaded; my $array = LoadFile $load_file; $loaded{$_->{id}} = $_ foreach @$array; + # Find new ones + my %missing = %loaded; + delete $missing{$_->id} foreach $layout->all; + # Create first in case they are referenced + foreach my $new (values %missing) + { + my $class = "GADS::Column::".camelize $new->{type}; + my $field = $class->new( + id => $new->{id}, + schema => schema, + user => undef, + layout => $layout, + ); + set_props($field, $new); + } + foreach my $field ($layout->all) { if (my $new = $loaded{$field->id}) { - $field->name ($new->{name}); - $field->name_short ($new->{name_short}); - $field->type ($new->{type}); - $field->optional ($new->{optional}); - $field->remember ($new->{remember}); - $field->isunique ($new->{isunique}); - $field->textbox ($new->{textbox}) - if $field->can('textbox'); - $field->typeahead ($new->{typeahead}) - if $field->can('typeahead'); - $field->force_regex ($new->{force_regex} || '') - if $field->can('force_regex'); - $field->position ($new->{position}); - $field->ordering ($new->{ordering}); - $field->end_node_only ($new->{end_node_only}) - if $field->can('end_node_only'); - $field->multivalue ($new->{multivalue}); - $field->description ($new->{description}); - $field->helptext ($new->{helptext}); - $field->display_field ($new->{display_field}); - $field->display_regex ($new->{display_regex}); - $field->link_parent_id($new->{link_parent_id}); - $field->filter->as_json($new->{filter}); - $field->_set_options ($new->{options}); - $field->enumvals ($new->{enumvals}) - if $field->type eq 'enum'; - $field->curval_field_ids($new->{curval_field_ids}) - if $field->type eq 'curval'; - + set_props($field, $new); $field->write(no_cache_update => 1); } else { diff --git a/lib/GADS/Column.pm b/lib/GADS/Column.pm index 928970167..69feac34a 100644 --- a/lib/GADS/Column.pm +++ b/lib/GADS/Column.pm @@ -833,8 +833,14 @@ sub write $self->_set__rset($rset); } else { - $rset = $self->schema->resultset('Layout')->find($self->id); - $rset->update($newitem); + if ($rset = $self->schema->resultset('Layout')->find($self->id)) + { + $rset->update($newitem); + } + else { + $rset = $self->schema->resultset('Layout')->create($newitem); + $self->_set__rset($rset); + } } $self->write_special(rset => $rset, id => $new_id || $self->id, %options); # Write any column-specific params From 13b8f1dddbb311ec55c72ef7d601a2fe58a9f758 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Thu, 31 Aug 2017 00:10:53 +0100 Subject: [PATCH 06/26] Do layout load in transaction --- bin/move-layout.pl | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/bin/move-layout.pl b/bin/move-layout.pl index c42cf684f..85118ee7e 100755 --- a/bin/move-layout.pl +++ b/bin/move-layout.pl @@ -88,6 +88,8 @@ sub set_props if ($load_file) { + my $guard = schema->txn_scope_guard; + my %loaded; my $array = LoadFile $load_file; $loaded{$_->{id}} = $_ foreach @$array; @@ -119,6 +121,8 @@ sub set_props say STDERR "Field ".$field->name." (ID ".$field->id.") not in updated layout - needs manual deletion"; } } + + $guard->commit; } else { From 20a5e824dbd94f360d49303646fddd555db26e49 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Thu, 31 Aug 2017 01:18:22 +0100 Subject: [PATCH 07/26] Many fixes for layout move script --- bin/move-layout.pl | 49 +++++++++++++++++++++++++++++------------ lib/GADS/Column.pm | 1 + lib/GADS/Column/Enum.pm | 6 +++-- 3 files changed, 40 insertions(+), 16 deletions(-) diff --git a/bin/move-layout.pl b/bin/move-layout.pl index 85118ee7e..f52b1724d 100755 --- a/bin/move-layout.pl +++ b/bin/move-layout.pl @@ -21,6 +21,8 @@ use FindBin; use lib "$FindBin::Bin/../lib"; +use Algorithm::Dependency::Ordered; +use Algorithm::Dependency::Source::HoA; use Dancer2; use Dancer2::Plugin::DBIC; use GADS::Config; @@ -54,7 +56,7 @@ schema => schema, ); -sub set_props +sub write_props { my ($field, $new) = @_; $field->name ($new->{name}); $field->name_short ($new->{name_short}); @@ -82,8 +84,13 @@ sub set_props $field->_set_options ($new->{options}); $field->enumvals ($new->{enumvals}) if $field->type eq 'enum'; - $field->curval_field_ids($new->{curval_field_ids}) - if $field->type eq 'curval'; + if ($field->type eq 'curval') + { + $field->curval_field_ids($new->{curval_field_ids}); + my ($random) = @{$field->curval_field_ids}; + $field->refers_to_instance($layout->column($random)->layout->instance_id); + } + $field->write(no_cache_update => 1, create_missing_id => 1); # Create any new enums, with existing IDs } if ($load_file) @@ -97,25 +104,39 @@ sub set_props # Find new ones my %missing = %loaded; delete $missing{$_->id} foreach $layout->all; + # Create first in case they are referenced - foreach my $new (values %missing) + if (%missing) { - my $class = "GADS::Column::".camelize $new->{type}; - my $field = $class->new( - id => $new->{id}, - schema => schema, - user => undef, - layout => $layout, - ); - set_props($field, $new); + my %deps = map { + $_->{id} => $_->{display_field} && $missing{$_->{display_field}} ? [ $_->{display_field} ] : [] + } values %missing; + + my $source = Algorithm::Dependency::Source::HoA->new(\%deps); + my $dep = Algorithm::Dependency::Ordered->new(source => $source) + or die 'Failed to set up dependency algorithm'; + my @order = @{$dep->schedule_all}; + my @missing = map { $missing{$_} } @order; + + foreach my $new (@missing) + { + say STDERR "Creating missing field $new->{id} ($new->{name})"; + my $class = "GADS::Column::".camelize $new->{type}; + my $field = $class->new( + id => $new->{id}, + schema => schema, + user => undef, + layout => $layout, + ); + write_props($field, $new); + } } foreach my $field ($layout->all) { if (my $new = $loaded{$field->id}) { - set_props($field, $new); - $field->write(no_cache_update => 1); + write_props($field, $new); } else { say STDERR "Field ".$field->name." (ID ".$field->id.") not in updated layout - needs manual deletion"; diff --git a/lib/GADS/Column.pm b/lib/GADS/Column.pm index 69feac34a..9d2d48bb2 100644 --- a/lib/GADS/Column.pm +++ b/lib/GADS/Column.pm @@ -838,6 +838,7 @@ sub write $rset->update($newitem); } else { + $newitem->{id} = $self->id; $rset = $self->schema->resultset('Layout')->create($newitem); $self->_set__rset($rset); } diff --git a/lib/GADS/Column/Enum.pm b/lib/GADS/Column/Enum.pm index f17bbd210..f2f4280a9 100644 --- a/lib/GADS/Column/Enum.pm +++ b/lib/GADS/Column/Enum.pm @@ -129,8 +129,10 @@ sub write_special unless $value =~ /^[ \S]+$/; if ($en->{id}) { - my $enumval = $self->schema->resultset('Enumval')->find($en->{id}) - or error __x"Bad ID {id} for multiple select update", id => $en->{id}; + my $enumval = $options{create_missing_id} + ? $self->schema->resultset('Enumval')->find_or_create({ id => $en->{id }}) + : $self->schema->resultset('Enumval')->find($en->{id}); + $enumval or error __x"Bad ID {id} for multiple select update", id => $en->{id}; $enumval->update({ value => $en->{value} }); } else { From 27693f3664a01e3a642eb93ba8de6df3a0595291 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Thu, 31 Aug 2017 19:35:23 +0100 Subject: [PATCH 08/26] Fix view creation filtering on filtered curval --- lib/GADS/Column/Curval.pm | 2 +- lib/GADS/Filter.pm | 22 ++++++++++++++++------ lib/GADS/Records.pm | 1 + t/009_typeahead.t | 32 ++++++++++++++++++++++++++++++++ 4 files changed, 50 insertions(+), 7 deletions(-) diff --git a/lib/GADS/Column/Curval.pm b/lib/GADS/Column/Curval.pm index fd1bf1ec3..6a3e4a87c 100644 --- a/lib/GADS/Column/Curval.pm +++ b/lib/GADS/Column/Curval.pm @@ -219,7 +219,7 @@ sub _build_view # Replace any "special" $short_name values with their actual value from the # record. If sub_values fails (due to record not being ready yet), then the # view is not built - return unless $view->filter->sub_values($self->layout->record); + return unless $view->filter->sub_values($self->layout); return $view; } diff --git a/lib/GADS/Filter.pm b/lib/GADS/Filter.pm index 4fc81950d..8be22c50c 100644 --- a/lib/GADS/Filter.pm +++ b/lib/GADS/Filter.pm @@ -177,28 +177,38 @@ sub columns_in_subs # Sub into the filter values from a record sub sub_values -{ my ($self, $record) = @_; +{ my ($self, $layout) = @_; my $filter = $self->as_hash; - foreach (@{$filter->{rules}}) + if (!$layout->record && @{$self->columns_in_subs($layout)}) { - return 0 unless $self->_sub_filter_single($_, $record); + # If we don't have a record (e.g. from typeahead search) and there + # are known shortnames in the filter, then don't apply the filter + # at all (there are no values to substitute in) + $filter = {}; + } + else { + foreach (@{$filter->{rules}}) + { + return 0 unless $self->_sub_filter_single($_, $layout); + } } $self->as_hash($filter); return 1; } sub _sub_filter_single -{ my ($self, $single, $record) = @_; +{ my ($self, $single, $layout) = @_; + my $record = $layout->record; if ($single->{rules}) { foreach (@{$single->{rules}}) { - return 0 unless $self->_sub_filter_single($_, $record); + return 0 unless $self->_sub_filter_single($_, $layout); } } elsif ($single->{value} && $single->{value} =~ /^\$([_0-9a-z]+)$/i) { - my $col = $record->layout->column_by_name_short($1); + my $col = $layout->column_by_name_short($1); if (!$col) { trace "No match for short name $1"; diff --git a/lib/GADS/Records.pm b/lib/GADS/Records.pm index 622b4ced7..b07965446 100644 --- a/lib/GADS/Records.pm +++ b/lib/GADS/Records.pm @@ -1025,6 +1025,7 @@ sub _search_construct my %permission = $ignore_perms ? () : (permission => 'read'); my ($parent_column, $column); + $filter->{id} or return; # Used to ignore filter if ($filter->{id} =~ /^([0-9]+)_([0-9]+)$/) { $column = $layout->column($2, %permission); diff --git a/t/009_typeahead.t b/t/009_typeahead.t index c8a89e17f..7d9627e25 100644 --- a/t/009_typeahead.t +++ b/t/009_typeahead.t @@ -51,6 +51,38 @@ is ($value->{name}, "Bar, 99, foo2, , 2009-01-02, 2008-05-04 to 2008-07-14, , , is (scalar @values, 1, "Typeahead returned correct number of results"); @values = $column->values_beginning_with(''); is (scalar @values, 2, "Typeahead returns all results for blank search"); +# Add a filter to the curval +$column->filter(GADS::Filter->new( + as_hash => { + rules => [{ + id => $curval_sheet->columns->{integer1}->id, + type => 'string', + value => '50', + operator => 'equal', + }], + }, +)); +$column->write; +@values = $column->values_beginning_with('50'); +is (scalar @values, 1, "Typeahead returned correct number of results (with matching filter)"); +@values = $column->values_beginning_with('99'); +is (scalar @values, 0, "Typeahead returned correct number of results (with no match filter)"); +# Add a filter which has record sub-values in. This should be ignored. +$column->filter(GADS::Filter->new( + as_hash => { + rules => [{ + id => $curval_sheet->columns->{integer1}->id, + type => 'string', + value => '$L1string1', + operator => 'equal', # String1 field in main sheet + }], + }, +)); +$column->write; +@values = $column->values_beginning_with('50'); +is (scalar @values, 1, "Typeahead returned correct number of results (with matching filter)"); +@values = $column->values_beginning_with('99'); +is (scalar @values, 1, "Typeahead returned correct number of results (with no match filter)"); $column = $columns->{calc1}; @values = $column->values_beginning_with('2'); From 63137cb2dc74b9250d07dcf1b2cc033345cdfabf Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Thu, 31 Aug 2017 20:06:31 +0100 Subject: [PATCH 09/26] Check curval filter values for validity --- lib/GADS/Column/Curval.pm | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/lib/GADS/Column/Curval.pm b/lib/GADS/Column/Curval.pm index 6a3e4a87c..d3d14df39 100644 --- a/lib/GADS/Column/Curval.pm +++ b/lib/GADS/Column/Curval.pm @@ -619,6 +619,23 @@ sub _build_all_ids ]; } +sub validate_search +{ my $self = shift; + my ($value, %options) = @_; + if (!$value) + { + return 0 unless $options{fatal}; + error __x"Search value cannot be blank for {col}.", + col => $self->name; + } + elsif ($value !~ /^[0-9]+$/) { + return 0 unless $options{fatal}; + error __x"Search value must be an ID number for {col}.", + col => $self->name; + } + 1; +} + sub random { my $self = shift; $self->all_ids->[rand @{$self->all_ids}]; From c9c8597e50b769aedffd203b3bbcc1db860717f0 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Thu, 31 Aug 2017 21:10:12 +0100 Subject: [PATCH 10/26] Allow invalid filter to be edited --- lib/GADS/Column/Curval.pm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/GADS/Column/Curval.pm b/lib/GADS/Column/Curval.pm index d3d14df39..f45d75568 100644 --- a/lib/GADS/Column/Curval.pm +++ b/lib/GADS/Column/Curval.pm @@ -347,7 +347,9 @@ sub _build_has_subvalues sub filter_value_to_text { my ($self, $id) = @_; - $id or return ''; + # Check for valid ID (in case search filter is corrupted) - Pg will choke + # on invalid IDs + $id =~ /^[0-9]+$/ or return ''; my $rows = $self->ids_to_values([$id]); $rows->[0]->{value}; } From 1628639d8b026eaf4368eb82f5378b2e01555a1e Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Thu, 31 Aug 2017 22:32:11 +0100 Subject: [PATCH 11/26] Provide sane check for view name too long --- lib/GADS/View.pm | 5 +++++ t/011_views.t | 10 ++++++++++ 2 files changed, 15 insertions(+) diff --git a/lib/GADS/View.pm b/lib/GADS/View.pm index 147853fbe..8e92b81cb 100644 --- a/lib/GADS/View.pm +++ b/lib/GADS/View.pm @@ -256,6 +256,11 @@ sub write $self->name or error __"Please enter a name for the view"; + # XXX Database schema currently restricts length of name. Should be changed + # to normal text field at some point + length $self->name < 128 + or error __"View name must be less than 128 characters"; + my $global = !$self->user ? 1 : $self->global; my $user_id = $global || $self->is_admin ? undef : $self->user->{id}; diff --git a/t/011_views.t b/t/011_views.t index 3281fb2c2..5d2502179 100644 --- a/t/011_views.t +++ b/t/011_views.t @@ -71,4 +71,14 @@ $view = GADS::View->new(%view_template, id => -10); is($view->name, undef, "Blank name for invalid view"); is(@{$view->columns}, 0, "No columns for invalid view"); +my $long = 'Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum'; + +$view = GADS::View->new( + %view_template, + name => $long, +); + +# Create normal view as normal user +try { $view->write }; +like($@, qr/View name must be less than/, "Failed to create view with name too long"); done_testing(); From e308bb7312b0799d50a3c9c7b26daf8bde66c38e Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Thu, 31 Aug 2017 23:23:41 +0100 Subject: [PATCH 12/26] Fix import of enumvals --- lib/GADS/Column/Enum.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/GADS/Column/Enum.pm b/lib/GADS/Column/Enum.pm index f2f4280a9..1e437f108 100644 --- a/lib/GADS/Column/Enum.pm +++ b/lib/GADS/Column/Enum.pm @@ -130,7 +130,7 @@ sub write_special if ($en->{id}) { my $enumval = $options{create_missing_id} - ? $self->schema->resultset('Enumval')->find_or_create({ id => $en->{id }}) + ? $self->schema->resultset('Enumval')->find_or_create({ id => $en->{id}, layout_id => $id }) : $self->schema->resultset('Enumval')->find($en->{id}); $enumval or error __x"Bad ID {id} for multiple select update", id => $en->{id}; $enumval->update({ value => $en->{value} }); From fd6c2096675969de1005378f427d5f4da481cd43 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Fri, 1 Sep 2017 08:43:34 +0100 Subject: [PATCH 13/26] Add missing dependency --- bin/move-layout.pl | 1 + 1 file changed, 1 insertion(+) diff --git a/bin/move-layout.pl b/bin/move-layout.pl index f52b1724d..400601893 100755 --- a/bin/move-layout.pl +++ b/bin/move-layout.pl @@ -26,6 +26,7 @@ use Dancer2; use Dancer2::Plugin::DBIC; use GADS::Config; +use GADS::Layout; use Getopt::Long qw(:config pass_through); use String::CamelCase qw(camelize); use YAML::XS qw/LoadFile DumpFile/; From ce322d325ebfd5899842194033fbd4d91400433c Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Fri, 1 Sep 2017 09:42:14 +0100 Subject: [PATCH 14/26] Add views to import facility --- bin/move-layout.pl | 188 ++++++++++++++++++++++++++++++--------------- 1 file changed, 127 insertions(+), 61 deletions(-) diff --git a/bin/move-layout.pl b/bin/move-layout.pl index 400601893..51417eac1 100755 --- a/bin/move-layout.pl +++ b/bin/move-layout.pl @@ -27,6 +27,7 @@ use Dancer2::Plugin::DBIC; use GADS::Config; use GADS::Layout; +use GADS::Views; use Getopt::Long qw(:config pass_through); use String::CamelCase qw(camelize); use YAML::XS qw/LoadFile DumpFile/; @@ -35,12 +36,13 @@ config => config, ); -my ($instance_id, $site_id, $load_file, $dump_file); +my ($instance_id, $site_id, $load_file, $dump_file, $global_views); GetOptions ( 'instance-id=s' => \$instance_id, 'site-id=s' => \$site_id, 'load-file=s' => \$load_file, 'dump-file=s' => \$dump_file, + 'global-views' => \$global_views, ) or exit; $instance_id or die "Need --instance-id"; @@ -57,6 +59,13 @@ schema => schema, ); +my $views = GADS::Views->new( + user => undef, + schema => schema, + layout => $layout, + instance_id => $instance_id, +); + sub write_props { my ($field, $new) = @_; $field->name ($new->{name}); @@ -98,49 +107,86 @@ sub write_props { my $guard = schema->txn_scope_guard; - my %loaded; my $array = LoadFile $load_file; - $loaded{$_->{id}} = $_ foreach @$array; - # Find new ones - my %missing = %loaded; - delete $missing{$_->id} foreach $layout->all; - - # Create first in case they are referenced - if (%missing) + if ($global_views) { - my %deps = map { - $_->{id} => $_->{display_field} && $missing{$_->{display_field}} ? [ $_->{display_field} ] : [] - } values %missing; - - my $source = Algorithm::Dependency::Source::HoA->new(\%deps); - my $dep = Algorithm::Dependency::Ordered->new(source => $source) - or die 'Failed to set up dependency algorithm'; - my @order = @{$dep->schedule_all}; - my @missing = map { $missing{$_} } @order; - - foreach my $new (@missing) + foreach my $import (@$array) { - say STDERR "Creating missing field $new->{id} ($new->{name})"; - my $class = "GADS::Column::".camelize $new->{type}; - my $field = $class->new( - id => $new->{id}, - schema => schema, - user => undef, - layout => $layout, + schema->resultset('View')->search({ + id => $import->{id}, + instance_id => { '!=' => $instance_id }, + })->count and die "View ID $import->{id} already exists but for wrong instance"; + schema->resultset('View')->find_or_create({ + id => $import->{id}, + instance_id => $instance_id, + }); + my $view = GADS::View->new( + id => $import->{id}, + user => undef, + schema => schema, + layout => $layout, + instance_id => $instance_id, ); - write_props($field, $new); + $view->columns($import->{columns}); + $view->global($import->{is_admin}); + $view->is_admin($import->{is_admin}); + $view->name($import->{name}); + $view->filter->as_json($import->{filter}); + $view->write; + my (@sort_fields, @sort_types); + foreach my $sort (@{$import->{sorts}}) + { + push @sort_fields, $sort->{layout_id}; + push @sort_types, $sort->{type}; + } + $view->set_sorts(\@sort_fields, \@sort_types); } } + else { + my %loaded; + $loaded{$_->{id}} = $_ foreach @$array; - foreach my $field ($layout->all) - { - if (my $new = $loaded{$field->id}) + # Find new ones + my %missing = %loaded; + delete $missing{$_->id} foreach $layout->all; + + # Create first in case they are referenced + if (%missing) { - write_props($field, $new); + my %deps = map { + $_->{id} => $_->{display_field} && $missing{$_->{display_field}} ? [ $_->{display_field} ] : [] + } values %missing; + + my $source = Algorithm::Dependency::Source::HoA->new(\%deps); + my $dep = Algorithm::Dependency::Ordered->new(source => $source) + or die 'Failed to set up dependency algorithm'; + my @order = @{$dep->schedule_all}; + my @missing = map { $missing{$_} } @order; + + foreach my $new (@missing) + { + say STDERR "Creating missing field $new->{id} ($new->{name})"; + my $class = "GADS::Column::".camelize $new->{type}; + my $field = $class->new( + id => $new->{id}, + schema => schema, + user => undef, + layout => $layout, + ); + write_props($field, $new); + } } - else { - say STDERR "Field ".$field->name." (ID ".$field->id.") not in updated layout - needs manual deletion"; + + foreach my $field ($layout->all) + { + if (my $new = $loaded{$field->id}) + { + write_props($field, $new); + } + else { + say STDERR "Field ".$field->name." (ID ".$field->id.") not in updated layout - needs manual deletion"; + } } } @@ -149,35 +195,55 @@ sub write_props else { my @out; - foreach my $field ($layout->all) + + if ($global_views) { - my $hash = { - id => $field->id, - name => $field->name, - name_short => $field->name_short, - type => $field->type, - optional => $field->optional, - remember => $field->remember, - isunique => $field->isunique, - textbox => $field->can('textbox') ? $field->textbox : 0, - typeahead => $field->can('typeahead') ? $field->typeahead : 0, - force_regex => $field->can('force_regex') ? $field->force_regex : '', - position => $field->position, - ordering => $field->ordering, - end_node_only => $field->can('end_node_only') ? $field->end_node_only : 0, - multivalue => $field->multivalue, - description => $field->description, - helptext => $field->helptext, - display_field => $field->display_field, - display_regex => $field->display_regex, - link_parent_id => $field->link_parent_id, - filter => $field->filter->as_json, - options => $field->options, - }; - $hash->{enumvals} = $field->enumvals if $field->type eq 'enum'; - $hash->{curval_field_ids} = $field->curval_field_ids if $field->type eq 'curval'; - push @out, $hash; + foreach my $view (@{$views->all}) + { + next unless $view->global || $view->is_admin; + push @out, { + id => $view->id, + name => $view->name, + global => $view->global, + is_admin => $view->is_admin, + filter => $view->filter->as_json, + columns => $view->columns, + sorts => $view->sorts, + }; + } } + else { + foreach my $field ($layout->all) + { + my $hash = { + id => $field->id, + name => $field->name, + name_short => $field->name_short, + type => $field->type, + optional => $field->optional, + remember => $field->remember, + isunique => $field->isunique, + textbox => $field->can('textbox') ? $field->textbox : 0, + typeahead => $field->can('typeahead') ? $field->typeahead : 0, + force_regex => $field->can('force_regex') ? $field->force_regex : '', + position => $field->position, + ordering => $field->ordering, + end_node_only => $field->can('end_node_only') ? $field->end_node_only : 0, + multivalue => $field->multivalue, + description => $field->description, + helptext => $field->helptext, + display_field => $field->display_field, + display_regex => $field->display_regex, + link_parent_id => $field->link_parent_id, + filter => $field->filter->as_json, + options => $field->options, + }; + $hash->{enumvals} = $field->enumvals if $field->type eq 'enum'; + $hash->{curval_field_ids} = $field->curval_field_ids if $field->type eq 'curval'; + push @out, $hash; + } + } + DumpFile $dump_file, [@out]; } From a5e70b41e66db36c1d46cc67f0adf6b638fb129a Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Fri, 1 Sep 2017 10:10:17 +0100 Subject: [PATCH 15/26] Temporary fix to ensure columns not moved between layouts --- lib/GADS/Column.pm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lib/GADS/Column.pm b/lib/GADS/Column.pm index 86817143e..1d69920c0 100644 --- a/lib/GADS/Column.pm +++ b/lib/GADS/Column.pm @@ -822,6 +822,9 @@ sub write else { if ($rset = $self->schema->resultset('Layout')->find($self->id)) { + # Check whether attempt to move between instances - this is a bug + $newitem->{instance_id} != $rset->instance_id + and panic "Attempt to move column between instances"; $rset->update($newitem); } else { From cb7839123e300af3b1d5cef2aa632270121515d4 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Fri, 1 Sep 2017 21:25:21 +0100 Subject: [PATCH 16/26] Optimise retrieval of user's tables --- lib/GADS/Instances.pm | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/lib/GADS/Instances.pm b/lib/GADS/Instances.pm index 169f01758..df15505c2 100644 --- a/lib/GADS/Instances.pm +++ b/lib/GADS/Instances.pm @@ -37,22 +37,30 @@ has user => ( sub _build_all { my $self = shift; + # See what tables this user has access to. Perform 2 separate queries, + # otherwise the combined number of rows to search through is huge for all + # the different user/group/layout combinations making the query very slow. + # + # First the user's groups, unless it's a layout admin my $search = {}; - $search = { 'user_groups.user_id' => $self->user->{id} } - if $self->user && !$self->user->{permission}->{layout}; - my $instance_rs = $self->schema->resultset('Instance')->search($search,{ + if ($self->user && !$self->user->{permission}->{layout}) + { + my @groups = $self->schema->resultset('Group')->search({ + 'user_groups.user_id' => $self->user->{id} + },{ + join => 'user_groups', + })->get_column('me.id')->all; + $search = {'layout_groups.group_id' => [@groups]}; + } + # Then the instances + my @instances = $self->schema->resultset('Instance')->search($search,{ join => { - layouts => { - layout_groups => { - group => 'user_groups', - }, - }, + layouts => 'layout_groups', }, collapse => 1, order_by => ['me.name'], - }); - my @all = $instance_rs->all; - \@all; + })->all; + \@instances; } sub is_valid From c60d3a9950ea26a890ff133df84c5b0dd0e18375 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Fri, 1 Sep 2017 21:33:04 +0100 Subject: [PATCH 17/26] Fix generation of config in onboard script --- bin/onboard.pl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bin/onboard.pl b/bin/onboard.pl index 9b48f4468..6a34ebfd8 100755 --- a/bin/onboard.pl +++ b/bin/onboard.pl @@ -96,7 +96,7 @@ my $layout = GADS::Layout->new( user => undef, schema => schema, - config => config, + config => GADS::Config->instance, instance_id => $instance_id, user_permission_override => 1 ); From dd9959dd669408890eebb10079285ee716faa807 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Fri, 1 Sep 2017 21:35:43 +0100 Subject: [PATCH 18/26] Allow values to be blanked in onboard script --- bin/onboard.pl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bin/onboard.pl b/bin/onboard.pl index 6a34ebfd8..e685f880b 100755 --- a/bin/onboard.pl +++ b/bin/onboard.pl @@ -497,7 +497,7 @@ sub update_fields if (ref $col && $col->userinput) # Not calculated fields { my $newv = $input->{$col->field}; - if (!$record->current_id || $newv) + if (!$record->current_id || defined $newv) { if ($col->type eq "daterange" && $ignore_incomplete_dateranges) { From 37ae1cd76db5ee517b362507880d7d2b9a571887 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Sat, 2 Sep 2017 08:21:30 +0100 Subject: [PATCH 19/26] Allow upload values to be blank and pass correct calc values for update_only --- lib/GADS/Import.pm | 29 +++++++---- lib/GADS/Record.pm | 12 ++++- t/014_import.t | 117 +++++++++++++++++++++++++++++++++++++++------ 3 files changed, 132 insertions(+), 26 deletions(-) diff --git a/lib/GADS/Import.pm b/lib/GADS/Import.pm index abf95aec7..24cb92440 100755 --- a/lib/GADS/Import.pm +++ b/lib/GADS/Import.pm @@ -407,7 +407,11 @@ sub _import_rows } elsif ($col->type eq "daterange") { - if ($value =~ /^(\H+)\h*(-|to)\h*(\H+)$/) + if (!$value) + { + $input->{$col->id} = ['','']; + } + elsif ($value =~ /^(\H+)\h*(-|to)\h*(\H+)$/) { $input->{$col->id} = [$1,$3]; } @@ -423,15 +427,18 @@ sub _import_rows } elsif ($col->type eq "intgr") { - my $qr = $self->round_integers ? qr/^[\.0-9]+$/ : qr/^[0-9]+$/; - if ($value =~ $qr) + if ($input->{$col->id} = $value) { - # Round decimals if needed - $input->{$col->id} = $value && $self->round_integers ? sprintf("%.0f", $value) : $value; - } - elsif ($value) { - push @bad, __x"Invalid value '{value}' for integer field '{colname}'", - value => $value, colname => $col->name; + my $qr = $self->round_integers ? qr/^[\.0-9]+$/ : qr/^[0-9]+$/; + if ($value =~ $qr) + { + # Round decimals if needed + $input->{$col->id} = $value && $self->round_integers ? sprintf("%.0f", $value) : $value; + } + elsif ($value) { + push @bad, __x"Invalid value '{value}' for integer field '{colname}'", + value => $value, colname => $col->name; + } } } else { @@ -588,7 +595,9 @@ sub update_fields if ($col->userinput && !$col->internal) # Not calculated fields { my $newv = $input->{$col->id}; - if (!$record->current_id || $newv ne '') + # If updating existing record, don't update if invalid value + # uploaded (value will be undefined) + if (!$record->current_id || defined $newv) { my $datum = $record->fields->{$col->id}; my $old_value = $datum->as_string; diff --git a/lib/GADS/Record.pm b/lib/GADS/Record.pm index 83ae31ea7..91ddb0856 100644 --- a/lib/GADS/Record.pm +++ b/lib/GADS/Record.pm @@ -1095,8 +1095,12 @@ sub write }; $self->fields->{-11}->current_id($self->current_id); $self->fields->{-11}->clear_value; # Will rebuild as current_id - $self->fields->{-12}->set_value($created_date); - $self->fields->{-13}->set_value($createdby, no_validation => 1); + unless ($options{update_only}) + { + # Keep original record values when only updating the record + $self->fields->{-12}->set_value($created_date); + $self->fields->{-13}->set_value($createdby, no_validation => 1); + } if ($need_app) { @@ -1354,6 +1358,9 @@ sub _field_write { if (!@{$datum_write->values}) { + $entry->{from} = undef; + $entry->{to} = undef; + $entry->{value} = undef, push @entries, $entry; # No values, but still need to write null value } my @texts = @{$datum_write->text_all}; @@ -1370,6 +1377,7 @@ sub _field_write { if (!@{$datum_write->ids}) { + $entry->{value} = undef; push @entries, $entry; # No values, but still need to write null value } foreach my $id (@{$datum_write->ids}) diff --git a/t/014_import.t b/t/014_import.t index 565f1da4d..444ac949b 100644 --- a/t/014_import.t +++ b/t/014_import.t @@ -2,6 +2,7 @@ use Test::More; # tests => 1; use strict; use warnings; +use Test::MockTime qw(set_fixed_time restore_time); # Load before DateTime use Log::Report; use GADS::Import; @@ -219,11 +220,11 @@ my @update_tests = ( existing_data => [ { string1 => 'Foo', - enum1 => 1, + enum1 => 'foo1', }, { string1 => 'Bar', - enum1 => 2, + enum1 => 'foo2', }, ], }, @@ -243,11 +244,11 @@ my @update_tests = ( existing_data => [ { string1 => 'Foo', - tree1 => 4, + tree1 => 'tree1', }, { string1 => 'Bar', - tree1 => 5, + tree1 => 'tree2', }, ], }, @@ -312,42 +313,123 @@ my @update_tests = ( }, ], }, + { + name => 'Update existing records only', + option => 'update_only', + data => "ID,string1,integer1,date1,enum1,tree1,daterange1,curval1\n3,Bar,200,2011-10-10,foo2,tree2,2011-10-10 to 2011-11-10,2\n4,,,,,,,", + unique => 'ID', + count => 2, + count_versions => 2, + calc_code => ' + function evaluate (_version_user, _version_datetime) + return _version_user.firstname .. _version_user.surname + .. _version_datetime.year .. _version_datetime.month .. _version_datetime.day + end + ', + results => { + string1 => 'Bar ', + integer1 => '200 ', + date1 => '2011-10-10 ', + enum1 => 'foo2 ', + tree1 => 'tree2 ', + daterange1 => '2011-10-10 to 2011-11-10 ', + curval1 => 'Bar, 99, foo2, , 2009-01-02, 2008-05-04 to 2008-07-14, , , b_red, 2008 ', + calc1 => 'User1User120141010 User1User120141010', + }, + written => 2, + errors => 0, + skipped => 0, + existing_data => [ + { + string1 => 'Foo', + integer1 => 50, + date1 => '2010-10-10', + enum1 => 'foo1', + tree1 => 'tree1', + daterange1 => ['2010-10-10', '2010-11-10'], + curval1 => 1, + }, + { + string1 => 'FooBar', + integer1 => 10, + date1 => '2010-10-10', + enum1 => 'foo1', + tree1 => 'tree1', + daterange1 => ['2010-10-10', '2010-11-10'], + curval1 => 1, + }, + ], + }, ); foreach my $test (@update_tests) { - my $sheet = $test->{existing_data} - ? t::lib::DataSheet->new(data => $test->{existing_data}) - : t::lib::DataSheet->new; + # Create initial records with this datetime + set_fixed_time('10/10/2014 01:00:00', '%m/%d/%Y %H:%M:%S'); + + my $curval_sheet = t::lib::DataSheet->new(instance_id => 2); + $curval_sheet->create_records; + my $schema = $curval_sheet->schema; + my %common = ( + curval => 2, + schema => $schema, + ); + if ($test->{calc_code}) + { + $common{calc_code} = $test->{calc_code}; + $common{calc_return_type} = 'string'; + } + my $sheet = $test->{existing_data} + ? t::lib::DataSheet->new(data => $test->{existing_data}, %common) + : t::lib::DataSheet->new(%common); - my $schema = $sheet->schema; my $layout = $sheet->layout; my $columns = $sheet->columns; $sheet->create_records; + # Then do upload with this datetime. With update_only, previous one + # should be used + set_fixed_time('05/05/2015 01:00:00', '%m/%d/%Y %H:%M:%S'); + my $user = $schema->resultset('User')->create({ username => 'test', password => 'test', }); - my $unique = $layout->column_by_name($test->{unique}); - $unique->isunique(1); - $unique->write; + my $unique_id; + if ($test->{unique}) + { + if ($test->{unique} eq 'ID') + { + $unique_id = -11; + } + else { + my $unique = $layout->column_by_name($test->{unique}); + $unique->isunique(1); + $unique->write; + $unique_id = $unique->id; + } + } my %options; if ($test->{option} eq 'update_unique') { - $options{update_unique} = $unique->id; + $options{update_unique} = $unique_id; } if ($test->{option} eq 'skip_existing_unique') { - $options{skip_existing_unique} = $unique->id; + $options{skip_existing_unique} = $unique_id; } if ($test->{option} eq 'no_change_unless_blank') { - $options{update_unique} = $unique->id; + $options{update_unique} = $unique_id; $options{no_change_unless_blank} = 'skip_new'; } + if ($test->{option} eq 'update_only') + { + $options{update_only} = 1; + $options{update_unique} = $unique_id; + } my $import = GADS::Import->new( schema => $schema, @@ -366,6 +448,13 @@ foreach my $test (@update_tests) ); is($records->count, $test->{count}, "Correct record count after import test $test->{name}"); + my $versions = $schema->resultset('Record')->search({ + instance_id => $sheet->instance_id, + },{ + join => 'current', + })->count; + is($versions, $test->{count_versions}, "Correct version count after import test $test->{name}") + if $test->{count_versions}; foreach my $field_name (keys %{$test->{results}}) { From 436531451cdff8b8eb77d54529610c312cce696a Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Sat, 2 Sep 2017 09:30:52 +0100 Subject: [PATCH 20/26] Write all values during import regardless --- lib/GADS/Import.pm | 81 ++++++++++++++++++++++------------------------ 1 file changed, 38 insertions(+), 43 deletions(-) diff --git a/lib/GADS/Import.pm b/lib/GADS/Import.pm index 24cb92440..872ecb485 100755 --- a/lib/GADS/Import.pm +++ b/lib/GADS/Import.pm @@ -595,55 +595,50 @@ sub update_fields if ($col->userinput && !$col->internal) # Not calculated fields { my $newv = $input->{$col->id}; - # If updating existing record, don't update if invalid value - # uploaded (value will be undefined) - if (!$record->current_id || defined $newv) + my $datum = $record->fields->{$col->id}; + my $old_value = $datum->as_string; + my $was_blank = $datum->blank; + + if ($self->_append_index->{$col->id}) { - my $datum = $record->fields->{$col->id}; - my $old_value = $datum->as_string; - my $was_blank = $datum->blank; + $newv =~ s/^\s+// if !$old_value; # Trim preceding line returns if no value to append to + # Make sure CR at end of old value if applicable + $old_value =~ s/\s+$//; + $old_value = "$old_value\n" if $old_value; + $newv = $old_value.$newv if $self->_append_index->{$col->id}; + } - if ($self->_append_index->{$col->id}) + # Don't update existing value if no_change_unless_blank is "skip_new" + if ($self->no_change_unless_blank eq 'skip_new' && $record->current_id && !$was_blank && !$self->_append_index->{$col->id}) + { + my $colname = $col->name; + my $newvalue = $col->fixedvals + ? $self->selects_reverse->{$col->id}->{$newv} + : $col->type eq 'daterange' + ? "$newv->[0] to $newv->[1]" + : $newv; + if (lc $old_value ne lc $newvalue) { - $newv =~ s/^\s+// if !$old_value; # Trim preceding line returns if no value to append to - # Make sure CR at end of old value if applicable - $old_value =~ s/\s+$//; - $old_value = "$old_value\n" if $old_value; - $newv = $old_value.$newv if $self->_append_index->{$col->id}; + push @$changes, qq(Not going to change value of "$colname" from "$old_value" to "$newvalue") } - - # Don't update existing value if no_change_unless_blank is "skip_new" - if ($self->no_change_unless_blank eq 'skip_new' && $record->current_id && !$was_blank && !$self->_append_index->{$col->id}) + elsif ($old_value ne $newvalue) { - my $colname = $col->name; - my $newvalue = $col->fixedvals - ? $self->selects_reverse->{$col->id}->{$newv} - : $col->type eq 'daterange' - ? "$newv->[0] to $newv->[1]" - : $newv; - if (lc $old_value ne lc $newvalue) - { - push @$changes, qq(Not going to change value of "$colname" from "$old_value" to "$newvalue") - } - elsif ($old_value ne $newvalue) - { - push @$changes, qq(Not going to change case of "$colname" from "$old_value" to "$newvalue") - unless $col->fixedvals; - } + push @$changes, qq(Not going to change case of "$colname" from "$old_value" to "$newvalue") + unless $col->fixedvals; } - else { - try { $datum->set_value($newv) }; - if (my $exception = $@->wasFatal) - { - push @bad, $exception->message->toString; - } - elsif ($self->report_changes && $record->current_id && $datum->changed && !$was_blank && !$self->_append_index->{$col->id}) - { - my $colname = $col->name; - my $newvalue = $datum->as_string; - push @$changes, qq(Change value of "$colname" from "$old_value" to "$newvalue") - if lc $old_value ne lc $newvalue; # Don't report change of case - } + } + else { + try { $datum->set_value($newv) }; + if (my $exception = $@->wasFatal) + { + push @bad, $exception->message->toString; + } + elsif ($self->report_changes && $record->current_id && $datum->changed && !$was_blank && !$self->_append_index->{$col->id}) + { + my $colname = $col->name; + my $newvalue = $datum->as_string; + push @$changes, qq(Change value of "$colname" from "$old_value" to "$newvalue") + if lc $old_value ne lc $newvalue; # Don't report change of case } } } From c8665ae93284be52b7ba242145bd5a473c1da0de Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Sat, 2 Sep 2017 09:56:42 +0100 Subject: [PATCH 21/26] Check for valid curval values during import --- lib/GADS/Column/Curval.pm | 17 +++++++++++++++++ lib/GADS/Datum/Curval.pm | 4 +--- t/014_import.t | 31 +++++++++++++++++++++++++++++++ 3 files changed, 49 insertions(+), 3 deletions(-) diff --git a/lib/GADS/Column/Curval.pm b/lib/GADS/Column/Curval.pm index f45d75568..aa70a4b63 100644 --- a/lib/GADS/Column/Curval.pm +++ b/lib/GADS/Column/Curval.pm @@ -621,6 +621,23 @@ sub _build_all_ids ]; } +sub validate +{ my ($self, $value, %options) = @_; + return 1 if !$value; + my $fatal = $options{fatal}; + if ($value !~ /^[0-9]+$/) + { + return 0 if !$fatal; + error __x"Value for {column} must be an integer", column => $self->name; + } + if (!$self->schema->resultset('Current')->search({ instance_id => $self->refers_to_instance, id => $value })->next) + { + return 0 if !$fatal; + error __x"{id} is not a valid record ID for {column}", id => $value, column => $self->name; + } + 1; +} + sub validate_search { my $self = shift; my ($value, %options) = @_; diff --git a/lib/GADS/Datum/Curval.pm b/lib/GADS/Datum/Curval.pm index 4cf2de916..a0df293c9 100644 --- a/lib/GADS/Datum/Curval.pm +++ b/lib/GADS/Datum/Curval.pm @@ -29,9 +29,7 @@ sub set_value { my ($self, $value) = @_; my $clone = $self->clone; # Copy before changing text my @values = sort grep {$_} ref $value eq 'ARRAY' ? @$value : ($value); - grep { - $_ !~ /^[0-9]+$/; - } @values and panic "Invalid value for ID"; + $self->column->validate($_, fatal => 1) foreach @values; my @old = sort @{$self->ids}; my $changed = "@values" ne "@old"; $self->_set_written_valid(!!@values); diff --git a/t/014_import.t b/t/014_import.t index 444ac949b..ad7f5b530 100644 --- a/t/014_import.t +++ b/t/014_import.t @@ -313,6 +313,37 @@ my @update_tests = ( }, ], }, + { + name => 'Invalid values', # Check we're not writing the record at all + option => 'update_unique', + data => "ID,integer1,date1,enum1,tree1,daterange1,curval1\n3,XX,,,,,\n3,,201-9,,,,\n3,,,foo4,,,\n3,,,,tree4,,\n3,,,,,2012-10-10 FF 2013-10-10,\n3,,,,,,9", + unique => 'ID', + count => 1, + count_versions => 1, + results => { + string1 => 'Foo', + integer1 => '50', + date1 => '2010-10-10', + enum1 => 'foo1', + tree1 => 'tree1', + daterange1 => '2010-10-10 to 2010-11-10', + curval1 => 'Foo, 50, foo1, , 2014-10-10, 2012-02-10 to 2013-06-15, , , c_amber, 2012', + }, + written => 0, + errors => 6, + skipped => 0, + existing_data => [ + { + string1 => 'Foo', + integer1 => 50, + date1 => '2010-10-10', + enum1 => 'foo1', + tree1 => 'tree1', + daterange1 => ['2010-10-10', '2010-11-10'], + curval1 => 1, + }, + ], + }, { name => 'Update existing records only', option => 'update_only', From d755a52c44a83e1815388fc9f5bca195b1e1b827 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Sat, 2 Sep 2017 10:07:09 +0100 Subject: [PATCH 22/26] Check for valid record ID for import update --- lib/GADS/Import.pm | 2 +- lib/GADS/Record.pm | 4 +++- t/014_import.t | 19 +++++++++++++++++++ 3 files changed, 23 insertions(+), 2 deletions(-) diff --git a/lib/GADS/Import.pm b/lib/GADS/Import.pm index 872ecb485..e4ffde05a 100755 --- a/lib/GADS/Import.pm +++ b/lib/GADS/Import.pm @@ -468,7 +468,7 @@ sub _import_rows { if ($self->update_unique == -11) # ID { - try { $record->find_current_id($unique_value) }; + try { $record->find_current_id($unique_value, $self->layout->instance_id) }; if ($@) { push @bad, qq(Failed to retrieve record ID $unique_value ($@). Data will not be uploaded.); diff --git a/lib/GADS/Record.pm b/lib/GADS/Record.pm index 91ddb0856..7a56e380d 100644 --- a/lib/GADS/Record.pm +++ b/lib/GADS/Record.pm @@ -408,11 +408,13 @@ sub find_record_id } sub find_current_id -{ my ($self, $current_id) = @_; +{ my ($self, $current_id, $search_instance_id) = @_; return unless $current_id; my $current = $self->schema->resultset('Current')->find($current_id) or error __x"Record ID {id} not found", id => $current_id; my $instance_id = $current->instance_id; + error __x"Record ID {id} invalid for table {table}", id => $current_id, table => $search_instance_id + if $search_instance_id && $search_instance_id != $current->instance_id; $self->_check_instance($instance_id); $self->_find(current_id => $current_id); } diff --git a/t/014_import.t b/t/014_import.t index ad7f5b530..aee3c416c 100644 --- a/t/014_import.t +++ b/t/014_import.t @@ -344,6 +344,25 @@ my @update_tests = ( }, ], }, + { + name => 'Attempt to update ID from different table', + option => 'update_unique', + data => "ID,string1\n1,Bar", # ID from curval table + unique => 'ID', + count => 1, + count_versions => 1, + results => { + string1 => 'Foo', + }, + written => 0, + errors => 0, + skipped => 1, + existing_data => [ + { + string1 => 'Foo', + }, + ], + }, { name => 'Update existing records only', option => 'update_only', From 5ac3d07e63f854c3eeb082699be598e26a8bc9ab Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Sat, 2 Sep 2017 15:18:13 +0100 Subject: [PATCH 23/26] Fix negative multivalue curval search --- lib/GADS/Records.pm | 78 +++++++++++++++++++++------------------------ t/003_search.t | 28 ++++++++++++++++ 2 files changed, 65 insertions(+), 41 deletions(-) diff --git a/lib/GADS/Records.pm b/lib/GADS/Records.pm index b07965446..b07155a50 100644 --- a/lib/GADS/Records.pm +++ b/lib/GADS/Records.pm @@ -104,7 +104,7 @@ sub view_limits_search if (keys %$decoded) { # Get the user search criteria - push @search, @{$self->_search_construct($decoded, $self->layout)}; + push @search, $self->_search_construct($decoded, $self->layout); } } } @@ -361,7 +361,7 @@ sub search_views { my $search = { 'me.instance_id' => $self->layout->instance_id, - @{$self->_search_construct($decoded, $self->layout, ignore_perms => 1, user => $user)}, + $self->_search_construct($decoded, $self->layout, ignore_perms => 1, user => $user), %{$self->record_later_search}, }; my $i = 0; my @ids; @@ -547,7 +547,7 @@ sub search_all_fields } # Produce a standard set of results without grouping -sub _build_results +sub _current_ids_rs { my $self = shift; # Build the search query first, to ensure that all join numbers are correct @@ -584,12 +584,16 @@ sub _build_results if $self->rewind; # Get the current IDs # Only take the latest record_single (no later ones) - my @cids = $self->schema->resultset('Current')->search( + $self->schema->resultset('Current')->search( [-and => $search_query], $select - )->get_column('me.id')->all; + )->get_column('me.id'); +} +sub _build_results +{ my $self = shift; + my @cids = $self->_current_ids_rs->all; # Now redo the query with those IDs. - @prefetches = $self->jpfetch(prefetch => 1, linked => 0); + my @prefetches = $self->jpfetch(prefetch => 1, linked => 0); unshift @prefetches, ( { 'createdby' => 'organisation', @@ -601,8 +605,9 @@ sub _build_results # We also add the join for record_later, so that we can take only the latest required record my @j = $self->jpfetch(sort => 1, prefetch => 0, linked => 0); my $rec2 = @j ? { record_single => [@j, 'record_later'] } : { record_single => 'record_later' }; + my @linked_prefetch = $self->linked_hash(prefetch => 1); - $select = { + my $select = { prefetch => [ $rec1, [@linked_prefetch], @@ -875,8 +880,7 @@ sub _query_params # Add any date ranges to the search from above if (@search_date) { - # _search_construct returns an array ref, so dereference it first - my @res = @{($self->_search_construct({condition => 'OR', rules => \@search_date}, $layout))}; + my @res = ($self->_search_construct({condition => 'OR', rules => \@search_date}, $layout)); push @limit, @res if @res; } @@ -893,7 +897,7 @@ sub _query_params if (keys %$decoded) { # Get the user search criteria - @search = @{$self->_search_construct($decoded, $layout, %options)}; + @search = $self->_search_construct($decoded, $layout, %options); } } } @@ -1006,7 +1010,7 @@ sub _search_construct push @final, @res if @res; } my $condition = $filter->{condition} && $filter->{condition} eq 'OR' ? '-or' : '-and'; - return @final ? [$condition => \@final] : []; + return @final ? ($condition => \@final) : (); } my %ops = ( @@ -1185,7 +1189,7 @@ sub _search_construct } my @final = map { - $self->_resolve($column, $_, \@values, 0, parent => $parent_column, %options); + $self->_resolve($column, $_, \@values, 0, parent => $parent_column, filter => $filter, %options); } @conditions; @final = ('-and' => [@final]); my $parent_column_link = $parent_column && $parent_column->link_parent;; @@ -1200,7 +1204,7 @@ sub _search_construct $link_parent = $column->link_parent; } my @final2 = map { - $self->_resolve($link_parent, $_, \@values, 1, parent => $parent_column_link, %options); + $self->_resolve($link_parent, $_, \@values, 1, parent => $parent_column_link, filter => $filter, %options); } @conditions; @final2 = ('-and' => [@final2]); @final = (['-or' => [@final], [@final2]]); @@ -1218,36 +1222,28 @@ sub _resolve # "foo" and "bar", then a search for "not foo" would still return the # "bar" and hence the whole record including "foo". We therefore have # to instead negate the record IDs containing that negative match. - if ($column->multivalue && $condition->{type} eq 'not_equal') + my $multivalue = $options{parent} ? $options{parent}->multivalue : $column->multivalue; + if ($multivalue && $condition->{type} eq 'not_equal') { - $value = @$value > 1 ? [ '-or' => @$value ] : $value->[0]; - my $subjoin = $column->subjoin; - my $table = $subjoin || $column->field; - +( + # Create a non-negative match of all the IDs that we don't want to + # match. Use a Records object so that all the normal requirements are + # dealt with, and pass it the current filter reversed + my $records = GADS::Records->new( + schema => $self->schema, + user => $self->user, + layout => $self->layout, + view => GADS::View->new( + filter => { %{$options{filter}}, operator => 'equal' }, # Switch + instance_id => $self->layout->instance_id, + layout => $self->layout, + schema => $self->schema, + user => $self->user, + ), + ); + return ( 'me.id' => { - -not_in => $self->schema->resultset('Current')->search({ - 'record_later.id' => undef, - "$table.$_->{s_field}" => $value, - }, { - select => "record_single.current_id", - join => [ - { - 'record_single' => [ - 'record_later', - $column->join, - ], - }, - { - linked => { # XXX needs testing and tests - 'record_single' => [ - 'record_later', - $column->join, - ], - }, - } - ], - } - )->as_query + # We want everything that is *not* those records + -not_in => $records->_current_ids_rs->as_query, } ); } diff --git a/t/003_search.t b/t/003_search.t index 127b2332b..bc791f4fd 100644 --- a/t/003_search.t +++ b/t/003_search.t @@ -607,6 +607,20 @@ my @filters = ( count => 1, no_errors => 1, }, + { + name => 'Search by curval ID not equal', + columns => [$columns->{string1}->id], + rules => [ + { + id => $columns->{curval1}->id, + type => 'string', + value => '2', + operator => 'not_equal', + }, + ], + count => 6, + no_errors => 1, + }, { name => 'Search curval ID and enum, only curval in view', columns => [$columns->{curval1}->id], # Ensure it's added as first join @@ -642,6 +656,20 @@ my @filters = ( count => 1, no_errors => 1, }, + { + name => 'Search by curval field not equal', + columns => [$columns->{string1}->id], + rules => [ + { + id => $columns->{curval1}->id .'_'. $curval_columns->{string1}->id, + type => 'string', + value => 'Bar', + operator => 'not_equal', + }, + ], + count => 6, + no_errors => 1, + }, { name => 'Search by curval enum field', columns => [$columns->{enum1}->id], From 61fecf672553ea9ea92adb58518b2101637fbf7a Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Sat, 2 Sep 2017 15:29:55 +0100 Subject: [PATCH 24/26] Fix rewind feature --- lib/GADS/Records.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/GADS/Records.pm b/lib/GADS/Records.pm index b07155a50..c3f66c8d2 100644 --- a/lib/GADS/Records.pm +++ b/lib/GADS/Records.pm @@ -580,8 +580,6 @@ sub _current_ids_rs $select->{rows} = $self->rows if $self->rows; $select->{page} = $page if $page; - local $GADS::Schema::Result::Record::REWIND = $self->rewind_formatted - if $self->rewind; # Get the current IDs # Only take the latest record_single (no later ones) $self->schema->resultset('Current')->search( @@ -591,6 +589,8 @@ sub _current_ids_rs sub _build_results { my $self = shift; + local $GADS::Schema::Result::Record::REWIND = $self->rewind_formatted + if $self->rewind; my @cids = $self->_current_ids_rs->all; # Now redo the query with those IDs. my @prefetches = $self->jpfetch(prefetch => 1, linked => 0); From 06aee2cdcc536979aeb209dfe4cef33fd3a5b605 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Sat, 2 Sep 2017 15:44:08 +0100 Subject: [PATCH 25/26] Add multivalue tests to rewind tests --- t/004_rewind.t | 280 +++++++++++++++++++++++++------------------------ 1 file changed, 142 insertions(+), 138 deletions(-) diff --git a/t/004_rewind.t b/t/004_rewind.t index ca4246ad7..782ad3b48 100644 --- a/t/004_rewind.t +++ b/t/004_rewind.t @@ -14,8 +14,6 @@ use GADS::RecordsGroup; use t::lib::DataSheet; -# We will use 3 dates for the data: all 10th October, but years 2014, 2015, 2016 -set_fixed_time('10/10/2014 01:00:00', '%m/%d/%Y %H:%M:%S'); $ENV{GADS_NO_FORK} = 1; my $data = [ @@ -25,142 +23,148 @@ my $data = [ }, ]; -my $sheet = t::lib::DataSheet->new(data => $data); -$sheet->create_records; - -my $schema = $sheet->schema; -my $layout = $sheet->layout; -my $string1 = $sheet->columns->{string1}; -my $integer1 = $sheet->columns->{integer1}; - -my $records = GADS::Records->new( - user => undef, - layout => $layout, - schema => $schema, -); - -is($records->count, 1, "Correct number of records on initial creation"); - -my $record = $records->single; - -# Make 2 further writes for subsequent 2 years -set_fixed_time('10/10/2015 01:00:00', '%m/%d/%Y %H:%M:%S'); -$record->fields->{$string1->id}->set_value('Foo2'); -$record->fields->{$integer1->id}->set_value('20'); -$record->write; -set_fixed_time('10/10/2016 01:00:00', '%m/%d/%Y %H:%M:%S'); -$record->fields->{$string1->id}->set_value('Foo3'); -$record->fields->{$integer1->id}->set_value('30'); -$record->write; - -# And a new record for the third year -$record->remove_id; -$record->fields->{$string1->id}->set_value('Foo10'); -$record->fields->{$integer1->id}->set_value('100'); -$record->write; - -$records->clear; -is($records->count, 2, "Correct number of records for today after second write"); - -# Go back to initial values (2014) -my $previous = DateTime->new( - year => 2015, - month => 01, - day => 01, - hour => 12, -); -# Use rewind feature and check records are as they were on previous date -$records = GADS::Records->new( - user => undef, - layout => $layout, - schema => $schema, - rewind => $previous, -); -is($records->count, 1, "Correct number of records for previous date (2014)"); - -$record = $records->single; - -is($record->fields->{$string1->id}->as_string, 'Foo1', "Correct old value for first record (2014)"); - -# Go back to second set (2015) -$previous->add(years => 1); -$records = GADS::Records->new( - user => undef, - layout => $layout, - schema => $schema, - rewind => $previous, -); -is($records->count, 1, "Correct number of records for previous date (2015)"); -$record = $records->single; -is($record->fields->{$string1->id}->as_string, 'Foo2', "Correct old value for first record (2015)"); - -# And back to today -$records = GADS::Records->new( - user => undef, - layout => $layout, - schema => $schema, -); -is($records->count, 2, "Correct number of records for current date"); -$record = $records->single; -is($record->fields->{$string1->id}->as_string, 'Foo3', "Correct value for first record current date"); - -# Retrieve single record -$record = GADS::Record->new( - user => undef, - layout => $layout, - schema => $schema, -); -$record->find_current_id(1); -is($record->fields->{$string1->id}->as_string, 'Foo3', "Correct value for first record current date, single retrieve"); -$record = GADS::Record->new( - user => undef, - layout => $layout, - schema => $schema, - rewind => $previous, -); -$record->find_current_id(1); -is($record->fields->{$string1->id}->as_string, 'Foo2', "Correct old value for first record (2015), single retrieve"); -# Try an edit - should bork -$record->fields->{$string1->id}->set_value('Bar'); -try { $record->write }; -ok($@, "Unable to write to record from historic retrieval"); - -# Do a graph check from a rewind date -my $graph = GADS::Graph->new( - title => 'Rewind graph', - layout => $layout, - schema => $schema, - type => 'bar', - x_axis => $string1->id, - y_axis => $integer1->id, - y_axis_stack => 'sum', -); -$graph->write; -$records = GADS::RecordsGroup->new( - user => undef, - layout => $layout, - schema => $schema, -); -my $graph_data = GADS::Graph::Data->new( - id => $graph->id, - records => $records, - schema => $schema, -); -is_deeply($graph_data->xlabels, ['Foo10','Foo3'], "Graph labels for current date correct"); -is_deeply($graph_data->points, [[100,30]], "Graph data for current date correct"); -$records = GADS::RecordsGroup->new( - user => undef, - layout => $layout, - schema => $schema, - rewind => $previous, -); -$graph_data = GADS::Graph::Data->new( - id => $graph->id, - records => $records, - schema => $schema, -); -is_deeply($graph_data->xlabels, ['Foo2'], "Graph data for previous date is correct"); -is_deeply($graph_data->points, [[20]], "Graph labels for previous date is correct"); +foreach my $multivalue (0..1) +{ + # We will use 3 dates for the data: all 10th October, but years 2014, 2015, 2016 + set_fixed_time('10/10/2014 01:00:00', '%m/%d/%Y %H:%M:%S'); + + my $sheet = t::lib::DataSheet->new(data => $data, multivalue => $multivalue); + $sheet->create_records; + + my $schema = $sheet->schema; + my $layout = $sheet->layout; + my $string1 = $sheet->columns->{string1}; + my $integer1 = $sheet->columns->{integer1}; + + my $records = GADS::Records->new( + user => undef, + layout => $layout, + schema => $schema, + ); + + is($records->count, 1, "Correct number of records on initial creation"); + + my $record = $records->single; + + # Make 2 further writes for subsequent 2 years + set_fixed_time('10/10/2015 01:00:00', '%m/%d/%Y %H:%M:%S'); + $record->fields->{$string1->id}->set_value('Foo2'); + $record->fields->{$integer1->id}->set_value('20'); + $record->write; + set_fixed_time('10/10/2016 01:00:00', '%m/%d/%Y %H:%M:%S'); + $record->fields->{$string1->id}->set_value('Foo3'); + $record->fields->{$integer1->id}->set_value('30'); + $record->write; + + # And a new record for the third year + $record->remove_id; + $record->fields->{$string1->id}->set_value('Foo10'); + $record->fields->{$integer1->id}->set_value('100'); + $record->write; + + $records->clear; + is($records->count, 2, "Correct number of records for today after second write"); + + # Go back to initial values (2014) + my $previous = DateTime->new( + year => 2015, + month => 01, + day => 01, + hour => 12, + ); + # Use rewind feature and check records are as they were on previous date + $records = GADS::Records->new( + user => undef, + layout => $layout, + schema => $schema, + rewind => $previous, + ); + is($records->count, 1, "Correct number of records for previous date (2014) $multivalue"); + + $record = $records->single; + + is($record->fields->{$string1->id}->as_string, 'Foo1', "Correct old value for first record (2014)"); + + # Go back to second set (2015) + $previous->add(years => 1); + $records = GADS::Records->new( + user => undef, + layout => $layout, + schema => $schema, + rewind => $previous, + ); + is($records->count, 1, "Correct number of records for previous date (2015)"); + $record = $records->single; + is($record->fields->{$string1->id}->as_string, 'Foo2', "Correct old value for first record (2015)"); + + # And back to today + $records = GADS::Records->new( + user => undef, + layout => $layout, + schema => $schema, + ); + is($records->count, 2, "Correct number of records for current date"); + $record = $records->single; + is($record->fields->{$string1->id}->as_string, 'Foo3', "Correct value for first record current date"); + + # Retrieve single record + $record = GADS::Record->new( + user => undef, + layout => $layout, + schema => $schema, + ); + $record->find_current_id(1); + is($record->fields->{$string1->id}->as_string, 'Foo3', "Correct value for first record current date, single retrieve"); + $record = GADS::Record->new( + user => undef, + layout => $layout, + schema => $schema, + rewind => $previous, + ); + $record->find_current_id(1); + is($record->fields->{$string1->id}->as_string, 'Foo2', "Correct old value for first record (2015), single retrieve"); + # Try an edit - should bork + $record->fields->{$string1->id}->set_value('Bar'); + try { $record->write }; + ok($@, "Unable to write to record from historic retrieval"); + + # Do a graph check from a rewind date + my $graph = GADS::Graph->new( + title => 'Rewind graph', + layout => $layout, + schema => $schema, + type => 'bar', + x_axis => $string1->id, + y_axis => $integer1->id, + y_axis_stack => 'sum', + ); + $graph->write; + $records = GADS::RecordsGroup->new( + user => undef, + layout => $layout, + schema => $schema, + ); + my $graph_data = GADS::Graph::Data->new( + id => $graph->id, + records => $records, + schema => $schema, + ); + is_deeply($graph_data->xlabels, ['Foo10','Foo3'], "Graph labels for current date correct"); + is_deeply($graph_data->points, [[100,30]], "Graph data for current date correct"); + $records = GADS::RecordsGroup->new( + user => undef, + layout => $layout, + schema => $schema, + rewind => $previous, + ); + $graph_data = GADS::Graph::Data->new( + id => $graph->id, + records => $records, + schema => $schema, + ); + is_deeply($graph_data->xlabels, ['Foo2'], "Graph data for previous date is correct"); + is_deeply($graph_data->points, [[20]], "Graph labels for previous date is correct"); +} restore_time(); From c83f2b427a252240505ed8c603d9945b1d2a12c5 Mon Sep 17 00:00:00 2001 From: Andy Beverley Date: Sat, 2 Sep 2017 16:39:46 +0100 Subject: [PATCH 26/26] Handle invalid columns in filters cleanly --- lib/GADS/Filter.pm | 14 ++++++++++---- lib/GADS/View.pm | 3 ++- t/011_views.t | 47 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 59 insertions(+), 5 deletions(-) diff --git a/lib/GADS/Filter.pm b/lib/GADS/Filter.pm index 8be22c50c..81b3e2fbc 100644 --- a/lib/GADS/Filter.pm +++ b/lib/GADS/Filter.pm @@ -101,7 +101,8 @@ sub base64 foreach my $filter (@{$self->filters}) { $self->layout or panic "layout has not been set in filter"; - my $col = $self->layout->column($filter->{column_id}); + my $col = $self->layout->column($filter->{column_id}) + or next; # Ignore invalid - possibly since deleted if ($col->has_filter_typeahead) { $filter->{data} = { @@ -140,20 +141,20 @@ has filters => ( sub _build_filters { my $self = shift; my $cols_in_filter = []; - _filter_tables($self->as_hash, $cols_in_filter); + $self->_filter_tables($self->as_hash, $cols_in_filter); $cols_in_filter; } # Recursively find all tables in a nested filter sub _filter_tables -{ my ($filter, $tables) = @_; +{ my ($self, $filter, $tables) = @_; if (my $rules = $filter->{rules}) { # Filter has other nested filters foreach my $rule (@$rules) { - _filter_tables($rule, $tables); + $self->_filter_tables($rule, $tables); } } elsif (my $id = $filter->{id}) { @@ -164,6 +165,11 @@ sub _filter_tables else { $filter->{column_id} = $filter->{id}; } + # If we have a layout, remove any invalid columns + if ($self->layout && !$self->layout->column($filter->{column_id})) + { + delete $filter->{$_} foreach keys %$filter; + } push @$tables, $filter; # Keep as reference so can be updated by other functions } } diff --git a/lib/GADS/View.pm b/lib/GADS/View.pm index 8e92b81cb..226672295 100644 --- a/lib/GADS/View.pm +++ b/lib/GADS/View.pm @@ -281,7 +281,8 @@ sub write # access to them. foreach my $filter (@{$self->filter->filters}) { - my $col = $self->layout->column($filter->{column_id}); + my $col = $self->layout->column($filter->{column_id}) + or error __x"Field ID {id} does not exist", id => $filter->{column_id}; my $val = $filter->{value}; my $op = $filter->{operator}; my $rtype = $col->return_type; diff --git a/t/011_views.t b/t/011_views.t index 5d2502179..aed3f4ebc 100644 --- a/t/011_views.t +++ b/t/011_views.t @@ -2,7 +2,9 @@ use Test::More; # tests => 1; use strict; use warnings; +use JSON qw(decode_json encode_json); use Log::Report; +use MIME::Base64; use t::lib::DataSheet; @@ -71,6 +73,51 @@ $view = GADS::View->new(%view_template, id => -10); is($view->name, undef, "Blank name for invalid view"); is(@{$view->columns}, 0, "No columns for invalid view"); +# Try and load a view with an invalid column in the filter (e.g. deleted) +my $filter = GADS::Filter->new( + as_hash => { + rules => [ + { + id => 100, + type => 'string', + value => 'foo2', + operator => 'equal', + }, + ], + condition => 'equal', + }, +); +$view = GADS::View->new( + name => 'Test', + filter => $filter, + instance_id => $layout->instance_id, + layout => $layout, + schema => $schema, + user => $user_admin, +); +try { $view->write }; +like($@, qr/does not exist/, "Sensible error message for invalid field ID"); +# Remove invalid filter to allow view to be written +$view->filter(undef); +$view->write; +# Force it into database (as if field deleted since view written) +$schema->resultset('View')->find($view->id)->update({ + filter => $filter->as_json, +}); +$view = GADS::View->new( + id => $view->id, + instance_id => $layout->instance_id, + layout => $layout, + schema => $schema, + user => $user_admin, +); +# Check the invalid column as been removed for the base64 representation going +# to the template. +# Need to compare as hash to ensure consistency +my $hash = {rules => [{}], condition => 'equal'}; +is_deeply(decode_json(decode_base64($view->filter->base64)), $hash, "Invalid rule removed from base64 of filter"); + +# Check view names that are too long for the DB my $long = 'Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum'; $view = GADS::View->new(