File Coverage

blib/lib/Gtk2/Ex/FormFactory/Widget.pm

Criterion	Covered	Total	%
statement	9	357	2.5
branch	0	160	0.0
condition	0	33	0.0
subroutine	3	119	2.5
pod	27	113	23.8
total	39	782	4.9

package Gtk2::Ex::FormFactory::Widget;

use strict;
use Carp;
use Scalar::Util qw(weaken);

my $NAME_CNT = 0;
my %WIDGET_NAMES;

#========================================================================
# Accessors for user specified attributes
#========================================================================
sub get_name			{ shift->{name}				}
sub get_object			{ shift->{object}			}
sub get_attr			{ shift->{attr}				}
sub get_properties		{ shift->{properties}			}
sub get_label			{ shift->{label}			}
sub get_label_for		{ shift->{label_for}			}
sub get_label_markup		{ shift->{label_markup}			}
sub get_label_group		{ shift->{label_group}			}
sub get_widget_group		{ shift->{widget_group}			}
sub get_tip			{ shift->{tip}				}
sub get_inactive		{ shift->{inactive}			}
sub get_active			{ shift->{active}			}
sub get_rules			{ shift->{rules}			}
sub get_expand			{ shift->{expand}			}
sub get_expand_h		{ shift->{expand_h}			}
sub get_expand_v		{ shift->{expand_v}			}
sub get_scrollbars		{ shift->{scrollbars}			}
sub get_signal_connect		{ shift->{signal_connect}		}
sub get_signal_connect_after	{ shift->{signal_connect_after}		}
sub get_width			{ shift->{width}			}
sub get_height			{ shift->{height}			}
sub get_customize_hook		{ shift->{customize_hook}		}
sub get_changed_hook		{ shift->{changed_hook}			}
sub get_changed_hook_after	{ shift->{changed_hook_after}		}
sub get_active_cond		{ shift->{active_cond}			}
sub get_active_depends		{ shift->{active_depends}		}
#------------------------------------------------------------------------
sub set_name			{ shift->{name}			= $_[1]	}
sub set_object			{ shift->{object}		= $_[1]	}
sub set_attr			{ shift->{attr}			= $_[1]	}
sub set_properties		{ shift->{properties}		= $_[1]	}
sub set_label			{ shift->{label}		= $_[1]	}
sub set_label_for		{ shift->{label_for}		= $_[1]	}
sub set_label_markup		{ shift->{label_markup}		= $_[1]	}
sub set_label_group		{ shift->{label_group}		= $_[1]	}
sub set_widget_group		{ shift->{widget_group}		= $_[1]	}
sub set_tip			{ shift->{tip}			= $_[1]	}
sub set_inactive		{ shift->{inactive}		= $_[1]	}
sub set_active			{ shift->{active}		= $_[1]	}
sub set_rules			{ shift->{rules}		= $_[1]	}
sub set_expand			{ shift->{expand}		= $_[1]	}
sub set_expand_h		{ shift->{expand_h}		= $_[1]	}
sub set_expand_v		{ shift->{expand_v}		= $_[1]	}
sub set_scrollbars		{ shift->{scrollbars}		= $_[1]	}
sub set_signal_connect		{ shift->{signal_connect}	= $_[1]	}
sub set_signal_connect_after	{ shift->{signal_connect_after}	= $_[1]	}
sub set_width			{ shift->{width}		= $_[1]	}
sub set_height			{ shift->{height}		= $_[1]	}
sub set_customize_hook		{ shift->{customize_hook}	= $_[1]	}
sub set_changed_hook		{ shift->{changed_hook}		= $_[1]	}
sub set_changed_hook_after	{ shift->{changed_hook_after}	= $_[1]	}
sub set_active_cond		{ shift->{active_cond}		= $_[1]	}
sub set_active_depends		{ shift->{active_depends}	= $_[1]	}
#========================================================================

