pgdiff/Pg/Scheme.pm

package Pg::Scheme;

use strict;
use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Carp;


use Exporter   ();
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);

$VERSION        = 1.00;
@ISA            = qw(Exporter);
@EXPORT         = qw(&func1 &func2 &func4);
%EXPORT_TAGS    = ( );     # eg: TAG => [ qw!name1 name2! ],
               
@EXPORT_OK      = qw(
                                &list_tables
                                &get_table_oid
                                &explain
                                &pg_attribute
                                &cols
                                &cols_notnull
                                &cols_null
                                &cols_pk
                                &cols_notpk
                );

my $debug;

sub new {
        my ($class, %args) = @_;
        my $self = {};
        bless($self, $class);
        $debug = $args{'DEBUG'};
        $self->{dbh} = $args{'dbh'} || croak "new needs to be called with 'dbh' which is handle to opened database";
        @{$self->{tables}} = ();
        $self ? return $self : return undef;
        # XXX begin transaction?
}

sub list_tables {
        my $self = shift;
        my $tables = shift;

        my @tables;

        if ($tables) {
                @tables = split(/,/,$tables);
        } else {
                # take all tables
                #$sql="select tablename from pg_tables where tablename not like 'pg_%' and tablename not like '_rserv_%'";
                # show tables (based on psql \dt)
                my $sql = "
                SELECT c.relname as table
                FROM pg_catalog.pg_class c
                        LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace
                WHERE c.relkind = 'r'
                        AND n.nspname NOT IN ('pg_catalog', 'pg_toast')
                        AND pg_catalog.pg_table_is_visible(c.oid)
                        and c.relname not like '_rserv_%'
                ";
                foreach my $table (@tables) {
                        $sql .= " and c.relname like '$table' x";
                }
                my $sth = $self->{'dbh'}->prepare($sql) || croak "can't prepare '$sql': ".$self->{'dbh'}->errstr;
                $sth->execute() || croak "can't execute '$sql': ".$sth->errstr;
                while(my $row = $sth->fetchrow_hashref()) {
                        push @tables,$row->{table};
                }
        }
        #@{$self->{'tables'}} = @tables;
        return @tables;
}

sub get_table_oid {
        my $self = shift;
        my $table = shift;

        # find table oid
        my $sql = "
        SELECT c.oid, n.nspname, c.relname
        FROM pg_catalog.pg_class c
        LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace
        WHERE pg_catalog.pg_table_is_visible(c.oid)
        AND c.relname = '$table'
        ORDER BY 2, 3
        ";

        my $sth = $self->{'dbh'}->prepare($sql);
        $sth->execute() || die;
        my $row = $sth->fetchrow_hashref();
        croak "Can't find OID of table '$table'\n" if (! $row);
        $sth->finish();

        return $row->{oid};
}

