home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / perl / scripts-osu / forms-1.0.shar.2 < prev    next >
Encoding:
Text File  |  1992-04-13  |  30.9 KB  |  1,074 lines
  1. Newsgroups: comp.lang.perl
  2. Path: cis.ohio-state.edu!zaphod.mps.ohio-state.edu!qt.cs.utexas.edu!cs.utexas.edu!uunet!snorkelwacker.mit.edu!bloom-picayune.mit.edu!math.mit.edu!drw
  3. From: drw@kronecker.mit.edu (Dale R. Worley)
  4. Subject: Forms-oriented input system, code
  5. Message-ID: <DRW.92Apr14115514@kronecker.mit.edu>
  6. Sender: news@athena.mit.edu (News system)
  7. Nntp-Posting-Host: kronecker.mit.edu
  8. Organization: MIT Dept. of Tetrapilotomy, Cambridge, MA, USA
  9. Date: Tue, 14 Apr 1992 16:55:14 GMT
  10. Lines: 1061
  11.  
  12. # Perl forms system, version 1.0.
  13.  
  14. # Written by Dale R. Worley (drw@math.mit.edu).
  15.  
  16. # WARRANTY DISCLAIMER
  17.  
  18. # This software was created by Dale R. Worley and is
  19. # distributed free of charge.  It is placed in the public domain and
  20. # permission is granted to anyone to use, duplicate, modify and redistribute
  21. # it provided that this notice is attached.
  22.  
  23. # Dale R. Worley provides absolutely NO WARRANTY OF ANY KIND
  24. # with respect to this software.  The entire risk as to the quality and
  25. # performance of this software is with the user.  IN NO EVENT WILL DALE
  26. # R. WORLEY BE LIABLE TO ANYONE FOR ANY DAMAGES ARISING OUT THE
  27. # USE OF THIS SOFTWARE, INCLUDING, WITHOUT LIMITATION, DAMAGES RESULTING FROM
  28. # LOST DATA OR LOST PROFITS, OR FOR ANY SPECIAL, INCIDENTAL OR CONSEQUENTIAL
  29. # DAMAGES.
  30.  
  31. package forms;
  32.  
  33. # The pattern to match field and attribute names
  34. # Must match Perl qualified names, at least, and not match whitespace
  35. $name_pat = '[^.=:\s]+';
  36.  
  37. # $debug Controls debugging:
  38. #    1    print field values as installed by process_representation
  39. #    2    print subroutine definitions that are evalled by 
  40. #        process_representation
  41.  
  42. # The sequence number of generated names
  43. $generated_name_seq = 0;
  44.  
  45. sub generate_name {
  46.     "forms_generated_" . $generated_name_seq++;
  47. }
  48.  
  49. sub process_representation {
  50.     local(*form, @input) = @_;
  51.     local(@fields, $i);
  52.  
  53.     # Clear the form array
  54.     %form = ();
  55.     # Process the input
  56.     for ($i = 0; $i <= $#input; $i++) {
  57.     $_ = $input[$i];
  58.     # Trim leading and trailing whitespace
  59.     s/^\s+//;
  60.     s/\s+$//;
  61.     if (/^$/ || /^#/) {
  62.         # Ignore comment lines
  63.     } elsif (/^($name_pat)\s*:$/o) {
  64.         # This is a "field:" line, setting the default field name
  65.         $default_field = $1;
  66.     } elsif (/^:$/) {
  67.         # This is a ":" line, setting the default to a constructed
  68.         # field name.
  69.         $default_field = &generate_name;
  70.     } elsif (/^($name_pat)\s*\.\s*($name_pat)\s*=\s*(.*)$/o) {
  71.         # This is an attribute setting line
  72.         &set_attribute($1, $2, $3) || return undef;
  73.     } elsif (/^\.\s*($name_pat)\s*=\s*(.*)$/o) {
  74.         # This is an attribute setting line for the form as a whole
  75.         &set_attribute('', $1, $2) || return undef;
  76.     } elsif (/^($name_pat)\s*=\s*(.*)$/o) {
  77.         # This is an attribute setting line for the default field
  78.         &set_attribute($default_field, $1, $2) || return undef;
  79.     } elsif (/^sub\s+($name_pat)\s+{$/) {
  80.         # This is a subroutine definition
  81.         &define_subroutine || return undef;
  82.     } elsif (/^\*(.*)$/) {
  83.         # This is an expression to be evaluated
  84.         print STDERR "Evalling: *$1\n" if $debug & 2;
  85.         {
  86.         package forms_user;
  87.         eval($1);
  88.         }
  89.         if ($@) {
  90.         # Error during eval
  91.         $error = "Error in freestanding expression at line $i: $@";
  92.         return undef;
  93.         }
  94.     } else {
  95.         # Invalid format
  96.         $error = "Invalid format at line $i: $_";
  97.         return undef;
  98.     }
  99.     }
  100.     # Perform the post-processing
  101.     # Set attribute initially_invisible from attribute invisible
  102.     grep(($form{$_, 'initially_invisible'} = $form{$_, 'invisible'}, 0),
  103.      @fields);
  104.     # Set the fields global attribute
  105.     $form{'', 'fields'} = join(',', @fields);
  106.     # Return success
  107.     1;
  108. }
  109.  
  110. sub set_attribute {
  111.     local($field, $attribute, $value) = @_;
  112.  
  113.     if ($value =~ /^&($name_pat)$/o) {
  114.     # It is "&function"; transform it into symbol table pointer
  115.         print STDERR "Evalling: *$1\n" if $debug & 2;
  116.     {
  117.         package forms_user;
  118.         $forms'value = eval("*$1");
  119.         }
  120.     if ($@) {
  121.         # Error during eval
  122.         $error = "Error in function name at line $i: $@";
  123.         return undef;
  124.         }
  125.     } elsif ($value =~ /^@($name_pat)$/o) {
  126.     # It is "@function"; transform it into symbol table pointer
  127.         print STDERR "Evalling: *$1\n" if $debug & 2;
  128.     $value = eval("*$1");
  129.     if ($@) {
  130.         # Error during eval
  131.         $error = "Error in function name at line $i: $@";
  132.         return undef;
  133.         }
  134.     } elsif ($value =~ /^"(.*)"$/) {
  135.     # It is a quoted string.  Extract the contents.
  136.     $value =  $1;
  137.     } elsif ($value eq '{') {
  138.     # It is "{"; read and define the subroutine
  139.     $name = &generate_name;
  140.     $value = "sub $name {\n";
  141.     # Get further input lines until end is seen
  142.     for ($i++; $i <= $#input; $i++) {
  143.         $_ = $input[$i];
  144.         s/\n//;
  145.         last if /^\s*};\s*$/;
  146.         $value .= $_ . "\n";
  147.         }
  148.     $value .= "}\n*$name";
  149.         print STDERR "Defining subroutine:\n", $value if $debug & 2;
  150.     {
  151.         package forms_user;
  152.         $forms'value = eval($forms'value);
  153.     }
  154.     if ($@) {
  155.         # Error during eval
  156.         $error = "Error in subroutine definition at line $i: $@";
  157.         return undef;
  158.         }
  159.     } elsif ($value =~ /^\*(.*)$/) {
  160.     # It is "*expression"; evaluate it
  161.         print STDERR "Evalling: *$1\n" if $debug & 2;
  162.     {
  163.         package forms_user;
  164.         $forms'value = eval($1);
  165.     }
  166.     if ($@) {
  167.         # Error during eval
  168.         $error = "Error in expression at line $i: $@";
  169.         return undef;
  170.         }
  171.     } else {
  172.     # The value is to be taken literally
  173.     }
  174.     print STDERR "\$form{$field, $attribute} = ", $value, "\n" if $debug & 1;
  175.     $form{$field, $attribute} = $value;
  176.     # Add the field to the @forms array, if it is not already there
  177.     push(@fields, $field) unless grep($_ eq $field, @fields);
  178.     # Return success
  179.     1;
  180. }
  181.  
  182. sub define_subroutine {
  183.     $value = $_ . "\n";
  184.     # Get further input lines until end is seen
  185.     for ($i++; $i <= $#input; $i++) {
  186.     $_ = $input[$i];
  187.     s/\n//;
  188.     last if /^\s*};\s*$/;
  189.     $value .= $_ . "\n";
  190.     }
  191.     $value .= "}\n";
  192.     print STDERR "Defining subroutine:\n", $value if $debug & 2;
  193.     {
  194.     package forms_user;
  195.     $forms'value = eval($forms'value);
  196.     }
  197.     if ($@) {
  198.     # Error during eval
  199.     $error = "Error in subroutine definition at line $i: $@";
  200.     return undef;
  201.     }
  202.     1;
  203. }
  204.  
  205. sub dump_form {
  206.     local(*form, $filehandle) = @_;
  207.     local($field, $attr);
  208.  
  209.     $filehandle = 'STDOUT' unless $filehandle;
  210.     foreach (sort keys %form) {
  211.     ($field, $attr) = /^(.*)$;(.*)$/o;
  212.     print $filehandle "$field.$attr = ", $form{$field, $attr}, "\n";
  213.     }
  214.     1;
  215. }
  216.  
  217. sub clear_values {
  218.     local(*form) = @_;
  219.  
  220.     foreach (split(',', $form{'', 'fields'})) {
  221.     $form{$_, 'value'} = undef;
  222.     }
  223. }
  224.  
  225. sub clear_values_and_redisplay {
  226.     foreach (split(',', $form{'', 'fields'})) {
  227.     $form{$_, 'value'} = undef;
  228.     &changed_value($_);
  229.     }
  230. }
  231.  
  232. sub reset_visibility {
  233.     local(*form) = @_;
  234.  
  235.     foreach (split(',', $form{'', 'fields'})) {
  236.     $form{$_, 'invisible'} = $form{$_, 'initially_invisible'};
  237.     }
  238. }
  239.  
  240. sub process_form {
  241.     local(*form) = @_;
  242.     local($exit_value, @fields, $x, $cursor_location, $y, $entered_field,
  243.     $current_field_no, $last_c);
  244.  
  245.     # Check that it's not empty
  246.     die "Empty form" unless $form{'', 'fields'};
  247.  
  248.     # Call initialize, if necessary
  249.     $y = $form{'', 'initialize'};
  250.     if ($y) {
  251.     local(*x) = $y;
  252.     &undefined_function('', 'initialize') unless defined(&x);
  253.     &x;
  254.     }        
  255.     # Construct displayed fields
  256.     @fields = split(',', $form{'', 'fields'});
  257.     foreach (@fields) {
  258.     if ($form{$_, 'field_length'}) {
  259.         $y = $form{$_, 'construct_displayed_value'};
  260.         local(*x) = $y;
  261.         &undefined_function($_, 'construct_displayed_value')
  262.         unless defined(&x);
  263.         $form{$_, 'displayed_value'} = &x($_, $form{$_, 'value'});
  264.         $y = $form{$_, 'initialize_displayed_field'};
  265.         local(*x) = $y;
  266.         &undefined_function($_, 'initialize_displayed_field')
  267.         unless defined(&x);
  268.         $form{$_, 'displayed_field'} =
  269.         &x($_, $form{$_, 'displayed_value'});
  270.     }
  271.     }
  272.     # Initialize screen
  273.     &'initscr;
  274.     &'leaveok($'stdscr, 0);
  275.     &'standend;
  276.     # Set terminal in the mode we like
  277.     &'nocbreak;
  278.     &'raw;
  279.     &'nonl;
  280.     &'noecho;
  281.     # Get the F keys loaded
  282.     &load_function_keys unless $function_keys_loaded;
  283.     # Redisplay screen
  284.     &'clear;
  285.     foreach (@fields) {
  286.     if (!$form{$_, 'invisible'}) {
  287.         # Write the label of the field, if there is one
  288.         if ($form{$_, 'label_text'}) {
  289.         local($r, $c) = split(',', $form{$_, 'label_location'});
  290.         &'move($r, $c);
  291.         &'addstr($form{$_, 'label_text'});
  292.     }
  293.         # Write the contents of the field, if there is one
  294.         if ($form{$_, 'field_length'}) {
  295.         local($r, $c) = split(',', $form{$_, 'field_location'});
  296.         &'move($r, $c);
  297.         &'standout;
  298.         &'addstr($form{$_, 'displayed_field'});
  299.         &'standend;
  300.         }
  301.     }
  302.     }
  303.     # Set cursor on first field
  304.     $entered_field = undef;
  305.     $current_field_no = $[ - 1;
  306.     &next_field;
  307.     # Set cursor location
  308.     if ($current_field_no >= $[) {
  309.     # Get $cursor_location
  310.     $_ = $fields[$current_field_no];
  311.     $y = $form{$_, 'initialize_displayed_field'};
  312.     local(*x) = $y;
  313.     &undefined_function($_, 'initialize_displayed_field')
  314.         unless defined(&x);
  315.     &x($_, $form{$_, 'displayed_value'});
  316.     local($r, $c) = split(',', $form{$_, 'field_location'});
  317.         &'move($r, $c + $cursor_location);
  318.     } else {
  319.     # No writable fields; put cursor in UL corner
  320.         &'move(0, 0);
  321.     }
  322.     # Loop waiting for a character
  323.     INPUT_LOOP: while (1) {
  324.     # Refresh the screen
  325.     &'refresh;
  326.     # Get a character
  327.     $c = &'getch;
  328.     # If it is ESC, get the whole escape sequence
  329.     if ($c eq "\e") {
  330.         local($d) = '0';
  331.         while ((length($c) < 6 && $d gt ' ' && $d lt '@') || 
  332.            (length($c) == 2 && ($d eq 'O' || $d eq '['))) {
  333.         $d = &'getch;
  334.         $c .= $d;
  335.         }
  336.         # Check if it is valid
  337.         $c = $function_key{$c};
  338.         if (!($c &&
  339.           ($form{'', $c} || ($current_field_no >= $[ &&
  340.                     $form{$fields[$current_field_no], $c})))) {
  341.         &report_error("Invalid escape sequence");
  342.             next INPUT_LOOP;
  343.         }
  344.     }
  345.     # Process it
  346.     # Exit or enter the field as appropriate
  347.     if ($c eq "\n" || $c eq "\r" || $c eq "\t" ||
  348.         (length($c) > 1 &&
  349.          !$form{$fields[$current_field_no], $c})) {
  350.         # LFD, RET, TAB, and function keys that are not local to
  351.         # the field exit the field first
  352.         next INPUT_LOOP if $entered_field && !&exit_field;
  353.     } elsif ($c eq "\031" || $c eq "\026") {
  354.         # C-y and C-v require to be in field
  355.          if (!$entered_field) {
  356.             &report_error("Must have entered field");
  357.         next INPUT_LOOP;
  358.         }
  359.     } elsif ($c eq "\f" || $c eq "\020" || $c eq "\003" || $c eq "\007" ||
  360.          $c eq "\e") {
  361.         # C-l, C-p, C-c, C-g, and ESC have no constraint
  362.     } else {
  363.         # All others enter the field first
  364.          &enter_field if !$entered_field;
  365.     }
  366.     # Process the character
  367.     if ($c eq "\n") {
  368.         # LFD - accept contents of form
  369.         # Call finalize, if necessary
  370.         $y = $form{'', 'finalize'};
  371.         if ($y) {
  372.         local(*x) = $y;
  373.         &undefined_function('', 'finalize') unless defined(&x);
  374.             # If finalize fails, it should have produced a message
  375.             next INPUT_LOOP if !&x;
  376.         }
  377.         # Exit successfully
  378.         $exit_value = 1;
  379.         last INPUT_LOOP;
  380.     } elsif ($c eq "\003" || $c eq "\007") {
  381.         # C-c, C-g - abort the form
  382.         if ($entered_field) {
  383.         $entered_field = undef;
  384.         $form{$entered_field, 'value'} = $previous_value;
  385.         $form{$entered_field, 'displayed_value'} = 
  386.             $previous_displayed_value;
  387.         $form{$entered_field, 'displayed_field'} =
  388.             $previous_displayed_field;
  389.         $cursor_location= $previous_cursor_location;
  390.         # Redisplay the field
  391.         local($r, $c) =
  392.             split(',', $form{$entered_field, 'field_location'});
  393.         &'move($r, $c);
  394.         &'standout;
  395.         &'addstr($form{$entered_field, 'displayed_field'});
  396.         &'standend;
  397.         &'move($r, $c + $cursor_location);
  398.         }
  399.         $exit_value = 0;
  400.         last INPUT_LOOP;
  401.     } elsif ($c eq "\r") {
  402.         # RET - go to next field
  403.         &next_field;
  404.         # Set cursor location
  405.         if ($current_field_no >= $[) {
  406.         # Get $cursor_location
  407.         $_ = $fields[$current_field_no];
  408.         $y = $form{$_, 'initialize_displayed_field'};
  409.         local(*x) = $y;
  410.         &undefined_function($_, 'initialize_displayed_field')
  411.             unless defined(&x);
  412.         &x($_, $form{$_, 'displayed_value'});
  413.         local($r, $c) = split(',', $form{$_, 'field_location'});
  414.         &'move($r, $c + $cursor_location);
  415.         } else {
  416.         # No writable fields; put cursor in UL corner
  417.         &'move(0, 0);
  418.         }
  419.     } elsif ($c eq "\t") {
  420.         # TAB - go to previous field
  421.         &previous_field;
  422.         # Set cursor location
  423.         if ($current_field_no >= $[) {
  424.         # Get $cursor_location
  425.         $_ = $fields[$current_field_no];
  426.         $y = $form{$_, 'initialize_displayed_field'};
  427.         local(*x) = $y;
  428.         &undefined_function($_, 'initialize_displayed_field')
  429.             unless defined(&x);
  430.         &x($_, $form{$_, 'displayed_value'});
  431.         local($r, $c) = split(',', $form{$_, 'field_location'});
  432.         &'move($r, $c + $cursor_location);
  433.         } else {
  434.         # No writable fields; put cursor in UL corner
  435.         &'move(0, 0);
  436.         }
  437.     } elsif ($c eq "\031") {
  438.         # C-y - restore previous value of the field and exit from field
  439.         $form{$entered_field, 'value'} = $previous_value;
  440.         $form{$entered_field, 'displayed_value'} = 
  441.         $previous_displayed_value;
  442.         $form{$entered_field, 'displayed_field'} =
  443.         $previous_displayed_field;
  444.         $cursor_location= $previous_cursor_location;
  445.         # Redisplay the field
  446.         local($r, $c) =
  447.         split(',', $form{$entered_field, 'field_location'});
  448.         &'move($r, $c);
  449.         &'standout;
  450.         &'addstr($form{$entered_field, 'displayed_field'});
  451.         &'standend;
  452.             &'move($r, $c + $cursor_location);
  453.         # Only once we're done with all this, forget the field
  454.         $entered_field = undef;
  455.     } elsif ($c eq "\026") {
  456.         if ($last_c eq "\026") {
  457.         # C-v C-v - exit valid field
  458.         &exit_field;
  459.         } else {
  460.             # C-v - perform validity check on field or exit field
  461.         $y = $form{$entered_field, 'validate_displayed_value'};
  462.         local(*x) = $y;
  463.         &undefined_function($entered_field, 'validate_displayed_value')
  464.             unless defined(&x);
  465.         if (&x($entered_field,
  466.             $form{$entered_field, 'displayed_value'})) {
  467.             &report_message("Field OK");
  468.         } else {
  469.             # validate_displayed_value routine should produce error
  470.             # message
  471.             # Do not give C-v C-v effect if he types C-v again.
  472.             $c = "\e";
  473.         }
  474.         }
  475.     } elsif ($c eq "\f") {
  476.         # C-l - redraw screen
  477.         &'clearok($'stdscr, 1);
  478.     } elsif ($c eq "\020") {
  479.         # C-p - give help
  480.         local($message);
  481.         if ($current_field_no >= $[ &&
  482.         ($message = 
  483.             $form{$fields[$current_field_no], 'help_message'}) &&
  484.         $last_c ne "\020" &&
  485.         $form{'MSG', 'field_length'}) {
  486.         # There is a current field, it has a help message, user
  487.         # has not typed C-p twice in a row, and there is a MSG
  488.         # field, so display field help message
  489.         &report_message($message);
  490.         } else {
  491.         # Display help screen
  492.         &display_help_screen;
  493.         # If he types C-p after this, he gets field help again.
  494.         $c = "\e";
  495.         }
  496.     } elsif ($c eq "\e") {
  497.         # ESC - invalid escape sequence
  498.     } elsif (length($c) > 1) {
  499.         # function key - do the appropriate function
  500.         $y = $form{$entered_field || '', $c};
  501.         local(*x) = $y;
  502.         &undefined_function($entered_field, $c) unless defined(&x);
  503.         &x;
  504.     } elsif (($c ge "\001" && $c lt " ") || $c gt "~") {
  505.         # Other control character
  506.         $y = $form{$_, 'edit'};
  507.         local(*x) = $y;
  508.         &undefined_function($_, 'edit') unless defined(&x);
  509.         &x($entered_field, $c);
  510.         # Redisplay the field
  511.         local($r, $c) =
  512.         split(',', $form{$entered_field, 'field_location'});
  513.         &'move($r, $c);
  514.         &'standout;
  515.         &'addstr($form{$entered_field, 'displayed_field'});
  516.         &'standend;
  517.             &'move($r, $c + $cursor_location);
  518.         } else {
  519.         # It is a printing character
  520.         $y = $form{$_, 'insert'};
  521.         local(*x) = $y;
  522.         &undefined_function($_, 'insert') unless defined(&x);
  523.         &x($entered_field, $c);
  524.         # Redisplay the field
  525.         local($r, $c) =
  526.         split(',', $form{$entered_field, 'field_location'});
  527.         &'move($r, $c);
  528.         &'standout;
  529.         &'addstr($form{$entered_field, 'displayed_field'});
  530.         &'standend;
  531.             &'move($r, $c + $cursor_location);
  532.         }
  533.     } continue {
  534.     # Record the last key
  535.     $last_c = $c;
  536.     }
  537.     # Delete the help screen window if necessary
  538.     if ($help_screen_window) {
  539.     &'delwin($help_screen_window);
  540.     $help_screen_window = undef;
  541.     }
  542.     # Move cursor to LL corner
  543.     &'move($'LINES-1, 0);
  544.     &'refresh;
  545.     &'endwin;
  546.     $exit_value;
  547. }
  548.  
  549. # Find next field that is visible, has a data area, and is writable.
  550. sub next_field {
  551.     local($old_field_no) = $current_field_no;
  552.  
  553.     # Look for a field after the current field
  554.     for ($current_field_no++; $current_field_no <= $#fields;
  555.      $current_field_no++) {
  556.     $_ = $fields[$current_field_no];
  557.     return if !$form{$_, 'invisible'} &&
  558.               $form{$_, 'field_length'} &&
  559.           !$form{$_, 'read_only'};
  560.     }
  561.     # Look for a field before the current field
  562.     for ($current_field_no = $[; $current_field_no <= $old_field_no;
  563.      $current_field_no++) {
  564.     $_ = $fields[$current_field_no];
  565.     return if !$form{$_, 'invisible'} &&
  566.               $form{$_, 'field_length'} &&
  567.           !$form{$_, 'read_only'};
  568.     }
  569.     # No field was found at all
  570.     $current_field_no = $[ - 1;
  571. }
  572.  
  573. # Find previous field that is visible, has a data area, and is writable.
  574. sub previous_field {
  575.     local($old_field_no) = $current_field_no;
  576.  
  577.     # Look for a field before the current field
  578.     for ($current_field_no--; $current_field_no >= $[; $current_field_no--) {
  579.     $_ = $fields[$current_field_no];
  580.     return if !$form{$_, 'invisible'} &&
  581.               $form{$_, 'field_length'} &&
  582.           !$form{$_, 'read_only'};
  583.     }
  584.     # Look for a field after the current field
  585.     for ($current_field_no = $#fields; $current_field_no >= $old_field_no;
  586.      $current_field_no--) {
  587.     $_ = $fields[$current_field_no];
  588.     return if !$form{$_, 'invisible'} &&
  589.               $form{$_, 'field_length'} &&
  590.           !$form{$_, 'read_only'};
  591.     }
  592.     # No field was found at all
  593.     $current_field_no = $[ - 1;
  594. }
  595.  
  596. # Enter the current field
  597. sub enter_field {
  598.     $entered_field = $fields[$current_field_no];
  599.     $previous_value = $form{$entered_field, 'value'};
  600.     $previous_displayed_value = $form{$entered_field, 'displayed_value'};
  601.     $previous_displayed_field = $form{$entered_field, 'displayed_field'};
  602.     $previous_cursor_location = $cursor_location;
  603. }
  604.  
  605. # Exit the current field
  606. sub exit_field {
  607.     local($y);
  608.  
  609.     # Perform validity checking
  610.     $y = $form{$entered_field, 'validate_displayed_value'};
  611.     local(*x) = $y;
  612.     &undefined_function($entered_field, 'validate_displayed_value')
  613.         unless defined(&x);
  614.     return 0
  615.     unless &x($entered_field, $form{$entered_field, 'displayed_value'});
  616.     $y = $form{$entered_field, 'interpret_displayed_value'};
  617.  
  618.     # Interpret the value
  619.     local(*x) = $y;
  620.     &undefined_function($entered_field, 'interpret_displayed_value')
  621.         unless defined(&x);
  622.     $form{$entered_field, 'value'} =
  623.     &x($entered_field, $form{$entered_field, 'displayed_value'});
  624.  
  625.     # Canonicalize the value, if necessary
  626.     if ($form{$entered_field, 'canonicalize'}) {
  627.         local($cursor_location);
  628.         local($old_r, $old_c);
  629.  
  630.         $y = $form{$entered_field, 'construct_displayed_value'};
  631.         local(*x) = $y;
  632.         &undefined_function($entered_field, 'construct_displayed_value')
  633.         unless defined(&x);
  634.         $form{$entered_field, 'displayed_value'} =
  635.         &x($entered_field, $form{$entered_field, 'value'});
  636.         $y = $form{$entered_field, 'initialize_displayed_field'};
  637.         local(*x) = $y;
  638.         &undefined_function($entered_field, 'initialize_displayed_field')
  639.         unless defined(&x);
  640.         $form{$entered_field, 'displayed_field'} =
  641.         &x($entered_field, $form{$entered_field, 'displayed_value'});
  642.  
  643.         # Save the cursor position
  644.         &'getyx($'stdscr, $old_r, $old_c);
  645.         # Rewrite the field
  646.         local($r, $c) = 
  647.         split(',', $form{$entered_field, 'field_location'});
  648.         &'move($r, $c);
  649.         &'standout;
  650.         &'addstr($form{$entered_field, 'displayed_field'});
  651.         &'standend;
  652.         # Restore the cursor
  653.         &'move($old_r, $old_c);
  654.     }
  655.  
  656.     # Clean up and exit
  657.     $entered_field = undef;
  658.     return 1;
  659. }
  660.  
  661. sub display_help_screen {
  662.     # Create help screen window if necessary
  663.     if (!$help_screen_window) {
  664.     local($i);
  665.  
  666.     $help_screen_window = &'newwin(0, 0, 0, 0);
  667.     $i = 0;
  668.     foreach (split(/\n/, <<'EOF')) {
  669.                         Forms 1.0 help screen
  670.  
  671. LFD or C-j   Accept contents of form    C-c or C-g   Abort the form
  672. RET or C-m   Go to next field           TAB or C-i   Go to previous field
  673.  
  674. C-y          Restore previous value of the field and exit from field
  675. C-v          Perform validity check on field
  676. C-v C-v      Exit from valid field
  677.  
  678. C-u          Clear field
  679. C-k          Clear to end of field
  680. C-r          Clear to beginning of field
  681.  
  682. C-a          Go to beginning of field   C-e          Go to end of field
  683. C-b          Go back one character      C-f          Go forward one character
  684. C-d          Delete next character      DEL or C-h   Delete previous character
  685.  
  686. C-p          Give help on this field (or show help screen if no help for field)
  687. C-p C-p      Show this help screen
  688.  
  689. Function keys 1 through 10 can be used as commands if allowed by the
  690. particular form.
  691.  
  692. Hit any key (other than C-p) to continue...
  693. EOF
  694.         &'wmove($help_screen_window, $i, 0);
  695.         &'waddstr($help_screen_window, $_);
  696.         $i++;
  697.     }
  698.     }
  699.  
  700.     # Write it to the terminal
  701.     &'clearok($help_screen_window, 1);
  702.     &'wrefresh($help_screen_window);
  703.     # Wait for a character that is not C-p
  704.     1 while &'getch eq "\020";
  705.     # Refresh the form
  706.     &'clearok($'stdscr, 1);
  707. }
  708.  
  709. # Report an error
  710. sub report_error {
  711.     local($message) = @_;
  712.  
  713.     &report_message($message);
  714.     print "\007";
  715. }
  716.  
  717. sub report_message {
  718.     local($message) = @_;
  719.     local($length) = $form{'MSG', 'field_length'};
  720.  
  721.     if ($length) {
  722.     $form{'MSG', 'value'} = substr($message, 0, $length) .
  723.         ' ' x ($length - length($message));
  724.     &changed_value('MSG');
  725.     }
  726. }
  727.  
  728. sub undefined_function {
  729.     local($field, $attr) = @_;
  730.     local($package, $filename, $line) = caller;
  731.  
  732.     die sprintf("Bad value of attribute function %s.%s: %s at %s line %s\n",
  733.         $field, $attr, $form{$field, $attr}, $filename, $line);
  734. }
  735.  
  736. sub changed_visibility {
  737.     local($_) = @_;
  738.     local($r, $c);
  739.  
  740.     # Record where the cursor is
  741.     &'getyx($'stdscr, $r, $c);
  742.     # Update the screen
  743.     if ($form{$_, 'invisible'}) {
  744.     # Erase the field from the screen
  745.     # Erase the label of the field, if there is one
  746.     if ($form{$_, 'label_text'}) {
  747.         local($r, $c) = split(',', $form{$_, 'label_location'});
  748.         &'move($r, $c);
  749.         &'addstr(' ' x length($form{$_, 'label_text'}));
  750.     }
  751.     # Erase the contents of the field, if there is one
  752.     if ($form{$_, 'field_length'}) {
  753.         local($r, $c) = split(',', $form{$_, 'field_location'});
  754.         &'move($r, $c);
  755.         &'addstr(' ' x length($form{$_, 'displayed_field'}));
  756.     }
  757.     } else {
  758.         # Show the field on the screen
  759.     # Write the label of the field, if there is one
  760.     if ($form{$_, 'label_text'}) {
  761.         local($r, $c) = split(',', $form{$_, 'label_location'});
  762.         &'move($r, $c);
  763.         &'addstr($form{$_, 'label_text'});
  764.     }
  765.     # Write the contents of the field, if there is one
  766.     # Assumes that the contents have already been calculated
  767.     if ($form{$_, 'field_length'}) {
  768.         local($r, $c) = split(',', $form{$_, 'field_location'});
  769.         &'move($r, $c);
  770.         &'standout;
  771.         &'addstr($form{$_, 'displayed_field'});
  772.         &'standend;
  773.     }
  774.     }
  775.     # Restore the cursor
  776.     &'move($r, $c);
  777. }
  778.  
  779. sub changed_value {
  780.     local($_) = @_;
  781.     local($y, $c);
  782.  
  783.     # Do nothing if the field has no data
  784.     if ($form{$_, 'field_length'}) {
  785.     $y = $form{$_, 'construct_displayed_value'};
  786.     local(*x) = $y;
  787.     &undefined_function($_, 'construct_displayed_value')
  788.         unless defined(&x);
  789.     $form{$_, 'displayed_value'} = &x($_, $form{$_, 'value'});
  790.     $y = $form{$_, 'initialize_displayed_field'};
  791.     local(*x) = $y;
  792.     &undefined_function($_, 'initialize_displayed_field')
  793.         unless defined(&x);
  794.     {
  795.         local($cursor_location);
  796.         $form{$_, 'displayed_field'} =
  797.         &x($_, $form{$_, 'displayed_value'});
  798.         $c = $cursor_location;
  799.     }
  800.     if ($_ eq $fields[$current_field_no]) {
  801.        # Have to move cursor to correct place
  802.        $cursor_location = $c;
  803.        local($r, $c) = split(',', $form{$_, 'field_location'});
  804.        &'move($r, $c + $cursor_location);
  805.         }
  806.     # Write the contents of the field, if it is visible
  807.     if (!$form{$_, 'invisible'}) {
  808.         local($old_r, $old_c);
  809.  
  810.         # Save the cursor position
  811.         &'getyx($'stdscr, $old_r, $old_c);
  812.         # Rewrite the field
  813.         local($r, $c) = split(',', $form{$_, 'field_location'});
  814.         &'move($r, $c);
  815.         &'standout;
  816.         &'addstr($form{$_, 'displayed_field'});
  817.         &'standend;
  818.         # Restore the cursor
  819.         &'move($old_r, $old_c);
  820.     }
  821.     }
  822. }
  823.  
  824. # Field support routines
  825.  
  826. # Routines for ordinary text fields
  827.  
  828. # inititlize_displayed_field:  Put cursor after last nonblank character.
  829. sub id_cursor_after {
  830.     local($field, $value) = @_;
  831.  
  832.     $value =~ /(\s*)$/;
  833.     $cursor_location = $form{$field, 'field_length'} - length($1);
  834.     $value;
  835. }
  836.  
  837. # construct_displayed_value:  Pad value to field length on right with spaces.
  838. sub char_field {
  839.     local($field, $value) = @_;
  840.     local($length) = $form{$field, 'field_length'};
  841.  
  842.     $length < length($value) ? substr($value, 0, $length) :
  843.     $length > length($value) ? $value . ' ' x ($length - length($value)) :
  844.         $value;
  845. }
  846.  
  847. # validate_displayed_value:  Always return true.
  848. sub true {
  849.     1;
  850. }
  851.  
  852. # interpret_displayed_value:  Truncate trailing spaces.
  853. sub trim_trailing_space {
  854.     local($field, $displayed) = @_;
  855.  
  856.     $displayed =~ s/\s+$//;
  857.     $displayed;
  858. }
  859.  
  860. # insert:  Insert character into string at current location.
  861. sub text_insert {
  862.     local($field, $c) = @_;
  863.     local($v) = $form{$field, 'displayed_value'};
  864.  
  865.     substr($v, $cursor_location, 0) = $c;
  866.     if (chop $v eq ' ') {
  867.     $form{$field, 'displayed_field'} = $v;
  868.     $form{$field, 'displayed_value'} = $v;
  869.     $cursor_location++;
  870.     } else {
  871.     &forms'report_error("Character will not fit");
  872.     }
  873. }
  874.  
  875. # edit:  Edit character string
  876. sub text_edit {
  877.     local($field, $c) = @_;
  878.     local($v) = $form{$field, 'displayed_value'};
  879.     local($length) = $form{$field, 'field_length'};
  880.  
  881.     if ($c eq "\025") {
  882.         # C-u - clear field
  883.         $v = ' ' x $length;
  884.     $cursor_location = 0;
  885.     } elsif ($c eq "\013") {
  886.     # C-k - clear to end of field
  887.     substr($v, $cursor_location) = ' ' x ($length - $cursor_location);
  888.     } elsif ($c eq "\022") {
  889.     # C-r - clear to beginning of field
  890.     substr($v, 0, $cursor_location) = '';
  891.     $v .= ' ' x $cursor_location;
  892.     $cursor_location = 0;
  893.     } elsif ($c eq "\001") {
  894.         # C-a - go to beginning of field
  895.     $cursor_location = 0;
  896.     } elsif ($c eq "\005") {
  897.     # C-e - go to end of field
  898.     $v =~ /(\s*)$/;
  899.     $cursor_location = $length - length($1);
  900.     } elsif ($c eq "\002") {
  901.     # C-b - go back one character
  902.     if ($cursor_location > 0) {
  903.         $cursor_location--;
  904.         } else {
  905.         &forms'report_error("Beginning of field");
  906.         }
  907.     } elsif ($c eq "\006") {
  908.     # C-f - go forward one character
  909.     if ($cursor_location < $length) {
  910.         $cursor_location++;
  911.     } else {
  912.         &forms'report_error("End of field");
  913.         }
  914.     } elsif ($c eq "\004") {
  915.     # C-d - delete next character
  916.     if ($cursor_location < $length) {
  917.         substr($v, $cursor_location, 1) = '';
  918.         $v .= ' ';
  919.     }
  920.     } elsif ($c eq "\177" || $c eq "\b") {
  921.     # DEL, C-h - delete previous character
  922.     if ($cursor_location > 0) {
  923.         substr($v, $cursor_location-1, 1) = '';
  924.         $v .= ' ';
  925.         $cursor_location--;
  926.     }
  927.     } else {
  928.         &forms'report_error("Invalid editing character");
  929.     }
  930.     $form{$field, 'displayed_field'} = $v;
  931.     $form{$field, 'displayed_value'} = $v;
  932. }
  933.  
  934. # Routines for hidden fields
  935.  
  936. # inititlize_displayed_field:  Put cursor after last nonblank character.
  937. sub id_cursor_after_hidden {
  938.     local($value) = &id_cursor_after(@_);
  939.  
  940.     $value =~ /(\s*)$/;
  941.     ('.' x length($`)) . (' ' x length($1));
  942. }
  943.  
  944. # insert:  Insert character into string at current location.
  945. sub text_insert_hidden {
  946.     local($field, $c) = @_;
  947.  
  948.     &text_insert($field, $c);
  949.     $form{$field, 'displayed_field'} =~ /(\s*)$/;
  950.     $form{$field, 'displayed_field'} = ('.' x length($`)) . (' ' x length($1));
  951. }
  952.  
  953. # edit:  Edit character string
  954. sub text_edit_hidden {
  955.     local($field, $c) = @_;
  956.  
  957.     &text_edit($field, $c);
  958.     $form{$field, 'displayed_field'} =~ /(\s*)$/;
  959.     $form{$field, 'displayed_field'} = ('.' x length($`)) . (' ' x length($1));
  960. }
  961.  
  962. # Routines for enumerated fields
  963.  
  964. # construct_displayed_value:  Translate value from table
  965. sub enum_field {
  966.     local($field, $value) = @_;
  967.     local($length) = $form{$field, 'field_length'};
  968.     local($table) = $form{$field, 'translate_table'};
  969.     
  970.     $value = ($table =~ m#(^|\\)([^=\\]*)=$value($|\\)#)[$[+1];
  971.  
  972.     $length < length($value) ? substr($value, 0, $length) :
  973.     $length > length($value) ? $value . ' ' x ($length - length($value)) :
  974.         $value;
  975. }
  976.  
  977. # validate_displayed_value:  Check that value is in table
  978. sub enum_validate {
  979.     local($field, $value) = @_;
  980.     local($table) = $form{$field, 'translate_table'};
  981.     local($result);
  982.     
  983.     $value =~ s/\s+$//;
  984.     if ($table =~ m#(^|\\)$value=([^=\\]*)($|\\)#i) {
  985.     $result = 1;
  986.     $enum_value_temporary = $2;
  987.     } else {
  988.     $result = 0;
  989.     &report_error("Invalid value");
  990.     }
  991.     $result;
  992. }
  993.  
  994. # interpret_displayed_value:  Retrieve value saved by enum_validate.
  995. sub enum_interpret {
  996.     $enum_value_temporary;
  997. }
  998.  
  999. # Function key table
  1000.  
  1001. # Freestanding X window on Sun
  1002. $function_key{"\e[224z"} = 'F1';
  1003. $function_key{"\e[225z"} = 'F2';
  1004. $function_key{"\e[226z"} = 'F3';
  1005. $function_key{"\e[227z"} = 'F4';
  1006. $function_key{"\e[228z"} = 'F5';
  1007. $function_key{"\e[229z"} = 'F6';
  1008. $function_key{"\e[230z"} = 'F7';
  1009. $function_key{"\e[231z"} = 'F8';
  1010. $function_key{"\e[232z"} = 'F9';
  1011. $function_key{"\e[-1z"} = 'F10';
  1012.  
  1013. # X terminal on Sun
  1014. $function_key{"\e[11~"} = 'F1';
  1015. $function_key{"\e[12~"} = 'F2';
  1016. $function_key{"\e[13~"} = 'F3';
  1017. $function_key{"\e[14~"} = 'F4';
  1018. $function_key{"\e[15~"} = 'F5';
  1019. $function_key{"\e[17~"} = 'F6';
  1020. $function_key{"\e[18~"} = 'F7';
  1021. $function_key{"\e[19~"} = 'F8';
  1022. $function_key{"\e[20~"} = 'F9';
  1023. $function_key{"\e[21~"} = 'F10';
  1024.  
  1025. # VT100
  1026. $function_key{"\eOP"} = 'F1';
  1027. $function_key{"\eOQ"} = 'F2';
  1028. $function_key{"\eOR"} = 'F3';
  1029. $function_key{"\eOS"} = 'F4';
  1030.  
  1031. # Easy to type by hand
  1032. $function_key{"\e1f"} = 'F1';
  1033. $function_key{"\e2f"} = 'F2';
  1034. $function_key{"\e3f"} = 'F3';
  1035. $function_key{"\e4f"} = 'F4';
  1036. $function_key{"\e5f"} = 'F5';
  1037. $function_key{"\e6f"} = 'F6';
  1038. $function_key{"\e7f"} = 'F7';
  1039. $function_key{"\e8f"} = 'F8';
  1040. $function_key{"\e9f"} = 'F9';
  1041. $function_key{"\e0f"} = 'F10';
  1042. $function_key{"\e10f"} = 'F10';
  1043. $function_key{"\e1F"} = 'F1';
  1044. $function_key{"\e2F"} = 'F2';
  1045. $function_key{"\e3F"} = 'F3';
  1046. $function_key{"\e4F"} = 'F4';
  1047. $function_key{"\e5F"} = 'F5';
  1048. $function_key{"\e6F"} = 'F6';
  1049. $function_key{"\e7F"} = 'F7';
  1050. $function_key{"\e8F"} = 'F8';
  1051. $function_key{"\e9F"} = 'F9';
  1052. $function_key{"\e0F"} = 'F10';
  1053. $function_key{"\e10F"} = 'F10';
  1054.  
  1055. # Load the function key definitions provided by termcap, but only after
  1056. # curses has been intitialized.  Called during initialization the first
  1057. # time process_form is executed.
  1058. sub load_function_keys {
  1059.     $function_key{&'getcap('k1')} = 'F1';
  1060.     $function_key{&'getcap('k2')} = 'F2';
  1061.     $function_key{&'getcap('k3')} = 'F3';
  1062.     $function_key{&'getcap('k4')} = 'F4';
  1063.     $function_key{&'getcap('k5')} = 'F5';
  1064.     $function_key{&'getcap('k6')} = 'F6';
  1065.     $function_key{&'getcap('k7')} = 'F7';
  1066.     $function_key{&'getcap('k8')} = 'F8';
  1067.     $function_key{&'getcap('k9')} = 'F9';
  1068.     $function_key{&'getcap('k;') || &'getcap('k0')} = 'F10';
  1069.     $function_keys_loaded = 1;
  1070. }
  1071.  
  1072. 1;
  1073.  
  1074.