Ftpsock.pas

Материал из DRKB



unit FtpSock;

{
  CrtSocket for Delphi 32
  Copyright (C) 1999-2001  Paul Toth <tothpaul@free.fr>
  http://tothpaul.free.fr

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

}

interface

uses
  CrtSock, SysUtils;

function FtpLogon(Server, User, Password: string): Integer;
procedure FtpLogoff;
function FtpQuote(cmd: string): Boolean;
function FtpOpenWrite(FileName: string): Integer;
function FtpOpenRead(FileName: string): Integer;
function FtpClose(FileHandle: Integer): Boolean;

function FtpError: string;

implementation

var
  ftpin, ftpout: TextFile;
  last: string;
  Read: Boolean;

function FtpError: string;
begin
  Result := last;
end;

function ReadString: string;
begin
  repeat
    ReadLn(ftpin, Result);
    //   writeln(result);
  until (Length(Result) < 4) or (Result[4] <> '-');
  last := Result;
end;

procedure WriteString(s: string);
begin
  //  writeln('>>>',s);
  WriteLn(ftpout, s);
end;

function Status: Char;
var
  s: string;
begin
  s := ReadString;
  if s = '' then Status := '?'
  else
    Status := s[1];
end;

function Exec(cmd: string): Char;
begin
  WriteString(cmd);
  Result := Status;
end;

function FtpLogon(Server, User, Password: string): Integer;
begin
  Result := CallServer(Server, 21);
  if Result > 0 then
  begin
    AssignCrtSock(Result, ftpin, ftpout);
    if Status = '2' then
    begin
      if (Exec('USER ' + User) = '3') and (Exec('PASS ' + Password) = '2') then exit;
      Disconnect(Result);
      Result := -3;
    end
    else
    begin
      Disconnect(Result);
      Result := -2;
    end;
  end;
end;

procedure FtpLogoff;
begin
  Exec('QUIT');
  CloseFile(ftpout);
end;

function FtpQuote(cmd: string): Boolean;
begin
  WriteString(Cmd);
  Result := (Status = '2');
end;

function GetValue(var s: string): Integer;
var
  i: Integer;
begin
  i := Length(s);
  while s[i] <> ',' do Dec(i);
  Result := StrToInt(Copy(s, i + 1, 3));
  SetLength(s, i - 1);
end;

function FtpOpenWrite(FileName: string): Integer;
var
  s: string;
  b, e: Integer;
  port: Word;
begin
  Read := False;
  Result := -1;
  if Exec('PASV') <> '2' then exit;
  b := 4;
  while (b < Length(last)) and (not (last[b] in ['0'..'9'])) do Inc(b);
  e := Length(last);
  while (e > 0) and (not (last[b] in ['0'..'9'])) do Dec(b);
  s := Copy(last, b, e - b - 1);
  port := GetValue(s);
  port := 256 * GetValue(s) + port;
  for e := 1 to Length(s) do if s[e] = ',' then s[e] := '.';
  // replace "," by "." in IP address
  WriteString('STOR ' + FileName);
  //  writeln('call ',s,':',port);
  Result := CallServer(s, port);
  if (Status <> '1') and (Result >= 0) then
  begin
    Disconnect(Result);
    Result := -1;
  end;
end;

function FtpOpenRead(FileName: string): Integer;
var
  s: string;
  b, e: Integer;
  port: Word;
begin
  Read := True;
  Result := -1;
  if Exec('PASV') <> '2' then exit;
  b := 4;
  while (b < Length(last)) and (not (last[b] in ['0'..'9'])) do Inc(b);
  e := Length(last);
  while (e > 0) and (not (last[b] in ['0'..'9'])) do Dec(b);
  s := Copy(last, b, e - b - 1);
  port := GetValue(s);
  port := 256 * GetValue(s) + port;
  for e := 1 to Length(s) do if s[e] = ',' then s[e] := '.';
  // replace "," by "." in IP address
  WriteString('RETR ' + FileName);
  Result := CallServer(s, port);
  if (Status <> '1') and (Result >= 0) then
  begin
    Disconnect(Result);
    Result := -1;
  end;
end;

function FtpClose(FileHandle: Integer): Boolean;
begin
  Disconnect(FileHandle);
  Result := Status = '2';
end;

end.