kgsueme/kgsueme/gtk.pl

package gtk;

use Carp;
use File::Temp;
use Gtk2;

# I have not yet found a way to simply default style properties
Gtk2::Rc->parse_string(<<EOF);

   style "base" {
      GtkTreeView::vertical_separator = 0
   }
   widget_class "*" style "base"

EOF

our $text_renderer = new Gtk2::CellRendererText;
our $int_renderer  = new Gtk2::CellRendererText;
$int_renderer->set (xalign => 1);

our $state = $util::state->{gtk} ||= {};

# shows the properties of a glib object
sub info {
   my ($idx, $obj) = @_;
   return if $seen{$idx}++;
   print "\n$idx\n";
   for ($obj->list_properties) {
      printf "%-16s %-24s %-24s %s\n", $_->{name}, $_->{type}, (join ":", @{$_->{flags}}), $_->{descr};
   }
}

my %get = (
   window_size     => sub { [ ($_[0]->allocation->values)[2,3] ] },
   #window_pos     => sub { die KGS::Listener::Debug::dumpval [ $_[0]->get_root_origin ] },
   column_size     => sub { $_[0]->get("width") || $_[0]->get("fixed_width") },
   modelsortorder  => sub { [ $_[0]->get_sort_column_id ] },
);

my %set = (
   window_size     => sub { $_[0]->set_default_size (@{$_[1]}) },
   #window_pos     => sub { $_[0]->set_uposition (@{$_[1]}) if @{$_[1]} },
   column_size     => sub { $_[0]->set (fixed_width => $_[1]) },
   modelsortorder  => sub { $_[0]->set_sort_column_id (@{$_[1]}) },
);

my %widget;

sub state {
   my ($widget, $class, $instance, %attr) = @_;

   while (my ($k, $v) = each %attr) {
      my ($set, $get) = $k =~ /=/ ? split /=/, $k : ($k, $k);

      $v = $state->{$class}{"*"}{$get}
         if exists $state->{$class}{"*"} && exists $state->{$class}{"*"}{$get};

      $v = $state->{$class}{$instance}{$get}
         if defined $instance
         && exists $state->{$class}{$instance} && exists $state->{$class}{$instance}{$get};

      $set{$get} ? $set{$get}->($widget, $v) : $widget->set($set => $v);

      #my $vx = KGS::Listener::Debug::dumpval $v; $vx =~ s/\s+/ /g; warn "set $class ($instance) $set => $vx\n";#d#
   }

   #$widget->signal_connect(destroy => sub { delete $widget{$widget}; 0 });

   $widget{$widget} = [$widget, $class, $instance, \%attr];
   Scalar::Util::weaken $widget{$widget}[0];
}

sub save_state {
   for (grep $_, values %widget) {
      my ($widget, $class, $instance, $attr) = @$_;

      next unless $widget; # no destroy => widget may be undef

      $widget->realize if $widget->can("realize");

      while (my ($k, $v) = each %$attr) {
         my ($set, $get) = $k =~ /=/ ? split /=/, $k : ($k, $k);
         $v = $get{$get} ? $get{$get}->($widget) : $widget->get($get);

         $state->{$class}{"*"}{$get}       = $v;
         $state->{$class}{$instance}{$get} = $v if defined $instance;

         #my $vx = KGS::Listener::Debug::dumpval $v; $vx =~ s/\s+/ /g; warn "get $class ($instance) $get => $vx\n";#d#
      }
   }
}

# string => Gtk2::Image
sub image_from_data {
   my ($data) = @_;
   my $img;
   
   if (defined $data) {
      # need to write to file first :/
      my ($fh, $filename) = File::Temp::tempfile ();
      syswrite $fh, $data;
      close $fh;
      $img = new_from_file Gtk2::Image $filename;
      unlink $filename;
   } else {
      $img = new_from_file Gtk2::Image KGS::Constants::findfile "KGS/kgsueme/images/default_userpic.png";
   }

   $img;
}

package gtk::widget;

# hacked gtk pseudo-widget

sub new {
   my $class = shift;
   bless { @_ }, $class;
}

sub widget { $_[0]{widget} }