#========================================================================
# Accessors for internal attributes
#========================================================================
sub get_context			{ shift->{form_factory}->get_context	}
sub get_form_factory		{ shift->{form_factory}			}
sub get_parent			{ shift->{parent}			}
sub get_gtk_widget		{ shift->{gtk_widget}			}
sub get_gtk_parent_widget	{ $_[0]->{gtk_parent_widget} ||
				  $_[0]->{gtk_widget}			}
sub get_gtk_properties_widget	{ $_[0]->{gtk_properties_widget} ||
				  $_[0]->{gtk_widget}			}
sub get_gtk_label_widget	{ shift->{gtk_label_widget}		}
sub get_layout_data		{ shift->{layout_data}			}
sub get_in_update		{ shift->{in_update}			}
sub get_no_widget_update	{ shift->{no_widget_update}		}
sub get_backup_widget_value	{ shift->{backup_widget_value}		}
sub get_widget_activity		{ shift->{widget_activity}		}
sub get_built			{ shift->{built}			}
#------------------------------------------------------------------------
sub set_form_factory		{ weaken( shift->{form_factory}	= $_[1])}
sub set_parent			{ weaken( shift->{parent}       = $_[1])}
sub set_gtk_widget		{ shift->{gtk_widget}		= $_[1]	}
sub set_gtk_parent_widget	{ shift->{gtk_parent_widget}	= $_[1]	}
sub set_gtk_properties_widget	{ shift->{gtk_properties_widget}= $_[1]	}
sub set_gtk_label_widget	{ shift->{gtk_label_widget}	= $_[1]	}
sub set_layout_data		{ shift->{layout_data}		= $_[1]	}
sub set_in_update		{ shift->{in_update}		= $_[1]	}
sub set_no_widget_update	{ shift->{no_widget_update}	= $_[1]	}
sub set_backup_widget_value	{ shift->{backup_widget_value}	= $_[1]	}
sub set_widget_activity		{ shift->{widget_activity}	= $_[1]	}
sub set_built			{ shift->{built}		= $_[1]	}
#========================================================================

#========================================================================
# Methods, which may be implemented by Widget subclasses
#========================================================================
sub get_type			{ die $_[0]." misses type() method"	}
sub get_gtk_signal_widget	{ $_[0]->get_gtk_widget			}
sub get_gtk_tip_widgets		{ [ $_[0]->get_gtk_widget ] 		}
sub get_gtk_check_widget	{ $_[0]->get_gtk_widget 		}
sub get_widget_check_value 	{ undef	}
sub has_additional_attrs	{ "" 	}
sub has_label			{ 0	}
sub object_to_widget 		{ 1 	}
sub widget_to_object 		{ 1 	}
sub empty_widget		{ 1 	}
sub backup_widget_value 	{ 1 	}
sub restore_widget_value 	{ 1 	}
sub isa_container		{ 0	}
sub widget_data_has_changed	{ $_[0]->get_backup_widget_value ne
				  $_[0]->get_widget_check_value }

#========================================================================

