1. Toby Inkster
  2. p5-ask

Commits

Toby Inkster  committed 923bc37

add multiple_choice and single_choice to the API; Ask::Zenity implements them

  • Participants
  • Parent commits d8e4738
  • Branches default

Comments (0)

Files changed (6)

File TODO

View file
  • Ignore whitespace
 
 Backend Improvements
 ====================
-Ask::Wx - support multi file selection
+Ask::Gtk - implement multiple_choice/single_choice
 Ask::STDIO - better file selection method
-
-
-API Improvements
-================
-multiple_choice method - select multiple items from a list
-single_choice method - select a single choice from a list
+Ask::Tk - implement multiple_choice/single_choice
+Ask::Wx - support multi file selection; implement multiple_choice/single_choice

File examples/multiple-choice.pl

View file
  • Ignore whitespace
+use 5.010;
+use strict;
+use warnings;
+use Ask -all;
+
+my $answer = single_choice(
+	text    => "If a=1, b=2. What is a+b?",
+	choices => [
+		[ A => 12 ],
+		[ B => 3  ],
+		[ C => 2  ],
+		[ D => 42 ],
+		[ E => "Fish" ],
+	],
+);
+
+if ($answer eq 'B') {
+	info "Correctamundo!";
+}
+
+else {
+	info "Wrong! ($answer)";
+}
+
+my @ingredients = multiple_choice(
+	text    => "What do you want on your pizza?",
+	choices => [
+		[ cheese    => 'Cheese' ],
+		[ tomato    => 'Tomato' ],
+		[ ham       => 'Ham'    ],
+		[ pineapple => 'Pineapple' ],
+		[ chocolate => 'Chocolate' ],
+	],
+);
+
+info "Making pizza dough";
+info "Adding $_" for @ingredients;
+error "Ooops! Dropped pizza on the floor! Sorry, no pizza for you!";

File lib/Ask.pm

View file
  • Ignore whitespace
 		if (eval { require Ask::Gtk }) {
 			return 'Ask::Gtk';
 		}
-
+		
 		if (eval { require Ask::Tk }) {
 			return 'Ask::Tk';
 		}
-
+		
 		if (eval { require Ask::Wx }) {
 			return 'Ask::Wx';
 		}
