#! /usr/bin/perl
# Copyright 2009, 2011 Myhailo Danylenko
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
=head1
Reads source and generates documentation, embedded in comments
=head1 SYNTAX
docgen.pl [B<-o> I<outfile>] [B<-t> I<title>] [B<-f> I<format>] F<infile> [F<infile>] ...
=cut
use strict;
use warnings;
use Pod::Usage;
use Getopt::Std;
$Getopt::Std::STANDARD_HELP_VERSION = 1;
our $VERSION = '0.0.3';
our sub HELP_MESSAGE {
pod2usage (-verbose => 2,
-noperldoc => 1);
}
=head1 OPTIONS
B<-o> F<outfile>
Output file (if not specified - stdout).
B<-t> I<title>
Title for documentation html page
B<-f> [I<html>|I<mdwn>]
Output type: html (default) or markdown.
B<-p> I<prefix>
Prefix to search, by default c-like '///'
B<-c> F<css-link>
Url to css file to include in html header.
=cut
our ( $opt_o, $opt_t, $opt_f, $opt_p, $opt_c )
= ( undef, "Docs", 'html', '///', undef );
getopts ( 'o:t:f:p:c:' );
$opt_c = $opt_c ? qq(\n<link rel="stylesheet" href="$opt_c" type="text/css" />) : "";
my $prefix_rx = quotemeta $opt_p;
my %docs;
my @tags;
my $inside;
my $harvest;
my @values;
foreach my $file (@ARGV) {
if ( not open SOURCE, '<', $file ) {
print STDERR "Cannot open $file\n";
next;
}
my $chunk = 0;
while (<SOURCE>) {
if ( $inside ) {
if ( /^$prefix_rx\s*G:\s*(.*?)\s*$/o ) {
$inside = 0;
$harvest = "V: $1";
} elsif ( /^$prefix_rx\s?(.*?)\s*$/o ) {
push @{$docs{$file}[$chunk]}, $1;
} else {
$inside = 0;
$chunk++;
}
} elsif ( $harvest ) {
if ( /\{\s*NULL.*\}/o ) {
push @{$docs{$file}[$chunk]}, $harvest . ' ' . join ( ', ', @values );
$harvest = undef;
@values = ();
$chunk++;
} elsif ( /\{\s*"(.+?)".*\}/o ) {
push @values, $1;
}
} elsif ( /^$opt_p\s*(.*?)\s*$/o ) {
my $tag = $1;
$inside = 1;
push @{$docs{$file}[$chunk]}, $tag;
# hack to allow twoword objects be written in text with spaces
# now it matches "lm message" instead of "lm message node" -.-
# and even if tag list will be reverse sorted by length,
# it will produce nested links...
# well, that all is now solved, but in not too impressive way..
$tag =~ s/[_\s]+/./go;
push @tags, $tag;
}
}
close SOURCE;
}
@tags = reverse sort { length $a <=> length $b } @tags;
if ( $opt_o ) {
open OUTPUT, ">", "$opt_o"
or die "Cannot open destination file '$opt_o': $!";
} else {
*OUTPUT = *STDOUT;
}
if ( $opt_f eq 'html' ) {
print OUTPUT <<HEADER
<html>
<head>
<title>$opt_t</title>$opt_c
</head>
<body>
HEADER
;
# TODO preserve original order
foreach my $file ( sort keys %docs ) {
print OUTPUT "<hr>\n";
foreach my $chunk ( @{$docs{$file}} ) {
my $head = shift @$chunk;
my $tag = $head;
my $list = undef;
$tag =~ s/[_\s]+/./go;
print OUTPUT "<a name='$tag'></a><h2>$head</h2>\n<p>";
foreach ( @$chunk ) {
s/^A: /<br\/><b>Arguments:<\/b> /o;
s/^R: /<br\/><b>Return values:<\/b> /o;
s/^V: /<br\/><b>Values:<\/b> /o;
s/^\[/<br\/><pre>/o;
s/^\]/<\/pre><br\/>/o;
if ( $list ) {
if ( /^\* /o ) {
s/^\* /<\/li>\n<li>/o;
} else {
s/^/<\/li>\n<\/ul> /o;
$list = undef;
}
} elsif ( /^\* /o ) {
s/^\* /<ul>\n<li>/o;
$list = 1;
}
foreach my $tag ( @tags ) {
# TODO quotemeta required, but for now
# this bug is rather desired...
#s/\b$tag\b/<a href="#$tag">$&<\/a>/g;
s/(.)\b($tag)\b/ if ( $1 eq '#' or $1 eq '>' ) { "$1$2" } else { "$1<a href='#$tag'>$2<\/a>" } /ge;
}
print OUTPUT "$_\n";
}
print OUTPUT "</li>\n</ul>" if $list;
print OUTPUT "</p>\n";
}
print OUTPUT "<hr>\n";
}
print OUTPUT "</body>\n</html>";
} elsif ( $opt_f eq 'mdwn' ) {
foreach my $file ( sort keys %docs ) {
print OUTPUT "\n\n- - -";
foreach my $chunk ( @{$docs{$file}} ) {
my $head = shift @$chunk;
my $tag = $head;
my $code = 0;
my $list = 0;
$tag =~ s/[_\s]+/./go;
print OUTPUT qq(\n\n<a name="$tag"></a>\n### $head);
foreach (@$chunk) {
if ( $code ) {
if ( /^\]\s*(.*?)\s*$/o ) {
print OUTPUT "\n\n$1 ";
$code = 0;
} else {
print OUTPUT "\n\t$_";
}
next;
} elsif ( /^\[\s*(.*?)\s*$/o ) {
$code = 1;
print OUTPUT "\n\n\t$1";
next;
} elsif ( $list ) {
if ( not /^\* /o ) {
$list = 0;
print OUTPUT "\n";
}
} elsif ( /^\* /o ) {
$list = 1;
print OUTPUT "\n";
}
if ( s/^A: (.*)$/ \n**Arguments:** $1 /o ) {
} elsif ( s/^R: (.*)$/ \n**Return values:** $1 /o ) {
} elsif ( s/^V: (.*)$/ \n**Values:** $1 /o ) {
} else {
s/^/\n/o;
}
foreach my $tag ( @tags ) {
s/(.)\b($tag)\b/ if ( $1 eq '#' or $1 eq '[' ) { "$1$2" } else { "$1\[$2\](#$tag)" } /ge;
}
print OUTPUT "$_";
}
};
print OUTPUT "\n\n- - -";
}
}
close OUTPUT;
# The end