#========================================================================
# Widget constructor - must be called by subclasses
#========================================================================
sub new {
	my $class = shift;
	my %par = @_;
	my  ($name, $object, $attr, $properties, $label, $label_group) =
	@par{'name','object','attr','properties','label','label_group'};
	my  ($widget_group, $inactive, $rules, $expand, $scrollbars) =
	@par{'widget_group','inactive','rules','expand','scrollbars'};
	my  ($signal_connect, $width, $height, $customize_hook) =
	@par{'signal_connect','width','height','customize_hook'};
	my  ($changed_hook, $tip, $expand_h, $expand_v, $label_markup) =
	@par{'changed_hook','tip','expand_h','expand_v','label_markup'};
	my  ($active, $signal_connect_after, $label_for) =
	@par{'active','signal_connect_after','label_for'};
	my  ($active_cond, $active_depends, $changed_hook_after) =
	@par{'active_cond','active_depends','changed_hook_after'};

	$active = 1 if not defined $active;

	#-- Short notation: 'object.attr', so you may omit 'object'
	if ( $attr and $attr =~ /^([^.]+)\.(.*)/ ) {
		$object = $1;
		$attr   = $2;
	}

	#-- Set a default for the Widget's name
	if ( not $name and $object and $attr ) {
		#-- Default name is object.attr, if both
		#-- object and attr are set
		my $cnt = 1;
		my $add = "";
		#-- Add a number, if the name is registered already
		while ( exists $WIDGET_NAMES{"$object.$attr$add"} ) {
			++$cnt;
			$add="_$cnt";
		}
		$name = "$object.$attr$add";

	} elsif ( not $name ) {
		#-- Widgets non associated with an object and
		#-- an attribute get a name derived from the
		#-- Widget's type
		$name ||= $class->get_type."_".$NAME_CNT++;
	}

	#-- Check if widget name is not already registered
	croak "Widget name '$name' is already registered"
		if exists $WIDGET_NAMES{$name};

	#-- Store widget name
	$WIDGET_NAMES{$name} = 1;

	#-- By default make widget insensitive when it's not active
	$inactive ||= "insensitive";

	#-- Expanding defaults
	$expand_h = $expand_v = $expand if defined $expand;
	$expand   = 0 unless defined $expand;
	$expand_h = 1 unless defined $expand_h;
	$expand_v = 0 unless defined $expand_v;

	croak "'inactive' must be 'insensitive' or 'invisible'"
		unless  $inactive eq 'insensitive' or
			$inactive eq 'invisible';

	my $self = bless {
		name			=> $name,
		object			=> $object,
		attr			=> $attr,
		properties		=> $properties,
		label			=> $label,
		label_for		=> $label_for,
		label_group		=> $label_group,
		label_markup		=> $label_markup,
		widget_group    	=> $widget_group,
		tip			=> $tip,
		active			=> $active,
		inactive		=> $inactive,
		rules			=> $rules,
		expand			=> $expand,
		expand_h		=> $expand_h,
		expand_v		=> $expand_v,
		scrollbars		=> $scrollbars,
		signal_connect		=> $signal_connect,
		signal_connect_after	=> $signal_connect_after,
		width			=> $width,
		height			=> $height,
		customize_hook		=> $customize_hook,
		changed_hook		=> $changed_hook,
		changed_hook_after	=> $changed_hook_after,
		active_cond		=> $active_cond,
		active_depends		=> $active_depends,
		layout_data		=> {},
	}, $class;

	return $self;
}

sub debug_dump {
    my $self = shift;
    my ($level) = @_;
    print "  "x$level;
    print $self->{name}."|".$self->{attr}."\n";
    1;
}

#========================================================================
# Cleanup of widget data; break circular references
#========================================================================
sub cleanup {
	my $self = shift;

	$Gtk2::Ex::FormFactory::DEBUG &&
		print "CLEANUP: $self ".$self->get_name."(".$self->get_attr.")\n";

	#-- Break circular references with the parent object
	$self->set_parent(undef);

	#-- Cut references to Gtk widgets - otherwise the Perl
	#-- garbage collector is confused. We have heavy circular
	#-- referencing from FormFactory widgets to Gtk widgets,
	#-- e.g. from callback closures.
	$self->set_gtk_widget(undef);
	$self->set_gtk_parent_widget(undef);
	$self->set_gtk_properties_widget(undef);
	$self->set_gtk_label_widget(undef);

	#-- Deregister the Widget name
	delete $WIDGET_NAMES{$self->get_name};

	#-- Delete all references to this widget from the
	#-- associated Context
	$self->get_context->deregister_widget ($self);

	#-- Destroy reference to the FormFactory
	$self->set_form_factory(undef);

	1;
}

#========================================================================
# Convenience method: get Object Proxy of this Widget
#========================================================================
sub get_proxy {
	$_[0]->get_form_factory
	     ->get_context
	     ->get_proxy($_[0]->get_object);
}

#========================================================================
# Build this Widget, using the FormFactory's Layout instance
#========================================================================
sub build {
	my $self = shift;

	$Gtk2::Ex::FormFactory::DEBUG &&
		print "$self->build\n";

	#-- The Layout object actually builds all widgets
	$self->get_form_factory
	     ->get_layouter
	     ->build_widget($self);

	$self->set_built(1);

	1;
}

