cleaned up some debug prints
[urisagit/Stem.git] / bin / stem2pod
CommitLineData
3104a1f1 1#!/usr/bin/perl -w
4536f655 2#
3104a1f1 3# stem2pod
4536f655 4#
3104a1f1 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.)
4536f655 11#
4536f655 12
13use strict;
3104a1f1 14use warnings;
4536f655 15use Data::Dumper;
3104a1f1 16use File::Slurp;
17use Carp;
18
4536f655 19
4536f655 20
3104a1f1 21# These globals are initalized in the BEGIN block at the bottom of this file
22# Please treat as constants.
23our ( %PRE_POD, %POST_POD );
4536f655 24
3104a1f1 25# Another global/"constant"
26our %IS_ATTR_PART = map { $_ => 1 } qw(
27 name
28 type
29 help
30 default
31 required
32 class
33 class_args
34);
4536f655 35
4536f655 36
4536f655 37
3104a1f1 38for my $file_name (@ARGV) {
39 stem2pod($file_name);
4536f655 40}
3104a1f1 41exit;
4536f655 42
4536f655 43
4536f655 44
4536f655 45
3104a1f1 46sub stem2pod {
47 my ($file_name) = @_;
4536f655 48
3104a1f1 49 my $file_text = read_file($file_name);
4536f655 50
3104a1f1 51 my $attr_spec = find_attr_spec( $file_text, $file_name );
4536f655 52
3104a1f1 53 my @meth_names = find_method_names( $file_text );
4536f655 54
3104a1f1 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 );
4536f655 59
3104a1f1 60 my ($class_name) = ($file_text =~ /^package\s+([\w:]+)/m);
4536f655 61
3104a1f1 62 my $attr_pod = generate_attr_pod( $attr_spec, $file_name, $class_name );
63
64 generate_boilerplate( $file_text, $class_name );
4536f655 65
3104a1f1 66 my $new_pod = generate_pod( $attr_pod, \@meth_names, $pod_sections );
4536f655 67
3104a1f1 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 }
4536f655 74
3104a1f1 75 write_file( "$file_name.new", $new_source );
4536f655 76}
77
78
4536f655 79
4536f655 80
4536f655 81
4536f655 82
4536f655 83
4536f655 84
4536f655 85
4536f655 86
4536f655 87
4536f655 88
4536f655 89
4536f655 90
3104a1f1 91# Finds and returns a list of the names of
92# methods/subroutines found in the file
93sub find_method_names {
94 my ( $file_text ) = @_;
4536f655 95
3104a1f1 96 my @meth_names = $file_text =~ /^sub\s+([^\W_]\w*)/gm;
4536f655 97
3104a1f1 98 return @meth_names;
99}
4536f655 100
4536f655 101
4536f655 102
4536f655 103
4536f655 104
3104a1f1 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...
108sub 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}
4536f655 160
4536f655 161
162
4536f655 163
4536f655 164
4536f655 165
3104a1f1 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() )
169sub generate_pod {
170 my ( $attr_pod, $meth_names, $pod_sections ) = @_;
4536f655 171
3104a1f1 172 my $new_pod;
4536f655 173
3104a1f1 174 $new_pod .= generate_pod_sections( $pod_sections, \%PRE_POD );
4536f655 175
3104a1f1 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 }
4536f655 182
3104a1f1 183 $new_pod .= "=head1 METHODS\n\n";
184 foreach my $meth_name ( @$meth_names ) {
4536f655 185
3104a1f1 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 }
4536f655 191
3104a1f1 192 if ( $meth_name eq 'new' ) {
193 $new_pod .= strip_blank_lines( <<END_POD ) . "\n\n";
4536f655 194
3104a1f1 195This is a class method that constructs the object. It uses
196the standard Stem API of key/value attributes. These are described
197in the \$attr_spec in the module, and it's POD is auto-generated.
4536f655 198
3104a1f1 199END_POD
200 next;
201 }
4536f655 202
3104a1f1 203 if ( $meth_name eq 'msg_in' ) {
204 $new_pod .= strip_blank_lines( <<END_POD ) . "\n\n";
4536f655 205
3104a1f1 206This method is the 'wildcard' Stem message handler and it is passed a single
207argument which is a L<Stem::Msg> object. This method is called if no
208specific message handler method is found in this cell. This is missing
209specific documentation to be filled in.
4536f655 210
3104a1f1 211END_POD
212 next;
213 }
4536f655 214
3104a1f1 215 if ( $meth_name =~ /^(.+)_in$/ ) {
216 my $msg_type = $1;
217 $new_pod .= strip_blank_lines( <<END_POD ) . "\n\n";
4536f655 218
3104a1f1 219This method is a Stem message handler for messages of type $msg_type.
220It is passed a single argument which is a L<Stem::Msg> object and
221its return value is ignored. This is missing specific documentation
222to be filled in.
4536f655 223
3104a1f1 224END_POD
225 next;
226 }
4536f655 227
3104a1f1 228 if ( $meth_name =~ /^(.+)_cmd$/ ) {
229 my $cmd_type = $1;
230 $new_pod .= strip_blank_lines( <<END_POD ) . "\n\n";
4536f655 231
3104a1f1 232This method is a Stem message handler for command messages of type $cmd_type.
233It is passed a single argument which is a L<Stem::Msg> object.
234Any return value will be sent back as a 'response' type message to the sender.
235This is missing specific documentation to be filled in.
4536f655 236
3104a1f1 237END_POD
238 next;
239 }
4536f655 240
3104a1f1 241 # All other methods just get this...
242 $new_pod .= "This method is missing documentation\n\n";
243 }
4536f655 244
3104a1f1 245 $new_pod .= generate_pod_sections( $pod_sections, \%POST_POD );
246
247 $new_pod .= "=cut\n\n";
4536f655 248
3104a1f1 249 return $new_pod;
250}
4536f655 251
4536f655 252
3104a1f1 253sub generate_pod_sections {
254 my ($existing_pod, $bp_pod) = @_;
255
256 my $new_pod;
4536f655 257
3104a1f1 258 foreach my $section ( @{ $bp_pod->{names} } ) {
4536f655 259
3104a1f1 260 (my $printable_section = $section) =~ tr/_/ /;
261 $new_pod .= "=head1 $printable_section\n\n";
4536f655 262
3104a1f1 263 my $found_sec = $existing_pod->{other}{ lc $section };
264
265 my $next_part = $found_sec ?
266 $found_sec->{body} : $bp_pod->{boilerplate}{$section} ;
4536f655 267
3104a1f1 268 $new_pod .= strip_blank_lines( $next_part ) . "\n\n";
269 }
4536f655 270
3104a1f1 271 return $new_pod;
272}
4536f655 273
4536f655 274
3104a1f1 275sub generate_boilerplate {
276 my ($file_text, $class_name) = @_;
4536f655 277
3104a1f1 278 $PRE_POD{boilerplate}{NAME} = <<END_POD;
279$class_name
280END_POD
4536f655 281
3104a1f1 282 if ($file_text =~ /\$attr_spec/) {
283 $POST_POD{boilerplate}{SEE_ALSO} = <<END_POD;
284L<Stem::Class>
285END_POD
286 }
4536f655 287
3104a1f1 288return;
289}
4536f655 290
3104a1f1 291# strip out leading and trailing blank lines
292sub strip_blank_lines {
293 my ($text) = @_;
294 $text =~ s/\A[\n]?\s*[\n]|[\n]\s*[\n]?\z//msg;
295 return $text;
296}
4536f655 297
4536f655 298
3104a1f1 299# tries to locate the $attr_spec array ref in the text
300# and returns it as a real data structure (eval magick)
301sub find_attr_spec {
302 my ( $file_text, $file_name ) = @_;
4536f655 303
3104a1f1 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 }
4536f655 311
3104a1f1 312 return $attr_spec;
313}
4536f655 314
4536f655 315
4536f655 316
3104a1f1 317
318# blow away __END__ and everything after (if present)
319# and replace with generated POD
320sub 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;
4536f655 326}
327
4536f655 328
4536f655 329
4536f655 330
4536f655 331
4536f655 332
4536f655 333
4536f655 334
3104a1f1 335# Stolen from uri's original script, but really,
336# really needs to be cleaned up...
337# TODO: clean up this sub, somehow...
338sub generate_attr_pod {
339 my ( $attr_list, $file_name, $package ) = @_;
4536f655 340
3104a1f1 341 my $pod .= <<POD ;
4536f655 342
3104a1f1 343=head2 Class Attributes for $package
344
345This pod is generated from the \$attr_spec in the module.
346That data is also used by L<Stem::Class> to parse the arguments
347passed to the class constructor new().
348
349=over 4
4536f655 350
4536f655 351POD
352
3104a1f1 353 #print "POD [$pod]\n" ;
4536f655 354
3104a1f1 355 foreach my $attr_ref ( @{$attr_list} ) {
4536f655 356
3104a1f1 357 my $name = $attr_ref->{name};
358
359 unless ($name) {
4536f655 360
3104a1f1 361 warn <<WARN ;
362Missing attribute name in Class $package in file $file_name
363WARN
364 next;
365 }
4536f655 366
3104a1f1 367 $pod .= <<POD ;
4536f655 368
3104a1f1 369=item * B<$name>
4536f655 370
3104a1f1 371=over 4
4536f655 372
373POD
374
3104a1f1 375 my $help = $attr_ref->{help};
4536f655 376
3104a1f1 377 unless ( defined($help) ) {
378 warn <<WARN ;
379Missing help in attribute $name in Class $package in file $file_name
380WARN
381 next;
382 }
4536f655 383
3104a1f1 384 $pod .= <<POD ;
4536f655 385
3104a1f1 386=item - $help
4536f655 387POD
3104a1f1 388# suppress line break in POD output after description
389 chomp $pod;
390
391 if ( my $attr_class = $attr_ref->{class} ) {
4536f655 392
3104a1f1 393 my $class_args =
394 '<' . join( ', ', @{ $attr_ref->{class_args} || [] } ) . '>';
4536f655 395
3104a1f1 396 $pod .= <<POD ;
397=item - Class Attribute: '$name' is an object of class $attr_class and constructed with: $class_args
4536f655 398POD
3104a1f1 399 }
4536f655 400
3104a1f1 401 exists( $attr_ref->{type} ) and $pod .= <<POD ;
402
403=item - The type of '$name' is: $attr_ref->{type}
4536f655 404POD
405
3104a1f1 406 if ( exists( $attr_ref->{default} ) ) {
4536f655 407
3104a1f1 408 my $default = $attr_ref->{default};
4536f655 409
3104a1f1 410 if ( ref($default) eq "ARRAY" ) {
4536f655 411
3104a1f1 412 $default = '(' . join( ', ', @{$default} ) . ')';
413 }
4536f655 414
3104a1f1 415 $pod .= <<POD
4536f655 416
3104a1f1 417=item - B<Default> value: $default
418POD
419 }
4536f655 420
3104a1f1 421 exists( $attr_ref->{required} ) and $pod .= <<POD ;
4536f655 422
3104a1f1 423=item - It is B<required>.
424POD
4536f655 425
3104a1f1 426 foreach my $attr ( sort keys %{$attr_ref} ) {
427 next if $IS_ATTR_PART{$attr};
428 $pod .= "Unknown attribute $attr\n";
429 }
4536f655 430
3104a1f1 431 $pod .= <<POD ;
432
433=back
434
435POD
436 }
4536f655 437
3104a1f1 438 $pod .= <<POD ;
439
440=back
4536f655 441
442=cut
443
4536f655 444POD
445
3104a1f1 446 #print "[$pod]" ;
447
448 #print "POD2 [", substr($pod, 0, 40), "]\n" ;
449
450 return $pod;
4536f655 451}
452
4536f655 453
4536f655 454
4536f655 455
4536f655 456
4536f655 457
4536f655 458
4536f655 459
4536f655 460
4536f655 461
4536f655 462
3104a1f1 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.
465BEGIN {
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',
478Name of module
479END_POD
480
481 SYNOPSIS => <<'END_POD',
482Code/config example
483END_POD
484
485 DESCRIPTION => <<'END_POD',
486What is this module good for?
487END_POD
488
489 );
490
491
492 # Boilerplate for each "post" section
493 my %POST_POD_BP = (
494
495 BUGS => <<'END_POD',
496None
497END_POD
498
499 TODO => <<'END_POD',
500END_POD
501
502 SEE_ALSO => <<'END_POD',
503END_POD
504
505 AUTHOR => <<'END_POD',
506Uri Guttman uri@cpan.org
507END_POD
508
509 LICENSE => <<'END_POD',
510Same as Perl
511END_POD
512
513 COPYRIGHT => <<'END_POD',
514(C) Uri Guttman, 2009
515END_POD
516
517 );
4536f655 518
4536f655 519
3104a1f1 520 # globals used in other parts of the program
521 %PRE_POD = (
522 names => \@PRE_POD_NAMES,
523 boilerplate => \%PRE_POD_BP,
524 );
4536f655 525
3104a1f1 526 %POST_POD = (
527 names => \@POST_POD_NAMES,
528 boilerplate => \%POST_POD_BP,
529 );
4536f655 530
4536f655 531}
532