lazarus-ccr/components/captcha/source/captchactrl.pas

{@@ ----------------------------------------------------------------------------
  This unit implements a CAPTCHA component for Lazarus.

  AUTHOR:  Werner Pamler

  LICENSE: LGPL with linking exception (like Lazarus LCL)
           See the file COPYING.modifiedLGPL.txt, included in the Lazarus
           distribution, for details about the license.
-------------------------------------------------------------------------------}

unit CaptchaCtrl;

{$mode OBJFPC}{$H+}
{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}
interface

uses
  Classes, SysUtils, Graphics, Controls;

type
  TCaptchaChar = record
    Character: String;    // Character (must be a string for UTF8)
    Angle: Integer;       // Rotation angle of character, in degrees
    Position: TPoint;     // Position of character within buffer bitmap (for TextOut)
    FontIndex: Integer;   // Index of font to be used
    Color: TColor;        // Random color of the character
  end;
  TCaptchaCharArray = array of TCaptchaChar;

  TCaptchaLine = record
    StartPt: TPoint;      // Random start point of the line
    EndPt: TPoint;        // Random end point of the line
    Color: TColor;        // Random line color
  end;
  TCaptchaLineArray = array of TCaptchaLine;

  TCaptchaOption = (
    coAlphaUpper, coAlphaLower, coNumeric, coCustom,
    coRotated, coFont1, coFont2, coLines
    );
  TCaptchaOptions = set of TCaptchaOption;
  TCaptchaCharsOption = coAlphaUpper..coCustom;

  TNewCaptchaEvent = (nceNone, nceClick, nceDblClick);

const
  DEFAULT_CAPTCHA_OPTIONS = [
    coAlphaUpper, coAlphaLower, coNumeric, coCustom,
    coRotated, coFont1, coFont2, coLines
  ];
  DEFAULT_CAPTCHA_NUMCHARS = 10;
  DEFAULT_CAPTCHA_NUMLINES = 30;

type
  TCaptchaLabel = class(TGraphicControl)
  private
    FBuffer: TBitmap;
    FCaptchaChars: TCaptchaCharArray;
    FCaptchaLines: TCaptchaLineArray;
    FValidChars: array[TCaptchaCharsOption] of string;
    FFonts: array[0..1] of TFont;
    FInitialized: Boolean;
    FMaxAngle: Integer;
    FNewCaptchaEvent: TNewCaptchaEvent;
    FNumChars: Integer;
    FNumLines: Integer;
    FOptions: TCaptchaOptions;
    function GetCaptchaText: String;
    function GetFont(AIndex: Integer): TFont;
    function GetValidChars(AIndex: Integer): String;
    procedure SetFont(AIndex: Integer; const AValue: TFont);
    procedure SetMaxAngle(const AValue: Integer);
    procedure SetNumChars(const AValue: Integer);
    procedure SetNumLines(const AValue: Integer);
    procedure SetOptions(const AValue: TCaptchaOptions);
    procedure SetValidChars(AIndex: Integer; const AValue: String);
  protected
    function AlmostBackgroundColor(AColor: TColor): Boolean;
    procedure CreateNewCaptcha(ANumChars, ANumLines: Integer; KeepText,KeepLines: Boolean);
    procedure DrawBuffer;
    procedure InitAngles;
    procedure InitCharPos(KeepVertPos: boolean);
    procedure InitFontIndex;
    procedure InitLineColors;
    procedure InitLines(ACount: Integer; KeepExisting: Boolean);
    procedure InitText(ACount: Integer; KeepExisting: Boolean);
    procedure InitTextColors;
  protected
    procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
      WithThemeSpace: Boolean); override;
    procedure Click; override;
    procedure DblClick; override;
    procedure Paint; override;
    procedure Resize; override;
    procedure SetColor(AValue: TColor); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure NewCaptcha;
    function Verify(const AText: String): Boolean;
    property Text: String read GetCaptchaText;
  published
    property CustomChars: String index ord(coCustom) read GetValidChars write SetValidChars;
    property Font1: TFont index 0 read GetFont write SetFont;
    property Font2: TFont index 1 read GetFont write SetFont;
    property Options: TCaptchaOptions read FOptions write SetOptions default DEFAULT_CAPTCHA_OPTIONS;
    property LowercaseChars: String index ord(coAlphaLower) read GetValidChars write SetValidChars;
    property MaxAngle: Integer read FMaxAngle write SetMaxAngle default 60;
    property NumericChars: String index ord(coNumeric) read GetValidChars write SetValidChars;
    property NewCaptchaEvent: TNewCaptchaEvent read FNewCaptchaEvent write FNewCaptchaEvent default nceNone;
    property NumChars: Integer read FNumChars write SetNumChars default DEFAULT_CAPTCHA_NUMCHARS;
    property NumLines: Integer read FNumLines write SetNumLines default DEFAULT_CAPTCHA_NUMLINES;
    property UppercaseChars: String index ord(coAlphaUpper) read GetValidChars write SetValidChars;

    property Align;
    property AutoSize default true;
    property BorderSpacing;
    property Color default clBlack;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseUp;
  end;

