File Coverage

blib/lib/BBS/Perm/Term.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package BBS::Perm::Term;

use warnings;
use strict;
use Carp;
use Glib qw/TRUE FALSE/;
use Gnome2::Vte;
use File::Spec::Functions 'file_name_is_absolute';

sub new {
    my ( $class, %opt ) = @_;
    my $self = {%opt};
    $self->{widget}   = Gtk2::HBox->new unless $self->{widget};
    $self->{terms}    = [];
    $self->{titles}   = [];
    $self->{encoding} = [];
    bless $self, ref $class || $class;
}

sub init {    # initiate a new term
    my ( $self, $conf ) = @_;
    my $term = Gnome2::Vte::Terminal->new;
    push @{ $self->{terms} },  $term;
    push @{ $self->{titles} }, $conf->{title}
      || $conf->{username} . '@' . $conf->{site};
    push @{ $self->{encoding} }, $conf->{encoding};

    if ( defined $self->{current} ) {    # has term already?
        $self->term->hide;
    }

    $self->{current} = $#{ $self->{terms} };
    $self->widget->pack_start( $self->term, TRUE, TRUE, 0 );
    $self->term->show;
    $self->term->grab_focus;

    if ( $conf->{encoding} ) {
        $term->set_encoding( $conf->{encoding} );
    }

    if ( $conf->{font} ) {
        my $font = Pango::FontDescription->from_string( $conf->{font} );
        $term->set_font($font);
    }

    if ( $conf->{color} ) {
        my @elements = qw/foreground background dim bold cursor highlight/;
        for (@elements) {
            if ( $conf->{color}{$_} ) {
                no strict 'refs';
                "Gnome2::Vte::Terminal::set_color_$_"->(
                    $term, Gtk2::Gdk::Color->parse( $conf->{color}{$_} )
                );
            }
        }
    }

    if ( $conf->{background_file} && -e $conf->{background_file} ) {
        $term->set_background_image_file( $conf->{background_file} );
    }

    if ( $conf->{background_transparent} ) {
        $term->set_background_transparent(1);
    }

    if ( defined $conf->{opacity} ) {
        $conf->{opacity} *= 65535 if $conf->{opacity} <= 1;
        $term->set_opacity($conf->{opacity});
    }

    if ( defined $conf->{mouse_autohide} ) {
        $term->set_mouse_autohide( $conf->{mouse_autohide} );
    }

    my $timeout = defined $conf->{timeout} ? $conf->{timeout} : 60;
    if ($timeout) {
        $term->{timer} = Glib::Timeout->add( 1000 * $timeout,
            sub { $term->feed_child( chr 0 ); return TRUE; }, $term );
    }
}

sub clean {    # called when child exited
    my $self = shift;
    my ( $current, $new_pos );
    $new_pos = $current = $self->{current};
    if ( @{ $self->{terms} } > 1 ) {
        if ( $current == @{ $self->{terms} } - 1 ) {
            $new_pos = 0;
        }
        else {
            $new_pos++;
        }
        $self->term->hide;
        $self->{terms}->[$new_pos]->show;
        $self->{terms}->[$new_pos]->grab_focus;
    }
    else {
        undef $new_pos;
    }
    $self->widget->remove( $self->term );
    $self->term->destroy;
    splice @{ $self->{terms} }, $current, 1;
    $self->{current} = $new_pos == 0 ? 0 : $new_pos - 1
      if defined $new_pos;
}

sub term {    # get current terminal
    my $self = shift;
    return $self->{terms}->[ $self->{current} ]
      if defined $self->{current};
}

sub switch {    # switch terms, -1 for left, 1 for right
    my ( $self, $offset ) = @_;
    return unless $offset;
    return unless @{ $self->{terms} } > 1;

    my ( $current, $new_pos );
    $new_pos = $current = $self->{current};

    if ( $offset == 1 ) {
        if ( $current >= @{ $self->{terms} } - 1 ) {
            $new_pos = 0;
        }
        else {
            $new_pos++;
        }
    }
    elsif ( $offset == -1 ) {
        if ( $current == 0 ) {
            $new_pos = @{ $self->{terms} } - 1;
        }
        else {
            $new_pos--;
        }
    }
    $self->term->hide if defined $self->term;
    $self->{current} = $new_pos;
    if ( $self->term ) {
        $self->term->show;
        $self->term->grab_focus;
    }
}

sub connect {
    my ( $self, $conf, $file, $site ) = @_;
    my $agent = $conf->{agent} || $self->{agent};

    # check if it's a perl script
    my $use_current_perl;

    unless ( file_name_is_absolute( $agent ) ) {
        require File::Which;
        my $path = File::Which::which( $agent );
        if ( $path ) {
            $agent = $path;
        }
        else {
            die "can't find $agent";
        }
    }

    if ( -T $agent ) {
        open my $fh, '<', $agent or die "can't open $agent: $!";
        my $shebang = <$fh>;
        if ( $shebang =~ m{#!/usr/bin/(?:perl|env\s+perl)} ) {
            $use_current_perl = 1;
        }
    }
    elsif ( !-e $agent ) {
        die "$agent doesn't exist";
    }

    if ($agent) {
        $self->term->fork_command(
            ( $use_current_perl ? $^X : $agent ),
            (
                [
                    ( $use_current_perl ? ($^X) : () ),
                    $agent,
                    $conf->{protocol} =~ /ssh|telnet/ ? ( $file, $site ) : ()
                ]
            ),
            undef, q{}, FALSE, FALSE, FALSE
        );
    }
    else {
        croak 'seems something wrong with your agent script';
    }
}

sub title {
    my $self = shift;
    return $self->{titles}[ $self->{current} ];
}

sub encoding {
    my $self = shift;
    return $self->{encoding}[ $self->{current} ];
}

sub text {    # get current terminal's text
              # list context is needed.
    my $self = shift;
    if ( $self->term ) {
        my ($text) = $self->term->get_text( sub { return TRUE } );
        return $text;
    }
}

sub widget {
    return shift->{widget};
}

1;

__END__