#!__PERL__ -w

$rcsId=' $Id: cxx_to_docbook.prl,v 1.3 2004/05/04 00:00:17 awb Exp $ ';

 ###########################################################################
 ##                                                                       ##
 ## Extract the doc++ comments and any grouped code from an example       ##
 ## program.                                                              ##
 ##                                                                       ##
 ## This is very hacky and probably doesn't generalise properly.          ##
 ## I'll try and rewrite it as a full parse and recreate system at some   ##
 ## point.                                                                ##
 ##                                                                       ##
 ###########################################################################

sub useage
{
    print <<END;

    Useage: example_to_docbook [-s SLEVEL] [-a] [-special PATTERN COMM] [-special \@NAME COMM] [ -t TITLE] EXAMPLE DOCBOOKFILE 

    Turn a C++ example into a docbook section.

	-s SLEVEL	Make the result a sectS, 0 => chapter.

	-a		Appendix rather than chapter if relevant.
	
	-t TITLE	Title of the resulting text. 

	-special \@NAME BEFORE COMM AFTER
			If we see //\@NAME, run COMMAND and include the
			output at this point.
	-special PATTERN  BEFORE COMM AFTER
			If we see PATTERN, run COMMAND and include the
			output at this point.
		
END
}

#__SHARED_SETUP__

$level=0;
$title=undef;
$chapter='chapter';

%patterns = ();