sub explain {
        my $self = shift;
        my $table = shift;

        # XXX if explained, return just results
        # return $self->{'explained'}->{$table}->{'pg_attribute'} if ($self->{'explained'}->{$table}->{'pg_attribute'});
        my @pg_attribute;

        my $oid = $self->get_table_oid($table);

        # get table description
        my $sql="
        SELECT a.attname,
        pg_catalog.format_type(a.atttypid, a.atttypmod) as format_type,
        a.attnotnull, a.atthasdef, a.attnum
        FROM pg_catalog.pg_attribute a
        WHERE a.attrelid = ? AND a.attnum > 0 AND NOT a.attisdropped
        ORDER BY a.attnum
        ";

        # get default value
        my $sql_def="
        SELECT adsrc as def FROM pg_catalog.pg_attrdef
        WHERE adrelid = ? and adnum=?
        ";

        my @cols;       # all columns (for insert)
        my @cols_null;  # columns compared by a=b or a is null and b is null
        my @cols_notnull;# columns compared by a=b

        my $sth = $self->{'dbh'}->prepare($sql);
        my $sth_def = $self->{'dbh'}->prepare($sql_def);
        $sth->execute($oid) || die;
        while(my $row = $sth->fetchrow_hashref()) {
                # attname | format_type | attnotnull | atthasdef | attnum
                push @cols,$row->{attname};

                if ($row->{attnotnull}) {
                        push @cols_notnull,$row->{attname};
                } else {
                        push @cols_null,$row->{attname};
                }

                if ($row->{atthasdef}) {
                        $sth_def->execute($oid,$row->{attnum}) || die;
                        my $row_def = $sth_def->fetchrow_hashref() || die "can't get attribute '",$row->{attname},"' default value!";
                        $row->{default} = $row_def->{def};
                }

                push @pg_attribute, $row;
        }

        @{$self->{'explained'}->{$table}->{'pg_attribute'}} = @pg_attribute;
        @{$self->{'explained'}->{$table}->{'cols'}} = @cols;
        @{$self->{'explained'}->{$table}->{'cols_notnull'}} = @cols_notnull;
        @{$self->{'explained'}->{$table}->{'cols_null'}} = @cols_null;

        # all, just for safe keeping
        @{$self->{'explained'}->{$table}->{'cols_notpk'}} = @cols;

        # now, try to find primary key

        my @cols_pk;    # columns which are primary key
        my @cols_notpk;
        my %in_pk;

        $sql="
SELECT
        i.indexrelid as indexrelid, i.indrelid as indrelid,
        count(a.attname) as cols_in_pk
FROM
        pg_catalog.pg_class c,
        pg_catalog.pg_index i,
        pg_catalog.pg_attribute a
WHERE
        c.oid = i.indrelid
        and i.indisunique
        and c.relname = '$table'
        and a.attrelid = i.indexrelid
GROUP BY
        i.indexrelid, i.indrelid, c.relname, i.indisprimary, i.indisunique
ORDER BY
        cols_in_pk ASC, i.indisprimary DESC, i.indisunique DESC, c.relname DESC
";
        print STDERR "DEBUG: $sql\n" if ($debug);
        $sth = $self->{'dbh'}->prepare($sql);
        $sth->execute() || die;
        my $row = $sth->fetchrow_hashref();
        if ($row) {
                $sql="
                select a1.attname as attname from pg_attribute a1, pg_attribute a2 where a1.attrelid = ".$row->{indexrelid}." and a2.attrelid=".$row->{indrelid}." and a1.attname = a2.attname and a2.attnotnull";
                
                my $sth2 = $self->{'dbh'}->prepare($sql);
                print STDERR "DEBUG: $sql\n" if ($debug);
                $sth2->execute() || die;
                while (my $row2 = $sth2->fetchrow_hashref()) {
                        push @cols_pk,$row2->{attname};
                        $in_pk{$row2->{attname}}++;
                }
                
        }

        foreach my $col (@cols) {
                push @cols_notpk,$col if (! $in_pk{$col});
        }

        @{$self->{'explained'}->{$table}->{cols_pk}} = @cols_pk;
        @{$self->{'explained'}->{$table}->{cols_notpk}} = @cols_notpk;

        # find triggers

        my @triggers;

        $sql ="
SELECT t.tgname
FROM pg_catalog.pg_trigger t
WHERE t.tgrelid = ? and (not tgisconstraint  OR NOT EXISTS  (SELECT 1 FROM pg_catalog.pg_depend d JOIN
 pg_catalog.pg_constraint c ON (d.refclassid = c.tableoid AND d.refobjid = c.oid)    WHERE d.classid = t.tableoid AND d.objid =
  t.oid AND d.deptype = 'i' AND c.contype = 'f'))
        ";

        $sth = $self->{'dbh'}->prepare($sql);
        $sth->execute($oid) || die;
        while(my $row = $sth->fetchrow_hashref()) {
                push @triggers,$row;
        }

        @{$self->{'explained'}->{$table}->{'triggers'}} = @triggers;

        return @pg_attribute;
}

# return all rows in PostgreSQL format
# attname | format_type | attnotnull | atthasdef | attnum
#
# somewhat internal function, but still usefull if you want to
# do tweaking of columns your way
#
sub pg_attribute {
        my $self = shift;
        my $table = shift;

        if (! $self->{'explained'}->{$table}) {
                $self->explain($table);
        }

        return $self->{'explained'}->{$table}->{pg_attribute};
}

# return columns in given table
sub cols {
        my $self = shift;
        my $table = shift;

        if (! $self->{'explained'}->{$table}) {
                $self->explain($table);
        }

        return $self->{'explained'}->{$table}->{cols};
}

