ftpobj.pas

Source code Delphi FTP-server

  if RegOpenKey(h,@Nm[1],h1) = ERROR_SUCCESS then
    begin
    w:=253;
    if RegQueryValueEx(h1,'Password',nil,nil,@Pw[1],@w) <> ERROR_SUCCESS then
      Pw:='~~<<<>>>~~'
    else
      SetStringSize(Pw,253);
    w:=253;
    if RegQueryValueEx(h1,'Home',nil,nil,@Hm[1],@w) <> ERROR_SUCCESS then
      Hm:='/'
    else
      SetStringSize(Hm,253);
    w:=sizeof(ID1);
    if RegQueryValueEx(h1,'UID',nil,nil,@ID1,@w) <> ERROR_SUCCESS then
      ID1:=$FFF0;
    w:=sizeof(Rt);
    if RegQueryValueEx(h1,'Root',nil,nil,@Rt,@w) <> ERROR_SUCCESS then
      Rt:=false;
    k:=1;
    for j:=1 to 20 do
      begin
      s:=format('Group%u',[j])+#0;
      w:=sizeof(n);
      if RegQueryValueEx(h1,@s[1],nil,nil,@n,@w) = ERROR_SUCCESS then
        begin
        l[k]:=n;
        inc(k);
        end;
      end;
    while k <= 20 do
      begin
      l[k]:=$FFF0;
      inc(k);
      end;
    SetStringSize(Nm,100);
    AddEntry(Nm,ID1,l,Pw,Rt,Hm);
    RegCloseKey(h1);
    end;
  inc(i);
  end;
RegCloseKey(h);
result:=true;
end;

function TUserList.Save;
var
 h,h1 : hKey;
 w : word;
 n : word;
 i,j : word;
 Nm,Pw,Hm  : string;
 ID1 : word;
 Rt : boolean;
 s : string[20];
begin
{ -- Opening Main Key Path -- }
RegOpenKey(HKEY_LOCAL_MACHINE,'SOFTWARE',h1);
RegCreateKey(h1,'Drt.',h);
RegCloseKey(h1);
RegCreateKey(h,'TFTP',h1);
RegCloseKey(h);
RegCreateKey(h1,'Users',h);
RegCloseKey(h1);
DeleteSubkeys(h);
n:=Count;
for i:=1 to n do
  begin
  Nm:=Name[i-1]+#0;
  ID1:=UID[i-1];
  Pw:=Password[i-1]+#0;
  Rt:=Root[i-1];
  Hm:=Home[i-1]+#0;
  RegCreateKey(h,@Nm[1],h1);
  w:=length(Pw);
  RegSetValueEx(h1,'Password',0,REG_SZ,@Pw[1],w);
  w:=length(Hm);
  RegSetValueEx(h1,'Home',0,REG_SZ,@Hm[1],w);
  w:=sizeof(ID1);
  RegSetValueEx(h1,'UID',0,REG_BINARY,@ID1,w);
  w:=sizeof(Rt);
  RegSetValueEx(h1,'Root',0,REG_BINARY,@Rt,w);
  for n:=1 to 20 do
    begin
    s:=format('Group%u',[n])+#0;
    j:=GID[i-1,n];
    if j <> $FFF0 then
      begin
      w:=sizeof(j);
      RegSetValueEx(h1,@s[1],0,REG_BINARY,@j,w);
      end;
    end;
  RegCloseKey(h1);
  end;
RegCloseKey(h);
result:=true;
end;

function TUserList.RdUID(Index : integer) : word;
begin
if (Index < 0) or (Index >= count) then
  begin
  result:=$fff0;
  exit;
  end;
result:=TUserItem(Objects[Index]).UID;
end;

function TUserList.RdGID(Index,GIndex : integer) : word;
begin
if (Index < 0) or (Index >= count) then
  begin
  result:=$fff0;
  exit;
  end;
result:=TUserItem(Objects[Index]).GID[GIndex];
end;

procedure TUserList.WrGID(Index,GIndex : integer; Value : word);
begin
if (Index < 0) or (Index >= count) then exit;
TUserItem(Objects[Index]).GID[GIndex]:=Value;
end;

function TUserList.RdName(Index : integer) : string;
begin
if (Index < 0) or (Index >= count) then
  begin
  result:='';
  exit;
  end;
result:=Strings[Index];
end;

function TUserList.RdPassword(Index : integer) : string;
begin
if (Index < 0) or (Index >= count) then
  begin
  result:='';
  exit;
  end;
result:=TUserItem(Objects[Index]).Password;
end;

procedure TUserList.WrPassword(Index : integer; Value : string);
begin
if (Index < 0) or (Index >= count) then exit;
TUserItem(Objects[Index]).Password:=Value;
end;

function TUserList.RdRoot(Index : integer) : boolean;
begin
if (Index < 0) or (Index >= count) then
  begin
  result:=false;
  exit;
  end;
result:=TUserItem(Objects[Index]).Root;
end;