-
+		
 		if (my $zenity = which('zenity')) {
 			$args->{zenity} //= $zenity;
 			return use_module("Ask::Zenity");
 
 =head1 SYNOPSIS
 
-	use 5.010;
-	use Ask;
-	
-	my $ask = Ask->detect;
-	
-	if ($ask->question(text => "Are you happy?")
-	and $ask->question(text => "Do you know it?")
-	and $ask->question(text => "Really want to show it?")) {
-		$ask->info(text => "Then clap your hands!");
-	}
+   use 5.010;
+   use Ask;
+   
+   my $ask = Ask->detect;
+   
+   if ($ask->question(text => "Are you happy?")
+   and $ask->question(text => "Do you know it?")
+   and $ask->question(text => "Really want to show it?")) {
+      $ask->info(text => "Then clap your hands!");
+   }
 
 =head1 DESCRIPTION
 
 Note that these objects don't usually inherit from C<Ask>, so the following
 will typically be false:
 
-	my $ask = Ask->detect(%arguments);
-	$ask->isa("Ask");
+   my $ask = Ask->detect(%arguments);
+   $ask->isa("Ask");
 
 Instead, check:
 
-	my $ask = Ask->detect(%arguments);
-	$ask->DOES("Ask::API");
+   my $ask = Ask->detect(%arguments);
+   $ask->DOES("Ask::API");
 
 =back
 
 selected (they are returned as a list); the C<directory> argument can be
 used to I<hint> that you want a directory.
 
+=item C<< single_choice(text => $text, choices => \@choices) >>
+
+Asks the user to select a single option from many choices.
+
+For example:
+
+   my $answer = $ask->single_choice(
+      text    => "If a=1, b=2. What is a+b?",
+      choices => [
+         [ A => 12 ],
+         [ B => 3  ],
+         [ C => 2  ],
+         [ D => 42 ],
+         [ E => "Fish" ],
+      ],
+   );
+
+=item C<< multiple_choice(text => $text, choices => \@choices) >>
+
+Asks the user to select zero or more options from many choices.
+
+   my @ingredients = $ask->multiple_choice(
+      text    => "What do you want on your pizza?",
+      choices => [
+         [ cheese    => 'Cheese' ],
+         [ tomato    => 'Tomato' ],
+         [ ham       => 'Ham'    ],
+         [ pineapple => 'Pineapple' ],
+         [ chocolate => 'Chocolate' ],
+      ],
+   );
+
 =back
 
 If you wish to create your own implementation of the Ask API, please
 
 To add extra methods to the Ask API you may use Moo roles:
 
-	{
-		package AskX::Method::Password;
-		use Moo::Role;
-		sub password {
-			my ($self, %o) = @_;
-			$o{hide_text} //= 1;
-			$o{text}      //= "please enter your password";
-			$self->entry(%o);
-		}
-	}
-	
-	my $ask = Ask->detect(traits => ['AskX::Method::Password']);
-	say "GOT: ", $ask->password;
+   {
+      package AskX::Method::Password;
+      use Moo::Role;
+      sub password {
+         my ($self, %o) = @_;
+         $o{hide_text} //= 1;
+         $o{text}      //= "please enter your password";
+         $self->entry(%o);
+      }
+   }
+   
+   my $ask = Ask->detect(traits => ['AskX::Method::Password']);
+   say "GOT: ", $ask->password;
 
 =head2 Export
 
 differently from the object-oriented interface in one regard; if called with
 one parameter, it's taken to be the "text" named argument.
 
-	use Ask qw( question info );
-	
-	if (question("Are you happy?")
-	and question("Do you know it?")
-	and question("Really want to show it?")) {
-		info("Then clap your hands!");
-	}
+   use Ask qw( question info );
+   
+   if (question("Are you happy?")
+   and question("Do you know it?")
+   and question("Really want to show it?")) {
+      info("Then clap your hands!");
+   }
 
 Ask uses L<Sub::Exporter::Progressive>, so exported functions may be renamed:
 
-	use Ask
-		question => { -as => 'interrogate' },
-		info     => { -as => 'notify' },
-	;
+   use Ask
+      question => { -as => 'interrogate' },
+      info     => { -as => 'notify' },
+   ;
 
 =head1 ENVIRONMENT
 

File lib/Ask/API.pm

View file
  • Ignore whitespace
 			return $self->entry(text => ($o{text} // 'Enter file name'));
 		}
 	}
+	
+	my $format_choices = sub {
+		my ($self, $choices) = @_;
+		join q[, ], map { sprintf('"%s" (%s)', @$_) } @$choices;
+	};
+	
+	my $filter_chosen = sub {
+		my ($self, $choices, $response) = @_;
+		my $valid   = {}; $valid->{$_->[0]}++ for @$choices;
+		my @choices = ($response =~ /\w+/g);
+		return(
+			[ grep  $valid->{$_}, @choices ],
+			[ grep !$valid->{$_}, @choices ],
+		);
+	};
+	
+	sub multiple_choice {
+		my ($self, %o) = @_;
+		my $choices = $self->$format_choices($o{choices});
+		
+		my ($allowed, $disallowed, $repeat);
+		
+		for (;;) {
+			my $response = $self->entry(
+				text       => "$o{text}. Choices: $choices. (Separate multiple choices with white space.)",
+				entry_text => ($repeat // ''),
+			);
+			($allowed, $disallowed) = $self->$filter_chosen($o{choices}, $response);
+			if (@$disallowed) {
+				my $d = join q[, ], @$disallowed;
+				$self->error(
+					text => "Not valid: $d. Please try again.",
+				);
+				$repeat = join q[ ], @$allowed;
+			}
+			else {
+				last;
+			}
+		}
+		
+		return @$allowed;
+	}
+
+	sub single_choice {
+		my ($self, %o) = @_;
+		my $choices = $self->$format_choices($o{choices});
+		
+		my ($allowed, $disallowed, $repeat);
+		
+		for (;;) {
+			my $response = $self->entry(
+				text       => "$o{text}. Choices: $choices. (Choose one.)",
+				entry_text => ($repeat // ''),
+			);
+			($allowed, $disallowed) = $self->$filter_chosen($o{choices}, $response);
+			if (@$disallowed) {
+				my $d = join q[, ], @$disallowed;
+				$self->error(
+					text => "Not valid: $d. Please try again.",
+				);
+				$repeat = $allowed->[0];
+			}
+			elsif (@$allowed != 1) {
+				$self->error(
+					text => "Not valid: choose one.",
+				);
+				$repeat = $allowed->[0];
+			}
+			else {
+				last;
+			}
+		}
+		
+		return $allowed->[0];
+	}
 }
 
 1;
 C<entry>.
 
 C<Ask::API> provides default implementations of C<warning>, C<error>,
-C<question> and C<file_selection> methods, but they're not espcially
-good, so you probably want to implement them too.
+C<question>, C<file_selection>, C<multiple_choice> and C<single_choice>
+methods, but they're not espcially good, so you probably want to implement
+most of those too.
 
 There is not currently any mechanism to "register" your implementation
 with L<Ask> so that C<< Ask->detect >> knows about it.

File lib/Ask/Functions.pm

View file
  • Ignore whitespace
 
 	my @F;
 	BEGIN {
-		@F = qw(info warning error entry question file_selection);
+		@F = qw(
+			info warning error entry question file_selection
+			single_choice multiple_choice
+		);
 		
 		eval qq{
 			sub $_ { unshift \@_, $_; goto \\&_called };

File lib/Ask/Zenity.pm

View file
  • Ignore whitespace
 		my $zen = $self->system_wrapper->new(
 			$self->zenity_path,
 			_optionize($cmd),
-			map sprintf('%s=%s', _optionize($_), $o{$_}), keys %o,
+			map sprintf('%s="%s"', _optionize($_), $o{$_}), keys %o,
 		);
 		# warn join q[ ], $zen->cmdline;
 		return $zen;
 
 	sub info {
 		my $self = shift;
-		$self->_zenity(info => @_);
+		$self->_zenity(info => @_)->close;
 	}
 
 	sub warning {
 		my $self = shift;
-		$self->_zenity(warning => @_);
+		$self->_zenity(warning => @_)->close;
 	}
 
 	sub error {
 		my $self = shift;
-		$self->_zenity(error => @_);
+		$self->_zenity(error => @_)->close;
 	}
 
 	sub question {
 		chomp $text;
 		return split m#[|]#, $text;
 	}
+	
+	sub single_choice {
+		my ($self, %o) = @_;
+		$o{title} //= 'Single choice';
+		$o{text}  //= 'Choose one.';
+		my ($c) = $self->_choice(radiolist => 1, %o);
+		return $c;
+	}
+	
+	sub multiple_choice {
+		my ($self, %o) = @_;
+		$o{title} //= 'Multiple choice';
+		$o{text}  //= '';
+		return $self->_choice(multiple => 1, checklist => 1, %o);
+	}
+	
+	sub _choice {
+		my ($self, %o) = @_;
+		my $subsequent;
+		my $zen = $self->system_wrapper->new(
+			$self->zenity_path,
+			'--list',
+			($o{radiolist} ? '--radiolist' : ()),
+			($o{checklist} ? '--checklist' : ()),
+			($o{multiple}  ? '--multiple'  : ()),
+			'--column=Select',
+			'--column=Code',
+			'--column=Choice',
+			'--hide-column=2',
+			'--text', $o{text},
+			map { ($subsequent++ ? 'FALSE' : 'TRUE'), @$_ } @{$o{choices}},
+		);
+		chomp(my $line = readline($zen->stdout));
+		split m{\|}, $line;
+	}
 }
 
 1;