[Bast-commits] r7985 - in
branches/DBIx-Class-Schema-Loader/current: .
lib/DBIx/Class/Schema/Loader lib/DBIx/Class/Schema/Loader/DBI t
caelum at dev.catalyst.perl.org
caelum at dev.catalyst.perl.org
Sun Nov 29 14:51:19 GMT 2009
Author: caelum
Date: 2009-11-29 14:51:18 +0000 (Sun, 29 Nov 2009)
New Revision: 7985
Modified:
branches/DBIx-Class-Schema-Loader/current/Changes
branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/Base.pm
branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm
branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm
branches/DBIx-Class-Schema-Loader/current/t/23dumpmore.t
Log:
added patch to generate POD from postgres by Andrey Kostenko (GUGU)
Modified: branches/DBIx-Class-Schema-Loader/current/Changes
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/Changes 2009-11-29 12:11:55 UTC (rev 7984)
+++ branches/DBIx-Class-Schema-Loader/current/Changes 2009-11-29 14:51:18 UTC (rev 7985)
@@ -1,5 +1,6 @@
Revision history for Perl extension DBIx::Class::Schema::Loader
+ - added patch to generate POD from postgres by Andrey Kostenko (GUGU)
- added test for norewrite feature
- fix default_value for MSSQL
Modified: branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/Base.pm
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/Base.pm 2009-11-29 12:11:55 UTC (rev 7984)
+++ branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/Base.pm 2009-11-29 14:51:18 UTC (rev 7985)
@@ -855,15 +855,59 @@
my $self = shift;
my $class = shift;
my $method = shift;
-
+ if ( $method eq 'table' ) {
+ my ($table) = @_;
+ $self->_pod( $class, "=head1 NAME" );
+ my $table_descr = $class;
+ if ( $self->can('_table_comment') ) {
+ my $comment = $self->_table_comment($table);
+ $table_descr .= " - " . $comment if $comment;
+ }
+ $self->{_class2table}{ $class } = $table;
+ $self->_pod( $class, $table_descr );
+ $self->_pod_cut( $class );
+ } elsif ( $method eq 'add_columns' ) {
+ $self->_pod( $class, "=head1 ACCESSORS" );
+ my $i = 0;
+ foreach ( @_ ) {
+ $i++;
+ next unless $i % 2;
+ $self->_pod( $class, '=head2 ' . $_ );
+ my $comment;
+ $comment = $self->_column_comment( $self->{_class2table}{$class}, ($i - 1) / 2 + 1 ) if $self->can('_column_comment');
+ $self->_pod( $class, $comment ) if $comment;
+ }
+ $self->_pod_cut( $class );
+ } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
+ $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
+ my ( $accessor, $rel_class ) = @_;
+ $self->_pod( $class, "=head2 $accessor" );
+ $self->_pod( $class, 'Type: ' . $method );
+ $self->_pod( $class, "Related object: L<$rel_class>" );
+ $self->_pod_cut( $class );
+ $self->{_relations_started} { $class } = 1;
+ }
my $args = dump(@_);
$args = '(' . $args . ')' if @_ < 2;
my $stmt = $method . $args . q{;};
warn qq|$class\->$stmt\n| if $self->debug;
$self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
+ return;
}
+# Stores a POD documentation
+sub _pod {
+ my ($self, $class, $stmt) = @_;
+ $self->_raw_stmt( $class, "\n" . $stmt );
+}
+
+sub _pod_cut {
+ my ($self, $class ) = @_;
+ $self->_raw_stmt( $class, "\n=cut\n" );
+}
+
+
# Store a raw source line for a class (for dumping purposes)
sub _raw_stmt {
my ($self, $class, $stmt) = @_;
Modified: branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm 2009-11-29 12:11:55 UTC (rev 7984)
+++ branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm 2009-11-29 14:51:18 UTC (rev 7985)
@@ -35,6 +35,7 @@
$self->{db_schema} ||= 'public';
}
+
sub _table_uniq_info {
my ($self, $table) = @_;
@@ -95,6 +96,32 @@
return \@uniqs;
}
+sub _table_comment {
+ my ( $self, $table ) = @_;
+ my ($table_comment) = $self->schema->storage->dbh->selectrow_array(
+ q{SELECT obj_description(oid)
+ FROM pg_class
+ WHERE relname=? AND relnamespace=(
+ SELECT oid FROM pg_namespace WHERE nspname=?)
+ }, undef, $table, $self->db_schema
+ );
+ return $table_comment
+}
+
+
+sub _column_comment {
+ my ( $self, $table, $column_number ) = @_;
+ my ($table_oid) = $self->schema->storage->dbh->selectrow_array(
+ q{SELECT oid
+ FROM pg_class
+ WHERE relname=? AND relnamespace=(
+ SELECT oid FROM pg_namespace WHERE nspname=?)
+ }, undef, $table, $self->db_schema
+ );
+ return $self->schema->storage->dbh->selectrow_array('SELECT col_description(?,?)', undef, $table_oid,
+ $column_number );
+}
+
sub _extra_column_info {
my ($self, $info) = @_;
my %extra_info;
Modified: branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm 2009-11-29 12:11:55 UTC (rev 7984)
+++ branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm 2009-11-29 14:51:18 UTC (rev 7985)
@@ -38,6 +38,16 @@
# concatenated if you wish.
}
+ sub _table_comment {
+ my ( $self, $table ) = @_;
+ return 'Comment';
+ }
+
+ sub _column_comment {
+ my ( $self, $table, $column_number ) = @_;
+ return 'Col. comment';
+ }
+
1;
=head1 DETAILS
@@ -62,6 +72,9 @@
This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
+To import comments from database you need to implement C<_table_comment>,
+C<_column_comment>
+
=cut
1;
Modified: branches/DBIx-Class-Schema-Loader/current/t/23dumpmore.t
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/t/23dumpmore.t 2009-11-29 12:11:55 UTC (rev 7984)
+++ branches/DBIx-Class-Schema-Loader/current/t/23dumpmore.t 2009-11-29 14:51:18 UTC (rev 7985)
@@ -8,7 +8,7 @@
$^O eq 'MSWin32'
? plan(skip_all => "ActiveState perl produces additional warnings, and this test uses unix paths")
- : plan(tests => 145);
+ : plan(tests => 153);
my $DUMP_PATH = './t/_dump';
@@ -142,11 +142,15 @@
],
Foo => [
qr/package DBICTest::DumpMore::1::Foo;/,
+ qr/=head1 NAME/,
+ qr/=head1 ACCESSORS/,
qr/->set_primary_key/,
qr/1;\n$/,
],
Bar => [
qr/package DBICTest::DumpMore::1::Bar;/,
+ qr/=head1 NAME/,
+ qr/=head1 ACCESSORS/,
qr/->set_primary_key/,
qr/1;\n$/,
],
More information about the Bast-commits
mailing list