! FILESPEC: FORMCHAR.TPU;1
   ! SYSTEM:   VAX and OpenVMS 
   ! LANGUAGE: VAX Text Processing Utility (VAXTPU)  
   ! ABSTRACT: VAXTPU source program to replace the ASCII 
   !           codes of a SAS PROC TABULATE FORMCHAR 
   !           string with the appropriate DEC Special 
   !           Graphic (DSG) characters and escape 
   !           sequences in order to produce solid- 
   !           lined tables on DEC VTxxx and LN0x 
   !           equipment. 
   ! VERSION:  3.0 
   ! INPUT:    SAS listing (.LIS) file 
   ! OUTPUT:   Edited SAS listing file suitable for 
   !           printing on DEC VTxxx terminals or 
   !           LN0x laser printers 
   ! COMPILE:  EDIT/TPU/NOSECTION/COMMAND=FORMCHAR 
   ! USAGE:    EDIT/TPU/NODISPLAY/SECTION=<disk>FORMCHAR- 
   !              [/INIT=fc-file -] 
   !              [/OUTPUT=out-file -] 
   !              [/JOURNAL -] 
   !                sas-lis-file 
   !           sas-lis-file = file name of SAS .LIS 
   !                          output file
   !           out-file     = optional output file 
   !                          containing the processed . 
   !                          LIS file (default is 
   !                          sas-filename.LNI) 
   !           fc-file      = optional file containing 
   !                          the FORMCHAR string used   
   !                           with the TABULATE (see  
   !                           precedence below) 
   ! NOTES:  Since this is a stand-alone TPU program, not 
   !         intended to be used with EVE or any other 
   !         section file, no attempt has been made to  
   !         avoid name conflicts 

   ! Procedure executed automatically when the TPU 
   ! editing session is started; creates all necessary  
   ! buffers and performs edits: 
procedure tpu$init_procedure

   ! Buffer to hold all TPU messages: 
message_buffer:=create_buffer("Message Buffer");
set(no_write, message_buffer);

   ! Check JOURNAL qualifier as a surrogate for LOG/NOLOG 
   ! type of command qualifier. 
if (get_info (COMMAND_LINE, "journal")=1) then
   logging_enabled:=1;
else
   logging_enabled:=0;
endif;

   ! Get filespec of SAS .LIS file to be processed... 
input_file:=get_info(command_line, 'file_name');

   ! Get expanded filespec supplying .LIS as the        
   ! default type.      
expanded_name:=file_parse(input_file, '.LIS');
file_spec:=file_search(expanded_name);
if file_spec='' then
   delete(message_buffer);
   message('Error searching for '+expanded_name);
   message('File not found');
   quit;
endif;

   ! Create editing buffer from input file.     
edit_buffer:=create_buffer('edit', file_spec);
if get_info(edit_buffer, 'record_count')=0 then
   delete(message_buffer);
   message('SAS LIS file, '+file_spec+ ', is empty');
   quit;
endif;
set(no_write, edit_buffer);
set(insert, edit_buffer);

   ! Check for an OUTPUT file specification.    
output_filespec:=get_info(command_line, 'output_file');
if output_filespec='' then

      ! No output file given, construct one from the    
      ! input file. Parse the file specification, and   
      ! construct the output filename using an output   
      ! file type of LNI.       
   output_filespec:=file_parse(file_spec, '', '', name)
                    +'.LNI';
endif;

   ! Check for an INITIALIZATION file used to store the 
   ! FORMCHAR string, 11 bytes of line-drawing  
   ! characters.        
   ! precedence: 1) /Initialization=qualifier
   !             2) logical name formchar$init
   !             3) formchar$init.formchar in 
   !                   default directory 
   !             4) formchar$init.formchar in 
   !                   main directory
   !             5) hardcoded default 
   !                   (usual PC ASCII string)
