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 "$::IMGDIR/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#

   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#
}

package gtk::text;

use base gtk::widget;

my $tagtable = new Gtk2::TextTagTable;

{
   my %tags = (
      default     => { foreground => "black" },
      node        => { foreground => "#0000b0", event => 1 },
      move        => { foreground => "#0000b0", event => 1 },
      user        => { foreground => "#0000b0", event => 1 },
      coord       => { foreground => "#0000b0", event => 1 },
      header      => { weight => 800, pixels_above_lines => 6 },
      description => { weight => 800, foreground => "blue" },
      infoblock   => { weight => 700, foreground => "blue" },
   );

   while (my ($k, $v) = each %tags) {
      my $tag = new Gtk2::TextTag $k;
      if (delete $v->{event}) {
         ###
      }
      $tag->set (%$v);
      $tagtable->add ($tag);
   }
}

sub new {
   my $class = shift;
   my $self = $class->SUPER::new(@_);

   $self->{buffer} = new Gtk2::TextBuffer $tagtable;

   $self->{widget} = new Gtk2::ScrolledWindow;
   $self->{widget}->set_policy("never", "always");

   $self->{widget}->add ($self->{view} = new_with_buffer Gtk2::TextView $self->{buffer});
   $self->{view}->set_wrap_mode ("word");
   $self->{view}->set_cursor_visible (0);

   $self->{view}->set_editable (0);

   use PApp::Util; warn PApp::Util::dumpval ($self->{view}->get_events);
   $self->{view}->signal_connect (motion_notify_event => sub {
      my ($widget, $event) = @_;

      my $window = $widget->get_window ("text");
      if ($event->window == $window) {
         my ($win, $x, $y, $mask) = $window->get_pointer;
          #     warn "TAG EVENT @_ ($window, $win, $x, $y, $mask)\n";
          #gtk_text_view_window_to_buffer_coords (text_view,
          #                                       GTK_TEXT_WINDOW_TEXT,
          #                                       text_view->drag_start_x,
          #                                       text_view->drag_start_y,
          #                                       &buffer_x,
          #                                       &buffer_y);
#
#          gtk_text_layout_get_iter_at_pixel (text_view->layout,
#                                             &iter,
#                                             buffer_x, buffer_y);
#
#          gtk_text_view_start_selection_dnd (text_view, &iter, event);
#          return TRUE;
      }
      0;
   });

   $self->set_end;

   $self;
}

sub set_end {
   my ($self) = @_;

   # this is probably also a hack...
   $self->{idle} ||= add Glib::Idle sub {
      $self->{view}->scroll_to_iter ($self->{buffer}->get_end_iter, 0, 0, 0, 0)
         if $self->{view};
      delete $self->{idle};
   };
}

sub at_end {
   my ($self) = @_;

   # this is, maybe, a bad hack :/
   my $adj = $self->{widget}->get_vadjustment;
   $adj->value + $adj->page_size >= $adj->upper - 0.5;
}

sub append_text {
   my ($self, $text) = @_;

   my $at_end = $self->at_end;

   my @tag;
   $text = "<default>$text</default>";

   # pseudo-simplistic-xml-parser
   for (;;) {
      $text =~ /\G<([^>]+)>/gc or last;
      my $tag = $1;
      if ($tag =~ s/^\///) {
         pop @tag;
      } else {
         push @tag, $tag;
      }

      $text =~ /\G([^<]*)/gc or last;
      $self->{buffer}->insert_with_tags_by_name ($self->{buffer}->get_end_iter, util::xmlto $1, $tag[-1])
         if length $1;
   }

   $self->set_end if $at_end;
}

sub set_text {
   my ($self, $text) = @_;

   my $at_end = $self->at_end;
           
   $self->{buffer}->set_text ("");
   $self->append_text ($text);

   $self->set_end if $at_end;
}

1;

