File Coverage

blib/lib/Tk/ObjectHandler.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Tk::ObjectHandler;

########################################################################
#                                                                      #
#              Tk::ObjectHandler, by Simon Parsons                     #
#                                                                      #
# This perl module is distributed under the terms of the GNU           #
# Public Licence and the Perl Artistic Licence.                        #
#                                                                      #
# Copyright (C) Simon Parsons, 2002                                    #
########################################################################

use strict;
use vars qw($VERSION $AUTOLOAD);
use Text::Wrap qw($columns wrap);
use Tk;
use Carp qw(carp croak);
$VERSION = '0.3';

use vars qw($AUTOLOAD);

sub new {
	my $class = shift;

	$class = ref($class) || $class;

	my $self = {
		'_OBJECT'   => new MainWindow(@_),
		'_COMMENT'  => '',
		'_CAN_LOOP' => 1,
	};

	bless $self, $class;

	return $self;
}

sub Loop {
	my $self = shift;

	if($self->{'_CAN_LOOP'} == 1) {
		MainLoop;
	}
}

sub add_widget {
	my $self = shift;
	my $type = shift;
	my $name = shift;

	my $class = ref($self) or croak '$self os not a valid object';

	return undef if(exists $self->{'_WIDGETS'}->{$name});

	$self->{'_WIDGETS'}->{$name} = {
		'_OBJECT' => $self->_make($type, @_),
		'_COMMENT'  => '',
		'_CAN_LOOP' => 0,
	};

	bless $self->{'_WIDGETS'}->{$name}, $class;

	return $self->{'_WIDGETS'}->{$name};
}

sub comment {
	my $self = shift;
	my $comment = shift || undef;

	$self->{'_COMMENT'} = $comment if(defined $comment);
	$self->{'_COMMENT'} =~ s/\s+/ /g;
	return $self->{'_COMMENT'} || '';
}

sub getobj {
	return $_[0]->{'_OBJECT'};
}

# Syntax (class, type', {args}
sub _make {
	my $self = shift;
	my $type = shift;

	eval "require Tk::$type;";
	require "Tk/$type.pm" unless($@);

	if($_[0] and substr($_[0],0,1) ne '-') {
		eval "require Tk::$_[0];";
		require "Tk/$_[0].pm" unless($@);
	}

	$type = $self->{'_OBJECT'}->$type(@_);

	return $type;
}

sub report {
	my $self = shift;
	my $tab = shift || 0;

	my $result = '';
	my $count = 0;

	if($tab+0 == 0) {
		$result = "Structural layout of $0\n\n";
		$result .= _make_entry($tab, ref($self->getobj), $self->{'_COMMENT'});
	} else {
		$result = '';
	}

	foreach (keys(%{$self->{'_WIDGETS'}})) {
		$result .= _make_entry($tab, "$_ - " . ref($self->{'_WIDGETS'}->{$_}->getobj), $self->{'_WIDGETS'}->{$_}->{'_COMMENT'});
		$result .= $self->{'_WIDGETS'}->{$_}->report($tab + 1);
	}
	$result .= "\n" if(keys(%{$self->{'_WIDGETS'}}));

	return $result;
}


sub _make_entry {
	my $tab = shift || 0;
	my $message_text = shift || ' ';
	my $comments = shift || ' ';

	$columns = 39; # for wrap
	my @list = split(/\n/, wrap("", "", $message_text));
	my @list2 = split(/\n/, wrap("", "", $comments));

	my $big = $#list > $#list2 ? $#list : $#list2;
	my $line = '';
	for(my $i = 0; $i <= $big; $i++) {
		if(defined $list[$i]) {
			$line .= join('', " " x $tab, $list[$i], " " x (40 - $tab - length($list[$i])));
			if(defined $list2[$i]) {
				$line .= $list2[$i];
			}
		} else {
			$line .= join('', " " x 40, $list2[$i]);
		}
		$line .= "\n";
	}
	return $line;

}


sub DESTROY {
}

sub AUTOLOAD {
	my $self = shift;
	my $type = ref($self) or croak '$self is not an object';

	my $name = $AUTOLOAD;
	$name =~ s/.*:://;

	if(exists $self->{'_WIDGETS'}->{$name}) {
		return $self->{'_WIDGETS'}->{$name};
	} else {
		return $self->{'_OBJECT'}->$name(@_);
	}
}

# Preloaded methods go here.

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__