%title 'Aux' MODULE aux (main=aux_main,IDENT = '4.5') = BEGIN ! ! COPYRIGHT (c) 1982 BY ! Project Software & Development, Inc. ! ! This software is furnished under a license and may be used and copied ! only in accordance with the terms of such license and with the ! inclusion of the above copyright notice. This software or any other ! copies thereof may not be provided or otherwise made available to any ! other person. No title to and ownership of the software is hereby ! transferred. ! ! The information in this software is subject to change without notice ! and should not be construed as a commitment by PROJECT SOFTWARE ! AND DEVELOPMENT, INC. ! ! PROJECT SOFTWARE assumes no responsibility for the use or reliability ! of its software on equipment which is not supplied by PROJECT SOFTWARE. ! !++ ! FACILITY: ! DCL alternate keypad applications ! ABSTRACT: ! ! Allows users to define keys on the VT100 alternate keypad to execute ! DCL commands. ! ! ENVIRONMENT: ! ! AUTHOR: V. Graham , CREATION DATE: April 1982 ! ! MODIFIED BY: ! ! MEH, 4-feb-1983, : VERSION 2 ! 01 - To make use of the VMS DCL routines. Extensively rewritten. ! MEH, 17-Jun-1983, : VERSION 3 ! 01 - To correct problem with errors on nonDECCRT's. ! 02 - To not repeat the prompt string unnecessarily. ! MEH, 11-Jul-1983, : VERSION 4 ! 01 - To correctly handle lack of translation of SYS$NODE. ! MEH, 13-Sep-1983, : Version 4.1 ! 01 - Added globals for time statistics. ! MEH, 18-Oct-1983, : Version 4.2 ! 01 - Added check to see if we are in batch mode and to abort if true. ! MEH, 8-Dec-1983, : VERSION 4.3 ! 01 - To make AUX_MBX name vary with the terminal so that we do not get ! funny results when multiple users in the same group. Also we will ! attempt to make AUX_MBX a permanent mailbox. ! MEH, 15-Dec-1983, : VERSION 4.4 ! 01 - To get the device characteristics to see if we are a remote terminal. ! We will not run if we are a remote termina. ! 02 - To look for the logical name AUX_CLOCK_INTERVAL for a delta time ! which is the clock update interval. If not defined, then it will ! default to 1 second. ! MEH, 16-Feb-1984, : VERSION 4.5 ! 01 - To save statistics in DCL common. !-- ! ! TABLE OF CONTENTS: ! FORWARD ROUTINE aux_main, exit_handler : NOVALUE, aux_read, is_aux_command, rd_pmt, decode_escape, decode_controls, error_handler, write_error, aux_search_table, get_symbols, build_command : NOVALUE, time_display_ast : NOVALUE, read_ready_ast : NOVALUE, aux_echo_line : NOVALUE, aux_top_line : NOVALUE, cleanup, unwinder ; ! ! ! INCLUDE FILES: ! library 'sys$library:lib'; Require 'sys$library:psdi'; Library 'Auxlib'; ! ! Macros ! ! ! Equated Symbols ! ! ! OWN STORAGE: ! own clock_interval: vector[2], !The binary clock update interval. command_display: dynamic_descriptor, command : dynamic_descriptor, terminator_mask: vector[4] initial( long( ctrl(A) or ctrl(B) or ctrl(D) or ctrl(E) or ctrl(F) or ctrl(G) or ctrl(H) or ctrl(J) or ctrl(K) or ctrl(L) or ctrl(M) or ctrl(N) or ctrl(P) or ctrl(R) or ctrl(U) or ctrl(V) or ctrl(W) or ctrl(X) or ctrl(Z) ), ! 1st longword 0,0, %x'80000000'), ! DEL in last longword terminators : descriptor(terminator_mask,16), mbx_chan : word, null_string : dynamic_descriptor ; Global aux_l_alarm : initial(0), aux_mode_buf : block[12,byte], aux_old_mode_buf : block[12,byte], aux_tt_chan : word ; Bind default_interval = $descriptor('0 00:00:01.00') : block[,byte], aux_clock_interval = $descriptor('AUX_CLOCK_INTERVAL') : block[,byte] ; ! ! EXTERNAL REFERENCES: ! External aux_l_statistics : long, aux_q_start_time : vector[2], aux_q_end_time : vector[2], aux_l_start_cpu : long, aux_l_end_cpu : long, aux_l_cp : long signed, new_line : block[,byte], blank : block[,byte], top_stuff : block[,byte], region2_23 : block[,byte], region2_24 : block[,byte], Line2 : Block[,Byte], line23 : block[,byte], scroll : block[,byte], line24 : block[,byte], bold_on : block[,byte], blink : block[,byte], reverse : block[,byte], save_cursor : block[,byte], bold_off : block[,byte], cursor_up : block[,byte], clear_line : block[,byte], AUX_mode : block[,byte], AUX_mode_off : block[,byte], wrap_on : block[,byte], wrap_off : block[,byte], restore_cursor : block[,byte], prompt : block[,byte], escape_keys : symbol_table, gold_escape_keys : symbol_table, control_keys : symbol_table, gold_control_keys : symbol_table, aux_lastcommand : block[,byte], global_symbol : long ; bind keys = uplit( escape_keys, control_keys, gold_escape_keys, gold_control_keys, terminators ) : vector[] ; external literal aux_invesc, aux_keynotdef, aux_unwind, aux_comvalue, aux_notdeccrt, aux_notbatch, aux_notnettrm, lib$_nosuchsym ; EXTERNAL ROUTINE aux_commands : addressing_mode(general), aux_title : addressing_mode(general), aux_check_alarm : addressing_mode(general), aux_bs : addressing_mode(general), aux_overlay_string : addressing_mode(general), aux_init_memory : addressing_mode(general), aux_save_memory : addressing_mode(general), aux_save_command : addressing_mode(general), quad_subtract : addressing_mode(general), sys$setddir : addressing_mode(general), lib$get_symbol : addressing_mode(general), lib$set_symbol : addressing_mode(general), lib$put_output : addressing_mode(general), lib$delete_logical : addressing_mode(general), lib$do_command : addressing_mode(general), str$free1_dx : addressing_mode(general), str$copy_dx : addressing_mode(general), str$concat : addressing_mode(general), str$append : addressing_mode(general), str$left : addressing_mode(general) ; ROUTINE aux_main = !++ ! FUNCTIONAL DESCRIPTION: ! This routine will read a VT100 keypad to build a DCL command string ! which will be executed directly after this image is run. ! ! FORMAL PARAMETERS: ! ! NONE ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! NONE ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN bind aux_mbx_prefix = $descriptor('AUX_MBX_'); own exit_status, exit_vector : vector[5] initial(0, ! Forward link exit_handler,! Address of handler 2, ! number of arguments exit_status, ! Address of status 0 ! If set to 1 then we need to reset terminal ! characteristics ) ; bind reset_needed = exit_vector[4] : long ; Local aux_mbx : dynamic_descriptor, aux_debug : dynamic_descriptor, status, iostat : vector [4,word]; Own devchar : block[1], Job_Sts : BitVector[32], Terminal: Allocate_string(15), Terminal_Desc: descriptor(Terminal,15) ; Bind Exit_Command = $descriptor('Exit') ; Bind GetJpi_Status = Uplit( Word(4,Jpi$_Sts),Job_Sts,0, Word(15,JPI$_TERMINAL),Terminal,Terminal_Desc[DSC$W_LENGTH], 0 ) ; ! ! Declare an error handler enable error_handler; ! ! Check if in batch mode -- abort if so. Perform($GetJpi(ItmLst=GetJpi_Status)); If .Job_Sts[$BitPosition(PCB$V_Batch)] then begin Signal(Aux_NotBatch); lib$do_command(Exit_Command); end; ! ! Initialize the DCL common memory aux_init_memory(); ! ! Declare an exit handler perform($dclexh(desblk=exit_vector)); ! ! Create a permanent (if possible) mailbox to be used for unsolicited input ! Remove the trailing colon from the name. terminal_desc[DSC$W_LENGTH] = .terminal_desc[DSC$W_LENGTH] -1; concat((aux_mbx,aux_mbx_prefix,terminal_desc)); IF (status = ($crembx(chan=mbx_chan,prmflg=1, !Permanent mailbox lognam=aux_mbx, maxmsg=msg_c_size ))) eql SS$_NOPRIV THEN BEGIN status = $crembx(chan=mbx_chan,prmflg=0, !Temporary mailbox lognam=aux_mbx, maxmsg=msg_c_size); END; IF .status neq SS$_NORMAL THEN BEGIN signal(.status); END; ! ! assign a channel and set the mode for the terminal - mode is reset at exit ! perform($assign ( chan = aux_tt_chan, devnam = $descriptor('SYS$COMMAND:'), mbxnam=aux_mbx)); ! ! Get the device characteristics. If the terminal is mounted then it is a ! DECnet terminal which we do not want to run on. ! If (status= $getdvi(efn=write_flag, chan = .aux_tt_chan, itmlst = uplit(word(4,Dvi$_devchar),devchar,0,0) )) then Begin perform($waitfr(efn=write_flag)); if .devchar[Dev$v_mnt] then Begin $dassgn(chan = .aux_tt_chan);aux_tt_chan = 0; Signal(aux_notnettrm); Lib$do_command(exit_command); End; End else Begin Signal(.status); End; ! ! sense and save the current terminal mode so it can be restored at exit ! perform($qiow( chan = .aux_tt_chan ,EFN=write_flag ,func = io$_sensemode ,iosb = iostat ,p1 = aux_mode_buf ,p2 = 12 )); ! ! Make sure that we are on a DECcrt if (.aux_mode_buf[d_char2] and tt2$m_deccrt) eql 0 then begin $dassgn(chan = .aux_tt_chan);aux_tt_chan = 0; signal(aux_notdeccrt); lib$do_command(Exit_Command); end; ! ! set terminal to escape and broadcast message ! Save current characteristics. ch$move(12,aux_mode_buf,aux_old_mode_buf); aux_mode_buf [d_char] = .aux_mode_buf [d_char] or tt$m_escape or tt$m_nobrdcst; aux_mode_buf [d_char2] = .aux_mode_buf [d_char2] or tt2$m_brdcstmbx; perform($qiow( chan = .aux_tt_chan ,EFN=write_flag ,func = io$_setmode ,iosb = iostat ,p1 = aux_mode_buf ,p2 = 12 )); reset_needed = 1; ! ! Get the clock interval from a logical name if defined. Begin Local_Descriptor(clock_value,63); Init_Descriptor(clock_value,63); If $trnlog(Lognam=Aux_Clock_Interval, Rsllen=Clock_Value_desc[Dsc$w_length], Rslbuf=Clock_Value_desc) eql Ss$_notran then Begin !Set default interval if no name. Ch$move(.Default_Interval[Dsc$w_length], .Default_Interval[Dsc$a_pointer], Ch$ptr(Clock_Value)); Clock_Value_Desc[Dsc$w_length] = .Default_Interval[Dsc$w_length]; End; ! ! Get the time interval we will be using for the clock. Perform($bintim(timbuf=Clock_Value_Desc,Timadr=Clock_Interval)); End; ! ! Display the top line aux_top_line(); ! ! Display the title if not done already aux_title(); ! ! Check the for the alarm symbol aux_check_alarm(); ! ! Set an attention ast on the mailbox. perform($qiow(chan =.mbx_chan, func=(io$_setmode or io$m_wrtattn), iosb=iostat, efn=mbx_flag, p1=read_ready_ast, p2=read_flag )); if not .iostat[0] then signal(.iostat[0]); ! ! read and execute ! until aux_read(prompt,command,command_display,keys) do; ! ! If symbol AUX_DEBUG is defined, then also show the command value if lib$get_symbol($descriptor('AUX_DEBUG'),aux_debug) then signal(aux_comvalue,1,command); ! ! Echo the line and turn off the keypad concat((command_display,aux_mode_off,command_display)); aux_echo_line(prompt,command_display); ! ! Get rid of the SYS$INPUT name if possible lib$delete_logical($descriptor('SYS$INPUT')); ! ! Save the last command aux_save_command(command); ! ! Wait for the display to complete perform($waitfr(efn=write_flag)); ! ! Now do the command return lib$do_command(command); END; !End of aux_main %sbttl 'Exit_handler' ROUTINE Exit_handler (exit_status,reset_needed) :NOVALUE = ! !++ ! FUNCTIONAL DESCRIPTION: ! This routine is called at exit time, if Reset_needed is 1 then ! we reset the terminal characteristics. ! ! FORMAL PARAMETERS: ! ! NONE ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! NONE ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN ! ! Save the last command memory aux_save_memory(); ! if .reset_needed then begin ! ! set terminal to noescape - restore terminal to original mode ! ! Leave width as the current width aux_old_mode_buf[d_pw] = .aux_mode_buf[d_pw]; perform($qiow( chan = .aux_tt_chan ,EFN=write_flag ,func = io$_setmode ,p1 = aux_old_mode_buf ,p2 = 12)); end; return; END; !End of Exit_handler %sbttl 'Aux_Read' Global ROUTINE Aux_Read( prompt : ref block[,byte], result : ref block[,byte], result_display : ref block[,byte], key_tables : ref vector[] ) = ! !++ ! FUNCTIONAL DESCRIPTION: ! Calls RD_PMT with an unwinding handler enabled. ! ! FORMAL PARAMETERS: ! ! prompt : Address of a descriptor to be used as the prompt. ! ! result : address of dynamic descriptor, to be set as the ! resulting DCL command. ! ! result_display : address of dynamic descriptor, to be set as the ! resulting display of the DCL command. ! ! key_tables : address of table of symbol tables. ! [ 0 ] : address of function key table. ! [ 1 ] : address of control key table. ! [ 2 ] : address of gold function key table. ! [ 3 ] : address of gold control key table. ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! 1 when result is a DCL command, 0 if someone signals unwinding. ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN local completed, ! Flag indicating a DCL command has been completed. return_terminates, local_prompt : dynamic_descriptor, keyboard_input : dynamic_descriptor, command : dynamic_descriptor, command_display : dynamic_descriptor ; enable unwinder; ! ! Set results to null free1_dx((.result)); free1_dx((.result_display)); ! ! Set Cursor position to null aux_l_cp = 0; ! do begin ! ! Free up the local strings. free1_dx((command)); free1_dx((command_display)); free1_dx((keyboard_input)); ! ! If we have something in the display buffer, ! Rebuild the prompt string concat((local_prompt,.prompt,.result_display,clear_line)); return_terminates = (.result_display[dsc$w_length] gtr 0); if .return_terminates then begin LOCAL bs_count, backspaces : dynamic_descriptor ; ! ! ! If current position is not the end of the string, ! append backspaces. bs_count = .result_display[dsc$w_length] - .aux_l_cp; if .bs_count gtr 0 then begin append((local_prompt,aux_bs(backspaces,.bs_count) )); free1_dx((backspaces)); end; end; ! ! Get some input until rd_pmt(command,command_display,keyboard_input,local_prompt,0, terminators,.key_tables,.return_terminates) do ; ! ! Overlay the keyboard input on top of what we have got so far. aux_overlay_string(aux_l_cp,.result,.result_display,keyboard_input); ! ! Got some input, if it is an internal command execute it ! otherwise concatenate it to the result if is_aux_command(command,command_display, .result,.result_display,.key_tables) then completed = 0 else begin ! ! Not an internal command, so concatenate things together. build_command(.result,.result_display,command,command_display); completed = 1; end; ! ! Now check to see if last character is a "-", if so, replace the "-" ! with a blank. ! And indicate the command is not completed. if .result[dsc$w_length] gtr 0 then begin local length ; length = .result[dsc$w_length] - 1; if ch$rchar(ch$ptr(.result[dsc$a_pointer],.length)) eql %c'-' then begin local lastposition ; lastposition = .result[dsc$w_length] -1; ch$wchar(%c' ',ch$ptr(.result[dsc$a_pointer],.lastposition)); ch$wchar(%c' ',ch$ptr(.result_display[dsc$a_pointer], .lastposition)); completed = 0; aux_l_cp = .result_display[dsc$w_length]; end; end; end until .completed and (.result[dsc$w_length] gtr 0); free1_dx((command)); free1_dx((local_prompt)); free1_dx((command_display)); ! ! Return success return 1; END; !End of Read %sbttl 'Is_aux_command' ROUTINE Is_aux_command ( cmd : ref block[,byte], cmd_display : ref block[,byte], result : ref block[,byte], result_display: ref block[,byte], key_tables : ref vector[] ) = ! !++ ! FUNCTIONAL DESCRIPTION: ! This routine checks to see if a command is an internal AUX command. ! if it is, it is executed otherwise return false. ! ! FORMAL PARAMETERS: ! ! cmd : address of a dynamic descriptor pointing at the ! command. ! cmd_display : address of a dynamic descriptor pointing at the ! displayable version of command. ! result : address of a dynamic descriptor pointing at the ! resulting command - possibly modified during the ! execution of an internal command. ! result_display : address of a dynamic descriptor pointing at the ! displayable version of result - possibly modified ! during the execution of an internal command. ! key_tables : address of a table of key symbol tables. ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! 1 if an aux command, 0 if not. ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN ! ! If first two characters are "$$" then this is an AUX command if .cmd[dsc$w_length] gtr 2 then begin bind first_2 = .cmd[dsc$a_pointer] : word; if .first_2 eql %ascii'$$' then ! ! Check for an AUX command, if an internal command then we ! will execute it return aux_commands(.cmd,.cmd_display,.result,.result_display, .key_tables); end; return 0; END; !End of Is_aux_command %sbttl 'Rd_pmt' routine rd_pmt ( terminator_value : ref block[,byte], terminator_value_display : ref block[,byte], keyboard_input : ref block[,byte], prompt : ref block[,byte], no_prompt, terminators : ref vector[2], key_tables : ref vector[4], return_terminates ) = ! ! Function: Reads the terminal and decodes the terminator character. ! ! Formal Parameters: ! terminator_value: address of a dynamic descriptor - returned as the ! value associated with the terminator. ! terminator_value_display: address of a dyanmic descriptor - returned ! as the display associated with the terminator. ! keyboard_input : address of a dynamic descriptor - returned as the ! data read from the keyboard. ! prompt : address of a prompt string descriptor. ! no_prompt: flag indicating whether or not a prompt is needed. ! terminators: address of a terminator list, if 0 then use default ! terminators. ! key_tables: address of a vector of addresses of symbol tables. ! [ 0 ] : address of function key table. ! [ 1 ] : address of control key table. ! [ 2 ] : address of gold function key table. ! [ 3 ] : address of gold control key table. ! Return_terminates: Flag indicating whether or not a terminates ! input even if nothing read. ! begin bind control_table = .key_tables[1] : symbol_table ; local prompt_written, iostat : vector[4,word] volatile ; local_descriptor(in_buf,256); init_descriptor(in_buf,0); ! ! Do reads until one of the terminators indicates it is ok to exit. do begin ! ! post a read prompt_written = 0; ! if .no_prompt then perform($qiow( chan = .aux_tt_chan ,EFN=read_flag ,iosb = iostat ,func = (io$_readvblk or io$m_trmnoecho or io$M_NoFiltr) ,p1 = .in_buf_desc[dsc$a_pointer] ,p2 = 256 ,p4 = .terminators )) else begin local typeahdcnt : vector[4,word]; perform($clref(efn=read_flag)); ! ! Check to see if any typeahead has already occured perform($qiow(chan=.aux_tt_chan, efn=typeahead_flag, iosb=iostat, func=(io$_sensemode or io$m_typeahdcnt), p1=typeahdcnt )); if not .iostat[0] then signal(.iostat[0]); ! ! If none has occured then if .typeahdcnt[0] eql 0 then begin ! ! Write the prompt, done this way so that the time display ! can do its thing without being interrupted by the read perform($qio(chan=.aux_tt_chan, efn=write_flag, iosb=iostat, func=(io$_writevblk or io$m_noformat or io$m_enablmbx), p1=.prompt[dsc$a_pointer], p2=.prompt[dsc$w_length] )); prompt_written = 1; ! ! Start the time display time_display_ast(); ! ! Wait for the input to come perform($waitfr(efn=read_flag)); end; ! ! Do the actual read if .prompt_written then perform($qiow(chan = .aux_tt_chan ,iosb = iostat ,func = (io$_readlblk or io$m_dsablmbx or io$m_trmnoecho or io$m_nofiltr) ,efn = read_flag ,p1 = .in_buf_desc[dsc$a_pointer] ,p2 = 256 ,p4 = .terminators )) else perform($qiow(chan = .aux_tt_chan ,iosb = iostat ,func = (io$_readprompt or io$m_dsablmbx or io$m_trmnoecho or io$m_nofiltr) ,efn = read_flag ,p1 = .in_buf_desc[dsc$a_pointer] ,p2 = 256 ,p4 = .terminators ,p5 = .prompt[dsc$a_pointer] ,p6 = .prompt[dsc$w_length] )); if not .iostat[0] then signal(.iostat[0]); end; ! ! Append current input to buffer in_buf_desc[dsc$w_length] = .iostat[1]; append((.keyboard_input,in_buf_desc)); ! ! Update IOSTAT so that it correctly points to the terminator if ! we have appended data to the buffer iostat[1] = .keyboard_input[dsc$w_length]; end until ( selectone .iostat[2] of set [escape] : decode_escape( .terminator_value, .terminator_value_display, .terminators, iostat, in_buf, .key_tables ); [cr] : ! ! Concatenate the received data to the commands begin free1_dx((.terminator_value)); ! Nothing for the terminator. free1_dx((.terminator_value_display)); (.keyboard_input[dsc$w_length] gtr 0) or .return_terminates ! Only if we got something end; [ctrl_z] : begin copy_dx((.terminator_value,$descriptor('Exit'))); copy_dx((.terminator_value_display,.terminator_value)); 1 ! Input completed end; [0 to delete ] : decode_controls( .terminator_value, .terminator_value_display, .terminators, iostat, control_table ); [otherwise] : begin 0 ! Continue with the prompting. end; tes ); return ss$_normal; end; %sbttl 'Decode_escape' Routine decode_escape( cmd : ref block[,byte], cmd_display: ref block[,byte], terminators, iostat : ref vector[4,word], in_buf : ref vector[,byte], key_tables: ref vector[4] ) = !++ ! FUNCTIONAL DESCRIPTION: ! This routine is called to decode the escape key sequences. ! ! FORMAL PARAMETERS: ! ! cmd : address of a dynamic descriptor which is returned ! as the command associated with the key - ! new stuff is concatenated to cmd. ! cmd_display: address of a dynamic descriptor which is returned ! as the display associated with the key - ! new stuff is concatenated to cmd_display. ! terminators: address of a terminator list, if 0 then use default ! terminators. ! iostat : address of the io status block associated with this ! reading. ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! 1 if input is complete, 0 if to continue reading. ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN external literal aux_unwind ; bind escape_sequence = in_buf[.iostat[1]+1] : vector[,byte]; bind escape_table = .key_tables[0] : symbol_table ; local our_key_tables : vector[4], status; ! ! If next character after the escape is not a 'O' or a '[' then signal ! an error selectone .escape_sequence[0] of set [ %c'O', %c'[' ] : ! ! Now check for PF1 - if found, then recursivly call rd_pmt using ! the gold_escape_keys table begin if .escape_sequence[1] neq %c'P' then begin local table_index; ! ! Now search the table for the specified key, ! if not in the table ignore this sequence. if (table_index=aux_search_table(.escape_sequence[1],escape_table)) lss 0 then return 0 ! ! Found symbol in table, get the associated values else if (status=get_symbols(.cmd,.cmd_display,.table_index, escape_table)) eql lib$_nosuchsym then begin signal(aux_keynotdef,1, .escape_table[.table_index,sym_a_command]); signal(aux_unwind); end; end else begin ! ! Routine to recursivly call Rd_pmt with an unwind handler routine recursive_rd_pmt(cmd_desc,display_desc,terminator_desc, key_table) = begin local kb : dynamic_descriptor, kb_addr : volatile, cmd_addr : volatile, display_addr: volatile ; enable cleanup(cmd_addr,display_addr,kb_addr); cmd_addr = .cmd_desc; display_addr = .display_desc; kb_addr = kb; return rd_pmt( .cmd_desc, .display_desc, kb, 0, 1, .terminator_desc, .key_table ); end; ! End of Recurive_Rd_pmt ! ! Recursively call Rd_pmt, if unwound,return false ! Build our own key table as only the gold tables our_key_tables[0] = our_key_tables[2] = .key_tables[2]; our_key_tables[1] = our_key_tables[3] = .key_tables[3]; status = recursive_rd_pmt(.cmd,.cmd_display,.terminators, our_key_tables); end; end; [ escape ] : begin signal(aux_unwind); status = 0; end; [ otherwise ] : begin signal(aux_invesc,1,.escape_sequence[0]); status = 0; end; tes; return .status; END; !End of Decode_escape %sbttl 'Decode_controls' Routine decode_controls( cmd : ref block[,byte], cmd_display: ref block[,byte], terminators, iostat : ref vector[4,word], control_table: ref symbol_table ) = !++ ! FUNCTIONAL DESCRIPTION: ! This routine is called when a terminator other than escape or return ! is used. ! ! FORMAL PARAMETERS: ! ! cmd : address of a dynamic descriptor which is returned ! as the command associated with the key - ! new stuff is concatenated to cmd. ! cmd_display: address of a dynamic descriptor which is returned ! as the display associated with the key - ! new stuff is concatenated to cmd_display. ! no_prompt: flag indicating whether or not a prompt is needed. ! terminators: address of a terminator list, if 0 then use default ! terminators. ! iostat : address of the io status block associated with this ! reading. ! control_table: address of the symbol table to be used when decoding ! the control characters. ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! 1 if input is complete, 0 if to continue reading. ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN LOCAL status : initial(0), table_index ; ! ! ! Search the table for an associated control character, ignore if ! not found if (table_index = aux_search_table(.iostat[2], .control_table)) eql -1 then return 0 else if (status = get_symbols(.cmd, .cmd_display, .table_index, .control_table) ) eql lib$_nosuchsym then ! ! If error is no such symbol, then let the world know about it. ! Unwind the stack to top level rd_pmt incase we were called in response ! to a GOLD key. begin signal(aux_keynotdef,1,.control_table[.table_index,sym_a_command]); signal(aux_unwind); end; return .status; END; !End of Decode_controls %sbttl 'Aux_Search_table' Global ROUTINE Aux_Search_table (char : byte ,table : ref symbol_table) = !++ ! FUNCTIONAL DESCRIPTION: ! This routine searches the given table for the specified character. ! If found, the table index is returned otherwise -1 is returned. ! ! FORMAL PARAMETERS: ! ! char - the character to look for. ! table - address of a symbol table. ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! 0-maxtableindex if successfull, -1 otherwise ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN local i : initial(0); return ( do if .table[.i,sym_b_char] eql .char then exitloop .i until .table[(i = .i + 1),sym_b_char] eql 0 ); END; !End of Search_table %sbttl 'Get_symbols' ROUTINE Get_symbols ( command : ref block[,byte], display : ref block[,byte], table_index: long, table : ref symbol_table ) = ! !++ ! FUNCTIONAL DESCRIPTION: ! This routine fetches the values associated with the symbols associated ! with a key. ! ! FORMAL PARAMETERS: ! ! command : address of a dynamic descriptor to receive the command ! symbol. ! display : address of a dynamic descriptor to receive the display ! symbol. ! table_index: value of index into the symbol table. ! table : address of the symbol table. ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! ss$_normal if found, lib$_nosuchSym if symbol is not defined, otherwise ! is other error code associated with lib$get_symbol. ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN local status; ! ! Get the key definition status= lib$get_symbol(.table[.table_index,sym_a_command],.command); ! ! If defined then look up the associated text if .status eql ss$_normal then begin ! ! Get associated text if possible otherwise subsitute the actual ! key value. if not lib$get_symbol(.table[.table_index,sym_a_display],.display) then copy_dx((.display,.command)); end; return .status; END; !End of Get_symbols %sbttl 'Error_handler' ROUTINE Error_handler (signal_array,mechanism_array) = ! !++ ! FUNCTIONAL DESCRIPTION: ! This handler will cause the message to be displayed on line 23 ! in bold mode if we have gotten assigned to a terminal. If the ! error severity is error or greater we will exit. ! ! FORMAL PARAMETERS: ! ! signal_array : address of the standard VMS signal array. ! mechanism_array : address of the standard VMS mechanism array. ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! NONE ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN map signal_array : ref vector[], mechanism_array : ref vector[] ; bind sts = signal_array[1] : block[1] ; ! ! If status is SS$_BADESCAPE, then change the severity to Warning if .sts eql ss$_badescape then sts[sts$v_severity] = sts$k_warning; ! ! If status is less than error then just continue ! ! Display the message but do not pass the PC & PSL to PUTMSG signal_array[0]=.signal_array[0]-2; $putmsg( facnam = $descriptor('AUX'), msgvec = .signal_array, actrtn = ( if .aux_tt_chan eql 0 then 0 else write_error ) ); if .sts[sts$v_success] or .sts[sts$v_severity] lss sts$k_error then return ss$_continue else return ss$_resignal; END; !End of Error_handler %sbttl 'Write_error' ROUTINE Write_error (err_desc) = ! !++ ! FUNCTIONAL DESCRIPTION: ! This routine writes an error message ! ! FORMAL PARAMETERS: ! ! err_desc : address of a message descriptor ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! 0 so that $putmsg does not put it anywhere else ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN own display_line : dynamic_descriptor ; map err_desc : ref block[,byte]; concat((display_line, save_cursor, region2_23, line23, bold_off, wrap_on, scroll, reverse, .err_desc, wrap_off, bold_on, region2_24, restore_cursor )); perform($qiow( chan=.aux_tt_chan, func=(io$_writelblk or io$m_noformat), efn=write_flag, p1=.display_line[dsc$a_pointer], p2=.display_line[dsc$w_length] )); return 0; END; !End of Write_error %sbttl 'Build_command' ROUTINE Build_command ( result : ref block[,byte], result_display : ref block[,byte], terminator_value : ref block[,byte], terminator_value_display: ref block[,byte] ) :NOVALUE = !++ ! FUNCTIONAL DESCRIPTION: ! This routine builds the command string. The terminator values are ! prefixed to the current results. ! ! ! FORMAL PARAMETERS: ! ! result : address of a dynamic descriptor, Returned as the ! command string. ! result_display : address of a dynamic descriptor, Returned as the ! displayable version of the command string. ! terminator_value: address of a descriptor pointing at the new command ! value. ! terminator_value_display: address of a descriptor pointing at the ! new command display value. ! ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! NONE ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN ! ! Put the terminator value in front of what we already have if there ! is anything there if .terminator_value[dsc$w_length] gtr 0 then begin if .result[dsc$w_length] gtr 0 then concat((.result,.terminator_value,blank,.result)) else copy_dx((.result,.terminator_value)); if .result_display[dsc$w_length] gtr 0 then concat((.result_display,.terminator_value_display,blank, .result_display)) else copy_dx((.result_display,.terminator_value_display)); end; return; END; !End of Build_command %sbttl 'Time_display_ast' ROUTINE Time_display_ast :NOVALUE = ! !++ ! FUNCTIONAL DESCRIPTION: ! This routine displays the current time at row 1, column TT_Width-8 ! It sets a timer so that it executes once a second. ! ! FORMAL PARAMETERS: ! ! NONE ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! NONE ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN bind time_pos = static_descriptor(%char(escape),'[1;'); own display_line : dynamic_descriptor ; local_descriptor(column,4); local_descriptor(time,20); init_descriptor(time,20); init_descriptor(column,4); ! ! Format the time string perform($fao(static_descriptor('!8%T'), time_desc[dsc$w_length], time_desc, 0 )); ! ! Format the column position perform($fao(static_descriptor('!SBH'), column_desc[dsc$w_length], column_desc, .aux_mode_buf[d_pw]-8 )); concat((display_line, save_cursor, (if .aux_l_alarm then blink else reverse), time_pos, column_desc, time_desc, bold_off, bold_on, restore_cursor)); ! ! And display it perform($qio(chan=.aux_tt_chan, func=(io$_writelblk or io$m_noformat), efn=time_flag, p1=.display_line[dsc$a_pointer], p2=.display_line[dsc$w_length] )); ! ! If time stats are being displayed do the necessary calculations if .Aux_L_Statistics then begin Own current_cpu ; Builtin emul !Used to convert CPUtime to timevalue ; bind c100000 = uplit(100000),!Used to convert CPUtime c0 = uplit(0), !... get_current_cpu = uplit(word(4,Jpi$_cputim),current_cpu,0,0) ; Local Current_Time : Vector[2], Idle_Time : Vector[2], last_command_elapsed: Vector[2], last_cpu_time : vector[2], current_cpu_time : vector[2], last_command_cpu : long ; Local_Descriptor(Line,80); Init_Descriptor(Line,80); perform($gettim(timadr= Current_Time)); ! ! get current cpu time perform($getjpi(itmlst=get_current_cpu)); ! ! Compute Idle time quad_subtract(Aux_Q_Start_Time,Current_Time,Idle_Time); ! ! Compute last command cpu time last_command_cpu = .aux_l_start_cpu - .aux_l_end_cpu; ! ! Compute last command elapsed time quad_subtract(Aux_q_end_time,Aux_q_start_time,last_command_elapsed); ! ! Convert CPU times to displable quantities emul(c100000,current_cpu,c0,current_cpu_time); emul(c100000,last_command_cpu,c0,last_cpu_time); ! Format the line. Perform($Fao($Descriptor( 'Idle:!8%T TotalCpu:!%T LastCommand Cpu:!%T Elapsed:!8%T'), Line_Desc[Dsc$W_length], Line_Desc, Idle_Time, current_cpu_time, last_cpu_time, last_command_elapsed )); concat((display_line, save_cursor, reverse, Line2, Line_Desc, bold_off, bold_on, restore_cursor)); ! ! And display it perform($qio(chan=.aux_tt_chan, func=(io$_writelblk or io$m_noformat), efn=time_flag, p1=.display_line[dsc$a_pointer], p2=.display_line[dsc$w_length] )); end; ! ! Reschedule ourselves for one second hence perform($setimr(daytim=clock_interval,astadr=time_display_ast)); END; !End of Time_display_ast %sbttl 'Read_ready_ast' ROUTINE Read_ready_ast (completed_flag) :NOVALUE = ! !++ ! FUNCTIONAL DESCRIPTION: ! This ast is called when we get notified of input from the terminal. ! We cancel the timer and set the specified flag. ! ! FORMAL PARAMETERS: ! ! completed_flag - Value of the event flag to be set. ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! NONE ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN macro msg_w_type = 0,0,16,0 %, msg_w_brdcstlen = 20,0,16,0 %, msg_t_brdcstmsg = 22,0,0,0 % ; own display_line : dynamic_descriptor ; local message : block[msg_c_size,byte], iostat : io_status_block ; ! ! Read the mailbox message perform($qiow(chan=.mbx_chan, func = (io$_readlblk or io$m_now), efn = mbx_flag, iosb = iostat, p1 = message, p2 = msg_c_size )); ! ! If message is a broadcast message then display it if .message[msg_w_type] eql msg$_trmbrdcst then begin local msg_desc : vector[2]; msg_desc[0] = .message[msg_w_brdcstlen]; msg_desc[1] = message[msg_t_brdcstmsg]; ! ! If message contains any escape codes, then all we want to ! do is set the scrolling region if ch$fail(ch$find_ch(.message[msg_w_brdcstlen], message[msg_t_brdcstmsg],%char(escape))) then concat((display_line, save_cursor,region2_23,reverse,wrap_on,line23,scroll, msg_desc,wrap_off,bold_off,bold_on,region2_24, restore_cursor )) else concat((display_line, save_cursor,region2_23,reverse,wrap_on,msg_desc,wrap_off, bold_off,bold_on,region2_24,restore_cursor )); perform($qio( chan = .aux_tt_chan, func = (io$_writelblk or io$m_noformat), iosb = iostat, efn = write_flag, p1 = .display_line[dsc$a_pointer], p2 = .display_line[dsc$w_length] )); end else if .message[msg_w_type] eql msg$_trmunsolic then begin ! ! Cancel the time display routine perform($cantim()); ! ! Set the specified flag perform($setef(efn=.completed_flag)); end; ! ! Renable our ast. perform($qiow(chan =.mbx_chan, func=(io$_setmode or io$m_wrtattn), iosb=iostat, efn=mbx_flag, p1=read_ready_ast, p2=.completed_flag )); if not .iostat[iosb_w_status] then signal(.iostat[iosb_w_status]); return; END; !End of Read_ready_ast %sbttl 'Aux_Echo_line' Global ROUTINE Aux_Echo_line (prompt,display_desc) :NOVALUE = ! !++ ! FUNCTIONAL DESCRIPTION: ! This routine echos the specified line on using the specified prompt ! string. ! ! FORMAL PARAMETERS: ! ! prompt : Address of a descriptor pointing at the prompt. ! display_desc : Address of a descriptor pointing at the text to be ! displayed. ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! NONE ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN own display_line : Dynamic_descriptor ; ! concat((display_line, line24, bold_on, .prompt, wrap_on, .display_desc, clear_line, static_descriptor(%char(cr)), wrap_off, bold_off)); perform($qio( chan = .aux_tt_chan, efn = write_flag, func = (io$_writelblk or io$m_noformat), p1 = .display_line[dsc$a_pointer], p2 = .display_line[dsc$w_length] )); return; END; !End of Aux_Echo_line %sbttl 'Aux_top_line' Global ROUTINE Aux_top_line :NOVALUE = ! !++ ! FUNCTIONAL DESCRIPTION: ! This routine displays the top line of the screen, causes a scroll on ! line 24 as well. ! ! FORMAL PARAMETERS: ! ! NONE ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! NONE ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN own uic : vector[2,word], username : allocate_string(12), disk_name : allocate_string(64), disk_name_desc : descriptor(disk_name,64), node_name : allocate_string(64), node_name_desc : descriptor(node_name,64), default : allocate_string(nam$c_maxrss), default_desc : descriptor(default,nam$c_maxrss), top_line : allocate_string(256), top_desc : descriptor(top_line,256) ; bind getjpi_list = uplit( word(4,jpi$_uic),uic,0, word(12,jpi$_username),username,0, 0 ) ; Local status ; own display_line : dynamic_descriptor ; ! ! ! Get uic and username perform($getjpi(itmlst=getjpi_list)); ! ! Get the default default_desc[dsc$w_length] = nam$c_maxrss; perform(sys$setddir(0,default_desc[dsc$w_length],default_desc)); ! ! Translate the node name node_name_desc[dsc$w_length] = 64; status=$trnlog(lognam=$descriptor('SYS$NODE'), rsllen=node_name_desc[dsc$w_length], rslbuf=node_name_desc ); if .status eql ss$_NoTran then node_name_desc[dsc$w_length] = 0 else if .status neq ss$_Normal then begin node_name_desc[dsc$w_Length] = 0; signal(.status); end; ! ! Translate the disk name disk_name_desc[dsc$w_length] = 64; perform($trnlog(lognam=$descriptor('SYS$DISK'), rsllen=disk_name_desc[dsc$w_length], rslbuf=disk_name_desc )); ! ! Format the default display line top_desc[dsc$w_length] = 256; perform($fao(static_descriptor('User:!ADDefault:!AS!AS!AS [!3OW,!3OW]'), top_desc[dsc$w_length], top_desc, 12,username, node_name_desc, disk_name_desc, default_desc, .uic[1],.uic[0] )); concat((display_line, top_stuff, top_desc, clear_line, line24, scroll, aux_mode )); ! ! Display the top line perform($qio(chan=.aux_tt_chan, EFN=write_flag, func=(io$_writevblk or io$m_noformat or io$m_canctrlo), p1=.display_line[dsc$a_pointer], p2=.display_line[dsc$w_length], p4 = 0 )); return; END; !End of Aux_top_line %sbttl 'Cleanup' Routine cleanup(signal_array,mech_array,enable_array) = !++ ! FUNCTIONAL DESCRIPTION: ! ! If signal is SS$_UNWIND then we do cleanup of dynamic strings. ! ! FORMAL PARAMETERS: ! ! enable_array[0] : Number of strings to be freed up. ! enable_array[n] : Address of Address of string to be freed up. ! ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! NONE ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN map signal_array : ref vector[], mech_array : ref vector[], enable_array : ref vector[] ; return (if .signal_array[1] eql ss$_unwind then begin ! ! Free strings if used incr i from 1 to .enable_array[0] do if ..enable_array[.i] neqa 0 then free1_dx(( ..enable_array[.i] )); ss$_continue end else ss$_resignal ); END; !End of Cleanup %sbttl 'Unwinder' ROUTINE Unwinder (signal_array,mech_array) = ! !++ ! FUNCTIONAL DESCRIPTION: ! This handler will cause the stack to be unwound if the signal is ! AUX_UNWIND or SS$_BADESCAPE ! ! FORMAL PARAMETERS: ! ! NONE ! ! IMPLICIT INPUTS: ! ! NONE ! ! IMPLICIT OUTPUTS: ! ! NONE ! ! ROUTINE VALUE: ! COMPLETION CODES: ! ! NONE ! ! SIDE EFFECTS: ! ! NONE ! !-- BEGIN map signal_array : ref vector[], mech_array : ref vector[] ; external literal aux_unwind; return (if (.signal_array[1] eql aux_unwind) or (.signal_array[1] eql ss$_badescape) then begin ! ! Change function result to 0 mech_array[3] = 0; ! ! And unwind setunwind(); ss$_continue end else ss$_resignal ); END; !End of Unwinder END !End of module ELUDOM