cleaned up some debug prints
[urisagit/Stem.git] / bin / stem2pod
1 #!/usr/bin/perl -w
2 #
3 #   stem2pod
4 #
5 # scans a file containing the code for a stem cell
6 # and updates it with pod generated from the cell's
7 # attribute variables.
8 #
9 # also generates pod for detected methods, subs, and
10 # any missing standard stuff (author, license, etc.)
11 #
12
13 use strict;
14 use warnings;
15 use Data::Dumper;
16 use File::Slurp;
17 use Carp;
18
19
20
21 # These globals are initalized in the BEGIN block at the bottom of this file
22 # Please treat as constants.
23 our ( %PRE_POD, %POST_POD );
24
25 # Another global/"constant"
26 our %IS_ATTR_PART = map { $_ => 1 } qw(
27   name
28   type
29   help
30   default
31   required
32   class
33   class_args
34 );
35
36
37
38 for my $file_name (@ARGV) {
39     stem2pod($file_name);
40 }
41 exit;
42
43
44
45
46 sub stem2pod {
47     my ($file_name) = @_;
48
49     my $file_text = read_file($file_name);
50
51     my $attr_spec = find_attr_spec( $file_text, $file_name );
52
53     my @meth_names = find_method_names( $file_text );
54
55     # extract_pod _literally_ extracts it - 
56     # removing any pod found from the text.
57     my $new_text = $file_text;
58     my $pod_sections = extract_pod( \$new_text, \@meth_names );
59
60     my ($class_name) = ($file_text =~ /^package\s+([\w:]+)/m);
61
62     my $attr_pod = generate_attr_pod( $attr_spec, $file_name, $class_name );
63     
64     generate_boilerplate( $file_text, $class_name );
65
66     my $new_pod = generate_pod( $attr_pod, \@meth_names, $pod_sections );
67
68     my $new_source = build_source( $new_pod, $new_text );
69
70     if ( $file_text eq $new_source ) {
71         warn "No changes to make to $file_name\n";
72         return;
73     }
74
75     write_file( "$file_name.new", $new_source );
76 }
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91 # Finds and returns a list of the names of 
92 # methods/subroutines found in the file
93 sub find_method_names {
94     my ( $file_text ) = @_;
95
96     my @meth_names = $file_text =~ /^sub\s+([^\W_]\w*)/gm;
97
98     return @meth_names;
99 }
100
101
102
103
104
105 # Find and _remove_ any POD in the file. 
106 # Returns a HoH-like data-structure that you should probably inspect
107 # with DD to see what it looks like...
108 sub extract_pod {
109     my ( $text_ref, $method_names ) = @_;
110     my %pod_sections;
111     my @pod_names;
112     while ( ${$text_ref} =~ 
113         s{
114                 ^                # begin of line
115                 (                # grab pod head line as $1
116                     =head\w* # begin pod section
117                         \s+
118                         (.+?)$   # grab section title as $2
119             )
120             (
121                         .+?      # grab pod body as $3
122                 )
123                 (?:          # match until after =cut, before =head or at EOF
124                 ^=cut
125               | (?=^=head)
126               | \z
127             )
128         }{}mxs 
129     ) {
130         my $head  = $1;
131         my $title = $2;
132         my $body  = $3;
133
134 #        # strip out leading and trailing blank lines
135 #        $body =~ s/\A[\n]\s*[\n]|[\n]\s*[\n]\z//msg;
136
137         # Does the section title contain the name of a method?
138         my ($method_name) = grep { $title =~ /$_/i and $_ } @$method_names;
139         if ( $method_name ) {
140         
141             warn "Duplicate pod section for method "
142                . "$method_name named [$title].\n"
143               if exists $pod_sections{methods}{$method_name};
144               
145             $pod_sections{methods}{$method_name}{head} = $head;  
146             $pod_sections{methods}{$method_name}{body} = $body;
147             
148             next;
149         }
150         
151         warn "Found pod section with duplicate name [$title]\n"
152           if exists $pod_sections{other}{ lc $title };
153           
154         $pod_sections{other}{ lc $title }{head} = $head;
155         $pod_sections{other}{ lc $title }{body} = $body;
156     }
157 #    print Dumper \%pod_sections; exit;
158     return \%pod_sections;
159 }
160
161
162
163
164
165
166 # Generate all the POD text in one big chunk...
167 # Fill in most sections with boilerplate, but will
168 # merge in sections that were already present ( found by extract_pod() )
169 sub generate_pod {
170     my ( $attr_pod, $meth_names, $pod_sections ) = @_;
171
172     my $new_pod;
173
174     $new_pod .= generate_pod_sections( $pod_sections, \%PRE_POD );
175
176     # attr_pod is always regenerated...
177     # TODO: perhaps it's better to call generate_attr_pod() here?
178     if ($attr_pod) {
179         $new_pod .= "=head1 ATTRIBUTES\n\n";
180         $new_pod .= strip_blank_lines( $attr_pod ) . "\n\n";
181     }
182
183     $new_pod .= "=head1 METHODS\n\n";
184     foreach my $meth_name ( @$meth_names ) {
185
186         $new_pod .= "=head2 $meth_name\n\n";
187         if ( my $meth_pod = $pod_sections->{methods}{$meth_name} ) {
188             $new_pod .= strip_blank_lines( $meth_pod->{body} ) . "\n\n";
189             next;
190         }
191
192         if ( $meth_name eq 'new' ) {
193             $new_pod .= strip_blank_lines( <<END_POD ) . "\n\n";
194
195 This is a class method that constructs the object. It uses
196 the standard Stem API of key/value attributes. These are described
197 in the \$attr_spec in the module, and it's POD is auto-generated.
198
199 END_POD
200             next;
201         }
202
203         if ( $meth_name eq 'msg_in' ) {
204             $new_pod .= strip_blank_lines( <<END_POD ) . "\n\n";
205
206 This method is the 'wildcard' Stem message handler and it is passed a single 
207 argument which is a L<Stem::Msg> object. This method is called if no 
208 specific message handler method is found in this cell. This is missing
209 specific documentation to be filled in.
210
211 END_POD
212             next;
213         }
214
215         if ( $meth_name =~ /^(.+)_in$/ ) {
216             my $msg_type = $1; 
217             $new_pod .= strip_blank_lines( <<END_POD ) . "\n\n";
218
219 This method is a Stem message handler for messages of type $msg_type.
220 It is passed a single argument which is a L<Stem::Msg> object and 
221 its return value is ignored. This is missing specific documentation 
222 to be filled in.
223
224 END_POD
225             next;
226         }
227
228         if ( $meth_name =~ /^(.+)_cmd$/ ) {
229             my $cmd_type = $1;
230             $new_pod .= strip_blank_lines( <<END_POD ) . "\n\n";
231
232 This method is a Stem message handler for command messages of type $cmd_type.
233 It is passed a single argument which is a L<Stem::Msg> object. 
234 Any return value will be sent back as a 'response' type message to the sender.
235 This is missing specific documentation to be filled in.
236
237 END_POD
238             next;
239         }
240
241         # All other methods just get this...
242         $new_pod .= "This method is missing documentation\n\n";
243     }
244
245     $new_pod .= generate_pod_sections( $pod_sections, \%POST_POD );
246     
247     $new_pod .= "=cut\n\n";
248
249     return $new_pod;
250 }
251
252
253 sub generate_pod_sections {
254     my ($existing_pod, $bp_pod) = @_;
255     
256     my $new_pod;
257
258     foreach my $section ( @{ $bp_pod->{names} } ) {
259
260         (my $printable_section = $section) =~ tr/_/ /;
261         $new_pod .= "=head1 $printable_section\n\n";
262
263         my $found_sec = $existing_pod->{other}{ lc $section };
264         
265         my $next_part = $found_sec ? 
266             $found_sec->{body} : $bp_pod->{boilerplate}{$section} ;
267
268         $new_pod .= strip_blank_lines( $next_part ) . "\n\n";
269     }
270
271     return $new_pod;
272 }
273
274
275 sub generate_boilerplate {
276     my ($file_text, $class_name) = @_;
277
278     $PRE_POD{boilerplate}{NAME} = <<END_POD;
279 $class_name
280 END_POD
281
282     if ($file_text =~ /\$attr_spec/) {
283         $POST_POD{boilerplate}{SEE_ALSO} = <<END_POD;
284 L<Stem::Class>
285 END_POD
286     }
287
288 return;
289 }
290
291 # strip out leading and trailing blank lines
292 sub strip_blank_lines {
293     my ($text) = @_;
294     $text =~ s/\A[\n]?\s*[\n]|[\n]\s*[\n]?\z//msg;
295     return $text;
296 }
297
298
299 # tries to locate the $attr_spec array ref in the text
300 # and returns it as a real data structure (eval magick)
301 sub find_attr_spec {
302     my ( $file_text, $file_name ) = @_;
303
304     # The regex below is naive but will be fine for now. I would
305     # prefer to use Text::Balanced or Regexp::Common though...
306     my $attr_spec;
307     if ( $file_text =~ /\$attr_spec\s*=\s*(\[[^\]]*\])\s*;/ ) {
308         $attr_spec = eval $1
309           or croak "Error parsing \$attr_spec from $file_name:\n$@\n";
310     }
311
312     return $attr_spec;
313 }
314
315
316
317
318 # blow away __END__ and everything after (if present) 
319 # and replace with generated POD
320 sub build_source {
321     my ( $new_pod, $file_text ) = @_;
322
323     ( my $new_text = $file_text ) =~ s/^__END__[\n].*//msg;
324
325     return $new_text . "__END__\n\n" . $new_pod;
326 }
327
328
329
330
331
332
333
334
335 # Stolen from uri's original script, but really, 
336 # really needs to be cleaned up...
337 # TODO: clean up this sub, somehow...
338 sub generate_attr_pod {
339     my ( $attr_list, $file_name, $package ) = @_;
340
341     my $pod .= <<POD ;
342
343 =head2 Class Attributes for $package
344
345 This pod is generated from the \$attr_spec in the module.
346 That data is also used by L<Stem::Class> to parse the arguments 
347 passed to the class constructor new().
348
349 =over 4
350
351 POD
352
353     #print "POD [$pod]\n" ;
354
355     foreach my $attr_ref ( @{$attr_list} ) {
356
357         my $name = $attr_ref->{name};
358
359         unless ($name) {
360
361             warn <<WARN ;
362 Missing attribute name in Class $package in file $file_name
363 WARN
364             next;
365         }
366
367         $pod .= <<POD ;
368
369 =item * B<$name>
370
371 =over 4
372
373 POD
374
375         my $help = $attr_ref->{help};
376
377         unless ( defined($help) ) {
378             warn <<WARN ;
379 Missing help in attribute $name in Class $package in file $file_name
380 WARN
381             next;
382         }
383
384         $pod .= <<POD ;
385
386 =item - $help
387 POD
388 # suppress line break in POD output after description
389         chomp $pod; 
390
391         if ( my $attr_class = $attr_ref->{class} ) {
392
393             my $class_args =
394               '<' . join( ', ', @{ $attr_ref->{class_args} || [] } ) . '>';
395
396             $pod .= <<POD ;
397 =item - Class Attribute: '$name' is an object of class $attr_class and constructed with: $class_args
398 POD
399         }
400
401         exists( $attr_ref->{type} ) and $pod .= <<POD ;
402
403 =item - The type of '$name' is: $attr_ref->{type}
404 POD
405
406         if ( exists( $attr_ref->{default} ) ) {
407
408             my $default = $attr_ref->{default};
409
410             if ( ref($default) eq "ARRAY" ) {
411
412                 $default = '(' . join( ', ', @{$default} ) . ')';
413             }
414
415             $pod .= <<POD
416
417 =item - B<Default> value: $default
418 POD
419         }
420
421         exists( $attr_ref->{required} ) and $pod .= <<POD ;
422
423 =item - It is B<required>.
424 POD
425
426         foreach my $attr ( sort keys %{$attr_ref} ) {
427             next if $IS_ATTR_PART{$attr};
428             $pod .= "Unknown attribute $attr\n";
429         }
430
431         $pod .= <<POD ;
432      
433 =back 
434   
435 POD
436     }
437
438     $pod .= <<POD ;
439
440 =back
441
442 =cut
443
444 POD
445
446     #print "[$pod]" ;
447
448     #print "POD2 [", substr($pod, 0, 40), "]\n" ;
449
450     return $pod;
451 }
452
453
454
455
456
457
458
459
460
461
462
463 # Globals declared at the top of this script are initalized here
464 # Keeping at the bottom of this file to (try to) reduce clutter.
465 BEGIN {
466
467     # Pod sections that go before attribute and method sections
468     my @PRE_POD_NAMES = qw( NAME SYNOPSIS DESCRIPTION );
469
470     # sections that go after
471     my @POST_POD_NAMES = qw( BUGS TODO SEE_ALSO AUTHOR LICENSE COPYRIGHT );
472
473
474     # Boilerplate for each "pre" section
475     my %PRE_POD_BP = (
476
477         NAME => <<'END_POD',
478 Name of module
479 END_POD
480
481         SYNOPSIS => <<'END_POD',
482 Code/config example
483 END_POD
484
485         DESCRIPTION => <<'END_POD',
486 What is this module good for?
487 END_POD
488
489     );
490
491
492     # Boilerplate for each "post" section
493     my %POST_POD_BP = (
494
495         BUGS => <<'END_POD',
496 None
497 END_POD
498
499         TODO => <<'END_POD',
500 END_POD
501
502         SEE_ALSO => <<'END_POD',
503 END_POD
504
505         AUTHOR => <<'END_POD',
506 Uri Guttman uri@cpan.org
507 END_POD
508
509         LICENSE => <<'END_POD',
510 Same as Perl
511 END_POD
512
513         COPYRIGHT => <<'END_POD',
514 (C) Uri Guttman, 2009
515 END_POD
516
517     );
518
519
520     # globals used in other parts of the program
521     %PRE_POD = (
522         names       => \@PRE_POD_NAMES,
523         boilerplate => \%PRE_POD_BP,
524     );
525
526     %POST_POD = (
527         names       => \@POST_POD_NAMES,
528         boilerplate => \%POST_POD_BP,
529     );
530
531 }
532