view release on metacpan or  search on metacpan

Clui  view on Meta::CPAN

		&speak($question);
	}

	while (1) {
		my $c = &getch();
		if ($c eq "\r") { &erase_lines(1); last; }
		if ($size_changed) {
			&erase_lines(0); $nol = &display_question($question);
		}
		if ($c == $KEY_LEFT) {
			if ($i > 0) { $i--; &left(1); }  # 1.44
		} elsif ($c == $KEY_RIGHT) {
			if ($i < $n) { &puts($silent ? "x" : $s[$i]); $i++; }
		} elsif ($c == $KEY_DELETE) {  # 1.54
			if ($i < $n) {
			 	$n--; splice(@s, $i, 1);
			  	foreach $j ($i..$#s) { &puts($silent ? "x" : $s[$j]); } # 1.67
			  	&clrtoeol(); &left($n-$i);
			}
		} elsif (($c eq "\cH") || ($c eq "\c?")) {
			if ($i > 0) {
			 	$n--; $i--;
				if (! $silent) { &speak($s[$i]); }   # 1.63
				splice(@s, $i, 1); &left(1);
			  	foreach $j ($i..$#s) { &puts($silent ? "x" : $s[$j]); } # 1.67
			  	&clrtoeol(); &left($n-$i);
			}
		} elsif ($c eq "\cC") {  # 1.56
			&erase_lines(1); &endwin();
			warn "^C\n"; kill('INT', $$); return undef;
		} elsif ($c eq "\cX" || $c eq "\cD") {  # clear ...
			&left($i); $i = 0; $n = 0; &clrtoeol(); @s = ();
		} elsif ($c eq "\cA" || $c == $KEY_HOME) { &left($i); $i = 0;
		} elsif ($c eq "\cE" || $c == $KEY_END)  { &right($n-$i); $i = $n;
		} elsif ($c eq "\cL") { &speak(join("", @s));  # redraw ...
		} elsif ($SpecialKey{$c}) { &beep();
		} elsif (ord($c) >= 32) {  # 1.51
			splice(@s, $i, 0, $c);
			&puts($silent ? "x" : $c);
			if (! $silent) {  &speak($c); }
			$n++; $i++;
			foreach $j ($i..$#s) { &puts($silent ? "x" : $s[$j]); }  # 1.67
			&clrtoeol();  &left($n-$i);
		} else { &beep();
		}
	}
	&speak(join("", @s), 'wait');
	&endwin(); $silent = q{}; return join("", @s);
}

# ----------------------- choose stuff -------------------------
sub debug {
	if (! open (DEBUG, '>>/tmp/clui.log')) {
		warn "can't open /tmp/clui.log: $!\n"; return;
	}
	print DEBUG "$_[0]\n"; close DEBUG;
}

my (%irow, %icol, $nrows, $clue_has_been_given, $choice, $this_cell);
my @marked;
my $HOME = $ENV{'HOME'} || $ENV{'LOGDIR'} || (getpwuid($<))[7];
srand(time() ^ ($$+($$<15)));

sub choose {  my $question = shift; local @list = @_;  # @list must be local
	# As from 1.22, allows multiple choice if called in array context

	return unless @list;
	grep (($_ =~ s/[\r\n]+$//) && 0, @list);	# chop final newlines
	my @biglist = @list; my $icell; @marked = ();

	$question =~ s/^[\n\r]+//;   # strip initial newline(s)
	$question =~ s/[\n\r]+$//;   # strip final newline(s)
	my ($firstline,$otherlines) = split(/\r?\n/, $question, 2);
	my $firstlinelength = length $firstline;

	$choice = &get_default($firstline);
	# If wantarray ? Is remembering multiple choices safe ?

	&initscr(mouse_mode=>1, speakup_silent=>1);
	&size_and_layout(0);
	@OtherLines = &fmt($otherlines);
	my $speaktext = join(' ',$list[$this_cell],'. ',@OtherLines);
	if (wantarray) {
		$#marked = $#list;
		if ($firstlinelength < $maxcols-30) {
			&puts("$firstline (multiple choice with spacebar)\n\r");
		} elsif ($firstlinelength < $maxcols-16) {
			&puts("$firstline (multiple choice)\n\r");
		} elsif ($firstlinelength < $maxcols-9) {
			&puts("$firstline (multiple)\n\r");
		} else {
			&puts("$firstline\n\r");
		}
		if ($nrows >= $maxrows) { &speak("$firstline, ", 'wait');
		} else { &speak("$firstline, multiple choice, $speaktext");
		}
	} else {
		&puts("$firstline\n\r");
		if ($nrows >= $maxrows) { &speak("$firstline, ", 'wait');
		} else { &speak("$firstline, choose, $speaktext");
		}
	}
	if ($nrows >= $maxrows) {
		@list = &narrow_the_search(@list);
		if (! @list) {
			&up(1); &clrtoeol(); &endwin(); $clue_has_been_given = 0;
			return wantarray ? () : undef;
		}
		my $speaktext = join(' ',$list[$this_cell],'. ',@OtherLines);
		&speak("choose, $speaktext");
	}
	&wr_screen();
	# the cursor is now on this_cell, not on the question
	print TTY "\e[6n";  # terminfo u7, will set $AbsCursX,$AbsCursY
	$CursorRow = $irow[$this_cell];  # global, needed by handle_mouse

	while (1) {
		$c = &getch();
		if ($size_changed) {
			&size_and_layout($nrows);
			if ($nrows >= $maxrows) {

Clui  view on Meta::CPAN

	} elsif ($argc == 1) {	# its a file, we will try RCS ...
		my $file = $title;

		# weed out no-go situations
		if (-d $file) {&sorry("$file is already a directory\n"); return 0;}
		if (-B _ && -s _) {&sorry("$file is not a text file\n"); return 0;}
		if (-T _ && !-w _) { &view($file); return 1; }
	
		# it's a writeable text file, so work out the locations
		if ($file =~ /\//) {
			($dirname, $basename) = $file =~ /^(.*)\/([^\/]+)$/;
			$rcsdir  = "$dirname/RCS";
			$rcsfile = "$rcsdir/$basename,v";
		} else {
			$basename = $file;
			$rcsdir  = "RCS";
			$rcsfile = "$rcsdir/$basename,v";
		}
		$rcslog = "$rcsdir/log";
	
		# we no longer create the RCS directory if it doesn't exist,
		# so `mkdir RCS' to enable rcs in a directory ...
		$rcs_ok = 1;	if (!-d $rcsdir) { $rcs_ok = 0; }
		if (-d _ && ! -w _) { $rcs_ok = 0;	warn "can't write in $rcsdir\n"; }
	
		# if the file doesn't exist, but the RCS does, then check it out
		if ($rcs_ok && -f $rcsfile && !-f $file) {
			system "co -l $file $rcsfile";
		}

		my $starttime = time;
		$editor = $ENV{EDITOR} || "vi"; # should also look in ~/db/choices.db
		system "$editor $file";
		my $elapsedtime = time - $starttime;
		# could be output or logged, for worktime accounting
	
		if ($rcs_ok && -T $file) {	 # check it in
			if (!-f $rcsfile) {
				my $msg = &ask("$file is new. Please describe it:");
				my $quotedmsg = $msg;  $quotedmsg =~ s/'/'"'"'/g;
				if ($msg) {
					system "ci -q -l -t-'$quotedmsg' -i $file $rcsfile";
					&logit($basename, $msg);
				}
			} else {
				my $msg = &ask("What changes have you made to $file ?");
				my $quotedmsg = $msg;  $quotedmsg =~ s/'/'"'"'/g;
				if ($msg) {
					system "ci -q -l -m'$quotedmsg' $file $rcsfile";
					&logit($basename, $msg);
				}
			}
		}
	}
}
sub logit { my ($file, $msg) = @_;
	if (! open(LOG, ">> $rcslog")) {  warn "can't open $rcslog: $!\n";
	} else {
		$pid = fork;	# log in background for better response time
		if (! $pid) {
			($user) = getpwuid($>);
			print LOG &timestamp, " $file $user $msg\n"; close LOG;
			if ($pid == 0) { exit 0; }	# the child's end, if a fork occurred
		}
	}
}
sub timestamp {
	# returns current date and time in "199403011 113520" format
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
	$wday += 0; $yday += 0; $isdst += 0; # avoid bloody -w warning
	return sprintf("%4.4d%2.2d%2.2d %2.2d%2.2d%2.2d",
		$year+1900, $mon+1, $mday, $hour, $min, $sec);
}

# ----------------------- sorry stuff -------------------------

sub sorry { # warns user of an error condition
	print STDERR "Sorry, $_[0]\n";
	&speak("Sorry, $_[0]", 'wait');
}
sub inform { my $text = $_[0];
	$text =~ s/([^\n])$/$1\n/s;
	if (open(TTY, ">$EncodingString", '/dev/tty')) {  # 1.43
		print TTY $text; close TTY;
	} else { warn $text;
	}
	&speak($text, 'wait');
}

# ----------------------- view stuff -------------------------

foreach $f ("/usr/bin/less", "/usr/bin/more") {
	if (-x $f) { $default_pager = $f; }
}
sub view {	my ($title, $text) = @_;	# or ($filename) =
	my $pager = $ENV{PAGER} || $default_pager;
	if (! $text and ($title =~ /\.doc$/i) and -r $title) {   # 1.65
		my $wvText = which('wvText');   if ($wvText) {
			my $tmpf = "/tmp/wv$$";
			system "$wvText '$title' $tmpf"; system "$pager $tmpf";
			unlink $tmpf; return 1;
		}
		my $antiword = which('antiword');   if ($antiword) {
			system "$antiword -i 1 '$title' | $pager"; return 1;
		}
		my $catdoc = which('catdoc');   if ($catdoc) {
			system "$catdoc '$title' | $pager"; return 1;
		}
		sorry("it's a .doc file; you need to install wv, antiword or catdoc");
		return 0;
	} elsif (! $text && -T $title && open(F,"< $title")) {
		$nlines = 0;
		while (<F>) { last if ($nlines++ > $maxrows); } close F;
		if ($nlines > (0.6*$maxrows)) {
			system "$pager  \'$title\'";
		} else {
			open(F,"< $title"); undef $/; $text=<F>; $/="\n"; close F;
			&tiview($title, $text);
		}
	} else {
		local (@lines) = split(/\r?\n/, $text, $maxrows);