procedure Register;

implementation

{$R captcha_images.res}

uses
  LCLIntf, Types, GraphUtil, Math, LazUTF8;

{ Component registration }

procedure Register;
begin
  RegisterComponents('Misc', [TCaptchaLabel]);
end;


{ Utility functions }

function RotatePoint(const APoint: TPoint; Angle: Double): TPoint;
var
  sinphi, cosphi: Double;
begin
  Angle := DegToRad(Angle);
  SinCos(angle, sinphi, cosphi);
  Result.X := Round( cosphi * APoint.X + sinphi * APoint.Y);
  Result.Y := Round(-sinphi * APoint.X + cosphi * APoint.Y);
end;

function RotateRect(const Width, Height: Integer; Angle: Double): TRect;
var
  P0, P1, P2, P3: TPoint;
begin
  P0 := Point(0, 0);
  P1 := RotatePoint(Point(0, Height), Angle);
  P2 := RotatePoint(Point(Width, 0), Angle);
  P3 := RotatePoint(Point(Width, Height), Angle);
  Result.Left := MinValue([P0.X, P1.X, P2.X, P3.X]);
  Result.Top := MinValue([P0.Y, P1.Y, P2.Y, P3.Y]);
  Result.Right := MaxValue([P0.X, P1.X, P2.X, P3.X]);
  Result.Bottom := MaxValue([P0.Y, P1.Y, P2.Y, P3.Y]);
end;


{ TCaptchaLabel }

constructor TCaptchaLabel.Create(AOwner: TComponent);
begin
  inherited;
  with GetControlClassDefaultSize do
    SetInitialBounds(0, 0, 300, 100);
  AutoSize := true;
  Color := clBlack;

  FBuffer := TBitmap.Create;
  FBuffer.PixelFormat := pf32bit;

  FFonts[0] := TFont.Create;
  FFonts[0].Size := 36;

  FFonts[1] := TFont.Create;
  {$IF DEFINED(MSWindows)}
  FFonts[1].Name := 'Courier New';
  {$ELSEIF DEFINED(Linux)}
  FFonts[1].Name := 'FreeMono';
  {$ELSEIF DEFINED(Darwin)}
  Fronts[1].Name := 'Courier';
  {$IFEND}
  FFonts[1].Size := 36;

  FOptions := DEFAULT_CAPTCHA_OPTIONS;
  FMaxAngle := 60;
  FNumChars := DEFAULT_CAPTCHA_NUMCHARS;
  FNumLines := DEFAULT_CAPTCHA_NUMLINES;
  FValidChars[coAlphaUpper] := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  FValidChars[coAlphaLower] := 'abcdefghijklmnopqrstuvwxyz';
  FValidChars[coNumeric] := '0123456789';
  FValidChars[coCustom] := '';
  FInitialized := false;

  // Do not call Randomize at runtime to facilitate debugging.
  if (csDesigning in ComponentState) then
    Randomize;
