DBICx::AutoDoc - Generate automatic documentation of DBIx::Class::Schema objects

  use DBICx:::AutoDoc;

  my $ad = DBICx:::AutoDoc->new(
    schema  => 'MyApp::DB',
    output  => '/tmp',
  );
  $ad->fill_template( 'html' );

  # pass options to constructor
  my $ad = DBICx::AutoDoc->new( schema => 'MyApp::DB' );

  # create object, then configure it
  my $ad = DBICx::AutoDoc->new();
  $ad->schema( 'MyApp::DB' );

  package MyApp::DB::Schema;
  use base qw( DBIx::Class::Schema );
  our $VERSION = 42;

  Error: Could not find/open font : Times-Roman

package DBICx::AutoDoc;
use strict;
use warnings;
our $VERSION = '0.07';
use base qw( Class::Accessor::Grouped );
use Carp qw( croak );
use Template;
use Class::Inspector;
use FindBin qw( );
use Data::Dump qw( dump );
use DBICx::AutoDoc::Magic;
use File::Temp qw( tempfile );
use Tie::IxHash;

__PACKAGE__->mk_group_accessors( simple => qw(
    output connect dsn user pass
) );
__PACKAGE__->mk_group_accessors( inherited => qw(
    include_path graphviz_command
) );
__PACKAGE__->include_path( __PACKAGE__->default_include_path() );
__PACKAGE__->graphviz_command( [ "fdp" ] );

sub new {
    my $self = bless( {
        output          => '.',
        connect         => 0,
    }, shift() );
    my %args = @_;

    for my $key ( keys %args ) { $self->$key( $args{ $key } ) }

    return $self;
}

sub schema {
    my ( $self, $val ) = @_;

    if ( $val ) {
        $self->{ 'schema' } = $val;
        eval "require $val";
        if ( $@ ) { croak "Could not load $val: $@" }
    } elsif( my $schema = $self->{ 'schema' } ) {
        if ( ref( $schema ) || ! $self->connect ) { return $schema }
        print "Connecting to database\n";
        $self->{ 'schema' } = $schema->connect(
            $self->dsn, $self->user, $self->pass,
        );
        return $self->{ 'schema' };
    } else {
        croak "No schema provided";
    }
}

sub schema_class {
    my ( $self ) = @_;

    my $schema = $self->schema;
    return ref( $schema ) || $schema;
}

sub schema_version { shift->schema->VERSION || 1 }

sub generated {
    my ( $self ) = @_;

    $self->{ 'generated' } ||= localtime;
    return $self->{ 'generated' };
}

sub software_versions {
    my ( $self ) = @_;

    return {
        map { ( $_ => $_->VERSION ) } qw(
            DBICx::AutoDoc DBICx::AutoDoc::Magic
            DBIx::Class Template
        )
    };
}

sub sources {
    my ( $self ) = @_;

    if ( $self->{ 'sources' } ) { return $self->{ 'sources' } }

    my $schema = $self->schema;

    my @sources = ();
    $self->{ 'sources' } = \@sources;

    my %source_names = ();
    $self->{ 'source_names' } = \%source_names;
    
    # mst: map { $_->source_name }
    #      grep { $_->result_class eq $class }
    #      map { $schema->source($_) } $schema->sources
    # mst: it's all you can have safely :)
    for my $moniker ( sort $schema->sources ) {
        my $source = $schema->source( $moniker );
        my $rs = $schema->resultset( $moniker );
        my $cl = $rs->result_class;

        $source_names{ $cl } = $source->source_name;

        # COLLECTING DATA
        push( @sources, {
            moniker             => $moniker,
            simple_moniker      => $self->get_simple_moniker_for( $moniker ),
            class               => $cl,
            primary_columns     => [ $cl->primary_columns ],
            table               => $cl->table,
            result_class        => $cl,
            resultset_class     => $cl->resultset_class,
            columns             => [ $self->get_columns_for( $cl ) ],
            unique_constraints  => [ $self->get_unique_constraints_for( $cl ) ],
            relationships       => [ $self->get_relationships_for( $cl ) ],
        } );
    }

    return $self->{ 'sources' };
}

sub inheritance {
    my ( $self, @classes ) = @_;

    if ( ! @classes ) {
        @classes = ( map { $_->{ 'class' } } @{ $self->sources } );
    }
    my %parents = ();
    while ( @classes ) {
        my $class = shift( @classes );
        next if $parents{ $class };
        my @tmp = do { no strict 'refs'; @{ $class.'::ISA' } };
        push( @classes, @tmp );
        $parents{ $class } = \@tmp;
    }
    return \%parents;
}

