--
with system, starlet, calendar, text_io; use starlet, calendar, text_io;
with GLOBAL_CONSTANTS, SYSTEM_LIBRARY, MISC_ROUTINES;
use GLOBAL_CONSTANTS, SYSTEM_LIBRARY, MISC_ROUTINES;
with DYNAMIC_STRING, LOGICAL_NAME_PROCESSOR, PASTEBOARD, TERMINAL_IO;
use DYNAMIC_STRING, LOGICAL_NAME_PROCESSOR, PASTEBOARD, TERMINAL_IO;
--
package body ENVIRONMENT_CONTROL is
--+----------------------------------------------------------------------
--
--	Unit Type : PACKAGE BODY 
--	Unit Name : ENVIRONMENT_CONTROL
--	Version   : V01.0F
--
--	Author : Stephen R. Rainier                  Date : 11/25/85
--
--	Purpose : To provide a virtual display of environment information.
--
--	Parameters :
--
--	Name		Mode(I,O,IO)	Type/Subtype		Description
--	----		------------	------------		------------
--	ENV_BLK		    IO		ENVIRONMENT_BLOCK	data to display
--	LEVEL		    I		ENV_LEVEL		subdirectory
--	PROCESS_ID	     IO		PRIVILEDGE_ID		process priv.
--	DISPLAY		     IO		DISPLAY_BLOCK		3 level Virt Dsp
--	ORIGIN_DIR	     IO		DYN_STRING		original DIR
--	MANAGERS	     IO		DYN_STRING		config manager/s
--	CONTROL_FLAG	     IO		boolean			signal ctrl char
--
--	Modifications :
--
--	Name			Date		Description of Change
--	----			----		---------------------
--
--	Packages "WITH"ed : TERMINAL_IO, PASTEBOARD, system, starlet, calendar
--			    DYNAMIC_STRING, LOGICAL_NAME_PROCESSOR, text_io,
--				GLOBAL_CONSTANTS, SYSTEM_LIBRARY, MISC_ROUTINES
--
--	Procedure/Function "CALL"s : INIT_ENV_REPORT, STOP_ENV_REPORT,ENV_REPORT
--					NEW_ENV_BLK, GET_ENVIRON, GET_INPUT
--					INIT_ENVIRONMENT, ERROR_MSG, SET_POS,
--					RESET_SCREEN
--
--	Exceptions :
--
--	Name			Handled/Raised		Description
--	----			--------------		-----------
--	VD_ERROR			R		virtual display error
--	USER_ERROR			R		err reading user priv
--	name_error			H		non-existent file
--
--	Side Effects :
--
--	Comments :
--%----------------------------------------------------------------------

--
--	Local (Invisible) Declarations
--

procedure FIND_PROCESS_PRIV(NAME : in string; PRIV : out PRIVILEDGE_ID;
			UIC : out DYN_STRING) is
  CMD_DATA : file_type;
  CMD_VALUE : DYN_STRING;
  ACC : PRIVILEDGE_ID;
  USER_STR : DYN_STRING;
  CHAR : character;
  FLAG : boolean := false;
  FIRST, SECOND : integer := 0;
begin
  open(CMD_DATA, IN_FILE, USER_FILE);
  reset(CMD_DATA);
  MANAGERS := D_STRING("");
  USERS := D_STRING("");

  while not end_of_file(CMD_DATA) loop
    CMD_VALUE := D_STRING("");
    CHAR := ' ';

    while (not end_of_line(CMD_DATA)) and (CHAR /= '!') loop
	get(CMD_DATA,CHAR);
	CMD_VALUE := CMD_VALUE & D_STRING(CHAR);
    end loop;

    skip_line(CMD_DATA);
    FIRST := INDEX(CMD_VALUE, D_STRING('/'), 1); -- Create user/acc list --
    SECOND := INDEX(CMD_VALUE, D_STRING('/'), FIRST + 1);
    if FIRST >= 1 and SECOND >= 1 then
      USERS := USERS & SUBSTRING(CMD_VALUE, 1, FIRST - 1) & D_STRING(':');
      ACC := PRIVILEDGE_ID'value(STR(SUBSTRING(CMD_VALUE, FIRST+1,
    							SECOND-FIRST-1)));
      if ACC = USER then USERS := USERS & D_STRING("R/");
      elsif ACC = CONFIG_MANAGER then USERS := USERS & D_STRING("C/");
      elsif ACC = VERSION_CONTROLLER then USERS := USERS & D_STRING("V/");
      elsif ACC = TEST_DIRECTOR then USERS := USERS & D_STRING("T/"); end if;
    end if;

    if INDEX(CMD_VALUE,D_STRING("CONFIG_MANAGER"),1) >= 1 then
	if LENGTH(MANAGERS) > 0 then MANAGERS := MANAGERS & D_STRING(",");
	end if;
	MANAGERS := MANAGERS & SUBSTRING(CMD_VALUE, 1, LENGTH(CMD_VALUE)-15);
    end if;
    if INDEX(CMD_VALUE,D_STRING(NAME),1) = 1 then
		FLAG := true; USER_STR := CMD_VALUE; end if;
  end loop;

  CLOSE(CMD_DATA);
  if FLAG then 
    FIRST := INDEX(USER_STR, D_STRING('/'), 1);
    SECOND := INDEX(USER_STR, D_STRING('/'), FIRST + 1);
    PRIV := PRIVILEDGE_ID'value(STR(SUBSTRING(USER_STR, FIRST+1, 
						SECOND-FIRST-1)));

    FIRST := SECOND;
    SECOND := LENGTH(USER_STR);
    UIC := SUBSTRING(USER_STR, FIRST+1, SECOND-FIRST);
  else
    PRIV := NOACCESS;
    UIC := D_STRING("");
    raise USER_ERROR;
  end if;

  exception
    when name_error | use_error => raise USER_ERROR;
    when others =>  PRIV := NOACCESS;
		    UIC := D_STRING("");
		    raise USER_ERROR;

end FIND_PROCESS_PRIV;

procedure LOG_USER(MSG : in string) is
  LOG_FILE : file_type;
begin
  open(LOG_FILE, out_file, STR(ROOT) & USERLOG_FILE);
  reset(LOG_FILE);
  put(LOG_FILE, MSG);
  close(LOG_FILE);
exception
  when status_error => ERR_CNT := ERR_CNT + 1;
		       if ERR_CNT > 5 then
			 raise;
		       else
			 LOG_USER(MSG);		-- retry 5 times --
			 ERR_CNT := 0;
		       end if;
end LOG_USER;


---------------------


procedure CLOCK_SET is
  YR_STR, DAY_STR, MON_STR, HR_STR, MIN_STR : string(1..2);
  STATUS : system.unsigned_longword := 0;
begin
  ASCII_TIME(YR_STR, MON_STR, DAY_STR, HR_STR, MIN_STR);
  PUT_CHARS(STATUS, DISPLAY.VIRT_DSP(1).DISPLAY_ID, MON_STR & "/" &
		DAY_STR & " " & HR_STR & ":" & MIN_STR, 1, 65);
end CLOCK_SET;

--
--	Global (Visible) Declarations
--

procedure INIT_ENVIRONMENT(DATA : in out ENVIRONMENT_BLOCK) is
  TEMP : DYN_STRING;
  START, FINISH, NAME_LEN, POS, PRMPT : integer := 0;
  LEN : short_integer := 0;
  USERNAME : string(1..16) := (1..16 => ' ');
  CMD_LINE : string(1..80) := (1..80 => ' ');
  OUT_STR : string(1..80) := (1..80 => ' ');
  CUR_TIME : time;
  PREV_PRI, STATUS, OUT_VALUE : system.unsigned_longword := 0;
  OUT_LEN : system.unsigned_word := 0;
  ITEM_LIST : ITEM_LIST_TYPE(1..2) := 
	(1 => (BUF_LEN => USERNAME'length, ITEM_CODE => JPI_USERNAME,
	      BUF_ADDRESS => USERNAME'address, RET_ADDRESS => NAME_LEN'address),
	 2 => (BUF_LEN => 0, ITEM_CODE => 0, BUF_ADDRESS => system.address_zero,
	      RET_ADDRESS => system.address_zero));
begin

--	Determine the System Disk and Root directory for this project         --

  GET_CMD_LINE(STATUS, CMD_LINE, "DISK: ", LEN, PRMPT); -- get the disk spec. --
  if integer(STATUS) /= 1 or LEN <= 0 then raise USER_ERROR; end if;
  DISK_ID := D_STRING(CMD_LINE(1..integer(LEN)));

  if INDEX(DISK_ID, D_STRING(' '), 1) >= 1 then		-- space delimiter 
    POS := INDEX(DISK_ID, D_STRING(' '), 1);
  elsif INDEX(DISK_ID, D_STRING(','), 1) >= 1 then	-- comma delimiter 
    POS := INDEX(DISK_ID, D_STRING(','), 1);
  elsif INDEX(DISK_ID, D_STRING(ascii.ht), 1) >= 1 then -- tab delimiter 
    POS := INDEX(DISK_ID, D_STRING(ascii.ht), 1);
  end if;
  if POS >= 1 then				-- got a delimiter --
    ROOT := SUBSTRING(DISK_ID, POS+1, LENGTH(DISK_ID)-POS);
    DISK_ID := SUBSTRING(DISK_ID, 1, POS-1);
  end if;

  if INDEX(DISK_ID, D_STRING(':'), 1) < 1 then
    DISK_ID := DISK_ID & D_STRING(':');
  end if;

  if POS = 0 then			-- we did not get both together --
    GET_CMD_LINE(STATUS, CMD_LINE, "ROOT: ", LEN, PRMPT); --get root directory--
    if integer(STATUS) /= 1 or LEN <= 0 then raise USER_ERROR; end if;
    ROOT := D_STRING(CMD_LINE(1..integer(LEN)));
  end if;
  if INDEX(ROOT, D_STRING('['), 1) < 1 then	-- put "[" on the front --
    ROOT := D_STRING('[') & ROOT;
  end if;
  if INDEX(ROOT, D_STRING(']'), 1) >= 1 then	-- take "]" off the back --
    ROOT := SUBSTRING(ROOT, 1, LENGTH(ROOT) - 1);
  end if;

--	Upgrade the priority and determine current environment		      --

  SETPRI(STATUS => STATUS, PRI => 10, PRVPRI => OLD_PRIORITY);

  STATUS := CREATE_LOGICAL(DATA_LOGICAL, STR(ROOT) & DATA_DIR);
  STATUS := CREATE_LOGICAL(DOC_LOGICAL, STR(ROOT) & DOC_DIR);
  STATUS := CREATE_LOGICAL(LOG_LOGICAL, STR(ROOT) & LOG_DIR);
  STATUS := CREATE_LOGICAL(INTEG_LOGICAL, STR(ROOT) & INTEG_DIR);

  TEMP := D_STRING(GET_LOGICAL(VERS_LOGICAL));
  if LENGTH(TEMP) > 0 then
    START := RINDEX(TEMP,D_STRING('.'),LENGTH(TEMP));
    FINISH := RINDEX(TEMP,D_STRING(']'),LENGTH(TEMP));
    DATA.VERSION := SUBSTRING(TEMP, START+1, FINISH-START-1);
  end if;

  TEMP := D_STRING(GET_LOGICAL(TEST_LOGICAL));
  if LENGTH(TEMP) > 0 then
    START := RINDEX(TEMP,D_STRING('.'),LENGTH(TEMP));
    FINISH := RINDEX(TEMP,D_STRING(']'),LENGTH(TEMP));
    DATA.TEST_BED := SUBSTRING(TEMP, START+1, FINISH-START-1);
  end if;

  TEMP := D_STRING(GET_LOGICAL(ENV_LOGICAL));
  if LENGTH(TEMP) > 0 then
    START := RINDEX(TEMP,D_STRING('.'),LENGTH(TEMP));
    FINISH := RINDEX(TEMP,D_STRING(']'),LENGTH(TEMP));
    DATA.ENVIRONMENT := SUBSTRING(TEMP, START+1, FINISH-START-1);
  end if;

  TEMP := D_STRING(GET_LOGICAL(FAC_LOGICAL));
  if LENGTH(TEMP) > 0 then
    START := RINDEX(TEMP,D_STRING('.'),LENGTH(TEMP));
    FINISH := RINDEX(TEMP,D_STRING(']'),LENGTH(TEMP));
    DATA.FACILITY := SUBSTRING(TEMP, START+1, FINISH-START-1);
  end if;

  DATA.MODULE := D_STRING(GET_LOGICAL(MOD_LOGICAL));

  STATUS := CREATE_LOGICAL(TMP_LIB_LOGICAL, GET_LOGICAL(LIB_LOGICAL));
  STATUS := CREATE_LOGICAL(LIB_LOGICAL, GET_ENVIRON(DATA,ENVIRONMENT) &
							LIB_DIR);
  DATA.LIBRARY := D_STRING(GET_LOGICAL(LIB_LOGICAL));

  SET_DIR(STATUS, GET_ENVIRON(DATA,FACILITY) & "]", OUT_LEN, OUT_STR);
  ORIGIN_DIR := D_STRING(OUT_STR(1..integer(OUT_LEN)));
  STATUS := CREATE_LOGICAL(DISK_LOGICAL, STR(DISK_ID));

--	Get Process identification (username)

  GETJPI(STATUS => STATUS, ITMLST => ITEM_LIST);
  DATA.PROCESS_NAME := D_STRING(USERNAME);
  FINISH := INDEX(DATA.PROCESS_NAME, D_STRING(" "), 1);
  DATA.PROCESS_NAME := D_STRING(USERNAME(1..FINISH - 1));
  FIND_PROCESS_PRIV(USERNAME(1..FINISH - 1), DATA.PRIVILEDGE, DATA.PROCESS_UIC);

