use Class::Unload;
require DBIx::Class;
-our $VERSION = '0.04999_13';
+our $VERSION = '0.05001';
__PACKAGE__->mk_group_ro_accessors('simple', qw/
schema
dump_directory
dump_overwrite
really_erase_my_files
- result_namespace
resultset_namespace
default_resultset_class
schema_base_class
schema_version_to_dump
_upgrading_from
_upgrading_from_load_classes
+ _downgrading_to_load_classes
+ _rewriting_result_namespace
use_namespaces
+ result_namespace
+ generate_pod
+ pod_comment_mode
+ pod_comment_spillover_length
/);
=head1 NAME
__PACKAGE__->naming('v5');
+=head2 generate_pod
+
+By default POD will be generated for columns and relationships, using database
+metadata for the text if available and supported.
+
+Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
+supported for Postgres right now.
+
+Set this to C<0> to turn off all POD generation.
+
+=head2 pod_comment_mode
+
+Controls where table comments appear in the generated POD. Smaller table
+comments are appended to the C<NAME> section of the documentation, and larger
+ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
+section to be generated with the comment always, only use C<NAME>, or choose
+the length threshold at which the comment is forced into the description.
+
+=over 4
+
+=item name
+
+Use C<NAME> section only.
+
+=item description
+
+Force C<DESCRIPTION> always.
+
+=item auto
+
+Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
+default.
+
+=back
+
+=head2 pod_comment_spillover_length
+
+When pod_comment_mode is set to C<auto>, this is the length of the comment at
+which it will be forced into a separate description section.
+
+The default is C<60>
+
=head2 relationship_attrs
Hashref of attributes to pass to each generated relationship, listed
$self->_check_back_compat;
$self->use_namespaces(1) unless defined $self->use_namespaces;
+ $self->generate_pod(1) unless defined $self->generate_pod;
+ $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
+ $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
$self;
}
open(my $fh, '<', $filename)
or croak "Cannot open '$filename' for reading: $!";
- my $load_classes = 0;
+ my $load_classes = 0;
+ my $result_namespace = '';
while (<$fh>) {
if (/^__PACKAGE__->load_classes;/) {
$load_classes = 1;
+ } elsif (/result_namespace => '([^']+)'/) {
+ $result_namespace = $1;
} elsif (my ($real_ver) =
/^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
if ($load_classes && (not defined $self->use_namespaces)) {
warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
-'load_classes;' static schema detected, turning off use_namespaces.
+'load_classes;' static schema detected, turning off 'use_namespaces'.
Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
variable to disable this warning.
$self->use_namespaces(0);
}
elsif ($load_classes && $self->use_namespaces) {
- $self->use_namespaces(1);
$self->_upgrading_from_load_classes(1);
}
+ elsif ((not $load_classes) && defined $self->use_namespaces
+ && (not $self->use_namespaces)) {
+ $self->_downgrading_to_load_classes(
+ $result_namespace || 'Result'
+ );
+ }
+ elsif ((not defined $self->use_namespaces)
+ || $self->use_namespaces) {
+ if (not $self->result_namespace) {
+ $self->result_namespace($result_namespace || 'Result');
+ }
+ elsif ($result_namespace ne $self->result_namespace) {
+ $self->_rewriting_result_namespace(
+ $result_namespace || 'Result'
+ );
+ }
+ }
# XXX when we go past .0 this will need fixing
my ($v) = $real_ver =~ /([1-9])/;
$self->schema_version_to_dump($real_ver);
- $self->use_namespaces(0) unless defined $self->use_namespaces;
-
last;
}
}
foreach my $prefix (@INC) {
my $fullpath = File::Spec->catfile($prefix, $file);
return $fullpath if -f $fullpath
- and Cwd::abs_path($fullpath) ne
- (Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '');
+ # abs_path throws on Windows for nonexistant files
+ and eval { Cwd::abs_path($fullpath) } ne
+ (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
}
return;
return $self->_find_file_in_inc($self->_class_path($class));
}
+sub _rewriting {
+ my $self = shift;
+
+ return $self->_upgrading_from
+ || $self->_upgrading_from_load_classes
+ || $self->_downgrading_to_load_classes
+ || $self->_rewriting_result_namespace
+ ;
+}
+
sub _rewrite_old_classnames {
my ($self, $code) = @_;
- return $code unless $self->_upgrading_from;
+ return $code unless $self->_rewriting;
my %old_classes = reverse %{ $self->_upgrading_classes };
my $real_inc_path = $self->_find_class_in_inc($class);
my $old_class = $self->_upgrading_classes->{$class}
- if $self->_upgrading_from;
+ if $self->_rewriting;
my $old_real_inc_path = $self->_find_class_in_inc($old_class)
if $old_class && $old_class ne $class;
$self->_write_classfile($src_class, $src_text);
}
+ # remove Result dir if downgrading from use_namespaces, and there are no
+ # files left.
+ if (my $result_ns = $self->_downgrading_to_load_classes
+ || $self->_rewriting_result_namespace) {
+ my $result_namespace = $self->_result_namespace(
+ $schema_class,
+ $result_ns,
+ );
+
+ (my $result_dir = $result_namespace) =~ s{::}{/}g;
+ $result_dir = $self->dump_directory . '/' . $result_dir;
+
+ unless (my @files = glob "$result_dir/*") {
+ rmdir $result_dir;
+ }
+ }
+
warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
}
$self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
}
+sub _result_namespace {
+ my ($self, $schema_class, $ns) = @_;
+ my @result_namespace;
+
+ if ($ns =~ /^\+(.*)/) {
+ # Fully qualified namespace
+ @result_namespace = ($1)
+ }
+ else {
+ # Relative namespace
+ @result_namespace = ($schema_class, $ns);
+ }
+
+ return wantarray ? @result_namespace : join '::', @result_namespace;
+}
+
# Create class with applicable bases, setup monikers, etc
sub _make_src_class {
my ($self, $table) = @_;
my @result_namespace = ($schema_class);
if ($self->use_namespaces) {
my $result_namespace = $self->result_namespace || 'Result';
- if ($result_namespace =~ /^\+(.*)/) {
- # Fully qualified namespace
- @result_namespace = ($1)
- }
- else {
- # Relative namespace
- push @result_namespace, $result_namespace;
- }
+ @result_namespace = $self->_result_namespace(
+ $schema_class,
+ $result_namespace,
+ );
}
my $table_class = join(q{::}, @result_namespace, $table_moniker);
if ((my $upgrading_v = $self->_upgrading_from)
- || $self->_upgrading_from_load_classes) {
+ || $self->_rewriting) {
local $self->naming->{monikers} = $upgrading_v
if $upgrading_v;
my @result_namespace = @result_namespace;
- @result_namespace = ($schema_class)
- if $self->_upgrading_from_load_classes;
+ if ($self->_upgrading_from_load_classes) {
+ @result_namespace = ($schema_class);
+ }
+ elsif (my $ns = $self->_downgrading_to_load_classes) {
+ @result_namespace = $self->_result_namespace(
+ $schema_class,
+ $ns,
+ );
+ }
+ elsif ($ns = $self->_rewriting_result_namespace) {
+ @result_namespace = $self->_result_namespace(
+ $schema_class,
+ $ns,
+ );
+ }
my $old_class = join(q{::}, @result_namespace,
$self->_table2moniker($table));
my $method = shift;
# generate the pod for this statement, storing it with $self->_pod
- $self->_make_pod( $class, $method, @_ );
+ $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
my $args = dump(@_);
$args = '(' . $args . ')' if @_ < 2;
if ( $method eq 'table' ) {
my ($table) = @_;
- $self->_pod( $class, "=head1 NAME" );
- my $table_descr = $class;
+ my $pcm = $self->pod_comment_mode;
+ my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
if ( $self->can('_table_comment') ) {
- my $comment = $self->_table_comment($table);
- $table_descr .= " - " . $comment if $comment;
+ $comment = $self->_table_comment($table);
+ $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
+ $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
+ $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
}
+ $self->_pod( $class, "=head1 NAME" );
+ my $table_descr = $class;
+ $table_descr .= " - " . $comment if $comment and $comment_in_name;
$self->{_class2table}{ $class } = $table;
$self->_pod( $class, $table_descr );
+ if ($comment and $comment_in_desc) {
+ $self->_pod( $class, "=head1 DESCRIPTION" );
+ $self->_pod( $class, $comment );
+ }
$self->_pod_cut( $class );
} elsif ( $method eq 'add_columns' ) {
$self->_pod( $class, "=head1 ACCESSORS" );
$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) = @_;
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff