[xmltv-commit] CVS: xmltv/lib AskTerm.pm,NONE,1.1 AskTk.pm,NONE,1.1 Ask.pm,1.9,1.10

[Ed A. <ep...@us...>]

Update of /cvsroot/xmltv/xmltv/lib
In directory sc8-pr-cvs1:/tmp/cvs-serv19589/lib

Modified Files:
	Ask.pm 
Added Files:
	AskTerm.pm AskTk.pm 
Log Message:
Applying Andy Balaam's patch for Tk configuration in environments that
support it (with a few changes).

XMLTV::Ask now has two implementations, AskTerm and AskTk, and chooses
one based on whether Tk is usable.  The grabbers need to use the
XMLTV::Ask routines exclusively when they want to communicate with the
user; in particular this means the new say() routine rather than
print().

I haven't tested the Tk configuration half yet.


--- NEW FILE: AskTerm.pm ---
# A few routines for asking the user questions.  Used in --configure
# and also by Makefile.PL, so this file should not depend on any
# nonstandard libraries.
#

package XMLTV::AskTerm;
use strict;
use base 'Exporter';
our @EXPORT = qw(ask
                 askQuestion
                 askBooleanQuestion
                 askManyBooleanQuestions
                 say
                );
use Carp qw(croak carp);

# Use Log::TraceMessages if installed.
BEGIN {
    eval { require Log::TraceMessages };
    if ($@) {
	*t = sub {};
	*d = sub { '' };
    }
    else {
	*t = \&Log::TraceMessages::t;
	*d = \&Log::TraceMessages::d;
    }
}

sub ask( $ );
sub askQuestion( $$@ );
sub askBooleanQuestion( $$ );
sub askManyBooleanQuestions( $@ );
sub say( $ );

sub ask( $ )
{
    my $prompt = shift;
    chomp $prompt;
    $prompt .= ' ' if $prompt !~ /\s$/;
    print STDERR $prompt;
    my $r = <STDIN>;
    for ($r) {
	return undef if not defined;
	s/^\s+//;
	s/\s+$//;
	return $_;
    }
}