end;

destructor TCaptchaLabel.Destroy;
begin
  Finalize(FCaptchaChars);
  Finalize(FCaptchaLines);
  FreeAndNil(FFonts[0]);
  FreeAndNil(FFonts[1]);
  FreeAndNil(FBuffer);
  inherited;
end;

function TCaptchaLabel.AlmostBackgroundColor(AColor: TColor): Boolean;
const
  TOLERANCE = 64;
var
  colorH, colorL, colorS: Byte;
  bgColorH, bgColorL, bgColorS: Byte;
begin
  ColorToHLS(ColorToRGB(AColor), colorH, colorL, colorS);
  ColorToHLS(ColorToRGB(Self.Color), bgColorH, bgColorL, bgColorS);
  Result := abs(colorL - bgColorL) < TOLERANCE;
end;

procedure TCaptchaLabel.CalculatePreferredSize(
  var PreferredWidth, PreferredHeight: integer;
  WithThemeSpace: Boolean);
begin
  inherited;

  CreateNewCaptcha(FNumChars, FNumLines, true, true);

  PreferredWidth := FBuffer.Width;
  PreferredHeight := 0;
  if (coFont1 in FOptions) then
  begin
    FBuffer.Canvas.Font.Assign(FFonts[0]);
    PreferredHeight := FBuffer.Canvas.TextHeight('Tg');
  end;
  if (coFont2 in FOptions) then
  begin
    FBuffer.Canvas.Font.Assign(FFonts[1]);
    PreferredHeight := Max(PreferredHeight, FBuffer.Canvas.TextHeight('Tg'));
  end;
  PreferredHeight := 3*PreferredHeight div 2;
end;

procedure TCaptchaLabel.Click;
begin
  inherited;
  if FNewCaptchaEvent = nceClick then
    NewCaptcha;
end;

procedure TCaptchaLabel.CreateNewCaptcha(ANumChars, ANumLines: Integer;
  KeepText, KeepLines: Boolean);
begin
  if not KeepText then
    FCaptchaChars := nil;
  FCaptchaLines := nil;
  InitText(ANumChars, KeepText);
  InitTextColors;                   // after InitText
  InitAngles;
  InitCharPos(false);
  InitLines(ANumLines, KeepLines);  // after InitCharPos
  InitLineColors;                   // after InitLines
  DrawBuffer;
end;

procedure TCaptchaLabel.DblClick;
begin
  inherited;
  if FNewCaptchaEvent = nceDblClick then
    NewCaptcha;
end;

procedure TCaptchaLabel.DrawBuffer;
var
  i: Integer;
begin
  if not Assigned(FBuffer) then
    exit;

  // Fill the buffer background in the requested color.
  FBuffer.Canvas.Brush.Color := Self.Color;
  FBuffer.Canvas.Brush.Style := bsSolid;
  FBuffer.Canvas.FillRect(0, 0, FBuffer.Width, FBuffer.Height);

  // Draw the captcha characters to the buffer bitmap
  if (FOptions * [coAlphaUpper, coAlphaLower, coNumeric, coCustom] <> []) and
     (FOptions * [coFont1, coFont2] <> []) then
  begin
    FBuffer.Canvas.Brush.Style := bsClear;
    for i := 0 to High(FCaptchaChars) do
      with FCaptchaChars[i] do
      begin
        FBuffer.Canvas.Font.Assign(FFonts[FontIndex]);
        FBuffer.Canvas.Font.Color := Color;
        if coRotated in FOptions then
          FBuffer.Canvas.Font.Orientation := Angle * 10
        else
          FBuffer.Canvas.Font.Orientation := 0;
        FBuffer.Canvas.TextOut(Position.X, Position.Y, Character);
      end;
  end;

  // Draw the captcha lines
  if coLines in FOptions then
  begin
    for i := 0 to High(FCaptchaLines) do
      with FCaptchaLines[i] do
      begin
        FBuffer.Canvas.Pen.Color := Color;
        FBuffer.Canvas.Line(StartPt.X, StartPt.Y, EndPt.X, EndPt.Y);
      end;
  end;
