1package Bigtop::Backend::Diagram::GraphvizSql;
2use strict; use warnings;
3
4use Inline;
5
6BEGIN {
7    Bigtop::Parser->add_valid_keywords (
8        Bigtop::Keywords->get_docs_for(
9            'app', 'label'
10        )
11    );
12    Bigtop::Parser->add_valid_keywords (
13        Bigtop::Keywords->get_docs_for(
14            'table', 'label'
15        )
16    );
17    Bigtop::Parser->add_valid_keywords (
18        Bigtop::Keywords->get_docs_for(
19            'field', 'quasi_refers_to'
20        )
21    );
22}
23
24sub what_do_you_make {
25    return [
26        [ 'docs/schema.diagram' => 'Graphviz dot file for SQL data model' ],
27    ];
28}
29
30sub backend_block_keywords {
31    return [
32        { keyword => 'no_gen',
33            label   => 'No Gen',
34            descr   => 'Skip everything for this backend',
35            type    => 'boolean' },
36
37        { keyword => 'template',
38            label   => 'Alternate Template',
39            descr   => 'A custom TT template.',
40            type    => 'text' },
41
42        { keyword => 'skip_layout',
43            label   => 'Skip Layout',
44            descr   => 'Do NOT run a Graphviz layout program like dot.',
45            type    => 'boolean' },
46
47        { keyword => 'layout_program',
48            label   => 'Layout Program',
49            descr   => 'Some Graphviz layout program like neato. '
50                        .   '[Default is dot]',
51            type    => 'text' },
52
53        { keyword => 'layout_flags',
54            label   => 'Layout Flags',
55            descr   => 'Command line flags for Graphviz layout program. '
56                        .   '[Default is -Tpdf]',
57            type    => 'text' },
58    ];
59}
60
61sub gen_Diagram {
62    shift;
63    my $base_dir = shift;
64    my $tree     = shift;
65
66    my $diagram_lines = $tree->walk_postorder(
67        'output_diagram_gvsql', $tree->{application}{lookup} );
68    my $diagram       = join '', @{ $diagram_lines };
69
70    my $docs_dir      = File::Spec->catdir( $base_dir, 'docs' );
71    my $out_file      = File::Spec->catfile( $docs_dir, 'schema.graphviz' );
72
73    open my $OUT, '>', $out_file or die "Couldn't write $out_file: $!\n";
74
75    print $OUT $diagram;
76
77    close $OUT;
78
79    # Decide whether and how to run a graphviz tool.
80    my $config_block = $tree->get_config()->{ Diagram };
81    $config_block = {} unless $config_block->{__NAME__} eq 'GraphvizSql';
82
83    return if defined $config_block->{ skip_layout }
84                  and $config_block->{ skip_layout };
85
86    my $prog      =  $config_block->{ layout_program } || 'dot';
87    my $flags     =  $config_block->{ layout_flags   } || '-Tpdf';
88    $flags        =~ /-T(\S+)/;
89    my $extension =  $1;
90    if ( not defined $extension ) {
91        $flags    .= ' -Tpdf';
92        $extension = 'pdf';
93    }
94
95    my $image_file = File::Spec->catfile( $docs_dir, "schema.$extension" );
96
97    `$prog $flags $out_file > $image_file`;
98}
99
100our $template_is_setup = 0;
101our $default_template_text = <<'EO_TT_blocks';
102[% BLOCK dot_file %]
103digraph g {
104    graph [
105        fontsize=30
106        labelloc="t"
107        label="[% label %]"
108        splines=true
109        overlap=false
110        rankdir = "LR"
111    ];
112    node [shape=plaintext]
113    ratio = auto;
114[% FOREACH table IN tables %]
115[% table %]
116[% END %]
117    date_box [
118      label = "Generated [% date_stamp %]"
119    ];
120[% FOREACH edge IN edges %]
121[% edge %]
122[% END %]
123}
124[% END %][%# dot_file %]
125
126[% BLOCK table %]
127    [% name %] [
128      label = <
129        <table border="1" cellborder="0">
130          <tr> <td><font point-size="12">[% label %]</font></td> </tr>
131[% FOREACH col IN columns %]
132          [% col %]
133[% END %]
134        </table>
135      >
136    ];
137[% END %][%# table %]
138
139[% BLOCK column %]
140<tr> <td align="left" PORT="[% port %]">[% label %]</td> </tr>
141[% END %][%# column %]
142EO_TT_blocks
143
144sub setup_template {
145    my $class         = shift;
146    my $template_text = shift || $default_template_text;
147
148    return if ( $template_is_setup );
149
150    Inline->bind(
151        TT                  => $template_text,
152        POST_CHOMP          => 1,
153        TRIM_LEADING_SPACE  => 0,
154        TRIM_TRAILING_SPACE => 0,
155    );
156
157    $template_is_setup = 1;
158}
159
160package # application
161    application;
162use strict; use warnings;
163
164sub output_diagram_gvsql {
165    my $self         = shift;
166    my $child_output = shift;
167    my $tables       = shift;
168
169    my $outputs = {
170        tables => [],
171        edges  => [],
172    };
173    foreach my $child_item ( @{ $child_output } ) {
174        my ( $type, $output ) = %{ $child_item };
175        push @{ $outputs->{ $type } }, $output;
176    }
177
178    my $label_statement = $self->get_app_statement( 'label' );
179    my $label = $label_statement->[0] || $self->get_name();
180
181    my $output = Bigtop::Backend::Diagram::GraphvizSql::dot_file(
182        {
183            label      => $label,
184            tables     => $outputs->{ tables },
185            edges      => $outputs->{ edges  },
186            date_stamp => scalar localtime,
187        }
188    );
189
190    return [ $output ];
191}
192
193package # table_block
194    table_block;
195use strict; use warnings;
196
197sub output_diagram_gvsql {
198    my $self         = shift;
199    my $child_output = shift;
200    my $tables       = shift;
201
202    my $skip_this = $self->walk_postorder( 'skip_this_table' );
203    return if defined $skip_this and $skip_this->[0];
204
205    # who am I
206    my $name = $self->get_name();
207    $name =~ s/.*\.//; # remove schema name
208
209    #my $DEBUG = ( $name eq 'session' );
210    #warn "table: $name\n" if $DEBUG;
211
212    # deal with child output, including foreign key columns
213    #use Data::Dumper; warn Dumper( $child_output ) if $DEBUG;
214    #return [];
215    my @edges;
216    my @columns;
217    my $indent = ' ' x 4;
218    foreach my $col ( @{ $child_output } ) {
219        my $col_output = Bigtop::Backend::Diagram::GraphvizSql::column(
220            {
221                port  => $col->{ local_col },
222                label => $col->{ label } || $col->{ local_col },
223            }
224        );
225        push @columns, $col_output;
226
227        if ( defined $col->{ foreign_col } ) {
228            my $port = $col->{ local_col };
229            $col->{ local_col } = "$name:$port";
230
231            my $edge = $indent
232                        . $col->{ local_col   } . ' -> '
233                        . $col->{ foreign_col };
234            if ( $col->{ foreign_type } eq 'quasi_refers_to' ) {
235                $edge .= ' [style="dotted"]';
236            }
237
238            push @edges, $edge;
239        }
240    }
241
242    # now make the table node, starting with a label statement if present
243    my $label;
244    CANDIDATE:
245    foreach my $block ( @{ $self->{__BODY__} } ) {
246        next CANDIDATE unless $block->{__TYPE__} eq 'label';
247
248        $label = ($block->{__ARGS__}->get_unquoted_args)->[0];
249        last CANDIDATE;
250    }
251    $label = join ' ', map { ucfirst $_ } split /_/, $name unless $label;
252
253    my $output = Bigtop::Backend::Diagram::GraphvizSql::table(
254        {
255            name    => $name,
256            label   => $label,
257            columns => \@columns,
258        }
259    );
260
261    if ( @edges ) {
262        return [
263            { tables => $output },
264            { edges  => join( "\n", @edges ) . "\n" }
265        ];
266    }
267    else {
268        return [ { tables => $output } ];
269    }
270}
271
272package # table_element_block
273    table_element_block;
274use strict; use warnings;
275
276sub output_diagram_gvsql {
277    my $self         = shift;
278    my $child_output = shift;
279
280    my $name = $self->get_name();
281
282    return unless defined $name;
283
284    my $skip_this = $self->walk_postorder( 'skip_this_field' );
285    return if defined $skip_this;
286
287    my $retval = {};
288    foreach my $el ( @{ $child_output } ) {
289        my ( $key, $val ) = %{ $el };
290        $retval->{ $key } = $val;
291    }
292    $retval->{ local_col } = $name;
293
294    return [ $retval ];
295}
296
297sub skip_this_table {
298    my $self         = shift;
299
300    if ( $self->{__TYPE__} eq 'not_for' ) {
301        my $skipped_backends = $self->{__ARGS__};
302        foreach my $spurned ( @{ $skipped_backends } ) {
303            return [ 1 ] if $spurned eq 'Diagram';
304        }
305    }
306    return;
307}
308
309package # field_statement
310    field_statement;
311use strict; use warnings;
312
313sub output_diagram_gvsql {
314    my $self         = shift;
315
316    my $keyword = $self->get_name();
317
318    if ( $keyword eq 'is' ) {
319        # place holder in case we care about special types
320        return;
321    }
322    elsif ( $keyword eq 'refers_to' or $keyword eq 'quasi_refers_to' ) {
323        my $foreign_info = $self->{__DEF__}{__ARGS__}[0];
324
325        return unless ( ref( $foreign_info ) eq 'HASH' );
326
327        my ( $table, $col ) = %{ $foreign_info };
328
329        $table =~ s/.*\.//;
330
331        return [
332            { foreign_col  => "$table:$col" },
333            { foreign_type => $keyword      },
334        ];
335    }
336    elsif ( $keyword eq 'label' ) {
337        return [
338            { label => $self->{__DEF__}{__ARGS__}[0] }
339        ];
340    }
341}
342
343sub skip_this_field {
344    my $self         = shift;
345
346    if ( $self->get_name() eq 'not_for' ) {
347        my $skipped_backends = $self->{__DEF__}{__ARGS__};
348        foreach my $spurned ( @{ $skipped_backends } ) {
349            return [ 1 ] if $spurned eq 'Diagram';
350        }
351    }
352    return;
353}
354
355package # join_table
356    join_table;
357use strict; use warnings;
358
359sub output_diagram_gvsql {
360    my $self         = shift;
361    my $child_output = shift;
362
363    # who am I
364    my $name = $self->{__NAME__};
365    $name =~ s/.*\.//;
366    # schema might still be there for old versions
367
368    # deal with child output
369    my @edges;
370    my @columns;
371    my $indent = ' ' x 4;
372    my $schema = '';
373    foreach my $col ( @{ $child_output } ) {
374        my $col_output = Bigtop::Backend::Diagram::GraphvizSql::column(
375            {
376                port  => $col->{ local_col },
377                label => $col->{ label } || $col->{ local_col },
378            }
379        );
380        push @columns, $col_output;
381
382        if ( $schema eq '' ) {
383            ( $schema, undef ) = split /\./, $col->{ full_name };
384            $name =~ s/^$schema//;
385        }
386
387        if ( defined $col->{ foreign_col } ) {
388            my $port = $col->{ local_col };
389            $col->{ local_col } = "$name:$port";
390
391            push @edges, $indent
392                        . $col->{ local_col   } . ' -> '
393                        . $col->{ foreign_col }
394        }
395    }
396
397    # now make the table node
398    my $label = join ' ', map { ucfirst $_ } split /_/, $name;
399
400    my $output = Bigtop::Backend::Diagram::GraphvizSql::table(
401        {
402            name    => $name,
403            label   => $label,
404            columns => \@columns,
405        }
406    );
407
408    if ( @edges ) {
409        return [
410            { tables => $output },
411            { edges  => join( "\n", @edges ) . "\n" }
412        ];
413    }
414    else {
415        return [ { tables => $output } ];
416    }
417}
418
419package # join_table_statement
420    join_table_statement;
421use strict; use warnings;
422
423sub output_diagram_gvsql {
424    my $self         = shift;
425    my $child_output = shift;
426
427    return unless $self->{__KEYWORD__} eq 'joins';
428    my @tables = %{ $self->{__DEF__}->get_first_arg() };
429
430    my @retvals;
431    foreach my $full_name ( @tables ) {
432        my $table     = $full_name;
433        $table        =~ s/.*\.//;
434        my $col_label = join ' ', map { ucfirst $_ } split /_/, $table;
435
436        push @retvals, {
437            foreign_col => "$table:id",
438            label       => $col_label,
439            local_col   => $table,
440            full_name   => $full_name,
441        };
442    }
443
444    return \@retvals;
445}
446
4471;
448
449__END__
450
451=head1 NAME
452
453Bigtop::Backend::Diagram::GraphvizSql - generates dot language file for data model
454
455=head1 SYNOPSIS
456
457If your bigtop file looks like this:
458
459    config {
460        SQL      ...      {}
461        Diagram  Graphviz {}
462    }
463    app App::Name {
464    }
465
466and there are table blocks in the app block, this module will make
467docs/schema.graphviz (relative to the build_dir) when you type:
468
469    bigtop app.bigtop Diagram
470
471or
472
473    bigtop app.bigtop all
474
475This generates C<docs/schema.graphviz>.
476By default this backend also runs the following command:
477
478    dot -Tpdf docs/schema.graphviz > docs/schema.pdf
479
480Use backend_block_keywords described below to control the behavior.
481
482=head1 DESCRIPTION
483
484This is a Bigtop backend which generates a file in the dot language
485understood by all the Graphviz tools.  For information about Graphviz,
486please visit L<http://www.graphviz.org>.  To summarize, the files
487generated by this module can be fed through dot or neato to produce
488a .png file (many other formats are available) showing the data
489model for your project.
490
491=head1 KEYWORDS
492
493This module assumes you are using one of the SQL backends which will
494define appropriate keywords for table and field definitions.  But, it
495defines three words of its own:
496
497=over 4
498
499=item label
500
501This is valid keyword for both the app and table levels.  The app label
502becomes the label for the whole picture.  The table label becomes the
503label for the record box of the table.  If these label keywords are
504not used the app name and table name are used instead, but split on
505underscores and ucfirst applied to all the words which are rejoined with
506a single space.
507
508=item quasi_refers_to
509
510This is valid at the field level and indicates that the field's value
511refers to a field in another table whenever the value is not null.  In the
512picture these links are drawn with dotted lines.
513
514=back
515
516=head1 METHODS
517
518To keep podcoverage tests happy.
519
520=over 4
521
522=item backend_block_keywords
523
524Tells tentmaker that I understand these config section backend block keywords:
525
526    no_gen
527    template
528    skip_layout
529    layout_program
530    layout_flags
531
532As mentioned in the L<SYNOPSIS> above, by default this backend runs
533the following command:
534
535    dot -Tpdf docs/schema.graphviz > docs/schema.pdf
536
537If skip_layout is present and true, no such command is run.  All you
538get is docs/schema.graphviz.  This flag supercedes the other keywords.
539
540layout_program defaults to C<dot>, but this keyword lets you change to
541any other interpretter of the dot language.  One of these is neato.  There
542are others.  In my humble opinion, only dot looks good for this type of
543diagram, so I stick with it.
544
545layout_flags lets you pass things to your layout program.  Feel free to
546pass anything.  If you use -T, the generated file will have the -T value
547as its file extension.  So this:
548
549    layout_flags `-Tpng`
550
551will actually execute this:
552
553    dot -Tpng docs/schema.graphviz > docs/schema.png
554
555If you omit -T a -Tpdf will be added for you.
556No other flags are parsed.
557
558=item what_do_you_make
559
560Tells tentmaker what this module makes.  Summary: docs/schema.graphviz.
561
562=item gen_Diagram
563
564Called by Bigtop::Parser to get me to do my thing.
565
566=item setup_template
567
568Called by Bigtop::Parser so the user can substitute an alternate template
569for the hard coded one here.
570
571=back
572
573
574=head1 AUTHOR
575
576Phil Crow <crow.phil@gmail.com>
577
578=head1 COPYRIGHT and LICENSE
579
580Copyright (C) 2010 by Phil Crow
581
582This library is free software; you can redistribute it and/or modify
583it under the same terms as Perl itself, either Perl version 5.10.0 or,
584at your option, any later version of Perl 5 you may have available.
585
586=cut
587