while ($#ARGV>=0)
    {
    if ($ARGV[0] =~ /^-+t/)
	{
	shift @ARGV;
	$title = shift @ARGV;
	}
    elsif ($ARGV[0] =~ /^-+special/)
	{
	shift @ARGV;
	my ($pat, $comm);
	$pat = shift @ARGV;
	$before = shift @ARGV;
	$comm = shift @ARGV;
	$after = shift @ARGV;
	$patterns{$pat} = [ $before, $comm, $after ];
	}
    elsif ($ARGV[0] =~ /^-+s/)
	{
	shift @ARGV;
	$level = shift @ARGV;
	}
    elsif ($ARGV[0] =~ /^-+a/)
	{
	shift @ARGV;
	$chapter = 'appendix';
	}
    elsif ($ARGV[0] =~ /^-+h/)
	{
	useage();
	exit(0);
	}
    else
	{
	last;
	}
    }

if ($#ARGV != 0)
    {
    useage();
    exit(1);
    }

$filename = shift @ARGV;

$special_pattern=build_pattern(\%patterns);

print STDERR "SP $special_pattern\n";

open(F, $filename) ||
    die "can't open $filename - $!";

$filename =~ m%([^/]+)$%;
# $name = $1;

$state='outside';
$top = $current = new Chunk "top";
set $top 'title', $title
    if defined($title);

$count_blahs=0;

while (<F>)
    {
    if ($state eq 'outside' &&
	m%\s*/\*\*\s*((.?).*)% &&
	$2 ne '*')
	{
	my ($rest) = $1;
	my ($new) = new Chunk "comment";
	add $current $new;
	$current=$new;
	$state='comment';
	add_comment_line($new, $rest);
	}

    elsif ($state eq 'comment' &&
	   m%\s*(.*)\*/\s*$%)
	{
	add_comment_line($current, $1)
	    if $1 ne '';

	$current = parent $current;
	$state='outside';
	}

    elsif ($state eq 'comment')
	{
	/^\s*\**(.*)$/;
	add_comment_line($current, $1)
	    if $1 ne '';
	}

    elsif ($state eq 'outside' &&
	   m%\s*//\@\{*\s*code%)
	{
	my ($rest) = $1;
	my ($new) = new Chunk "code";
	add $current $new;
	$current=$new;
	$state='code';
	}

    elsif ($state eq 'code' &&
	   m%\s*//\@\}\s*code%)
	{
	$current = parent $current;
	$state='outside';
	}

    elsif ($state eq 'code' &&
	   m%\s*//\@\s*([a-z]+)\s+(.*)%)
	{
	set $current 'example', $2
	    if $1 eq 'example';
	set $current 'title', $2
	    if $1 eq 'title';
	}

    elsif ($state eq 'code')
	{
	chop;
	add $current $_;
	}

    elsif ($state eq 'outside' &&
	   m%\s*//\@\{\s*$%)
	{
	my ($rest) = $1;
	my ($new) = new Chunk "group";
	add $current $new;
	$current=$new;
	set $new 'title', 'Unnamed Group ' . ++$count_blahs;
	$state='outside';
	}

    elsif ($state eq 'outside' &&
	   m%\s*//\@\}\s*$%)
	{
	$current = parent $current;
	die "//\@} outside any group"
	    if !defined($current);
	$state='outside';
	}

    elsif ($state eq 'outside' &&
	   $special_pattern &&
	   m/$special_pattern/)
	{
	my ($match) = $1;
	my ($before, $command, $after);
	foreach $p (keys(%patterns))
	    {
	    if ($match =~ /^$p$/)
		{
		($before, $command, $after)=@{$patterns{$p}};
		print STDERR "DO '$match' '$p' '$command'\n";
		last;
		}
	    }
	
	if (defined($command))
	    {
	    my ($new) = new Chunk "command";
	    set $new 'before', $before;
	    set $new 'command', $command;
	    set $new 'after', $after;
	    add $current $new;
	    }
	}
    elsif ($state eq 'outside' &&
	   m!^\s*//\s*\@\s*(\S*)!)
	{
	my ($tag) = $1;
	my ($before, $command, $after) = @{$patterns{"\@$tag"}};
	
	if (defined($command))
	    {
	    print STDERR "DO '$tag' '$command'\n";
	    my ($new) = new Chunk "command";
	    set $new 'before', $before;
	    set $new 'command', $command;
	    set $new 'after', $after;
	    add $current $new;
	    }
	else
	    {
	    print STDERR "UNKNOWN '$tag'\n";
	    }
	}
    }

massage($top);

print_docbook(STDOUT, $top, $level);

exit(0);

sub massage
{
    my ($chunk) = @_;

    my ($bits) = get $chunk 'bits';

    if (ref($chunk) && 
	((type $chunk) eq 'group' || (type $chunk) eq 'top' ) &&  
	$#$bits == 0 && 
	ref($$bits[0]) && 
	(($$bits[0]->type()) eq 'group'|| ($$bits[0]->type()) eq 'group1')
	)
	{
	print STDERR "collapse {@{[%$chunk]}} // {@{[%{$$bits[0]}]}}\n";
        foreach $k (keys(%{$$bits[0]}))
	    {
	    print STDERR "    $k ${$$bits[0]}{$k}\n";
	    ${$chunk}{$k} = ${$$bits[0]}{$k}
		if defined (${$$bits[0]}{$k}) && ${$$bits[0]}{$k}
			&& $k ne 'type';
	    }

        print STDERR "gives {@{[%$chunk]}}\n";
	massage($top);
	return;
	}
    elsif ((type $chunk) eq 'code')
       {
       while ($#$bits >= 0 && $$bits[0] eq '')
	   {
	   shift(@{$bits});
	   }
       while ($#$bits >= 0 && $$bits[$#$bits] eq '')
	   {
	   pop(@{$bits});
	   }
       }
    else
	{
	my ($i);
	for($i=0; $i <= $#$bits;$i++)
	    {
	    my ($bit) = $$bits[$i];
	    if ($i+1 <= $#$bits)
		{
		my ($next) = $$bits[$i+1];

		if (ref($bit) && (type $bit) eq 'comment' &&
		    ref($next) && (type $next) eq 'group')
		    {
		    print STDERR "combine {@{[%$bit]}} // {@{[%$next]}}\n";
		    set $next 'title', (title $bit);
		    set $bit 'title', undef;
		    set $next 'toc', (get $bit 'toc');
		    set $bit 'toc', undef;
		    set $next 'id', (get $bit 'id');
		    set $bit 'id', undef;

		    add_first $next $bit;

		    splice(@$bits, $i, 1, ());
		    $bit= $next;

		    set $bit 'type', 'group1';
		    massage($top);
		    return;
		    }
		}

	    massage($bit)
		if ref($bit);
	    }
	}
	
}

sub print_docbook
{
    my ($s, $chunk, $level) = @_;

    print STDERR "P $chunk\n";

    unless (ref($chunk))
	{
	print $s "  "x$level, "<para>$chunk</para>\n";
	return;
	}

    my ($type) = type $chunk;
    my ($title) = get $chunk 'title';
    my ($id) = get $chunk 'id';
    if ($type eq 'top')
	{
	print_level_tag($s, $level, $id);

	print $s "\t<title>$title</title>\n\n"
	    if defined($title);

	print $s "  "x$level, "  <toc depth='", (get $chunk 'toc'), "'></toc>\n"
	    if defined(get $chunk 'toc');

	foreach $bit (@{get $chunk 'bits'})
	    {
	    print_docbook($s, $bit, $level+1);
	    }
	
	print_level_tag($s, $level, "/");
	}
    elsif ($type eq 'command')
	{
	my ($before) = get $chunk 'before';
	my ($command) = get $chunk 'command';
	my ($after) = get $chunk 'after';

	print STDERR "COMMAND $command\n";

	$|=1;
	print "";

	print $s "  "x$level, "  <!-- $command -->\n";
	print $s "  "x$level, "  $before\n"
	    if $before ne '';
	system($command);
	print $s "  "x$level, "  $after\n"
	    if $after ne '';
	print $s "  "x$level, "  <!-- DONE $command -->\n";
	}
    elsif ($type eq 'group' || $type eq 'group1')
	{
	print_level_tag($s, $level, $id);
	print $s "  "x$level, "  <title>$title</title>\n"
	    if defined($title);

	print $s "  "x$level, "  <toc></toc>\n"
	    if defined(get $chunk 'toc');

	foreach $bit (@{get $chunk 'bits'})
	    {
	    print_docbook($s, $bit, $level+1);
	    }
	print_level_tag($s, $level, "/");
	}
    elsif ($type eq 'comment')
	{
	if (defined($title))
	    {
	    print $s "  "x$level, "<simplesect>\n";
	    print $s "  "x$level, "  <title>$title</title>\n";
	    }

	print $s "  "x$level, "<para>\n";

	foreach $line (@{get $chunk 'bits'})
	    {
	    print $s $line, "\n";
	    }

	print $s "  "x$level, "</para>\n";

	my ($refs) = get $chunk 'refs';
	if ($#$refs >=0)
	    {
	    print $s "  "x$level, "  <formalpara>\n";
	    print $s "  "x$level, "    <title>See also</title><para>\n";
	    print $s "  "x$level, "    <itemizedlist>\n";

	    foreach $ref (@$refs)
		{
		print $s "  "x$level, "    <listitem><para>$ref</para></listitem>\n"; 
		}

	    print $s "  "x$level, "    </itemizedlist>\n";
	    print $s "  "x$level, "  </para></formalpara>\n";
	    }

	if (defined($title))
	    {
	    print $s "  "x$level, "</simplesect>\n";
	    }
	}
    elsif ($type eq 'code')
	{
	my ($exampleid) = get $chunk 'example';

	if (defined($exampleid))
	    {
	    print $s "  "x$level, "<example id='$exampleid'>\n";
	    if (defined($title))
		{
		print $s "  "x$level, "  <title>$title</title>\n";
		}
	    else
		{
		print $s "  "x$level, "  <title>Example $exampleid</title>\n";
		}
	    }

	print $s "  "x$level, "<programlisting arch='c'>";

	my ($first) = 1;

	foreach $line (@{get $chunk 'bits'})
	    {
	    print "\n"
		unless $first;
	    local ($_) = $line;

	    s/&/&amp;/g;
	    s/</&lt;/g;
	    s/>/&gt;/g;
	    s%//\s*(.*)$%// <lineannotation>$1</lineannotation>%;

	    print $s $_;
	    $first=0;
	    }

	print $s "  "x$level, "</programlisting>\n";
	if (defined($exampleid))
	    {
	    print $s "  "x$level, "</example>\n";
	    }

	}
}

sub print_level_tag
{
    my ($s, $l, $end) = @_;

    if(defined($end))
	{
	if ($end eq '/')
	    {
	    $id='';
	    }
	else
	    {
	    $id=" id='$end'";
	    $end='';
	    }
	}
    else
	{
	$id=$end='';
	}
    
    my ($what) = $l==0?$chapter:"sect$l";

    print $s "  "x$l, "<$end$what$id>\n";
}

sub add_comment_line
{
    my ($chunk, $line) = @_;
    
    if ($line =~ /^\s*\@\s*([a-z]+)(\s+(.*))?/)
	{
	my ($op, $arg) = ($1, $3);

	print STDERR "OP=$op ARG=$arg\n";
	if ($op eq 'name' || $op eq 'title')
	    {
	    set $chunk 'title', $arg;
	    }
	elsif ($op eq 'see')
	    {
	    add $chunk 'refs', $arg;
	    }
	elsif ($op eq 'id')
	    {
	    set $chunk 'id', id_munge($arg);
	    }
	elsif ($op eq 'toc')
	    {
	    if (defined($arg))
		{
		set $chunk 'toc', $arg;
		}
	    else
		{
		set $chunk 'toc', 1;
		}
	    }
	}
    else
	{
	add $chunk $line;
	}
}

sub build_pattern
{
    my ($patterns) = @_;
    my (@alts) = grep ($_ !~ /^\@/, keys(%$patterns));

    return @alts?"(" . join("|", @alts) . ")":'';
}

sub id_munge
{
    my ($id) = @_;

    $id =~ s/[^-A-Za-z0-9]+/-/g;
    return $id;
}

package Chunk;

sub new
{
    my ($class, $type) = @_;
    my ($self) = { bits => [], refs=> [], decls => [], type => $type};

    return bless $self, $class;
}

sub add
{
    my ($self, $what, $new) = @_;

    if (!defined($new))
	{
	$new=$what;
	$$new{parent} = $self
	    if ref($new) eq 'Chunk';
	
	push (@{$$self{bits}}, $new);
	}
    else
	{
	push (@{$$self{$what}}, $new);
	}

}

sub add_first
{
    my ($self, $what, $new) = @_;

    if (!defined($new))
	{
	$new=$what;
	$$new{parent} = $self
	    if ref($new) eq 'Chunk';
	
	unshift (@{$$self{bits}}, $new);
	}
    else
	{
	unshift (@{$$self{$what}}, $new);
	}

}

sub last_bit
{
    my ($self) = @_;

    return ${$$self{bits}}[$#{$$self{bits}}]
        if $#{$$self{bits}} >=0;
    return undef;
}


sub drop_last_bit
{
    my ($self) = @_;

    pop(@{$$self{bits}});
}

sub last_bit_type

{
    my ($self, $type) = @_;
    
    return $$self{type} eq $type;
}

sub set
{
    my ($self, $key, $val) = @_;
    
    $$self{$key} = $val;
}

sub get
{
    my ($self, $key) = @_;
    
    return $$self{$key};
}

sub parent
{
    my ($self) = @_;
    return $$self{parent};
}

sub type
{
    my ($self) = @_;
    return $$self{type};
}

sub title
{
    my ($self) = @_;
    return $$self{title};
}