{***************************************************************************}
{ TMS Captcha Image for IntraWeb                                            }
{ for Delphi & C++Builder                                                   }
{                                                                           }
{ written by TMS Software                                                   }
{            copyright © 2009 - 2013                                        }
{            Email : info@tmssoftware.com                                   }
{            Web : http://www.tmssoftware.com                               }
{                                                                           }
{ The source code is given as is. The author is not responsible             }
{ for any possible damage done due to the use of this code.                 }
{ The component can be freely used in any application. The complete         }
{ source code remains property of the author and may not be distributed,    }
{ published, given or sold in any form as such. No parts of the source      }
{ code can be included in any other component or application without        }
{ written authorization of the author.                                      }
{***************************************************************************}

unit IWCaptchaImage;

{$I TMSDEFS.INC}

interface

uses
  IWAdvCaptchaImage, IWAdvGDIP,
  Controls, Graphics, Windows,
  {$IFDEF DELPHI6_LVL}
  Types,
  {$ENDIF}
  Classes, IWControl, IWTypes, SysUtils, IWTMSBase, {IWExtCtrls,}
  IWHTMLTag, IWRenderContext, IWColor, IWXMLTag
{----------------------------------------------}
{  I M P O R T A N T   N O T I C E             }
{                                              }
{ If there is a "File not found" compiler      }
{ error, please comment/uncomment the required }
{ lines based on the IntraWeb version.         }
{----------------------------------------------}
  //, Vcl.Imaging.JPeg
  , JPeg
  ;

const
  MAJ_VER = 1; // Major version nr.
  MIN_VER = 6; // Minor version nr.
  REL_VER = 0; // Release nr.
  BLD_VER = 1; // Build nr.
  DATE_VER = 'Nov, 2012'; // Month version

type
  TTIWCaptchaImage = class;

  {$IFDEF DELPHIXE2_LVL}
  [ComponentPlatformsAttribute(pidWin32 or pidWin64)]
  {$ENDIF}
  TTIWCaptchaImage = class(TIWControl)
  private
    FAvoidChars: string;
    FCaptchaCode: string;
    FCaptchaType: TCaptchaType;
    FCaptchaLength: integer;
    FCaptchaBackground: TCaptchaBackground;
    FCaptchaFont: TFont;
    FCaptchaBackgroundColor: TColor;
    FCaptchaBackgroundColorTo: TColor;
    FShapeType: TCaptchaShapeType;
    FShapeOpacity: TFillOpacity;
    FShapeColor: TColor;
    FShapePenWidth: Byte;
    FShapeAngle: Integer;
    FShapeDistance: Integer;
    FUpperCaseAlpha: Boolean;
    FImage: TIWAdvCaptchaImage;
    FNoResize: Boolean;
    FVersion: string;
    FChanged: boolean;
    FUpdateCount: integer;
    //FImageQuality: Integer;
    FCaptchaCodeHatchStyle: THatchStyle;
    FCaptchaCodeStyle: TCaptchaCodeStyle;
    FCaptchaCodeTexture: TCaptchaCodeTexture;
    function GetVersion: string;
    //procedure SetImageQuality(const Value: Integer);
    procedure SetCaptchaCode(const Value: string);
    procedure SetAvoidChars(const Value: string);
    procedure SetCaptchaBackground(const Value: TCaptchaBackground);
    procedure SetCaptchaBackgroundColor(const Value: TColor);
    procedure SetCaptchaBackgroundColorTo(const Value: TColor);
    procedure SetCaptchaFont(const Value: TFont);
    procedure SetCaptchaLength(const Value: Integer);
    procedure SetCaptchaType(const Value: TCaptchaType);
    procedure SetCaptchaCodeHatchStyle(const Value: THatchStyle);
    procedure SetCaptchaCodeStyle(const Value: TCaptchaCodeStyle);
    procedure SetCaptchaCodeTexture(const Value: TCaptchaCodeTexture);
    procedure SetShapeAngle(const Value: Integer);
    procedure SetShapeColor(const Value: TColor);
    procedure SetShapeDistance(const Value: Integer);
    procedure SetShapeOpacity(const Value: TFillOpacity);
    procedure SetShapePenWidth(const Value: Byte);
    procedure SetShapeType(const Value: TCaptchaShapeType);
    procedure SetUpperCaseAlpha(const Value: Boolean);
  protected
    function GenerateCacheFile(): string;
    function ImageHTML(const ASrc: string; AContext: TIWBaseComponentContext): TIWHTMLTag;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Resize; override;
    procedure ApplyAppearance;
    procedure ImageChanged(Sender: TObject);
    procedure IWPaint; override;
    function RenderHTML(AContext: TIWBaseComponentContext): TIWHTMLTag; override;
    function RenderAsync(AContext: TIWBaseHTMLComponentContext): TIWXMLTag; override;
    function GetVersionNr: Integer; virtual;
    function GetVersionString: string; virtual;
    procedure GenerateNew;
  published
    property AvoidChars: string read FAvoidChars write SetAvoidChars;

    property CaptchaCode: string read FCaptchaCode write SetCaptchaCode;
    property CaptchaType: TCaptchaType read FCaptchaType write SetCaptchaType default ctAlphanumeric;
    property CaptchaLength: Integer read FCaptchaLength write SetCaptchaLength default 6;
    property CaptchaBackground: TCaptchaBackground read FCaptchaBackground write SetCaptchaBackground default cbNoise;
    property CaptchaFont: TFont read FCaptchaFont write SetCaptchaFont;
    property CaptchaBackgroundColor: TColor read FCaptchaBackgroundColor write SetCaptchaBackgroundColor default clSilver;
    property CaptchaBackgroundColorTo: TColor read FCaptchaBackgroundColorTo write SetCaptchaBackgroundColorTo default clNone;
    property CaptchaCodeHatchStyle: THatchStyle read FCaptchaCodeHatchStyle write SetCaptchaCodeHatchStyle default HatchStyleSmallConfetti;
    property CaptchaCodeTexture: TCaptchaCodeTexture read FCaptchaCodeTexture write SetCaptchaCodeTexture default ctSolid;
    property CaptchaCodeStyle: TCaptchaCodeStyle read FCaptchaCodeStyle write SetCaptchaCodeStyle default csWave;
    property ShapeType: TCaptchaShapeType read FShapeType write SetShapeType default stArbitrary;
    property ShapeOpacity: TFillOpacity read FShapeOpacity write SetShapeOpacity default 150;
    property ShapeColor: TColor read FShapeColor write SetShapeColor default clBlack;
    property ShapePenWidth: Byte read FShapePenWidth write SetShapePenWidth default 1;
    property ShapeAngle: Integer read FShapeAngle write SetShapeAngle default 0;
    property ShapeDistance: Integer read FShapeDistance write SetShapeDistance default 8;
    property UpperCaseAlpha: Boolean read FUpperCaseAlpha write SetUpperCaseAlpha default False;

    property Version: string read GetVersion;
    //property ImageQuality: Integer read FImageQuality write SetImageQuality default 100;
  end;

  function GetControlHTML(Control: TIWCustomControl; AContext: TIWBaseComponentContext): string;

implementation
uses
  IWGlobal, IWAppForm, IWForm, IWServerControllerBase, IWApplication,
  TMSIWStrings, TMSIWSystem;


function GetControlHTML(Control: TIWCustomControl;
  AContext: TIWBaseComponentContext): string;
var
  it: TIWHTMLTag;
begin
  // !!!!!!!!!!!!!! IMPORTANT NOTICE !!!!!!!!!!!!!!!!!!
  //
  // If you encounter a compilation problem here,
  // make sure that you followed the installation steps
  // in INSTALL.TXT, in particular, that you're using the
  // correct TMSDEFS.INC file
  //
  // !!!!!!!!!!!!!! IMPORTANT NOTICE !!!!!!!!!!!!!!!!!!

  it := Control.RenderHTML(AContext);

  Result := it.Render;
  it.Free;
end;

{ TTIWCaptchaImage }

function TTIWCaptchaImage.RenderAsync(
  AContext: TIWBaseHTMLComponentContext): TIWXMLTag;
var
  js: string;
begin
  Result := TIWXMLTag.CreateTag('control');
  try
    Result.AddStringParam('id', HTMLName);
    Result.AddStringParam('type', 'TIWCaptchaImage');
    RenderAsyncCommonProperties( AContext, Result );

    js := 'el = document.getElementById("' + HTMLName + '");'#13
    + 'if (el)'#13
    + '  el.src = "' + GenerateCacheFile + '"'#13;

    GGetWebApplicationThreadVar.CallBackResponse.AddJavaScriptToExecute(js);

  except
    FreeAndNil(Result);
  end;
end;

function TTIWCaptchaImage.GenerateCacheFile: string;
var
  ms: TMemoryStream;
begin
    if Assigned(FImage) then
    begin
      //Result := GetNewCacheFile('jpg',true);
      ApplyAppearance;
      FCaptchaCode := FImage.CaptchaCode;
      //FImage.SaveToFile(result, ciJPEG);

      ms := TMemoryStream.Create;
      FImage.SaveToStream(ms,ciJPEG);

      try
        ms.Position := 0;
        Result := TIWAppCache.StreamToCacheFile(ms, imgJPEG);
      finally
        ms.Free;
      end;
    end;
end;

procedure TTIWCaptchaImage.GenerateNew;
begin
  if Assigned(FImage) then  
    FImage.GenerateNew;
  Invalidate;
end;

function TTIWCaptchaImage.GetVersion: string;
begin
  Result := FVersion;
end;

function TTIWCaptchaImage.GetVersionNr: Integer;
begin
  Result := MakeLong(MakeWord(BLD_VER, REL_VER), MakeWord(MIN_VER, MAJ_VER));
end;

function TTIWCaptchaImage.GetVersionString: string;
var
  vn: Integer;
begin
  vn := GetVersionNr;
  Result := IntToStr(Hi(Hiword(vn))) + '.' + IntToStr(Lo(Hiword(vn))) + '.' + IntToStr(Hi(Loword(vn))) + '.' + IntToStr(Lo(Loword(vn))) + ' ' + DATE_VER;
end;

procedure TTIWCaptchaImage.ApplyAppearance;
begin
  FImage.Width := Width;
  FImage.Height := Height;

  //FImage.CaptchaCode := CaptchaCode;
  
  FImage.AvoidChars := AvoidChars;
  FImage.CaptchaType := CaptchaType;
  FImage.CaptchaLength := CaptchaLength;
  FImage.CaptchaBackground := CaptchaBackground;
  FImage.CaptchaFont := CaptchaFont;
  FImage.CaptchaBackgroundColor := CaptchaBackgroundColor;
  FImage.CaptchaBackgroundColorTo := CaptchaBackgroundColorTo;
  FImage.ShapeType := ShapeType;
  FImage.ShapeOpacity := ShapeOpacity;
  FImage.ShapeColor := ShapeColor;
  FImage.ShapePenWidth := ShapePenWidth;
  FImage.ShapeAngle := ShapeAngle;
  FImage.ShapeDistance := ShapeDistance;
  FImage.UpperCaseAlpha := UpperCaseAlpha;
end;                                     

constructor TTIWCaptchaImage.Create(AOwner: TComponent);
begin
  inherited;
  FImage := TIWAdvCaptchaImage.Create(Self);

  FImage.GenerateNew;

  FCaptchaCode := FImage.CaptchaCode;
  //FCaptchaCode := '';
  FAvoidChars := 'ol01';  // confusing chars
  FCaptchaFont := TFont.Create;
  FCaptchaFont.Name := 'Tahoma';
  FCaptchaFont.Size := 48;
  FCaptchaType := ctAlphanumeric;
  FCaptchaLength := 6;
  FCaptchaBackgroundColor := clSilver;
  FCaptchaBackgroundColorTo := clNone;
  FCaptchaBackground := cbNoise;
  FCaptchaCodeTexture := ctSolid;
  FCaptchaCodeStyle := csWave;
  FShapeType := stArbitrary;
  FShapeOpacity := 150;
  FShapeAngle := 0;
  FShapeColor := clBlack;
  FShapePenWidth := 1;
  FShapeDistance := 8;
  FCaptchaCodeHatchStyle := HatchStyleSmallConfetti;

  //FImageQuality := 100;

  FNoResize := true;
  Width := FImage.Width;
  Height := FImage.Height;
  FNoResize := false;
  FUpdateCount := 0;
  FVersion := GetVersionString;
end;

destructor TTIWCaptchaImage.Destroy;
begin
  FImage.Free;
  FCaptchaFont.Free;  
  inherited;
end;

procedure TTIWCaptchaImage.IWPaint;
begin
  if not (Assigned(FImage)) then
  begin
    inherited;
    Exit;
  end;

  inc(FUpdateCount);

  if FChanged then
    ApplyAppearance;

  FChanged := false;

  //FImage.GenerateNew;
  FImage.DrawCaptchaImage(Canvas);

  dec(FUpdateCount);
end;

function TTIWCaptchaImage.ImageHTML(const ASrc: string; AContext: TIWBaseComponentContext): TIWHTMLTag;
begin
  Result := TIWHTMLTag.CreateTag('IMG');
  Result.AddStringParam('SRC', ASrc);
  Result.AddStringParam('NAME', HTMLName);
  Result.AddIntegerParam('WIDTH', Width);
  Result.AddIntegerParam('HEIGHT', Height);
end;

procedure TTIWCaptchaImage.ImageChanged(Sender: TObject);
begin
  if FUpdateCount = 0 then
  begin
    FChanged := true;
    Invalidate;
  end;
end;

function TTIWCaptchaImage.RenderHTML(AContext: TIWBaseComponentContext): TIWHTMLTag;
begin
  Result := ImageHTML(GenerateCacheFile, AContext);
end;

procedure TTIWCaptchaImage.Resize;
begin
  inherited;
  if not FNoResize and Assigned(FImage) then
  begin
    FImage.Width := Width;
    FImage.Height := Height;
  end;
end;

procedure TTIWCaptchaImage.SetAvoidChars(const Value: string);
begin
  if FAvoidChars <> value then
  begin
    FAvoidChars := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetCaptchaBackground(
  const Value: TCaptchaBackground);
begin
  if FCaptchaBackground <> value then
  begin
    FCaptchaBackground := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetCaptchaBackgroundColor(const Value: TColor);
begin
  if FCaptchaBackgroundColor <> value then
  begin
    FCaptchaBackgroundColor := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetCaptchaBackgroundColorTo(const Value: TColor);
begin
  if FCaptchaBackgroundColorTo <> value then
  begin
    FCaptchaBackgroundColorTo := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetCaptchaCode(const Value: string);
begin
  if FCaptchaCode <> value then
  begin
    FCaptchaCode := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetCaptchaCodeHatchStyle(const Value: THatchStyle);
begin
  if FCaptchaCodeHatchStyle <> value then
  begin
    FCaptchaCodeHatchStyle := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetCaptchaCodeStyle(const Value: TCaptchaCodeStyle);
begin
  if FCaptchaCodeStyle <> value then
  begin
    FCaptchaCodeStyle := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetCaptchaCodeTexture(
  const Value: TCaptchaCodeTexture);
begin
  if FCaptchaCodeTexture <> value then
  begin
    FCaptchaCodeTexture := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetCaptchaFont(const Value: TFont);
begin
  if FCaptchaFont <> value then
  begin
    FCaptchaFont := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetCaptchaLength(const Value: Integer);
begin
  if FCaptchaLength <> value then
  begin
    FCaptchaLength := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetCaptchaType(const Value: TCaptchaType);
begin
  if FCaptchaType <> value then
  begin
    FCaptchaType := Value;
    ImageChanged(Self);
  end;
end;

{
procedure TTIWCaptchaImage.SetImageQuality(const Value: Integer);
begin
  if FImageQuality <> value then
  begin
    FImageQuality := Value;
    ImageChanged(Self);
  end;
end;
}

procedure TTIWCaptchaImage.SetShapeAngle(const Value: Integer);
begin
  if FShapeAngle <> value then
  begin
    FShapeAngle := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetShapeColor(const Value: TColor);
begin
  if FShapeColor <> value then
  begin
    FShapeColor := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetShapeDistance(const Value: Integer);
begin
  if FShapeDistance <> value then
  begin
    FShapeDistance := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetShapeOpacity(const Value: TFillOpacity);
begin
  if FShapeOpacity <> value then
  begin
    FShapeOpacity := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetShapePenWidth(const Value: Byte);
begin
  if FShapePenWidth <> value then
  begin
    FShapePenWidth := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetShapeType(const Value: TCaptchaShapeType);
begin
  if FShapeType <> value then
  begin
    FShapeType := Value;
    ImageChanged(Self);
  end;
end;

procedure TTIWCaptchaImage.SetUpperCaseAlpha(const Value: Boolean);
begin
  if FUpperCaseAlpha <> value then
  begin
    FUpperCaseAlpha := Value;
    ImageChanged(Self);
  end;
end;

end.
