unit URLScan;
{==============================================================================}
{ Scanning RichView for URLs                                                   }
{ Copyright (c) Sergey Tkachenko                                  }
{==============================================================================}
{ Unicode uppercase URLs can be processed only in WinNT/2000/XP                }
{==============================================================================}

interface

{$I RV_Defs.inc}

uses Windows, Messages, SysUtils, Classes, Clipbrd,
     RVStyle, RVScroll, RichView, CRVFData, RVTable, RVEdit, RVFuncs, RVItem,
     RVUni, RVStr, RVTypes;

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

//--------------------- Document scanning -------------------------------------
// Detecting URLs
function ScanURLs(RVData: TCustomRVFormattedData;
  URLScanProcedure: TRVURLScanProcedure; AssignTags: Boolean): Boolean;
// Removing all URLs
function ClearHypertext(RVData: TCustomRVFormattedData;
  URLScanProcedure: TRVURLScanProcedure; ClearTags: Boolean): Boolean;
//---------------------- Detect on typing -------------------------------------
// Closing hyperlink
procedure TerminateHyperlink(rve: TCustomRichViewEdit;
  URLScanProcedure: TRVURLScanProcedure; Forced: Boolean);
// Detecting URL on typing
procedure DetectURL(rve: TCustomRichViewEdit; URLScanProcedure: TRVURLScanProcedure;
  AssignTags: Boolean);
//----------------------- Clipboard -------------------------------------------
// Pasting text with URL detection
function PasteTextWithURLs(rve: TCustomRichViewEdit;
  URLScanProc: TRVURLScanProcedure): Boolean;

implementation

uses CRVData;

