source: PATCHED/FCM_V1.2/bin/fcm @ 2

Last change on this file since 2 was 1, checked in by fcm, 15 years ago

creation de larborescence
File size: 23.2 KB
Line 
1#!/usr/bin/perl
2# ------------------------------------------------------------------------------
3# NAME
4#   fcm
5#
6# SYNOPSIS
7#   fcm SUBCOMMAND [OPTIONS...] ARGS...
8#
9# DESCRIPTION
10#   The fcm command is the frontend of the FCM system. The first argument to the
11#   command must be a recognised subcommand. See "fcm help" for a full list of
12#   functionalities.
13#
14# COPYRIGHT
15#   (C) Crown copyright Met Office. All rights reserved.
16#   For further details please refer to the file COPYRIGHT.txt
17#   which you should have received as part of this distribution.
18# ------------------------------------------------------------------------------
19
20# Standard pragmas:
21use warnings;
22use strict;
23
24# Standard modules:
25use File::Basename;
26use File::Spec;
27use Getopt::Long;
28use Cwd;
29
30# FCM component modules:
31use lib File::Spec->catfile (dirname (dirname ($0)), 'lib');
32use Fcm::Config;
33use Fcm::Extract;
34use Fcm::Build;
35use Fcm::Util;
36
37BEGIN {
38  eval {
39    require Fcm::Cm;
40    import Fcm::Cm;
41
42    require Fcm::CmUrl;
43    import Fcm::CmUrl;
44  }
45}
46
47# Function declaration:
48sub cmp_ext_cfg;
49sub invoke_build_system;
50sub invoke_extract_system;
51sub invoke_cfg_printer;
52sub invoke_cm_system;
53sub invoke_www_browser;
54sub invoke_help;
55
56# ------------------------------------------------------------------------------
57
58my $prog      = basename $0;
59my $year      = (localtime)[5] + 1900;
60my $copyright = <<EOF;
61
62(C) Crown copyright $year Met Office. All rights reserved.
63EOF
64
65# List of sub-commands recognised by FCM
66my %subcommand = (
67  HLP => [qw/help ? h/],
68  BLD => [qw/build bld/],
69  EXT => [qw/extract ext/],
70  CFG => [qw/cfg/],
71  GUI => [qw/gui/],
72  CM  => [qw/
73    branch    br
74    conflicts cf
75    add
76    blame     praise annotate ann
77    cat
78    checkout  co
79    cleanup
80    commit    ci
81    copy      cp
82    delete    del    remove   rm
83    diff      di
84    export
85    import
86    info
87    list      ls
88    lock
89    log
90    merge
91    mkdir
92    mkpatch
93    move      mv     rename   ren
94    propdel   pdel   pd
95    propedit  pedit  pe
96    propget   pget   pg
97    proplist  plist  pl
98    propset   pset   ps
99    resolved
100    revert
101    status    stat   st
102    switch    sw
103    unlock
104    update    up
105  /],
106  CMP => [qw/cmp-ext-cfg/],
107  WWW => [qw/www trac/],
108);
109
110# Get configuration settings
111my $config = Fcm::Config->new ();
112$config->get_config ();
113
114# Determine the functionality of this invocation of the command
115my $function = @ARGV ? shift @ARGV : '';
116
117# Run command accordingly
118if (grep {$_ eq $function} @{ $subcommand{BLD} }) {
119  invoke_build_system;
120
121} elsif (grep {$_ eq $function} @{ $subcommand{EXT} }) {
122  invoke_extract_system;
123
124} elsif (grep {$_ eq $function} @{ $subcommand{CFG} }) {
125  invoke_cfg_printer;
126
127} elsif (grep {$_ eq $function} @{ $subcommand{GUI} }) {
128  &run_command (['fcm_gui', @ARGV], METHOD => 'exec');
129
130} elsif (grep {$_ eq $function} @{ $subcommand{CM} }) {
131  invoke_cm_system;
132
133} elsif (grep {$_ eq $function} @{ $subcommand{CMP} }) {
134  cmp_ext_cfg;
135
136} elsif (grep {$_ eq $function} @{ $subcommand{WWW} }) {
137  invoke_www_browser;
138
139} elsif ($function =~ /^\s*$/ or grep {$_ eq $function} @{ $subcommand{HLP} }) {
140  invoke_help;
141
142} else {
143  w_report 'Unknown command: ', $function;
144  e_report 'Type "', $prog, ' help" for usage';
145}
146
147exit;
148
149# ------------------------------------------------------------------------------
150# SYNOPSIS
151#   $cfg = &main::cfg ();
152#
153# DESCRIPTION
154#   Return the $config variable.
155# ------------------------------------------------------------------------------
156
157sub cfg {
158  return $config;
159}
160
161# ------------------------------------------------------------------------------
162# SYNOPSIS
163#   &cmp_ext_cfg ();
164#
165# DESCRIPTION
166#   Compare two similar extract configuration files.
167# ------------------------------------------------------------------------------
168
169sub cmp_ext_cfg {
170  # Check options
171  # ----------------------------------------------------------------------------
172  my ($wiki, $verbose);
173
174  GetOptions ('wiki|w=s' => \$wiki, 'verbose|v' => \$verbose);
175
176  # Check arguments
177  # ----------------------------------------------------------------------------
178  e_report $prog, ' ', $function,
179           ': 2 extract config files must be specified, abort.'
180    if @ARGV < 2;
181
182  # Invoke 2 new instances of the Fcm::Extract class
183  # ----------------------------------------------------------------------------
184  my (@cfg, $rc);
185  for my $i (0 .. 1) {
186    $cfg[$i] = Fcm::Extract->new (CFG_SRC => $ARGV[$i]);
187
188    # Read the extract configuration file
189    $rc = $cfg[$i]->decipher_cfg;
190    $rc = $cfg[$i]->expand_cfg if $rc;
191
192    last if not $rc;
193  }
194
195  # Throw error if command has failed
196  # ----------------------------------------------------------------------------
197  e_report $prog, ' ', $function,
198           ': cannot read extract configuration file, abort' if not $rc;
199
200  # Get list of URLs
201  # ----------------------------------------------------------------------------
202  my @urls = ();
203  for my $i (0 .. 1) {
204    # List of branches in each extract configuration file
205    my @branches = $cfg[$i]->branches;
206
207    for my $branch (@branches) {
208      # Ignore declarations of local directories
209      next if $branch->type eq 'user';
210
211      # List of SRC declarations in each branch
212      my %dirs = $branch->dirs;
213
214      for my $dir (values %dirs) {
215        # Set up a new instance of Fcm::CmUrl object for each SRC declaration
216        my $cm_url = Fcm::CmUrl->new (
217          URL => $dir . ($branch->version ? '@' . $branch->version : ''),
218        );
219
220        $urls[$i]{$cm_url->branch_url}{$dir} = $cm_url;
221      }
222    }
223  }
224
225  # Compare
226  # ----------------------------------------------------------------------------
227  my %log;
228  for my $i (0 .. 1) {
229    # Compare the first file with the second one and then vice versa
230    my $j = ($i == 0) ? 1 : 0;
231
232    for my $branch (sort keys %{ $urls[$i] }) {
233      if (exists $urls[$j]{$branch}) {
234        # Same REPOS declarations in both files
235        for my $dir (sort keys %{ $urls[$i]{$branch} }) {
236          if (exists $urls[$j]{$branch}{$dir}) {
237            # Same SRC declarations in both files, only need to compare once
238            next if $i == 1;
239
240            my $this_url = $urls[$i]{$branch}{$dir};
241            my $that_url = $urls[$j]{$branch}{$dir};
242
243            # Check whether their last changed revisions are the same
244            my $this_rev = $this_url->svninfo (FLAG => 'Last Changed Rev');
245            my $that_rev = $that_url->svninfo (FLAG => 'Last Changed Rev');
246
247            # Make sure last changed revisions differ
248            next if $this_rev eq $that_rev;
249
250            # Not interested in the log before the minimum revision
251            my $min_rev = ($this_url->pegrev > $that_url->pegrev)
252                          ? $that_url->pegrev : $this_url->pegrev;
253
254            $this_rev = $min_rev if $this_rev < $min_rev;
255            $that_rev = $min_rev if $that_rev < $min_rev;
256
257            # Get list of changed revisions using the commit log
258            my $u   = ($this_rev > $that_rev) ? $this_url : $that_url;
259            my %revs = $u->svnlog (REV => [$this_rev, $that_rev]);
260
261            for my $rev (keys %revs) {
262              # Check if revision is already in the list
263              next if exists $log{$branch}{$rev};
264
265              # Not interested in the minimum revision
266              next if $rev == $min_rev;
267
268              # Get list of changed paths. Accept this revision only if it
269              # contains changes in the current branch
270              my %paths  = %{ $revs{$rev}{paths} };
271
272              for my $path (keys %paths) {
273                my $change_url = Fcm::CmUrl->new (URL => $u->root . $path);
274
275                if ($change_url->branch eq $u->branch) {
276                  $log{$branch}{$rev} = $u;
277                  last;
278                }
279              }
280            }
281
282          } else {
283            # Report SRC declaration in one file but not in another
284            print $urls[$i]{$branch}{$dir}->url_peg, ':', "\n";
285            print '  in    : ', $ARGV[$i], "\n";
286            print '  not in: ', $ARGV[$j], "\n\n";
287          }
288        }
289
290      } else {
291        # Report REPOS declaration in one file but not in another
292        print $branch, ':', "\n";
293        print '  in    : ', $ARGV[$i], "\n";
294        print '  not in: ', $ARGV[$j], "\n\n";
295      }
296    }
297  }
298
299  # Report modifications
300  # ----------------------------------------------------------------------------
301  print 'Revisions at which declared source directories are modified:', "\n\n"
302    if keys %log;
303
304  if (defined $wiki) {
305    # Output in wiki format
306    my $wiki_url  = Fcm::CmUrl->new (URL => &expand_url_keyword (URL => $wiki));
307    my $base_trac = $wiki
308                    ? &get_browser_url (URL => $wiki_url->project_url)
309                    : $wiki_url;
310    $base_trac    = $wiki_url if not $base_trac;
311
312    for my $branch (sort keys %log) {
313      # Name of the branch
314      my $branch_trac = &get_browser_url (URL => $branch);
315      $branch_trac =~ s#^$base_trac(?:/*|$)#source:#;
316
317      print '[', $branch_trac, ']:', "\n";
318
319      # Revision table
320      for my $rev (sort {$b <=> $a} keys %{ $log{$branch} }) {
321        print $log{$branch}{$rev}->display_svnlog ($rev, $base_trac), "\n";
322      }
323
324      print "\n";
325    }
326
327  } else {
328    my $separator = '-' x 80 . "\n";
329
330    for my $branch (sort keys %log) {
331      # Output in plain text format
332      print $branch, ':', "\n";
333
334      if ($verbose or &cfg->verbose > 1) {
335        # Verbose mode, print revision log
336        for my $rev (sort {$b <=> $a} keys %{ $log{$branch} }) {
337          print $separator, $log{$branch}{$rev}->display_svnlog ($rev), "\n";
338        }
339
340      } else {
341        # Normal mode, print list of revisions
342        print join (' ', sort {$b <=> $a} keys %{ $log{$branch} }), "\n";
343      }
344
345      print $separator, "\n";
346    }
347  }
348
349  return $rc;
350}
351
352# ------------------------------------------------------------------------------
353# SYNOPSIS
354#   &invoke_build_system ();
355#
356# DESCRIPTION
357#   Invoke the build system.
358# ------------------------------------------------------------------------------
359
360sub invoke_build_system {
361  my ($archive, $full, $ignore_lock, $jobs, $stage, @targets, $verbose);
362
363  GetOptions (
364    'archive|a'   => \$archive,     # switch on archive mode?
365    'full|f'      => \$full,        # full build?
366    'ignore-lock' => \$ignore_lock, # ignore lock file?
367    'jobs|j=i'    => \$jobs,        # number of parallel jobs in make
368    'stage|s=s'   => \$stage,       # build up to and including this stage
369    'targets|t=s' => \@targets,     # make targets
370    'verbose|v=i' => \$verbose,     # verbose level
371  );
372
373  # Verbose level
374  $config->verbose ($verbose) if defined $verbose;
375
376  # Invoke a new instance of the Fcm::Build class
377  my $bld = Fcm::Build->new (CFG_SRC  => @ARGV ? join (' ', @ARGV) : cwd ());
378
379  # Perform build
380  $bld->build (
381    ARCHIVE     => $archive,
382    FULL        => $full,
383    IGNORE_LOCK => $ignore_lock,
384    JOBS        => $jobs ? $jobs : 1,
385    STAGE       => $stage ? $stage : 5,
386    TARGETS     => (@targets ? [split (/:/, join (':', @targets))] : [qw/all/]),
387  );
388
389  return 1;
390}
391
392# ------------------------------------------------------------------------------
393# SYNOPSIS
394#   &invoke_extract_system ();
395#
396# DESCRIPTION
397#   Invoke the extract system.
398# ------------------------------------------------------------------------------
399
400sub invoke_extract_system {
401  my ($full, $ignore_lock, $verbose);
402
403  GetOptions (
404    'full|f'      => \$full,        # full extract?
405    'ignore-lock' => \$ignore_lock, # ignore lock file?
406    'verbose|v=i' => \$verbose,     # verbose level
407  );
408
409  $config->verbose ($verbose) if defined $verbose;
410
411  # Invoke a new instance of the Fcm::Extract class
412  my $ext = Fcm::Extract->new (CFG_SRC => @ARGV ? join (' ', @ARGV) : cwd ());
413
414  # Perform extract
415  $ext->extract (FULL => $full, IGNORE_LOCK => $ignore_lock);
416
417  return 1;
418}
419
420# ------------------------------------------------------------------------------
421# SYNOPSIS
422#   &invoke_cfg_printer ();
423#
424# DESCRIPTION
425#   Invoke the CFG file pretty printer.
426# ------------------------------------------------------------------------------
427
428sub invoke_cfg_printer {
429
430  use Fcm::CfgFile;
431
432  my $out_file;
433  GetOptions (
434    'output|o=s'  => \$out_file,  # output file for print
435  );
436
437  my $file = join (' ', @ARGV);
438  e_report $prog, ' ', $function, ': file not specified, abort.' if ! $file;
439
440  # Invoke a new Fcm::CfgFile instance
441  my $cfg = Fcm::CfgFile->new (SRC => $file);
442
443  # Read the cfg file
444  my $read = $cfg->read_cfg;
445  e_report if not $read;
446
447  # Pretty print CFG file
448  $cfg->print_cfg ($out_file);
449
450  return 1;
451}
452
453# ------------------------------------------------------------------------------
454# SYNOPSIS
455#   &invoke_cm_system ();
456#
457# DESCRIPTION
458#   Invoke a code management system command.
459# ------------------------------------------------------------------------------
460
461sub invoke_cm_system {
462
463  &cm_command ($function);
464
465  return 1;
466}
467
468# ------------------------------------------------------------------------------
469# SYNOPSIS
470#   &invoke_www_browser ();
471#
472# DESCRIPTION
473#   Invoke a web browser on the specified PATH.
474# ------------------------------------------------------------------------------
475
476sub invoke_www_browser {
477
478  # Options
479  my ($browser);
480  GetOptions (
481    'browser|b=s' => \$browser, # browser command
482  );
483
484  $browser = &cfg->setting (qw/MISC WEB_BROWSER/) unless $browser;
485
486  # Arguments
487  my ($arg) = @ARGV ? $ARGV[0] : (&is_wc () ? '.' : '');
488  e_report $prog, ' ', $function,
489           ': input URL not specified and . not a working copy, abort.'
490    if not $arg;
491
492  # Local PATH?
493  $arg = &expand_tilde ($arg);
494  $arg = &get_url_of_wc ($arg) if -e $arg;
495
496  # Expand URL and revision keywords
497  my $www_url = &expand_url_keyword (URL => $arg);
498  my $rev     = 'HEAD';
499
500  if ($www_url =~ m#^(\w+://\S+)@(\S+)$#) {
501    $www_url = $1;
502    $rev     = $2;
503  }
504
505  $rev = &expand_rev_keyword (URL => $www_url, REV => $rev, HEAD => 1)
506    unless uc ($rev) eq 'HEAD';
507
508  # Get web browser URL
509  $www_url = &get_browser_url (URL => $www_url);
510  die 'WWW URL not defined for "', $arg, '", abort' unless $www_url;
511
512  $www_url = $www_url . '?rev=' . $rev;
513
514  # Execute command
515  my @command = (split (/\s+/, $browser), $www_url);
516  &run_command (\@command, METHOD => 'exec', PRINT => 1);
517}
518
519# ------------------------------------------------------------------------------
520# SYNOPSIS
521#   &invoke_help ();
522#
523# DESCRIPTION
524#   Invoke help.
525# ------------------------------------------------------------------------------
526
527sub invoke_help {
528
529  my $cmd = @ARGV ? shift @ARGV : undef;
530
531  if ($cmd) {
532    if (grep {$_ eq $cmd} @{ $subcommand{BLD} }) {
533      print <<EOF;
534$prog $cmd: invoke the build system.
535usage: $prog $cmd [OPTIONS...] [CFGFILE]
536
537  The path to a CFG file may be provided. Otherwise, the build system
538  searches the default locations for a bld cfg file.
539
540  If no option is specified, the options "-s 5 -t all -j 1 -v 1" are assumed.
541
542  If the option for full build is specified, the sub-directories created by
543  previous builds will be removed, so that the current build can start cleanly.
544
545  The -s option can be used to limit the actions performed by the build system
546  up to a named stage. The stages are:
547    "1", "s" or "setup"                - stage 1, setup
548    "2", "pp" or "pre_process"         - stage 2, pre-process
549    "3", "gd" or "generate_dependency" - stage 3, generate dependency
550    "4", "gi" or "generate_interface"  - stage 4, generate Fortran 9X interface
551    "5", "m", "make"                   - stage 5, make
552
553  If a colon separated list of targets is specified using the -t option, the
554  default targets specified in the configuration file will not be used.
555
556  If archive mode is switched on, build sub-directories that are only used
557  in the build process will be archived to TAR files. The default is off.
558
559  If specified, the verbose level must be an integer greater than 0. Verbose
560  level 0 is the quiet mode. Increasing the verbose level will increase the
561  amount of diagnostic output.
562
563  When a build is invoked, it sets up a lock file in the build root directory.
564  The lock is normally removed at the end of the build. While the lock file is
565  in place, othe build commands invoked in the same root directory will fail.
566  If you need to bypass this check for whatever reason, you can invoke the
567  build system with the --ignore-lock option.
568
569Valid options:
570  -a [--archive]     : archive build sub-directories?
571  -f [--full]        : full build
572  --ignore-lock      : ignore lock files in build root directory
573  -j [--jobs] arg    : number of parallel jobs that "make" can handle
574  -s [--stage] arg   : perform build up to a named stage
575  -t [--targets] arg : build a colon (:) separated list of targets
576  -v [--verbose] arg : verbose level
577$copyright
578EOF
579
580    } elsif (grep {$_ eq $cmd} @{ $subcommand{EXT} }) {
581      print <<EOF;
582$prog $cmd: invoke the extract system.
583usage: $prog $cmd [OPTIONS...] [CFGFILE]
584
585  The path to a CFG file may be provided. Otherwise, the extract system
586  searches the default locations for an ext cfg file.
587
588  If no option is specified, the system will attempt an incremental extract
589  where appropriate.
590
591  If specified, the verbose level must be an integer greater than 0. Verbose
592  level 0 is the quiet mode. Increasing the verbose level will increase the
593  amount of diagnostic output.
594
595  When an extract is invoked, it sets up a lock file in the extract destination
596  root directory. The lock is normally removed at the end of the extract. While
597  the lock file is in place, othe extract commands invoked in the same
598  destination root directory will fail. If you need to bypass this check for
599  whatever reason, you can invoke the extract system with the --ignore-lock
600  option.
601
602Valid options:
603  -f [--full]        : perform a full/clean extract
604  --ignore-lock      : ignore lock files in build root directory
605  -v [--verbose] arg : verbose level
606$copyright
607EOF
608
609    } elsif (grep {$_ eq $cmd} @{ $subcommand{CFG} }) {
610      print <<EOF;
611$prog $cmd: invoke the CFG file pretty printer.
612usage: $prog $cmd [OPTIONS...] FILE
613
614  If no option is specified, the output will be sent to standard output.
615
616Valid options:
617  -o [--output] arg : send output to a file as specified by arg.
618$copyright
619EOF
620
621    } elsif (grep {$_ eq $cmd} @{ $subcommand{GUI} }) {
622      print <<EOF;
623$prog $cmd: invoke the GUI wrapper for CM commands.
624usage: $prog $cmd DIR
625
626  The optional argument DIR modifies the initial working directory.
627$copyright
628EOF
629
630    } elsif (grep {$_ eq $cmd} @{ $subcommand{CM} }) {
631      @ARGV = qw(--help);
632      cm_command ($cmd);
633
634    } elsif (grep {$_ eq $cmd} @{ $subcommand{CMP} }) {
635      print <<EOF;
636$prog $cmd: compare two similar extract configuration files.
637usage: $prog $cmd [OPTIONS...] CFG1 CFG2
638
639  Compares the extract configurations of two similar extract configuration
640  files CFG1 and CFG2.
641
642Valid options:
643  -v [--verbose]  : print revision tables in verbose mode. In particular,
644                    display the change log of each revision.
645  -w [--wiki] arg : print revision tables in wiki format. The argument to this
646                    option must be the Subversion URL or FCM URL keyword of a
647                    FCM project associated with the intended Trac system. This
648                    option overrides the -v option.
649$copyright
650EOF
651
652    } elsif (grep {$_ eq $cmd} @{ $subcommand{WWW} }) {
653      print <<EOF;
654$prog $cmd: invoke the web repository browser on a Subversion URL.
655usage: $prog $cmd [OPTIONS...] [PATH]
656
657  If PATH is specified, it must be a FCM URL keyword, a Subversion URL or the
658  PATH to a local working copy. If not specified, the current working directory
659  is assumed to be a working copy. If the --browser option is specified, the
660  specified web browser command is used to launch the repository browser.
661  Otherwise, it attempts to use the default browser from the configuration
662  setting.
663
664Valid options:
665  -b [--browser] arg : specify a command arg for the web browser.
666$copyright
667EOF
668
669    } elsif (grep {$_ eq $cmd} @{ $subcommand{HLP} }) {
670      print <<EOF;
671help (?, h): Describe the usage of $prog or its subcommands.
672usage: $prog help [SUBCOMMAND...]
673$copyright
674EOF
675
676      &run_command ([qw/svn help/, $cmd, @ARGV], PRINT => 1);
677
678    } else {
679      warn $prog, ' help: "', $cmd, '" not recognised';
680      $cmd = undef;
681    }
682  }
683
684  if (not $cmd) {
685    # Get output from "svn help"
686    my @lines = &run_command (
687      [qw/svn help/], DEVNULL => 1, METHOD => 'qx', ERROR => 'ignore',
688    );
689
690    # Get release number, (and revision number from revision number file)
691    my $release  = &cfg->setting ('RELEASE');
692    my $rev_file = &cfg->setting ('REV_FILE');
693
694    if (-r $rev_file) {
695      open FILE, '<', $rev_file;
696      my $rev = readline 'FILE';
697      close FILE;
698
699      chomp $rev;
700      $release .= '-dev (r' . $rev . ')' if $rev;
701    }
702
703    # Print common help
704    print <<EOF;
705usage: $prog <subcommand> [options] [args]
706Flexible configuration management system, release $release.
707Type "$prog help <subcommand>" for help on a specific subcommand.
708
709Available subcommands:
710  help       (h, ?) - help
711  build      (bld)  - build system
712EOF
713
714    # The following are only available on platforms with "svn" installed
715    if (@lines) {
716      print <<EOF;
717  branch     (br)   - cm system: branch info & creation
718  cfg               - CFG file pretty printer
719  cmp-ext-cfg       - compare two similar extract configuration files
720  conflicts  (cf)   - cm system: resolve conflicts
721  extract    (ext)  - extract system
722  mkpatch           - create patches from specified revisions of a URL
723  trac       (www)  - cm system: browse a path using the web browser
724  <SVN COMMANDS>    - any Subversion sub-commands
725EOF
726    }
727
728    # Print FCM copyright notice
729    print $copyright;
730
731    # Print output from "svn help"
732    if (@lines) {
733      print "\n";
734      &print_command ([qw/svn help/]);
735      print @lines;
736    }
737  }
738
739  return 1;
740}
741
742# ------------------------------------------------------------------------------
743# SYNOPSIS
744#   $ans = &main::get_input (MESSAGE => $mesg, TYPE => $type, DEFAULT => $def);
745#
746# DESCRIPTION
747#   Get an input string from the user and return it as $ans. MESSAGE is the
748#   main message printed on screen to prompt the user for an input.  If TYPE is
749#   'YN', print message to prompt user to enter either 'y' or 'n'. If TYPE is
750#   'YNA', then 'a' is given as a third option. If DEFAULT is set, print message
751#   to inform user that the return value will be set to the $def (if nothing is
752#   entered).
753# ------------------------------------------------------------------------------
754
755sub get_input {
756  my %args = @_;
757  my $type  = exists $args{TYPE}    ? $args{TYPE}    : '';
758  my $mesg  = exists $args{MESSAGE} ? $args{MESSAGE} : '';
759  my $def   = exists $args{DEFAULT} ? $args{DEFAULT} : '';
760
761  my $ans;
762
763  while (1) {
764    # Print the prompt
765    print $mesg;
766    print "\n", 'Enter "y" or "n"' if uc ($type) eq 'YN';
767    print "\n", 'Enter "y", "n" or "a"' if uc ($type) eq 'YNA';
768    print ' (or just press <return> for "', $def, '")' if $def;
769    print ': ';
770
771    # Get answer from STDIN
772    $ans = <STDIN>;
773    chomp $ans;
774
775    # Set answer to default, if necessary
776    $ans = $def if ($def and not $ans);
777
778    if ($type =~ /^yna?$/i) {
779      # For YN and YNA type dialog boxes,
780      # check that the answer is in the correct form
781      my $pat = (uc ($type) eq 'YN' ? 'y|n' : 'y|n|a');
782      last if $ans =~ /^(?:$pat)/i;
783
784    } else {
785      last;
786    }
787  }
788
789  return $ans;
790}
791
792# ------------------------------------------------------------------------------
793
794__END__
Note: See TracBrowser for help on using the repository browser.