end;

function TCaptchaLabel.GetFont(AIndex: Integer): TFont;
begin
  Result := FFonts[AIndex];
end;

function TCaptchaLabel.GetCaptchaText: string;
var
  i: Integer;
begin
  Result := '';
  for i := 0 to High(FCaptchaChars) do
    Result := Result + FCaptchaChars[i].Character;
end;

function TCaptchaLabel.GetValidChars(AIndex: Integer): String;
begin
  Result := FValidChars[TCaptchaCharsOption(AIndex)];
end;

procedure TCaptchaLabel.InitAngles;
var
  i: Integer;
begin
  for i := 0 to High(FCaptchaChars) do
    FCaptchaChars[i].Angle := Random(FMaxAngle*2) - FMaxAngle;
end;

{ Calculates the character positions and stores them in the ChaptchaChars array
  When KeepVertPos is false, the vertical position of the characters is selected
  randomly within the height of the control. Otherwise the already stored
  vertical positions are used. }
procedure TCaptchaLabel.InitCharPos(KeepVertPos: Boolean);
var
  x: Integer;
  i: Integer;
  R: TRect;
  ext: TSize;
  w, h: Integer;
  fnt: TFont;
  maxHeight: Integer;
begin
  maxHeight := 0;
  x := 0;
  for i := 0 to High(FCaptchaChars) do
  begin
    // Set character font
    fnt := FFonts[FCaptchaChars[i].FontIndex];
    FBuffer.Canvas.Font.Assign(fnt);

    // Get character size
    ext := FBuffer.Canvas.TextExtent(FCaptchaChars[i].Character);

    // Rotate the character and get the bounds of the enclosing rectangle.
    // The rotation occurs around the upper left corner of the character.
    if coRotated in FOptions then
      R := RotateRect(ext.CX, ext.CY, FCaptchaChars[i].Angle)
    else
      // unrotated: add some extra space for better legibility
      R := Rect(0, 0, ext.CX * 6 div 5, ext.CY);
    w := R.Right - R.Left;
    h := R.Bottom - R.Top;

    // Horizontal drawing coordinate
    FCaptchaChars[i].Position.X := x - R.Left;

    // Vertical drawing coordinate: randomly inside control
    if not KeepVertPos then
    begin
      if Self.Height > h then
        FCaptchaChars[i].Position.Y := Max(0, Random(Height - h) - R.Top)
      else
        FCaptchaChars[i].Position.Y := 0;
    end;

    // Find max y coordinate needed to enclose the entire text
    maxHeight := Max(maxHeight, FCaptchaChars[i].Position.Y + h);
    // Next drawing position
    x := x + w;
  end;

  // Set size of the bitmap buffer so that the entire captcha is enclosed.
  FBuffer.SetSize(x, maxHeight);
end;

procedure TCaptchaLabel.InitFontIndex;
var
  i: Integer;
begin
  if FOptions * [coFont1, coFont2] = [coFont1] then
    for i := 0 to High(FCaptchaChars) do
      FCaptchaChars[i].FontIndex := 0
  else
  if FOptions * [coFont1, coFont2] = [coFont2] then
    for i := 0 to High(FCaptchaChars) do
      FCaptchaChars[i].FontIndex := 1
  else
    for i := 0 to High(FCaptchaChars) do
      FCaptchaChars[i].FontIndex := Random(2);
end;

{ Pick random color for a line.
  Make sure that the color is not too close to the background color. }
