package SQL::Translator::Producer::GraphViz;

=pod

=head1 NAME

SQL::Translator::Producer::GraphViz - GraphViz producer for SQL::Translator

=head1 SYNOPSIS

  use SQL::Translator;

  my $trans = SQL::Translator->new(
      from => 'MySQL',            # or your db of choice
      to   => 'GraphViz',
      producer_args => {
          out_file         => 'schema.png',
          bgcolor          => 'lightgoldenrodyellow',
          show_constraints => 1,
          show_datatypes   => 1,
          show_sizes       => 1
      }
  ) or die SQL::Translator->error;

  $trans->translate or die $trans->error;

=head1 DESCRIPTION

Creates a graph of a schema using the amazing graphviz
(see http://www.graphviz.org/) application (via
the L<GraphViz> module).  It's nifty--you should try it!

=head1 PRODUCER ARGS

All L<GraphViz> constructor attributes are accepted and passed
through to L<GraphViz/new>. The following defaults are assumed
for some attributes:

  layout => 'dot',
  overlap => 'false',

  node => {
    shape => 'record',
    style => 'filled',
    fillcolor => 'white',
  },

  # in inches
  width => 8.5,
  height => 11,

See the documentation of L<GraphViz/new> for more info on these
and other attributes.

In addition this producer accepts the following arguments:

=over 4

=item * skip_tables

An arrayref or a comma-separated list of table names that should be
skipped. Note that a skipped table node may still appear if another
table has foreign key constraints pointing to the skipped table. If
this happens no table field/index information will be included.

=item * skip_tables_like

An arrayref or a comma-separated list of regular expressions matching
table names that should be skipped.

=item * cluster

Clustering of tables allows you to group and box tables according to
function or domain or whatever criteria you choose.  The syntax for
clustering tables is:

  cluster => 'cluster1=table1,table2;cluster2=table3,table4'

Or pass it as an arrayref like so:

  cluster => [ 'cluster1=table1,table2', 'cluster2=table3,table4' ]

Or like so:

  cluster => [
    { name => 'cluster1', tables => [ 'table1', 'table2' ] },
    { name => 'cluster2', tables => [ 'table3', 'table4' ] },
  ]

=item * out_file

The name of the file where the resulting GraphViz output will be
written. Alternatively an open filehandle can be supplied. If
undefined (the default) - the result is returned as a string.

=item * output_type (DEFAULT: 'png')

This determines which
L<output method|GraphViz/as_canon, as_text, as_gif etc. methods>
will be invoked to generate the graph: C<png> translates to
C<as_png>, C<ps> to C<as_ps> and so on.

=item * fontname

This sets the global font name (or full path to font file) for
node, edge, and graph labels

=item * fontsize

This sets the global font size for node and edge labels (note that
arbitrarily large sizes may be ignored due to page size or graph size
constraints)

=item * show_fields (DEFAULT: true)

If set to a true value, the names of the columns in a table will
be displayed in each table's node

=item * show_fk_only

If set to a true value, only columns which are foreign keys
will be displayed in each table's node

=item * show_datatypes

If set to a true value, the datatype of each column will be
displayed next to each column's name; this option will have no
effect if the value of C<show_fields> is set to false

=item * friendly_ints

If set to a true value, each integer type field will be displayed
as a tinyint, smallint, integer or bigint depending on the field's
associated size parameter. This only applies for the C<integer>
type (and not the C<int> type, which is always assumed to be a
32-bit integer); this option will have no effect if the value of
C<show_fields> is set to false

=item * friendly_ints_extended

If set to a true value, the friendly ints displayed will take into
account the non-standard types, 'tinyint' and 'mediumint' (which,
as far as I am aware, is only implemented in MySQL)

=item * show_sizes

If set to a true value, the size (in bytes) of each CHAR and
VARCHAR column will be displayed in parentheses next to the
column's name; this option will have no effect if the value of
C<show_fields> is set to false

=item * show_constraints

If set to a true value, a field's constraints (i.e., its
primary-key-ness, its foreign-key-ness and/or its uniqueness)
will appear as a comma-separated list in brackets next to the
field's name; this option will have no effect if the value of
C<show_fields> is set to false

=item * show_indexes

If set to a true value, each record will also show the indexes
set on each table. It describes the index types along with
which columns are included in the index.

=item * show_index_names (DEFAULT: true)

