source: OFFICIAL/FCM_V1.3/bin/fcm @ 7

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

creation de larborescence
File size: 23.4 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;
187
188    # Read the extract configuration file
189    $cfg[$i]->cfg->src ($ARGV[$i]);
190    $cfg[$i]->parse_cfg;
191    $rc = $cfg[$i]->expand_cfg;
192
193    last if not $rc;
194  }
195
196  # Throw error if command has failed
197  # ----------------------------------------------------------------------------
198  e_report $prog, ' ', $function,
199           ': cannot read extract configuration file, abort' if not $rc;
200
201  # Get list of URLs
202  # ----------------------------------------------------------------------------
203  my @urls = ();
204  for my $i (0 .. 1) {
205    # List of branches in each extract configuration file
206    my @branches = @{ $cfg[$i]->branches };
207
208    for my $branch (@branches) {
209      # Ignore declarations of local directories
210      next if $branch->type eq 'user';
211
212      # List of SRC declarations in each branch
213      my %dirs = %{ $branch->dirs };
214
215      for my $dir (values %dirs) {
216        # Set up a new instance of Fcm::CmUrl object for each SRC declaration
217        my $cm_url = Fcm::CmUrl->new (
218          URL => $dir . ($branch->revision ? '@' . $branch->revision : ''),
219        );
220
221        $urls[$i]{$cm_url->branch_url}{$dir} = $cm_url;
222      }
223    }
224  }
225
226  # Compare
227  # ----------------------------------------------------------------------------
228  my %log;
229  for my $i (0 .. 1) {
230    # Compare the first file with the second one and then vice versa
231    my $j = ($i == 0) ? 1 : 0;
232
233    for my $branch (sort keys %{ $urls[$i] }) {
234      if (exists $urls[$j]{$branch}) {
235        # Same REPOS declarations in both files
236        for my $dir (sort keys %{ $urls[$i]{$branch} }) {
237          if (exists $urls[$j]{$branch}{$dir}) {
238            # Same SRC declarations in both files, only need to compare once
239            next if $i == 1;
240
241            my $this_url = $urls[$i]{$branch}{$dir};
242            my $that_url = $urls[$j]{$branch}{$dir};
243
244            # Check whether their last changed revisions are the same
245            my $this_rev = $this_url->svninfo (FLAG => 'Last Changed Rev');
246            my $that_rev = $that_url->svninfo (FLAG => 'Last Changed Rev');
247
248            # Make sure last changed revisions differ
249            next if $this_rev eq $that_rev;
250
251            # Not interested in the log before the minimum revision
252            my $min_rev = ($this_url->pegrev > $that_url->pegrev)
253                          ? $that_url->pegrev : $this_url->pegrev;
254
255            $this_rev = $min_rev if $this_rev < $min_rev;
256            $that_rev = $min_rev if $that_rev < $min_rev;
257
258            # Get list of changed revisions using the commit log
259            my $u   = ($this_rev > $that_rev) ? $this_url : $that_url;
260            my %revs = $u->svnlog (REV => [$this_rev, $that_rev]);
261
262            for my $rev (keys %revs) {
263              # Check if revision is already in the list
264              next if exists $log{$branch}{$rev};
265
266              # Not interested in the minimum revision
267              next if $rev == $min_rev;
268
269              # Get list of changed paths. Accept this revision only if it
270              # contains changes in the current branch
271              my %paths  = %{ $revs{$rev}{paths} };
272
273              for my $path (keys %paths) {
274                my $change_url = Fcm::CmUrl->new (URL => $u->root . $path);
275
276                if ($change_url->branch eq $u->branch) {
277                  $log{$branch}{$rev} = $u;
278                  last;
279                }
280              }
281            }
282
283          } else {
284            # Report SRC declaration in one file but not in another
285            print $urls[$i]{$branch}{$dir}->url_peg, ':', "\n";
286            print '  in    : ', $ARGV[$i], "\n";
287            print '  not in: ', $ARGV[$j], "\n\n";
288          }
289        }
290
291      } else {
292        # Report REPOS declaration in one file but not in another
293        print $branch, ':', "\n";
294        print '  in    : ', $ARGV[$i], "\n";
295        print '  not in: ', $ARGV[$j], "\n\n";
296      }
297    }
298  }
299
300  # Report modifications
301  # ----------------------------------------------------------------------------
302  print 'Revisions at which declared source directories are modified:', "\n\n"
303    if keys %log;
304
305  if (defined $wiki) {
306    # Output in wiki format
307    my $wiki_url  = Fcm::CmUrl->new (URL => &expand_url_keyword (URL => $wiki));
308    my $base_trac = $wiki
309                    ? &get_browser_url (URL => $wiki_url->project_url)
310                    : $wiki_url;
311    $base_trac    = $wiki_url if not $base_trac;
312
313    for my $branch (sort keys %log) {
314      # Name of the branch
315      my $branch_trac = &get_browser_url (URL => $branch);
316      $branch_trac =~ s#^$base_trac(?:/*|$)#source:#;
317
318      print '[', $branch_trac, ']:', "\n";
319
320      # Revision table
321      for my $rev (sort {$b <=> $a} keys %{ $log{$branch} }) {
322        print $log{$branch}{$rev}->display_svnlog ($rev, $base_trac), "\n";
323      }
324
325      print "\n";
326    }
327
328  } else {
329    my $separator = '-' x 80 . "\n";
330
331    for my $branch (sort keys %log) {
332      # Output in plain text format
333      print $branch, ':', "\n";
334
335      if ($verbose or &cfg->verbose > 1) {
336        # Verbose mode, print revision log
337        for my $rev (sort {$b <=> $a} keys %{ $log{$branch} }) {
338          print $separator, $log{$branch}{$rev}->display_svnlog ($rev), "\n";
339        }
340
341      } else {
342        # Normal mode, print list of revisions
343        print join (' ', sort {$b <=> $a} keys %{ $log{$branch} }), "\n";
344      }
345
346      print $separator, "\n";
347    }
348  }
349
350  return $rc;
351}
352
353# ------------------------------------------------------------------------------
354# SYNOPSIS
355#   &invoke_build_system ();
356#
357# DESCRIPTION
358#   Invoke the build system.
359# ------------------------------------------------------------------------------
360
361sub invoke_build_system {
362  my ($archive, $clean, $full, $ignore_lock, $jobs, $stage, @targets, $verbose);
363
364  GetOptions (
365    'archive|a'   => \$archive,     # switch on archive mode?
366    'clean'       => \$clean,       # run in clean mode?
367    'full|f'      => \$full,        # full build?
368    'ignore-lock' => \$ignore_lock, # ignore lock file?
369    'jobs|j=i'    => \$jobs,        # number of parallel jobs in make
370    'stage|s=s'   => \$stage,       # build up to and including this stage
371    'targets|t=s' => \@targets,     # make targets
372    'verbose|v=i' => \$verbose,     # verbose level
373  );
374
375  # Verbose level
376  $config->verbose ($verbose) if defined $verbose;
377
378  # Invoke a new instance of the Fcm::Build class
379  my $bld = Fcm::Build->new;
380  $bld->cfg->src (@ARGV ? join (' ', @ARGV) : cwd ());
381
382  # Perform build
383  $bld->invoke (
384    ARCHIVE     => $archive,
385    CLEAN       => $clean,
386    FULL        => $full,
387    IGNORE_LOCK => $ignore_lock,
388    JOBS        => $jobs ? $jobs : 1,
389    STAGE       => $stage ? $stage : 5,
390    TARGETS     => (@targets ? [split (/:/, join (':', @targets))] : [qw/all/]),
391  );
392
393  return 1;
394}
395
396# ------------------------------------------------------------------------------
397# SYNOPSIS
398#   &invoke_extract_system ();
399#
400# DESCRIPTION
401#   Invoke the extract system.
402# ------------------------------------------------------------------------------
403
404sub invoke_extract_system {
405  my ($clean, $full, $ignore_lock, $verbose);
406
407  GetOptions (
408    'clean'       => \$clean,       # run in clean mode?
409    'full|f'      => \$full,        # full extract?
410    'ignore-lock' => \$ignore_lock, # ignore lock file?
411    'verbose|v=i' => \$verbose,     # verbose level
412  );
413
414  $config->verbose ($verbose) if defined $verbose;
415
416  # Invoke a new instance of the Fcm::Extract class
417  my $ext = Fcm::Extract->new;
418  $ext->cfg->src (@ARGV ? join (' ', @ARGV) : cwd ());
419
420  # Perform extract
421  $ext->invoke (CLEAN => $clean, FULL => $full, IGNORE_LOCK => $ignore_lock);
422
423  return 1;
424}
425
426# ------------------------------------------------------------------------------
427# SYNOPSIS
428#   &invoke_cfg_printer ();
429#
430# DESCRIPTION
431#   Invoke the CFG file pretty printer.
432# ------------------------------------------------------------------------------
433
434sub invoke_cfg_printer {
435
436  use Fcm::CfgFile;
437
438  my $out_file;
439  GetOptions (
440    'output|o=s'  => \$out_file,  # output file for print
441  );
442
443  my $file = join (' ', @ARGV);
444  e_report $prog, ' ', $function, ': file not specified, abort.' if ! $file;
445
446  # Invoke a new Fcm::CfgFile instance
447  my $cfg = Fcm::CfgFile->new (SRC => $file);
448
449  # Read the cfg file
450  &cfg->verbose (0); # Set verbose mode to zero to suppress file name printing
451  my $read = $cfg->read_cfg;
452  e_report if not $read;
453
454  # Pretty print CFG file
455  $cfg->print_cfg ($out_file);
456
457  return 1;
458}
459
460# ------------------------------------------------------------------------------
461# SYNOPSIS
462#   &invoke_cm_system ();
463#
464# DESCRIPTION
465#   Invoke a code management system command.
466# ------------------------------------------------------------------------------
467
468sub invoke_cm_system {
469
470  &cm_command ($function);
471
472  return 1;
473}
474
475# ------------------------------------------------------------------------------
476# SYNOPSIS
477#   &invoke_www_browser ();
478#
479# DESCRIPTION
480#   Invoke a web browser on the specified PATH.
481# ------------------------------------------------------------------------------
482
483sub invoke_www_browser {
484
485  # Options
486  my ($browser);
487  GetOptions (
488    'browser|b=s' => \$browser, # browser command
489  );
490
491  $browser = &cfg->setting (qw/WEB_BROWSER/) unless $browser;
492
493  # Arguments
494  my ($arg) = @ARGV ? $ARGV[0] : (&is_wc () ? '.' : '');
495  e_report $prog, ' ', $function,
496           ': input URL not specified and . not a working copy, abort.'
497    if not $arg;
498
499  # Local PATH?
500  $arg = &expand_tilde ($arg);
501  $arg = &get_url_of_wc ($arg) if -e $arg;
502
503  # Expand URL and revision keywords
504  my $www_url = &expand_url_keyword (URL => $arg);
505  my $rev     = 'HEAD';
506
507  if ($www_url =~ m#^(\w+://\S+)@(\S+)$#) {
508    $www_url = $1;
509    $rev     = $2;
510  }
511
512  $rev = &expand_rev_keyword (URL => $www_url, REV => $rev, HEAD => 1)
513    unless uc ($rev) eq 'HEAD';
514
515  # Get web browser URL
516  $www_url = &get_browser_url (URL => $www_url);
517  die 'WWW URL not defined for "', $arg, '", abort' unless $www_url;
518
519  $www_url = $www_url . '?rev=' . $rev;
520
521  # Execute command
522  my @command = (split (/\s+/, $browser), $www_url);
523  &run_command (\@command, METHOD => 'exec', PRINT => 1);
524}
525
526# ------------------------------------------------------------------------------
527# SYNOPSIS
528#   &invoke_help ();
529#
530# DESCRIPTION
531#   Invoke help.
532# ------------------------------------------------------------------------------
533
534sub invoke_help {
535
536  my $cmd = @ARGV ? shift @ARGV : undef;
537
538  if ($cmd) {
539    if (grep {$_ eq $cmd} @{ $subcommand{BLD} }) {
540      print <<EOF;
541$prog $cmd: invoke the build system.
542usage: $prog $cmd [OPTIONS...] [CFGFILE]
543
544  The path to a CFG file may be provided. Otherwise, the build system
545  searches the default locations for a bld cfg file.
546
547  If no option is specified, the options "-s 5 -t all -j 1 -v 1" are assumed.
548
549  If the option for full build is specified, the sub-directories created by
550  previous builds will be removed, so that the current build can start cleanly.
551
552  The -s option can be used to limit the actions performed by the build system
553  up to a named stage. The stages are:
554    "1", "s" or "setup"                - stage 1, setup
555    "2", "pp" or "pre_process"         - stage 2, pre-process
556    "3", "gd" or "generate_dependency" - stage 3, generate dependency
557    "4", "gi" or "generate_interface"  - stage 4, generate Fortran 9X interface
558    "5", "m", "make"                   - stage 5, make
559
560  If a colon separated list of targets is specified using the -t option, the
561  default targets specified in the configuration file will not be used.
562
563  If archive mode is switched on, build sub-directories that are only used
564  in the build process will be archived to TAR files. The default is off.
565
566  If specified, the verbose level must be an integer greater than 0. Verbose
567  level 0 is the quiet mode. Increasing the verbose level will increase the
568  amount of diagnostic output.
569
570  When a build is invoked, it sets up a lock file in the build root directory.
571  The lock is normally removed at the end of the build. While the lock file is
572  in place, othe build commands invoked in the same root directory will fail.
573  If you need to bypass this check for whatever reason, you can invoke the
574  build system with the --ignore-lock option.
575
576Valid options:
577  -a [--archive]     : archive build sub-directories?
578  -f [--full]        : full build
579  --ignore-lock      : ignore lock files in build root directory
580  -j [--jobs] arg    : number of parallel jobs that "make" can handle
581  -s [--stage] arg   : perform build up to a named stage
582  -t [--targets] arg : build a colon (:) separated list of targets
583  -v [--verbose] arg : verbose level
584$copyright
585EOF
586
587    } elsif (grep {$_ eq $cmd} @{ $subcommand{EXT} }) {
588      print <<EOF;
589$prog $cmd: invoke the extract system.
590usage: $prog $cmd [OPTIONS...] [CFGFILE]
591
592  The path to a CFG file may be provided. Otherwise, the extract system
593  searches the default locations for an ext cfg file.
594
595  If no option is specified, the system will attempt an incremental extract
596  where appropriate.
597
598  If specified, the verbose level must be an integer greater than 0. Verbose
599  level 0 is the quiet mode. Increasing the verbose level will increase the
600  amount of diagnostic output.
601
602  When an extract is invoked, it sets up a lock file in the extract destination
603  root directory. The lock is normally removed at the end of the extract. While
604  the lock file is in place, othe extract commands invoked in the same
605  destination root directory will fail. If you need to bypass this check for
606  whatever reason, you can invoke the extract system with the --ignore-lock
607  option.
608
609Valid options:
610  -f [--full]        : perform a full/clean extract
611  --ignore-lock      : ignore lock files in build root directory
612  -v [--verbose] arg : verbose level
613$copyright
614EOF
615
616    } elsif (grep {$_ eq $cmd} @{ $subcommand{CFG} }) {
617      print <<EOF;
618$prog $cmd: invoke the CFG file pretty printer.
619usage: $prog $cmd [OPTIONS...] FILE
620
621  If no option is specified, the output will be sent to standard output.
622
623Valid options:
624  -o [--output] arg : send output to a file as specified by arg.
625$copyright
626EOF
627
628    } elsif (grep {$_ eq $cmd} @{ $subcommand{GUI} }) {
629      print <<EOF;
630$prog $cmd: invoke the GUI wrapper for CM commands.
631usage: $prog $cmd DIR
632
633  The optional argument DIR modifies the initial working directory.
634$copyright
635EOF
636
637    } elsif (grep {$_ eq $cmd} @{ $subcommand{CM} }) {
638      @ARGV = qw(--help);
639      cm_command ($cmd);
640
641    } elsif (grep {$_ eq $cmd} @{ $subcommand{CMP} }) {
642      print <<EOF;
643$prog $cmd: compare two similar extract configuration files.
644usage: $prog $cmd [OPTIONS...] CFG1 CFG2
645
646  Compares the extract configurations of two similar extract configuration
647  files CFG1 and CFG2.
648
649Valid options:
650  -v [--verbose]  : print revision tables in verbose mode. In particular,
651                    display the change log of each revision.
652  -w [--wiki] arg : print revision tables in wiki format. The argument to this
653                    option must be the Subversion URL or FCM URL keyword of a
654                    FCM project associated with the intended Trac system. This
655                    option overrides the -v option.
656$copyright
657EOF
658
659    } elsif (grep {$_ eq $cmd} @{ $subcommand{WWW} }) {
660      print <<EOF;
661$prog $cmd: invoke the web repository browser on a Subversion URL.
662usage: $prog $cmd [OPTIONS...] [PATH]
663
664  If PATH is specified, it must be a FCM URL keyword, a Subversion URL or the
665  PATH to a local working copy. If not specified, the current working directory
666  is assumed to be a working copy. If the --browser option is specified, the
667  specified web browser command is used to launch the repository browser.
668  Otherwise, it attempts to use the default browser from the configuration
669  setting.
670
671Valid options:
672  -b [--browser] arg : specify a command arg for the web browser.
673$copyright
674EOF
675
676    } elsif (grep {$_ eq $cmd} @{ $subcommand{HLP} }) {
677      print <<EOF;
678help (?, h): Describe the usage of $prog or its subcommands.
679usage: $prog help [SUBCOMMAND...]
680$copyright
681EOF
682
683      &run_command ([qw/svn help/, $cmd, @ARGV], PRINT => 1);
684
685    } else {
686      warn $prog, ' help: "', $cmd, '" not recognised';
687      $cmd = undef;
688    }
689  }
690
691  if (not $cmd) {
692    # Get output from "svn help"
693    my @lines = &run_command (
694      [qw/svn help/], DEVNULL => 1, METHOD => 'qx', ERROR => 'ignore',
695    );
696
697    # Get release number, (and revision number from revision number file)
698    my $release  = &cfg->setting ('FCM_RELEASE');
699    my $rev_file = &cfg->setting ('FCM_REV_FILE');
700
701    if (-r $rev_file) {
702      open FILE, '<', $rev_file;
703      my $rev = readline 'FILE';
704      close FILE;
705
706      chomp $rev;
707      $release .= ' (r' . $rev . ')' if $rev;
708    }
709
710    # Print common help
711    print <<EOF;
712usage: $prog <subcommand> [options] [args]
713Flexible configuration management system, release $release.
714Type "$prog help <subcommand>" for help on a specific subcommand.
715
716Available subcommands:
717  help       (h, ?) - help
718  build      (bld)  - build system
719EOF
720
721    # The following are only available on platforms with "svn" installed
722    if (@lines) {
723      print <<EOF;
724  branch     (br)   - cm system: branch info & creation
725  cfg               - CFG file pretty printer
726  cmp-ext-cfg       - compare two similar extract configuration files
727  conflicts  (cf)   - cm system: resolve conflicts
728  extract    (ext)  - extract system
729  mkpatch           - create patches from specified revisions of a URL
730  trac       (www)  - cm system: browse a path using the web browser
731  <SVN COMMANDS>    - any Subversion sub-commands
732EOF
733    }
734
735    # Print FCM copyright notice
736    print $copyright;
737
738    # Print output from "svn help"
739    if (@lines) {
740      print "\n";
741      &print_command ([qw/svn help/]);
742      print @lines;
743    }
744  }
745
746  return 1;
747}
748
749# ------------------------------------------------------------------------------
750# SYNOPSIS
751#   $ans = &main::get_input (MESSAGE => $mesg, TYPE => $type, DEFAULT => $def);
752#
753# DESCRIPTION
754#   Get an input string from the user and return it as $ans. MESSAGE is the
755#   main message printed on screen to prompt the user for an input.  If TYPE is
756#   'YN', print message to prompt user to enter either 'y' or 'n'. If TYPE is
757#   'YNA', then 'a' is given as a third option. If DEFAULT is set, print message
758#   to inform user that the return value will be set to the $def (if nothing is
759#   entered).
760# ------------------------------------------------------------------------------
761
762sub get_input {
763  my %args = @_;
764  my $type  = exists $args{TYPE}    ? $args{TYPE}    : '';
765  my $mesg  = exists $args{MESSAGE} ? $args{MESSAGE} : '';
766  my $def   = exists $args{DEFAULT} ? $args{DEFAULT} : '';
767
768  my $ans;
769
770  while (1) {
771    # Print the prompt
772    print $mesg;
773    print "\n", 'Enter "y" or "n"' if uc ($type) eq 'YN';
774    print "\n", 'Enter "y", "n" or "a"' if uc ($type) eq 'YNA';
775    print ' (or just press <return> for "', $def, '")' if $def;
776    print ': ';
777
778    # Get answer from STDIN
779    $ans = <STDIN>;
780    chomp $ans;
781
782    # Set answer to default, if necessary
783    $ans = $def if ($def and not $ans);
784
785    if ($type =~ /^yna?$/i) {
786      # For YN and YNA type dialog boxes,
787      # check that the answer is in the correct form
788      my $pat = (uc ($type) eq 'YN' ? 'y|n' : 'y|n|a');
789      last if $ans =~ /^(?:$pat)/i;
790
791    } else {
792      last;
793    }
794  }
795
796  return $ans;
797}
798
799# ------------------------------------------------------------------------------
800
801__END__
Note: See TracBrowser for help on using the repository browser.