unit URLScan;
{==============================================================================}
{ Scanning RichView for URLs                                                   }
{ Copyright (c) 2001 by Sergey Tkachenko                                       }
{==============================================================================}
{ ClearHypertext allows to convert all (or selected) hypertext links           }
{ to normal text.                                                              }
{ ScanURLs searches for URLs and make them hypertext                           }
{ These functions receive new style for text via call of URLScanProcedure.     }
{ Calling for TRichViewEdit.RVData requires call ClearUndo before.             }
{==============================================================================}

interface

uses SysUtils, Classes,
     RVStyle, RichView, CRVFData, RVTable, RVEdit, RVFuncs, RVItem;

type
  TRVURLScanProcedure = procedure (OldStyleNo: Integer;
                                 var NewStyleNo: Integer;
                                 ToHypertext: Boolean) of object;

function ScanURLs(RVData: TCustomRVFormattedData;
                    URLScanProcedure: TRVURLScanProcedure): Boolean;
function ClearHypertext(RVData: TCustomRVFormattedData;
                          URLScanProcedure: TRVURLScanProcedure): Boolean;

implementation

uses CRVData;

{--------------------------------------------------------------}
function IsAddress(const str: String): Boolean;
var s: String;
begin
  // Checks for prefix.
  // For better results, it should check for lengths...
  s := UpperCase(str);
  Result :=
        (Pos('HTTP://',   s)=1) or
        (Pos('FTP://',    s)=1) or
        (Pos('FILE://',   s)=1) or
        (Pos('GOPHER://', s)=1) or
        (Pos('MAILTO://', s)=1) or        
        (Pos('HTTPS://',  s)=1) or
        (Pos('MAILTO:',   s)=1) or
        (Pos('NEWS:',     s)=1) or
        (Pos('TELNET:',   s)=1) or
        (Pos('WAIS:',     s)=1) or
        (Pos('WWW.',      s)=1) or
        (Pos('FTP.',      s)=1);
end;
{--------------------------------------------------------------}
function IsEmail(const s: String): Boolean;
var p1, p2: Integer;
   pchr: PChar;
begin
  //'@' must exist and '.' must be after it. This is not comprehensive test,
  //but I think that it's ok
  Result := False;
  p1 := Pos('@', s);
  if p1=0 then exit;
  pchr := StrRScan(PChar(s),'.');
  if pchr = nil then exit;
  p2 := pchr - PChar(s)+1;
  if p1>p2 then exit;
  Result := True;
