File Coverage

lib/Parse/Dia/SQL/Output/SQLite3.pm

Criterion	Covered	Total	%
statement	18	18	100.0
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	24	24	100.0

package Parse::Dia::SQL::Output::SQLite3;

# $Id: SQLite3.pm,v 1.5 2009/05/14 09:42:47 aff Exp $

=pod

=head1 NAME

Parse::Dia::SQL::Output::SQLite3 - Create SQL for SQLite version 3.

=head1 SYNOPSIS

    use Parse::Dia::SQL;
    my $dia = Parse::Dia::SQL->new(file => 'foo.dia', db => 'sqlite3');
    print $dia->get_sql();

=head1 DESCRIPTION

This sub-class creates SQL for the SQLite database version 3.

=cut

use warnings;
use strict;

use Data::Dumper;
use File::Spec::Functions qw(catfile);

use lib q{lib};
use base q{Parse::Dia::SQL::Output};    # extends

require Parse::Dia::SQL::Logger;
require Parse::Dia::SQL::Const;

=head2 new

The constructor.

Object names in SQLite have no inherent limit. 60 has been arbitrarily chosen.

=cut

sub new {
  my ( $class, %param ) = @_;
  my $self = {};

  # Set defaults for sqlite
  $param{db} = q{sqlite3};
  $param{object_name_max_length} = $param{object_name_max_length} || 60;

  $self = $class->SUPER::new( %param );
  bless( $self, $class );

  return $self;
}

=head2 _get_create_table_sql

Generate create table statement for a single table using SQLite
syntax:

Includes class comments before the table definition.

Includes autoupdate triggers based on the class comment.

=head3 autoupdate triggers

If the class comment includes a line like:

/>

Then an 'after update' trigger is generated for this table which
executes the statement I for the updated row.

Examples of use include tracking record modification dates
(C<>) or deriving a value from
another field (C<>)

=cut

sub _get_create_table_sql {

  my ( $self, $table ) = @_;
  my $sqlstr = '';
  my $temp;
  my $comment;
  my $tablename;
  my $trigger = '';
  my $update;
  my $primary_keys = '';

  # include the comments before the table creation
  $comment = $table->{comment};
  if ( !defined( $comment ) ) { $comment = ''; }
  $tablename = $table->{name};
  $sqlstr .= $self->{newline};
  if ( $comment ne "" ) {
    $temp = "-- $comment";
    $temp =~ s/\n/\n-- /g;
    $temp =~ s/^-- $//mgi;
    if ( $temp ne "" ) {
      if ( $temp !~ /\n$/m ) { $temp .= $self->{newline}; }
      $sqlstr .= $temp;
    }
  }

  # Call the base class to generate the main create table statements
  $sqlstr .= $self->SUPER::_get_create_table_sql( $table );

  # Generate update triggers if required
  if ( $comment =~ //mi ) {
    $update  = $3;    # what we will set it to
    $trigger = $2;    # the trigger suffix to use (optional)
    $trigger = $tablename . "_autoupdate" . $trigger;

    # Check that the column exists
    foreach $temp ( @{ $table->{attList} } ) {

      # build the two primary key elements
      if ( $$temp[3] == 2 ) {
        if ( $primary_keys ) { $primary_keys .= " and "; }
        $primary_keys .= $$temp[0] . "=OLD." . $$temp[0];
      }
    }

    $sqlstr .=
        "drop trigger if exists $trigger"
      . $self->{end_of_statement}
      . $self->{newline};

    $sqlstr .=
"create trigger $trigger after update on $tablename begin update $tablename set $update where $primary_keys;end"
      . $self->{end_of_statement}
      . $self->{newline};

    $sqlstr .= $self->{newline};
  }

  return $sqlstr;
}

=head2 get_schema_drop

Generate drop table statements for all tables using SQLite syntax:

  drop table {foo} if exists

=cut

sub get_schema_drop {
  my $self   = shift;
  my $sqlstr = '';

  return unless $self->_check_classes();

CLASS:
  foreach my $object ( @{ $self->{classes} } ) {
    next CLASS if ( $object->{type} ne q{table} );

    # Sanity checks on internal state
    if (!defined( $object )
      || ref( $object ) ne q{HASH}
      || !exists( $object->{name} ) )
    {
      $self->{log}
        ->error( q{Error in table input - cannot create drop table sql!} );
      next;
    }

    $sqlstr .=
        qq{drop table if exists }
      . $object->{name}
      . $self->{end_of_statement}
      . $self->{newline};
  }

  return $sqlstr;
}

=head2 get_view_drop

Generate drop view statements for all tables using SQLite syntax:

  drop view {foo} if exists

=cut