--	CREATE all the ASC$ logical symbols
--
-- ***** NOTE - For consistency, these symbol names should correspond to *****
-- ***** the COMMAND_ID's defined in the command_parser package spec.    *****
--

  STATUS := CREATE_SYMBOL("ACS$CMP",ACS_CMP);
  STATUS := CREATE_SYMBOL("ACS$ADE",ACS_ADE);
  STATUS := CREATE_SYMBOL("ACS$ASE",ACS_ASE);
  STATUS := CREATE_SYMBOL("ACS$CHE",ACS_CHE);
  STATUS := CREATE_SYMBOL("ACS$EXP",ACS_EXP);
  STATUS := CREATE_SYMBOL("ACS$LIB",ACS_LIB);
  STATUS := CREATE_SYMBOL("ACS$LNK",ACS_LNK);
  STATUS := CREATE_SYMBOL("ACS$REC",ACS_REC);
  STATUS := CREATE_SYMBOL("ACS$REF",ACS_REF);
  STATUS := CREATE_SYMBOL("ACS$ENT",ACS_ENT);
  STATUS := CREATE_SYMBOL("ACS$VER",ACS_VER);
  STATUS := CREATE_SYMBOL("ACS$GET",ACS_GET);
  STATUS := CREATE_SYMBOL("ACS$FOR",ACS_FOR);
  STATUS := CREATE_SYMBOL("ACS$MER",ACS_MER);
  STATUS := CREATE_SYMBOL("ACS$CLIB",ACS_CLIB);
  STATUS := CREATE_SYMBOL("ACS$DLIB",ACS_DLIB);
  STATUS := CREATE_SYMBOL("ACS$CSUB",ACS_CSUB);
  STATUS := CREATE_SYMBOL("ACS$DSUB",ACS_DSUB);

--	Establish proper access to the current library

  TEMP := D_STRING("ACS ASE/NOLOG");	-- properly assign ADA$LIB
  if DATA.PRIVILEDGE /= CONFIG_MANAGER then	-- only read at top level
    TEMP := TEMP & D_STRING("/READ_ONLY");
  end if;
  TEMP := TEMP & D_STRING(" " & LIB_LOGICAL);
  SET_POS; DO_CMD(TEMP); RESET_POS;		-- execute the ACS SET LIB

--	Log the User into the System

CUR_TIME := clock;
LOG_USER("User " & STR(DATA.PROCESS_NAME) & "/" &
	PRIVILEDGE_ID'image(DATA.PRIVILEDGE) & " logged in at " &
	integer'image(integer(seconds(CUR_TIME))) & " on " &
  	month_number'image(month(CUR_TIME)) & "-" &
  	day_number'image(day(CUR_TIME)) & "-" &
  	year_number'image(year(CUR_TIME)));

exception
  when others => raise;

end INIT_ENVIRONMENT;

procedure INIT_ENV_REPORT is
  STATUS : system.unsigned_longword := 0;

begin
  CREATE_PASTEBOARD(STATUS, DISPLAY.PASTEBOARD_ID,DISPLAY.OUT_DEVICE,
  	DISPLAY.ROW_COUNT,DISPLAY.COLUMN_COUNT);
  if integer(STATUS) /= 1 then RAISE VD_ERROR; end if;

  CREATE_KEYBOARD(STATUS, DISPLAY.KEYBOARD_ID, DISPLAY.IN_TERMINAL);
  if integer(STATUS) /= 1 then RAISE VD_ERROR; end if;
  CREATE_VIRTUAL_DISPLAY(STATUS, 2, 80, DISPLAY.VIRT_DSP(2).DISPLAY_ID,
						SMG_M_BORDER,0);
  if integer(STATUS) /= 1 then RAISE VD_ERROR; end if;
  LABEL_BORDER(STATUS, DISPLAY.VIRT_DSP(2).DISPLAY_ID, " [TAPSE/V01.0F] ",
	SMGK_TOP);

  CREATE_VIRTUAL_DISPLAY(STATUS, 4, 90, DISPLAY.VIRT_DSP(1).DISPLAY_ID,
  	SMG_M_BORDER, SMG_M_REVERSE);
  if integer(STATUS) /= 1 then RAISE VD_ERROR; end if;

  CLOCK_SET;

  PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,"Unit-",1,1);
  PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,"Vers-",2,1);
  PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,"Test-",3,1);
  PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,"Env -",2,41);
  PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,"Fac -",3,41);
  PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,"ALib-",4,1);

  PASTE_VIRTUAL_DISPLAY(STATUS, DISPLAY.VIRT_DSP(1).DISPLAY_ID,
  		DISPLAY.PASTEBOARD_ID,1,1);
  PASTE_VIRTUAL_DISPLAY(STATUS, DISPLAY.VIRT_DSP(2).DISPLAY_ID,
  		DISPLAY.PASTEBOARD_ID,6,1);
  ALLOW_ESCAPE(STATUS, DISPLAY.VIRT_DSP(2).DISPLAY_ID, 0);
