view release on metacpan or  search on metacpan

lib/Term/GnuScreen.pm  view on Meta::CPAN

package Term::GnuScreen;

use Moo;
use File::Temp qw(tmpnam);
use autodie qw(:all);
use File::Which;
use IO::CaptureOutput qw(capture);

our $VERSION = '0.06';

BEGIN {

	no strict 'refs';

	my @commands = ( qw( acladd aclchg acldel aclgrp aclumask activity addacl allpartial
	altscreen at attrcolor autodetach autonuke backtick bce bell_msg 
	bindkey blanker blankerprg break breaktype bufferfile c1 caption chacl
	charset clear colon command compacthist console copy copy_reg
	crlf debug defautonuke defbce defbreaktype defc1 defcharset defencoding
	defescape defflow defgr defhstatus deflog deflogin defmode defmonitor
	defnonblock defobuflimit defscrollback defshell defsilence defslowpaste
	defutf8 defwrap defwritelock defzombie detach digraph dinfo displays
	dumptermcap echo encoding escape eval fit flow focus gr 
	hardcopy_append hardcopydir hardstatus height help history hstatus idle
	ignorecase info ins_reg lastmsg license lockscreen log logfile login
	logtstamp mapdefault mapnotnext maptimeout markkeys maxwin monitor
	msgminwait msgwait multiuser nethack next nonblock number obuflimit only
	other partial password paste pastefont pow_break pow_detach pow_detach_msg
	prev printcmd process quit readbuf readreg redisplay register remove
	removebuf reset resize screen scrollback select sessionname setenv setsid
	shell shelltitle silence silencewait sleep slowpaste source sorendition
	split startup_message stuff su suspend term termcap terminfo termcapinfo
	time title unsetenv utf8 vbell vbell_msg vbellwait version wall
	width windowlist windows wrap writebuf writelock xoff xon zmodem zombie ) );

	for my $name (@commands) {
		*{__PACKAGE__ . "::$name"} = sub { shift->send_command($name,@_) }
	}

	my @rcommands = ( qw( bind kill meta chdir exec umask) );

	for my $name (@rcommands) {
		*{__PACKAGE__ . "::s$name"} = sub { shift->send_command($name,@_) }
	}
}

has session    => (is => 'rw'  );
has window     => (is => 'rw', default => sub { 0 } );
has executable => (is => 'rw', default => sub { which("screen") } );
has create     => (is => 'ro', default => sub { 0 } );
has debugging  => (is => 'rw', default => sub { 0 } );

sub BUILD {
	my ($self) = @_;
	if ($self->create) {
		if (!$self->session) {
			$self->session("term_gnuscreen.$$" . int(rand(10000)));
		}
		$self->call_screen('-m','-d');
	}
	return;
}

sub send_command {
	my ($self,$cmd,@args) = @_;
	die "No command supplied while trying to call screen via -X."
		if !$cmd;
	return $self->call_screen('-X', $cmd, @args) if $cmd;
}

sub call_screen {
	my ($self,@parameter) = @_;
	my @screencmd = ( $self->executable );
	push @screencmd, '-S', $self->session if defined $self->session;
	push @screencmd, '-p', $self->window  if defined $self->window;
	push @screencmd, @parameter;

	if ($self->debugging) {
		print STDERR "Command: " . join(" ",@screencmd) . "\n";
	}

	my ($stdout,$stderr);
	eval { 
		capture { system(@screencmd) } \$stdout, \$stderr;
		1;
	} or do {
		my $err;# = $!;
		$err = $stderr if defined $stderr;
		$err = $stdout if defined $stdout; # '*err*, stdout seems to be actual more helpful
		die "$err";
	};
	return 1;
}