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