freebsd-skq/contrib/dialog/demo.pl

338 lines
11 KiB
Perl
Raw Normal View History

2018-10-20 20:32:57 +00:00
#!/usr/bin/env perl
# $Id: demo.pl,v 1.23 2018/06/12 21:39:44 tom Exp $
################################################################################
# Copyright 2018 Thomas E. Dickey
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License, version 2.1
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this program; if not, write to
# Free Software Foundation, Inc.
# 51 Franklin St., Fifth Floor
# Boston, MA 02110, USA.
################################################################################
# This demonstration is provided solely to exercise the sample Perl wrapper for
# dialog which is included in its source-code. See libui-dialog-perl for a
# more comprehensive binding.
#
# TODO: modify dialog.pl to use $DIALOG environment variable, drive from GetOpts here
# TODO: eliminate constant $scr_lines in dialog.pl
use warnings;
use strict;
use diagnostics;
use FindBin qw($Bin $Script);
use lib "$Bin";
require "dialog.pl";
dialog->import('@dialog_result');
our @dialog_result;
sub tput($$) {
my $name = shift;
my $default = shift;
my $value = `tput "$name"`;
chomp $value;
$value = $default unless ( $value =~ /^[0-9]+$/ );
return $value;
}
sub napms($) {
my $msecs = shift;
select( undef, undef, undef, $msecs * 0.001 );
}
sub show_results($$) {
my $title = shift;
my $width = shift;
&rhs_msgbox(
$title,
sprintf(
"Resulting text:\\n %s", join( '\\n ', @dialog_result )
),
$width
);
}
sub doit() {
my $status = 1;
my $RHS_CLEAR = "clear";
my $RHS_TEXTBOX = "textbox";
my $RHS_MSGBOX = "msgbox";
my $RHS_INFOBOX = "infobox";
my $RHS_YESNO = "yesno";
my $RHS_GAUGE = "gauge";
my $RHS_INPUTBOX = "inputbox";
my $RHS_MENU = "menu";
my $RHS_MENUL = "menul";
my $RHS_MENUA = "menua";
my $RHS_CHECKLIST = "checklist";
my $RHS_CHECKLISTL = "checklistl";
my $RHS_CHECKLISTA = "checklista";
my $RHS_RADIOLIST = "radiolist";
my @demo_2col = qw(
This that
is has
a this
2-column quoted
menu "tag".
);
my @demo_3col;
my @demo_tags;
my %demo_hash;
for ( my $s = 0, my $t = 0 ; $s <= $#demo_2col ; $s += 2, $t += 3 ) {
my $d = $s / 2;
my $c1 = $demo_2col[$s];
my $c2 = $demo_2col[ $s + 1 ];
$demo_3col[$t] = $c1;
$demo_3col[ $t + 1 ] = $c2;
$demo_3col[ $t + 2 ] = ( $c1 =~ /2/ ) ? 1 : 0;
$demo_tags[$d] = $c1;
$demo_tags[$d] =~ s/2/1/;
$demo_tags[ $d + ( $#demo_2col + 1 ) / 2 ] = $c2;
$demo_hash{ sprintf( "%d %s", $d, $c1 ) } = $c2;
}
while ( $status > 0 ) {
my $lines = &tput( "lines", 24 );
my $cols = &tput( "cols", 80 );
my $maxcols = $cols - 4;
my $mincols = ( $cols > 8 ) ? 8 : $cols;
my $midcols = int( ( $cols * 3 ) / 4 );
@dialog_result = ();
$status = &rhs_menu(
"My title", "My message",
0, 14,
$RHS_CLEAR, "clear and exit",
$RHS_TEXTBOX, "text-box of this script",
$RHS_MSGBOX, "informational-message, OK button",
$RHS_INFOBOX, "informational-message, no button",
$RHS_YESNO, "message with Yes/No buttons",
$RHS_GAUGE, "message with progress-gauge",
$RHS_INPUTBOX, "input-box",
$RHS_MENU, "menu, with tags and description",
$RHS_MENUL, "menu, using only tags",
$RHS_MENUA, "alphabetically sorted menu",
$RHS_CHECKLIST, "check-list with tags and description",
$RHS_CHECKLISTL, "check-list using only tags",
$RHS_CHECKLISTA, "alphabetically sorted check-list",
$RHS_RADIOLIST, "list of radio-buttons"
);
if ( $status > 0 and $#dialog_result == 0 ) {
my $testcase = $dialog_result[0];
if ( $testcase eq $RHS_CLEAR ) {
&rhs_clear;
last;
}
elsif ( $testcase eq $RHS_TEXTBOX ) {
&rhs_textbox( "This script", "$Script", 0, 0 );
}
elsif ( $testcase eq $RHS_MSGBOX ) {
my $msg =
"This is a demonstration script.\\n"
. "This should be the second line,\\n"
. "and this should be the third line,";
&rhs_msgbox( "A message", $msg,
int( ( length($msg) + 3 ) / 3 ) + 3 );
}
elsif ( $testcase eq $RHS_INFOBOX ) {
my $msg =
"This is a fairly long line of text, used to"
. " show how dialog can be used to wrap lines to fit in"
. " screens with different width. The text will start wide,"
. " then get narrower, showing a new infobox for each width"
. " before going back up to the full width of the terminal.";
my $wide = $maxcols;
while ( $wide > $mincols ) {
&rhs_infobox( "Info-box", $msg, $wide-- );
&napms(50);
}
while ( $wide < $maxcols ) {
&rhs_infobox( "Info-box", $msg, ++$wide );
&napms(50);
}
&rhs_msgbox( "Info-end", $msg, $wide );
}
elsif ( $testcase eq $RHS_YESNO ) {
if (
&rhs_yesno(
"Yes/no",
"Should \"dialog --yesno\" return \"1\" on \"yes\""
. " to simplify (some) shell scripts?",
$cols / 2
)
)
{
&rhs_msgbox(
"Explanation",
"No, a successful program exits with "
. "\"0\" (EXIT_SUCCESS)",
$cols / 2
);
}
else {
&rhs_msgbox(
"Explanation",
"Shell scripts assume that \"exit\ 0\" is successful;"
. " Perl is different.",
$cols / 2
);
}
}
elsif ( $testcase eq $RHS_GAUGE ) {
my $pct = 0;
my $sec = 10;
&rhs_gauge(
"My gauge",
"Show progress (or lack of it)",
$midcols * 3, $pct
);
while ( $pct < 100 ) {
$pct++;
&napms($sec);
$sec *= 1.04;
&rhs_update_gauge($pct);
}
$pct = 99;
&rhs_update_gauge_and_message( "This will go faster", $pct );
while ( $pct > 0 ) {
$pct--;
&napms($sec);
$sec /= 1.05;
&rhs_update_gauge($pct);
}
&napms(1000);
&rhs_stop_gauge;
}
elsif ( $testcase eq $RHS_INPUTBOX ) {
if (
&rhs_inputbox(
"My inputbox", "This demonstrates the inputbox",
$maxcols, ""
)
)
{
&show_results( "My inputbox", $midcols );
}
}
elsif ( $testcase eq $RHS_MENU ) {
if (
&rhs_menu(
(
"A menu",
"This menu uses \"tag\" values and descriptions:",
$midcols, ( $#demo_2col + 1 ) / 2
),
@demo_2col
)
)
{
&show_results( "My menu", $midcols );
}
}
elsif ( $testcase eq $RHS_MENUL ) {
if (
&rhs_menul(
(
"A menu", "This menu uses only the \"tag\" values:",
$midcols, $#demo_tags + 1
),
@demo_tags
)
)
{
&show_results( "My long-menu", $midcols );
}
}
elsif ( $testcase eq $RHS_MENUA ) {
if (
&rhs_menua(
"A menu", "This menu uses the sorted keys from a hash:",
$midcols, %demo_hash
)
)
{
&show_results( "My alpha-menu", $midcols );
}
}
elsif ( $testcase eq $RHS_CHECKLIST ) {
if (
&rhs_checklist(
(
"A checklist",
"This checklist uses \"tag\" values"
. " and descriptions:",
$midcols,
( $#demo_3col + 1 ) / 3
),
@demo_3col
)
)
{
&show_results( "My checklist", $midcols );
}
}
elsif ( $testcase eq $RHS_CHECKLISTL ) {
if (
&rhs_checklistl(
(
"A checklist",
"This checklist uses only the \"tag\" values:",
$midcols, $#demo_tags + 1
),
@demo_tags
)
)
{
&show_results( "My long-checklist", $midcols );
}
}
elsif ( $testcase eq $RHS_CHECKLISTA ) {
if (
&rhs_checklista(
"A checklist",
"This checklist uses the sorted keys from a hash:",
$midcols, %demo_hash
)
)
{
&show_results( "My alpha-checklist", $midcols );
}
}
elsif ( $testcase eq $RHS_RADIOLIST ) {
if (
&rhs_radiolist(
(
"A radiolist",
"This radiolist uses \"tag\" values"
. " and descriptions:",
$midcols,
( $#demo_3col + 1 ) / 3
),
@demo_3col
)
)
{
&show_results( "My radiolist", $midcols );
}
}
}
}
}
&doit;
1;