File Coverage

lib/Parse/Dia/SQL/Output/SQLite3fk.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


line stmt bran cond sub pod time code
1             package Parse::Dia::SQL::Output::SQLite3fk;
2              
3             # $Id: SQLite3.pm,v 1.5 2009/05/14 09:42:47 aff Exp $
4              
5             =pod
6              
7             =head1 NAME
8              
9             Parse::Dia::SQL::Output::SQLite3fk - Create SQL for SQLite version 3, with foreign key support
10              
11             =head1 SYNOPSIS
12              
13             use Parse::Dia::SQL;
14             my $dia = Parse::Dia::SQL->new(file => 'foo.dia', db => 'sqlite3fk');
15             print $dia->get_sql();
16              
17             =head1 DESCRIPTION
18              
19             This sub-class creates SQL for the SQLite database version 3.
20              
21             =cut
22              
23 1     1   1286 use warnings;
  1         2  
  1         26  
24 1     1   3 use strict;
  1         1  
  1         14  
25              
26 1     1   2 use Data::Dumper;
  1         1  
  1         36  
27 1     1   4 use File::Spec::Functions qw(catfile);
  1         1  
  1         50  
28              
29 1     1   3 use lib q{lib};
  1         14  
  1         5  
30 1     1   65 use base q{Parse::Dia::SQL::Output}; # extends
  1         1  
  1         99  
