#!/usr/local/bin/perl -w
use Carp qw( carp cluck ) ;my $changed ;
my $package ;
my %is_attr_part = map { $_ => 1 } qw(
name
type
help
default
required
class
class_args
) ;
foreach my $file_name ( @ARGV ) {
process_source_file( $file_name ) ;
}
exit ;
sub process_source_file {
my ( $file_name ) = @_ ;
my $code_text = read_file( $file_name ) ;
my $new_code_text = process_code_text( $file_name, $code_text ) ;
if ( $new_code_text eq $code_text ) {
print "$file_name SAME\n" ;
return ;
}
print "$file_name CHANGED\n" ;
write_file( "$file_name.new, $new_code_text ) ;
}
sub process_code_text {
my ( $file_name, $text ) = @_ ;
$text =~ s{
(
^package
.+?
^sub
)
}
{
update_attr_spec( $1, $file_name )
}mgsex ;
$text =~ s{
(.{0,20}?)
^sub
\s+
(\w+)
\s*
}
{ update_sub_pod( $1, $2 ) }mgsex ;
unless( $text =~ /^=cut\s*^\s*1\s*;\s*/m ) {
$text =~ s{^\s*1\s*;\s*$}{ update_trailing_pod() }mex ;
}
return $text ;
}
sub update_attr_spec {
my( $attr_text, $file_name ) = @_ ;
( $package ) = $attr_text =~ /^package\s+([\w:]+)/ ;
$attr_text =~ s/\n*^\
$attr_text =~ s{ (^my\s+\$attr_spec.+?^]\s*;\s*) }
{ attr_spec_to_pod( $1, $file_name ) }gmsex ;
return $attr_text ;
}
sub attr_spec_to_pod {
my ( $attr_text, $file_name ) = @_ ;
my $pod ;
$attr_text =~ s/\s*\z// ;
my( $attr_list_text ) =
$attr_text =~ /^my\s+\$attr_spec.+?=(.+?^\])/ms ;
$attr_list_text or die
"can't parse out attr list from file $file_name class $package" ;
my $attr_list = eval $attr_list_text ;
$pod .= <<POD ;
###########
# This POD section is autogenerated. Any edits to it will be lost.
=head2 Class Attributes for $package
=over 4
POD
foreach my $attr_ref ( @{$attr_list} ) {
my $name = $attr_ref->{name} ;
if ( $name ) {
$pod .= <<POD ;
=item * Attribute - B<$name>
=over 4
POD
}
else {
warn <<WARN ;
Missing attribute name in Class $package in file $file_name
WARN
next ;
}
my $help = $attr_ref->{help} ;
if ( defined( $help ) ) {
$pod .= <<POD ;
=item Description:
$help
POD
}
else {
warn <<WARN ;
Missing help in attribute $name in Class $package in file $file_name
WARN
}
if ( my $attr_class = $attr_ref->{class} ) {
my $class_args = '<' .
join( ', ', @{$attr_ref->{class_args} || []} )
. '>' ;
$pod .= <<POD ;
=item Class Attribute:
'$name' is an object of class $attr_class and constructed with:
$class_args
POD
}
exists( $attr_ref->{type} ) and $pod .= <<POD ;
=item The type of '$name' is:
$attr_ref->{type}
POD
if ( exists( $attr_ref->{default} ) ) {
my $default = $attr_ref->{default} ;
if( ref($default) eq "ARRAY" ) {
$default =
'(' . join( ', ', @{$default} ) . ')' ;
}
$pod .= <<POD
=item B<Default> value:
$default
POD
}
exists( $attr_ref->{required} ) and $pod .= <<POD ;
=item It is B<required>.
POD
foreach my $attr ( sort keys %{ $attr_ref } ) {
next if $is_attr_part{ $attr } ;
$pod .= "Unknown attribute $attr\n" ;
}
$pod .= <<POD ;
=back
POD
}
$pod .= <<POD ;
=back
=cut
# End of autogenerated POD
###########
POD
return "$attr_text\n\n$pod" ;
}
sub update_sub_pod {
my( $cut_text, $name ) = @_ ;
if ( $cut_text =~ /^=cut\s*$/m || $name =~ /^_/ ) {
return "${cut_text}sub $name " ;
}
my $desc = get_sub_pod( $name ) ;
my $pod = <<POD ;
$cut_text$desc
=cut
sub $name
POD
chomp $pod ;
return $pod ;
}
sub get_sub_pod {
my ( $name ) = @_ ;
return <<POD if $name eq 'new' ;
=head3 Constructor - B<new>
The B<new> method creates an object of the class B<$package>.
POD
return <<POD if $name eq 'msg_in' ;
=head3 Message Handler - B<msg_in>
The B<msg_in> method is effectively a default method for message
delivery. If any message to this cell can't be delivered to another
method, then it will be delivered to the B<msg_in> method. If a
command message is delivered and a value is returned by B<msg_in>, a
response message is sent back to the originating cell with that value.
POD
return <<POD if $name =~ /(\w+)_in$/ ;
=head3 Message Handler - $name
B<$1> type messages are delivered to this method. Its return value is
ignored by the message delivery system.
POD
return <<POD if $name =~ /(\w+)_cmd$/ ;
=head3 Command Message Handler - $name
B<$1> command messages are delivered to this method. If any value is
returned, the message delivery system will create a response type
message and dispatch it back to the sending cell.
POD
return <<POD ;
=head3 Method - $name
POD
}
sub update_trailing_pod {
my( $tail_text ) = @_ ;
return <<POD ;
=head1 Bugs
=head1 Todo
=head1 See Also
=head1 Author
Uri Guttman, E<lt>uri\@stemsystems.comE<gt>
=cut
1 ;
POD
}
sub read_file {
my( $file_name ) = shift ;
local( *FH ) ;
open( FH, $file_name ) || carp "can't open $file_name $!" ;
return <FH> if wantarray ;
my $buf ;
sysread( FH, $buf, -s FH ) ;
return $buf ;
}
sub write_file {
my( $file_name ) = shift ;
local( *FH ) ;
open( FH, ">$file_name" ) || carp "can't create $file_name $!" ;
print FH @_ ;
}
sub dump_attr {
my( $key, $text ) = @_ ;
$text =~ /(;\s+
print "$key [$1]\n" ;
}