install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler/Prompt.pm

   1 package App::Info::Handler::Prompt;
   2
   3 # $Id: Prompt.pm,v 1.1 2004-04-29 09:21:29 ivan Exp $
   4
   5 =head1 NAME
   6
   7 App::Info::Handler::Prompt - Prompting App::Info event handler
   8
   9 =head1 SYNOPSIS
  10
  11   use App::Info::Category::FooApp;
  12   use App::Info::Handler::Print;
  13
  14   my $prompter = App::Info::Handler::Print->new;
  15   my $app = App::Info::Category::FooApp->new( on_unknown => $prompter );
  16
  17   # Or...
  18   my $app = App::Info::Category::FooApp->new( on_confirm => 'prompt' );
  19
  20 =head1 DESCRIPTION
  21
  22 App::Info::Handler::Prompt objects handle App::Info events by printing their
  23 messages to C<STDOUT> and then accepting a new value from C<STDIN>. The new
  24 value is validated by any callback supplied by the App::Info concrete subclass
  25 that triggered the event. If the value is valid, App::Info::Handler::Prompt
  26 assigns the new value to the event request. If it isn't it prints the error
  27 message associated with the event request, and then prompts for the data
  28 again.
  29
  30 Although designed with unknown and confirm events in mind,
  31 App::Info::Handler::Prompt handles info and error events as well. It will
  32 simply print info event messages to C<STDOUT> and print error event messages
  33 to C<STDERR>. For more interesting info and error event handling, see
  34 L<App::Info::Handler::Print|App::Info::Handler::Print> and
  35 L<App::Info::Handler::Carp|App::Info::Handler::Carp>.
  36
  37 Upon loading, App::Info::Handler::Print registers itself with
  38 App::Info::Handler, setting up a single string, "prompt", that can be passed
  39 to an App::Info concrete subclass constructor. This string is a shortcut that
  40 tells App::Info how to create an App::Info::Handler::Print object for handling
  41 events.
  42
  43 =cut
  44
  45 use strict;
  46 use App::Info::Handler;
  47 use vars qw($VERSION @ISA);
  48 $VERSION = '0.22';
  49 @ISA = qw(App::Info::Handler);
  50
  51 # Register ourselves.
  52 App::Info::Handler->register_handler
  53   ('prompt' => sub { __PACKAGE__->new('prompt') } );
  54
  55 =head1 INTERFACE
  56
  57 =head2 Constructor
  58
  59 =head3 new
  60
  61   my $prompter = App::Info::Handler::Prompt->new;
  62
  63 Constructs a new App::Info::Handler::Prompt object and returns it. No special
  64 arguments are required.
  65
  66 =cut
  67
  68 sub new {
  69     my $pkg = shift;
  70     my $self = $pkg->SUPER::new(@_);
  71     $self->{tty} = -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) );
  72     # We're done!
  73     return $self;
  74 }
  75
  76 my $get_ans = sub {
  77     my ($prompt, $tty, $def) = @_;
  78     # Print the message.
  79     local $| = 1;
  80     local $\;
  81     print $prompt;
  82
  83     # Collect the answer.
  84     my $ans;
  85     if ($tty) {
  86         $ans = <STDIN>;
  87         if (defined $ans ) {
  88             chomp $ans;
  89         } else { # user hit ctrl-D
  90             print "\n";
  91         }
  92     } else {
  93         print "$def\n" if defined $def;
  94     }
  95     return $ans;
  96 };
  97
  98 sub handler {
  99     my ($self, $req) = @_;
 100     my $ans;
 101     my $type = $req->type;
 102     if ($type eq 'unknown' || $type eq 'confirm') {
 103         # We'll want to prompt for a new value.
 104         my $val = $req->value;
 105         my ($def, $dispdef) = defined $val ? ($val, " [$val] ") : ('', ' ');
 106         my $msg = $req->message or Carp::croak("No message in request");
 107         $msg .= $dispdef;
 108
 109         # Get the answer.
 110         $ans = $get_ans->($msg, $self->{tty}, $def);
 111         # Just return if they entered an empty string or we couldnt' get an
 112         # answer.
 113         return 1 unless defined $ans && $ans ne '';
 114
 115         # Validate the answer.
 116         my $err = $req->error;
 117         while (!$req->value($ans)) {
 118             print "$err: '$ans'\n";
 119             $ans = $get_ans->($msg, $self->{tty}, $def);
 120             return 1 unless defined $ans && $ans ne '';
 121         }
 122
 123     } elsif ($type eq 'info') {
 124         # Just print the message.
 125         print STDOUT $req->message, "\n";
 126     } elsif ($type eq 'error') {
 127         # Just print the message.
 128         print STDERR $req->message, "\n";
 129     } else {
 130         # This shouldn't happen.
 131         Carp::croak("Invalid request type '$type'");
 132     }
 133
 134     # Return true to indicate that we've handled the request.
 135     return 1;
 136 }
 137
 138 1;
 139 __END__
 140
 141 =head1 BUGS
 142
 143 Report all bugs via the CPAN Request Tracker at
 144 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
 145
 146 =head1 AUTHOR
 147
 148 David Wheeler <L<david@wheeler.net|"david@wheeler.net">>
 149
 150 =head1 SEE ALSO
 151
 152 L<App::Info|App::Info> documents the event handling interface.
 153
 154 L<App::Info::Handler::Carp|App::Info::Handler::Carp> handles events by
 155 passing their messages Carp module functions.
 156
 157 L<App::Info::Handler::Print|App::Info::Handler::Print> handles events by
 158 printing their messages to a file handle.
 159
 160 L<App::Info::Handler|App::Info::Handler> describes how to implement custom
 161 App::Info event handlers.
 162
 163 =head1 COPYRIGHT AND LICENSE
 164
 165 Copyright (c) 2002, David Wheeler. All Rights Reserved.
 166
 167 This module is free software; you can redistribute it and/or modify it under the
 168 same terms as Perl itself.
 169
 170 =cut