sub AUTOLOAD {
   $AUTOLOAD =~ /::([^:]+)$/ or Carp::confess "$AUTOLOAD: no such method (illegal name)";
   ref $_[0]{widget} or Carp::confess "AUTOLOAD: non-method call $AUTOLOAD(@_)\n";
   my $method = $_[0]{widget}->can ($1)
      or Carp::confess "$AUTOLOAD: no such method";
   # do NOT cache.. we are fats enough this way
   unshift @_, shift->{widget};
   &$method;
}

sub destroy {
   my ($self) = @_;
   warn "destroy($self)";#d#

   delete $self->{app};

   for (keys %$self) {
      warn "$self->{$_} destroy" if UNIVERSAL::can ($self->{$_}, "destroy");
      (delete $self->{$_})->destroy
         if UNIVERSAL::can ($self->{$_}, "destroy");
#         if (UNIVERSAL::isa ($self->{$_}, Glib::Object)
#             && UNIVERSAL::isa ($self->{$_}, gtk::widget))
#            && $self->{$_}->can("destroy");
   }
}

sub DESTROY {
   my ($self) = @_;
   warn "DESTROY($self)";#d#
}

1;

Revision:	1.30
Committed:	Mon May 31 18:18:26 2004 UTC (20 years ago) by root
Content type:	text/plain
Branch:	MAIN
Changes since 1.29:	+1 -1 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	pcg	1.1	package gtk;
2
3	pcg	1.3	use Carp;
4	pcg	1.15	use File::Temp;
5			use Gtk2;
6	pcg	1.3
7	pcg	1.26	# I have not yet found a way to simply default style properties
8	pcg	1.24	Gtk2::Rc->parse_string(<<EOF);
9
10			style "base" {
11			GtkTreeView::vertical_separator = 0
12			}
13			widget_class "*" style "base"
14
15			EOF
16
17	pcg	1.1	our $text_renderer = new Gtk2::CellRendererText;
18			our $int_renderer = new Gtk2::CellRendererText;
19			$int_renderer->set (xalign => 1);
20
21	pcg	1.5	our $state = $util::state->{gtk} \|\|= {};
22	pcg	1.1
23			# shows the properties of a glib object
24	pcg	1.3	sub info {
25	pcg	1.1	my ($idx, $obj) = @_;
26	pcg	1.5	return if $seen{$idx}++;
27	pcg	1.1	print "\n$idx\n";
28			for ($obj->list_properties) {
29			printf "%-16s %-24s %-24s %s\n", $_->{name}, $_->{type}, (join ":", @{$_->{flags}}), $_->{descr};
30			}
31			}
32
33			my %get = (
34			window_size => sub { [ ($_[0]->allocation->values)[2,3] ] },
35			#window_pos => sub { die KGS::Listener::Debug::dumpval [ $_[0]->get_root_origin ] },
36	pcg	1.5	column_size => sub { $_[0]->get("width") \|\| $_[0]->get("fixed_width") },
37	pcg	1.10	modelsortorder => sub { [ $_[0]->get_sort_column_id ] },
38	pcg	1.1	);
39
40			my %set = (
41	pcg	1.8	window_size => sub { $_[0]->set_default_size (@{$_[1]}) },
42			#window_pos => sub { $_[0]->set_uposition (@{$_[1]}) if @{$_[1]} },
43			column_size => sub { $_[0]->set (fixed_width => $_[1]) },
44	pcg	1.10	modelsortorder => sub { $_[0]->set_sort_column_id (@{$_[1]}) },
45	pcg	1.1	);
46
47	pcg	1.5	my %widget;
48
49	pcg	1.1	sub state {
50			my ($widget, $class, $instance, %attr) = @_;
51
52			while (my ($k, $v) = each %attr) {
53			my ($set, $get) = $k =~ /=/ ? split /=/, $k : ($k, $k);
54	pcg	1.9
55			$v = $state->{$class}{"*"}{$get}
56			if exists $state->{$class}{""} && exists $state->{$class}{""}{$get};
57
58			$v = $state->{$class}{$instance}{$get}
59			if defined $instance
60			&& exists $state->{$class}{$instance} && exists $state->{$class}{$instance}{$get};
61
62	pcg	1.1	$set{$get} ? $set{$get}->($widget, $v) : $widget->set($set => $v);
63	pcg	1.9
64	pcg	1.26	#my $vx = KGS::Listener::Debug::dumpval $v; $vx =~ s/\s+/ /g; warn "set $class ($instance) $set => $vx\n";#d#
65	pcg	1.1	}
66
67	pcg	1.8	#$widget->signal_connect(destroy => sub { delete $widget{$widget}; 0 });
68	pcg	1.1
69	pcg	1.5	$widget{$widget} = [$widget, $class, $instance, \%attr];
70			Scalar::Util::weaken $widget{$widget}[0];
71	pcg	1.1	}
72
73			sub save_state {
74	pcg	1.5	for (grep $_, values %widget) {
75			my ($widget, $class, $instance, $attr) = @$_;
76
77	pcg	1.8	next unless $widget; # no destroy => widget may be undef
78
79	pcg	1.5	$widget->realize if $widget->can("realize");
80
81			while (my ($k, $v) = each %$attr) {
82			my ($set, $get) = $k =~ /=/ ? split /=/, $k : ($k, $k);
83			$v = $get{$get} ? $get{$get}->($widget) : $widget->get($get);
84
85			$state->{$class}{"*"}{$get} = $v;
86			$state->{$class}{$instance}{$get} = $v if defined $instance;
87	pcg	1.9
88	pcg	1.26	#my $vx = KGS::Listener::Debug::dumpval $v; $vx =~ s/\s+/ /g; warn "get $class ($instance) $get => $vx\n";#d#
89	pcg	1.1	}
90			}
91	pcg	1.15	}
92
93			# string => Gtk2::Image
94			sub image_from_data {
95			my ($data) = @_;
96	pcg	1.18	my $img;
97	pcg	1.15
98	pcg	1.18	if (defined $data) {
99			# need to write to file first :/
100			my ($fh, $filename) = File::Temp::tempfile ();
101			syswrite $fh, $data;
102			close $fh;
103			$img = new_from_file Gtk2::Image $filename;
104			unlink $filename;
105			} else {
106	pcg	1.29	$img = new_from_file Gtk2::Image KGS::Constants::findfile "KGS/kgsueme/images/default_userpic.png";
107	pcg	1.18	}
108	pcg	1.15
109			$img;
110	pcg	1.1	}
111
112	pcg	1.2	package gtk::widget;
113
114			# hacked gtk pseudo-widget
115
116	pcg	1.3	sub new {
117			my $class = shift;
118			bless { @_ }, $class;
119			}
120
121	pcg	1.2	sub widget { $_[0]{widget} }
122
123			sub AUTOLOAD {
124	pcg	1.3	$AUTOLOAD =~ /::([^:]+)$/ or Carp::confess "$AUTOLOAD: no such method (illegal name)";
125	pcg	1.5	ref $_[0]{widget} or Carp::confess "AUTOLOAD: non-method call $AUTOLOAD(@_)\n";
126	root	1.30	my $method = $_[0]{widget}->can ($1)
127	pcg	1.3	or Carp::confess "$AUTOLOAD: no such method";
128			# do NOT cache.. we are fats enough this way
129			unshift @_, shift->{widget};
130			&$method;
131			}
132
133	pcg	1.5	sub destroy {
134			my ($self) = @_;
135	pcg	1.14	warn "destroy($self)";#d#
136	pcg	1.12
137	pcg	1.27	delete $self->{app};
138
139	pcg	1.5	for (keys %$self) {
140	pcg	1.25	warn "$self->{$_} destroy" if UNIVERSAL::can ($self->{$_}, "destroy");
141	pcg	1.5	(delete $self->{$_})->destroy
142	pcg	1.13	if UNIVERSAL::can ($self->{$_}, "destroy");
143			# if (UNIVERSAL::isa ($self->{$_}, Glib::Object)
144			# && UNIVERSAL::isa ($self->{$_}, gtk::widget))
145			# && $self->{$_}->can("destroy");
146	pcg	1.5	}
147			}
148
149			sub DESTROY {
150			my ($self) = @_;
151	pcg	1.14	warn "DESTROY($self)";#d#
152	pcg	1.5	}
153
154	pcg	1.1	1;
155