Created
March 26, 2011 20:07
-
-
Save Elv13/888592 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#! perl | |
use Carp qw(confess cluck); | |
use AnyEvent; | |
use AnyEvent::DBus; | |
use Net::DBus::Annotation qw(:call); | |
use Net::DBus; | |
use Net::DBus::Service; | |
use Net::DBus::Reactor; | |
my $bus = Net::DBus->session(); | |
my $service = $bus->export_service("org.schmorp.urxvt"); | |
#my @dbusObject = ByPid->new($service,$$); | |
my @mainObj = {}; | |
my @dbusObject = {}; | |
sub refresh { | |
my ($self) = @_; | |
@mainObj[$$] = $self; | |
my $ncol = $self->ncol; | |
my $text = " " x $ncol; | |
my $rend = [($self->{rs_tabbar}) x $ncol]; | |
my @ofs; | |
substr $text, 0, 7, "[NEW2] |"; | |
@$rend[0 .. 5] = ($self->{rs_tab}) x 6; | |
push @ofs, [0, 6, sub { $_[0]->new_tab }]; | |
my $ofs = 7; | |
my $idx = 0; | |
for my $tab (@{ $self->{tabs} }) { | |
$idx++; | |
my $act = $tab->{activity} && $tab != $self->{cur} | |
? "*" : " "; | |
if ($tab->{activity} == 1 && $tab != $self->{cur}) { | |
print("Trying to emit\n\n"); | |
@dbusObject[$$]->emitContentChanged($idx); | |
} | |
my $txt = "$act$idx$act"; | |
my $len = length $txt; | |
substr $text, $ofs, $len + 1, "$txt|"; | |
@$rend[$ofs .. $ofs + $len - 1] = ($self->{rs_tab}) x $len | |
if $tab == $self->{cur}; | |
push @ofs, [ $ofs, $ofs + $len, sub { $_[0]->make_current ($tab) } ]; | |
$ofs += $len + 1; | |
} | |
$self->{tabofs} = \@ofs; | |
$self->ROW_t (0, $text, 0, 0, $ncol); | |
$self->ROW_r (0, $rend, 0, 0, $ncol); | |
$self->want_refresh; | |
} | |
sub new_tab { | |
my ($self, @argv) = @_; | |
my $offset = $self->fheight; | |
# save a backlink to us, make sure tabbed is inactive | |
push @urxvt::TERM_INIT, sub { | |
my ($term) = @_; | |
$term->{parent} = $self; | |
for (0 .. urxvt::NUM_RESOURCES - 1) { | |
my $value = $self->{resource}[$_]; | |
$term->resource ("+$_" => $value) | |
if defined $value; | |
} | |
$term->resource (perl_ext_2 => $term->resource ("perl_ext_2") . ",-tabbed"); | |
}; | |
push @urxvt::TERM_EXT, urxvt::ext::tabbed::tab::; | |
my $term = new urxvt::term | |
$self->env, $urxvt::RXVTNAME, | |
-embed => $self->parent, | |
@argv, | |
; | |
} | |
sub configure { | |
my ($self) = @_; | |
my $tab = $self->{cur}; | |
# this is an extremely dirty way to force a configurenotify, but who cares | |
$tab->XMoveResizeWindow ( | |
$tab->parent, | |
0, $self->{tabheight} + 1, | |
$self->width, $self->height - $self->{tabheight} | |
); | |
$tab->XMoveResizeWindow ( | |
$tab->parent, | |
0, $self->{tabheight}, | |
$self->width, $self->height - $self->{tabheight} | |
); | |
} | |
sub on_resize_all_windows { | |
my ($self, $width, $height) = @_; | |
1 | |
} | |
sub copy_properties { | |
my ($self) = @_; | |
my $tab = $self->{cur}; | |
my $wm_normal_hints = $self->XInternAtom ("WM_NORMAL_HINTS"); | |
my $current = delete $self->{current_properties}; | |
# pass 1: copy over properties different or nonexisting | |
for my $atom ($tab->XListProperties ($tab->parent)) { | |
my ($type, $format, $items) = $self->XGetWindowProperty ($tab->parent, $atom); | |
# fix up size hints | |
if ($atom == $wm_normal_hints) { | |
my (@hints) = unpack "l!*", $items; | |
$hints[$_] += $self->{tabheight} for (4, 6, 16); | |
$items = pack "l!*", @hints; | |
} | |
my $cur = delete $current->{$atom}; | |
# update if changed, we assume empty items and zero type and format will not happen | |
$self->XChangeProperty ($self->parent, $atom, $type, $format, $items) | |
if $cur->[0] != $type or $cur->[1] != $format or $cur->[2] ne $items; | |
$self->{current_properties}{$atom} = [$type, $format, $items]; | |
} | |
# pass 2, delete all extraneous properties | |
$self->XDeleteProperty ($self->parent, $_) for keys %$current; | |
} | |
sub make_current { | |
my ($self, $tab) = @_; | |
if (my $cur = $self->{cur}) { | |
delete $cur->{activity}; | |
$cur->XUnmapWindow ($cur->parent) if $cur->mapped; | |
$cur->focus_out; | |
} | |
$self->{cur} = $tab; | |
$self->configure; | |
$self->copy_properties; | |
$tab->focus_out; # just in case, should be a nop | |
$tab->focus_in if $self->focus; | |
$tab->XMapWindow ($tab->parent); | |
delete $tab->{activity}; | |
$self->refresh; | |
() | |
} | |
sub on_focus_in { | |
my ($self, $event) = @_; | |
$self->{cur}->focus_in; | |
() | |
} | |
sub on_focus_out { | |
my ($self, $event) = @_; | |
$self->{cur}->focus_out; | |
() | |
} | |
sub on_key_press { | |
my ($self, $event) = @_; | |
$self->{cur}->key_press ($event->{state}, $event->{keycode}, $event->{time}); | |
1 | |
} | |
sub on_key_release { | |
my ($self, $event) = @_; | |
$self->{cur}->key_release ($event->{state}, $event->{keycode}, $event->{time}); | |
1 | |
} | |
sub on_button_press { | |
1 | |
} | |
sub on_button_release { | |
my ($self, $event) = @_; | |
if ($event->{row} == 0) { | |
for my $button (@{ $self->{tabofs} }) { | |
$button->[2]->($self, $event) | |
if $event->{col} >= $button->[0] | |
&& $event->{col} < $button->[1]; | |
} | |
} | |
1 | |
} | |
sub on_motion_notify { | |
1 | |
} | |
sub on_init { | |
my ($self) = @_; | |
$self->{resource} = [map $self->resource ("+$_"), 0 .. urxvt::NUM_RESOURCES - 1]; | |
$self->resource (int_bwidth => 0); | |
$self->resource (name => "URxvt.tabbed"); | |
$self->resource (pty_fd => -1); | |
$self->option ($urxvt::OPTION{scrollBar}, 0); | |
my $fg = $self->x_resource ("tabbar-fg"); | |
my $bg = $self->x_resource ("tabbar-bg"); | |
my $tabfg = $self->x_resource ("tab-fg"); | |
my $tabbg = $self->x_resource ("tab-bg"); | |
defined $fg or $fg = 3; | |
defined $bg or $bg = 0; | |
defined $tabfg or $tabfg = 0; | |
defined $tabbg or $tabbg = 1; | |
$self->{rs_tabbar} = urxvt::SET_COLOR (urxvt::DEFAULT_RSTYLE, $fg + 2, $bg + 2); | |
$self->{rs_tab} = urxvt::SET_COLOR (urxvt::DEFAULT_RSTYLE, $tabfg + 2, $tabbg + 2); | |
() | |
} | |
sub on_start { | |
my ($self) = @_; | |
#my $bus = Net::DBus->session(); | |
#my $service = $bus->export_service("org.schmorp.urxvt"); | |
@dbusObject[$$] = ByPid->new($service,$$); | |
$self->{tabheight} = $self->int_bwidth + $self->fheight + $self->lineSpace; | |
$self->cmd_parse ("\033[?25l"); | |
my @argv = $self->argv; | |
do { | |
shift @argv; | |
} while @argv && $argv[0] ne "-e"; | |
$self->new_tab (@argv); | |
() | |
} | |
sub on_configure_notify { | |
my ($self, $event) = @_; | |
$self->configure; | |
$self->refresh; | |
() | |
} | |
sub on_wm_delete_window { | |
my ($self) = @_; | |
$_->destroy for @{ $self->{tabs} }; | |
1 | |
} | |
sub tab_start { | |
my ($self, $tab) = @_; | |
$tab->XChangeInput ($tab->parent, urxvt::PropertyChangeMask); | |
push @{ $self->{tabs} }, $tab; | |
# $tab->{name} ||= scalar @{ $self->{tabs} }; | |
$self->make_current ($tab); | |
() | |
} | |
sub tab_destroy { | |
my ($self, $tab) = @_; | |
$self->{tabs} = [ grep $_ != $tab, @{ $self->{tabs} } ]; | |
if (@{ $self->{tabs} }) { | |
if ($self->{cur} == $tab) { | |
delete $self->{cur}; | |
$self->make_current ($self->{tabs}[-1]); | |
} else { | |
$self->refresh; | |
} | |
} else { | |
# delay destruction a tiny bit | |
$self->{destroy} = urxvt::iw->new->start->cb (sub { $self->destroy }); | |
} | |
() | |
} | |
sub tab_key_press { | |
my ($self, $tab, $event, $keysym, $str) = @_; | |
if ($event->{state} & urxvt::ShiftMask) { | |
if ($keysym == 0xff51 || $keysym == 0xff53) { | |
my ($idx) = grep $self->{tabs}[$_] == $tab, 0 .. $#{ $self->{tabs} }; | |
--$idx if $keysym == 0xff51; | |
++$idx if $keysym == 0xff53; | |
$self->make_current ($self->{tabs}[$idx % @{ $self->{tabs}}]); | |
return 1; | |
} elsif ($keysym == 0xff54) { | |
$self->new_tab; | |
return 1; | |
} | |
} | |
###This code allow to switch from tab to tab with the keyboard, however, it is | |
###in direct conflict with the bash/zsh "move cursor one word left" | |
###enable it at will or replace the shortcut to something else. | |
#elsif ($event->{state} & urxvt::ControlMask) { | |
# if ($keysym == 0xff51 || $keysym == 0xff53) { | |
# my ($idx1) = grep $self->{tabs}[$_] == $tab, 0 .. $#{ $self->{tabs} }; | |
# my $idx2 = ($idx1 + ($keysym == 0xff51 ? -1 : +1)) % @{ $self->{tabs} }; | |
# | |
# ($self->{tabs}[$idx1], $self->{tabs}[$idx2]) = | |
# ($self->{tabs}[$idx2], $self->{tabs}[$idx1]); | |
# | |
# $self->make_current ($self->{tabs}[$idx2]); | |
# | |
# return 1; | |
# } | |
#} | |
() | |
} | |
sub tab_property_notify { | |
my ($self, $tab, $event) = @_; | |
$self->copy_properties | |
if $event->{window} == $tab->parent; | |
() | |
} | |
sub tab_activity { | |
my ($self, $tab) = @_; | |
$self->refresh; | |
} | |
package urxvt::ext::tabbed::tab; | |
# helper extension implementing the subwindows of a tabbed terminal. | |
# simply proxies all interesting calls back to the tabbed class. | |
{ | |
for my $hook qw(start destroy key_press property_notify) { | |
eval qq{ | |
sub on_$hook { | |
my \$parent = \$_[0]{term}{parent} | |
or return; | |
\$parent->tab_$hook (\@_) | |
} | |
}; | |
die if $@; | |
} | |
} | |
sub on_add_lines { | |
$_[0]->{activity}++ | |
or $_[0]{term}{parent}->tab_activity ($_[0]); | |
() | |
} | |
package ByPid; | |
use base qw(Net::DBus::Object); | |
use Net::DBus::Exporter qw(org.schmorp.urxvt); | |
#Read only properties | |
dbus_property("count", "string","read"); | |
dbus_property("email", "string", "read"); | |
#Read and write properties | |
dbus_property("age", "int32", "write"); | |
#Signals | |
dbus_signal("contentChanged", ["string"]); #Arg=the tab index, usually 0 | |
sub new { | |
my $class = shift; | |
my $service = shift; | |
my $self = $class->SUPER::new($service, "/pid/".shift."/control"); | |
bless $self, $class; | |
return $self; | |
} | |
dbus_method("addTab", [], ["int32"]); | |
sub addTab { | |
my $self = shift; | |
my $message = shift; | |
print "Do hello world\n"; | |
@mainObj[$$]->new_tab(); | |
for my $tab (@{ @mainObj[$$]->{tabs} }) { | |
print $tab."Do hello world\n"; | |
} | |
return ["Hello", " from example-service.pl"]; | |
} | |
dbus_method("selectTab", [], ["int32"]); | |
sub selectTab { | |
my $self = shift; | |
my $message = shift; | |
print "Do hello world2\n"; | |
@mainObj[$$]->make_current (@{@mainObj[$$]->{tabs} }[$message]); | |
for my $tab (@{ @mainObj[$$]->{tabs} }) { | |
print $tab."Do hello world\n"; | |
} | |
return ["Hello", " from example-service.pl"]; | |
} | |
#For some odd reasons, we might want to call it externally | |
dbus_method("emitContentChanged", [], ["int32"]); | |
sub emitContentChanged { | |
my $self = shift; | |
my $index = shift; | |
$self->emit_signal("contentChanged", "$index"); | |
print("Signal emmited\n\n"); | |
return "done"; | |
} | |
package UrxvtTab; | |
use base qw(Net::DBus::Object); | |
use Net::DBus::Exporter qw(org.schmorp.urxvt); | |
sub new { | |
my $class = shift; | |
my $service = shift; | |
my $self = $class->SUPER::new($service, "/pid/".shift."/".shift); | |
bless $self, $class; | |
return $self; | |
} | |
dbus_method("closeTab", ["int32"], [["array", "string"]]); | |
sub closeTab { | |
my $self = shift; | |
my $message = shift; | |
print "Do hello world\n"; | |
print $message, "\n"; | |
return ["Hello", " from example-service.pl"]; | |
} | |
dbus_method("getTitle", [], ["string"]); | |
sub getTitle { | |
my $self = shift; | |
my $message = shift; | |
print "Do hello world\n"; | |
print $message, "\n"; | |
return "Hello title 1"; | |
} | |
package main; | |
sub start_thread { | |
my $bus = Net::DBus->session(); | |
my $service = $bus->export_service("org.schmorp.urxvt"); | |
#my $object2 = UrxvtTab->new($service,12,1); | |
#my $object3 = UrxvtTab->new($service,12,2); | |
#my $object4 = UrxvtTab->new($service,12,3); | |
#my $object = ByPid->new($service,12); | |
#Net::DBus::Reactor->main->run(); | |
#AE::cv->recv; | |
} | |
#start_thread(); |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment