File Coverage

blib/lib/Rose/DB/Object/Metadata/Auto/Pg.pm
Criterion Covered Total %
statement 18 67 26.8
branch 0 24 0.0
condition 0 3 0.0
subroutine 6 8 75.0
pod 1 2 50.0
total 25 104 24.0


line stmt bran cond sub pod time code
1             package Rose::DB::Object::Metadata::Auto::Pg;
2              
3 1     1   7 use strict;
  1         2  
  1         46  
4              
5 1     1   6 use Carp();
  1         2  
  1         18  
6              
7 1     1   5 use Rose::DB::Object::Metadata::UniqueKey;
  1         2  
  1         30  
8              
9 1     1   688 use Rose::DB::Object::Metadata::Auto;
  1         3  
  1         93  
10             our @ISA = qw(Rose::DB::Object::Metadata::Auto);
11              
12             our $Debug;
13              
14             our $VERSION = '0.812';
15              
16             # Other useful columns, not selected for now
17             # pg_get_indexdef(i.oid) AS indexdef
18             # n.nspname AS schemaname,
19             # c.relname AS tablename,
20             # i.relname AS indexname,
21             # t.spcname AS "tablespace",
22             # x.indisunique AS is_unique_index,
23             #
24             # Plus this join condition for table "t"
25             # LEFT JOIN pg_catalog.pg_tablespace t ON t.oid = i.reltablespace
26 1     1   8 use constant UNIQUE_INDEX_SQL => <<'EOF';
  1         2  
  1         84  
27             SELECT
28             x.indrelid,
29             x.indkey,
30             i.relname AS key_name,
31             CASE WHEN x.indpred IS NULL THEN 0 ELSE 1 END AS has_predicate
32             FROM
33             pg_catalog.pg_index x
34             JOIN pg_catalog.pg_class c ON c.oid = x.indrelid
35             JOIN pg_catalog.pg_class i ON i.oid = x.indexrelid
36             LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace
37             WHERE
38             x.indisunique = 't' AND
39             c.relkind = 'r' AND
40             i.relkind = 'i' AND
41             n.nspname = ? AND
42             c.relname = ?
43             EOF
44              
45 1     1   6 use constant UNIQUE_INDEX_COLUMNS_SQL_STUB => <<'EOF';
  1         3  
  1         618  
46             SELECT
47             attname
48             FROM
49             pg_catalog.pg_attribute
50             WHERE
51             attrelid = ? AND
52             attnum
53             EOF
54              
55             sub auto_generate_unique_keys
56             {
57 0     0 1   my($self) = shift;
58              
59 0 0         unless(defined wantarray)
60             {
61 0           Carp::croak "Useless call to auto_generate_unique_keys() in void context";
62             }
63              
64 0           my($class, @unique_keys, $error);
65              
66             TRY:
67             {
68 0           local $@;
  0            
69              
70             eval
71 0           {
72 0 0         $class = $self->class or die "Missing class!";
73              
74 0           my $db = $self->db;
75 0 0         my $dbh = $db->dbh or die $db->error;
76              
77 0           local $dbh->{'FetchHashKeyName'} = 'NAME';
78              
79 0           my $schema = $self->select_schema($db);
80 0 0         $schema = $db->default_implicit_schema unless(defined $schema);
81 0 0         $schema = lc $schema if(defined $schema);
82              
83 0           my $table = lc $self->table;
84              
85 0           my($relation_id, $column_nums, $key_name, $has_predicate);
86              
87 0           my $sth = $dbh->prepare(UNIQUE_INDEX_SQL);
88              
89 0           $sth->execute($schema, $table);
90 0           $sth->bind_columns(\($relation_id, $column_nums, $key_name, $has_predicate));
91              
92 0           while($sth->fetch)
93             {
94             # See if we need to ignore predicated unique indices. The semantics
95             # of predicated indexes, e.g.,
96             #
97             # CREATE UNIQUE INDEX ... WHERE column = 'value'
98             #
99             # are different from RDBO's unique key semantics in that predicates
100             # (may) cause the index to apply only partially to the table.
101 0 0 0       if($has_predicate && !$self->include_predicated_unique_indexes)
102             {
103 0 0         $Debug && warn "$class - Skipping predicated unique index $key_name\n";
104 0           next;
105             }
106              
107             # Skip functional indexes (e.g., "... ON (LOWER(name))") which show up
108             # as having a pg_index.indkey ($column_nums) value of 0.
109 0 0         next if($column_nums eq '0');
110              
111 0           my $uk =
112             Rose::DB::Object::Metadata::UniqueKey->new(
113             name => $key_name,
114             parent => $self,
115             has_predicate => $has_predicate);
116              
117             # column_nums is a space-separated list of numbers. It's really an
118             # "in2vector" data type, which seems sketchy to me, but whatever.
119             # We can fall back to the pg_get_indexdef() function and try to
120             # parse that mess if this ever stops working.
121 0           my @column_nums = grep { /^\d+$/ } split(/\s+/, $column_nums);
  0            
122              
123 0           my $col_sth = $dbh->prepare(UNIQUE_INDEX_COLUMNS_SQL_STUB .
124             ' IN(' . join(', ', @column_nums) . ')');
125              
126 0           my($column, @columns);
127              
128 0           $col_sth->execute($relation_id);
129 0           $col_sth->bind_columns(\$column);
130              
131 0           while($col_sth->fetch)
132             {
133 0           push(@columns, $column);
134             }
135              
136 0 0         unless(@columns)
137             {
138 0           die "No columns found for relation id $relation_id, column numbers @column_nums";
139             }
140              
141 0           $uk->columns(\@columns);
142              
143 0           push(@unique_keys, $uk);
144             }
145             };
146              
147 0           $error = $@;
148             }
149              
150 0 0         if($error)
151             {
152 0           Carp::croak "Could not auto-retrieve unique keys for class $class - $error";
153             }
154              
155             # This sort order is part of the API, and is essential to make the
156             # test suite work.
157 0           @unique_keys = sort { lc $a->name cmp lc $b->name } @unique_keys;
  0            
158              
159 0 0         return wantarray ? @unique_keys : \@unique_keys;
160             }
161              
162             sub auto_generate_column
163             {
164 0     0 0   my($self, $name, $col_info) = @_;
165              
166 0 0         if ($col_info->{'TYPE_NAME'} eq 'bigint')
167             {
168             # Newer versions of DBD::Pg and/or PostgreSQL seem to return default bigint
169             # values wrapped in single quotes. Strip them off.
170 0           $col_info->{'COLUMN_DEF'} =~ s/^'(\d+)'$/$1/;
171             }
172              
173 0           $col_info->{'NUMERIC_PRECISION'} = $col_info->{'DECIMAL_DIGITS'};
174 0           $col_info->{'NUMERIC_SCALE'} = $col_info->{'COLUMN_SIZE'};
175              
176 0           return $self->SUPER::auto_generate_column($name, $col_info);
177             }
178              
179             1;