Programmer's ROM - The Computer Language Library

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

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

Wrap

Text File | 1988-05-03 | 256.1 KB | 6,469 lines

-------- SIMTEL20 Ada Software Repository Prologue ------------ -- -* -- Unit name : Menu Manager Package -- Version : 1.0 -- Contact : Lt. Colonel Falgiano -- : ESD/SCW -- : Hanscom AFB, MA 01731 -- Author : Jerry Horsewood -- : Adasoft, Inc, 9300 -- : Anapolis Road -- : Lanham, MD 20706 -- DDN Address : -- Copyright : (c) 1985 Adasoft, Inc. -- Date created : 19 January 1985 -- Release date : May 1985 -- Last update : -- -* --------------------------------------------------------------- -- -* -- Keywords : ----------------: -- -- Abstract : VIDEO is a menu manager package that is ----------------: divided into four functional areas. It will ----------------: provide application programmers with the ----------------: ability to run various application systems ----------------: from a menu driven user interface. ----------------: Applications to be invoked via menu selections ----------------: may be written in any language providing the ----------------: PRAGMA INTERFACE is supported. The four ----------------: functional areas are initialization of the ----------------: overall application system, modeling of the ----------------: application system, running the application, ----------------: and diagramming the system. ----------------: ----------------: 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 -- 05/84 1.0 Jerry Horsewood 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 ------------------------------- --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --caisioco.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: CAIS_IO_CONTROL * -- * VERSION: 1.0a1 * -- * DATE : APRIL, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- CAIS_IO_CONTROL contains some definitions redefined in CAIS_PAGE_TERMINAL -- package CAIS_IO_CONTROL is type FILE_TYPE is ( CURRENT_INPUT, CURRENT_OUTPUT ); type SELECT_ENUMERATION is ( FROM_ACTIVE_POSITION_TO_END, FROM_START_TO_ACTIVE_POSITION, ALL_POSITIONS ); type FUNCTION_KEY_DESCRIPTOR is ( KBS, KINSCH ); end CAIS_IO_CONTROL; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --caisio.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: CAIS_IO * -- * VERSION: 1.0a1 * -- * DATE : APRIL, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- CAIS_IO contains the procedures used to read from the keyboard and -- write to the terminal. This is NOT a CAIS standard package. Used only -- in the package body of CAIS_PAGE_TERMINAL. The package body has an -- initialization section that opens the keyboard file, using the result -- of TEXT_IO.STANDARD_INPUT for the name string . -- package CAIS_IO is procedure GET ( ITEM : out CHARACTER ); -- Get uses Sequential_io to get characters from the keyboard -- procedure PUT ( ITEM : in CHARACTER ); -- Put is used to write characters to the screen -- procedure PUT ( STR : in STRING ); -- Put is used to write escape sequences to the terminal -- end CAIS_IO; with TEXT_IO, SEQUENTIAL_IO; package body CAIS_IO is package NEW_IO is new SEQUENTIAL_IO ( CHARACTER ); use NEW_IO; KEYBOARD : FILE_TYPE; procedure GET ( ITEM : out CHARACTER ) is begin NEW_IO.READ ( KEYBOARD, ITEM ); end GET; procedure PUT ( ITEM : in CHARACTER ) is begin TEXT_IO.PUT ( ITEM ); end PUT; procedure PUT ( STR : in STRING ) is begin TEXT_IO.PUT ( STR ); end PUT; begin OPEN ( KEYBOARD, IN_FILE, TEXT_IO.NAME(TEXT_IO.STANDARD_INPUT) ); end CAIS_IO; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --passprocs.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: PASS_PROCS * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the definition of the Password type used throughout -- VIDEO, and the subroutines used for manipulating that password. -- package PASS_PROCS is type PASSWORD_TYPE is private; procedure STRING_TO_PASS ( STR : in STRING; LNTH : in NATURAL; PASS : out PASSWORD_TYPE ); -- procedure string_to_pass takes a string of up to eight characters (and -- the string length), and returns an encoded password. function PASS_TO_STRING ( PASS : in PASSWORD_TYPE ) return STRING; -- pass_to_string takes an encoded password and returns it in a decoded string; function VERIFY_PASSWORD ( PASS1 : in PASSWORD_TYPE; PASS2 : in PASSWORD_TYPE ) return BOOLEAN; -- verify password compares two passwords and returns true if they match. function HAS_PASSWORD ( PASS : in PASSWORD_TYPE ) return BOOLEAN; -- has_password determines if the password flag has been set. private type PASSWORD_TYPE is record LNTH : NATURAL range 1..8 := 0; STR : STRING (1..8) := " "; FLAG : BOOLEAN := FALSE; end record; end PASS_PROCS; package body PASS_PROCS is type ENCIPHER_MODE is ( ENCIPHER, DECIPHER ); procedure NBS_ENCIPHER ( PASS : in out PASSWORD_TYPE; MODE : in ENCIPHER_MODE ) is -- nbs_encipher is a non-exportable routine that enciphers or deciphers the -- password string in a password. begin for I in 1..PASS.LNTH loop if MODE = ENCIPHER then PASS.STR(I) := CHARACTER'val( CHARACTER'pos( PASS.STR(I) ) - 32 + I ); else -- mode = decipher PASS.STR(I) := CHARACTER'val( CHARACTER'pos( PASS.STR(I) ) + 32 - I ); end if; -- mode = encipher end loop; -- 1..pass.lnth loop end NBS_ENCIPHER; procedure STRING_TO_PASS ( STR : in STRING; LNTH : in NATURAL; PASS : out PASSWORD_TYPE ) is TEMP_PASS : PASSWORD_TYPE; begin if LNTH > 0 then TEMP_PASS.FLAG := TRUE; TEMP_PASS.STR(1..LNTH) := STR(1..LNTH); TEMP_PASS.LNTH := LNTH; end if; -- lnth > 0 NBS_ENCIPHER ( TEMP_PASS, ENCIPHER ); PASS := TEMP_PASS; end STRING_TO_PASS; function PASS_TO_STRING ( PASS : in PASSWORD_TYPE ) return STRING is TEMP_PASS : PASSWORD_TYPE; begin TEMP_PASS := PASS; NBS_ENCIPHER ( TEMP_PASS, DECIPHER ); if TEMP_PASS.FLAG then return TEMP_PASS.STR; end if; -- only if it has a password end PASS_TO_STRING; function VERIFY_PASSWORD ( PASS1 : in PASSWORD_TYPE; PASS2 : in PASSWORD_TYPE ) return BOOLEAN is RETURN_VAL : BOOLEAN := FALSE; begin -- if they are equal in length and then they match character for character. if PASS1.LNTH = PASS2.LNTH and then PASS1.STR(1..PASS1.LNTH) = PASS2.STR(1..PASS1.LNTH) then RETURN_VAL := TRUE; end if; return RETURN_VAL; end VERIFY_PASSWORD; function HAS_PASSWORD ( PASS : in PASSWORD_TYPE ) return BOOLEAN is begin return PASS.FLAG; end HAS_PASSWORD; end PASS_PROCS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --vidtypes.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: VIDEO_TYPES * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the global types, constants and variables used -- in all the VIDEO procedures. -- with PASS_PROCS; package VIDEO_TYPES is -- -- Global exceptions -- USER_QUIT : exception; BAD_PASSWORD : exception; -- -- General constants and types -- subtype PRINTABLE is CHARACTER range ' '..'~'; subtype LOWER_CASE is CHARACTER range 'a'..'z'; -- Terminal constants and types -- FIRST_COL : constant NATURAL := 0; FIRST_ROW : constant NATURAL := 0; LAST_ROW : constant NATURAL := 23; LAST_COL : constant NATURAL := 79; MAX_LINE_LNTH : constant NATURAL := LAST_COL + 1; MAX_DISP_LINES : constant NATURAL := LAST_ROW - 3; subtype COLUMN is NATURAL range FIRST_COL..LAST_COL; subtype ROWS is NATURAL range FIRST_ROW..LAST_ROW; type POSITION_TYPE is record COL : COLUMN; ROW : ROWS; end record; HOME_POSITION : constant POSITION_TYPE := ( FIRST_COL, FIRST_ROW ); MAX_POSITION : constant POSITION_TYPE := ( LAST_COL, LAST_ROW ); ERROR_LINE : constant POSITION_TYPE := ( FIRST_COL, LAST_ROW - 1 ); PROMPT_LINE : constant POSITION_TYPE := ( FIRST_COL, LAST_ROW ); type PAGE_LINE is record LNTH : POSITIVE range 1..MAX_LINE_LNTH; LINE : STRING (1..MAX_LINE_LNTH); end record; type TEXT_PAGE is array (1..MAX_DISP_LINES) of PAGE_LINE; subtype HEADER_LINES is INTEGER range 1..5; type HEADER_TYPE is array ( HEADER_LINES ) of STRING(1..MAX_LINE_LNTH); -- -- VIDEO constants and types -- type FLAG is ( ON, OFF ); type OPTIONS is ( CR, SLASH, C, I, M, R, T, X, Z, ONE, TWO, THREE, FOUR, FIVE, SIX, SEVEN, EIGHT, NINE, TEN, ELEVEN, TWELVE, THIRTEEN, FOURTEEN, FIFTEEN ); subtype CHOICES is OPTIONS range ONE..FIFTEEN; type MENU_OPTIONS is array (CHOICES) of NATURAL; type VALID is array (OPTIONS) of STRING (1..2); type NODE is ( BOOT, MENU, INSTRUCTION, PROGRAM ); subtype USER_NODE is NODE range MENU..PROGRAM; type NAME_REC is record LENGTH : POSITIVE range 1..20 := 20; NAME : STRING (1..20) := " "; end record; type FILE_NAME is record DEV : NAME_REC := (14," "); DIR : NAME_REC; FIL : NAME_REC := (13," "); end record; type FILESPEC is record LENGTH : POSITIVE range 1..75 := 1; NAME : STRING (1..75); end record; type NODE_RECORD ( NODE_TYPE : NODE := MENU ) is record LAST_NODE : NATURAL; LAST_MENU : NATURAL; POSITION : NATURAL; NODE_PASSWORD : PASS_PROCS.PASSWORD_TYPE; case NODE_TYPE is when BOOT => DEFAULT : FILE_NAME; LAST_FREE_NODE : NATURAL; NEXT_FREE_NODE : NATURAL; when MENU => MENU_PATH : FILE_NAME; OPTION : MENU_OPTIONS; when others => PATH : FILE_NAME; NEXT_NODE : NATURAL; end case; end record; -- -- VIDEO global variables -- ACTIVE_POSITION : POSITION_TYPE := HOME_POSITION; ECHO_ON : BOOLEAN := TRUE; end VIDEO_TYPES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --videbug.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: VIDEO_DEBUG * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains two routines for program development. These -- routines trace exceptions from the lowest level they are raised in. -- package VIDEO_DEBUG is procedure TRACE_EXCEPTION ( MSG : in STRING ); -- this routine rights a message to a text file procedure PRINT_EXCEPTIONS; -- this routine is included in the highest routine and closes the file end VIDEO_DEBUG; with TEXT_IO;use TEXT_IO; package body VIDEO_DEBUG is PRINT : FILE_TYPE; procedure TRACE_EXCEPTION ( MSG : in STRING ) is begin while not IS_OPEN ( PRINT ) loop begin OPEN ( PRINT, OUT_FILE, "ERRORS.TXT" ); exception when NAME_ERROR => CREATE ( PRINT, OUT_FILE, "ERRORS.TXT" ); end; end loop; PUT_LINE ( PRINT, MSG ); exception when others => CLOSE ( PRINT ); raise; end TRACE_EXCEPTION; procedure PRINT_EXCEPTIONS is begin CLOSE ( PRINT ); exception when others => raise; end PRINT_EXCEPTIONS; end VIDEO_DEBUG; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --commsgs.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: COMMON_MESSAGES * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the common_messages used throughout VIDEO -- package COMMON_MESSAGES is type ERRS is ( NODETYPE, FILE_ACCESS, INVALID_RESP, CR_INVAL, PROC_TERM, INV_BR_NO, INV_NODETYPE, INV_FILNAM, INV_PASS, NON_NUMERIC, OPEN_ERR, INV_DIRNAM, INV_DEVNAM ); type COMMON_ERRORS is array (ERRS) of STRING (1..80); type MSGS is ( SUCCESS, CUR_FILNAM, CUR_DIRNAM, CUR_DEV, SUCCESS_INIT ); type COMMON_MSGS is array (MSGS) of STRING (1..80); type MENU_TYPES is ( COPYRIGHT, MAINT ); subtype LINES is INTEGER range 1..22; type MENU_TABLE is array (MENU_TYPES, LINES) of STRING (1..80); type MENU_LINES is array (MENU_TYPES ) of LINES; BLANKS : constant STRING (1..19) := " "; ERRORS : constant COMMON_ERRORS := ( "**ERROR**NODE TYPE OUT-OF-RANGE " & BLANKS, "**ERROR**UNABLE TO ACCESS FILE " & BLANKS, "**ERROR**RESPONSE IS NOT A VALID OPTION OR SPECIAL CHARACTER " & BLANKS, "**ERROR**CARRIAGE RETURN RESPONSE IS NOT ACCEPTABLE " & BLANKS, "**ERROR**PROCESS TERMINATED - REASON " & BLANKS, "**ERROR**INVALID BRANCH NUMBER ENTERED " & BLANKS, "**ERROR**INVALID NODE TYPE ENTERED " & BLANKS, "**ERROR**INVALID FILE NAME ENTERED " & BLANKS, "**ERROR**INVALID PASSWORD ENTERED " & BLANKS, "**ERROR**NON-NUMERIC DATA ENTERED " & BLANKS, "**ERROR**OPEN ERROR OCCURRED WHILE ATTEMPTING TO OPEN FILE " & BLANKS, "**ERROR**INVALID DIRECTORY NAME ENTERED " & BLANKS, "**ERROR**INVALID DEVICE NAME ENTERED " & BLANKS ); MESSAGES : constant COMMON_MSGS := ( "PROCESS HAS COMPLETED SUCCESSFULLY " & BLANKS, "THE CURRENT FILE NAME IS " & BLANKS, "THE CURRENT DIRECTORY NAME IS " & BLANKS, "THE CURRENT DEVICE NAME IS " & BLANKS, "APPLICATION MODEL INITIALIZATION HAS COMPLETED SUCCESSFULLY " & BLANKS); LAST_LINE : MENU_LINES := ( 6, 7 ); MENU_BLANKS : STRING(1..15) := " "; MENUS : MENU_TABLE := ( (1=>MENU_BLANKS & "VIDEO VERSION 1 LEVEL 0 RELEASE DATE: MAY-30-1985" & MENU_BLANKS, 2=>MENU_BLANKS & " " & MENU_BLANKS, 3=>MENU_BLANKS & " Developed by AdaSoft, Inc., Lanham, MD. " & MENU_BLANKS, 4=>MENU_BLANKS & " For Naval Ocean Systems Center, San Diego, CA. " & MENU_BLANKS, 5=>MENU_BLANKS & " Under Contract No. N66001-85-C-0049 " & MENU_BLANKS, 6..22=> MENU_BLANKS & " " & MENU_BLANKS ), (1=>MENU_BLANKS & " * * * * M A I N T E N A N C E M E N U * * * * " & MENU_BLANKS, 2=>MENU_BLANKS & " " & MENU_BLANKS, 3=>MENU_BLANKS & " 1. ADD A NODE " & MENU_BLANKS, 4=>MENU_BLANKS & " 2. MODIFY/DISPLAY NODE " & MENU_BLANKS, 5=>MENU_BLANKS & " 3. DELETE ONE OR MORE NODES " & MENU_BLANKS, 6=>MENU_BLANKS & " 4. INSERT A NODE " & MENU_BLANKS, 7=>MENU_BLANKS & " 5. MOVE A SUBMODEL " & MENU_BLANKS, 8..22 => MENU_BLANKS & " " & MENU_BLANKS )); end COMMON_MESSAGES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --prompts.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: PROMPT_MESSAGES * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the prompts used throughout VIDEO -- package PROMPT_MESSAGES is type PROMPTS is ( OPTION_NO, SLASH_RTN, ADD_BR_NO, ADD_TYP, ADD_FILNAM, PASSWRD, EXIT_MAINT, DEL_BR_NO, NEW_FILNAM, NEW_PASS, DEL, CNCT_BR, CR_GO, PASS_APL_MDL, PASS_RUN_APL, DEL_NOD, CR_GO_SL_RTN, DEL_THIS_NOD, MOD_APL_PRMS, MOD_DEL_PRMS, PASS_APL_MORE, DEL_PASS, RTNOD_DIR, NAM_APL_INIT, PASS_MDL, RTNOD_NAM, PASS_RUN_APPL, RTNOD_TYP, DIRNAM, DIRNAM_APL_MDL, NEW_DIRNAM, DEVNAM, DEVNAM_APL_MDL, NEW_DEVNAM, RTNOD_DEV, APL_NAM, BR_NO_MOV_FRM, BR_NO_MOV_TO, FILNAM ); type PROMPT_MSGS is array ( PROMPTS ) of STRING (1..72); BLANKS : constant STRING (1..8) := " "; PROMPT : PROMPT_MSGS := ( "ENTER NUMBER CORRESPONDING TO SELECTED OPTION " & BLANKS, "ENTER SLASH TO RETURN TO LAST MENU " & BLANKS, "ENTER BRANCH NUMBER TO WHICH NODE IS TO BE ADDED " & BLANKS, "ENTER TYPE OF NODE TO BE ADDED (MENU, INST, PROG ) " & BLANKS, "ENTER FILE NAME OF NODE TO BE ADDED " & BLANKS, "ENTER PASSWORD OR CARRIAGE RETURN IF NONE " & BLANKS, "ENTER CARRIAGE RETURN TO EXIT FROM MAINTENANCE " & BLANKS, "ENTER BRANCH NUMBER FOR PORTION OF MODEL TO BE DELETED " & BLANKS, "ENTER NEW FILE NAME OR CARRIAGE RETURN IF NONE " & BLANKS, "ENTER NEW PASSWORD OR CARRIAGE RETURN IF NONE " & BLANKS, "ENTER 'YES' TO PERFORM DELETION " & BLANKS, "ENTER BRANCH NUMBER FOR CONNECTION OF REMAINING MODEL " & BLANKS, "ENTER CARRIAGE RETURN TO CONTINUE " & BLANKS, "ENTER PASSWORD TO ACCESS THE APPLICATION MODEL " & BLANKS, "ENTER PASSWORD TO RUN THE APPLICATION " & BLANKS, "ENTER 'YES' TO DELETE ONLY THE SPECIFIED NODE " & BLANKS, "ENTER CARRIAGE RETURN TO CONTINUE - SLASH TO RETURN TO LAST MENU" & BLANKS, "ENTER 'YES' TO INCLUDE THIS NODE IN DELETION " & BLANKS, "ENTER 'YES' TO MODIFY APPLICATION SYSTEM PARAMETERS " & BLANKS, "ENTER 'YES' TO MODIFY OR DELETE THE PARAMETER STRING " & BLANKS, "ENTER PASSWORD TO ACCESS APPLICATION BEYOND THIS POINT " & BLANKS, "ENTER 'YES' TO DELETE THE CURRENT PASSWORD " & BLANKS, "ENTER ROOT NODE DIRECTORY OR CARRIAGE RETURN FOR DEFAULT " & BLANKS, "ENTER NAME OF APPLICATION MODEL BEING INITIALIZED " & BLANKS, "ENTER PASSWORD FOR ACCESS TO MODEL (1-8 CHARACTERS) " & BLANKS, "ENTER FILE NAME OF ROOT NODE FOR APPLICATION MODEL " & BLANKS, "ENTER PASSWORD TO RUN APPLICATION (1-8 CHARACTERS) " & BLANKS, "ENTER APPLICATION MODEL ROOT NODE TYPE ( MENU, INST ) " & BLANKS, "ENTER DIRECTORY NAME OR CARRIAGE RETURN FOR DEFAULT " & BLANKS, "ENTER NAME OF DIRECTORY CONTAINING APPLICATION MODEL " & BLANKS, "ENTER NEW DIRECTORY NAME OR CARRIAGE RETURN FOR DEFAULT " & BLANKS, "ENTER DEVICE NAME OR CARRIAGE RETURN FOR DEFAULT " & BLANKS, "ENTER NAME OF DEVICE CONTAINING APPLICATION MODEL " & BLANKS, "ENTER NEW DEVICE NAME OR CARRIAGE RETURN FOR DEFAULT " & BLANKS, "ENTER ROOT NODE DEVICE OR CARRIAGE RETURN FOR DEFAULT " & BLANKS, "ENTER NAME OF APPLICATION TO BE RUN " & BLANKS, "ENTER BRANCH NUMBER FROM WHICH SUBMODEL IS TO BE MOVED " & BLANKS, "ENTER BRANCH NUMBER TO WHICH SUBMODEL IS TO BE MOVED " & BLANKS, "ENTER FILE NAME OR CARRIAGE RETURN IF NONE " & BLANKS ); end PROMPT_MESSAGES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --caispage.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: CAIS_PAGE_TERMINAL * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the underlying terminal control features used -- in all the VIDEO procedures. The interface specifications are in -- conformance with the proposed CAIS Standard, and packages for specific -- terminals that conform to this standard may be substituted. -- -- The body for this package currently controls the terminal features of an -- ANSII terminal (in the package ANSII_TERMINAL), and it will be necessary to -- modify this for other terminal types. -- with CAIS_IO_CONTROL, VIDEO_TYPES; package CAIS_PAGE_TERMINAL is -- ******************************** -- * NOTE: the following subtypes * -- * are redefinitions of types * -- * declared in CAIS_IO_CONTROL. * -- ******************************** subtype FILE_TYPE is CAIS_IO_CONTROL.FILE_TYPE; subtype POSITION_TYPE is VIDEO_TYPES.POSITION_TYPE; subtype SELECT_ENUMERATION is CAIS_IO_CONTROL.SELECT_ENUMERATION; subtype FUNCTION_KEY_DESCRIPTOR is CAIS_IO_CONTROL.FUNCTION_KEY_DESCRIPTOR; procedure SET_POSITION ( TERMINAL : in FILE_TYPE; POSITION : in POSITION_TYPE ); -- Set_position sets the position of the cursor on the screen and updates -- the current position maintained as a global in VIDEO_TYPES. function POSITION ( TERMINAL : in FILE_TYPE ) return POSITION_TYPE; -- Position returns the current cursor position as a point_record. function SIZE ( TERMINAL : in FILE_TYPE ) return POSITION_TYPE; -- Position returns the maximum screen size as a point_record. procedure PUT ( TERMINAL : in FILE_TYPE; ITEM : in CHARACTER ); -- Put places a single character on the screen at the active cursor position -- and updates the active position by one. procedure ERASE_CHARACTER ( TERMINAL : in FILE_TYPE; COUNT : in POSITIVE := 1 ); -- Erase_character erases the character immediately left of the cursor and -- places the cursor at that location. procedure SET_ECHO ( TERMINAL : in FILE_TYPE; TO : in BOOLEAN := TRUE ); -- Set_echo sets the global Echo_on in Video_types either on(TRUE) or off. function ECHO ( TERMINAL : in FILE_TYPE ) return BOOLEAN; -- Returns the current state of Video_types.Echo_on. procedure GET ( TERMINAL : in FILE_TYPE; ITEM : out CHARACTER; KEYS : in out FUNCTION_KEY_DESCRIPTOR ); -- Get captures a character or function key from the user. procedure GET ( TERMINAL : in FILE_TYPE; ITEM : out STRING; LAST : out NATURAL; KEYS : in out FUNCTION_KEY_DESCRIPTOR ); -- Gets a string by making repeated calls to Get ( character ); procedure ERASE_IN_DISPLAY ( TERMINAL : in FILE_TYPE; SELECTION : in SELECT_ENUMERATION ); -- Erase_in_display erases all or part of the screen, depending on the -- selection. procedure ERASE_IN_LINE ( TERMINAL : in FILE_TYPE; SELECTION : in SELECT_ENUMERATION ); -- Erase_in_line erases all or part of a line, depending on the selection. procedure BELL ( TERMINAL : in FILE_TYPE ); -- rings the terminal bell. end CAIS_PAGE_TERMINAL; with CAIS_IO; package body CAIS_PAGE_TERMINAL is use CAIS_IO_CONTROL, VIDEO_TYPES; -- The package ANSII_TERMINAL contains the ESC sequences used in this -- version of CAIS_PAGE_TERMINAL. Because TELESOFT-Ada Ver. 1.5 does -- not allow catenation of a character and a string, this package has -- a package body to add the ESC character to the first part of the strings. -- package ANSII_TERMINAL is ERASE : STRING(1..1); TO_END : STRING(1..2) := "[0"; FROM_BEGINNING : STRING(1..2) := "[1"; ALL_PARTS : STRING(1..2) := "[2"; OF_SCREEN : STRING(1..1) := "J"; OF_LINE : STRING(1..1) := "K"; CURSOR_MOVE : STRING(1..2) := " ["; end ANSII_TERMINAL; package body ANSII_TERMINAL is begin ERASE(1) := ASCII.ESC; CURSOR_MOVE(1) := ASCII.ESC; end ANSII_TERMINAL; use ANSII_TERMINAL; procedure UPDATE ( TERMINAL : in FILE_TYPE; POSITION : in out POSITION_TYPE ) is -- this procedure updates Video_types.active_position begin if POSITION.COL < VIDEO_TYPES.COLUMN'last then POSITION.COL := POSITION.COL + 1; else POSITION.ROW := POSITION.ROW + 1; POSITION.COL := 0; end if; end UPDATE; procedure SET_POSITION ( TERMINAL : in FILE_TYPE; POSITION : in POSITION_TYPE ) is begin CAIS_IO.PUT ( CURSOR_MOVE & INTEGER'image(POSITION.ROW) & ";" & INTEGER'image(POSITION.COL) & "H"); VIDEO_TYPES.ACTIVE_POSITION := POSITION; end SET_POSITION; function POSITION ( TERMINAL : in FILE_TYPE ) return POSITION_TYPE is begin return VIDEO_TYPES.ACTIVE_POSITION; end POSITION; function SIZE ( TERMINAL : in FILE_TYPE ) return POSITION_TYPE is begin return VIDEO_TYPES.MAX_POSITION; end SIZE; procedure PUT ( TERMINAL : in FILE_TYPE; ITEM : in CHARACTER ) is begin CAIS_IO.PUT ( ITEM ); UPDATE ( TERMINAL, VIDEO_TYPES.ACTIVE_POSITION ); end PUT; procedure ERASE_CHARACTER ( TERMINAL : in FILE_TYPE; COUNT : in POSITIVE := 1 ) is SPACE : constant CHARACTER := ' '; LAST_POSITION : POSITION_TYPE; begin LAST_POSITION := POSITION ( CURRENT_OUTPUT ); for I in 1..COUNT loop PUT ( CURRENT_OUTPUT, SPACE ); end loop; SET_POSITION ( CURRENT_OUTPUT, LAST_POSITION ); end ERASE_CHARACTER; procedure SET_ECHO ( TERMINAL : in FILE_TYPE; TO : in BOOLEAN := TRUE ) is begin VIDEO_TYPES.ECHO_ON := TO; end SET_ECHO; function ECHO ( TERMINAL : in FILE_TYPE ) return BOOLEAN is begin return VIDEO_TYPES.ECHO_ON; end ECHO; procedure GET ( TERMINAL : in FILE_TYPE; ITEM : out CHARACTER; KEYS : in out FUNCTION_KEY_DESCRIPTOR ) is begin CAIS_IO.GET ( ITEM ); end GET; procedure GET ( TERMINAL : in FILE_TYPE; ITEM : out STRING; LAST : out NATURAL; KEYS : in out FUNCTION_KEY_DESCRIPTOR ) is CHAR : CHARACTER; begin LAST := 0; loop -- continue getting characters until a <CR> is recieved GET ( TERMINAL, CHAR, KEYS ); exit when CHAR = ASCII.CR; if CHAR in VIDEO_TYPES.PRINTABLE then LAST := LAST + 1; ITEM ( LAST ) := CHAR; end if; end loop; end GET; procedure ERASE_IN_DISPLAY ( TERMINAL : in FILE_TYPE; SELECTION : in SELECT_ENUMERATION ) is begin case SELECTION is when FROM_ACTIVE_POSITION_TO_END => CAIS_IO.PUT ( ERASE & TO_END & OF_SCREEN ); when FROM_START_TO_ACTIVE_POSITION => CAIS_IO.PUT ( ERASE & FROM_BEGINNING & OF_SCREEN ); when ALL_POSITIONS => CAIS_IO.PUT ( ERASE & ALL_PARTS & OF_SCREEN ); SET_POSITION ( CURRENT_OUTPUT, HOME_POSITION ); end case; end ERASE_IN_DISPLAY; procedure ERASE_IN_LINE ( TERMINAL : in FILE_TYPE; SELECTION : in SELECT_ENUMERATION ) is LAST_POSITION : POSITION_TYPE; LINE_START : VIDEO_TYPES.POSITION_TYPE := ( 0,0 ); begin case SELECTION is when FROM_ACTIVE_POSITION_TO_END => CAIS_IO.PUT ( ERASE & TO_END & OF_LINE ); when FROM_START_TO_ACTIVE_POSITION => CAIS_IO.PUT ( ERASE & FROM_BEGINNING & OF_LINE ); when ALL_POSITIONS => LAST_POSITION := POSITION ( CURRENT_OUTPUT ); LINE_START.ROW := LAST_POSITION.ROW; SET_POSITION ( CURRENT_OUTPUT, LINE_START ); CAIS_IO.PUT ( ERASE & ALL_PARTS & OF_LINE ); SET_POSITION ( CURRENT_OUTPUT, LAST_POSITION ); end case; end ERASE_IN_LINE; procedure BELL ( TERMINAL : in FILE_TYPE ) is begin CAIS_IO.PUT ( ASCII.BEL ); end BELL; end CAIS_PAGE_TERMINAL; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --caisint.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: CAIS_INTERFACE * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the interface to the terminal control features used -- in all the VIDEO procedures. The interface specifications are in -- conformance with the proposed CAIS Standard, and packages for specific -- terminals that conform to this standard may be substituted for the -- underlying package CAIS_PAGE_TERMINAL without affecting this package. -- with VIDEO_TYPES,CAIS_IO_CONTROL, CAIS_PAGE_TERMINAL; package CAIS_INTERFACE is -- These subtypes are redefinitions of the types defined in -- CAIS_PAGE_TERMINAL -- subtype FILE_TYPE is CAIS_PAGE_TERMINAL.FILE_TYPE; subtype POSITION_TYPE is CAIS_PAGE_TERMINAL.POSITION_TYPE; subtype SELECT_ENUMERATION is CAIS_PAGE_TERMINAL.SELECT_ENUMERATION; subtype FUNCTION_KEY_DESCRIPTOR is CAIS_PAGE_TERMINAL.FUNCTION_KEY_DESCRIPTOR; procedure HANDLE_EXCEPTION ( MSG : in STRING ); -- This procedure recurs throughout all of VIDEO and allows -- unhandled exceptions to be traced from their lowest level. -- -- The following functions are in CAIS_PAGE_TERMINAL and perform -- the same function. -- procedure SET_POSITION ( POSITION : in POSITION_TYPE ); function POSITION return POSITION_TYPE; function SIZE return POSITION_TYPE; procedure PUT ( ITEM : in CHARACTER ); procedure PUT ( ITEM : in STRING ); procedure SET_ECHO ( TO : in BOOLEAN := TRUE ); function ECHO return BOOLEAN; procedure GET ( ITEM : out CHARACTER; KEYS : in out FUNCTION_KEY_DESCRIPTOR ); procedure GET ( ITEM : out STRING; LAST : out NATURAL; KEYS : in out FUNCTION_KEY_DESCRIPTOR ); procedure ERASE_CHARACTER ( COUNT : in POSITIVE := 1 ); procedure ERASE_IN_DISPLAY ( SELECTION : in SELECT_ENUMERATION ); procedure ERASE_IN_LINE ( SELECTION : in SELECT_ENUMERATION ); procedure BELL; end CAIS_INTERFACE; with VIDEO_DEBUG; package body CAIS_INTERFACE is use VIDEO_TYPES,CAIS_IO_CONTROL, CAIS_PAGE_TERMINAL; EXCEPT : constant STRING (1..34) := "EXCEPTION RAISED IN CAIS_INTERFACE"; procedure HANDLE_EXCEPTION ( MSG : in STRING ) is begin VIDEO_DEBUG.TRACE_EXCEPTION ( MSG ); end HANDLE_EXCEPTION; procedure SET_POSITION ( POSITION : in POSITION_TYPE ) is begin SET_POSITION ( CURRENT_OUTPUT, POSITION ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS SET_POSITION" ); raise; end SET_POSITION; function POSITION return POSITION_TYPE is begin return POSITION ( CURRENT_OUTPUT ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS POSITION" ); raise; end POSITION; function SIZE return POSITION_TYPE is begin return SIZE ( CURRENT_OUTPUT ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS SIZE" ); raise; end SIZE; procedure PUT ( ITEM : in CHARACTER ) is begin PUT ( CURRENT_OUTPUT, ITEM ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS PUT (character)" ); raise; end PUT; procedure PUT ( TERMINAL : in FILE_TYPE; ITEM : in STRING ) is begin for INDEX in ITEM'first..ITEM'last loop PUT ( TERMINAL, ITEM (INDEX) ); end loop; exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS PUT ( terminal, string )" ); raise; end PUT; procedure PUT ( ITEM : in STRING ) is begin PUT ( CURRENT_OUTPUT, ITEM ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS PUT (string)" ); raise; end PUT; procedure SET_ECHO ( TO : in BOOLEAN := TRUE ) is begin SET_ECHO ( CURRENT_INPUT, TO ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS SET_ECHO" ); raise; end SET_ECHO; function ECHO return BOOLEAN is begin return ECHO ( CURRENT_INPUT ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS ECHO" ); raise; end ECHO; procedure GET ( ITEM : out CHARACTER; KEYS : in out FUNCTION_KEY_DESCRIPTOR ) is begin GET ( CURRENT_INPUT, ITEM, KEYS ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS GET (character)" ); raise; end GET; procedure GET ( ITEM : out STRING; LAST : out NATURAL; KEYS : in out FUNCTION_KEY_DESCRIPTOR ) is begin GET ( CURRENT_INPUT, ITEM, LAST, KEYS ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS GET ( string )" ); raise; end GET; procedure ERASE_CHARACTER ( COUNT : in POSITIVE := 1 ) is begin ERASE_CHARACTER ( CURRENT_OUTPUT, COUNT ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS ERASE_CHARACTER" ); raise; end ERASE_CHARACTER; procedure ERASE_IN_DISPLAY ( SELECTION : in SELECT_ENUMERATION ) is begin ERASE_IN_DISPLAY ( CURRENT_OUTPUT, SELECTION ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS ERASE_IN_DISPLAY" ); raise; end ERASE_IN_DISPLAY; procedure ERASE_IN_LINE ( SELECTION : in SELECT_ENUMERATION ) is begin ERASE_IN_LINE ( CURRENT_OUTPUT, SELECTION ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS ERASE_IN_LINE" ); raise; end ERASE_IN_LINE; procedure BELL is begin BELL ( CURRENT_OUTPUT ); exception when others => HANDLE_EXCEPTION ( EXCEPT & " SUB-ROUTINE IS BELL" ); raise; end BELL; end CAIS_INTERFACE; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --comprocs.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: COMMON_PROCS * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the routines commonly used throughout VIDEO. -- with VIDEO_TYPES, PASS_PROCS, COMMON_MESSAGES; package COMMON_PROCS is type MOVEMENT is ( UP, DOWN, LEFT, RIGHT ); type NAME_PART is ( DEV, DIR, FIL ); INVALID_CHOICE : exception; -- exception raised by a user entering an invalid choice. INVALID_NAME : exception; -- exception raised by a user entering an invalid name. procedure HANDLE_EXCEPTION ( MSG : in STRING ); -- renames the procedure CAIS_INTERFACE.HANDLE_EXCEPTION; procedure HOME_CLEAR; -- moves the cursor to column 0, row 0 and clears the screen. procedure MOVE_CURSOR ( TO : in VIDEO_TYPES.POSITION_TYPE ); -- moves the cursor to a specific location on the screen and updates the -- active position. procedure CLEAR_SCREEN; -- clears the screen from the active position to the end of the screen. procedure CLEAR_LINE; -- erases the line at the active position. procedure NEXT_LINE; -- moves the cursor to the begining of the next line. If such a move would -- go past the bottom of the screen, it beeps only. procedure SKIP_LINE ( NUMBER : in POSITIVE := 1 ); -- moves the cursor down at least one line. Beeps if the move would go -- past the bottom of the screen. procedure MOVE ( DIRECTION : in MOVEMENT ); -- moves the cursor one position up, down, left or right unless such a -- move would leave the screen. procedure GET_CHAR ( CHAR : out CHARACTER ); -- gets a character from the keyboard. procedure GET_STRING ( STR : out STRING; INDEX : out NATURAL; LOCATION : in VIDEO_TYPES.POSITION_TYPE; DEFAULT : in STRING ); -- moves the cursor to a particular location and gets a string. If a default -- is supplied, and the echo is on, it is displayed. If the echo is on, the -- maximum size of the string is displayed as a string of underbars. The -- user can backspace to delete characters, and can delete all characters -- typed with CTL-U or CTL-X. procedure PUT_STRING ( STR : in STRING ); -- displays a string at the active position. procedure MSG_PROC ( MSG : in STRING; LINE : in VIDEO_TYPES.POSITION_TYPE ); -- places a message on a particular line position. procedure PROMPT_MSG ( MSG : in STRING ); -- places a prompt on the prompt_line, and leaves the active position set -- at the end of the displayed string. procedure SCREEN_DISPLAY ( WHICH : in COMMON_MESSAGES.MENU_TYPES ); -- displays the menu arrays in common_messages. function GET_INPUT return VIDEO_TYPES.OPTIONS; -- returns a valid member of the enumeration type Options. procedure GET_PASSWORD ( MSG : in STRING; PASS : out PASS_PROCS.PASSWORD_TYPE ); -- prompts for and returns the password. No default is allowed, and the -- field characters are not displayed. The echo is turned off, and -- the password is not echoed. procedure GET_NEW_PASSWORD ( MSG : in STRING; DEFAULT : in STRING; PASS : out PASS_PROCS.PASSWORD_TYPE ); -- functions the same as Get_password, however, a default is allowed and -- the user will be asked to verify the password by entering it twice. procedure GET_DEV_NAME ( PROMPT : in STRING; DEFAULT : in STRING; LENGTH : out POSITIVE; NAME : out STRING ); -- prompts for and gets the system-dependent device name. procedure GET_DIR_NAME ( PROMPT : in STRING; DEFAULT : in STRING; LENGTH : out POSITIVE; NAME : out STRING ); -- prompts for and gets the system-dependent directory name. procedure GET_FIL_NAME ( PROMPT : in STRING; DEFAULT : in STRING; LENGTH : out POSITIVE; NAME : out STRING ); -- prompts for and gets the system-dependent file name. function GET_NODE_TYPE ( MSG : in STRING ) return VIDEO_TYPES.USER_NODE; -- prompts for and gets the node type. function MATCH ( MATCH_STR : in STRING; STR : in STRING ) return NATURAL; -- determines if STR contains MATCH_STR and returns the position of the -- first occurence of MATCH_STR, or else returns 0. end COMMON_PROCS; with CAIS_IO_CONTROL, CAIS_INTERFACE, TERMINAL_CONTROL; package BODY COMMON_PROCS is use CAIS_IO_CONTROL, VIDEO_TYPES,COMMON_MESSAGES,TERMINAL_CONTROL; EXCEPT : constant STRING (1..32) := "EXCEPTION RAISED IN COMMON_PROCS"; ERROR_LINE : VIDEO_TYPES.POSITION_TYPE renames VIDEO_TYPES.ERROR_LINE; PROMPT_LINE : VIDEO_TYPES.POSITION_TYPE renames VIDEO_TYPES.PROMPT_LINE; procedure HANDLE_EXCEPTION ( MSG : in STRING ) is begin CAIS_INTERFACE.HANDLE_EXCEPTION ( MSG ); end HANDLE_EXCEPTION; function COMPRESS ( MSG : in STRING ) return STRING is -- removes spaces from the right end of a string subtype VALID_CHARS is CHARACTER range '!'..'~'; LEN : POSITIVE := 1; begin for I in reverse MSG'range loop if MSG (I) in VALID_CHARS then LEN := I; exit; end if; -- character not a space end loop; if LEN = MSG'length then return MSG (1..LEN); else -- otherwise, return the length + two spaces return MSG (1..LEN + 1); end if; -- len = msg'length exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS COMPRESS" ); raise; end COMPRESS; procedure HOME_CLEAR is begin CAIS_INTERFACE.ERASE_IN_DISPLAY ( ALL_POSITIONS ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS HOME_CLEAR" ); raise; end HOME_CLEAR; procedure MOVE_CURSOR ( TO : in VIDEO_TYPES.POSITION_TYPE ) is begin CAIS_INTERFACE.SET_POSITION ( TO ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS MOVE_CURSOR" ); raise; end MOVE_CURSOR; procedure CLEAR_SCREEN is begin CAIS_INTERFACE.ERASE_IN_DISPLAY ( FROM_ACTIVE_POSITION_TO_END ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS CLEAR_SCREEN" ); raise; end CLEAR_SCREEN; procedure CLEAR_LINE is begin CAIS_INTERFACE.ERASE_IN_LINE ( FROM_ACTIVE_POSITION_TO_END ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS CLEAR_LINE" ); raise; end CLEAR_LINE; procedure NEXT_LINE is POS : VIDEO_TYPES.POSITION_TYPE; begin POS := CAIS_INTERFACE.POSITION; if POS.ROW + 1 <= VIDEO_TYPES.LAST_ROW then POS.COL := 0; POS.ROW := POS.ROW + 1; CAIS_INTERFACE.SET_POSITION ( POS ); else -- trying to move past the last line CAIS_INTERFACE.BELL; end if; exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS NEXT_LINE" ); raise; end NEXT_LINE; procedure SKIP_LINE ( NUMBER : in POSITIVE := 1 ) is POS : VIDEO_TYPES.POSITION_TYPE; begin POS := CAIS_INTERFACE.POSITION; if POS.ROW + NUMBER <= VIDEO_TYPES.LAST_ROW then POS.COL := 0; POS.ROW := POS.ROW + NUMBER; CAIS_INTERFACE.SET_POSITION ( POS ); else -- trying to skip past the last row CAIS_INTERFACE.BELL; end if; exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS SKIP_LINE" ); raise; end SKIP_LINE; procedure MOVE ( DIRECTION : in MOVEMENT ) is CURSOR, LAST, FIRST : VIDEO_TYPES.POSITION_TYPE; begin -- get the screen minimum and maximum positions, and the cursor location. FIRST := VIDEO_TYPES.HOME_POSITION; LAST := CAIS_INTERFACE.SIZE; CURSOR := CAIS_INTERFACE.POSITION; case DIRECTION is when UP => if CURSOR.ROW < FIRST.ROW then CURSOR.ROW := CURSOR.ROW - 1; else -- illegal move CAIS_INTERFACE.BELL; end if; when DOWN => if CURSOR.ROW < LAST.ROW then CURSOR.ROW := CURSOR.ROW + 1; else -- illegal move CAIS_INTERFACE.BELL; end if; when LEFT => if CURSOR.COL > FIRST.COL then CURSOR.COL := CURSOR.COL - 1; else -- illegal move CAIS_INTERFACE.BELL; end if; when RIGHT => if CURSOR.COL < LAST.COL then CURSOR.COL := CURSOR.COL + 1; else -- illegal move CAIS_INTERFACE.BELL; end if; end case; CAIS_INTERFACE.SET_POSITION ( CURSOR ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS MOVE" ); raise; end MOVE; procedure GET_CHAR ( CHAR : out CHARACTER ) is KEY : CAIS_INTERFACE.FUNCTION_KEY_DESCRIPTOR; begin CAIS_INTERFACE.GET ( CHAR, KEY ); end GET_CHAR; procedure GET_STRING ( STR : out STRING; INDEX : out NATURAL; LOCATION : in VIDEO_TYPES.POSITION_TYPE; DEFAULT : in STRING ) is subtype CHARSET is VIDEO_TYPES.PRINTABLE; FIELDCHAR : constant CHARACTER := '_'; SPACE : constant CHARACTER := ' '; MAX_LENGTH : constant POSITIVE := STR'length; CHAR : CHARACTER; KEY : CAIS_INTERFACE.FUNCTION_KEY_DESCRIPTOR; CURSOR : VIDEO_TYPES.POSITION_TYPE; NEW_LOCATION : VIDEO_TYPES.POSITION_TYPE := LOCATION; procedure INITIALIZE_FIELD ( LOCATION : in VIDEO_TYPES.POSITION_TYPE ) is -- Initialize field moves the cursor to the specified location. If echo -- is on, it puts the fieldcharacters and the default ( if given ). It -- then moves the cursor to the field beginning. begin if CAIS_INTERFACE.ECHO then CAIS_INTERFACE.SET_POSITION ( LOCATION ); -- display field characters for the maximum length expected. for I in STR'range loop CAIS_INTERFACE.PUT ( FIELDCHAR ); end loop; CAIS_INTERFACE.SET_POSITION ( LOCATION ); if DEFAULT (1) /= ' ' then CAIS_INTERFACE.PUT ( DEFAULT ); end if; -- otherwise, no default to display end if; -- otherwise, display nothing CAIS_INTERFACE.SET_POSITION ( LOCATION ); INDEX := 0; exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS INITIALIZE_FIELD" ); raise; end INITIALIZE_FIELD; begin NEW_LOCATION.COL := NEW_LOCATION.COL + 1; INITIALIZE_FIELD ( NEW_LOCATION ); loop -- until <CR> is entered. CAIS_INTERFACE.GET ( CHAR, KEY ); exit when CHAR = ASCII.CR; if ( CHAR = ASCII.BS or CHAR = ASCII.DEL ) and then INDEX > 0 then -- user wants to backspace at least one character STR ( INDEX ) := ' '; -- remove the character from the string INDEX := INDEX - 1; -- decrement the index if CAIS_INTERFACE.ECHO then MOVE ( LEFT ); CAIS_INTERFACE.PUT ( FIELDCHAR ); MOVE ( LEFT ); if INDEX = 0 and then DEFAULT (1) /= ' ' then -- if backspacing to the begining of the field CAIS_INTERFACE.PUT ( DEFAULT ); CAIS_INTERFACE.SET_POSITION ( LOCATION ); end if; end if; -- Echo is on elsif ( CHAR = ASCII.CAN or CHAR = ASCII.NAK ) and then INDEX > 0 then -- user wants to re-type the entire field INITIALIZE_FIELD ( NEW_LOCATION ); elsif CHAR in CHARSET and then INDEX < MAX_LENGTH then -- user has entered a valid character and not exceeded field length if CAIS_INTERFACE.ECHO then if INDEX = 0 and then DEFAULT (1) /= ' ' then -- user doesn't want default so get rid of it for I in DEFAULT'range loop CAIS_INTERFACE.PUT ( FIELDCHAR ); end loop; CAIS_INTERFACE.SET_POSITION ( LOCATION ); end if; -- index = 0 and then there is a default CAIS_INTERFACE.PUT ( CHAR ); end if; -- echo is on INDEX := INDEX + 1; STR ( INDEX ) := CHAR; else -- user did something wrong (invalid character or exceeded field) CAIS_INTERFACE.BELL; end if; -- evaluation of entered character end loop; -- MAIN if INDEX = 0 and then CHAR = ASCII.CR then -- user entered nothing but a <CR> if DEFAULT (1) /= ' ' then -- user accepted default INDEX := DEFAULT'length; STR(1..INDEX) := DEFAULT; -- sets string to default end if; if CAIS_INTERFACE.ECHO then -- blank out the field CURSOR := LOCATION; CURSOR.COL := CURSOR.COL + DEFAULT'length; CAIS_INTERFACE.SET_POSITION ( CURSOR ); for I in DEFAULT'length + 1..MAX_LENGTH loop CAIS_INTERFACE.PUT ( SPACE ); end loop; end if; end if; exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS GET_STRING" ); raise; end GET_STRING; procedure PUT_STRING ( STR : in STRING ) is begin CLEAR_LINE; CAIS_INTERFACE.PUT ( COMPRESS ( STR ) ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS PUT_STRING" ); raise; end PUT_STRING; procedure MSG_PROC ( MSG : in STRING; LINE : in VIDEO_TYPES.POSITION_TYPE ) is begin MOVE_CURSOR ( LINE ); PUT_STRING ( MSG ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS MSG_PROC" ); raise; end MSG_PROC; procedure PROMPT_MSG ( MSG : in STRING ) is begin MOVE_CURSOR ( PROMPT_LINE ); PUT_STRING ( MSG ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS PROMPT_MSG" ); raise; end PROMPT_MSG; procedure SCREEN_DISPLAY ( WHICH : in COMMON_MESSAGES.MENU_TYPES ) is DISPLAY_LINE : VIDEO_TYPES.POSITION_TYPE := ( 0,2 ); begin HOME_CLEAR; MOVE_CURSOR ( DISPLAY_LINE ); for I in 1..LAST_LINE ( WHICH ) loop -- display up to 22 lines DISPLAY_LINE.ROW := I; MSG_PROC ( COMMON_MESSAGES.MENUS ( WHICH, I ), DISPLAY_LINE ); end loop; exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS SCREEN_DISPLAY" ); raise; end SCREEN_DISPLAY; function GET_INPUT return OPTIONS is -- because Telesoft-Ada does not implement enumeration_IO, this routine -- must convert character input to the corresponding enumeration type. -- The routine uses a look-up table of character strings, and returns the -- index corresponding to the match. VALID_OPTION : constant VIDEO_TYPES.VALID := ( "CR", " /", " C", " I", " M", " R", " T", " X", " Z", " 1", " 2", " 3", " 4", " 5", " 6", " 7", " 8", " 9", "10", "11", "12", "13", "14", "15" ); SPACE : constant CHARACTER := ' '; DEFAULT : constant STRING (1..1) := " "; CHARS : STRING (1..2) := " "; INDEX : NATURAL range 0..2; PROMPT_FIELD : VIDEO_TYPES.POSITION_TYPE; KEY : CAIS_INTERFACE.FUNCTION_KEY_DESCRIPTOR; CHOICE : OPTIONS; GOOD_CHOICE : BOOLEAN := FALSE; begin PROMPT_FIELD := CAIS_INTERFACE.POSITION; for I in 1..2 loop -- user gets two chances exit when GOOD_CHOICE; begin -- local block with exception GET_STRING ( CHARS, INDEX, PROMPT_FIELD, DEFAULT ); if INDEX = 0 then CHARS := "CR"; elsif INDEX = 1 then -- convert to upper-case if neccessary if CHARS (1) in VIDEO_TYPES.LOWER_CASE then CHARS (1) := CHARACTER'val ( CHARACTER'pos(CHARS(1) ) - 32 ); end if; -- switch character positions if only one character was entered CHARS (2) := CHARS (1); CHARS (1) := SPACE; end if; for J in OPTIONS loop -- check characters entered against valid choices exit when GOOD_CHOICE; if CHARS = VALID_OPTION (J) then GOOD_CHOICE := TRUE; CHOICE := J; end if; end loop; if not GOOD_CHOICE then -- choice was not in valid choices raise INVALID_CHOICE; end if; exception when INVALID_CHOICE => -- this exception is handled here the first time the user enters -- a bad choice, and is raised to the calling routine after the -- second try, in case it needs to be handled differently if I < 2 then MSG_PROC ( ERRORS ( INVALID_RESP ), ERROR_LINE ); MOVE_CURSOR ( PROMPT_FIELD ); else -- wrong on second try raise; end if; when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS CHOICE" ); raise; end; end loop; -- for i in 1..2 loop return CHOICE; end GET_INPUT; procedure READ_NOECHO ( DEFAULT : in STRING; PASS : out PASS_PROCS.PASSWORD_TYPE ) is -- this routine is the underlying routine for getting passwords. It turns -- echoing off before getting the string, then turns it back on again. ON : constant BOOLEAN := TRUE; OFF : constant BOOLEAN := FALSE; KEY : CAIS_INTERFACE.FUNCTION_KEY_DESCRIPTOR; STR : STRING(1..8); LNTH : NATURAL; begin CAIS_INTERFACE.SET_ECHO ( OFF ); GET_STRING ( STR, LNTH, CAIS_INTERFACE.POSITION, DEFAULT ); if LNTH > 0 then -- some password was entered for I in 1..LNTH loop -- convert to upper case if necessary if STR (I) in VIDEO_TYPES.LOWER_CASE then STR (I) := CHARACTER'val ( CHARACTER'pos( STR(I) ) - 32 ); end if; end loop; -- for loop -- pass to password procs and get back an ecrypted password PASS_PROCS.STRING_TO_PASS ( STR, LNTH, PASS ); end if; -- length > 0 CAIS_INTERFACE.SET_ECHO ( ON ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS READ_NOECHO" ); raise; end READ_NOECHO; procedure GET_PASSWORD ( MSG : in STRING; PASS : out PASS_PROCS.PASSWORD_TYPE ) is DEFAULT : STRING(1..1) := " "; begin PROMPT_MSG ( MSG ); READ_NOECHO ( DEFAULT, PASS ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS GET_PASSWORD" ); raise; end GET_PASSWORD; procedure GET_NEW_PASSWORD ( MSG : in STRING; DEFAULT : in STRING; PASS : out PASS_PROCS.PASSWORD_TYPE ) is PASS1 : PASS_PROCS.PASSWORD_TYPE; NULL_PASS : PASS_PROCS.PASSWORD_TYPE; begin loop -- loop until password is accepted PROMPT_MSG ( MSG ); READ_NOECHO ( DEFAULT, PASS ); if PASS_PROCS.HAS_PASSWORD ( PASS ) then -- if user entered a password, have it entered again to verify PROMPT_MSG ( "ENTER PASSWORD AGAIN TO VERIFY" ); READ_NOECHO ( DEFAULT, PASS1 ); if PASS_PROCS.VERIFY_PASSWORD ( PASS1, PASS ) then exit; else -- first and second passwords entered did not match MSG_PROC ( "PASSWORDS DO NOT MATCH - PLEASE RE-ENTER", ERROR_LINE ); end if; -- verify_passwords else -- no password entered exit; end if; -- has_password PASS1 := NULL_PASS; PASS := NULL_PASS; end loop; -- main loop exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS GET_NEW_PASSWORD" ); raise; end GET_NEW_PASSWORD; function VERIFY ( MSG : in COMMON_MESSAGES.MSGS; NAME : in STRING ) return BOOLEAN is -- this routine displays the name the user entered and asks for -- verification. RESPONSE : VIDEO_TYPES.OPTIONS; OK : BOOLEAN := FALSE; begin loop -- until user enters <C> or <CR> exit when OK; begin -- local block with exception MSG_PROC ( MESSAGES (MSG), ERROR_LINE ); PUT_STRING ( NAME ); -- display the current string PROMPT_MSG ( "ENTER <CR> TO CONFIRM - <C> TO CHANGE "); RESPONSE := GET_INPUT; -- prompt for change or accept if ( RESPONSE = CR OR RESPONSE = C ) then OK := TRUE; else -- response not cr or c raise INVALID_CHOICE; end if; exception when INVALID_CHOICE => CAIS_INTERFACE.BELL; when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS VERIFY" ); raise; end; -- end of local block end loop; -- end of main loop if RESPONSE = C then OK := FALSE; end if; -- otherwise, user confirmed name return OK; end VERIFY; procedure GET_NAME ( PART : in NAME_PART; PROMPT : in STRING; DEFAULT : in STRING; LENGTH : out POSITIVE; NAME : out STRING ) is -- pseudo-generic routine for getting any part of the filespec from the user VALID : BOOLEAN := FALSE; MSG : COMMON_MESSAGES.MSGS; ERROR : STRING (1..80); begin for I in NAME'range loop -- initialize name to blanks NAME (I) := ' '; end loop; case PART is -- set up the appropriate prompt and error message when DEV => ERROR := ERRORS (INV_DEVNAM); MSG := CUR_DEV; when DIR => ERROR := ERRORS (INV_DIRNAM); MSG := CUR_DIRNAM; when FIL => ERROR := ERRORS (INV_FILNAM); MSG := CUR_FILNAM; end case; loop -- until a valid name is entered exit when VALID; begin -- local block and exception COMMON_PROCS.PROMPT_MSG (PROMPT); COMMON_PROCS.GET_STRING ( NAME, LENGTH, CAIS_INTERFACE.POSITION, DEFAULT ); if LENGTH > 0 then if NAME(1) = '/' then -- user wants to quit VALID := TRUE; else -- user entered a name so verify it VALID := VERIFY ( MSG, NAME(1..LENGTH) ); end if; -- user wants to quit or entered valid name else -- it is an error raise INVALID_NAME; end if; -- valid string entered exception when INVALID_NAME => MSG_PROC ( ERROR, ERROR_LINE ); when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS GET_NAME" ); raise; end; -- local block end loop; -- main loop end GET_NAME; procedure GET_DEV_NAME ( PROMPT : in STRING; DEFAULT : in STRING; LENGTH : out POSITIVE; NAME : out STRING ) is begin GET_NAME ( DEV, PROMPT, DEFAULT, LENGTH, NAME ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS GET_DEV_NAME" ); raise; end GET_DEV_NAME; procedure GET_DIR_NAME ( PROMPT : in STRING; DEFAULT : in STRING; LENGTH : out POSITIVE; NAME : out STRING ) is begin GET_NAME ( DIR, PROMPT, DEFAULT, LENGTH, NAME ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS GET_DIR_NAME" ); raise; end GET_DIR_NAME; procedure GET_FIL_NAME ( PROMPT : in STRING; DEFAULT : in STRING; LENGTH : out POSITIVE; NAME : out STRING ) is begin GET_NAME ( FIL, PROMPT, DEFAULT, LENGTH, NAME ); exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS GET_FIL_NAME" ); raise; end GET_FIL_NAME; function GET_NODE_TYPE ( MSG : in STRING ) return USER_NODE is NO_DEFAULT : constant STRING (1..2) := " "; NODE_TYPE : STRING (1..4); LENGTH : POSITIVE; OK : BOOLEAN := FALSE; RETURN_VAL : VIDEO_TYPES.USER_NODE; begin while not OK loop -- loop until valid node type entered begin PROMPT_MSG ( MSG ); GET_STRING ( NODE_TYPE, LENGTH, CAIS_INTERFACE.POSITION, NO_DEFAULT ); for I in 1..4 loop -- convert to upper case if NODE_TYPE (I) in VIDEO_TYPES.LOWER_CASE then NODE_TYPE (I) := CHARACTER'val( CHARACTER'pos(NODE_TYPE(I) ) - 32 ); end if; end loop; -- i in 1..4 -- then convert type entered to enumeration type if NODE_TYPE = "PROG" then RETURN_VAL := PROGRAM; OK := TRUE; elsif NODE_TYPE = "INST" then RETURN_VAL := INSTRUCTION; OK := TRUE; elsif NODE_TYPE = "MENU" then RETURN_VAL := MENU; OK := TRUE; else raise INVALID_CHOICE; end if; exception when INVALID_CHOICE => MSG_PROC ( ERRORS (INV_NODETYPE), ERROR_LINE ); when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS GET_NODE_TYPE" ); raise; end; end loop; -- main loop return RETURN_VAL; end GET_NODE_TYPE; function MATCH ( MATCH_STR : in STRING; STR : in STRING ) return NATURAL is -- the algorithm for this can be found in the Sept. 1984 issue -- of Scientific American. The function first sets up a look up -- table of characters with the position value set to the length -- of the string to match (MATCH_STR). It then places the position -- value of each character in match_str into the table, starting with -- the second position from the end ( position 1 ) and working left. -- The search is conducted by matching the positions of the nth char -- of match_str with the nth char of str. If they match, then the next -- character to the left is checked. If there is no character match -- found, the match_str is moved right by the number of spaces in the -- look-up table for the character in str that did not match. Match_str -- will be moved it's full length if the character in str is not found -- in match_str, otherwise it will be moved only far enough to line up -- matching characters, and the search will be ended when not enough -- characters remain in str. Supposedly, it`s pretty fast. subtype PRINTABLE is VIDEO_TYPES.PRINTABLE; type CHAR_TABLE is array (PRINTABLE) of POSITIVE; RETURN_VALUE : NATURAL := 0; INDEX : NATURAL := MATCH_STR'last; POS : NATURAL := 0; TABLE : CHAR_TABLE := ( PRINTABLE'first..PRINTABLE'last => MATCH_STR'length); begin -- starting from the right side of MATCH STR for I in reverse MATCH_STR'first..MATCH_STR'last - 1 loop for J in PRINTABLE loop -- look up the character in the table if MATCH_STR (I) = J then -- enter the position of that character within MATCH_STR in the table POS := POS + 1; TABLE (J) := POS; exit; end if; -- characters match end loop; -- j in printable end loop; -- i in match_str'last..match_str'first while RETURN_VALUE = 0 and INDEX <= STR'last loop -- while no match found and still more to check for I in reverse MATCH_STR'range loop -- beginning with the last character in MATCH_STR if MATCH_STR (I) = STR (INDEX) then -- if they match if I = MATCH_STR'first then -- and if it is the first character in match_str -- then string was found RETURN_VALUE := INDEX; exit; end if; -- match_str'first -- otherwise, do nothing but check the next character else -- move the index INDEX := INDEX + TABLE ( STR (INDEX) ); exit; end if; -- match_str(i) = str(index) INDEX := INDEX - 1; end loop; -- for i in reverse match_str'range end loop; -- main loop return RETURN_VALUE; exception when others => HANDLE_EXCEPTION ( EXCEPT & "SUB-ROUTINE IS MATCH" ); raise; end MATCH; end COMMON_PROCS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --videoio.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: VIDEO_IO * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the io_routines for video. It also redefines the -- standard exceptions for io. -- with VIDEO_TYPES,IO_EXCEPTIONS; package VIDEO_IO is PAGE_TERMINATOR : constant STRING(1..6) := "<PAGE>"; END_REC : constant NATURAL := 0; type DISP is ( SAVE_FILE, DELETE_FILE ); FILE_EXISTS : exception; STATUS_ERROR : exception renames IO_EXCEPTIONS.STATUS_ERROR; MODE_ERROR : exception renames IO_EXCEPTIONS.MODE_ERROR; NAME_ERROR : exception renames IO_EXCEPTIONS.NAME_ERROR; USE_ERROR : exception renames IO_EXCEPTIONS.USE_ERROR; DEVICE_ERROR : exception renames IO_EXCEPTIONS.DEVICE_ERROR; END_ERROR : exception renames IO_EXCEPTIONS.END_ERROR; DATA_ERROR : exception renames IO_EXCEPTIONS.DATA_ERROR; procedure CREATE_NODE_FILE ( FILE : in VIDEO_TYPES.FILESPEC ); -- procedure to create a node file procedure OPEN_NODE_FILE ( FILE : in VIDEO_TYPES.FILESPEC ); -- procedure to open an existing node file function NODE_FILE_OPEN return BOOLEAN; -- determine if node file is open function END_OF_NODE_FILE return BOOLEAN; -- check for end of node file procedure READ_NODE ( ITEM : out VIDEO_TYPES.NODE_RECORD; INDEX : in NATURAL ); -- reads a node record from the node file procedure WRITE_NODE ( ITEM : in out VIDEO_TYPES.NODE_RECORD ); -- writes a node record to the position stored in the node record procedure CLOSE_NODE_FILE ( DISPOSITION : in DISP ); -- closes or deletes a node file procedure OPEN_TEXT_FILE ( FILE : in VIDEO_TYPES.FILESPEC ); -- opens an instruction or menu file function END_OF_TEXT return BOOLEAN; -- checks for end of file function TEXT_FILE_OPEN return BOOLEAN; -- determines if text file is open procedure READ_PAGE ( DISP : out VIDEO_TYPES.TEXT_PAGE ); -- reads lines from instruction or menu file until it encounters <PAGE>, -- end of file, or max_lines. procedure READ_NAME ( BOOT_NAME : out STRING; LEN : out NATURAL ); -- trys to read a string from a file. Reads only the first line of the -- file. procedure CLOSE_TEXT_FILE; -- closes text_file ( no delete ) end VIDEO_IO; with DIRECT_IO, TEXT_IO, COMMON_PROCS; package body VIDEO_IO is -- due to the use of renamed exceptions, standard expections had to -- raise the renamed exception in some cases. EXCEPT : constant STRING (1..28) := "EXCEPTION RAISED IN VIDEO_IO"; package VIDEO_FILE_IO is new DIRECT_IO ( VIDEO_TYPES.NODE_RECORD ); NODE_FILE : VIDEO_FILE_IO.FILE_TYPE; TEXT_FILE : TEXT_IO.FILE_TYPE; procedure OPEN_NODE_FILE ( FILE : in VIDEO_TYPES.FILESPEC ) is use VIDEO_FILE_IO; begin VIDEO_FILE_IO.OPEN ( NODE_FILE, INOUT_FILE, FILE.NAME(1..FILE.LENGTH) ); exception when NAME_ERROR => raise VIDEO_IO.NAME_ERROR; when USE_ERROR => raise VIDEO_IO.USE_ERROR; when STATUS_ERROR => raise VIDEO_IO.STATUS_ERROR; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS OPEN_NODE_FILE"); raise; end OPEN_NODE_FILE; procedure CREATE_NODE_FILE ( FILE : in VIDEO_TYPES.FILESPEC ) is use VIDEO_FILE_IO; begin -- attempts to open the file with the name given. If name_error raised, -- then file does not exist and is created. VIDEO_FILE_IO.OPEN ( NODE_FILE, INOUT_FILE, FILE.NAME(1..FILE.LENGTH) ); CLOSE_NODE_FILE ( SAVE_FILE ); -- file of that name does exist, and so exception raised to calling routine raise FILE_EXISTS; exception when FILE_EXISTS => raise FILE_EXISTS; when NAME_ERROR => -- handler for creating file VIDEO_FILE_IO.CREATE ( NODE_FILE, INOUT_FILE, FILE.NAME(1..FILE.LENGTH)); when VIDEO_IO.STATUS_ERROR => raise FILE_EXISTS; when USE_ERROR => raise VIDEO_IO.USE_ERROR; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS CREATE_NODE_FILE"); raise; end CREATE_NODE_FILE; procedure READ_NODE ( ITEM : out VIDEO_TYPES.NODE_RECORD; INDEX : in NATURAL ) is NDEX : VIDEO_FILE_IO.POSITIVE_COUNT; begin -- convert natural to positive_count NDEX := VIDEO_FILE_IO.COUNT(INDEX + 1); VIDEO_FILE_IO.READ ( NODE_FILE, ITEM, NDEX ); exception when DATA_ERROR => raise VIDEO_IO.DATA_ERROR; when MODE_ERROR => raise VIDEO_IO.MODE_ERROR; when END_ERROR => raise VIDEO_IO.END_ERROR; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS READ_NODE"); raise; end READ_NODE; procedure WRITE_NODE ( ITEM : in out VIDEO_TYPES.NODE_RECORD ) is NDEX : VIDEO_FILE_IO.POSITIVE_COUNT; begin -- convert natural to positive_count NDEX := VIDEO_FILE_IO.COUNT( ITEM.POSITION + 1 ); -- index for write is stored in node_record as position VIDEO_FILE_IO.WRITE (NODE_FILE, ITEM, NDEX ); exception when USE_ERROR => raise VIDEO_IO.USE_ERROR; when MODE_ERROR => raise VIDEO_IO.MODE_ERROR; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS WRITE_NODE"); raise; end WRITE_NODE; procedure CLOSE_NODE_FILE ( DISPOSITION : in DISP ) is begin if DISPOSITION = SAVE_FILE then VIDEO_FILE_IO.CLOSE ( NODE_FILE ); else VIDEO_FILE_IO.DELETE ( NODE_FILE ); end if; exception when STATUS_ERROR => raise VIDEO_IO.STATUS_ERROR; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS CLOSE_NODE_FILE"); raise; end CLOSE_NODE_FILE; function NODE_FILE_OPEN return BOOLEAN is begin return VIDEO_FILE_IO.IS_OPEN ( NODE_FILE ); exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS NODE_FILE_OPEN"); raise; end NODE_FILE_OPEN; function END_OF_NODE_FILE return BOOLEAN is begin return VIDEO_FILE_IO.END_OF_FILE ( NODE_FILE ); exception when MODE_ERROR => raise VIDEO_IO.MODE_ERROR; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS END_OF_NODE_FILE"); raise; end END_OF_NODE_FILE; procedure OPEN_TEXT_FILE ( FILE : in out VIDEO_TYPES.FILESPEC ) is use TEXT_IO; begin TEXT_IO.OPEN ( TEXT_FILE, IN_FILE, FILE.NAME(1..FILE.LENGTH) ); exception when NAME_ERROR => raise VIDEO_IO.NAME_ERROR; when USE_ERROR => raise VIDEO_IO.USE_ERROR; when STATUS_ERROR => raise VIDEO_IO.STATUS_ERROR; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS OPEN_TEXT_FILE"); raise; end OPEN_TEXT_FILE; function END_OF_TEXT return BOOLEAN is begin return TEXT_IO.END_OF_FILE ( TEXT_FILE ); exception when MODE_ERROR => raise VIDEO_IO.MODE_ERROR; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS END_OF_TEXT"); raise; end END_OF_TEXT; function TEXT_FILE_OPEN return BOOLEAN is begin return TEXT_IO.IS_OPEN ( TEXT_FILE ); exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS TEXT_FILE_OPEN"); raise; end TEXT_FILE_OPEN; procedure READ_PAGE ( DISP : out VIDEO_TYPES.TEXT_PAGE ) is begin for I in 1..VIDEO_TYPES.MAX_DISP_LINES loop -- for the maximum number of displayable lines if END_OF_TEXT then -- insert a dummy <PAGE> DISP(I).LNTH := PAGE_TERMINATOR'length; DISP(I).LINE(1..DISP(I).LNTH) := PAGE_TERMINATOR; else -- get the next_line TEXT_IO.GET_LINE ( TEXT_FILE, DISP(I).LINE, DISP(I).LNTH ); if DISP(I).LNTH = 0 then -- take care of blank lines DISP(I).LNTH := 1; DISP(I).LINE(1..1) := " "; end if; end if; -- end of text exit when DISP(I).LINE(1..DISP(I).LNTH) = PAGE_TERMINATOR; end loop; -- main loop exception when DATA_ERROR => raise VIDEO_IO.DATA_ERROR; when MODE_ERROR => raise VIDEO_IO.MODE_ERROR; when END_ERROR => raise VIDEO_IO.END_ERROR; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS READ_PAGE" ); raise; end READ_PAGE; procedure READ_NAME ( BOOT_NAME : out STRING; LEN : out NATURAL ) is begin TEXT_IO.GET_LINE ( TEXT_FILE, BOOT_NAME, LEN ); exception when DATA_ERROR => raise VIDEO_IO.DATA_ERROR; when MODE_ERROR => raise VIDEO_IO.MODE_ERROR; when END_ERROR => raise VIDEO_IO.END_ERROR; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS READ_NAME" ); raise; end READ_NAME; procedure CLOSE_TEXT_FILE is begin TEXT_IO.CLOSE ( TEXT_FILE ); exception when STATUS_ERROR => raise VIDEO_IO.STATUS_ERROR; when others => COMMON_PROCS.HANDLE_EXCEPTION(EXCEPT & " SUBROUTINE IS CLOSE_TEXT_FILE"); raise; end CLOSE_TEXT_FILE; end VIDEO_IO; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --sysdepd.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: SYSTEM_DEPENDENT * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the system dependent area of VIDEO. Specifically, -- building of filenames has been isolated in the package body, and must -- be changed for each hardware system running VIDEO. Areas requiring -- such changes will be highlighted. -- with VIDEO_TYPES; package SYSTEM_DEPENDENT is procedure SET_MODIFY_FLAG ( TO : in VIDEO_TYPES.FLAG ); -- this procedure toggles the modify_flag, which determines whether a -- filename can be modified in a model session. function BUILD_FILESPEC ( FROM : in VIDEO_TYPES.FILE_NAME ) return VIDEO_TYPES.FILESPEC; -- this function takes a filename record as it is stored in the node -- record and return a filename string for opening files. function GET_FILENAME ( DEFAULT : in VIDEO_TYPES.FILE_NAME; DEV_PROMPT : in STRING; DIR_PROMPT : in STRING; FIL_PROMPT : in STRING; NODE_TYPE : in VIDEO_TYPES.NODE ) return VIDEO_TYPES.FILE_NAME; -- this function prompts for each required part of the filename -- and returns it in a record format for storage in the node file. procedure GET_BOOT_NAME ( NAME : out VIDEO_TYPES.FILESPEC; OK : out BOOLEAN ); -- this procedure attempts to read the boot file name from a file -- called 'video.dat'. This file may be created in a command file or -- may be created with the text editor and reference in a command file to -- start video or vidmodl. If found, the procedure will return TRUE in ok -- and the filename in name. end SYSTEM_DEPENDENT; with COMMON_PROCS, VIDEO_IO; package body SYSTEM_DEPENDENT is use VIDEO_TYPES; EXCEPT : constant STRING (1..36) := "EXCEPTION RAISED IN SYSTEM_DEPENDENT"; -- ****************************************** -- * The following constants will change * -- * to the appropriate form for the host * -- * system. * -- ****************************************** -- DEV_DELIM : constant STRING (1..1) := ":"; LEFT_DELIM: constant STRING (1..1) := "["; DIR_DELIM : constant STRING (1..1) := "]"; DATA_EXT : constant STRING (1..4) := ".DAT"; TEXT_EXT : constant STRING (1..4) := ".TXT"; PROG_EXT : constant STRING (1..4) := ".COD"; MAX_EXT_LEN : constant NATURAL := 4; BOOT_NAME : VIDEO_TYPES.FILESPEC; -- initialized when elaborated; -- see end of pkg -- -- ******************************************** -- * The following constants determine the * -- * filename part that will be prompted * -- * for and must be changed for other hosts * -- ******************************************** -- DEV_REQUIRED : constant BOOLEAN := TRUE; DIR_REQUIRED : constant BOOLEAN := TRUE; MODIFY_FLAG : VIDEO_TYPES.FLAG := OFF; procedure MAKE_CAPS ( THIS : in out STRING ) is -- this is a local procedure that sets a string to upper_case begin for I in 1..THIS'last loop if THIS(I) in VIDEO_TYPES.LOWER_CASE then THIS(I) := CHARACTER'val ( CHARACTER'pos ( THIS(I) ) - 32 ); end if; end loop; end MAKE_CAPS; procedure SET_MODIFY_FLAG ( TO : in VIDEO_TYPES.FLAG ) is begin MODIFY_FLAG := TO; end SET_MODIFY_FLAG; function BUILD_FILESPEC ( FROM : in VIDEO_TYPES.FILE_NAME ) return VIDEO_TYPES.FILESPEC is FILSPEC : VIDEO_TYPES.FILESPEC; begin if DEV_REQUIRED then if DIR_REQUIRED then -- build the filespec from device, directory and filename FILSPEC.LENGTH := FROM.DEV.LENGTH + FROM.DIR.LENGTH + FROM.FIL.LENGTH; FILSPEC.NAME(1..FILSPEC.LENGTH) := FROM.DEV.NAME(1..FROM.DEV.LENGTH) & FROM.DIR.NAME(1..FROM.DIR.LENGTH) & FROM.FIL.NAME(1..FROM.FIL.LENGTH); else -- build filespec from device and filename FILSPEC.LENGTH := FROM.DEV.LENGTH + FROM.FIL.LENGTH; FILSPEC.NAME(1..FILSPEC.LENGTH) := FROM.DEV.NAME(1..FROM.DEV.LENGTH) & FROM.FIL.NAME(1..FROM.FIL.LENGTH); end if; elsif DIR_REQUIRED then -- build filespec from directory and filename FILSPEC.LENGTH := FROM.DIR.LENGTH + FROM.FIL.LENGTH; FILSPEC.NAME(1..FILSPEC.LENGTH) := FROM.DIR.NAME(1..FROM.DIR.LENGTH) & FROM.FIL.NAME(1..FROM.FIL.LENGTH); else -- build filespec from filename only FILSPEC.LENGTH := FROM.FIL.LENGTH; FILSPEC.NAME(1..FILSPEC.LENGTH) := FROM.FIL.NAME(1..FROM.FIL.LENGTH); end if; return FILSPEC; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUB-ROUTINE IS BUILD_FILESPEC"); raise; end BUILD_FILESPEC; function GET_FILENAME ( DEFAULT : in VIDEO_TYPES.FILE_NAME; DEV_PROMPT : in STRING; DIR_PROMPT : in STRING; FIL_PROMPT : in STRING; NODE_TYPE : in VIDEO_TYPES.NODE ) return VIDEO_TYPES.FILE_NAME is NO_MATCH : constant NATURAL := 0; EXTENSION : STRING(1..MAX_EXT_LEN); FILNAME : VIDEO_TYPES.FILE_NAME; TEMP_STR : VIDEO_TYPES.NAME_REC; MAX_DIR_LEN: POSITIVE := FILNAME.DIR.LENGTH; MAX_DEV_LEN: POSITIVE := FILNAME.DEV.LENGTH; MAX_FIL_LEN: POSITIVE := FILNAME.FIL.LENGTH; begin case NODE_TYPE is -- determine the appropriate extension when MENU|INSTRUCTION => EXTENSION := TEXT_EXT; when PROGRAM => EXTENSION := PROG_EXT; when BOOT => EXTENSION := DATA_EXT; end case; if DEV_REQUIRED then COMMON_PROCS.GET_DEV_NAME ( DEV_PROMPT, DEFAULT.DEV.NAME(1..DEFAULT.DEV.LENGTH), FILNAME.DEV.LENGTH, FILNAME.DEV.NAME(1..MAX_DEV_LEN) ); if FILNAME.DEV.LENGTH = 1 and then FILNAME.DEV.NAME(1) = '/' then raise USER_QUIT; end if; MAKE_CAPS ( FILNAME.DEV.NAME(1..FILNAME.DEV.LENGTH) ); if COMMON_PROCS.MATCH ( DEV_DELIM, FILNAME.DEV.NAME(1..FILNAME.DEV.LENGTH) ) = NO_MATCH then -- if user did not enter the device delimiter then add to end FILNAME.DEV.NAME(1..FILNAME.DEV.LENGTH + DEV_DELIM'length) := FILNAME.DEV.NAME(1..FILNAME.DEV.LENGTH) & DEV_DELIM; FILNAME.DEV.LENGTH := FILNAME.DEV.LENGTH + DEV_DELIM'length; end if; -- match end if; -- device required if DIR_REQUIRED then COMMON_PROCS.GET_DIR_NAME ( DIR_PROMPT, DEFAULT.DIR.NAME(1..DEFAULT.DIR.LENGTH), FILNAME.DIR.LENGTH, FILNAME.DIR.NAME(1..MAX_DIR_LEN) ); if FILNAME.DIR.LENGTH = 1 and then FILNAME.DIR.NAME(1) = '/' then raise USER_QUIT; end if; MAKE_CAPS ( FILNAME.DIR.NAME(1..FILNAME.DIR.LENGTH) ); if COMMON_PROCS.MATCH ( DIR_DELIM, FILNAME.DIR.NAME(1..FILNAME.DIR.LENGTH) ) = NO_MATCH then -- if user did not enter the directory delimiter then add to end FILNAME.DIR.NAME(1..FILNAME.DIR.LENGTH + DIR_DELIM'length) := FILNAME.DIR.NAME(1..FILNAME.DIR.LENGTH) & DIR_DELIM; FILNAME.DIR.LENGTH := FILNAME.DIR.LENGTH + DIR_DELIM'length; end if; -- match dir_delim if FILNAME.DIR.NAME(1) /= LEFT_DELIM(1) then -- first char must be '[' TEMP_STR.NAME(1..FILNAME.DIR.LENGTH) := -- if missing, add it in FILNAME.DIR.NAME(1..FILNAME.DIR.LENGTH); TEMP_STR.LENGTH := FILNAME.DIR.LENGTH; FILNAME.DIR.LENGTH := FILNAME.DIR.LENGTH + 1; FILNAME.DIR.NAME(1..FILNAME.DIR.LENGTH) := LEFT_DELIM & TEMP_STR.NAME(1..TEMP_STR.LENGTH); end if; -- dir.name(1) /= '[' end if; -- directory required if MODIFY_FLAG = OFF then COMMON_PROCS.GET_FIL_NAME ( FIL_PROMPT, DEFAULT.FIL.NAME(1..DEFAULT.FIL.LENGTH), FILNAME.FIL.LENGTH, FILNAME.FIL.NAME(1..MAX_FIL_LEN) ); if FILNAME.FIL.LENGTH = 1 and then FILNAME.FIL.NAME(1) = '/' then raise USER_QUIT; end if; MAKE_CAPS ( FILNAME.FIL.NAME(1..FILNAME.FIL.LENGTH) ); if EXTENSION = PROG_EXT then if COMMON_PROCS.MATCH (EXTENSION, FILNAME.FIL.NAME(1..FILNAME.FIL.LENGTH)) /= NO_MATCH then -- if user did enter the file extension then delete from end FILNAME.FIL.LENGTH := FILNAME.FIL.LENGTH - EXTENSION'length; end if; -- match extension else -- node type is not program if COMMON_PROCS.MATCH (EXTENSION, FILNAME.FIL.NAME(1..FILNAME.FIL.LENGTH)) = NO_MATCH then FILNAME.FIL.NAME(1..FILNAME.FIL.LENGTH + EXTENSION'length) := FILNAME.FIL.NAME(1..FILNAME.FIL.LENGTH) & EXTENSION; FILNAME.FIL.LENGTH := FILNAME.FIL.LENGTH + EXTENSION'length; end if; -- user did not enter file extension so add to the end end if; -- extension = program end if; -- ok to modify return FILNAME; exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUB-ROUTINE IS GET_FILENAME"); raise; end GET_FILENAME; procedure GET_BOOT_NAME ( NAME : out VIDEO_TYPES.FILESPEC; OK : out BOOLEAN ) is begin VIDEO_IO.OPEN_TEXT_FILE ( BOOT_NAME ); VIDEO_IO.READ_NAME ( NAME.NAME, NAME.LENGTH ); VIDEO_IO.CLOSE_TEXT_FILE; OK := TRUE; exception when VIDEO_IO.NAME_ERROR|VIDEO_IO.DATA_ERROR| VIDEO_IO.MODE_ERROR|VIDEO_IO.END_ERROR => OK := FALSE; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUB-ROUTINE IS GET_BOOT_NAME"); raise; end GET_BOOT_NAME; begin BOOT_NAME.LENGTH := 5 + DATA_EXT'length; BOOT_NAME.NAME(1..BOOT_NAME.LENGTH) := "VIDEO" & DATA_EXT; end SYSTEM_DEPENDENT; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --vidprocs.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: VIDEO_PROCS * -- * VERSION: 1.0a1 * -- * DATE : FEBRUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- This package contains types, global variables and subroutines used in -- VIDEO_MODEL, VIDEO, and VIDEO_DIAGRAM. -- with VIDEO_TYPES; package VIDEO_PROCS is -- The following are global constants: INST_ENABLED : constant VIDEO_TYPES.FLAG := VIDEO_TYPES.ON; INST_DISABLED: constant VIDEO_TYPES.FLAG := VIDEO_TYPES.OFF; -- the value of Inst_flag determines if instruction pages are displayed INST_FLAG : VIDEO_TYPES.FLAG := INST_ENABLED; -- -- VIDEO_PROCS visible procedures and subroutines -- function HAS_PASSWORD ( REC : in VIDEO_TYPES.NODE_RECORD ) return BOOLEAN; -- Has_password is an interface to a routine in Password_procs. function PASSWORD_OK ( REC : in VIDEO_TYPES.NODE_RECORD; MSG : in STRING ) return BOOLEAN; -- Password_ok prompts for a password and checks it against the password -- in the node record. The user gets three tries then raises Bad_password -- if incorrect. procedure DISPLAY_PAGE ( DISP : in VIDEO_TYPES.TEXT_PAGE ); -- Display_page will display up to Video_types.max_display_lines. If it -- encounters a <PAGE> mark in the text file, or reaches the end of file -- before max_lines are read, it displays only those lines. procedure MENU_PROC ( MENU_MSG : in STRING; REC : in VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS; NEXT_REC : out NATURAL ); -- Menu_proc displays a menu. The user is prompted to enter a valid -- numeric choice, a special character, or a slash to return to the -- previous menu. procedure INST_PROC ( INST_MSG : in STRING; REC : in VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS; NEXT_REC : out NATURAL ); -- Inst_proc displays instruction pages until there are no more pages, -- or the user enters a slash. No instructions are displayed if the -- instruction flag is disabled. Special characters may also be entered. procedure MENU_INIT ( MSG : in STRING; HDR : in VIDEO_TYPES.HEADER_TYPE; FILNAM : out VIDEO_TYPES.FILESPEC; BOOT_REC : out VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ); -- Menu_init first displays the header, then prompts for the name -- of the node file. If the file can be opened, and there is a -- password for the boot record, the user is prompted for the -- password. If the password is correct, success becomes true, -- otherwise, bad_password is raised. function CONFIRMED ( MSG : in STRING ) return BOOLEAN; -- Confirmed prompts with a message, accepts only Y or N, and -- returns the corresponding boolean. end VIDEO_PROCS; with PASS_PROCS, COMMON_PROCS, PROMPT_MESSAGES, COMMON_MESSAGES, SYSTEM_DEPENDENT, VIDEO_IO; package body VIDEO_PROCS is use PROMPT_MESSAGES, COMMON_MESSAGES, VIDEO_TYPES, SYSTEM_DEPENDENT; EXCEPT : constant STRING (1..31) := "EXCEPTION RAISED IN VIDEO_PROCS"; function CONFIRMED ( MSG : in STRING ) return BOOLEAN is OK : BOOLEAN := FALSE; ANSWER : CHARACTER; begin loop -- until response is valid COMMON_PROCS.PROMPT_MSG ( MSG ); COMMON_PROCS.GET_CHAR ( ANSWER ); case ANSWER is when 'N'|'n' => exit; when 'Y'|'y' => OK := TRUE; exit; when others => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP),ERROR_LINE ); end case; -- answer end loop; -- valid response return OK; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS CONFIRMED"); raise; end CONFIRMED; function HANDLE_NO_FILE return VIDEO_TYPES.OPTIONS is -- Handle_no_file is used when an attempt to access an instruction -- or menu file named in the corresponding node raises Name_error. -- The user is prompted to enter a slash to return to the previous menu -- although other special characters may be entered. CHOICE : VIDEO_TYPES.OPTIONS; begin COMMON_PROCS.MSG_PROC ( ERRORS(FILE_ACCESS), ERROR_LINE ); loop -- until valid response COMMON_PROCS.PROMPT_MSG ( PROMPT(SLASH_RTN) ); CHOICE := COMMON_PROCS.GET_INPUT; if CHOICE in SLASH..Z then return CHOICE; else -- invalid response COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); end if; -- choice in slash..z end loop; -- valid response end HANDLE_NO_FILE; function HAS_PASSWORD ( REC : in VIDEO_TYPES.NODE_RECORD ) return BOOLEAN is begin return PASS_PROCS.HAS_PASSWORD ( REC.NODE_PASSWORD ); exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS HAS_PASSWORD"); raise; end HAS_PASSWORD; function PASSWORD_OK ( REC : in VIDEO_TYPES.NODE_RECORD; MSG : in STRING ) return BOOLEAN is PASS : PASS_PROCS.PASSWORD_TYPE; OK : BOOLEAN := FALSE; begin for TRIES in 1..3 loop COMMON_PROCS.GET_PASSWORD ( MSG, PASS ); OK := PASS_PROCS.VERIFY_PASSWORD ( PASS, REC.NODE_PASSWORD ); exit when OK; COMMON_PROCS.MSG_PROC ( ERRORS(INV_PASS), ERROR_LINE ); end loop; return OK; exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS PASSWORD_OK"); raise; end PASSWORD_OK; procedure DISPLAY_PAGE ( DISP : in VIDEO_TYPES.TEXT_PAGE ) is DISPLAY_LINE : VIDEO_TYPES.POSITION_TYPE := ( 0,0 ); begin COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.MOVE_CURSOR ( DISPLAY_LINE ); for I in 1..VIDEO_TYPES.MAX_DISP_LINES loop exit when DISP(I).LINE(1..DISP(I).LNTH) = VIDEO_IO.PAGE_TERMINATOR; DISPLAY_LINE.ROW := I; COMMON_PROCS.MSG_PROC ( DISP(I).LINE(1..DISP(I).LNTH), DISPLAY_LINE); end loop; -- i in 1..max_disp_lines exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS DISPLAY_PAGE"); raise; end DISPLAY_PAGE; procedure MENU_PROC ( MENU_MSG : in STRING; REC : in VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS; NEXT_REC : out NATURAL ) is VALID : BOOLEAN := FALSE; DISP_PAGE : VIDEO_TYPES.TEXT_PAGE; FILNAM : VIDEO_TYPES.FILESPEC; INVALID_CHOICE : exception; -- local exception begin FILNAM := SYSTEM_DEPENDENT.BUILD_FILESPEC ( REC.MENU_PATH ); VIDEO_IO.OPEN_TEXT_FILE( FILNAM ); VIDEO_IO.READ_PAGE ( DISP_PAGE ); VIDEO_IO.CLOSE_TEXT_FILE; DISPLAY_PAGE ( DISP_PAGE ); while not VALID loop COMMON_PROCS.PROMPT_MSG ( MENU_MSG ); CHOICE := COMMON_PROCS.GET_INPUT; case CHOICE is -- accepts any option when CR => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); when ONE..FIFTEEN => if REC.OPTION(CHOICE) = VIDEO_IO.END_REC then -- no node attached to this branch COMMON_PROCS.MSG_PROC ( "NOT A VALID CHOICE", ERROR_LINE ); else -- node attached to this branch NEXT_REC := REC.OPTION(CHOICE); CHOICE := CR; VALID := TRUE; end if; -- rec.option(choice) = end_rec when others => -- special character entered VALID := TRUE; end case; -- choice end loop; -- while not valid exception when VIDEO_IO.NAME_ERROR => -- could not locate text file for that node CHOICE := HANDLE_NO_FILE; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS MENU_PROC"); raise; end MENU_PROC; procedure INST_PROC ( INST_MSG : in STRING; REC : in VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS; NEXT_REC : out NATURAL ) is ROOT_REC_NO : constant NATURAL := 1; DISP_PAGE : VIDEO_TYPES.TEXT_PAGE; FILNAM : VIDEO_TYPES.FILESPEC; DONE : BOOLEAN := FALSE; begin if INST_FLAG = INST_ENABLED or else REC.POSITION = ROOT_REC_NO then -- display text only if instruction enabled or root node FILNAM := SYSTEM_DEPENDENT.BUILD_FILESPEC ( REC.PATH ); VIDEO_IO.OPEN_TEXT_FILE ( FILNAM ); else -- don't display text COMMON_PROCS.HOME_CLEAR; end if; -- inst_enabled while not DONE loop -- outer loop if INST_FLAG = INST_ENABLED or else REC.POSITION = ROOT_REC_NO then VIDEO_IO.READ_PAGE ( DISP_PAGE ); DISPLAY_PAGE ( DISP_PAGE ); end if; -- inst_enabled loop -- inner loop if not VIDEO_IO.END_OF_TEXT then COMMON_PROCS.PROMPT_MSG ( PROMPT(CR_GO_SL_RTN)); else COMMON_PROCS.PROMPT_MSG ( INST_MSG ); end if; CHOICE := COMMON_PROCS.GET_INPUT; case CHOICE is -- accept only <CR>, slash, or special characters when CR => if (INST_FLAG = INST_DISABLED and then REC.POSITION /= ROOT_REC_NO) or else VIDEO_IO.END_OF_TEXT then -- don't display text or no more to display DONE := TRUE; if REC.NEXT_NODE /= VIDEO_IO.END_REC then -- there is a node after this one NEXT_REC := REC.NEXT_NODE; exit; else -- no further nodes COMMON_PROCS.MSG_PROC ( "**ERROR** NO NODES BEYOND THIS NODE", ERROR_LINE ); end if; -- next_node /= end_rec else -- more to come exit; end if; -- inst-disabled or else end of text when SLASH..Z => DONE := TRUE; exit; when others => COMMON_PROCS.MSG_PROC (ERRORS(INVALID_RESP),ERROR_LINE); end case; -- choice end loop; -- inner loop end loop; -- while not done (outer loop) if INST_FLAG = INST_ENABLED or else REC.POSITION = ROOT_REC_NO then VIDEO_IO.CLOSE_TEXT_FILE; end if; exception when VIDEO_IO.NAME_ERROR => -- cannot find the associated text_file CHOICE := HANDLE_NO_FILE; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS INST_PROC"); VIDEO_IO.CLOSE_TEXT_FILE; raise; end INST_PROC; procedure MENU_INIT ( MSG : in STRING; HDR : in VIDEO_TYPES.HEADER_TYPE; FILNAM : out VIDEO_TYPES.FILESPEC; BOOT_REC : out VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ) is BOOT_REC_NUM : constant NATURAL := 0; BOOT_FILE : VIDEO_TYPES.FILE_NAME; CONTINUE : BOOLEAN := TRUE; OPEN_OK : BOOLEAN := FALSE; FOUND : BOOLEAN := FALSE; begin SUCCESS := FALSE; COMMON_PROCS.SCREEN_DISPLAY ( COPYRIGHT ); COMMON_PROCS.SKIP_LINE; for I in HEADER_LINES loop COMMON_PROCS.PUT_STRING ( HDR(I) ); COMMON_PROCS.NEXT_LINE; end loop; while CONTINUE loop begin -- local block -- first look to see if a file name has been placed in the file -- video.dat SYSTEM_DEPENDENT.GET_BOOT_NAME ( FILNAM, FOUND ); if not FOUND then -- get the filename from the user BOOT_FILE := SYSTEM_DEPENDENT.GET_FILENAME ( BOOT_FILE, PROMPT(DEVNAM_APL_MDL), PROMPT(DIRNAM_APL_MDL), PROMPT(APL_NAM), BOOT); FILNAM := SYSTEM_DEPENDENT.BUILD_FILESPEC ( BOOT_FILE ); end if; -- found VIDEO_IO.OPEN_NODE_FILE ( FILNAM ); CONTINUE := FALSE; OPEN_OK := TRUE; exception when VIDEO_IO.NAME_ERROR => COMMON_PROCS.MSG_PROC ( "**ERROR** CANNOT FIND FILE " & FILNAM.NAME(1..FILNAM.LENGTH), ERROR_LINE ); if not CONFIRMED ("DO YOU WANT TO TRY ANOTHER FILENAME (Y/N)?") then raise USER_QUIT; end if; -- not confirmed end; -- local block end loop; -- while continue if OPEN_OK then -- node file was located and opened VIDEO_IO.READ_NODE ( BOOT_REC, BOOT_REC_NUM ); if HAS_PASSWORD (BOOT_REC) and then not PASSWORD_OK(BOOT_REC, MSG) then -- user entered an invalid password raise BAD_PASSWORD; end if; SUCCESS := TRUE; end if; -- open ok exception when USER_QUIT => raise; when BAD_PASSWORD => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS MENU_INIT"); raise; end MENU_INIT; end VIDEO_PROCS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --modlprocs.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: MODEL_PROCS * -- * VERSION: 1.0a1 * -- * DATE : FEBRUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains global types, variables and subroutines used -- only in VIDEO_MODEL. -- with VIDEO_TYPES, PASS_PROCS; package MODEL_PROCS is procedure GET_ANSWER ( MSG : in STRING; AFFIRMATIVE : out BOOLEAN; CHOICE : out VIDEO_TYPES.OPTIONS ); -- Get_answer prompts the user for a yes, no, slash, or <CR> response. -- If yes or no, it returns a boolean. If <CR> or slash, it is returned -- in CHOICE and AFFIRMATIVE is set to false. function CONFIRMED ( MSG : in STRING ) return BOOLEAN; -- Confirmed prompts for a Y/N answer and returns a corresponding boolean. -- No other characters are accepted. function GET_BRANCH ( MSG : in STRING ) return VIDEO_TYPES.OPTIONS; -- Get_branch prompts the user for the menu branch number. It returns -- either ONE..FIFTEEN, <CR>, or SLASH. procedure PUT_HEADER ( HEADER : in VIDEO_TYPES.HEADER_TYPE ); -- This is a pseudo-generic header routine. It clears the screen and -- displays all the strings in the header array. procedure GET_COMMON ( DEF_NAME : in VIDEO_TYPES.FILE_NAME; DEV_PROMPT : in STRING; DIR_PROMPT : in STRING; FIL_PROMPT : in STRING; PASS_PROMPT : in STRING; NODE_TYP : in VIDEO_TYPES.NODE; FILNAM : out VIDEO_TYPES.FILE_NAME; PASS : out PASS_PROCS.PASSWORD_TYPE ); -- Get_common passes all the appropriate prompts and defaults and -- returns the file name and node password. Calls are made to routines -- defined in the package Common_procs. end MODEL_PROCS; with COMMON_MESSAGES, COMMON_PROCS, SYSTEM_DEPENDENT; package body MODEL_PROCS is use VIDEO_TYPES, COMMON_MESSAGES; EXCEPT : constant STRING(1..31) := "EXCEPTION RAISED IN MODEL_PROCS"; procedure GET_ANSWER ( MSG : in STRING; AFFIRMATIVE : out BOOLEAN; CHOICE : out VIDEO_TYPES.OPTIONS ) is DONE : BOOLEAN := FALSE; POS : VIDEO_TYPES.POSITION_TYPE; ANSWER : STRING(1..3); LEN : NATURAL; DEFAULT : STRING (1..3) := " "; begin CHOICE := CR; while not DONE loop COMMON_PROCS.PROMPT_MSG ( MSG ); POS := VIDEO_TYPES.ACTIVE_POSITION; COMMON_PROCS.GET_STRING ( ANSWER, LEN, POS, DEFAULT ); if LEN > 0 then -- response was not a <CR> case ANSWER(1) is -- look only at the first character when 'y'|'Y' => AFFIRMATIVE := TRUE; DONE := TRUE; when 'n'|'N' => AFFIRMATIVE := FALSE; DONE := TRUE; when '/' => CHOICE := SLASH; DONE := TRUE; when others => COMMON_PROCS.MSG_PROC (ERRORS(INVALID_RESP), ERROR_LINE ); end case; else -- response was a <CR> AFFIRMATIVE := FALSE; DONE := TRUE; end if; -- len > 0 end loop; -- while not done exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS GET_ANSWER"); end GET_ANSWER; function CONFIRMED ( MSG : in STRING ) return BOOLEAN is OK : BOOLEAN := FALSE; ANSWER : CHARACTER; begin loop -- until y or n entered COMMON_PROCS.PROMPT_MSG ( MSG ); COMMON_PROCS.GET_CHAR ( ANSWER ); case ANSWER is when 'N'|'n' => exit; when 'Y'|'y' => OK := TRUE; exit; when others => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP),ERROR_LINE ); end case; -- answer end loop; -- main loop return OK; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS CONFIRMED"); raise; end CONFIRMED; function GET_BRANCH ( MSG : in STRING ) return VIDEO_TYPES.OPTIONS is CHOICE : VIDEO_TYPES.OPTIONS; VALID : BOOLEAN := FALSE; begin while not VALID loop -- until response is valid begin COMMON_PROCS.PROMPT_MSG ( MSG ); CHOICE := COMMON_PROCS.GET_INPUT; case CHOICE is when SLASH|ONE..FIFTEEN => VALID := TRUE; when others => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); end case; -- choice exception when COMMON_PROCS.INVALID_CHOICE => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); end; end loop; -- response loop return CHOICE; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS GET_BRANCH"); raise; end GET_BRANCH; procedure PUT_HEADER ( HEADER : in VIDEO_TYPES.HEADER_TYPE ) is DISPLAY_LINE : VIDEO_TYPES.POSITION_TYPE := ( 0,0 ); begin COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.MOVE_CURSOR ( DISPLAY_LINE ); for I in VIDEO_TYPES.HEADER_LINES loop DISPLAY_LINE.ROW := I; COMMON_PROCS.MSG_PROC ( HEADER(I), DISPLAY_LINE ); end loop; -- i in header_lines exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS PUT_HEADER"); raise; end PUT_HEADER; procedure GET_COMMON ( DEF_NAME : in VIDEO_TYPES.FILE_NAME; DEV_PROMPT : in STRING; DIR_PROMPT : in STRING; FIL_PROMPT : in STRING; PASS_PROMPT : in STRING; NODE_TYP : in VIDEO_TYPES.NODE; FILNAM : out VIDEO_TYPES.FILE_NAME; PASS : out PASS_PROCS.PASSWORD_TYPE ) is DEFAULT : STRING(1..1) := " "; -- default string for password begin FILNAM := SYSTEM_DEPENDENT.GET_FILENAME ( DEF_NAME, DEV_PROMPT, DIR_PROMPT, FIL_PROMPT, NODE_TYP ); COMMON_PROCS.GET_NEW_PASSWORD ( PASS_PROMPT, DEFAULT, PASS ); exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS GET_COMMON"); raise; end GET_COMMON; end MODEL_PROCS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --progprocs.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: PROGRAM_PROCS * -- * VERSION: 1.0a1 * -- * DATE : FEBRUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package provides a system_dependent function that forks a user -- application program as a process. The implementation of this routine -- must be changed for each operating system. -- package PROGRAM_PROCS is procedure RUN_PROGRAM ( NAME : in STRING; LEN : in POSITIVE ); -- -- Run_program is an interface to the operating system function that -- starts an application program as a process. The full filename is -- provided as a string, and the length of the name_string must be -- passed also. -- end PROGRAM_PROCS; with TEXT_IO, HOST_LCD_IF; package body PROGRAM_PROCS is use HOST_LCD_IF; procedure RUN_PROGRAM ( NAME : in STRING; LEN : in POSITIVE ) is FRTN_INT : LONG_INTEGER; RESULT : HOST_LCD_IF.ERROR_CLASS; begin if CanForkProgram then HOST_LCD_IF.FORK_PROGRAM ( NAME(1..LEN), " ", TRUE, FRTN_INT, RESULT); else TEXT_IO.PUT_LINE ("PROGRAM " & NAME(1..LEN) & " CANNOT BE RUN" ); end if; TEXT_IO.SET_INPUT (TEXT_IO.STANDARD_INPUT); TEXT_IO.SET_OUTPUT ( TEXT_IO.STANDARD_OUTPUT); end RUN_PROGRAM; end PROGRAM_PROCS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --videomain.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: VIDEO_MAIN * -- * VERSION: 1.0a1 * -- * DATE : FEBRUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- with VIDEO_TYPES, PASS_PROCS; package VIDEO_MAIN is -- -- VIDEO_MAIN global variables -- PASSWORD_FLAG : VIDEO_TYPES.FLAG := VIDEO_TYPES.ON; ERROR_MSG : VIDEO_TYPES.FLAG := VIDEO_TYPES.ON; READ_REC_NUM : NATURAL; CUR_REC_NUM : NATURAL; procedure MENU_INIT ( MSG : in STRING; HDR : in VIDEO_TYPES.HEADER_TYPE; FILNAM : out VIDEO_TYPES.FILESPEC; BOOT_REC : out VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ); procedure PROG_PROC ( MSG : in STRING; REC : in VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS; NEXT_REC : out NATURAL ); procedure PROCESS_OPTION ( LAST_MENU_PTR : in NATURAL; CUR_REC : in out VIDEO_TYPES.NODE_RECORD; ROOT_NUM : in NATURAL; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; CHOICE : in out VIDEO_TYPES.OPTIONS ); procedure GET_ANSWER ( MSG : in STRING; AFFIRMATIVE : out BOOLEAN; CHOICE : out VIDEO_TYPES.OPTIONS ); function CONFIRMED ( MSG : in STRING ) return BOOLEAN; function GET_BRANCH ( MSG : in STRING ) return VIDEO_TYPES.OPTIONS; procedure PUT_HEADER ( HEADER : in VIDEO_TYPES.HEADER_TYPE ); procedure GET_COMMON ( DEF_NAME : in VIDEO_TYPES.FILE_NAME; DEV_PROMPT : in STRING; DIR_PROMPT : in STRING; FIL_PROMPT : in STRING; PASS_PROMPT : in STRING; NODE_TYP : in VIDEO_TYPES.NODE; FILNAM : out VIDEO_TYPES.FILE_NAME; PASS : out PASS_PROCS.PASSWORD_TYPE ); end VIDEO_MAIN; with COMMON_PROCS, COMMON_MESSAGES, PROMPT_MESSAGES, PROGRAM_PROCS, VIDEO_IO, SYSTEM_DEPENDENT, VIDEO_PROCS, TEXT_IO; package body VIDEO_MAIN is use VIDEO_TYPES, COMMON_MESSAGES, PROMPT_MESSAGES; EXCEPT : constant STRING(1..30) := "EXCEPTION RAISED IN VIDEO_MAIN"; procedure MENU_INIT ( MSG : in STRING; HDR : in VIDEO_TYPES.HEADER_TYPE; FILNAM : out VIDEO_TYPES.FILESPEC; BOOT_REC : out VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ) is BOOT_FILE : VIDEO_TYPES.FILE_NAME; CONTINUE : BOOLEAN := TRUE; OPEN_OK : BOOLEAN := FALSE; FOUND : BOOLEAN := FALSE; begin SUCCESS := FALSE; COMMON_PROCS.SCREEN_DISPLAY ( COPYRIGHT ); COMMON_PROCS.SKIP_LINE; for I in VIDEO_TYPES.HEADER_LINES loop COMMON_PROCS.PUT_STRING ( HDR(I) ); COMMON_PROCS.NEXT_LINE; end loop; while CONTINUE loop begin -- first look to see if a file name has been placed in the file -- video.dat SYSTEM_DEPENDENT.GET_BOOT_NAME ( FILNAM, FOUND ); if not FOUND then -- get the filename from the user BOOT_FILE := SYSTEM_DEPENDENT.GET_FILENAME ( BOOT_FILE, PROMPT(DEVNAM_APL_MDL), PROMPT(DIRNAM_APL_MDL), PROMPT(APL_NAM), BOOT); FILNAM := SYSTEM_DEPENDENT.BUILD_FILESPEC ( BOOT_FILE ); end if; -- found VIDEO_IO.OPEN_NODE_FILE ( FILNAM ); CONTINUE := FALSE; OPEN_OK := TRUE; exception when VIDEO_IO.NAME_ERROR => COMMON_PROCS.MSG_PROC ("**ERROR** CANNOT FIND FILE " & FILNAM.NAME(1..FILNAM.LENGTH), ERROR_LINE ); if not CONFIRMED ("DO YOU WANT TO TRY ANOTHER FILENAME (Y/N) ?") then raise USER_QUIT; end if; end; end loop; if OPEN_OK then SUCCESS := TRUE; end if; exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS MENU_INIT" ); raise; end MENU_INIT; procedure PROG_PROC ( MSG : in STRING; REC : in VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS; NEXT_REC : out NATURAL ) is NO_MATCH : constant NATURAL := 0; FILSPEC : VIDEO_TYPES.FILESPEC; begin COMMON_PROCS.HOME_CLEAR; FILSPEC := SYSTEM_DEPENDENT.BUILD_FILESPEC ( REC.PATH ); PROGRAM_PROCS.RUN_PROGRAM ( FILSPEC.NAME, FILSPEC.LENGTH ); COMMON_PROCS.PROMPT_MSG ( MSG ); loop CHOICE := COMMON_PROCS.GET_INPUT; if CHOICE in CR..Z then exit; else COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); end if; end loop; if CHOICE = CR then if REC.NEXT_NODE /= VIDEO_IO.END_REC then NEXT_REC := REC.NEXT_NODE; else COMMON_PROCS.MSG_PROC ( "**ERROR** NO NODES BEYOND THIS NODE", ERROR_LINE ); PASSWORD_FLAG := VIDEO_TYPES.OFF; end if; end if; exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS PROG_PROC"); raise; end PROG_PROC; procedure PROCESS_OPTION ( LAST_MENU_PTR : in NATURAL; CUR_REC : in out VIDEO_TYPES.NODE_RECORD; ROOT_NUM : in NATURAL; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; CHOICE : in out VIDEO_TYPES.OPTIONS ) is begin case CHOICE is when SLASH => PASSWORD_FLAG := VIDEO_TYPES.OFF; if LAST_MENU_PTR /= BOOT_REC.POSITION then READ_REC_NUM := LAST_MENU_PTR; else COMMON_PROCS.MSG_PROC ( "** ERROR ** CURRENT NODE IS FIRST NODE", ERROR_LINE ); COMMON_PROCS.PROMPT_MSG ("ENTER 'T' TO TERMINATE OR <CR> TO PROCEED"); end if; when R => READ_REC_NUM := ROOT_NUM; PASSWORD_FLAG := VIDEO_TYPES.OFF; when I => VIDEO_PROCS.INST_FLAG := VIDEO_PROCS.INST_ENABLED; ERROR_MSG := VIDEO_PROCS.INST_ENABLED; READ_REC_NUM := CUR_REC_NUM; PASSWORD_FLAG := VIDEO_TYPES.OFF; COMMON_PROCS.MSG_PROC ("INSTRUCTION PAGE DISPLAY HAS BEEN ENABLED", ERROR_LINE ); when X => VIDEO_PROCS.INST_FLAG := VIDEO_PROCS.INST_DISABLED; ERROR_MSG := VIDEO_PROCS.INST_DISABLED; READ_REC_NUM := CUR_REC_NUM; PASSWORD_FLAG := VIDEO_TYPES.OFF; COMMON_PROCS.MSG_PROC ("INSTRUCTION PAGE DISPLAY HAS BEEN DISABLED", ERROR_LINE ); when T => COMMON_PROCS.HOME_CLEAR; READ_REC_NUM := BOOT_REC.POSITION; when others => null; end case; exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS PROCESS_OPTION"); raise; end PROCESS_OPTION; procedure GET_ANSWER ( MSG : in STRING; AFFIRMATIVE : out BOOLEAN; CHOICE : out VIDEO_TYPES.OPTIONS ) is DONE : BOOLEAN := FALSE; POS : VIDEO_TYPES.POSITION_TYPE; ANSWER : STRING(1..3); LEN : NATURAL; DEFAULT : STRING (1..3) := " "; begin CHOICE := CR; while not DONE loop COMMON_PROCS.PROMPT_MSG ( MSG ); POS := VIDEO_TYPES.ACTIVE_POSITION; COMMON_PROCS.GET_STRING ( ANSWER, LEN, POS, DEFAULT ); if LEN > 0 then case ANSWER(1) is when 'y'|'Y' => AFFIRMATIVE := TRUE; DONE := TRUE; when 'n'|'N' => AFFIRMATIVE := FALSE; DONE := TRUE; when '/' => CHOICE := SLASH; DONE := TRUE; when others => COMMON_PROCS.MSG_PROC (ERRORS(INVALID_RESP), ERROR_LINE ); end case; else AFFIRMATIVE := FALSE; DONE := TRUE; end if; end loop; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS GET_ANSWER"); end GET_ANSWER; function CONFIRMED ( MSG : in STRING ) return BOOLEAN is OK : BOOLEAN := FALSE; ANSWER : CHARACTER; begin loop COMMON_PROCS.PROMPT_MSG ( MSG ); COMMON_PROCS.GET_CHAR ( ANSWER ); case ANSWER is when 'N'|'n' => exit; when 'Y'|'y' => OK := TRUE; exit; when others => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP),ERROR_LINE ); end case; end loop; return OK; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS CONFIRMED"); raise; end CONFIRMED; function GET_BRANCH ( MSG : in STRING ) return VIDEO_TYPES.OPTIONS is CHOICE : VIDEO_TYPES.OPTIONS; begin loop COMMON_PROCS.PROMPT_MSG ( MSG ); CHOICE := COMMON_PROCS.GET_INPUT; case CHOICE is when SLASH|ONE..FIFTEEN => exit; when others => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); end case; end loop; return CHOICE; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS GET_BRANCH"); raise; end GET_BRANCH; procedure PUT_HEADER ( HEADER : in VIDEO_TYPES.HEADER_TYPE ) is DISPLAY_LINE : VIDEO_TYPES.POSITION_TYPE := ( 0,0 ); begin COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.MOVE_CURSOR ( DISPLAY_LINE ); for I in VIDEO_TYPES.HEADER_LINES loop DISPLAY_LINE.ROW := I; COMMON_PROCS.MSG_PROC ( HEADER(I), DISPLAY_LINE ); end loop; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS PUT_HEADER"); raise; end PUT_HEADER; procedure GET_COMMON ( DEF_NAME : in VIDEO_TYPES.FILE_NAME; DEV_PROMPT : in STRING; DIR_PROMPT : in STRING; FIL_PROMPT : in STRING; PASS_PROMPT : in STRING; NODE_TYP : in VIDEO_TYPES.NODE; FILNAM : out VIDEO_TYPES.FILE_NAME; PASS : out PASS_PROCS.PASSWORD_TYPE ) is begin FILNAM := SYSTEM_DEPENDENT.GET_FILENAME ( DEF_NAME, DEV_PROMPT, DIR_PROMPT, FIL_PROMPT, NODE_TYP ); COMMON_PROCS.GET_PASSWORD ( PASS_PROMPT, PASS ); exception when BAD_PASSWORD => raise; when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS GET_COMMON"); raise; end GET_COMMON; end VIDEO_MAIN; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --diagmsg.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: DIAGRAM_MESSAGES * -- * VERSION: 1.0a1 * -- * DATE : FEBRUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the prompts and error messages used in VIDEO_DIAGRAM. -- package DIAGRAM_MESSAGES is type ERRORS is ( READ_SPEC, NO_SPEC, OPEN_MODEL, READ_MODEL, END_OF_MODEL, TRAVERSE_MODEL, OPEN_TEMP, FREE_TEMP, OPEN_NODE, READ_NODE, PRINT_PASS ); type PROMPTS is ( DEV_NAME, DIR_NAME, FIL_NAME, PASS_RUN_APL, PASSWRD, SUCCESS ); type ERROR_MESSAGES is array (ERRORS) of STRING(1..75); ERROR : ERROR_MESSAGES := ( "**ERROR** AN ERROR OCCURRED READING THE MODEL FILE SPECIFICATION ", "**ERROR** NO MODEL FILE SPECIFICATION WAS ENTERED ", "**ERROR** AN ERROR OCCURRED OPENING THE MODEL FILE: ", "**ERROR** AN ERROR OCCURRED READING THE MODEL FILE AT RECORD: ", "**ERROR** AN END-OF-FILE WAS ENCOUNTERED READING THE MODEL FILE AT RECORD: ", "**ERROR** AN ERROR OCCURRED WHILE TRAVERSING THE MODEL ", "**ERROR** AN ERROR OCCURRED ATTEMPTING TO ALLOCATE TEMPORARY STORAGE ", "**ERROR** AN ERROR OCCURRED FREEING TEMPORARY STORAGE ", "**ERROR** AN ERROR OCCURRED OPENING THE NODE FILE: ", "**ERROR** AN ERROR OCCURRED READING THE NODE FILE: ", "**WARNING** MODEL PASSWORD INVALID-ACCESS PASSWORDS WILL NOT BE PRINTED "); type PROMPT_MESSAGES is array (PROMPTS) of STRING(1..58); PROMPT : PROMPT_MESSAGES := ( "ENTER DEVICE NAME OF MODEL TO BE DIAGRAMMED ", "ENTER DIRECTORY NAME OF MODEL TO BE DIAGRAMMED ", "ENTER FILENAME OF MODEL TO BE DIAGRAMMED ", "ENTER PASSWORD TO RUN APPLICATION ", "ENTER APPLICATION MODEL PASSWORD TO PRINT ACCESS PASSWORD ", "THE VIDEO DIAGRAM PROGRAM HAS COMPLETED SUCCESSFULLY " ); end DIAGRAM_MESSAGES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --diagtypes.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: DIAGRAM_TYPES * -- * VERSION: 1.0a1 * -- * DATE : FEBRUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the constants and types used in DIAGRAM. -- with VIDEO_TYPES; package DIAGRAM_TYPES is use VIDEO_TYPES; MAX_PAGE_LENGTH : constant LONG_INTEGER := 55; MAX_LINE_LENGTH : constant LONG_INTEGER := 132; OUTPUT_FILE : constant STRING(1..12) := "DIAGPRNT.TXT"; RPT_HDR_1 : constant STRING(1..50) := "VIDEO VERSION 1.0 LEVEL 0 RELEASE DATE: MAY, 1985"; RPT_HDR_2 : constant STRING(1..19) := "DIAGRAM OF MODEL: "; PAGE_HDR_1 : constant STRING(1..132) := " <--------- M O D E L S T R U C T U R E ---------> NODE ACCES" & "S "; PAGE_HDR_2 : constant STRING(1..132) := " 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16>16 TYPE NODE" & " N O D E F I L E S P E C PASSWORD "; subtype NODE_LEVEL is INTEGER range 1..17; type PRINT_RECORD is record NODE_TYPE : VIDEO_TYPES.NODE; PREV_NODE : VIDEO_TYPES.NODE; LEVEL : NODE_LEVEL := 1; FILSPEC : VIDEO_TYPES.FILESPEC; PASSWORD : STRING(1..8) := " "; end record; end DIAGRAM_TYPES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --diagramio.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: DIAGRAM_IO * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the io_routines for DIAGRAM. -- with DIAGRAM_TYPES; package DIAGRAM_IO is procedure CREATE_PRINT_FILE; -- procedure to create a print file function PRINT_FILE_OPEN return BOOLEAN; -- determine if print file is open procedure PRINT ( ITEM : in STRING ); -- writes a print record to the print file function LINE return INTEGER; -- returns the current line number procedure SKIP_LINES ( NUMBER : in POSITIVE := 1 ); -- Outputs at least one blank line procedure CLOSE_PRINT_FILE; -- closes a print file procedure DELETE_PRINT_FILE; -- deletes a print file end DIAGRAM_IO; with TEXT_IO, COMMON_PROCS; package body DIAGRAM_IO is EXCEPT : constant STRING (1..30) := "EXCEPTION RAISED IN DIAGRAM_IO"; PRINT_FILE : TEXT_IO.FILE_TYPE; procedure CREATE_PRINT_FILE is use DIAGRAM_TYPES, TEXT_IO; begin TEXT_IO.CREATE ( PRINT_FILE, OUT_FILE, OUTPUT_FILE ); TEXT_IO.SET_PAGE_LENGTH ( PRINT_FILE, MAX_PAGE_LENGTH ); TEXT_IO.SET_LINE_LENGTH ( PRINT_FILE, MAX_LINE_LENGTH ); exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS CREATE_PRINT_FILE"); raise; end CREATE_PRINT_FILE; procedure PRINT ( ITEM : in STRING ) is begin TEXT_IO.PUT_LINE ( PRINT_FILE, ITEM ); exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS PRINT"); raise; end PRINT; function LINE return INTEGER is LINE_COUNT : TEXT_IO.COUNT; begin LINE_COUNT := TEXT_IO.LINE ( PRINT_FILE ); return INTEGER(LINE_COUNT); exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS LINE"); raise; end LINE; procedure SKIP_LINES ( NUMBER : in POSITIVE := 1 ) is SPACING : TEXT_IO.POSITIVE_COUNT; begin SPACING := TEXT_IO.POSITIVE_COUNT(NUMBER); TEXT_IO.NEW_LINE ( PRINT_FILE, SPACING ); exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS SKIP_LINES"); raise; end SKIP_LINES; procedure CLOSE_PRINT_FILE is begin TEXT_IO.CLOSE ( PRINT_FILE ); exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS CLOSE_PRINT_FILE"); raise; end CLOSE_PRINT_FILE; function PRINT_FILE_OPEN return BOOLEAN is begin return TEXT_IO.IS_OPEN ( PRINT_FILE ); exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS PRINT_FILE_OPEN"); raise; end PRINT_FILE_OPEN; procedure DELETE_PRINT_FILE is begin if PRINT_FILE_OPEN then TEXT_IO.DELETE (PRINT_FILE); end if; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS DELETE_PRINT_FILE"); end DELETE_PRINT_FILE; end DIAGRAM_IO; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --init.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: INIT * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the main routines used in VIDEO_INIT. -- with VIDEO_TYPES; package INIT is procedure INIT_HEADER ( HDR : in VIDEO_TYPES.HEADER_TYPE ); -- this displays the copyright message and initialization header. procedure INIT_TREE ( BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ); -- init_tree prompts the user for the name of the node(boot) file, -- then attempts to create the file. If successful, init_tree sets up -- the boot record, and prompts for the boot password, which controls -- access to the node. -- exceptions raised are file_exists, status_error, and name error. -- The handler for these asks the user to continue(Y/N). If yes, user -- is again prompted for a file name, otherwise, the program will end. procedure INIT_ROOT ( BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; ROOT_REC : in out VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ); -- The root node is the first node displayed when a user has successfully -- opened the node file. Init_root prompts the user for the root node type, -- the name of the file to display, and the root password. The root record -- is then created, and written to the file. If the write is successful, -- the boot record is updated to point to the next free node. -- The exception use_error is handled when file capacity exceeded. procedure WRAP_UP ( SAVE : in BOOLEAN ); -- If the entire process has been successful, wrap_up closes the node -- file. Otherwise, wrap_up deletes the node_file. end INIT; with PASS_PROCS, COMMON_MESSAGES, PROMPT_MESSAGES, COMMON_PROCS, SYSTEM_DEPENDENT, VIDEO_IO, VIDEO_DEBUG; package body INIT is use VIDEO_TYPES, COMMON_MESSAGES, PROMPT_MESSAGES; EXCEPT : constant STRING (1..24) := "EXCEPTION RAISED IN INIT"; NO_DEFAULT : STRING(1..1) := " "; procedure INIT_HEADER (HDR : in VIDEO_TYPES.HEADER_TYPE ) is begin COMMON_PROCS.SCREEN_DISPLAY ( COPYRIGHT ); COMMON_PROCS.SKIP_LINE (2); for I in VIDEO_TYPES.HEADER_LINES loop COMMON_PROCS.PUT_STRING ( HDR (I) ); COMMON_PROCS.NEXT_LINE; end loop; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUB-ROUTINE IS INIT_HEADER"); raise; end INIT_HEADER; procedure INIT_TREE ( BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ) is CONTINUE : BOOLEAN := TRUE; ANSWER : CHARACTER; BOOT_FILSPEC : VIDEO_TYPES.FILESPEC; REC_DEFAULT : VIDEO_TYPES.FILE_NAME; begin SUCCESS := FALSE; while CONTINUE loop begin BOOT_REC.DEFAULT := SYSTEM_DEPENDENT.GET_FILENAME ( REC_DEFAULT, PROMPT(DEVNAM_APL_MDL), PROMPT(DIRNAM_APL_MDL), PROMPT(NAM_APL_INIT), BOOT ); BOOT_FILSPEC := SYSTEM_DEPENDENT.BUILD_FILESPEC ( BOOT_REC.DEFAULT ); VIDEO_IO.CREATE_NODE_FILE ( BOOT_FILSPEC ); BOOT_REC.DEFAULT.FIL := REC_DEFAULT.FIL; BOOT_REC.LAST_NODE := 0; BOOT_REC.LAST_MENU := 0; BOOT_REC.POSITION := 0; COMMON_PROCS.GET_NEW_PASSWORD ( PROMPT(PASS_MDL), NO_DEFAULT, BOOT_REC.NODE_PASSWORD ); BOOT_REC.NEXT_FREE_NODE := 0; BOOT_REC.LAST_FREE_NODE := 1; VIDEO_IO.WRITE_NODE ( BOOT_REC ); CONTINUE := FALSE; SUCCESS := TRUE; exception -- local block exception handlers when USER_QUIT => COMMON_PROCS.PROMPT_MSG ( "ARE YOU SURE YOU WANT TO QUIT(Y/N) ?"); COMMON_PROCS.GET_CHAR ( ANSWER ); if ANSWER = 'y' or ANSWER = 'Y' then raise USER_QUIT; end if; when VIDEO_IO.FILE_EXISTS => COMMON_PROCS.MSG_PROC ( "FILE ALREADY EXISTS", ERROR_LINE ); COMMON_PROCS.PROMPT_MSG ( "DO YOU WANT TO CONTINUE(Y/N) ?"); COMMON_PROCS.GET_CHAR ( ANSWER ); if ANSWER = 'N' or ANSWER = 'n' then raise USER_QUIT; end if; when VIDEO_IO.STATUS_ERROR => COMMON_PROCS.MSG_PROC ( "FILE ALREADY OPEN", ERROR_LINE ); COMMON_PROCS.PROMPT_MSG ( "DO YOU WANT TO CONTINUE(Y/N) ?"); COMMON_PROCS.GET_CHAR ( ANSWER ); if ANSWER = 'N' or ANSWER = 'n' then raise USER_QUIT; end if; when VIDEO_IO.NAME_ERROR => COMMON_PROCS.MSG_PROC ("NOT A VALID NAME", ERROR_LINE ); COMMON_PROCS.PROMPT_MSG ( "DO YOU WANT TO CONTINUE(Y/N) ?"); COMMON_PROCS.GET_CHAR ( ANSWER ); if ANSWER = 'N' or ANSWER = 'n' then raise USER_QUIT; end if; when VIDEO_IO.USE_ERROR => COMMON_PROCS.MSG_PROC ("FILE CAPACITY EXCEEDED - SEE SYSTEM MANAGER", ERROR_LINE ); raise; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUB-ROUTINE IS INIT_TREE"); raise; end; -- local block end loop; -- while continue end INIT_TREE; procedure INIT_ROOT ( BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; ROOT_REC : in out VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ) is VALID : BOOLEAN := FALSE; ANSWER : CHARACTER; PASS : PASS_PROCS.PASSWORD_TYPE; ROOT_NODE_TYPE : VIDEO_TYPES.USER_NODE; REC_FILNAM : VIDEO_TYPES.FILE_NAME; begin while not VALID loop -- main begin ROOT_NODE_TYPE := COMMON_PROCS.GET_NODE_TYPE ( PROMPT(RTNOD_TYP) ); if ROOT_NODE_TYPE in MENU..INSTRUCTION then REC_FILNAM := SYSTEM_DEPENDENT.GET_FILENAME ( BOOT_REC.DEFAULT, PROMPT(RTNOD_DEV), PROMPT(RTNOD_DIR), PROMPT(RTNOD_NAM), ROOT_NODE_TYPE ); COMMON_PROCS.GET_NEW_PASSWORD ( PROMPT(PASS_RUN_APL), NO_DEFAULT, PASS ); if ROOT_NODE_TYPE = MENU then ROOT_REC := ( MENU, 0, 1, BOOT_REC.LAST_FREE_NODE, PASS, REC_FILNAM, (ONE..FIFTEEN => VIDEO_IO.END_REC) ); else -- root_node_type = instruction ROOT_REC := ( INSTRUCTION, 0, 1, BOOT_REC.LAST_FREE_NODE, PASS, REC_FILNAM, VIDEO_IO.END_REC ); end if; -- root_node_type = menu VIDEO_IO.WRITE_NODE ( ROOT_REC ); BOOT_REC.LAST_FREE_NODE := BOOT_REC.LAST_FREE_NODE + 1; VIDEO_IO.WRITE_NODE ( BOOT_REC ); VALID := TRUE; SUCCESS := TRUE; else -- node type entered was program or boot COMMON_PROCS.MSG_PROC ( ERRORS(INV_NODETYPE), ERROR_LINE ); end if; -- root node type is valid exception when USER_QUIT => COMMON_PROCS.PROMPT_MSG ( "ARE YOU SURE YOU WANT TO QUIT(Y/N) ?"); COMMON_PROCS.GET_CHAR ( ANSWER ); if ANSWER = 'y' or ANSWER = 'Y' then raise USER_QUIT; end if; end; end loop; -- main exception when USER_QUIT => raise; when VIDEO_IO.USE_ERROR => COMMON_PROCS.MSG_PROC ( "FILE CAPACITY EXCEEDED - SEE SYSTEM MANAGER", ERROR_LINE ); raise; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUB-ROUTINE IS INIT_ROOT"); raise; end INIT_ROOT; procedure WRAP_UP ( SAVE : in BOOLEAN ) is use VIDEO_IO; begin if VIDEO_IO.NODE_FILE_OPEN then if SAVE then VIDEO_IO.CLOSE_NODE_FILE ( SAVE_FILE ); else -- delete the file VIDEO_IO.CLOSE_NODE_FILE ( DELETE_FILE ); end if; -- save end if; -- node_file_open end WRAP_UP; end INIT; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --vidinit.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * MAIN_PROCEDURE : VIDEO_INIT * -- * VERSION : 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This is the main procedure for initialization of the video node file. -- with VIDEO_TYPES, COMMON_MESSAGES, COMMON_PROCS, INIT, VIDEO_DEBUG; procedure VIDEO_INIT is use VIDEO_TYPES, COMMON_MESSAGES, INIT; EXCEPT : constant STRING (1..30) := "EXCEPTION RAISED IN VIDEO_INIT"; BLANKS : STRING (1..14) := " "; INIT_HDR : constant VIDEO_TYPES.HEADER_TYPE := (1=>BLANKS & "*****************************************************" & BLANKS, 2=>BLANKS & "* *" & BLANKS, 3=>BLANKS & "* VIDEO INITIALIZATION *" & BLANKS, 4=>BLANKS & "* *" & BLANKS, 5=>BLANKS & "*****************************************************" & BLANKS ); BOOT_REC : VIDEO_TYPES.NODE_RECORD (BOOT); ROOT_REC : VIDEO_TYPES.NODE_RECORD; -- uses the default type menu OK : BOOLEAN := FALSE; begin INIT_HEADER ( INIT_HDR ); INIT_TREE ( BOOT_REC, OK ); if OK then -- node file created and boot record written INIT_ROOT ( BOOT_REC, ROOT_REC, OK ); if OK then -- root record written and boot record updated COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.MOVE_CURSOR ( HOME_POSITION ); COMMON_PROCS.PUT_STRING (MESSAGES (SUCCESS_INIT) ); COMMON_PROCS.NEXT_LINE; else -- init_root failed COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.MOVE_CURSOR ( HOME_POSITION ); COMMON_PROCS.PUT_STRING ( ERRORS(PROC_TERM) ); COMMON_PROCS.PUT_STRING ( ": INIT_ROOT FAILED" ); COMMON_PROCS.NEXT_LINE; end if; -- init_root ok else -- init_tree failed COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.MOVE_CURSOR ( HOME_POSITION ); COMMON_PROCS.PUT_STRING ( ERRORS(PROC_TERM) ); COMMON_PROCS.PUT_STRING ( ": INIT_TREE FAILED" ); COMMON_PROCS.NEXT_LINE; end if; -- init_tree ok INIT.WRAP_UP ( OK ); -- saves or deletes the file depending on value of ok exception when USER_QUIT => COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.MOVE_CURSOR ( HOME_POSITION ); COMMON_PROCS.PUT_STRING ( "VIDEO INITIALIZATION SESSION STOPPED" ); COMMON_PROCS.NEXT_LINE; -- if user quit, delete the node file OK := FALSE; INIT.WRAP_UP ( OK ); when others => -- if anything else went wrong, delete the node file OK := FALSE; INIT.WRAP_UP ( OK ); -- close the file containing the exception trace VIDEO_DEBUG.PRINT_EXCEPTIONS; end VIDEO_INIT; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --add.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: ADD * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains all the routines used by VIDEO_MODEL for adding nodes. -- with VIDEO_TYPES; package ADD is procedure NODE_DIAG ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC: in out VIDEO_TYPES.NODE_RECORD; CHOICE : in out VIDEO_TYPES.OPTIONS ); -- Node_diag is the main routine for adding and the only routine visible -- outside the package. When called by model, it first displays the add -- header, then prompts for the type of node to add. It then calls the -- add routine corresponding to the node type. These routines prompt the -- user for the necessary information, add the node, and if successful, -- update the current node and boot node. end ADD; with PASS_PROCS, COMMON_MESSAGES, PROMPT_MESSAGES, VIDEO_IO, COMMON_PROCS, MODEL_PROCS; package body ADD is use VIDEO_TYPES, COMMON_MESSAGES, PROMPT_MESSAGES; EXCEPT : constant STRING(1..23) := "EXCEPTION RAISED IN ADD"; NO_DEFAULT: STRING(1..1) := " "; BLANKS : STRING (1..14) := " "; ADD_HEADER : constant VIDEO_TYPES.HEADER_TYPE := (1=>BLANKS & "*****************************************************" & BLANKS, 2=>BLANKS & "* *" & BLANKS, 3=>BLANKS & "* ***** ADD MODE ***** *" & BLANKS, 4=>BLANKS & "* *" & BLANKS, 5=>BLANKS & "*****************************************************" & BLANKS ); procedure ADD_COMMON ( BOOT_REC : in VIDEO_TYPES.NODE_RECORD; NODE_TYP : in VIDEO_TYPES.NODE; FILENAM : out VIDEO_TYPES.FILE_NAME; PASS : out PASS_PROCS.PASSWORD_TYPE ) is -- Add_common prompts the user for the filename and the password of the -- node to be added. begin MODEL_PROCS.GET_COMMON ( BOOT_REC.DEFAULT, PROMPT (DEVNAM), PROMPT (DIRNAM), PROMPT (ADD_FILNAM), PROMPT(PASSWRD), NODE_TYP, FILENAM, PASS ); exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS ADD_COMMON"); raise; end ADD_COMMON; function ADD_BRANCH ( MSG : in STRING; CUR_REC : in VIDEO_TYPES.NODE_RECORD ) return VIDEO_TYPES.OPTIONS is -- -- Add_branch is called by the add routines if the current record is -- a menu node. It prompts the user for the menu branch to add the new -- node to. -- CHOICE : VIDEO_TYPES.OPTIONS; TRIES : NATURAL range 0..2 := 0; begin loop -- until valid branch or tries > 2 TRIES := TRIES + 1; CHOICE := MODEL_PROCS.GET_BRANCH ( MSG ); case CHOICE is when SLASH => -- cancel add exit; when ONE..FIFTEEN => if CUR_REC.OPTION(CHOICE) /= VIDEO_IO.END_REC then -- invalid branch choosen COMMON_PROCS.MSG_PROC ( ERRORS(INV_BR_NO), ERROR_LINE ); if TRIES = 2 then COMMON_PROCS.MSG_PROC ( "**ERROR** BRANCH IS ALREADY CONNECTED" & " TO A NODE", ERROR_LINE ); if MODEL_PROCS.CONFIRMED ( "DO YOU WANT TO TRY ANOTHER " & "BRANCH (Y/N)?") then TRIES := 0; -- try again else -- tell user to insert node COMMON_PROCS.MSG_PROC ( "TO ADD AT THIS NODE USE INSERT MODE", ERROR_LINE ); loop -- until valid response COMMON_PROCS.PROMPT_MSG ("ENTER SLASH TO RETURN TO " & "MAINTENANCE MENU" ); CHOICE := COMMON_PROCS.GET_INPUT; exit when CHOICE = SLASH; end loop; -- valid response end if; -- confirmed try again end if; -- tries = 2 else -- valid branch number choosen exit; end if; -- cur_rec.option(choice) /= end_rec when others => -- ignore all other responses null; end case; -- choice end loop; -- main return CHOICE; exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS ADD_BRANCH"); raise; end ADD_BRANCH; procedure ADD_NODE (NEW_REC : in out VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ) is -- Add_node prompts the user to confirm the add. If yes, the record is -- added, and success becomes true. If no, or if the write fails, success -- returns as false. -- begin SUCCESS := FALSE; if MODEL_PROCS.CONFIRMED ( "ADD THIS NODE (Y/N) ?" ) then VIDEO_IO.WRITE_NODE ( NEW_REC ); SUCCESS := TRUE; end if; exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS ADD_NODE"); raise; end ADD_NODE; procedure ADD_MENU ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; IN_BRANCH : in out VIDEO_TYPES.OPTIONS ) is -- Add_menu looks first at the current_node and prompts for the branch -- to attach to if the current_node is a menu. If it is not a menu and -- the next_node is free, or if it is a menu and the choosen branch is -- free, add_common is called to get the filename and password of the -- new node. If the boot record pointers indicate that there are no -- free nodes within the file, (i.e. no free space needs to be recovered), -- then the position is set to end-of-file, otherwise, the first available -- space is used. The record is then created, and, if the node is added, -- the boot and current records are updated. -- NEW_REC : VIDEO_TYPES.NODE_RECORD; FILENAM : VIDEO_TYPES.FILE_NAME; PASS : PASS_PROCS.PASSWORD_TYPE; NEW_POSITION : NATURAL; NEXT_FREE_NODE : NATURAL; LAST_MENU : NATURAL; ADD_OK : BOOLEAN; begin if CUR_REC.NODE_TYPE = MENU then -- prompt for in_branch IN_BRANCH := ADD_BRANCH ( PROMPT(ADD_BR_NO), CUR_REC ); LAST_MENU := CUR_REC.POSITION; else -- current_node = instruction or program if CUR_REC.NEXT_NODE /= VIDEO_IO.END_REC then -- user should use insert mode COMMON_PROCS.MSG_PROC ( "**ERROR** THERE IS A NODE ATTACHED TO " & "THIS NODE - USE INSERT MODE", ERROR_LINE ); IN_BRANCH := SLASH; end if; -- cur_rec.next_node not free LAST_MENU := CUR_REC.LAST_MENU; end if; -- cur_rec.node_type = menu if IN_BRANCH /= SLASH then -- user did not cancel ADD_COMMON ( BOOT_REC, MENU, FILENAM, PASS ); if BOOT_REC.NEXT_FREE_NODE = 0 then -- no free space to recover NEW_POSITION := BOOT_REC.LAST_FREE_NODE; else -- recover free space VIDEO_IO.READ_NODE ( NEW_REC, BOOT_REC.NEXT_FREE_NODE ); NEXT_FREE_NODE := NEW_REC.LAST_NODE; NEW_POSITION := BOOT_REC.NEXT_FREE_NODE; end if; -- next_free_node = 0 NEW_REC := ( MENU, CUR_REC.POSITION, LAST_MENU, NEW_POSITION, PASS, FILENAM, (ONE..FIFTEEN => VIDEO_IO.END_REC) ); ADD_NODE ( NEW_REC, ADD_OK ); if ADD_OK then -- new_record was added if BOOT_REC.NEXT_FREE_NODE = 0 then -- update pointer to end of file BOOT_REC.LAST_FREE_NODE := BOOT_REC.LAST_FREE_NODE + 1; else -- recover free space BOOT_REC.NEXT_FREE_NODE := NEXT_FREE_NODE; end if; -- next_free_node = 0 if CUR_REC.NODE_TYPE = MENU then CUR_REC.OPTION ( IN_BRANCH ) := NEW_REC.POSITION; else -- type is instruction or program CUR_REC.NEXT_NODE := NEW_REC.POSITION; end if; -- node type is menu VIDEO_IO.WRITE_NODE ( BOOT_REC ); VIDEO_IO.WRITE_NODE ( CUR_REC ); end if; -- add_ok end if; -- in_branch /= slash exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS ADD_MENU"); raise; end ADD_MENU; procedure ADD_INST ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; IN_BRANCH : in out VIDEO_TYPES.OPTIONS ) is -- -- Add_inst behaves exactly as add_menu, except in setting up the node_record -- NEW_REC : VIDEO_TYPES.NODE_RECORD; FILENAM : VIDEO_TYPES.FILE_NAME; PASS : PASS_PROCS.PASSWORD_TYPE; NEW_POSITION : NATURAL; NEXT_FREE_NODE : NATURAL; LAST_MENU : NATURAL; ADD_OK : BOOLEAN; begin if CUR_REC.NODE_TYPE = MENU then IN_BRANCH := ADD_BRANCH ( PROMPT(ADD_BR_NO), CUR_REC ); LAST_MENU := CUR_REC.POSITION; else -- cur_rec.node_type = instruction or program if CUR_REC.NEXT_NODE /= VIDEO_IO.END_REC then -- next node is not free COMMON_PROCS.MSG_PROC ( "**ERROR** THERE IS A NODE ATTACHED TO " & "THIS NODE - USE INSERT MODE", ERROR_LINE ); IN_BRANCH := SLASH; end if; -- next_node /= end_rec LAST_MENU := CUR_REC.LAST_MENU; end if; -- node_type = menu if IN_BRANCH /= SLASH then -- user did not cancel ADD_COMMON ( BOOT_REC, INSTRUCTION, FILENAM, PASS ); if BOOT_REC.NEXT_FREE_NODE = 0 then -- no free space to recover NEW_POSITION := BOOT_REC.LAST_FREE_NODE; else -- free space to recover VIDEO_IO.READ_NODE ( NEW_REC, BOOT_REC.NEXT_FREE_NODE ); NEXT_FREE_NODE := NEW_REC.LAST_NODE; NEW_POSITION := BOOT_REC.NEXT_FREE_NODE; end if; -- next_free_node = 0 NEW_REC := ( INSTRUCTION, CUR_REC.POSITION, LAST_MENU, NEW_POSITION, PASS, FILENAM, VIDEO_IO.END_REC ); ADD_NODE ( NEW_REC, ADD_OK ); if ADD_OK then if BOOT_REC.NEXT_FREE_NODE = 0 then -- update pointer to end of file BOOT_REC.LAST_FREE_NODE := BOOT_REC.LAST_FREE_NODE + 1; else -- recover free space BOOT_REC.NEXT_FREE_NODE := NEXT_FREE_NODE; end if; -- next_free_node = 0 if CUR_REC.NODE_TYPE = MENU then CUR_REC.OPTION ( IN_BRANCH ) := NEW_REC.POSITION; else -- node_type = instruction or program CUR_REC.NEXT_NODE := NEW_REC.POSITION; end if; -- node_type = menu VIDEO_IO.WRITE_NODE ( BOOT_REC ); VIDEO_IO.WRITE_NODE ( CUR_REC ); end if; -- add_ok end if; -- in_branch /= slash exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS ADD_INST"); raise; end ADD_INST; procedure ADD_PROG ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; IN_BRANCH : in out VIDEO_TYPES.OPTIONS ) is -- -- Add_prog performs the same way as Add_menu except in creating node_record -- NEW_REC : VIDEO_TYPES.NODE_RECORD; FILENAM : VIDEO_TYPES.FILE_NAME; PASS : PASS_PROCS.PASSWORD_TYPE; NEW_POSITION : NATURAL; NEXT_FREE_NODE : NATURAL; LAST_MENU : NATURAL; ADD_OK : BOOLEAN; begin if CUR_REC.NODE_TYPE = MENU then IN_BRANCH := ADD_BRANCH ( PROMPT(ADD_BR_NO), CUR_REC ); LAST_MENU := CUR_REC.POSITION; else -- node_type = instruction or program if CUR_REC.NEXT_NODE /= VIDEO_IO.END_REC then -- next_node is not free COMMON_PROCS.MSG_PROC ( "**ERROR** THERE IS A NODE ATTACHED TO " & "THIS NODE - USE INSERT MODE", ERROR_LINE ); IN_BRANCH := SLASH; end if; -- next_node /= end_rec LAST_MENU := CUR_REC.LAST_MENU; end if; -- node_type = menu if IN_BRANCH /= SLASH then -- user did not cancel ADD_COMMON ( BOOT_REC, PROGRAM, FILENAM, PASS ); if BOOT_REC.NEXT_FREE_NODE = 0 then -- no free space to recover NEW_POSITION := BOOT_REC.LAST_FREE_NODE; else -- free space to recover VIDEO_IO.READ_NODE ( NEW_REC, BOOT_REC.NEXT_FREE_NODE ); NEXT_FREE_NODE := NEW_REC.LAST_NODE; NEW_POSITION := BOOT_REC.NEXT_FREE_NODE; end if; -- next_free_node = 0 NEW_REC := ( PROGRAM, CUR_REC.POSITION, LAST_MENU, NEW_POSITION, PASS, FILENAM, VIDEO_IO.END_REC ); ADD_NODE ( NEW_REC, ADD_OK ); if ADD_OK then if BOOT_REC.NEXT_FREE_NODE = 0 then -- no free space to recover BOOT_REC.LAST_FREE_NODE := BOOT_REC.LAST_FREE_NODE + 1; else -- free space to recover BOOT_REC.NEXT_FREE_NODE := NEXT_FREE_NODE; end if; -- next_free_node = 0 if CUR_REC.NODE_TYPE = MENU then CUR_REC.OPTION ( IN_BRANCH ) := NEW_REC.POSITION; else -- node_type = instruction or program CUR_REC.NEXT_NODE := NEW_REC.POSITION; end if; -- node_type = menu VIDEO_IO.WRITE_NODE ( BOOT_REC ); VIDEO_IO.WRITE_NODE ( CUR_REC ); end if; -- add_ok end if; -- in_branch /= slash exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS ADD_PROG"); raise; end ADD_PROG; procedure NODE_DIAG ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC: in out VIDEO_TYPES.NODE_RECORD; CHOICE : in out VIDEO_TYPES.OPTIONS ) is NEW_NODE_TYPE : VIDEO_TYPES.USER_NODE; begin MODEL_PROCS.PUT_HEADER ( ADD_HEADER ); NEW_NODE_TYPE := COMMON_PROCS.GET_NODE_TYPE ( PROMPT(ADD_TYP) ); case NEW_NODE_TYPE is -- evaluate new_node_type when MENU => ADD_MENU ( CUR_REC, BOOT_REC, CHOICE ); when INSTRUCTION => ADD_INST ( CUR_REC, BOOT_REC, CHOICE ); when PROGRAM => ADD_PROG ( CUR_REC, BOOT_REC, CHOICE ); end case; -- new_node_type exception when USER_QUIT => CHOICE := SLASH; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS ADD_NODE_DIAG"); raise; end NODE_DIAG; end ADD; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --delete.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: DELETE * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains all the routines used by VIDEO_MODEL for deleting -- nodes. -- with VIDEO_TYPES; package DELETE is procedure NODE_DIAG ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS ); -- Node_diag is the only routine visible outside the package body. It -- first displays the delete header. Then, if the current node is a -- menu, it prompts for a branch number to delete. If a <CR> is entered, -- the current node will be deleted, otherwise, only the node attached -- to the choosen branch will be marked for delete. If the current node -- is a program or instruction node, the user will be prompted to include -- the current node in the delete. The user will then be asked if the -- selected node is the only node to be deleted. If yes, then the user -- is asked to confirm single node deletion, if no, to confirm multiple -- node deletion. If the user confirms, deletion will proceed, and a -- result message will be displayed. An attempt to perform single -- deletion on a menu node with subtrees will not be allowed. If the -- process is successful, the boot record and current record will be -- updated. -- Delete recovers free space within the file by marking deleted -- records as usable for subsequent adds or inserts. If the deletion -- fails, Delete will attempt to recover the deleted nodes, and will -- indicate the success or failure of this process. Since the likely -- cause of failure is a hardware or file_io error, it is important -- that a back-up copy of the file be made prior to any modeling session. -- end DELETE; with COMMON_MESSAGES, PROMPT_MESSAGES, VIDEO_IO, COMMON_PROCS, MODEL_PROCS; package body DELETE is use VIDEO_TYPES, COMMON_MESSAGES, PROMPT_MESSAGES; EXCEPT : constant STRING(1..26) := "EXCEPTION RAISED IN DELETE"; DELETE_FAILED : exception; BLANKS : STRING (1..14) := " "; DELETE_HEADER : constant VIDEO_TYPES.HEADER_TYPE := (1=>BLANKS & "*****************************************************" & BLANKS, 2=>BLANKS & "* *" & BLANKS, 3=>BLANKS & "* ***** DELETE MODE ***** *" & BLANKS, 4=>BLANKS & "* *" & BLANKS, 5=>BLANKS & "*****************************************************" & BLANKS ); function GET_BRANCH ( MSG : in STRING ) return VIDEO_TYPES.OPTIONS is -- -- Get_branch prompts the user for a branch number. It will accept -- 1..15, slash, or <CR>. -- CHOICE : VIDEO_TYPES.OPTIONS; begin loop -- until valid response COMMON_PROCS.PROMPT_MSG ( MSG ); CHOICE := COMMON_PROCS.GET_INPUT; case CHOICE is when CR|SLASH|ONE..FIFTEEN => exit; when others => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); end case; end loop; -- until valid response return CHOICE; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS GET_BRANCH"); raise; end GET_BRANCH; function GET_DELETE_BRANCH ( REC : in VIDEO_TYPES.NODE_RECORD; MSG : in STRING ) return VIDEO_TYPES.OPTIONS is -- -- Get_delete_branch gets the branch number to be deleted, then confirms -- that the choosen branch has a subtree attached. If not, an error is -- indicated. -- BRANCH : VIDEO_TYPES.OPTIONS; begin loop -- until valid branch entered BRANCH := GET_BRANCH ( MSG ); case BRANCH is when CR|SLASH => exit; when ONE..FIFTEEN => if REC.OPTION(BRANCH) = VIDEO_IO.END_REC then COMMON_PROCS.MSG_PROC ( ERRORS(INV_BR_NO), ERROR_LINE ); else -- branch has a subtree exit; end if; -- rec.option(branch) = end_rec when others => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); end case; -- branch end loop; -- until valid return BRANCH; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS GET_DELETE_BRANCH"); raise; end GET_DELETE_BRANCH; procedure GET_NODES ( CUR_REC : in VIDEO_TYPES.NODE_RECORD; PREV_REC : out VIDEO_TYPES.NODE_RECORD; DEL_REC : out VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS ) is -- Get_nodes first determines if the current node is a menu node. If so -- it prompts the user to enter the number of the branch to be deleted. -- If the user enters a <CR>, then the current_node is marked for deletion, -- otherwise, the node attached to the choosen branch is marked. -- If the current node is a program or instruction, the user is prompted -- to delete the current node. If the user confirms, the current record -- is marked for deletion, otherwise, the next_node is marked. -- If the current node is to be deleted, then it becomes the delete_record, -- and the previous node is read from the file, and will be updated if -- the deletion succeeds. If the current node is not to be deleted, the -- current record becomes the previous record, and the next node becomes -- the delete record. -- BRANCH : VIDEO_TYPES.OPTIONS; INCLUDE_CUR : BOOLEAN := FALSE; begin case CUR_REC.NODE_TYPE is when MENU => BRANCH := GET_DELETE_BRANCH ( CUR_REC, PROMPT(DEL_BR_NO) ); case BRANCH is when SLASH => -- user canceled operation CHOICE := SLASH; when CR => -- current_record is to be included in deletion DEL_REC := CUR_REC; VIDEO_IO.READ_NODE ( PREV_REC, DEL_REC.LAST_NODE ); when ONE..FIFTEEN => -- delete part or all of a sub-tree PREV_REC := CUR_REC; VIDEO_IO.READ_NODE ( DEL_REC, PREV_REC.OPTION(BRANCH) ); when others => -- ignore anything else null; end case; -- branch when others => -- cur_rec.node_type = program or instruction -- so ask if user wants to include this node MODEL_PROCS.GET_ANSWER ( PROMPT(DEL_THIS_NOD), INCLUDE_CUR, CHOICE ); if INCLUDE_CUR then DEL_REC := CUR_REC; VIDEO_IO.READ_NODE ( PREV_REC, DEL_REC.LAST_NODE ); else -- begin deletion with the next node PREV_REC := CUR_REC; VIDEO_IO.READ_NODE ( DEL_REC, PREV_REC.NEXT_NODE ); end if; -- include current node end case; -- cur_rec.node_type exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS GET_NODES"); raise; end GET_NODES; procedure DELETE_MULTIPLE_NODES (PREV_REC : in VIDEO_TYPES.NODE_RECORD; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ) is -- Delete_multiple_nodes is a recursive routine that deletes a subtree. Since -- it is recursive, a node that is not a leaf will not be deleted until it's -- subtrees are deleted. There are two cases for this routine, depending -- on the type of the previous record. The routine first determines this type. -- If it is a menu node, then for each branch that has a subtree, it reads -- the next node into Delete_record, and passes that record in a recursive -- call. If the call returns successfully, the delete_record is updated to -- indicate the next free node (last node deleted) and the boot record is -- updated to point to the next free space. -- If it is a program or instruction node and it has a subtree, it reads -- the next_node into the delete_record, then passes this delete_record in -- a recursive call. If the call returns successfully, the delete and boot -- records are updated to reflect the free space. -- DEL_REC : VIDEO_TYPES.NODE_RECORD; begin SUCCESS := FALSE; case PREV_REC.NODE_TYPE is when MENU => -- then node may have more than one subtree for I in ONE..FIFTEEN loop if PREV_REC.OPTION(I) /= VIDEO_IO.END_REC then -- there is a subtree attached VIDEO_IO.READ_NODE ( DEL_REC, PREV_REC.OPTION(I) ); DELETE_MULTIPLE_NODES ( DEL_REC, BOOT_REC, SUCCESS ); if SUCCESS then -- the subtree for this delete record has been deleted so -- set delete record's pointer to the last deleted node. DEL_REC.LAST_NODE := BOOT_REC.NEXT_FREE_NODE; DEL_REC.LAST_MENU := VIDEO_IO.END_REC; -- zero out last menu -- set boot record pointer for recoverable space to this -- node position BOOT_REC.NEXT_FREE_NODE := DEL_REC.POSITION; -- write the node back to the file VIDEO_IO.WRITE_NODE ( DEL_REC ); end if; -- success end if; -- prev_rec.option(i) /= end_rec end loop; -- for i in one..fifteen when PROGRAM|INSTRUCTION => if PREV_REC.NEXT_NODE /= VIDEO_IO.END_REC then -- node has a subtree VIDEO_IO.READ_NODE ( DEL_REC, PREV_REC.NEXT_NODE ); DELETE_MULTIPLE_NODES ( DEL_REC, BOOT_REC, SUCCESS ); if SUCCESS then -- subtree has been deleted so -- point this record to the last record deleted DEL_REC.LAST_NODE := BOOT_REC.NEXT_FREE_NODE; -- zero out the last_menu pointer DEL_REC.LAST_MENU := VIDEO_IO.END_REC; -- update the boot record BOOT_REC.NEXT_FREE_NODE := DEL_REC.POSITION; -- rewrite the node VIDEO_IO.WRITE_NODE ( DEL_REC ); end if; -- success end if; -- prev_rec.next_node /= end_rec when others => null; end case; -- prev_rec.node_type SUCCESS := TRUE; exception when VIDEO_IO.DEVICE_ERROR|VIDEO_IO.DATA_ERROR|VIDEO_IO.END_ERROR => raise DELETE_FAILED; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS " & "DELETE_MULTIPLE_NODES" ); raise; end DELETE_MULTIPLE_NODES; procedure DELETE_SINGLE_NODE ( DEL_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ) is -- Delete_single_node first determines the node type. If it is a menu, -- the operation is terminated. Otherwise, the user is prompted to confirm -- the deletion. If confirmed, the next_record is read and connected to -- the prior node, and the delete_record is deleted. If successful, the -- boot record is updated, and the delete and next records are rewritten. -- NEXT_REC : VIDEO_TYPES.NODE_RECORD; CHOICE : VIDEO_TYPES.OPTIONS; DELETE_OK: BOOLEAN := FALSE; begin SUCCESS := FALSE; if DEL_REC.NODE_TYPE = MENU then -- cannot single delete a menu node COMMON_PROCS.MSG_PROC ( "**ERROR** NODE CANNOT BE DELETED AS " & "IT HAS MORE THAN ONE BRANCH", ERROR_LINE ); else -- node is a program or instruction node COMMON_PROCS.MSG_PROC ( "**WARNING** SINGLE NODE DELETION IS " & "QUEUED FOR PROCESSING", ERROR_LINE ); MODEL_PROCS.GET_ANSWER ( PROMPT(DEL), DELETE_OK, CHOICE ); end if; -- del_rec.node_type = menu if CHOICE /= SLASH and then DELETE_OK then -- user has not canceled process so get the next record VIDEO_IO.READ_NODE ( NEXT_REC, DEL_REC.NEXT_NODE ); -- point the next record to the previous record and last menu NEXT_REC.LAST_NODE := DEL_REC.LAST_NODE; NEXT_REC.LAST_MENU := DEL_REC.LAST_MENU; -- point the delete record to the next free space DEL_REC.LAST_NODE := BOOT_REC.NEXT_FREE_NODE; DEL_REC.LAST_MENU := VIDEO_IO.END_REC; -- point the boot record free space pointer to this node BOOT_REC.NEXT_FREE_NODE := DEL_REC.POSITION; -- rewrite the delete_record and the next_record VIDEO_IO.WRITE_NODE ( DEL_REC ); VIDEO_IO.WRITE_NODE ( NEXT_REC ); SUCCESS := TRUE; end if; exception when VIDEO_IO.DEVICE_ERROR|VIDEO_IO.DATA_ERROR|VIDEO_IO.END_ERROR => raise DELETE_FAILED; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS " & "DELETE_SINGLE_NODE" ); raise; end DELETE_SINGLE_NODE; procedure RECOVER_NODES ( PREV_REC : in VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ) is -- Recover nodes is a recursive routine that attempts to recover nodes -- that have been deleted by tracing forward from the last node deleted -- to the first node deleted. -- DEL_REC : VIDEO_TYPES.NODE_RECORD; begin SUCCESS := FALSE; case PREV_REC.NODE_TYPE is when MENU => for I in ONE..FIFTEEN loop if PREV_REC.OPTION(I) /= VIDEO_IO.END_REC then VIDEO_IO.READ_NODE ( DEL_REC, PREV_REC.OPTION(I) ); DEL_REC.LAST_NODE := PREV_REC.POSITION; VIDEO_IO.WRITE_NODE ( DEL_REC ); end if; end loop; when PROGRAM|INSTRUCTION => if PREV_REC.NEXT_NODE /= VIDEO_IO.END_REC then VIDEO_IO.READ_NODE ( DEL_REC, PREV_REC.NEXT_NODE ); DEL_REC.LAST_NODE := PREV_REC.POSITION; VIDEO_IO.WRITE_NODE ( DEL_REC ); end if; when others => null; end case; SUCCESS := TRUE; exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS " & "DELETE_MULTIPLE_NODES" ); raise; end RECOVER_NODES; procedure NODE_DIAG ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS ) is ROOT_REC_POSITION : constant NATURAL := 1; PREV_REC : VIDEO_TYPES.NODE_RECORD; DEL_REC : VIDEO_TYPES.NODE_RECORD; BRANCH : VIDEO_TYPES.OPTIONS; NEXT_NODE : NATURAL := VIDEO_IO.END_REC; DELETE_OK : BOOLEAN := FALSE; RECOVER_OK : BOOLEAN := FALSE; SINGLE_NODE : BOOLEAN := FALSE; DELETE_DONE : BOOLEAN := FALSE; begin MODEL_PROCS.PUT_HEADER ( DELETE_HEADER ); GET_NODES ( CUR_REC, PREV_REC, DEL_REC, CHOICE ); if CHOICE /= SLASH then -- user has not canceled operation MODEL_PROCS.GET_ANSWER ( PROMPT(DEL_NOD), SINGLE_NODE, CHOICE ); if SINGLE_NODE then if DEL_REC.POSITION /= ROOT_REC_POSITION then -- delete only this node DELETE_SINGLE_NODE ( DEL_REC, BOOT_REC, DELETE_DONE ); if DELETE_DONE then -- if deletion worked NEXT_NODE := DEL_REC.NEXT_NODE; end if; -- single delete_done else COMMON_PROCS.MSG_PROC ( "**ERROR** DELETION OF APPLICATION " & "MODEL ROOT NODE IS NOT PERMITTED", ERROR_LINE ); end if; -- del_rec.position /= root_rec_position else -- multiple node deletion if DEL_REC.POSITION /= ROOT_REC_POSITION then COMMON_PROCS.MSG_PROC ( "**WARNING** MULTIPLE NODE DELETION IS " & "QUEUED FOR PROCESSING", ERROR_LINE ); MODEL_PROCS.GET_ANSWER ( PROMPT(DEL), DELETE_OK, CHOICE ); if CHOICE /= SLASH and then DELETE_OK then -- user has not canceled DELETE_MULTIPLE_NODES ( DEL_REC, BOOT_REC, DELETE_DONE ); if DELETE_DONE then -- deletion has completed so far so delete the deletenode DEL_REC.LAST_NODE := BOOT_REC.NEXT_FREE_NODE; DEL_REC.LAST_MENU := VIDEO_IO.END_REC; BOOT_REC.NEXT_FREE_NODE := DEL_REC.POSITION; VIDEO_IO.WRITE_NODE ( DEL_REC ); end if; -- multiple delete_done end if; -- choice /= slash and then delete_ok else COMMON_PROCS.MSG_PROC ( "**ERROR** APPLICATION MODEL ROOT NODE " & "CANNOT BE DELETED", ERROR_LINE ); end if; -- del_rec /= root_rec_position end if; -- single node if DELETE_DONE then -- nodes were deleted if PREV_REC.NODE_TYPE = MENU then -- set the branch to end rec for I in ONE..FIFTEEN loop if PREV_REC.OPTION(I) = DEL_REC.POSITION then PREV_REC.OPTION(I) := NEXT_NODE; exit; end if; -- prev_rec.option(i) = del_rec.position end loop; -- for i in one..fifteen else -- prev_node is program or instruction PREV_REC.NEXT_NODE := NEXT_NODE; end if; -- prev_rec.node_type = menu VIDEO_IO.WRITE_NODE ( PREV_REC ); VIDEO_IO.WRITE_NODE ( BOOT_REC ); CUR_REC := PREV_REC; -- display prev_rec on return else -- deletion not done CHOICE := SLASH; end if; -- delete_done end if; -- choice /= slash exception when DELETE_FAILED => -- attempt to recover COMMON_PROCS.MSG_PROC ( "**WARNING** DELETE FAILED - ATTEMPTING " & "RECOVERY", ERROR_LINE ); RECOVER_NODES ( PREV_REC, RECOVER_OK ); if RECOVER_OK then COMMON_PROCS.MSG_PROC ("RECOVERY SUCCESSFUL - PLEASE TEST FILE", ERROR_LINE ); else COMMON_PROCS.MSG_PROC ("RECOVERY FAILED - EXIT MODEL AND USE " & "BACK-UP OF NODE FILE", ERROR_LINE ); end if; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS NODE_DIAG"); raise; end NODE_DIAG; end DELETE; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --move.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: MOVE * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains all the routines used in VIDEO_MODEL to move nodes. -- Subtrees can only be moved from one branch to another on the same menu. -- with VIDEO_TYPES; package MOVE is procedure NODE_DIAG ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS ); -- -- Node_diag is the only routine visible outside this package. -- It begins by displaying the move header, then, if the current_node -- is a menu, it prompts for the branch to move from, and the branch to -- move to. If the branch to move from has no subtree or the branch to -- move to has a subtree, the user is warned, and prompted for another -- branch. If the move is successful, the current_record is -- rewritten. If the current_node is not a menu, the move operation -- is not allowed. -- end MOVE; with PASS_PROCS, COMMON_MESSAGES, PROMPT_MESSAGES, VIDEO_IO, COMMON_PROCS, MODEL_PROCS; package body MOVE is use VIDEO_TYPES, COMMON_MESSAGES, PROMPT_MESSAGES; EXCEPT : constant STRING(1..24) := "EXCEPTION RAISED IN MOVE"; BLANKS : STRING (1..14) := " "; MOVE_HEADER : constant VIDEO_TYPES.HEADER_TYPE := (1=>BLANKS & "*****************************************************" & BLANKS, 2=>BLANKS & "* *" & BLANKS, 3=>BLANKS & "* ***** MOVE MODE ***** *" & BLANKS, 4=>BLANKS & "* *" & BLANKS, 5=>BLANKS & "*****************************************************" & BLANKS ); type NUMBER_ARRAY is array (ONE..FIFTEEN) of STRING(1..2); NUMBER : constant NUMBER_ARRAY := ( "1 ","2 ","3 ","4 ","5 ","6 ","7 ","8 ", "9 ","10","11","12","13","14","15" ); procedure NODE_DIAG ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS ) is NEW_BRANCH_NUM : VIDEO_TYPES.OPTIONS; NEXT_REC : VIDEO_TYPES.NODE_RECORD; begin MODEL_PROCS.PUT_HEADER ( MOVE_HEADER ); if CUR_REC.NODE_TYPE = MENU then loop -- until choice is valid CHOICE := MODEL_PROCS.GET_BRANCH ( PROMPT(BR_NO_MOV_FRM) ); case CHOICE is when SLASH => exit; when ONE..FIFTEEN => if CUR_REC.OPTION( CHOICE ) /= VIDEO_IO.END_REC then exit; else -- no submodel at this branch COMMON_PROCS.MSG_PROC ( "**ERROR** THERE IS NO SUBMODEL " & "CONNECTED TO BRANCH " & NUMBER(CHOICE), ERROR_LINE ); end if; -- cur_rec.option(choice) /= end_rec when others => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); end case; -- choice end loop; -- until choice is valid while CHOICE /= SLASH loop NEW_BRANCH_NUM := MODEL_PROCS.GET_BRANCH ( PROMPT(BR_NO_MOV_TO) ); case NEW_BRANCH_NUM is when SLASH => CHOICE := NEW_BRANCH_NUM; when ONE..FIFTEEN => if CUR_REC.OPTION(NEW_BRANCH_NUM) = VIDEO_IO.END_REC then VIDEO_IO.READ_NODE ( NEXT_REC, CUR_REC.OPTION(CHOICE) ); NEXT_REC.LAST_NODE := CUR_REC.POSITION; exit; else -- new_branch is not free COMMON_PROCS.MSG_PROC ( "**ERROR** THERE IS ALREADY A SUBMODEL " & "CONNECTED TO BRANCH " & NUMBER(NEW_BRANCH_NUM), ERROR_LINE ); end if; -- cur_rec.option(new_branch_num) = end_rec when others => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); end case; -- new_branch_num end loop; -- choice /= slash if CHOICE /= SLASH then -- user did not cancel VIDEO_IO.WRITE_NODE ( NEXT_REC ); CUR_REC.OPTION( CHOICE ) := VIDEO_IO.END_REC; CUR_REC.OPTION( NEW_BRANCH_NUM ) := NEXT_REC.POSITION; VIDEO_IO.WRITE_NODE ( CUR_REC ); end if; -- choice /= slash else -- cur_rec.node_type = program or menu COMMON_PROCS.MSG_PROC ( "**ERROR** THE MOVE OPERATION WAS NOT " & "INVOKED AT A MENU NODE", ERROR_LINE ); CHOICE := SLASH; end if; -- cur_rec.node_type = menu exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS NODE_DIAG"); raise; end NODE_DIAG; end MOVE; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --modify.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: MODIFY * -- * VERSION: 1.0a1 * -- * DATE : FEBRUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains subroutines used by VIDEO_MODEL to modify nodes. -- with VIDEO_TYPES; package MODIFY is procedure NODE_DIAG ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC: in out VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS ); -- Node_diag is the only routine visible outside of this package. It -- prompts the user to modify the boot record defaults, or the current -- node. If boot record is to be modified, only the default directory or -- device names can be modified. In addition, if there is a password, it -- is displayed, and can be modified or removed. If there is no password, -- a password can be added. -- If the user wishes to modify the current node, the current filename -- will be displayed and can be modified, and the current password will -- be displayed and can be modified. -- The user can choose to display only by accepting the defaults ( the -- current parameters ). If nothing new is entered, the record is not -- updated. -- If any parameters have been changed, the user is asked to confirm -- that these changes are to be accepted. If no, no changes are made. -- end MODIFY; with PASS_PROCS, COMMON_MESSAGES, PROMPT_MESSAGES, SYSTEM_DEPENDENT, VIDEO_IO, COMMON_PROCS, MODEL_PROCS; package body MODIFY is use VIDEO_TYPES, COMMON_MESSAGES, PROMPT_MESSAGES; EXCEPT : constant STRING(1..32) := "EXCEPTION RAISED IN MODEL_PROCS "; type MOD_CHOICE is ( PARMS, CUR_NODE, QUIT ); -- local type BLANKS : STRING (1..14) := " "; MODIFY_HEADER : constant VIDEO_TYPES.HEADER_TYPE := (1=>BLANKS & "*****************************************************" & BLANKS, 2=>BLANKS & "* *" & BLANKS, 3=>BLANKS & "* ***** MODIFY MODE ***** *" & BLANKS, 4=>BLANKS & "* *" & BLANKS, 5=>BLANKS & "*****************************************************" & BLANKS ); procedure MODIFY_COMMON ( CUR_REC : in VIDEO_TYPES.NODE_RECORD; FILENAM : out VIDEO_TYPES.FILE_NAME; PASS : out PASS_PROCS.PASSWORD_TYPE ) is -- Modify_common displays the current filename and prompts for changes. -- It then displays the current password and prompts for changes. These -- are returned to the calling routine. DEF_FILNAM : VIDEO_TYPES.FILE_NAME; DEF_PASS : STRING(1..1) := " "; AFFIRMATIVE: BOOLEAN := FALSE; CHOICE : VIDEO_TYPES.OPTIONS; begin case CUR_REC.NODE_TYPE is -- set up the default filename for display when BOOT => DEF_FILNAM := CUR_REC.DEFAULT; when MENU => DEF_FILNAM := CUR_REC.MENU_PATH; when others => DEF_FILNAM := CUR_REC.PATH; end case; FILENAM := SYSTEM_DEPENDENT.GET_FILENAME ( DEF_FILNAM, PROMPT(NEW_DEVNAM), PROMPT (NEW_DIRNAM), PROMPT (NEW_FILNAM), CUR_REC.NODE_TYPE ); if PASS_PROCS.HAS_PASSWORD ( CUR_REC.NODE_PASSWORD ) then COMMON_PROCS.MSG_PROC ("THE CURRENT PASSWORD IS " & PASS_PROCS.PASS_TO_STRING (CUR_REC.NODE_PASSWORD), ERROR_LINE ); else -- node is not password protected COMMON_PROCS.MSG_PROC ( "NODE IS NOT CURRENTLY PASSWORD PROTECTED", ERROR_LINE ); end if; -- has_password MODEL_PROCS.GET_ANSWER ("ENTER 'YES' TO MODIFY PASSWORD", AFFIRMATIVE, CHOICE ); if AFFIRMATIVE then -- user wants to modify or add password COMMON_PROCS.GET_NEW_PASSWORD ( PROMPT(NEW_PASS), DEF_PASS, PASS ); end if; -- if affirmative COMMON_PROCS.MOVE_CURSOR ( ERROR_LINE ); COMMON_PROCS.CLEAR_LINE; exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS MODIFY_COMMON"); raise; end MODIFY_COMMON; procedure MODIFY_NODE ( REC : in out VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS ) is -- Modify_node first displays the type of node being modified. It then -- calls modify common to display current parameters and get changes. -- If the filename returned has been changed, or the password has been -- changed, the user is asked to confirm the changes. If yes, then the -- filename and/or password parts of the node record are updated. Otherwise, -- the record remains the same. -- DISPLAY_NODE : STRING(1..4); NEW_FILENAME : VIDEO_TYPES.FILE_NAME; DEF_NAME : VIDEO_TYPES.FILE_NAME; NEW_PASSWRD : PASS_PROCS.PASSWORD_TYPE; FILE_CHANGED : BOOLEAN := TRUE; PASS_CHANGED : BOOLEAN := TRUE; begin case REC.NODE_TYPE is -- set up defaults when BOOT => DISPLAY_NODE := "BOOT"; DEF_NAME := REC.DEFAULT; when MENU => DISPLAY_NODE := "MENU"; DEF_NAME := REC.MENU_PATH; when INSTRUCTION => DISPLAY_NODE := "INST"; DEF_NAME := REC.PATH; when PROGRAM => DISPLAY_NODE := "PROG"; DEF_NAME := REC.PATH; end case; COMMON_PROCS.MSG_PROC ("THE TYPE OF NODE BEING MODIFIED OR DISPLAYED IS " & DISPLAY_NODE, ERROR_LINE ); MODIFY_COMMON ( REC, NEW_FILENAME, NEW_PASSWRD ); if NEW_FILENAME = DEF_NAME then -- file was not changed FILE_CHANGED := FALSE; end if; -- otherwise, filename was changed if NEW_PASSWRD = REC.NODE_PASSWORD then -- password was not changed PASS_CHANGED := FALSE; end if; -- otherwise, password was changed if FILE_CHANGED or else PASS_CHANGED then -- filename or password were changed if MODEL_PROCS.CONFIRMED ("SAVE CHANGES TO THIS NODE (Y/N) ?") then -- user confirmed changes if PASS_CHANGED then -- update the password REC.NODE_PASSWORD := NEW_PASSWRD; end if; if FILE_CHANGED then -- update the filename case REC.NODE_TYPE is when BOOT => REC.DEFAULT := NEW_FILENAME; when MENU => REC.MENU_PATH := NEW_FILENAME; when others => REC.PATH := NEW_FILENAME; end case; -- node type end if; -- file was changed else -- user did not confirm changes CHOICE := SLASH; end if; -- confirmed changes else -- no changes were made CHOICE := SLASH; end if; -- changes were made exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS MODIFY_NODE"); raise; end MODIFY_NODE; function MODIFY_WHAT return MOD_CHOICE is -- Modify_what asks if the user wishes to modify the boot record. If so, -- the boot record becomes the current record. Otherwise, the current -- record will be modified. CHOICE : MOD_CHOICE := QUIT; AFFIRMATIVE : BOOLEAN := FALSE; OPT : VIDEO_TYPES.OPTIONS; begin MODEL_PROCS.GET_ANSWER ( PROMPT(MOD_APL_PRMS), AFFIRMATIVE, OPT ); if AFFIRMATIVE then -- boot rec will be displayed or modified CHOICE := PARMS; SYSTEM_DEPENDENT.SET_MODIFY_FLAG ( ON ); else -- current record will be modified CHOICE := CUR_NODE; end if; -- affirmative, otherwise quit return CHOICE; exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS MODIFY_WHAT"); end MODIFY_WHAT; procedure NODE_DIAG ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC: in out VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS ) is CHANGE : MOD_CHOICE; begin MODEL_PROCS.PUT_HEADER ( MODIFY_HEADER ); CHANGE := MODIFY_WHAT; case CHANGE is -- evaluated user response when PARMS => MODIFY_NODE ( BOOT_REC, CHOICE ); if CHOICE /= SLASH then -- user made changes VIDEO_IO.WRITE_NODE ( BOOT_REC ); end if; when CUR_NODE => MODIFY_NODE ( CUR_REC, CHOICE ); if CHOICE /= SLASH then -- user made changes VIDEO_IO.WRITE_NODE ( CUR_REC ); end if; when QUIT => CHOICE := SLASH; end case; exception when USER_QUIT => CHOICE := SLASH; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS NODE_DIAG"); raise; end NODE_DIAG; end MODIFY; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --insert.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: INSERT * -- * VERSION: 1.0a1 * -- * DATE : JANUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains all the routines used by VIDEO_MODEL to insert nodes. -- with VIDEO_TYPES; package INSERT is procedure NODE_DIAG ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC: in out VIDEO_TYPES.NODE_RECORD; CHOICE : in out VIDEO_TYPES.OPTIONS ); -- -- Node_diag is the only procedure in insert visible outside the package. -- It first displays the insert header, then prompts for the node type to -- be inserted. It then calls the insert routine corresponding to the -- node type. -- end INSERT; with PASS_PROCS, COMMON_MESSAGES, PROMPT_MESSAGES, VIDEO_IO, COMMON_PROCS, MODEL_PROCS; package body INSERT is use VIDEO_TYPES, COMMON_MESSAGES, PROMPT_MESSAGES; EXCEPT : constant STRING(1..27) := "EXCEPTION RAISED IN INSERT "; NO_DEFAULT: STRING(1..1) := " "; BLANKS : STRING (1..14) := " "; INSERT_HEADER : constant VIDEO_TYPES.HEADER_TYPE := (1=>BLANKS & "*****************************************************" & BLANKS, 2=>BLANKS & "* *" & BLANKS, 3=>BLANKS & "* ***** INSERT MODE ***** *" & BLANKS, 4=>BLANKS & "* *" & BLANKS, 5=>BLANKS & "*****************************************************" & BLANKS ); procedure INSERT_COMMON ( BOOT_REC : in VIDEO_TYPES.NODE_RECORD; NODE_TYP : in VIDEO_TYPES.NODE; FILENAM : out VIDEO_TYPES.FILE_NAME; PASS : out PASS_PROCS.PASSWORD_TYPE ) is -- -- Insert_common prompts the user for the filename and password for the -- node to be inserted. -- begin MODEL_PROCS.GET_COMMON ( BOOT_REC.DEFAULT, PROMPT (DEVNAM), PROMPT (DIRNAM), PROMPT (ADD_FILNAM), PROMPT(PASSWRD), NODE_TYP, FILENAM, PASS ); exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS INSERT_COMMON"); raise; end INSERT_COMMON; function INSERT_BRANCH ( MSG : in STRING; CUR_REC : in VIDEO_TYPES.NODE_RECORD ) return VIDEO_TYPES.OPTIONS is -- -- Insert_branch is called when the current_record is a menu. It -- prompts the user for a valid input branch. If the branch number -- entered is free, it tells the user to either choose another branch -- or use the add mode. -- CHOICE : VIDEO_TYPES.OPTIONS; TRIES : NATURAL range 0..2 := 0; begin loop -- main loop TRIES := TRIES + 1; CHOICE := MODEL_PROCS.GET_BRANCH ( MSG ); case CHOICE is when SLASH => exit; when ONE..FIFTEEN => if CUR_REC.OPTION(CHOICE) = VIDEO_IO.END_REC then COMMON_PROCS.MSG_PROC ( ERRORS(INV_BR_NO), ERROR_LINE ); if TRIES = 2 then COMMON_PROCS.MSG_PROC ( "**ERROR** BRANCH IS NOT CONNECTED" & " TO A NODE", ERROR_LINE ); if MODEL_PROCS.CONFIRMED ( "DO YOU WANT TO TRY ANOTHER " & "BRANCH (Y/N)?") then TRIES := 0; else -- not confirmed COMMON_PROCS.MSG_PROC ( "TO ADD AT THIS NODE USE ADD MODE", ERROR_LINE ); loop -- until slash is entered COMMON_PROCS.PROMPT_MSG ("ENTER SLASH TO RETURN TO " & "MAINTENANCE MENU" ); CHOICE := COMMON_PROCS.GET_INPUT; exit when CHOICE = SLASH; end loop; -- until slash is entered end if; -- confirmed try again end if; -- tries = 2 else -- cur_rec.option(choice) /= end_rec exit; end if; -- cur_rec.option(choice) = end_rec when others => null; end case; -- choice end loop; -- main return CHOICE; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & " SUBROUTINE IS INSERT_BRANCH"); raise; end INSERT_BRANCH; function GET_OUT_BRANCH ( MSG : in STRING ) return VIDEO_TYPES.OPTIONS is CHOICE : VIDEO_TYPES.OPTIONS; -- -- Get_out_branch is called if the node to be inserted is a menu. It -- prompts the user for the branch to attach the existing subtree. -- begin loop -- until valid branch CHOICE := MODEL_PROCS.GET_BRANCH ( MSG ); case CHOICE is when SLASH|ONE..FIFTEEN => exit; when others => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); end case; -- choice end loop; -- until valid branch return CHOICE; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS GET_OUT_BRANCH"); raise; end GET_OUT_BRANCH; procedure INSERT_NODE (NEW_REC : in out VIDEO_TYPES.NODE_RECORD; SUCCESS : out BOOLEAN ) is -- -- Insert_node prompts the user to confirm the insert. If confirmed, and -- node is inserted, success := true. Otherwise, success = false. -- begin SUCCESS := FALSE; if MODEL_PROCS.CONFIRMED ( "INSERT THIS NODE (Y/N) ?" ) then VIDEO_IO.WRITE_NODE ( NEW_REC ); SUCCESS := TRUE; end if; -- confirmed insert exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS INSERT_NODE"); raise; end INSERT_NODE; procedure INSERT_MENU ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; IN_BRANCH : in out VIDEO_TYPES.OPTIONS ) is -- -- Insert_menu first prompts for the in_branch if the current_node is -- a menu. Otherwise, it checks to see if current_node.next_node is -- attached to a subtree. If the user does not cancel insert, then the -- user is prompted for the out_branch to attach the subtree. If there -- is no free space to recover, the position of the new record is set -- to end of file, otherwise, it is set to the first free space. The -- user is then prompted for the filename and password for the node, and -- the record is created. If the user confirms the insert, and the -- write is successful, the next_node is updated and written. If that -- write succeeds, the boot and current records are updated. -- NEW_REC : VIDEO_TYPES.NODE_RECORD; NEXT_REC : VIDEO_TYPES.NODE_RECORD; FILENAM : VIDEO_TYPES.FILE_NAME; BRANCHES : VIDEO_TYPES.MENU_OPTIONS := (ONE..FIFTEEN => VIDEO_IO.END_REC); OUT_BRANCH : VIDEO_TYPES.OPTIONS; PASS : PASS_PROCS.PASSWORD_TYPE; NEW_POSITION : NATURAL; NEXT_FREE_NODE : NATURAL; LAST_MENU : NATURAL; NEXT_NODE : NATURAL; INSERT_OK : BOOLEAN; begin if CUR_REC.NODE_TYPE = MENU then IN_BRANCH := INSERT_BRANCH ( PROMPT(ADD_BR_NO), CUR_REC ); if IN_BRANCH /= SLASH then NEXT_NODE := CUR_REC.OPTION(IN_BRANCH); LAST_MENU := CUR_REC.POSITION; end if; else -- node_type = program or instruction if CUR_REC.NEXT_NODE = VIDEO_IO.END_REC then COMMON_PROCS.MSG_PROC ( "**ERROR** THERE IS NO NODE ATTACHED TO " & "THIS NODE - USE ADD MODE", ERROR_LINE ); IN_BRANCH := SLASH; else -- current_record has a subtree NEXT_NODE := CUR_REC.NEXT_NODE; end if; -- next_node = end_rec LAST_MENU := CUR_REC.LAST_MENU; end if; -- node_type = menu if IN_BRANCH /= SLASH then -- user did not cancel OUT_BRANCH := GET_OUT_BRANCH ( PROMPT(CNCT_BR) ); if OUT_BRANCH /= SLASH then -- user did not cancel BRANCHES(OUT_BRANCH) := NEXT_NODE; if BOOT_REC.NEXT_FREE_NODE = 0 then -- no free space to recover NEW_POSITION := BOOT_REC.LAST_FREE_NODE; else -- free space to recover VIDEO_IO.READ_NODE ( NEW_REC, BOOT_REC.NEXT_FREE_NODE ); NEXT_FREE_NODE := NEW_REC.LAST_NODE; NEW_POSITION := BOOT_REC.NEXT_FREE_NODE; end if; -- next_free_node = 0 INSERT_COMMON ( BOOT_REC, MENU, FILENAM, PASS ); NEW_REC := ( MENU, CUR_REC.POSITION, LAST_MENU, NEW_POSITION, PASS, FILENAM, BRANCHES ); INSERT_NODE ( NEW_REC, INSERT_OK ); if INSERT_OK then VIDEO_IO.READ_NODE ( NEXT_REC, NEW_REC.OPTION(OUT_BRANCH) ); NEXT_REC.LAST_NODE := NEW_REC.POSITION; NEXT_REC.LAST_MENU := NEW_REC.POSITION; if BOOT_REC.NEXT_FREE_NODE = 0 then -- no free space to recover BOOT_REC.LAST_FREE_NODE := BOOT_REC.LAST_FREE_NODE + 1; else -- free space to recover BOOT_REC.NEXT_FREE_NODE := NEXT_FREE_NODE; end if; -- next_free_node = 0 if CUR_REC.NODE_TYPE = MENU then CUR_REC.OPTION ( IN_BRANCH ) := NEW_REC.POSITION; else -- node_type = program or instruction CUR_REC.NEXT_NODE := NEW_REC.POSITION; end if; -- node_type = menu VIDEO_IO.WRITE_NODE ( BOOT_REC ); VIDEO_IO.WRITE_NODE ( CUR_REC ); VIDEO_IO.WRITE_NODE ( NEXT_REC ); else -- insert failed or was canceled IN_BRANCH := OUT_BRANCH; end if; -- insert_ok end if; -- out_branch /= slash end if; -- in_branch /= slash exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS INSERT_MENU"); raise; end INSERT_MENU; procedure INSERT_INST ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; IN_BRANCH : in out VIDEO_TYPES.OPTIONS ) is -- -- Insert_inst performs in the same manner as insert_menu except it does -- not prompt for an out_branch, and the record format is somewhat different. -- NEW_REC : VIDEO_TYPES.NODE_RECORD; NEXT_REC : VIDEO_TYPES.NODE_RECORD; FILENAM : VIDEO_TYPES.FILE_NAME; PASS : PASS_PROCS.PASSWORD_TYPE; NEW_POSITION : NATURAL; NEXT_FREE_NODE : NATURAL; NEXT_NODE : NATURAL; LAST_MENU : NATURAL; INSERT_OK : BOOLEAN; begin if CUR_REC.NODE_TYPE = MENU then IN_BRANCH := INSERT_BRANCH ( PROMPT(ADD_BR_NO), CUR_REC ); if IN_BRANCH /= SLASH then NEXT_NODE := CUR_REC.OPTION(IN_BRANCH); LAST_MENU := CUR_REC.POSITION; end if; else -- node_type = program or instruction if CUR_REC.NEXT_NODE = VIDEO_IO.END_REC then -- next_node is free COMMON_PROCS.MSG_PROC ( "**ERROR** THERE IS NO NODE ATTACHED TO " & "THIS NODE - USE ADD MODE", ERROR_LINE ); IN_BRANCH := SLASH; else -- next_node has a subtree NEXT_NODE := CUR_REC.NEXT_NODE; end if; -- next_node = end_rec LAST_MENU := CUR_REC.LAST_MENU; end if; -- node_type = menu if IN_BRANCH /= SLASH then -- user did not cancel INSERT_COMMON ( BOOT_REC, INSTRUCTION, FILENAM, PASS ); if BOOT_REC.NEXT_FREE_NODE = 0 then -- no free space to recover NEW_POSITION := BOOT_REC.LAST_FREE_NODE; else -- free space to recover VIDEO_IO.READ_NODE ( NEW_REC, BOOT_REC.NEXT_FREE_NODE ); NEXT_FREE_NODE := NEW_REC.LAST_NODE; NEW_POSITION := BOOT_REC.NEXT_FREE_NODE; end if; -- next_free_node = 0 NEW_REC := ( INSTRUCTION, CUR_REC.POSITION, LAST_MENU, NEW_POSITION, PASS, FILENAM, NEXT_NODE ); INSERT_NODE ( NEW_REC, INSERT_OK ); if INSERT_OK then -- update the next node VIDEO_IO.READ_NODE ( NEXT_REC, NEW_REC.NEXT_NODE ); NEXT_REC.LAST_NODE := NEW_REC.POSITION; NEXT_REC.LAST_MENU := LAST_MENU; if BOOT_REC.NEXT_FREE_NODE = 0 then -- no free space to recover BOOT_REC.LAST_FREE_NODE := BOOT_REC.LAST_FREE_NODE + 1; else -- free space to recover BOOT_REC.NEXT_FREE_NODE := NEXT_FREE_NODE; end if; -- next_free_node = 0 if CUR_REC.NODE_TYPE = MENU then CUR_REC.OPTION ( IN_BRANCH ) := NEW_REC.POSITION; else -- node_type = program or instruction CUR_REC.NEXT_NODE := NEW_REC.POSITION; end if; -- node_type = menu VIDEO_IO.WRITE_NODE ( BOOT_REC ); VIDEO_IO.WRITE_NODE ( CUR_REC ); VIDEO_IO.WRITE_NODE ( NEXT_REC ); end if; -- insert ok end if; -- in_branch /= slash exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS INSERT_INST"); raise; end INSERT_INST; procedure INSERT_PROG ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; IN_BRANCH : in out VIDEO_TYPES.OPTIONS ) is -- -- Insert_prog performs in the same manner as insert_menu except it does -- not prompt for an out_branch, and the record format is somewhat different. -- NEW_REC : VIDEO_TYPES.NODE_RECORD; NEXT_REC : VIDEO_TYPES.NODE_RECORD; FILENAM : VIDEO_TYPES.FILE_NAME; PASS : PASS_PROCS.PASSWORD_TYPE; NEW_POSITION : NATURAL; NEXT_FREE_NODE : NATURAL; NEXT_NODE : NATURAL; LAST_MENU : NATURAL; INSERT_OK : BOOLEAN; begin if CUR_REC.NODE_TYPE = MENU then IN_BRANCH := INSERT_BRANCH ( PROMPT(ADD_BR_NO), CUR_REC ); if IN_BRANCH /= SLASH then NEXT_NODE := CUR_REC.OPTION(IN_BRANCH); LAST_MENU := CUR_REC.POSITION; end if; else -- node_type = program or instruction if CUR_REC.NEXT_NODE = VIDEO_IO.END_REC then COMMON_PROCS.MSG_PROC ( "**ERROR** THERE IS NO NODE ATTACHED TO " & "THIS NODE - USE ADD MODE", ERROR_LINE ); IN_BRANCH := SLASH; else -- next_node has a subtree NEXT_NODE := CUR_REC.NEXT_NODE; end if; -- next_node = end_rec LAST_MENU := CUR_REC.LAST_MENU; end if; -- node_type = menu if IN_BRANCH /= SLASH then -- user did not cancel INSERT_COMMON ( BOOT_REC, PROGRAM, FILENAM, PASS ); if BOOT_REC.NEXT_FREE_NODE = 0 then -- no free space to recover NEW_POSITION := BOOT_REC.LAST_FREE_NODE; else -- free space to recover VIDEO_IO.READ_NODE ( NEW_REC, BOOT_REC.NEXT_FREE_NODE ); NEXT_FREE_NODE := NEW_REC.LAST_NODE; NEW_POSITION := BOOT_REC.NEXT_FREE_NODE; end if; -- next_free_node = 0 NEW_REC := ( PROGRAM, CUR_REC.POSITION, LAST_MENU, NEW_POSITION, PASS, FILENAM, NEXT_NODE ); INSERT_NODE ( NEW_REC, INSERT_OK ); if INSERT_OK then -- update next record VIDEO_IO.READ_NODE ( NEXT_REC, NEW_REC.NEXT_NODE ); NEXT_REC.LAST_NODE := NEW_REC.POSITION; NEXT_REC.LAST_MENU := NEW_REC.LAST_MENU; if BOOT_REC.NEXT_FREE_NODE = 0 then -- no free space to recover BOOT_REC.LAST_FREE_NODE := BOOT_REC.LAST_FREE_NODE + 1; else -- free space to recover BOOT_REC.NEXT_FREE_NODE := NEXT_FREE_NODE; end if; -- next_free_node = 0 if CUR_REC.NODE_TYPE = MENU then CUR_REC.OPTION ( IN_BRANCH ) := NEW_REC.POSITION; else -- node_type = program or instruction CUR_REC.NEXT_NODE := NEW_REC.POSITION; end if; -- node_type = menu VIDEO_IO.WRITE_NODE ( BOOT_REC ); VIDEO_IO.WRITE_NODE ( CUR_REC ); VIDEO_IO.WRITE_NODE ( NEXT_REC ); end if; -- insert ok end if; -- in_branch /= slash exception when USER_QUIT => raise; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS INSERT_PROG"); raise; end INSERT_PROG; procedure NODE_DIAG ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC: in out VIDEO_TYPES.NODE_RECORD; CHOICE : in out VIDEO_TYPES.OPTIONS ) is NEW_NODE_TYPE : VIDEO_TYPES.USER_NODE; begin MODEL_PROCS.PUT_HEADER ( INSERT_HEADER ); NEW_NODE_TYPE := COMMON_PROCS.GET_NODE_TYPE ( PROMPT(ADD_TYP) ); case NEW_NODE_TYPE is when MENU => INSERT_MENU ( CUR_REC, BOOT_REC, CHOICE ); when INSTRUCTION => INSERT_INST ( CUR_REC, BOOT_REC, CHOICE ); when PROGRAM => INSERT_PROG ( CUR_REC, BOOT_REC, CHOICE ); end case; exception when USER_QUIT => CHOICE := SLASH; when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS INSERT_NODE_DIAG"); raise; end NODE_DIAG; end INSERT; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --model.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: MODEL * -- * VERSION: 1.0a1 * -- * DATE : FEBRUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package exports several routines to VIDEO_MODEL. It also serves -- as a repository for some global variables. -- with VIDEO_TYPES; package MODEL is -- -- MODEL global variables -- PASSWORD_FLAG : VIDEO_TYPES.FLAG := VIDEO_TYPES.ON; ERROR_MSG : VIDEO_TYPES.FLAG := VIDEO_TYPES.ON; READ_REC_NUM : NATURAL; CUR_REC_NUM : NATURAL; procedure PROG_PROC ( PROG_MSG : in STRING; REC : in VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS; NEXT_REC : out NATURAL ); -- -- Prog_proc is the routine used by VIDEO_MODEL when it encounters a -- program node. It displays the name of the program that will be run -- during an application session, and prompts the user to either -- return to the previous menu or proceed to the next node. It also -- accepts any special character. -- procedure PROCESS_OPTION ( LAST_MENU_PTR : in NATURAL; CUR_REC : in out VIDEO_TYPES.NODE_RECORD; ROOT_NUM : in NATURAL; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; CHOICE : in out VIDEO_TYPES.OPTIONS ); -- -- Process_option recieves the special character entered at any node and -- responds to it. The only difference between the modelling version and -- the run-time version is that in this version, Z is an acceptable -- choice, and causes maintenance mode to be entered. -- Allowable special characters and their response are: -- Z - Enter Maintenance -- R - Return to the Root Node -- I - Causes Instruction pages to be displayed -- X - Disables Instruction page display -- T - Terminates a model session -- / - Return to the previous menu -- <CR> - In general, proceed to the next node end MODEL; with COMMON_PROCS, COMMON_MESSAGES, PROMPT_MESSAGES, VIDEO_IO, SYSTEM_DEPENDENT, ADD, MODIFY, DELETE, INSERT, MOVE, VIDEO_PROCS; package body MODEL is use VIDEO_TYPES, COMMON_MESSAGES, PROMPT_MESSAGES; EXCEPT : constant STRING(1..32) := "EXCEPTION RAISED IN MODEL_PROCS "; procedure MAINT_INIT is -- -- Maint_init displays the maintenance menu in Common_messages. -- begin COMMON_PROCS.SCREEN_DISPLAY ( MAINT ); exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS MAINT_INIT"); raise; end MAINT_INIT; procedure PROG_PROC ( PROG_MSG : in STRING; REC : in VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS; NEXT_REC : out NATURAL ) is NO_MATCH : constant NATURAL := 0; FILSPEC : VIDEO_TYPES.FILESPEC; begin COMMON_PROCS.HOME_CLEAR; FILSPEC := SYSTEM_DEPENDENT.BUILD_FILESPEC ( REC.PATH ); COMMON_PROCS.MSG_PROC ("PROGRAM " & FILSPEC.NAME(1..FILSPEC.LENGTH) & " WILL BE RUN AT THIS NODE", ERROR_LINE ); COMMON_PROCS.PROMPT_MSG ( PROG_MSG ); loop -- until valid response CHOICE := COMMON_PROCS.GET_INPUT; if CHOICE in CR..Z then exit; else -- invalid choice COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); end if; -- choice in cr..z end loop; -- until valid response if CHOICE = CR then if REC.NEXT_NODE /= VIDEO_IO.END_REC then NEXT_REC := REC.NEXT_NODE; else -- node is a leaf node COMMON_PROCS.MSG_PROC ( "**ERROR** NO NODES BEYOND THIS NODE", ERROR_LINE ); PASSWORD_FLAG := VIDEO_TYPES.OFF; end if; -- next_node /= end_rec end if; -- choice = cr exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS PROG_PROC"); raise; end PROG_PROC; procedure MAINT_PROC ( CUR_REC : in out VIDEO_TYPES.NODE_RECORD; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; CHOICE : out VIDEO_TYPES.OPTIONS; NEXT_REC : out NATURAL ) is -- -- Maint_proc is invoked when the user enters a Z at any node. It begins -- by closing the text file if open, then displays the maintenance menu. -- The user is prompted for a maintenance mode ( add, delete, insert, move, -- modify ). Valid responses are 1..5, slash, and <CR>. If 1..5, the -- corresponding mode is entered. Otherwise, maintenance is terminated. -- If maintenance has been successful, the user is prompted to exit -- maintenance with a <CR>. -- VALID : BOOLEAN; EXIT_MAINTENANCE : BOOLEAN := FALSE; MSG : STRING(1..52); begin if VIDEO_IO.TEXT_FILE_OPEN then -- close the test file if necessary VIDEO_IO.CLOSE_TEXT_FILE; end if; MAIN: loop -- main MAINT_INIT; VALID := FALSE; COMMON_PROCS.PROMPT_MSG ( PROMPT(OPTION_NO) ); while not VALID loop CHOICE := COMMON_PROCS.GET_INPUT; case CHOICE is when CR|SLASH|ONE..FIVE => VALID := TRUE; when others => COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE ); end case; -- choice end loop; -- while not valid case CHOICE is when ONE => ADD.NODE_DIAG ( CUR_REC, BOOT_REC, CHOICE ); if CHOICE /= SLASH then MSG := "ADDITION HAS BEEN COMPLETED SUCCESSFULLY "; end if; when TWO => MODIFY.NODE_DIAG (CUR_REC, BOOT_REC, CHOICE ); SYSTEM_DEPENDENT.SET_MODIFY_FLAG ( OFF ); if CHOICE /= SLASH then MSG := "MODIFICATION/DISPLAY HAS BEEN COMPLETED SUCCESSFULLY"; end if; when THREE => DELETE.NODE_DIAG (CUR_REC, BOOT_REC, CHOICE ); if CHOICE /= SLASH then MSG := "DELETION HAS BEEN COMPLETED SUCCESSFULLY "; end if; when FOUR => INSERT.NODE_DIAG (CUR_REC, BOOT_REC, CHOICE ); if CHOICE /= SLASH then MSG := "INSERTION HAS BEEN COMPLETED SUCCESSFULLY "; end if; when FIVE => MOVE.NODE_DIAG (CUR_REC, CHOICE ); if CHOICE /= SLASH then MSG := "MOVE HAS BEEN COMPLETED SUCCESSFULLY "; end if; when others => exit; end case; if CHOICE /= SLASH then COMMON_PROCS.MSG_PROC ( MSG, ERROR_LINE ); end if; while not EXIT_MAINTENANCE loop begin COMMON_PROCS.PROMPT_MSG ( PROMPT(EXIT_MAINT) ); if COMMON_PROCS.GET_INPUT = CR then -- maintenance session done NEXT_REC := CUR_REC.POSITION; EXIT_MAINTENANCE := TRUE; else COMMON_PROCS.MSG_PROC ( ERRORS(INVALID_RESP), ERROR_LINE); end if; -- get_input = cr exception when COMMON_PROCS.INVALID_CHOICE => COMMON_PROCS.MSG_PROC ("ONLY <CR> WILL BE ACCEPTED HERE", ERROR_LINE ); end; -- local block end loop; -- for get input exit MAIN when EXIT_MAINTENANCE; end loop; -- main exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS MAINT_PROC"); raise; end MAINT_PROC; procedure PROCESS_OPTION ( LAST_MENU_PTR : in NATURAL; CUR_REC : in out VIDEO_TYPES.NODE_RECORD; ROOT_NUM : in NATURAL; BOOT_REC : in out VIDEO_TYPES.NODE_RECORD; CHOICE : in out VIDEO_TYPES.OPTIONS ) is begin case CHOICE is when SLASH => -- go back to the previous menu PASSWORD_FLAG := VIDEO_TYPES.OFF; -- disable password if LAST_MENU_PTR /= BOOT_REC.POSITION then READ_REC_NUM := LAST_MENU_PTR; else -- can't go back further than root node COMMON_PROCS.MSG_PROC ( "** ERROR ** CURRENT NODE IS FIRST NODE", ERROR_LINE ); COMMON_PROCS.PROMPT_MSG ("ENTER 'T' TO TERMINATE OR <CR> TO PROCEED"); end if; -- last_menu_ptr /= boot_rec.position when Z => -- enter maintenance mode READ_REC_NUM := CUR_REC_NUM; MAINT_PROC ( CUR_REC, BOOT_REC, CHOICE, READ_REC_NUM ); PASSWORD_FLAG := VIDEO_TYPES.OFF; when R => -- go back to root node READ_REC_NUM := ROOT_NUM; PASSWORD_FLAG := VIDEO_TYPES.OFF; when I => -- enable instruction display VIDEO_PROCS.INST_FLAG := VIDEO_PROCS.INST_ENABLED; ERROR_MSG := VIDEO_PROCS.INST_ENABLED; READ_REC_NUM := CUR_REC_NUM; PASSWORD_FLAG := VIDEO_TYPES.OFF; COMMON_PROCS.MSG_PROC ( "INSTRUCTION PAGE DISPLAYING HAS BEEN ENABLED", ERROR_LINE ); when X => -- disable instruction display VIDEO_PROCS.INST_FLAG := VIDEO_PROCS.INST_DISABLED; ERROR_MSG := VIDEO_PROCS.INST_DISABLED; READ_REC_NUM := CUR_REC_NUM; PASSWORD_FLAG := VIDEO_TYPES.OFF; COMMON_PROCS.MSG_PROC ("INSTRUCTION PAGE DISPLAYING HAS BEEN DISABLED", ERROR_LINE ); when T => -- terminate the session COMMON_PROCS.HOME_CLEAR; READ_REC_NUM := BOOT_REC.POSITION; when others => -- ignore anything else null; end case; -- choice exception when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT & " SUBROUTINE IS PROCESS_OPTION"); raise; end PROCESS_OPTION; end MODEL; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --vidmodl.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: VIDEO_MODEL * -- * VERSION: 1.0a1 * -- * DATE : FEBRUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This is the main procedure for VIDEO_MODEL. -- It begins by displaying the copyright message and the model header. -- The user is prompted for the application file name and the password -- for modelling. If this succeeds, the user is then prompted for the -- password to run the application. The program then loops until the -- user terminates the session. The next node is read, and if password -- protected, the user is prompted for the password. If the password is -- correct, the node type is determined and the proper routine for that -- node type is run. The user may then enter a special character or -- choice to proceed further, to back-track, to terminate, to initiate -- maintenance, or to disable/enable instruction pages. The model session -- proceeds as does a run-time VIDEO session, except that at any node, -- maintenance may be performed. -- The maintenance functions are add a node, delete a node, insert a -- node, move a subtree on a menu, and modify a node. -- If the session is terminated for any reason, the node file is closed -- and saved. -- with VIDEO_TYPES, PROMPT_MESSAGES, COMMON_MESSAGES, COMMON_PROCS, VIDEO_IO, SYSTEM_DEPENDENT, VIDEO_DEBUG, VIDEO_PROCS, MODEL; procedure VIDEO_MODEL is use VIDEO_TYPES, PROMPT_MESSAGES, COMMON_MESSAGES, VIDEO_IO, SYSTEM_DEPENDENT; EXCEPT : constant STRING(1..31) := "EXCEPTION RAISED IN VIDEO_MODEL"; ROOT_REC_NUM : constant NATURAL := 1; subtype SPECIAL_CHARS is VIDEO_TYPES.OPTIONS range SLASH..Z; BOOT_REC : VIDEO_TYPES.NODE_RECORD; NODE_REC : VIDEO_TYPES.NODE_RECORD; NODE_FILENAM : VIDEO_TYPES.FILESPEC; OPTION : VIDEO_TYPES.CHOICES; INIT_OK : BOOLEAN := FALSE; PASS_PROMPT : STRING(1..72) := PROMPT(PASS_RUN_APL); USER_PROMPT : STRING(1..72) := PROMPT(SLASH_RTN); INVALID_NODE : exception; INVALID_OPTION : exception; BLANKS : STRING (1..14) := " "; HEADER : constant VIDEO_TYPES.HEADER_TYPE := (1=>BLANKS & "*****************************************************" & BLANKS, 2=>BLANKS & "* *" & BLANKS, 3=>BLANKS & "* ***** VIDEO MODEL ***** * " & BLANKS, 4=>BLANKS & "* *" & BLANKS, 5=>BLANKS & "*****************************************************" & BLANKS ); begin VIDEO_PROCS.MENU_INIT ( PROMPT(PASS_APL_MDL), HEADER, NODE_FILENAM, BOOT_REC, INIT_OK ); if INIT_OK then -- begin by reading and displaying the root node MODEL.READ_REC_NUM := ROOT_REC_NUM; MODEL.CUR_REC_NUM := BOOT_REC.POSITION; MODEL.PASSWORD_FLAG := ON; while MODEL.READ_REC_NUM > BOOT_REC.POSITION loop -- main loop begin -- local block and exception handlers USER_PROMPT := PROMPT(SLASH_RTN); VIDEO_IO.READ_NODE ( NODE_REC, MODEL.READ_REC_NUM ); if MODEL.PASSWORD_FLAG = ON and then VIDEO_PROCS.HAS_PASSWORD ( NODE_REC ) then -- proceeding forward and node is password protected if not VIDEO_PROCS.PASSWORD_OK (NODE_REC, PASS_PROMPT ) then -- user will not be able to proceed further raise BAD_PASSWORD; end if; -- not password_ok end if; -- password_flag on and then node has password MODEL.CUR_REC_NUM := MODEL.READ_REC_NUM; MODEL.PASSWORD_FLAG := ON; -- password flag must always be on case NODE_REC.NODE_TYPE is when MENU => for I in VIDEO_TYPES.CHOICES loop if NODE_REC.OPTION (I) /= VIDEO_IO.END_REC then USER_PROMPT := PROMPT(OPTION_NO); exit; end if; end loop; VIDEO_PROCS.MENU_PROC (USER_PROMPT, NODE_REC, OPTION, MODEL.READ_REC_NUM ); when INSTRUCTION => if NODE_REC.NEXT_NODE /= VIDEO_IO.END_REC then USER_PROMPT := PROMPT(CR_GO_SL_RTN); end if; VIDEO_PROCS.INST_PROC (USER_PROMPT, NODE_REC, OPTION, MODEL.READ_REC_NUM ); when PROGRAM => if NODE_REC.NEXT_NODE /= VIDEO_IO.END_REC then USER_PROMPT := PROMPT(CR_GO_SL_RTN); end if; MODEL.PROG_PROC ( USER_PROMPT, NODE_REC, OPTION, MODEL.READ_REC_NUM ); when others => raise INVALID_NODE; end case; -- node_rec.node_type if OPTION in SPECIAL_CHARS then -- handle special characters MODEL.PROCESS_OPTION ( NODE_REC.LAST_MENU, NODE_REC, ROOT_REC_NUM, BOOT_REC, OPTION ); end if; -- option in special_chars exception -- local exception handler when BAD_PASSWORD => if MODEL.CUR_REC_NUM = BOOT_REC.POSITION then -- bad root password raise; else -- bad node password, no further access MODEL.READ_REC_NUM := MODEL.CUR_REC_NUM; MODEL.PASSWORD_FLAG := OFF; end if; -- cur_rec_num = boot_rec.position when INVALID_OPTION => -- ignore invalid options null; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT ); raise; end; -- local block PASS_PROMPT := PROMPT(PASS_APL_MORE); end loop; -- main loop end if; -- init_ok VIDEO_IO.CLOSE_NODE_FILE (SAVE_FILE); COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.MSG_PROC ( MESSAGES(SUCCESS), ERROR_LINE ); exception when USER_QUIT => COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.PUT_STRING ("VIDEO MODEL SESSION STOPPED"); if VIDEO_IO.NODE_FILE_OPEN then VIDEO_IO.CLOSE_NODE_FILE (SAVE_FILE); end if; COMMON_PROCS.NEXT_LINE; when BAD_PASSWORD => -- bad boot or root password COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.PUT_STRING ( " PROCESS TERMINATED " & ": ACCESS DENIED" ); VIDEO_IO.CLOSE_NODE_FILE ( SAVE_FILE ); COMMON_PROCS.NEXT_LINE; when others => if VIDEO_IO.NODE_FILE_OPEN then VIDEO_IO.CLOSE_NODE_FILE ( SAVE_FILE ); end if; VIDEO_DEBUG.PRINT_EXCEPTIONS; end VIDEO_MODEL; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --video.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: VIDEO * -- * VERSION: 1.0a1 * -- * DATE : FEBRUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- with VIDEO_TYPES, PROMPT_MESSAGES, COMMON_MESSAGES, COMMON_PROCS, VIDEO_IO, SYSTEM_DEPENDENT, VIDEO_DEBUG, VIDEO_PROCS, VIDEO_MAIN; procedure VIDEO is use VIDEO_TYPES, PROMPT_MESSAGES, COMMON_MESSAGES, VIDEO_IO, SYSTEM_DEPENDENT; EXCEPT : constant STRING(1..25) := "EXCEPTION RAISED IN VIDEO"; ROOT_REC_NUM : constant NATURAL := 1; subtype SPECIAL_CHARS is VIDEO_TYPES.OPTIONS range SLASH..Z; BOOT_REC : VIDEO_TYPES.NODE_RECORD; NODE_REC : VIDEO_TYPES.NODE_RECORD; NODE_FILENAM : VIDEO_TYPES.FILESPEC; OPTION : VIDEO_TYPES.CHOICES; INIT_OK : BOOLEAN := FALSE; PASS_PROMPT : STRING(1..72) := PROMPT(PASS_RUN_APL); USER_PROMPT : STRING(1..72); INVALID_NODE : exception; INVALID_OPTION : exception; BLANKS : STRING (1..14) := " "; VIDEO_HEADER : constant VIDEO_TYPES.HEADER_TYPE := (1=>BLANKS & "*****************************************************" & BLANKS, 2=>BLANKS & "* *" & BLANKS, 3=>BLANKS & "* ***** VIDEO ***** * " & BLANKS, 4=>BLANKS & "* *" & BLANKS, 5=>BLANKS & "*****************************************************" & BLANKS ); begin VIDEO_MAIN.MENU_INIT ( PROMPT(PASS_APL_MDL), VIDEO_HEADER, NODE_FILENAM, BOOT_REC, INIT_OK ); if INIT_OK then VIDEO_MAIN.READ_REC_NUM := ROOT_REC_NUM; VIDEO_MAIN.CUR_REC_NUM := BOOT_REC.POSITION; VIDEO_MAIN.PASSWORD_FLAG := ON; while VIDEO_MAIN.READ_REC_NUM > BOOT_REC.POSITION loop begin USER_PROMPT := PROMPT(SLASH_RTN); VIDEO_IO.READ_NODE ( NODE_REC, VIDEO_MAIN.READ_REC_NUM ); if VIDEO_MAIN.PASSWORD_FLAG = ON and then VIDEO_PROCS.HAS_PASSWORD ( NODE_REC ) then if not VIDEO_PROCS.PASSWORD_OK (NODE_REC, PASS_PROMPT ) then raise BAD_PASSWORD; end if; end if; VIDEO_MAIN.CUR_REC_NUM := VIDEO_MAIN.READ_REC_NUM; VIDEO_MAIN.PASSWORD_FLAG := ON; case NODE_REC.NODE_TYPE is when MENU => for I in VIDEO_TYPES.CHOICES loop if NODE_REC.OPTION (I) /= VIDEO_IO.END_REC then USER_PROMPT := PROMPT (OPTION_NO); exit; end if; end loop; VIDEO_PROCS.MENU_PROC (USER_PROMPT, NODE_REC, OPTION, VIDEO_MAIN.READ_REC_NUM ); when INSTRUCTION => if NODE_REC.NEXT_NODE /= VIDEO_IO.END_REC then USER_PROMPT := PROMPT (CR_GO_SL_RTN); end if; VIDEO_PROCS.INST_PROC (USER_PROMPT, NODE_REC, OPTION, VIDEO_MAIN.READ_REC_NUM ); when PROGRAM => if NODE_REC.NEXT_NODE /= VIDEO_IO.END_REC then USER_PROMPT := PROMPT (CR_GO_SL_RTN); end if; VIDEO_MAIN.PROG_PROC ( USER_PROMPT, NODE_REC, OPTION, VIDEO_MAIN.READ_REC_NUM ); when others => raise INVALID_NODE; end case; if OPTION in SPECIAL_CHARS then VIDEO_MAIN.PROCESS_OPTION ( NODE_REC.LAST_MENU, NODE_REC, ROOT_REC_NUM, BOOT_REC, OPTION ); end if; exception when BAD_PASSWORD => if VIDEO_MAIN.CUR_REC_NUM = BOOT_REC.POSITION then raise; else VIDEO_MAIN.READ_REC_NUM := VIDEO_MAIN.CUR_REC_NUM; VIDEO_MAIN.PASSWORD_FLAG := OFF; end if; when INVALID_OPTION => null; when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT ); raise; end; PASS_PROMPT := PROMPT(PASS_APL_MORE); end loop; end if; VIDEO_IO.CLOSE_NODE_FILE (SAVE_FILE); COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.MSG_PROC ( MESSAGES(SUCCESS), ERROR_LINE ); exception when USER_QUIT => COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.PUT_STRING ( "VIDEO SESSION STOPPED" ); if VIDEO_IO.NODE_FILE_OPEN then VIDEO_IO.CLOSE_NODE_FILE (SAVE_FILE ); end if; when BAD_PASSWORD => COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.PUT_STRING ( " PROCESS TERMINATED " & ": ACCESS DENIED" ); VIDEO_IO.CLOSE_NODE_FILE ( SAVE_FILE ); COMMON_PROCS.NEXT_LINE; when others => if VIDEO_IO.NODE_FILE_OPEN then VIDEO_IO.CLOSE_NODE_FILE ( SAVE_FILE ); end if; VIDEO_DEBUG.PRINT_EXCEPTIONS; end VIDEO; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --diagram.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * PACKAGE: DIAGRAM * -- * VERSION: 1.0a1 * -- * DATE : FEBRUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This package contains the routines used directly by VIDEO_DIAGRAM. -- with VIDEO_TYPES, DIAGRAM_TYPES; package DIAGRAM is procedure INIT ( SHOW_PASS : out BOOLEAN; SUCCESS : out BOOLEAN ); procedure PRINT_NODE ( CURRENT_NODE : in VIDEO_TYPES.NODE_RECORD; CUR_LEVEL : in DIAGRAM_TYPES.NODE_LEVEL; LAST_NODE : in VIDEO_TYPES.NODE; SHOW_PASS : in BOOLEAN; SUCCESS : out BOOLEAN ); procedure WRAP_UP ( SUCCESS : in BOOLEAN ); end DIAGRAM; with PASS_PROCS, COMMON_MESSAGES, COMMON_PROCS, SYSTEM_DEPENDENT, VIDEO_IO, VIDEO_PROCS, DIAGRAM_IO, DIAGRAM_MESSAGES, TEXT_IO; package body DIAGRAM is use VIDEO_TYPES, COMMON_MESSAGES, DIAGRAM_MESSAGES; EXCEPT : constant STRING(1..28) := "EXCEPTION RAISED IN DIAGRAM "; MAX_LINE_LENGTH : constant NATURAL := NATURAL(DIAGRAM_TYPES.MAX_LINE_LENGTH); procedure INIT_HEADER is BLANKS : STRING (1..14) := " "; DIAGRAM_HEADER : constant VIDEO_TYPES.HEADER_TYPE := (1=>BLANKS & "*****************************************************" & BLANKS, 2=>BLANKS & "* *" & BLANKS, 3=>BLANKS & "* ***** VIDEO DIAGRAM ***** *" & BLANKS, 4=>BLANKS & "* *" & BLANKS, 5=>BLANKS & "*****************************************************" & BLANKS ); begin COMMON_PROCS.SCREEN_DISPLAY ( COPYRIGHT ); COMMON_PROCS.SKIP_LINE (2); for I in VIDEO_TYPES.HEADER_LINES loop COMMON_PROCS.PUT_STRING ( DIAGRAM_HEADER(I) ); COMMON_PROCS.NEXT_LINE; end loop; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS INIT_HEADER"); raise; end INIT_HEADER; procedure CENTER ( STR : in STRING; PRINT_STR : out STRING ) is STR_LEN : NATURAL; FIRST_COL : NATURAL; begin STR_LEN := STR'length; FIRST_COL := ( PRINT_STR'length - STR_LEN) / 2; for I in 1..PRINT_STR'last loop PRINT_STR (I) := ' '; end loop; PRINT_STR(FIRST_COL..(FIRST_COL + STR_LEN) - 1) := STR; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS CENTER"); raise; end CENTER; procedure INIT ( SHOW_PASS: out BOOLEAN; SUCCESS : out BOOLEAN ) is use VIDEO_PROCS; NODE_FILENAME : VIDEO_TYPES.FILE_NAME; BOOT_FILESPEC : VIDEO_TYPES.FILESPEC; ROOT_REC : VIDEO_TYPES.NODE_RECORD; BOOT_REC : VIDEO_TYPES.NODE_RECORD; HDR_LINE : STRING(1..MAX_LINE_LENGTH); DONE : BOOLEAN := FALSE; begin INIT_HEADER; while not DONE loop begin NODE_FILENAME := SYSTEM_DEPENDENT.GET_FILENAME ( NODE_FILENAME, PROMPT (DEV_NAME), PROMPT (DIR_NAME), PROMPT (FIL_NAME), BOOT ); BOOT_FILESPEC := SYSTEM_DEPENDENT.BUILD_FILESPEC ( NODE_FILENAME ); VIDEO_IO.OPEN_NODE_FILE ( BOOT_FILESPEC ); DONE := TRUE; exception when VIDEO_IO.NAME_ERROR|VIDEO_IO.USE_ERROR => COMMON_PROCS.MSG_PROC ( "**ERROR** FILE DOES NOT EXIST", ERROR_LINE ); if not CONFIRMED ("DO YOU WANT TO TRY AGAIN (Y/N) ?" ) then raise USER_QUIT; end if; end; end loop; -- while not done VIDEO_IO.READ_NODE ( ROOT_REC, 1 ); if VIDEO_PROCS.HAS_PASSWORD (ROOT_REC) and then not VIDEO_PROCS.PASSWORD_OK (ROOT_REC, PROMPT(PASS_RUN_APL) ) then raise BAD_PASSWORD; end if; VIDEO_IO.READ_NODE ( BOOT_REC, 0 ); if VIDEO_PROCS.HAS_PASSWORD ( BOOT_REC ) and then not VIDEO_PROCS.PASSWORD_OK ( BOOT_REC, PROMPT(PASSWRD) ) then SHOW_PASS := FALSE; COMMON_PROCS.MSG_PROC ( ERROR(PRINT_PASS), ERROR_LINE ); else SHOW_PASS := TRUE; end if; DIAGRAM_IO.CREATE_PRINT_FILE; CENTER ( DIAGRAM_TYPES.RPT_HDR_1, HDR_LINE ); DIAGRAM_IO.PRINT ( HDR_LINE ); CENTER ( DIAGRAM_TYPES.RPT_HDR_2 & BOOT_FILESPEC.NAME(1..BOOT_FILESPEC.LENGTH), HDR_LINE ); DIAGRAM_IO.PRINT ( HDR_LINE ); DIAGRAM_IO.SKIP_LINES (2); DIAGRAM_IO.PRINT ( DIAGRAM_TYPES.PAGE_HDR_1 ); DIAGRAM_IO.PRINT ( DIAGRAM_TYPES.PAGE_HDR_2 ); SUCCESS := TRUE; exception when USER_QUIT => raise; when BAD_PASSWORD => COMMON_PROCS.MSG_PROC ("**PROCESS TERMINATED - ACCESS DENIED**", ERROR_LINE ); raise; when OTHERS => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS INIT" ); raise; end INIT; function BUILD ( NODE_REC : in VIDEO_TYPES.NODE_RECORD; LEVEL : in DIAGRAM_TYPES.NODE_LEVEL; LAST_NODE: in VIDEO_TYPES.NODE; SHOW_PASS: in BOOLEAN ) return DIAGRAM_TYPES.PRINT_RECORD is PRINT_REC : DIAGRAM_TYPES.PRINT_RECORD; begin if VIDEO_PROCS.HAS_PASSWORD (NODE_REC) then if SHOW_PASS then PRINT_REC.PASSWORD := PASS_PROCS.PASS_TO_STRING ( NODE_REC.NODE_PASSWORD ); else PRINT_REC.PASSWORD := "YES "; end if; else PRINT_REC.PASSWORD := "NO PASS "; end if; case NODE_REC.NODE_TYPE is when MENU => PRINT_REC.FILSPEC := SYSTEM_DEPENDENT.BUILD_FILESPEC ( NODE_REC.MENU_PATH ); when INSTRUCTION|PROGRAM => PRINT_REC.FILSPEC := SYSTEM_DEPENDENT.BUILD_FILESPEC ( NODE_REC.PATH ); when others => null; end case; PRINT_REC.NODE_TYPE := NODE_REC.NODE_TYPE; PRINT_REC.PREV_NODE := LAST_NODE; PRINT_REC.LEVEL := LEVEL; return PRINT_REC; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS BUILD"); raise; end BUILD; function FORMAT_STRING ( PRINT_REC : in DIAGRAM_TYPES.PRINT_RECORD; SHOW_PASS : in BOOLEAN ) return STRING is TWENTY_SIX_BLANKS : constant STRING(1..26) := " "; TWO_BLANKS : constant STRING(1..2) := " "; BLANK : constant STRING(1..1) := " "; PRINT_LINE : STRING(1..MAX_LINE_LENGTH ); LEVEL_FIELD : STRING(1..54) := TWENTY_SIX_BLANKS & TWENTY_SIX_BLANKS & TWO_BLANKS; FILESPEC_FIELD : STRING(1..52) := TWENTY_SIX_BLANKS & TWENTY_SIX_BLANKS; NODE_TYPE_FIELD : STRING(1..7) := " "; ACCESS_NODE_FIELD : STRING(1..7) := " "; PASSWORD_FIELD : STRING(1..11) := " "; begin case PRINT_REC.NODE_TYPE is when MENU => NODE_TYPE_FIELD := "MENU "; when INSTRUCTION => NODE_TYPE_FIELD := "INST "; when PROGRAM => NODE_TYPE_FIELD := "PROG "; when others => null; end case; case PRINT_REC.PREV_NODE is when MENU => ACCESS_NODE_FIELD := "MENU "; when INSTRUCTION => ACCESS_NODE_FIELD := "INST "; when PROGRAM => ACCESS_NODE_FIELD := "PROG "; when others => ACCESS_NODE_FIELD := "BOOT "; end case; LEVEL_FIELD(3*PRINT_REC.LEVEL) := NODE_TYPE_FIELD(1); FILESPEC_FIELD(1..PRINT_REC.FILSPEC.LENGTH) := PRINT_REC.FILSPEC.NAME(1..PRINT_REC.FILSPEC.LENGTH); if SHOW_PASS then PASSWORD_FIELD(1..8) := PRINT_REC.PASSWORD; end if; PRINT_LINE := BLANK & LEVEL_FIELD & NODE_TYPE_FIELD & ACCESS_NODE_FIELD & FILESPEC_FIELD & PASSWORD_FIELD; return PRINT_LINE; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS FORMAT_STRING"); raise; end FORMAT_STRING; procedure PRINT ( RPT_LINE : in STRING ) is begin if DIAGRAM_IO.LINE = 1 then DIAGRAM_IO.PRINT ( DIAGRAM_TYPES.PAGE_HDR_1 ); DIAGRAM_IO.PRINT ( DIAGRAM_TYPES.PAGE_HDR_2 ); end if; DIAGRAM_IO.PRINT ( RPT_LINE ); exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS PRINT"); raise; end PRINT; procedure PRINT_NODE ( CURRENT_NODE : in VIDEO_TYPES.NODE_RECORD; CUR_LEVEL : in DIAGRAM_TYPES.NODE_LEVEL; LAST_NODE : in VIDEO_TYPES.NODE; SHOW_PASS : in BOOLEAN; SUCCESS : out BOOLEAN ) is NEXT_NODE : VIDEO_TYPES.NODE_RECORD; PRINT_REC : DIAGRAM_TYPES.PRINT_RECORD; RPT_LINE : STRING (1..MAX_LINE_LENGTH); NEXT_LEVEL : DIAGRAM_TYPES.NODE_LEVEL := CUR_LEVEL + 1; begin PRINT_REC := BUILD (CURRENT_NODE, CUR_LEVEL, LAST_NODE, SHOW_PASS ); RPT_LINE := FORMAT_STRING ( PRINT_REC, SHOW_PASS ); PRINT ( RPT_LINE ); case CURRENT_NODE.NODE_TYPE is when MENU => for I in ONE..FIFTEEN loop if CURRENT_NODE.OPTION(I) /= VIDEO_IO.END_REC then VIDEO_IO.READ_NODE ( NEXT_NODE, CURRENT_NODE.OPTION(I) ); PRINT_NODE ( NEXT_NODE, NEXT_LEVEL, CURRENT_NODE.NODE_TYPE, SHOW_PASS, SUCCESS ); else SUCCESS := TRUE; end if; end loop; when others => if CURRENT_NODE.NEXT_NODE /= VIDEO_IO.END_REC then VIDEO_IO.READ_NODE ( NEXT_NODE, CURRENT_NODE.NEXT_NODE ); PRINT_NODE ( NEXT_NODE, NEXT_LEVEL, CURRENT_NODE.NODE_TYPE, SHOW_PASS, SUCCESS ); else SUCCESS := TRUE; end if; end case; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS PRINT_NODE"); raise; end PRINT_NODE; procedure WRAP_UP ( SUCCESS : in BOOLEAN ) is use VIDEO_IO; begin VIDEO_IO.CLOSE_NODE_FILE ( SAVE_FILE ); if SUCCESS then DIAGRAM_IO.CLOSE_PRINT_FILE; else DIAGRAM_IO.DELETE_PRINT_FILE; end if; exception when others => COMMON_PROCS.HANDLE_EXCEPTION (EXCEPT & "SUBROUTINE IS WRAP_UP"); raise; end WRAP_UP; end DIAGRAM; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --vidiag.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- ********************************************************************** -- * * -- * MAIN_PROCEDURE : VIDEO_DIAGRAM * -- * VERSION : 1.0a1 * -- * DATE : FEBRUARY, 1985 * -- * AUTHOR : STEPHEN J. HYLAND * -- * AdaSoft, Inc. * -- * Lanham, MD * -- * * -- ********************************************************************** -- -- This is the main procedure for diagramming the application model. The -- initialization process displays the copyright message, then prompts for -- the model filename. The user must enter the model password to run -- VIDEO_DIAGRAM. The user is then prompted for the model password. If it -- is entered, the passwords associated with each node will be printed. If -- it is not entered, or it is incorrect, the report will only indicate if -- the node is password-protected. -- Upon completion of initialization, the procedure will begin creating -- the application diagram. When this completes, the process will have -- created a text file that must then be printed by the user. This report -- is 132 columns long. Appropriate messages indicate the successful or -- unsuccessful completion of the program. -- with VIDEO_TYPES, VIDEO_IO, VIDEO_DEBUG, COMMON_PROCS, DIAGRAM_TYPES, DIAGRAM_IO, DIAGRAM_MESSAGES, DIAGRAM; procedure VIDEO_DIAGRAM is use VIDEO_TYPES, DIAGRAM_MESSAGES; EXCEPT : constant STRING(1..33) := "EXCEPTION RAISED IN VIDEO_DIAGRAM"; ROOT_NODE_POSITION : constant NATURAL := 1; ROOT_NODE : VIDEO_TYPES.NODE_RECORD; ROOT_LEVEL : DIAGRAM_TYPES.NODE_LEVEL := DIAGRAM_TYPES.NODE_LEVEL'first; SHOW_PASS : BOOLEAN := FALSE; RESULT_OK : BOOLEAN := FALSE; begin DIAGRAM.INIT ( SHOW_PASS, RESULT_OK ); if RESULT_OK then begin VIDEO_IO.READ_NODE ( ROOT_NODE, ROOT_NODE_POSITION ); DIAGRAM.PRINT_NODE ( ROOT_NODE, ROOT_LEVEL, BOOT, SHOW_PASS, RESULT_OK ); COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.MSG_PROC ( PROMPT(SUCCESS), ERROR_LINE ); exception when BAD_PASSWORD => null; end; end if; DIAGRAM.WRAP_UP ( RESULT_OK ); exception when USER_QUIT => COMMON_PROCS.HOME_CLEAR; COMMON_PROCS.MSG_PROC ( "DIAGRAM SESSION STOPPED", ERROR_LINE ); when others => COMMON_PROCS.HANDLE_EXCEPTION ( EXCEPT ); VIDEO_DEBUG.PRINT_EXCEPTIONS; if VIDEO_IO.NODE_FILE_OPEN then VIDEO_IO.CLOSE_NODE_FILE ( VIDEO_IO.SAVE_FILE ); end if; if DIAGRAM_IO.PRINT_FILE_OPEN then DIAGRAM_IO.DELETE_PRINT_FILE; end if; end VIDEO_DIAGRAM;