#2345678901234567890123456789012345678901234567890123456789012345678901234567890
=head1 NAME

UML::Sequence::Raster - converts xml sequence files to a raster image

=head1 SYNOPSIS

    use UML::Sequence::Raster;

    seq2raster @ARGV;

=head1 DESCRIPTION

This module supports the seq2rast.pl script like Pod::Html supports pod2html.
The array passed to seq2rast.pl should have the following form:

 ([ I<options-pairs>, ] [input_file_name])

where I<options-pairs> are any of

=over 4

=item C<-a color>

specifies a color to be used to fill the activation boxes. Must be a string
of either hexadecimal RGB values, I<e.g.,> B<'#FF00AC0024B1'>, or a name from
the following list of supported colors:

    white     lyellow     lpurple     lbrown
    lgray     yellow      purple      dbrown
    gray      dyellow     dpurple     transparent
    dgray     lgreen      lorange
    black     green       orange
    lblue     dgreen      pink
    blue      lred        dpink
    dblue     red         marine
    gold      dred        cyan

=item C<-c color>

specifies a color to be used to fill the class boxes. See the C<-a>
option for acceptable color specifications.

=item C<-e>

specifies that embedded annotations are to be applied
to the raster image. Only valid when the C<-m> or C<-M>
option is also specified. When an arrow label has associated annotations,
the labels with be suffixed with a superscript number linking to
a text section containing the annotation text.

=item C<-f "font">, C<-F fontfile>

Specifies a font to be used to render text. C<-f> uses a "named"
font, e.g., "Times New Roman", which can be resolved to a TrueType
font file. The special fontname B<gd> may be used to specify the
GD builtin fonts (which are also the default on non-Win32 platforms).
Values other than B<gd> are currently only supported on Win32 platforms
with L<Win32::Font::NameToFile> installed.

C<-F> specifies the actual fontfile name, e.g., 'ARIALBD.TTF'.

Note that, on Win32 platforms with L<Win32::Font::NameToFile> installed,
using a named font will cause this module to attempt to locate
bold (for class name labels) and italic (for event labels) versions
of the font file. The base font will be used if either
is not found.

=item C<-g arrow-gap>

If C<arrow-gap> is an integer value, specifies number of pixels between arrows
(default is 40 pixels).
If C<arrow-gap> is a fractional value, specifies a scaling factor for the
default number of pixels between arrows.

=item C<-j>

specifies that Javascript'ed tooltip annotations are to be applied
to the raster image. Only valid when the C<-m> or C<-M>
option is also specified. When an arrow label has associated annotations,
the hyperlinks in the areamap for the label will include
C<onmouseover()> function calls containing the annotation text for use with the
Javascript tooltip package available at
L<http://www.walterzorn.com/tooltip/tooltip_e.htm>. Note that annotated
labels will be underlined in the image.

=item C<-m areamap-path>, C<-M areamap-path>

specifies the name of a file to receive HTML containing
an image element, areamap, and (optionally)
either an ordered list of annotations (if L<-e> was specified)
or a script tag linking to the
Javascript tooltip script (if L<-j> was specified) to be applied to
the raster image. Only valid when either the L<-p> or L<-P> option is specified.
C<-M> specifies append mode for the output file.

=item C<-o output_file_name>

specifies the output file name. The format of the image is determined
by the file qualifier as follows:

    .png, .PNG => PNG format
    .gif, .GIF => GIF format
    .jpg, .jpeg, .JPG, .JPEG => JPEG format

If not specified, output is sent to STDOUT in PNG format.

=item C<-p classdocs-path>, C<-P classdocs-path>

specifies a base path to classdocs generated by psichedoc.
Adds an areamap to the HTML output file specified by the C<-m> or C<-M>
option with hyperlinks to the documents for individual classes and/or methods,
excluding method labels w/ embedded whitespace. Additionally, the specified
path is used with any generated HTML imagemap. Both C<-p> and C<-P> behave
the same; both are supported for compatibility with L<UML::Sequence::Svg>.

=item C<-s "Signature">

specifies a signature to apply to the lower right corner in small text,
e.g., "Copyright(C) 2006, GOWI Corp.".

=item C<-w box-width>

specifies width of class box in pixels; default is 125. Used to compute
class header boxes and areamap coordinates.

=item C<-x char-width>

specifies width of characters in pixels; default is 6. Used to compute
class header boxes and areamap coordinates.

=item C<-y char-height>

specifies height of characters in pixels; default is 14. Used to compute
class header boxes and areamap coordinates.

=back

By default input is from standard in and output is to standard out.

=cut

package UML::Sequence::Raster;

use Exporter;
@ISA    = qw(Exporter);
@EXPORT = qw(seq2raster);

use XML::DOM;
use Getopt::Std;
use GD;
use GD qw(gdSmallFont gdLargeFont gdMediumBoldFont gdTinyFont gdGiantFont);
use GD::Text::Wrap;

if ($^O eq 'MSWin32') {
    require Win32::Font::NameToFile;
    import Win32::Font::NameToFile qw(get_ttf_abs_path get_ttf_bold  get_ttf_italic);
}

use strict;
use warnings;

our $VERSION = '0.01';

# Constant declarations.
my $CLASS_TEXT_Y      =  40;
my $CLASS_BOX_Y       =  25;
my $CLASS_BOX_HEIGHT  =  20;
my $CLASS_BOX_WIDTH   = 125;
my $CLASS_SPACING     =   3;

my $LEFT_EDGE         =  92;

my $ACTIVATION_WIDTH  =  15;
my $ACTIVATION_OFFSET =  10;

my $FIRST_ARROW       =  55;
my $ARROW_SPACING     =  60;
my $ARROW_DELTA       =  0;

use constant LINE_THICKNESS => 2;

use constant LEFT_ARROW => 0;
use constant RIGHT_ARROW => 1;
use constant HALF_LEFT_ARROW => 2;
use constant HALF_RIGHT_ARROW => 3;
my @arrowpts = (
[0, 0, 12, 6, 0, 14],
[0, 6, 12, 0, 12, 14],
[0, 4, 12, 4, 12, 14],
[0, 14, 12, 4, 0, 4],
);
my @arrows = ();

# Global variable:
my $output_file = "-";
my $classcolor = 'white';
my $actcolor = 'white';
my $docpath;            # path to assoc. classdocs
my $mappath;            # path to write areamap file
my $mapname;            # imagemap name derived from raster output filename
my $classcharwidth = 9; # width of class header characters
my $charwidth = 8;      # width of characters
my $charht = 10;        # height of characters
my $annot;              # annotations behavior:
                        # 'e' : embed in specified file;
                        # 'j' : apply javascript tooltips in specified file
                        # NOTE: specified file may be same as image map file
my $white;
my $black;

my %colors = (
    white    => [255,255,255],
    lgray    => [191,191,191],
    gray    => [127,127,127],
    dgray    => [63,63,63],
    black    => [0,0,0],
    lblue    => [0,0,255],
    blue    => [0,0,191],
    dblue    => [0,0,127],
    gold    => [255,215,0],
    lyellow    => [255,255,125],
    yellow    => [255,255,0],
    dyellow    => [127,127,0],
    lgreen    => [0,255,0],
    green    => [0,191,0],
    dgreen    => [0,127,0],
    lred    => [255,0,0],
    red        => [191,0,0],
    dred    => [127,0,0],
    lpurple    => [255,0,255],
    purple    => [191,0,191],
    dpurple    => [127,0,127],
    lorange    => [255,183,0],
    orange    => [255,127,0],
    pink    => [255,183,193],
    dpink    => [255,105,180],
    marine    => [127,127,255],
    cyan    => [0,255,255],
    lbrown    => [210,180,140],
    dbrown    => [165,42,42],
    transparent => [1,1,1]
);
#
#    font names
#
my $fontfile;
my $fontname;
my $titlefont;
my $classfont;
my $methodfont;
my $eventfont;
my $tinyfont;

my $sig;
#
#    caches of text elements, to optimize
#    rendering
#
my @class_hdrs = ();
my @classtext = ();
my @labeltext = ();
my @italtext = ();
my @supertext = ();

sub seq2raster {
    local (@ARGV) = @_;
    my $opts = parse_command_line();

    $classcolor = $opts->{c} || 'white';
    $actcolor = $opts->{a} || 'white';
    $docpath = $opts->{p} || $opts->{P};
    $mappath = $opts->{m} || $opts->{M};
    $charwidth = $opts->{x} || 6;
    $charht = $opts->{y} || 14;
    $CLASS_BOX_WIDTH = $opts->{w} || 125;
    $annot = $opts->{e} ? 'e' : $opts->{j} ? 'j' : undef;
    $fontfile = $opts->{F};
    $fontname = $opts->{f};
    $sig = $opts->{s};

    die "Annotation requested without output path."
        if ($annot && (! $mappath));

    $ARROW_SPACING = (index($opts->{g}, '.') >= 0) ?
        int($ARROW_SPACING * $opts->{g}) : $opts->{g}
        if $opts->{g};

    $docpath .= '/'
        if ($docpath && (substr($docpath, -1, 1) ne '/'));

    my $input_file = shift @ARGV;

    if (defined $input_file) {
        open INPUT, "$input_file"
            or die "Couldn't open $input_file for input: $!\n";
    }
    else {
        *INPUT = *STDIN;
    }
#
#    DAA Add HTML image map rendering
#
    my $mapfd;
    if (defined($mappath)) {
        $mappath = $opts->{M} ? ">>$mappath" : ">$mappath";
        die "Cannot open image map file $mappath: $!"
            unless open($mapfd, $mappath);
#
#    define a mapname from output file name (if any)
#
        $mapname = ($output_file=~/(\w+)\.\w+$/) ? $1 : 'mapname';
        print $mapfd
"<html>
<body>
<img border=0 src='$mapname\.png' usemap='#$mapname'>
<MAP NAME='$mapname'>
";
    }

    my $parser       = XML::DOM::Parser->new();
    my $doc          = $parser->parse(*INPUT);

    my $sequence     = $doc->getDocumentElement();
    my $title        = $sequence->getAttribute("title");

    my $classes      = $doc->getElementsByTagName("class");
#
#    DAA added to track previous class for drawing async arrows
#
    my %priors       = ();
    my $class_hash   = build_class_name_hash($classes);
    my $class_count  = scalar (keys %$class_hash);
#
#    if external events, but not first, then trim
#
    $class_count--
        if exists($class_hash->{_EXTERNAL}) && $class_hash->{_EXTERNAL};
#
#    compute class header text now, so we get get true box sizes
#
    my $maxClassHt = 1;
    while (my ($class, $idx) = each %$class_hash) {
        if ($class eq '_EXTERNAL') {
            $ARROW_DELTA = 1 if ($idx == 0);
            next;
        }
        $class_hdrs[$idx] = _wrapText($class);
        my $lines = ($class_hdrs[$idx]=~tr/\n//) + 1;
        $maxClassHt = $lines if ($lines > $maxClassHt);
    }
    $CLASS_BOX_HEIGHT *= $maxClassHt;
    $FIRST_ARROW = $CLASS_TEXT_Y + $CLASS_BOX_HEIGHT;

    my $arrow_count  = count_arrows($doc);
    my $width        = ($class_count + 0.5) *
        ($CLASS_BOX_WIDTH + $CLASS_SPACING) + 40;
    my $height       = $FIRST_ARROW + ($arrow_count + 1) * ($ARROW_SPACING);

    my $format = ($output_file eq '-') ? 'png' :
        ($output_file=~/\.(gif|jpg|jpeg|png)$/i) ? lc $1 : 'png';

    my $img = GD::Image->new($width, $height);
    $white = $img->colorAllocate(@{$colors{white}});
    $black = $img->colorAllocate(@{$colors{black}});
    $classcolor = ($classcolor eq 'black') ? $black :
        ($classcolor eq 'white') ? $white :
        (substr($classcolor,0,1) eq '#') ?
            $img->colorAllocate(_dehex($classcolor)) :
            $img->colorAllocate(@{$colors{$classcolor}});

    $actcolor = ($actcolor eq 'black') ? $black :
        ($actcolor eq 'white') ? $white :
        (substr($actcolor,0,1) eq '#') ?
            $img->colorAllocate(_dehex($actcolor)) :
            $img->colorAllocate(@{$colors{$actcolor}});
#
#    create arrowhead markers
#
    my ($arrow, $trans, $arrowblack, $poly);

    foreach (@arrowpts) {
        $arrow = GD::Image->new(12,14);
        $trans = $arrow->colorAllocate(128, 128, 128);
        $arrowblack = $arrow->colorAllocate(0,0,0);
        $arrow->transparent($trans);
        $arrow->filledRectangle(0,0,12,14, $trans);
        $poly = GD::Polygon->new();
        $poly->addPt(shift @$_, shift @$_)
            while scalar @$_;
        $arrow->filledPolygon($poly, $arrowblack);
        push @arrows, $arrow;
    }
#
#    load fonts
#    set default to GD fonts
#
    $titlefont = gdGiantFont;
    $classfont = gdGiantFont;
    $methodfont = gdSmallFont;
    $eventfont = gdSmallFont;
    $tinyfont = gdTinyFont;
    my ($boldfont, $italfont);
    if (($^O eq 'MSWin32') &&
        ((!$fontname) || (lc $fontname ne 'gd'))) {
        if ($fontfile) {
            $boldfont = $fontfile;
            $italfont = $fontfile;
        }
        else  {
            $fontname = 'Arial' unless $fontname;

            $fontfile = get_ttf_abs_path($fontname);
            $fontname = 'Arial',
            $fontfile = get_ttf_abs_path($fontname)
                unless $fontfile;

            $boldfont = get_ttf_bold($fontname) || $fontfile;
            $italfont = get_ttf_italic($fontname) || $fontfile;
        }
        $titlefont = $classfont = $boldfont;
        $methodfont = $eventfont = $tinyfont = $fontfile;
    }
    elsif (($^O ne 'MSWin32') && $fontfile) {
# don't really know what to do about non-Win32
#        $boldfont = $fontfile;
#        $italfont = $fontfile;
        $titlefont = $classfont = $boldfont;
        $methodfont = $eventfont = $tinyfont = $fontfile;
    }

    draw_classes($img, $classes, $mapfd, \%priors);
    draw_arrows($img, $doc, $class_hash, $mapfd, \%priors);
    render_text($img, $title);
#
#    DAA terminate areamap
#
    if (defined($mapfd)) {
        print $mapfd '
<script language="JavaScript" type="text/javascript" src="../wz_tooltip.js"></script>

</body>
</html>
'
        if $opts->{j};
        close $mapfd;
    }

    open GDOUT, ">$output_file";
    binmode GDOUT;
    print GDOUT $img->$format();
    close GDOUT unless $output_file eq '-';
}

sub _dehex {
    my $color = substr($_[0], 1);

    my ($len, $off1, $off2) = (length($color) == 6) ? (2, 2, 4) : (2, 4, 8);
    return ((length($color) == 6) || (length($color) == 12)) ?
        (hex(substr($color, 0, $len)),
        hex(substr($color, $len, $len)),
        hex(substr($color, $len << 1, $len))) :
        (0,0,0);
}

sub draw_classes {
  my ($img, $classes, $mapfd, $priors) = @_;

  my $x        = $LEFT_EDGE;
  my $box_left = $x - 8;
  my $max_extent;
  my $boxht = $CLASS_BOX_HEIGHT;
  my $boxtext;

  my $prior = '_EXTERNAL';
  for (my $i = 0; $i < $classes->getLength(); $i++) {
    my $class      = $classes->item($i);
    my $life_x     = int($x + $CLASS_BOX_WIDTH / 2);
    my $class_name = $class  ->getAttribute("name");

    next if ($class_name eq '_EXTERNAL');

    $priors->{$class_name} = $prior;
    $prior = $class_name;
#
#    DAA add hyperlink to psichedocs
#
    my $class_path = ($docpath && ($class_name!~/\s/)) ?
        $docpath . join('/', split(/::/, $class_name)) . '.html' : undef;

    my $born       = $class  ->getAttribute("born")
                     * $ARROW_SPACING + $FIRST_ARROW;
    my $extends_to = ($class ->getAttribute("extends-to") + 1)
                     * $ARROW_SPACING + $FIRST_ARROW;

    if (not defined $max_extent) { $max_extent = $extends_to; }
#
#    DAA rearranged to place text on top of rectangle
#    for fill purposes
#
    $img->setThickness(LINE_THICKNESS);
    $img->filledRectangle($box_left, $CLASS_BOX_Y,
        $box_left + $CLASS_BOX_WIDTH, $CLASS_BOX_Y + $boxht, $classcolor);

    $img->rectangle($box_left, $CLASS_BOX_Y,
        $box_left + $CLASS_BOX_WIDTH, $CLASS_BOX_Y + $boxht, $black);
#
#    draw class name
#
    push @classtext, [$class_hdrs[$i], $x, 26, $CLASS_BOX_WIDTH];
#
#    DAA support areamaps
#
    print $mapfd "<AREA TITLE='$class_name'",
        ($class_path ? " HREF='$class_path'" : ''),
        " SHAPE=RECT COORDS='$box_left,$CLASS_BOX_Y,",
        $box_left + $CLASS_BOX_WIDTH, ',', $CLASS_BOX_Y + $boxht, "'>\n"
        if $mapfd;

    $img->dashedLine($life_x, $born, $life_x, $max_extent, $black);

    my $activation_x = int($box_left + $CLASS_BOX_WIDTH / 2);
    my @activations  = $class->getElementsByTagName("activation");
    foreach my $activation (@activations) {
      $born       = $activation->getAttribute("born");
      $extends_to = $activation->getAttribute("extends-to");
      my $offset     = $activation->getAttribute("offset");
      my $top        = $FIRST_ARROW  + $born       * $ARROW_SPACING;
      my $height     = ($extends_to  - $born + .5) * $ARROW_SPACING;
      my $left       = $activation_x + $offset     * $ACTIVATION_OFFSET;

        $img->filledRectangle($left, $top,
            $left + $ACTIVATION_WIDTH, $top + $height, $actcolor);
        $img->rectangle($left, $top,
            $left + $ACTIVATION_WIDTH, $top + $height, $black);
    }
#    }
    $x        += $CLASS_BOX_WIDTH + $CLASS_SPACING;
    $box_left += $CLASS_BOX_WIDTH + $CLASS_SPACING;
  }
  return $img;
}

sub count_arrows {
  my $doc    = shift;
  my $arrows = $doc->getElementsByTagName("arrow");
  return $arrows->getLength();
}

sub draw_arrows {
  my ($img, $doc, $class_hash, $mapfd, $priors) = @_;

  my $arrows     = $doc->getElementsByTagName("arrow");
  my $annotnum = 1;
  my $annotspan = "\n<ol>\n" if ($annot && ($annot eq 'e'));

  for (my $i = 0; $i < $arrows->getLength(); $i++) {
    my $arrow = $arrows->item($i);
    my $from         = $arrow->getAttribute("from"       );
    my $to           = $arrow->getAttribute("to"         );
#
#    DAA 12/24/2005
#    use type attribute to specify returnvalue or external
#    which changes the line style to dashed or folded, respectively
#    also note that $from for external events originate at the far left
#
    my $type         = $arrow->getAttribute("type"       );
    my $label        = $arrow->getAttribute("label"      );
    my $from_offset  = $arrow->getAttribute("from-offset");
    my $to_offset    = $arrow->getAttribute("to-offset"  );
    my $annots       = $arrow->getElementsByTagName('annotation');
    $annots          = $annots->item(0) if $annots;
    my $y            = $FIRST_ARROW + ($i + 1) * $ARROW_SPACING;

    my $from_number  = ($from eq '_EXTERNAL') ?
        $class_hash->{$priors->{$to}} : $class_hash->{$from};
    my $to_number    = $class_hash->{$to};

    $from_number--, $to_number-- if $ARROW_DELTA;

    $label =~ s/</&lt;/g;
    $label =~ s/>/&gt;/g;
    my $class_path;
#
#    DAA add hyperlink to psichedocs
#
    if ($docpath && ($to!~/\s/)) {
        my $doclabel = $label;
        $doclabel=~s/[\*!]//g;
        $doclabel=~s/^\s*\[[^\]]*\]\s*//;
        $doclabel=~s/^\s+//;
        $doclabel=~s/\s+$//;
        $class_path = $docpath . join('/', split(/::/, $to)) .
            ".html#$doclabel"
            unless ($doclabel=~/\s/);
    }

    if ($from_number < $to_number) {  # arrow from left to right
      my $x1 = $from_number * ($CLASS_BOX_WIDTH + $CLASS_SPACING) + $LEFT_EDGE
               + ($CLASS_BOX_WIDTH + $ACTIVATION_WIDTH)/2
               + $from_offset * $ACTIVATION_OFFSET;
      $x1 += 20 if ($from eq '_EXTERNAL');
      my $x2 = $to_number   * ($CLASS_BOX_WIDTH + $CLASS_SPACING) + $LEFT_EDGE
               + ($CLASS_BOX_WIDTH - $ACTIVATION_WIDTH)/2;
#
#    DAA cuddle the label to the arrowhead
#
      my $xlab = $x2 - $CLASS_SPACING - 6;
      my $ylab = $y  - $charht;
#
#    DAA changed to support call vs. return vs. async activations
#
        $img->setThickness(LINE_THICKNESS);
        ($type eq 'return') ?
            $img->dashedLine($x1, $y, $x2, $y, $black) :
            $img->line($x1, $y, $x2, $y, $black);
        my $arrowimg = $arrows[($type eq 'async') ?
            HALF_RIGHT_ARROW : LEFT_ARROW];
        $img->copy($arrowimg, $x2-14, $y-6, 0,0,
            $arrowimg->width, $arrowimg->height);
#
#    DAA need to add hrefs for methods, but we'll need to track the "to" class
#    name, and ignore names w/ whitespace
#
        drawLabel->($img, $mapfd, $xlab, $ylab, 1,
            $type, $label, $class_path, $mapname, $i,
            \$annotnum, $annots, \$annotspan)
            if defined($label);
    }
    elsif ($from_number > $to_number) {  # arrow from right to left
      my $x1 = $from_number * ($CLASS_BOX_WIDTH + $CLASS_SPACING) + $LEFT_EDGE
               + ($CLASS_BOX_WIDTH - $ACTIVATION_WIDTH)/2;
      my $x2 = $to_number   * ($CLASS_BOX_WIDTH + $CLASS_SPACING) + $LEFT_EDGE
               + ($CLASS_BOX_WIDTH + $ACTIVATION_WIDTH)/2
               + $to_offset * $ACTIVATION_OFFSET;
#
#    DAA changed to support call vs. return vs. async activations
#    (note async activations always go from left to right, so we won't get
#    any here...)
#
        $img->setThickness(LINE_THICKNESS);
        ($type eq 'return') ?
            $img->dashedLine($x1, $y, $x2, $y, $black) :
            $img->line($x1, $y, $x2, $y, $black);
        my $arrowimg = $arrows[RIGHT_ARROW];
        $img->copy($arrowimg, $x2, $y-6, 0,0,
            $arrowimg->width, $arrowimg->height);

      my $xlab = $x2 + $CLASS_SPACING + 6;
      my $ylab = $y  - $charht;
#
#    DAA need to add hrefs for methods, but we'll need to track the "to" class
#    name, and ignore names w/ whitespace
#
        drawLabel->($img, $mapfd, $xlab, $ylab, 0,
            $type, $label, $class_path, $mapname, $i,
            \$annotnum, $annots, \$annotspan)
            if defined($label);
    }
    else {               # arrow from and to same class
      my $x1 = $from_number * ($CLASS_BOX_WIDTH + $CLASS_SPACING) + $LEFT_EDGE
               + ($CLASS_BOX_WIDTH + $ACTIVATION_WIDTH)/2
               + $from_offset * $ACTIVATION_OFFSET;
      my $x2 = $to_number   * ($CLASS_BOX_WIDTH + $CLASS_SPACING) + $LEFT_EDGE
               + ($CLASS_BOX_WIDTH + $ACTIVATION_WIDTH)/2
               + $to_offset * $ACTIVATION_OFFSET;
      $y -= 10;
      my $y2 = $y + 20;
      my $x1padded = $x1 + $ACTIVATION_OFFSET + 15;
        $img->setThickness(LINE_THICKNESS);
        $img->line($x1, $y, $x1padded, $y, $black);
        $img->line($x1padded, $y, $x1padded, $y2, $black);
        $img->line($x1padded, $y2, $x2, $y2, $black);
        my $arrowimg = $arrows[RIGHT_ARROW];
        $img->copy($arrowimg, $x2, $y2-6, 0,0,
            $arrowimg->width, $arrowimg->height);

      my $xlab = $x1padded + $CLASS_SPACING;
      my $ylab = ($y + $y2) / 2;
#
#    DAA need to add hrefs for methods, but we'll need to track the "to" class
#    name, and ignore names w/ whitespace
#
        drawLabel->($img, $mapfd, $xlab, $ylab, 0,
            $type, $label, $class_path, $mapname, $i,
            \$annotnum, $annots, \$annotspan)
            if defined($label);
    }
  }
#
#    DAA save annotations if any
#
    if ($mapfd) {
        print $mapfd "</MAP>\n\n";
        print $mapfd "$annotspan\n</ol>\n"
              if $annotspan && ($annotspan ne '<ol>');
    }

  return $img;
}

sub build_class_name_hash {
    my $class_nodes = shift;
    my %classes;  # keyed by class name store left to right position
    my ($class, $class_name);

    $class = $class_nodes->item($_),
    $class_name = $class->getAttribute('name'),
    $classes{$class_name} = $_
          for (0..$class_nodes->getLength() - 1);

  return \%classes;
}

sub parse_command_line {
    my %opts;
    getopts('a:c:ef:F:g:jm:M:o:p:P:s:w:x:y:', \%opts);
    $output_file = $opts{o} if defined $opts{o};
    $classcolor = $opts{c} || 'white';
    $actcolor = $opts{a} || 'white';
    $docpath = $opts{p} || $opts{P};
    $annot = $opts{e} || $opts{j};
    $fontfile = $opts{F};
    $fontname = $opts{f};
    $sig = $opts{s};
    return \%opts;
}

sub _createLabelMap {
    my ($x1, $y1, $x2, $y2, $title, $name, $path,
        $annot_text, $annot_name, $annot_span) = @_;
#
#    NOTE: Batik seems to render the text coords about 10px lower than raster,
#    so we'll cheat here...may not be needed for GD
#
    $y1 -= 10, $y2 -= 10;
#
#    also, if label has a newline, hyperlink bottom line only
#
    if ($title=~/\n/) {
        $y1 += 16;
        $y2 += 16;
        $x2 = $x1 + ((length($title) - index($title, "\n") - 1) * $charwidth);
    }
    $title=~tr/\n/ /;
    my $maptext =
"<AREA NAME='$name' TITLE='$title' SHAPE=RECT COORDS='$x1,$y1,$x2,$y2' " .
        ($path ? "HREF='$path' " : '');

    if ($annot_text) {
        if ($annot && ($annot eq 'j')) {
#
#    Scripted annotation
#
            $annot_text =~s/'/\\'/g;    # escape single quotes
            $title =~s/'/\\'/g;            # escape single quotes
#
#    NOTE: this must all be on 1 line!!!
#
            $maptext .="
onmouseover=\"this.T_STATIC=true;this.T_FONTCOLOR='black';this.T_FONTSIZE='12px';this.T_BGCOLOR='#e0e0e0';this.T_OPACITY=90;this.T_SHADOWWIDTH=8;return escape('$annot_text')\" >
";
        }
        else {     # annot eq 'e'
#
#    embedded annotation, add anchor and annotation text
#    NOTE: the offsets used here are heuristic, need a bbox jscript
#
            my ($x3, $y3, $y4) = ($x2+4, $y1 + (($y2 - $y1)>>1), $y1 - 4);

            $maptext .= ">
<AREA SHAPE=RECT COORDS='$x2,$y4,$x3,$y3' HREF='#$annot_name'>
";

            $annot_text=~s/</&lt;/g;
            $annot_text=~s/>/&gt;/g;
            $$annot_span .= "
<a name='$annot_name'></a>
<li>$annot_text
<p>
";
        }
    }
    else {
        $maptext .= ">\n";
    }

    return $maptext;
}

sub render_text {
    my $img = shift;
    my $title = shift;
    my ($align, $len, $nl, $oldlen, $ullen, $x, $xul, $y, $yul);

    my $textimg = GD::Text::Wrap->new($img,
        preserve_nl => 1,
        line_space => 0,
        align => 'left',
        color => $black
    );
#
#    render title (if any)
#
    $textimg->set_font($titlefont, 12);
    $textimg->set(text => $title),
    $textimg->draw(5, 15)
        if $title;
#
#    render classnames
#
    $textimg->set_font($classfont, 12);
    foreach (@classtext) {
        $textimg->set(
            text => $_->[0],
            width => $_->[3]);
        $textimg->draw($_->[1], $_->[2]);
    }
#
#    render labels
#
    $img->setThickness(1);
    $textimg->set_font($methodfont, 10);
    foreach (@labeltext) {
#
#    we need to set alignment based on the arrow direction
#
        $align = $_->[5] ? 'right' : 'left';

        $nl = index($_->[0], "\n");
        $x = $xul = $_->[1];
        ($y, $yul) = ($_->[2] - 4, $_->[2] + 10);
        $ullen = $len = $textimg->width($_->[0]);

        if (($nl > 0) && $_->[4]) {
            $yul += $charht + 4,
            my @segs = split(/\n/, $_->[0]);
            $oldlen = $ullen;
            $ullen = $textimg->width($segs[1]);
            $xul += ($oldlen - $ullen)
                if ($align eq 'right') && ($ullen < $oldlen);
        }

        $textimg->set(
            text => $_->[0],
            align => $align,
            width => $len);

        $textimg->draw($x, $y);
        $img->line($xul, $yul, $xul + $ullen, $yul, $black)
            if $_->[4];
    }
#
#    render italics
#
    $textimg->set_font($eventfont, 10);
    foreach (@italtext) {
        $len = $textimg->width($_->[0]);
        $textimg->set(
            text => $_->[0],
            width => $len);
        $textimg->draw($_->[1], $_->[2] - 4);
        $img->line($_->[1], $_->[2] + 10, $_->[1] + $len, $_->[2] + 10, $black)
            if $_->[4];
    }
#
#    render superscripts
#
    $textimg->set_font($tinyfont, 8);
    $textimg->set(
        text => $_->[0],
        align => 'left',
        width => 10),
    $textimg->draw($_->[1], $_->[2])
        foreach (@supertext);
#
#    render signature (if any)
#
    if ($sig) {
        $textimg->set_font($tinyfont, 6);
        $len = $textimg->width($sig);
        $textimg->set(
            text => $sig,
            width => $len,
            align => 'left');
        my ($x, $y) = ($img->width - $len - 20, $img->height - 20);
        $textimg->draw($x, $y)
    }

    return 1;
}

