File Coverage

blib/lib/Class/DBI/Column.pm
Criterion Covered Total %
statement 26 26 100.0
branch 3 4 75.0
condition 2 2 100.0
subroutine 10 10 100.0
pod 1 5 20.0
total 42 47 89.4


line stmt bran cond sub pod time code
1             package Class::DBI::Column;
2              
3             =head1 NAME
4            
5             Class::DBI::Column - A column in a table
6            
7             =head1 SYNOPSIS
8            
9             my $column = Class::DBI::Column->new($name);
10            
11             my $name = $column->name;
12            
13             my @groups = $column->groups;
14             my $pri_col = $colg->primary;
15            
16             if ($column->in_database) { ... }
17            
18             =head1 DESCRIPTION
19            
20             Each Class::DBI class maintains a list of its columns as class data.
21             This provides an interface to those columns. You probably shouldn't be
22             dealing with this directly.
23            
24             =head1 METHODS
25            
26             =cut
27              
28 24     24   406 use strict;
  24         438  
  24         370  
29 24     24   437 use base 'Class::Accessor::Fast';
  24         278  
  24         427  
30 24     24   429 use Carp;
  24         364  
  24         475  
31              
32             __PACKAGE__->mk_accessors(
33             qw/name accessor mutator placeholder is_constrained/
34             );
35              
36             use overload
37 12903     12903   287963 '""'     => sub { shift->name_lc },
38 24     24   1110 fallback => 1;
  24         251  
  24         671  
39              
40             =head2 new
41            
42             my $column = Class::DBI::Column->new($column)
43            
44             A new object for this column.
45            
46             =cut
47              
48             sub new {
49 228     228 1 5326 my $class = shift;
50 228 50       20289 my $name = shift or croak "Column needs a name";
51 228   100     14397 my $opt = shift || {};
52 228         19281 return $class->SUPER::new(
53             {
54             name        => $name,
55             accessor    => $name,
56             mutator     => $name,
57             _groups     => {},
58             placeholder => '?',
59             %$opt,
60             }
61             );
62             }
63              
64 13409     13409 0 292932 sub name_lc { lc shift->name }
65              
66             sub add_group {
67 239     239 0 6081 my ($self, $group) = @_;
68 239         12348 $self->{_groups}->{$group} = 1;
69             }
70              
71             sub groups {
72 1418     1418 0 30930 my $self = shift;
73 1418         27072 my %groups = %{ $self->{_groups} };
  1418         28935  
74 1418 100       21122 delete $groups{All} if keys %groups > 1;
75 1418         30951 return keys %groups;
76             }
77              
78             sub in_database {
79 1238     1238 0 27699 return !scalar grep $_ eq "TEMP", shift->groups;
80             }
81              
82             1;
83