Tento zdrojový kód je k dispozici ke stažení zde: cmd_v12_2004_09_27.zip(~1 MB)

  1: unit ChipThr;
  2: 
  3: interface
  4: uses Windows,Classes,Chip;
  5: 
  6: type
  7:   TSendKeyEvent=procedure (Sender:TObject; Key:char) of object;
  8:   TBasicThread=class(TThread)
  9:   protected
 10:    FTag:integer;
 11:    FOnIdle:TNotifyEvent;
 12:    FOnSendKey:TSendKeyEvent;
 13:    FKeyBuf:string;
 14:    FKeyLock:TRTLCriticalSection;
 15:    FCommand:string;
 16:    FBas:TBasic;
 17:    FOut:char;
 18:    FInput,FOutput:TextFile;
 19:    procedure DoTTY;
 20:   public
 21:    function ReadKey:char;
 22:    function KeyPressed:boolean;
 23:   protected
 24:    procedure TTY(c:char);
 25:    function ReadBuf(Buffer: PChar; Count: Cardinal): Cardinal;
 26:    procedure WriteBuf(Buffer: PChar; Count: Cardinal);
 27:    procedure Execute;override;
 28:    procedure Idle;
 29:    procedure InitializeEngine;virtual;
 30:   public
 31:    constructor Create(AFactory:TBasicClass; const ACommand:string);
 32:    destructor Destroy;override;
 33:    procedure PushKey(key:char);
 34:    property OnSendKey:TSendKeyEvent read FOnSendKey write FOnSendKey;
 35:    property OnIdle:TNotifyEvent read FOnIdle write FOnIdle;
 36:    property Tag:integer read FTag write FTag;
 37:    property Script:TBasic read FBas;
 38:   end;
 39: 
 40: implementation
 41: uses SysUtils;
 42: 
 43: procedure TBasicThread.InitializeEngine;
 44: begin
 45: end;
 46: 
 47: procedure TBasicThread.Idle;
 48: begin
 49:   if Assigned(FOnIdle) then FOnIdle(Self);
 50:   Suspend
 51: end;
 52: 
 53: procedure TBasicThread.DoTTY;
 54: begin
 55:   if Assigned(FOnSendKey) then FOnSendKey(Self,FOut)
 56: end;
 57: 
 58: procedure TBasicThread.TTY;
 59: begin
 60:   FOut:=c;
 61:   Synchronize(DoTTY)
 62: end;
 63: 
 64: constructor TBasicThread.Create;
 65: begin
 66:   inherited Create(true);
 67:   FCommand:=ACommand;
 68:   FBas:=AFactory.Create;
 69:   InitializeCriticalSection(FKeyLock)
 70: end;
 71: 
 72: function TBasicThread.KeyPressed;
 73: begin
 74:   EnterCriticalSection(FKeyLock);
 75:   Result:=FKeyBuf<>'';
 76:   LeaveCriticalSection(FKeyLock)
 77: end;
 78: 
 79: function TBasicThread.ReadKey;
 80: label loop;
 81: begin
 82:   loop:
 83:   EnterCriticalSection(FKeyLock);
 84:   if FKeyBuf='' then
 85:    Result:=#0
 86:   else begin
 87:    Result:=FKeyBuf[1];
 88:    Delete(FKeyBuf,1,1)
 89:   end;
 90:   LeaveCriticalSection(FKeyLock);
 91:   if Result=#0 then begin
 92:    Idle;
 93:    goto loop
 94:   end
 95: end;
 96: 
 97: function TBasicThread.ReadBuf;
 98: var
 99:    Ch: Char;
