/usr/local/CPAN/X11-Motif/X11/Toolkit/Widget.pm
package X11::Toolkit::Widget;
# Copyright 1997 by Ken Fox
use strict;
use vars qw($VERSION);
$VERSION = 1.0;
package X::Toolkit::Widget;
use Carp;
use vars qw(%class_registry %resource_registry %resource_alias
%constraint_resource_registry %constraint_resource_alias
%resource_conversion_mandatory %resource_conversion_prohibited
%class_converter_to %type_converter_to %type_registry
%constraint_handlers %call_data_registry %resource_hints);
%class_registry = ();
%resource_registry = ();
%resource_alias = ();
%constraint_resource_registry = ();
%constraint_resource_alias = ();
%resource_conversion_mandatory = ();
%resource_conversion_prohibited = ( 'String' => 1 );
%class_converter_to = ();
%type_converter_to = ();
%type_registry = ();
%constraint_handlers = ();
%call_data_registry = ();
$resource_alias{'Core'} = { 'bg' => 'background', 'fg' => 'foreground' };
# Resource Hints:
#
# 'u' -- Xt doesn't provide enough information to determine whether a
# resource value is signed or unsigned. In practice, this is
# only a problem for short integers that should not be sign
# extended. Longer integers are always sign extended -- we
# just hope that users don't use values that would make a
# difference on a machine with 64-bit (or longer) integers!
%resource_hints = ( 'Dimension' => 'u', 'ShellHorizDim' => 'u', 'ShellVertDim' => 'u' );
my $event_loop_nesting = 0;
# ================================================================================
# Utility functions
sub Realize { XtRealizeWidget($_[0]) }
sub Manage { XtManageChild($_[0]) }
sub Unmanage { XtUnmanageChild($_[0]) }
sub GetContext { XtWidgetToApplicationContext($_[0]) }
sub FullName {
my $w = shift;
my @name = ();
while ($w) {
unshift @name, XtName($w);
$w = XtParent($w);
}
join('.', @name);
}
sub constraint_resource_info {
my($self, $res_name) = @_;
my $parent = Parent($self);
my @output = ();
if (defined $parent) {
my $type_name = Class($parent)->name();
push @output, $res_name;
my $alias = $constraint_resource_alias{$type_name}{$res_name};
if (defined $alias) {
$output[0] .= " ($alias)";
$res_name = $alias;
}
my $info = $constraint_resource_registry{$type_name}{$res_name};
if (defined $info) {
push @output, @{$info};
}
}
@output;
}
sub resource_info {
my($self, $res_name) = @_;
my $type_name = Class($self)->name();
my @output = ();
$res_name =~ s|^-||;
push @output, $res_name;
my $alias = $resource_alias{$type_name}{$res_name};
if (defined $alias) {
$output[0] .= " ($alias)";
$res_name = $alias;
}
my $info = $resource_registry{$type_name}{$res_name};
if (defined $info) {
push @output, @{$info};
}
else {
return constraint_resource_info($self, $res_name);
}
@output;
}
sub conversion_is_mandatory {
my($res_type) = @_;
$resource_conversion_mandatory{$res_type}++;
}
sub conversion_is_prohibited {
my($res_type) = @_;
$resource_conversion_prohibited{$res_type}++;
}
sub register_converter {
my($res_type, $to) = @_;
unshift @{$type_converter_to{$res_type}}, $to;
}
sub register_class_converter {
my($res_class, $to) = @_;
unshift @{$class_converter_to{$res_class}}, $to;
}
sub set_resource {
my($name, $value, $registry, $resources, $callbacks) = @_;
if (ref $name) {
my $num = scalar @{$name};
my $i = 1;
while ($i < $num) {
set_resource($name->[$i] => $name->[$i + 1],
$registry, $resources, $callbacks);
$i += 2;
}
$name = $name->[0];
}
# $info->[0] = resource class
# $info->[1] = resource type
# $info->[2] = resource size
my $info = $registry->{$name};
if ($info->[1] eq 'Callback') {
# Callbacks aren't treated as normal resources since they
# must be set using the special XtAddCallback() interface.
$callbacks->{$name} = $value if (defined $callbacks);
}
elsif (defined $resource_conversion_prohibited{$info->[1]}) {
# Force the toolkit to use a string value instead of trying
# to run a conversion sequence. The rule of thumb is if you
# use a C string to set the resource value, then the resource
# should be set using this code.
$resources->{$name} = X::Toolkit::InArg::new($value, $info->[1], $info->[2], 1);
}
elsif (defined $resource_conversion_mandatory{$info->[1]}) {
# If resource conversion is mandatory, then the class and type
# converters will always be run -- regardless of what the input
# resource value is.
foreach my $proc (@{$class_converter_to{$info->[0]}}) {
&{$proc}(\$value);
}
foreach my $proc (@{$type_converter_to{$info->[1]}}) {
&{$proc}(\$value);
}
$resources->{$name} = $value;
}
elsif (X::is_string($value)) {
# If the input value is a string, try running through the resource
# converters until one of them returns a non-string value.
# First, try to run a class-based resource converter on the value.
foreach my $proc (@{$class_converter_to{$info->[0]}}) {
last if (&{$proc}(\$value));
}
if (X::is_string($value)) {
# Next, try to run a type-based resource converter on the value.
foreach my $proc (@{$type_converter_to{$info->[1]}}) {
last if (&{$proc}(\$value));
}
if (X::is_string($value) && !X::is_numeric($value)) {
# Finally, let the toolkit converters do the conversion if
# the value is still a string (and does not have an alternate
# integer value). This could generate a toolkit warning if
# the widget set does not provide a conversion from string
# format. Most resources have these converters though because
# they are used for converting app-defaults files.
#
# The reason why we don't run potential numbers through the
# toolkit conversion is because a number is almost always
# an enumeration value. Most converters don't handle the
# numeric value, but rather the symbolic name. If we ran
# numbers through the toolkit conversion there's a good chance
# the conversion would fail. Besides, if the value is already
# an integer it skips the relatively slow toolkit conversion
# process.
$value = X::Toolkit::InArg::new($value, $info->[1], $info->[2], 0);
}
}
$resources->{$name} = $value;
}
else {
# Lastly, if the attribute is not a string and does not require
# conversion, the resource is just set directly. This allows
# objects (i.e. blessed refs) returned from other X11 routines
# to be used directly.
$resources->{$name} = $value;
}
}
sub build_resource_table {
my $type_name = shift;
my $parent_type_name = shift;
my $resources = shift;
my $callbacks = shift;
my $pseudo_resources = shift;
my $alias = $resource_alias{$type_name};
my $registry = $resource_registry{$type_name};
my $constraint_alias;
my $constraint_registry;
if (defined $parent_type_name) {
$constraint_alias = $constraint_resource_alias{$parent_type_name};
$constraint_registry = $constraint_resource_registry{$parent_type_name};
}
my($res_name, $value);
my $num = scalar @_;
my $i = 0;
while ($i < $num) {
$res_name = $_[$i++];
$res_name =~ s|^-||;
$value = $_[$i++];
if (defined $alias->{$res_name}) {
set_resource($alias->{$res_name} => $value,
$registry, $resources, $callbacks);
}
elsif (defined $registry->{$res_name}) {
set_resource($res_name => $value,
$registry, $resources, $callbacks);
}
elsif (defined $constraint_alias && defined $constraint_alias->{$res_name}) {
set_resource($constraint_alias->{$res_name} => $value,
$constraint_registry, $resources, $callbacks);
}
elsif (defined $constraint_registry && defined $constraint_registry->{$res_name}) {
set_resource($res_name => $value,
$constraint_registry, $resources, $callbacks);
}
elsif ($res_name eq 'name') {
$pseudo_resources->{'name'} = $value
}
elsif ($res_name eq 'managed') {
$pseudo_resources->{'managed'} = X::cvt_to_Boolean($value);
}
elsif ($res_name eq 'mapped') {
$pseudo_resources->{'mapped'} = X::cvt_to_Boolean($value);
}
elsif ($res_name eq 'xy') {
my $pos = $value;
if (ref $pos) {
if (defined $pos->[0]) {
set_resource('x' => $pos->[0], $registry, $resources, $callbacks);
}
if (defined $pos->[1]) {
set_resource('y' => $pos->[1], $registry, $resources, $callbacks);
}
}
}
else {
carp "resource $res_name not defined on widget class $type_name";
}
}
}
sub build_strict_resource_table {
my $type_name = shift;
my $parent_type_name = shift;
my $resources = shift;
my $callbacks = shift;
my $registry = $resource_registry{$type_name};
my $constraint_registry;
if (defined $parent_type_name) {
$constraint_registry = $constraint_resource_registry{$parent_type_name};
}
my($res_name, $value);
my $num = scalar @_;
my $i = 0;
while ($i < $num) {
$res_name = $_[$i++];
$res_name =~ s|^-||;
$value = $_[$i++];
if (defined $registry->{$res_name}) {
set_resource($res_name => $value,
$registry, $resources, $callbacks);
}
elsif (defined $constraint_registry && defined $constraint_registry->{$res_name}) {
set_resource($res_name => $value,
$constraint_registry, $resources, $callbacks);
}
else {
carp "resource $res_name not defined on widget class $type_name";
}
}
}
sub build_resource_query_table {
my $type_name = shift;
my $parent_type_name = shift;
my $resources = shift;
my $alias = $resource_alias{$type_name};
my $registry = $resource_registry{$type_name};
my $constraint_alias;
my $constraint_registry;
if (defined $parent_type_name) {
$constraint_alias = $constraint_resource_alias{$parent_type_name};
$constraint_registry = $constraint_resource_registry{$parent_type_name};
}
my $res_name;
my $num = scalar @_;
my $i = 0;
my $info;
my $hints;
while ($i < $num) {
$res_name = $_[$i++];
$res_name =~ s|^-||;
undef $info;
if (defined $alias->{$res_name}) {
if (ref $alias->{$res_name}) {
$res_name = $alias->{$res_name}[0];
}
else {
$res_name = $alias->{$res_name};
}
$info = $registry->{$res_name};
}
elsif (defined $registry->{$res_name}) {
$info = $registry->{$res_name};
}
elsif (defined $constraint_alias && defined $constraint_alias->{$res_name}) {
if (ref $constraint_alias->{$res_name}) {
$res_name = $constraint_alias->{$res_name}[0];
}
else {
$res_name = $constraint_alias->{$res_name};
}
$info = $constraint_registry->{$res_name};
}
elsif (defined $constraint_registry && defined $constraint_registry->{$res_name}) {
$info = $constraint_registry->{$res_name};
}
if (defined $info) {
$hints = $resource_hints{$info->[2]} || '';
push @{$resources}, X::Toolkit::OutArg::new($res_name, $info->[0],
$info->[1], $info->[2],
$hints);
}
else {
carp "resource $res_name not defined on widget class $type_name";
}
}
}
sub build_strict_resource_query_table {
my $type_name = shift;
my $parent_type_name = shift;
my $resources = shift;
my $registry = $resource_registry{$type_name};
my $constraint_registry;
if (defined $parent_type_name) {
$constraint_registry = $constraint_resource_registry{$parent_type_name};
}
my $res_name;
my $num = scalar @_;
my $i = 0;
my $info;
my $hints;
while ($i < $num) {
$res_name = $_[$i++];
$res_name =~ s|^-||;
undef $info;
if (defined $registry->{$res_name}) {
$info = $registry->{$res_name};
}
elsif (defined $constraint_registry && defined $constraint_registry->{$res_name}) {
$info = $constraint_registry->{$res_name};
}
if (defined $info) {
$hints = $resource_hints{$info->[2]} || '';
push @{$resources}, X::Toolkit::OutArg::new($res_name, $info->[0],
$info->[1], $info->[2],
$hints);
}
else {
carp "resource $res_name not defined on widget class $type_name";
}
}
}
sub add_callback_set {
my($self, $type_name, $callbacks) = @_;
if (defined $callbacks && defined %{$callbacks}) {
my($cb_name, $proc);
while (($cb_name, $proc) = each %{$callbacks}) {
if (ref $proc eq 'ARRAY') {
$self->priv_XtAddCallback($cb_name, $proc->[0],
$call_data_registry{$type_name.','.$cb_name},
$proc->[1]);
}
else {
$self->priv_XtAddCallback($cb_name, $proc,
$call_data_registry{$type_name.','.$cb_name});
}
}
}
}
# ================================================================================
# Tk-like object interface
#
# The methods implemented here provide a completely different (and
# hopefully better) interface to the X Toolkit. The Tk indirect
# object style is used, i.e. [verb] [noun] [indirect object]. For
# example, instead of saying:
#
# $widget->manage();
#
# you say:
#
# manage $widget;
#
# Actually either syntax is acceptable but the methods are written
# to make sense when read in the second syntax.
# --------------------------------------------------------------------------------
# change $widget resource => value, ...
#
# change the value of one or more of a widget's resources
sub change {
my $self = shift;
my $parent = Parent($self);
my $type_name = Class($self)->name();
my $parent_type_name;
# shells don't have parents
if (defined $parent) {
$parent_type_name = Class($parent)->name();
}
my %resources = ();
my %callbacks;
my %pseudo_resources = ();
build_resource_table($type_name, $parent_type_name,
\%resources, \%callbacks, \%pseudo_resources, @_);
if (exists $pseudo_resources{'managed'}) {
if ($pseudo_resources{'managed'}) {
$self->Manage();
}
else {
$self->Unmanage();
}
}
if (exists $pseudo_resources{'mapped'}) {
if ($self->IsRealized()) {
my $dpy = Display($self);
my $win = Window($self);
if ($pseudo_resources{'mapped'}) {
X::MapWindow($dpy, $win);
}
else {
X::UnmapWindow($dpy, $win);
}
}
else {
if ($pseudo_resources{'mapped'}) {
$resources{'mappedWhenManaged'} = X::True;
}
else {
$resources{'mappedWhenManaged'} = X::False;
}
}
}
$self->priv_XtSetValues(%resources) if (%resources);
$self->add_callback_set($type_name, \%callbacks);
}
# --------------------------------------------------------------------------------
# child = give $widget class, resource => value, ...
#
# give a parent widget a new child widget of the given class with the
# given default resource values
sub give {
my $parent = shift;
my $type = shift;
my $type_name;
my @arg_list = ();
if (!ref $type) {
$type_name = lc $type;
$type_name =~ s|^-||;
$type = $class_registry{$type_name};
if (ref $type) {
if (ref $type eq 'ARRAY') {
($type, @arg_list) = @{$type};
if (ref $arg_list[0] eq 'CODE') {
my $proc = shift @arg_list;
return &{$proc}($parent, $type, @arg_list, @_);
}
}
}
else {
croak "$type_name is not a registered widget class";
}
}
$type_name = $type->name();
push @arg_list, @_;
my %resources = ();
my %callbacks;
my %pseudo_resources = ();
build_resource_table($type_name, Class($parent)->name(),
\%resources, \%callbacks, \%pseudo_resources, @arg_list);
my $name = $pseudo_resources{'name'};
if (!defined $name) {
$name = 'an_'.$type_name;
}
my $managed = $pseudo_resources{'managed'};
if (!defined $managed) {
$managed = 1;
}
my $child;
if (exists($resource_registry{$type_name}{'allowShellResize'})) {
$child = X::Toolkit::priv_XtCreatePopupShell($name, $type, $parent, %resources);
if (!defined $child) {
carp "couldn't create $type_name popup $name";
}
else {
$child->add_callback_set($type_name, \%callbacks);
}
}
else {
$child = X::Toolkit::priv_XtCreateWidget($name, $type, $parent, %resources);
if (!defined $child) {
carp "couldn't create $type_name widget $name";
}
else {
$child->add_callback_set($type_name, \%callbacks);
$child->Manage() if ($managed && $parent->XtIsWidget());
}
}
$child;
}
# --------------------------------------------------------------------------------
# constrain $widget resource => value, ...
#
# constrain the location and size of a widget by defining the constraint
# resources of the child (the change method will also do this, but this
# routine will prohibit non-constraint resources from being changed)
sub constrain {
my $self = shift;
my $parent = Parent($self);
if (defined $parent)
{
my $parent_type_name = Class($parent)->name();
my $alias = $constraint_resource_alias{$parent_type_name};
my $registry = $constraint_resource_registry{$parent_type_name};
my $custom_handler = $constraint_handlers{$parent_type_name};
my %resources = ();
my($res_name, $value);
my $num = scalar @_;
my $i = 0;
while ($i < $num) {
$res_name = $_[$i++];
$res_name =~ s|^-||;
$value = $_[$i++];
if (defined $alias->{$res_name}) {
set_resource($alias->{$res_name} => $value, $registry, \%resources);
}
elsif (defined $registry->{$res_name}) {
set_resource($res_name => $value, $registry, \%resources);
}
elsif (defined $custom_handler && &$custom_handler($res_name, $value, $registry, \%resources))
{
}
else {
carp "resource $res_name not defined on widget class $parent_type_name";
}
}
$self->priv_XtSetValues(%resources) if (%resources);
}
}
# --------------------------------------------------------------------------------
# (value, ...) = query $widget resource, ...
#
# query the widget for the current values of the given resources. the
# values are returned as a list in the same order that the resource
# names are given.
sub query {
my $self = shift;
my $parent = Parent($self);
my $type_name = Class($self)->name();
my $parent_type_name;
# shells don't have parents
if (defined $parent) {
$parent_type_name = Class($parent)->name();
}
my @resources = ();
build_resource_query_table($type_name, $parent_type_name, \@resources, @_);
# also need to handle the pseudo resources like name and managed -- but
# this is very tricky because the pseudo resource values must be inserted
# into the returned value list in the proper location. this can be done
# with splice(). only do the special splice() code if there are pseudo
# resources -- otherwise just do the simple return.
$self->priv_XtGetValues(@resources) if (@resources);
}
# --------------------------------------------------------------------------------
# handle $widget
#
# tell the widget to display itself and then start handling all input
# events.
sub handle {
my $self = shift;
if (!$self->IsRealized()) {
$self->Realize();
}
my $context = $self->GetContext();
my $nesting_on_entry = $event_loop_nesting;
my $event;
++$event_loop_nesting;
while ($event_loop_nesting > $nesting_on_entry) {
$event = $context->AppNextEvent;
X::Toolkit::DispatchEvent($event);
}
}
sub return_from_handler () {
--$event_loop_nesting;
}
# --------------------------------------------------------------------------------
# $widget->set_inherited_resources(name => value, ...)
#
# This is totally different from the other set values functions.
# set_inherited_resources will create an entry in the resource database
# that applies below the current widget. This only makes sense for
# manager widgets, i.e. widgets with children.
#
# For example, this:
#
# $form->set_inherited_resources('*foreground', 'white');
#
# will set the foreground of all the children of the form to white.
#
# NOTE: Resources set with this routine only affect widgets at creation
# time. Existing widgets will not be affected.
sub set_inherited_resources {
my $w = shift;
my $db = X::Toolkit::Database($w->Display());
my($res, $val);
my $fullname = $w->FullName();
while (@_) {
$res = shift;
$val = shift;
if (defined($res) && defined($val)) {
$res = $fullname.$res;
X::XrmPutStringResource($db, $res, $val);
}
}
}
# ================================================================================
# X Toolkit compatibility functions
#
# The intention is to support the Xt interface as faithfully as
# possible. Where an obvious C limitation can be easily removed,
# in creating ArgLists for example, the Xt interface is *slightly*
# improved.
sub XtAddCallback {
my($self, $cb_name, $proc, $client_data) = @_;
my $type_name = Class($self)->name();
if (exists $resource_registry{$type_name}{$cb_name} &&
$resource_registry{$type_name}{$cb_name}[1] eq 'Callback')
{
$self->priv_XtAddCallback($cb_name, $proc,
$call_data_registry{$type_name.','.$cb_name},
$client_data);
}
}
sub XtSetValues {
my $self = shift;
my $parent = Parent($self);
my $type_name = Class($self)->name();
my $parent_type_name;
# shells don't have parents
if (defined $parent) {
$parent_type_name = Class($parent)->name();
}
my %resources = ();
my %callbacks;
build_strict_resource_table($type_name, $parent_type_name,
\%resources, \%callbacks, @_);
$self->priv_XtSetValues(%resources);
}
sub XtGetValues {
my $self = shift;
my $parent = Parent($self);
my $type_name = Class($self)->name();
my $parent_type_name;
# shells don't have parents
if (defined $parent) {
$parent_type_name = Class($parent)->name();
}
my @resources = ();
build_strict_resource_query_table($type_name, $parent_type_name, \@resources, @_);
$self->priv_XtGetValues(@resources) if (@resources);
}
1;