# Create drop view for all views
sub get_view_drop {
  my $self   = shift;
  my $sqlstr = '';

  return unless $self->_check_classes();

CLASS:
  foreach my $object ( @{ $self->{classes} } ) {
    next CLASS if ( $object->{type} ne q{view} );

    # Sanity checks on internal state
    if (!defined( $object )
      || ref( $object ) ne q{HASH}
      || !exists( $object->{name} ) )
    {
      $self->{log}
        ->error( q{Error in table input - cannot create drop table sql!} );
      next;
    }

    $sqlstr .=
        qq{drop view if exists }
      . $object->{name}
      . $self->{end_of_statement}
      . $self->{newline};
  }

  return $sqlstr;

}

=head2 _get_fk_drop

Drop foreign key enforcement triggers using SQLite syntax:

  drop trigger {foo} if exists

The automatically generated foreign key enforcement triggers are:

See L<"_get_create_association_sql"> for more details.

=over

=item I_bi_tr

=item I_bu_tr

=item I_buparent_tr

=item I_bdparent_tr

=back

=cut

# Drop all foreign keys
sub _get_fk_drop {
  my $self   = shift;
  my $sqlstr = '';
  my $temp;

  return unless $self->_check_associations();

  # drop fk
  foreach my $association ( @{ $self->{associations} } ) {
    my ( $table_name, $constraint_name, undef, undef, undef, undef ) =
      @{$association};

    $temp = $constraint_name . "_bi_tr";
    $sqlstr .=
        qq{drop trigger if exists $temp}
      . $self->{end_of_statement}
      . $self->{newline};

    $temp = $constraint_name . "_bu_tr";
    $sqlstr .=
        qq{drop trigger if exists $temp}
      . $self->{end_of_statement}
      . $self->{newline};

    $temp = $constraint_name . "_buparent_tr";
    $sqlstr .=
        qq{drop trigger if exists $temp}
      . $self->{end_of_statement}
      . $self->{newline};

    $temp = $constraint_name . "_bdparent_tr";
    $sqlstr .=
        qq{drop trigger if exists $temp}
      . $self->{end_of_statement}
      . $self->{newline};

    $sqlstr .= $self->{newline};

  }
  return $sqlstr;
}

=head2 _get_drop_index_sql

drop index statement using SQLite syntax:

  drop index {foo} if exists

=cut

sub _get_drop_index_sql {
  my ( $self, $tablename, $indexname ) = @_;
  return
      qq{drop index if exists $indexname}
    . $self->{end_of_statement}
    . $self->{newline};
}

=head2 get_permissions_create

SQLite doesn't support permissions, so suppress this output.

=cut

sub get_permissions_create {
  return '';
}

=head2 get_permissions_drop

SQLite doesn't support permissions, so suppress this output.

=cut

sub get_permissions_drop {
  return '';
}

=head2 _get_create_association_sql

Create the foreign key enforcement triggers using SQLite syntax:

  create trigger {fkname}[_bi_tr|_bu_tr|_bdparent_tr|_buparent_tr]

Because SQLite doesn't natively enforce foreign key constraints (see L),
we use triggers to emulate this behaviour.

The trigger names are the default contraint name (something like I_fk_I) with suffixes described below.

=over

=item I<{constraint_name}> is the name of the association, either specified or generated.

=item I<{child_table}> is the name of the dependent or child table.

=item I<{child_fkcolumn}> is the field in the dependent table that hold the foreign key.

=item I<{parent_table}> is the name of the parent table.

=item I<{parent_key}> is the key field of the parent table.

=back

=head3 Before insert - Dependent Table

I_bi_tr

Before insert on the child table require that the parent key exists.

  create trigger {constraint_name}_bi_tr before insert on {child_table}
    for each row
      begin
        select
          raise(abort, 'insert on table {child_table} violates foreign key constraint {constraint_name}')
          where new.{child_fkcolumn} is not null and (select {parent_key} from {parent_table} where {parent_key}=new.{child_fkcolumn}) is null;
      end;

=head3 Before update - Dependent Table

I_bu_tr

Before update on the child table require that the parent key exists.

  create trigger {constraint_name}_bu_tr before update on {table_name}
    for each row
      begin
        select raise(abort, 'update on table {child_table} violates foreign key constraint {constraint_name}')
        where new.{child_fkcolumn} is not null and (select {parent_key} from {parent_table} where {parent_key}=new.{child_fkcolumn}) is null;
      end;


=head3 Before update - Parent Table

I_buparent_tr

Before update on the primary key of the parent table ensure that there are no dependent child records.
Note that cascading updates B.

  create trigger {constraint_name}_buparent_tr before update on {parent_table}
    for each row when new.{parent_key} <> old.{parent_key}
      begin
        select raise(abort, 'update on table {parent_table} violates foreign key constraint {constraint_name} on {child_table}')
        where (select {child_fkcolumn} from {child_table} where {child_fkcolumn}=old.{parent_key}) is not null;
      end;