init_filename:=get_info(command_line, 'init_file');
if init_filename='' then

      ! No INIT file specified on the command line,     
      ! check for either a logical name or the reserved         
      ! filename in the default directory.      

      ! Get expanded filespec supplying .FORMCHAR as the        
      ! default type...
   expanded_name:=file_parse('formchar$init','.FORMCHAR');
   init_filespec:= file_search(expanded_name);
   if init_filespec='' then

   ! No logical defined, nor was FORMCHAR$INIT.FORMCHAR 
   ! in the default directory found, check the main     
   ! directory as pointed to by SYS$LOGIN.      
   init_filespec:=
      file_search('sys$login:formchar$init.formchar');
      if init_filespec='' then

         ! With no initialization file available, an    
         ! assumed FC string will be used by default. At        
         ! this site, it is the same as that used on many       
         ! PC printers. 
      fc_vertical:=ascii(179);
      fc_horizontal:=ascii(196);
      fc_upper_left:=ascii(218);
      fc_upper_middle:=ascii(194);
      fc_upper_right:=ascii(191);
      fc_middle_left:=ascii(195);
      fc_middle_middle:=ascii(197);
      fc_middle_right:=ascii(180);
      fc_lower_left:=ascii(192);
      fc_lower_middle:=ascii(193);
      fc_lower_right:=ascii(217);
      if logging_enabled=1 then
         formchar_string:=fc_vertical+fc_horizontal+
            fc_upper_left+fc_upper_middle+fc_upper_right+
            fc_middle_left+fc_middle_middle+fc_middle_right
           +fc_lower_left+fc_lower_middle+fc_lower_right;
         endif;
      endif;
   endif;
else

      ! Get expanded filespec suppling .FORMCHAR as the 
      ! default.        
   expanded_name:=file_parse(init_filename,'.FORMCHAR');
   init_filespec:=file_search(expanded_name);
   if init_filespec='' then
      delete(message_buffer);
      message('Error searching for '+expanded_name);
      message('FORMCHAR string file not found');
      quit;
   endif;
endif;

   ! If a FORMCHAR file exists, put the contents into a 
   ! buffer for processing.     
if init_filespec<>'' then

   init_buffer:=create_buffer('init', init_filespec);
   if get_info(init_buffer, 'record_count')=0 then
      delete(message_buffer);
      message('Initialization file, '+init_filespec+
              ',is empty');
      quit;
   endif;
   set(no_write, init_buffer);

      ! Extract the FORMCHAR characters from the first   
      ! line.   
   position(beginning_of(init_buffer));
   formchar_string:=current_line;
   fc_length:=length(formchar_string);

      ! Check the length.       
   if fc_length>11 then
      fc_extra:=fc_length-11;
      delete(message_buffer);
      message('Warning: FORMCHAR string is '+str(fc_length)
              +'bytes and should be just 11.');
      message('Extra'+str(fc_extra)+
               'characters ignored.');
      message_buffer:=create_buffer("Message Buffer");
   endif;
   if fc_length<11 then
      fc_short:=11-fc_length;
      delete(message_buffer);
      message('Error: FORMCHAR string is '+str(fc_length)
              +'bytes and should be 11.');
      message('FORMCHAR post-processor aborted.');
      quit;

   endif;

      ! Check for duplicates (must be disallowed) by    
      ! comparing each character to those following.    
   fc_i:=0;
   loop
      fc_i:=fc_i+1;
      exitif(fc_i=11) or
         (index(
            substr(formchar_string, fc_i+1, fc_length-fc_i),
            substr(formchar_string, fc_i, 1)
                )> 0);
   endloop;
   if fc_i<11 then
         delete(message_buffer);
         message('Error: FORMCHAR string, "'+ 
                         formchar_string
                 +'", contains non-unique characters.');
         message('Character "'+
                  substr(formchar_string, fc_i, 1)+
                 '"was encountered twice.');
         quit;
   endif;
   fc_vertical:=substr(formchar_string, 1, 1);
   fc_horizontal:=substr(formchar_string, 2, 1);
   fc_upper_left:=substr(formchar_string, 3, 1);
   fc_upper_middle:=substr(formchar_string, 4, 1);
   fc_upper_right:=substr(formchar_string, 5, 1);
   fc_middle_left:=substr(formchar_string, 6, 1);
   fc_middle_middle:=substr(formchar_string, 7, 1);
   fc_middle_right:=substr(formchar_string, 8, 1);
   fc_lower_left:=substr(formchar_string, 9, 1);
   fc_lower_middle:=substr(formchar_string, 10, 1);
   fc_lower_right:=substr(formchar_string, 11, 1);
endif;

   ! Define the character strings that are to be        
   ! substituted for the FORMCHAR characters: these     
   ! are the DEC Special Graphic (or VT100 line-drawing)        
   ! characters, in combination with the necessary      
   ! locking shift or single shift escape sequences.    