--  DISABLE_CONTROL(STATUS, 16#02000000#, OLD_MASK); -- disable Y  --
--  if integer(STATUS) /= 1 then 
--    put(" Disable Status = ");put(integer'image(integer(STATUS))); new_line;
--    raise VD_ERROR;
--  end if;

  ENV_REPORT.START;

exception
  when others => raise;

end INIT_ENV_REPORT;

procedure EXIT_ENVIRONMENT is
  STATUS, PRI : system.unsigned_longword := 0;
  OUT_LEN : system.unsigned_word := 0;
  OUT_STR : string(1..80) := (1..80 => ' ');
  CUR_TIME : time;
begin
  SETPRI(STATUS => STATUS, PRI => OLD_PRIORITY, PRVPRI => PRI);
  STATUS := KILL_LOGICAL(VERS_LOGICAL);
  STATUS := KILL_LOGICAL(TEST_LOGICAL);
  STATUS := KILL_LOGICAL(ENV_LOGICAL);
  STATUS := KILL_LOGICAL(FAC_LOGICAL);
  STATUS := KILL_LOGICAL(MOD_LOGICAL);
  STATUS := CREATE_LOGICAL(LIB_LOGICAL,GET_LOGICAL(TMP_LIB_LOGICAL));
  STATUS := KILL_LOGICAL(TMP_LIB_LOGICAL);
  STATUS := KILL_LOGICAL(DATA_LOGICAL);
  STATUS := KILL_LOGICAL(DOC_LOGICAL);
  STATUS := KILL_LOGICAL(LOG_LOGICAL);
  STATUS := KILL_LOGICAL(INTEG_LOGICAL);
  SET_DIR(STATUS, STR(ORIGIN_DIR), OUT_LEN, OUT_STR);
  STATUS := KILL_LOGICAL(DISK_LOGICAL);
  STATUS := KILL_SYMBOL("ACS$CMP");
  STATUS := KILL_SYMBOL("ACS$ADE");
  STATUS := KILL_SYMBOL("ACS$ASE");
  STATUS := KILL_SYMBOL("ACS$CHE");
  STATUS := KILL_SYMBOL("ACS$EXP");
  STATUS := KILL_SYMBOL("ACS$LIB");
  STATUS := KILL_SYMBOL("ACS$LNK");
  STATUS := KILL_SYMBOL("ACS$REC");
  STATUS := KILL_SYMBOL("ACS$REF");
  STATUS := KILL_SYMBOL("ACS$ENT");
  STATUS := KILL_SYMBOL("ACS$VER");
  STATUS := KILL_SYMBOL("ACS$GET");
  STATUS := KILL_SYMBOL("ACS$FOR");
  STATUS := KILL_SYMBOL("ACS$MER");
  STATUS := KILL_SYMBOL("ACS$CLIB");
  STATUS := KILL_SYMBOL("ACS$DLIB");
  STATUS := KILL_SYMBOL("ACS$CSUB");
  STATUS := KILL_SYMBOL("ACS$DSUB");

--	Logout the User into the System

  CUR_TIME := clock;
  LOG_USER("User " & " EXITed at " & 
	integer'image(integer(seconds(CUR_TIME))) & " on " &
  	month_number'image(month(CUR_TIME)) & "-" &
  	day_number'image(day(CUR_TIME)) & "-" &
  	year_number'image(year(CUR_TIME)));

exception
  when others => raise;

end EXIT_ENVIRONMENT;

procedure QUIT_ENVIRONMENT is
  STATUS, PRI : system.unsigned_longword := 0;
  OUT_LEN : system.unsigned_word := 0;
  OUT_STR : string(1..80) := (1..80 => ' ');
  CUR_TIME : time;
begin
  SETPRI(STATUS => STATUS, PRI => OLD_PRIORITY, PRVPRI => PRI);
  STATUS := KILL_LOGICAL(DATA_LOGICAL);
  STATUS := KILL_LOGICAL(DOC_LOGICAL);
  STATUS := KILL_LOGICAL(LOG_LOGICAL);
  STATUS := KILL_LOGICAL(INTEG_LOGICAL);
  STATUS := CREATE_LOGICAL(LIB_LOGICAL,GET_LOGICAL(TMP_LIB_LOGICAL));
  STATUS := KILL_LOGICAL(TMP_LIB_LOGICAL);
  STATUS := KILL_LOGICAL(DISK_LOGICAL);
  SET_DIR(STATUS, STR(ORIGIN_DIR), OUT_LEN, OUT_STR);
  STATUS := KILL_SYMBOL("ACS$CMP");
  STATUS := KILL_SYMBOL("ACS$ADE");
  STATUS := KILL_SYMBOL("ACS$ASE");
  STATUS := KILL_SYMBOL("ACS$CHE");
  STATUS := KILL_SYMBOL("ACS$EXP");
  STATUS := KILL_SYMBOL("ACS$LIB");
  STATUS := KILL_SYMBOL("ACS$LNK");
  STATUS := KILL_SYMBOL("ACS$REC");
  STATUS := KILL_SYMBOL("ACS$REF");
  STATUS := KILL_SYMBOL("ACS$ENT");
  STATUS := KILL_SYMBOL("ACS$VER");
  STATUS := KILL_SYMBOL("ACS$GET");
  STATUS := KILL_SYMBOL("ACS$FOR");
  STATUS := KILL_SYMBOL("ACS$MER");
  STATUS := KILL_SYMBOL("ACS$CLIB");
  STATUS := KILL_SYMBOL("ACS$DLIB");
  STATUS := KILL_SYMBOL("ACS$CSUB");
  STATUS := KILL_SYMBOL("ACS$DSUB");

--	Logout the User into the System

  CUR_TIME := clock;
  LOG_USER("User " & " QUIT at " & 
	integer'image(integer(seconds(CUR_TIME))) & " on " &
  	month_number'image(month(CUR_TIME)) & "-" &
  	day_number'image(day(CUR_TIME)) & "-" &
  	year_number'image(year(CUR_TIME)));

exception
  when others => raise;

end QUIT_ENVIRONMENT;

procedure NEW_ENV_BLK(DATA : in out ENVIRONMENT_BLOCK; LEVEL : in ENV_LEVEL;
			NAME : in LOGICAL_NAME_TYPE) is
  FULL : DYN_STRING := D_STRING("");
  PRECEED : DYN_STRING := ROOT;
  STATUS : system.unsigned_longword := 0;
  OUT_LEN : system.unsigned_word := 0;
  OUT_STR : string(1..80) := (1..80 => ' ');
begin
  if LEVEL = VERSION then
    DATA.VERSION := D_STRING(NAME);
    DATA.TEST_BED := D_STRING("");
    DATA.ENVIRONMENT := D_STRING("");
    DATA.FACILITY := D_STRING("");
    STATUS := KILL_LOGICAL(VERS_LOGICAL);
    STATUS := KILL_LOGICAL(TEST_LOGICAL);
    STATUS := KILL_LOGICAL(ENV_LOGICAL);
    STATUS := KILL_LOGICAL(FAC_LOGICAL);
    if NAME /= "" then
      STATUS := CREATE_LOGICAL(VERS_LOGICAL, STR(PRECEED) & "." & NAME & "]");
    end if;
  end if;
  if LENGTH(DATA.VERSION) > 0 then
    PRECEED := PRECEED & D_STRING(".") & DATA.VERSION;
  end if;

  if LEVEL = TEST_BED then
    DATA.TEST_BED := D_STRING(NAME);
    DATA.ENVIRONMENT := D_STRING("");
    DATA.FACILITY := D_STRING("");
    STATUS := KILL_LOGICAL(TEST_LOGICAL);
    STATUS := KILL_LOGICAL(ENV_LOGICAL);
    STATUS := KILL_LOGICAL(FAC_LOGICAL);
    if NAME /= "" then
      STATUS := CREATE_LOGICAL(TEST_LOGICAL, STR(PRECEED) & "." & NAME & "]");
    end if;
  end if;
  if LENGTH(DATA.TEST_BED) > 0 then
    PRECEED := PRECEED & D_STRING(".") & DATA.TEST_BED;
  end if;

  if LEVEL = ENVIRONMENT then
    DATA.ENVIRONMENT := D_STRING(NAME);
    DATA.FACILITY := D_STRING("");
    STATUS := KILL_LOGICAL(ENV_LOGICAL);
    STATUS := KILL_LOGICAL(FAC_LOGICAL);
    if NAME /= "" then
      STATUS := CREATE_LOGICAL(ENV_LOGICAL, STR(PRECEED) & "." & NAME & "]");
    end if;
  end if;
  if LENGTH(DATA.ENVIRONMENT) > 0 then
    PRECEED := PRECEED & D_STRING(".") & DATA.ENVIRONMENT;
  end if;

  if LEVEL = FACILITY then
    DATA.FACILITY := D_STRING(NAME);
    STATUS := KILL_LOGICAL(FAC_LOGICAL);
    if NAME /= "" then
      STATUS := CREATE_LOGICAL(FAC_LOGICAL, STR(PRECEED) & "." & NAME & "]");
    end if;
  end if;
  if LENGTH(DATA.FACILITY) > 0 then
    FULL := PRECEED & D_STRING(".") & DATA.FACILITY;
  else
    FULL := PRECEED;
  end if;

  if LEVEL = MODULE then
    DATA.MODULE := D_STRING(NAME);
    STATUS := KILL_LOGICAL(MOD_LOGICAL);
    STATUS := CREATE_LOGICAL(MOD_LOGICAL, NAME);
  else
    DATA.MODULE := D_STRING(GET_LOGICAL(MOD_LOGICAL));
  end if;

  STATUS := CREATE_LOGICAL(LIB_LOGICAL, STR(PRECEED) & LIB_DIR);
  DATA.LIBRARY := D_STRING(GET_LOGICAL(LIB_LOGICAL));

  SET_DIR(STATUS,STR(FULL) & "]", OUT_LEN, OUT_STR);

  ENV_REPORT.UPDATE(DATA);

exception
  when others => raise;

end NEW_ENV_BLK;

function GET_ENVIRON(DATA : in ENVIRONMENT_BLOCK;
		LEVEL : in ENV_LEVEL := ENVIRONMENT) return string is
  CMD_STR : DYN_STRING := ROOT;
begin
  if LENGTH(DATA.VERSION) > 0 then CMD_STR := CMD_STR & D_STRING('.') &
						DATA.VERSION; end if;
  if LEVEL /= VERSION then		-- Keep going? --
    if LENGTH(DATA.TEST_BED) > 0 then CMD_STR := CMD_STR & D_STRING('.') &
						DATA.TEST_BED; end if;
    if LEVEL /= TEST_BED then		-- Keep going? --
      if LENGTH(DATA.ENVIRONMENT) > 0 then CMD_STR := CMD_STR & D_STRING('.') &
						DATA.ENVIRONMENT; end if;
      if LEVEL /= ENVIRONMENT then		-- Keep going? --
	if LENGTH(DATA.FACILITY) > 0 then CMD_STR := CMD_STR & D_STRING('.') &
						DATA.FACILITY; end if;
      end if;
    end if;
  end if;
  return STR(CMD_STR);

exception
  when others => raise;

end GET_ENVIRON;

procedure GET_INPUT(LINE : out DYN_STRING; TCODE : out system.unsigned_word;
		INFILE : in out DYN_STRING) is
  STATUS : system.unsigned_longword := 0;
  OSTR : string(1..512) := (1..512 => ' ');
  STR_LEN : system.unsigned_word :=512;

begin
    LINE := D_STRING("");
    BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    ERASE_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,80,1,1);
    END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);

    if LENGTH(INFILE) > 0 then		-- got an indirect command file --
      if integer(IND_KEYBOARD_ID) = 0 then -- first time; open new file --
	CREATE_KEYBOARD(STATUS, IND_KEYBOARD_ID, STR(INFILE));
	if integer(STATUS) /= 1 then raise VD_ERROR; end if;
      end if;
      READ_STRING(STATUS => STATUS, KEYBOARD_ID => IND_KEYBOARD_ID,
		OUT_STR => OSTR, PROMPT => "$", MODIFIER => 0,
		OUT_LEN => STR_LEN, TERMINATOR => TCODE, 
		DISPLAY_ID => DISPLAY.VIRT_DSP(2).DISPLAY_ID);
      if integer(STATUS) /= 1 then	-- reached the end of file --
	DELETE_KEYBOARD(STATUS, IND_KEYBOARD_ID);
	IND_KEYBOARD_ID := 0;
	INFILE := D_STRING("");
	GET_INPUT(LINE, TCODE, INFILE);	-- still need a command line --
      else
	BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
		OSTR(1..integer(STR_LEN)),1,1);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);

	OSTR := UPPER(OSTR);
	LINE := D_STRING(OSTR(1..integer(STR_LEN)));
      end if;
    else					-- normal read from TTY --
      READ_STRING(STATUS => STATUS, KEYBOARD_ID => DISPLAY.KEYBOARD_ID,
		OUT_STR => OSTR, PROMPT => "$", MODIFIER => 0,
		OUT_LEN => STR_LEN, TERMINATOR => TCODE, 
		DISPLAY_ID => DISPLAY.VIRT_DSP(2).DISPLAY_ID);
      OSTR := UPPER(OSTR);
      LINE := D_STRING(OSTR(1..integer(STR_LEN)));
    end if;

    BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    ERASE_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,80,2,1);
    END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);