#========================================================================
# Connect all Gtk signals of this widget
#========================================================================
sub connect_signals {
	my $self = shift;

	#-- Some widgets have not Gtk pendant, so there
	#-- may be no signal connecting at all
	my $gtk_widget = $self->get_gtk_widget;
	return unless $gtk_widget;

	#-- Need the context
	my $context = $self->get_context;

	#-- Register the widget here...
	#-- (deregistering is done in ->cleanup)
	$context->register_widget($self);

	#-- On focus-in we backup the current object value
	#-- (probably we need to restore this if the user
	#--  enters invalid data)
	$self->get_gtk_check_widget->signal_connect ("focus-in-event", sub {
		$self->backup_widget_value;
		0;
	});

	#-- On focus-out we check for valid data
	$self->get_gtk_check_widget->signal_connect ("focus-out-event", sub {
		$self->check_widget_value;
		0;
	});

	#-- Connect the changed signal, if the widgets provides
	#-- a method for this
	$self->connect_changed_signal
		if $self->can("connect_changed_signal");

	#-- Connect additional user specified signals
	my $signal_connect = $self->get_signal_connect;
	if ( $signal_connect ) {
		my $signal_widget = $self->get_gtk_signal_widget;
		while ( my ($signal, $callback) = each %{$signal_connect} ) {
			$signal_widget->signal_connect ( $signal => $callback );
		}
	}

	#-- Connect additional user specified signals (after)
	my $signal_connect_after = $self->get_signal_connect_after;
	if ( $signal_connect_after ) {
		my $signal_widget = $self->get_gtk_signal_widget;
		while ( my ($signal, $callback) = each %{$signal_connect_after} ) {
			$signal_widget->signal_connect ( $signal => $callback );
		}
	}
	1;
}

#========================================================================
# Lookup a widget
#========================================================================
sub get_widget {
	my $self = shift;
	my ($name) = @_;

	my $widget;
	my $form_factory = $self->get_form_factory;

	croak "Widget '$name' not registered to this ".
	    "form factory ('".$form_factory->get_name."')"
	    	unless $widget = $form_factory->get_widgets_by_name->{$name};

	return $widget;
}


#========================================================================
# Lookup a widget reference
#========================================================================
sub lookup_widget {
	my $self = shift;
	my ($name) = @_;

	if ( $name =~ /sibling\s*\((.*?)\)/ ) {
		my $sibling_idx = $1;
		my $siblings = $self->get_parent->get_content;
		my $self_idx;
		foreach my $sibling ( @{$siblings} ) {
			if ( $sibling eq $self ) {
				$self_idx ||= 0;
				last;
			}
			++$self_idx;
		}
		die "Impossible" unless defined $self_idx;
		my $sibling = $siblings->[$sibling_idx+$self_idx];
		die "Can't find sibling($sibling_idx)" unless $sibling;
		return $sibling;
	} else {
		return $self->get_form_factory->get_widget($name);
	}
}