# return not null columns in given table
sub cols_notnull {
        my $self = shift;
        my $table = shift;

        if (! $self->{'explained'}->{$table}) {
                $self->explain($table);
        }

        return $self->{'explained'}->{$table}->{cols_notnull};
}

# return columns which *can* be null in given table
sub cols_null {
        my $self = shift;
        my $table = shift;

        if (! $self->{'explained'}->{$table}) {
                $self->explain($table);
        }

        return $self->{'explained'}->{$table}->{cols_null};
}

# return primary key columns
sub cols_pk {
        my $self = shift;
        my $table = shift;

        if (! $self->{'explained'}->{$table}) {
                $self->explain($table);
        }

        return $self->{'explained'}->{$table}->{cols_pk};
}

# return columns not in primary key
sub cols_notpk {
        my $self = shift;
        my $table = shift;

        if (! $self->{'explained'}->{$table}) {
                $self->explain($table);
        }

        return $self->{'explained'}->{$table}->{cols_notpk};
}

# get active triggers
sub get_activetriggers {
        my $self = shift;

        # find table oid
        my $sql = "
        SELECT tgname FROM pg_trigger
                WHERE tgname not like 'pg_%' and tgenabled IS TRUE
        ";

        my $sth = $self->{'dbh'}->prepare($sql);
        $sth->execute() || die;

        my @triggers;

        while (my ($tr) = $sth->fetchrow_array()) {
                push @triggers,$tr;
        }
        $sth->finish();

        return @triggers;
}

# return triggers
sub triggers {
        my $self = shift;
        my $table = shift;

        if (! $self->{'explained'}->{$table}) {
                $self->explain($table);
        }

        return $self->{'explained'}->{$table}->{triggers};
}