exception
  when VD_ERROR => ERROR_MSG(MISSING_FILE);
  		   IND_KEYBOARD_ID := 0;
  		   INFILE := D_STRING("");
		   TCODE := 0;
  when others => raise;

end GET_INPUT;

procedure ERROR_MSG(MSG_NUM : in integer := 0) is
  STATUS : system.unsigned_longword := 0;
begin
  case MSG_NUM is

    when PRIV_ERR => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Priviledge not available for the specified operation! *****",
	2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    when DCL_ERR => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Attempt to execute an illegal instruction! *****",2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    when SRCE_ERR => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Attempt to use a source module not in the source facility!*****",
	2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    when EXT_ERR => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Invalid file extension supplied for the specified operation! " &
	"*****",2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    when ESC_ERR => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Control character escape illegal!  Please use exit or quit. " &
	"*****",2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    when ACC_ERR =>
	put_line("***** Fatal - no access priviledge for this project! *****");
    when DAT_ERR => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Fatal - crucial data file appears to be unavailable! *****",
	2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	delay 5.0;
    when ACL_ERR => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Error encountered in modifying an access control list! *****",
	2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    when HDR_ERR => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Unable to successfully create the source header... report the" &
	" problem to the config manager! *****",2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);

    when NOT_IMP => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Sorry, that command has not been implemented! *****",2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    when NO_FILE => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** The requested file is unavailable for check-out! *****",
	2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    when CMD_ERR => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Format of the command line is illegal! *****",2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    when ENV_ERR => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Unrecognized level name specified; processing incomplete! *****",
	2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    when MISSING_FILE => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** File missing or uncreateable; unable to complete command! *****",
	2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
    when UNKNOWN_ERROR => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Received unexpected exception; report problem to config manag" &
	"er! *****", 2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	delay 5.0;
    when VD_ERR => BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,
	"***** Unexpected error in establishing virtual displays! *****",
	2,1,0,0,0);
	END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	delay 5.0;
    when others => null;

  end case;