# Ask a question where the answer is one of a set of alternatives.
#
# Parameters:
#   question text
#   default choice
#   Remaining arguments are the choices available.
#
# Returns one of the choices, or undef if input could not be read.
#
sub askQuestion( $$@ )
{
    my $question=shift(@_); die if not defined $question;
    chomp $question;
    my $default=shift(@_); die if not defined $default;
    my @options=@_; die if not @options;
    t "asking question $question, default $default";
    croak "default $default not in options"
      if not grep { $_ eq $default } @options;

    my $options_size = length("@options");
    t "size of options: $options_size";
    my $all_digits = not ((my $tmp = join('', @options)) =~ tr/0-9//c);
    t "all digits? $all_digits";
    if ($options_size < 20 or $all_digits) {
	# Simple style, one line question.
	my $str = "$question [".join(',',@options)." (default=$default)] ";
	while ( 1 ) {
	    my $res=ask($str);
	    return undef if not defined $res;
	    return $default if $res eq '';

	    # Check for exact match, then for substring matching.
	    foreach (@options) {
		return $_ if $_ eq $res;
	    }
	    my @poss;
	    foreach (@options) {
		push @poss, $_ if /\Q$res\E/i;
	    }
	    if (@poss == 1) {
		# Unambiguous substring match.
		return $poss[0];
	    }

	    print STDERR "invalid response, please choose one of ".join(',', @options)."\n\n";
	}
    }
    else {
	# Long list of options, present as numbered multiple choice.
	print STDERR "$question\n";
	my $optnum = 0;
	my (%num_to_choice, %choice_to_num);
	foreach (@options) {
	    print STDERR "$optnum: $_\n";
	    $num_to_choice{$optnum} = $_;
	    $choice_to_num{$_} = $optnum;
	    ++ $optnum;
	}
	$optnum--;
	my $r=undef;
	my $default_num = $choice_to_num{$default};
	die if not defined $default_num;
	until (defined $r) {
	    $r = askQuestion('Select one:',
			     $default_num, 0 .. $optnum);
	    return undef if not defined $r;
	    for ($num_to_choice{$r}) { return $_ if defined }
	    print STDERR "invalid response, please choose one of "
	      .0 .. $optnum."\n\n";
	    undef $r;
	}
    }
}

# Ask a yes/no question.
#
# Parameters: question text,
#             default (true or false)
#
# Returns true or false, or undef if input could not be read.
#
sub askBooleanQuestion( $$ )
{
    my ($text, $default) = @_;
    my $r = askQuestion($text, ($default ? 'yes' : 'no'), 'yes', 'no');
    return undef if not defined $r;
    return 1 if $r eq 'yes';
    return 0 if $r eq 'no';
    die;
}

# Ask yes/no questions with option 'default to all'.
#
# Parameters: default (true or false),
#             question texts (one per question).
#
# Returns: lots of booleans, one for each question.  If input cannot
# be read, then a partial list is returned.
#
sub askManyBooleanQuestions( $@ )
{
    my $default = shift;

    # Catch a common mistake - passing the answer string as default
    # instead of a Boolean.
    #
    carp "default is $default, should be 0 or 1"
      if $default ne '0' and $default ne '1';

    my @r;
    while (@_) {
	my $q = shift @_;
	my $r = askQuestion($q, ($default ? 'yes' : 'no'),
			    'yes', 'no', 'all', 'none');
	last if not defined $r;
	if ($r eq 'yes') {
	    push @r, 1;
	}
	elsif ($r eq 'no') {
	    push @r, 0;
	}
	elsif ($r eq 'all' or $r eq 'none') {
	    my $bool = ($r eq 'all');
	    push @r, $bool;
	    foreach (@_) {
		print STDERR "$_ ", ($bool ? 'yes' : 'no'), "\n";
		push @r, $bool;
	    }
	    last;
	}
	else { die }
    }
    return @r;
}

sub say( $ )
{
    my $question = shift;
    print STDERR "$question\n";
}


1;

--- NEW FILE: AskTk.pm ---
# A few GUI routines for asking the user questions.
#

package XMLTV::AskTk;
use strict;
use base 'Exporter';
our @EXPORT = qw(ask
                 askQuestion
                 askBooleanQuestion
                 askManyBooleanQuestions
                 say
                );
use Carp qw(croak);
# Use Log::TraceMessages if installed.
BEGIN {
    eval { require Log::TraceMessages };
    if ($@) {
	*t = sub {};
	*d = sub { '' };
    }
    else {
	*t = \&Log::TraceMessages::t;
	*d = \&Log::TraceMessages::d;
    }
}

use Tk;

my $main_window;
my $top_frame;
my $middle_frame; 
my $bottom_frame;
my $mid_bottom_frame;

sub ask( $ );
sub askQuestion( $$@ );
sub askBooleanQuestion( $$ );
sub askManyBooleanQuestions( $@ );
sub askBooleanOptions( $$$@ );
sub say( $ );

sub ask( $ ) {
    my $question = shift;
    my $textbox;
	
    $main_window = MainWindow->new;

    $main_window->title("Question");
    $main_window->minsize(qw(400 250));
    $main_window->geometry('+250+150');

    $top_frame    = $main_window->Frame()->pack;
    $middle_frame = $main_window->Frame()->pack;
    $bottom_frame = $main_window->Frame()->pack(-side => 'bottom');
	
    $top_frame->Label(-height => 2)->pack;
	
    $top_frame->Label(-text => $question)->pack;
	
    $bottom_frame->Button(-text    => "OK",
			  -command => sub { goto(answer_ok2) },
			  width    => 10
			 )->pack(padx => 2, pady => 4);
								
    $textbox = $middle_frame->Entry()->pack();
    MainLoop();
	
  answer_ok2:
    my $ans = $textbox->get();
    $main_window->destroy;
    return $ans;
}


# Ask a question where the answer is one of a set of alternatives.
#
# Parameters:
#   question text
#   default choice
#   Remaining arguments are the choices available.
#
# Returns one of the choices, or undef if input could not be read.
#
sub askQuestion( $$@ ) {
    my $question = shift; die if not defined $question;
    my $default = shift; die if not defined $default;
    my @options = @_; die if not @options;
    t "asking question $question, default $default";
    croak "default $default not in options"
      if not grep { $_ eq $default } @options;
    return askBooleanOptions( $question, $default, 0, @options );
}

# Ask a yes/no question.
#
# Parameters: question text,
#             default (true or false)
#
# Returns true or false, or undef if input could not be read.
#
sub askBooleanQuestion( $$ ) {
    my ($text, $default) = @_;	
    t "asking question $text, default $default";
	
    $main_window = MainWindow->new;

    $main_window->title('Question');
    $main_window->minsize(qw(400 250));
    $main_window->geometry('+250+150');

    $top_frame    = $main_window->Frame()->pack;
    $middle_frame = $main_window->Frame()->pack;
    $bottom_frame = $main_window->Frame()->pack(-side => 'bottom');
	
    $top_frame->Label(-height => 2)->pack;
    $top_frame->Label(-text => $text)->pack;
	
    $bottom_frame->Button(-text    => "Yes",
			  # -command => sub {
                          #     recreate_frames;
			  #     draw_download_channels();
                          # },
			  -command => sub { goto(answer_yes) },
			  width => 10,
			 )->pack(-side => 'left', padx => 2, pady => 4);
	
    $bottom_frame->Button(-text    => "No",
			  # -command => sub { exit(0) },
			  -command => sub { goto(answer_no) },
			  width => 10
			 )->pack(-side => 'left', padx => 2, pady => 4);
	
    MainLoop();
	
  answer_no:
    $main_window->destroy;
    return 0;
	
  answer_yes:
    $main_window->destroy;
    return 1;
}

# Ask yes/no questions with option 'default to all'.
#
# Parameters: default (true or false),
#             question texts (one per question).
#
# Returns: lots of booleans, one for each question.  If input cannot
# be read, then a partial list is returned.
#
sub askManyBooleanQuestions( $@ ) {
    my $default=shift;
    my @options = @_;
    return askBooleanOptions('', $default, 1, @options);
}

sub askBooleanOptions( $$$@ ) {
    my $question=shift;
    my $default=shift;
    my $allowedMany=shift;
    my @options = @_;

    return if not @options;
	
    my $select_all_button;
    my $select_none_button;

    my $listbox;
    my $i;
	
    $main_window = MainWindow->new;

    $main_window->title('Question');
    $main_window->minsize(qw( 400 250 ));
    $main_window->geometry('+250+150');

    $top_frame    = $main_window->Frame()->pack;
    $middle_frame = $main_window->Frame()->pack(-fill => 'both');
	
    $top_frame->Label(-height => 2)->pack;

    $top_frame->Label(-text => $question)->pack;
						
    $listbox = $middle_frame->ScrlListbox();
		
    $listbox->insert(0, @options);
	
    if ($allowedMany) {
	$listbox->configure( -selectmode => 'multiple' );
		
	if ($default) {
	    $listbox->selectionSet( 0, 'end' );
	}
		
	$mid_bottom_frame = $main_window->Frame()->pack();
	
	$select_all_button = $mid_bottom_frame->Button
	  (-text => 'Select All',
	   -command => sub { $listbox->selectionSet(0, 1000) },
	   width => 10,
	  )->pack(-side => 'left');
	
	$select_none_button = $mid_bottom_frame->Button
	  (-text => 'Select None',
	   -command => sub { $listbox->selectionClear(0, 1000) },
	   width => 10,
	  )-> pack(-side => 'right');
    }
    else {
	$listbox->configure(-selectmode => 'single');
	$listbox->selectionSet(indexArray($default, @options));
    }
	
    $listbox->pack(-fill => 'x', -padx => '5', -pady => '2');
	
    $bottom_frame = $main_window->Frame()->pack(-side => 'bottom');
	
    $bottom_frame->Button(-text    => 'OK',
			  -command => sub { goto(answer_ok); },
			  width    => 10,
			 )->pack(padx => 2, pady => 4);
								
    MainLoop();

  answer_ok:
    if( $allowedMany ) {
	my @choices;
	my @choice_numbers = $listbox->curselection;
			
	$i=0;
	foreach (@options) {
	    push @choices, 0;
	    foreach( @choice_numbers ) {
		if ($options[$_] eq $options[$i]) {
		    $choices[$i] = 1;
		}
	    }
	    $i++;
	}
			
	$main_window->destroy;
	return @choices;
	
    }
    else {
	my $ans = $options[$listbox->curselection];
	$main_window->destroy;
	return $ans;
    }
}

sub say( $ ) {
    my $question = shift;
	
    $main_window = MainWindow->new;

    $main_window->title("Information");
    $main_window->minsize(qw(400 250));
    $main_window->geometry('+250+150');

    $top_frame    = $main_window->Frame()->pack;
    $middle_frame = $main_window->Frame()->pack;
    $bottom_frame = $main_window->Frame()->pack(-side => 'bottom');
	
    $top_frame->Label(-height => 2)->pack;
    $top_frame->Label(-text => $question)->pack;
	
    $bottom_frame->Button(-text    => "OK",
			  -command => sub { goto(answer_ok3) },
			  width    => 10,
			 )->pack(padx => 2, pady => 4);
	
    MainLoop();
	
  answer_ok3:
    $main_window->destroy;
}


sub indexArray($@)
{
    my $s=shift;
    my @array = @_;
	
    for (my $i = 0; $i < $#array; $i++) {
	return $i if $array[$i] eq $s;
    }
	
    return -1;
}

1;

Index: Ask.pm
===================================================================
RCS file: /cvsroot/xmltv/xmltv/lib/Ask.pm,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -d -r1.9 -r1.10
*** Ask.pm	17 Aug 2003 14:01:45 -0000	1.9
--- Ask.pm	28 Aug 2003 20:56:59 -0000	1.10
***************
*** 6,18 ****
  package XMLTV::Ask;
  use strict;
- use base 'Exporter';
- our @EXPORT = qw(ask
- 		 askQuestion
- 		 askBooleanQuestion
- 		 askManyBooleanQuestions
- 		);
  use Carp qw(croak carp);
  
! # Use Log::TraceMessages if installed.
  BEGIN {
      eval { require Log::TraceMessages };
--- 6,12 ----
  package XMLTV::Ask;
  use strict;
  use Carp qw(croak carp);
  
! # Use Log::TraceMessages if installed, and choose graphical or not.
  BEGIN {
      eval { require Log::TraceMessages };
***************
*** 25,179 ****
  	*d = \&Log::TraceMessages::d;
      }
- }
- 
- sub ask( $ );
- sub askQuestion( $$@ );
- sub askBooleanQuestion( $$ );
- 
- sub ask( $ )
- {
-     print shift;
-     my $r = <STDIN>;
-     for ($r) {
- 	return undef if not defined;
- 	s/^\s+//;
- 	s/\s+$//;
- 	return $_;
-     }
- }
  
! # Ask a question where the answer is one of a set of alternatives.
! #
! # Parameters:
! #   question text
! #   default choice
! #   Remaining arguments are the choices available.
! #
! # Returns one of the choices, or undef if input could not be read.
! #
! sub askQuestion( $$@ )
! {
!     my $question=shift(@_); die if not defined $question;
!     my $default=shift(@_); die if not defined $default;
!     my @options=@_; die if not @options;
!     t "asking question $question, default $default";
!     croak "default $default not in options"
!       if not grep { $_ eq $default } @options;
! 
!     my $options_size = length("@options");
!     t "size of options: $options_size";
!     my $all_digits = not ((my $tmp = join('', @options)) =~ tr/0-9//c);
!     t "all digits? $all_digits";
!     if ($options_size < 20 or $all_digits) {
! 	# Simple style, one line question.
! 	my $str = "$question [".join(',',@options)." (default=$default)] ";
! 	while ( 1 ) {
! 	    my $res=ask($str);
! 	    return undef if not defined $res;
! 	    return $default if $res eq '';
! 
! 	    # Check for exact match, then for substring matching.
! 	    foreach (@options) {
! 		return $_ if $_ eq $res;
! 	    }
! 	    my @poss;
! 	    foreach (@options) {
! 		push @poss, $_ if /\Q$res\E/i;
! 	    }
! 	    if ( @poss == 1 ) {
! 		# Unambiguous substring match.
! 		return $poss[0];
! 	    }
! 
! 	    print "invalid response, please choose one of ".join(',', @options)."\n\n";
! 	}
      }
      else {
! 	# Long list of options, present as numbered multiple choice.
! 	print "$question\n";
! 	my $optnum = 0;
! 	my (%num_to_choice, %choice_to_num);
! 	foreach (@options) {
! 	    print "$optnum: $_\n";
! 	    $num_to_choice{$optnum} = $_;
! 	    $choice_to_num{$_} = $optnum;
! 	    ++ $optnum;
! 	}
! 	$optnum--;
! 	my $r=undef;
! 	my $default_num = $choice_to_num{$default};
! 	die if not defined $default_num;
! 	while (!defined($r) ) {
! 	    $r = askQuestion('Select one:',
! 			     $default_num, 0 .. $optnum);
! 	    return undef if not defined $r;
! 	    for ($num_to_choice{$r}) { return $_ if defined }
! 	    print "invalid response, please choose one of "
! 	      .0 .. $optnum."\n\n";
! 	    undef $r;
! 	}
      }
  }
  
- # Ask a yes/no question.
- #
- # Parameters: question text,
- #             default (true or false)
- #
- # Returns true or false, or undef if input could not be read.
- #
- sub askBooleanQuestion( $$ )
- {
-     my ($text, $default) = @_;
-     my $r = askQuestion($text, ($default ? 'yes' : 'no'), 'yes', 'no');
-     return undef if not defined $r;
-     return 1 if $r eq 'yes';
-     return 0 if $r eq 'no';
-     die;
- }
- 
- # Ask yes/no questions with option 'default to all'.
- #
- # Parameters: default (true or false),
- #             question texts (one per question).
- #
- # Returns: lots of booleans, one for each question.  If input cannot
- # be read, then a partial list is returned.
- #
- sub askManyBooleanQuestions( $@ )
- {
-     my $default = shift;
- 
-     # Catch a common mistake - passing the answer string as default
-     # instead of a Boolean.
-     #
-     carp "default is $default, should be 0 or 1"
-       if $default ne '0' and $default ne '1';
  
-     my @r;
-     while (@_) {
- 	my $q = shift @_;
- 	my $r = askQuestion($q, ($default ? 'yes' : 'no'),
- 			    'yes', 'no', 'all', 'none');
- 	last if not defined $r;
- 	if ($r eq 'yes') {
- 	    push @r, 1;
- 	}
- 	elsif ($r eq 'no') {
- 	    push @r, 0;
- 	}
- 	elsif ($r eq 'all' or $r eq 'none') {
- 	    my $bool = ($r eq 'all');
- 	    push @r, $bool;
- 	    foreach (@_) {
- 		print "$_ ", ($bool ? 'yes' : 'no'), "\n";
- 		push @r, $bool;
- 	    }
- 	    last;
- 	}
- 	else { die }
-     }
-     return @r;
- }
  
  1;
--- 19,34 ----
  	*d = \&Log::TraceMessages::d;
      }
  
!     if ((defined($ENV{DISPLAY}) || $^O eq 'MSWin32') && eval { require Tk }) {
! 	require XMLTV::AskTk; XMLTV::AskTk->import;
! 	*XMLTV::Ask:: = *XMLTV::AskTk::;
      }
      else {
! 	require XMLTV::AskTerm; XMLTV::AskTerm->import;
! 	*XMLTV::Ask:: = *XMLTV::AskTerm::;
      }
  }
  
  
  
  1;