File Coverage

blib/lib/Class/CodeStyler.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

# vim:ts=4 sw=4
# ----------------------------------------------------------------------------------------------------
#  Name		: Class::CodeStyler.pm
#  Created	: 24 April 2006
#  Author	: Mario Gaffiero (gaffie)
#
# Copyright 2006-2007 Mario Gaffiero.
#
# This file is part of Class::CodeStyler(TM).
#
# Class::CodeStyler is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# Class::CodeStyler is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Class::CodeStyler; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
# ----------------------------------------------------------------------------------------------------
# Modification History
# When          Version     Who     What
# ----------------------------------------------------------------------------------------------------
package Class::CodeStyler;
require 5.005_62;
use strict;
use warnings;
use vars qw($VERSION $BUILD);
$VERSION = 0.27;
$BUILD = 'Tue May 01 18:32:42 GMTDT 2007';
use Carp qw(confess);
use stl;
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::Element::Abstract;
	use base qw(Class::STL::Element);
	use Class::STL::ClassMembers qw(owner);
	use Class::STL::ClassMembers::Constructor;
	sub prepare
	{
		confess __PACKAGE__ . "::prepare() -- pure virtual function must be overridden.";
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::CodeText;
	use base qw(Class::STL::Containers::Stack);
	use Class::STL::ClassMembers
		Class::STL::ClassMembers::DataMember->new(name => 'newline_is_on',	default => 1),
		Class::STL::ClassMembers::DataMember->new(name => 'indent_is_on', default => 1),
		Class::STL::ClassMembers::DataMember->new(name => '_indent_next', default => 1),
		Class::STL::ClassMembers::DataMember->new(name => 'current_tab', default => 0),
		Class::STL::ClassMembers::DataMember->new(name => 'tab_type', default => 'spaces', validate => '(hard|spaces)'),
		Class::STL::ClassMembers::DataMember->new(name => 'tab_size', default => 2),
		Class::STL::ClassMembers::DataMember->new(name => 'debug', default => 0),
		Class::STL::ClassMembers::DataMember->new(name => 'raw_is_on', default => 0);
	use Class::STL::ClassMembers::Constructor;
	sub append_newline
	{
		my $self = shift;
		return if ($self->raw_is_on());
		$self->push($self->factory(data => "\n"));
		$self->_indent_next(1);
		print STDERR "NEWLINE:\n" if ($self->debug());
	}
	sub append_text
	{
		my $self = shift;
		my $code = shift || '';
		$self->push($self->factory(data => $self->current_indent() . $code));
		print STDERR "CODE   :@{[ $self->current_indent() ]}${code}\n" if ($self->debug());
		$self->_indent_next(0);
	}
	sub current_indent
	{
		my $self = shift;
		return '' if ($self->raw_is_on());
		return '' if (!$self->indent_is_on());
		return '' unless ($self->_indent_next());
		my $tabchar = $self->tab_type() eq 'hard' ? "\t" : ' ';
		return ($tabchar x ($self->current_tab() * $self->tab_size()));
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::FindName;
	use base qw(Class::STL::Utilities::FunctionObject::UnaryFunction);
	use Class::STL::ClassMembers qw( name );
	use Class::STL::ClassMembers::Constructor;
	sub function_operator
	{
		my $self = shift;
		my $arg = shift; # element object
		return $arg->program_name() eq $self->name() ? $arg : 0;
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::Program::Abstract;
	use base qw(Class::CodeStyler::Element::Abstract);
	use stl qw( find_if stack list iterator find for_each mem_fun );
	use UNIVERSAL qw(isa can);
	use Class::STL::ClassMembers
	(
		qw(
			program_name segments code_text
			_bracket_stack _parent _insert_point _jump_stack _over_stack _anchor_stack
		),
		Class::STL::ClassMembers::DataMember->new(name => 'suppress_comments', default => 0),
		Class::STL::ClassMembers::DataMember->new(name => 'tab_size', default => 2),
		Class::STL::ClassMembers::DataMember->new(name => 'tab_type', default => 'spaces', validate => '(hard|spaces)'),
		Class::STL::ClassMembers::DataMember->new(name => 'debug', default => 0),
		Class::STL::ClassMembers::DataMember->new(name => 'divider_length', default => 70),
		Class::STL::ClassMembers::DataMember->new(name => 'divider_char', default => '-'),
		Class::STL::ClassMembers::DataMember->new(name => 'comment_start_char', default => '#'),
		Class::STL::ClassMembers::DataMember->new(name => 'comment_block_begin_char', default => ''),
		Class::STL::ClassMembers::DataMember->new(name => 'comment_block_end_char', default => ''),
		Class::STL::ClassMembers::DataMember->new(name => 'comment_block_char', default => ''),
		Class::STL::ClassMembers::DataMember->new(name => 'disable_newline', default => 0),
		Class::STL::ClassMembers::DataMember->new(name => 'print_bookmarks', default => 0),
		Class::STL::ClassMembers::DataMember->new(name => 'open_block_on_newline', default => 1),
	);
	use Class::STL::ClassMembers::Constructor;
	sub exists
	{
		my $self = shift;
		my $name = shift;
		my @l = grep($_->program_name() eq $name, $self->to_array());
		return $l[0] if (@l);
		return 0;
	}
#?	sub exists #TODO: memleak? slow?
#?	{
#?		my $self = shift;
#?		my $name = shift;
#?		my $s;
#?		return $s->p_element()
#?			if ($s = find_if($self->segments()->begin(), $self->segments()->end(),
#?				Class::CodeStyler::FindName->new(name => $name)));
#?		return 0;
#?	}
	sub new_extra
	{
		my $self = shift;
		$self->code_text(Class::CodeStyler::CodeText->new(
				debug => $self->debug(),
				tab_size => $self->tab_size(),
				tab_type => $self->tab_type(),
			))
			unless (defined($self->code_text()));
		$self->segments(list(element_type => 'Class::CodeStyler::Element::Abstract'));
		$self->_bracket_stack(stack());
		$self->_jump_stack(stack());
		$self->_anchor_stack(stack());
		$self->_over_stack(stack());
		$self->_insert_point(iterator($self->segments()->begin()));
		return $self;
	}
	sub add
	{
		my $self = shift;
		foreach my $code (@_)
		{
			confess "@{[ __PACKAGE__ ]}->add(): Undefined object!" unless (defined($code));
			if (ref($code) && $code->isa(__PACKAGE__))
			{
				$code->code_text($self->code_text());
				$code->_parent($self);
				map
				(
					$self->add($_),
					grep
					(
						!$_->isa('Class::CodeStyler::Bookmark') || !find($self->segments()->begin(), $self->segments()->end(), $_->data()),
						$code->segments()->to_array()
					)
				);
				next;
			}
			elsif (ref($code) && $code->isa('Class::CodeStyler::Element::Abstract'))
			{
				$code->owner($self);
				$self->segments()->insert($self->_insert_point(), 1, $code);
			}
			elsif (!ref($code))
			{
				$self->add(Class::CodeStyler::Code->new(code => $code));
				next;
			}
			else
			{
				next;
			}
		}
	}
	sub code
	{
		my $self = shift;
		my $code = @_ ? shift : '';
		$self->add(Class::CodeStyler::Code->new(code => $code));
	}
	sub open_block
	{
		my $self = shift;
		my $bracket = shift || '{';
		my %_bracket_pairs = ( '(' => ')', '{' => '}', '[' => ']', '<' => '>' );
		$self->add(Class::CodeStyler::OpenBlock->new(bracket_char => $bracket));
		$self->_bracket_stack()->push($self->_bracket_stack()->factory($_bracket_pairs{$bracket}));
		return;
	}
	sub close_block
	{
		my $self = shift;
		return unless ($self->_bracket_stack()->size()); #ignore unmatched 'open_block'
		my $bracket = $self->_bracket_stack()->top()->data();
		$self->_bracket_stack()->pop();
		$self->add(Class::CodeStyler::CloseBlock->new(bracket_char => $bracket));
		return;
	}
	sub newline_on
	{
		my $self = shift;
		$self->add(Class::CodeStyler::ToggleNewline->new(on => 1));
	}
	sub newline_off
	{
		my $self = shift;
		$self->add(Class::CodeStyler::ToggleNewline->new(on => 0));
	}
	sub indent_on
	{
		my $self = shift;
		$self->add(Class::CodeStyler::ToggleIndent->new(on => 1));
	}
	sub indent_off
	{
		my $self = shift;
		$self->add(Class::CodeStyler::ToggleIndent->new(on => 0));
	}
	sub over
	{
		my $self = shift;
		my $indent = shift || 1;
		$self->add(Class::CodeStyler::Indent->new(indent => $indent));
		$self->_over_stack()->push($self->_over_stack()->factory($indent));
		return;
	}
	sub back
	{
		my $self = shift;
		return unless ($self->_over_stack()->size()); #ignore unmatched 'back'
		$self->add(Class::CodeStyler::Indent->new(indent => -($self->_over_stack()->top()->data())));
		$self->_over_stack()->pop();
		return;
	}
	sub comment
	{
		my $self = shift;
		my $txt = shift;
		$self->add(Class::CodeStyler::Comment->new(data => $txt));
	}
	sub divider
	{
		my $self = shift;
		$self->add(Class::CodeStyler::Divider->new());
	}
	sub anchor_set
	{
		my $self = shift;
		$self->add(Class::CodeStyler::Anchor->new(data => "@{[
				$self->_insert_point()->at_end()
					? $self->_insert_point()->p_container()->size()
					: $self->_insert_point()->arr_idx()
			]}"));
		$self->_anchor_stack()->push($self->_insert_point()->prev()->clone());
	}
	sub anchor_return
	{
		my $self = shift;
		return unless($self->_anchor_stack()->size());
		$self->_insert_point($self->_anchor_stack()->top()->clone());
		$self->_anchor_stack()->pop();
	}
	sub bookmark
	{
		my $self = shift;
		my $id = shift;
		$self->add(Class::CodeStyler::Bookmark->new(data => $id));
	}
	sub jump
	{
		my $self = shift;
		my $id = shift;
		my $found;
		#TODO: potential bug if comment.data same as bookmark.data (id)!
		if ($found = find($self->segments()->begin(), $self->segments()->end(), $id))
		{
			$self->_jump_stack()->push($self->_insert_point()->clone());
			$self->_insert_point($found);
			return $found;
		}
		return 0;
	}
	sub return
	{
		my $self = shift;
		return unless($self->_jump_stack()->size());
		$self->_insert_point($self->_jump_stack()->top()->clone());
		$self->_jump_stack()->pop();
	}
	sub clear
	{
		my $self = shift;
		$self->code_text()->clear();
		return $self;
	}
	sub prepare
	{
		my $self = shift;
		# This works because all 'segments' elements are (ultimately) derived
		# from Class::CodeStyler::Element::Abstract. Recursion via this prepare() will
		# occure if the element is a Class::CodeStyler::Program.
#?		for_each($self->segments()->begin(), $self->segments()->end(), mem_fun('prepare')); #TODO: memleak? slow?
		map($_->prepare(), $self->segments()->to_array());
		return $self;
	}
	sub print
	{
		my $self = shift;
		return $self->code_text()->join('');
		# Class::STL::Containers function -- joins print() return for all elements;
	}
	sub raw
	{
		my $self = shift;
		$self->code_text()->raw_is_on(1);
		$self->code_text()->clear();
		$self->prepare();
		my $txt = $self->print();
		$self->code_text()->raw_is_on('0');
		return $txt;
	}
	sub save
	{
		my $self = shift;
		my $filename = shift || $self->program_name();
		confess "save() -- Unable to save -- 'program_name' is not defined."
			unless defined($filename);
		open(SAVE, ">@{[ $filename ]}");
		print SAVE $self->print();
	}
	sub display
	{
		my $self = shift;
		my $line_number = 1;
		my @p;
		foreach (split(/\n/, $self->print()))
		{
			push(@p, sprintf(" %5d %s", $line_number++, $_));
		}
		return join("\n", @p);
	}
	sub syntax_check
	{
		my $self = shift;
		$self->save("@{[ $self->program_name() ]}.DEBUG");
		my $check = `perl -cw @{[ $self->program_name() ]}.DEBUG 2>&1`;
		chomp($check);
		if ($check !~ /syntax OK/i)
		{
			$self->code("__END__");
			$self->code("Syntax check summary follows:");
			$self->code("$check");
			$self->clear();
			$self->prepare();
			$self->save("@{[ $self->program_name() ]}.DEBUG");
		}
		else
		{
			unlink "@{[ $self->program_name() ]}.DEBUG";
		}
		return $check;
	}
	sub exec
	{
		my $self = shift;
		$self->save("@{[ $self->program_name() ]}.EXEC");
		exec("perl @{[ $self->program_name() ]}.EXEC");
	}
	sub run
	{
		my $self = shift;
		$self->save("@{[ $self->program_name() ]}.EXEC");
		system("perl @{[ $self->program_name() ]}.EXEC");
	}
	sub eval
	{
		my $self = shift;
		my $code = $self->print();
		eval($code);
		confess "**Error in eval:\n$@" if ($@);
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::Program::Perl;
	use base qw(Class::CodeStyler::Program::Abstract);
	use Class::STL::ClassMembers;
	use Class::STL::ClassMembers::Constructor;
	sub new_extra
	{
		my $self = shift;
		$self->comment_start_char('#');
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::Program::C;
	use base qw(Class::CodeStyler::Program::Abstract);
	use Class::STL::ClassMembers;
	use Class::STL::ClassMembers::Constructor;
	sub new_extra
	{
		my $self = shift;
		$self->comment_start_char('//');
		$self->comment_block_begin_char('/*');
		$self->comment_block_char      (' *');
		$self->comment_block_end_char  (' */');
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::Program::Pod;
	use base qw(Class::CodeStyler::Program::Abstract);
	use Class::STL::ClassMembers qw( title version type user_email author pdf );
	use Class::STL::ClassMembers::Constructor;
	sub new_extra
	{
		my $self = shift;
		$self->comment_start_char('=cut ');
		$self->code("=pod");
		$self->code();
	}
	sub head1
	{
		my $self = shift;
		my $code = shift || '';
		$self->code('=head1 ' . $code);
		$self->code();
	}
	sub head2
	{
		my $self = shift;
		my $code = shift || '';
		$self->code('=head2 ' . $code);
		$self->code();
	}
	sub head3
	{
		my $self = shift;
		my $code = shift || '';
		$self->code('=head3 ' . $code);
		$self->code();
	}
	sub head4
	{
		my $self = shift;
		my $code = shift || '';
		$self->code('=head4 ' . $code);
		$self->code();
	}
	sub begin
	{
		my $self = shift;
		my $code = shift || '';
		$self->code('=begin ' . $code);
		$self->code();
	}
	sub end
	{
		my $self = shift;
		my $code = shift || '';
		$self->code('=end ' . $code);
		$self->code();
	}
	sub item
	{
		my $self = shift;
		my $code = shift || '';
		$self->code();
		$self->code('=item ' . $code);
		$self->code();
	}
	sub literal
	{
		my $self = shift;
		my $code = shift || '';
		$self->code(' ' . $code);
		$self->code();
	}
	sub page
	{
		my $self = shift;
		$self->code('=page');
		$self->code();
	}
	sub over
	{
		my $self = shift;
		my $indent = shift;
		$self->code("=over @{[ defined($indent) ? $indent : '' ]}");
		$self->code();
	}
	sub back
	{
		my $self = shift;
		$self->code('=back ');
		$self->code();
	}
	sub to_pdf
	{
#>		$self->pdf(Class::CodeStyler::Pod2Pdf->new(
#>			title => $self->title(),
#>			version => $self->version(),
#>			type => $self->type(),
#>			email => $self->user_email(),
#>			author => $self->author(),
#>		));
#>		$self->pdf()->produce();
	}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::CodeStyler::Anchor;
use base qw(Class::CodeStyler::Element::Abstract);
	use Class::STL::ClassMembers;
	use Class::STL::ClassMembers::Constructor;
	sub prepare
	{
		my $self = shift;
		return unless ($self->owner()->print_bookmarks());
		return if ($self->owner()->code_text()->raw_is_on());
		$self->owner()->code_text()->append_text("# ANCHOR ---- @{[ $self->data() ]}");
		$self->owner()->code_text()->append_newline();
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::Bookmark;
	use base qw(Class::CodeStyler::Element::Abstract);
	use Class::STL::ClassMembers;
	use Class::STL::ClassMembers::Constructor;
	sub prepare
	{
		my $self = shift;
		return unless ($self->owner()->print_bookmarks());
		return if ($self->owner()->code_text()->raw_is_on());
		$self->owner()->code_text()->append_text("# BOOKMARK ---- @{[ $self->data() ]}");
		$self->owner()->code_text()->append_newline();
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::OpenBlock;
	use base qw(Class::CodeStyler::Element::Abstract);
	use Class::STL::ClassMembers qw(bracket_char);
	use Class::STL::ClassMembers::Constructor;
	sub prepare
	{
		my $self = shift;
		$self->owner()->code_text()->append_text($self->bracket_char());
		return unless ($self->owner()->code_text()->newline_is_on());
		$self->owner()->code_text()->current_tab($self->owner()->code_text()->current_tab()+1);
		$self->owner()->code_text()->append_newline();
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::CloseBlock;
	use base qw(Class::CodeStyler::Element::Abstract);
	use Class::STL::ClassMembers qw(bracket_char);
	use Class::STL::ClassMembers::Constructor;
	sub prepare
	{
		my $self = shift;
		$self->owner()->code_text()->current_tab($self->owner()->code_text()->current_tab()-1) if ($self->owner()->code_text()->newline_is_on());
		$self->owner()->code_text()->append_text($self->bracket_char());
		$self->owner()->code_text()->append_newline() if ($self->owner()->code_text()->newline_is_on());
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::Code;
	use base qw(Class::CodeStyler::Element::Abstract);
	use Class::STL::ClassMembers qw(code);
	use Class::STL::ClassMembers::Constructor;
	sub prepare
	{
		my $self = shift;
		confess "Undefined 'owner' (@{[ $self->code() ]})!" unless (defined($self->owner()));
		$self->owner()->code_text()->append_text($self->code());
		$self->owner()->code_text()->append_newline() if ($self->owner()->code_text()->newline_is_on());
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::Comment;
	use base qw(Class::CodeStyler::Element::Abstract);
	use Class::STL::ClassMembers;
	use Class::STL::ClassMembers::Constructor;
	sub prepare
	{
		my $self = shift;
#>		return if ($self->owner()->code_text()->raw_is_on());
		$self->owner()->code_text()->append_text($self->owner()->comment_start_char() . $self->data());
		$self->owner()->code_text()->append_newline() if ($self->owner()->code_text()->newline_is_on());
	}
}
# ----------------------------------------------------------------------------------------------------
{#TODO:
	package Class::CodeStyler::CommentBegin;
}
# ----------------------------------------------------------------------------------------------------
{#TODO:
	package Class::CodeStyler::CommentEnd;
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::Divider;
	use base qw(Class::CodeStyler::Element::Abstract);
	use Class::STL::ClassMembers;
	use Class::STL::ClassMembers::Constructor;
	sub prepare
	{
		my $self = shift;
		$self->owner()->code_text()->append_text($self->owner()->comment_start_char());
		$self->owner()->code_text()->append_text($self->owner()->divider_char() x $self->owner()->divider_length());
		$self->owner()->code_text()->append_newline() if ($self->owner()->code_text()->newline_is_on());
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::ToggleNewline;
	use base qw(Class::CodeStyler::Element::Abstract);
	use Class::STL::ClassMembers qw(on);
	use Class::STL::ClassMembers::Constructor;
	sub prepare
	{
		my $self = shift;
		$self->owner()->code_text()->newline_is_on($self->on());
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::ToggleIndent;
	use base qw(Class::CodeStyler::Element::Abstract);
	use Class::STL::ClassMembers qw(on);
	use Class::STL::ClassMembers::Constructor;
	sub prepare
	{
		my $self = shift;
		$self->owner()->code_text()->indent_is_on($self->on());
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package Class::CodeStyler::Indent;
	use base qw(Class::CodeStyler::Element::Abstract);
	use Class::STL::ClassMembers qw(indent);
	use Class::STL::ClassMembers::Constructor;
	sub prepare
	{
		my $self = shift;
		$self->owner()->code_text()->current_tab($self->owner()->code_text()->current_tab()+$self->indent());
	}
}
# ----------------------------------------------------------------------------------------------------
#TODO: User can extend Class::CodeStyler::Element::Abstract to provide specific code-blocks...
1;