Revision:	1.26
Committed:	Sat Jun 28 04:26:15 2003 UTC (20 years, 11 months ago) by pcg
Content type:	text/plain
Branch:	MAIN
Changes since 1.25:	+3 -3 lines
Log Message:	* empty log message *
#	Content
1	package gtk;
2
3	use Carp;
4	use File::Temp;
5	use Gtk2;
6
7	# I have not yet found a way to simply default style properties
8	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	our $text_renderer = new Gtk2::CellRendererText;
18	our $int_renderer = new Gtk2::CellRendererText;
19	$int_renderer->set (xalign => 1);
20
21	our $state = $util::state->{gtk} \|\|= {};
22
23	# shows the properties of a glib object
24	sub info {
25	my ($idx, $obj) = @_;
26	return if $seen{$idx}++;
27	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	column_size => sub { $_[0]->get("width") \|\| $_[0]->get("fixed_width") },
37	modelsortorder => sub { [ $_[0]->get_sort_column_id ] },
38	);
39
40	my %set = (
41	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	modelsortorder => sub { $_[0]->set_sort_column_id (@{$_[1]}) },
45	);
46
47	my %widget;
48
49	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
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	$set{$get} ? $set{$get}->($widget, $v) : $widget->set($set => $v);
63
64	#my $vx = KGS::Listener::Debug::dumpval $v; $vx =~ s/\s+/ /g; warn "set $class ($instance) $set => $vx\n";#d#
65	}
66
67	#$widget->signal_connect(destroy => sub { delete $widget{$widget}; 0 });
68
69	$widget{$widget} = [$widget, $class, $instance, \%attr];
70	Scalar::Util::weaken $widget{$widget}[0];
71	}
72
73	sub save_state {
74	for (grep $_, values %widget) {
75	my ($widget, $class, $instance, $attr) = @$_;
76
77	next unless $widget; # no destroy => widget may be undef
78
79	$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
88	#my $vx = KGS::Listener::Debug::dumpval $v; $vx =~ s/\s+/ /g; warn "get $class ($instance) $get => $vx\n";#d#
89	}
90	}
91	}
92
93	# string => Gtk2::Image
94	sub image_from_data {
95	my ($data) = @_;
96	my $img;
97
98	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	$img = new_from_file Gtk2::Image "$::IMGDIR/default_userpic.png";
107	}
108
109	$img;
110	}
111
112	package gtk::widget;
113
114	# hacked gtk pseudo-widget
115
116	sub new {
117	my $class = shift;
118	bless { @_ }, $class;
119	}
120
121	sub widget { $_[0]{widget} }
122
123	sub AUTOLOAD {
124	$AUTOLOAD =~ /::([^:]+)$/ or Carp::confess "$AUTOLOAD: no such method (illegal name)";
125	ref $_[0]{widget} or Carp::confess "AUTOLOAD: non-method call $AUTOLOAD(@_)\n";
126	my $method = $_[0]{widget}->can($1)
127	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	sub destroy {
134	my ($self) = @_;
135	warn "destroy($self)";#d#
136
137	for (keys %$self) {
138	warn "$self->{$_} destroy" if UNIVERSAL::can ($self->{$_}, "destroy");
139	(delete $self->{$_})->destroy
140	if UNIVERSAL::can ($self->{$_}, "destroy");
141	# if (UNIVERSAL::isa ($self->{$_}, Glib::Object)
142	# && UNIVERSAL::isa ($self->{$_}, gtk::widget))
143	# && $self->{$_}->can("destroy");
144	}
145	}
146
147	sub DESTROY {
148	my ($self) = @_;
149	warn "DESTROY($self)";#d#
150	}
151
152	package gtk::text;
153
154	use base gtk::widget;
155
156	my $tagtable = new Gtk2::TextTagTable;
157
158	{
159	my %tags = (
160	default => { foreground => "black" },
161	node => { foreground => "#0000b0", event => 1 },
162	move => { foreground => "#0000b0", event => 1 },
163	user => { foreground => "#0000b0", event => 1 },
164	coord => { foreground => "#0000b0", event => 1 },
165	header => { weight => 800, pixels_above_lines => 6 },
166	description => { weight => 800, foreground => "blue" },
167	infoblock => { weight => 700, foreground => "blue" },
168	);
169
170	while (my ($k, $v) = each %tags) {
171	my $tag = new Gtk2::TextTag $k;
172	if (delete $v->{event}) {
173	###
174	}
175	$tag->set (%$v);
176	$tagtable->add ($tag);
177	}
178	}
179
180	sub new {
181	my $class = shift;
182	my $self = $class->SUPER::new(@_);
183
184	$self->{buffer} = new Gtk2::TextBuffer $tagtable;
185
186	$self->{widget} = new Gtk2::ScrolledWindow;
187	$self->{widget}->set_policy("never", "always");
188
189	$self->{widget}->add ($self->{view} = new_with_buffer Gtk2::TextView $self->{buffer});
190	$self->{view}->set_wrap_mode ("word");
191	$self->{view}->set_cursor_visible (0);
192
193	$self->{view}->set_editable (0);
194
195	use PApp::Util; warn PApp::Util::dumpval ($self->{view}->get_events);
196	$self->{view}->signal_connect (motion_notify_event => sub {
197	my ($widget, $event) = @_;
198
199	my $window = $widget->get_window ("text");
200	if ($event->window == $window) {
201	my ($win, $x, $y, $mask) = $window->get_pointer;
202	# warn "TAG EVENT @_ ($window, $win, $x, $y, $mask)\n";
203	#gtk_text_view_window_to_buffer_coords (text_view,
204	# GTK_TEXT_WINDOW_TEXT,
205	# text_view->drag_start_x,
206	# text_view->drag_start_y,
207	# &buffer_x,
208	# &buffer_y);
209	#
210	# gtk_text_layout_get_iter_at_pixel (text_view->layout,
211	# &iter,
212	# buffer_x, buffer_y);
213	#
214	# gtk_text_view_start_selection_dnd (text_view, &iter, event);
215	# return TRUE;
216	}
217	0;
218	});
219
220	$self->set_end;
221
222	$self;
223	}
224
225	sub set_end {
226	my ($self) = @_;
227
228	# this is probably also a hack...
229	$self->{idle} \|\|= add Glib::Idle sub {
230	$self->{view}->scroll_to_iter ($self->{buffer}->get_end_iter, 0, 0, 0, 0)
231	if $self->{view};
232	delete $self->{idle};
233	};
234	}
235
236	sub at_end {
237	my ($self) = @_;
238
239	# this is, maybe, a bad hack :/
240	my $adj = $self->{widget}->get_vadjustment;
241	$adj->value + $adj->page_size >= $adj->upper - 0.5;
242	}
243
244	sub append_text {
245	my ($self, $text) = @_;
246
247	my $at_end = $self->at_end;
248
249	my @tag;
250	$text = "<default>$text</default>";
251
252	# pseudo-simplistic-xml-parser
253	for (;;) {
254	$text =~ /\G<([^>]+)>/gc or last;
255	my $tag = $1;
256	if ($tag =~ s/^\///) {
257	pop @tag;
258	} else {
259	push @tag, $tag;
260	}
261
262	$text =~ /\G([^<]*)/gc or last;
263	$self->{buffer}->insert_with_tags_by_name ($self->{buffer}->get_end_iter, util::xmlto $1, $tag[-1])
264	if length $1;
265	}
266
267	$self->set_end if $at_end;
268	}
269
270	sub set_text {
271	my ($self, $text) = @_;
272
273	my $at_end = $self->at_end;
274
275	$self->{buffer}->set_text ("");
276	$self->append_text ($text);
277
278	$self->set_end if $at_end;
279	}
280
281	1;
282