-+-+-+-+-+-+-+-+ START OF PART 40 -+-+-+-+-+-+-+-+ X %immed prvprv : integer := %immed 0) : integer; X external; X`20 X BEGIN X priv_mask.low := %X'10000000'; `7B SYSPRV `7D X priv_mask.high := %X'00000000'; X $setprv(enbflg:=switch_val,privs:=priv_mask); X END; X `20 X `5Bexternal(LIB$DO_COMMAND)`5D function lib$do_command( X %descr msg_str : vtype) : integer; external; X X`7B Spawn a shell `7D X `5Bexternal(LIB$SPAWN)`5D function shell_out( X command_str : integer := %immed 0; X input_file: integer := %immed 0; X output_file : integer := %immed 0; X flags : integer := %immed 0; X process_name : integer := %immed 0; X process_id: integer := %immed 0; X comp_status : integer := %immed 0; X comp_efn : integer := %immed 0; X comp_astadr : integer := %immed 0; X comp_astprm : integer := %immed 0 ) : integer; X external; X`20 X`20 X`7B Turn off Control-Y `7D X`5Bpsect(io$code)`5D procedure no_controly; X var X bit_mask : unsigned; X`20 X `5Bexternal(LIB$DISABLE_CTRL)`5D function y_off( X var mask : unsigned; X old_mask : integer := %immed 0) : integer; X external; X`20 X BEGIN X bit_mask := %X'02000000'; `7B No Control-Y `7D X y_off(mask:=bit_mask); X END; X`20 X`20 X`7B Turn on Control-Y `7D X`5Bpsect(io$code)`5D procedure controly; X var X bit_mask : unsigned; X`20 X `5Bexternal(LIB$ENABLE_CTRL)`5D function y_on( X var mask : unsigned; X old_mask : integer := %immed 0) : integer; X external; X`20 X BEGIN X bit_mask := %X'02000000'; `7B Control-Y `7D X y_on(mask:=bit_mask); X END; X`20 X`20 X`7B Dump IO to buffer X NOTE: Source is PUTQIO.MAR `7D X procedure put_buffer ( X %ref out_str : varying `5Ba`5D of char; X %immed row : integer; X %immed col : integer ); X external; X`20 X`20 X`7B Dump the IO buffer to terminal X NOTE: Source is PUTQIO.MAR `7D X procedure put_qio; X external; X`20 X`20 X`5Bpsect(io$code)`5D procedure exit; X`20 X`7B Immediate exit from program `7D X `5Bexternal(SYS$EXIT)`5D function $exit( X %immed status : integer := %immed 1) : integer; X external; X`20 X BEGIN X controly; `7B Turn control-Y back on `7D X put_qio; `7B Dump any remaining buffer `7D X $exit; `7B exit from game `7D X END; X`20 X`20 X`7B Initializes I/O channel for use with INKEY `7D X`5Bpsect(io$code)`5D procedure init_channel; X type X ttype = packed array `5B1..3`5D of char; X var X status: integer; X terminal : ttype; X`20 X `5Bexternal(SYS$ASSIGN)`5D function assign( X %stdescr terminal : ttype; X var channel : `5Bvolatile`5D integer; X acmode: integer := %immed 0; X mbxnam: integer := %immed 0) : integer; X external; X`20 X BEGIN X terminal := 'TT:'; X status := assign(terminal,channel); X if (not odd(status)) then X BEGIN X writeln('Channel could not be assigned '); X exit; X END X END; X`20 X`20 X`7B QIOW definition `7D X `5Basynchronous,external(SYS$QIOW)`5D function qiow_read( X %immed efn : integer := %immed 1; X %immed chan : integer; X %immed func : integer := %immed 0; X %immed isob : integer := %immed 0; X %immed astadr : integer := %immed 0; X %immed astprm : integer := %immed 0; X %ref get_char : `5Bunsafe`5D char := %immed 0; X %immed buff_len : integer := %immed 0; X %immed delay_time : integer := %immed 0; X %immed p4 : integer := %immed 0; X %immed p5 : integer := %immed 0; X %immed p6 : integer := %immed 0) : integer; X external; X`20 X`7B Gets single character from keyboard and returns `7D X`5Bpsect(io$code)`5D procedure inkey(var getchar : char); X var X status: integer; X BEGIN X put_qio; `7B Dump IO buffer XAllow device driver to catch up XNOTE: Remove or comment out for VMS 4.0 or greater X set_time(bintime:=IO$BIN_PAUSE); X hibernate; XNow read `7D X qiow_read(chan:=channel, X func:=IO$MOR_INPUT, X get_char:=getchar, X buff_len:=1 ); X msg_flag := false; X END; X`20 X`7B Gets single character from keyboard and returns `7D X`5Bpsect(io$code)`5D procedure inkey_delay ( X var getchar : char; X delay : integer ); X var X status: integer; X BEGIN X put_qio; `7B Dump the IO buffer XAllow device driver to catch up XNOTE: Remove or comment out for VMS 4.0 or greater X set_time(bintime:=IO$BIN_PAUSE); X hibernate; XNow read `7D X getchar := null; `7B Blank out return character `7D X qiow_read(chan:=channel, X func:=IO$MOR_DELAY, X get_char:=getchar, X buff_len:=1, X delay_time:=delay ); X END; X`20 X`20 X`7B Flush the buffer `7D X`5Bpsect(io$code)`5D procedure flush; X BEGIN X`7B Allow device driver to catch up X NOTE: Remove or comment out for VMS 4.0 or greater X set_time(bintime:=IO$BIN_PAUSE); X hibernate; XNow flush `7D X qiow_read(chan:=channel,func:=IO$MOR_IPURGE); X END; X`20 X`20 X`7B Flush buffer before input `7D X`5Bpsect(io$code)`5D procedure inkey_flush(var x : char); X BEGIN X put_qio; `7B Dump the IO buffer `7D X if (not(wizard)) then flush; X inkey(x); X END; X`20 X`20 X`7B Retrieves foreign string input with game command `7D X `5Bexternal(LIB$GET_FOREIGN)`5D procedure get_foreign( X %descr msg_str : vtype; X %descr prompt : vtype := %immed 0; X %ref len : integer := %immed 0); X external; X`20 X`20 X`7B Clears given line of text `7D X`5Bpsect(io$code)`5D procedure erase_line ( row,col : integer ); X BEGIN X put_buffer(cursor_erl,row,col); X END; X`20 X`20 X`7B Clears screen at given row, column `7D X`5Bpsect(io$code)`5D procedure clear(row,col : integer); X var X i1 : integer; X BEGIN X for i1 := 2 to 23 do used_line`5Bi1`5D := false; X put_buffer(cursor_erp,row,col); X put_qio; `7B Dump the Clear Sequence `7D X END; X`20 X`20 X`7B Outputs a line to a given interpolated y,x position `7D X`5Bpsect(io$code)`5D procedure print( X str_buff : varying`5Ba`5D of char; X row : integer; X col : integer ); X BEGIN X row := row - panel_row_prt;`7B Real co-ords convert to screen position Vs `7D X col := col - panel_col_prt; X used_line`5Brow`5D := true; X put_buffer(str_buff,row,col) X END; X`20 X`20 X`7B Outputs a line to a given y,x position `7D X`5Bpsect(io$code)`5D procedure prt( X str_buff : varying`5Ba`5D of char; X row : integer; X col : integer ); X BEGIN X put_buffer(cursor_erl+str_buff,row,col); X END; X X`20 X`7B Outputs message to top line of screen `7D X`5Bpsect(io$code)`5D procedure msg_print(str_buff : varying`5Ba`5D of char V); X var X old_len : integer; X in_char : char; X`09out_val`09 : vtype; X BEGIN X if (msg_flag and more_flag) then X BEGIN X old_len := length(old_msg) + 1; X put_buffer(' -more-',msg_line,old_len); X repeat X inkey(in_char); X until (ord(in_char) in `5B3,13,25,26,27,32`5D); X END; X put_buffer(cursor_erl+str_buff,msg_line,msg_line); X old_msg := str_buff; X msg_flag := true; X END; X`20 X`20 X`7B Prompts (optional) and returns ord value of input char X Function returns false if ,CNTL/(Y,C,Z) is input `7D X`5Bpsect(io$code)`5D function get_com ( X prompt : varying`5Ba`5D of char; X var command : char ) : boolean; X var X com_val : integer; X BEGIN X if (length(prompt) > 1) then prt(prompt,1,1); X inkey(command); X com_val := ord(command); X CASE com_val of X 3,25,26,27: get_com := false; X otherwise get_com := true; X END; X erase_line(msg_line,msg_line); X msg_flag := false; X END; X`20 X`20 X`7B Gets a string terminated by X Function returns false if ,CNTL/(Y,C,Z) is input `7D X`5Bpsect(io$code)`5D function get_string ( X var in_str: varying`5Ba`5D of char; X row,column,slen : integer ) : boolean; X var X start_col,END_col,i1 : integer; X x : char; X tmp : vtype; X flag,abort : boolean; X`20 X BEGIN X abort := false; X flag := false; X in_str:= ''; X put_buffer(pad(in_str,' ',slen),row,column); X put_buffer('',row,column); X start_col := column; X END_col := column + slen - 1; X repeat X inkey(x); X CASE ord(x) of X 3,25,26,27 : abort := true; X 13 : flag := true; X 127 : BEGIN X if (column > start_col) then X BEGIN X column := column - 1; X put_buffer(' '+chr(8),row,column); X in_str := substr(in_str,1,length(in_str)-1); X END; X END; X otherwise BEGIN X tmp := x; X put_buffer(tmp,row,column); X in_str := in_str + tmp; X column := column + 1; X if (column > END_col) then X flag := true; X END; X END; X until (flag or abort); X if (abort) then X get_string := false X else X BEGIN `7B Remove trailing blanks `7D X i1 := length(in_str); X if (i1 > 1) then X BEGIN X while ((in_str`5Bi1`5D = ' ') and (i1 > 1)) do X i1 := i1 - 1; X in_str := substr(in_str,1,i1); X END; X get_string := true; X END; X END; X`20 X`20 X`7B Return integer value of hex string `7D X`5Bpsect(io$code)`5D function get_hex_value(row,col,slen : integer) : intege Vr; X type X pack_type = packed array `5B1..9`5D of char; X var X bin_val : integer; X tmp_str : vtype; X pack_str : pack_type; X`20 X `5Basynchronous,external(OTS$CVT_TZ_L)`5D function convert_hex_to_bin( X %stdescr hex_str : pack_type; X %ref hex_val : integer; X %immed val_size : integer := %immed 4; X %immed flags : integer := %immed 1) : integer; X external; X`20 X BEGIN X bin_val := 0; X get_hex_value := 0; X if (get_string(tmp_str,row,col,slen)) then X if (length(tmp_str) <= 8) then X BEGIN X pack_str := pad(tmp_str,' ',9); X if (odd(convert_hex_to_bin(pack_str,bin_val))) then X get_hex_value := bin_val; X END; X END; X`20 X`20 X`20 X`7B Pauses for user response before returning `7D X`5Bpsect(io$code)`5D procedure pause(prt_line : integer); X var X dummy : char; X BEGIN X prt('`5BPress any key to continue`5D',prt_line,24); X inkey(dummy); X erase_line(prt_line,1); X END; X`20 X`20 X`5Bpsect(io$code)`5D procedure pause_exit(prt_line : integer); X var X dummy : char; X BEGIN X prt('`5BPress any key to continue, or -Z to exit`5D',prt_line V,11); X inkey(dummy); X CASE ord(dummy) of X 3,25,26 : Begin X erase_line(prt_line,1); X exit; X End; X otherwise; X END; X erase_line(prt_line,1); X END; X`20 X`7B Prints a line to the screen, time efficient `7D X`5Bpsect(io$code)`5D procedure dprint(str : vtype; row : integer); X var X i1,i2,nblanks,xpos : integer; X prt_str : vtype; X BEGIN X prt_str := ''; X nblanks := 0; X xpos := 0; X for i1 := 1 to length(str) do X BEGIN X if (str`5Bi1`5D = ' ') then X BEGIN X if (xpos > 0) then X BEGIN X nblanks := nblanks + 1; X if (nblanks > 5) then X BEGIN X nblanks := 0; X put_buffer(prt_str,row,xpos); X prt_str := ''; X xpos := 0; X END X END; X END X else X BEGIN X if (xpos = 0) then xpos := i1; X if (nblanks > 0) then X BEGIN X for i2 := 1 to nblanks do X prt_str := prt_str + ' '; X nblanks := 0; X END; X prt_str := prt_str + str`5Bi1`5D; X END; X END; X if (xpos > 0) then X put_buffer(prt_str,row,xpos); X END; X X`20 X`7B Returns the image path for BOSS X Path is returned in a VARYING`5B80`5D of char `7D X`5Bpsect(io$code)`5D procedure get_paths; X type X word = 0..65535; X rec_jpi = record X pathinfo : packed record X pathlen: word; X jpi$_imagname: word; X END; X ptr_path : `5Epath; X ptr_pathlen : `5Einteger; X ENDlist : integer X END; X path = packed array `5B1..128`5D of char; X var X i1 : integer; X tmp_str : path; X image_path: vtype; X flag: boolean; X`20 X`7B Call JPI and return the image path as a packed 128 `7D +-+-+-+-+-+-+-+- END OF PART 40 +-+-+-+-+-+-+-+-