{======================= Processing ANSI text =================================}
function FindChar(pc: PRVAnsiChar; 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 some undocumented methods
function DetectURLsA(var RVData: TCustomRVFormattedData; Index: Integer;
  URLScanProcedure: TRVURLScanProcedure; AssignTags: Boolean): Boolean;
var CurrentWord: TRVAnsiString;
    i,p: Integer;
    s,s1: TRVAnsiString;
    tagstr : String;
    pc, pcstart: PRVAnsiChar;
    Len, URLStyle: Integer;
    StringList: TStringList;
    sourceitem,item: TCustomRVItemInfo;
begin
   s := RVData.GetItemTextA(Index);
   pc := PRVAnsiChar(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^, PRVAnsiChar(CurrentWord)^, p-1);
     if (RV_CharPos(PRVAnsiChar(CurrentWord), '.', p-1)<>0) and
        (RVIsURL(String(CurrentWord)) or RVIsEmail(String(CurrentWord))) then begin
        if StringList=nil then
          StringList := TStringList.Create;
        if pcstart<pc then begin
          SetLength(s1, pc-pcstart);
          Move(pcstart^, PRVAnsiChar(s1)^, pc-pcstart);
          StringList.Add(String(s1));
        end;
        StringList.AddObject(String(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;
   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^, PRVAnsiChar(s1)^, pc-pcstart);
      StringList.Add(String(s1));
    end;
    sourceitem := RVData.GetItem(Index);
    if not (rvoTagsArePChars in RVData.Options) then
      AssignTags := False;
    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 begin
        item.StyleNo := UrlStyle;
        if AssignTags then begin
          tagstr := StringList[i];
          if RVIsEmail(tagstr) and not RVIsURL(tagstr) then
            tagstr := 'mailto:'+tagstr;
          item.Tag := Integer(StrNew(PChar(tagstr)));
        end;
      end;
      RVData.Items.InsertObject(Index+1, TRVAnsiString(StringList[i]),item);
    end;
    if StringList.Objects[0]<>nil then begin
      sourceitem.StyleNo := UrlStyle;
      if AssignTags then begin
        tagstr := StringList[0];
        if RVIsEmail(tagstr) and not RVIsURL(tagstr) then
          tagstr := 'mailto:'+tagstr;
        sourceitem.Tag := Integer(StrNew(PChar(tagstr)));
      end;
    end;
    RVData.Items[Index] := TRVAnsiString(StringList[0]);
   end;
   StringList.Free;
end;
{======================= Processing Unicode text ==============================}
{$IFDEF RICHVIEWDEF3}
{------------------------------------------------------------------------------}
function CharPosW(const Str: PRVUnicodeChar {EAX}; Chr: TRVUnicodeChar {DX} ;
  Length: Integer {ECX}): Integer; assembler;
asm
        TEST    EAX,EAX
        JE      @@2
        PUSH    EDI
        PUSH    EBX
        MOV     EDI,Str
        MOV     EBX,Str
        MOV     AX,Chr
        REPNE   SCASW
        MOV     EAX,0
        JNE     @@1
        MOV     EAX,EDI
        SUB     EAX,EBX
@@1:    POP     EBX
        POP     EDI
@@2:
end;
{--------------------------------------------------------------}
function FindCharW(pc: PRVUnicodeChar; Len: Integer): Integer;
var i: Integer;
begin
  for i := 0 to Len-1 do
    if pc[i] in [WideChar(' '),WideChar(','),WideChar('('),WideChar(')'),
      WideChar(';'),WideChar('"'),WideChar(''''),
      WideChar('‘'), WideChar('’'), WideChar('“'), WideChar('”'), WideChar('<'),
      WideChar('>')] then begin
      Result := i+1;
      exit;
    end;
  Result := 0;
end;
{--------------------------------------------------------------}
// This function uses some undocumented methods
function DetectURLsW(var RVData: TCustomRVFormattedData; Index: Integer;
  URLScanProcedure: TRVURLScanProcedure; AssignTags: Boolean): Boolean;
var CurrentWord: TRVUnicodeString;
    i,p: Integer;
    s : TRVUnicodeString;
    s1: TRVUnicodeString;
    pc, pcstart: PRVUnicodeChar;
    tagstr: String;
    Len, URLStyle: Integer;
    StringList: TStringList;
    sourceitem,item: TCustomRVItemInfo;
begin
   s := RVData.GetItemTextW(Index);
   pc := PRVUnicodeChar(s);
   pcstart := pc;
   Len := Length(s);
   StringList := nil;
   while Len>0 do begin
     p := FindCharW(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^, PRVUnicodeChar(CurrentWord)^, (p-1)*2);
     if (CharPosW(PRVUnicodeChar(CurrentWord), '.', p-1)<>0) and
        (RVIsURL(CurrentWord) or RVIsEmail(CurrentWord)) then begin
        if StringList=nil then
          StringList := TStringList.Create;
        if pcstart<pc then begin
          SetLength(s1, pc-pcstart);
          Move(pcstart^, Pointer(s1)^, (pc-pcstart)*2);
          StringList.Add(s1);
        end;
        SetLength(s1, Length(CurrentWord));
        Move(pc^, Pointer(s1)^, Length(s1)*2);
        StringList.AddObject(s1, TObject(1));
        inc(pc, p-1);
        dec(Len, p-1);
        pcstart := pc;
        end
     else begin
       inc(pc, p-1);
       dec(Len, p-1);
     end;
   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^, Pointer(s1)^, (pc-pcstart)*2);
      StringList.Add(s1);
    end;
    sourceitem := RVData.GetItem(Index);
    if not (rvoTagsArePChars in RVData.Options) then
      AssignTags := False;    
    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 begin
        item.StyleNo := UrlStyle;
        if AssignTags then begin
          tagstr := StringList[i];
          if RVIsEmail(tagstr) and not RVIsURL(tagstr) then
            tagstr := 'mailto:'+tagstr;
          item.Tag := Integer(StrNew(PChar(tagstr)));
        end;
      end;
      RVData.Items.InsertObject(Index+1, RVU_GetRawUnicode(StringList[i]),item);
    end;
    if StringList.Objects[0]<>nil then begin
      sourceitem.StyleNo := UrlStyle;
      if AssignTags then begin
        tagstr := StringList[0];
        if RVIsEmail(tagstr) and not RVIsURL(tagstr) then
          tagstr := 'mailto:'+tagstr;
        sourceitem.Tag := Integer(StrNew(PChar(tagstr)));
      end;
    end;
    RVData.Items[Index] := RVU_GetRawUnicode(StringList[0]);
   end;
   StringList.Free;
end;
{$ENDIF}
{========================== Common functions ==================================}
function ScanURLs(RVData: TCustomRVFormattedData;
  URLScanProcedure: TRVURLScanProcedure; AssignTags: Boolean): 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,
              AssignTags) then begin
              Result := True;
              table.Changed;
            end;
      end
    else if (StyleNo>=0) then
      if not RVStyle.TextStyles[StyleNo].Unicode then
         Result := DetectURLsA(RVData, i, URLScanProcedure, AssignTags) or Result
      {$IFDEF RICHVIEWDEF3}
      else
         Result := DetectURLsW(RVData, i, URLScanProcedure, AssignTags) or Result
      {$ENDIF};
  end;
end;
{--------------------------------------------------------------}
function ClearHypertext(RVData: TCustomRVFormattedData;
  URLScanProcedure: TRVURLScanProcedure; ClearTags: Boolean): 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, ClearTags) then begin
              Result := True;
              table.Changed;
            end;
      end
    else if (StyleNo>=0) and RVStyle.TextStyles[StyleNo].Jump then begin
       URLScanProcedure(StyleNo,StyleNo,False);
       if StyleNo<>RVData.GetItemStyle(i) then begin
         RVData.GetItem(i).StyleNo := StyleNo;
         if ClearTags then
           RVData.SetItemTag(i, 0);
         Result := True;
       end;
    end;
  end;
  if Result then
    RVData.Normalize;
end;
{------------------------------------------------------------------------------}
procedure DetectURL(rve: TCustomRichViewEdit; URLScanProcedure: TRVURLScanProcedure;
  AssignTags: Boolean);
var ItemNo, WordEnd, WordStart, CurStyleNo, HypStyleNo: Integer;
    s: String;
    EndShifted: Boolean;
begin
  rve := rve.TopLevelEditor;
  if rve.SelectionExists then
    exit;
  ItemNo := rve.CurItemNo;
  if (rve.GetItemStyle(ItemNo)<0) or rve.Style.TextStyles[rve.GetItemStyle(ItemNo)].Jump then
    exit;
  WordEnd := rve.OffsetInCurItem;
  if WordEnd<=1 then
    exit;
  s := rve.GetItemTextW(ItemNo);
  WordStart := WordEnd-1;
  while (WordStart>1) and (s[WordStart-1]<>' ') do
    dec(WordStart);
  EndShifted := False;
  s := Copy(s, WordStart, WordEnd-WordStart);
  if (Length(s)>0) and (s[1] in ['<','(','{','[','''','"','‘','’','“','”']) then begin
    inc(WordStart);
    s := Copy(s, 2, Length(s)-1);
  end;
  if (Length(s)>0) and (s[Length(s)] in ['>',')','}',']','''','"','‘','’','“','”',',',':',';']) then begin
    dec(WordEnd);
    s := Copy(s, 1, Length(s)-1);
    EndShifted := True;
  end;
  if RVIsEmail(s) or RVIsURL(s) then begin
    CurStyleNo := rve.CurTextStyleNo;
    rve.SetSelectionBounds(ItemNo, WordStart, ItemNo, WordEnd);
    HypStyleNo := rve.GetItemStyle(ItemNo);
    URLScanProcedure(HypStyleNo, HypStyleNo, True);
    rve.ApplyTextStyle(HypStyleNo);
    if not RVIsURL(s) and RVIsEmail(s) then
      s := 'mailto:'+s;
    if AssignTags and (rvoTagsArePChars in rve.Options) then
      rve.SetCurrentTag(Integer(StrNew(PChar(s))));
    rve.SetSelectionBounds(rve.CurItemNo, rve.OffsetInCurItem, rve.CurItemNo, rve.OffsetInCurItem);
    if EndShifted then
      SendMessage(rve.Handle, WM_KEYDOWN, VK_RIGHT, 0);
    rve.CurTextStyleNo := CurStyleNo;
  end;
end;
{------------------------------------------------------------------------------}
procedure TerminateHyperlink(rve: TCustomRichViewEdit;
  URLScanProcedure: TRVURLScanProcedure; Forced: Boolean);
var StyleNo: Integer;
begin
  if (rve.CurTextStyleNo=rve.CurItemStyle) and
     rve.Style.TextStyles[rve.CurTextStyleNo].Jump and
     not rve.SelectionExists then begin
    rve := rve.TopLevelEditor;
    if (rve.OffsetInCurItem>=rve.GetOffsAfterItem(rve.CurItemNo)) or Forced then begin
      StyleNo := rve.CurTextStyleNo;
      URLScanProcedure(StyleNo, StyleNo, False);
      rve.CurTextStyleNo := StyleNo;
    end;
  end;
end;
{------------------------------------------------------------------------------}
// Pastes plain text from the Clipboard with URL detection
// Works only if RVF and RTF is not available in the Clipboard
function PasteTextWithURLs(rve: TCustomRichViewEdit;
  URLScanProc: TRVURLScanProcedure): Boolean;
var RichView: TRichView;
    Stream: TMemoryStream;
begin
  Result := False;
  if not Clipboard.HasFormat(CF_TEXT) or
    Clipboard.HasFormat(CFRV_RVF) or
    Clipboard.HasFormat(CFRV_RTF) then
    exit;
  RichView := TRichView.Create(nil);
  try
    RichView.Style := rve.Style;
    RichView.Visible := False;
    RichView.Options := rve.Options;
    RichView.Parent := rve.Parent;
    if rve.Style.TextStyles[rve.CurItemStyle].Unicode and
       Clipboard.HasFormat(CF_UNICODETEXT) then
      RichView.AddTextNLW(Clipboard.AsText, rve.CurItemStyle, rve.CurParaStyleNo,
        rve.CurParaStyleNo, False);
    ScanURLs(RichView.RVData, URLScanProc, True);
    Stream := TMemoryStream.Create;
    try
      RichView.SaveRVFToStream(Stream, False);
      Stream.Position := 0;
      rve.InsertRVFFromStreamEd(Stream);
      Result := True;
    finally
      Stream.Free;
    end;
  finally
    RichView.Free;
  end;
end;


end.
