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