dbsrgits · kiwiroy · Apr 15, 2024
diff --git a/lib/SQL/Translator/Parser/SQLite.pm b/lib/SQL/Translator/Parser/SQLite.pm
@@ -252,8 +252,23 @@ create : comment(s?) CREATE TEMPORARY(?) TABLE table_name '(' definition(s /,/)
         for my $def ( @{ $item[7] } ) {
             if ( $def->{'supertype'} eq 'column' ) {
                 push @{ $tables{ $table_name }{'fields'} }, $def;
+                if (my $check = $def->{check}) {
+                  my ($constraint) = grep { exists $_->{type} && $_->{type} eq 'check' } @{$def->{constraints}};
+                  push @{ $tables{ $table_name }{'constraints'} }, {
+                    comments => $def->{comments},
+                    expression => $check,
+                    fields => [ $def->{name} ],
+                    on_conflict => $constraint->{on_conflict},
+                    type => 'check',
+                  };
+                }
             }
             elsif ( $def->{'supertype'} eq 'constraint' ) {
+                if ($def->{type} eq 'check') {
+                  my $expression = $def->{expression};
+                  push @{$def->{fields}}, $_
+                    for (grep { $expression =~ m/\b\Q$_\E\b/ } map { $_->{name} } @{$tables{$table_name}{fields}});
+                }
                 push @{ $tables{ $table_name }{'constraints'} }, $def;
             }
         }
@@ -289,7 +304,7 @@ column_def: comment(s?) NAME type(?) column_constraint_def(s?)
                 $column->{'is_unique'} = 1;
             }
             elsif ( $c->{'type'} eq 'check' ) {
-                $column->{'check'} = $c->{'expression'};
+                ($column->{'check'} = $c->{'expression'}) =~ s/(^\s*|\s$)//g;
             }
             elsif ( $c->{'type'} eq 'default' ) {
                 $column->{'default'} = $c->{'value'};
@@ -344,11 +359,11 @@ column_constraint : NOT_NULL conflict_clause(?)
         }
     }
     |
-    CHECK_C '(' expr ')' conflict_clause(?)
+    CHECK_C '(' expr(s /(?^ui:(AND|OR))/) ')' conflict_clause(?) # ?^ in perl >= 5.14
     {
         $return = {
             type        => 'check',
-            expression  => $item[3],
+            expression  => join(' ', @{$item[3]}),
             on_conflict => $item[5][0],
         }
     }
@@ -416,12 +431,14 @@ table_constraint : PRIMARY_KEY parens_field_list conflict_clause(?)
         }
     }
     |
-    CHECK_C '(' expr ')' conflict_clause(?)
+    CHECK_C '(' expr(s /(?^ui:(AND|OR))/) ')' conflict_clause(?)
     {
+        # trim whitespace
+        (my $exp = join(' ', @{$item[3]})) =~ s/(^\s*|\s*$)//g;
         $return         = {
             supertype   => 'constraint',
             type        => 'check',
-            expression  => $item[3],
+            expression  => $exp,
             on_conflict => $item[5][0],
         }
     }
@@ -478,7 +495,11 @@ column_list : field_name(s /,/)
 parens_value_list : '(' VALUE(s /,/) ')'
     { $item[2] }
 
-expr : /[^)]* \( [^)]+ \) [^)]*/x # parens, balanced one deep
+function_call : /(\w* ( \( ( (?:(?>[^()]+)|(?2))* ) \) ) )/x # from perldoc perlre
+
+expr : function_call '=' literal { $return = join ' ', @item[1..3] }
+    | function_call
+    | /[^)]* \( [^)]+ \) [^)]*/x # parens, balanced one deep
     | /[^)]+/
 
 sort_order : /(ASC|DESC)/i
@@ -538,6 +559,9 @@ nonstring : /[^;\'"]+/
 
 statement_body : string | nonstring
 
+literal : /[-+]?\d*\.?\d+(?:[eE]\d+)?/
+    | string
+
 trigger_step : /(select|delete|insert|update)/i statement_body(s?) SEMICOLON
     {
         $return = join( ' ', $item[1], join ' ', @{ $item[2] || [] } )
@@ -718,6 +742,7 @@ sub parse {
         on_delete        => $cdata->{'on_delete'}  || $cdata->{'on_delete_do'},
         on_update        => $cdata->{'on_update'}  || $cdata->{'on_update_do'},
       ) or die $table->error;
+      $constraint->expression($cdata->{expression}) if defined $cdata->{expression} and $cdata->{expression} =~ m/\w+/;
     }
   }
 