procedure TUserList.WrRoot(Index : integer; Value : boolean);
begin
if (Index < 0) or (Index >= count) then exit;
TUserItem(Objects[Index]).Root:=Value;
end;

function TUserList.RdHome(Index : integer) : string;
begin
if (Index < 0) or (Index >= count) then
  begin
  result:='';
  exit;
  end;
result:=TUserItem(Objects[Index]).Home;
end;

procedure TUserList.WrHome(Index : integer; Value : string);
begin
if (Index < 0) or (Index >= count) then exit;
TUserItem(Objects[Index]).Home:=Value;
end;

function TUserList.RdGIDUID(UID : word; GIndex : integer) : word;
var
 i : integer;
begin
result:=$fff0;
if Count = 0 then exit;
for i:=0 to Count-1 do
  begin
  if TUserItem(Objects[i]).UID = UID then
    begin
    result:=TUserItem(Objects[i]).GID[GIndex];
    end;
  end;
end;

procedure TUserList.WrGIDUID(UID : word; GIndex : integer; Value : word);
var
 i : integer;
begin
if Count = 0 then exit;
for i:=0 to Count-1 do
  begin
  if TUserItem(Objects[i]).UID = UID then
    begin
    TUserItem(Objects[i]).GID[GIndex]:=Value;
    end;
  end;
end;

function TUserList.RdNameUID(UID : word) : string;
var
 i : integer;
begin
result:='';
if Count = 0 then exit;
for i:=0 to Count-1 do
  begin
  if TUserItem(Objects[i]).UID = UID then
    begin
    result:=Strings[i];
    end;
  end;
end;

function TUserList.RdPassUID(UID : word) : string;
var
 i : integer;
begin
result:='';
if Count = 0 then exit;
for i:=0 to Count-1 do
  begin
  if TUserItem(Objects[i]).UID = UID then
    begin
    result:=TUserItem(Objects[i]).Password;
    end;
  end;
end;

procedure TUserList.WrPassUID(UID : word; Value : string);
var
 i : integer;
begin
if Count = 0 then exit;
for i:=0 to Count-1 do
  begin
  if TUserItem(Objects[i]).UID = UID then
    begin
    TUserItem(Objects[i]).Password:=Value;
    end;
  end;
end;

function TUserList.RdRootUID(UID : word) : boolean;
var
 i : integer;
begin
result:=false;
if Count = 0 then exit;
for i:=0 to Count-1 do
  begin
  if TUserItem(Objects[i]).UID = UID then
    begin
    result:=TUserItem(Objects[i]).Root;
    end;
  end;
end;

procedure TUserList.WrRootUID(UID : word; Value : boolean);
var
 i : integer;
begin
if Count = 0 then exit;
for i:=0 to Count-1 do
  begin
  if TUserItem(Objects[i]).UID = UID then
    begin
    TUserItem(Objects[i]).Root:=Value;
    end;
  end;
end;

function TUserList.RdHomeUID(UID : word) : string;
var
 i : integer;
begin
result:='';
if Count = 0 then exit;
for i:=0 to Count-1 do
  begin
  if TUserItem(Objects[i]).UID = UID then
    begin
    result:=TUserItem(Objects[i]).Home;
    end;
  end;
end;

procedure TUserList.WrHomeUID(UID : word; Value : string);
var
 i : integer;
begin
if Count = 0 then exit;
for i:=0 to Count-1 do
  begin
  if TUserItem(Objects[i]).UID = UID then
    begin
    TUserItem(Objects[i]).Home:=Value;
    end;
  end;
end;

function TUserList.UIDByName(AName : string) : word;
var
 i : integer;
begin
result:=$FFF0;
i:=IndexOf(AName);
if i >= 0 then
  result:=UID[i];
end;

function TUserList.GIDByName(AName : string;GIndex : integer) : word;
var
 i : integer;
begin
result:=$FFF0;
i:=IndexOf(AName);
if i >= 0 then
  result:=GID[i,GIndex];
end;

function TUserList.PassByName(AName : string) : string;
var
 i : integer;
begin
result:='';
i:=IndexOf(AName);
if i >= 0 then
  result:=Password[i];
end;

function TUserList.RootByName(AName : string) : boolean;
var
 i : integer;
begin
result:=false;
i:=IndexOf(AName);
if i >= 0 then
  result:=Root[i];
end;

function TUserList.HomeByName(AName : string) : string;
var
 i : integer;
begin
result:='';
i:=IndexOf(AName);
if i >= 0 then
  result:=Home[i];
end;

function TUserList.InGroupByName(AName : string; AGID : word) : boolean;
var
 i,j : integer;
begin
result:=false;
if AGID = $FFF0 then
  exit;
i:=IndexOf(AName);
if i >= 0 then
  for j:=1 to 20 do
    if AGID = GID[i,j] then
      begin
      result:=true;
      exit;
      end;
end;

procedure TUserList.GroupsClear(AUID : word);
var
 i : integer;
begin
for i:=1 to 20 do
  GID[AUID,i]:=$FFF0;