#========================================================================
# Update this widgets resp. transfer the object's value to the Widget
#========================================================================
sub update {
	my $self = shift;
	my ($change_state) = @_;

        $change_state = '' if not defined $change_state;

	$Gtk2::Ex::FormFactory::DEBUG &&
	    print "update_widget(".$self->get_name.", $change_state)\n";

	#-- Check if widget updating is temoprarily disabled
	#-- (refer to widget_value_changed() for this)
	return if $self->get_no_widget_update;

	#-- Is no object associated with this widget?
	if ( not $self->get_object ) {
		#-- Only a activity update may be possible, if
		#-- an Gtk widget is present at all
		if ( $self->get_gtk_parent_widget ) {
			my $active = $self->get_active;
			$active = $active ? "active" : "inactive";
			$self->update_widget_activity ( $active );
		}
		return;
	}

	#-- We're going to change the widget's state. This will
	#-- trigger the widget's changed signal. To prevent, that
	#-- this triggers an object update again, we set this
	#-- widget into update state (refer to widget_value_changed()
	#-- for details)
	$self->set_in_update(1);

	#-- Do we have an activity update? (if $change state is given,
	#-- and contains the string 'inactive') - Default is to detect
	#-- activity by the correspondent Proxy method (see below)
	my $active;
	$active = $change_state =~ /inactive/ ? 0 : 1
		if $change_state ne '';

	#-- Now transform the object's activity state into a
	#-- correspondent widget sensivity/visibility.
	if ( $self->get_object and $self->get_gtk_parent_widget ) {
		#-- Get object's activity state
		$active = $self->get_proxy($self->get_object)
			       ->get_attr_activity($self->get_attr)
					if not defined $active;

		#-- And set visibility or sensitivity accordingly,
		#-- dependend on what's defined in the widget
		$self->update_widget_activity ( $active );
	}

	#-- Transfer object value to widget
	if ( $change_state eq '' ) {
		$self->object_to_widget
			if $self->get_proxy->get_object;
	} elsif ( $change_state =~ /empty/ ) {
		$self->empty_widget;
	}

	#-- Set widget into normal update state
	$self->set_in_update(0);

	1;
}

#========================================================================
# Update this widget, and it's child; overwritten by Container class
#========================================================================
sub update_all {
	my $self = shift;

	#-- For a non Container widget, this is the same as update()
	$self->update(@_);

	1;
}

#========================================================================
# Update this widget's activity state: (in)sensitive / (in)visible
#========================================================================
sub update_widget_activity {
	my $self = shift;
	my ($active) = @_;

	$active = 0 if $active eq 'inactive';

	#-- Use the Widget's activity value over the given $active
	if ( defined $self->get_widget_activity ) {
		$active = $self->get_widget_activity;
	}

        #-- Get associated object (if there is one)
        my $object_name = $self->get_object;
        my $object      = $object_name ? $self->get_proxy->get_object : undef;

        #-- If there is an object association but the object is
        #-- currently not defined, set widget inactive
        if ( $object_name && ! defined $object ) {
            $active = 0;
        }
        #-- Otherwise check if an additional condition needs to be applied
        else {
            my $cond = $self->get_active_cond;
            $active = &$cond($object) if $cond;
        }

        my $action = $self->get_inactive;

        if ( $active eq 'insensitive' ) {
            $action = "insensitive";
            $active = 0;
        }
        elsif ( $active eq 'invisible' ) {
            $action = "invisible";
            $active = 0;
        }
        elsif ( $active eq 'sensitive' ) {
            $action = "insensitive";
            $active = 1;
        }
        elsif ( $active eq 'visible' ) {
            $action = "invisible";
            $active = 1;
        }

	if ( $active ) {
		#-- Make the widget visible resp. sensitive
		if ( $action eq 'invisible' ) {
			$Gtk2::Ex::FormFactory::DEBUG &&
			    print "  update_widget_activity(".
			    	  $self->get_name.
			          ", show)\n";
			$self->get_gtk_parent_widget->show;
			$self->get_gtk_label_widget->show
				if $self->get_gtk_label_widget;
		} else {
			$Gtk2::Ex::FormFactory::DEBUG &&
			    print "  update_widget_activity(".
			    	  $self->get_name.
			          ", sensitive)\n";
			$self->get_gtk_parent_widget->show;
			$self->get_gtk_label_widget->show
				if $self->get_gtk_label_widget;
			$self->get_gtk_parent_widget->set_sensitive(1);
			$self->get_gtk_label_widget->set_sensitive(1)
				if $self->get_gtk_label_widget;
		}

	} else {
		#-- Make the widget invisible resp. insensitive
		if ( $action eq 'invisible' ) {
			$Gtk2::Ex::FormFactory::DEBUG &&
			    print "  update_widget_activity(".
			    	  $self->get_name.
			          ", hide)\n";
			$self->get_gtk_parent_widget->hide;
			$self->get_gtk_label_widget->hide
				if $self->get_gtk_label_widget;
		} else {
			$Gtk2::Ex::FormFactory::DEBUG &&
			    print "  update_widget_activity(".
			    	  $self->get_name.
			          ", insensitive)\n";
			$self->get_gtk_parent_widget->set_sensitive(0);
			$self->get_gtk_label_widget->set_sensitive(0)
				if $self->get_gtk_label_widget;
		}
	}

	#-- Remember state
	$self->set_active($active);

	1;
}