sub drawLabel {
    my ($img, $mapfd, $xlab, $ylab, $align, $type, $label, $path,
        $mapname, $i, $annotnum, $annots, $annotspan) = @_;

     $xlab -= ($charwidth * length($label)) if $align;
    my $xend = $xlab + ($charwidth * length($label));
    my $yend = $ylab + $charht;
    my $xmap = $xlab;

    if ($type eq 'async') {
        push @italtext,
            [ $label, $xlab, $ylab, $xend - $xlab - 6,
                (($annot && ($annot eq 'j') && $annots) ? 1 : undef), $align ];
    }
    else {
#
#    if conditional, add line break
#
        if ($label=~s/^(\[[^\]]+\])\s*(.*)$/$1\n$2/) {
#
#    and adjust offsets
#
            my ($top, $bot) = (length($1), length($2));
            $top = $bot if ($top < $bot);
            $xlab = $xend - ($top * $charwidth),
            $xmap = $xend - ($bot * $charwidth)
                if $align;
            $ylab -= ($charht + 6);
        }
        push @labeltext,
            [ $label, $xlab, $ylab, $xend - $xlab - 6,
                (($annot && ($annot eq 'j') && $annots) ? 1 : undef), $align ];
    }
#
#    if annotated, add superscript if embedded
#
    push @supertext, [ $$annotnum++, $xend, $ylab - 5 ]
        if ($annot && ($annot eq 'e') && $annots);
