This source code file is available for download here: cmd_v12_2004_09_27.zip(~1 MB)
1: | { KEYWORDS: VERSION,TUNE } |
2: | { VERSION: 1.1 } |
3: | { 1.1 / 20.8.2002 |
4: | - shell can spawn basic interpreter for running BAS files |
5: | 1.0 |
6: | - shell router for console applications |
7: | } |
8: | unit basShell; |
9: | |
10: | { TUNE: if defined, OS Process spawning will be enabled. if not, only |
11: | TChip processes can be spawned } |
12: | {$DEFINE USEEXEC} |
13: | |
14: | interface |
15: | uses Windows,Chip,Classes; |
16: | |
17: | procedure LoadOSEnvironment(Environment:TStrings); |
18: | |
19: | type |
20: | TBreakProc=procedure of object; |
21: | TExecutor=class |
22: | private |
23: | Line:string; |
24: | Col:integer; |
25: | protected |
26: | procedure NewLine(Process: THandle; Buffer:PChar; Count:integer);virtual; |
27: | function ReadChar(Process: THandle; var Buffer:Char):boolean;virtual; |
28: | private |
29: | Breaker: TBreakProc; |
30: | BreakFlag: Boolean; |
31: | public |
32: | Script:TBasic; |
33: | Output:string; |
34: | Capture:boolean; |
35: | function Execute(const cmd:string):integer; |
36: | procedure SetBreak; |
37: | end; |
38: | |
39: | type |
40: | TBasic=class(Chip.TBasic) |
41: | private |
42: | exec: TExecutor; |
43: | protected |
44: | procedure CallShellSub(const cmd:string);override; |
45: | function CallShellFunction(const cmd:string):string;override; |
46: | function Shell(const cmd:string):integer; |
47: | function ShellFunction(const cmd:string):string; |
48: | public |
49: | constructor Create;override; |
50: | procedure SetBreak;override; |
51: | end; |
52: | |
53: | implementation |
54: | uses SysUtils{$IFDEF USEEXEC},ConsoleApp{$ENDIF}; |
55: | |
56: | procedure TExecutor.SetBreak; |
57: | begin |
58: | BreakFlag := True; |
59: | if Assigned(Breaker) then |
60: | Breaker |
61: | end; |
62: | |
63: | function TExecutor.ReadChar; |
64: | begin |
65: | Result:=false |
66: | end; |
67: | |
68: | procedure TExecutor.NewLine; |
69: | |
70: | procedure TTY(ch:char); |
71: | begin |
72: | case ch of |
73: | #8: if Col>1 then |
74: | if Col>Length(Line) then begin |
75: | dec(Col); |
76: | SetLength(Line,Col-1) |
77: | end else |
78: | { TODO: }; |
79: | #10: begin if Output<>'' then Output:=Output+#13#10; Output:=Output+Line; Line:=''; Col:=1 end; |
80: | #13: Col:=1; |
81: | else |
82: | if Col<=Length(Line) then |
83: | Line[Col]:=ch |
84: | else |
85: | Line:=Line+ch; |
86: | inc(Col) |
87: | end |
88: | end; |
89: | |
90: | begin |
91: | if not Assigned(Script) then exit; |
92: | if Count>0 then OemToCharBuff(Buffer,Buffer,Count); |
93: | while Count>0 do begin |
94: | if Capture then |
95: | TTY(Buffer[0]) |
96: | else begin |
97: | Write(Script.output^,Buffer[0]); |
98: | end; |
99: | inc(Buffer); |
100: | dec(Count) |
101: | end |
102: | end; |
103: | |
104: | { Text file device driver output function } |
105: | |
106: | function CrtOutput(var F: TTextRec): Integer; far; |
107: | begin |
108: | if F.BufPos <> 0 then |
109: | with TObject((@F.UserData)^) as TExecutor do |
110: | begin |
111: | NewLine(0,PChar(F.BufPtr), F.BufPos); |
112: | F.BufPos := 0; |
113: | end; |
114: | CrtOutput := 0; |
115: | end; |
116: | |
117: | { Text file device driver close function } |
118: | |
119: | function CrtClose(var F: TTextRec): Integer; far; |
120: | begin |
121: | CrtClose := 0; |
122: | end; |
123: | |
124: | { Text file device driver open function } |
125: | |
126: | function CrtOpen(var F: TTextRec): Integer; far; |
127: | begin |
128: | F.Mode := fmOutput; |
129: | F.InOutFunc := @CrtOutput; |
130: | F.FlushFunc := @CrtOutput; |
131: | F.CloseFunc := @CrtClose; |
132: | CrtOpen := 0; |
133: | end; |
134: | |
135: | function TExecutor.Execute; |
136: | var h,t,n:integer; |
137: | var qch:char; |
138: | |
139: | function GetEnv:string; |
140: | var env:TStrings; |
141: | |
142: | procedure QuickSort(L, R: Integer); |
143: | var |
144: | I, J: Integer; |
145: | P: string; |
146: | begin |
147: | repeat |
148: | I := L; |
149: | J := R; |
150: | P := env.Names[(L + R) shr 1]; |
151: | repeat |
152: | while CompareText(env.Names[I], P) < 0 do Inc(I); |
153: | while CompareText(env.Names[J], P) > 0 do Dec(J); |
154: | if I <= J then |
155: | begin |
156: | env.Exchange(I, J); |
157: | Inc(I); |
158: | Dec(J); |
159: | end; |
160: | until I > J; |
161: | if L < J then QuickSort(L, J); |
162: | L := I; |
163: | until I >= R; |
164: | end; |
165: | |
166: | var i:integer; |
167: | begin |
168: | env:=TStringList.Create; |
169: | if Assigned(Script) then begin |
170: | env.Assign(Script.Environment); |
171: | Script.ExportCommons(env) |
172: | end; |
173: | |
174: | { now sort the env block since OS relies on it } |
175: | if env.Count>1 then QuickSort(0,env.Count-1); |
176: | |
177: | Result:=''; |
178: | for i:=0 to env.Count-1 do |
179: | Result:=Result+env[i]+#0; |
180: | |
181: | env.Free |
182: | end; |
183: | |
184: | procedure AssignEnv(env:TStrings); |
185: | begin |
186: | env.Assign(Script.Environment); |
187: | Script.ExportCommons(env) |
188: | end; |
189: | |
190: | var fileName:string; |
191: | var subScript:Chip.TBasic; |
192: | var subOutput:TextFile; |
193: | begin |
194: | { separate command from parameters } |
195: | n:=length(cmd); |
196: | h:=1; |
197: | while (h<=n) and (cmd[h]=' ') do inc(h); |
198: | if (h<=n) and (cmd[h]='"') then begin |
199: | inc(h); |
200: | qch:='"' |
201: | end else |
202: | qch:=' '; |
203: | t:=h; |
204: | while (t<=n) and (cmd[t]<>qch) do inc(t); |
205: | |
206: | Line:=''; |
207: | Output:=''; |
208: | Col:=1; |
209: | |
210: | fileName:=Copy(cmd,h,t-h); |
211: | if UpperCase(ExtractFileExt(fileName))='.BAS' { TODO: } then begin |
212: | fileName:=Script.ExpandFileName(fileName,false); |
213: | |
214: | subScript:=TBasicClass(Script.ClassType).Create; |
215: | try |
216: | AssignEnv(subScript.Environment); |
217: | |
218: | subScript.input:=script.input; |
219: | if Capture then begin |
220: | FillChar(subOutput,sizeof(TTextRec),0); |
221: | with TTextRec(subOutput) do |
222: | begin |
223: | Handle := Cardinal(-1); |
224: | Mode := fmClosed; |
225: | BufSize := SizeOf(Buffer); |
226: | BufPtr := @Buffer; |
227: | OpenFunc := @CrtOpen; |
228: | Move(Self, UserData[1],Sizeof(Pointer)); |
229: | Name[0] := #0; |
230: | end; |
231: | subScript.output:=@subOutput; |
232: | Rewrite(subOutput) |
233: | end else |
234: | subScript.output:=script.output; |
235: | |
236: | try |
237: | Breaker := subScript.SetBreak; |
238: | subScript.Run(Format('RUN "%s"',[fileName])); |
239: | Result:=0 |
240: | finally |
241: | Breaker := nil; |
242: | if Capture then |
243: | CloseFile(subOutput) |
244: | end |
245: | finally |
246: | subScript.Free |
247: | end |
248: | |
249: | end else begin |
250: | {$IFDEF USEEXEC} |
251: | Result:=ExecConsoleApp(fileName,Copy(cmd,t+1,maxint),GetEnv,ReadChar,NewLine,@BreakFlag); |
252: | {$ELSE} |
253: | raise Exception.Create('Executable image is not a supported type') |
254: | {$ENDIF} |
255: | end; |
256: | if Line<>'' then begin |
257: | if Output<>'' then Output:=Output+#13#10; |
258: | Output:=Output+Line; |
259: | Line:='' |
260: | end |
261: | end; |
262: | |
263: | procedure LoadOSEnvironment; |
264: | var env,p:PChar; |
265: | var n:integer; |
266: | var line:string; |
267: | begin |
268: | Environment.Clear; |
269: | env:=GetEnvironmentStrings; |
270: | p:=env; |
271: | while p[0]<>#0 do begin |
272: | n:=StrLen(p); |
273: | SetLength(line,n); |
274: | Move(p[0],line[1],n); |
275: | Environment.Add(line); |
276: | inc(p,n+1) |
277: | end; |
278: | FreeEnvironmentStrings(env) |
279: | end; |
280: | |
281: | procedure TBasic.SetBreak; |
282: | begin |
283: | if Assigned(exec) then |
284: | exec.SetBreak; |
285: | inherited |
286: | end; |
287: | |
288: | function TBasic.Shell; |
289: | begin |
290: | exec:=TExecutor.Create; |
291: | exec.Script:=Self; |
292: | try |
293: | Result:=exec.Execute(cmd) |
294: | finally |
295: | FreeAndNil(exec) |
296: | end |
297: | end; |
298: | |
299: | function TBasic.ShellFunction; |
300: | begin |
301: | exec:=TExecutor.Create; |
302: | exec.Script:=Self; |
303: | exec.Capture:=true; |
304: | try |
305: | exec.Execute(cmd); |
306: | Result:=exec.Output |
307: | finally |
308: | FreeAndNil(exec) |
309: | end |
310: | end; |
311: | |
312: | procedure TBasic.CallShellSub; |
313: | begin |
314: | Shell(cmd) |
315: | end; |
316: | |
317: | function TBasic.CallShellFunction; |
318: | begin |
319: | Result:=ShellFunction(cmd) |
320: | end; |
321: | |
322: | constructor TBasic.Create; |
323: | begin |
324: | inherited; |
325: | LoadOSEnvironment(Environment); |
326: | MapMethod('Shell',vkInteger,chr(vkString or vkConst),Self,@TBasic.Shell); |
327: | MapMethod('Shell$',vkString,chr(vkString or vkConst),Self,@TBasic.ShellFunction); |
328: | end; |
329: | |
330: | end. |