File Coverage

blib/lib/Tkx.pm

Criterion	Covered	Total	%
statement	10	107	9.3
branch	0	36	0.0
condition	0	20	0.0
subroutine	4	22	18.1
pod			n/a
total	14	185	7.5

package Tkx;

use strict;
our $VERSION = '1.09';

{
    # predeclare
    package Tkx::widget;
    package Tkx::i;
}

eval {
    package_require("Tk");
};
if ($@) {
    $@ =~ s/^this isn't a Tk application//;  # what crap
    die $@;
}

our $TRACE;
our $TRACE_MAX_STRING;
our $TRACE_COUNT;
our $TRACE_TIME;
our $TRACE_CALLER;

$TRACE = $ENV{PERL_TKX_TRACE} unless defined $TRACE;
$TRACE_MAX_STRING = 64 unless defined $TRACE_MAX_STRING;
$TRACE_COUNT = 1 unless defined $TRACE_COUNT;
$TRACE_TIME = 1 unless defined $TRACE_TIME;
$TRACE_CALLER = 1 unless defined $TRACE_CALLER;


sub import {
    my($class, @subs) = @_;
    my $pkg = caller;
    for (@subs) {
	s/^&//;
	if (/^[a-zA-Z]\w*/ && $_ ne "import") {
	    no strict 'refs';
	    *{"$pkg\::$_"} = \&$_;
	}
	else {
	    die qq("$_" is not exported by the $class module);
	}
    }
}

sub AUTOLOAD {
    our $AUTOLOAD;
    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
    return scalar(Tkx::i::call(Tkx::i::expand_name($method), @_));
}

sub MainLoop () {
    while (eval { local $TRACE; Tkx::i::call("winfo", "exists", ".") }) {
	Tkx::i::DoOneEvent(0);
    }
}

sub SplitList ($) {
    my $list = shift;
    unless (wantarray) {
	require Carp;
	Carp::croak("Tkx::SplitList needs list context");
    }
    return @$list if ref($list) eq "ARRAY" || ref($list) eq "Tcl::List";
    return Tkx::i::call("concat", $list);
}

*Ev = \&Tcl::Ev;

package Tkx::widget;

use overload '""' => sub { ${$_[0]} },
             fallback => 1;

my %data;
my %class;
my %mega;

sub new {
    my $class = shift;
    my $name = shift;
    return bless \$name, $class{$name} || $class;
}

sub _data {
    my $self = shift;
    return $data{$$self} ||= {};
}

sub _kid {
    my($self, $name) = @_;
    substr($name, 0, 0) = $$self eq "." ? "." : "$$self.";
    return $self->_nclass->new($name);
}

sub _kids {
    my $self = shift;
    my $nclass = $self->_nclass;
    return map $nclass->new($_), Tkx::SplitList(Tkx::winfo_children($self));
}

sub _parent {
    my $self = shift;
    my $name = $$self;
    return undef if $name eq ".";
    substr($name, rindex($name, ".")) = "";
    $name = "." unless length($name);
    return $self->_nclass->new($name);
}

sub _class {
    my $self = shift;
    my $old = ref($self);
    if (@_) {
	my $class = shift;
	$class{$$self} = $class;
	bless $self, $class;
    }
    $old;
}

sub _Mega {
    my $class = shift;
    my $widget = shift;
    my $impclass = shift || caller;
    $mega{$widget} = $impclass;
}

sub _nclass {
    __PACKAGE__;
}

sub _mpath {
    my $self = shift;
    $$self;
}

sub AUTOLOAD {
    my $self = shift;

    our $AUTOLOAD;
    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);

    if (substr($method, 0, 4) eq "new_") {
	my $widget = Tkx::i::expand_name(substr($method, 4));
	my $name;
	for (my $i = 0; $i < @_; $i += 2) {
	    if ($_[$i] eq "-name") {
		(undef, $name) = splice(@_, $i, 2);
		substr($name, 0, 0) = ($$self eq "." ? "." : "$$self.")
		    if index($name, ".") == -1;
		last;
	    }
	}
	$name ||= Tkx::i::wname($widget, $$self);
	if (my $mega = $mega{$widget}) {
	    return $mega->_Populate($widget, $name, @_);
	}
	return $self->_nclass->new(scalar(Tkx::i::call($widget, $name, @_)));
    }

    my $prefix = substr($method, 0, 2);
    if ($prefix eq "m_") {
	my @i = Tkx::i::expand_name(substr($method, 2));
        my $p = $self->_mpath($i[0]);
        return scalar(Tkx::i::call($p, @i, @_)) if $p eq $$self || !$class{$p};
        return (bless \$p, $class{$p})->$method(@_);
    }

    if ($prefix eq "g_") {
        return scalar(Tkx::i::call(Tkx::i::expand_name(substr($method, 2)), $$self, @_));
    }

    if (index($prefix, "_") != -1) {
	require Carp;
	Carp::croak("method '$method' reserved by Tkx");
    }

    $method = "m_$method";
    return $self->$method(@_);
}

