A jak sprawdzić czy plik znajduje się na serwerze (HTTP) bez próby jego ściągnięcia

Poniższy program wysyła metodą HEAD nagłówki do serwera, dzięki temu otrzymuje od serwera tylko nagłówki bez ew. treści pliku i stwierdza po nich obecność pliki na serwerze.

Do sekcji uses należy dopisać unit IdTCPClient - unit jest z pakietu Indy a program był testowany na Indy 9 i Delphi 7

Kod:

type TPlikInfo=record
  status:string;
  rozmiar:Int64;
  blad:byte;
  lokalizacja:string;
  typ:string;
 end;

const HeFileExist=0;
  HeServerError=1;
  HeFileNotFound=2;
  HeRedirected=3;

// powyżej jest zadeklarowany typ który zwraca funkcja sprawdzająca, zwraca ona status otrzymany od serwera, rozmiar pliku, rodzaj błędu jeśli wystąpił, lokalizację pliku jeśli nastąpiło przekierowanie oraz typ mime

{
  Kod sprawdzania dostępu do pliku na serwerze HTTP by Adamo 2005
}

function dajResztePo(co,wczym:string):string;
// funkcja zwraca ze stringa wszystko po wystąpieniu innego stringu
var c,w:string;
begin
  c:=lowercase(co); w:=lowercase(wczym);
  if Pos(c,w)>0 then
   Result:=Copy(wczym,Pos(c,w)+Length(c),Length(w)) else
   Result:='';
end;

function plikIstnieje(nazwa:string):TPlikInfo;
var host,request,data,text,status:string; client:TIdTCPClient;
 r:TPlikInfo;
const CRL=#13#10;
begin
 r.status:='503 Service Unavailable';
 r.rozmiar:=-1;
 r.blad:=HeServerError;
 r.typ:='...';
 client:=TIdTCPClient.Create(nil);
 host:=nazwa;
 if pos('://',host)>0 then
  host:=Copy(host,pos('://',host)+3,length(host));
 request:='';
 if pos('/',host)>0 then begin
  request:=Copy(host,pos('/',host),length(host));
  host:=Copy(host,1,pos('/',host)-1);
 end;
 if pos('?',host)>0 then begin
  request:=Copy(host,pos('?',host),length(host))+request;
  host:=Copy(host,1,pos('?',host)-1);
 end;
 if (length(request)<1) or (request[1]<>'/') then
  request:='/'+request;
 r.lokalizacja:='http://'+host+request;
 client.Port:=80;
 client.Host:=host;
 try
   client.Connect(3000);
   data:='HEAD '+request+' HTTP/1.0'+CRL+
     'Accept: ..., */*'+CRL+
     'Referer: http://'+host+CRL+
     'Accept-Language: pl'+CRL+
     'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)'+CRL+
     'Host: '+host+CRL+
     'Connection: close'+CRL+CRL;
   client.Write(data);
   r.blad:=HeFileNotFound;
   repeat
     data:=client.ReadLn(#$A,1000);
     ////
     text:=dajResztePo('HTTP/',data);
     if text<>'' then
      status:=dajResztePo(' ',text);
     ////
     text:=dajResztePo('Content-type: ',data);
     if text<>'' then r.typ:=text;
     ////
     text:=dajResztePo('Location: ',data);
     if text<>'' then begin
       r.lokalizacja:=text;
       r.blad:=3;
     end;
     ////
     text:=dajResztePo('Content-Length: ',data);
     if text<>'' then r.rozmiar:=StrToInt(text);
     ////
   until data='';
   if Pos('200',status)>0 then r.blad:=HeFileExist;
   r.status:=status;
 except
   r.blad:=HeServerError;
 end;
 if client.Connected then client.Disconnect;
 client.Free;
 if r.blad<>HeFileExist then r.rozmiar:=-1;
 Result:=r;
end;

---

Przykład użycia:

na formę wrzucić trzy kontrolki Label i jeden Edit oraz jeden Button, pod OnClick buttona przypisać tą procedurę:

procedure TForm1.Button1Click(Sender: TObject);
var r:TPlikInfo;
begin
  Enabled:=false;
  Label1.Caption:='Wysyłam zapytanie do serwera ...';
  Application.ProcessMessages;
  r:=plikIstnieje(Edit1.Text);
  case r.blad of
    HeServerError: Label1.Caption:='Plik jest nieosiągalny';
    HeFileNotFound: Label1.Caption:='Plik nie istnieje na serwerze';
    HeRedirected: Label1.Caption:='Nastąpiło przekierowanie na '+r.lokalizacja;
    HeFileExist: begin
      Label1.Caption:='Plik istnieje na serwerze';
      if r.rozmiar<>-1 then
        Label1.Caption:=Label1.Caption+' i zajmuje '+
          IntToStr(r.rozmiar)+' bajtów';
      end;
  end;
  ////
  Label2.Caption:='Typ: '+r.typ;
  Label3.Caption:='Status: '+r.status;
  Enabled:=true;
end;

procedura zwróci w pierwszym Labelu text czy plik istnieje i ew. ile zajmuje, w drugim typ mime tego pliku a w trzecim status zwrócony przez serwer, jeśli chcemy tylko "true" lub "false" to można dopisać taką funkcję i się do niej odwoływać:

function FileExistsOnServer(URL: String): Boolean;
var r:TPlikInfo; ur:string;
begin
  ur:=URL;
  repeat
    r:=plikIstnieje(ur);
    if r.blad=HeRedirected then ur:=r.lokalizacja;
  until r.blad<>HeRedirected;
  Result:=r.blad=HeFileExist; // zwraca true jeśli plik istnieje
end;

Wsio