sub get_columns_for {
    my ( $self, $class ) = @_;

    my %cols = ();
    tie( %cols, 'Tie::IxHash' );

    # COLUMNS
    for ( $class->columns ) {
        my $col = $class->column_info( $_ );
        $col->{ 'name' } = $_;
        $col->{ 'is_inflated' } = delete $col->{ '_inflate_info' } ? 1 : 0;
        $cols{ $_ } = $col;
    }

    # PRIMARY COLUMNS
    for my $c ( $class->primary_columns ) {
        $cols{ $c }->{ 'is_primary' } = 1;
    }

    # UNIQUE CONSTRAINTS
    my %tmp = $class->unique_constraints;
    while ( my ( $key, $val ) = each %tmp ) {
        for my $x ( @{ $val } ) {
            push( @{ $cols{ $x }->{ 'unique_constraints' } }, $key );
        }
    }

    return values %cols;
}

sub get_unique_constraints_for {
    my ( $self, $class ) = @_;

    # UNIQUE CONSTRAINTS
    my %unique = ();

    my %tmp = $class->unique_constraints;
    for my $key ( sort keys %tmp ) {
        $unique{ $key }->{ 'name' } = $key;
        $unique{ $key }->{ 'columns' } = $tmp{ $key }
    }

    return values %unique;
}

sub get_relationships_for {
    my ( $self, $class ) = @_;

    my %relationships = ();

    # RELATIONSHIPS (from DBICx::AutoDoc::Magic)
    unless ( $class->can( '_autodoc' ) ) {
        croak "$class cannot _autodoc, something must have gone wrong";
    }

    my $ad = $class->_autodoc || {};
    for ( @{ $ad->{ 'relationships' } || [] } ) {
        my ( $type, $relname, @parts ) = @{ $_ };
        my $rel = ( $relationships{ $relname } ||= {} );
        @{ $rel }{qw( name type )} = ( $relname, $type );

        if ( $type eq 'many_to_many' ) {
            @{ $rel }{qw( link_rel_name foreign_rel_name attributes )} = @parts;
        } else {
            @{ $rel }{qw( foreign_class condition attributes )} = @parts;
        }
    }

    # RELATIONSHIPS (from DBIx::Class::Relationship)
    for my $name ( $class->relationships ) {
        my $rel = ( $relationships{ $name } ||= {} );
        my $info = $class->relationship_info( $name );
        $rel->{ 'name' } ||= $name;
        for my $key ( keys %{ $info } ) {
            $rel->{ $key } = $info->{ $key };
        }
    }

    # GENERAL RELATIONSHIP MUNGING
    for my $name ( keys %relationships ) {
        my $rel = $relationships{ $name };
        for my $x ( '', 'foreign_' ) {
            if ( $rel->{ $x.'class' } ) {
                $rel->{ $x.'moniker' } = $rel->{ $x.'class' }->source_name;
            }
        }
    }

    return values %relationships;
}

sub relationship_map {
    my ( $self ) = @_;

    my @relmap = ();
    my $snames = $self->{ 'source_names' };

    for my $source ( @{ $self->sources } ) {
        for my $rel ( @{ $source->{ 'relationships' } } ) {
            my $type = $rel->{ 'type' };
            my $map = {
                name    => $rel->{ 'name' },
                type    => $type,
            };
            push( @relmap, $map );
            if ( $type eq 'many_to_many' ) {
                for my $x (qw( link_rel_name foreign_rel_name )) {
                    $map->{ $x } = $rel->{ $x };
                }
                $map->{ 'accessor' } = 'many_to_many';
            } else {
                $map->{ 'accessor' } = $rel->{ 'attr' }->{ 'accessor' };
                $map->{ 'self' } = $source->{ 'moniker' };
                $map->{ 'foreign' } = $snames->{ $rel->{ 'foreign_class' } };

                my %cond = %{ $rel->{ 'cond' } };
            
                my @cond = ();
                while ( my ( $l, $r ) = each %cond ) {
                    push( @cond, { split( '\.', $l, 2 ), split( '\.', $r ) } );
                }
                $map->{ 'cond' } = \@cond;
            }
        }
    }
    return \@relmap;
}