sub DESTROY {}  # avoid AUTOLOADing it


package Tkx::widget::_destroy;

sub new {
    my($class, @paths) = @_;
    bless \@paths, $class;
}

sub DESTROY {
    my $self = shift;
    for my $path (@$self) {
	if ($path eq ".") {
	    %data = ();
	    return;
	}

	my $path_re = qr/^\Q$path\E(?:\.|\z)/;
        for my $hash (\%data, \%class) {
	    for my $key (keys %$hash) {
		next unless $key =~ $path_re;
		delete $hash->{$key};
	    }
	}
    }
}

package Tkx::i;

use Tcl;

my $interp;
my $trace_count = 0;
my $trace_start_time = 0;

BEGIN {
    $Tcl::STACK_TRACE = 0;
    $interp = Tcl->new;
    $interp->Init;
}

sub interp {
    return $interp;
}

sub expand_name {
    my(@f) = (shift);
    @f = split(/(?
    for (@f) {
	s/(?
	s/(?
    }
    wantarray ? @f : $f[0];
}

sub wname {
    my($class, $parent) = @_;
    my $name = lc($class);
    $name =~ s/.*:://;
    substr($name, 1) = "";
    my @kids = call("winfo", "children", $parent);
    substr($name, 0, 0) = ($parent eq "." ? "." : "$parent.");
    if (grep $_ eq $name, @kids) {
	my %kids = map { $_ => 1 } @kids;
	my $count = 2;
	$count++ while $kids{"$name$count"};
	$name .= $count;
    }
    $name;
}

sub call {
    if ($Tkx::TRACE) {
	my @prefix = "Tkx";
	if ($Tkx::TRACE_COUNT) {
	    push(@prefix, ++$trace_count);
	}
	if ($Tkx::TRACE_TIME) {
	    my $ts;
	    unless ($trace_start_time) {
		if (eval { require Time::HiRes }) {
		    $trace_start_time = Time::HiRes::time();
		}
		else {
		    $trace_start_time = time;
		}
	    }
	    if (defined &Time::HiRes::time) {
		$ts = sprintf "%.1fs", Time::HiRes::time() - $trace_start_time;
	    }
	    else {
		$ts = time - $trace_start_time;
		$ts .= "s";
	    }
	    push(@prefix, $ts);
	}
	if ($Tkx::TRACE_CALLER) {
	    my $i = 0;
	    while (my($pkg, $file, $line) = caller($i)) {
		unless ($pkg eq "Tkx" || $pkg =~ /^Tkx::/) {
		    $file =~ s,.*[/\\],,;
		    push(@prefix, $file, $line);
		    last;
		}
		$i++;
	    }
	}

	my($cmd, @args) = @_;
	for (@args) {
	    if (ref eq "CODE" || ref eq "ARRAY" && ref($_->[0]) eq "CODE") {
		$_ = "perl::callback";
	    }
	    elsif (ref eq "ARRAY" || ref eq "Tcl::List") {
		$_ = $interp->call("format", "[list %s]", $_);
	    }
	    else {
		if ($TRACE_MAX_STRING && length > $TRACE_MAX_STRING) {
		    substr($_, 2*$TRACE_MAX_STRING/3, -$TRACE_MAX_STRING/3) = " ... ";
		}
		s/([\\{}\"\[\]\$])/\\$1/g;
		s/\r/\\r/g;
		s/\n/\\n/g;
		s/\t/\\t/g;
		s/([^\x00-\xFF])/sprintf "\\u%04x", ord($1)/ge;
		s/([^\x20-\x7e])/sprintf "\\x%02x", ord($1)/ge;
		$_ = "{$_}" if / /;
	    }
	}
	print STDERR join(" ", (join("-", @prefix) . ":"), $cmd, @args) . "\n";
    }
    my @cleanup;
    if ($_[0] eq "destroy") {
	my @paths = @_;
	shift(@paths);
	push(@cleanup, Tkx::widget::_destroy->new(@paths));
    }

    if (wantarray) {
	my @a = eval { $interp->call(@_) };
	return @a unless $@;
    }
    else {
	my $a = eval { $interp->call(@_) };
	return $a unless $@;
    }

    # report exception relative to the non-Tkx caller
    if (!ref($@) && $@ =~ s/( at .*[\\\/](Tkx|Tcl)\.pm line \d+\.\n\z)//) {
           my $i = 1;
           my($pkg, $file, $line);
           while (($pkg, $file, $line) = caller($i)) {
               last if $pkg !~ /^Tkx(::|$)/;
               $i++;
           };
           $@ .= " at $file line $line.\n";
    }
    die $@;
}

sub DoOneEvent {
    $interp->DoOneEvent(@_);
}

1;

__END__