end;

function TUserList.GroupsCount(AUID : word) : integer;
var
 i,j : integer;
begin
j:=0;
for i:=1 to 20 do
  if GID[AUID,i] <> $FFF0 then inc(j);
result:=j;
end;

{ ---------- TGrpList ---------- }

function TGrpList.GetGID : word;
var
 a : array [0..8191] of byte;
 i : word;
 j : word;
 w : word;
begin
if Count = 0 then
  begin
  result:=0;
  exit;
  end;
for i:=0 to 8191 do
  a[i]:=0;
for i:=0 to Count-1 do
  begin
  w:=GID[i];
  a[w shr 3]:=a[w shr 3] or ($80 shr (w and 7));
  end;
for i:=0 to 8191 do
  begin
  if a[i] <> $ff then
    begin
    j:=0;
    while (a[i] and $80) <> 0 do
      begin
      inc(j);
      a[i]:=a[i] shl 1;
      end;
    result:=((i shl 3) and $fff8) or j;
    exit;
    end
  end;
result:=$ffff;
end;

constructor TGrpList.create;
begin
inherited create;
sorted:=true;
end;

function TGrpList.AddGrp(Name : string) : integer;
var
 i : integer;
 o : TGrpItem;
begin
Name:=trim(Name);
o:=TGrpItem.create;
o.GID:=GetGID;
i:=IndexOf(Name);
if i = -1 then
  begin
  result:=AddObject(Name,o);
  exit;
  end;
o.destroy;
result:=-1;
end;

procedure TGrpList.AddEntry(Name : string; GID : word);
var
 o : TGrpItem;
begin
Name:=trim(Name);
o:=TGrpItem.create;
o.GID:=GID;
AddObject(Name,o);
end;

function TGrpList.Load;
var
 h,h1 : hKey;
 i : word;
 w : dword;
 ID : word;
 sk : string[100];
begin
Clear;
result:=false;
{ -- Opening Main Key Path -- }
RegOpenKey(HKEY_LOCAL_MACHINE,'SOFTWARE',h1);
if RegOpenKey(h1,'Drt.',h) <> ERROR_SUCCESS then
  begin
  RegCloseKey(h1);
  exit;
  end;
RegCloseKey(h1);
if RegOpenKey(h,'TFTP',h1) <> ERROR_SUCCESS then
  begin
  RegCloseKey(h);
  exit;
  end;
RegCloseKey(h);
if RegOpenKey(h1,'Groups',h) <> ERROR_SUCCESS then
  begin
  RegCloseKey(h1);
  exit;
  end;
RegCloseKey(h1);
i:=0;
while RegEnumKey(h,i,@sk[1],99) = ERROR_SUCCESS do
  begin
  if RegOpenKey(h,@sk[1],h1) = ERROR_SUCCESS then
    begin
    w:=sizeof(ID);
    if RegQueryValueEx(h1,'GID',nil,nil,@ID,@w) = ERROR_SUCCESS then
      begin
      SetStringSize(sk,100);
      AddEntry(sk,ID);
      end;
    RegCloseKey(h1);
    end;
  inc(i);
  end;
RegCloseKey(h);
result:=true;
end;

function TGrpList.Save;
var
 h,h1 : hKey;
 w : word;
 n : word;
 i : word;
 Nm : string;
 ID : word;
begin
{ -- Opening Main Key Path -- }
RegOpenKey(HKEY_LOCAL_MACHINE,'SOFTWARE',h1);
RegCreateKey(h1,'Drt.',h);
RegCloseKey(h1);
RegCreateKey(h,'TFTP',h1);
RegCloseKey(h);
RegCreateKey(h1,'Groups',h);
RegCloseKey(h1);
DeleteSubkeys(h);
n:=Count;
for i:=1 to n do
  begin
  Nm:=Name[i-1]+#0;
  ID:=GID[i-1];
  RegCreateKey(h,@Nm[1],h1);
  w:=sizeof(ID);
  RegSetValueEx(h1,'GID',0,REG_BINARY,@ID,w);
  RegCloseKey(h1);
  end;
RegCloseKey(h);
result:=true;
end;

function TGrpList.RdName(Index : integer) : string;
begin
if (Index < 0) or (Index >= Count) then
  begin
  result:='';
  exit;
  end;
result:=Strings[Index];
end;

function TGrpList.RdGID(Index : integer) : word;
begin
if (Index < 0) or (Index >= Count) then
  begin
  result:=$ffff;
  exit;
  end;
result:=TGrpItem(Objects[Index]).GID;
end;

function TGrpList.RdNameGID(GID : word) : string;
var
 i : integer;
begin
result:='';
if Count = 0 then exit;
for i:=0 to Count-1 do
  begin
  if TGrpItem(Objects[i]).GID = GID then
    begin
    result:=Strings[i];
    end;
  end;
end;

function TGrpList.GIDByName(Name : string) : word;
begin
result:=GID[IndexOf(Name)];
end;

end.