GTM
view release on metacpan or search on metacpan
package GTM;
our $VERSION = "0.6";
use common::sense;
use utf8;
use Gtk2;
use Gtk2::SimpleMenu ();
use AnyEvent;
use AnyEvent::Util;
use File::HomeDir ();
use Gtk2::Ex::PodViewer ();
use POSIX qw(setsid _exit);
=head1 NAME
GTM - A gui frontend for the GT.M database
=head1 SYNOPSIS
gtm
run the gtm frontend
=head1 FILES
~/.gtmrc
preferences (you can source it).
=cut
BEGIN {
use base 'Exporter';
our @EXPORT_OK = qw(set_busy output %override save_prefs);
our @EXPORT = ();
}
use GTM::Run ();
our %override;
our ($gtm_version, $gtm_utf8);
our @gtm_variables = (qw/gtm_dist gtmroutines gtmgbldir gtm_log gtm_chset gtm_icu_version/);
our %win_size;
sub win_size ($$;$$) {
my ($w, $n, $x, $y) = @_;
unless (exists $win_size{$n}) {
$win_size{$n} = [ $x || 960, $y || 600 ];
}
$w->signal_connect (
size_allocate => sub {
$win_size{$n} = [ $_[1]->width, $_[1]->height ];
}
);
$w->resize (@{$win_size{$n}});
}
my $main_window;
sub error_dialog ($@) {
my ($parent, @data) = @_;
my $dialog = new Gtk2::Dialog ("Program Error, \$\@ exception raised.", $parent, 'modal', OK => 42);
win_size ($dialog, "error_dialog", 670, 320);
$dialog->set_default_response (42);
my $sa = new_scrolled_textarea ();
$sa->set_size_request (660, 300);
scrollarea_output ($sa, join "", @data);
$dialog->vbox->add ($sa);
$dialog->show_all;
$dialog->run;
$dialog->destroy;
}
sub gtm_doc ($$) {
my ($parent, $file) = @_;
my $dialog = new Gtk2::Dialog ("Documentation", $parent, 'modal', OK => 42);
$dialog->set_default_response (42);
my $pod = new Gtk2::Ex::PodViewer;
my $file = findfile ("GTM/$file");
$pod->load ($file);
$pod->set_size_request (660, 620);
$dialog->vbox->add ($pod);
$dialog->show_all;
$dialog->run;
$dialog->destroy;
}
sub new_scrolled_textarea () {
my $tv = new Gtk2::TextView;
my $s = new Gtk2::ScrolledWindow;
$s->add ($tv);
$tv->set_editable (0);
$tv->set_cursor_visible (0);
my $buffer = $tv->get_buffer;
my $end_mark = $buffer->create_mark ('end', $buffer->get_end_iter, 0);
$s->{end} = $end_mark;
$s->{tv} = $tv;
$s->can_focus (0);
$tv->can_focus (0);
my $font_desc = Gtk2::Pango::FontDescription->from_string ("monospace 10");
$tv->modify_font ($font_desc);
$s;
}
sub scrollarea_clear ($) {
my $s = shift;
$s->{tv}->set_buffer (new Gtk2::TextBuffer);
my $buffer = $s->{tv}->get_buffer;
my $end_mark = $buffer->create_mark ('end', $buffer->get_end_iter, 0);
$s->{end} = $end_mark;
}
sub scrollarea_output ($@) {
my ($sa, @d) = @_;
my $tv = $sa->{tv};
my $lines = join "", @d;
my $buf = $tv->get_buffer;
$buf->insert ($buf->get_end_iter, $lines);
$tv->scroll_to_mark ($sa->{end}, 0, 1, 0, 1);
}
my $rcfile = my_home File::HomeDir . "/.gtmrc";
sub save_prefs () {
open my $fh, ">", $rcfile
or do { warn "can't create '$rcfile': $!"; return; };
while (my ($k, $v) = each %win_size) {
print $fh "# win=$k w=$v->[0] h=$v->[1]\n";
}
while (my ($k, $v) = each %override) {
$v =~ s/"/\\"/g;
print $fh "$k=\"$v\"\nexport $k\n\n";
}
}
sub load_prefs () {
open my $fh, "<", $rcfile
or do { warn "can't open '$rcfile': $!"; return; };
while (my $line = <$fh>) {
if ($line =~ /^#\s+win=(\w+)\s+w=(\d+)\s+h=(\d+)$/) {
my ($window, $win_width, $win_height) = ($1, $2, $3);
$win_size{$window} = [ $win_width, $win_height ];
}
if ($line =~ /^(gtm\w+)=\"(.*)\"$/) {
my ($k, $v) = ($1, $2);
$v =~ s/\\"/"/g;
$override{$k} = $v;
}
}
}
# as you can see, i don't like xterm :)
# run update-alternatives --config x-terminal-emulator
# to set the default terminal type
sub run_console () {
my $pid = fork;
return unless $pid == 0;
local %ENV = (%ENV, %override);
setsid;
exec ($_, "-e", "$ENV{gtm_dist}/mumps", "-direct")
for (
qw/x-terminal-emulator urxvt
rxvt-unicode rxvt Eterm
konsole xterm/
);
_exit (0);
}
sub ident_file ($) {
my $f = shift;
open my $fh, "<", $f or return;
sysread $fh, my $buffer, 512;
# dies ist der header comment UTF-8
# GT.M 09-FEB-2010 10:17:47
return ("gtm-globals", $1)
if (
$buffer =~ m/ ^ (.*) \015? \012
GT\.M \s+
\d+ - [A-Z]{3} - \d{4} \s+
\d+ : \d+ : \d+
/sx
);
# Cache for Windows NT^INT^dies ist die description^~Format=Cache.S~
# %RO on 08 Feb 2010 4:19 PM
return ("cac-routines", $1)
if (
$buffer =~ m/ ^Cache \s+ for \s+ .*?
\^ .*? \^ (.*?) \^
.*? \015? \012
\% RO \s+ on \s+ \d+
sub edit_environment (@) {
my $dialog = new Gtk2::Dialog (
"Customize environment", $main_window, 'modal',
'gtk-cancel' => 0,
OK => 42
);
$dialog->set_default_response (42);
my @vars = @_;
my $cnt = @vars;
my $t = new Gtk2::Table ($cnt + 1, 3, 0);
my $e0 = new Gtk2::Entry;
my $e1 = new Gtk2::Entry;
my $e2 = new Gtk2::Entry;
my $l0 = new Gtk2::Label ("Environment Variable");
my $l1 = new Gtk2::Label ("Environment Value");
my $l2 = new Gtk2::Label ("Environment Override");
$l1->set_size_request (400, -1);
$l2->set_size_request (400, -1);
$t->attach_defaults ($l0, 0, 1, 0, 1);
$t->attach_defaults ($l1, 1, 2, 0, 1);
$t->attach_defaults ($l2, 2, 3, 0, 1);
my @entries;
for my $i (0 .. $cnt - 1) {
my $env = new Gtk2::Entry;
$env->set_editable (0);
$env->set_text ($vars[$i]);
$env->can_focus (0);
$t->attach_defaults ($env, 0, 1, $i + 1, $i + 2);
my $val = new Gtk2::Entry;
$val->set_editable (0);
$val->can_focus (0);
my $v = $ENV{$vars[$i]};
unless (exists $ENV{$vars[$i]}) {
$v = '<<<undef>>>';
$val->modify_base ('GTK_STATE_NORMAL', new Gtk2::Gdk::Color (65535, 65535, 1000));
}
$val->set_text ($v);
$t->attach_defaults ($val, 1, 2, $i + 1, $i + 2);
my $e = new Gtk2::Entry;
my $v = $override{$vars[$i]};
$e->set_text ($v);
$t->attach_defaults ($e, 2, 3, $i + 1, $i + 2);
$entries[$i] = $e;
}
$dialog->vbox->add ($t);
$dialog->show_all;
if ($dialog->run == 42) {
for (my $i = 0 ; $i < $cnt ; $i++) {
my $k = $vars[$i];
my $v = $entries[$i]->get_text;
delete $override{$k};
$override{$k} = $v if length $v;
}
get_gtm_version ();
save_prefs;
}
$dialog->destroy;
}
my $menu_tree = [
_File => {
item_type => '<Branch>',
children => [
"_Routine Restore" => {
callback => sub { gtm_routine_restore; },
accelerator => 'F2',
},
"_Global Restore" => {
callback => sub { gtm_global_restore; },
accelerator => 'F3',
},
'Global _Output (%GO)' => {callback => sub { gtm_go ($main_window); },},
Separator => {item_type => '<Separator>',},
"_Console" => {
callback => sub { run_console; },
accelerator => '<Alt>C',
},
Separator => {item_type => '<Separator>',},
E_xit => {
callback => sub { main_quit Gtk2; },
accelerator => '<Alt>X',
},
],
},
_Variables => {
item_type => '<Branch>',
children => [
'_Edit all variables' => {callback => sub { edit_environment (@gtm_variables) },},
'_Clear all overrides' => {callback => sub { %override = (); save_prefs(); },},
Separator => {item_type => '<Separator>',},
],
},
_Database => {
item_type => '<Branch>',
children => [
'_Integrity check' => {
callback => sub { gtm_integ (); }
},
'_Rundown' => {
callback => sub {
gtm_rundown ();
},
accelerator => '<Alt>R'
},
Separator => {item_type => '<Separator>',},
'_Freeze Database' => {
callback => sub {
gtm_freeze (1);
}
},
'_Thaw Database' => {
callback => sub {
gtm_freeze (0);
}
},
Separator => {item_type => '<Separator>',},
'_Backup Database' => {
callback => sub {
gtm_backup();
}
},
],
},
_Locks => {
item_type => '<Branch>',
children => [
'Manage Locks' => {
callback => sub {
gtm_locks ();
}
},
],
},
_Journal => {
item_type => '<Branch>',
children => [
'_Enable\/switch Journal' => {
callback => sub {
gtm_journal (1);
}
},
'_Disable Journal' => {
callback => sub {
gtm_journal (0);
}
}
push @buttons, $b;
$box->pack_start ($b, 0, 0, 0);
$b->show;
}
}
);
}
sub gtm_locks() {
@buttons = ();
my $dialog = new Gtk2::Dialog ("Manage Locks", $main_window, 'modal', OK => 42);
win_size ($dialog, "manage_locks", 200, 200);
$dialog->set_default_response (42);
my $button = new Gtk2::Button ("_Refresh");
my $frame = new Gtk2::Frame ("Locks held");
$frame->set_border_width (5);
$frame->set_shadow_type ("etched-out");
my $vbox = new Gtk2::VBox;
$frame->add ($vbox);
$button->signal_connect (clicked => sub { update_locks ($vbox); });
$dialog->vbox->pack_start ($button, 0, 0, 0);
$dialog->vbox->pack_start ($frame, 0, 0, 0);
update_locks ($vbox);
$dialog->show_all;
$dialog->run;
$dialog->destroy;
}
$SIG{__WARN__} = sub { output @_; };
sub findfile {
my @files = @_;
file:
for (@files) {
for my $prefix (@INC, "/") {
if (-f "$prefix/$_") {
$_ = "$prefix/$_";
next file;
}
}
die "$_: file not found in \@INC\nINC=" . join ("\n", @INC);
}
wantarray ? @files : $files[0];
}
our $button;
sub new () {
my $menu = new Gtk2::SimpleMenu (menu_tree => $menu_tree);
$main_scroll = new_scrolled_textarea();
$main_window = new Gtk2::Window ('toplevel');
$main_window->signal_connect (destroy => sub { main_quit Gtk2; });
win_size ($main_window, "main_window", 960, 600);
my $v = new Gtk2::VBox;
$v->pack_start ($menu->{widget}, 0, 0, 0);
$v->pack_start ($button, 0, 0, 0);
$v->add ($main_scroll);
$main_window->add ($v);
$main_window->add_accel_group ($menu->{accel_group});
load_prefs;
set_busy (0);
get_gtm_version();
$main_window;
}
my $was_busy = 1;
my $timer;
my $counter = 0;
my ($red, $green, $off);
$button = new Gtk2::Button;
$green = new_from_file Gtk2::Image (findfile ("GTM/images/ampel-green.png"));
$red = new_from_file Gtk2::Image (findfile ("GTM/images/ampel-red.png"));
$off = new_from_file Gtk2::Image (findfile ("GTM/images/ampel-off.png"));
sub set_busy ($) {
my $busy = shift;
return if $was_busy == $busy;
if ($busy == 0) {
undef $timer;
$button->set_image ($green);
} else {
$counter = 0;
$timer = AnyEvent->timer (
after => 0,
interval => .25,
cb => sub {
$button->set_image (++$counter % 2 ? $red : $off);
}
);
}
$was_busy = $busy;
}
=head1 SEE ALSO
L<GTM::Run>
=head1 AUTHOR
Stefan Traby <stefan@hello-penguin.com>
http://oesiman.de/gt.m/
=cut
1;
( run in 0.979 second using v1.01-cache-2.11-cpan-8f98c5d2c55 )