bin/stem2pod

   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__