=head1 NAME

UML::Sequence - This package makes UML sequence diagrams, often by running the code.

=head1 SYNOPSIS

  use UML::Sequence;

  my $tree = UML::Sequence->new(\@methods, \@outline, \&parse_method);
  print $tree->build_xml_sequence('Title');

=head1 DESCRIPTION

To use this package, or see how to use it, see L<genericseq.pl> and
L<seq2svg.pl>.

This class helps produce UML sequence diagrams.  build_xml_sequence
returns a string (suitable for printing to a file) which the seq2svg.pl
script converts into svg.

To control the appearance of the sequence diagram, pass to the constructor:

1 a reference to an array containing the signatures you want to hear about
  or a reference to a hash whose keys are the signatures you want
2 a reference to an array containing the lines in the outline of calls
3 a reference to a sub which takes signatures and returns class and method names

To build the array references and supply the code reference consult
UML::Sequence::SimpleSeq, UML::Sequence::JavaSeq, or UML::Sequence::PerlSeq.
To see one way to call these look in the supplied genericseq script.

=head2 EXPORT

None, this module is object oriented.

=cut

package UML::Sequence;

require 5.005_62;
use strict;
use warnings;

our $VERSION = '0.03';

use UML::Sequence::Activation;

sub new {
    my $class              = shift; # standard
    my $methods_to_include = shift; # array or hash of methods you want to see
    my $input              = shift; # the outline of calls
    my $parse_signature    = shift; # code ref which returns class and method

    my $methods_hash;
    if (ref($methods_to_include) =~ /ARRAY/) {
        $methods_hash = _build_methods_hash($methods_to_include);
    }
    else {
        $methods_hash = $methods_to_include;
    }

    my $stack = [];
    my $root = {
        LEVEL   => -1,
        DATA    => [],
        NAME    => scalar &$parse_signature(shift @$input),
        DISCARD => 0,
    };

    my $self = {};
    $self->{TREE}     = $root;
    $self->{STACK}    = $stack;
    $self->{INCLUDE}  = $methods_hash;
    $self->{SIGPARSE} = $parse_signature;
    bless $self, $class;

    push @$stack, $root;

# 2.
    foreach (@$input) {
        my $input_line = $_;
        my $depth;

        if ($input_line =~ s/^(\s+)//) { $depth = length $1; }
        else                           { $depth = 0;         }

        $self->_update_stack($input_line, $depth);
    }
    return $self;
}

sub _grab_outline_text {
# 1a.
    _run_dprof(@_);

# 1b.
    my $input = _read_dprofpp();
# The next line uses the sample data in __DATA__ see the comment there
#    my $input = _read_sample();
    return $input;
}

sub _build_methods_hash {
    my $methods_list = shift;
    my %methods_hash;

    foreach my $method (@$methods_list) {
        $methods_hash{$method}++;
    }
    return \%methods_hash;
}

#sub _read_sample {
#    my @retval = map { chomp $_; $_; } <DATA>;
#    return \@retval;
#}

sub _update_stack {
    my $self     = shift;
    my $method   = shift;
    my $level    = shift;
    my $new_node = {
         LEVEL   => $level,
         DATA    => [],
         NAME    => $method,
#        DISCARD => 0,
    };

    while ($level <= $self->{STACK}[-1]{LEVEL}) {
        pop @{$self->{STACK}};
    }

    $new_node->{DISCARD} = $self->{STACK}[-1]{DISCARD};
    unless (defined $self->{INCLUDE}{$method}) {
        $new_node->{DISCARD} = 1;
    }

    push @{$self->{STACK}[-1]{DATA}}, $new_node;
    push @{$self->{STACK}}, $new_node;
}

sub print_tree {
    my $self   = shift;

    return _print_tree($self->{TREE}, "");
}

sub _print_tree {
    my $root   = shift;
    my $indent = shift;
    my $retval;

    return unless defined $root;  # recursion base
    return if ($root->{DISCARD});

    $retval = "$indent$root->{NAME}\n";

    foreach my $child (@{$root->{DATA}}) {
        my $child_output = _print_tree($child, "$indent  ");
        $retval         .= $child_output if $child_output;
    }
    return $retval;
}

sub build_xml_sequence {
    my $self  = shift;
    my $title = shift;

    $self->{ARROW_NUM}  = 0;
    $self->{ARROW_LIST} = "<arrow_list>\n";
    $self->_build_xml_sequence($self->{TREE});
    $self->{ARROW_LIST} .= "</arrow_list>\n";

    $self->_build_class_list();
    if ($title) {
        return "<?xml version='1.0' ?>\n<sequence title='$title'>\n"
             . "$self->{CLASS_LIST}\n"
             . "$self->{ARROW_LIST}</sequence>\n";
    }
    else {
        return "<?xml version='1.0' ?>\n<sequence>\n$self->{CLASS_LIST}\n"
             . "$self->{ARROW_LIST}</sequence>\n";
    }
}

sub _build_xml_sequence {
    my $self = shift;
    my $root = shift;  # you must pass this in, $self->{TREE} never changes

    # recursion bases
    return unless defined $root;
    return if $root->{DISCARD};
    my $root_call = $root->{NAME};
    return unless defined $root_call;

    my $class = $self->{SIGPARSE}($root_call);

    # put into to class list, if it isn't already there
    if (not defined $self->{ACTIVATIONS}{$class}) {
        push @{$self->{CLASSES}}, $class;
    }

    # create activation and add it to the list for this class
    my $activation = UML::Sequence::Activation->new();
    $activation->starts($self->{ARROW_NUM});
    my $offset = UML::Sequence::Activation
        ->find_offset($self->{ACTIVATIONS}{$class});
    $activation->offset($offset);

    push @{$self->{ACTIVATIONS}{$class}}, $activation;

    # visit children
    foreach my $child (@{$root->{DATA}}) {
        next if $child->{DISCARD};

        my ($child_class, $method) = $self->{SIGPARSE}($child->{NAME});
        my $child_offset =
            UML::Sequence::Activation
                ->find_offset($self->{ACTIVATIONS}{$child_class});

        $self->{ARROW_NUM}++;
        $self->{ARROW_LIST} .=
          "  <arrow from='$class' to='$child_class' type='call' " .
          "label='$method'\n"                                     .
          "         from-offset='$offset' to-offset='$child_offset' />\n";
        $self->_build_xml_sequence($child);
    }

    $activation->ends($self->{ARROW_NUM});
}

sub _build_class_list {
    my $self = shift;
    $self->{CLASS_LIST} = "<class_list>\n";

    foreach my $class (@{$self->{CLASSES}}) {
        my ($starts, $ends) =
            UML::Sequence::Activation
                ->find_bounds($self->{ACTIVATIONS}{$class});
        $self->{CLASS_LIST} .=
            "  <class name='$class' born='$starts' extends-to='$ends'>\n" .
            "    <activation_list>\n";

        foreach my $activation (@{$self->{ACTIVATIONS}{$class}}) {
            my $act_start = $activation->starts();
            my $act_end    = $activation->ends();
            my $act_offset = $activation->offset();
            $self->{CLASS_LIST} .=
                "      <activation born='$act_start' extends-to='$act_end' " .
                "offset='$act_offset' />\n";
        }
        $self->{CLASS_LIST} .= "    </activation_list>\n  </class>\n";
    }
    $self->{CLASS_LIST} .= "</class_list>\n";
}

1;
=head1 EDIT HISTORY

  0.01 Jan 2003  Initial release.
  0.02 Feb 2003  Corrected diagrams so separate instances have their own life
                 lines.
                 Included samples directory with instructions for producing
                 the samples (see samples/README in the distribution).
  0.03 Mar 2003  See Changes file (this release didn't affect this file)

=head1 AUTHOR
 
Phil Crow, <philcrow2000@yahoo.com>
  
=head1 SEE ALSO

L<genericseq.pl>
L<seq2svg.pl>

=head1 COPYRIGHT
   
Copyright 2003, Philip Crow, all rights reserved.  You may modify and/or
redistribute this code in the same manner as Perl itself.

=cut

# This data is a small subset of a typical dprofpp -T output.
# It's used by _read_sample so you can debug with a small input set.
# Use _read_sample in place of _read_dprofpp to switch to this set.
__DATA__
DiePair::new
   Die::new
   Die::new
DiePair::roll
   Die::roll
   Die::roll
DiePair::total
DiePair::doubles
DiePair::to_string