1;
1	package Pg::Scheme;
2
3	use strict;
4	use warnings;
5	use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
6	use Carp;
7
8
9	use Exporter ();
10	our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
11
12	$VERSION = 1.00;
13	@ISA = qw(Exporter);
14	@EXPORT = qw(&func1 &func2 &func4);
15	%EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
16
17	@EXPORT_OK = qw(
18	&list_tables
19	&get_table_oid
20	&explain
21	&pg_attribute
22	&cols
23	&cols_notnull
24	&cols_null
25	&cols_pk
26	&cols_notpk
27	);
28
29	my $debug;
30
31	sub new {
32	my ($class, %args) = @_;
33	my $self = {};
34	bless($self, $class);
35	$debug = $args{'DEBUG'};
36	$self->{dbh} = $args{'dbh'} \|\| croak "new needs to be called with 'dbh' which is handle to opened database";
37	@{$self->{tables}} = ();
38	$self ? return $self : return undef;
39	# XXX begin transaction?
40	}
41
42	sub list_tables {
43	my $self = shift;
44	my $tables = shift;
45
46	my @tables;
47
48	if ($tables) {
49	@tables = split(/,/,$tables);
50	} else {
51	# take all tables
52	#$sql="select tablename from pg_tables where tablename not like 'pg_%' and tablename not like '_rserv_%'";
53	# show tables (based on psql \dt)
54	my $sql = "
55	SELECT c.relname as table
56	FROM pg_catalog.pg_class c
57	LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace
58	WHERE c.relkind = 'r'
59	AND n.nspname NOT IN ('pg_catalog', 'pg_toast')
60	AND pg_catalog.pg_table_is_visible(c.oid)
61	and c.relname not like '_rserv_%'
62	";
63	foreach my $table (@tables) {
64	$sql .= " and c.relname like '$table' x";
65	}
66	my $sth = $self->{'dbh'}->prepare($sql) \|\| croak "can't prepare '$sql': ".$self->{'dbh'}->errstr;
67	$sth->execute() \|\| croak "can't execute '$sql': ".$sth->errstr;
68	while(my $row = $sth->fetchrow_hashref()) {
69	push @tables,$row->{table};
70	}
71	}
72	#@{$self->{'tables'}} = @tables;
73	return @tables;
74	}
75
76	sub get_table_oid {
77	my $self = shift;
78	my $table = shift;
79
80	# find table oid
81	my $sql = "
82	SELECT c.oid, n.nspname, c.relname
83	FROM pg_catalog.pg_class c
84	LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace
85	WHERE pg_catalog.pg_table_is_visible(c.oid)
86	AND c.relname = '$table'
87	ORDER BY 2, 3
88	";
89
90	my $sth = $self->{'dbh'}->prepare($sql);
91	$sth->execute() \|\| die;
92	my $row = $sth->fetchrow_hashref();
93	croak "Can't find OID of table '$table'\n" if (! $row);
94	$sth->finish();
95
96	return $row->{oid};
97	}
98
99	sub explain {
100	my $self = shift;
101	my $table = shift;
102
103	# XXX if explained, return just results
104	# return $self->{'explained'}->{$table}->{'pg_attribute'} if ($self->{'explained'}->{$table}->{'pg_attribute'});
105	my @pg_attribute;
106
107	my $oid = $self->get_table_oid($table);
108
109	# get table description
110	my $sql="
111	SELECT a.attname,
112	pg_catalog.format_type(a.atttypid, a.atttypmod) as format_type,
113	a.attnotnull, a.atthasdef, a.attnum
114	FROM pg_catalog.pg_attribute a
115	WHERE a.attrelid = ? AND a.attnum > 0 AND NOT a.attisdropped
116	ORDER BY a.attnum
117	";
118
119	# get default value
120	my $sql_def="
121	SELECT adsrc as def FROM pg_catalog.pg_attrdef
122	WHERE adrelid = ? and adnum=?
123	";
124
125	my @cols; # all columns (for insert)
126	my @cols_null; # columns compared by a=b or a is null and b is null
127	my @cols_notnull;# columns compared by a=b
128
129	my $sth = $self->{'dbh'}->prepare($sql);
130	my $sth_def = $self->{'dbh'}->prepare($sql_def);
131	$sth->execute($oid) \|\| die;
132	while(my $row = $sth->fetchrow_hashref()) {
133	# attname \| format_type \| attnotnull \| atthasdef \| attnum
134	push @cols,$row->{attname};
135
136	if ($row->{attnotnull}) {
137	push @cols_notnull,$row->{attname};
138	} else {
139	push @cols_null,$row->{attname};
140	}
141
142	if ($row->{atthasdef}) {
143	$sth_def->execute($oid,$row->{attnum}) \|\| die;
144	my $row_def = $sth_def->fetchrow_hashref() \|\| die "can't get attribute '",$row->{attname},"' default value!";
145	$row->{default} = $row_def->{def};
146	}
147
148	push @pg_attribute, $row;
149	}
150
151	@{$self->{'explained'}->{$table}->{'pg_attribute'}} = @pg_attribute;
152	@{$self->{'explained'}->{$table}->{'cols'}} = @cols;
153	@{$self->{'explained'}->{$table}->{'cols_notnull'}} = @cols_notnull;
154	@{$self->{'explained'}->{$table}->{'cols_null'}} = @cols_null;
155
156	# all, just for safe keeping
157	@{$self->{'explained'}->{$table}->{'cols_notpk'}} = @cols;
158
159	# now, try to find primary key
160
161	my @cols_pk; # columns which are primary key
162	my @cols_notpk;
163	my %in_pk;
164
165	$sql="
166	SELECT
167	i.indexrelid as indexrelid, i.indrelid as indrelid,
168	count(a.attname) as cols_in_pk
169	FROM
170	pg_catalog.pg_class c,
171	pg_catalog.pg_index i,
172	pg_catalog.pg_attribute a
173	WHERE
174	c.oid = i.indrelid
175	and i.indisunique
176	and c.relname = '$table'
177	and a.attrelid = i.indexrelid
178	GROUP BY
179	i.indexrelid, i.indrelid, c.relname, i.indisprimary, i.indisunique
180	ORDER BY
181	cols_in_pk ASC, i.indisprimary DESC, i.indisunique DESC, c.relname DESC
182	";
183	print STDERR "DEBUG: $sql\n" if ($debug);
184	$sth = $self->{'dbh'}->prepare($sql);
185	$sth->execute() \|\| die;
186	my $row = $sth->fetchrow_hashref();
187	if ($row) {
188	$sql="
189	select a1.attname as attname from pg_attribute a1, pg_attribute a2 where a1.attrelid = ".$row->{indexrelid}." and a2.attrelid=".$row->{indrelid}." and a1.attname = a2.attname and a2.attnotnull";
190
191	my $sth2 = $self->{'dbh'}->prepare($sql);
192	print STDERR "DEBUG: $sql\n" if ($debug);
193	$sth2->execute() \|\| die;
194	while (my $row2 = $sth2->fetchrow_hashref()) {
195	push @cols_pk,$row2->{attname};
196	$in_pk{$row2->{attname}}++;
197	}
198
199	}
200
201	foreach my $col (@cols) {
202	push @cols_notpk,$col if (! $in_pk{$col});
203	}
204
205	@{$self->{'explained'}->{$table}->{cols_pk}} = @cols_pk;
206	@{$self->{'explained'}->{$table}->{cols_notpk}} = @cols_notpk;
207
208	# find triggers
209
210	my @triggers;
211
212	$sql ="
213	SELECT t.tgname
214	FROM pg_catalog.pg_trigger t
215	WHERE t.tgrelid = ? and (not tgisconstraint OR NOT EXISTS (SELECT 1 FROM pg_catalog.pg_depend d JOIN
216	pg_catalog.pg_constraint c ON (d.refclassid = c.tableoid AND d.refobjid = c.oid) WHERE d.classid = t.tableoid AND d.objid =
217	t.oid AND d.deptype = 'i' AND c.contype = 'f'))
218	";
219
220	$sth = $self->{'dbh'}->prepare($sql);
221	$sth->execute($oid) \|\| die;
222	while(my $row = $sth->fetchrow_hashref()) {
223	push @triggers,$row;
224	}
225
226	@{$self->{'explained'}->{$table}->{'triggers'}} = @triggers;
227
228	return @pg_attribute;
229	}
230
231	# return all rows in PostgreSQL format
232	# attname \| format_type \| attnotnull \| atthasdef \| attnum
233	#
234	# somewhat internal function, but still usefull if you want to
235	# do tweaking of columns your way
236	#
237	sub pg_attribute {
238	my $self = shift;
239	my $table = shift;
240
241	if (! $self->{'explained'}->{$table}) {
242	$self->explain($table);
243	}
244
245	return $self->{'explained'}->{$table}->{pg_attribute};
246	}
247
248	# return columns in given table
249	sub cols {
250	my $self = shift;
251	my $table = shift;
252
253	if (! $self->{'explained'}->{$table}) {
254	$self->explain($table);
255	}
256
257	return $self->{'explained'}->{$table}->{cols};
258	}
259
260	# return not null columns in given table
261	sub cols_notnull {
262	my $self = shift;
263	my $table = shift;
264
265	if (! $self->{'explained'}->{$table}) {
266	$self->explain($table);
267	}
268
269	return $self->{'explained'}->{$table}->{cols_notnull};
270	}
271
272	# return columns which can be null in given table
273	sub cols_null {
274	my $self = shift;
275	my $table = shift;
276
277	if (! $self->{'explained'}->{$table}) {
278	$self->explain($table);
279	}
280
281	return $self->{'explained'}->{$table}->{cols_null};
282	}
283
284	# return primary key columns
285	sub cols_pk {
286	my $self = shift;
287	my $table = shift;
288
289	if (! $self->{'explained'}->{$table}) {
290	$self->explain($table);
291	}
292
293	return $self->{'explained'}->{$table}->{cols_pk};
294	}
295
296	# return columns not in primary key
297	sub cols_notpk {
298	my $self = shift;
299	my $table = shift;
300
301	if (! $self->{'explained'}->{$table}) {
302	$self->explain($table);
303	}
304
305	return $self->{'explained'}->{$table}->{cols_notpk};
306	}
307
308	# get active triggers
309	sub get_activetriggers {
310	my $self = shift;
311
312	# find table oid
313	my $sql = "
314	SELECT tgname FROM pg_trigger
315	WHERE tgname not like 'pg_%' and tgenabled IS TRUE
316	";
317
318	my $sth = $self->{'dbh'}->prepare($sql);
319	$sth->execute() \|\| die;
320
321	my @triggers;
322
323	while (my ($tr) = $sth->fetchrow_array()) {
324	push @triggers,$tr;
325	}
326	$sth->finish();
327
328	return @triggers;
329	}
330
331	# return triggers
332	sub triggers {
333	my $self = shift;
334	my $table = shift;
335
336	if (! $self->{'explained'}->{$table}) {
337	$self->explain($table);
338	}
339
340	return $self->{'explained'}->{$table}->{triggers};
341	}
342
343	1;