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.

Do you have questions, comments, feedback?