If C<show_indexes> is set to a true value, then the value of this
parameter determines whether or not to print names of indexes.
if C<show_index_names> is false, then a list of indexed columns
will appear below the field list. Otherwise, it will be a list
prefixed with the name of each index.

=item * natural_join

If set to a true value, L<SQL::Translator::Schema/make_natural_joins>
will be called before generating the graph.

=item * join_pk_only

The value of this option will be passed as the value of the
like-named argument to L<SQL::Translator::Schema/make_natural_joins>;
implies C<< natural_join => 1 >>

=item * skip_fields

The value of this option will be passed as the value of the
like-named argument to L<SQL::Translator::Schema/make_natural_joins>;
implies C<< natural_join => 1 >>

=back

=head2 DEPRECATED ARGS

=over 4

=item * node_shape

Deprecated, use node => { shape => ... } instead

=item * add_color

Deprecated, use bgcolor => 'lightgoldenrodyellow' instead

If set to a true value, the graphic will have a background
color of 'lightgoldenrodyellow'; otherwise the default
white background will be used

=item * nodeattrs

Deprecated, use node => { ... } instead

=item * edgeattrs

Deprecated, use edge => { ... } instead

=item * graphattrs

Deprecated, use graph => { ... } instead

=back

=cut

use warnings;
use strict;
use GraphViz;
use SQL::Translator::Schema::Constants;
use SQL::Translator::Utils qw(debug);
use Scalar::Util           qw/openhandle/;

our $DEBUG;
our $VERSION = '1.66';
$DEBUG = 0 unless defined $DEBUG;