end;
{--------------------------------------------------------------}
function FindChar(pc: PChar; Len: Integer): Integer;
var i: Integer;
begin
  for i := 0 to Len-1 do
    if pc[i] in [' ',',','(',')',';','"',''''] then begin
      Result := i+1;
      exit;
    end;
  Result := 0;
end;
{--------------------------------------------------------------}
// This function uses undocumented methods
function DetectURLs(var RVData: TCustomRVFormattedData;
                     Index: Integer;
                     URLScanProcedure: TRVURLScanProcedure): Boolean;
var CurrentWord: String;
    i,p: Integer;
    s,s1 : String;
    pc, pcstart: PChar;
    Len, Plus, URLStyle: Integer;
    StringList: TStringList;
    sourceitem,item: TCustomRVItemInfo;
begin
   s := RVData.Items[Index];
   pc := PChar(s);
   pcstart := pc;
   Len := Length(s);
   StringList := nil;
   while Len>0 do begin
     p := FindChar(pc, Len);
     if p=1 then begin
       inc(pc);
       dec(Len);
       continue;
     end;
     if p=0 then
       p := Len+1;
     SetLength(CurrentWord, p-1);
     Move(pc^, PChar(CurrentWord)^, p-1);
     Plus := 0;
     if CurrentWord[p-1] in ['.',',',':',';','(',')','"',''''] then begin
       dec(p);
       CurrentWord := Copy(CurrentWord,1, p-1);
       Plus := 1;
     end;
     if (RV_CharPos(PChar(CurrentWord), '.', p-1)<>0) and
        IsAddress(CurrentWord) or IsEmail(CurrentWord) then begin
        if StringList=nil then
          StringList := TStringList.Create;
        if pcstart<pc then begin
          SetLength(s1, pc-pcstart);
          Move(pcstart^, PChar(s1)^, pc-pcstart);
          StringList.Add(s1);
        end;
        StringList.AddObject(CurrentWord, TObject(1));
        inc(pc, p-1);
        dec(Len, p-1);
        pcstart := pc;
        end
     else begin
       inc(pc, p-1);
       dec(Len, p-1);
     end;
     inc(pc, Plus);
     dec(Len,Plus);
   end;
   Result := StringList<>nil;
   if Result then begin
    URLStyle := RVData.GetItemStyle(Index);
    URLScanProcedure(URLStyle, URLStyle, True);
    if URLStyle=RVData.GetItemStyle(Index) then begin
      StringList.Free;
      Result := False;
      exit;
    end;
    if pcstart<pc then begin
      SetLength(s1, pc-pcstart);
      Move(pcstart^, PChar(s1)^, pc-pcstart);
      StringList.Add(s1);
    end;
    sourceitem := RVData.GetItem(Index);
    for i := StringList.Count-1 downto 1 do begin
      item := TCustomRVItemInfoClass(sourceitem.ClassType).Create(RVData);
      item.Assign(sourceitem);
      item.SameAsPrev := True;
      if StringList.Objects[i]<>nil then
        item.StyleNo := UrlStyle;
      RVData.Items.InsertObject(Index+1,StringList[i],item);
    end;
    if StringList.Objects[0]<>nil then
      sourceitem.StyleNo := UrlStyle;
    RVData.Items[Index] := StringList[0];
   end;
   StringList.Free;
end;
{--------------------------------------------------------------}
function ScanURLs(RVData: TCustomRVFormattedData;
                    URLScanProcedure: TRVURLScanProcedure): Boolean;
var i,r,c: Integer;
    table: TRVTableItemInfo;
    RVStyle: TRVStyle;
    StyleNo: Integer;
begin
  Result := False;
  RVStyle := RVData.GetRVStyle;
  for i := RVData.Items.Count-1 downto 0 do begin
    StyleNo := RVData.GetItemStyle(i);
    if StyleNo=rvsTable then begin
      table := TRVTableItemInfo(RVData.GetItem(i));
      for r := 0 to table.Rows.Count-1 do
        for c := 0 to table.Rows[r].Count-1 do
          if table.Cells[r,c]<>nil then
            if ScanURLs(TCustomRVFormattedData(table.Cells[r,c].GetRVData), URLScanProcedure) then begin
              Result := True;
              table.Changed;
            end;
      end
    else if (StyleNo>=0) and not RVStyle.TextStyles[StyleNo].Unicode then begin
       Result := DetectURLs(RVData, i, URLScanProcedure) or Result;
    end;
  end;
end;
{--------------------------------------------------------------}
function ClearHypertext(RVData: TCustomRVFormattedData;
                          URLScanProcedure: TRVURLScanProcedure): Boolean;
var i,r,c: Integer;
    table: TRVTableItemInfo;
    RVStyle: TRVStyle;
    StyleNo: Integer;
begin
  Result := False;
  RVStyle := RVData.GetRVStyle;
  for i := RVData.Items.Count-1 downto 0 do begin
    StyleNo := RVData.GetItemStyle(i);
    if StyleNo=rvsTable then begin
      table := TRVTableItemInfo(RVData.GetItem(i));
      for r := 0 to table.Rows.Count-1 do
        for c := 0 to table.Rows[r].Count-1 do
          if table.Cells[r,c]<>nil then
            if ClearHypertext(TCustomRVFormattedData(table.Cells[r,c].GetRVData), URLScanProcedure) then begin
              Result := True;
              table.Changed;
            end;
      end
    else if (StyleNo>=0) and not RVStyle.TextStyles[StyleNo].Unicode and
            RVStyle.TextStyles[StyleNo].Jump then begin
       URLScanProcedure(StyleNo,StyleNo,False);
       Result := StyleNo<>RVData.GetItemStyle(i);
       if Result then
         RVData.GetItem(i).StyleNo := StyleNo;
    end;
  end;
  if Result then
    RVData.Normalize;
end;

end.
