File Coverage

blib/lib/DBIx/DBSchema/ForeignKey.pm
Criterion Covered Total %
statement 3 52 5.7
branch 0 26 0.0
condition 0 15 0.0
subroutine 1 13 7.6
pod 12 12 100.0
total 16 118 13.5


line stmt bran cond sub pod time code
1             package DBIx::DBSchema::ForeignKey;
2              
3 1     1   6 use strict;
  1         2  
  1         630  
4              
5             our $VERSION = '0.13';
6             our $DEBUG = 0;
7              
8             =head1 NAME
9              
10             DBIx::DBSchema::ForeignKey - Foreign key objects
11              
12             =head1 SYNOPSIS
13              
14             use DBIx::DBSchema::ForeignKey;
15              
16             $foreign_key = new DBIx::DBSchema::ForeignKey (
17             { 'columns' => [ 'column_name' ],
18             'table' => 'foreign_table',
19             }
20             );
21              
22             $foreign_key = new DBIx::DBSchema::ForeignKey (
23             {
24             'constraint' => 'constraint_name',
25             'columns' => [ 'column_name', 'column2' ],
26             'table' => 'foreign_table',
27             'references' => [ 'foreign_column', 'foreign_column2' ],
28             'match' => 'MATCH FULL', # or MATCH SIMPLE
29             'on_delete' => 'NO ACTION', # on clauses: NO ACTION / RESTRICT /
30             'on_update' => 'RESTRICT', # CASCADE / SET NULL / SET DEFAULT
31             }
32             );
33              
34             =head1 DESCRIPTION
35              
36             DBIx::DBSchema::ForeignKey objects represent a foreign key.
37              
38             =head1 METHODS
39              
40             =over 4
41              
42             =item new HASHREF | OPTION, VALUE, ...
43              
44             Creates a new DBIx::DBschema::ForeignKey object.
45              
46             Accepts either a hashref or a list of options and values.
47              
48             Options are:
49              
50             =over 8
51              
52             =item constraint - constraint name
53              
54             =item columns - List reference of column names
55              
56             =item table - Foreign table name
57              
58             =item references - List reference of column names in foreign table
59              
60             =item match -
61              
62             =item on_delete -
63              
64             =item on_update -
65              
66             =back
67              
68             =cut
69              
70             sub new {
71 0     0 1   my $proto = shift;
72 0   0       my $class = ref($proto) || $proto;
73 0 0         my %opt = ref($_[0]) ? %{$_[0]} : @_; #want a new reference
  0            
74 0           my $self = \%opt;
75 0           bless($self, $class);
76             }
77              
78             =item constraint [ CONSTRAINT_NAME ]
79              
80             Returns or sets the constraint name
81              
82             =cut
83              
84             sub constraint {
85 0     0 1   my($self, $value) = @_;
86 0 0         if ( defined($value) ) {
87 0           $self->{constraint} = $value;
88             } else {
89 0           $self->{constraint};
90             }
91             }
92              
93             =item table [ TABLE_NAME ]
94              
95             Returns or sets the foreign table name
96              
97             =cut
98              
99             sub table {
100 0     0 1   my($self, $value) = @_;
101 0 0         if ( defined($value) ) {
102 0           $self->{table} = $value;
103             } else {
104 0           $self->{table};
105             }
106             }
107              
108             =item columns [ LISTREF ]
109              
110             Returns or sets the columns.
111              
112             =cut
113              
114             sub columns {
115 0     0 1   my($self, $value) = @_;
116 0 0         if ( defined($value) ) {
117 0           $self->{columns} = $value;
118             } else {
119 0           $self->{columns};
120             }
121             }
122              
123             =item columns_sql
124              
125             Returns a comma-joined list of columns, suitable for an SQL statement.
126              
127             =cut
128              
129             sub columns_sql {
130 0     0 1   my $self = shift;
131 0           join(', ', @{ $self->columns } );
  0            
132             }
133              
134             =item references [ LISTREF ]
135              
136             Returns or sets the referenced columns.
137              
138             =cut
139              
140             sub references {
141 0     0 1   my($self, $value) = @_;
142 0 0         if ( defined($value) ) {
143 0           $self->{references} = $value;
144             } else {
145 0           $self->{references};
146             }
147             }
148              
149             =item references_sql
150              
151             Returns a comma-joined list of referenced columns, suitable for an SQL
152             statement.
153              
154             =cut
155              
156             sub references_sql {
157 0     0 1   my $self = shift;
158 0 0         join(', ', @{ $self->references || $self->columns } );
  0            
159             }
160              
161             =item match [ TABLE_NAME ]
162              
163             Returns or sets the MATCH clause
164              
165             =cut
166              
167             sub match {
168 0     0 1   my($self, $value) = @_;
169 0 0         if ( defined($value) ) {
170 0           $self->{match} = $value;
171             } else {
172 0 0         defined($self->{match}) ? $self->{match} : '';
173             }
174             }
175              
176             =item on_delete [ ACTION ]
177              
178             Returns or sets the ON DELETE clause
179              
180             =cut
181              
182             sub on_delete {
183 0     0 1   my($self, $value) = @_;
184 0 0         if ( defined($value) ) {
185 0           $self->{on_delete} = $value;
186             } else {
187 0 0         defined($self->{on_delete}) ? $self->{on_delete} : '';
188             }
189             }
190              
191             =item on_update [ ACTION ]
192              
193             Returns or sets the ON UPDATE clause
194              
195             =cut
196              
197             sub on_update {
198 0     0 1   my($self, $value) = @_;
199 0 0         if ( defined($value) ) {
200 0           $self->{on_update} = $value;
201             } else {
202 0 0         defined($self->{on_update}) ? $self->{on_update} : '';
203             }
204             }
205              
206             =item sql_foreign_key
207              
208             Returns an SQL FOREIGN KEY statement.
209              
210             =cut
211              
212             sub sql_foreign_key {
213 0     0 1   my( $self ) = @_;
214              
215 0           my $table = $self->table;
216 0           my $col_sql = $self->columns_sql;
217 0           my $ref_sql = $self->references_sql;
218              
219             "FOREIGN KEY ( $col_sql ) REFERENCES $table ( $ref_sql ) ".
220 0           join ' ', map { (my $thing_sql = uc($_) ) =~ s/_/ /g;
  0            
221 0           "$thing_sql ". $self->$_;
222             }
223             grep $self->$_, qw( match on_delete on_update );
224             }
225              
226             =item cmp OTHER_INDEX_OBJECT
227              
228             Compares this object to another supplied object. Returns true if they are
229             have the same table, columns and references.
230              
231             =cut
232              
233             sub cmp {
234 0     0 1   my( $self, $other ) = @_;
235              
236 0 0 0       $self->table eq $other->table
      0        
      0        
      0        
237             and $self->columns_sql eq $other->columns_sql
238             and $self->references_sql eq $other->references_sql
239             and uc($self->match) eq uc($other->match)
240             and uc($self->on_delete) eq uc($other->on_delete)
241             and uc($self->on_update) eq uc($other->on_update)
242             ;
243             }
244              
245             =back
246              
247             =head1 AUTHOR
248              
249             Ivan Kohler
250              
251             Copyright (c) 2013 Freeside Internet Services, Inc.
252             All rights reserved.
253             This program is free software; you can redistribute it and/or modify it under
254             the same terms as Perl itself.
255              
256             =head1 BUGS
257              
258             Should give in and Mo or Moo.
259              
260             =head1 SEE ALSO
261              
262             L, L, L
263              
264             =cut
265              
266             1;
267              
268