# -*- perl -*- # # Module::TestConfig - asks questions and autowrite a module # # $Id: README,v 1.1 2003/08/20 19:30:20 jkeroes Exp $ package Module::TestConfig; require 5.005_62; use strict; use Carp; use Fcntl; use File::Basename qw/dirname/; use File::Path qw/mkpath/; use Text::FormatTable; use Data::Dumper; use Term::ReadKey; use Params::Validate; use Config::Auto; use Module::TestConfig::Question; use vars qw/$VERSION/; $VERSION = '0.02'; #------------------------------------------------------------ # Methods #------------------------------------------------------------ sub new { my $proto = shift; my $class = ref $proto || $proto; my $self = bless {}, $class; return $self->init( verbose => 1, defaults => 'defaults.config', file => 'MyConfig.pm', package => 'MyConfig', order => [ qw/defaults/ ], questions => [ ], _defaults => { }, qi => 0, @_, ); } sub init { my ( $self, %args ) = @_; while ( my ( $method, $args ) = each %args ) { if ( $self->can( $method ) ) { $self->$method( $args ); } else { croak "Can't handle arg: '$method'. Aborting"; } } $self->load_defaults; return $self; } sub load_defaults { my $self = shift; $self->{_defaults} = Config::Auto::parse( $self->{defaults} ) if -r $self->{defaults}; } sub verbose { my $self = shift; $self->{verbose} = shift if @_; $self->{verbose}; } sub debug { my $self = shift; $self->{debug} = shift if @_; $self->{debug}; } sub file { my $self = shift; $self->{file} = shift if @_; $self->{file}; } sub package { my $self = shift; $self->{package} = shift if @_; $self->{package}; } # The filename of the defaults file. sub defaults { my $self = shift; $self->{defaults} = shift if @_; $self->{defaults}; } # The defaults hash sub _defaults { my $self = shift; $self->{_defaults} = shift if @_; $self->{_defaults}; } sub order { my $self = shift; if ( @_ ) { my @order = ref $_[0] eq "ARRAY" ? @{ $_[0] } : @_; for my $order ( @order ) { croak "Bad arg given to order(): '$order'" unless grep /^$order$/, qw/defaults env/; } $self->{order} = [ @order ]; } return wantarray ? @{ $self->{order} } : $self->{order}; } sub questions { my $self = shift; if ( @_ > 1 ) { $self->{questions} = [ map { Module::TestConfig::Question->new( $_ ) } @_ ]; } elsif ( @_ == 1 && ref $_[0] eq "ARRAY" ) { $self->{questions} = [ map { Module::TestConfig::Question->new( $_ ) } @{ $_[0] } ]; } elsif ( @_ ) { croak "questions() got bad args. Needs a list or arrayref."; } return wantarray ? @{ $self->{questions} } : $self->{questions}; } sub answers { my $self = shift; $self->{answers} = shift if @_; return wantarray ? %{ $self->{answers} } : $self->{answers}; } sub answer { my $self = shift; return $self->{answers}{+shift}; } sub ask { my $self = shift; do { my $i = $self->{qi}; my $q = $self->{questions}[$i]; my $name = $q->name; # Skip the question? if ( $q->skip ) { if ( ref $q->skip eq "CODE" ) { next if $q->skip->( $self ); } elsif ( not ref $q->skip ) { next if $q->skip; } else { croak "Don't know how to handle question #$i\'s skip block"; } } $self->prompt( $q ); # Valid answer? my @args = ( $q->name => $self->{answers}{name}); if ( $q->validate && ! validate( @args, $q->validate ) ) { warn "Your answer didn't validate. Please try again.\n\n"; redo; } } while ( $self->{qi}++ < scalar @{$self->{questions}} - 1 ); return $self; } sub get_default { my ($self, $i) = @_; $i ||= $self->{qi}; my $q = $self->{questions}[$i]; my $default = $q->default; my $name = $q->name or croak "No name defined for question \#$i."; for ( $self->order ) { if ( /^env/o ) { return $ENV{"\U$name"} if defined $ENV{"\U$name"}; return $ENV{"\L$name"} if defined $ENV{"\L$name"}; } return $self->{_defaults}{$name} if /^defaults/ && $self->{_defaults}{$name}; } # This will be undef unless set via answers() # or new( answers => {...} ). return $self->{answers}{$name} || $default; } sub save { my ($self) = @_; my $text = $self->package_text or croak "No text to save. Aborting."; my $dir = dirname( $self->{file} ); unless ( -d $dir ) { mkpath( [ $dir ], $self->{verbose}) or croak "Can't make path $dir: $!"; } sysopen F, $self->{file}, O_CREAT | O_WRONLY | O_TRUNC, 0600 or croak "Can't open '$self->{file}' for write: $!"; print F $text; close F or carp "Can't close '$self->{file}'. $!", return; print "Module::TestConfig saved $self->{file} with these settings:\n" . $self->report if $self->{verbose}; } sub report { my $self = shift; my $screen_width = (Term::ReadKey::GetTerminalSize())[0] || 79; my $table = Text::FormatTable->new( '| r | l |' ); $table->rule('='); $table->head('Name', 'Value'); $table->rule('='); for my $q ( @{ $self->{questions} } ) { if ( $q->noecho ) { $table->row( $q->name, '*****' ); } else { $table->row( $q->name, $self->answer( $q->name ) ); } } $table->rule('-'); return $table->render($screen_width); } sub package_text { my $self = shift; local $/ = undef; local $_ = ; my $pkg = $self->{package}; $Data::Dumper::Terse = 2; my $answers = Data::Dumper->Dump( [$self->{answers}] ); s/%%PACKAGE%%/$pkg/m; s/%%ANSWERS%%/$answers/m; return $_; } # Based on ExtUtils::MakeMaker::prompt(). sub prompt { my $self = shift; my $q = shift || $self->{questions}[$self->{qi}]; local $| = 1; croak "prompt() called incorrectly" unless defined $q->msg && defined $q->name; my $def = $self->get_default; my $dispdef = defined $def ? " [$def] " : " "; $def = defined $def ? $def : ""; print $q->msg . $dispdef; my $ans = ''; my $ISA_TTY = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)); # Pipe? if ( $ISA_TTY ) { if ( $Term::ReadKey::VERSION && $q->noecho ) { ReadMode( 'noecho' ); chomp( $ans = ReadLine(0) ); ReadMode( 'normal' ); print "\n"; } else { chomp( $ans = ); } } else { print "$def\n"; } $self->{answers}{$q->name} = $ans ne '' ? $ans : $def; } # Question index sub qi { my $self = shift; $self->{qi} = shift if @_; $self->{qi}; } #------------------------------------------------------------ # Docs #------------------------------------------------------------ =head1 NAME Module::TestConfig - Write a config module for your tests and/or module. =head1 SYNOPSIS use Module::TestConfig; Module::TestConfig->new( verbose => 1, defaults => 'defaults.config', file => 'MyConfig.pm', package => 'MyConfig', order => [ qw/defaults env/ ], questions => [ [ 'Would you like tea?' => 'tea', 'y' ], [ 'Crumpets?' => 'crumpets', 'y' ], ] )->ask->save; # and in another module or test file: use MyConfig; my $config = TestConfig->new; print $config->tea eq 'y' ? "We're having tea today; splendid!" : "No tea, I'm afraid. P'raps tomorrow."; print $config->crumpets eq 'y' ? "Crumpets; lovely!" : "Alas, we have no crumpets today"; =head1 DESCRIPTION This module prompts a user for info and writes a module for later use. You can use it during the module build process (e.g. perl Makefile.PL) to share info among your test files. You can use it to write a module and install that into your site_perl tree. Module::TestConfig writes an object-oriented file. You specify the file's location as well as the package name. When you use that file, all of the question names will behave as object methods. e.g. If you asked the question: Module::TestConfig->new( file => 't/MyConfig.pm', package => 'MyConfig', questions => [ { name => 'fingers', msg => 'How many fingers am I holding up?', default => 11, }, ], )->ask->save; Then the file t/MyConfig.pm would be written. To use it, add this to another file: use MyConfig; my $config = MyConfig->new; print $config->fingers; # prints 11 or whatever number the user picked. =head2 PUBLIC METHODS =over 2 =item new() Args and defaults: verbose => 1, defaults => 'defaults.config', file => 'MyConfig.pm', package => 'MyConfig', order => [ 'defaults' ], questions => [ ... ], Returns a new Module::TestConfig object. =item questions() Set up the questions that we prompt the user for. They can be in one of two forms, the array form or the hash form. See L for more about the question's arguments. Args: =over 4 =item questions: A string like "Have you seen my eggplant?" or "Kittens:". They look best when they end with a ':' or a '?'. =item name: A simple mnemonic used for looking up values later. Since it will turn into a method name in the future, it ought to match /[\w_]+/. =item default: optional. a default answer. =item options: optional. A hashref with any or all of the following: =over 4 =item noecho: optional. 1 or 0. Do we print the user's answer while they are typing? This is useful when asking for for passwords. =item skip: optional. Accepts either a coderef or a scalar. The Module::TestConfig will be passed to the coderef as its first and only argument. Use it to look up answer()s. If the coderef returns true or the scalar is true, the current question will be skipped. =item validate: optional. a Params::Validate::validate() hashref. See L. The question will loop until the user types an answer that validates. =back =back Args: an AoH. e.g. questions( [ { ... }, ... ] ) a LoH. e.g. questions( { ... }, ... ) e.g. [ [ "Question to ask", $name, $optional_default, \%optional_options ], ... ] or [ { question => "Question to ask", name => "foo", default => 0, opts => { ... } }, ... ] the $optional_options looks like: { noecho => 1, # set to 1 for password-prompting skip => \&coderef | $scalar, # skip the current question if true validate => Params::Validate::hashref # question will loop until this passes ... } Returns: a list of questions in list context an arrayref of questions in scalar context. =item ask() Asks the user the questions. Returns: a Module::TestConfig object. =item save() Writes our answers to the file. The file created will always be 0600 for security reasons. This may change in the future. See L<"SECURITY"> for more info. =item defaults() A file parsed by Config::Auto which may be used as default answers to the questions. See L<"order()"> Default: "defaults.config" Args: A filename or path. Returns: A filename or path. =item file() The filename that gets written during save(). Default: "MyConfig.pm" Args: a filepath that should probably end in ".pm". e.g. "t/MyConfig.pm" Returns: the filename or path. =item package() The file's package name written during save(). Default: "MyConfig" Args: a package namespace. e.g. "Foo::Bar::Baz" Returns: the set package. =item order() Default: [ 'defaults' ] Args: ordered list of 'defaults' and/or 'env'. Defaults to the questions can come from either a file, the environment, or some combination of both. Args: =over 4 =item defaults: a file read by Config::Auto that must parse to a hash of question names and values. =item env: environment variables in either upper or lowercase. =back The following will also be checked, in order: =over 4 =item answers: Any answers already hard-set via answers(). =item a question's default: A default supplied with the question. =back There's a security risk when accepting defaults from the environment. See L<"SECURITY"> =item answer() Get the current value of a question. This can be used with skip. Args: a question's name. Returns: The current value or undef. =item verbose() Should the module be chatty while running? Should it print a report at the end? Default: 1 Args: 1 or 0 Returns: current value =item debug() Placeholder for future development - this method isn't used. Default: 0 Args: 1 or 0 Returns: current value =back =head1 PROTECTED METHODS These are documented primarily for subclassing. =over 2 =item answers() A user's questions get stored here. If you preset any answers beforehand, they may be used as defaults. See L<"order()"> for those rules. Args: a hash of question names and answers Returns: A hash in list context, a hashref in scalar context. =item prompt() Ask the user a question. The answer will be cached in the object for later. Args: $question, $default_answer, \%options =item get_default() Look through the options(), the answers(), and the question's default for a suitable default to print with the question. =item load_defaults() Uses Config::Auto to parse the file specified by defaults(). Defaults are stored in $obj-E{_defaults}. =item package_text() Returns the new file's text. This should take package() and answers() into account. =item qi() The current question index. Args: A number Returns: The current number =item report() Returns a report of question names and values. Will be printed if the object is in verbose mode. =back =head1 SECURITY The resultant file (TestConfig.pm by default) will be chmod'd to 0600 but it will remain on the system. Using the environment as input may also be a security risk - or a potential bug - especially if your names mimic existing environment variables. =head1 AUTHOR Joshua Keroes Ejkeroes@eli.netE =head1 COPYRIGHT AND LICENSE Copyright 2003 by Joshua Keroes Ejkeroes@eli.netE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L L =cut # Template for module generation follows: __DATA__ # -*- perl -*- # # This module was autogenerated by Module::TestConfig package %%PACKAGE%%; use strict; use Carp; use vars '$AUTOLOAD'; sub new { my $proto = shift; my $class = ref $proto || $proto; my $self = %%ANSWERS%%; return bless $self, $class; } sub AUTOLOAD { my $self = shift; ($AUTOLOAD) = $AUTOLOAD =~ /(\w+)$/; croak "No such method: $AUTOLOAD" unless defined $self->{$AUTOLOAD} || $AUTOLOAD eq "DESTROY"; return $self->{$AUTOLOAD}; } 1;