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(<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# 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# } 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 = "$text"; # 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;