#========================================================================
# Convenience method: get the Object's value
#========================================================================
sub get_object_value {
	my $self = shift;
	my ($attr) = @_;

	#-- By default get the primary attribute
	$attr ||= $self->get_attr;

	#-- Return nothing if this widget has no associated Object
	return if not $self->get_object;

	#-- Otherweise use the Proxy to return the Object's value
	return $self->get_proxy($self->get_object)
		    ->get_attr ($attr);
}

#========================================================================
# Convenience method: set the Object's value
#========================================================================
sub set_object_value {
	my $self = shift;
	my ($attr, $value) = @_;

	#-- If only one argument is given this is the value of
	#-- the default attribute of this widget
	if ( @_ == 1 ) {
		$value = $attr;
		$attr  = $self->get_attr;
	}

	#-- Do nothing if this widget has no associated Object
	return if not $self->get_object;

	#-- Otherwise use the Proxy to set the Object's value
	return $self->get_proxy($self->get_object)
		    ->set_attr ($attr => $value );
}

#========================================================================
# Check the widget value against the specified rules
#========================================================================
sub check_widget_value {
	my $self = shift;

	#-- Return true, if this Widget has no associated rules
	my $rules = $self->get_rules;
	return 1 if not defined $rules;

	#-- Check only if data changed
	return 1 unless $self->widget_data_has_changed;

	#-- Rule checking is done by a Rules Object associated
	#-- with the FormFactory of this Widget
	my $rule_checker = $self->get_form_factory->get_rule_checker;

	my $message;
	if ( $self->get_form_factory->get_sync && $self->get_object ) {
		#-- If the FormFactory is in Sync mode, check
		#-- the Object's value (access is faster than getting
		#-- the Widget value)
		$message = $rule_checker->check (
			$rules,
			$self->get_label,
			$self->get_object_value
		);
	} else {
		#-- If the FormFactory is not in Sync mode, the
		#-- Widget value is checked
		$message = $rule_checker->check (
			$rules,
			$self->get_label,
			$self->get_widget_check_value
		);
	}

	#-- Restore the Widget value and print an error dialog,
	#-- if the Rule check failed.
	if ( $message ) {
		$self->restore_widget_value;
		$self->show_error_message (
			message => $message,
		);
	}

	return 0;
}

#========================================================================
# Callback method, called if the user changed the Widget
#========================================================================
sub widget_value_changed {
	my $self = shift;

	#-- Do nothing if this Widget is already in update state
	#-- (otherwise recursive updates may be triggered)
	return if $self->get_in_update;

	$Gtk2::Ex::FormFactory::DEBUG &&
	    print $self->get_type."(".$self->get_name.") value changed\n";

	my $object = $self->get_object ? $self->get_proxy->get_object : undef;

	if ( $self->get_form_factory->get_sync ) {
		#-- Call the Widget's change hook
		my $changed_hook = $self->get_changed_hook;
		&$changed_hook($object, $self)
			if $changed_hook;

		#-- Apply all changes and update dependent
		#-- widgets accordingly
		$self->apply_changes if $object;

		#-- Call Widget's change_after_hook
		my $changed_hook_after = $self->get_changed_hook_after;
		&$changed_hook_after($object, $self)
			if $changed_hook_after;

	} else {
		#-- Changing the object normally triggers this
		#-- change also in the widget (refer to
		#-- Context->update_object_attr_widgets). We need
		#-- to prevent this.
		$self->set_no_widget_update(1);

		#-- Call the Widget's change hook, if one was set
		my $changed_hook = $self->get_changed_hook;
		&$changed_hook($object, $self)
			if $changed_hook;

		#-- Now update all dependent widgets
		$self->get_form_factory
		     ->get_context
		     ->update_object_attr_widgets(
		     	$self->get_object, $self->get_attr
		     );

		#-- Set widget into normal update state again
		$self->set_no_widget_update(0);

		#-- Call Widget's change_after_hook
		my $changed_hook_after = $self->get_changed_hook_after;
		&$changed_hook_after($object, $self)
			if $changed_hook_after;
	}

	1;
}

