unit URLScan;
{==============================================================================}
{ Scanning RichView for URLs                                                   }
{ Copyright (c) Sergey Tkachenko                                  }
{ StrPosW is from http://www.delphi-unicode.net/Library.php                    }
{==============================================================================}
{ 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;

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: 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 some undocumented methods
function DetectURLs(var RVData: TCustomRVFormattedData; Index: Integer;
  URLScanProcedure: TRVURLScanProcedure; AssignTags: Boolean): Boolean;
var CurrentWord: String;
    i,p: Integer;
    s,s1, tagstr : String;
    pc, pcstart: PChar;
    Len, URLStyle: Integer;
    StringList: TStringList;
    sourceitem,item: TCustomRVItemInfo;
begin
   s := RVData.GetItemTextA(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);
     if (RV_CharPos(PChar(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^, 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;
   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);
    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,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] := StringList[0];
   end;
   StringList.Free;
end;
{======================= Processing Unicode text ==============================}
{$IFDEF RICHVIEWDEF3}
function StrPosW(Str, SubStr: PWideChar): PWideChar;

// returns a pointer to the first occurance of SubStr in Str

asm
         PUSH EDI
         PUSH ESI
         PUSH EBX
         OR EAX, EAX
         JZ @@2
         OR EDX, EDX
         JZ @@2
         MOV EBX, EAX
         MOV EDI, EDX
         XOR AX, AX
         MOV ECX, 0FFFFFFFFH
         REPNE SCASW
         NOT ECX
         DEC ECX
         JZ @@2
         MOV ESI, ECX
         MOV EDI, EBX
         MOV ECX, 0FFFFFFFFH
         REPNE SCASW
         NOT ECX
         SUB ECX, ESI
         JBE @@2
         MOV EDI, EBX
         LEA EBX, [ESI - 1] // Note: 2 would be wrong here, we are dealing with numbers not an address
@@1:     MOV ESI, EDX
         LODSW
         REPNE SCASW
         JNE @@2
         MOV EAX, ECX
         PUSH EDI
         MOV ECX, EBX
         REPE CMPSW
         POP EDI
         MOV ECX, EAX
         JNE @@1
         LEA EAX, [EDI - 2]
         JMP @@3

@@2:     XOR EAX, EAX
@@3:     POP EBX
         POP ESI
         POP EDI
end;
{------------------------------------------------------------------------------}
function CharPosW(const Str: PWideChar {EAX}; Chr: WideChar {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 LowerCaseW(const s: WideString): WideString;
var
  Len: Integer;
begin
  Len := Length(s);
  SetLength(Result, Length(s));
  Move(PWideChar(s)^, PWideChar(Result)^, Length(s)*2);
  if Len > 0 then
    CharLowerBuffW(Pointer(Result), Len);
end;
{--------------------------------------------------------------}
function IsURLW(const str: WideString): Boolean;
var s: WideString;
    ps: PWideChar;
    {....................................}
    function CheckPrefix(Prefix: PWideChar): Boolean;
    begin
      Result := (Length(str)>Length(Prefix)) and (StrPosW(ps, Prefix)=ps);
    end;
    {....................................}
begin
  if Assigned(RVIsCustomURL) then
    Result := RVIsCustomURL(s)
  else
    Result := False;
  if not Result then begin
    // LowerCaseW will work only for WinNT-based systems
    s := LowerCaseW(str);
    ps := PWideChar(s);
    Result :=
          CheckPrefix('http://') or
          CheckPrefix('ftp://') or
          CheckPrefix('file://') or
          CheckPrefix('gopher://') or
          CheckPrefix('mailto:') or
          CheckPrefix('https://') or
          CheckPrefix('news:') or
          CheckPrefix('telnet:') or
          CheckPrefix('wais:') or
          CheckPrefix('www.') or
          CheckPrefix('ftp.');
  end;
end;
{--------------------------------------------------------------}
function IsEmailW(const s: WideString): Boolean;
var i: Integer;
    at: Boolean;
begin
  //'@' must exist and '.' must be after it. This is not comprehensive test,
  //but I think that it's ok
  at := False;
  Result := False;
  for i := 1 to Length(s) do
    case s[i] of
    '@':
       begin
         if at then
           exit;
         at := True;
       end;
    '.':
       begin
         if at then begin
           Result := True;
           exit;
         end;
       end;
    end;
end;
{--------------------------------------------------------------}
function FindCharW(pc: PWideChar; 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: WideString;
    i,p: Integer;
    s : WideString;
    s1: String;
    pc, pcstart: PWideChar;
    tagstr: String;
    Len, URLStyle: Integer;
    StringList: TStringList;
    sourceitem,item: TCustomRVItemInfo;
begin
   s := RVData.GetItemTextW(Index);
   pc := PWideChar(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^, PWideChar(CurrentWord)^, (p-1)*2);
     if (CharPosW(PWideChar(CurrentWord), '.', p-1)<>0) and
        (IsURLW(CurrentWord) or IsEmailW(CurrentWord)) then begin
        if StringList=nil then
          StringList := TStringList.Create;
        if pcstart<pc then begin
          SetLength(s1, (pc-pcstart)*2);
          Move(pcstart^, PChar(s1)^, (pc-pcstart)*2);
          StringList.Add(s1);
        end;
        SetLength(s1, Length(CurrentWord)*2);
        Move(pc^, PChar(s1)^, Length(s1));
        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)*2);
      Move(pcstart^, PChar(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 := RVU_UnicodeToAnsi(RVData.GetStyleCodePage(UrlStyle), 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, StringList[i],item);
    end;
    if StringList.Objects[0]<>nil then begin
      sourceitem.StyleNo := UrlStyle;
      if AssignTags then begin
        tagstr := RVU_UnicodeToAnsi(RVData.GetStyleCodePage(UrlStyle), StringList[0]);
        if RVIsEmail(tagstr) and not RVIsURL(tagstr) then
          tagstr := 'mailto:'+tagstr;
        sourceitem.Tag := Integer(StrNew(PChar(tagstr)));
      end;
    end;
    RVData.Items[Index] := 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 := DetectURLs(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.GetItemTextA(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;
{------------------------------------------------------------------------------}
// Returns WideString from the Clipboard
function GetTextFromClipboardW: WideString;
var
  mem: Cardinal;
  ptr: Pointer;
  s: String;
begin
  Result := '';
  Clipboard.Open;
  try
    mem := Clipboard.GetAsHandle(CF_UNICODETEXT);
    SetLength(s, GlobalSize(mem));
    ptr := GlobalLock(mem);
    Move(ptr^,PChar(s)^, Length(s));
    GlobalUnlock(mem);
  finally
    Clipboard.Close;
  end;
  if Length(s)=0 then exit;
  ptr := RVU_StrScanW(Pointer(s), 0, Length(s) div 2);
  if ptr<>nil then
    SetLength(s, PChar(ptr)-PChar(s));
  Result := RVU_RawUnicodeToWideString(s);
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(GetTextFromClipboardW, rve.CurItemStyle, rve.CurParaStyleNo,
        rve.CurParaStyleNo, False)
    else
      RichView.AddTextNLA(Clipboard.AsText, rve.CurItemStyle, rve.CurParaStyleNo,
        rve.CurParaStyleNo);
    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.
