{ PICSKIO.INC - Pascal Integrated Communications System Kernel - I/O routines } { 6/11/87 Ver 1.6 Copyright 1987 by Les Archambault} procedure log(activity: byte; text: Str20); { Update log file } begin seek(logr_file, FileSize(logr_file)); GetTAD(logr_rec.date); logr_rec.action := activity; if valid_pw then logr_rec.user := user_loc else logr_rec.user :=0; logr_rec.text := text; write(logr_file, logr_rec); close(logr_file); reset(logr_file); end; procedure SetSect(Drive, User: integer); { Set to file section } begin BDOS(seldrive, Drive); BDOS(getseluser, User) end; function input_timeout:boolean; {decrement counter to determine timeout} begin If (not local_online) then input_time:=input_time-1.0; If local_online then input_time:=input_time-0.2; {5 times longer} if (not clock) and (frac(int(input_time)/int(lps*0.12))=0.0) then begin tick_a_sec; hour_count:=hour_count+1.666; end; If input_time<0.0 then begin Writeln(usr,' ++ Eingabe-Timeout ++'); setsect(HomDrv,HomUsr); log(13,' '); remote_online:=false; if local_online then local_online:=false; mdhangup; input_timeout:=true; end else input_timeout:=false; end; function Online: boolean; { Determine whether system is still online - local or remote } begin if remote_online then if ch_carck then online := TRUE else begin putstat(' Carrier verloren...'); setsect(homdrv,homusr); log(12,' '); mdhangup; remote_online := FALSE; online := FALSE end else online := local_online end; procedure PutByte(b: byte); begin if ch_carck then ch_out(b) end; function GetByte(sec: integer; var timeout: boolean): byte; { Get byte from modem with 'sec' seconds timeout } var count: real; begin count := sec * lps; while (not ch_inprdy) and (ch_carck) and (count > 0.0) do count := count - 1.0; timeout := (not ch_carck) or (count <= 0.0); if timeout then GetByte := ord(NUL) else GetByte := ch_inp end; function GetChar: char; { Get character: no wait, no echo } type byteset = set of byte; const umlaut_set : byteset = [$81,$84,$8E,$94,$99,$9A,$E1]; var ch: char; bt: byte; begin if keypressed then begin read(KBD, ch); if (not online) and (not (ch in [^C, LF, CR, FF])) then ch := NUL; case ch of ^W: begin op_chat := TRUE; ch := ' ' end; ^E: begin remote_copy := not remote_copy; if remote_copy then putstat(' +++ Remote Copy ein +++') else putstat(' +++ Remote Copy aus +++'); ch := NUL end; ^R: begin delay_down := not delay_down; if delay_down then putstat(' +++ Verzoegerte Trennung ein +++') else putstat(' +++ Verzoegerte Trennung aus +++'); ch := NUL end; ^T: begin remote_online := FALSE; mdhangup; ch := NUL end; LF: begin if online then putstat(' ^W: CHAT, ^E: Remote Copy ein/aus, ^R: verzoegerte Trennung, ^T: Twit') else putstat(' ^C: PICS beenden, ^L: Lokale Benutzung'); if online then ch := NUL; end end { case } end else if (ch_inprdy and remote_copy) then begin bt := ch_inp; if bt < $80 then ch := chr(bt) else if (bt in umlaut_set) then ch := chr(bt) else ch := NUL end else ch := NUL; GetChar := ch end; function brk: boolean; { Check for break or pause } var test:boolean; ch: char; begin if (not abort) then begin input_time:=timeout * lps * 0.125; {set input timer with speed adjust} ch := GetChar; if ch = DC3 then { ^S } repeat ch := GetChar until (not online) or (ch <> NUL) or (input_timeout); test:= (not online) or (ch = ETX) or (ch=#$0B); { ^C or ^K } if test then begin mult_cmds:=false; cmd_queue:=''; end; brk:=test; end else begin abort:=false; brk:=true; end; end; { function Upcase(ch: char): char; var bt: byte; begin bt := ord(ch); if bt > $60 then if bt < $7B then bt := bt-$20 else begin if bt = $84 then bt := $8E; if bt = $81 then bt := $9A; if bt = $94 then bt := $99 end; Upcase := chr(bt) end; } procedure PutChar(ch: char); { User written I/O driver to output character } var i: integer; ch1: char; begin ch1 := NUL; if user_rec.shift_lock then ch := Upcase(ch); if online then begin if (not ansi) then begin if (ord(ch) > $7F) then begin if ord(ch)=$8E then begin ch1:='A'; ch:='E' end; {AE} if ord(ch)=$9A then begin ch1:='U'; ch:='E' end; {UE} if ord(ch)=$99 then begin ch1:='O'; ch:='E' end; {OE} if ord(ch)=$84 then begin ch1:='a'; ch:='e' end; {ae} if ord(ch)=$81 then begin ch1:='u'; ch:='e' end; {ue} if ord(ch)=$94 then begin ch1:='o'; ch:='e' end; {oe} if ord(ch)=$E1 then begin ch1:='s'; ch:='s' end {ss} end; { if ord(ch) > $7F } if ch1<>NUL then begin if printer_copy then BDOS(5,ord(ch1)); BDOS(6,ord(ch1)); if remote_copy then ch_out(ord(ch1)) end; { if ch1<>NUL } end; { if not ansi } if printer_copy then BDOS(5,ord(ch)); if (ch<>BEL) or local_online then BDOS(6,ord(ch)); if remote_copy then begin ch_out(ord(ch)); if ch = CR then for i := 1 to user_rec.nulls do ch_out(ord(NUL)); if ch = LF then for i := 1 to user_rec.nulls do ch_out(ord(NUL)) end { if remote_copy } end { if online } end; procedure GetStr(var inpstr: StrStd; var ch: char; maxlen: integer; mode: Str10); { Get a valid input string from the user } type charset = set of char; const termset: charset = [LF, CR, ETX]; var auto, echo, shiftlock, wrap, question, umlaut: boolean; i, len, cursor: integer; begin if user_rec.columns < maxlen then maxlen := user_rec.columns; auto := (pos('A', mode) > 0); { Line complete when full } echo := (pos('E', mode) > 0); { Display characters on entry } shiftlock := (pos('S', mode) > 0); { Make all characters upper case } wrap := (pos('W', mode) > 0); { Word wrap } question := (pos('?', mode) > 0); { Force inpstr := '?' when encountered } umlaut := (pos('U', mode) = 0) and ansi; { Umlaute ausfiltern wenn U gesetzt oder Simulator eingeschaltet - B.B. } auto := auto or wrap; { Wrap forces auto on } len := length(inpstr); cursor := succ(len); if echo and (cursor > 0) then Write(USR, inpstr); repeat input_time:=timeout * lps * 0.125; { This loop is slower than GetByte } repeat ch := GetChar; until (not online) or (ch <> NUL) or (input_timeout); if shiftlock then ch := UpCase(ch); case ch of TAB: repeat if echo then Write(USR, ' '); cursor := succ(cursor); insert(' ', inpstr, cursor) until (0 = cursor mod 5) or (cursor >= maxlen); RUB, BS: if cursor > 1 then begin Write(USR, BS, ' ', BS); cursor := pred(cursor); delete(inpstr, cursor, 1) end; CAN: while cursor > 1 do begin Write(USR, BS, ' ', BS); cursor := pred(cursor); delete(inpstr, cursor, 1) end; ^A: while cursor > 1 do begin if echo then Write(USR, BS); cursor := pred(cursor) end; ^S: if cursor > 1 then begin if echo then Write(USR, BS); cursor := pred(cursor) end; ^D: if cursor <= length(inpstr) then begin if echo then Write(USR, inpstr[cursor]); cursor := succ(cursor) end; ^F: while cursor <= length(inpstr) do begin if echo then Write(USR, inpstr[cursor]); cursor := succ(cursor) end; ^G: if cursor <= length(inpstr) then delete(inpstr, cursor, 1); else if (ch >= ' ') then if (umlaut or (ch <= '~')) then if ((len < maxlen) or auto) then begin if echo then Write(USR, ch) else write(USR,'.'); if ((ch = '?') and question and (len=0)) then begin inpstr := ch; ch := CR end else begin insert(ch, inpstr, cursor); cursor := succ(cursor) end end end; len := length(inpstr) until (not online) or (ch in termset) or ((len >= maxlen) and auto); next_inpstr := ''; if wrap and (len >= maxlen) then begin while (inpstr[len] <> ' ') and (len > 1) do len := pred(len); if len > 1 then begin if echo then begin for i := succ(len) to length(inpstr) do Write(USR, BS); for i := succ(len) to length(inpstr) do Write(USR, ' ') end; next_inpstr := copy(inpstr, succ(len), length(inpstr)); inpstr := copy(inpstr, 1, pred(len)) end end end; procedure pause; { Pause for user response before continuing } var ch:char; begin input_time:=timeout * lps * 0.125; {set timer with speed adjust} Write(USR, ''); if user_rec.noisy then Write(USR, BEL); repeat ch:=GetChar; if (ch=ETX) or (ch=#$0B) or (upcase(ch)='K') then abort:=true; until (not online) or (ch <> NUL) or (input_timeout); Write(USR, CR, ' ':16, CR) end; function prompt(pr: StrPr; len: integer; mode: Str10): StrStd; { Prompt user, return string and process multiple command buffer } type charset = set of char; const delim_set:charset = [';',' ',',']; var i, j: integer; reply,buffer: StrStd; t:tad_array; begin reply := ''; buffer:=''; ch:=' '; If (not mult_cmds) or (pos('L',mode)>0) then {L for literal} begin Write(USR, pr); if pos('M',mode)>0 then Write(USR, ' [? = Menue]'); Write(USR, '> '); if user_rec.noisy then Write(USR, BEL); if (macro_in_progress) and (macro_file_exists) then begin buffer:=''; ch:=' '; while (not eof(macro_file)) and (length(buffer)=0) do begin ch:=' '; readln(macro_file,buffer); i:=1; j:=length(buffer); while (j>0) and (i<=j) do begin {remove rest of line after first delimeter found} if buffer[i] in delim_set then delete(buffer,i,j-(i-1)); j:=length(buffer); i:=succ(i); end; if length(buffer)>0 then begin if pos('S',mode)>0 then for i:=1 to length(buffer) do buffer[i]:=upcase(buffer[i]); if (buffer='^M') or (buffer='^m') then begin buffer:=chr(13); ch:=chr(13); end else ch:=Upcase(buffer[1]); write(buffer); end; end; {reading macro file} if eof(macro_file) then begin macro_in_progress:=false; gettad(t); macro_done:=t[3]; end; end else GetStr(buffer, ch, len, mode); end else buffer:=cmd_queue; {feed in from queue} If pos('L',mode)=0 then {not literal, process mult. commands} begin i:=0; j:=0; repeat i:=succ(i); if (pos('N',mode)>0) and (buffer[i]=' ') then i:=succ(i); if buffer[i] in delim_set then j:=i; until (i>=length(buffer)) or (buffer[i] in delim_set); if j>0 then begin mult_cmds:=true; reply:=copy(buffer,1,j-1); {get command from buffer} delete(buffer,1,j); {remove cmd and delimeter} if buffer='' then begin mult_cmds:=false; cmd_queue:=''; end else cmd_queue:=buffer; {save balance for next command} if reply='' then reply:=' '; if macro_in_progress and (reply=chr(13)) then reply:=' '; end else begin mult_cmds:=false; cmd_queue:=''; reply:=buffer; {for single commands} if reply='' then reply:=' '; {so we wont bomb ch assignments} if macro_in_progress and (reply=chr(13)) then reply:=' '; end; end {not literal} else begin {literal} reply:=buffer; mult_cmds:=false; cmd_queue:=''; end; writeln(usr); prompt:=reply; end; {prompt} function ask(pr: StrPr): boolean; { Ask yes-or-no question and return TRUE for 'Y', FALSE otherwise } var ch: char; begin pr := concat(pr, ' [J/N] ? '); repeat ch:=copy(prompt(pr,1,'ES'),1,1); until (ch in ['J','N',' ']) or (not online); ask:=(ch='J'); end; {end of PICSkio.inc }