diff --git a/t/23json.t b/t/23json.t
@@ -147,8 +147,8 @@ my $json = from_json(<<JSON);
             "constraints" : [
                {
                   "deferrable" : 1,
-                  "expression" : "",
-                  "fields" : [],
+                  "expression" : "age < 100",
+                  "fields" : ["age"],
                   "match_type" : "",
                   "name" : "",
                   "on_delete" : "",

diff --git a/t/24yaml.t b/t/24yaml.t
@@ -122,8 +122,8 @@ schema:
     pet:
       constraints:
         - deferrable: 1
-          expression: ''
-          fields: []
+          expression: 'age < 100'
+          fields: ['age']
           match_type: ''
           name: ''
           on_delete: ''

diff --git a/t/27sqlite-parser.t b/t/27sqlite-parser.t
@@ -10,7 +10,7 @@ use SQL::Translator;
 use SQL::Translator::Schema::Constants;
 
 BEGIN {
-  maybe_plan(26, 'SQL::Translator::Parser::SQLite');
+  maybe_plan(64, 'SQL::Translator::Parser::SQLite');
 }
 SQL::Translator::Parser::SQLite->import('parse');
 
@@ -49,6 +49,12 @@ my $file = "$Bin/data/sqlite/create.sql";
   is($c1->reference_table,             'person',      'References person table');
   is(join(',', $c1->reference_fields), 'person_id',   'References person_id field');
 
+  my $c0 = shift @constraints;
+  is($c0->type,       'CHECK',     'CHECK constraint');
+  is($c0->expression, 'age < 100', 'contraint expression');
+  is_deeply([ $c0->field_names ], ['age'], 'fields that check refers to');
+  is($c0->table, 'pet', 'table name is pet');
+
   my @views = $schema->get_views;
   is(scalar @views, 1, 'Parsed one views');
 
@@ -75,6 +81,13 @@ $file = "$Bin/data/sqlite/named.sql";
   my @constraints = $t1->get_constraints;
   is(scalar @constraints, 5, '5 constraints on pet');
 
+  my $c0 = $constraints[0];
+  is($c0->type, 'CHECK',         'constraint has correct type');
+  is($c0->name, 'age_under_100', 'constraint check has correct name');
+  is_deeply([ $c0->field_names ], ['age'], 'fields that check refers to');
+  is($c0->table,      'pet',                                 'table name is pet');
+  is($c0->expression, 'age < 100 and age not in (101, 102)', 'constraint expression');
+
   my $c1 = $constraints[2];
   is($c1->type,                        'FOREIGN KEY',  'FK constraint');
   is($c1->reference_table,             'person',       'References person table');
@@ -92,3 +105,45 @@ $file = "$Bin/data/sqlite/named.sql";
   is($c3->on_delete, '',          'On delete not defined');
 
 }
+
+$file = "$Bin/data/sqlite/checks.sql";
+{
+  local $/;
+  open my $fh, "<$file" or die "Can't read file '$file': $!\n";
+  my $data = <$fh>;
+  my $t    = SQL::Translator->new(trace => 0, debug => 0);
+  parse($t, $data);
+
+  my $schema = $t->schema;
+
+  my @tables = $schema->get_tables;
+  is(scalar @tables, 2, 'Parsed one table');
+
+  is($tables[0]->name, 'pet',        "'Pet' table");
+  is($tables[1]->name, 'zoo_animal', "'Zoo Amimal' table");
+
+  for my $t1 (@tables) {
+    my @fields = $t1->get_fields;
+    is(scalar @fields, 4, 'Four fields in "pet" table');
+
+    my $visits = $fields[3];
+    is($visits->name,          'vet_visits', 'field name correct');
+    is($visits->default_value, '[]',         'default value is empty array');
+    is($visits->is_nullable,   0,            'not null');
+
+    my @constraints = $t1->get_constraints;
+    is(scalar @constraints, 2, '2 constraints on pet');
+
+    my $c0 = $constraints[0];
+    is($c0->type, 'CHECK', 'constraint has correct type');
+    is_deeply([ $c0->field_names ], ['vet_visits'], 'fields that check refers to');
+    is($c0->table,      $t1->name,                                                     'table name is pet');
+    is($c0->expression, q{json_valid(vet_visits) and json_type(vet_visits) = 'array'}, 'constraint expression');
+
+    my $c1 = $constraints[1];
+    is($c1->type,              'PRIMARY KEY',      'PK constraint');
+    is($c1->table,             $t1->name,          'pet table');
+    is($c1->name,              'pk_pet',           'Constraint name pk_pet');
+    is(join(',', $c1->fields), 'pet_id,person_id', 'References person_id field');
+  }
+}
diff --git a/t/data/sqlite/checks.sql b/t/data/sqlite/checks.sql
@@ -0,0 +1,16 @@
+create table pet (
+  "pet_id" int,
+  "person_id" int,
+  "name" varchar(30),
+  "vet_visits" text not null check(json_valid(vet_visits) and json_type(vet_visits) = 'array') default '[]',
+  constraint pk_pet primary key (pet_id, person_id)
+);
+
+create table zoo_animal (
+    "pet_id" int,
+    "person_id" int,
+    "name" varchar(30),
+    "vet_visits" text not null default '[]',
+    constraint ck_json_array check(json_valid(vet_visits) and json_type(vet_visits) = 'array'),
+    constraint pk_pet primary key (pet_id, person_id)
+);