home *** CD-ROM | disk | FTP | other *** search
/ Nebula 1 / Nebula One.iso / Internet / WWW / Perl_WWW_Utilities / MHonArc / install.me < prev    next >
Encoding:
Text File  |  1996-03-12  |  21.4 KB  |  644 lines
  1. #! /usr/local/bin/perl
  2. ##---------------------------------------------------------------------------##
  3. ##  File:
  4. ##      install.me
  5. ##  Author:
  6. ##      Earl Hood       ehood@convex.com
  7. ##  Description:
  8. ##      Configurable installation program.
  9. ##    Just edit the variables in the CONFIG section for setting defaults
  10. ##    for the particular program.
  11. ##  To Do:
  12. ##    o Add support for manpages to go in different section directories.
  13. ##
  14. ##---------------------------------------------------------------------------##
  15. ##    Copyright (C) 1995        Earl Hood, ehood@convex.com
  16. ##
  17. ##    This program is free software; you can redistribute it and/or modify
  18. ##    it under the terms of the GNU General Public License as published by
  19. ##    the Free Software Foundation; either version 2 of the License, or
  20. ##    (at your option) any later version.
  21. ##
  22. ##    This program is distributed in the hope that it will be useful,
  23. ##    but WITHOUT ANY WARRANTY; without even the implied warranty of
  24. ##    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  25. ##    GNU General Public License for more details.
  26. ##
  27. ##    You should have received a copy of the GNU General Public License
  28. ##    along with this program; if not, write to the Free Software
  29. ##    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  30. ##---------------------------------------------------------------------------##
  31. ###############################################################################
  32. package main;
  33.  
  34. ##  Check what system we are executing under
  35. {
  36.     local($tmp);
  37.     if (($tmp = $ENV{'COMSPEC'}) && ($tmp =~ /[a-zA-Z]:\\/) && (-e $tmp)) {
  38.         $'MSDOS = 1;  $'MACOS = 0;  $'UNIX = 0;
  39.         $'DIRSEP = '\\';  $'CURDIR = '.';
  40.     } elsif (defined($MacPerl'Version)) {
  41.         $'MSDOS = 0;  $'MACOS = 1;  $'UNIX = 0;
  42.         $'DIRSEP = ':';  $'CURDIR = ':';
  43.     } else {
  44.         $'MSDOS = 0;  $'MACOS = 0;  $'UNIX = 1;
  45.         $'DIRSEP = '/';  $'CURDIR = '.';
  46.     }
  47.     ##  Store name of program
  48.     ($tmp = $'DIRSEP) =~ s/(\W)/\\$1/g;
  49.     ($'PROG = $0) =~ s%.*[$tmp]%%o;
  50. }
  51.  
  52. ##---------------------------------------------------------------------------
  53. ##    Begin CONFIG section
  54. ##
  55.  
  56. eval 'umask 022' if $UNIX;    # Set umask
  57.  
  58. ## Set flags
  59. $dobin = 1;    # Set to 1 if exectuables to install
  60. $dolib = 1;    # Set to 1 if libraries to install
  61. $dodoc = 1;    # Set to 1 if documents to install
  62.  
  63. ## Set default values
  64. $bindir  = (!$MSDOS ? '/usr/local/bin' : 'C:\\BIN');
  65. $libdir  = (!$MSDOS ? '/usr/local/lib/MHonArc' : 'C:\\LIB\\MHONARC');
  66. $docdir  = (!$MSDOS ? '/usr/local/lib/MHonArc/doc' : 'C:\\DOC\\MHONARC');
  67. $perlprg = (!$MSDOS ? '/usr/local/bin/perl' : 'C:\\BIN\\PERL.EXE');
  68.  
  69. ## Set files to install
  70. $relbin = '.';       # Location of source bin files relative to install.me
  71. @binfiles = (
  72.     "mhonarc",
  73. );
  74. $rellib = 'lib';    # Location of source lib files relative to install.me
  75. @libfiles = (
  76.     "base64.pl",
  77.     "mhdb.pl",
  78.     "mhexternal.pl",
  79.     "mhtxt2022.pl",
  80.     "mhtxthtml.pl",
  81.     "mhtxtplain.pl",
  82.     "mhtxtsetext.pl",
  83.     "mhutil.pl",
  84.     "osinit.pl",
  85.     "qprint.pl",
  86.     "readmail.pl",
  87. );
  88. $reldoc = 'doc';    # Location of source doc files relative to install.me
  89. @docfiles = (
  90.     "adding.html",
  91.     "contacts.html",
  92.     "details.html",
  93.     "diagnos.html",
  94.     "indexpg.html",
  95.     "install.html",
  96.     "intro.html",
  97.     "message.html",
  98.     "mhonarc.html",
  99.     "mhonarc.txt",
  100.     "mime.html",
  101.     "overview.html",
  102.     "qstart.html",
  103.     "rcfile.html",
  104.     "removing.html",
  105.     "stamp_t.gif",
  106.     "thread.html",
  107. );
  108.  
  109. ## Define intro text
  110. $introText =<<EndofIntro;
  111. MHonArc Installation
  112. ====================
  113. The installation process will ask you a series of questions on where
  114. the Perl executable is and where to put MHonArc files.  Just hit <CR>
  115. to accept the default values listed in ()'s.
  116.  
  117. If directory path does not exist on your system, the installation
  118. program will create the path for you.
  119.  
  120. EndofIntro
  121. ##
  122. ##    End CONFIG section
  123. ##---------------------------------------------------------------------------
  124. ##---------------------------------------------------------------------------
  125. ##    Main routine
  126. ##---------------------------------------------------------------------------
  127. {
  128. { package uio;
  129.     @LastText = ();    ## Cached text
  130.     $use_handler = 1;    ## Flag to use private CONT signal handler
  131.     $ext_sigcont;    ## External CONT handler
  132. }
  133.  
  134. if ($ARGV[0]) {        ## Check for batch mode
  135.     eval qq{require "$ARGV[0]"};
  136.     die "ERROR: Unable to read $ARGV[0]\n"  if $@;
  137.  
  138. } else {        ## Interactive mode
  139.     print STDOUT $introText;
  140.     &print_note("Make sure all pathnames are absolute.");
  141.     &pause();
  142.  
  143.     do {
  144.     ## Get installation directories and path to Perl
  145.     while (1) {
  146.         $tmp = &prompt_user_def("Perl executable", $perlprg, 0, 1);
  147.         last if -x $tmp;
  148.         print STDERR "$tmp not executable\n";
  149.     }
  150.     $perlprg = $tmp;
  151.     if ($dobin) {
  152.         do {
  153.         $tmp = &prompt_user_def("Location to install programs",
  154.                      $bindir, 0, 1);
  155.         } while (!&create_dir($tmp));
  156.         $bindir = $tmp;
  157.     }
  158.     if ($dolib) {
  159.         do {
  160.         $tmp = &prompt_user_def("Location to install libraries",
  161.                     $libdir, 0, 1);
  162.         } while (!&create_dir($tmp));
  163.         $libdir = $tmp;
  164.     }
  165.     if ($dodoc) {
  166.         if (&ask_question("Install documentation", 1)) {
  167.         do {
  168.             $tmp = &prompt_user_def("Location to install docs",
  169.                         $docdir, 0, 1);
  170.         } while (!&create_dir($tmp));
  171.         $docdir = $tmp;
  172.         } else {
  173.         $dodoc = 0;
  174.         }
  175.     }
  176.     print STDOUT "\n",
  177.              "You've specified the following:\n",
  178.              "\tPerl location: $perlprg\n";
  179.     print STDOUT "\tProgram directory: $bindir\n"  if $dobin;
  180.     print STDOUT "\tLibrary directory: $libdir\n"  if $dolib;
  181.     print STDOUT "\tDoc directory: $docdir\n"  if $dodoc;
  182.     } while (!&ask_question("Is this correct", 1));
  183. }
  184.  
  185. ## Install files
  186. $perlprg = "#! $perlprg\n";
  187. $perlprg .= "unshift(\@INC, '$libdir');\n"  if $dolib;
  188.  
  189. if ($dobin && @binfiles) {
  190.     print STDOUT "Installing the following into $bindir\n";
  191.     foreach $file (@binfiles) {
  192.     &cp("$relbin$DIRSEP$file", "$bindir$DIRSEP$file", $perlprg);
  193.     print STDOUT "\t", $file, "\n";
  194.     chmod 0755, "$bindir/$file";
  195.     }
  196. }
  197. if ($dolib && @libfiles) {
  198.     print STDOUT "Installing the following into $libdir\n";
  199.     foreach $file (@libfiles) {
  200.     &cp("$rellib$DIRSEP$file", "$libdir$DIRSEP$file");
  201.     print STDOUT "\t", $file, "\n";
  202.     }
  203. }
  204. if ($dodoc && @docfiles) {
  205.     print STDOUT "Installing the following into $docdir\n";
  206.     foreach $file (@docfiles) {
  207.     &cp("$reldoc$DIRSEP$file", "$docdir$DIRSEP$file");
  208.     print STDOUT "\t", $file, "\n";
  209.     }
  210. }
  211.  
  212. exit 0;
  213. }
  214. ##---------------------------------------------------------------------------
  215. ##    Main subroutines
  216. ##---------------------------------------------------------------------------
  217. sub create_dir {
  218.     local($d) = shift;
  219.     local($tmp);
  220.     ($tmp = $DIRSEP) =~ s/(\W)/\\$1/g;
  221.     local(@a) = grep($_ ne '', split(/$tmp/o, $d));
  222.     local($path, $dir);
  223.  
  224.     if ($MSDOS) {
  225.     if ($d =~ m%^\s*([a-zA-Z]:)?[/\\]%) {
  226.         $path = shift @a;
  227.     } else {
  228.         $path = '.';
  229.     }
  230.     } else {
  231.     if ($d =~ /^\s*\//) {
  232.         $path = '';
  233.     } else {
  234.         $path = '.';
  235.     }
  236.     }
  237.     foreach $dir (@a) {
  238.     if (! -e "$path$DIRSEP$dir") {
  239.         if (!mkdir("$path$DIRSEP$dir", 0777)) {
  240.         print STDERR "Unable to create $path$DIRSEP$dir: $!\n";
  241.         return 0;
  242.         }
  243.     } elsif (! -d "$path$DIRSEP$dir") {
  244.         print STDERR "$dir is not a directory\n";
  245.         return 0;
  246.     }
  247.     $path .= $DIRSEP . $dir;
  248.     }
  249.     if (! -w $d) {
  250.     print STDERR "$d not writable\n";
  251.     return 0;
  252.     }
  253.     1;
  254. }
  255. ##---------------------------------------------------------------------------
  256. sub cp {
  257.     local($src, $dst, $prepend) = @_;
  258.     open(SRC, $src) || die "Unable to open $src: $!\n";
  259.     open(DST, "> $dst") || die "Unable to create $dst: $!\n";
  260.     if (-B $src) { binmode( SRC ); binmode( DST ); }
  261.     if ($prepend) {
  262.     print DST $prepend;
  263.     }
  264.     print DST <SRC>;
  265.     close(SRC);
  266.     close(DST);
  267. }
  268.  
  269.  
  270. ###############################################################################
  271. package uio;
  272.  
  273. ##---------------------------------------------------------------------------##
  274. ##  The following routines are defined in this package.  All routines
  275. ##  work off of STDOUT.
  276. ##    sub main'ask_question        -- ask yes/no question
  277. ##    sub main'do_num_menu        -- autonumber menu items & print
  278. ##    sub main'flush            -- flush filehandle
  279. ##    sub main'get_char_choice    -- get char that is in list
  280. ##    sub main'get_later_date        -- Get date later than some date
  281. ##    sub main'get_lc_string        -- get string converted to lowercase
  282. ##    sub main'get_string        -- get string
  283. ##    sub main'pause            -- pause until <CR> hit
  284. ##    sub main'print_error        -- print error message
  285. ##    sub main'print_info        -- print information message
  286. ##    sub main'print_menu        -- print a menu to screen
  287. ##    sub main'print_note        -- print note message
  288. ##    sub main'print_warning        -- print warning message
  289. ##    sub main'prompt_user        -- prompt user for string
  290. ##    sub main'prompt_user_def    -- prompt_user() with default value
  291. ##
  292. ##  Private routines.
  293. ##    sub handler            -- private SIGCONT handler
  294. ##    sub print_message         -- print typed message to screen
  295. ##    sub print_txt            -- print text and cache it
  296. ##    sub reset_handler        -- unregister handler()
  297. ##    sub set_handler            -- register handler()
  298. ##
  299. ##  Notes:
  300. ##    For the pause() and prompt_user*() routines, a signal handler
  301. ##    is registered to handle the SIGCONT signal.  This enables the
  302. ##    routines to redisplay the prompt after the program has been
  303. ##    suspended and continued while prompting the user for input.
  304. ##    The handler has to redisplay the text, therefore the mentioned
  305. ##    routines use the print_txt() for caching the prompt text.
  306. ##
  307. ##    When the signal handler is registered, any existing handler for
  308. ##    SIGCONT is stored and is called first before redisplaying the
  309. ##    cached text.  Uio's signal handler can be disabled if the
  310. ##    variable $uio'use_handler is set to zero.  By default, the
  311. ##    value is one.  More inforamtion is below in the various
  312. ##    subroutine descriptions.
  313. ##---------------------------------------------------------------------------##
  314.                 ##------------------##
  315.                 ## Global variables ##
  316.                 ##------------------##
  317. ##---------------------------------------------------------------------------
  318. @LastText = ();        ## Cached text
  319. $use_handler = 1;    ## Flag to use private CONT signal handler
  320. $ext_sigcont;        ## External CONT handler
  321. ##---------------------------------------------------------------------------
  322.             ##---------------------------------##
  323.             ## Private subroutine declerations ##
  324.             ##---------------------------------##
  325. ##---------------------------------------------------------------------------
  326. ##    print_txt() prints @_ to STDOUT.  It also makes a copy of @_ to
  327. ##    an array called @LastText.  Any outside package can access it
  328. ##    using uio'LastText.  This is useful for redisplaying text
  329. ##    after the program has been suspended and continued.
  330. ##
  331. sub print_txt {
  332.     print STDOUT @_;  @LastText = @_;
  333. }
  334. ##---------------------------------------------------------------------------
  335. ##    This routine is used by print_{error, info, note, warning}
  336. ##    routines to output an informitive message to STDOUT.
  337. ##
  338. sub print_message {
  339.     local($type, $mesg) = ($_[0], join("", @_[1 .. $#_]));
  340.     local($head) = sprintf("    %9s", "$type  ");
  341.     local($indent) = " " x 13;
  342.     local($i, $dashes, @array);
  343.  
  344.     @array = split(/\n/, $mesg);
  345.     foreach (@array) { $i = length($_)  if length($_) > $i; }
  346.     $dashes = " " x 4 . "-" x ($i+10);
  347.     $mesg = join("\n", @array);
  348.     $* = 1;
  349.     $mesg =~ s/\n/\n$indent/g;
  350.     $mesg = $head . $mesg;
  351.     print STDOUT "$dashes\n", "$mesg\n", "$dashes\n";
  352.     $* = 0;
  353. }
  354. ##---------------------------------------------------------------------------
  355. ##    handler() is the private signal handler for the uio package.
  356. ##    It's used to when SIGCONT is caught for redisplay cached text.
  357. ##    The external handler is called if defined.
  358. ##
  359. sub handler {
  360.     if ($ext_sigcont ne 'IGNORE' && $ext_sigcont ne 'DEFAULT' &&
  361.     $ext_sigcont ne "") { &$ext_sigcont(@_); }
  362.     print STDOUT @LastText;
  363.     &'flush(STDOUT);
  364.     push(@Redo, 1);
  365. }
  366. ##---------------------------------------------------------------------------
  367. ##    set_handler() sets the private CONT signal handler.
  368. ##
  369. sub set_handler {
  370.     return unless $use_handler;
  371.     $ext_sigcont = $SIG{'CONT'};
  372.     $SIG{'CONT'} = "uio'handler";
  373. }
  374. ##---------------------------------------------------------------------------
  375. ##    reset_handler() restores the external handler
  376. ##
  377. sub reset_handler {
  378.     return unless $use_handler;
  379.     $SIG{'CONT'} = $ext_sigcont;
  380. }
  381. ##---------------------------------------------------------------------------
  382.             ##--------------------------------##
  383.             ## Public subroutine declerations ##
  384.             ##--------------------------------##
  385. ##---------------------------------------------------------------------------
  386. ##    print_menu() a tabular list of items in a "menu" type format.  The
  387. ##    list is printed in column major order.
  388. ##    Parameters:
  389. ##        $title    : The title of the menu if not null.
  390. ##        $cols    : Number of columns in menu.
  391. ##        $box    : Boolean flag for drawing a box around menu.
  392. ##        $sep    : Separator string between columns.
  393. ##        @menu_items    : Array of menu items.
  394. ##    In box mode the title appears above the box.  Care must be taken
  395. ##    in the number of columns chosen when menu items string lengths get
  396. ##    long.  This routine assumes there is plenty of screen space to
  397. ##    print out the menu.
  398. ##
  399. sub main'print_menu {
  400.     local($title, $cols, $box, $sep, @menu_items) = @_;
  401.     local($i, $j, $indent, $sp, $fmt, $lside, $rside);
  402.  
  403.     $sp = " ";  $indent = $sp x 8;
  404.     foreach (@menu_items) { $i = length($_)  if length($_) > $i; }
  405.     $fmt = "%-${i}s";
  406.     $dashes = "-" x (($cols-1)*length($sep) + $cols*$i + 2);
  407.     $lines = ($#menu_items+1)/$cols;
  408.     $lines = ($lines == int($lines) ? $lines : int($lines)+1);
  409.     print STDOUT "$indent$title\n"  if $title ne "";    ## Print $title
  410.     print STDOUT "$indent $dashes\n"  if $box;        ## Print top of box
  411.     $lside = ($box ? "| " : "  ");
  412.     $rside = ($box ? " |\n" : "  \n");
  413.     for ($i=0; $i < $lines; $i++) {
  414.     print STDOUT $indent, $lside;
  415.     for ($j=0; $j < $cols; $j++) {
  416.         print STDOUT sprintf($fmt, $menu_items[$i + $j*$lines]);
  417.         print STDOUT $sep  if $j < $cols-1;
  418.     }
  419.     print STDOUT $rside;
  420.     }
  421.     print STDOUT "$indent $dashes\n" if $box;
  422. }
  423. ##---------------------------------------------------------------------------
  424. ##    do_num_menu() automatically generates a numbered list of items
  425. ##    for selection.  The routine returns the string item that is
  426. ##    selected.  This routine also appends a "Other" option and
  427. ##    if selected, will prompt for a user defined string.
  428. ##
  429. sub main'do_num_menu {
  430.     local($title, $prompt, $isother, $otherprompt, $otherdef, $cols,
  431.       @array) = @_;
  432.     local(@menu_items) = @array;
  433.     local($i, $tmp);
  434.  
  435.     ## Prepend numbers to items ##
  436.     for ($i=0; $i <= $#menu_items; $i++) {
  437.         $menu_items[$i] = $i+1 . " = \"$menu_items[$i]\"";
  438.     }
  439.     ## Add other selection if needed ##
  440.     push(@menu_items, $i+1 . " = Other")  if $isother;
  441.     ## Print menu ##
  442.     print STDOUT "\n$title:\n\n";
  443.     &'print_menu("", $cols, 0, " " x 5, @menu_items);
  444.     ## Get selection ##
  445.     while (1) {
  446.     $tmp = &'prompt_user_def("\n$prompt", "1", 0, 0);
  447.     last  if ($tmp >= 1 && $tmp <= $#menu_items+1);
  448.     &'print_error("Invalid selection -- $tmp");
  449.     }
  450.     ## Determine selection ##
  451.     if ($isother && $tmp == $#menu_items+1) {
  452.         $tmp = &'prompt_user_def("  Other: $otherprompt", $otherdef, 1, 0);
  453.     }
  454.     else { $tmp = $array[$tmp-1]; }
  455.     $tmp;
  456. }
  457. ##---------------------------------------------------------------------------
  458. ##     print_*() routines to print a message of type '*' to the screen.
  459. ##
  460. sub main'print_error { &print_message("ERROR", @_); }
  461. sub main'print_info { &print_message("Info:", @_); }
  462. sub main'print_note { &print_message("Note:", @_); }
  463. sub main'print_warning { &print_message("WARNING", @_); }
  464. ##---------------------------------------------------------------------------
  465. ##    Get string from STDIN and lowercase it.
  466. ##    called "get_lc_string".
  467. ##
  468. sub main'get_lc_string {
  469.     local($tmp);
  470.     $tmp = <STDIN>;
  471.     while (shift(@Redo)) { $tmp = <STDIN>; }
  472.     chop $tmp;
  473.     $tmp =~ tr/A-Z/a-z/;
  474.     $tmp;
  475. }
  476. ##---------------------------------------------------------------------------
  477. ##    Get string from STDIN.
  478. ##
  479. sub main'get_string {
  480.     local($tmp);
  481.     $tmp = <STDIN>;
  482.     while (shift(@Redo)) { $tmp = <STDIN>; }
  483.     chop $tmp;
  484.     $tmp;
  485. }
  486. ##---------------------------------------------------------------------------
  487. ##    Pause output until CR is hit.
  488. ##
  489. sub main'pause {
  490.     &set_handler();
  491.     local($tmp);
  492.     &print_txt("\nHit <CR> to continue ... ");
  493.     $tmp = <STDIN>;
  494.     while (shift(@Redo)) { $tmp = <STDIN>; }
  495.     &reset_handler();
  496. }
  497. ##---------------------------------------------------------------------------
  498. ##    Prompt user for a string of input.  This routine appends a "->"
  499. ##    to the prompt string.  All leading and trailing whitespaces are
  500. ##    removed from the input string before returned.
  501. ##
  502. sub main'prompt_user {
  503.     &set_handler();
  504.     local($prompt, $nonnull, $return) = @_;
  505.     local($tmp);
  506.     $prompt .= "\n" if $return;
  507.     $prompt .= " -> ";
  508.     while (1) {
  509.     &print_txt($prompt);
  510.     $tmp = &'get_string();
  511.     &'print_error("Entry cannot be blank."), next
  512.         if $nonnull && $tmp =~ /^\s*$/;
  513.     $tmp =~ s/^\s*(.*[^\s])\s*$/\1/;  ## strip beginning/trailing spaces
  514.     last;
  515.     }
  516.     &reset_handler();
  517.     $tmp;
  518. }
  519. ##---------------------------------------------------------------------------
  520. ##    Like prompt_user() but a default choice is given.
  521. ##
  522. sub main'prompt_user_def {
  523.     &set_handler();
  524.     local($prompt, $default, $nonnull, $return) = @_;
  525.     local($tmp);
  526.     $prompt .= " (\"$default\")";
  527.     $prompt .= "\n" if $return;
  528.     $prompt .= " -> ";
  529.     while(1) {
  530.     &print_txt($prompt);
  531.     $tmp = &'get_string();
  532.     $tmp = $default  if $tmp =~ m/^\s*$/;
  533.     &'print_error("Entry cannot be blank."), next
  534.         if $nonnull && $tmp =~ /^\s*$/;
  535.     $tmp =~ s/^\s*(.*[^\s])\s*$/\1/;
  536.     last;
  537.     }
  538.     &reset_handler();
  539.     $tmp;
  540. }
  541. ##---------------------------------------------------------------------------
  542. ##    ask_question() asks a yes/no question.  $default signifies the
  543. ##    default response: 1 = yes, 0 = no.  The default response and
  544. ##    a '?' are appended to the prompt.
  545. ##
  546. sub main'ask_question {
  547.     &set_handler();
  548.     local($prompt, $default) = @_;
  549.     local($tmp, $ret);
  550.     if ($default) { $prompt .= " (\"y\")"; }
  551.     else { $prompt .= " (\"n\")"; };
  552.     while(1) {
  553.     &print_txt("$prompt?  ");
  554.     $tmp = &'get_lc_string();
  555.     $ret = 1, last  if ($tmp =~ /^\s*$/ && $default);
  556.     $ret = 0, last  if ($tmp =~ /^\s*$/ && !$default);
  557.     $ret = 1, last  if ($tmp =~ /^\s*y\s*$/ || $tmp =~ /^\s*yes*\s*$/);
  558.     $ret = 0, last  if ($tmp =~ /^\s*n\s*$/ || $tmp =~ /^\s*no*\s*$/);
  559.     }
  560.     &reset_handler();
  561.     $ret;
  562. }
  563. ##---------------------------------------------------------------------------
  564. ##    get_char_choice() gets a single character response.  Valid
  565. ##    character responses are specified by @chars.  A default can
  566. ##    be specified by $default, and it is the choice if CR is hit.
  567. ##    All whitespaces (except \r and \n) and non-specified chars
  568. ##    are ignored.  This function returns with choice when a valid
  569. ##    character is hit.  Character choices are case-insensitive.
  570. ##
  571. ##    The terminal is put into raw mode for get_char_choice() to
  572. ##    perform its task.  Because of this, SIGINT, SIGQUIT, and
  573. ##    SIGTERM are temporarily ignored until a valid character is
  574. ##    hit.  The original signal handlers are restored before the
  575. ##    functions returns.
  576. ##
  577. sub main'get_char_choice {
  578.     local($default, @chars) = @_;
  579.     local($in, $return);
  580.     local($choices) = join(" ", @chars);
  581.     $choices =~ tr/A-Z/a-z/;
  582.     local($sigint, $sigquit, $sigterm, $sigtstp) =
  583.     ($SIG{'INT'}, $SIG{'QUIT'}, $SIG{'TERM'}, $SIG{'TSTP'});
  584.  
  585.     &'flush(STDOUT);
  586.     $SIG{'INT'} = 'IGNORE'; $SIG{'QUIT'} = 'IGNORE'; $SIG{'TERM'} = 'IGNORE';
  587.     $SIG{'TSTP'} = 'IGNORE';
  588.     system("stty raw -echo");    ## Set terminal in raw mode
  589.     while (1) {
  590.         $in = getc(STDIN);
  591.         $return = $default, last if $default ne "" &&
  592.                     ($in eq "\r" || $in eq "\n");
  593.     next if $in =~ /\s/;
  594.         $in =~ tr/A-Z/a-z/;
  595.     $in =~ s/([\[\]\(\)\.\^\{\}\$\*\?\+\\\|])/\\\1/g;
  596.         $return = $in, last if $choices =~ /$in/;
  597.     }
  598.     system("stty -raw echo");    ## Restore terminal
  599.     print STDOUT "$return\n";    ## Output selection
  600.     $SIG{'INT'} = $sigint;    ## Restore signal handler
  601.     $SIG{'QUIT'} = $sigquit;    ## Restore signal handler
  602.     $SIG{'TERM'} = $sigterm;    ## Restore signal handler
  603.     $SIG{'TSTP'} = $sigtstp;    ## Restore signal handler
  604.     $return;
  605. }
  606. ##---------------------------------------------------------------------------
  607. ##    flush() flushes the buffer of passed in filehandle.  Copied from
  608. ##    "flush.pl".
  609. ##
  610. sub main'flush {
  611.     local($old) = select(shift);
  612.     $| = 1;
  613.     print "";
  614.     $| = 0;
  615.     select($old);
  616. }
  617. ##---------------------------------------------------------------------------
  618. ##    get_later_date() retrieves from STDIN a date later than the
  619. ##    julian date $ljdate.  $prompt is the user prompt and $default
  620. ##    is the default response.  This routine uses the julian date
  621. ##    routines defined in "date.pl".  "date.pl" must be required
  622. ##    somewhere in the Perl program for this routine to work.
  623. ##
  624. sub main'get_later_date {
  625.     local($prompt, $default, $ljdate) = @_;
  626.     local($tmp, $i, $m, $d, $y, $wd);
  627.     while (1) {
  628.     $tmp = &'prompt_user_def($prompt, $default, 1, 0);
  629.     if ($tmp !~ m!^(\d{1,2})[-/](\d{1,2})[-/](\d{2}|\d{4})$!) {
  630.         &'print_error("Incorrect date specification -- $tmp\n",
  631.             "Valid date formats: 02-28-94, 4/1/94, 12-25-1994.");
  632.     }
  633.     else {
  634.         $i = &'jday($1, $2, ($3 > 1900 ? $3 : "19".$3));
  635.         last  if $i > $ljdate;
  636.         ($m, $d, $y, $wd) = &'jdate($ljdate);
  637.         &'print_error("Date must be later than $m/$d/$y.");
  638.     }
  639.     }
  640.     $tmp;
  641. }
  642. ##---------------------------------------------------------------------------
  643. 1;  ## end package
  644.