Детектор мертвых ссылок

Материал из DRKB


Любой серьезный web сайт и его web мастер должны всегда следить за актуальность ссылок. И если обнаружится мертвая ссылка (например другой web сайт прекратил существование), но нет никаких оправданий для внутренних мертвых ссылок. И поэтому я написал простую программу, назвав ее HTMLINKS, которая может сканировать .HTM файлы на их присутствие на локальной машине. (что бы потом загрузить их на сервер). HTM файлы из текущего каталога и всех подкаталогов рекурсивно читаются и проверяются на тег "<A HREF=" или "<FRAME SRC=". Если страница локальная, то есть без префикса "http://", то файл открывается с использованием относительно пути. Если страница не находится, то мы имеем внутреннюю мертвую ссылку, которая должна быть исправлена!!

Заметим, что программа игнорирует все "file://", "ftp://", "mailto:", "news:" and ".exe?" значения если они встретятся внутри "HREF" части. Конечно, вы свободны в расширить HTMLINKS для проверки и этих случаев, можно также реализовать проверку и внешних ссылок. Для информации я написал и детектор внешних мертвых ссылок в статье для The Delphi Magazine, подробности можно найти на моем web сайте. Для анализа мертвых локальных ссылок код следующий:

{$APPTYPE CONSOLE}
{$I-,H+}
uses
  SysUtils;
var
  Path: String;

procedure CheckHTML(const Path: String);
var
  SRec: TSearchRec;
  Str: String;
  f: Text;
begin
  if FindFirst('*.htm', faArchive, SRec) = 0 then
  repeat
    Assign(f, SRec.Name);
    Reset(f);
    if IOResult = 0 then { no error }
    begin
      while not eof(f) do
      begin
        ReadLn(f, Str);
        while (Pos('<A HREF="', Str) > 0) or
              (Pos('FRAME SRC="', Str) > 0) do
        begin
          if Pos('<A HREF="', Str) > 0 then
            Delete(Str, 1, Pos('HREF="', Str) + 8 - 3)
          else
            Delete(Str, 1, Pos('FRAME SRC="', Str) + 10);
          if  (Pos('#', Str) <> 1)
          and (Pos('http://', Str) <> 1)
          and (Pos('mailto:', Str) <> 1)
          and (Pos('news:', Str) <> 1)
          and (Pos('ftp://', Str) <> 1)
          and (Pos('.exe?', Str) = 0) then { skip external links & exe }
          begin
            if Pos('file:///', Str) = 1 then
              Delete(Str, 1, 8);
            if  (Pos('#', Str) > 0)
            and (Pos('#', Str) < Pos('"', Str)) then
              Str[Pos('#', Str)] := '"';
            if not FileExists(Copy(Str, 1, Pos('"', Str)-1)) then
              WriteLn(Path, '\', SRec.Name, ': [', Copy(Str, 1, Pos('"', Str)-1), ']');
          end;
        end;
      end;
    end;
    Close(f);
    //if IOResult <> 0 then { skip }
  until FindNext(SRec) <> 0;
  FindClose(SRec);
  // check sub-directories recursively
  if FindFirst('*.*', faDirectory, SRec) = 0 then
  repeat
    if ((SRec.Attr AND faDirectory) = faDirectory)
    and (SRec.Name[1] <> '.') then
    begin
      ChDir(SRec.Name);
      CheckHTML(Path + '\' + SRec.Name);
      ChDir('..')
    end;
  until FindNext(SRec) <> 0;
  FindClose(SRec);
end;

begin
  WriteLn('HTMLinks 4.0 (c) 1997-2000 by Bob Swart (aka Dr.Bob - www.drbob42.com)');
  WriteLn;
  FileMode := $40;
  GetDir(0, Path);
  CheckHTML(Path);
end.


Source: Интернет решения от доктора Боба (http://www.drbob42.com)
Author: (c) 2000, Анатолий Подгорецкий, перевод на русский язык (http://nps.vnet.ee/ftp)
ID: 03440