Programmer's ROM - The Computer Language Library

home *** CD-ROM | disk | FTP | other *** search

/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / virterm / vt2.src < prev next >

Wrap

Text File | 1988-05-03 | 219.5 KB | 6,379 lines

-------- SIMTEL20 Ada Software Repository Prologue ------------ -- -* -- Unit name : Virtual Terminal Protocol -- Version : 1.0 -- Contact : Lt. Colonel Falgiano -- : ESD/SCW -- : Hanscom AFB, MA 01731 -- Author : John Foreman -- : Texas Instruments, Inc. -- : P.O. Box 801 MS 8007 -- : McKinney, TX 75069 -- DDN Address : -- Copyright : (c) 1985 Texas Instruments, Inc. -- Date created : 9 November 1984 -- Release date : March 1985 -- Last update : -- -* --------------------------------------------------------------- -- -* -- Keywords : ----------------: -- -- Abstract : The ANSI virtual terminal is a program level ----------------: interface providing support for scroll, page ----------------: and form-mode terminals. This package uses ----------------: a terminal capabilities database to determine ----------------: the capabilities of a variety of terminals. ----------------: This package was designed to enhance the ----------------: transportability of the source code and ----------------: interoperability of the terminal capabilities ----------------: database. ----------------: ----------------: This tool was developed as a precursor for ----------------: the WMCCS Information System (WIS). An ----------------: executable version of the tool has been ----------------: demonstrated. This source code has sub- ----------------: sequently been recompiled but has not under- ----------------: gone extensive testing. ----------------: -- -* ------------------ Revision history --------------------------- -- -* -- DATE VERSION AUTHOR HISTORY -- 03/85 1.0 John Foreman Initial Release -- -* ------------------ Distribution and Copyright ----------------- -- -* -- This prologue must be included in all copies of this software. -- -- This software is copyright by the author. -- -- This software is released to the Ada community. -- This software is released to the Public Domain (note: -- software released to the Public Domain is not subject -- to copyright protection). -- Restrictions on use or distribution: NONE -- -* ----------------- Disclaimer ---------------------------------- -- -* -- This software and its documentation are provided "AS IS" and -- without any expressed or implied warranties whatsoever. -- -- No warranties as to performance, merchantability, or fitness -- for a particular purpose exist. -- -- Because of the diversity of conditions and hardware under -- which this software may be used, no warranty of fitness for -- a particular purpose is offered. The user is advised to -- test the software thoroughly before relying on it. The user -- must assume the entire risk and liability of using this -- software. -- -- In no event shall any person or organization of people be -- held responsible for any direct, indirect, consequential -- or inconsequential damages or lost profits. -- -* ----------------- END-PROLOGUE ------------------------------- :::::::::: vt_cmp.dis :::::::::: -- Ada source file in compilation order -- The names of the following files were changed in order to -- maintain a 9-character unique limit: -- Old Name New Name -- REDISPLAY_BODY.ADA REDISP_BODY.ADA -- REDISPLAY_SPEC.ADA REDISP_SPEC.ADA -- vtcontent_spec.ada sysdep_spec.ada tcf_spec.ada scroll_spec.ada page_spec.ada form_spec.ada vtinput_spec.ada driver_spec.ada redisp_spec.ada sysdep_body.ada tcf_body.ada driver_body.ada vtinput_body.ada redisp_body.ada scroll_body.ada page_body.ada form_body.ada activate_form.ada :::::::::: vt_src.dis :::::::::: -- Ada source file in compilation order -- The names were changed on the following files to put them -- into the 9-character unique limit: -- Old Name New Name -- REDISPLAY_BODY.ADA REDISP_BODY.ADA -- REDISPLAY_SPEC.ADA REDISP_SPEC.ADA -- vtcontent_spec.ada sysdep_spec.ada tcf_spec.ada scroll_spec.ada page_spec.ada form_spec.ada vtinput_spec.ada driver_spec.ada redisp_spec.ada sysdep_body.ada tcf_body.ada driver_body.ada vtinput_body.ada redisp_body.ada scroll_body.ada page_body.ada form_body.ada activate_form.ada -- -- Data files -- tcf term recompile.cli :::::::::: vtcontent_spec.ada :::::::::: -- ---------------------------------------------------------------------------- -- ABSTRACT: This package consisting only of a specification, contains -- the supporting constant and type definitions used by other -- packages in defining and manipulating a virtual display. -- Many of the enumerated types use names that match the names -- in the ANSI X3.64 [ANSI74] standard. -- ----------------------------------------------------------------------------- PACKAGE vt_content IS TYPE graphic_rendition_enum IS ( sgpr, -- primary rendition sgri, -- reverse image sgno ); -- no rendition (blank) TYPE area_qualifiers_enum IS ( dqnn, -- accept no input (protected) dqag, -- accept graphic input dqan ); -- accept numeric input max_row : CONSTANT integer := 60; max_column : CONSTANT integer := 132; SUBTYPE column_range IS positive RANGE 1..max_column; SUBTYPE row_range IS positive RANGE 1..max_row; height : row_range; width : column_range; TYPE vt_position_xy_record IS RECORD row_position :row_range; col_position :column_range; END RECORD; TYPE tabs_array IS ARRAY( column_range ) OF BOOLEAN; TYPE vt_position_record IS RECORD qualifier_head :boolean ; rendition :graphic_rendition_enum; qualifiers :area_qualifiers_enum; END RECORD; -- vt_position_record TYPE vt_column_descriptors IS ARRAY( column_range ) OF vt_position_record; TYPE vt_column_record IS RECORD corresponding_line : natural; descriptors : vt_column_descriptors; data : string( column_range ); length : natural; -- when this is zero line is blank END RECORD; -- vt_column_record TYPE vt_content_array IS ARRAY( row_range ) OF vt_column_record; TYPE vt_content_record IS RECORD active_position :vt_position_xy_record; insert_mode :boolean; current_rendition : graphic_rendition_enum; tabs :tabs_array; element :vt_content_array; END RECORD; -- vt_content_record TYPE vt_content_access IS ACCESS vt_content_record; END vt_content; :::::::::: sysdep_spec.ada :::::::::: -- --------------------------------------------------------------------------- -- ABSTRACT: This system dependency package is the only package that -- needs modifications when rehosting the Virtual Terminal tool -- to another environment. -- The supported functions are: -- * open the physical terminal, -- * close the physical terminal, -- * put strings to the physical terminal, -- * get strings form the physical terminal, -- * get terminal capabilities file (TCF) name, -- * get the terminal's name (to be subsequently looked up in TCF -- * check the validity of a particular character. -- -- ---------------------------------------------------------------------------- PACKAGE sysdep IS PROCEDURE open; -- -- Open the console for binary I/O, no echo. -- PROCEDURE close; -- -- Close the console. Parameters should be reset to original condition. -- PROCEDURE put ( data : IN string ); -- -- Put a string to the terminal. There should be no translation of -- the characters. There can be exceptions to this rule (like CTRL-S and -- CTRL-Q) and these exceptions must be identified in valid_character -- below. -- PROCEDURE get ( data : OUT string; last : OUT natural ); -- -- Get a string from the terminal keyboard. This ocurrs with no echo -- and no translations. -- PROCEDURE tcf_name ( name : OUT string; last : OUT natural ); -- -- Returns the name of the terminal capabilities file as a string. -- You better pass in a string of sufficient length to handle the name -- that is returned or you will get a constraint error. 80 is a good -- random number. -- PROCEDURE terminal_name ( name : OUT string; last : OUT natural ); -- -- Returns the name of the terminal. This name of a string like "tv970". -- If the name cannot be determined then last is returned as 0 (zero). -- Again, you better make the name parameter big enough to hold the -- value returned. -- -- A DG implementation note: This procedure looks for a file called -- TERM on your searchlist. -- FUNCTION valid_character ( item : IN character ) RETURN boolean; -- -- Returns a boolean value identifying whether the character passed in -- is safe to use in the environment. Suspicious characters include -- CTRL-S CTRL-Q CTRL-C CTRL-Y. END sysdep; :::::::::: tcf_spec.ada :::::::::: -- ---------------------------------------------------------------------------- -- ABSTRACT: This package incorporates a variation of the UNIX terminal -- capabilities data base which is used to define the mapping. -- The TCF package defines one procedure initialize. This -- initialize procedure opens the TCF data base file, fills in -- the data structures and then closes the TCF data base file. -- The 'name' parameter passed in holds the terminal name. This -- parameter is used to search the TCF file for the terminal -- characteristics associated with the terminal name. Theses -- characteristics are then put into the termcap_operations -- variable. The variable termcap_operations is used by both -- the DRIVER package and the VT_INPUT package. -- -- ----------------------------------------------------------------------------- PACKAGE tcf IS -- Constants max_termcap_entry : CONSTANT integer := 1920; max_string_data : CONSTANT integer := 100; -- Types SUBTYPE string_data_array IS string( 1..max_string_data ); SUBTYPE termcap_entry_array IS string( 1..max_termcap_entry ); TYPE termcap_entries_enum IS ( cd, -- clear to end of display ce, -- clear to end of line cm, -- cursor movement i_s, -- initialization string al, -- insert line dl, -- delete line dc, -- delete character vb, -- bell nl, -- new line so, -- start standout mode im, -- enter insert mode ei, -- end insert mode sf, -- scroll up sr, -- scroll down l1, -- function key 1 label l2, -- function key 2 label l3, -- function key 3 label l4, -- function key 4 label l5, -- function key 5 label l6, -- function key 6 label l7, -- function key 7 label l8, -- function key 8 label l9, -- function key 9 label y0, -- function key 10 label y1, -- function key 11 label y2, -- function key 12 label y3, -- function key 13 label y4, -- function key 14 label y5, -- function key 15 label y6, -- function key 16 label y7, -- function key 17 label y8, -- function key 18 label y9, -- function key 19 label h0, -- function key 20 label h1, -- function key 21 label h2, -- function key 22 label h3, -- function key 23 label h4, -- function key 24 label h5, -- function key 25 label h6, -- function key 26 label h7, -- function key 27 label h8, -- function key 28 label h9, -- function key 29 label v0, -- function key 30 label v1, -- function key 31 label v2, -- function key 32 label ku, -- cursor up key kd, -- cursor down key kl, -- cursor left key kr, -- cursor right key k1, -- function 1 key k2, -- function 2 key k3, -- function 3 key k4, -- function 4 key k5, -- function 5 key k6, -- function 6 key k7, -- function 7 key k8, -- function 8 key k9, -- function 9 key x0, -- function 10 key x1, -- function 11 key x2, -- function 12 key x3, -- function 13 key x4, -- function 14 key x5, -- function 15 key x6, -- function 16 key x7, -- function 17 key x8, -- function 18 key x9, -- function 19 key g0, -- function 20 key g1, -- function 21 key g2, -- function 22 key g3, -- function 23 key g4, -- function 24 key g5, -- function 25 key g6, -- function 26 key g7, -- function 27 key g8, -- function 28 key g9, -- function 29 key t0, -- function 30 key t1, -- function 31 key t2, -- function 32 key wr, -- wraps at end of line su, -- scrolls up at bottom li, -- number of lines se, -- end standout mode an, -- ansi terminal vt, -- vt terminal ca, -- clear all of line cl, -- clear screen ds, -- co -- number of columns ); SUBTYPE key_range IS termcap_entries_enum RANGE ku..t2; TYPE termcap_operation_record IS RECORD encoded_data : string_data_array; encoded_data_length : integer; parameter : integer; bool_parameter : boolean; END RECORD; TYPE termcap_operation_array is array(termcap_entries_enum) of termcap_operation_record; -- Variables termcap_operations : termcap_operation_array; -- Procedures PROCEDURE initialize ( name : IN string); -- Exceptions tcf_error : EXCEPTION; unsupported_terminal : EXCEPTION; END tcf; :::::::::: scroll_spec.ada :::::::::: -- --------------------------------------------------------------------------- -- ABSTRACT: A user's program can WITH this package to provide a device- -- independent terminal interface that is functionally equivalent -- to a scroll-terminal. This is the simplest form of terminal that -- this virtual terminal suports. This package should be chosen for -- any of the following reasons: -- -- 1. The user's terminal is primitive. Either it could be a CRT -- with little functionality, or a printing terminal. -- 2. The user wants maximum transportability. -- 3. The user does not need advanced capabiltiies for the -- application. -- 4. The user's application may run over low speed communication -- lines, making the page and form mode unacceptable. -- ----------------------------------------------------------------------------- PACKAGE scroll_terminal IS TYPE function_key_enum IS ( up_arrow, down_arrow, left_arrow, right_arrow, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13, f14, f15, f16, f17, f18, f19, f20, f21, f22, f23, f24, f25, f26, f27, f28, f29, f30, f31, f32 ); TYPE function_key_descriptor( length : positive := 32) IS PRIVATE; PROCEDURE open (name : IN string := "none" ); PROCEDURE close; PROCEDURE set_position (position : IN positive); FUNCTION position RETURN positive; FUNCTION size RETURN positive; PROCEDURE set_tab; PROCEDURE clear_tab; PROCEDURE tab (count : IN positive := 1); PROCEDURE new_line (count : IN positive := 1); PROCEDURE new_page (count : IN positive := 1); PROCEDURE put (item : IN character); PROCEDURE put (item : IN string); PROCEDURE update_line; PROCEDURE get( data : OUT string; last : OUT natural; keys : OUT function_key_descriptor; timeout : IN duration := duration'last ); FUNCTION function_count(keys : IN function_key_descriptor) RETURN natural; PROCEDURE function_key(keys: IN function_key_descriptor; index : IN positive; key_identifier : OUT function_key_enum; previous_position : OUT natural); PROCEDURE function_key_name ( key_identifier : IN function_key_enum; key_name : OUT string; last : OUT natural); PROCEDURE bell; uninitialized : EXCEPTION; tcf_error : EXCEPTION; terminal_too_primitive : EXCEPTION; unsupported_terminal : EXCEPTION; invalid_function_key : EXCEPTION; PRIVATE TYPE keystroke_record IS RECORD key : function_key_enum; position : positive; END RECORD; TYPE function_key_array IS ARRAY( positive RANGE <> ) OF keystroke_record; TYPE function_key_descriptor( length : positive := 32 ) IS RECORD no_of_keys : natural := 0; keys : function_key_array( 1..length ); END RECORD; END scroll_terminal; :::::::::: page_spec.ada :::::::::: -- ---------------------------------------------------------------------------- -- ABSTRACT: A user's program can WITH this package to provide a device- -- independent terminal interface that is functionally equivalent -- to a page_terminal. This is the most advanced form of terminal -- that this virtual terminal supports. This package should be -- chosen for any of the following reasons: -- -- 1. The user's terminal has advanced features. The terminal is -- directly addressable, with erase to end of line, and erase -- to end of screen capabilities. -- 2. The user wants advanced capabilities and is willing to -- sacrifice some transportability. -- ----------------------------------------------------------------------------- PACKAGE page_terminal IS TYPE function_key_enum IS ( up_arrow, down_arrow, left_arrow, right_arrow, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13, f14, f15, f16, f17, f18, f19, f20, f21, f22, f23, f24, f25, f26, f27, f28, f29, f30, f31, f32 ); TYPE function_key_descriptor( length : positive := 32) IS PRIVATE; TYPE xy_position IS RECORD line : positive; column : positive; END RECORD; TYPE select_enumeration IS (from_xy_position_to_end, from_start_to_xy_position, all_positions); TYPE graphic_rendition_enumeration IS (primary_rendition, reverse_image, no_image ); PROCEDURE open (name : IN string := "none" ); PROCEDURE close; PROCEDURE set_position (position : IN xy_position); FUNCTION position RETURN xy_position; FUNCTION size RETURN xy_position; PROCEDURE delete_character (count : IN positive := 1); PROCEDURE delete_line (count : IN positive := 1); PROCEDURE erase_in_display (selection : select_enumeration); PROCEDURE erase_in_line (selection : select_enumeration); PROCEDURE enter_insert_mode; PROCEDURE exit_insert_mode; PROCEDURE insert_line (count : IN positive := 1); PROCEDURE select_graphic_rendition (selection : IN graphic_rendition_enumeration); PROCEDURE set_tab; PROCEDURE clear_tab; PROCEDURE tab (count : IN positive := 1); PROCEDURE put (item : IN character); PROCEDURE put (item : IN string); PROCEDURE update_screen ( top_line : IN positive; bottom_line : IN positive ); PROCEDURE update_line( the_line : IN positive ); PROCEDURE update_cursor; PROCEDURE redraw_screen; PROCEDURE get( data : OUT string; last : OUT natural; keys : OUT function_key_descriptor; timeout : IN duration := duration'last ); FUNCTION function_count(keys : IN function_key_descriptor) RETURN natural; PROCEDURE function_key(keys: IN function_key_descriptor; index : IN positive; key_identifier : OUT function_key_enum; previous_position : OUT natural); PROCEDURE function_key_name ( key_identifier : IN function_key_enum; key_name : OUT string; last : OUT natural); PROCEDURE bell; uninitialized : EXCEPTION; tcf_error : EXCEPTION; terminal_too_primitive : EXCEPTION; unsupported_terminal : EXCEPTION; invalid_function_key : EXCEPTION; PRIVATE TYPE keystroke_record IS RECORD key : function_key_enum; position : positive; END RECORD; TYPE function_key_array IS ARRAY( positive RANGE <> ) OF keystroke_record; TYPE function_key_descriptor( length : positive := 32 ) IS RECORD no_of_keys : natural := 0; keys : function_key_array( 1..length ); END RECORD; END page_terminal; :::::::::: form_spec.ada :::::::::: -- ----------------------------------------------------------------------------- -- ABSTRACT: A user's program may WITH this package to provide a device- -- independent terminal interface that is functionally equivalent to -- a form terminal. -- The display of a form-mode terminal is divided into qualified -- areas that have the same attributes. The user program defines -- qualified areas on the virtual display by making calls on -- form_terminal.set_position and form_terminal.define_qualified_area -- A call upon form_terminal.activate_form will map the virtual -- terminal display into the actual terminal display and allow -- editing of the form without user program intervention. When -- the user has finished editing the form the user presses a -- function key (as defined in the terminal capabilities file) -- which returns control to the user's program. -- ---------------------------------------------------------------------------- PACKAGE form_terminal IS TYPE xy_position IS RECORD line : positive; column : positive; END RECORD; TYPE termination_key_range IS RANGE 1..32; TYPE area_intensity IS (none, normal, high); TYPE area_protection IS (unprotected, protected); TYPE area_input IS (graphic_characters, numerics ); PROCEDURE open (name : IN string := "none"); PROCEDURE close; PROCEDURE set_position (position : IN xy_position); FUNCTION position RETURN xy_position; FUNCTION size RETURN xy_position; PROCEDURE define_qualified_area (intensity : IN area_intensity := normal; protection : IN area_protection := protected; input : IN area_input := graphic_characters ); PROCEDURE clear_qualified_area; PROCEDURE tab; PROCEDURE put (item : IN character); PROCEDURE put (item : IN string); PROCEDURE get (item : OUT character); PROCEDURE get (item : OUT string); PROCEDURE erase_area; PROCEDURE erase_display; PROCEDURE activate_form; FUNCTION is_form_updated RETURN boolean; FUNCTION area_qualifier_requires_space RETURN boolean; FUNCTION termination_key RETURN termination_key_range; uninitialized : EXCEPTION; tcf_error : EXCEPTION; terminal_too_primitive : EXCEPTION; unsupported_terminal : EXCEPTION; invalid_function_key : EXCEPTION; END form_terminal; :::::::::: vtinput_spec.ada :::::::::: -- ----------------------------------------------------------------------------- -- ABSTRACT: This package provides an interface to get keystrokes from the -- actual terminals keyboard. The keystrokes include regular ASCII -- keys and function keys (including the arrow keys). The function -- and arrow keys are identified throught the use of the terminal -- capabilities data base. There can be up to 32 function keys. -- There will always be 4 arrow keys. -- ----------------------------------------------------------------------------- PACKAGE vt_input IS TYPE function_key_enum IS ( up_arrow, down_arrow, left_arrow, right_arrow, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13, f14, f15, f16, f17, f18, f19, f20, f21, f22, f23, f24, f25, f26, f27, f28, f29, f30, f31, f32 ); -- These could be private if I could simply figure out how to window -- the page_terminal to see these things efficiently... -- v------v--------v--------v---------v---------v---------v---------v-----v TYPE keystroke_record IS RECORD key : function_key_enum; position : positive; END RECORD; TYPE function_key_array IS ARRAY( positive RANGE <> ) OF keystroke_record; TYPE function_key_descriptor( length : positive := 32 ) IS RECORD no_of_keys : natural := 0; keys : function_key_array( 1..length ); END RECORD; -- ^------^--------^--------^---------^---------^---------^---------^-----^ PROCEDURE get( data : OUT string; last : OUT natural; keys : IN OUT function_key_descriptor; timeout : IN duration := duration'last ); FUNCTION function_count(keys : IN function_key_descriptor) RETURN natural; PROCEDURE function_key(keys : IN function_key_descriptor; index : IN positive; key_identifier : OUT function_key_enum; previous_position : OUT natural); PROCEDURE function_key_name ( key_identifier : IN function_key_enum; key_name : OUT string; last : OUT natural); invalid_function_key : EXCEPTION; uninitialized : EXCEPTION; END vt_input; :::::::::: driver_spec.ada :::::::::: -- ---------------------------------------------------------------------------- -- ABSTRACT: The DRIVER package performs the following functions: -- * initialize the actual terminal, -- * initialize the TCF, -- * interpret the ANSI compatible character codes and translate -- them into device specific character codes, -- * close the actual terminal -- ---------------------------------------------------------------------------- PACKAGE driver IS -- Types TYPE terminal_capabilities_enum IS ( erase_to_end_of_screen_is, erase_to_end_of_line_is, move_the_cursor_is, insert_line_is, delete_line_is, delete_character_is, beep_is, highlight_is, erase_all_of_display_is, erase_all_of_line_is, new_line_is, insert_mode_is ) ; TYPE terminal_capabilities_set IS array( terminal_capabilities_enum ) OF boolean; -- Variables supported_functions : terminal_capabilities_set; -- Procedures PROCEDURE vt_initialize( name : IN string; lines : OUT integer; columns : OUT integer ); PROCEDURE close_virtual_terminal; PROCEDURE interpret ( command_string : IN string); uninitialized : EXCEPTION; tcf_error : EXCEPTION; unsupported_terminal : EXCEPTION; END driver; :::::::::: redisp_spec.ada :::::::::: -- ----------------------------------------------------------------------------- -- ABSTRACT: The REDISPLAY package perfroms the function of mappeing -- characters and lines from the data structures of the VT_CONTENT -- package to the actual display. -- -- This package WITH's the VT_CONTENT package to make the data -- structures in VT_CONTENT visible to redisplay. The VT_CONTENT -- data structures describe how the image on the actual display -- looks after REDISPLAY package is invoked and how the image of -- actual display looks before the REDISPLAY package is invoked. -- When a change is made to the data structures in VT_CONTENT, the -- image on the actual display must be updated to reflect the change. -- ----------------------------------------------------------------------------- WITH vt_content; PACKAGE redisplay IS PROCEDURE fix_cursor( old_screen : IN OUT vt_content.vt_content_access; new_screen : IN OUT vt_content.vt_content_access ); PROCEDURE redraw_screen( old_screen : IN OUT vt_content.vt_content_access; new_screen : IN vt_content.vt_content_access; top_line : vt_content.row_range; bottom_line : vt_content.row_range ); PROCEDURE redisplay_screen_with_movement( old_screen : IN OUT vt_content.vt_content_access; new_screen : IN vt_content.vt_content_access; top_line : vt_content.row_range; bottom_line : vt_content.row_range ); PROCEDURE redisplay_screen_with_redraw( old_screen : IN OUT vt_content.vt_content_access; new_screen : IN vt_content.vt_content_access; top_line : IN vt_content.row_range; bottom_line : IN vt_content.row_range ); PROCEDURE redisplay_line_with_redraw( old_screen : IN OUT vt_content.vt_content_access; new_screen : IN vt_content.vt_content_access; old_line : IN vt_content.row_range; new_line : IN vt_content.row_range ); END redisplay; :::::::::: sysdep_body.ada :::::::::: -- ---------------------------------------------------------------------------- -- ABSTRACT: This system dependency package is the only package to be changed -- when rehosting the Virtual Terminal tool to another environment. -- The supported functions are: -- * open the physical terminal, -- * close the physical terminal, -- * put strings to the physical terminal, -- * get strings from the physical terminal, -- * get the terminal capabilities file (TCF) name, -- * get the terminal's name (to be subsequently looked up in TCF -- * check the validity of a particular character. -- ----------------------------------------------------------------------------- WITH tty_io, text_io, sys_calls, file_definitions, file_io, bit_ops, current_exception; PACKAGE BODY sysdep IS buffer_byte_ptr : integer; buffer : integer; invalid_chars_array : ARRAY( 1..2 ) OF character; terminal : file_definitions.channel_number; tty : tty_io.file_type; previously_opened : boolean := false; temp_buffer_last : natural; PRAGMA page; TASK tty_server IS ENTRY go; ENTRY start_get; ENTRY get( data : OUT string; last : OUT natural ); END tty_server; TASK BODY tty_server IS bytes_read : integer; error_code : integer; BEGIN ACCEPT go; LOOP SELECT ACCEPT start_get; file_io.read( terminal, error_code, bytes_read, buffer_byte_ptr, file_definitions.binary_io, 1 ); buffer := bit_ops.logical_right_shift( buffer, 24 ); ACCEPT get( data : OUT string; last : OUT natural ) DO last := 1; data( 1 ) := character'val( buffer ); END get; OR TERMINATE; END SELECT; END LOOP; END tty_server; PROCEDURE open IS console_characteristics : file_io.device_characteristics; error_code : integer; ac0, ac1, ac2 : integer; name : sys_calls.call_name; error_id : sys_calls.error_code; BEGIN IF NOT previously_opened THEN tty_io.open( tty, tty_io.inout_file, "@console" ); -- turn off the keyboard interrupt capabilities ac0 := 0; ac1 := 0; ac2 := 0; name := sys_calls.kioff; sys_calls.long_sys( name, ac0, ac1, ac2, error_id ); file_io.open( "@console", terminal, error_code, file_definitions.open_for_input_output + file_definitions.binary_io + file_definitions.variable_length ); file_io.get_characteristics( terminal, console_characteristics, error_code ); console_characteristics.echo := file_io.no_echo; console_characteristics.characteristics( file_io.non_ansi_standard_device ) := false; file_io.set_characteristics( terminal, console_characteristics, error_code ); buffer_byte_ptr := integer'val( buffer'address ); buffer_byte_ptr := bit_ops.left_shift_by_1( buffer_byte_ptr ); tty_server.go; previously_opened := true; END IF; END open; PROCEDURE close IS error_code : integer; BEGIN -- lets not do anything and let AOS clean up after me. -- file_io.close( terminal, error_code ); NULL; END close; PROCEDURE put ( data : IN string ) IS BEGIN tty_io.put( tty, data ); END put; PROCEDURE get ( data : OUT string; last : OUT natural ) IS BEGIN tty_server.start_get; tty_server.get( data, last ); END get; PROCEDURE tcf_name ( name : OUT string; last : OUT natural ) IS BEGIN last := name'first+2; name( name'first..(name'first)+2 ) := "TCF"; END tcf_name; PROCEDURE terminal_name ( name : OUT string; last : OUT natural ) IS terminal_name_file : text_io.file_type; line_buffer : string( 1..80 ); last_char_on_line : natural; BEGIN text_io.open( terminal_name_file, text_io.in_file, "TERM" ); text_io.reset(terminal_name_file); text_io.get_line( terminal_name_file, line_buffer, last_char_on_line ); name( name'first..(name'first)+last_char_on_line-1 ) := line_buffer( 1..last_char_on_line ); last := name'first + last_char_on_line - 1; text_io.close( terminal_name_file ); EXCEPTION WHEN others => last := 0; END terminal_name; FUNCTION valid_character ( item : IN character ) RETURN boolean IS valid_flag : boolean; BEGIN valid_flag := true; FOR i IN 1..8 LOOP IF invalid_chars_array( i )=item THEN valid_flag := false; END IF; END LOOP; RETURN valid_flag; END valid_character; BEGIN -- please refer to AOS/VS Programmer's Manual, Volume 1, System Concepts -- page 5-20 for a description of these character codes. invalid_chars_array( 1 ) := ascii.dc3; -- CTRL-S invalid_chars_array( 2 ) := ascii.dc1; -- CTRL-Q END sysdep; :::::::::: tcf_body.ada :::::::::: -- ---------------------------------------------------------------------------- -- ABSTRACT: This package incorporates a variation of the UNIX terminal -- capabilities data base which is used to define the mapping. -- The TCF package defines one procedure called initialize. -- This initialize procedure opens the TCF data base file, -- fills in the data structures and then closes the TCF data -- base file. The 'name' parameter passed in holds the -- terminal name. This parameter is used to search the TCF -- file for the terminal characteristics associated with the -- terminal name. These characteristics are then put into the -- termcap_operations variable. The variable termcap_operations -- is used by both the driver package and the vt_input package. -- ----------------------------------------------------------------------------- WITH sysdep, text_io; PACKAGE BODY tcf IS -- ------------------------------------------------------------------------ -- initialize procedure initializes the terminal by opening the TERMCAP -- (TCF). -- searching the TCF for the terminal name -- associating the terminal characteristics in the TCF to the -- data structures in the TCF_SPEC. -- ------------------------------------------------------------------------- PROCEDURE initialize ( name : IN string) IS SUBTYPE gen_string IS STRING(1..80); found : boolean; termcap_file : text_io.file_type; read_buffer : STRING(1..1920); continue : boolean; termcap_entry : termcap_entry_array; i,j,k : integer; tcf_last : natural; term_file : gen_string; term_name : string(1..80); term_name_last : natural; -- --------------------------------------------------------------------------- -- this procedure blanks out the data structures that will -- hold the terminal characteristics. PROCEDURE initialize_termcap_entry_fields IS i : termcap_entries_enum; BEGIN -- initialize_termcap_entry_fields -- for each entry in the termcap_operations variable, initialize to -- appropriate default value. FOR i IN cd..co LOOP termcap_operations(i).encoded_data_length := 0; termcap_operations(i).parameter := 0; termcap_operations(i).bool_parameter := false; END LOOP; END initialize_termcap_entry_fields; -- ----------------------------------------------------------------------------- PROCEDURE get_termcap_entry_fields(entry_length : IN integer) IS TYPE fields_entry_enum IS ( cd, -- clear to end of display ce, -- clear to end of line cm, -- cursor movement i_s, -- initialization string al, -- insert line dl, -- delete line dc, -- delete character vb, -- bell nl, -- new line so, -- start standout mode im, -- enter insert mode ei, -- end insert mode sf, -- scroll up sr, -- scroll down l1, -- function key 1 label l2, -- function key 2 label l3, -- function key 3 label l4, -- function key 4 label l5, -- function key 5 label l6, -- function key 6 label l7, -- function key 7 label l8, -- function key 8 label l9, -- function key 9 label y0, -- function key 10 label y1, -- function key 11 label y2, -- function key 12 label y3, -- function key 13 label y4, -- function key 14 label y5, -- function key 15 label y6, -- function key 16 label y7, -- function key 17 label y8, -- function key 18 label y9, -- function key 19 label h0, -- function key 20 label h1, -- function key 21 label h2, -- function key 22 label h3, -- function key 23 label h4, -- function key 24 label h5, -- function key 25 label h6, -- function key 26 label h7, -- function key 27 label h8, -- function key 28 label h9, -- function key 29 label v0, -- function key 30 label v1, -- function key 31 label v2, -- function key 32 label ku, -- cursor up key kd, -- cursor down key kl, -- cursor left key kr, -- cursor right key k1, -- function 1 key k2, -- function 2 key k3, -- function 3 key k4, -- function 4 key k5, -- function 5 key k6, -- function 6 key k7, -- function 7 key k8, -- function 8 key k9, -- function 9 key x0, -- function 10 key x1, -- function 11 key x2, -- function 12 key x3, -- function 13 key x4, -- function 14 key x5, -- function 15 key x6, -- function 16 key x7, -- function 17 key x8, -- function 18 key x9, -- function 19 key g0, -- function 20 key g1, -- function 21 key g2, -- function 22 key g3, -- function 23 key g4, -- function 24 key g5, -- function 25 key g6, -- function 26 key g7, -- function 27 key g8, -- function 28 key g9, -- function 29 key t0, -- function 30 key t1, -- function 31 key t2, -- function 32 key wr, -- wraps at end of line su, -- scrolls up at bottom li, -- number of lines se, -- end standout mode an, -- ansi terminal vt, -- vt100 terminal ca, -- clear all of line cl, -- clear screen ds, -- co -- number of columns ); i,j : INTEGER; field_entries_list : CONSTANT STRING := "cdcecmisaldldcvbnlsoimeisfsrl1l2l3l4l5l6" & "l7l8l9y0y1y2y3y4y5y6y7y8y9h0h1h2h3h4h5h6" & "h7h8h9v0v1v2kukdklkrk1k2k3k4k5k6k7k8k9x0" & "x1x2x3x4x5x6x7x8x9g0g1g2g3g4g5g6g7g8g9t0" & "t1t2wrsuliseanvtcacldsco" ; -- ---------------------------------------------------------------------------- PROCEDURE store_entry(entry1 : IN termcap_entries_enum; position : IN OUT integer ) IS i : integer; -- -------------------------------------------------------------------- PROCEDURE decode_entry(data : IN OUT termcap_operation_record ) IS i,j : integer; store_temp : string_data_array; store_octal : integer; mil_padding : integer; BEGIN -- decode_entry mil_padding := 0; i := 1; j := 0; WHILE data.encoded_data(i) IN '0'..'9' LOOP mil_padding := (mil_padding*10) + (character'pos(data.encoded_data(i)) - character'pos('0')); i:= i + 1; END LOOP; IF data.encoded_data(i) /= '*' THEN i := i - 1; END IF; LOOP i := i + 1; j := j + 1; CASE data.encoded_data(i) IS WHEN '^' => i := i + 1; store_temp (j) := character'val(character'pos( data.encoded_data(i))-64); WHEN '\' => i := i + 1; CASE data.encoded_data(i) IS WHEN 'e'|'E' => store_temp(j) := character'val(27); --ESC WHEN '^' => store_temp(j) := '^'; WHEN 'n'|'N' => store_temp(j) := character'val(10); --LF WHEN '\' => store_temp(j) := '\'; WHEN 'r'|'R' => store_temp(j) := character'val(13); --CR WHEN 't'|'T' => store_temp(j) := character'val(9); -- TAB WHEN 'b'|'B' => store_temp(j) := character'val(8); -- BS WHEN 'f'|'F' => store_temp(j) := character'val(12); -- FF WHEN OTHERS => -- must be an octal number store_octal := 0; WHILE (data.encoded_data(i) IN '0'..'7' ) LOOP store_octal := (store_octal * 8) + (character'pos(data.encoded_data(i))- character'pos('0')); i := i + 1; END LOOP; i := i - 1; store_temp(j) := character'val(store_octal); END CASE; WHEN OTHERS => store_temp(j) := data.encoded_data(i); END CASE; EXIT WHEN i = data.encoded_data_length; END LOOP; data.encoded_data_length := j; FOR j IN 1..data.encoded_data_length LOOP data.encoded_data(j) := store_temp(j); END LOOP; END decode_entry; -- ----------------------------------------------------------------------------- BEGIN -- store_entry -- scan the termcap entry to determine if it is an value assignment(#), -- a boolean value(:), or an escape sequence to decode (=). position := position + 2; CASE termcap_entry(position) IS WHEN '=' => position := position + 1; -- position on the first character i := 1; WHILE termcap_entry(position) /= ':' LOOP termcap_operations(entry1).encoded_data(i) := termcap_entry(position); i := i + 1; position := position + 1; END LOOP; termcap_operations(entry1).encoded_data_length := i - 1; decode_entry(termcap_operations(entry1)); WHEN ':' => termcap_operations(entry1).bool_parameter := true; WHEN '#' => LOOP position := position + 1; termcap_operations(entry1).parameter := (termcap_operations(entry1).parameter * 10) + (character'pos(termcap_entry(position)) - character'pos('0')); EXIT WHEN NOT (termcap_entry(position+1) IN '0'..'9'); END LOOP; position := position + 1; WHEN OTHERS => null; END CASE; END store_entry; -- ------------------------------------------------------------------------- BEGIN -- get_termcap_entries_fields -- initialize data structures that will hold termcap entries to default values. initialize_termcap_entry_fields; i := 1; -- associate terminal capabilties to appropriate data structures WHILE i < entry_length LOOP IF ( termcap_entry( i ) = ':' ) AND ( termcap_entry( i + 1) /= '\' ) THEN j := field_entries_list'first - 2; i := i + 1; LOOP j := j + 2; EXIT WHEN ( j >= field_entries_list'last ) OR ELSE ((termcap_entry( i ) = field_entries_list ( j )) AND (termcap_entry(i+1) = field_entries_list (j+1))); END LOOP; IF j < field_entries_list'last THEN CASE j IS WHEN 1 => store_entry( cd,i); WHEN 3 => store_entry(ce,i); WHEN 5 => store_entry(cm,i); WHEN 7 => store_entry(i_s,i); WHEN 9 => store_entry(al,i); WHEN 11 => store_entry(dl,i); WHEN 13 => store_entry(dc,i); WHEN 15 => store_entry(vb,i); WHEN 17 => store_entry(nl,i); WHEN 19 => store_entry(so,i); WHEN 21 => store_entry(im,i); WHEN 23 => store_entry(ei,i); WHEN 25 => store_entry(sf,i); WHEN 27 => store_entry(sr,i); WHEN 29 => store_entry(l1,i); WHEN 31 => store_entry(l2,i); WHEN 33 => store_entry(l3,i); WHEN 35 => store_entry(l4,i); WHEN 37 => store_entry(l5,i); WHEN 39 => store_entry(l6,i); WHEN 41 => store_entry(l7,i); WHEN 43 => store_entry(l8,i); WHEN 45 => store_entry(l9,i); WHEN 47 => store_entry(y0,i); WHEN 49 => store_entry(y1,i); WHEN 51 => store_entry(y2,i); WHEN 53 => store_entry(y3,i); WHEN 55 => store_entry(y4,i); WHEN 57 => store_entry(y5,i); WHEN 59 => store_entry(y6,i); WHEN 61 => store_entry(y7,i); WHEN 63 => store_entry(y8,i); WHEN 65 => store_entry(y9,i); WHEN 67 => store_entry(h0,i); WHEN 69 => store_entry(h1,i); WHEN 71 => store_entry(h2,i); WHEN 73 => store_entry(h3,i); WHEN 75 => store_entry(h4,i); WHEN 77 => store_entry(h5,i); WHEN 79 => store_entry(h6,i); WHEN 81 => store_entry(h7,i); WHEN 83 => store_entry(h8,i); WHEN 85 => store_entry(h9,i); WHEN 87 => store_entry(v0,i); WHEN 89 => store_entry(v1,i); WHEN 91 => store_entry(v2,i); WHEN 93 => store_entry(ku,i); WHEN 95 => store_entry(kd,i); WHEN 97 => store_entry(kl,i); WHEN 99 => store_entry(kr,i); WHEN 101 => store_entry(k1,i); WHEN 103 => store_entry(k2,i); WHEN 105 => store_entry(k3,i); WHEN 107 => store_entry(k4,i); WHEN 109 => store_entry(k5,i); WHEN 111 => store_entry(k6,i); WHEN 113 => store_entry(k7,i); WHEN 115 => store_entry(k8,i); WHEN 117 => store_entry(k9,i); WHEN 119 => store_entry(x0,i); WHEN 121 => store_entry(x1,i); WHEN 123 => store_entry(x2,i); WHEN 125 => store_entry(x3,i); WHEN 127 => store_entry(x4,i); WHEN 129 => store_entry(x5,i); WHEN 131 => store_entry(x6,i); WHEN 133 => store_entry(x7,i); WHEN 135 => store_entry(x8,i); WHEN 137 => store_entry(x9,i); WHEN 139 => store_entry(g0,i); WHEN 141 => store_entry(g1,i); WHEN 143 => store_entry(g2,i); WHEN 145 => store_entry(g3,i); WHEN 147 => store_entry(g4,i); WHEN 149 => store_entry(g5,i); WHEN 151 => store_entry(g6,i); WHEN 153 => store_entry(g7,i); WHEN 155 => store_entry(g8,i); WHEN 157 => store_entry(g9,i); WHEN 159 => store_entry(t0,i); WHEN 161 => store_entry(t1,i); WHEN 163 => store_entry(t2,i); WHEN 165 => store_entry(wr,i); WHEN 167 => store_entry(su,i); WHEN 169 => store_entry(li,i); WHEN 171 => store_entry(se,i); WHEN 173 => store_entry(an,i); WHEN 175 => store_entry(vt,i); WHEN 177 => store_entry(ca,i); WHEN 179 => store_entry(cl,i); WHEN 181 => store_entry(ds,i); WHEN 183 => store_entry(co,i); WHEN OTHERS => null; END CASE; END IF; ELSE i := i + 1; END IF; END LOOP; END get_termcap_entry_fields; -- ------------------------------------------------------------------- -- open the TCF PROCEDURE inittcf is BEGIN -- inittcf text_io.open(termcap_file,text_io.in_file,term_file(1..tcf_last)); EXCEPTION WHEN OTHERS => RAISE tcf_error; END inittcf; -- -------------------------------------------------------------------- BEGIN -- initialize -- determine if user supplied terminal name -- if not, call sysdep.terminal_name to get default terminal_name. IF ((name'last - name'first) = 3 ) AND THEN name(name'first..name'first+3) = "none" THEN sysdep.terminal_name(term_name,term_name_last); ELSE term_name(1..name'length) := name; term_name_last := name'length; END IF; -- find the name of the tcf sysdep.tcf_name(term_file,tcf_last); -- open the tcf inittcf; found := false; -- search the tcf for the terminal name passed in WHILE (NOT found) AND (NOT text_io.end_of_file( termcap_file)) LOOP LOOP text_io.get_line( termcap_file, read_buffer, i ); EXIT WHEN ((read_buffer( 1 ) /= ' ') AND (read_buffer( 1 ) /= character'val(9)) AND (read_buffer( 1 ) /= '#')) OR text_io.end_of_file( termcap_file ); END LOOP; i := 0; LOOP i := i + 1; EXIT WHEN ( read_buffer( i ) = '|' ) OR ( read_buffer( i ) = ':' ); END LOOP; IF read_buffer( i ) /= ':' THEN i := i + 1; j := term_name'first; continue := true; WHILE (j <= term_name_last) AND continue LOOP IF read_buffer( i ) /= term_name( j ) THEN continue := false; END IF; j := j + 1; i := i + 1; END LOOP; IF (read_buffer ( i ) = '|' ) AND continue THEN found := true; END IF; END IF; END LOOP; -- found terminal name IF found THEN k := 1; text_io.get_line( termcap_file, read_buffer, i ); WHILE (read_buffer( 1 ) = ' ') OR (read_buffer( 1 ) = character'val(9)) LOOP FOR j IN 1..i LOOP termcap_entry( k ) := read_buffer( j ); k := k + 1; END LOOP; text_io.get_line( termcap_file, read_buffer, i); IF text_io.end_of_line( termcap_file ) THEN read_buffer( 1 ) := '#'; END IF; END LOOP; get_termcap_entry_fields(k); IF termcap_operations(i_s).encoded_data_length /= 0 THEN sysdep.put(termcap_operations(i_s).encoded_data(1.. termcap_operations(i_s).encoded_data_length)); END IF; ELSE -- couldn't find terminal name in tcf file, raise exception RAISE unsupported_terminal; END IF; EXCEPTION WHEN text_io.end_error => raise unsupported_terminal; WHEN unsupported_terminal => raise; WHEN tcf_error => raise; WHEN OTHERS => RAISE tcf_error; END initialize; END tcf; :::::::::: driver_body.ada :::::::::: -- ---------------------------------------------------------------------------- -- ABSTRACT: The DRIVER package performs the following functions: -- * initialize the actual terminal, -- * initialize the TCF, -- * interpret the ANSI compatible character codes and -- translate them into device specific character codes, -- * close the actual terminal. -- ----------------------------------------------------------------------------- WITH sysdep, text_io, tcf; PACKAGE BODY driver IS out_buffer : STRING(1..1920); initialized : BOOLEAN := false; PROCEDURE vt_initialize( name : IN string; lines : OUT integer; columns: OUT integer ) is -- open the virtual terminal by calling sysdep.open -- initialize the virtual terminal by calling tcf.initialize -- passing the name of the terminal as a parameter. -- associate the terminal characteristics to the -- supported functions variable. BEGIN -- virtual_terminal_initialize -- initialize the terminal sysdep.open; tcf.initialize(name); lines := tcf.termcap_operations(tcf.li).parameter; columns := tcf.termcap_operations(tcf.co).parameter; supported_functions := terminal_capabilities_set'(erase_to_end_of_screen_is ..insert_mode_is => false); IF tcf.termcap_operations(tcf.cd).encoded_data_length > 0 then supported_functions(erase_to_end_of_screen_is) := true; END IF; IF tcf.termcap_operations(tcf.ce).encoded_data_length > 0 THEN supported_functions(erase_to_end_of_line_is) := true; END IF; IF tcf.termcap_operations(tcf.cm).encoded_data_length > 0 THEN supported_functions(move_the_cursor_is) := true; END IF; IF tcf.termcap_operations(tcf.al).encoded_data_length > 0 THEN supported_functions(insert_line_is) := true; END IF; IF tcf.termcap_operations(tcf.dl).encoded_data_length > 0 THEN supported_functions(delete_line_is) := true; END IF; IF tcf.termcap_operations(tcf.dc).encoded_data_length > 0 THEN supported_functions(delete_character_is) := true; END IF; IF tcf.termcap_operations(tcf.vb).encoded_data_length > 0 THEN supported_functions(beep_is) := true; END IF; IF tcf.termcap_operations(tcf.so).encoded_data_length > 0 THEN supported_functions(highlight_is) := true; END IF; IF tcf.termcap_operations(tcf.im).encoded_data_length > 0 THEN supported_functions(insert_mode_is) := true; END IF; IF tcf.termcap_operations(tcf.ca).encoded_data_length > 0 THEN supported_functions(erase_all_of_display_is) := true; END IF; IF tcf.termcap_operations(tcf.cl).encoded_data_length > 0 THEN supported_functions(erase_all_of_line_is) := true; END IF; IF tcf.termcap_operations(tcf.nl).encoded_data_length > 0 THEN supported_functions(new_line_is) := true; END IF; -- successful opening of terminal. initialized := true; EXCEPTION -- unsuccessful initialization of terminal WHEN tcf.unsupported_terminal => RAISE unsupported_terminal; WHEN tcf.tcf_error => RAISE tcf_error; WHEN OTHERS => RAISE uninitialized; END vt_initialize; PROCEDURE close_virtual_terminal is -- close the virtual terminal by calling sysdep.close BEGIN -- close_virtual_terminal initialized := false; IF tcf.termcap_operations(tcf.ds).encoded_data_length /= 0 THEN sysdep.put(tcf.termcap_operations(tcf.ds).encoded_data(1.. tcf.termcap_operations(tcf.ds).encoded_data_length)); END IF; sysdep.close; END close_virtual_terminal; -- ------------------------------------------------------------------------- PROCEDURE erase_to_end_of_screen( pos : IN OUT INTEGER ) IS BEGIN -- erase_to_end_of_screen pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.cd).encoded_data_length-1)) := tcf.termcap_operations(tcf.cd).encoded_data(1..tcf.termcap_operations( tcf.cd).encoded_data_length); pos := pos + (tcf.termcap_operations(tcf.cd).encoded_data_length-1); END erase_to_end_of_screen; -- --------------------------------------------------------------------------- PROCEDURE erase_all_of_display( pos : IN OUT INTEGER ) IS BEGIN -- erase_all_of_display pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.cl).encoded_data_length-1)) := tcf.termcap_operations(tcf.cl).encoded_data(1..tcf.termcap_operations( tcf.cl).encoded_data_length); pos := pos + (tcf.termcap_operations(tcf.cl).encoded_data_length-1); END erase_all_of_display; -- ----------------------------------------------------------------------------- PROCEDURE erase_all_of_line( pos : IN OUT INTEGER ) IS BEGIN -- erase_all_of_line pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.ca).encoded_data_length-1)) := tcf.termcap_operations(tcf.ca).encoded_data(1..tcf.termcap_operations( tcf.ca).encoded_data_length); pos := pos + (tcf.termcap_operations(tcf.ca).encoded_data_length-1); END erase_all_of_line; -- ----------------------------------------------------------------------------- PROCEDURE erase_to_end_of_line( pos : IN OUT INTEGER) IS BEGIN -- erase_to_end_of_line pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.ce).encoded_data_length-1)) := tcf.termcap_operations(tcf.ce).encoded_data(1..tcf.termcap_operations( tcf.ce).encoded_data_length); pos := pos + (tcf.termcap_operations(tcf.ce).encoded_data_length-1); END erase_to_end_of_line; -- ----------------------------------------------------------------------------- PROCEDURE move_the_cursor_to(p_x : IN positive; p_y : IN positive; pos : IN OUT INTEGER ) IS digit_width : CONSTANT integer := 5; SUBTYPE digit_array IS string(1..digit_width); exchange : integer; i,j : integer; x,y : integer; xdigits,ydigits : digit_array; processedx,processedy : boolean; hold : integer; -- ------------------------------------------------------------------- PROCEDURE to_digits(p_value : IN integer; result : IN OUT digit_array ) IS leftover, value, saved : INTEGER; i,j,result_index : INTEGER; BEGIN -- to_digits value := p_value; FOR i IN 1..digit_width LOOP result(i) := '0'; END LOOP; result_index := digit_width; WHILE value > 0 LOOP saved := value; value := value / 10; leftover := saved - (value*10); result(result_index) := character'val(leftover + character'pos('0')); result_index := result_index - 1; END LOOP; END to_digits; -- --------------------------------------------------------------------- BEGIN -- move_the_cursor_to x := p_x - 1; y := p_y - 1; hold := pos; processedx := false; processedy := false; i := 0; LOOP i := i + 1; IF tcf.termcap_operations(tcf.cm).encoded_data(i) /= '%' THEN pos := pos + 1; out_buffer(pos) := tcf.termcap_operations(tcf.cm).encoded_data(i); ELSE i := i + 1; CASE tcf.termcap_operations(tcf.cm).encoded_data(i) IS WHEN '2' => IF NOT processedx THEN to_digits(x,xdigits); FOR j IN digit_width-1..digit_width LOOP pos := pos+1; out_buffer(pos) := xdigits(j); END LOOP; processedx := true; ELSE to_digits(y,ydigits); FOR j IN digit_width-1..digit_width LOOP pos := pos + 1; out_buffer(pos) := ydigits(j); END LOOP; processedy := true; END IF; WHEN '3' => IF NOT processedx THEN to_digits(x,xdigits); FOR j In digit_width-2..digit_width LOOP pos := pos + 1; out_buffer(pos) := xdigits(j); END LOOP; processedx := true; ELSE to_digits(y,ydigits); FOR j IN digit_width-2..digit_width LOOP pos := pos + 1; out_buffer(pos) := ydigits(j); END LOOP; processedy := true; END IF; WHEN '.' => IF NOT processedx THEN pos := pos + 1; out_buffer(pos) :=character'val(x); processedx := true; ELSE pos := pos + 1; out_buffer(pos) := character'val(y); processedy := true; END IF; WHEN '+' => IF NOT processedx THEN i := i + 1; pos := pos + 1; out_buffer(pos) := character'val(x+character'pos( tcf.termcap_operations(tcf.cm). encoded_data(i))); processedx := true; ELSE i := i + 1; pos := pos + 1; out_buffer(pos) := character'val(y+character'pos( tcf.termcap_operations(tcf.cm). encoded_data(i))); processedy := true; END IF; WHEN '<' => IF NOT processedx THEN i := i + 1; IF x < character'pos( tcf.termcap_operations(tcf.cm).encoded_data(i)) THEN pos := pos + 1; out_buffer(pos) := character'val(x +(character'pos( tcf.termcap_operations(tcf.cm). encoded_data(i+1)))); processedx := true; i := i + 1; ELSE pos := pos + 1; out_buffer(pos) := character'val(x); processedx := true; i := i + 1; END IF; ELSE i := i + 1; IF y < character'pos( tcf.termcap_operations(tcf.cm).encoded_data(i)) THEN pos := pos + 1; out_buffer(pos) := character'val(y+(character'pos( tcf.termcap_operations(tcf.cm). encoded_data(i+1)))); processedy := true; i := i + 1; ELSE pos := pos + 1; out_buffer(pos) := character'val(x); processedy := true; i := i + 1; END IF; END IF; WHEN 'r' => exchange := x; x := y; y := exchange; WHEN 'i' => x := x+1; y := y + 1; WHEN '%' => pos := pos + 1; out_buffer(pos) := '%'; WHEN 'd' => IF NOT processedx THEN to_digits(x,xdigits); -- scan for leading zeroes j := 1; WHILE(xdigits(j) = '0') LOOP j := j + 1; END LOOP; -- found first significant digit FOR k IN j..digit_width LOOP pos := pos + 1; out_buffer(pos) := xdigits(k); END LOOP; processedx := true; ELSE j := 1; to_digits(y,ydigits); WHILE(ydigits(j) = '0') LOOP j := j + 1; END LOOP; FOR k IN j..digit_width LOOP pos := pos + 1; out_buffer(pos) := ydigits(k); END LOOP; processedy := true; END IF; WHEN OTHERS => null; END CASE; END IF; EXIT WHEN i=tcf.termcap_operations(tcf.cm).encoded_data_length; END LOOP; END move_the_cursor_to; -- ----------------------------------------------------------------------------- PROCEDURE insert_line( pos : IN OUT INTEGER; p_num : IN OUT INTEGER ) IS BEGIN -- insert_line WHILE p_num /= 0 LOOP pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.al).encoded_data_length-1)) := tcf.termcap_operations(tcf.al).encoded_data(1.. tcf.termcap_operations(tcf.al).encoded_data_length); p_num := p_num - 1; pos := pos +(tcf.termcap_operations(tcf.al).encoded_data_length-1); END LOOP; END insert_line; -- ----------------------------------------------------------------------------- PROCEDURE delete_line( pos : IN OUT INTEGER; p_num : IN OUT INTEGER ) IS BEGIN -- delete_line WHILE p_num /= 0 LOOP pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.dl).encoded_data_length-1)) := tcf.termcap_operations(tcf.dl).encoded_data(1.. tcf.termcap_operations(tcf.dl).encoded_data_length); p_num := p_num - 1; pos := pos +(tcf.termcap_operations(tcf.dl).encoded_data_length-1); END LOOP; END delete_line; -- ----------------------------------------------------------------------------- PROCEDURE delete_character( pos : IN OUT INTEGER; p_num : IN OUT INTEGER ) IS BEGIN -- delete_character WHILE p_num /= 0 LOOP pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.dc).encoded_data_length-1)) := tcf.termcap_operations(tcf.dc).encoded_data(1.. tcf.termcap_operations(tcf.dc).encoded_data_length); p_num := p_num - 1; pos := pos +(tcf.termcap_operations(tcf.dc).encoded_data_length-1); END LOOP; END delete_character; -- ----------------------------------------------------------------------------- PROCEDURE beep( pos : IN OUT INTEGER ) IS BEGIN -- beep pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.vb).encoded_data_length-1)) := tcf.termcap_operations(tcf.vb).encoded_data(1..tcf.termcap_operations( tcf.vb).encoded_data_length); pos := pos +(tcf.termcap_operations(tcf.vb).encoded_data_length-1); END beep; -- ---------------------------------------------------------------------------- PROCEDURE new_line( pos : IN OUT INTEGER ) IS BEGIN -- new_line pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.nl).encoded_data_length-1)) := tcf.termcap_operations(tcf.nl).encoded_data(1..tcf.termcap_operations( tcf.nl).encoded_data_length); pos := pos +(tcf.termcap_operations(tcf.nl).encoded_data_length-1); END new_line; -- ----------------------------------------------------------------------------- PROCEDURE turn_on_highlighting( pos : IN OUT INTEGER ) IS BEGIN -- turn_on_highlighting pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.so).encoded_data_length-1)) := tcf.termcap_operations(tcf.so).encoded_data(1..tcf.termcap_operations( tcf.so).encoded_data_length); pos := pos + (tcf.termcap_operations(tcf.so).encoded_data_length-1); END turn_on_highlighting; -- ----------------------------------------------------------------------------- PROCEDURE turn_off_highlighting( pos : IN OUT INTEGER ) IS BEGIN -- turn_off_highlighting pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.se).encoded_data_length-1)) := tcf.termcap_operations(tcf.se).encoded_data(1..tcf.termcap_operations( tcf.se).encoded_data_length); pos := pos + (tcf.termcap_operations(tcf.se).encoded_data_length-1); END turn_off_highlighting; -- --------------------------------------------------------------------------- PROCEDURE enter_insert_mode( pos : IN OUT INTEGER ) IS BEGIN -- enter_insert_mode pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.im).encoded_data_length-1)) := tcf.termcap_operations(tcf.im).encoded_data(1..tcf.termcap_operations( tcf.im).encoded_data_length); pos := pos + (tcf.termcap_operations(tcf.im).encoded_data_length-1); END enter_insert_mode; -- ---------------------------------------------------------------------------- PROCEDURE exit_insert_mode( pos : IN OUT INTEGER ) IS BEGIN -- exit_insert_mode pos := pos + 1; out_buffer(pos..pos+(tcf.termcap_operations(tcf.ei).encoded_data_length-1)) := tcf.termcap_operations(tcf.ei).encoded_data(1..tcf.termcap_operations( tcf.ei).encoded_data_length); pos := pos + (tcf.termcap_operations(tcf.ei).encoded_data_length-1); END exit_insert_mode; -- --------------------------------------------------------------------------- PROCEDURE interpret ( command_string : IN string ) IS j,k,x : INTEGER; param : INTEGER; found : BOOLEAN; param2 : INTEGER; ansi_CSI : CONSTANT STRING (1..2) := ascii.esc & '['; ansi_EDe : CONSTANT STRING (1..2) := "0J"; ansi_EDa : CONSTANT STRING (1..2) := "2J"; ansi_ELe : CONSTANT STRING (1..2) := "0K"; ansi_ELa : CONSTANT STRING (1..2) := "2K"; ansi_SGP : CONSTANT STRING (1..2) := "0m"; ansi_SGR : CONSTANT STRING (1..2) := "7m"; ansi_IMs : CONSTANT STRING (1..2) := "4h"; ansi_IMr : CONSTANT STRING (1..2) := "4l"; -- ----------------------------------------------------------------------------- PROCEDURE get_number(c_str : IN string; last_pos : IN OUT integer; result : OUT integer) IS c_p : integer; BEGIN -- get_number c_p := last_pos + 1; WHILE (c_str(c_p) IN '0'..'9' AND c_p /= c_str'last) LOOP c_p := c_p + 1; END LOOP; c_p := c_p - 1; result := INTEGER'VALUE(c_str(last_pos..c_p)); last_pos := c_p; END get_number; -- -------------------------------------------------------------------------- -- scan incoming for incoming ansi sequences, map to terminal specific -- sequences, and put to terminal. BEGIN -- interpret IF NOT initialized THEN RAISE uninitialized; END IF; IF tcf.termcap_operations(tcf.an).bool_parameter = true THEN sysdep.put(command_string); GOTO exit_quick; END IF; j := 1; x := 0; k := 0; -- check for end of the command string WHILE ((j-1) /= command_string'last ) LOOP -- scan for esc character IF command_string(j) = ascii.esc AND j /= command_string'last THEN -- have esc, start of ansi sequence -- mark position of esc character with variable k k := j; -- check next position for [ IF command_string(j+1) = '[' -- have CSI THEN j := j + 2; IF command_string(j) IN '0'..'9' THEN get_number(command_string,j,param); j := j + 1; -- match against ansi constants IF command_string(k+2..j) = ANSI_ELe THEN -- check to see if function is supported by the vt IF supported_functions(erase_to_end_of_line_is) = true THEN erase_to_end_of_line(x); j := j + 1; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSIF command_string(k+2..j) = ANSI_ELa THEN IF supported_functions(erase_all_of_line_is) = true THEN erase_all_of_line(x); j := j + 1; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSIF command_string(k+2..j) = ANSI_EDe THEN IF supported_functions(erase_to_end_of_screen_is) = true THEN erase_to_end_of_screen(x); j := j + 1; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSIF command_string(k+2..j) = ANSI_EDa THEN IF supported_functions(erase_all_of_display_is)= true AND supported_functions(move_the_cursor_is) = true THEN move_the_cursor_to(1,1,x); erase_all_of_display(x); j := j + 1; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSIF command_string(k+2..j) = ANSI_SGP THEN IF supported_functions(highlight_is) = true THEN turn_off_highlighting(x); j := j + 1; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSIF command_string(k+2..j) = ANSI_SGR THEN IF supported_functions(highlight_is) = true THEN turn_on_highlighting(x); j := j + 1; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSIF command_string(k+2..j) = ANSI_IMs THEN IF supported_functions(insert_mode_is) = true THEN enter_insert_mode(x); j := j + 1; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSIF command_string(k+2..j) = ANSI_IMr THEN IF supported_functions(insert_mode_is) = true THEN exit_insert_mode(x); j := j + 1; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSIF command_string(j) = 'P' THEN IF supported_functions(delete_character_is) = true THEN delete_character(x,param); j := j + 1; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSIF command_string(j) = 'M' THEN IF supported_functions(delete_line_is) = true THEN delete_line(x,param); j := j + 1; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSIF command_string(j) = 'L' THEN IF supported_functions(insert_line_is) = true THEN insert_line(x,param); j := j + 1; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSIF command_string(j) = ';' THEN j := j + 1; get_number(command_string,j,param2); j := j + 1; IF command_string(j) = 'H' THEN IF supported_functions(move_the_cursor_is) = true THEN move_the_cursor_to(param,param2,x); j := j + 1; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSE x := x + 1; out_buffer(x..j) := command_string(k..j); x := j; j := j + 1; END IF; ELSE -- have esc[non-numeric junk x := x + 1; out_buffer(x..j-1) := command_string(k..j-1); x := j - 1; END IF; ELSE -- have esc+junk x := x + 1; out_buffer(x) := command_string(k); j := j + 1; END IF; -- if not an ansi sequence put in output buffer ELSE -- no esc, check for bell IF command_string(j) = ascii.bel THEN -- have bell IF supported_functions(beep_is) = true THEN -- bell supported beep(x); j := j + 1; ELSE x := x + 1; out_buffer(x) := command_string(j); j := j + 1; END IF; ELSIF command_string(j) = ascii.lf THEN -- have a line feed IF supported_functions(new_line_is) = true THEN new_line(x); j := j + 1; ELSE x := x + 1; out_buffer(x) := command_string(j); j := j + 1; END IF; ELSE x := x + 1; out_buffer(x) := command_string(j); j := j + 1; END IF; END IF; END LOOP; -- check for anything left in output buffer and put to screen IF x > 0 THEN sysdep.put(out_buffer(1..x)); -- blank out buffer out_buffer := string'(out_buffer'first..out_buffer'last => ' '); END IF; <<exit_quick>> null; EXCEPTION WHEN tcf.tcf_error => RAISE tcf_error; WHEN tcf.unsupported_terminal => RAISE unsupported_terminal; END interpret; END driver; :::::::::: vtinput_body.ada :::::::::: -- ----------------------------------------------------------------------------- -- ABSTRACT: This package provides an interface to get keystrokes from the -- actual terminals keyboard. The keystrokes include regular ASCII -- keys and function keys (including the arrow keys). The function -- and arrow keys are identified throught the use of the terminal -- capabilities data base. There can be up to 32 function keys. -- There will always be 4 arrow keys. -- ----------------------------------------------------------------------------- WITH tcf, sysdep; PACKAGE BODY vt_input IS initialized : boolean := false; function_key_count : natural := 0; current_function_key : natural; PRAGMA page; PROCEDURE get( data : OUT string; last : OUT natural; keys : IN OUT function_key_descriptor; timeout : IN duration := duration'last ) IS max_string : CONSTANT positive := 80; SUBTYPE work_string IS string( 1..max_string ); tty_last : natural; tty_string : work_string; pos : natural := 0; remainder : work_string; remainder_last : natural := 0; f_key : function_key_enum; temp_last : natural := 0; char : character; -- ---------------- PROCEDURE next_character ( pos : IN OUT natural; char : OUT character ) IS BEGIN IF pos = 0 THEN sysdep.get( tty_string, tty_last ); pos := 1; END IF; IF pos <= tty_last THEN char := tty_string( pos ); pos := pos + 1; ELSE sysdep.get( tty_string, tty_last ); pos := 1; next_character( pos, char ); END IF; END next_character; -- ---------------- FUNCTION last_character( pos : IN natural ) RETURN boolean IS BEGIN IF pos > tty_last THEN RETURN true; ELSE RETURN false; END IF; END last_character; -- ---------------- PROCEDURE check_function_key ( data : IN string; current_position : IN OUT tcf.key_range; found : OUT boolean; more : OUT boolean ) IS BEGIN more := false; found := false; FOR i IN current_position..tcf.key_range'LAST LOOP IF (tcf.termcap_operations( i ).encoded_data_length >= data'LENGTH) AND THEN (tcf.termcap_operations( i ). encoded_data( 1..data'LENGTH ) = data) THEN IF tcf.termcap_operations( i ).encoded_data_length = data'LENGTH THEN more := false; -- finished, no more left found := true; -- It is good ELSE more := true; -- more to come, candidate is found found := false; -- not done yet END IF; current_position := i; EXIT; END IF; END LOOP; END check_function_key; -- ---------------- PROCEDURE get_function_key ( remainder : IN OUT string; rem_last : IN OUT natural; f_key : IN OUT function_key_enum ) IS candidate_key : boolean; finished : boolean; key_position : tcf.key_range := tcf.key_range'FIRST; char : character; BEGIN next_character( pos, char ); rem_last := 1; remainder( rem_last ) := char; check_function_key( remainder( 1..rem_last ), key_position, finished, candidate_key ); WHILE (NOT finished) AND candidate_key LOOP next_character( pos, char ); rem_last := rem_last + 1; remainder( rem_last ) := char; check_function_key( remainder( 1..rem_last ), key_position, finished, candidate_key ); END LOOP; IF finished AND (NOT candidate_key) THEN -- found a function key CASE key_position IS WHEN tcf.ku => f_key := up_arrow; WHEN tcf.kd => f_key := down_arrow; WHEN tcf.kl => f_key := left_arrow; WHEN tcf.kr => f_key := right_arrow; WHEN tcf.k1 => f_key := f1; WHEN tcf.k2 => f_key := f2; WHEN tcf.k3 => f_key := f3; WHEN tcf.k4 => f_key := f4; WHEN tcf.k5 => f_key := f5; WHEN tcf.k6 => f_key := f6; WHEN tcf.k7 => f_key := f7; WHEN tcf.k8 => f_key := f8; WHEN tcf.k9 => f_key := f9; WHEN tcf.x0 => f_key := f10; WHEN tcf.x1 => f_key := f11; WHEN tcf.x2 => f_key := f12; WHEN tcf.x3 => f_key := f13; WHEN tcf.x4 => f_key := f14; WHEN tcf.x5 => f_key := f15; WHEN tcf.x6 => f_key := f16; WHEN tcf.x7 => f_key := f17; WHEN tcf.x8 => f_key := f18; WHEN tcf.x9 => f_key := f19; WHEN tcf.g0 => f_key := f20; WHEN tcf.g1 => f_key := f21; WHEN tcf.g2 => f_key := f22; WHEN tcf.g3 => f_key := f23; WHEN tcf.g4 => f_key := f24; WHEN tcf.g5 => f_key := f25; WHEN tcf.g6 => f_key := f26; WHEN tcf.g7 => f_key := f27; WHEN tcf.g8 => f_key := f28; WHEN tcf.g9 => f_key := f29; WHEN tcf.t0 => f_key := f30; WHEN tcf.t1 => f_key := f31; WHEN tcf.t2 => f_key := f32; WHEN OTHERS => NULL; END CASE; rem_last := 0; END IF; END get_function_key; -- ---------------- PROCEDURE store_data_string ( in_data : IN string ) IS BEGIN data( temp_last+1..temp_last+in_data'LENGTH ) := in_data; temp_last := temp_last + in_data'LENGTH; END store_data_string; -- ---------------- PROCEDURE store_f_key ( f_key : IN function_key_enum ) IS BEGIN keys.no_of_keys := keys.no_of_keys + 1; keys.keys( keys.no_of_keys ).key := f_key; keys.keys( keys.no_of_keys ).position := temp_last + 1; END store_f_key; -- ---------------- BEGIN -- get keys.no_of_keys := 0; LOOP get_function_key( remainder, remainder_last, f_key ); IF remainder_last /= 0 THEN store_data_string( remainder( 1..remainder_last ) ); ELSE store_f_key( f_key ); END IF; EXIT WHEN last_character( pos ); END LOOP; last := temp_last; END get; PRAGMA page; FUNCTION function_count(keys : IN function_key_descriptor) RETURN natural IS BEGIN RETURN keys.no_of_keys; END function_count; PRAGMA page; PROCEDURE function_key(keys : IN function_key_descriptor; index : IN positive; key_identifier : OUT function_key_enum; previous_position : OUT natural) IS BEGIN key_identifier := keys.keys( index ).key; previous_position := keys.keys( index ).position; END function_key; PRAGMA page; PROCEDURE function_key_name ( key_identifier : IN function_key_enum; key_name : OUT string; last : OUT natural) IS temp_key : tcf.termcap_entries_enum; temp_last : natural; up_name : CONSTANT string := "Up Arrow"; down_name : CONSTANT string := "Down Arrow"; right_name : CONSTANT string := "Right Arrow"; left_name : CONSTANT string := "Left Arrow"; BEGIN IF key_identifier IN f1..f32 THEN CASE key_identifier IS WHEN f1 => temp_key := tcf.l1; WHEN f2 => temp_key := tcf.l2; WHEN f3 => temp_key := tcf.l3; WHEN f4 => temp_key := tcf.l4; WHEN f5 => temp_key := tcf.l5; WHEN f6 => temp_key := tcf.l6; WHEN f7 => temp_key := tcf.l7; WHEN f8 => temp_key := tcf.l8; WHEN f9 => temp_key := tcf.l9; WHEN f10 => temp_key := tcf.y0; WHEN f11 => temp_key := tcf.y1; WHEN f12 => temp_key := tcf.y2; WHEN f13 => temp_key := tcf.y3; WHEN f14 => temp_key := tcf.y4; WHEN f15 => temp_key := tcf.y5; WHEN f16 => temp_key := tcf.y6; WHEN f17 => temp_key := tcf.y7; WHEN f18 => temp_key := tcf.y8; WHEN f19 => temp_key := tcf.y9; WHEN f20 => temp_key := tcf.h0; WHEN f21 => temp_key := tcf.h1; WHEN f22 => temp_key := tcf.h2; WHEN f23 => temp_key := tcf.h3; WHEN f24 => temp_key := tcf.h4; WHEN f25 => temp_key := tcf.h5; WHEN f26 => temp_key := tcf.h6; WHEN f27 => temp_key := tcf.h7; WHEN f28 => temp_key := tcf.h8; WHEN f29 => temp_key := tcf.h9; WHEN f30 => temp_key := tcf.v0; WHEN f31 => temp_key := tcf.v1; WHEN f32 => temp_key := tcf.v2; WHEN OTHERS => NULL; END CASE; temp_last := key_name'first + tcf.termcap_operations( temp_key ).encoded_data_length - 1; IF temp_last /= 0 THEN key_name( key_name'first..key_name'first + tcf.termcap_operations( temp_key ).encoded_data_length - 1 ) := tcf.termcap_operations( temp_key ).encoded_data( 1..tcf.termcap_operations( temp_key ).encoded_data_length ); END IF; ELSE CASE key_identifier IS WHEN up_arrow => key_name( key_name'first.. key_name'first+up_name'last-up_name'first ) := up_name; temp_last := up_name'last - up_name'first + 1; WHEN down_arrow => key_name( key_name'first.. key_name'first+down_name'last-down_name'first ) := down_name; temp_last := down_name'last - down_name'first + 1; WHEN left_arrow => key_name( key_name'first.. key_name'first+left_name'last-left_name'first ) := left_name; temp_last := left_name'last - left_name'first + 1; WHEN right_arrow => key_name( key_name'first.. key_name'first+right_name'last-right_name'first ) := right_name; temp_last := right_name'last - right_name'first + 1; WHEN OTHERS => NULL; END CASE; END IF; last := temp_last; END function_key_name; BEGIN -- vt_input NULL; END vt_input; :::::::::: redisp_body.ada :::::::::: -- ---------------------------------------------------------------------------- -- ABSTRACT: The REDISPLAY package WITH's the VT_CONTENT package to make the -- data structures in vt_content visible to REDISPLAY. The -- VT_CONTENT data structures describe how the image on the actual -- display looks after the REDISPLAY package is invoked and how -- the image of the actual display looks before the REDISPLAY -- is invoked. When a change is made to the data structures in -- VT_CONTENT, the image on the actual display must be udpated to -- reflect the change. -- ----------------------------------------------------------------------------- WITH vt_content, driver; USE vt_content; PACKAGE BODY redisplay IS ansi_CSI : CONSTANT string( 1..2 ) := ascii.esc & '['; -- these next three are constructed below in the appropriate procedures. -- They actually have parameters. -- -- ansi_DCH : CONSTANT string( 1..3 ) := ansi_CSI & 'P'; -- -- ansi_DL : CONSTANT string( 1..3 ) := ansi_CSI & 'M'; -- ansi_IL : CONSTANT string( 1..3 ) := ansi_CSI & 'L'; ansi_EDe : CONSTANT string( 1..4 ) := ansi_CSI & "0J"; ansi_EDs : CONSTANT string( 1..4 ) := ansi_CSI & "1J"; ansi_EDa : CONSTANT string( 1..4 ) := ansi_CSI & "2J"; ansi_ELe : CONSTANT string( 1..4 ) := ansi_CSI & "0K"; ansi_ELs : CONSTANT string( 1..4 ) := ansi_CSI & "1K"; ansi_ELa : CONSTANT string( 1..4 ) := ansi_CSI & "2K"; ansi_SGP : CONSTANT string( 1..4 ) := ansi_CSI & "0m"; ansi_SGR : CONSTANT string( 1..4 ) := ansi_CSI & "7m"; ansi_IMs : CONSTANT string( 1..4 ) := ansi_CSI & "4h"; ansi_IMr : CONSTANT string( 1..4 ) := ansi_CSI & "4l"; -- v----v----v----v----v----v----v----v -- this is a temporary for use by any procedure or function. -- it is put here for efficiency. Ideally it would go in the -- appropriate procedure or function. output_buffer : string( 1..255 ); -- ^----^----^----^----^----^----^----^ -- --------------------------------------------------------------------------- FUNCTION value_string( value : IN positive ) RETURN string IS value_image : CONSTANT string := positive'image( value ); BEGIN RETURN value_image( (value_image'first + 1)..value_image'last ); END; -- --------------------------------------------------------------------------- PROCEDURE put_the_cursor_at( row, col : IN positive ) IS ansi_buffer : CONSTANT string := string'(ansi_CSI & value_string( row ) & ";" & value_string( col ) & "H" ); BEGIN driver.interpret( ansi_buffer ); END put_the_cursor_at; PRAGMA page; -- --------------------------------------------------------------------------- PROCEDURE check_cursor ( old_screen : IN OUT vt_content.vt_content_access; line : IN positive; column : IN positive ) IS BEGIN IF old_screen.active_position /= vt_content.vt_position_xy_record'(line,column) THEN put_the_cursor_at(line,column); old_screen.active_position := vt_content.vt_position_xy_record'(line,column); END IF; END check_cursor; PRAGMA page; -- ---------------------------------------------------------------------------- PROCEDURE fix_cursor ( old_screen : IN OUT vt_content.vt_content_access; new_screen : IN OUT vt_content.vt_content_access ) IS BEGIN IF old_screen.active_position /= new_screen.active_position THEN put_the_cursor_at ( new_screen.active_position.row_position, new_screen.active_position.col_position ); old_screen.active_position := new_screen.active_position; END IF; END fix_cursor; PRAGMA page; -- -------------------------------------------------------------------------- PROCEDURE redraw_line( old_screen : IN OUT vt_content.vt_content_access; new_screen : IN vt_content.vt_content_access; old_line : IN vt_content.row_range; new_line : IN vt_content.row_range ) IS buffer_index : natural := 0; done : boolean := false; no_diff_up_front : boolean := true; no_diff_at_end : boolean := true; start_update_position : positive := 1; end_update_position : natural := new_screen.element( new_line ).length; BEGIN IF new_screen.element( new_line ).length = 0 THEN old_screen.element( old_line ).length := 0; GOTO quick_out; END IF; FOR i IN 1..new_screen.element(new_line).length LOOP IF driver.supported_functions( driver.highlight_is ) THEN IF old_screen.current_rendition /= new_screen.element( new_line ).descriptors( i ).rendition THEN CASE new_screen.element( new_line ). descriptors( i ).rendition IS WHEN vt_content.sgpr => output_buffer( buffer_index+1..buffer_index+ansi_SGP'LENGTH ) := ansi_SGP; buffer_index := buffer_index + ansi_SGP'LENGTH; WHEN vt_content.sgri => output_buffer( buffer_index+1..buffer_index+ansi_SGR'LENGTH ) := ansi_SGR; buffer_index := buffer_index + ansi_SGR'LENGTH; WHEN vt_content.sgno => NULL; END CASE; -- set the default rendition old_screen.current_rendition := new_screen.element( new_line ).descriptors( i ).rendition; END IF; END IF; -- now move the data into the output buffer buffer_index := buffer_index + 1; IF new_screen.element( new_line ).descriptors( i ).rendition = vt_content.sgno THEN output_buffer( buffer_index ) := ' '; ELSE output_buffer( buffer_index ) := new_screen.element( new_line ).data( i ); END IF; END LOOP; -- put the data out check_cursor( old_screen, new_line, start_update_position ); driver.interpret( output_buffer( 1..buffer_index ) ); IF old_screen.active_position.col_position+buffer_index > vt_content.width THEN old_screen.active_position.col_position := vt_content.width; ELSE old_screen.active_position.col_position := old_screen.active_position.col_position + buffer_index; END IF; IF old_screen.element( old_line ).length > new_screen.element( new_line ).length THEN driver.interpret( ansi_ELe ); END IF; old_screen.element( old_line ):= new_screen.element( new_line ); <<quick_out>> NULL; END redraw_line; -- ------------------------------------------------------------------------- PRAGMA page; PROCEDURE redraw_screen( old_screen : IN OUT vt_content.vt_content_access; new_screen : IN vt_content.vt_content_access; top_line : vt_content.row_range; bottom_line : vt_content.row_range ) IS BEGIN put_the_cursor_at(1,1); driver.interpret(ansi_ede); FOR i In top_line..bottom_line LOOP redraw_line( old_screen, new_screen, i ,i); END LOOP; END redraw_screen; PRAGMA page; -- ------------------------------------------------------------------------- PROCEDURE redisplay_screen_with_movement( old_screen : IN OUT vt_content.vt_content_access; new_screen : IN vt_content.vt_content_access; top_line : vt_content.row_range; bottom_line : vt_content.row_range ) IS tmp_line : positive; the_line : positive := top_line; insert_count : integer; offset : natural := 0; i : integer; -- -------------------------------------------------------------------------- PROCEDURE next_change( current_position : IN OUT positive; count : IN OUT integer ) IS BEGIN -- determine the number of lines inserted -- current_position defines the line of the last insertion count := 0; WHILE ( new_screen.element( current_position ). corresponding_line = 0 ) AND ( current_position <= bottom_line ) LOOP current_position := current_position + 1; count := count + 1; END LOOP; END next_change; -- ----------------------------------------------------------------------- PROCEDURE fix_deletes IS zero_count : integer := 0; BEGIN -- search for lines to be deleted, call driver.interpret -- to perform deletions. the_line := top_line; LOOP IF the_line /= top_line THEN -- scanning line other than top line IF new_screen.element(the_line).corresponding_line = 0 THEN -- keeps track of number of insertions zero_count := zero_count + 1; ELSIF new_screen.element(the_line).corresponding_line- new_screen.element(the_line-1).corresponding_line > 1 AND new_screen.element(the_line-1).corresponding_line /=0 THEN -- a deletion(s) occurred between the_line and the -- previous line check_cursor(old_screen,the_line-zero_count,1); driver.interpret(ansi_CSI & value_string(new_screen.element(the_line). corresponding_line - new_screen. element(the_line-1).corresponding_line -1) & "M" ); ELSIF new_screen.element(the_line-1).corresponding_line = 0 AND new_screen.element(the_line).corresponding_line /= 1 THEN -- the previous line is 0 (insertion) IF new_screen.element(the_line).corresponding_line - new_screen.element(the_line-zero_count-1). corresponding_line > 1 THEN -- compare the line with the previous non-zero line check_cursor(old_screen,the_line-zero_count,1); driver.interpret(ansi_CSI & value_string(new_screen.element(the_line). corresponding_line - new_screen.element(the_line-zero_count- 1). corresponding_line-1) & "M"); END IF; END IF; ELSE -- if top line, compare corresponding_line against the_line -- if greater than 1, call driver.interpret to delete lines IF new_screen.element(the_line).corresponding_line = 0 THEN zero_count := zero_count + 1; ELSIF new_screen.element(the_line).corresponding_line - the_line >= 1 THEN check_cursor(old_screen,the_line-zero_count,1); driver.interpret(ansi_CSI & value_string(new_screen.element(the_line).corresponding_line - (the_line)) & "M" ); END IF; END IF; the_line := the_line+1; EXIT WHEN the_line > bottom_line; END LOOP; the_line := top_line; END fix_deletes; -- ---------------------------------------------------------------------------- PROCEDURE fix_inserts IS tmp_line : positive; BEGIN -- scan for lines to be inserted the_line := top_line; LOOP IF new_screen.element(the_line).corresponding_line = 0 THEN -- found a line to be inserted -- call next_change to determine if following lines -- need to be inserted tmp_line := the_line; next_change(the_line,insert_count); check_cursor(old_screen,tmp_line,1); driver.interpret(ansi_CSI & value_string(insert_count) & "L"); ELSE the_line := the_line + 1; END IF; EXIT WHEN (the_line) > bottom_line; END LOOP; END fix_inserts; -- --------------------------------------------------------------------------- BEGIN -- scan the new_screen for deletes and perform, -- scan the new_screen for inserts and perform, fix_deletes; fix_inserts; -- if an insert line, redraw it -- if anything else, redisplay line with redraw FOR i IN top_line..bottom_line LOOP IF new_screen.element(i).corresponding_line = 0 THEN redraw_line(old_screen,new_screen,i,i); ELSIF new_screen.element(i).corresponding_line > 0 THEN redisplay_line_with_redraw(old_screen, new_screen, new_screen.element(i).corresponding_line, i); END IF; END LOOP; -- reset the old_screen to look like the physical screen FOR i IN top_line..bottom_line LOOP old_screen.element(i) := new_screen.element(i); new_screen.element(i).corresponding_line := i; END LOOP; END redisplay_screen_with_movement; -- ------------------------------------------------------------------------- PRAGMA page; PROCEDURE redisplay_screen_with_redraw( old_screen : IN OUT vt_content.vt_content_access; new_screen : IN vt_content.vt_content_access; top_line : IN vt_content.row_range; bottom_line : IN vt_content.row_range ) IS BEGIN FOR i IN top_line..bottom_line LOOP redisplay_line_with_redraw ( old_screen, new_screen, i, i ); END LOOP; END redisplay_screen_with_redraw; -- -------------------------------------------------------------------------- PRAGMA page; PROCEDURE redisplay_line_with_redraw( old_screen : IN OUT vt_content.vt_content_access; new_screen : IN vt_content.vt_content_access; old_line : IN vt_content.row_range; new_line : IN vt_content.row_range ) IS buffer_index : natural := 0; done : boolean := false; no_diff_up_front : boolean := true; no_diff_at_end : boolean := true; start_update_position : positive := 1; end_update_position : natural := new_screen.element( new_line ).length; BEGIN IF new_screen.element( new_line ).length = 0 THEN -- erase all of line IF old_screen.element( old_line ).length /= 0 THEN check_cursor( old_screen,new_line, 1 ); -- move the cursor to the beginning of the line driver.interpret( ansi_ELe ); -- erase to end of line old_screen.element( old_line ).length := 0; END IF; GOTO quick_out; END IF; LOOP EXIT WHEN (NOT no_diff_up_front) OR (start_update_position > old_screen.element( old_line ).length) OR (start_update_position > new_screen.element( new_line ).length ); IF ( old_screen.element( old_line ). descriptors( start_update_position ) /= new_screen.element( new_line ). descriptors( start_update_position ) ) OR ( old_screen.element( old_line ). data( start_update_position ) /= new_screen.element( new_line ). data( start_update_position ) ) THEN no_diff_up_front := false; ELSE start_update_position := start_update_position + 1; END IF; END LOOP; IF old_screen.element( old_line ).length = new_screen.element( new_line ).length THEN WHILE no_diff_at_end AND ( start_update_position <= end_update_position ) LOOP IF ( old_screen.element( old_line ). descriptors( end_update_position ) /= new_screen.element( new_line ). descriptors( end_update_position ) ) OR ( old_screen.element( old_line ). data( end_update_position ) /= new_screen.element( new_line ). data( end_update_position ) ) THEN no_diff_at_end := false; ELSE end_update_position := end_update_position - 1; END IF; END LOOP; END IF; IF start_update_position > end_update_position THEN IF old_screen.element( old_line ).length > new_screen.element( new_line ).length THEN check_cursor( old_screen,new_line, end_update_position+1 ); driver.interpret( ansi_ELe ); old_screen.element( old_line ) := new_screen.element( new_line ); END IF; GOTO quick_out; END IF; FOR i IN start_update_position..end_update_position LOOP IF driver.supported_functions( driver.highlight_is ) THEN IF old_screen.current_rendition /= new_screen.element( new_line ).descriptors( i ).rendition THEN CASE new_screen.element( new_line ). descriptors( i ).rendition IS WHEN vt_content.sgpr => output_buffer( buffer_index+1..buffer_index+ansi_SGP'LENGTH ) := ansi_SGP; buffer_index := buffer_index + ansi_SGP'LENGTH; WHEN vt_content.sgri => output_buffer( buffer_index+1..buffer_index+ansi_SGR'LENGTH ) := ansi_SGR; buffer_index := buffer_index + ansi_SGR'LENGTH; WHEN vt_content.sgno => NULL; END CASE; -- set the default rendition old_screen.current_rendition := new_screen.element( new_line ).descriptors( i ).rendition; END IF; END IF; -- now move the data into the output buffer buffer_index := buffer_index + 1; IF new_screen.element( new_line ).descriptors( i ).rendition = vt_content.sgno THEN output_buffer( buffer_index ) := ' '; ELSE output_buffer( buffer_index ) := new_screen.element( new_line ).data( i ); END IF; END LOOP; -- put the data out check_cursor( old_screen,new_line, start_update_position ); driver.interpret( output_buffer( 1..buffer_index ) ); IF old_screen.active_position.col_position+buffer_index > vt_content.width THEN old_screen.active_position.col_position := vt_content.width; ELSE old_screen.active_position.col_position := old_screen.active_position.col_position + buffer_index; END IF; IF old_screen.element( old_line ).length > new_screen.element( new_line ).length THEN driver.interpret( ansi_ELe ); END IF; old_screen.element( old_line ):= new_screen.element( new_line ); <<quick_out>> NULL; END redisplay_line_with_redraw; -- ---------------------------------------------------------------------------- BEGIN -- redisplay NULL; END redisplay; :::::::::: scroll_body.ada :::::::::: -- ---------------------------------------------------------------------------- -- ABSTRACT: A user's program can WITH this package to provide a device- -- independent terminal interface that is functionally equivalent -- to a scroll-terminal. This is the simplest form of terminal that -- this virtual terminal supports. This package should be chosen for -- any of the following reasons: -- -- 1. The user's terminal is primitive. Either it could be a CRT -- with little functionality, or a printing terminal. -- 2. The user wants maximum transportability. -- 3. The user does not need advanced capabilities for the -- application. -- 4. The user's application may run over low speed communication -- lines, making the page and form mode unacceptable. -- ----------------------------------------------------------------------------- WITH sysdep, driver, vt_input, vt_content; USE vt_content; -- resolves visibility problems PACKAGE BODY scroll_terminal IS actual_screen, virtual_screen : vt_content.vt_content_access; immediate : boolean := false; initialized :boolean := false; active_line : CONSTANT positive := 24 ; PRAGMA page; PROCEDURE open (name : IN string := "none" ) IS BEGIN driver.vt_initialize( name, vt_content.height, vt_content.width) ; virtual_screen := NEW vt_content.vt_content_record ; actual_screen := NEW vt_content.vt_content_record ; virtual_screen.current_rendition := vt_content.sgpr ; virtual_screen.active_position.row_position := active_line ; FOR i IN 1..vt_content.width LOOP virtual_screen.element(active_line).descriptors(i). rendition := vt_content.sgpr ; virtual_screen.tabs(i) := FALSE ; END LOOP ; FOR i IN 1..vt_content.height LOOP virtual_screen.element(i).length := 0 ; END LOOP ; initialized := true ; actual_screen.ALL := virtual_screen.ALL ; EXCEPTION WHEN driver.tcf_error => RAISE tcf_error ; WHEN driver.unsupported_terminal => RAISE unsupported_terminal ; WHEN driver.uninitialized => RAISE uninitialized ; END open ; PRAGMA page; PROCEDURE close IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; initialized := false ; driver.close_virtual_terminal ; END close; PRAGMA page; PROCEDURE set_position (position : IN positive) IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; IF position > vt_content.width THEN virtual_screen.active_position.col_position := vt_content.width ; ELSE virtual_screen.active_position.col_position := position ; END IF ; END set_position; PRAGMA page; FUNCTION position RETURN positive IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; RETURN (virtual_screen.active_position.col_position) ; END position; PRAGMA page; FUNCTION size RETURN positive IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; RETURN (vt_content.width) ; END size; PRAGMA page; PROCEDURE set_tab IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; virtual_screen.tabs(virtual_screen.active_position.col_position) := TRUE ; END set_tab; PRAGMA page; PROCEDURE clear_tab IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; virtual_screen.tabs(virtual_screen.active_position.col_position) := FALSE ; END clear_tab; PRAGMA page; PROCEDURE tab (count : IN positive := 1) IS temp_col : positive := virtual_screen.active_position.col_position ; found_next_tab_stop : BOOLEAN := false ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; FOR i IN 1..count LOOP found_next_tab_stop := false ; LOOP temp_col := temp_col + 1 ; IF virtual_screen.tabs(temp_col) THEN found_next_tab_stop := TRUE ; END IF ; EXIT WHEN found_next_tab_stop OR (temp_col = vt_content.width) ; END LOOP ; EXIT WHEN temp_col = vt_content.width ; virtual_screen.active_position.col_position := temp_col ; END LOOP ; IF found_next_tab_stop THEN virtual_screen.active_position.col_position := temp_col ; END IF ; END tab; PRAGMA page; PROCEDURE new_line (count : IN positive := 1) IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; -- update the line, move cursor, reset active line to null update_line ; FOR i IN 1..count LOOP driver.interpret( ascii.cr & ascii.lf ) ; END LOOP ; virtual_screen.element(active_line).length := 0 ; virtual_screen.active_position.col_position := 1 ; END new_line; PRAGMA page; PROCEDURE new_page (count : IN positive := 1) IS buffer : string(1..1) := string'(1 => ascii.ff ) ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; update_line ; FOR i IN 1..count LOOP driver.interpret( buffer ) ; END LOOP ; virtual_screen.active_position.col_position := 1 ; virtual_screen.element(active_line).length := 0 ; END new_page; PRAGMA page; PROCEDURE put (item : IN character) IS buffer : string(1..1) ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; buffer(1) := item ; put(buffer) ; END put; PRAGMA page; PROCEDURE put (item : IN string) IS temp_col : positive := virtual_screen.active_position.col_position ; stop_pos : positive ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; -- first blank out area between current line length and -- the active position FOR i IN virtual_screen.element(active_line).length + 1.. virtual_screen.active_position.col_position - 1 LOOP virtual_screen.element(active_line).data(i) := ' ' ; END LOOP ; IF temp_col + item'LENGTH -1 >= vt_content.width THEN stop_pos := vt_content.width - temp_col + 1 ; virtual_screen.element(active_line).data(temp_col.. vt_content.width) := item(1..stop_pos) ; temp_col := vt_content.width ; virtual_screen.element(active_line).length := vt_content.width; ELSE virtual_screen.element(active_line).data(temp_col.. temp_col+item'LENGTH -1 ) := item ; temp_col := temp_col + item'LENGTH - 1 ; virtual_screen.element(active_line).length := temp_col ; temp_col := temp_col + 1 ; END IF ; virtual_screen.active_position.col_position := temp_col ; END put; PRAGMA page; PROCEDURE update_line IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; IF virtual_screen.element(active_line).length /= 0 THEN driver.interpret(virtual_screen.element(active_line).data(1.. virtual_screen.element(active_line).length) ) ; END IF ; virtual_screen.element(active_line).length := 0 ; virtual_screen.active_position.col_position:= 1 ; END update_line; PRAGMA page; FUNCTION valid_character( item : IN character ) RETURN boolean IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; RETURN (sysdep.valid_character( item ) ) ; END valid_character; PRAGMA page; FUNCTION convert_key_enum( key_id : IN vt_input.function_key_enum ) RETURN function_key_enum IS temp_id : function_key_enum; BEGIN CASE key_id IS WHEN vt_input.up_arrow => temp_id := up_arrow; WHEN vt_input.down_arrow => temp_id := down_arrow; WHEN vt_input.left_arrow => temp_id := left_arrow; WHEN vt_input.right_arrow => temp_id := right_arrow; WHEN vt_input.f1 => temp_id := f1; WHEN vt_input.f2 => temp_id := f2; WHEN vt_input.f3 => temp_id := f3; WHEN vt_input.f4 => temp_id := f4; WHEN vt_input.f5 => temp_id := f5; WHEN vt_input.f6 => temp_id := f6 ; WHEN vt_input.f7 => temp_id := f7 ; WHEN vt_input.f8 => temp_id := f8 ; WHEN vt_input.f9 => temp_id := f9 ; WHEN vt_input.f10 => temp_id := f10; WHEN vt_input.f11 => temp_id := f11; WHEN vt_input.f12 => temp_id := f12; WHEN vt_input.f13 => temp_id := f13; WHEN vt_input.f14 => temp_id := f14; WHEN vt_input.f15 => temp_id := f15; WHEN vt_input.f16 => temp_id := f16; WHEN vt_input.f17 => temp_id := f17; WHEN vt_input.f18 => temp_id := f18; WHEN vt_input.f19 => temp_id := f19; WHEN vt_input.f20 => temp_id := f20; WHEN vt_input.f21 => temp_id := f21; WHEN vt_input.f22 => temp_id := f22; WHEN vt_input.f23 => temp_id := f23; WHEN vt_input.f24 => temp_id := f24; WHEN vt_input.f25 => temp_id := f25; WHEN vt_input.f26 => temp_id := f26; WHEN vt_input.f27 => temp_id := f27; WHEN vt_input.f28 => temp_id := f28; WHEN vt_input.f29 => temp_id := f29; WHEN vt_input.f30 => temp_id := f30; WHEN vt_input.f31 => temp_id := f31; WHEN vt_input.f32 => temp_id := f32; WHEN OTHERS => NULL; END CASE; RETURN temp_id; END convert_key_enum; FUNCTION convert_key_enum( key_id : IN function_key_enum ) RETURN vt_input.function_key_enum IS temp_id : vt_input.function_key_enum; BEGIN CASE key_id IS WHEN up_arrow => temp_id := vt_input.up_arrow; WHEN down_arrow => temp_id := vt_input.down_arrow; WHEN left_arrow => temp_id := vt_input.left_arrow; WHEN right_arrow => temp_id := vt_input.right_arrow; WHEN f1 => temp_id := vt_input.f1; WHEN f2 => temp_id := vt_input.f2; WHEN f3 => temp_id := vt_input.f3; WHEN f4 => temp_id := vt_input.f4; WHEN f5 => temp_id := vt_input.f5; WHEN f6 => temp_id := vt_input.f6 ; WHEN f7 => temp_id := vt_input.f7 ; WHEN f8 => temp_id := vt_input.f8 ; WHEN f9 => temp_id := vt_input.f9 ; WHEN f10 => temp_id := vt_input.f10; WHEN f11 => temp_id := vt_input.f11; WHEN f12 => temp_id := vt_input.f12; WHEN f13 => temp_id := vt_input.f13; WHEN f14 => temp_id := vt_input.f14; WHEN f15 => temp_id := vt_input.f15; WHEN f16 => temp_id := vt_input.f16; WHEN f17 => temp_id := vt_input.f17; WHEN f18 => temp_id := vt_input.f18; WHEN f19 => temp_id := vt_input.f19; WHEN f20 => temp_id := vt_input.f20; WHEN f21 => temp_id := vt_input.f21; WHEN f22 => temp_id := vt_input.f22; WHEN f23 => temp_id := vt_input.f23; WHEN f24 => temp_id := vt_input.f24; WHEN f25 => temp_id := vt_input.f25; WHEN f26 => temp_id := vt_input.f26; WHEN f27 => temp_id := vt_input.f27; WHEN f28 => temp_id := vt_input.f28; WHEN f29 => temp_id := vt_input.f29; WHEN f30 => temp_id := vt_input.f30; WHEN f31 => temp_id := vt_input.f31; WHEN f32 => temp_id := vt_input.f32; WHEN OTHERS => NULL; END CASE; RETURN temp_id; END convert_key_enum; PROCEDURE convert_descriptor( keys : IN function_key_descriptor; key_temp : OUT vt_input.function_key_descriptor ) IS BEGIN key_temp.no_of_keys := keys.no_of_keys; FOR i IN 1..keys.no_of_keys LOOP key_temp.keys( i ).key := convert_key_enum( keys.keys( i ).key ); key_temp.keys( i ).position := keys.keys( i ).position; END LOOP; END convert_descriptor; PROCEDURE convert_descriptor( keys : IN vt_input.function_key_descriptor; key_temp : OUT function_key_descriptor ) IS BEGIN key_temp.no_of_keys := keys.no_of_keys; FOR i IN 1..keys.no_of_keys LOOP key_temp.keys( i ).key := convert_key_enum( keys.keys( i ).key ); key_temp.keys( i ).position := keys.keys( i ).position; END LOOP; END convert_descriptor; PRAGMA page; PROCEDURE get( data : OUT string; last : OUT natural; keys : OUT function_key_descriptor; timeout : IN duration := duration'last ) IS key_temp : vt_input.function_key_descriptor( 32 ); BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; vt_input.get( data, last, key_temp, timeout ); convert_descriptor( key_temp, keys ); END get; PRAGMA page; FUNCTION function_count(keys : IN function_key_descriptor) RETURN natural IS key_temp : vt_input.function_key_descriptor( 32 ); BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; convert_descriptor( keys, key_temp ); RETURN vt_input.function_count( key_temp ); END function_count; PRAGMA page; PROCEDURE function_key(keys : IN function_key_descriptor; index : IN positive; key_identifier : OUT function_key_enum; previous_position : OUT natural) IS key_temp : vt_input.function_key_descriptor( 32 ); id_temp : vt_input.function_key_enum; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; convert_descriptor( keys, key_temp ); vt_input.function_key( key_temp, index, id_temp, previous_position ); key_identifier := convert_key_enum( id_temp ); END function_key; PRAGMA page; PROCEDURE function_key_name ( key_identifier : IN function_key_enum; key_name : OUT string; last : OUT natural) IS key_temp : vt_input.function_key_enum; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; key_temp := convert_key_enum( key_identifier ); vt_input.function_key_name( key_temp, key_name, last ); END function_key_name; PRAGMA page; PROCEDURE bell IS buffer : string(1..1) := string'(1 => ascii.bel ) ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; driver.interpret( buffer ) ; END bell; BEGIN -- scroll_terminal NULL; EXCEPTION WHEN driver.tcf_error => RAISE tcf_error ; WHEN driver.unsupported_terminal => RAISE unsupported_terminal ; WHEN driver.uninitialized => RAISE uninitialized ; END scroll_terminal; :::::::::: page_body.ada :::::::::: -- ---------------------------------------------------------------------------- -- ABSTRACT: A user's program can WITH this package to provide a device- -- independent terminal interface that is functionally equivalent -- to a page-terminal. This is the most advanced form of terminal -- that this virtual terminal supports. This package should be -- chosen for any of the following reasons: -- -- 1. The user's terminal has advanced features. The terminal is -- directly addressable, with erase to end of line, and erase -- to end of screen capabilities. -- 2. The user wants advanced capabilities and is willing to -- sacrifice some transportability. -- ----------------------------------------------------------------------------- WITH driver, redisplay, vt_input, sysdep, -- only for valid_character function ! vt_content; USE vt_content; -- resolves visibility problems with operators PACKAGE BODY page_terminal IS ansi_CSI : CONSTANT string( 1..2 ) := ascii.esc & '['; -- these next three are constructed below in the appropriate procedures. -- They actually have parameters. -- -- ansi_DCH : CONSTANT string( 1..3 ) := ansi_CSI & 'P'; -- -- ansi_DL : CONSTANT string( 1..3 ) := ansi_CSI & 'M'; -- ansi_IL : CONSTANT string( 1..3 ) := ansi_CSI & 'L'; ansi_EDe : CONSTANT string( 1..4 ) := ansi_CSI & "0J"; ansi_EDs : CONSTANT string( 1..4 ) := ansi_CSI & "1J"; ansi_EDa : CONSTANT string( 1..4 ) := ansi_CSI & "2J"; ansi_ELe : CONSTANT string( 1..4 ) := ansi_CSI & "0K"; ansi_ELs : CONSTANT string( 1..4 ) := ansi_CSI & "1K"; ansi_ELa : CONSTANT string( 1..4 ) := ansi_CSI & "2K"; ansi_SGP : CONSTANT string( 1..4 ) := ansi_CSI & "0m"; ansi_SGR : CONSTANT string( 1..4 ) := ansi_CSI & "7m"; ansi_IMs : CONSTANT string( 1..4 ) := ansi_CSI & "4h"; ansi_IMr : CONSTANT string( 1..4 ) := ansi_CSI & "4l"; actual_screen, virtual_screen : vt_content.vt_content_access; initialized : boolean := false; PRAGMA page; FUNCTION value_string( value : IN positive ) RETURN string IS value_image : CONSTANT string := positive'image( value ); BEGIN RETURN value_image( (value_image'first + 1)..value_image'last ); END; PROCEDURE blank_columns( row : IN positive; start_col : IN natural; end_col : IN natural ) IS BEGIN FOR temp_col IN start_col..end_col LOOP virtual_screen.element( row ).data( temp_col ) := ' '; virtual_screen.element( row ).descriptors( temp_col ).rendition := vt_content.sgpr; END LOOP; END blank_columns; PRAGMA page; PROCEDURE open (name : IN string := "none" ) IS BEGIN driver.vt_initialize ( name, vt_content.height, vt_content.width ); IF NOT (driver.supported_functions(driver.erase_to_end_of_screen_is) AND driver.supported_functions(driver.erase_to_end_of_line_is) AND driver.supported_functions(driver.move_the_cursor_is)) THEN RAISE terminal_too_primitive; END IF; actual_screen := NEW vt_content.vt_content_record; virtual_screen := NEW vt_content.vt_content_record; initialized := true; -- erase all of display driver.interpret ( ansi_CSI & value_string( 1 ) & ";" & value_string( 1 ) & "H" & ansi_EDe ); virtual_screen.current_rendition := vt_content.sgpr; virtual_screen.insert_mode := false; -- no tabs initially FOR col IN 1..vt_content.width LOOP virtual_screen.tabs( col ) := false; END LOOP; FOR row IN 1..vt_content.height LOOP virtual_screen.element( row ).corresponding_line := row; END LOOP; -- make the actual look like the virtual actual_screen.ALL := virtual_screen.ALL; EXCEPTION WHEN driver.tcf_error => RAISE tcf_error; WHEN driver.unsupported_terminal => RAISE unsupported_terminal; WHEN driver.uninitialized => RAISE uninitialized; END open; PRAGMA page; PROCEDURE close IS BEGIN IF driver.supported_functions( driver.highlight_is ) THEN CASE actual_screen.current_rendition IS WHEN vt_content.sgpr => NULL; WHEN vt_content.sgri => driver.interpret( ansi_SGP ); WHEN vt_content.sgno => NULL; END CASE; END IF; initialized := false; driver.close_virtual_terminal; END close; PRAGMA page; PROCEDURE set_position (position : IN xy_position) IS buffer : CONSTANT string := ansi_CSI & value_string( position.line ) & ';' & value_string( position.column ) & 'H' ; temp_lin : positive; temp_col : positive; BEGIN -- set_position -- if terminal has not been opened raise uninitialized IF NOT initialized THEN RAISE uninitialized; END IF; temp_lin := position.line; temp_col := position.column; -- If out of bounds on either line or column, set the values -- the max and continue. IF temp_lin > vt_content.height THEN temp_lin := vt_content.height; END IF; IF temp_col > vt_content.width THEN temp_col := vt_content.width; END IF; -- alter the virtual data structure. virtual_screen.active_position := vt_content.vt_position_xy_record'( temp_lin, temp_col ); END set_position; PRAGMA page; FUNCTION position RETURN xy_position IS BEGIN -- raise exception if terminal has not been opened IF NOT initialized THEN RAISE uninitialized; END IF; RETURN xy_position'( virtual_screen.active_position.row_position, virtual_screen.active_position.col_position ); END position; PRAGMA page; FUNCTION size RETURN xy_position IS BEGIN IF NOT initialized THEN RAISE uninitialized; END IF; RETURN xy_position'( vt_content.height, vt_content.width ); END size; PRAGMA page; PROCEDURE delete_character (count : IN positive := 1) IS buffer : CONSTANT string := ansi_CSI & value_string( count ) & 'P'; temp_row : positive := virtual_screen.active_position.row_position; temp_col : positive := virtual_screen.active_position.col_position; temp_len : natural := virtual_screen.element( temp_row ).length; BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; IF temp_len /= 0 THEN IF temp_col <= temp_len THEN IF count >= temp_len-temp_col+1 THEN virtual_screen.element( temp_row ).length := temp_col - 1; ELSE virtual_screen.element( temp_row ). data( temp_col..temp_len-count ) := virtual_screen.element( temp_row ). data( temp_col+count..temp_len ); virtual_screen.element( temp_row ). descriptors( temp_col..temp_len-count ) := virtual_screen.element( temp_row ). descriptors( temp_col+count..temp_len ); virtual_screen.element( temp_row ).length := temp_len - count; END IF; END IF; END IF; END delete_character; PRAGMA page; PROCEDURE delete_line (count : IN positive := 1) IS buffer : CONSTANT string := ansi_CSI & value_string( count ) & 'M'; temp_row : positive; BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; temp_row := virtual_screen.active_position.row_position; IF count >= (vt_content.height - temp_row + 1) THEN FOR i IN temp_row..vt_content.height LOOP virtual_screen.element( i ).length := 0; virtual_screen.element( i ).corresponding_line := 0; END LOOP; ELSE virtual_screen.element( temp_row..vt_content.height-count ) := virtual_screen.element( temp_row+count..vt_content.height ); FOR i IN vt_content.height-count+1..vt_content.height LOOP virtual_screen.element( i ).length := 0; virtual_screen.element( i ).corresponding_line := 0; END LOOP; END IF; END delete_line; PRAGMA page; PROCEDURE erase_in_display (selection : select_enumeration) IS PROCEDURE erase_lines ( top_line : IN positive; bottom_line : IN positive ) IS BEGIN -- erase_lines FOR temp_row IN top_line..bottom_line LOOP -- initially every line is empty virtual_screen.element( temp_row ).length := 0; END LOOP; END erase_lines; BEGIN -- erase_in_display -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; CASE selection IS WHEN from_xy_position_to_end => -- cursor remains where it is. erase_in_line( from_xy_position_to_end ); erase_lines( virtual_screen.active_position.row_position + 1, vt_content.height ); WHEN from_start_to_xy_position => -- cursor remain where it is. erase_in_line( from_start_to_xy_position ); erase_lines( 1, virtual_screen.active_position.row_position - 1 ); WHEN all_positions => -- place the active position at 1,1 virtual_screen.active_position := vt_content.vt_position_xy_record'( 1, 1 ); -- now erase all of virtual screen erase_lines( 1, vt_content.height ); END CASE; END erase_in_display; PRAGMA page; PROCEDURE erase_in_line (selection : select_enumeration) IS temp_row : positive; line_len : natural; temp_col : positive; BEGIN -- raise exception uninitialized when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; temp_row := virtual_screen.active_position.row_position; temp_col := virtual_screen.active_position.col_position; line_len := virtual_screen.element( temp_row ).length; -- do nothing and get out quick when the active position is located -- out beyond the length of the current line. IF line_len < temp_col THEN GOTO quick_out; END IF; CASE selection IS WHEN from_xy_position_to_end => virtual_screen.element( temp_row ).length := temp_col-1; WHEN from_start_to_xy_position => virtual_screen.element( temp_row ).data(1..temp_col) := string'( 1..temp_col => ' ' ); FOR i IN 1..temp_col LOOP virtual_screen.element( temp_row ). descriptors( i ).rendition := vt_content.sgpr; END LOOP; WHEN all_positions => virtual_screen.element( temp_row ).length := 0; END CASE; <<quick_out>> NULL; END erase_in_line; PRAGMA page; PROCEDURE enter_insert_mode IS BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; virtual_screen.insert_mode := true; END enter_insert_mode; PRAGMA page; PROCEDURE exit_insert_mode IS BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; virtual_screen.insert_mode := false; END exit_insert_mode; PRAGMA page; PROCEDURE insert_line (count : IN positive := 1) IS buffer : CONSTANT string := ansi_CSI & value_string( count ) & 'L'; temp_row : positive := virtual_screen.active_position.row_position; BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; IF count >= (vt_content.height - temp_row + 1) THEN FOR i IN temp_row..vt_content.height LOOP virtual_screen.element( i ).length := 0; virtual_screen.element( i ).corresponding_line := 0; END LOOP; ELSE virtual_screen.element( temp_row+count..vt_content.height ) := virtual_screen.element( temp_row..vt_content.height-count ); FOR i IN temp_row..temp_row+count-1 LOOP virtual_screen.element( i ).length := 0; virtual_screen.element( i ).corresponding_line := 0; END LOOP; END IF; END insert_line; PRAGMA page; PROCEDURE select_graphic_rendition (selection : IN graphic_rendition_enumeration) IS BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; CASE selection IS WHEN primary_rendition => virtual_screen.current_rendition := vt_content.sgpr; WHEN reverse_image => virtual_screen.current_rendition := vt_content.sgri; WHEN no_image => virtual_screen.current_rendition := vt_content.sgno; END CASE; END select_graphic_rendition; PRAGMA page; PROCEDURE set_tab IS BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; virtual_screen.tabs( virtual_screen.active_position.col_position ) := true; END set_tab; PRAGMA page; PROCEDURE clear_tab IS BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; virtual_screen.tabs( virtual_screen.active_position.col_position ) := false; END clear_tab; PRAGMA page; PROCEDURE tab (count : IN positive := 1) IS temp_col : positive := virtual_screen.active_position.col_position; found_next_tab_stop : boolean := false; BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; FOR i IN 1..count LOOP found_next_tab_stop := false ; -- find the next tab. If there are no tabs set then do nothing. LOOP temp_col := temp_col + 1; IF virtual_screen.tabs( temp_col ) THEN found_next_tab_stop := TRUE; END IF; EXIT WHEN found_next_tab_stop OR (temp_col = vt_content.width); END LOOP; EXIT WHEN temp_col = vt_content.width ; virtual_screen.active_position.col_position := temp_col ; END LOOP ; IF found_next_tab_stop THEN virtual_screen.active_position.col_position := temp_col; END IF; END tab; PRAGMA page; PROCEDURE put (item : IN character) IS buffer : string( 1..1 ); BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; buffer( 1 ) := item; put( buffer ) ; END put; PRAGMA page; PROCEDURE put (item : IN string) IS item_len : positive; line_len : natural; temp_row : positive; temp_col : positive; BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; item_len := item'length; temp_row := virtual_screen.active_position.row_position; temp_col := virtual_screen.active_position.col_position; line_len := virtual_screen.element( temp_row ).length; IF NOT virtual_screen.insert_mode THEN IF temp_col+item_len-1 > vt_content.width THEN item_len := vt_content.width - temp_col + 1; END IF; ELSE IF line_len+item_len > vt_content.width THEN IF temp_col+item_len-1 > vt_content.width THEN line_len := temp_col - 1; item_len := vt_content.width-temp_col + 1; ELSE line_len := vt_content.width-item_len; END IF; END IF; END IF; IF temp_col > line_len THEN -- outside previous line boundary blank_columns( temp_row, line_len+1, temp_col-1 ); virtual_screen.element( temp_row ). data( temp_col..temp_col+item_len-1 ) := item( item'first..item'first+item_len-1 ); FOR i IN temp_col..temp_col+item_len-1 LOOP virtual_screen.element( temp_row ).descriptors( i ). rendition := virtual_screen.current_rendition; END LOOP; line_len := temp_col + item_len - 1; IF line_len/=vt_content.width THEN virtual_screen.active_position.col_position := line_len + 1; ELSE virtual_screen.active_position.col_position := line_len; END IF; ELSE IF NOT virtual_screen.insert_mode THEN -- no insert mode, intra line editing virtual_screen.element( temp_row ). data( temp_col..temp_col+item_len-1 ) := item( item'first..item'first+item_len-1 ); FOR i IN temp_col..temp_col+item_len-1 LOOP virtual_screen.element( temp_row ).descriptors( i ). rendition := virtual_screen.current_rendition; END LOOP; IF temp_col+item_len-1 > line_len THEN line_len := temp_col + item_len - 1; END IF; IF virtual_screen.active_position.col_position + item_len < vt_content.width THEN virtual_screen.active_position.col_position := virtual_screen.active_position.col_position + item_len; ELSE virtual_screen.active_position.col_position := vt_content.width; END IF; ELSE -- insert mode, intra line editing virtual_screen.element( temp_row ). data( temp_col+item_len..line_len+item_len ) := virtual_screen.element( temp_row ). data( temp_col..line_len ); virtual_screen.element( temp_row ). descriptors( temp_col+item_len..line_len+item_len ) := virtual_screen.element( temp_row ). descriptors( temp_col..line_len ); virtual_screen.element( temp_row ). data( temp_col..temp_col+item_len-1 ) := item( item'first..item'first+item_len-1 ); FOR i IN temp_col..temp_col+item_len-1 LOOP virtual_screen.element( temp_row ). descriptors( i ).rendition := virtual_screen.current_rendition; END LOOP; line_len := line_len + item_len; IF virtual_screen.active_position.col_position + item_len < vt_content.width THEN virtual_screen.active_position.col_position := virtual_screen.active_position.col_position + item_len; ELSE virtual_screen.active_position.col_position := vt_content.width; END IF; END IF; END IF; virtual_screen.element( temp_row ).length := line_len; END put; PRAGMA page; PROCEDURE update_screen ( top_line : IN positive; bottom_line : IN positive ) IS BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; IF driver.supported_functions( driver.insert_line_is ) AND driver.supported_functions( driver.delete_line_is ) THEN redisplay.redisplay_screen_with_movement ( actual_screen, virtual_screen, top_line, bottom_line ); redisplay.fix_cursor ( actual_screen, virtual_screen ); ELSE redisplay.redisplay_screen_with_redraw ( actual_screen, virtual_screen, top_line, bottom_line ); redisplay.fix_cursor ( actual_screen, virtual_screen ); END IF; END update_screen; PRAGMA page; PROCEDURE update_line( the_line : IN positive ) IS BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; redisplay.redisplay_line_with_redraw ( actual_screen, virtual_screen, the_line, the_line ); redisplay.fix_cursor ( actual_screen, virtual_screen ); END update_line; PRAGMA page; PROCEDURE update_cursor IS BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; redisplay.fix_cursor ( actual_screen, virtual_screen ); END update_cursor; PRAGMA page; PROCEDURE redraw_screen IS BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; redisplay.redraw_screen( actual_screen, virtual_screen, 1, vt_content.height ); redisplay.fix_cursor ( actual_screen, virtual_screen ); END redraw_screen; PRAGMA page; FUNCTION valid_character( item : IN character ) RETURN boolean IS BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; RETURN sysdep.valid_character( item ); END valid_character; FUNCTION convert_key_enum( key_id : IN vt_input.function_key_enum ) RETURN function_key_enum IS temp_id : function_key_enum; BEGIN CASE key_id IS WHEN vt_input.up_arrow => temp_id := up_arrow; WHEN vt_input.down_arrow => temp_id := down_arrow; WHEN vt_input.left_arrow => temp_id := left_arrow; WHEN vt_input.right_arrow => temp_id := right_arrow; WHEN vt_input.f1 => temp_id := f1; WHEN vt_input.f2 => temp_id := f2; WHEN vt_input.f3 => temp_id := f3; WHEN vt_input.f4 => temp_id := f4; WHEN vt_input.f5 => temp_id := f5; WHEN vt_input.f6 => temp_id := f6 ; WHEN vt_input.f7 => temp_id := f7 ; WHEN vt_input.f8 => temp_id := f8 ; WHEN vt_input.f9 => temp_id := f9 ; WHEN vt_input.f10 => temp_id := f10; WHEN vt_input.f11 => temp_id := f11; WHEN vt_input.f12 => temp_id := f12; WHEN vt_input.f13 => temp_id := f13; WHEN vt_input.f14 => temp_id := f14; WHEN vt_input.f15 => temp_id := f15; WHEN vt_input.f16 => temp_id := f16; WHEN vt_input.f17 => temp_id := f17; WHEN vt_input.f18 => temp_id := f18; WHEN vt_input.f19 => temp_id := f19; WHEN vt_input.f20 => temp_id := f20; WHEN vt_input.f21 => temp_id := f21; WHEN vt_input.f22 => temp_id := f22; WHEN vt_input.f23 => temp_id := f23; WHEN vt_input.f24 => temp_id := f24; WHEN vt_input.f25 => temp_id := f25; WHEN vt_input.f26 => temp_id := f26; WHEN vt_input.f27 => temp_id := f27; WHEN vt_input.f28 => temp_id := f28; WHEN vt_input.f29 => temp_id := f29; WHEN vt_input.f30 => temp_id := f30; WHEN vt_input.f31 => temp_id := f31; WHEN vt_input.f32 => temp_id := f32; WHEN OTHERS => NULL; END CASE; RETURN temp_id; END convert_key_enum; FUNCTION convert_key_enum( key_id : IN function_key_enum ) RETURN vt_input.function_key_enum IS temp_id : vt_input.function_key_enum; BEGIN CASE key_id IS WHEN up_arrow => temp_id := vt_input.up_arrow; WHEN down_arrow => temp_id := vt_input.down_arrow; WHEN left_arrow => temp_id := vt_input.left_arrow; WHEN right_arrow => temp_id := vt_input.right_arrow; WHEN f1 => temp_id := vt_input.f1; WHEN f2 => temp_id := vt_input.f2; WHEN f3 => temp_id := vt_input.f3; WHEN f4 => temp_id := vt_input.f4; WHEN f5 => temp_id := vt_input.f5; WHEN f6 => temp_id := vt_input.f6 ; WHEN f7 => temp_id := vt_input.f7 ; WHEN f8 => temp_id := vt_input.f8 ; WHEN f9 => temp_id := vt_input.f9 ; WHEN f10 => temp_id := vt_input.f10; WHEN f11 => temp_id := vt_input.f11; WHEN f12 => temp_id := vt_input.f12; WHEN f13 => temp_id := vt_input.f13; WHEN f14 => temp_id := vt_input.f14; WHEN f15 => temp_id := vt_input.f15; WHEN f16 => temp_id := vt_input.f16; WHEN f17 => temp_id := vt_input.f17; WHEN f18 => temp_id := vt_input.f18; WHEN f19 => temp_id := vt_input.f19; WHEN f20 => temp_id := vt_input.f20; WHEN f21 => temp_id := vt_input.f21; WHEN f22 => temp_id := vt_input.f22; WHEN f23 => temp_id := vt_input.f23; WHEN f24 => temp_id := vt_input.f24; WHEN f25 => temp_id := vt_input.f25; WHEN f26 => temp_id := vt_input.f26; WHEN f27 => temp_id := vt_input.f27; WHEN f28 => temp_id := vt_input.f28; WHEN f29 => temp_id := vt_input.f29; WHEN f30 => temp_id := vt_input.f30; WHEN f31 => temp_id := vt_input.f31; WHEN f32 => temp_id := vt_input.f32; WHEN OTHERS => NULL; END CASE; RETURN temp_id; END convert_key_enum; PROCEDURE convert_descriptor( keys : IN function_key_descriptor; key_temp : OUT vt_input.function_key_descriptor ) IS BEGIN key_temp.no_of_keys := keys.no_of_keys; FOR i IN 1..keys.no_of_keys LOOP key_temp.keys( i ).key := convert_key_enum( keys.keys( i ).key ); key_temp.keys( i ).position := keys.keys( i ).position; END LOOP; END convert_descriptor; PROCEDURE convert_descriptor( keys : IN vt_input.function_key_descriptor; key_temp : OUT function_key_descriptor ) IS BEGIN key_temp.no_of_keys := keys.no_of_keys; FOR i IN 1..keys.no_of_keys LOOP key_temp.keys( i ).key := convert_key_enum( keys.keys( i ).key ); key_temp.keys( i ).position := keys.keys( i ).position; END LOOP; END convert_descriptor; PRAGMA page; PROCEDURE get( data : OUT string; last : OUT natural; keys : OUT function_key_descriptor; timeout : IN duration := duration'last ) IS key_temp : vt_input.function_key_descriptor( 32 ); BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; vt_input.get( data, last, key_temp, timeout ); convert_descriptor( key_temp, keys ); END get; PRAGMA page; FUNCTION function_count(keys : IN function_key_descriptor) RETURN natural IS key_temp : vt_input.function_key_descriptor( 32 ); BEGIN IF NOT initialized THEN RAISE uninitialized; END IF; convert_descriptor( keys, key_temp ); RETURN vt_input.function_count( key_temp ); END function_count; PRAGMA page; PROCEDURE function_key(keys : IN function_key_descriptor; index : IN positive; key_identifier : OUT function_key_enum; previous_position : OUT natural) IS key_temp : vt_input.function_key_descriptor( 32 ); id_temp : vt_input.function_key_enum; BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; convert_descriptor( keys, key_temp ); vt_input.function_key( key_temp, index, id_temp, previous_position ); key_identifier := convert_key_enum( id_temp ); END function_key; PRAGMA page; PROCEDURE function_key_name ( key_identifier : IN function_key_enum; key_name : OUT string; last : OUT natural) IS key_temp : vt_input.function_key_enum; BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; key_temp := convert_key_enum( key_identifier ); vt_input.function_key_name( key_temp, key_name, last ); END function_key_name; PRAGMA page; PROCEDURE bell IS buffer : string( 1..1 ); BEGIN -- raise exception when terminal not open IF NOT initialized THEN RAISE uninitialized; END IF; buffer( 1 ) := ascii.bel; driver.interpret( buffer ); END bell; END page_terminal; :::::::::: form_body.ada :::::::::: -- ----------------------------------------------------------------------------- -- ABSTRACT: A user's program may WITH this package to provide a device- -- independent terminal interface that is functionally equivalent to -- a form terminal. -- The display of a form-mode terminal is divided into qualified -- areas that have the same attributes. The user program defines -- qualified areas on the virtual display by making calls on -- form_terminal.set_position and form_terminal.define_qualified_area -- A call upon form_terminal.activate_form will map the virtual -- display into the actual terminal display and allow editing of the -- form without user program intervention. When the user has -- finished editing the form the user presses a function key (as -- defined in the terminal capabilities file) which returns control -- to the user's program. -- ---------------------------------------------------------------------------- WITH vt_input, vt_content , driver ; USE vt_content ; PACKAGE BODY form_terminal IS ansi_CSI : CONSTANT STRING(1..2) := ascii.esc & '[' ; actual_screen, virtual_screen : vt_content.vt_content_access ; form_is_modified : BOOLEAN := FALSE ; number_of_qualified_areas : NATURAL := 0 ; function_key_struck : vt_input.function_key_enum ; function_key_struck_last : natural ; initialized : boolean := false ; PRAGMA page; FUNCTION value_string( value : IN positive ) RETURN STRING IS value_image : CONSTANT STRING := positive'image( value ) ; BEGIN RETURN value_image( (value_image'first +1)..(value_image'last) ) ; END value_string ; PROCEDURE next_position( row, col : IN OUT POSITIVE ) IS BEGIN col := col + 1 ; IF col > vt_content.width THEN col := 1 ; row := row + 1 ; END IF ; IF row > vt_content.height THEN row := 1 ; END IF ; END next_position ; PROCEDURE previous_position ( row, col : IN OUT positive) IS BEGIN IF col = 1 THEN col := vt_content.width ; IF row = 1 THEN --stepping back row := vt_content.height ; --up the screen with ELSE --line and screen row := row - 1 ; --wrap END IF ; ELSE col := col - 1 ; END IF ; END previous_position ; PRAGMA page ; PROCEDURE blank_columns( row : IN positive ; start_col : IN natural ; stop_col : IN natural ) IS BEGIN FOR i IN start_col..stop_col LOOP virtual_screen.element(row).data(i) := ' ' ; END LOOP ; END blank_columns ; PROCEDURE back_tab IS temp_row : positive := virtual_screen.active_position.row_position ; temp_col : positive := virtual_screen.active_position.col_position ; found_qualifier_head : BOOLEAN := FALSE ; BEGIN LOOP IF virtual_screen.element(temp_row).descriptors(temp_col). qualifier_head THEN found_qualifier_head := TRUE ; END IF ; EXIT WHEN found_qualifier_head ; previous_position(temp_row, temp_col) ; END LOOP ; virtual_screen.active_position.row_position := temp_row ; virtual_screen.active_position.col_position := temp_col ; END back_tab ; PRAGMA page ; PROCEDURE open( name : IN string := "none") IS ansi_EDa : string(1..4) := ansi_CSI & "2J" ; BEGIN -- driver.vt_initialize( name, vt_content.height, vt_content.width) ; IF NOT (driver.supported_functions(driver.erase_to_end_of_screen_is) AND driver.supported_functions(driver.erase_to_end_of_line_is) AND driver.supported_functions(driver.move_the_cursor_is)) THEN RAISE terminal_too_primitive ; END IF ; actual_screen := NEW vt_content.vt_content_record ; virtual_screen := NEW vt_content.vt_content_record ; FOR i IN 1..vt_content.height LOOP virtual_screen.element(i).length := 0 ; FOR j IN 1..vt_content.width LOOP virtual_screen.element(i).descriptors(j). qualifier_head := FALSE ; virtual_screen.element(i).descriptors(j). rendition := vt_content.sgpr ; virtual_screen.element(i).descriptors(j). qualifiers:= vt_content.dqnn ; END LOOP ; END LOOP ; initialized := true ; driver.interpret( ansi_EDa ) ; -- erase display actual_screen.ALL := virtual_screen.ALL ; EXCEPTION WHEN driver.uninitialized => RAISE uninitialized ; WHEN driver.tcf_error => RAISE tcf_error ; WHEN driver.unsupported_terminal => RAISE unsupported_terminal ; END open; PRAGMA page ; PROCEDURE close IS ansi_SGP : CONSTANT string( 1..4 ) := string'( ascii.esc & "[0m" ); BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; IF driver.supported_functions( driver.highlight_is ) THEN CASE actual_screen.current_rendition IS WHEN vt_content.sgpr => NULL; WHEN vt_content.sgri => driver.interpret( ansi_SGP ); WHEN vt_content.sgno => NULL; END CASE; END IF; initialized := false ; driver.close_virtual_terminal ; END close; PRAGMA page ; PROCEDURE set_position (position : IN xy_position) IS buffer : CONSTANT STRING := ansi_CSI & value_string( position.line ) & ';' & value_string( position.column) & 'H' ; temp_lin : positive := position.line ; temp_col : positive := position.column ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; -- if either line or column is greater than max, then -- set to max and continue IF temp_lin > vt_content.height THEN temp_lin := vt_content.height ; END IF ; IF temp_col > vt_content.width THEN temp_col := vt_content.width ; END IF ; -- change virtual representation virtual_screen.active_position := vt_content. vt_position_xy_record'( temp_lin, temp_col ) ; END set_position; PRAGMA page ; FUNCTION position RETURN xy_position IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; RETURN xy_position'( virtual_screen.active_position.row_position, virtual_screen.active_position.col_position ) ; END position; PRAGMA page ; FUNCTION size RETURN xy_position IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; RETURN xy_position'( vt_content.height, vt_content.width ) ; END size; PRAGMA page ; PROCEDURE define_qualified_area (intensity : IN area_intensity := normal; protection : IN area_protection := protected; input : IN area_input := graphic_characters ) IS temp_row : positive := virtual_screen.active_position.row_position ; temp_col : positive := virtual_screen.active_position.col_position ; acceptable_input : vt_content.area_qualifiers_enum ; area_intensity : vt_content.graphic_rendition_enum ; prev_field_ri : boolean := false ; line_length : natural ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; IF virtual_screen.element(temp_row).descriptors(temp_col). rendition = vt_content.sgri THEN prev_field_ri := TRUE ; line_length := temp_col - 1 ; END IF ; virtual_screen.element(temp_row).descriptors(temp_col) .qualifier_head := TRUE ; -- qualifier head is always primary rendition and protected -- and blank virtual_screen.element(temp_row).data(temp_col) := ' ' ; CASE intensity IS WHEN normal => area_intensity := vt_content.sgpr ; WHEN none => area_intensity := vt_content.sgno ; WHEN high => area_intensity := vt_content.sgri ; END CASE ; -- if reverse image, put blanks from present length to qual. head -- IF area_intensity = vt_content.sgri THEN FOR i IN virtual_screen.element(temp_row).length + 1.. temp_col - 1 LOOP virtual_screen.element(temp_row).data(i) := ' ' ; END LOOP ; END IF ; virtual_screen.element(temp_row).descriptors(temp_col) .rendition := vt_content.sgpr ; virtual_screen.element(temp_row).descriptors(temp_col) .qualifiers := vt_content.dqnn ; next_position( temp_row, temp_col ) ; number_of_qualified_areas := number_of_qualified_areas + 1 ; -- set protection of qualified area IF protection = protected THEN -- accept no input acceptable_input := vt_content.dqnn ; ELSE -- area is unprotected, set the type of characters allowed -- in the qualified area CASE input IS WHEN graphic_characters => -- accept graphic characters acceptable_input := vt_content.dqag ; WHEN numerics => -- accept numeric characters acceptable_input := vt_content.dqan ; WHEN OTHERS => NULL ; END CASE ; -- set the intensity allowed in the qualified area END IF ; -- put attributes in all positions of qualified area LOOP EXIT WHEN virtual_screen.element(temp_row).descriptors(temp_col). qualifier_head ; virtual_screen.element(temp_row).descriptors(temp_col). qualifiers := acceptable_input ; virtual_screen.element(temp_row).descriptors(temp_col). rendition := area_intensity ; IF (area_intensity = vt_content.sgri) AND (virtual_screen. element(temp_row).length < temp_col) THEN virtual_screen.element(temp_row).data(temp_col) := ' ' ; virtual_screen.element(temp_row).length := temp_col ; END IF ; IF (prev_field_ri) AND (area_intensity /= vt_content.sgri) THEN IF virtual_screen.element(temp_row).data(temp_col) /= ' ' THEN line_length := temp_col ; END IF ; IF temp_col = vt_content.width THEN virtual_screen.element(temp_row).length := line_length ; line_length := 0 ; END IF ; END IF ; next_position(temp_row, temp_col) ; END LOOP ; IF (prev_field_ri) and (area_intensity /= vt_content.sgri) and (temp_col > virtual_screen.element(temp_row).length) THEN virtual_screen.element(temp_row).length := line_length ; END IF ; END define_qualified_area ; PRAGMA page ; PROCEDURE clear_qualified_area IS temp_qualifiers : vt_content.area_qualifiers_enum ; temp_rendition : vt_content.graphic_rendition_enum ; temp_row : positive ; temp_col : positive ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; IF number_of_qualified_areas > 0 THEN back_tab ; temp_row := virtual_screen.active_position.row_position ; temp_col := virtual_screen.active_position.col_position ; virtual_screen.element(temp_row).descriptors(temp_col). qualifier_head := FALSE ; IF number_of_qualified_areas = 1 THEN --special case, set screen to protected --and primary rendition FOR i IN 1..vt_content.height LOOP FOR j IN 1..vt_content.width LOOP virtual_screen.element(i).descriptors(j). rendition := vt_content.sgpr ; virtual_screen.element(i).descriptors(j). qualifiers := vt_content.dqnn ; END LOOP ; END LOOP ; ELSE --get previous areas attributes previous_position(temp_row, temp_col) ; temp_qualifiers := virtual_screen.element(temp_row). descriptors(temp_col).qualifiers ; temp_rendition := virtual_screen.element(temp_row). descriptors(temp_col).rendition ; --get back to the correct position next_position(temp_row, temp_col) ; LOOP virtual_screen.element(temp_row).descriptors (temp_col).qualifiers := temp_qualifiers ; virtual_screen.element(temp_row).descriptors (temp_col).rendition := temp_rendition ; next_position(temp_row, temp_col) ; EXIT WHEN virtual_screen.element(temp_row). descriptors(temp_col).qualifier_head ; END LOOP ; END IF ; number_of_qualified_areas := number_of_qualified_areas - 1 ; END IF ; END clear_qualified_area; PRAGMA page ; PROCEDURE tab IS temp_row : positive := virtual_screen.active_position.row_position ; temp_col : positive := virtual_screen.active_position.col_position ; found_next_qual_area : boolean := false ; all_positions_checked: natural := vt_content.height * vt_content.width ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; IF number_of_qualified_areas > 0 THEN LOOP -- move to the next position next_position( temp_row, temp_col ) ; IF virtual_screen.element(temp_row).descriptors(temp_col) .qualifier_head THEN found_next_qual_area := true ; END IF ; EXIT WHEN found_next_qual_area ; END LOOP ; IF found_next_qual_area THEN virtual_screen.active_position.row_position := temp_row ; virtual_screen.active_position.col_position := temp_col ; END IF ; END IF ; END tab; PRAGMA page ; PROCEDURE put (item : IN character) IS buffer : STRING( 1..1 ) ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; buffer( 1 ) := item ; put(buffer) ; END put; PRAGMA page ; PROCEDURE put (item : IN string) IS temp_row : positive := virtual_screen.active_position.row_position ; temp_col : positive := virtual_screen.active_position.col_position ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; blank_columns( temp_row, virtual_screen.element(temp_row) .length + 1 , temp_col - 1 ) ; FOR i IN 1..item'LENGTH LOOP virtual_screen.element(temp_row).data(temp_col) := item(i) ; IF temp_col = vt_content.width THEN virtual_screen.element(temp_row).length := vt_content.width ; END IF ; next_position( temp_row, temp_col ) ; END LOOP ; -- reset the line length if need be IF virtual_screen.element(temp_row).length < temp_col - 1 THEN virtual_screen.element(temp_row).length := temp_col - 1; END IF ; -- set active position virtual_screen.active_position.row_position := temp_row ; virtual_screen.active_position.col_position := temp_col ; END put; PRAGMA page ; PROCEDURE get (item : OUT character) IS buffer : string(1..1) ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; get( buffer ) ; item := buffer(1) ; END get; PRAGMA page ; PROCEDURE get (item : OUT string) IS temp_row : positive := virtual_screen.active_position.row_position ; temp_col : positive := virtual_screen.active_position.col_position ; pad_it : BOOLEAN := false ; i : natural ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; FOR i IN item'FIRST..item'LAST LOOP IF virtual_screen.element(temp_row).length < temp_col THEN EXIT ; pad_it := true ; END IF ; item( i ) := virtual_screen.element(temp_row). data(temp_col) ; next_position( temp_row, temp_col ) ; END LOOP ; -- pad the output string, if necessary IF pad_it THEN FOR j IN i..item'LAST LOOP item(j) := ' ' ; END LOOP ; END IF ; -- move active position to next position next_position( temp_row, temp_col ) ; virtual_screen.active_position.row_position := temp_row ; virtual_screen.active_position.col_position := temp_col ; END get; PRAGMA page ; PROCEDURE erase_area IS space : CONSTANT CHARACTER := ' ' ; save_row, temp_row : natural := virtual_screen.active_position.row_position ; save_col, temp_col : natural := virtual_screen.active_position.col_position ; start_col,stop_col,start_row,stop_row : positive ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; IF number_of_qualified_areas = 0 THEN FOR i IN 1..vt_content.height LOOP virtual_screen.element(i).length := 0 ; END LOOP ; ELSE -- find qualifier head and next qualifier head -- save these values back_tab ; start_row := virtual_screen.active_position.row_position ; start_col := virtual_screen.active_position.col_position ; tab ; stop_row := virtual_screen.active_position.row_position ; stop_col := virtual_screen.active_position.col_position ; IF start_row = stop_row THEN -- next qual. area starts on the same line -- IF virtual_screen.element(start_row).length < start_col THEN NULL ; ELSE blank_columns(start_row, start_col, stop_col-1) ; END IF ; ELSE -- next qual. area starts on a following line -- -- First, blank out appropriate positions on the -- starting line IF virtual_screen.element(start_row).length > start_col THEN virtual_screen.element(start_row).length :=start_col-1 ; END IF ; -- Then blank out all full lines between the two qual. -- heads, if any exist. temp_row := start_row ; LOOP temp_row := temp_row + 1 ; IF temp_row > vt_content.height THEN temp_row := 1 ; END IF ; EXIT WHEN temp_row = stop_row ; virtual_screen.element(temp_row).length := 0 ; END LOOP ; -- Finally, blank out appropriate positions on the line -- where the next qual. area begins IF virtual_screen.element(temp_row).length < stop_col THEN virtual_screen.element(temp_row).length := 0 ; ELSE blank_columns(stop_row, 1, stop_col - 1) ; END IF ; END IF ; -- reset active position to original values virtual_screen.active_position.row_position := save_row ; virtual_screen.active_position.col_position := save_col ; END IF ; END erase_area; PRAGMA page ; PROCEDURE erase_display IS save_pos : vt_content.vt_position_xy_record := virtual_screen. active_position ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; --set active position at (1, 1) and then --erase all lines virtual_screen.active_position := vt_content. vt_position_xy_record'(1, 1) ; FOR i IN 1..vt_content.height LOOP virtual_screen.element( i ).length := 0 ; END LOOP ; --clear all qualified areas on the virtual display FOR i IN 1..number_of_qualified_areas LOOP --tab to each qualified area and clear it --screen should be protected and primary rendition --when finished tab ; clear_qualified_area ; END LOOP ; -- reset active position virtual_screen.active_position := save_pos ; END erase_display ; PRAGMA page ; PROCEDURE activate_form IS SEPARATE ; PRAGMA page ; FUNCTION is_form_updated RETURN boolean IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; RETURN form_is_modified ; END is_form_updated; PRAGMA page ; FUNCTION area_qualifier_requires_space RETURN boolean IS BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; RETURN true ; END area_qualifier_requires_space ; PRAGMA page ; FUNCTION termination_key RETURN termination_key_range IS temp_value : termination_key_range ; BEGIN IF NOT initialized THEN RAISE uninitialized ; END IF ; CASE function_key_struck IS WHEN vt_input.f1 => temp_value := 1; WHEN vt_input.f2 => temp_value := 2; WHEN vt_input.f3 => temp_value := 3; WHEN vt_input.f4 => temp_value := 4; WHEN vt_input.f5 => temp_value := 5; WHEN vt_input.f6 => temp_value := 6; WHEN vt_input.f7 => temp_value := 7; WHEN vt_input.f8 => temp_value := 8 ; WHEN vt_input.f9 => temp_value := 9 ; WHEN vt_input.f10 => temp_value := 10; WHEN vt_input.f11 => temp_value := 11; WHEN vt_input.f12 => temp_value := 12; WHEN vt_input.f13 => temp_value := 13; WHEN vt_input.f14 => temp_value := 14; WHEN vt_input.f15 => temp_value := 15; WHEN vt_input.f16 => temp_value := 16; WHEN vt_input.f17 => temp_value := 17; WHEN vt_input.f18 => temp_value := 18; WHEN vt_input.f19 => temp_value := 19; WHEN vt_input.f20 => temp_value := 20; WHEN vt_input.f21 => temp_value := 21; WHEN vt_input.f22 => temp_value := 22; WHEN vt_input.f23 => temp_value := 23; WHEN vt_input.f24 => temp_value := 24; WHEN vt_input.f25 => temp_value := 25; WHEN vt_input.f26 => temp_value := 26; WHEN vt_input.f27 => temp_value := 27; WHEN vt_input.f28 => temp_value := 28; WHEN vt_input.f29 => temp_value := 29; WHEN vt_input.f30 => temp_value := 30; WHEN vt_input.f31 => temp_value := 31; WHEN vt_input.f32 => temp_value := 32; WHEN OTHERS => NULL; END CASE ; RETURN (temp_value) ; END termination_key; PRAGMA page ; BEGIN -- form_terminal NULL; END form_terminal; :::::::::: activate_form.ada :::::::::: -- ----------------------------------------------------------------------------- -- ABSTRACT: This procedure is part of the FORM_TERMINAL package. -- A call upon form_terminal.activate_form will map the virtual -- terminal display into the actual terminal display and allow -- editing of the form without user program intervention. When -- the user has finished editing the form the user presses a -- function key ( as defined in the terminal capabilities file) -- which returns control to the user's program. -- ---------------------------------------------------------------------------- WITH driver, redisplay , vt_input ; SEPARATE( form_terminal ) PROCEDURE activate_form IS key_name : string(1..11) ; key_id : vt_input.function_key_enum ; prev_pos : natural ; leave_body : BOOLEAN := FALSE ; count : natural := 0 ; data : string(1..80) ; last : natural ; keys : vt_input.function_key_descriptor( 32 ) ; number_of_function_keys : natural ; last_position : natural ; i : positive ; bell : string(1..1) := string'(1 => ascii.bel) ; PROCEDURE handle_function_key ( key_id : IN vt_input. function_key_enum ; leave_body : OUT BOOLEAN ) IS temp_row : positive := virtual_screen.active_position.row_position; temp_col : positive := virtual_screen.active_position.col_position; BEGIN IF key_id IN vt_input.f1..vt_input.f32 THEN leave_body := TRUE ; ELSE leave_body := FALSE; CASE key_id IS WHEN vt_input.up_arrow => IF temp_row = 1 THEN temp_row := vt_content.height ; ELSE temp_row := temp_row - 1 ; END IF ; WHEN vt_input.down_arrow => IF temp_row = vt_content.height THEN temp_row := 1 ; ELSE temp_row := temp_row + 1 ; END IF ; WHEN vt_input.left_arrow => previous_position( temp_row, temp_col ) ; WHEN vt_input.right_arrow => next_position( temp_row, temp_col ) ; WHEN OTHERS => NULL ; END CASE ; virtual_screen.active_position.row_position := temp_row ; virtual_screen.active_position.col_position := temp_col ; redisplay.fix_cursor( actual_screen, virtual_screen ) ; END IF ; END handle_function_key ; PRAGMA page ; PROCEDURE handle_string( data : IN string ; last : IN natural ) IS top_line, bottom_line, temp_row : positive := virtual_screen.active_position.row_position ; temp_col : positive := virtual_screen.active_position.col_position ; ok : BOOLEAN ; count : NATURAL := 0 ; input_type : vt_content.area_qualifiers_enum ; save_row, save_col : positive ; only_cursor_movement : BOOLEAN := true ; BEGIN -- handle string FOR i IN 1..last LOOP CASE data(i) IS WHEN ascii.cr => temp_row := virtual_screen.active_position .row_position ; temp_col := virtual_screen.active_position .col_position ; temp_col := 1 ; IF temp_row = vt_content.height THEN temp_row := 1 ; ELSE temp_row := temp_row + 1 ; END IF ; virtual_screen.active_position. row_position:= temp_row ; virtual_screen.active_position. col_position:= temp_col ; WHEN ascii.del=> temp_row := virtual_screen.active_position .row_position ; temp_col := virtual_screen.active_position .col_position ; previous_position( temp_row, temp_col ) ; IF (virtual_screen.element(temp_row). descriptors(temp_col).qualifiers = vt_content.dqnn) THEN driver.interpret( bell ) ; ELSE form_is_modified := true ; virtual_screen.element(temp_row).data (temp_col) := ' ' ; END IF ; only_cursor_movement := false ; virtual_screen.active_position. row_position:= temp_row ; virtual_screen.active_position. col_position:= temp_col ; WHEN ascii.ht => count := 0 ; save_row := virtual_screen.active_position. row_position ; save_col := virtual_screen.active_position. col_position ; LOOP tab ; next_position( virtual_screen.active_position. row_position, virtual_screen.active_position. col_position ) ; IF virtual_screen.element( virtual_screen.active_position. row_position).descriptors(virtual_screen. active_position.col_position). qualifier_head THEN -- special case, two qualiifer heads -- in immediate succession next_position( virtual_screen.active_position. row_position, virtual_screen.active_position. col_position ) ; END IF ; count := count + 1; EXIT WHEN (virtual_screen.element( virtual_screen.active_position. row_position).descriptors(virtual_screen. active_position.col_position).qualifiers /= vt_content.dqnn) OR (count > number_of_qualified_areas) ; END LOOP ; IF count > number_of_qualified_areas THEN virtual_screen.active_position. row_position := save_row ; virtual_screen.active_position. col_position := save_col ; END IF ; WHEN OTHERS => temp_row := virtual_screen.active_position .row_position ; temp_col := virtual_screen.active_position .col_position ; only_cursor_movement := false ; input_type := virtual_screen.element (temp_row).descriptors(temp_col). qualifiers ; CASE input_type IS WHEN vt_content.dqnn => ok := FALSE ; WHEN vt_content.dqag => IF data(i) IN ' '..'~' THEN ok := TRUE ; ELSE ok := FALSE; END IF ; WHEN vt_content.dqan => IF data(i) IN '0'..'9' THEN ok := TRUE ; ELSE ok := FALSE; END IF ; END CASE ; IF ok THEN put(data(i) ) ; form_is_modified := true ; IF virtual_screen.active_position. row_position IN top_line..bottom_line THEN NULL ; ELSIF virtual_screen.active_position. row_position < top_line THEN top_line := virtual_screen. active_position.row_position ; ELSE bottom_line := virtual_screen. active_position.row_position ; END IF ; ELSE driver.interpret( bell ) ; END IF ; END CASE ; END LOOP ; -- redisplay line with new additions IF only_cursor_movement THEN redisplay.fix_cursor( actual_screen, virtual_screen ) ; ELSE IF top_line = bottom_line THEN redisplay.redisplay_line_with_redraw( actual_screen, virtual_screen, top_line, top_line ) ; ELSE redisplay.redisplay_screen_with_redraw( actual_screen, virtual_screen, top_line, bottom_line ) ; END IF ; redisplay.fix_cursor( actual_screen, virtual_screen ) ; END IF ; END handle_string ; PRAGMA page ; BEGIN -- activate form IF NOT initialized THEN RAISE uninitialized ; END IF ; form_is_modified := false ; IF number_of_qualified_areas = 0 THEN -- set screen protected and primary rendition set_position( xy_position'(1, 1) ) ; FOR i IN 1..vt_content.height LOOP FOR j IN 1..vt_content.width LOOP virtual_screen.element(i).descriptors(j). qualifiers := vt_content.dqnn ; virtual_screen.element(i).descriptors(j). rendition := vt_content.sgpr ; END LOOP ; END LOOP ; ELSE -- move cursor to first unprotected area on the -- display if one exists set_position( xy_position'(vt_content.height, vt_content.width - 1) ) ; LOOP tab ; next_position( virtual_screen.active_position.row_position, virtual_screen.active_position.col_position ) ; count := count + 1 ; EXIT WHEN (virtual_screen.element(virtual_screen.active_position .row_position).descriptors(virtual_screen. active_position.col_position).qualifiers /= vt_content.dqnn) OR (count > number_of_qualified_areas) ; END LOOP ; IF count > number_of_qualified_areas THEN -- no unprotected areas defined, set act pos to 1,1 set_position( xy_position'(1, 1) ) ; END IF ; END IF ; redisplay.redisplay_screen_with_redraw( actual_screen, virtual_screen, 1, vt_content.height ) ; redisplay.fix_cursor( actual_screen, virtual_screen ) ; -- begin local editting local_editting_loop : LOOP vt_input.get( data, last, keys ) ; number_of_function_keys := vt_input.function_count( keys ) ; IF last = 0 THEN IF number_of_function_keys = 0 THEN NULL ; ELSE FOR i IN 1..number_of_function_keys LOOP vt_input.function_key( keys, i, key_id, prev_pos ) ; handle_function_key( key_id, leave_body ) ; IF leave_body THEN EXIT local_editting_loop ; END IF ; END LOOP ; END IF ; ELSE IF number_of_function_keys = 0 THEN handle_string( data, last ) ; ELSE last_position := 1 ; FOR i IN 1..number_of_function_keys LOOP vt_input.function_key( keys, i, key_id, prev_pos ) ; IF prev_pos /= 0 THEN handle_string( data(last_position.. prev_pos), (prev_pos - last_position + 1)) ; last_position := prev_pos + 1; END IF ; handle_function_key( key_id, leave_body ) ; IF leave_body THEN EXIT local_editting_loop ; END IF ; END LOOP ; IF last_position <= last THEN handle_string( data( last_position..last ), (last - last_position + 1)) ; END IF ; END IF ; END IF ; END LOOP local_editting_loop ; function_key_struck := key_id ; END activate_form ; :::::::::: tcf :::::::::: t1|tv970|tv-970|televideo 970:\ :al=1*\E[1L:am:bs:cd=\E[J:ce=\E[K:cl=\E[2J:cm=\E[%i%2;%2H:co#80:\ :dc=\E[1P:dl=1*\E[1M:dn=\E[1B:ei=\E[4l:ho=\E[H:im=\E[4h:li#24:mi:\ :nd=\E[1C:as=\E[10m:ae=\E[11m:ms:pt:se=\E[0m:so=\E[7m:up=\E[1A:\ :vs=\E[>4h:ve=\E[>4l:kb=^h:ku=\E[1A:kd=\E[1B:kl=\E[1D:kr=\E[1C:\ :kh=\E[H:kn#8:k1=\EOS:k2=\EOT:k3=\EOU:k4=\EOV:k5=\EOW:l6=blue:\ :sr=\EM:is=\E<\E[2J:\ :ca=\E[2K:ds=\E[?2l:\ :l1=F1:l2=F2:l3=F3:l4=F4:l5=F5:l6=F6:l7=F7:l8=F8:l9=F9:y0=F10:\ :y1=F11:y2=F12:y3=F13:y4=F14:y5=F15:y6=F16:\ :y7=Shift F1:y8=Shift F2:y9=Shift F3:h0=Shift F4:h1=Shift F5:\ :h2=Shift F6:h3=Shift F7:h4=Shift F8:h5=Shift F9:h6=Shift F10:\ :h7=Shift F11:h8=Shift F12:h9=Shift F13:v0=Shift F14:v1=Shift F15:\ :v2=Shift F16:an:\ :k1=\E?a:k2=\E?b:k3=\E?c:k4=\E?d:k5=\E?e:k6=\E?f:k7=\E?g:k8=\E?h:\ :k9=\E?i:x0=\E?j:x1=\E?k:x2=\E?l:x3=\E?m:x4=\E?n:x5=\E?o:x6=\E?p:\ :x7=\E?A:x8=\E?B:x9=\E?C:g0=\E?D:g1=\E?E:g2=\E?F:g3=\E?G:g4=\E?H:\ :g5=\E?I:g6=\E?J:g7=\E?K:g8=\E?L:g9=\E?M:t0=\E?N:t1=\E?O:t2=\E?P:\ :ku=\E[A:kd=\E[B:kr=\E[C:kl=\E[D: d1|vt100|vt-100|pt100|pt-100|dec vt100:\ :co#80:li#24:am:cl=50\E[;H\E[2J:bs:cm=5\E[%i%2;%2H:nd=2\E[C:up=2\E[A:\ :ce=3\E[K:cd=50\E[J:so=2\E[7m:se=2\E[m:us=2\E[4m:ue=2\E[m:\ :is=\E>\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h:ks=\E[?1h\E=:ke=\E[?1l\E>:\ :if=/usr/lib/tabset/vt100:ku=\EOA:kd=\EOB:kr=\EOC:kl=\EOD:\ :kh=\E[H:k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:pt:sr=5\EM: dv|vt52|dec vt52:\ :bs:cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#80:li#24:nd=\EC:\ :pt:sr=\EI:up=\EA:ku=\EA:kd=\EB:kr=\EC:kl=\ED: d5|vi50|Visual 50:\ :al=\EL:ca=\015\EK:\ :l1=F1:k1=\EP:l2=F2:k2=\EQ:\ :pt:bs:cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#80:dl=\EM:\ :li#24:nd=\EC:pt:se=\ET:so=\EU:sf=\ED:sr=\EI:up=\EA:\ :kl=\ED:vb=\E9@\E9P\E9@\E9P\E9@\E9P\E9@\E9P: # # :::::::::: term :::::::::: tv970 this is a dummy line to get around the END_ERROR problem :::::::::: recompile.cli :::::::::: ada vtcontent_spec ada sysdep_spec ada tcf_spec ada scroll_spec ada page_spec ada form_spec ada vtinput_spec ada driver_spec ada redisplay_spec ada sysdep_body ada tcf_body ada driver_body ada vtinput_body ada redisplay_body ada scroll_body ada page_body ada form_body ada activate_form