DBSchema/ForeignKey.pm

   1 package DBIx::DBSchema::ForeignKey;
   2
   3 use strict;
   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   my $proto = shift;
  72   my $class = ref($proto) || $proto;
  73   my %opt = ref($_[0]) ? %{$_[0]} : @_; #want a new reference
  74   my $self = \%opt;
  75   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   my($self, $value) = @_;
  86   if ( defined($value) ) {
  87     $self->{constraint} = $value;
  88   } else {
  89     $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   my($self, $value) = @_;
 101   if ( defined($value) ) {
 102     $self->{table} = $value;
 103   } else {
 104     $self->{table};
 105   }
 106 }
 107
 108 =item columns [ LISTREF ]
 109
 110 Returns or sets the columns.
 111
 112 =cut
 113
 114 sub columns {
 115   my($self, $value) = @_;
 116   if ( defined($value) ) {
 117     $self->{columns} = $value;
 118   } else {
 119     $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   my $self = shift;
 131   join(', ', @{ $self->columns } );
 132 }
 133
 134 =item references [ LISTREF ]
 135
 136 Returns or sets the referenced columns.
 137
 138 =cut
 139
 140 sub references {
 141   my($self, $value) = @_;
 142   if ( defined($value) ) {
 143     $self->{references} = $value;
 144   } else {
 145     $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   my $self = shift;
 158   join(', ', @{ $self->references || $self->columns } );
 159 }
 160
 161 =item match [ TABLE_NAME ]
 162
 163 Returns or sets the MATCH clause
 164
 165 =cut
 166
 167 sub match {
 168   my($self, $value) = @_;
 169   if ( defined($value) ) {
 170     $self->{match} = $value;
 171   } else {
 172     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   my($self, $value) = @_;
 184   if ( defined($value) ) {
 185     $self->{on_delete} = $value;
 186   } else {
 187     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   my($self, $value) = @_;
 199   if ( defined($value) ) {
 200     $self->{on_update} = $value;
 201   } else {
 202     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   my( $self ) = @_;
 214
 215   my $table = $self->table;
 216   my $col_sql = $self->columns_sql;
 217   my $ref_sql = $self->references_sql;
 218
 219   "FOREIGN KEY ( $col_sql ) REFERENCES $table ( $ref_sql ) ".
 220     join ' ', map { (my $thing_sql = uc($_) ) =~ s/_/ /g;
 221                     "$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   my( $self, $other ) = @_;
 235
 236   $self->table eq $other->table
 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 <ivan-dbix-dbschema@420.am>
 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<DBIx::DBSchema::Table>, L<DBIx::DBSchema>, L<DBI>
 263
 264 =cut
 265
 266 1;
 267
 268