100:    I: Cardinal;
101: 
102:    procedure WriteChar(c:char);
103:    begin
104:     TTY(c)
105:    end;
106: 
107: begin
108:    I := 0;
109:    repeat
110:      Ch := ReadKey;
111:      case Ch of
112:        #8:
113:          if I > 0 then
114:          begin
115:            Dec(I);
116:            WriteChar(#8);
117:          end;
118:        #32..#255:
119:          if I < Count - 2 then
120:          begin
121:            Buffer[I] := Ch;
122:            Inc(I);
123:            WriteChar(Ch);
124:          end;
125:      end;
126:    until (Ch in [#0,#13]);
127:    Buffer[I] := Ch;
128:    Inc(I);
129:    if Ch = #13 then
130:    begin
131:      Buffer[I] := #10;
132:      Inc(I);
133:      WriteBuf(#13#10,2);
134:    end;
135:    ReadBuf := I;
136: end;
137: 
138: procedure TBasicThread.WriteBuf;
139: begin
140:   while Count>0 do begin
141:    TTY(Buffer^);
142:    inc(Buffer);
143:    dec(Count)
144:   end
145: end;
146: 
147: { Text file device driver output function }
148: 
149: function CrtOutput(var F: TTextRec): Integer; far;
150: begin
151:    if F.BufPos <> 0 then
152:    with TObject((@F.UserData)^) as TBasicThread do
153:    begin
154:      WriteBuf(PChar(F.BufPtr), F.BufPos);
155:      F.BufPos := 0;
156:    end;
157:    CrtOutput := 0;
158: end;
159: 
160: { Text file device driver input function }
161: 
162: function CrtInput(var F: TTextRec): Integer; far;
163: begin
164:    with TObject((@F.UserData)^) as TBasicThread do
165:      F.BufEnd := ReadBuf(PChar(F.BufPtr), F.BufSize);
166:    F.BufPos := 0;
167:    CrtInput := 0;
168: end;
169: 
170: { Text file device driver close function }
171: 
172: function CrtClose(var F: TTextRec): Integer; far;
173: begin
174:    CrtClose := 0;
175: end;
176: 
177: { Text file device driver open function }
178: 
179: function CrtOpen(var F: TTextRec): Integer; far;
180: begin
181:    if F.Mode = fmInput then
182:    begin
183:      F.InOutFunc := @CrtInput;
184:      F.FlushFunc := nil;
185:    end else
186:    begin
187:      F.Mode := fmOutput;
188:      F.InOutFunc := @CrtOutput;
189:      F.FlushFunc := @CrtOutput;
190:    end;
191:    F.CloseFunc := @CrtClose;
192:    CrtOpen := 0;
193: end;
194: 
195: procedure TBasicThread.Execute;
196: 
197:   procedure AssignCrt(var F: Text);
198:   begin
199:     with TTextRec(F) do
200:     begin
201:       Handle := Cardinal(-1);
202:       Mode := fmClosed;
203:       BufSize := SizeOf(Buffer);
204:       BufPtr := @Buffer;
205:       OpenFunc := @CrtOpen;
206:       Move(Self, UserData[1],Sizeof(Pointer));
207:       Name[0] := #0;
208:     end;
209:   end;
210: 
211: begin
212:   FBas.Input:=@FInput;
213:   AssignCrt(FInput);
214:   Reset(FInput);
215:   FBas.Output:=@FOutput;
216:   AssignCrt(FOutput);
217:   Rewrite(FOutput);
218:   InitializeEngine;
219:   FBas.Run(FCommand)
220: end;
221: 
222: procedure TBasicThread.PushKey;
223: begin
224:   EnterCriticalSection(FKeyLock);
225:   if key = #3 then
226:     FBas.SetBreak
227:   else
228:     FKeyBuf:=FKeyBuf+key;
229:   Resume;
230:   LeaveCriticalSection(FKeyLock)
231: end;
232: 
233: destructor TBasicThread.Destroy;
234: begin
235:   FBas.Free;
236:   CloseFile(FInput);
237:   CloseFile(FOutput);
238:   DeleteCriticalSection(FKeyLock);
239:   inherited
240: end;
241: 
242: end.
Máte otázky, připomínky?