#========================================================================
# Transfer the Widget value to the Object; no activity update
#========================================================================
sub apply_changes {
	my $self = shift;

	$Gtk2::Ex::FormFactory::DEBUG &&
	    print "apply_changes ".$self->get_type."(".$self->get_name.")\n";

	#-- No widget update when setting the object value
	$self->set_no_widget_update(1);

	#-- Set object value from current widget value
	$self->widget_to_object;

	#-- Widget updates allowed again
	$self->set_no_widget_update(0);

	1;
}

#========================================================================
# Apply all changes incl. children
# (here the samy as apply, overriden by Container)
#========================================================================
sub apply_changes_all { shift->apply_changes }

#========================================================================
# Commit the Widget's Proxy Buffer (if Proxy is buffered at all)
#========================================================================
sub commit_proxy_buffers {
	my $self = shift;

	return unless $self->get_object;

	#-- Nothing to do in synced FormFactories
	#-- where the Proxy doesn't buffer
	my $proxy = $self->get_proxy;
	return 1 unless $proxy->get_buffered;

	#-- Commit the Proxy's attribute buffer to the object
	$proxy->commit_attr($self->get_attr);

	#-- And probably additional attributes...
	if ( $self->has_additional_attrs ) {
		my $add_attrs = $self->has_additional_attrs;
		my $object = $self->get_object;
		foreach my $add_attr ( @{$add_attrs} ) {
			my $get_attr_name_method = "get_attr_$add_attr";
			my $attr = $self->$get_attr_name_method();
			$proxy->commit_attr($attr);
		}
	}

	return 1;
}

#========================================================================
# Commit proxy buffer changes incl. children
# (here the samy as apply, overriden by Container)
#========================================================================
sub commit_proxy_buffers_all { shift->commit_proxy_buffers }

#========================================================================
# Commit the Widget's Proxy Buffer (if Proxy is buffered at all)
#========================================================================
sub discard_proxy_buffers {
	my $self = shift;

	return unless $self->get_object;

	#-- Nothing to do in synced FormFactories
	#-- where the Proxy doesn't buffer
	my $proxy = $self->get_proxy;
	return 1 unless $proxy->get_buffered;

	#-- Discard the Proxy's attribute buffer
	$proxy->discard_attr($self->get_attr);

	#-- And probably additional attributes...
	if ( $self->has_additional_attrs ) {
		my $add_attrs = $self->has_additional_attrs;
		my $object = $self->get_object;
		foreach my $add_attr ( @{$add_attrs} ) {
			my $get_attr_name_method = "get_attr_$add_attr";
			my $attr = $self->$get_attr_name_method();
			$proxy->discard_attr($attr);
		}
	}

	return 1;
}

#========================================================================
# Commit proxy buffer changes incl. children
# (here the samy as apply, overriden by Container)
#========================================================================
sub discard_proxy_buffers_all { shift->discard_proxy_buffers }

#========================================================================
# Show an error dialog
#========================================================================
sub show_error_message {
	my $self = shift;
	my %par = @_;
	my ($message, $type) = @par{'message','type'};

	$type ||= "error";

	$type = "GTK_MESSAGE_".uc($type);

	my $dialog = Gtk2::MessageDialog->new (
		$self->get_form_factory->get_form_factory_gtk_window,
		'GTK_DIALOG_DESTROY_WITH_PARENT',
		$type,
		'GTK_BUTTONS_CLOSE',
		$message,
	);

	$dialog->signal_connect( "response", sub { $dialog->destroy } );
	$dialog->set_position ('center');
	$dialog->set ( modal => 1 );
	$dialog->show;

	1;
}

1;

__END__