lib/DBIx/Class/Table.pm

   1 package DBIx::Class::Table;
   2
   3 use strict;
   4 use warnings;
   5
   6 use DBIx::Class::ResultSet;
   7
   8 use Carp qw/croak/;
   9
  10 use base qw/DBIx::Class/;
  11 __PACKAGE__->load_components(qw/AccessorGroup/);
  12
  13 __PACKAGE__->mk_group_accessors('simple' =>
  14   qw/_columns name resultset_class result_class storage/);
  15
  16 =head1 NAME
  17
  18 DBIx::Class::Table - Table object
  19
  20 =head1 SYNOPSIS
  21
  22 =head1 DESCRIPTION
  23
  24 This class is responsible for defining and doing table-level operations on
  25 L<DBIx::Class> classes.
  26
  27 =head1 METHODS
  28
  29 =cut
  30
  31 sub new {
  32   my ($class, $attrs) = @_;
  33   $class = ref $class if ref $class;
  34   my $new = bless($attrs || {}, $class);
  35   $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
  36   $new->{_columns} ||= {};
  37   $new->{name} ||= "!!NAME NOT SET!!";
  38   return $new;
  39 }
  40
  41 sub add_columns {
  42   my ($self, @cols) = @_;
  43   while (my $col = shift @cols) {
  44     $self->add_column($col => (ref $cols[0] ? shift : {}));
  45   }
  46 }
  47
  48 sub add_column {
  49   my ($self, $col, $info) = @_;
  50   $self->_columns->{$col} = $info || {};
  51 }
  52
  53 =head2 add_columns
  54
  55   $table->add_columns(qw/col1 col2 col3/);
  56
  57   $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
  58
  59 Adds columns to the table object. If supplied key => hashref pairs uses
  60 the hashref as the column_info for that column.
  61
  62 =cut
  63
  64 sub resultset {
  65   my $self = shift;
  66   my $rs_class = $self->resultset_class;
  67   eval "use $rs_class;";
  68   return $rs_class->new($self);
  69 }
  70
  71 =head2 has_column
  72
  73   if ($obj->has_column($col)) { ... }
  74
  75 Returns 1 if the table has a column of this name, 0 otherwise.
  76
  77 =cut
  78
  79 sub has_column {
  80   my ($self, $column) = @_;
  81   return exists $self->_columns->{$column};
  82 }
  83
  84 =head2 column_info
  85
  86   my $info = $obj->column_info($col);
  87
  88 Returns the column metadata hashref for a column.
  89
  90 =cut
  91
  92 sub column_info {
  93   my ($self, $column) = @_;
  94   croak "No such column $column" unless exists $self->_columns->{$column};
  95   return $self->_columns->{$column};
  96 }
  97
  98 =head2 columns
  99
 100   my @column_names = $obj->columns;
 101
 102 =cut
 103
 104 sub columns {
 105   croak "columns() is a read-only accessor, did you mean add_columns()?" if (@_ > 1);
 106   return keys %{shift->_columns};
 107 }
 108
 109 1;
 110
 111 =head1 AUTHORS
 112
 113 Matt S. Trout <mst@shadowcatsystems.co.uk>
 114
 115 =head1 LICENSE
 116
 117 You may distribute this code under the same terms as Perl itself.
 118
 119 =cut
 120