#
#    DAA support areamaps
#
    $ylab += $charht,
    $yend += $charht
        unless ($yend - $ylab > $charht);
    print $mapfd _createLabelMap(
        $xmap, $ylab, $xend, $yend,             # location
        $label, "$mapname\_$i", (($type eq 'call') ? $path : undef),
        ($annots ? $annots->getAttribute('text') : undef),
            "$mapname\_annot_$i", $annotspan)    # annotation
        if $mapfd;

    return $img;
}
#
#    to wrap long class names in the header boxes
#
sub _wrapText {
    my ($text, $xpos) = @_;

    return $text
        if ((length($text) * $classcharwidth) < ($CLASS_BOX_WIDTH - 6));
#
#    split on whitespace, dot/colon/underscore, or
#    lowercaseUppercase
#
    my $maxChars = int(($CLASS_BOX_WIDTH - 10)/$classcharwidth);
    my @lines = ();
    my @pieces = ();
    while ($text=~s/([^:\.\s_]+)((:+)|\.|_|\s+)?//) {
        my ($t, $p) = ($1, $2);
        push @pieces, $t;
#
#    if the text is still too long, look for lowerUpper
#
        if (length($pieces[-1]) <= $maxChars) {
            push(@pieces, $p) if $p;
            next;
        }

        $t = pop @pieces;
        push @pieces, $1
            while ($t=~s/^(.*?[a-z])([A-Z].*)$/$2/);
        push @pieces, $t if ($t ne '');

        push(@pieces, $p) if $p;
    }
#
#    now reassemble to minimize box height
#
    $lines[0] = shift @pieces;
    foreach (@pieces) {
        $lines[-1] .= $_,
        next
            if (length($lines[-1]) <= $maxChars) &&
                ((length($lines[-1]) + length($_)) <= $maxChars);
        push @lines, $_ unless /^\s+$/;
    }

    return join("\n", @lines);
}
1;

=head1 Application Notes

The diagram layout of output of this module differs slightly
from the layout of L<UML::Sequence::Svg> output; specifically,
this module stacks conditionals atop the activation label in
order to avoid collisions with activation bars.

=head1 SEE ALSO

L<UML::Sequence::Svg>

=head1 AUTHOR

Dean Arnold L<mailto:darnold@presicient.com>

=head1 COPYRIGHT

Copyright (C) 2006, Dean Arnold, Presicient Corp., USA. All rights reserved.

Portions Copyright 2003, Philip Crow, all rights reserved.

You may modify and/or redistribute this code in the same manner as Perl itself.

=cut