1 #! /usr/bin/perl |
|
2 |
|
3 # Copyright 2009, 2011 Myhailo Danylenko |
|
4 # |
|
5 # This program is free software: you can redistribute it and/or modify |
|
6 # it under the terms of the GNU General Public License as published by |
|
7 # the Free Software Foundation, either version 2 of the License, or |
|
8 # (at your option) any later version. |
|
9 # |
|
10 # This program is distributed in the hope that it will be useful, |
|
11 # but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
13 # GNU General Public License for more details. |
|
14 # |
|
15 # You should have received a copy of the GNU General Public License |
|
16 # along with this program. If not, see <http://www.gnu.org/licenses/>. |
|
17 |
|
18 =head1 |
|
19 |
|
20 Reads source and generates documentation, embedded in comments |
|
21 |
|
22 =head1 SYNTAX |
|
23 |
|
24 docgen.pl [B<-o> I<outfile>] [B<-t> I<title>] [B<-f> I<format>] F<infile> [F<infile>] ... |
|
25 |
|
26 =cut |
|
27 |
|
28 use strict; |
|
29 use warnings; |
|
30 |
|
31 use Pod::Usage; |
|
32 use Getopt::Std; |
|
33 $Getopt::Std::STANDARD_HELP_VERSION = 1; |
|
34 |
|
35 our $VERSION = '0.0.3'; |
|
36 our sub HELP_MESSAGE { |
|
37 pod2usage (-verbose => 2, |
|
38 -noperldoc => 1); |
|
39 } |
|
40 |
|
41 =head1 OPTIONS |
|
42 |
|
43 B<-o> F<outfile> |
|
44 |
|
45 Output file (if not specified - stdout). |
|
46 |
|
47 B<-t> I<title> |
|
48 |
|
49 Title for documentation html page |
|
50 |
|
51 B<-f> [I<html>|I<mdwn>] |
|
52 |
|
53 Output type: html (default) or markdown. |
|
54 |
|
55 B<-p> I<prefix> |
|
56 |
|
57 Prefix to search, by default c-like '///' |
|
58 |
|
59 B<-c> F<css-link> |
|
60 |
|
61 Url to css file to include in html header. |
|
62 |
|
63 =cut |
|
64 |
|
65 our ( $opt_o, $opt_t, $opt_f, $opt_p, $opt_c ) |
|
66 = ( undef, "Docs", 'html', '///', undef ); |
|
67 getopts ( 'o:t:f:p:c:' ); |
|
68 $opt_c = $opt_c ? qq(\n<link rel="stylesheet" href="$opt_c" type="text/css" />) : ""; |
|
69 my $prefix_rx = quotemeta $opt_p; |
|
70 |
|
71 my %docs; |
|
72 my @tags; |
|
73 my $inside; |
|
74 my $harvest; |
|
75 my @values; |
|
76 |
|
77 foreach my $file (@ARGV) { |
|
78 if ( not open SOURCE, '<', $file ) { |
|
79 print STDERR "Cannot open $file\n"; |
|
80 next; |
|
81 } |
|
82 |
|
83 my $chunk = 0; |
|
84 |
|
85 while (<SOURCE>) { |
|
86 if ( $inside ) { |
|
87 if ( /^$prefix_rx\s*G:\s*(.*?)\s*$/o ) { |
|
88 $inside = 0; |
|
89 $harvest = "V: $1"; |
|
90 } elsif ( /^$prefix_rx\s?(.*?)\s*$/o ) { |
|
91 push @{$docs{$file}[$chunk]}, $1; |
|
92 } else { |
|
93 $inside = 0; |
|
94 $chunk++; |
|
95 } |
|
96 } elsif ( $harvest ) { |
|
97 if ( /\{\s*NULL.*\}/o ) { |
|
98 push @{$docs{$file}[$chunk]}, $harvest . ' ' . join ( ', ', @values ); |
|
99 $harvest = undef; |
|
100 @values = (); |
|
101 $chunk++; |
|
102 } elsif ( /\{\s*"(.+?)".*\}/o ) { |
|
103 push @values, $1; |
|
104 } |
|
105 } elsif ( /^$opt_p\s*(.*?)\s*$/o ) { |
|
106 |
|
107 my $tag = $1; |
|
108 $inside = 1; |
|
109 push @{$docs{$file}[$chunk]}, $tag; |
|
110 # hack to allow twoword objects be written in text with spaces |
|
111 # now it matches "lm message" instead of "lm message node" -.- |
|
112 # and even if tag list will be reverse sorted by length, |
|
113 # it will produce nested links... |
|
114 # well, that all is now solved, but in not too impressive way.. |
|
115 $tag =~ s/[_\s]+/./go; |
|
116 push @tags, $tag; |
|
117 } |
|
118 } |
|
119 |
|
120 close SOURCE; |
|
121 } |
|
122 |
|
123 @tags = reverse sort { length $a <=> length $b } @tags; |
|
124 |
|
125 if ( $opt_o ) { |
|
126 open OUTPUT, ">", "$opt_o" |
|
127 or die "Cannot open destination file '$opt_o': $!"; |
|
128 } else { |
|
129 *OUTPUT = *STDOUT; |
|
130 } |
|
131 |
|
132 if ( $opt_f eq 'html' ) { |
|
133 |
|
134 print OUTPUT <<HEADER |
|
135 <html> |
|
136 <head> |
|
137 <title>$opt_t</title>$opt_c |
|
138 </head> |
|
139 <body> |
|
140 HEADER |
|
141 ; |
|
142 |
|
143 # TODO preserve original order |
|
144 foreach my $file ( sort keys %docs ) { |
|
145 print OUTPUT "<hr>\n"; |
|
146 foreach my $chunk ( @{$docs{$file}} ) { |
|
147 my $head = shift @$chunk; |
|
148 my $tag = $head; |
|
149 my $list = undef; |
|
150 $tag =~ s/[_\s]+/./go; |
|
151 print OUTPUT "<a name='$tag'></a><h2>$head</h2>\n<p>"; |
|
152 foreach ( @$chunk ) { |
|
153 s/^A: /<br\/><b>Arguments:<\/b> /o; |
|
154 s/^R: /<br\/><b>Return values:<\/b> /o; |
|
155 s/^V: /<br\/><b>Values:<\/b> /o; |
|
156 s/^\[/<br\/><pre>/o; |
|
157 s/^\]/<\/pre><br\/>/o; |
|
158 if ( $list ) { |
|
159 if ( /^\* /o ) { |
|
160 s/^\* /<\/li>\n<li>/o; |
|
161 } else { |
|
162 s/^/<\/li>\n<\/ul> /o; |
|
163 $list = undef; |
|
164 } |
|
165 } elsif ( /^\* /o ) { |
|
166 s/^\* /<ul>\n<li>/o; |
|
167 $list = 1; |
|
168 } |
|
169 foreach my $tag ( @tags ) { |
|
170 # TODO quotemeta required, but for now |
|
171 # this bug is rather desired... |
|
172 #s/\b$tag\b/<a href="#$tag">$&<\/a>/g; |
|
173 s/(.)\b($tag)\b/ if ( $1 eq '#' or $1 eq '>' ) { "$1$2" } else { "$1<a href='#$tag'>$2<\/a>" } /ge; |
|
174 } |
|
175 print OUTPUT "$_\n"; |
|
176 } |
|
177 print OUTPUT "</li>\n</ul>" if $list; |
|
178 print OUTPUT "</p>\n"; |
|
179 } |
|
180 print OUTPUT "<hr>\n"; |
|
181 } |
|
182 |
|
183 print OUTPUT "</body>\n</html>"; |
|
184 |
|
185 } elsif ( $opt_f eq 'mdwn' ) { |
|
186 |
|
187 print OUTPUT <<HEADER |
|
188 |
|
189 [[!meta title="$opt_t"]] |
|
190 |
|
191 [[!toc]] |
|
192 HEADER |
|
193 ; |
|
194 |
|
195 foreach my $file ( sort keys %docs ) { |
|
196 print OUTPUT "\n\n- - -"; |
|
197 foreach my $chunk ( @{$docs{$file}} ) { |
|
198 my $head = shift @$chunk; |
|
199 my $tag = $head; |
|
200 my $code = 0; |
|
201 my $list = 0; |
|
202 $tag =~ s/[_\s]+/./go; |
|
203 print OUTPUT qq(\n\n<a name="$tag"></a>\n### $head); |
|
204 foreach (@$chunk) { |
|
205 if ( $code ) { |
|
206 if ( /^\]\s*(.*?)\s*$/o ) { |
|
207 print OUTPUT "\n\n$1 "; |
|
208 $code = 0; |
|
209 } else { |
|
210 print OUTPUT "\n\t$_"; |
|
211 } |
|
212 next; |
|
213 } elsif ( /^\[\s*(.*?)\s*$/o ) { |
|
214 $code = 1; |
|
215 print OUTPUT "\n\n\t$1"; |
|
216 next; |
|
217 } elsif ( $list ) { |
|
218 if ( not /^\* /o ) { |
|
219 $list = 0; |
|
220 print OUTPUT "\n"; |
|
221 } |
|
222 } elsif ( /^\* /o ) { |
|
223 $list = 1; |
|
224 print OUTPUT "\n"; |
|
225 } |
|
226 |
|
227 if ( s/^A: (.*)$/ \n**Arguments:** $1 /o ) { |
|
228 } elsif ( s/^R: (.*)$/ \n**Return values:** $1 /o ) { |
|
229 } elsif ( s/^V: (.*)$/ \n**Values:** $1 /o ) { |
|
230 } else { |
|
231 s/^/\n/o; |
|
232 } |
|
233 foreach my $tag ( @tags ) { |
|
234 s/(.)\b($tag)\b/ if ( $1 eq '#' or $1 eq '[' ) { "$1$2" } else { "$1\[$2\](#$tag)" } /ge; |
|
235 } |
|
236 print OUTPUT "$_"; |
|
237 } |
|
238 }; |
|
239 print OUTPUT "\n\n- - -"; |
|
240 } |
|
241 |
|
242 } |
|
243 |
|
244 close OUTPUT; |
|
245 |
|
246 # The end |
|