end ERROR_MSG;

procedure STOP_ENV_REPORT is
  STATUS : system.unsigned_longword := 0;
begin
	DELETE_VIRTUAL_DISPLAY(STATUS, DISPLAY.VIRT_DSP(1).DISPLAY_ID);
	DELETE_VIRTUAL_DISPLAY(STATUS, DISPLAY.VIRT_DSP(2).DISPLAY_ID);
	ERASE_PASTEBOARD(STATUS,DISPLAY.PASTEBOARD_ID);

	if ENV_REPORT'callable then
	  ENV_REPORT.STOP;
	  ABORT ENV_REPORT;
	end if;

end STOP_ENV_REPORT;


procedure SET_POS(START : in integer := 9) is
  STATUS : system.unsigned_longword := 0;
begin
  SAVE_PHYSICAL_SCREEN(STATUS, DISPLAY.PASTEBOARD_ID,
			DISPLAY.VIRT_DSP(3).DISPLAY_ID, START, 24);
  SET_PHYSICAL_CURSOR(STATUS, DISPLAY.PASTEBOARD_ID, 24, 1);
end SET_POS;


procedure RESET_POS is
  STATUS : system.unsigned_longword := 0;
begin
  new_line(2);
  POP_VIRTUAL_DISPLAY(STATUS, DISPLAY.VIRT_DSP(3).DISPLAY_ID,
			DISPLAY.PASTEBOARD_ID);
