1 #!/usr/local/bin/perl -w
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.
9 # if a file is changed, it is written out over itself. unchanged
10 # files are not touched.
14 use Carp qw( carp cluck ) ;
17 #use Test::More tests => 1 ;
19 #$SIG{__WARN__} = sub { cluck } ;
24 my %is_attr_part = map { $_ => 1 } qw(
34 foreach my $file_name ( @ARGV ) {
36 process_source_file( $file_name ) ;
41 sub process_source_file {
43 my ( $file_name ) = @_ ;
45 my $code_text = read_file( $file_name ) ;
47 my $new_code_text = process_code_text( $file_name, $code_text ) ;
49 #print $new_code_text ;
51 if ( $new_code_text eq $code_text ) {
53 print "$file_name SAME\n" ;
57 print "$file_name CHANGED\n" ;
59 write_file( "$file_name.new, $new_code_text ) ;
61 # write_file( "$file_name.bak, $code_text ) ;
62 # write_file( $file_name, $new_code_text ) ;
66 sub process_code_text {
68 my ( $file_name, $text ) = @_ ;
72 ^package # start at package line
73 .+? # the middle stuff
74 ^sub # start of constructor
78 update_attr_spec( $1, $file_name )
88 { update_sub_pod( $1, $2 ) }mgsex ;
90 unless( $text =~ /^=cut\s*^\s*1\s*;\s*/m ) {
92 $text =~ s{^\s*1\s*;\s*$}{ update_trailing_pod() }mex ;
99 sub update_attr_spec {
101 my( $attr_text, $file_name ) = @_ ;
103 #print "U1 <$attr_text>\n" ;
105 ( $package ) = $attr_text =~ /^package\s+([\w:]+)/ ;
107 $attr_text =~ s/\n*^\#{5,}\n.+?^\#{5,}\n*//ms ;
108 # and print "DELETED OLD POD\n" ;
110 #print "U3 <$attr_text>\n" ;
112 $attr_text =~ s{ (^my\s+\$attr_spec.+?^]\s*;\s*) }
113 { attr_spec_to_pod( $1, $file_name ) }gmsex ;
115 #dump_attr( 'ATTR', $attr_text ) ;
116 #print "ATTR [", substr( $attr_text, -40 ), "]\n" ;
117 #print "U2 [$attr_text]\n" ;
122 sub attr_spec_to_pod {
124 my ( $attr_text, $file_name ) = @_ ;
128 #print "ATTR [$attr_text]\n" ;
129 #print "ATTR END1 [", substr( $attr_text, -30), "]\n" ;
131 $attr_text =~ s/\s*\z// ;
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" ;
138 #print "ATTR2 [$attr_list_text]\n" ;
139 my $attr_list = eval $attr_list_text ;
143 # This POD section is autogenerated. Any edits to it will be lost.
145 =head2 Class Attributes for $package
151 #print "POD [$pod]\n" ;
154 foreach my $attr_ref ( @{$attr_list} ) {
156 my $name = $attr_ref->{name} ;
162 =item * Attribute - B<$name>
171 Missing attribute name in Class $package in file $file_name
177 my $help = $attr_ref->{help} ;
179 if ( defined( $help ) ) {
191 Missing help in attribute $name in Class $package in file $file_name
195 if ( my $attr_class = $attr_ref->{class} ) {
197 my $class_args = '<' .
198 join( ', ', @{$attr_ref->{class_args} || []} )
203 =item Class Attribute:
205 '$name' is an object of class $attr_class and constructed with:
211 exists( $attr_ref->{type} ) and $pod .= <<POD ;
213 =item The type of '$name' is:
218 if ( exists( $attr_ref->{default} ) ) {
220 my $default = $attr_ref->{default} ;
222 if( ref($default) eq "ARRAY" ) {
225 '(' . join( ', ', @{$default} ) . ')' ;
230 =item B<Default> value:
236 exists( $attr_ref->{required} ) and $pod .= <<POD ;
238 =item It is B<required>.
241 foreach my $attr ( sort keys %{ $attr_ref } ) {
242 next if $is_attr_part{ $attr } ;
243 $pod .= "Unknown attribute $attr\n" ;
259 # End of autogenerated POD
265 #print "POD2 [", substr($pod, 0, 40), "]\n" ;
267 return "$attr_text\n\n$pod" ;
272 my( $cut_text, $name ) = @_ ;
274 #print "SUB [$cut_text][$name]\n" ;
276 if ( $cut_text =~ /^=cut\s*$/m || $name =~ /^_/ ) {
278 #print "SUB1 [${cut_text}sub $name ]\n" if $name eq 'new' ;
279 #dump_new( 'POD FOUND', $cut_text ) ;
281 return "${cut_text}sub $name " ;
284 #print "NO SUB POD for $name\n" ;
286 my $desc = get_sub_pod( $name ) ;
288 #dump_new( 'CUT', $cut_text ) ;
289 #dump_new( 'DESC', $desc ) ;
290 #print "CUT2 [$cut_text]\nDESC [$desc]\n" if $name eq 'new' ;
301 #print "SUB2 [$pod]\n" if $name eq 'new' ;
310 return <<POD if $name eq 'new' ;
311 =head3 Constructor - B<new>
313 The B<new> method creates an object of the class B<$package>.
317 return <<POD if $name eq 'msg_in' ;
318 =head3 Message Handler - B<msg_in>
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.
327 return <<POD if $name =~ /(\w+)_in$/ ;
328 =head3 Message Handler - $name
330 B<$1> type messages are delivered to this method. Its return value is
331 ignored by the message delivery system.
334 return <<POD if $name =~ /(\w+)_cmd$/ ;
335 =head3 Command Message Handler - $name
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.
343 =head3 Method - $name
348 sub update_trailing_pod {
350 my( $tail_text ) = @_ ;
352 # return $tail_text if $tail_text =~ /=cut/ ;
354 #print "1 [$tail_text]\n" ;
366 Uri Guttman, E<lt>uri\@stemsystems.comE<gt>
377 my( $file_name ) = shift ;
380 open( FH, $file_name ) || carp "can't open $file_name $!" ;
382 return <FH> if wantarray ;
386 sysread( FH, $buf, -s FH ) ;
392 my( $file_name ) = shift ;
396 open( FH, ">$file_name" ) || carp "can't create $file_name $!" ;
403 my( $key, $text ) = @_ ;
405 $text =~ /(;\s+#{3,})/s or return ;
407 print "$key [$1]\n" ;