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);

        my $sql="
        SELECT a.attname,
        pg_catalog.format_type(a.atttypid, a.atttypmod),
        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
        ";

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

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

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

        }

        @{$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;

        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_triggers {
        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;
}

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	my $sql="
110	SELECT a.attname,
111	pg_catalog.format_type(a.atttypid, a.atttypmod),
112	a.attnotnull, a.atthasdef, a.attnum
113	FROM pg_catalog.pg_attribute a
114	WHERE a.attrelid = ? AND a.attnum > 0 AND NOT a.attisdropped
115	ORDER BY a.attnum
116	";
117
118	my @cols; # all colums (for insert)
119	my @cols_null; # colums compared by a=b or a is null and b is null
120	my @cols_notnull;# colums compared by a=b
121
122	my $sth = $self->{'dbh'}->prepare($sql);
123	$sth->execute($oid) \|\| die;
124	while(my $row = $sth->fetchrow_hashref()) {
125	# attname \| format_type \| attnotnull \| atthasdef \| attnum
126	push @pg_attribute, $row;
127	push @cols,$row->{attname};
128
129	if ($row->{attnotnull}) {
130	push @cols_notnull,$row->{attname};
131	} else {
132	push @cols_null,$row->{attname};
133	}
134
135	}
136
137	@{$self->{'explained'}->{$table}->{'pg_attribute'}} = @pg_attribute;
138	@{$self->{'explained'}->{$table}->{'cols'}} = @cols;
139	@{$self->{'explained'}->{$table}->{'cols_notnull'}} = @cols_notnull;
140	@{$self->{'explained'}->{$table}->{'cols_null'}} = @cols_null;
141
142	# all, just for safe keeping
143	@{$self->{'explained'}->{$table}->{'cols_notpk'}} = @cols;
144
145	# now, try to find primary key
146
147	my @cols_pk; # columns which are primary key
148	my @cols_notpk;
149	my %in_pk;
150
151	$sql="
152	SELECT
153	i.indexrelid as indexrelid, i.indrelid as indrelid,
154	count(a.attname) as cols_in_pk
155	FROM
156	pg_catalog.pg_class c,
157	pg_catalog.pg_index i,
158	pg_catalog.pg_attribute a
159	WHERE
160	c.oid = i.indrelid
161	and i.indisunique
162	and c.relname = '$table'
163	and a.attrelid = i.indexrelid
164	GROUP BY
165	i.indexrelid, i.indrelid, c.relname, i.indisprimary, i.indisunique
166	ORDER BY
167	cols_in_pk ASC, i.indisprimary DESC, i.indisunique DESC, c.relname DESC
168	";
169	print STDERR "DEBUG: $sql\n" if ($debug);
170	$sth = $self->{'dbh'}->prepare($sql);
171	$sth->execute() \|\| die;
172	my $row = $sth->fetchrow_hashref();
173	if ($row) {
174	$sql="
175	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";
176
177	my $sth2 = $self->{'dbh'}->prepare($sql);
178	print STDERR "DEBUG: $sql\n" if ($debug);
179	$sth2->execute() \|\| die;
180	while (my $row2 = $sth2->fetchrow_hashref()) {
181	push @cols_pk,$row2->{attname};
182	$in_pk{$row2->{attname}}++;
183	}
184
185	}
186
187	foreach my $col (@cols) {
188	push @cols_notpk,$col if (! $in_pk{$col});
189	}
190
191	@{$self->{'explained'}->{$table}->{cols_pk}} = @cols_pk;
192	@{$self->{'explained'}->{$table}->{cols_notpk}} = @cols_notpk;
193
194	return @pg_attribute;
195	}
196
197	# return all rows in PostgreSQL format
198	# attname \| format_type \| attnotnull \| atthasdef \| attnum
199	#
200	# somewhat internal function, but still usefull if you want to
201	# do tweaking of columns your way
202	#
203	sub pg_attribute {
204	my $self = shift;
205	my $table = shift;
206
207	if (! $self->{'explained'}->{$table}) {
208	$self->explain($table);
209	}
210
211	return $self->{'explained'}->{$table}->{pg_attribute};
212	}
213
214	# return columns in given table
215	sub cols {
216	my $self = shift;
217	my $table = shift;
218
219	if (! $self->{'explained'}->{$table}) {
220	$self->explain($table);
221	}
222
223	return $self->{'explained'}->{$table}->{cols};
224	}
225
226	# return not null columns in given table
227	sub cols_notnull {
228	my $self = shift;
229	my $table = shift;
230
231	if (! $self->{'explained'}->{$table}) {
232	$self->explain($table);
233	}
234
235	return $self->{'explained'}->{$table}->{cols_notnull};
236	}
237
238	# return columns which can be null in given table
239	sub cols_null {
240	my $self = shift;
241	my $table = shift;
242
243	if (! $self->{'explained'}->{$table}) {
244	$self->explain($table);
245	}
246
247	return $self->{'explained'}->{$table}->{cols_null};
248	}
249
250	# return primary key columns
251	sub cols_pk {
252	my $self = shift;
253	my $table = shift;
254
255	if (! $self->{'explained'}->{$table}) {
256	$self->explain($table);
257	}
258
259	return $self->{'explained'}->{$table}->{cols_pk};
260	}
261
262	# return columns not in primary key
263	sub cols_notpk {
264	my $self = shift;
265	my $table = shift;
266
267	if (! $self->{'explained'}->{$table}) {
268	$self->explain($table);
269	}
270
271	return $self->{'explained'}->{$table}->{cols_notpk};
272	}
273
274	# get active triggers
275	sub get_triggers {
276	my $self = shift;
277
278	# find table oid
279	my $sql = "
280	SELECT tgname FROM pg_trigger
281	WHERE tgname not like 'pg_%' and tgenabled IS TRUE
282	";
283
284	my $sth = $self->{'dbh'}->prepare($sql);
285	$sth->execute() \|\| die;
286
287	my @triggers;
288
289	while (my ($tr) = $sth->fetchrow_array()) {
290	push @triggers,$tr;
291	}
292	$sth->finish();
293
294	return @triggers;
295	}
296
297	1;