end RESET_POS;


procedure RESTORE_POS is
  STATUS : system.unsigned_longword := 0;
begin
  new_line(2);
  POP_VIRTUAL_DISPLAY(STATUS, DISPLAY.VIRT_DSP(3).DISPLAY_ID,
			DISPLAY.PASTEBOARD_ID);
  DELETE_VIRTUAL_DISPLAY(STATUS, DISPLAY.VIRT_DSP(1).DISPLAY_ID);
  DELETE_VIRTUAL_DISPLAY(STATUS, DISPLAY.VIRT_DSP(2).DISPLAY_ID);
  DELETE_PASTEBOARD(STATUS,DISPLAY.PASTEBOARD_ID);
  ENV_REPORT.STOP;
  INIT_ENV_REPORT;
  
end RESTORE_POS;


procedure RESET_SCREEN is
  STATUS : system.unsigned_longword := 0;
begin
  REPAINT(STATUS, DISPLAY.PASTEBOARD_ID);
end RESET_SCREEN;

task body ENV_REPORT is
  DATA : ENVIRONMENT_BLOCK;
  RUNNING : BOOLEAN := FALSE;
  X, Y : integer := 1;
  STATUS : system.unsigned_longword := 0;
begin
  loop
    select
	accept START do
	  RUNNING := TRUE;
	end START;
    or
	accept STOP do
	  RUNNING := FALSE;
	end STOP;
    or
	accept UPDATE(ARG : ENVIRONMENT_BLOCK) do
	  DATA := ARG;
	end UPDATE;
	if RUNNING then			-- update the virtual display area
	  BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	  RETURN_CURSOR_POS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,X,Y);
	  CLOCK_SET;
	  ERASE_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,56,1,8);
	  PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,STR(DATA.MODULE),
			1,8,0,SMG_M_BOLD,SMG_M_REVERSE);
	  ERASE_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,32,2,8);
	  PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,STR(DATA.VERSION),
			2,8,0,SMG_M_BOLD,SMG_M_REVERSE);
	  ERASE_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,32,3,8);
	  PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,STR(DATA.TEST_BED),
			3,8,0,SMG_M_BOLD,SMG_M_REVERSE);
	  ERASE_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,32,2,48);
	  PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,
		STR(DATA.ENVIRONMENT),2,48,0,SMG_M_BOLD,SMG_M_REVERSE);
	  ERASE_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,32,3,48);
	  PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,STR(DATA.FACILITY),
			3,48,0,SMG_M_BOLD,SMG_M_REVERSE);
	  ERASE_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,72,4,8);
	  PUT_CHARS(STATUS,DISPLAY.VIRT_DSP(1).DISPLAY_ID,STR(DATA.LIBRARY),
			4,8,0,SMG_M_BOLD,SMG_M_REVERSE);
	  SET_CURSOR(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,X,Y);
	  END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	end if;
    or
	accept CLOCK;
	if RUNNING then			-- update the virtual display area
	  BEGIN_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	  RETURN_CURSOR_POS(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,X,Y);
	  CLOCK_SET;
	  SET_CURSOR(STATUS,DISPLAY.VIRT_DSP(2).DISPLAY_ID,X,Y);
	  END_UPDATE(STATUS,DISPLAY.PASTEBOARD_ID);
	end if;
    or
	terminate;

    end select;
  end loop;
end ENV_REPORT;



begin

	null;

end ENVIRONMENT_CONTROL;