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 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);
        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	dpavlin	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	dpavlin	1.2	&get_table_oid
20			&explain
21			&pg_attribute
22			&cols
23			&cols_notnull
24			&cols_null
25			&cols_pk
26			&cols_notpk
27	dpavlin	1.1	);
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	dpavlin	1.2	sub explain {
100	dpavlin	1.1	my $self = shift;
101			my $table = shift;
102
103	dpavlin	1.2	# XXX if explained, return just results
104			# return $self->{'explained'}->{$table}->{'pg_attribute'} if ($self->{'explained'}->{$table}->{'pg_attribute'});
105			my @pg_attribute;
106	dpavlin	1.1
107			my $oid = $self->get_table_oid($table);
108
109	dpavlin	1.4	# get table description
110	dpavlin	1.1	my $sql="
111			SELECT a.attname,
112	dpavlin	1.4	pg_catalog.format_type(a.atttypid, a.atttypmod) as format_type,
113	dpavlin	1.1	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	dpavlin	1.4	# 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	dpavlin	1.2	my @cols; # all colums (for insert)
126			my @cols_null; # colums compared by a=b or a is null and b is null
127			my @cols_notnull;# colums compared by a=b
128
129	dpavlin	1.1	my $sth = $self->{'dbh'}->prepare($sql);
130	dpavlin	1.4	my $sth_def = $self->{'dbh'}->prepare($sql_def);
131	dpavlin	1.1	$sth->execute($oid) \|\| die;
132			while(my $row = $sth->fetchrow_hashref()) {
133			# attname \| format_type \| attnotnull \| atthasdef \| attnum
134	dpavlin	1.2	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	dpavlin	1.4	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	dpavlin	1.2	}
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	dpavlin	1.4	# 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	dpavlin	1.2	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	dpavlin	1.1	}
304
305	dpavlin	1.2	return $self->{'explained'}->{$table}->{cols_notpk};
306	dpavlin	1.1	}
307	dpavlin	1.3
308			# get active triggers
309	dpavlin	1.4	sub get_activetriggers {
310	dpavlin	1.3	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	dpavlin	1.4	# 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	dpavlin	1.1	1;