Commit | Line | Data |
4536f655 |
1 | #!/usr/local/bin/perl -w |
2 | # |
3 | # stem2pod |
4 | # |
5 | # takes filename (a stem module) arguments and it updates their |
6 | # pod from their attribute descriptions. it also will insert pod |
7 | # templates for methods, subs and standard pod sections. |
8 | # |
9 | # if a file is changed, it is written out over itself. unchanged |
10 | # files are not touched. |
11 | |
12 | use strict; |
13 | |
14 | use Carp qw( carp cluck ) ; |
15 | use Data::Dumper; |
16 | |
17 | #use Test::More tests => 1 ; |
18 | |
19 | #$SIG{__WARN__} = sub { cluck } ; |
20 | |
21 | my $changed ; |
22 | my $package ; |
23 | |
24 | my %is_attr_part = map { $_ => 1 } qw( |
25 | name |
26 | type |
27 | help |
28 | default |
29 | required |
30 | class |
31 | class_args |
32 | ) ; |
33 | |
34 | foreach my $file_name ( @ARGV ) { |
35 | |
36 | process_source_file( $file_name ) ; |
37 | } |
38 | |
39 | exit ; |
40 | |
41 | sub process_source_file { |
42 | |
43 | my ( $file_name ) = @_ ; |
44 | |
45 | my $code_text = read_file( $file_name ) ; |
46 | |
47 | my $new_code_text = process_code_text( $file_name, $code_text ) ; |
48 | |
49 | #print $new_code_text ; |
50 | |
51 | if ( $new_code_text eq $code_text ) { |
52 | |
53 | print "$file_name SAME\n" ; |
54 | return ; |
55 | } |
56 | |
57 | print "$file_name CHANGED\n" ; |
58 | |
59 | write_file( "$file_name.new, $new_code_text ) ; |
60 | |
61 | # write_file( "$file_name.bak, $code_text ) ; |
62 | # write_file( $file_name, $new_code_text ) ; |
63 | |
64 | } |
65 | |
66 | sub process_code_text { |
67 | |
68 | my ( $file_name, $text ) = @_ ; |
69 | |
70 | $text =~ s{ |
71 | ( |
72 | ^package # start at package line |
73 | .+? # the middle stuff |
74 | ^sub # start of constructor |
75 | ) |
76 | } |
77 | { |
78 | update_attr_spec( $1, $file_name ) |
79 | }mgsex ; |
80 | |
81 | $text =~ s{ |
82 | (.{0,20}?) |
83 | ^sub |
84 | \s+ |
85 | (\w+) |
86 | \s* |
87 | } |
88 | { update_sub_pod( $1, $2 ) }mgsex ; |
89 | |
90 | unless( $text =~ /^=cut\s*^\s*1\s*;\s*/m ) { |
91 | |
92 | $text =~ s{^\s*1\s*;\s*$}{ update_trailing_pod() }mex ; |
93 | } |
94 | |
95 | return $text ; |
96 | } |
97 | |
98 | |
99 | sub update_attr_spec { |
100 | |
101 | my( $attr_text, $file_name ) = @_ ; |
102 | |
103 | #print "U1 <$attr_text>\n" ; |
104 | |
105 | ( $package ) = $attr_text =~ /^package\s+([\w:]+)/ ; |
106 | |
107 | $attr_text =~ s/\n*^\#{5,}\n.+?^\#{5,}\n*//ms ; |
108 | # and print "DELETED OLD POD\n" ; |
109 | |
110 | #print "U3 <$attr_text>\n" ; |
111 | |
112 | $attr_text =~ s{ (^my\s+\$attr_spec.+?^]\s*;\s*) } |
113 | { attr_spec_to_pod( $1, $file_name ) }gmsex ; |
114 | |
115 | #dump_attr( 'ATTR', $attr_text ) ; |
116 | #print "ATTR [", substr( $attr_text, -40 ), "]\n" ; |
117 | #print "U2 [$attr_text]\n" ; |
118 | |
119 | return $attr_text ; |
120 | } |
121 | |
122 | sub attr_spec_to_pod { |
123 | |
124 | my ( $attr_text, $file_name ) = @_ ; |
125 | |
126 | my $pod ; |
127 | |
128 | #print "ATTR [$attr_text]\n" ; |
129 | #print "ATTR END1 [", substr( $attr_text, -30), "]\n" ; |
130 | |
131 | $attr_text =~ s/\s*\z// ; |
132 | |
133 | my( $attr_list_text ) = |
134 | $attr_text =~ /^my\s+\$attr_spec.+?=(.+?^\])/ms ; |
135 | $attr_list_text or die |
136 | "can't parse out attr list from file $file_name class $package" ; |
137 | |
138 | #print "ATTR2 [$attr_list_text]\n" ; |
139 | my $attr_list = eval $attr_list_text ; |
140 | |
141 | $pod .= <<POD ; |
142 | ########### |
143 | # This POD section is autogenerated. Any edits to it will be lost. |
144 | |
145 | =head2 Class Attributes for $package |
146 | |
147 | =over 4 |
148 | |
149 | POD |
150 | |
151 | #print "POD [$pod]\n" ; |
152 | |
153 | |
154 | foreach my $attr_ref ( @{$attr_list} ) { |
155 | |
156 | my $name = $attr_ref->{name} ; |
157 | |
158 | if ( $name ) { |
159 | |
160 | $pod .= <<POD ; |
161 | |
162 | =item * Attribute - B<$name> |
163 | |
164 | =over 4 |
165 | |
166 | POD |
167 | } |
168 | else { |
169 | |
170 | warn <<WARN ; |
171 | Missing attribute name in Class $package in file $file_name |
172 | WARN |
173 | |
174 | next ; |
175 | } |
176 | |
177 | my $help = $attr_ref->{help} ; |
178 | |
179 | if ( defined( $help ) ) { |
180 | |
181 | $pod .= <<POD ; |
182 | |
183 | =item Description: |
184 | |
185 | $help |
186 | POD |
187 | } |
188 | else { |
189 | |
190 | warn <<WARN ; |
191 | Missing help in attribute $name in Class $package in file $file_name |
192 | WARN |
193 | } |
194 | |
195 | if ( my $attr_class = $attr_ref->{class} ) { |
196 | |
197 | my $class_args = '<' . |
198 | join( ', ', @{$attr_ref->{class_args} || []} ) |
199 | . '>' ; |
200 | |
201 | $pod .= <<POD ; |
202 | |
203 | =item Class Attribute: |
204 | |
205 | '$name' is an object of class $attr_class and constructed with: |
206 | $class_args |
207 | POD |
208 | } |
209 | |
210 | |
211 | exists( $attr_ref->{type} ) and $pod .= <<POD ; |
212 | |
213 | =item The type of '$name' is: |
214 | |
215 | $attr_ref->{type} |
216 | POD |
217 | |
218 | if ( exists( $attr_ref->{default} ) ) { |
219 | |
220 | my $default = $attr_ref->{default} ; |
221 | |
222 | if( ref($default) eq "ARRAY" ) { |
223 | |
224 | $default = |
225 | '(' . join( ', ', @{$default} ) . ')' ; |
226 | } |
227 | |
228 | $pod .= <<POD |
229 | |
230 | =item B<Default> value: |
231 | |
232 | $default |
233 | POD |
234 | } |
235 | |
236 | exists( $attr_ref->{required} ) and $pod .= <<POD ; |
237 | |
238 | =item It is B<required>. |
239 | POD |
240 | |
241 | foreach my $attr ( sort keys %{ $attr_ref } ) { |
242 | next if $is_attr_part{ $attr } ; |
243 | $pod .= "Unknown attribute $attr\n" ; |
244 | } |
245 | |
246 | $pod .= <<POD ; |
247 | |
248 | =back |
249 | |
250 | POD |
251 | } |
252 | |
253 | $pod .= <<POD ; |
254 | |
255 | =back |
256 | |
257 | =cut |
258 | |
259 | # End of autogenerated POD |
260 | ########### |
261 | |
262 | POD |
263 | |
264 | #print "[$pod]" ; |
265 | #print "POD2 [", substr($pod, 0, 40), "]\n" ; |
266 | |
267 | return "$attr_text\n\n$pod" ; |
268 | } |
269 | |
270 | sub update_sub_pod { |
271 | |
272 | my( $cut_text, $name ) = @_ ; |
273 | |
274 | #print "SUB [$cut_text][$name]\n" ; |
275 | |
276 | if ( $cut_text =~ /^=cut\s*$/m || $name =~ /^_/ ) { |
277 | |
278 | #print "SUB1 [${cut_text}sub $name ]\n" if $name eq 'new' ; |
279 | #dump_new( 'POD FOUND', $cut_text ) ; |
280 | |
281 | return "${cut_text}sub $name " ; |
282 | } |
283 | |
284 | #print "NO SUB POD for $name\n" ; |
285 | |
286 | my $desc = get_sub_pod( $name ) ; |
287 | |
288 | #dump_new( 'CUT', $cut_text ) ; |
289 | #dump_new( 'DESC', $desc ) ; |
290 | #print "CUT2 [$cut_text]\nDESC [$desc]\n" if $name eq 'new' ; |
291 | |
292 | my $pod = <<POD ; |
293 | $cut_text$desc |
294 | =cut |
295 | |
296 | sub $name |
297 | POD |
298 | |
299 | chomp $pod ; |
300 | |
301 | #print "SUB2 [$pod]\n" if $name eq 'new' ; |
302 | |
303 | return $pod ; |
304 | } |
305 | |
306 | sub get_sub_pod { |
307 | |
308 | my ( $name ) = @_ ; |
309 | |
310 | return <<POD if $name eq 'new' ; |
311 | =head3 Constructor - B<new> |
312 | |
313 | The B<new> method creates an object of the class B<$package>. |
314 | |
315 | POD |
316 | |
317 | return <<POD if $name eq 'msg_in' ; |
318 | =head3 Message Handler - B<msg_in> |
319 | |
320 | The B<msg_in> method is effectively a default method for message |
321 | delivery. If any message to this cell can't be delivered to another |
322 | method, then it will be delivered to the B<msg_in> method. If a |
323 | command message is delivered and a value is returned by B<msg_in>, a |
324 | response message is sent back to the originating cell with that value. |
325 | POD |
326 | |
327 | return <<POD if $name =~ /(\w+)_in$/ ; |
328 | =head3 Message Handler - $name |
329 | |
330 | B<$1> type messages are delivered to this method. Its return value is |
331 | ignored by the message delivery system. |
332 | POD |
333 | |
334 | return <<POD if $name =~ /(\w+)_cmd$/ ; |
335 | =head3 Command Message Handler - $name |
336 | |
337 | B<$1> command messages are delivered to this method. If any value is |
338 | returned, the message delivery system will create a response type |
339 | message and dispatch it back to the sending cell. |
340 | POD |
341 | |
342 | return <<POD ; |
343 | =head3 Method - $name |
344 | POD |
345 | |
346 | } |
347 | |
348 | sub update_trailing_pod { |
349 | |
350 | my( $tail_text ) = @_ ; |
351 | |
352 | # return $tail_text if $tail_text =~ /=cut/ ; |
353 | |
354 | #print "1 [$tail_text]\n" ; |
355 | |
356 | return <<POD ; |
357 | |
358 | =head1 Bugs |
359 | |
360 | =head1 Todo |
361 | |
362 | =head1 See Also |
363 | |
364 | =head1 Author |
365 | |
366 | Uri Guttman, E<lt>uri\@stemsystems.comE<gt> |
367 | |
368 | =cut |
369 | |
370 | 1 ; |
371 | POD |
372 | |
373 | } |
374 | |
375 | sub read_file { |
376 | |
377 | my( $file_name ) = shift ; |
378 | |
379 | local( *FH ) ; |
380 | open( FH, $file_name ) || carp "can't open $file_name $!" ; |
381 | |
382 | return <FH> if wantarray ; |
383 | |
384 | my $buf ; |
385 | |
386 | sysread( FH, $buf, -s FH ) ; |
387 | return $buf ; |
388 | } |
389 | |
390 | sub write_file { |
391 | |
392 | my( $file_name ) = shift ; |
393 | |
394 | local( *FH ) ; |
395 | |
396 | open( FH, ">$file_name" ) || carp "can't create $file_name $!" ; |
397 | |
398 | print FH @_ ; |
399 | } |
400 | |
401 | sub dump_attr { |
402 | |
403 | my( $key, $text ) = @_ ; |
404 | |
405 | $text =~ /(;\s+#{3,})/s or return ; |
406 | |
407 | print "$key [$1]\n" ; |
408 | } |
409 | |
410 | __END__ |