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	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			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	dpavlin	1.2	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	dpavlin	1.1	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	dpavlin	1.2	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	dpavlin	1.1	}
270
271	dpavlin	1.2	return $self->{'explained'}->{$table}->{cols_notpk};
272	dpavlin	1.1	}
273	dpavlin	1.3
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	dpavlin	1.1	1;