af_file.pas

ArtFormula package contains two nonvisual Delphi component for symbolic expression parsing and evalu

unit af_file;

interface
uses formula;

procedure Install(var Formula : TArtFormula);


implementation
uses sysutils, windows;

type TMyFile = class
      private
       fname : string;
       f : file of char;
       buf : string;
       opened : boolean;
       procedure setname(s:string);
       procedure getbuff;
       function getnext:string;
      public
       procedure Open(s:string);
       procedure close;
       function read: string;
       function readln: string;
       function get: char;
       function eof : boolean;
       function size : longint;
       function pos : longint;
       function date : TDateTime;
       procedure write(s:string);
       procedure writeln(s:string);
       procedure seek(pos:longint);
       property FileName : string read fname write setname;
      end;

var Files : array of TMyFile;

{$I-}
function TMyFile.getnext:string;
var i,p,l:integer;
begin
 result := '';
 if buf = '' then exit;
 i := 1;
 l := length(buf);
 while (i<=l) and ((buf[i] = ' ') or (buf[i] = #9)) do inc(i);
 p := 0;
 while ((i+p)<=l) and (buf[i+p] <> ' ') and (buf[i+p] <> #9) do inc(p);
 if p > 0 then result := copy(buf,i,p);
 if i+p < l then buf := copy(buf,i+p,l-i-p+1)
 else buf := '';
end;

procedure TMyFile.setname(s:string);
begin
 if opened then closefile(f);
 assignfile(f,s);
 opened := false;
 fname := s;
 buf := '';
end;
{$I+}

procedure TMyFile.seek(pos:longint);
begin
 system.Seek(f,pos);
end;

procedure TMyFile.Open(s:string);
begin
 s := AnsiUpperCase(s);
 if (s = 'REWRITE') or (s = 'WRITE') then rewrite(f)
 else
 if s = 'APPEND' then
 begin
  rewrite(f);
  system.Seek(f,system.FileSize(f));
 end
 else
  reset(f);
 buf := '';
 opened := true;
end;

procedure TMyFile.getbuff;
var x:char;
begin
  system.read(f,x);
  while (x <> #10) and not system.eof(f) do
  begin
   buf := buf + x;
   system.read(f,x);
  end;
end;

procedure TMyFile.close;
begin
 if opened then Closefile(f);
 buf := '';
 opened := false;
end;

function TMyFile.read: string;
begin
 if buf <> '' then result := getnext
 else
 begin
  result := '';
  while (result = '') and not system.eof(f) do
  begin
   getbuff;
   result := getnext;
  end;
 end;
end;

function TMyFile.get: char;
var b : char;
begin
  system.read(f,b);
  result := b;
end;

function TMyFile.eof : boolean;
begin
 result := system.eof(f) and (buf='');
end;

function TMyFile.size : longint;
begin
 result := system.filesize(f);
end;

function TMyFile.pos : longint;
begin
 result := system.filePos(f);
end;

function TMyFile.date : TDateTime;
begin
 result := FileDateToDateTime(fileAge(fname));
end;

function TMyFile.readln: string;
var s,i:integer;
begin
 i := 0;
 if buf <> '' then
 begin
  result := buf;
  buf := '';
 end
 else
 begin
   getbuff;
   s := length(buf);
   if buf[s] = '#10' then inc(i);
   if buf[s-1] = '#13' then inc(i);
   result := copy(buf,1,s-i);
   buf := '';
 end;
end;

procedure TMyFile.write(s:string);
var i:integer;
    c : char;
begin
 for i := 1 to length(s) do
 begin
  c := s[i];
  system.write(f,c);
 end;
end;

procedure TMyFile.writeln(s:string);
var i:integer; c:char;
begin
 for i := 1 to length(s) do
 system.write(f,s[i]);
 c := #13;
 system.write(f,c);
 c := #10;
 system.write(f,c);
end;


{$I-}
function mychdir(var Calc : TFormulaCalc):TCalcItem;
begin
 chdir(Calc.TopS);
 if IOResult = 0 then
  setN(result,1)
 else SetN(result,0);
end;
{$I+}

function mygetdir(var Calc : TFormulaCalc):TCalcItem;
begin
 sets(result,GetCurrentDir);
end;

function mycreatedir(var Calc : TFormulaCalc):TCalcItem;
begin
 if createdir(Calc.Tops) then
  setN(result,1)
 else setN(result,0);
end;

function mydeletefile(var Calc : TFormulaCalc):TCalcItem;
begin
 if sysutils.deletefile(Calc.TopS) then
  setN(result,1)
 else setN(result,0)
end;

function mycopyfile(var Calc : TFormulaCalc):TCalcItem;
var s1,s2:string; x:boolean;
begin
 s1 := Calc.ItemS(2);
 s2 := calc.ItemS(1);
 x := calc.TopN <> 0;

 if copyfile(pchar(s1),pchar(s2),longbool(x)) then
  setN(result,1)
 else setN(result,0)
end;


function mydirexists(var Calc : TFormulaCalc):TCalcItem;
begin
 if directoryexists(calc.TopS) then
  setN(result,1)
 else setN(result,0)
end;

function myfileexists(var Calc : TFormulaCalc):TCalcItem;
begin
 if fileexists(CALC.TopS) then
  setN(result,1)
 else setN(result,0)
end;

function myremovedir(var Calc : TFormulaCalc):TCalcItem;
begin
 if removedir(calc.tops) then
  setN(result,1)
 else setN(result,0)
end;

function myrenamefile(var Calc : TFormulaCalc):TCalcItem;
var s,s1:string;
begin
 s := calc.ItemS(1);
 s1 := calc.TopS;
 if renamefile(s,s1) then
  setN(result,1)
 else setN(result,0)
end;

function myfilename(var Calc : TFormulaCalc):TCalcItem;
begin
 sets(result, extractfilename(calc.TopS));
end;

function myfilepath(var Calc : TFormulaCalc):TCalcItem;
begin
 sets(result, extractfilepath(calc.TopS));
end;

//-----------------------------------------------------------

function myfile(var Calc : TFormulaCalc):TCalcItem;
begin
 setN(result,trunc(Calc.topn));
end;

function myfilesetname(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.ItemN(1));
 Files[current].FileName := Calc.TopS;
 setN(result,current);
end;

function myfilegetname(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.TopN);
 setS(result,Files[current].FileName);
end;

function myfileclose(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.TopN);
 Files[current].close;
 setN(result,current);
end;

function myfileopen(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.ItemN(1));
 Files[current].open(calc.tops);
 setN(result,current);
end;

function myfileseek(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.ItemN(1));
 Files[current].seek(trunc(Calc.topn));
 setN(result,current);
end;

function myfileread(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.TopN);
 setS(result,Files[current].read);
end;

function myfileget(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.TopN);
 setS(result,Files[current].get);
end;

function myfilereadln(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.TopN);
 setS(result,Files[current].readln);
end;

function myfileeof(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.TopN);
 if Files[current].eof then
  setN(result,1)
 else
  setN(result,0);
end;

function myfilepos(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.TopN);
 setN(result,Files[current].pos);
end;

function myfiledate(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.TopN);
 setN(result,Files[current].date);
end;

function myfilesize(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.TopN);
 setN(result,Files[current].size);
end;

function myfilewrite(var Calc : TFormulaCalc):TCalcItem;
var i,cnt:integer;
    current:integer;
begin
  cnt := trunc(Calc.TopN);
  current := trunc(Calc.ItemN(cnt+1));
  for i := cnt downto 1 do
   Files[current].write(Calc.ItemS(i));
  setN(result,current);
end;

function myfilewriteln(var Calc : TFormulaCalc):TCalcItem;
var i,cnt:integer;
    current:integer;
begin
  cnt := trunc(Calc.TopN);
  current := trunc(Calc.ItemN(cnt+1));
  for i := cnt downto 2 do
   Files[current].write(Calc.ItemS(i));
  Files[current].writeln(Calc.ItemS(1));
  setN(result,current);
end;

function myfilenew(var Calc : TFormulaCalc):TCalcItem;
var i,p : integer;
begin
 p := -1;
 for i := 0 to high(Files) do
 begin
  if Files[i] = nil then
  begin
   p := i;
   exit;
  end;
 end;
 if p = -1 then
 begin
  p := high(Files)+1;
  setlength(Files,p+1);
 end;
 Files[p] := TMyFile.Create;
 setN(result,p);
end;

function myfilefreeall(var Calc : TFormulaCalc):TCalcItem;
var i:integer;
begin
 for i := 0 to high(Files) do
 begin
   Files[i].close;
   Freeandnil(Files[i]);
 end;
 Files := nil;
 setN(result,0);
end;

function myfilefree(var Calc : TFormulaCalc):TCalcItem;
var current:integer;
begin
 current := trunc(Calc.TopN);
 Files[current].close;
 Freeandnil(Files[current]);
end;

procedure Install(var Formula : TArtFormula);
var module : PTableItem;
begin
 Formula.AddUserFunction('chdir',1,mychdir);
 Formula.AddUserFunction('getdir',0,mygetdir);
 Formula.AddUserFunction('createdir',1,mycreatedir);
 Formula.AddUserFunction('deletefile',1,mydeletefile);
 Formula.AddUserFunction('copyfile',3,mycopyfile);
 Formula.AddUserFunction('direxists',1,mydirexists);
 Formula.AddUserFunction('fileexists',1,myfileexists);
 Formula.AddUserFunction('removedir',1,myremovedir);
 Formula.AddUserFunction('renamefile',2,myrenamefile);
 Formula.AddUserFunction('filename',1,myfilename);
 Formula.AddUserFunction('filepath',1,myfilepath);

 module := Formula.AddUserFunction('file',1,myfile,true);
 Formula.AddModuleFunction(module,'setname',1,myfilesetname);
 Formula.AddModuleFunction(module,'name',0,myfilegetname);
 Formula.AddModuleFunction(module,'close',0,myfileclose);
 Formula.AddModuleFunction(module,'open',1,myfileopen);
 Formula.AddModuleFunction(module,'seek',1,myfileseek);
 Formula.AddModuleFunction(module,'read',0,myfileread);
 Formula.AddModuleFunction(module,'get',0,myfileget);
 Formula.AddModuleFunction(module,'readln',0,myfilereadln);
 Formula.AddModuleFunction(module,'eof',0,myfileeof);
 Formula.AddModuleFunction(module,'pos',0,myfilepos);
 Formula.AddModuleFunction(module,'date',0,myfiledate);
 Formula.AddModuleFunction(module,'size',0,myfilesize);
 Formula.AddModuleFunction(module,'write',-1,myfilewrite);
 Formula.AddModuleFunction(module,'writeln',-1,myfilewriteln);
 Formula.AddModuleFunction(module,'new',0,myfilenew);
 Formula.AddModuleFunction(module,'free',0,myfilefree);
 Formula.AddModuleFunction(module,'freeall',0,myfilefreeall);
end;

end.