#!/usr/local/bin/perl -w
#
#	stem2pod
#
#	takes filename (a stem module) arguments and it updates their
#	pod from their attribute descriptions. it also will insert pod
#	templates for methods, subs and standard pod sections.
#
#	if a file is changed, it is written out over itself. unchanged
#	files are not touched.

use strict;

use Carp qw( carp cluck ) ;
use Data::Dumper;

#use Test::More tests => 1 ;

#$SIG{__WARN__} = sub { 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 ) ;

#print $new_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 ) ;

#	write_file( "$file_name.bak, $code_text ) ;
#	write_file( $file_name, $new_code_text ) ;

}

sub process_code_text {

	my ( $file_name, $text ) = @_ ;

	$text =~ s{
		  (
		     ^package			# start at package line
		     .+?			# the middle stuff
		     ^sub			# start of constructor
		  )
		}
		{
		  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 ) = @_ ;

#print "U1 <$attr_text>\n" ;

	( $package ) = $attr_text =~ /^package\s+([\w:]+)/ ;

	$attr_text =~ s/\n*^\#{5,}\n.+?^\#{5,}\n*//ms ;
# and print "DELETED OLD POD\n" ;

#print "U3 <$attr_text>\n" ;

	$attr_text =~ s{ (^my\s+\$attr_spec.+?^]\s*;\s*) }
		       { attr_spec_to_pod( $1, $file_name ) }gmsex ;

#dump_attr( 'ATTR', $attr_text ) ;
#print "ATTR [", substr( $attr_text, -40 ), "]\n" ;
#print "U2 [$attr_text]\n" ;

	return $attr_text ;
}

sub attr_spec_to_pod {

	my ( $attr_text, $file_name ) = @_ ;

	my $pod ;

#print "ATTR [$attr_text]\n" ;
#print "ATTR END1 [", substr( $attr_text, -30), "]\n" ;

	$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" ;

#print "ATTR2 [$attr_list_text]\n" ;
	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

#print "POD [$pod]\n" ;


	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

#print "[$pod]" ;
#print "POD2 [", substr($pod, 0, 40), "]\n" ;

	return "$attr_text\n\n$pod" ;
}

sub update_sub_pod {

	my( $cut_text, $name ) = @_ ;

#print "SUB [$cut_text][$name]\n" ;

	if ( $cut_text =~ /^=cut\s*$/m || $name =~ /^_/ ) {

#print "SUB1 [${cut_text}sub $name ]\n"  if $name eq 'new' ;
#dump_new( 'POD FOUND', $cut_text ) ;

		return "${cut_text}sub $name " ;
	}

#print "NO SUB POD for $name\n" ;

	my $desc = get_sub_pod( $name ) ;

#dump_new( 'CUT', $cut_text ) ;
#dump_new( 'DESC', $desc ) ;
#print "CUT2 [$cut_text]\nDESC [$desc]\n" if $name eq 'new' ;

	my $pod = <<POD ;
$cut_text$desc
=cut

sub $name 
POD

	chomp $pod ;

#print "SUB2 [$pod]\n" if $name eq 'new' ;

	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 $tail_text if $tail_text =~ /=cut/ ;

#print "1 [$tail_text]\n" ;

	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+#{3,})/s or return ;

	print "$key [$1]\n" ;
}

__END__