view release on metacpan or  search on metacpan

lib/GTM.pm  view on Meta::CPAN

    gtm_run ($cmd, %r);
}

sub get_gtm_version () {
    my $lines;
    gtm_run (
        [qw[ mumps -direct ]],
        ">"  => \$lines,
        "2>" => \$lines,
        "<"  => \"Write \$C(26)_\$ZVersion_\$C(26)_\$ZCHset_\$C(26) Halt\n",
        cb   => sub {
            output ("$lines\n");
            if ($lines =~ m/\x1a([^\x1a]+)\x1a([^\x1a]+)\x1a/ms) {
                $gtm_version = $1;
                $gtm_utf8    = 1;
                $gtm_utf8    = 0 if $2 eq "M";
                $main_window->set_title ("GT.M GUI v$VERSION ($gtm_version) UTF-8=$gtm_utf8");
            }
        }
    );
}

sub gtm_integ () {

    # gtm_run_out ([ qw[ mupip integ -full -noonline -reg * ]]);
    gtm_run_out ([qw[ mupip integ -noonline -reg * ]]);
}

sub gtm_rundown () {
    gtm_run_out ([qw[ mupip rundown /REG=* ]]);
}

sub gtm_freeze ($) {
    if ($_[0]) {
        gtm_run_out ([qw[ mupip freeze -on * ]]);
    } else {
        gtm_run_out ([qw[ mupip freeze -off * ]]);
    }
}

sub gtm_journal ($) {
    if ($_[0]) {
        gtm_run_out ([qw[ mupip SET -JOURNAL=ON,BEFORE_IMAGES -REGION * ]]);
    } else {
        gtm_run_out ([qw[ mupip SET -JOURNAL=OFF -REGION * ]]);
    }
}

sub remove_lock($$$) {
    my ($ref, $pid, $cb) = @_;
    gtm_run (
             [ "lke", "clear", "-pid=$pid", "-lock=$ref", "-nointeractive" ],
             ">"  => sub { output (@_) },
             "2>" => sub { output (@_) },
             $cb ? (cb => $cb) : (),
            );
}

my @buttons;

sub update_locks ($) {
    my $box = shift;
    my $lines;
    my $cv = gtm_run (
        [qw/lke show -all/],
        ">"  => \$lines,
        "2>" => \$lines,
        cb   => sub {
            output ("$lines\n");
            $box->remove ($_) for (@buttons);
            @buttons = ();
            while ($lines =~ m/^(.*)\s+Owned\s+by\s+PID=\s*(\d+)/mg) {
                my ($ref, $pid) = ($1, $2);
                my $b = new Gtk2::Button ("ref=$ref pid=$pid");
                $b->signal_connect (
                    "clicked" => sub {
                        remove_lock ($ref, $pid, sub { update_locks ($box) });
                    }
                );
                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);
    }