lib/DBIx/Class/Table.pm

   1 package DBIx::Class::Table;
   2
   3 use strict;
   4 use warnings;
   5
   6 use DBIx::Class::ResultSet;
   7 use Data::Page;
   8
   9 use base qw/DBIx::Class/;
  10
  11 __PACKAGE__->mk_classdata('_columns' => {});
  12
  13 __PACKAGE__->mk_classdata('_table_name');
  14
  15 __PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do anything yet!
  16
  17 __PACKAGE__->mk_classdata('_resultset_class' => 'DBIx::Class::ResultSet');
  18
  19 sub iterator_class { shift->_resultset_class(@_) }
  20
  21 =head1 NAME
  22
  23 DBIx::Class::Table - Basic table methods
  24
  25 =head1 SYNOPSIS
  26
  27 =head1 DESCRIPTION
  28
  29 This class is responsible for defining and doing basic operations on
  30 L<DBIx::Class> objects.
  31
  32 =head1 METHODS
  33
  34 =cut
  35
  36 sub _register_columns {
  37   my ($class, @cols) = @_;
  38   my $names = { %{$class->_columns} };
  39   $names->{$_} ||= {} for @cols;
  40   $class->_columns($names);
  41 }
  42
  43 sub _mk_column_accessors {
  44   my ($class, @cols) = @_;
  45   $class->mk_group_accessors('column' => @cols);
  46 }
  47
  48 =head2 add_columns
  49
  50   __PACKAGE__->add_columns(qw/col1 col2 col3/);
  51
  52 Adds columns to the current package, and creates accessors for them
  53
  54 =cut
  55
  56 sub add_columns {
  57   my ($class, @cols) = @_;
  58   $class->_register_columns(@cols);
  59   $class->_mk_column_accessors(@cols);
  60 }
  61
  62 =head2 search_literal
  63
  64   my @obj    = $class->search_literal($literal_where_cond, @bind);
  65   my $cursor = $class->search_literal($literal_where_cond, @bind);
  66
  67 =cut
  68
  69 sub search_literal {
  70   my ($class, $cond, @vals) = @_;
  71   $cond =~ s/^\s*WHERE//i;
  72   my $attrs = (ref $vals[$#vals] eq 'HASH' ? { %{ pop(@vals) } } : {});
  73   $attrs->{bind} = \@vals;
  74   return $class->search(\$cond, $attrs);
  75 }
  76
  77 =head2 count_literal
  78
  79   my $count = $class->count_literal($literal_where_cond);
  80
  81 =cut
  82
  83 sub count_literal {
  84   my $class = shift;
  85   return $class->search_literal(@_)->count;
  86 }
  87
  88 =head2 count
  89
  90   my $count = $class->count({ foo => 3 });
  91
  92 =cut
  93
  94 sub count {
  95   my $class = shift;
  96   return $class->search(@_)->count;
  97 }
  98
  99 =head2 search
 100
 101   my @obj    = $class->search({ foo => 3 }); # "... WHERE foo = 3"
 102   my $cursor = $class->search({ foo => 3 });
 103
 104 To retrieve all rows, simply call C<search()> with no condition parameter,
 105
 106   my @all = $class->search(); # equivalent to search({})
 107
 108 If you need to pass in additional attributes (see
 109 L<DBIx::Class::ResultSet/Attributes> for details) an empty hash indicates
 110 no condition,
 111
 112   my @all = $class->search({}, { cols => [qw/foo bar/] }); # "SELECT foo, bar FROM $class_table"
 113
 114 =cut
 115
 116 sub search {
 117   my $class = shift;
 118   #warn "@_";
 119   my $attrs = { };
 120   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 121     $attrs = { %{ pop(@_) } };
 122   }
 123   $attrs->{where} = (@_ == 1 || ref $_[0] eq "HASH" ? shift: {@_});
 124
 125   my $rs = $class->resultset($attrs);
 126
 127   return (wantarray ? $rs->all : $rs);
 128 }
 129
 130 sub resultset {
 131   my $class = shift;
 132
 133   my $rs_class = $class->_resultset_class;
 134   eval "use $rs_class;";
 135   my $rs = $rs_class->new($class, @_);
 136 }
 137
 138 =head2 search_like
 139
 140 Identical to search except defaults to 'LIKE' instead of '=' in condition
 141
 142 =cut
 143
 144 sub search_like {
 145   my $class    = shift;
 146   my $attrs = { };
 147   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 148     $attrs = pop(@_);
 149   }
 150   my $query    = ref $_[0] eq "HASH" ? { %{shift()} }: {@_};
 151   $query->{$_} = { 'like' => $query->{$_} } for keys %$query;
 152   return $class->search($query, { %$attrs });
 153 }
 154
 155 sub _select_columns {
 156   return keys %{$_[0]->_columns};
 157 }
 158
 159 =head2 table
 160
 161   __PACKAGE__->table('tbl_name');
 162
 163 =cut
 164
 165 sub table {
 166   shift->_table_name(@_);
 167 }
 168
 169 =head2 find_or_create
 170
 171   $class->find_or_create({ key => $val, ... });
 172
 173 Searches for a record matching the search condition; if it doesn't find one,
 174 creates one and returns that instead
 175
 176 =cut
 177
 178 sub find_or_create {
 179   my $class    = shift;
 180   my $hash     = ref $_[0] eq "HASH" ? shift: {@_};
 181   my $exists = $class->find($hash);
 182   return defined($exists) ? $exists : $class->create($hash);
 183 }
 184
 185 =head2 has_column
 186
 187   if ($obj->has_column($col)) { ... }
 188
 189 Returns 1 if the object has a column of this name, 0 otherwise
 190
 191 =cut
 192
 193 sub has_column {
 194   my ($self, $column) = @_;
 195   return exists $self->_columns->{$column};
 196 }
 197
 198 =head2 column_info
 199
 200   my $info = $obj->column_info($col);
 201
 202 Returns the column metadata hashref for the column
 203
 204 =cut
 205
 206 sub column_info {
 207   my ($self, $column) = @_;
 208   die "No such column $column" unless exists $self->_columns->{$column};
 209   return $self->_columns->{$column};
 210 }
 211
 212 =head2 columns
 213
 214   my @column_names = $obj->columns;
 215
 216 =cut
 217
 218 sub columns {
 219   die "columns() is a read-only accessor, did you mean add_columns()?" if (@_ > 1);
 220   return keys %{shift->_columns};
 221 }
 222
 223 1;
 224
 225 =head1 AUTHORS
 226
 227 Matt S. Trout <mst@shadowcatsystems.co.uk>
 228
 229 =head1 LICENSE
 230
 231 You may distribute this code under the same terms as Perl itself.
 232
 233 =cut
 234