31              
32             require Parse::Dia::SQL::Logger;
33             require Parse::Dia::SQL::Const;
34              
35             =head2 new
36              
37             The constructor.
38              
39             Object names in SQLite have no inherent limit. 60 has been arbitrarily chosen.
40              
41             =cut
42              
43             sub new {
44             my ( $class, %param ) = @_;
45             my $self = {};
46              
47             # Set defaults for sqlite
48             $param{db} = q{sqlite3fk};
49             $param{object_name_max_length} = $param{object_name_max_length} || 60;
50              
51             $self = $class->SUPER::new( %param );
52             bless( $self, $class );
53              
54             return $self;
55             }
56              
57             =head2 _get_create_table_sql
58              
59             Generate create table statement for a single table using SQLite
60             syntax:
61              
62             Includes class comments before the table definition.
63              
64             Includes autoupdate triggers based on the class comment.
65              
66             Includes foreign key support of the form
67              
68             foreign key(thisColumn) references thatTable(thatColumn) {action}
69            
70             Where {action} is the optional contraint condition, such as 'on delete cascade' exactly as entered in the diagram.
71              
72             =head3 autoupdate triggers
73              
74             If the class comment includes a line like:
75              
76             />
77              
78             Then an 'after update' trigger is generated for this table which
79             executes the statement I for the updated row.
80              
81             Examples of use include tracking record modification dates
82             (C<>) or deriving a value from
83             another field (C<>)
84              
85             =cut
86              
87             sub _get_create_table_sql {
88              
89             my ( $self, $table ) = @_;
90             my $sqlstr = '';
91             my $temp;
92             my $comment;
93             my $tablename;
94             my $trigger = '';
95             my $update;
96             my $primary_keys = '';
97              
98             my @columns = ();
99             my @primary_keys = ();
100             my @comments = ();
101              
102             # Sanity checks on table ref
103             return unless $self->_check_attlist($table);
104              
105            
106             # include the comments before the table creation
107             $comment = $table->{comment};
108             if ( !defined( $comment ) ) { $comment = ''; }
109             $tablename = $table->{name};
110             $sqlstr .= $self->{newline};
111             if ( $comment ne "" ) {
112             $temp = "-- $comment";
113             $temp =~ s/\n/\n-- /g;
114             $temp =~ s/^-- $//mgi;
115             if ( $temp ne "" ) {
116             if ( $temp !~ /\n$/m ) { $temp .= $self->{newline}; }
117             $sqlstr .= $temp;
118             }
119             }
120              
121             # Call the base class to generate the main create table statements
122             $sqlstr .= $self->SUPER::_get_create_table_sql( $table );
123              
124             # Generate update triggers if required
125             if ( $comment =~ //mi ) {
126             $update = $3; # what we will set it to
127             $trigger = $2; # the trigger suffix to use (optional)
128             $trigger = $tablename . "_autoupdate" . $trigger;
129              
130             # Check that the column exists
131             foreach $temp ( @{ $table->{attList} } ) {
132              
133             # build the two primary key elements
134             if ( $$temp[3] == 2 ) {
135             if ( $primary_keys ) { $primary_keys .= " and "; }
136             $primary_keys .= $$temp[0] . "=OLD." . $$temp[0];
137             }
138             }
139              
140             $sqlstr .=
141             "drop trigger if exists $trigger"
142             . $self->{end_of_statement}
143             . $self->{newline};
144              
145             $sqlstr .=
146             "create trigger $trigger after update on $tablename begin update $tablename set $update where $primary_keys;end"
147             . $self->{end_of_statement}
148             . $self->{newline};
149              
150             $sqlstr .= $self->{newline};
151             }
152              
153             return $sqlstr;
154             }
155              
156             =head2 _create_pk_string
157              
158             Override default functon to include foreign key clauses
159              
160             =cut
161              
162             sub _create_pk_string {
163             my ($self, $tablename, @pks) = @_;
164             my $sqlstr = '';
165             my $sep = '';
166              
167             $sqlstr .= $self->SUPER::_create_pk_string($tablename, @pks);
168              
169             my $fk = '';
170             # Find the foriegn keys for this table
171             if ($self->_check_associations()) {
172             foreach my $object (@{ $self->{associations} }) {
173             my ( $table_name, $constraint_name, $key_column, $ref_table, $ref_column, $constraint_action ) = @{$object};
174             if ( $table_name eq $tablename ) {
175             #print "ref from " . $table_name . "." . $key_column . " to " . $ref_table . "." . $ref_column ." as " . $constraint_name . " with action " . $constraint_action . ".\n";
176             $fk .= $self->{newline}
177             . $self->{indent}
178             . qq{foreign key} . '('
179             . $key_column . ') '
180             . qq{references }
181             . $ref_table . '(' . $ref_column .') '
182             . $constraint_action
183             . ',';
184             }
185             }
186             }
187            
188             # Trim the last comma
189             $fk =~ s/,$//;
190             # If we have both PK and FK cluases, we need a comma separator
191             if ($fk and $sqlstr) {
192             $sqlstr .= ',';
193             }
194             return $sqlstr . $fk;
195             }
196              
197              
198             =head2 get_schema_drop
199              
200             Generate drop table statments for all tables using SQLite syntax:
201              
202             drop table {foo} if exists
203              
204             =cut
205              
206             sub get_schema_drop {
207             my $self = shift;
208             my $sqlstr = '';
209              
210             return unless $self->_check_classes();
211              
212             CLASS:
213             foreach my $object ( @{ $self->{classes} } ) {
214             next CLASS if ( $object->{type} ne q{table} );
215              
216             # Sanity checks on internal state
217             if (!defined( $object )
218             || ref( $object ) ne q{HASH}
219             || !exists( $object->{name} ) )
220             {
221             $self->{log}
222             ->error( q{Error in table input - cannot create drop table sql!} );
223             next;
224             }
225              
226             $sqlstr .=
227             qq{drop table if exists }
228             . $object->{name}
229             . $self->{end_of_statement}
230             . $self->{newline};
231             }
232              
233             return $sqlstr;
234             }
235              
236             =head2 get_view_drop
237              
238             Generate drop view statments for all tables using SQLite syntax:
239              
240             drop view {foo} if exists
241              
242             =cut
243              
244             # Create drop view for all views
245             sub get_view_drop {
246             my $self = shift;
247             my $sqlstr = '';
248              
249             return unless $self->_check_classes();
250              
251             CLASS:
252             foreach my $object ( @{ $self->{classes} } ) {
253             next CLASS if ( $object->{type} ne q{view} );
254              
255             # Sanity checks on internal state
256             if (!defined( $object )
257             || ref( $object ) ne q{HASH}
258             || !exists( $object->{name} ) )
259             {
260             $self->{log}
261             ->error( q{Error in table input - cannot create drop table sql!} );
262             next;
263             }
264              
265             $sqlstr .=
266             qq{drop view if exists }
267             . $object->{name}
268             . $self->{end_of_statement}
269             . $self->{newline};
270             }
271              
272             return $sqlstr;
273              
274             }
275              
276             =head2 _get_fk_drop
277              
278             Foreign key enforcement is embedded in the table definitions for SQLite, so no output is required here.
279              
280             =cut
281              
282             # Drop all foreign keys
283             sub _get_fk_drop {
284             my $self = shift;
285              
286             return '';
287             }
288              
289             =head2 _get_drop_index_sql
290              
291             drop index statement using SQLite syntax:
292              
293             drop index {foo} if exists
294              
295             =cut
296              
297             sub _get_drop_index_sql {
298             my ( $self, $tablename, $indexname ) = @_;
299             return
300             qq{drop index if exists $indexname}
301             . $self->{end_of_statement}
302             . $self->{newline};
303             }
304              
305             =head2 get_permissions_create
306              
307             SQLite doesn't support permissions, so suppress this output.
308              
309             =cut
310              
311             sub get_permissions_create {
312             return '';
313             }
314              
315             =head2 get_permissions_drop
316              
317             SQLite doesn't support permissions, so suppress this output.
318              
319             =cut
320              
321             sub get_permissions_drop {
322             return '';
323             }
324              
325             =head2 _get_create_association_sql
326              
327             Foreign key enforcement is embedded in the table definitions for SQLite, so no output is required here.
328              
329             =cut
330              
331             # Create sql for given association.
332             sub _get_create_association_sql {
333             my ( $self, $association ) = @_;
334              
335             return '';
336             }
337              
338             1;
339              
340             =head1 TODO
341              
342             Things that might get added in future versions:
343              
344             =head3 Views
345              
346             Views haven't been tested. They might already work, but who knows...
347              
348             =head3 Other stuff
349              
350             Bugs etc
351              
352             =cut
353              
354             __END__