procedure TCaptchaLabel.InitLineColors;
var
  i: Integer;
begin
  // Line colors
  if (FOptions * [coLines] <> []) then
    for i := 0 to High(FCaptchaLines) do
      repeat
        FCaptchaLines[i].Color := TColor(Random($FFFFFF));
      until not AlmostBackgroundColor(FCaptchaLines[i].Color);
end;

procedure TCaptchaLabel.InitLines(ACount: Integer; KeepExisting: Boolean);
var
  i, n: Integer;
begin
  if coLines in FOptions then
  begin
    if KeepExisting then
      n := Length(FCaptchaLines)
    else
      n := 0;
    SetLength(FCaptchaLines, ACount);
    for i := n to High(FCaptchaLines) do
    begin
      // Select random start and end points
      FCaptchaLines[i].StartPt := Point(
        Random(FBuffer.Width),
        Random(FBuffer.Height)
      );
      FCaptchaLines[i].EndPt := Point(
        Random(FBuffer.Width),
        Random(FBuffer.Height)
      );

      // Select random line color
      repeat
        FCaptchaLines[i].Color := TColor(Random($FFFFFF));
      until not AlmostBackgroundColor(FCaptchaLines[i].Color);
    end;
  end;
end;

procedure TCaptchaLabel.InitText(ACount: Integer; KeepExisting: Boolean);
var
  i, n: Integer;
  validChars: String;
  co: TCaptchaCharsOption;
begin
  if (FOptions * [coAlphaUpper, coAlphaLower, coNumeric, coCustom] <> []) and
     (FOptions * [coFont1, coFont2] <> []) then
  begin
    // Prepare character list for captcha
    validChars := '';
    for co in TCaptchaCharsOption do
      if co in FOptions then
        validChars := validChars + FValidChars[co];;
    // Remove characters which are hard to distinguish
    if FOptions * [coAlphaUpper, coAlphaLower] = [coAlphaUpper, coAlphaLower] then
    begin
      i := Pos('I', validChars);  // Remove upper-case I
      if i > 0 then Delete(validChars, i, 1);
      i := Pos('l', validChars);  // Remove lower-case L
      if i > 0 then Delete(validChars, i, 1);
    end;
    if FOptions * [coAlphaUpper, coNumeric] = [coAlphaUpper, coNumeric] then
    begin
      i := Pos('O', validChars);   // Remove upper-case O
      if i > 0 then Delete(validChars, i, 1);
      i := Pos('0', validChars);   // Remove number zero
      if i > 0 then Delete(validChars, i, 1);
    end;

    if KeepExisting then
      n := Length(FCaptchaChars)
    else
      n := 0;
    // Get random captcha characters, but keep previously assigned chars.
    SetLength(FCaptchaChars, ACount);
    for i := n to High(FCaptchaChars) do
    begin
      // Pick random character from the validChars. Take care of UTF8.
      FCaptchaChars[i].Character := UTF8Copy(validChars, random(UTF8Length(validChars)) + 1, 1);

      // Pick one of the fonts
      if FOptions * [coFont1, coFont2] = [coFont1] then
        FCaptchaChars[i].FontIndex := 1
      else
      if FOptions * [coFont1, coFont2] = [coFont2] then
        FCaptchaChars[i].FontIndex := 2
      else
        FCaptchaChars[i].FontIndex := Random(2);

      if KeepExisting then
      begin
        // Set random text color
        repeat
          FCaptchaChars[i].Color := TColor(Random($FFFFFF));
        until not AlmostbackgroundColor(FCaptchaChars[i].Color);

        // Set random rotation angle
        if (coRotated in FOptions) then
          FCaptchaChars[i].Angle := Random(FMaxAngle*2) - FMaxAngle;
      end;
    end;
  end else
    SetLength(FCaptchaChars, 0);
end;

{ Pick random color for a character.
  Make sure that the color is not too close to the background color. }
