diff --git a/components/captcha/README.txt b/components/captcha/README.txt new file mode 100644 index 000000000..5e9424d2e --- /dev/null +++ b/components/captcha/README.txt @@ -0,0 +1,62 @@ +-------------------------------------------------------------------------------- + Visual CAPTCHA component for Lazarus +-------------------------------------------------------------------------------- + +Description +----------- + +The component TCaptcha descends from TGraphicControl and contains its own drawing +routine. Just place it on the form and use it. It displays a random string with +slanted characters and overlaid lines. + +The method Verify() checks whether a user-provided string matches the +captcha string and returns true. + +There are several properties to define its behaviour: + +* NumChars: Number of characters in the captcha + +* NumLines: Number of lines drawn over the captcha + +* Font1, Font2: two fonts to be mixed within the captcha randomly + +* MaxAngle: maximum rotation angle for the characters which are rotated by a + random angle between -MaxAngle and +MaxAngle + +* Color: the background color of the area of the control covered by the captcha. + Character and line colors are selected such that a minimum brightness difference + to the background color is achieved. + +* Options: This is a set of the following options which can be combined: + * coAlphaUpper: Use uppercase characters as defined by the the UppercaseChars string + * coAlphaLower: Use lowercase characters as defined by the LowercaseChars string + * coNumeric: Use numeric characters as defined by the NumericChars string + (the characters which are hard to distinguish are skipped, + zero vs uppercase O, lowercase L vs upper case I) + * coCustom: Use special characters as defined by the CustomChars string + * coRotated: Characters are rotated + * coFont1: Font1 is used + * coFont2: Font2 is used + * coLines: Lines are drawn over the captcha + +* NewCaptchaEvent: Enumerated property for how to quickly select of a new captcha + string at runtime: + * nceNone: deactivated; captcha can only be changed by code. + * nceClick: a new captcha is created when the user clicks on the control + * nceDblClick: a new captcha is created when the user double-clicks on the control. + + +Installation +------------ + +* Load the package file captcha_pkg.lpk into the Lazarus Package Editor and + click "Use" > "Install" to rebuild the Lazarus IDE. When Lazarus restarts you + find the new component in the palette "Misc". + + +License +------- + +LGPL with linking exception, like the Lazarus LCL. +See the file COPYING.modifiedLGPL.txt, included in the Lazarus distribution, +for details about the license. diff --git a/components/captcha/captcha_pkg.lpk b/components/captcha/captcha_pkg.lpk new file mode 100644 index 000000000..c6f5666dc --- /dev/null +++ b/components/captcha/captcha_pkg.lpk @@ -0,0 +1,40 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/captcha/captcha_pkg.pas b/components/captcha/captcha_pkg.pas new file mode 100644 index 000000000..b115ba8b6 --- /dev/null +++ b/components/captcha/captcha_pkg.pas @@ -0,0 +1,22 @@ +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit captcha_pkg; + +{$warn 5023 off : no warning about unused units} +interface + +uses + CaptchaCtrl, LazarusPackageIntf; + +implementation + +procedure Register; +begin + RegisterUnit('CaptchaCtrl', @CaptchaCtrl.Register); +end; + +initialization + RegisterPackage('captcha_pkg', @Register); +end. diff --git a/components/captcha/demo_runtime/capcha_demo.lpi b/components/captcha/demo_runtime/capcha_demo.lpi new file mode 100644 index 000000000..2436f5620 --- /dev/null +++ b/components/captcha/demo_runtime/capcha_demo.lpi @@ -0,0 +1,89 @@ + + + + + + + + + + + + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <XPManifest> + <DpiAware Value="True"/> + </XPManifest> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="1"> + <Mode0 Name="default"/> + </Modes> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="3"> + <Unit0> + <Filename Value="capcha_demo.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="main.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="DemoForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + </Unit1> + <Unit2> + <Filename Value="..\source\captchactrl.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="CaptchaUnit"/> + </Unit2> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="bin\$(TargetCPU)-$(TargetOS)\capcha_demo"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\source"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Debugging> + <DebugInfoType Value="dsDwarf2Set"/> + </Debugging> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/components/captcha/demo_runtime/capcha_demo.lpr b/components/captcha/demo_runtime/capcha_demo.lpr new file mode 100644 index 000000000..488b6781a --- /dev/null +++ b/components/captcha/demo_runtime/capcha_demo.lpr @@ -0,0 +1,24 @@ +program capcha_demo; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX} + cthreads, + {$ENDIF} + {$IFDEF HASAMIGA} + athreads, + {$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, main + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource:=True; + Application.Initialize; + Application.CreateForm(TDemoForm, DemoForm); + Application.Run; +end. + diff --git a/components/captcha/demo_runtime/main.lfm b/components/captcha/demo_runtime/main.lfm new file mode 100644 index 000000000..23f98f571 --- /dev/null +++ b/components/captcha/demo_runtime/main.lfm @@ -0,0 +1,418 @@ +object DemoForm: TDemoForm + Left = 285 + Height = 385 + Top = 131 + Width = 693 + AutoSize = True + Caption = 'Captcha Demo' + ClientHeight = 385 + ClientWidth = 693 + OnCreate = FormCreate + LCLVersion = '2.3.0.0' + object SettingsPanel: TPanel + Left = 16 + Height = 239 + Top = 130 + Width = 661 + Align = alBottom + AutoSize = True + BorderSpacing.Around = 16 + BevelOuter = bvNone + ClientHeight = 239 + ClientWidth = 661 + TabOrder = 1 + object clbBackgroundColor: TColorBox + AnchorSideLeft.Control = cmbNewCaptchaEvent + AnchorSideTop.Control = SettingsPanel + AnchorSideRight.Control = cmbNewCaptchaEvent + AnchorSideRight.Side = asrBottom + Left = 113 + Height = 22 + Top = 0 + Width = 123 + Anchors = [akTop, akLeft, akRight] + DropDownCount = 32 + ItemHeight = 16 + OnChange = clbBackgroundColorChange + TabOrder = 0 + end + object lblBackgroundColor: TLabel + AnchorSideLeft.Control = SettingsPanel + AnchorSideTop.Control = clbBackgroundColor + AnchorSideTop.Side = asrCenter + Left = 0 + Height = 15 + Top = 4 + Width = 94 + Caption = 'Background color' + end + object lblMaxAngle: TLabel + AnchorSideLeft.Control = SettingsPanel + AnchorSideTop.Control = seMaxAngle + AnchorSideTop.Side = asrCenter + Left = 0 + Height = 15 + Top = 30 + Width = 55 + Caption = 'Max angle' + end + object seMaxAngle: TSpinEdit + AnchorSideLeft.Control = cmbNewCaptchaEvent + AnchorSideTop.Control = clbBackgroundColor + AnchorSideTop.Side = asrBottom + AnchorSideRight.Control = cmbNewCaptchaEvent + AnchorSideRight.Side = asrBottom + Left = 113 + Height = 23 + Top = 26 + Width = 123 + Alignment = taRightJustify + Anchors = [akTop, akLeft, akRight] + BorderSpacing.Top = 4 + Increment = 5 + MaxValue = 90 + OnChange = seMaxAngleChange + TabOrder = 1 + end + object cgOptions: TCheckGroup + AnchorSideLeft.Control = clbBackgroundColor + AnchorSideLeft.Side = asrBottom + AnchorSideTop.Control = SettingsPanel + Left = 260 + Height = 103 + Top = 0 + Width = 418 + AutoFill = True + AutoSize = True + BorderSpacing.Left = 24 + Caption = 'Options' + ChildSizing.LeftRightSpacing = 16 + ChildSizing.TopBottomSpacing = 6 + ChildSizing.HorizontalSpacing = 12 + ChildSizing.EnlargeHorizontal = crsHomogenousChildResize + ChildSizing.EnlargeVertical = crsHomogenousChildResize + ChildSizing.ShrinkHorizontal = crsScaleChilds + ChildSizing.ShrinkVertical = crsScaleChilds + ChildSizing.Layout = cclLeftToRightThenTopToBottom + ChildSizing.ControlsPerLine = 4 + ClientHeight = 83 + ClientWidth = 414 + Columns = 4 + Items.Strings = ( + 'Alpha uppercase' + 'Alpha lowercase' + 'Numeric' + 'Custom' + 'Rotated' + 'Font 1' + 'Font 2' + 'Lines' + ) + OnItemClick = cgOptionsItemClick + TabOrder = 4 + Data = { + 080000000202020202020202 + } + object Label6: TLabel + Left = 16 + Height = 25 + Top = 52 + Width = 108 + Caption = ' ' + end + object btnFont1: TButton + AnchorSideTop.Side = asrBottom + Left = 136 + Height = 25 + Top = 52 + Width = 70 + AutoSize = True + Caption = 'Font 1...' + Constraints.MaxWidth = 70 + OnClick = btnFont1Click + TabOrder = 0 + end + object btnFont2: TButton + AnchorSideLeft.Side = asrBottom + AnchorSideTop.Side = asrBottom + Left = 254 + Height = 25 + Top = 52 + Width = 70 + AutoSize = True + BorderSpacing.Left = 8 + BorderSpacing.Top = 8 + Caption = 'Font 2...' + Constraints.MaxWidth = 70 + Constraints.MinWidth = 70 + OnClick = btnFont2Click + TabOrder = 1 + end + end + object lblCharCount: TLabel + AnchorSideLeft.Control = SettingsPanel + AnchorSideTop.Control = seCharCount + AnchorSideTop.Side = asrCenter + Left = 0 + Height = 15 + Top = 57 + Width = 88 + Caption = 'Character count:' + end + object seCharCount: TSpinEdit + AnchorSideLeft.Control = cmbNewCaptchaEvent + AnchorSideTop.Control = seMaxAngle + AnchorSideTop.Side = asrBottom + AnchorSideRight.Control = cmbNewCaptchaEvent + AnchorSideRight.Side = asrBottom + Left = 113 + Height = 23 + Top = 53 + Width = 123 + Alignment = taRightJustify + Anchors = [akTop, akLeft, akRight] + BorderSpacing.Top = 4 + MaxValue = 90 + OnChange = seCharCountChange + TabOrder = 2 + end + object lblLinesCount: TLabel + AnchorSideLeft.Control = SettingsPanel + AnchorSideTop.Control = seLinesCount + AnchorSideTop.Side = asrCenter + Left = 0 + Height = 15 + Top = 84 + Width = 61 + Caption = 'Lines count' + end + object seLinesCount: TSpinEdit + AnchorSideLeft.Control = cmbNewCaptchaEvent + AnchorSideTop.Control = seCharCount + AnchorSideTop.Side = asrBottom + AnchorSideRight.Control = cmbNewCaptchaEvent + AnchorSideRight.Side = asrBottom + Left = 113 + Height = 23 + Top = 80 + Width = 123 + Alignment = taRightJustify + Anchors = [akTop, akLeft, akRight] + BorderSpacing.Top = 4 + MaxValue = 90 + OnChange = seLinesCountChange + TabOrder = 3 + end + object cmbNewCaptchaEvent: TComboBox + AnchorSideLeft.Control = Label1 + AnchorSideLeft.Side = asrBottom + AnchorSideTop.Control = seLinesCount + AnchorSideTop.Side = asrBottom + AnchorSideRight.Control = seLinesCount + AnchorSideRight.Side = asrBottom + Left = 113 + Height = 23 + Top = 107 + Width = 123 + BorderSpacing.Left = 12 + BorderSpacing.Top = 4 + ItemHeight = 15 + ItemIndex = 0 + Items.Strings = ( + 'none' + 'Click' + 'Double Click' + ) + OnChange = cmbNewCaptchaEventChange + TabOrder = 5 + Text = 'none' + end + object Label1: TLabel + AnchorSideLeft.Control = SettingsPanel + AnchorSideTop.Control = cmbNewCaptchaEvent + AnchorSideTop.Side = asrCenter + Left = 0 + Height = 15 + Top = 111 + Width = 101 + Caption = 'New captcha event' + end + object edUppercaseChars: TEdit + AnchorSideLeft.Control = cmbNewCaptchaEvent + AnchorSideRight.Control = cgOptions + AnchorSideRight.Side = asrBottom + Left = 113 + Height = 23 + Top = 135 + Width = 565 + Anchors = [akTop, akLeft, akRight] + OnChange = edUppercaseCharsChange + TabOrder = 6 + TextHint = 'Upper-case characters to be used' + end + object Label2: TLabel + AnchorSideLeft.Control = SettingsPanel + AnchorSideTop.Control = edUppercaseChars + AnchorSideTop.Side = asrCenter + Left = 0 + Height = 15 + Top = 139 + Width = 60 + Caption = 'Upper-case' + end + object Label3: TLabel + AnchorSideLeft.Control = SettingsPanel + AnchorSideTop.Control = edLowercaseChars + AnchorSideTop.Side = asrCenter + Left = 0 + Height = 15 + Top = 166 + Width = 60 + Caption = 'Lower-case' + end + object edLowercaseChars: TEdit + AnchorSideLeft.Control = cmbNewCaptchaEvent + AnchorSideTop.Control = edUppercaseChars + AnchorSideTop.Side = asrBottom + AnchorSideRight.Control = cgOptions + AnchorSideRight.Side = asrBottom + Left = 113 + Height = 23 + Top = 162 + Width = 565 + Anchors = [akTop, akLeft, akRight] + BorderSpacing.Top = 4 + OnChange = edLowercaseCharsChange + TabOrder = 7 + TextHint = 'Lower-case characters to be used' + end + object Label4: TLabel + AnchorSideLeft.Control = SettingsPanel + AnchorSideTop.Control = edNumericChars + AnchorSideTop.Side = asrCenter + Left = 0 + Height = 15 + Top = 193 + Width = 77 + Caption = 'Numeric chars' + end + object edNumericChars: TEdit + AnchorSideLeft.Control = cmbNewCaptchaEvent + AnchorSideTop.Control = edLowercaseChars + AnchorSideTop.Side = asrBottom + AnchorSideRight.Control = cgOptions + AnchorSideRight.Side = asrBottom + Left = 113 + Height = 23 + Top = 189 + Width = 565 + Anchors = [akTop, akLeft, akRight] + BorderSpacing.Top = 4 + OnChange = edNumericCharsChange + TabOrder = 8 + TextHint = 'Numeric characters' + end + object Label5: TLabel + AnchorSideLeft.Control = SettingsPanel + AnchorSideTop.Control = edCustomChars + AnchorSideTop.Side = asrCenter + Left = 0 + Height = 15 + Top = 220 + Width = 95 + Caption = 'Any custom chars' + end + object edCustomChars: TEdit + AnchorSideLeft.Control = cmbNewCaptchaEvent + AnchorSideTop.Control = edNumericChars + AnchorSideTop.Side = asrBottom + AnchorSideRight.Control = cgOptions + AnchorSideRight.Side = asrBottom + Left = 113 + Height = 23 + Top = 216 + Width = 565 + Anchors = [akTop, akLeft, akRight] + BorderSpacing.Top = 4 + OnChange = edCustomCharsChange + TabOrder = 9 + TextHint = 'Any other characters to be included' + end + end + object gbVerify: TGroupBox + Left = 16 + Height = 69 + Top = 25 + Width = 661 + Align = alBottom + AutoSize = True + BorderSpacing.Around = 16 + Caption = 'Enter CAPTCHA code' + ClientHeight = 49 + ClientWidth = 657 + TabOrder = 0 + object edTestCode: TEdit + AnchorSideLeft.Control = gbVerify + AnchorSideTop.Control = gbVerify + AnchorSideTop.Side = asrCenter + AnchorSideRight.Control = btnVerify + Left = 16 + Height = 23 + Top = 13 + Width = 472 + Anchors = [akTop, akLeft, akRight] + BorderSpacing.Left = 16 + TabOrder = 0 + TextHint = 'Enter the CAPTCHA code here' + end + object btnVerify: TButton + AnchorSideLeft.Control = edTestCode + AnchorSideLeft.Side = asrBottom + AnchorSideTop.Control = gbVerify + AnchorSideTop.Side = asrCenter + AnchorSideRight.Control = btnTryAgain + Left = 500 + Height = 25 + Top = 12 + Width = 56 + Anchors = [akTop, akRight] + AutoSize = True + BorderSpacing.Left = 12 + BorderSpacing.Right = 8 + BorderSpacing.Bottom = 12 + Caption = 'Verify' + OnClick = btnVerifyClick + TabOrder = 1 + end + object btnTryAgain: TButton + AnchorSideTop.Control = gbVerify + AnchorSideTop.Side = asrCenter + AnchorSideRight.Control = gbVerify + AnchorSideRight.Side = asrBottom + Left = 564 + Height = 25 + Top = 12 + Width = 77 + Anchors = [akTop, akRight] + AutoSize = True + BorderSpacing.Right = 16 + Caption = 'Try again!' + OnClick = btnTryAgainClick + TabOrder = 2 + end + end + object Bevel1: TBevel + Left = 0 + Height = 4 + Top = 110 + Width = 693 + Align = alBottom + Shape = bsBottomLine + end + object FontDialog: TFontDialog + MinFontSize = 0 + MaxFontSize = 0 + Left = 496 + Top = 288 + end +end diff --git a/components/captcha/demo_runtime/main.pas b/components/captcha/demo_runtime/main.pas new file mode 100644 index 000000000..f5a9c7979 --- /dev/null +++ b/components/captcha/demo_runtime/main.pas @@ -0,0 +1,192 @@ +unit main; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, ColorBox, + StdCtrls, Spin, CaptchaCtrl; + +type + + { TDemoForm } + + TDemoForm = class(TForm) + Bevel1: TBevel; + btnTryAgain: TButton; + btnFont1: TButton; + btnFont2: TButton; + btnVerify: TButton; + cgOptions: TCheckGroup; + clbBackgroundColor: TColorBox; + cmbNewCaptchaEvent: TComboBox; + edNumericChars: TEdit; + edCustomChars: TEdit; + edUppercaseChars: TEdit; + edLowercaseChars: TEdit; + edTestCode: TEdit; + FontDialog: TFontDialog; + gbVerify: TGroupBox; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + Label4: TLabel; + Label5: TLabel; + Label6: TLabel; + lblBackgroundColor: TLabel; + lblMaxAngle: TLabel; + lblCharCount: TLabel; + lblLinesCount: TLabel; + SettingsPanel: TPanel; + seMaxAngle: TSpinEdit; + seCharCount: TSpinEdit; + seLinesCount: TSpinEdit; + procedure btnTryAgainClick(Sender: TObject); + procedure Button1Click(Sender: TObject); + procedure btnFont1Click(Sender: TObject); + procedure btnFont2Click(Sender: TObject); + procedure btnVerifyClick(Sender: TObject); + procedure cgOptionsItemClick(Sender: TObject; Index: integer); + procedure clbBackgroundColorChange(Sender: TObject); + procedure cmbNewCaptchaEventChange(Sender: TObject); + procedure edCustomCharsChange(Sender: TObject); + procedure edNumericCharsChange(Sender: TObject); + procedure edLowercaseCharsChange(Sender: TObject); + procedure edUppercaseCharsChange(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure seMaxAngleChange(Sender: TObject); + procedure seCharCountChange(Sender: TObject); + procedure seLinesCountChange(Sender: TObject); + private + FCaptcha: TCaptcha; + + public + + end; + +var + DemoForm: TDemoForm; + +implementation + +{$R *.lfm} + +{ TDemoForm } + +procedure TDemoForm.FormCreate(Sender: TObject); +var + i: Integer; +begin + Randomize; + + FCaptcha := TCaptcha.Create(self); + FCaptcha.Width := Width; + FCaptcha.Parent := self; + FCaptcha.Color := clWhite; + FCaptcha.NumChars := 8; + FCaptcha.Align := alClient; + FCaptcha.BorderSpacing.Around := 6; + FCaptcha.CustomChars := 'äöü:'; + FCaptcha.NumericChars := '0123'; + FCaptcha.Options := FCaptcha.Options - [coAlphaUpper, coAlphaLower, coNumeric]; + + clbBackgroundColor.Selected := FCaptcha.Color; + seMaxAngle.Value := FCaptcha.MaxAngle; + seCharCount.Value := FCaptcha.NumChars; + seLinesCount.Value := FCaptcha.NumLines; + edUpperCaseChars.Text := FCaptcha.UppercaseChars; + edLowercaseChars.Text := FCaptcha.LowercaseChars; + edNumericChars.Text := FCaptcha.NumericChars; + edCustomChars.Text := FCaptcha.CustomChars; + for i := 0 to cgOptions.Items.Count-1 do + cgOptions.Checked[i] := TCaptchaOption(i) in FCaptcha.Options; +end; + +procedure TDemoForm.seMaxAngleChange(Sender: TObject); +begin + FCaptcha.MaxAngle := seMaxAngle.Value; +end; + +procedure TDemoForm.seCharCountChange(Sender: TObject); +begin + FCaptcha.NumChars := seCharCount.Value; +end; + +procedure TDemoForm.seLinesCountChange(Sender: TObject); +begin + FCaptcha.NumLines := seLinesCount.Value; +end; + +procedure TDemoForm.clbBackgroundColorChange(Sender: TObject); +begin + FCaptcha.Color := clbBackgroundColor.Selected; +end; + +procedure TDemoForm.cmbNewCaptchaEventChange(Sender: TObject); +begin + FCaptcha.NewCaptchaEvent := TNewCaptchaEvent(cmbNewCaptchaEvent.ItemIndex); +end; + +procedure TDemoForm.edCustomCharsChange(Sender: TObject); +begin + FCaptcha.CustomChars := edCustomChars.Text; +end; + +procedure TDemoForm.edNumericCharsChange(Sender: TObject); +begin + FCaptcha.NumericChars := edNumericChars.Text; +end; + +procedure TDemoForm.edLowercaseCharsChange(Sender: TObject); +begin + FCaptcha.LowercaseChars := edLowercaseChars.Text; +end; + +procedure TDemoForm.edUppercaseCharsChange(Sender: TObject); +begin + FCaptcha.UppercaseChars := edUppercaseChars.Text; +end; + +procedure TDemoForm.btnTryAgainClick(Sender: TObject); +begin + FCaptcha.NewCaptcha; +end; + +procedure TDemoForm.Button1Click(Sender: TObject); +begin + FCaptcha.AutoSize := not FCaptcha.AutoSize; +end; + +procedure TDemoForm.btnFont1Click(Sender: TObject); +begin + FontDialog.Font.Assign(FCaptcha.Font1); + if FontDialog.Execute then + FCaptcha.Font1 := FontDialog.Font; +end; + +procedure TDemoForm.btnFont2Click(Sender: TObject); +begin + FontDialog.Font.Assign(FCaptcha.Font2); + if FontDialog.Execute then + FCaptcha.Font2 := FontDialog.Font; +end; + +procedure TDemoForm.btnVerifyClick(Sender: TObject); +begin + if FCaptcha.Verify(edTestCode.Text) then + ShowMessage('Valid.') + else + ShowMessage('NOT valid.' + LineEnding + 'The correct code would have been: "' + FCaptcha.Text + '"'); +end; + +procedure TDemoForm.cgOptionsItemClick(Sender: TObject; Index: integer); +begin + if cgOptions.Checked[Index] then + FCaptcha.Options := FCaptcha.Options + [TCaptchaOption(Index)] + else + FCaptcha.Options := FCaptcha.Options - [TCaptchaOption(Index)] +end; + +end. + diff --git a/components/captcha/images/make_res.bat b/components/captcha/images/make_res.bat new file mode 100644 index 000000000..dd7b2000e --- /dev/null +++ b/components/captcha/images/make_res.bat @@ -0,0 +1 @@ +lazres ../source/captcha_images.res tcaptcha.png tcaptcha_150.png tcaptcha_200.png \ No newline at end of file diff --git a/components/captcha/images/tcaptcha-screenshot.png b/components/captcha/images/tcaptcha-screenshot.png new file mode 100644 index 000000000..5d00eedfb Binary files /dev/null and b/components/captcha/images/tcaptcha-screenshot.png differ diff --git a/components/captcha/images/tcaptcha.png b/components/captcha/images/tcaptcha.png new file mode 100644 index 000000000..94744f869 Binary files /dev/null and b/components/captcha/images/tcaptcha.png differ diff --git a/components/captcha/images/tcaptcha_150.png b/components/captcha/images/tcaptcha_150.png new file mode 100644 index 000000000..ceb9ca9c1 Binary files /dev/null and b/components/captcha/images/tcaptcha_150.png differ diff --git a/components/captcha/images/tcaptcha_200.png b/components/captcha/images/tcaptcha_200.png new file mode 100644 index 000000000..d992dff38 Binary files /dev/null and b/components/captcha/images/tcaptcha_200.png differ diff --git a/components/captcha/images/tcaptcha_200.svg b/components/captcha/images/tcaptcha_200.svg new file mode 100644 index 000000000..54b176b68 --- /dev/null +++ b/components/captcha/images/tcaptcha_200.svg @@ -0,0 +1,149 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<svg + width="32" + height="32" + id="svg2" + sodipodi:version="0.32" + inkscape:version="1.1 (c68e22c387, 2021-05-23)" + version="1.0" + sodipodi:docname="tcaptcha_200.svg" + inkscape:output_extension="org.inkscape.output.svg.inkscape" + inkscape:export-filename="D:\Prog_Lazarus\wp-git\Captcha_Component\images\tcaptcha_200.png" + inkscape:export-xdpi="144" + inkscape:export-ydpi="144" + xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + xmlns="http://www.w3.org/2000/svg" + xmlns:svg="http://www.w3.org/2000/svg" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:cc="http://creativecommons.org/ns#" + xmlns:dc="http://purl.org/dc/elements/1.1/"> + <defs + id="defs4" /> + <sodipodi:namedview + id="base" + pagecolor="#ffffff" + bordercolor="#666666" + borderopacity="1.0" + inkscape:pageopacity="0.0" + inkscape:pageshadow="2" + inkscape:zoom="22.283453" + inkscape:cx="19.498774" + inkscape:cy="15.661846" + inkscape:document-units="px" + inkscape:current-layer="layer1" + showgrid="true" + objecttolerance="10" + gridtolerance="10" + guidetolerance="10" + showguides="true" + inkscape:guide-bbox="true" + inkscape:window-width="2560" + inkscape:window-height="1017" + inkscape:window-x="-8" + inkscape:window-y="-8" + inkscape:window-maximized="1" + inkscape:snap-bbox="true" + inkscape:bbox-paths="true" + inkscape:bbox-nodes="true" + inkscape:snap-bbox-edge-midpoints="true" + inkscape:snap-bbox-midpoints="true" + inkscape:object-paths="true" + inkscape:snap-intersection-paths="true" + inkscape:snap-smooth-nodes="true" + inkscape:snap-midpoints="true" + inkscape:snap-object-midpoints="true" + inkscape:document-rotation="0" + inkscape:pagecheckerboard="0"> + <inkscape:grid + type="xygrid" + id="grid2409" + visible="true" + enabled="true" + spacingx="0.5" + spacingy="0.5" + empspacing="2" + snapvisiblegridlinesonly="true" + originx="0" + originy="0" /> + </sodipodi:namedview> + <metadata + id="metadata7"> + <rdf:RDF> + <cc:Work + rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type + rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> + <dc:title /> + </cc:Work> + </rdf:RDF> + </metadata> + <g + inkscape:label="Ebene 1" + inkscape:groupmode="layer" + id="layer1"> + <path + style="opacity:1;fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1;stroke-linecap:square;stroke-linejoin:round;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;paint-order:normal" + d="m 23.778199,13.878703 -8.485283,8.485282 H 12.464442 L 8.2218252,18.121319 16.707106,9.636038 h 2.82843 z" + id="rect875" + inkscape:connector-curvature="0" + sodipodi:nodetypes="ccccccc" /> + <rect + style="opacity:0.9;fill:#000000;stroke-width:1.99937;stroke-linecap:round;stroke-linejoin:round;paint-order:markers fill stroke" + id="rect853" + width="28" + height="28" + x="2" + y="2" + rx="6121.7002" + ry="0" /> + <text + xml:space="preserve" + style="font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;font-size:16px;line-height:1.25;font-family:sans-serif;-inkscape-font-specification:'sans-serif, Normal';font-variant-ligatures:normal;font-variant-caps:normal;font-variant-numeric:normal;font-variant-east-asian:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:0.372304" + x="-3.9211442" + y="18.060839" + id="text857" + transform="rotate(-22.87353)"><tspan + sodipodi:role="line" + id="tspan855" + x="-3.9211442" + y="18.060839" + style="font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;font-size:16px;font-family:sans-serif;-inkscape-font-specification:'sans-serif, Normal';font-variant-ligatures:normal;font-variant-caps:normal;font-variant-numeric:normal;font-variant-east-asian:normal;fill:#ffff00;stroke-width:0.372304">a</tspan></text> + <text + xml:space="preserve" + style="font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;font-size:16px;line-height:1.25;font-family:sans-serif;-inkscape-font-specification:'sans-serif, Normal';font-variant-ligatures:normal;font-variant-caps:normal;font-variant-numeric:normal;font-variant-east-asian:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:0.462961" + x="21.717392" + y="8.9995241" + id="text861" + transform="rotate(14.80282)"><tspan + sodipodi:role="line" + id="tspan859" + x="21.717392" + y="8.9995241" + style="font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;font-size:16px;font-family:sans-serif;-inkscape-font-specification:'sans-serif, Normal';font-variant-ligatures:normal;font-variant-caps:normal;font-variant-numeric:normal;font-variant-east-asian:normal;fill:#ff0000;stroke-width:0.462961">5</tspan></text> + <text + xml:space="preserve" + style="font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;font-size:16px;line-height:1.25;font-family:sans-serif;-inkscape-font-specification:'sans-serif, Normal';font-variant-ligatures:normal;font-variant-caps:normal;font-variant-numeric:normal;font-variant-east-asian:normal;fill:#ff00ff;fill-opacity:1;stroke:none;stroke-width:0.382719" + x="9.09375" + y="29.832031" + id="text865"><tspan + sodipodi:role="line" + id="tspan863" + x="9.09375" + y="29.832031" + style="font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;font-size:16px;font-family:sans-serif;-inkscape-font-specification:'sans-serif, Normal';font-variant-ligatures:normal;font-variant-caps:normal;font-variant-numeric:normal;font-variant-east-asian:normal;fill:#ff00ff;stroke-width:0.382719">M</tspan></text> + <path + style="fill:#00ff00;stroke:#00ffff;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="m 3,6 26,8" + id="path867" /> + <path + style="fill:none;stroke:#00ff00;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 6,28 29,22" + id="path869" /> + <path + style="fill:none;stroke:#ffaaaa;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 10,3 29,27" + id="path871" /> + </g> +</svg> diff --git a/components/captcha/source/captcha_images.res b/components/captcha/source/captcha_images.res new file mode 100644 index 000000000..8d10bfe7c Binary files /dev/null and b/components/captcha/source/captcha_images.res differ diff --git a/components/captcha/source/captchactrl.pas b/components/captcha/source/captchactrl.pas new file mode 100644 index 000000000..360d7a573 --- /dev/null +++ b/components/captcha/source/captchactrl.pas @@ -0,0 +1,674 @@ +{@@ ---------------------------------------------------------------------------- + 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+} + +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 + TCaptcha = 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', [TCaptcha]); +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; + + +{ TCaptcha } + +constructor TCaptcha.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 TCaptcha.Destroy; +begin + Finalize(FCaptchaChars); + Finalize(FCaptchaLines); + FreeAndNil(FFonts[0]); + FreeAndNil(FFonts[1]); + FreeAndNil(FBuffer); + inherited; +end; + +function TCaptcha.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 TCaptcha.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 TCaptcha.Click; +begin + inherited; + if FNewCaptchaEvent = nceClick then + NewCaptcha; +end; + +procedure TCaptcha.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 TCaptcha.DblClick; +begin + inherited; + if FNewCaptchaEvent = nceDblClick then + NewCaptcha; +end; + +procedure TCaptcha.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 TCaptcha.GetFont(AIndex: Integer): TFont; +begin + Result := FFonts[AIndex]; +end; + +function TCaptcha.GetCaptchaText: string; +var + i: Integer; +begin + Result := ''; + for i := 0 to High(FCaptchaChars) do + Result := Result + FCaptchaChars[i].Character; +end; + +function TCaptcha.GetValidChars(AIndex: Integer): String; +begin + Result := FValidChars[TCaptchaCharsOption(AIndex)]; +end; + +procedure TCaptcha.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 TCaptcha.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 TCaptcha.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 TCaptcha.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 TCaptcha.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 TCaptcha.InitText(ACount: Integer; KeepExisting: Boolean); +var + i, j, n: Integer; + ok: Boolean; + 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 TCaptcha.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 TCaptcha.NewCaptcha; +begin + CreateNewCaptcha(FNumChars, FNumLines, false, false); + Invalidate; +end; + +procedure TCaptcha.Paint; +begin + Canvas.Draw((Width - FBuffer.Width) div 2, (Height - FBuffer.Height) div 2, FBuffer); +end; + +procedure TCaptcha.Resize; +begin + inherited; + if Assigned(FBuffer) and not FInitialized then + begin + CreateNewCaptcha(FNumChars, FNumLines, false, false); + FInitialized := true; + end; +end; + +procedure TCaptcha.SetColor(AValue: TColor); +begin + if AValue = Color then + exit; + inherited SetColor(AValue); + InitTextColors; + InitLineColors; + DrawBuffer; + Invalidate; +end; + +procedure TCaptcha.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 TCaptcha.SetMaxAngle(const AValue: Integer); +begin + if AValue = FMaxAngle then + exit; + FMaxAngle := AValue; + InitAngles; + InitCharPos(true); + DrawBuffer; + Invalidate; +end; + +procedure TCaptcha.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 TCaptcha.SetNumLines(const AValue: Integer); +begin + if AValue = FNumLines then + exit; + FNumLines := AValue; + InitLines(FNumLines, true); + DrawBuffer; + Invalidate; +end; + +procedure TCaptcha.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 TCaptcha.SetValidChars(AIndex: Integer; const AValue: String); +begin + if FValidChars[TCaptchaCharsOption(AIndex)] = AValue then + exit; + FValidChars[TCaptchaCharsOption(AIndex)] := AValue; + NewCaptcha; +end; + + +function TCaptcha.Verify(const AText: String): Boolean; +begin + Result := (AText = GetCaptchaText); +end; + +end. +