escape:=ascii(27);
SI:=ascii(15);
SS3:=ascii(143);
sg_vertical:=SS3+'x';
sg_horizontal:='q';
sg_upper_left:=escape+'+0'+escape+'ol';
sg_upper_middle:='w';
sg_upper_right:='k'+SI;
sg_middle_left:=escape+'ot';
sg_middle_middle:='n';
sg_middle_right:='u'+SI;
sg_lower_left:=escape+'om';
sg_lower_middle:='v';
sg_lower_right:='j'+SI;

   ! Construct "source" and "destination" strings for use        
   ! in a TRANSLATE function call.       
source_string:=fc_horizontal+fc_upper_middle+
               fc_middle_middle+fc_lower_middle;
destin_string:=sg_horizontal+sg_upper_middle+
              sg_middle_middle+sg_lower_middle;

   ! Construct string of the five FORMCHAR characters    
   ! internal to the table and that potentially border   
   ! table text; a pattern is also defined that will     
   ! match any one.      
onetomany_chars:=
   fc_vertical+fc_upper_right+fc_middle_left+
   fc_middle_right+fc_lower_left;
onetomany_patt:=any(onetomany_chars, 1);

   ! BEGIN FILE EDITING  
   ! Loop through entire file searching for the FORMCHAR         
   ! upper-left table character as a marker for the      
   ! beginning of a table. This speeds processing by not         
   ! attempting to map FORMCHAR characters throughout the        
   ! entire file. However, this will ignore PROCs that   
   ! don't use this character (for example, PROC FREQ).  
table_count:=0;
position(beginning_of(edit_buffer));
loop
   exitif mark(none)=end_of(edit_buffer);
   table_start_range:=search(fc_upper_left,forward,exact);
   exitif table_start_range=0;

   ! There is a table here, now find the end.    
table_start:= beginning_of(table_start_range);
position(table_start);
table_end_range:=search(fc_lower_right,forward,exact);
if table_end_range=0 then
      delete(message_buffer);
      message('SAS LIS file,'+file_spec +
               ',contains an incomplete table.');
      quit;
   endif;
   table_count:=table_count+1;
   table_end:=end_of(table_end_range);
   table_range:=create_range(table_start,table_end,none);

      ! Perform one-to-one substitutions for the four    
      ! characters internal to the table lines (these    
      ! don't require a locking shift, since they're     
      ! bracketed by characters that will handle mapping         
      ! DSG to the in-use table and demapping it).       
   translate(table_range, destin_string, source_string);

      ! Perform one-to-many substitutions for the five   
      ! types of table characters that border table      
      ! text and must handle a single shift, locking     
      ! shift, or remapping.     
   position(table_start);
   loop
      text_range:=search(onetomany_patt, forward, exact);
      exitif(text_range=0) or
            (beginning_of(text_range)>=table_end);
   position(beginning_of(text_range));
   i:=index(onetomany_chars, current_character);
   erase(text_range);
   position(end_of(text_range));
   case i from 1 to 5
         [1]: copy_text(sg_vertical);
         [2]: copy_text(sg_upper_right);
         [3]: copy_text(sg_middle_left);
         [4]: copy_text(sg_middle_right);
         [5]: copy_text(sg_lower_left);
      endcase;
      position(end_of(text_range));
   endloop;

      ! Perform one-to-many substitution for the         
      ! upper-left position of the table (found          
      ! previously).     
   erase(table_start_range);
   position(end_of(table_start_range));
   copy_text(sg_upper_left);

      ! Finally, perform one-to-many substitution for the        
      ! lower-right position of the table (found         
      ! previously).     
   erase(table_end_range);
   position(end_of(table_end_range));
   copy_text(sg_lower_right);
endloop;

   ! Write out the updated .LIS file.    
write_file(edit_buffer, output_filespec);

if logging_enabled = 1 then
   delete(message_buffer);
   if init_filespec='' then
      message('No FORMCHAR string file available.');
   else
      message('FORMCHAR string file: '+init_filespec);
   endif;
   message('FORMCHAR string used: '+formchar_string);
   if table_count=0 then
      message('No tables processed.');
   else if table_count=1 then
      message('1 table processed.');
   else
      message(str(table_count)+' tables processed.');
   endif;
   endif;
   message('Output written to file'+output_filespec);
endif;

quit;
endprocedure;

   ! When this program is compiled, the following code  
   ! saves the section file and quits the TPU session   
   ! doing the compiling.       
save('formchar');
quit;