sub produce {
  my $t      = shift;
  my $schema = $t->schema;
  my $args   = $t->producer_args;
  local $DEBUG = $t->debug;

  # translate legacy {node|edge|graph}attrs to just {node|edge|graph}
  for my $argtype (qw/node edge graph/) {
    my $old_arg = $argtype . 'attrs';

    my %arglist = (map { %{ $_ || {} } } (delete $args->{$old_arg}, delete $args->{$argtype}));

    $args->{$argtype} = \%arglist if keys %arglist;
  }

  # explode font settings
  for (qw/fontsize fontname/) {
    if (defined $args->{$_}) {
      $args->{node}{$_}  ||= $args->{$_};
      $args->{edge}{$_}  ||= $args->{$_};
      $args->{graph}{$_} ||= $args->{$_};
    }
  }

  # legacy add_color setting, trumped by bgcolor if set
  $args->{bgcolor} ||= 'lightgoldenrodyellow' if $args->{add_color};

  # legacy node_shape setting, defaults to 'record', trumped by {node}{shape}
  $args->{node}{shape} ||= ($args->{node_shape} || 'record');

  # maintain defaults
  $args->{layout}          ||= 'dot';
  $args->{output_type}     ||= 'png';
  $args->{overlap}         ||= 'false';
  $args->{node}{style}     ||= 'filled';
  $args->{node}{fillcolor} ||= 'white';

  $args->{show_fields}      = 1   if not exists $args->{show_fields};
  $args->{show_index_names} = 1   if not exists $args->{show_index_names};
  $args->{width}            = 8.5 if not defined $args->{width};
  $args->{height}           = 11  if not defined $args->{height};
  for ($args->{height}, $args->{width}) {
    $_ = 0 unless $_ =~ /^\d+(?:.\d+)?$/;
    $_ = 0 if $_ < 0;
  }

  # so split won't warn
  $args->{$_} ||= '' for qw/skip_fields skip_tables skip_tables_like cluster/;

  my %skip_fields = map { s/^\s+|\s+$//g; length $_ ? ($_, 1) : () }
      split(/,/, $args->{skip_fields});

  my %skip_tables = map { $_, 1 } (
    ref $args->{skip_tables} eq 'ARRAY'
    ? @{ $args->{skip_tables} }
    : split(/\s*,\s*/, $args->{skip_tables})
  );

  my @skip_tables_like = map {qr/$_/} (
    ref $args->{skip_tables_like} eq 'ARRAY'
    ? @{ $args->{skip_tables_like} }
    : split(/\s*,\s*/, $args->{skip_tables_like})
  );

  # join_pk_only/skip_fields implies natural_join
  $args->{natural_join} = 1
      if ($args->{join_pk_only} or scalar keys %skip_fields);

  # usually we do not want direction when using natural join
  $args->{directed} = ($args->{natural_join} ? 0 : 1)
      if not exists $args->{directed};

  $schema->make_natural_joins(
    join_pk_only => $args->{join_pk_only},
    skip_fields  => $args->{skip_fields},
  ) if $args->{natural_join};

  my %cluster;
  if (defined $args->{'cluster'}) {
    my @clusters;
    if (ref $args->{'cluster'} eq 'ARRAY') {
      @clusters = @{ $args->{'cluster'} };
    } else {
      @clusters = split /\s*;\s*/, $args->{'cluster'};
    }

    for my $c (@clusters) {
      my ($cluster_name, @cluster_tables);
      if (ref $c eq 'HASH') {
        $cluster_name   = $c->{'name'} || $c->{'cluster_name'};
        @cluster_tables = @{ $c->{'tables'} || [] };
      } else {
        my ($name, $tables) = split /\s*=\s*/, $c;
        $cluster_name   = $name;
        @cluster_tables = split /\s*,\s*/, $tables;
      }

      for my $table (@cluster_tables) {
        $cluster{$table} = $cluster_name;
      }
    }
  }

  #
  # Create a blank GraphViz object and see if we can produce the output type.
  #
  my $gv = GraphViz->new(%$args)
      or die sprintf("Can't create GraphViz object: %s\n", $@ || 'reason unknown');

  my $output_method = "as_$args->{output_type}";

  # the generators are AUTOLOADed so can't use ->can ($output_method)
  eval { $gv->$output_method };
  die "Invalid output type: '$args->{output_type}'" if $@;

  #
  # Process tables definitions, create nodes
  #
  my %nj_registry;    # for locations of fields for natural joins
  my @fk_registry;    # for locations of fields for foreign keys

TABLE:
  for my $table ($schema->get_tables) {

    my $table_name = $table->name;
    if (@skip_tables_like or keys %skip_tables) {
      next TABLE if $skip_tables{$table_name};
      for my $regex (@skip_tables_like) {
        next TABLE if $table_name =~ $regex;
      }
    }

    my @fields = $table->get_fields;
    if ($args->{show_fk_only}) {
      @fields = grep { $_->is_foreign_key } @fields;
    }

    my $field_str = '';
    if ($args->{show_fields}) {
      my @fmt_fields;
      for my $field (@fields) {

        my $field_info;
        if ($args->{show_datatypes}) {

          my $field_type = $field->data_type;
          my $size       = $field->size;

          if ( $args->{friendly_ints}
            && $size
            && (lc($field_type) eq 'integer')) {
            # Automatically translate to int2, int4, int8
            # Type (Bits)     Max. Signed/Unsigned  Length
            # tinyint* (8)    128                   3
            #                 255                   3
            # smallint (16)   32767                 5
            #                 65535                 5
            # mediumint* (24) 8388607               7
            #                 16777215              8
            # int (32)        2147483647            10
            #                 4294967295            11
            # bigint (64)     9223372036854775807   19
            #                 18446744073709551615  20
            #
            # * tinyint and mediumint are nonstandard extensions which are
            #   only available under MySQL (to my knowledge)
            if ($size <= 3 and $args->{friendly_ints_extended}) {
              $field_type = 'tinyint';
            } elsif ($size <= 5) {
              $field_type = 'smallint';
            } elsif ($size <= 8 and $args->{friendly_ints_extended}) {
              $field_type = 'mediumint';
            } elsif ($size <= 11) {
              $field_type = 'integer';
            } else {
              $field_type = 'bigint';
            }
          }

          $field_info = $field_type;
          if ( $args->{show_sizes}
            && $size
            && ($field_type =~ /^ (?: NUMERIC | DECIMAL | (VAR)?CHAR2? ) $/ix)) {
            $field_info .= '(' . $size . ')';
          }
        }

        my $constraints;
        if ($args->{show_constraints}) {
          my @constraints;
          push(@constraints, $field->is_auto_increment ? 'PA' : 'PK')
              if $field->is_primary_key;
          push(@constraints, 'FK') if $field->is_foreign_key;
          push(@constraints, 'U')  if $field->is_unique;
          push(@constraints, 'N')  if $field->is_nullable;

          $constraints = join(',', @constraints);
        }

        # construct the field line from all info gathered so far
        push @fmt_fields, join(' ', '-', $field->name, $field_info || (), $constraints ? "[$constraints]" : (),);
      }

      # join field lines with graphviz formatting
      $field_str = join('\l', @fmt_fields) . '\l';

    }

    my $index_str = '';
    if ($args->{show_indexes}) {

      my @fmt_indexes;
      for my $index ($table->get_indices) {
        next unless $index->is_valid;

        push @fmt_indexes,
            join(' ',
              '*',
              $args->{show_index_names}
              ? $index->name . ':'
              : (),
              join(', ', $index->fields),
              ($index->type eq 'UNIQUE') ? '[U]' : (),
            );
      }

      # join index lines with graphviz formatting (if any indexes at all)
      $index_str = join('\l', @fmt_indexes) . '\l' if @fmt_indexes;
    }

    my $name_str = $table_name . '\n';

    # escape spaces
    for ($name_str, $field_str, $index_str) {
      $_ =~ s/ /\\ /g;
    }

    my $node_args;

    # only the 'record' type supports nice formatting
    if ($args->{node}{shape} eq 'record') {

      # the necessity to supply shape => 'record' is a graphviz bug
      $node_args = {
        shape => 'record',
        label => sprintf('{%s}', join('|', $name_str, $field_str || (), $index_str || (),),),
      };
    } else {
      my $sep = sprintf('%s\n', '-' x ((length $table_name) + 2));

      $node_args = { label => join($sep, $name_str, $field_str || (), $index_str || (),), };
    }

    if (my $cluster_name = $cluster{$table_name}) {
      $node_args->{cluster} = $cluster_name;
    }

    $gv->add_node(qq["$table_name"], %$node_args);

    debug("Processing table '$table_name'");

    debug("Fields = ", join(', ', map { $_->name } @fields)) if $DEBUG;

    for my $f (@fields) {
      my $name      = $f->name or next;
      my $is_pk     = $f->is_primary_key;
      my $is_unique = $f->is_unique;

      #
      # Decide if we should skip this field.
      #
      if ($args->{natural_join}) {
        next unless $is_pk || $f->is_foreign_key;
      }

      my $constraints = $f->{'constraints'};

      if ($args->{natural_join} && !$skip_fields{$name}) {
        push @{ $nj_registry{$name} }, $table_name;
      }
    }

    unless ($args->{natural_join}) {
      for my $c ($table->get_constraints) {
        next unless $c->type eq FOREIGN_KEY;
        my $fk_table = $c->reference_table or next;

        for my $field_name ($c->fields) {
          for my $fk_field ($c->reference_fields) {
            next unless defined $schema->get_table($fk_table);

            # a condition is optional if at least one fk is nullable
            push @fk_registry, [ $table_name, $fk_table, scalar(grep { $_->is_nullable } ($c->fields)) ];
          }
        }
      }
    }
  }

  #
  # Process relationships, create edges
  #
  my (@table_bunches, %optional_constraints);
  if ($args->{natural_join}) {
    for my $field_name (keys %nj_registry) {
      my @table_names = @{ $nj_registry{$field_name} || [] } or next;
      next if scalar @table_names == 1;
      push @table_bunches, [@table_names];
    }
  } else {
    for my $i (0 .. $#fk_registry) {
      my $fk = $fk_registry[$i];
      push @table_bunches, [ $fk->[0], $fk->[1] ];
      $optional_constraints{$i} = $fk->[2];
    }
  }

  my %done;
  for my $bi (0 .. $#table_bunches) {
    my @tables = @{ $table_bunches[$bi] };

    for my $i (0 .. $#tables) {
      my $table1 = $tables[$i];
      for my $j (1 .. $#tables) {
        next if $i == $j;
        my $table2 = $tables[$j];
        next if $done{$table1}{$table2};
        debug("Adding edge '$table2' -> '$table1'");
        $gv->add_edge(
            qq["$table2"], qq["$table1"], arrowhead => $optional_constraints{$bi}
          ? 'empty'
          : 'normal',
        );
        $done{$table1}{$table2} = 1;
      }
    }
  }

  #
  # Print the image
  #
  if (my $out = $args->{out_file}) {
    if (openhandle($out)) {
      print $out $gv->$output_method;
    } else {
      open my $fh, '>', $out or die "Can't write '$out': $!\n";
      binmode $fh;
      print $fh $gv->$output_method;
      close $fh;
    }
  } else {
    return $gv->$output_method;
  }
}

1;

=pod

=head1 AUTHOR

Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>

Jonathan Yu E<lt>frequency@cpan.orgE<gt>

=head1 SEE ALSO

SQL::Translator, GraphViz

=cut