=head3 Before delete - Parent Table

I_bdparent_tr

The default behaviour can be modified through the contraint (in the multiplicity field) of the association.

=head4 Default (On Delete Restrict)

Before delete on the parent table ensure that there are no dependent child records.

  create trigger {constraint_name}_bdparent_tr before delete on {parent_table}
    for each row
      begin
        select raise(abort, 'delete on table {parent_table} violates foreign key constraint {constraint_name} on {child_table}')
        where (select {child_fkcolumn} from {child_table} where {child_fkcolumn}=old.{parent_key}) is not null;
      end;

=head4 On Delete Cascade

Before delete on the parent table delete all dependent child records.

  create trigger {constraint_name}_bdparent_tr before delete on {parent_table}
    for each row
      begin
        delete from {child_table} where {child_table}.{child_fkcolumn}=old.{parent_key};
      end;

=head4 On Delete Set Null

Before delete on the parent table set the foreign key field(s) in all dependent child records to NULL.

  create trigger {constraint_name}_bdparent_tr before delete on {parent_table}
    for each row
      begin
        update {child_table} set {child_table}.{child_fkcolumn}=null where {child_table}.{child_fkcolumn}=old.{parent_key};
      end;

=cut

# Create sql for given association.
sub _get_create_association_sql {
  my ( $self, $association ) = @_;
  my $sqlstr = '';
  my $temp;

  # Sanity checks on input
  if ( ref( $association ) ne 'ARRAY' ) {
    $self->{log}
      ->error( q{Error in association input - cannot create association sql!} );
    return;
  }

  # FK constraints are implemented as triggers in SQLite

  my (
    $table_name, $constraint_name, $key_column,
    $ref_table,  $ref_column,      $constraint_action
  ) = @{$association};

  # Shorten constraint name, if necessary (DB2 only)
  $constraint_name = $self->_create_constraint_name( $constraint_name );

  $temp = $constraint_name . "_bi_tr";
  $sqlstr .=
qq{create trigger $temp before insert on $table_name for each row begin select raise(abort, 'insert on table $table_name violates foreign key constraint $constraint_name') where new.$key_column is not null and (select $ref_column from $ref_table where $ref_column=new.$key_column) is null;end}
    . $self->{end_of_statement}
    . $self->{newline};

  $temp = $constraint_name . "_bu_tr";
  $sqlstr .=
qq{create trigger $temp before update on $table_name for each row begin select raise(abort, 'update on table $table_name violates foreign key constraint $constraint_name') where new.$key_column is not null and (select $ref_column from $ref_table where $ref_column=new.$key_column) is null;end}
    . $self->{end_of_statement}
    . $self->{newline};

  # note that the before delete triggers are on the parent ($ref_table)
  $temp = $constraint_name . "_bdparent_tr";
  if ( $constraint_action =~ /on delete cascade/i ) {
    $sqlstr .=
qq{create trigger $temp before delete on $ref_table for each row begin delete from $table_name where $table_name.$key_column=old.$ref_column;end}
      . $self->{end_of_statement}
      . $self->{newline};
  } elsif ( $constraint_action =~ /on delete set null/i ) {
    $sqlstr .=
qq{create trigger $temp before delete on $ref_table for each row begin update $table_name set $key_column=null where $table_name.$key_column=old.$ref_column;end}
      . $self->{end_of_statement}
      . $self->{newline};
  } else    # default on delete restrict
  {
    $sqlstr .=
qq{create trigger $temp before delete on $ref_table for each row begin select raise(abort, 'delete on table $ref_table violates foreign key constraint $constraint_name on $table_name') where (select $key_column from $table_name where $key_column=old.$ref_column) is not null;end}
      . $self->{end_of_statement}
      . $self->{newline};
  }

  # Cascade updates doesn't work, so we always restrict
  $temp = $constraint_name . "_buparent_tr";
  $sqlstr .=
qq{create trigger $temp before update on $ref_table for each row when new.$ref_column <> old.$ref_column begin select raise(abort, 'update on table $ref_table violates foreign key constraint $constraint_name on $table_name') where (select $key_column from $table_name where $key_column=old.$ref_column) is not null;end}
    . $self->{end_of_statement}
    . $self->{newline};

  $sqlstr .= $self->{newline};

  return $sqlstr;
}

1;

=head1 TODO

Things that might get added in future versions:

=head3 Mandatory constraints

The current foreign key triggers allow NULL in the child table. This might use a keyword in the
multiplicity field (perhaps 'required') or could check the 'not null' state of the child fkcolumn.

=head3 Views

Views haven't been tested. They might already work, but who knows...

=head3 Other stuff

Bugs etc

=cut

__END__