#!/usr/bin/perl -w
=head1 NAME
 
vdbe_graph.pl - graph the flow control of vdbe explain output

=head1 SYNOPSIS

  $ vdbe_graph.pl -h
  $ sqlite3 db 'create table exampl (one, two)';
  $ sqlite3 -separator $'\t' db 'explain select one from exampl' \
     | tee ops |head -n 3
  0       Goto    0       10      
  1       Integer 0       0      
  2       OpenRead        0       2  
  
  $ vdbe_graph.pl ops 
  +------------------------+
  | 0 Goto (0, 10)         |
  | 10 Transaction (0, 0)  |
  | 11 VerifyCookie (0, 1) |
  | 12 Goto (0, 1)         |
  | 1 Integer (0, 0)       |
  | 2 OpenRead (0, 2)      |
  | 3 SetNumColumns (0, 1) |
  +------------------------+
    |
    |
    v
  +-----------------------------+
  | 4 Rewind (0, 8)             |
  +-----------------------------+
    |
    |                         +----+
    v                         v    |
  +-----------------------------+  |
  | 5 Column (0, 0)             |  |
  | 6 Callback (1, 0)           |  |
  +-----------------------------+  |
    |                              |
    |                              |
    v                              |
  +-----------------------------+  |
  | 7 Next (0, 5)               |  |
  +-----------------------------+  |
    |                         |    |
    |                         +----+
    v
  +-----------------------------+
  | 8 Close (0, 0)              |
  | 9 Halt (0, 0)               |
  +-----------------------------+

=head1 DESCRIPTION

vdbe_graph.pl reads a tsv formatted SQLite3 "explain" listing and 
prints a flow graph of the opcodes.  The output can be ascii, unicode,
graphviz or png (with "dot" installed).  This tool is intended to make
explain's output slightly more intelligible.

=head1 SEE ALSO

L<Graph::Easy>, L<http://bloodgate.com/perl/graph/>, 
L<http://www.graphviz.org/>

=head1 AUTHOR

Brad Bowman <vdbe@bereft.net>

=cut

use strict;
use YAML;
use Graph::Easy;
use Getopt::Std;
binmode STDOUT, ':utf8';
our $VERSION = '1.01';
$Getopt::Std::STANDARD_HELP_VERSION = 1;

my %ext_formats = (
    asc => 'ascii',
    html=> 'html',
    yml => 'yaml',
    txt => 'txt',
    box => 'boxart',
    viz => 'graphviz',
    png => 'graphviz',
);

my %opt;
getopts('ho:f:', \%opt);

if ($opt{h}) {
    HELP_MESSAGE();
    exit(0);
}

my $ext = ($opt{o} && $opt{o} =~ /\.(...)$/) ? $1 : '';
my $format = $ext_formats{ $opt{f} || ''} 
            || $opt{f} || $ext_formats{$ext} || 'ascii';


my $g = Graph::Easy->new();
$g->set_attribute('flow', 'south');

my $prev;
my @ops;
while (<>) {
    chomp;
    my @fields = split /\t/, $_;
    next unless $fields[0] =~ /^\d+$/;

    my %curr;
    @curr{qw(n op p1 p2 p3)}  = @fields;
    my $params = join(", ", @fields[2..$#fields]);

    my $n = $g->add_node($curr{n});
    # "to insert a line break include a literal '\n' \l = left align
    $n->set_attribute(label => "$curr{n} $curr{op} ($params)\\l");
    $n->set_attribute(align => 'left'); # first line

    if ($prev) {
        my $e = $g->add_edge($prev->{n} => $curr{n});
    }
    $prev = \%curr;
    push @ops, \%curr;
}

my %jumps = map { $_ => 1 } qw(
    Next Prev Gosub ForceInt MustBeInt Eq Ne Lt Le Gt Ge 
    If IfNot IsNull NotNull Distinct Found NotFound IsUnique NotExists
    IdxGT IdxGE IdxLT FifoRead IfMemPos IfMemNeg IfMemZero VFilter VNext);

for my $n (grep { exists $jumps{$_->{op}} } @ops) {
    $g->add_edge($n->{n} => $n->{p2});
}

#  If P2 is not zero and one or more of the entries are NULL, 
#  then jump to the address given by P2
my %maybe_jumps = map { $_ => 1 } qw(
    Last MakeRecord MoveGe MoveGt MoveLt MoveLe Rewind 
    );

for my $n (grep { exists $maybe_jumps{$_->{op}} && $_->{p2} ne '0' } @ops) {
    $g->add_edge($n->{n} => $n->{p2});
}

for my $n (grep { $_->{op} eq 'Goto' } @ops) {
    $g->del_edge($g->edge($n->{n} => $n->{n}+1));
    $g->add_edge($n->{n} => $n->{p2});
}

for my $n (grep { $_->{op} eq 'Halt' } @ops) {
    next unless $g->node($n->{n}+1);
    $g->del_edge($g->edge($n->{n} => $n->{n}+1));
}

# merge adjacent nodes in a block
#   nodes must be connected by 1 edge and
#   nodes can't have other links (except TO first)
my %seen;
my @todo;

sub add_todo {
    for (@_) {
        unshift @todo, $_ if !$seen{$_};
        $seen{$_}++;
    }
}
add_todo($g->node(0)); # initialize

sub show {
    return; 
    my $pfx = shift;
    warn "$pfx: ", join(", ", map { $_->label } @_), "\n";
}

my $this_node; # outer scope for "redo"
while ($this_node = shift @todo) {
    show "\nthis" => $this_node;
    show have => @todo;
    my @next_nodes = $this_node->successors();
    show next => @next_nodes;
    if (@next_nodes == 1) {
        my $next_node = $next_nodes[0];
        my @next_successors = $next_node->successors;

        show next_next => @next_successors;
        # we can only merge this and next 
        # if next has 0|1 successors and exactly 1 predcessor (this)
        if (@next_successors <= 1 && $next_node->predecessors == 1) {
            show merge => ($this_node, $next_node);

            $this_node->set_attribute(label => 
                            $this_node->label . $next_node->label);
    
            # one link $this->$next and $next has <= 1 successor so merge
            $g->merge_nodes($this_node, $next_node);
            # merge_nodes deletes the second node from the graph

            # may also want to merge the next one
            redo;
        } else {
            # can't merge this or next so push the grand-kids
            add_todo(@next_successors);
        }
    } elsif (@next_nodes > 1) {
        # can't merge, add successor nodes to @todo
        add_todo(@next_nodes);
    } else {
        # no successors, go to next on @todo
    }
}

# flow out from the bottom & into the top of blocks
for my $e ($g->edges) {
    $e->set_attribute(start => 'south');
    $e->set_attribute(end   => 'north');
}


# Where does the output go
if (defined $opt{o}) {
    if ($ext eq 'png') {
        open OUT, "| dot -Tpng -o $opt{o}"; # sec
    } else {
        open OUT, ">", $opt{o};
    }
    binmode OUT, ':utf8';
    select OUT;
}

if ($g->can("as_$format")) {
    my $meth = "as_$format";
    print $g->$meth;
} elsif ($format eq 'yaml') {
    print YAML::Dump $g;
} else {
    die "Unknown format '$format'";
}

sub HELP_MESSAGE {
    my $formats = join "\n",
                  map { "  $_ => $ext_formats{$_}" } sort keys %ext_formats;
    print <<"USAGE";
Usage:
  $0 [-o <outputfile.ext>] [-f format] explain_trace.tsv
Formats:
$formats   
To generate an explain trace use: 
        sqlite3 -separator \$'\\t' db 'explain select * from exampl'
USAGE
}