procedure TCaptchaLabel.InitTextColors;
var
  i: Integer;
begin
  // Character colors
  if (FOptions * [coAlphaUpper, coAlphaLower, coNumeric, coCustom] <> []) then
    for i := 0 to High(FCaptchaChars) do
      repeat
        FCaptchaChars[i].Color := TColor(Random($FFFFFF));
      until not AlmostbackgroundColor(FCaptchaChars[i].Color);
end;

procedure TCaptchaLabel.NewCaptcha;
begin
  CreateNewCaptcha(FNumChars, FNumLines, false, false);
  Invalidate;
end;

procedure TCaptchaLabel.Paint;
begin
  Canvas.Draw((Width - FBuffer.Width) div 2, (Height - FBuffer.Height) div 2, FBuffer);
end;

procedure TCaptchaLabel.Resize;
begin
  inherited;
  if Assigned(FBuffer) and not FInitialized then
  begin
    CreateNewCaptcha(FNumChars, FNumLines, false, false);
    FInitialized := true;
  end;
end;

procedure TCaptchaLabel.SetColor(AValue: TColor);
begin
  if AValue = Color then
    exit;
  inherited SetColor(AValue);
  InitTextColors;
  InitLineColors;
  DrawBuffer;
  Invalidate;
end;

procedure TCaptchaLabel.SetFont(AIndex: Integer; const AValue: TFont);
begin
  if FFonts[AIndex].IsEqual(AValue) then
    exit;
  FFonts[AIndex].Assign(AValue);
  InitFontIndex;
  InitCharPos(true);
  DrawBuffer;
  Invalidate;
end;

procedure TCaptchaLabel.SetMaxAngle(const AValue: Integer);
begin
  if AValue = FMaxAngle then
    exit;
  FMaxAngle := AValue;
  InitAngles;
  InitCharPos(true);
  DrawBuffer;
  Invalidate;
end;

procedure TCaptchaLabel.SetNumChars(const AValue: Integer);
begin
  if AValue = FNumChars then
    exit;
  FNumChars := AValue;
  InitText(FNumChars, true);
  InitAngles;
  InitCharPos(false);
  InitLines(FNumLines, false);
  DrawBuffer;
  Invalidate;
end;

procedure TCaptchaLabel.SetNumLines(const AValue: Integer);
begin
  if AValue = FNumLines then
    exit;
  FNumLines := AValue;
  InitLines(FNumLines, true);
  DrawBuffer;
  Invalidate;
end;

procedure TCaptchaLabel.SetOptions(const AValue: TCaptchaOptions);
var
  oldOptions: TCaptchaOptions;
begin
  if AValue = FOptions then
    exit;
  oldOptions := FOptions;
  FOptions := AValue;
  if (oldOptions * [coAlphaUpper, coAlphaLower, coNumeric, coCustom] <>
          AValue * [coAlphaUpper, coAlphaLower, coNumeric, coCustom])
  then
    InitText(FNumChars, false);
  if (oldOptions * [coFont1, coFont2] <> AValue * [coFont1, coFont2]) then
  begin
    InitFontIndex;
    InitCharPos(false);
  end;
  if (oldOptions * [coRotated] <> AValue * [coRotated]) then
  begin
    InitAngles;
    InitCharPos(true);
  end;
  if oldOptions * [coLines] <> AValue * [coLines] then
    InitLines(FNumLines, true);
  DrawBuffer;
  Invalidate;
end;

procedure TCaptchaLabel.SetValidChars(AIndex: Integer; const AValue: String);
begin
  if FValidChars[TCaptchaCharsOption(AIndex)] = AValue then
    exit;
  FValidChars[TCaptchaCharsOption(AIndex)] := AValue;
  NewCaptcha;
end;


function TCaptchaLabel.Verify(const AText: String): Boolean;
begin
  Result := (AText = GetCaptchaText);
end;

end.