sub get_simple_moniker_for {
    my ( $self, $moniker ) = @_;

    #if ( $moniker->can( 'source_name' ) ) { $moniker = $moniker->source_name }

    $self->{ '_simple_moniker_cache' } ||= {};
    my $cache = $self->{ '_simple_moniker_cache' };
    
    if ( $cache->{ $moniker } ) { return $cache->{ $moniker } }

    my $simple = $moniker;
    $simple =~ s/\W+/_/g;

    my %inverse_cache = reverse %{ $cache };
    if ( $inverse_cache{ $simple } ) {
        my $i = 0;
        while ( $inverse_cache{ $simple.$i } ) { $i++ }
        $simple .= $i;
    }

    $cache->{ $moniker } = $simple;
}

sub byname($$) { return shift->{ 'name' } cmp shift->{ 'name' } }

sub get_vars {
    my ( $self ) = @_;

    my @vars = qw(
        schema schema_class schema_version generated software_versions sources
        relationship_map filename_base output connect dsn user
        graphviz_command inheritance
    );

    $self->{ '_vars' } ||= {
        autodoc         => $self,
        dumper          => sub { return dump( @_ ) },
        simplify        => sub { return $self->get_simple_moniker_for( @_ ) },
        output_filename => sub { return $self->output_filename( @_ ) },
        ENV             => \%ENV,
        varlist         => [ @vars, 'ENV' ],
        ( map { ( $_ => $self->$_() ) } @vars ),
    };
    return $self->{ '_vars' };
}

sub find_template_file {
    my ( $self, $template ) = @_;

    my $path = $self->include_path;
    if ( ! ref $path ) { $path = [ $path ] }

    for my $x ( @{ $path } ) {
        my $test = File::Spec->catfile( $x, $template );
        if ( -f $test ) { return $test }
    }

    return;
}

sub fill_template {
    my ( $self, $template ) = @_;

    my $first_line = sub {
        open( my $fh, shift() ); chomp( my $start = <$fh> ); close( $fh );
        return $start;
    };

    my $tmpl = Template->new( { INCLUDE_PATH => $self->include_path } );
    my $outfile = $self->output_filename( $template, 1 );
    my $vars = $self->get_vars;

    if ( $first_line->( $self->find_template_file( $template ) ) =~ /^#!/ ) {
        my ( undef, $file ) = tempfile();
        my $script = $outfile.'.script';
        $tmpl->process( $template, $vars, $script ) || croak $tmpl->error;

        my $cmd = $first_line->( $script );
        $cmd =~ s/^#!//;

        open( my $outfh, '>', $outfile );
        open( my $infh, '-|', $cmd, $script );
        $outfh->print( <$infh> );
        close( $infh );
        close( $outfh );
        unlink( $script );
    } else {
        $tmpl->process( $template, $vars, $outfile ) || croak $tmpl->error;
    }
}

sub filename_base {
    my ( $self ) = @_;

    my $name = ref( $self->schema ) || $self->schema;
    if ( ! $name ) { croak "Cannot call filename_base without a schema" }
    $name =~ s/::/-/g;
    return join( '-', $name, $self->schema->VERSION || 1 );
}

sub output_filename {
    my ( $self, $template, $full ) = @_;

    my $base = $self->filename_base;
    $template =~ s/^AUTODOC/$base/;
    if ( $full ) {
        return File::Spec->catfile( $self->output, $template );
    } else {
        return $template;
    }
}

sub default_include_path {
    my ( $self ) = @_;
    my $class = ref( $self ) || $self;
    my $short = Class::Inspector->filename( $class );
    my $long = Class::Inspector->loaded_filename( $class );
    substr( $short, -3, 3, '' );
    $long =~ m{^(.*)\Q$short\E\.pm\z}s or die "Failed to find base dir";
    my $dir = File::Spec->catdir( $1, 'auto', $short );
    return [ $dir, File::Spec->catdir( $FindBin::Bin, "templates" ) ];
}

sub list_templates {
    my ( $self ) = @_;

    my $inc = $self->include_path;
    if ( ! ref $inc ) { $inc = [ $inc ] }
    my %tmpls = ();
    for my $dir ( @{ $inc } ) {
        opendir( my $dirfh, $dir );
        for ( readdir( $dirfh ) ) {
            next unless /^AUTODOC/;
            $tmpls{ $_ } = 1;
        }
        closedir( $dirfh );
    }

    return sort { length( $a ) <=> length( $b ) || $a cmp $b } keys %tmpls;
}

sub fill_all_templates {
    my ( $self ) = @_;

    $self->fill_templates( $self->list_templates );
}

sub fill_templates {
    my ( $self, @templates ) = @_;

    $self->fill_template( $_ ) for @templates;
}


1;
__END__