diff --git a/components/everettrandom/latest_stable/demo/everett_demo.ico b/components/everettrandom/latest_stable/demo/everett_demo.ico new file mode 100644 index 000000000..0341321b5 Binary files /dev/null and b/components/everettrandom/latest_stable/demo/everett_demo.ico differ diff --git a/components/everettrandom/latest_stable/demo/everett_demo.lpi b/components/everettrandom/latest_stable/demo/everett_demo.lpi new file mode 100644 index 000000000..389d31ff7 --- /dev/null +++ b/components/everettrandom/latest_stable/demo/everett_demo.lpi @@ -0,0 +1,174 @@ + + + + + + + + + + + + + <Scaled Value="True"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <XPManifest> + <DpiAware Value="True"/> + </XPManifest> + <Icon Value="0"/> + </General> + <VersionInfo> + <UseVersionInfo Value="True"/> + <MinorVersionNr Value="1"/> + </VersionInfo> + <BuildModes Count="3"> + <Item1 Name="Debug" Default="True"/> + <Item2 Name="Win64"> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="$(ProjPath)\win64bit\everett_demo"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <CodeGeneration> + <SmartLinkUnit Value="True"/> + <TargetCPU Value="x86_64"/> + <TargetOS Value="win64"/> + <Optimizations> + <OptimizationLevel Value="3"/> + </Optimizations> + </CodeGeneration> + <Linking> + <Debugging> + <GenerateDebugInfo Value="False"/> + </Debugging> + <LinkSmart Value="True"/> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + </Item2> + <Item3 Name="Win32"> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="$(ProjPath)\win32bit\everett_demo"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <CodeGeneration> + <SmartLinkUnit Value="True"/> + <TargetCPU Value="i386"/> + <TargetOS Value="win32"/> + <Optimizations> + <OptimizationLevel Value="3"/> + </Optimizations> + </CodeGeneration> + <Linking> + <Debugging> + <GenerateDebugInfo Value="False"/> + </Debugging> + <LinkSmart Value="True"/> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + </Item3> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0"/> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="everettrandom"/> + <MinVersion Minor="1" Release="2" Valid="True"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="everett_demo.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="umainform.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="mainform"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="$(ProjPath)\debug\everett_demo"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <IncludeAssertionCode Value="True"/> + </SyntaxOptions> + </Parsing> + <CodeGeneration> + <Checks> + <IOChecks Value="True"/> + <RangeChecks Value="True"/> + <OverflowChecks Value="True"/> + <StackChecks Value="True"/> + </Checks> + <VerifyObjMethodCallValidity Value="True"/> + </CodeGeneration> + <Linking> + <Debugging> + <DebugInfoType Value="dsDwarf2Set"/> + <UseHeaptrc Value="True"/> + <TrashVariables Value="True"/> + <UseExternalDbgSyms Value="True"/> + </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/everettrandom/latest_stable/demo/everett_demo.lpr b/components/everettrandom/latest_stable/demo/everett_demo.lpr new file mode 100644 index 000000000..fb342f8c6 --- /dev/null +++ b/components/everettrandom/latest_stable/demo/everett_demo.lpr @@ -0,0 +1,23 @@ +program everett_demo; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, umainform + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource:=True; + Application.Title:='Demo of TEverett'; + Application.Scaled:=True; + Application.Initialize; + Application.CreateForm(Tmainform, mainform); + Application.Run; +end. + diff --git a/components/everettrandom/latest_stable/demo/everett_demo.lps b/components/everettrandom/latest_stable/demo/everett_demo.lps new file mode 100644 index 000000000..da330332c --- /dev/null +++ b/components/everettrandom/latest_stable/demo/everett_demo.lps @@ -0,0 +1,214 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="11"/> + <BuildModes Active="Debug"/> + <Units Count="10"> + <Unit0> + <Filename Value="everett_demo.lpr"/> + <IsPartOfProject Value="True"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="-1"/> + <TopLine Value="-1"/> + <CursorPos X="-1" Y="-1"/> + <UsageCount Value="103"/> + </Unit0> + <Unit1> + <Filename Value="umainform.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="mainform"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="18"/> + <CursorPos X="29" Y="51"/> + <UsageCount Value="103"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit1> + <Unit2> + <Filename Value="..\uclseverett.pas"/> + <UnitName Value="useverettrandom"/> + <EditorIndex Value="-1"/> + <CursorPos X="18" Y="9"/> + <UsageCount Value="17"/> + </Unit2> + <Unit3> + <Filename Value="..\everettrandom.pas"/> + <EditorIndex Value="-1"/> + <CursorPos X="47" Y="11"/> + <UsageCount Value="18"/> + </Unit3> + <Unit4> + <Filename Value="..\everett_httpclient.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="734"/> + <CursorPos X="20" Y="767"/> + <UsageCount Value="38"/> + </Unit4> + <Unit5> + <Filename Value="..\ueverettrandom.pas"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="1"/> + <TopLine Value="126"/> + <CursorPos X="21" Y="166"/> + <UsageCount Value="38"/> + <Loaded Value="True"/> + </Unit5> + <Unit6> + <Filename Value="..\..\..\lazautoupdate\latest_stable\ulazautoupdate.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="235"/> + <UsageCount Value="5"/> + </Unit6> + <Unit7> + <Filename Value="..\..\..\examplecomponent\latest_stable\myexamplecontrol.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="112"/> + <UsageCount Value="5"/> + </Unit7> + <Unit8> + <Filename Value="..\..\..\aboutcomponent\aboutcomponentunit.pas"/> + <UnitName Value="AboutComponentunit"/> + <EditorIndex Value="-1"/> + <TopLine Value="268"/> + <CursorPos X="37" Y="29"/> + <UsageCount Value="36"/> + </Unit8> + <Unit9> + <Filename Value="C:\lazarustrunk32\lazarus\lcl\extctrls.pp"/> + <UnitName Value="ExtCtrls"/> + <EditorIndex Value="-1"/> + <TopLine Value="1068"/> + <CursorPos X="3" Y="1091"/> + <UsageCount Value="35"/> + </Unit9> + </Units> + <JumpHistory Count="30" HistoryIndex="29"> + <Position1> + <Filename Value="..\ueverettrandom.pas"/> + <Caret Line="227" TopLine="196"/> + </Position1> + <Position2> + <Filename Value="..\ueverettrandom.pas"/> + <Caret Line="231" Column="13" TopLine="214"/> + </Position2> + <Position3> + <Filename Value="..\ueverettrandom.pas"/> + <Caret Line="297" Column="34" TopLine="275"/> + </Position3> + <Position4> + <Filename Value="..\ueverettrandom.pas"/> + <Caret Line="207" Column="9" TopLine="185"/> + </Position4> + <Position5> + <Filename Value="..\ueverettrandom.pas"/> + <Caret Line="225" Column="37" TopLine="217"/> + </Position5> + <Position6> + <Filename Value="umainform.pas"/> + <Caret Line="8" Column="24"/> + </Position6> + <Position7> + <Filename Value="umainform.pas"/> + <Caret Line="54" TopLine="10"/> + </Position7> + <Position8> + <Filename Value="umainform.pas"/> + <Caret Line="52" Column="23" TopLine="16"/> + </Position8> + <Position9> + <Filename Value="umainform.pas"/> + <Caret Line="51" Column="23" TopLine="15"/> + </Position9> + <Position10> + <Filename Value="..\ueverettrandom.pas"/> + <Caret Line="131" Column="26" TopLine="123"/> + </Position10> + <Position11> + <Filename Value="umainform.pas"/> + <Caret Line="30" Column="39" TopLine="11"/> + </Position11> + <Position12> + <Filename Value="umainform.pas"/> + <Caret Line="31" Column="39" TopLine="11"/> + </Position12> + <Position13> + <Filename Value="umainform.pas"/> + <Caret Line="30" Column="39" TopLine="11"/> + </Position13> + <Position14> + <Filename Value="umainform.pas"/> + <Caret Line="20" Column="18" TopLine="11"/> + </Position14> + <Position15> + <Filename Value="..\ueverettrandom.pas"/> + <Caret Line="134" Column="29" TopLine="112"/> + </Position15> + <Position16> + <Filename Value="..\ueverettrandom.pas"/> + <Caret Line="135" Column="25" TopLine="105"/> + </Position16> + <Position17> + <Filename Value="umainform.pas"/> + <Caret Line="20" Column="30" TopLine="14"/> + </Position17> + <Position18> + <Filename Value="umainform.pas"/> + <Caret Line="21" Column="30" TopLine="14"/> + </Position18> + <Position19> + <Filename Value="umainform.pas"/> + <Caret Line="20" Column="30" TopLine="14"/> + </Position19> + <Position20> + <Filename Value="umainform.pas"/> + <Caret Line="21" Column="30" TopLine="14"/> + </Position20> + <Position21> + <Filename Value="umainform.pas"/> + <Caret Line="22" Column="30" TopLine="14"/> + </Position21> + <Position22> + <Filename Value="umainform.pas"/> + <Caret Line="23" Column="30" TopLine="14"/> + </Position22> + <Position23> + <Filename Value="umainform.pas"/> + <Caret Line="64" Column="32" TopLine="26"/> + </Position23> + <Position24> + <Filename Value="umainform.pas"/> + <Caret Line="31" Column="27" TopLine="31"/> + </Position24> + <Position25> + <Filename Value="umainform.pas"/> + <Caret Line="80" Column="69" TopLine="32"/> + </Position25> + <Position26> + <Filename Value="..\ueverettrandom.pas"/> + <Caret Line="123" Column="27" TopLine="115"/> + </Position26> + <Position27> + <Filename Value="umainform.pas"/> + <Caret Line="50" Column="29" TopLine="36"/> + </Position27> + <Position28> + <Filename Value="umainform.pas"/> + <Caret Line="69" Column="27" TopLine="40"/> + </Position28> + <Position29> + <Filename Value="umainform.pas"/> + <Caret Line="70" Column="27" TopLine="41"/> + </Position29> + <Position30> + <Filename Value="..\ueverettrandom.pas"/> + <Caret Line="336" Column="40" TopLine="176"/> + </Position30> + </JumpHistory> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0" ActiveMode=""/> + </RunParams> + </ProjectSession> +</CONFIG> diff --git a/components/everettrandom/latest_stable/demo/everett_demo.res b/components/everettrandom/latest_stable/demo/everett_demo.res new file mode 100644 index 000000000..252e0dda3 Binary files /dev/null and b/components/everettrandom/latest_stable/demo/everett_demo.res differ diff --git a/components/everettrandom/latest_stable/demo/readme.txt b/components/everettrandom/latest_stable/demo/readme.txt new file mode 100644 index 000000000..34bc1da12 --- /dev/null +++ b/components/everettrandom/latest_stable/demo/readme.txt @@ -0,0 +1,55 @@ +================================================================================ +Description and purpose +======================= +The Everett interpretation of quantum mechanics ("Many Worlds") is that when +an interaction is made with an elementary wave function (such as an electron or +photon etc) the universe bifurcates. +ref: https://en.wikipedia.org/wiki/Many-worlds_interpretation + +This happens naturally of course (just via radioactive decays in atoms of your +body there are about 5000 bifucations per second) but this component brings into +the mix "Free Will". By requesting a random number from the online source, which +is a beam-splitter based in Austrailia you are bifurcating the Universe deliberately +- that is, based on your Free Will. +You may or may not find that interesting, but nevertheless this component gives +you this ability (to "play God" with the Universe) + +The random numbers returned are truly random (i.e. not pseudorandom via algorithm) + +This package is a wrapper for querying a quantum number generator based in Austrailia. + + +Usage +===== +Open everettrandom.lpk and compile it. +In your application, include everettrandom as a required package +In a form unit: +In the Uses clause, add ueverettrandom + +Code +==== +Declare as a variable: MyEverett: TEverett; +In form Create: MyEverett := TEverett.Create(Self); +If you don't want to show a dialog whilst querying the server: MyEverett.ShowWaitDialog:=FALSE; + +There are 3 functions that will retrieve a single integer: +// Fetch a single random number +function MyEverett.GetSingle8Bit: integer; +function MyEverett.GetSingle16Bit: integer; +function MyEverett.GetSingleHex: String; + +// Array functions will put results into: +// (GetInteger8BitArray, GetInteger16BitArray) populates MyEverett.IntegerArray[0..Pred(ArraySize)] +// (GetHexArray) populates MyEverett.HexArray[0..Pred(ArraySize)] +// First set the properties: +// MyEverett.ArraySize (default=1) +//..and for Hex results +// MyEverett.HexSize (default=1) e.g. 1=00->FF 2=0000->FFFF 3=000000->FFFFFF etc. +// Result for array functions is TRUE(Success) or FALSE(failure) +function MyEverett.GetInteger8BitArray:Boolean; +function MyEverett.GetInteger16BitArray:Boolean; +function MyEverett.GetHexArray:Boolean; + +Demo +==== +The Demo app shows the usage of everettrandom \ No newline at end of file diff --git a/components/everettrandom/latest_stable/demo/umainform.lfm b/components/everettrandom/latest_stable/demo/umainform.lfm new file mode 100644 index 000000000..d48ac7e03 --- /dev/null +++ b/components/everettrandom/latest_stable/demo/umainform.lfm @@ -0,0 +1,136 @@ +object mainform: Tmainform + Left = 730 + Height = 500 + Top = 304 + Width = 300 + BorderIcons = [] + Caption = 'mainform' + ClientHeight = 500 + ClientWidth = 300 + OnCreate = FormCreate + OnResize = FormResize + Position = poScreenCenter + LCLVersion = '2.0.3.0' + object pnlMain: TPanel + Left = 0 + Height = 438 + Top = 0 + Width = 300 + Align = alTop + Anchors = [akTop, akLeft, akRight, akBottom] + BorderStyle = bsSingle + ClientHeight = 434 + ClientWidth = 296 + TabOrder = 0 + object rgSingleElement: TRadioGroup + Left = 1 + Height = 127 + Top = 1 + Width = 168 + AutoFill = True + Caption = 'Element Type' + ChildSizing.LeftRightSpacing = 6 + ChildSizing.EnlargeHorizontal = crsHomogenousChildResize + ChildSizing.EnlargeVertical = crsHomogenousChildResize + ChildSizing.ShrinkHorizontal = crsScaleChilds + ChildSizing.ShrinkVertical = crsScaleChilds + ChildSizing.Layout = cclLeftToRightThenTopToBottom + ChildSizing.ControlsPerLine = 1 + ClientHeight = 107 + ClientWidth = 164 + ItemIndex = 0 + Items.Strings = ( + 'Byte (0-255)' + 'Integer (0-65535)' + 'Hex (00-FF)' + ) + TabOrder = 0 + end + object grpNumElements: TGroupBox + Left = 168 + Height = 55 + Top = 1 + Width = 121 + Anchors = [akTop, akLeft, akRight] + Caption = 'Number of Elements' + ClientHeight = 35 + ClientWidth = 117 + TabOrder = 1 + object spArrayNumber: TSpinEdit + Left = 8 + Height = 23 + Top = 8 + Width = 64 + MaxValue = 1024 + MinValue = 1 + TabOrder = 0 + Value = 1 + end + end + object grpResults: TGroupBox + Left = 1 + Height = 305 + Top = 128 + Width = 294 + Align = alBottom + Anchors = [akTop, akLeft, akRight, akBottom] + Caption = 'Result(s)' + ClientHeight = 285 + ClientWidth = 290 + TabOrder = 2 + object lstResults: TListBox + Left = 8 + Height = 271 + Top = 8 + Width = 272 + Anchors = [akTop, akLeft, akRight, akBottom] + ItemHeight = 0 + TabOrder = 0 + end + end + object grp_HexSize: TGroupBox + Left = 168 + Height = 73 + Top = 56 + Width = 121 + Anchors = [akTop, akLeft, akRight] + Caption = 'Hex Size' + ClientHeight = 53 + ClientWidth = 117 + TabOrder = 3 + object spHexSize: TSpinEdit + Left = 8 + Height = 23 + Top = 8 + Width = 64 + MaxValue = 1024 + MinValue = 1 + TabOrder = 0 + Value = 1 + end + end + end + object cmdClose: TBitBtn + Left = 208 + Height = 30 + Top = 452 + Width = 75 + Anchors = [akRight, akBottom] + DefaultCaption = True + Kind = bkClose + ModalResult = 11 + TabOrder = 1 + end + object cmdSplit: TBitBtn + Left = 16 + Height = 30 + Top = 452 + Width = 179 + Anchors = [akLeft, akRight, akBottom] + Caption = 'Split the Universe!' + Default = True + ModalResult = 1 + OnClick = cmdSplitClick + TabOrder = 2 + end +end diff --git a/components/everettrandom/latest_stable/demo/umainform.pas b/components/everettrandom/latest_stable/demo/umainform.pas new file mode 100644 index 000000000..eb7804771 --- /dev/null +++ b/components/everettrandom/latest_stable/demo/umainform.pas @@ -0,0 +1,92 @@ +unit umainform; + +{$mode objfpc}{$H+} + +interface + +uses + SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, Buttons, StdCtrls, + Spin, ueverettrandom; + +type + + { Tmainform } + + Tmainform = class(TForm) + cmdSplit: TBitBtn; + cmdClose: TBitBtn; + grpNumElements: TGroupBox; + grp_HexSize: TGroupBox; + grpResults: TGroupBox; + lstResults: TListBox; + pnlMain: TPanel; + rgSingleElement: TRadioGroup; + spArrayNumber: TSpinEdit; + spHexSize: TSpinEdit; + procedure cmdSplitClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormResize(Sender: TObject); + private + myEverett: TEverett; + public + + end; + +var + mainform: Tmainform; + +implementation + +{$R *.lfm} + +{ Tmainform } + +procedure Tmainform.FormCreate(Sender: TObject); +begin + Caption:=Application.Name; + Icon:=Application.Icon; + myEverett := TEverett.Create(Self); + // Set up dialog + // MyEverett.WaitDialogCaption:='Please wait. contacting server'; + MyEverett.ShowWaitDialog:=TRUE; +end; + +procedure Tmainform.FormResize(Sender: TObject); +begin + // Set minimum size + if Width < 300 then + Width := 300; + if Height < 500 then + Height := 500; +end; + +procedure Tmainform.cmdSplitClick(Sender: TObject); +var + s: string; + ct:Integer; +begin + lstResults.Clear; + MyEverett.ArraySize:=spArrayNumber.Value; + MyEverett.HexSize:=spHexSize.Value; + case rgSingleElement.ItemIndex of + 0:begin + MyEverett.GetInteger8BitArray; + for ct:=0 to Pred(MyEverett.ArraySize) do + lstResults.Items.Add(InttoStr(MyEverett.IntegerArray[ct])); + end; + 1:begin + MyEverett.GetInteger16BitArray; + for ct:=0 to Pred(MyEverett.ArraySize) do + lstResults.Items.Add(InttoStr(MyEverett.IntegerArray[ct])); + end; + 2:begin + MyEverett.GetHexArray; + for ct:=0 to Pred(MyEverett.ArraySize) do + lstResults.Items.Add(MyEverett.HexArray[ct]); + end; + end; + s := 'Universe sucessfully split' + LineEnding; + ShowMessageFmt('%s%d times!',[s,spArrayNumber.Value]); +end; + +end. diff --git a/components/everettrandom/latest_stable/everett_httpclient.pas b/components/everettrandom/latest_stable/everett_httpclient.pas new file mode 100644 index 000000000..98d228630 --- /dev/null +++ b/components/everettrandom/latest_stable/everett_httpclient.pas @@ -0,0 +1,1965 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2011 by the Free Pascal development team + + HTTP client component. + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +unit everett_httpclient; + +{ --------------------------------------------------------------------- + Todo: + * Proxy support ? + ---------------------------------------------------------------------} + + +{$mode objfpc}{$H+} + +{$IF FPC_VERSION = 3} + {$IF FPC_RELEASE > 0} + {$IF FPC_PATCH > 0} + {$DEFINE FPC311} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +interface + +uses + Classes, SysUtils, ssockets, httpdefs, uriparser, base64; + +Const + // Socket Read buffer size + ReadBufLen = 4096; + // Default for MaxRedirects Request redirection is aborted after this number of redirects. + DefMaxRedirects = 16; + +Type + TRedirectEvent = Procedure (Sender : TObject; Const ASrc : String; Var ADest: String) of object; + TPasswordEvent = Procedure (Sender : TObject; Var RepeatRequest : Boolean) of object; + // During read of headers, ContentLength equals 0. + // During read of content, of Server did not specify contentlength, -1 is passed. + // CurrentPos is reset to 0 when the actual content is read, i.e. it is the position in the data, discarding header size. + TDataEvent = Procedure (Sender : TObject; Const ContentLength, CurrentPos : Int64) of object; + // Use this to set up a socket handler. UseSSL is true if protocol was https + TGetSocketHandlerEvent = Procedure (Sender : TObject; Const UseSSL : Boolean; Out AHandler : TSocketHandler) of object; + + TFPCustomHTTPClient = Class; + + { TProxyData } + + TProxyData = Class (TPersistent) + private + FHost: string; + FPassword: String; + FPort: Word; + FUserName: String; + FHTTPClient : TFPCustomHTTPClient; + Protected + Function GetProxyHeaders : String; virtual; + Property HTTPClient : TFPCustomHTTPClient Read FHTTPClient; + Public + Procedure Assign(Source: TPersistent); override; + Property Host: string Read FHost Write FHost; + Property Port: Word Read FPort Write FPort; + Property UserName : String Read FUserName Write FUserName; + Property Password : String Read FPassword Write FPassword; + end; + + { TFPCustomHTTPClient } + TFPCustomHTTPClient = Class(TComponent) + private + FDataRead : Int64; + FContentLength : Int64; + FAllowRedirect: Boolean; + FMaxRedirects: Byte; + FOnDataReceived: TDataEvent; + FOnHeaders: TNotifyEvent; + FOnPassword: TPasswordEvent; + FOnRedirect: TRedirectEvent; + FPassword: String; + FIOTimeout: Integer; + FSentCookies, + FCookies: TStrings; + FHTTPVersion: String; + FRequestBody: TStream; + FRequestHeaders: TStrings; + FResponseHeaders: TStrings; + FResponseStatusCode: Integer; + FResponseStatusText: String; + FServerHTTPVersion: String; + FSocket : TInetSocket; + FBuffer : Ansistring; + FUserName: String; + FOnGetSocketHandler : TGetSocketHandlerEvent; + FNeedToBreak: Boolean; + FProxy : TProxyData; + function CheckContentLength: Int64; + function CheckTransferEncoding: string; + function GetCookies: TStrings; + function GetProxy: TProxyData; + Procedure ResetResponse; + Procedure SetCookies(const AValue: TStrings); + procedure SetProxy(AValue: TProxyData); + Procedure SetRequestHeaders(const AValue: TStrings); + procedure SetIOTimeout(AValue: Integer); + protected + Function NoContentAllowed(ACode : Integer) : Boolean; + // True if we need to use a proxy: ProxyData Assigned and Hostname Set + Function ProxyActive : Boolean; + // Override this if you want to create a custom instance of proxy. + Function CreateProxyData : TProxyData; + // Called whenever data is read. + Procedure DoDataRead; virtual; + // Parse response status line. Saves status text and protocol, returns numerical code. Exception if invalid line. + Function ParseStatusLine(AStatusLine : String) : Integer; + // Construct server URL for use in request line. + function GetServerURL(URI: TURI): String; + // Read 1 line of response. Fills FBuffer + function ReadString: String; + // Check if response code is in AllowedResponseCodes. if not, an exception is raised. + // If AllowRedirect is true, and the result is a Redirect status code, the result is also true + // If the OnPassword event is set, then a 401 will also result in True. + function CheckResponseCode(ACode: Integer; const AllowedResponseCodes: array of Integer): Boolean; virtual; + // Read response from server, and write any document to Stream. + Procedure ReadResponse(Stream: TStream; const AllowedResponseCodes: array of Integer; HeadersOnly: Boolean = False); virtual; + // Read server response line and headers. Returns status code. + Function ReadResponseHeaders : integer; virtual; + // Allow header in request ? (currently checks only if non-empty and contains : token) + function AllowHeader(var AHeader: String): Boolean; virtual; + // Connect to the server. Must initialize FSocket. + Procedure ConnectToServer(const AHost: String; APort: Integer; UseSSL : Boolean=False); virtual; + // Disconnect from server. Must free FSocket. + Procedure DisconnectFromServer; virtual; + // Run method AMethod, using request URL AURL. Write Response to Stream, and headers in ResponseHeaders. + // If non-empty, AllowedResponseCodes contains an array of response codes considered valid responses. + // If HandleRedirect is True, then Redirect status is accepted as a correct status, but request is not repeated. + // No authorization callback. + Procedure DoMethod(Const AMethod,AURL : String; Stream : TStream; Const AllowedResponseCodes : Array of Integer); virtual; + // Send request to server: construct request line and send headers and request body. + Procedure SendRequest(const AMethod: String; URI: TURI); virtual; + // Create socket handler for protocol AProtocol. Calls OnGetSocketHandler. + Function GetSocketHandler(Const UseSSL : Boolean) : TSocketHandler; virtual; + Public + Constructor Create(AOwner: TComponent); override; + Destructor Destroy; override; + // Add header Aheader with value AValue to HTTPHeaders, replacing exiting values + Class Procedure AddHeader(HTTPHeaders : TStrings; Const AHeader,AValue : String); + // Index of header AHeader in httpheaders. + Class Function IndexOfHeader(HTTPHeaders : TStrings; Const AHeader : String) : Integer; + // Return value of header AHeader from httpheaders. Returns empty if it doesn't exist yet. + Class Function GetHeader(HTTPHeaders : TStrings; Const AHeader : String) : String; + // Request Header management + // Return index of header, -1 if not present. + Function IndexOfHeader(Const AHeader : String) : Integer; + // Add header, replacing an existing one if it exists. + Procedure AddHeader(Const AHeader,AValue : String); + // Return header value, empty if not present. + Function GetHeader(Const AHeader : String) : String; + // General-purpose call. Handles redirect and authorization retry (OnPassword). + Procedure HTTPMethod(Const AMethod,AURL : String; Stream : TStream; Const AllowedResponseCodes : Array of Integer); virtual; + // Execute GET on server, store result in Stream, File, StringList or string + Procedure Get(Const AURL : String; Stream : TStream); + Procedure Get(Const AURL : String; const LocalFileName : String); + Procedure Get(Const AURL : String; Response : TStrings); + Function Get(Const AURL : String) : String; + // Check if responsecode is a redirect code that this class handles (301,302,303,307,308) + Class Function IsRedirect(ACode : Integer) : Boolean; virtual; + // If the code is a redirect, then this method must return TRUE if the next request should happen with a GET (307/308) + Class Function RedirectForcesGET(ACode : Integer) : Boolean; virtual; + // Simple class methods + Class Procedure SimpleGet(Const AURL : String; Stream : TStream); + Class Procedure SimpleGet(Const AURL : String; const LocalFileName : String); + Class Procedure SimpleGet(Const AURL : String; Response : TStrings); + Class Function SimpleGet(Const AURL : String) : String; + // Simple post + // Post URL, and Requestbody. Return response in Stream, File, TstringList or String; + Procedure Post(const URL: string; const Response: TStream); + Procedure Post(const URL: string; Response : TStrings); + Procedure Post(const URL: string; const LocalFileName: String); + function Post(const URL: string) : String; + // Simple class methods. + Class Procedure SimplePost(const URL: string; const Response: TStream); + Class Procedure SimplePost(const URL: string; Response : TStrings); + Class Procedure SimplePost(const URL: string; const LocalFileName: String); + Class function SimplePost(const URL: string) : String; + // Simple Put + // Put URL, and Requestbody. Return response in Stream, File, TstringList or String; + Procedure Put(const URL: string; const Response: TStream); + Procedure Put(const URL: string; Response : TStrings); + Procedure Put(const URL: string; const LocalFileName: String); + function Put(const URL: string) : String; + // Simple class methods. + Class Procedure SimplePut(const URL: string; const Response: TStream); + Class Procedure SimplePut(const URL: string; Response : TStrings); + Class Procedure SimplePut(const URL: string; const LocalFileName: String); + Class function SimplePut(const URL: string) : String; + // Simple Delete + // Delete URL, and Requestbody. Return response in Stream, File, TstringList or String; + Procedure Delete(const URL: string; const Response: TStream); + Procedure Delete(const URL: string; Response : TStrings); + Procedure Delete(const URL: string; const LocalFileName: String); + function Delete(const URL: string) : String; + // Simple class methods. + Class Procedure SimpleDelete(const URL: string; const Response: TStream); + Class Procedure SimpleDelete(const URL: string; Response : TStrings); + Class Procedure SimpleDelete(const URL: string; const LocalFileName: String); + Class function SimpleDelete(const URL: string) : String; + // Simple Options + // Options from URL, and Requestbody. Return response in Stream, File, TstringList or String; + Procedure Options(const URL: string; const Response: TStream); + Procedure Options(const URL: string; Response : TStrings); + Procedure Options(const URL: string; const LocalFileName: String); + function Options(const URL: string) : String; + // Simple class methods. + Class Procedure SimpleOptions(const URL: string; const Response: TStream); + Class Procedure SimpleOptions(const URL: string; Response : TStrings); + Class Procedure SimpleOptions(const URL: string; const LocalFileName: String); + Class function SimpleOptions(const URL: string) : String; + // Get HEAD + Class Procedure Head(AURL : String; Headers: TStrings); + // Post Form data (www-urlencoded). + // Formdata in string (urlencoded) or TStrings (plain text) format. + // Form data will be inserted in the requestbody. + // Return response in Stream, File, TStringList or String; + Procedure FormPost(const URL, FormData: string; const Response: TStream); + Procedure FormPost(const URL : string; FormData: TStrings; const Response: TStream); + Procedure FormPost(const URL, FormData: string; const Response: TStrings); + Procedure FormPost(const URL : string; FormData: TStrings; const Response: TStrings); + function FormPost(const URL, FormData: string): String; + function FormPost(const URL: string; FormData : TStrings): String; + // Simple form + Class Procedure SimpleFormPost(const URL, FormData: string; const Response: TStream); + Class Procedure SimpleFormPost(const URL : string; FormData: TStrings; const Response: TStream); + Class Procedure SimpleFormPost(const URL, FormData: string; const Response: TStrings); + Class Procedure SimpleFormPost(const URL : string; FormData: TStrings; const Response: TStrings); + Class function SimpleFormPost(const URL, FormData: string): String; + Class function SimpleFormPost(const URL: string; FormData : TStrings): String; + // Post a file + Procedure FileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream); + // Post form with a file + Procedure FileFormPost(const AURL: string; FormData: TStrings; AFieldName, AFileName: string; const Response: TStream); + // Post a stream + Procedure StreamFormPost(const AURL, AFieldName, AFileName: string; const AStream: TStream; const Response: TStream); + // Post form with a stream + Procedure StreamFormPost(const AURL: string; FormData: TStrings; const AFieldName, AFileName: string; const AStream: TStream; const Response: TStream); + // Simple form of Posting a file + Class Procedure SimpleFileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream); + Protected + // Timeouts + Property IOTimeout : Integer read FIOTimeout write SetIOTimeout; + // Before request properties. + // Additional headers for request. Host; and Authentication are automatically added. + Property RequestHeaders : TStrings Read FRequestHeaders Write SetRequestHeaders; + // Cookies. Set before request to send cookies to server. + // After request the property is filled with the cookies sent by the server. + Property Cookies : TStrings Read GetCookies Write SetCookies; + // Optional body to send (mainly in POST request) + Property RequestBody : TStream read FRequestBody Write FRequestBody; + // used HTTP version when constructing the request. + Property HTTPversion : String Read FHTTPVersion Write FHTTPVersion; + // After request properties. + // After request, this contains the headers sent by server. + Property ResponseHeaders : TStrings Read FResponseHeaders; + // After request, HTTP version of server reply. + Property ServerHTTPVersion : String Read FServerHTTPVersion; + // After request, HTTP response status of the server. + Property ResponseStatusCode : Integer Read FResponseStatusCode; + // After request, HTTP response status text of the server. + Property ResponseStatusText : String Read FResponseStatusText; + // Allow redirect in HTTPMethod ? + Property AllowRedirect : Boolean Read FAllowRedirect Write FAllowRedirect; + // Maximum number of redirects. When this number is reached, an exception is raised. + Property MaxRedirects : Byte Read FMaxRedirects Write FMaxRedirects default DefMaxRedirects; + // Called On redirect. Dest URL can be edited. + // If The DEST url is empty on return, the method is aborted (with redirect status). + Property OnRedirect : TRedirectEvent Read FOnRedirect Write FOnRedirect; + // Proxy support + Property Proxy : TProxyData Read GetProxy Write SetProxy; + // Authentication. + // When set, they override the credentials found in the URI. + // They also override any Authenticate: header in Requestheaders. + Property UserName : String Read FUserName Write FUserName; + Property Password : String Read FPassword Write FPassword; + // If a request returns a 401, then the OnPassword event is fired. + // It can modify the username/password and set RepeatRequest to true; + Property OnPassword : TPasswordEvent Read FOnPassword Write FOnPassword; + // Called whenever data is read from the connection. + Property OnDataReceived : TDataEvent Read FOnDataReceived Write FOnDataReceived; + // Called when headers have been processed. + Property OnHeaders : TNotifyEvent Read FOnHeaders Write FOnHeaders; + // Called to create socket handler. If not set, or Nil is returned, a standard socket handler is created. + Property OnGetSocketHandler : TGetSocketHandlerEvent Read FOnGetSocketHandler Write FOnGetSocketHandler; + Property NeedToBreak: Boolean read FNeedToBreak write FNeedToBreak; + end; + + + TFPHTTPClient = Class(TFPCustomHTTPClient) + Published + Property IOTimeout; + Property RequestHeaders; + Property RequestBody; + Property ResponseHeaders; + Property HTTPversion; + Property ServerHTTPVersion; + Property ResponseStatusCode; + Property ResponseStatusText; + Property Cookies; + Property AllowRedirect; + Property MaxRedirects; + Property OnRedirect; + Property UserName; + Property Password; + Property OnPassword; + Property OnDataReceived; + Property OnHeaders; + Property OnGetSocketHandler; + Property Proxy; + Property NeedToBreak; + end; + + EHTTPClient = Class(EHTTP); + +Function EncodeURLElement(S : String) : String; +Function DecodeURLElement(Const S : String) : String; + +implementation +{$if not defined(hasamiga)} +uses sslsockets; +{$endif} + +resourcestring + SErrInvalidProtocol = 'Invalid protocol: "%s"'; + SErrReadingSocket = 'Error reading data from socket'; + SErrInvalidProtocolVersion = 'Invalid protocol version in response: "%s"'; + SErrInvalidStatusCode = 'Invalid response status code: %s'; + SErrUnexpectedResponse = 'Unexpected response status code: %d'; + SErrChunkTooBig = 'Chunk too big'; + SErrChunkLineEndMissing = 'Chunk line end missing'; + SErrMaxRedirectsReached = 'Maximum allowed redirects reached: %d'; + //SErrRedirectAborted = 'Redirect aborted.'; + +Const + CRLF = #13#10; + +function EncodeURLElement(S: String): String; + +Const + NotAllowed = [ ';', '/', '?', ':', '@', '=', '&', '#', '+', '_', '<', '>', + '"', '%', '{', '}', '|', '\', '^', '~', '[', ']', '`' ]; + +var + i, o, l : Integer; + h: string[2]; + P : PChar; + c: AnsiChar; +begin + l:=Length(S); + If (l=0) then Exit; + SetLength(Result,l*3); + P:=Pchar(Result); + for I:=1 to L do + begin + C:=S[i]; + O:=Ord(c); + if (O<=$20) or (O>=$7F) or (c in NotAllowed) then + begin + P^ := '%'; + Inc(P); + h := IntToHex(Ord(c), 2); + p^ := h[1]; + Inc(P); + p^ := h[2]; + Inc(P); + end + else + begin + P^ := c; + Inc(p); + end; + end; + SetLength(Result,P-PChar(Result)); +end; + +function DecodeURLElement(Const S: AnsiString): AnsiString; + +var + i,l,o : Integer; + c: AnsiChar; + p : pchar; + h : string; + +begin + l := Length(S); + if l=0 then exit; + SetLength(Result, l); + P:=PChar(Result); + i:=1; + While (I<=L) do + begin + c := S[i]; + if (c<>'%') then + begin + P^:=c; + Inc(P); + end + else if (I<L-1) then + begin + H:='$'+Copy(S,I+1,2); + o:=StrToIntDef(H,-1); + If (O>=0) and (O<=255) then + begin + P^:=char(O); + Inc(P); + Inc(I,2); + end; + end; + Inc(i); + end; + SetLength(Result, P-Pchar(Result)); +end; + +{ TProxyData } + +function TProxyData.GetProxyHeaders: String; +begin + Result:=''; + if (UserName<>'') then + Result:='Proxy-Authorization: Basic ' + EncodeStringBase64(UserName+':'+UserName); +end; + +procedure TProxyData.Assign(Source: TPersistent); + +Var + D : TProxyData; + +begin + if Source is TProxyData then + begin + D:=Source as TProxyData; + Host:=D.Host; + Port:=D.Port; + UserName:=D.UserName; + Password:=D.Password; + end + else + inherited Assign(Source); +end; + +{ TFPCustomHTTPClient } + +procedure TFPCustomHTTPClient.SetRequestHeaders(const AValue: TStrings); +begin + if FRequestHeaders=AValue then exit; + FRequestHeaders.Assign(AValue); +end; + +procedure TFPCustomHTTPClient.SetIOTimeout(AValue: Integer); +begin + if AValue=FIOTimeout then exit; + FIOTimeout:=AValue; + {$IFDEF FPC311} + if Assigned(FSocket) then + FSocket.IOTimeout:=AValue; + {$ENDIF} +end; + +function TFPCustomHTTPClient.NoContentAllowed(ACode: Integer): Boolean; +begin + Result:=((ACode div 100)=1) or ((ACode=204) or (ACode=304)) +end; + +function TFPCustomHTTPClient.ProxyActive: Boolean; +begin + Result:=Assigned(FProxy) and (FProxy.Host<>'') and (FProxy.Port>0); +end; + +function TFPCustomHTTPClient.CreateProxyData: TProxyData; +begin + Result:=TProxyData.Create; +end; + +procedure TFPCustomHTTPClient.DoDataRead; +begin + If Assigned(FOnDataReceived) Then + FOnDataReceived(Self,FContentLength,FDataRead); +end; + +function TFPCustomHTTPClient.IndexOfHeader(const AHeader: String): Integer; +begin + Result:=IndexOfHeader(RequestHeaders,AHeader); +end; + +procedure TFPCustomHTTPClient.AddHeader(const AHeader, AValue: String); + +begin + AddHeader(RequestHeaders,AHeader,AValue); +end; + +function TFPCustomHTTPClient.GetHeader(const AHeader: String): String; + + +begin + Result:=GetHeader(RequestHeaders,AHeader); +end; + +function TFPCustomHTTPClient.GetServerURL(URI: TURI): String; + +Var + D : String; + +begin + D:=URI.Path; + If Length(D) = 0 then + D := '/' + else If (D[1]<>'/') then + D:='/'+D; + If (D[Length(D)]<>'/') then + D:=D+'/'; + Result:=D+URI.Document; + if (URI.Params<>'') then + Result:=Result+'?'+URI.Params; + if ProxyActive then + begin + if URI.Port>0 then + Result:=':'+IntToStr(URI.Port)+Result; + Result:=URI.Protocol+'://'+URI.Host+Result; + end; +end; + +function TFPCustomHTTPClient.GetSocketHandler(const UseSSL: Boolean): TSocketHandler; + +begin + Result:=Nil; + if Assigned(FonGetSocketHandler) then + FOnGetSocketHandler(Self,UseSSL,Result); + if (Result=Nil) then + {$if not defined(HASAMIGA)} + If UseSSL then + Result:=TSSLSocketHandler.Create + else + {$endif} + Result:=TSocketHandler.Create; +end; + +procedure TFPCustomHTTPClient.ConnectToServer(const AHost: String; + APort: Integer; UseSSL : Boolean = False); + +Var + G : TSocketHandler; + + +begin + if (Aport=0) then + if UseSSL then + Aport:=443 + else + Aport:=80; + G:=GetSocketHandler(UseSSL); + FSocket:=TInetSocket.Create(AHost,APort,G); + try + {$IFDEF FPC311} + if FIOTimeout <> 0 then + FSocket.IOTimeout := FIOTimeout; + {$ENDIF} + FSocket.Connect; + except + FreeAndNil(FSocket); + Raise; + end; +end; + +procedure TFPCustomHTTPClient.DisconnectFromServer; + +begin + FreeAndNil(FSocket); +end; + +function TFPCustomHTTPClient.AllowHeader(var AHeader: String): Boolean; + +begin + Result:=(AHeader<>'') and (Pos(':',AHeader)<>0); +end; + +procedure TFPCustomHTTPClient.SendRequest(const AMethod: String; URI: TURI); + +Var + PH,UN,PW,S,L : String; + I : Integer; + +begin + S:=Uppercase(AMethod)+' '+GetServerURL(URI)+' '+'HTTP/'+FHTTPVersion+CRLF; + UN:=URI.Username; + PW:=URI.Password; + if (UserName<>'') then + begin + UN:=UserName; + PW:=Password; + end; + If (UN<>'') then + begin + S:=S+'Authorization: Basic ' + EncodeStringBase64(UN+':'+PW)+CRLF; + I:=IndexOfHeader('Authorization'); + If I<>-1 then + RequestHeaders.Delete(i); + end; + if Assigned(FProxy) and (FProxy.Host<>'') then + begin + PH:=FProxy.GetProxyHeaders; + if (PH<>'') then + S:=S+PH+CRLF; + end; + S:=S+'Host: '+URI.Host; + If (URI.Port<>0) then + S:=S+':'+IntToStr(URI.Port); + S:=S+CRLF; + If Assigned(RequestBody) and (IndexOfHeader('Content-Length')=-1) then + AddHeader('Content-Length',IntToStr(RequestBody.Size)); + For I:=0 to FRequestHeaders.Count-1 do + begin + l:=FRequestHeaders[i]; + If AllowHeader(L) then + S:=S+L+CRLF; + end; + if Assigned(FCookies) then + begin + L:='Cookie:'; + For I:=0 to FCookies.Count-1 do + begin + If (I>0) then + L:=L+'; '; + L:=L+FCookies[i]; + end; + if AllowHeader(L) then + S:=S+L+CRLF; + end; + FreeAndNil(FSentCookies); + FSentCookies:=FCookies; + FCookies:=Nil; + S:=S+CRLF; + FSocket.WriteBuffer(S[1],Length(S)); + If Assigned(FRequestBody) then + FSocket.CopyFrom(FRequestBody,FRequestBody.Size); +end; + +function TFPCustomHTTPClient.ReadString : String; + + Procedure FillBuffer; + + Var + R : Integer; + + begin + SetLength(FBuffer,ReadBufLen); + r:=FSocket.Read(FBuffer[1],ReadBufLen); + If r<0 then + Raise EHTTPClient.Create(SErrReadingSocket); + if (r<ReadBuflen) then + SetLength(FBuffer,r); + FDataRead:=FDataRead+R; + DoDataRead; + end; + +Var + CheckLF,Done : Boolean; + P,L : integer; + +begin + Result:=''; + Done:=False; + CheckLF:=False; + Repeat + if NeedToBreak then + Break; + if Length(FBuffer)=0 then + FillBuffer; + if Length(FBuffer)=0 then + Done:=True + else if CheckLF then + begin + If (FBuffer[1]<>#10) then + Result:=Result+#13 + else + begin + System.Delete(FBuffer,1,1); + Done:=True; + end; + end; + if not Done then + begin + P:=Pos(#13#10,FBuffer); + If P=0 then + begin + L:=Length(FBuffer); + CheckLF:=FBuffer[L]=#13; + if CheckLF then + Result:=Result+Copy(FBuffer,1,L-1) + else + Result:=Result+FBuffer; + FBuffer:=''; + end + else + begin + Result:=Result+Copy(FBuffer,1,P-1); + System.Delete(FBuffer,1,P+1); + Done:=True; + end; + end; + until Done; +end; +Function GetNextWord(Var S : String) : string; + +Const + WhiteSpace = [' ',#9]; + +Var + P : Integer; + +begin + While (Length(S)>0) and (S[1] in WhiteSpace) do + Delete(S,1,1); + P:=Pos(' ',S); + If (P=0) then + P:=Pos(#9,S); + If (P=0) then + P:=Length(S)+1; + Result:=Copy(S,1,P-1); + Delete(S,1,P); +end; + +function TFPCustomHTTPClient.ParseStatusLine(AStatusLine: String): Integer; + +Var + S : String; + +begin + S:=Uppercase(GetNextWord(AStatusLine)); + If (Copy(S,1,5)<>'HTTP/') then + Raise EHTTPClient.CreateFmt(SErrInvalidProtocolVersion,[S]); + System.Delete(S,1,5); + FServerHTTPVersion:=S; + S:=GetNextWord(AStatusLine); + Result:=StrToIntDef(S,-1); + if Result=-1 then + Raise EHTTPClient.CreateFmt(SErrInvalidStatusCode,[S]); + FResponseStatusText:=AStatusLine; +end; + +function TFPCustomHTTPClient.ReadResponseHeaders: integer; + + Procedure DoCookies(S : String); + + Var + P : Integer; + C : String; + + begin + If Assigned(FCookies) then + FCookies.Clear; + P:=Pos(':',S); + System.Delete(S,1,P); + Repeat + if NeedToBreak then + Break; + P:=Pos(';',S); + If (P=0) then + P:=Length(S)+1; + C:=Trim(Copy(S,1,P-1)); + Cookies.Add(C); + System.Delete(S,1,P); + Until (S=''); + end; + +Const + SetCookie = 'set-cookie'; + +Var + StatusLine,S : String; + +begin + StatusLine:=ReadString; + Result:=ParseStatusLine(StatusLine); + Repeat + if NeedToBreak then + Break; + S:=ReadString; + if (S<>'') then + begin + ResponseHeaders.Add(S); + If (LowerCase(Copy(S,1,Length(SetCookie)))=SetCookie) then + DoCookies(S); + end + Until (S=''); + If Assigned(FOnHeaders) then + FOnHeaders(Self); +end; + +function TFPCustomHTTPClient.CheckResponseCode(ACode: Integer; + const AllowedResponseCodes: array of Integer): Boolean; + +Var + I : Integer; + +begin + Result:=(High(AllowedResponseCodes)=-1); + if not Result then + begin + I:=Low(AllowedResponseCodes); + While (Not Result) and (I<=High(AllowedResponseCodes)) do + begin + Result:=(AllowedResponseCodes[i]=ACode); + Inc(I); + end + end; + If (Not Result) then + begin + if AllowRedirect then + Result:=IsRedirect(ACode); + If (ACode=401) then + Result:=Assigned(FOnPassword); + end; +end; + +function TFPCustomHTTPClient.CheckContentLength: Int64; + +Const CL ='content-length:'; + +Var + S : String; + I : integer; + +begin + Result:=-1; + I:=0; + While (Result=-1) and (I<FResponseHeaders.Count) do + begin + S:=Trim(LowerCase(FResponseHeaders[i])); + If (Copy(S,1,Length(Cl))=Cl) then + begin + System.Delete(S,1,Length(CL)); + Result:=StrToInt64Def(Trim(S),-1); + end; + Inc(I); + end; + FContentLength:=Result; +end; + +function TFPCustomHTTPClient.CheckTransferEncoding: string; + +Const CL ='transfer-encoding:'; + +Var + S : String; + I : integer; + +begin + Result:=''; + I:=0; + While (I<FResponseHeaders.Count) do + begin + S:=Trim(LowerCase(FResponseHeaders[i])); + If (Copy(S,1,Length(Cl))=Cl) then + begin + System.Delete(S,1,Length(CL)); + Result:=Trim(S); + exit; + end; + Inc(I); + end; +end; + +function TFPCustomHTTPClient.GetCookies: TStrings; +begin + If (FCookies=Nil) then + FCookies:=TStringList.Create; + Result:=FCookies; +end; + +function TFPCustomHTTPClient.GetProxy: TProxyData; +begin + If not Assigned(FProxy) then + begin + FProxy:=CreateProxyData; + FProxy.FHTTPClient:=Self; + end; + Result:=FProxy; +end; + +procedure TFPCustomHTTPClient.SetCookies(const AValue: TStrings); +begin + if GetCookies=AValue then exit; + GetCookies.Assign(AValue); +end; + +procedure TFPCustomHTTPClient.SetProxy(AValue: TProxyData); +begin + if (AValue=FProxy) then exit; + Proxy.Assign(AValue); +end; + +procedure TFPCustomHTTPClient.ReadResponse(Stream: TStream; + const AllowedResponseCodes: array of Integer; HeadersOnly: Boolean); + + Function Transfer(LB : Integer) : Integer; + + begin + Result:=FSocket.Read(FBuffer[1],LB); + If Result<0 then + Raise EHTTPClient.Create(SErrReadingSocket); + if (Result>0) then + begin + FDataRead:=FDataRead+Result; + DoDataRead; + Stream.Write(FBuffer[1],Result); + end; + end; + + Procedure ReadChunkedResponse; + { HTTP 1.1 chunked response: + There is no content-length. The response consists of several chunks of + data, each + - beginning with a line + - starting with a hex number DataSize, + - an optional parameter, + - ending with #13#10, + - followed by the data, + - ending with #13#10 (not in DataSize), + It ends when the DataSize is 0. + After the last chunk there can be a some optional entity header fields. + This trailer is not yet implemented. } + var + BufPos: Integer; + + function FetchData(out Cnt: integer): boolean; + + begin + SetLength(FBuffer,ReadBuflen); + Cnt:=FSocket.Read(FBuffer[1],length(FBuffer)); + If Cnt<0 then + Raise EHTTPClient.Create(SErrReadingSocket); + SetLength(FBuffer,Cnt); + BufPos:=1; + Result:=Cnt>0; + FDataRead:=FDataRead+Cnt; + DoDataRead; + end; + + Function ReadData(Data: PByte; Cnt: integer): integer; + + var + l: Integer; + begin + Result:=0; + while Cnt>0 do + begin + l:=length(FBuffer)-BufPos+1; + if l=0 then + if not FetchData(l) then + exit; // end of stream + if l>Cnt then + l:=Cnt; + System.Move(FBuffer[BufPos],Data^,l); + inc(BufPos,l); + inc(Data,l); + inc(Result,l); + dec(Cnt,l); + end; + end; + + var + c: char; + ChunkSize: Integer; + l: Integer; + begin + BufPos:=1; + repeat + if NeedToBreak then + Break; + // read ChunkSize + ChunkSize:=0; + repeat + if NeedToBreak then + Break; + if ReadData(@c,1)<1 then exit; + case c of + '0'..'9': ChunkSize:=ChunkSize*16+ord(c)-ord('0'); + 'a'..'f': ChunkSize:=ChunkSize*16+ord(c)-ord('a')+10; + 'A'..'F': ChunkSize:=ChunkSize*16+ord(c)-ord('A')+10; + else break; + end; + if ChunkSize>1000000 then + Raise EHTTPClient.Create(SErrChunkTooBig); + until false; + // read till line end + while (c<>#10) do + if ReadData(@c,1)<1 then exit; + if ChunkSize=0 then exit; + // read data + repeat + if NeedToBreak then + Break; + l:=length(FBuffer)-BufPos+1; + if l=0 then + if not FetchData(l) then + exit; // end of stream + if l>ChunkSize then + l:=ChunkSize; + if l>0 then + begin + // copy chunk data to output + Stream.Write(FBuffer[BufPos],l); + inc(BufPos,l); + dec(ChunkSize,l); + end; + until ChunkSize=0; + // read #13#10 + if ReadData(@c,1)<1 then exit; + if c<>#13 then + Raise EHTTPClient.Create(SErrChunkLineEndMissing); + if ReadData(@c,1)<1 then exit; + if c<>#10 then + Raise EHTTPClient.Create(SErrChunkLineEndMissing); + // next chunk + until false; + end; + +Var + L : Int64; + LB,R : Integer; + +begin + FDataRead:=0; + FContentLength:=0; + SetLength(FBuffer,0); + FResponseStatusCode:=ReadResponseHeaders; + if not CheckResponseCode(FResponseStatusCode,AllowedResponseCodes) then + Raise EHTTPClient.CreateFmt(SErrUnexpectedResponse,[ResponseStatusCode]); + if HeadersOnly Or (AllowRedirect and IsRedirect(FResponseStatusCode)) then + exit; + if CompareText(CheckTransferEncoding,'chunked')=0 then + ReadChunkedResponse + else + begin + // Write remains of buffer to output. + LB:=Length(FBuffer); + FDataRead:=LB; + If (LB>0) then + Stream.WriteBuffer(FBuffer[1],LB); + // Now read the rest, if any. + SetLength(FBuffer,ReadBuflen); + L:=CheckContentLength; + If (L>LB) then + begin + // We cannot use copyfrom, it uses ReadBuffer, and this is dangerous with sockets + L:=L-LB; + Repeat + if NeedToBreak then + Break; + LB:=ReadBufLen; + If (LB>L) then + LB:=L; + R:=Transfer(LB); + L:=L-R; + until (L=0) or (R=0); + end + else if (L<0) and (Not NoContentAllowed(ResponseStatusCode)) then + begin + // No content-length, so we read till no more data available. + Repeat + if NeedToBreak then + Break; + R:=Transfer(ReadBufLen); + until (R=0); + end; + end; +end; + +procedure TFPCustomHTTPClient.DoMethod(const AMethod, AURL: String; + Stream: TStream; const AllowedResponseCodes: array of Integer); + +Var + URI : TURI; + P,CHost : String; + CPort : Word; + +begin + ResetResponse; + URI:=ParseURI(AURL,False); + p:=LowerCase(URI.Protocol); + If Not ((P='http') or (P='https')) then + Raise EHTTPClient.CreateFmt(SErrInvalidProtocol,[URI.Protocol]); + if ProxyActive then + begin + CHost:=Proxy.Host; + CPort:=Proxy.Port; + end + else + begin + CHost:=URI.Host; + CPort:=URI.Port; + end; + ConnectToServer(CHost,CPort,P='https'); + try + SendRequest(AMethod,URI); + ReadResponse(Stream,AllowedResponseCodes,CompareText(AMethod,'HEAD')=0); + finally + DisconnectFromServer; + end; +end; + +constructor TFPCustomHTTPClient.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + // Infinite timeout on most platforms + FIOTimeout:=0; + FRequestHeaders:=TStringList.Create; + FResponseHeaders:=TStringList.Create; + FHTTPVersion:='1.1'; + FMaxRedirects:=DefMaxRedirects; +end; + +destructor TFPCustomHTTPClient.Destroy; +begin + FreeAndNil(FProxy); + FreeAndNil(FCookies); + FreeAndNil(FSentCookies); + FreeAndNil(FRequestHeaders); + FreeAndNil(FResponseHeaders); + inherited Destroy; +end; + +class procedure TFPCustomHTTPClient.AddHeader(HTTPHeaders: TStrings; + const AHeader, AValue: String); +Var +J: Integer; +begin + j:=IndexOfHeader(HTTPHeaders,Aheader); + if (J<>-1) then + HTTPHeaders.Delete(j); + HTTPHeaders.Add(AHeader+': '+Avalue); +end; + + +class function TFPCustomHTTPClient.IndexOfHeader(HTTPHeaders: TStrings; + const AHeader: String): Integer; + +Var + L : Integer; + H : String; +begin + H:=LowerCase(Aheader); + l:=Length(AHeader); + Result:=HTTPHeaders.Count-1; + While (Result>=0) and ((LowerCase(Copy(HTTPHeaders[Result],1,l)))<>h) do + Dec(Result); +end; + +class function TFPCustomHTTPClient.GetHeader(HTTPHeaders: TStrings; + const AHeader: String): String; +Var + I : Integer; +begin + I:=IndexOfHeader(HTTPHeaders,AHeader); + if (I=-1) then + Result:='' + else + begin + Result:=HTTPHeaders[i]; + I:=Pos(':',Result); + if (I=0) then + I:=Length(Result); + System.Delete(Result,1,I); + Result:=TrimLeft(Result); + end; +end; + +procedure TFPCustomHTTPClient.ResetResponse; + +begin + FResponseStatusCode:=0; + FResponseStatusText:=''; + FResponseHeaders.Clear; + FServerHTTPVersion:=''; + FBuffer:=''; +end; + + +procedure TFPCustomHTTPClient.HTTPMethod(const AMethod, AURL: String; + Stream: TStream; const AllowedResponseCodes: array of Integer); + +Var + M,L,NL : String; + RC : Integer; + RR : Boolean; // Repeat request ? + +begin + L:=AURL; + RC:=0; + RR:=False; + M:=AMethod; + Repeat + if FNeedToBreak then + Break; + if Not AllowRedirect then + DoMethod(M,L,Stream,AllowedResponseCodes) + else + begin + DoMethod(M,L,Stream,AllowedResponseCodes); + if IsRedirect(FResponseStatusCode) then + begin + Inc(RC); + if (RC>MaxRedirects) then + Raise EHTTPClient.CreateFmt(SErrMaxRedirectsReached,[RC]); + NL:=GetHeader(FResponseHeaders,'Location'); + if Not Assigned(FOnRedirect) then + L:=NL + else + FOnRedirect(Self,L,NL); + if (RedirectForcesGET(FResponseStatusCode)) then + M:='GET'; + L:=NL; + // Request has saved cookies in sentcookies. + FreeAndNil(FCookies); + FCookies:=FSentCookies; + FSentCookies:=Nil; + end; + end; + if (FResponseStatusCode=401) then + begin + RR:=False; + if Assigned(FOnPassword) then + FOnPassword(Self,RR); + end + else + RR:=AllowRedirect and IsRedirect(FResponseStatusCode) and (L<>'') + until not RR; +end; + +procedure TFPCustomHTTPClient.Get(const AURL: String; Stream: TStream); +begin + HTTPMethod('GET',AURL,Stream,[200]); +end; + +procedure TFPCustomHTTPClient.Get(const AURL: String; + const LocalFileName: String); + +Var + F : TFileStream; + +begin + F:=TFileStream.Create(LocalFileName,fmCreate); + try + Get(AURL,F); + finally + F.Free; + end; +end; + +procedure TFPCustomHTTPClient.Get(const AURL: String; Response: TStrings); +begin + Response.Text:=Get(AURL); +end; + +function TFPCustomHTTPClient.Get(const AURL: String): String; + +Var + SS : TStringStream; + +begin + SS:=TStringStream.Create(''); + try + Get(AURL,SS); + Result:=SS.Datastring; + finally + SS.Free; + end; +end; + +class function TFPCustomHTTPClient.IsRedirect(ACode: Integer): Boolean; +begin + Case ACode of + 301, + 302, + 303, + 307,808 : Result:=True; + else + Result:=False; + end; +end; + +class function TFPCustomHTTPClient.RedirectForcesGET(ACode: Integer): Boolean; +begin + Result:=(ACode=303) +end; + + +class procedure TFPCustomHTTPClient.SimpleGet(const AURL: String; + Stream: TStream); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Get(AURL,Stream); + finally + Free; + end; +end; + + +class procedure TFPCustomHTTPClient.SimpleGet(const AURL: String; + const LocalFileName: String); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Get(AURL,LocalFileName); + finally + Free; + end; +end; + + +class procedure TFPCustomHTTPClient.SimpleGet(const AURL: String; + Response: TStrings); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Get(AURL,Response); + finally + Free; + end; +end; + + +class function TFPCustomHTTPClient.SimpleGet(const AURL: String): String; + +begin + With Self.Create(nil) do + try + Result:=Get(AURL); + finally + Free; + end; +end; + + +procedure TFPCustomHTTPClient.Post(const URL: string; const Response: TStream); +begin + HTTPMethod('POST',URL,Response,[]); +end; + + +procedure TFPCustomHTTPClient.Post(const URL: string; Response: TStrings); +begin + Response.Text:=Post(URL); +end; + + +procedure TFPCustomHTTPClient.Post(const URL: string; + const LocalFileName: String); + +Var + F : TFileStream; + +begin + F:=TFileStream.Create(LocalFileName,fmCreate); + try + Post(URL,F); + finally + F.Free; + end; +end; + + +function TFPCustomHTTPClient.Post(const URL: string): String; +Var + SS : TStringStream; +begin + SS:=TStringStream.Create(''); + try + Post(URL,SS); + Result:=SS.Datastring; + finally + SS.Free; + end; +end; + + +class procedure TFPCustomHTTPClient.SimplePost(const URL: string; + const Response: TStream); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Post(URL,Response); + finally + Free; + end; +end; + + +class procedure TFPCustomHTTPClient.SimplePost(const URL: string; + Response: TStrings); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Post(URL,Response); + finally + Free; + end; +end; + + +class procedure TFPCustomHTTPClient.SimplePost(const URL: string; + const LocalFileName: String); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Post(URL,LocalFileName); + finally + Free; + end; +end; + + +class function TFPCustomHTTPClient.SimplePost(const URL: string): String; + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Result:=Post(URL); + finally + Free; + end; +end; + +procedure TFPCustomHTTPClient.Put(const URL: string; const Response: TStream); +begin + HTTPMethod('PUT',URL,Response,[]); +end; + +procedure TFPCustomHTTPClient.Put(const URL: string; Response: TStrings); +begin + Response.Text:=Put(URL); +end; + +procedure TFPCustomHTTPClient.Put(const URL: string; const LocalFileName: String + ); + +Var + F : TFileStream; + +begin + F:=TFileStream.Create(LocalFileName,fmCreate); + try + Put(URL,F); + finally + F.Free; + end; +end; + +function TFPCustomHTTPClient.Put(const URL: string): String; +Var + SS : TStringStream; +begin + SS:=TStringStream.Create(''); + try + Put(URL,SS); + Result:=SS.Datastring; + finally + SS.Free; + end; +end; + +class procedure TFPCustomHTTPClient.SimplePut(const URL: string; + const Response: TStream); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Put(URL,Response); + finally + Free; + end; +end; + +class procedure TFPCustomHTTPClient.SimplePut(const URL: string; + Response: TStrings); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Put(URL,Response); + finally + Free; + end; +end; + +class procedure TFPCustomHTTPClient.SimplePut(const URL: string; + const LocalFileName: String); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Put(URL,LocalFileName); + finally + Free; + end; +end; + +class function TFPCustomHTTPClient.SimplePut(const URL: string): String; + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Result:=Put(URL); + finally + Free; + end; +end; + +procedure TFPCustomHTTPClient.Delete(const URL: string; const Response: TStream + ); +begin + HTTPMethod('DELETE',URL,Response,[]); +end; + +procedure TFPCustomHTTPClient.Delete(const URL: string; Response: TStrings); +begin + Response.Text:=Delete(URL); +end; + +procedure TFPCustomHTTPClient.Delete(const URL: string; + const LocalFileName: String); + +Var + F : TFileStream; + +begin + F:=TFileStream.Create(LocalFileName,fmCreate); + try + Delete(URL,F); + finally + F.Free; + end; +end; + +function TFPCustomHTTPClient.Delete(const URL: string): String; +Var + SS : TStringStream; +begin + SS:=TStringStream.Create(''); + try + Delete(URL,SS); + Result:=SS.Datastring; + finally + SS.Free; + end; +end; + +class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string; + const Response: TStream); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Delete(URL,Response); + finally + Free; + end; +end; + +class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string; + Response: TStrings); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Delete(URL,Response); + finally + Free; + end; +end; + +class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string; + const LocalFileName: String); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Delete(URL,LocalFileName); + finally + Free; + end; +end; + +class function TFPCustomHTTPClient.SimpleDelete(const URL: string): String; + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Result:=Delete(URL); + finally + Free; + end; +end; + +procedure TFPCustomHTTPClient.Options(const URL: string; const Response: TStream + ); +begin + HTTPMethod('OPTIONS',URL,Response,[]); +end; + +procedure TFPCustomHTTPClient.Options(const URL: string; Response: TStrings); +begin + Response.Text:=Options(URL); +end; + +procedure TFPCustomHTTPClient.Options(const URL: string; + const LocalFileName: String); + +Var + F : TFileStream; + +begin + F:=TFileStream.Create(LocalFileName,fmCreate); + try + Options(URL,F); + finally + F.Free; + end; +end; + +function TFPCustomHTTPClient.Options(const URL: string): String; +Var + SS : TStringStream; +begin + SS:=TStringStream.Create(''); + try + Options(URL,SS); + Result:=SS.Datastring; + finally + SS.Free; + end; +end; + +class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string; + const Response: TStream); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Options(URL,Response); + finally + Free; + end; +end; + +class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string; + Response: TStrings); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Options(URL,Response); + finally + Free; + end; +end; + +class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string; + const LocalFileName: String); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Options(URL,LocalFileName); + finally + Free; + end; +end; + +class function TFPCustomHTTPClient.SimpleOptions(const URL: string): String; + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Result:=Options(URL); + finally + Free; + end; +end; + +class procedure TFPCustomHTTPClient.Head(AURL: String; Headers: TStrings); +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + HTTPMethod('HEAD', AURL, Nil, [200]); + Headers.Assign(ResponseHeaders); + Finally + Free; + end; +end; + +procedure TFPCustomHTTPClient.FormPost(const URL, FormData: string; + const Response: TStream); + +begin + RequestBody:=TStringStream.Create(FormData); + try + AddHeader('Content-Type','application/x-www-form-urlencoded'); + Post(URL,Response); + finally + RequestBody.Free; + RequestBody:=Nil; + end; +end; + +procedure TFPCustomHTTPClient.FormPost(const URL: string; FormData: TStrings; + const Response: TStream); + +Var + I : Integer; + S,N,V : String; + +begin + S:=''; + For I:=0 to FormData.Count-1 do + begin + If (S<>'') then + S:=S+'&'; + FormData.GetNameValue(i,n,v); + S:=S+EncodeURLElement(N)+'='+EncodeURLElement(V); + end; + FormPost(URL,S,Response); +end; + +procedure TFPCustomHTTPClient.FormPost(const URL, FormData: string; + const Response: TStrings); +begin + Response.Text:=FormPost(URL,FormData); +end; + +procedure TFPCustomHTTPClient.FormPost(const URL: string; FormData: TStrings; + const Response: TStrings); +begin + Response.Text:=FormPost(URL,FormData); +end; + +function TFPCustomHTTPClient.FormPost(const URL, FormData: string): String; +Var + SS : TStringStream; +begin + SS:=TStringStream.Create(''); + try + FormPost(URL,FormData,SS); + Result:=SS.Datastring; + finally + SS.Free; + end; +end; + +function TFPCustomHTTPClient.FormPost(const URL: string; FormData: TStrings): String; +Var + SS : TStringStream; +begin + SS:=TStringStream.Create(''); + try + FormPost(URL,FormData,SS); + Result:=SS.Datastring; + finally + SS.Free; + end; +end; + +class procedure TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string; + const Response: TStream); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + FormPost(URL,FormData,Response); + Finally + Free; + end; +end; + + +class procedure TFPCustomHTTPClient.SimpleFormPost(const URL: string; + FormData: TStrings; const Response: TStream); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + FormPost(URL,FormData,Response); + Finally + Free; + end; +end; + + +class procedure TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string; + const Response: TStrings); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + FormPost(URL,FormData,Response); + Finally + Free; + end; +end; + +class procedure TFPCustomHTTPClient.SimpleFormPost(const URL: string; + FormData: TStrings; const Response: TStrings); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + FormPost(URL,FormData,Response); + Finally + Free; + end; +end; + +class function TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string + ): String; + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Result:=FormPost(URL,FormData); + Finally + Free; + end; +end; + +class function TFPCustomHTTPClient.SimpleFormPost(const URL: string; + FormData: TStrings): String; + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + Result:=FormPost(URL,FormData); + Finally + Free; + end; +end; + + +procedure TFPCustomHTTPClient.FileFormPost(const AURL, AFieldName, + AFileName: string; const Response: TStream); +begin + FileFormPost(AURL, nil, AFieldName, AFileName, Response); +end; + +procedure TFPCustomHTTPClient.FileFormPost(const AURL: string; + FormData: TStrings; AFieldName, AFileName: string; const Response: TStream); +var + F: TFileStream; +begin + F:=TFileStream.Create(AFileName,fmOpenRead or fmShareDenyWrite); + try + StreamFormPost(AURL, FormData, AFieldName, ExtractFileName(AFileName), F, Response); + finally + F.Free; + end; +end; + +procedure TFPCustomHTTPClient.StreamFormPost(const AURL, AFieldName, + AFileName: string; const AStream: TStream; const Response: TStream); +begin + StreamFormPost(AURL, nil, AFieldName, AFileName, AStream, Response); +end; + +procedure TFPCustomHTTPClient.StreamFormPost(const AURL: string; + FormData: TStrings; const AFieldName, AFileName: string; + const AStream: TStream; const Response: TStream); +Var + S, Sep : string; + SS : TStringStream; + I: Integer; + N,V: String; +begin + Sep:=Format('%.8x_multipart_boundary',[Random($ffffff)]); + AddHeader('Content-Type','multipart/form-data; boundary='+Sep); + SS:=TStringStream.Create(''); + try + if (FormData<>Nil) then + for I:=0 to FormData.Count -1 do + begin + // not url encoded + FormData.GetNameValue(I,N,V); + S :='--'+Sep+CRLF; + S:=S+Format('Content-Disposition: form-data; name="%s"'+CRLF+CRLF+'%s'+CRLF,[N, V]); + SS.WriteBuffer(S[1],Length(S)); + end; + S:='--'+Sep+CRLF; + s:=s+Format('Content-Disposition: form-data; name="%s"; filename="%s"'+CRLF,[AFieldName,ExtractFileName(AFileName)]); + s:=s+'Content-Type: application/octet-string'+CRLF+CRLF; + SS.WriteBuffer(S[1],Length(S)); + AStream.Seek(0, soFromBeginning); + SS.CopyFrom(AStream,AStream.Size); + S:=CRLF+'--'+Sep+'--'+CRLF; + SS.WriteBuffer(S[1],Length(S)); + SS.Position:=0; + RequestBody:=SS; + Post(AURL,Response); + finally + RequestBody:=Nil; + SS.Free; + end; +end; + + +class procedure TFPCustomHTTPClient.SimpleFileFormPost(const AURL, AFieldName, + AFileName: string; const Response: TStream); + +begin + With Self.Create(nil) do + try + RequestHeaders.Add('Connection: Close'); + FileFormPost(AURL,AFieldName,AFileName,Response); + Finally + Free; + end; +end; + +end. + diff --git a/components/everettrandom/latest_stable/everettrandom.lpk b/components/everettrandom/latest_stable/everettrandom.lpk new file mode 100644 index 000000000..58ed89931 --- /dev/null +++ b/components/everettrandom/latest_stable/everettrandom.lpk @@ -0,0 +1,66 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <Package Version="4"> + <PathDelim Value="\"/> + <Name Value="everettrandom"/> + <Type Value="RunTimeOnly"/> + <AddToProjectUsesSection Value="True"/> + <Author Value="minesadorada"/> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <CodeGeneration> + <SmartLinkUnit Value="True"/> + <RelocatableUnit Value="True"/> + <Optimizations> + <OptimizationLevel Value="3"/> + </Optimizations> + </CodeGeneration> + <Linking> + <Debugging> + <GenerateDebugInfo Value="False"/> + </Debugging> + </Linking> + </CompilerOptions> + <Description Value="Random integer(s) via an online quantum beam splitter. Each call to the server splits the Universe accorsing to Everett's interpretation of quantum mechanics"/> + <License Value="LGPLV2"/> + <Version Minor="1" Release="3"/> + <Files Count="3"> + <Item1> + <Filename Value="everett_httpclient.pas"/> + <UnitName Value="everett_httpclient"/> + </Item1> + <Item2> + <Filename Value="open_ssl.pas"/> + <UnitName Value="open_ssl"/> + </Item2> + <Item3> + <Filename Value="ueverettrandom.pas"/> + <UnitName Value="ueverettrandom"/> + </Item3> + </Files> + <i18n> + <EnableI18N Value="True"/> + <OutDir Value="locale"/> + <EnableI18NForLFM Value="True"/> + </i18n> + <RequiredPkgs Count="2"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + <Item2> + <PackageName Value="FCL"/> + </Item2> + </RequiredPkgs> + <UsageOptions> + <UnitPath Value="$(PkgOutDir)"/> + </UsageOptions> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + </Package> +</CONFIG> diff --git a/components/everettrandom/latest_stable/everettrandom.pas b/components/everettrandom/latest_stable/everettrandom.pas new file mode 100644 index 000000000..6df3f3755 --- /dev/null +++ b/components/everettrandom/latest_stable/everettrandom.pas @@ -0,0 +1,15 @@ +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit everettrandom; + +{$warn 5023 off : no warning about unused units} +interface + +uses + everett_httpclient, open_ssl, ueverettrandom; + +implementation + +end. diff --git a/components/everettrandom/latest_stable/everettrandom.zip b/components/everettrandom/latest_stable/everettrandom.zip new file mode 100644 index 000000000..8a225ede7 Binary files /dev/null and b/components/everettrandom/latest_stable/everettrandom.zip differ diff --git a/components/everettrandom/latest_stable/jsoneditor.exe b/components/everettrandom/latest_stable/jsoneditor.exe new file mode 100644 index 000000000..458dcb059 Binary files /dev/null and b/components/everettrandom/latest_stable/jsoneditor.exe differ diff --git a/components/everettrandom/latest_stable/locale/everett_httpclient.po b/components/everettrandom/latest_stable/locale/everett_httpclient.po new file mode 100644 index 000000000..ebe86fe01 --- /dev/null +++ b/components/everettrandom/latest_stable/locale/everett_httpclient.po @@ -0,0 +1,35 @@ +msgid "" +msgstr "Content-Type: text/plain; charset=UTF-8" + +#: everett_httpclient.serrchunklineendmissing +msgid "Chunk line end missing" +msgstr "" + +#: everett_httpclient.serrchunktoobig +msgid "Chunk too big" +msgstr "" + +#: everett_httpclient.serrinvalidprotocol +msgid "Invalid protocol: \"%s\"" +msgstr "" + +#: everett_httpclient.serrinvalidprotocolversion +msgid "Invalid protocol version in response: \"%s\"" +msgstr "" + +#: everett_httpclient.serrinvalidstatuscode +msgid "Invalid response status code: %s" +msgstr "" + +#: everett_httpclient.serrmaxredirectsreached +msgid "Maximum allowed redirects reached: %d" +msgstr "" + +#: everett_httpclient.serrreadingsocket +msgid "Error reading data from socket" +msgstr "" + +#: everett_httpclient.serrunexpectedresponse +msgid "Unexpected response status code: %d" +msgstr "" + diff --git a/components/everettrandom/latest_stable/locale/jsoneditor.en.po b/components/everettrandom/latest_stable/locale/jsoneditor.en.po new file mode 100644 index 000000000..8e6535534 --- /dev/null +++ b/components/everettrandom/latest_stable/locale/jsoneditor.en.po @@ -0,0 +1,396 @@ +msgid "" +msgstr "" +"Content-Type: text/plain; charset=UTF-8\n" +"Project-Id-Version: \n" +"POT-Creation-Date: \n" +"PO-Revision-Date: \n" +"Last-Translator: minesadorada <minesadorada@charcodelvalle.com>\n" +"Language-Team: \n" +"MIME-Version: 1.0\n" +"Content-Transfer-Encoding: 8bit\n" +"Language: en\n" +"X-Generator: Poedit 1.8.11\n" + +#: tfrmmain.chk_disableinopm.caption +msgid "Disable in OPM" +msgstr "Disable in OPM" + +#: tfrmmain.chk_disableinopm.hint +msgid "Warning! This will disable installing or updating your package in OPM" +msgstr "Warning! This will disable installing or updating your package in OPM" + +#: tfrmmain.cmd_addpackagefile.caption +msgctxt "tfrmmain.cmd_addpackagefile.caption" +msgid "Add" +msgstr "Add" + +#: tfrmmain.cmd_addpackagefile.hint +msgctxt "tfrmmain.cmd_addpackagefile.hint" +msgid "" +"Add Package File:\n" +"The update zip can contain more than one lpk file\n" +"deployed to the same place.\n" +msgstr "" +"Add Package File:\n" +"The update zip can contain more than one lpk file\n" +"deployed to the same place.\n" + +#: tfrmmain.cmd_close.caption +msgid "&Close" +msgstr "&Close" + +#: tfrmmain.cmd_removelastpackagefile.caption +msgctxt "tfrmmain.cmd_removelastpackagefile.caption" +msgid "Remove" +msgstr "Remove" + +#: tfrmmain.cmd_removelastpackagefile.hint +msgctxt "tfrmmain.cmd_removelastpackagefile.hint" +msgid "" +"Remove Package File:\n" +"Deletes the last entry from the list\n" +msgstr "" +"Remove Package File:\n" +"Deletes the last entry from the list\n" + +#: tfrmmain.cmd_save.caption +msgid "&Save" +msgstr "&Save" + +#: tfrmmain.cmd_save.hint +msgid "" +"Save the current configuration to disk\n" +"as a JSON update file\n" +msgstr "" +"Save the current configuration to disk\n" +"as a JSON update file\n" + +#: tfrmmain.edt_downloadzipurl.hint +msgctxt "tfrmmain.edt_downloadzipurl.hint" +msgid "" +"Download URL:\n" +"Include the FULL url needed to download the package Zip file\n" +msgstr "" +"Download URL:\n" +"Include the FULL url needed to download the package Zip file\n" + +#: tfrmmain.edt_updatezipname.hint +msgctxt "tfrmmain.edt_updatezipname.hint" +msgid "" +"Update Zip Name:\n" +"This is just the filename (not including the path)\n" +"of your update zip. Type, or click the [...]\n" +msgstr "" +"Update Zip Name:\n" +"This is just the filename (not including the path)\n" +"of your update zip. Type, or click the [...]\n" + +#: tfrmmain.filemenu.caption +msgid "File" +msgstr "File" + +#: tfrmmain.fileopen1.caption +msgid "&Open ..." +msgstr "&Open ..." + +#: tfrmmain.fileopen1.hint +msgid "Open" +msgstr "Open" + +#: tfrmmain.filesaveas1.caption +msgid "&Save As ..." +msgstr "&Save As ..." + +#: tfrmmain.filesaveas1.hint +msgid "Save As" +msgstr "Save As" + +#: tfrmmain.lbl_downloadzipurl.caption +msgctxt "tfrmmain.lbl_downloadzipurl.caption" +msgid "Download URL:" +msgstr "Download URL:" + +#: tfrmmain.lbl_packagefiles.caption +msgctxt "tfrmmain.lbl_packagefiles.caption" +msgid "Package Files:" +msgstr "Package Files:" + +#: tfrmmain.lbl_updatezipname.caption +msgctxt "tfrmmain.lbl_updatezipname.caption" +msgid "Update Zip Name:" +msgstr "Update Zip Name:" + +#: tfrmmain.loaditem.caption +msgid "Load..." +msgstr "Load..." + +#: tfrmmain.mnu_fileexit.caption +msgid "E&xit" +msgstr "E&xit" + +#: tfrmmain.mnu_filenew.caption +msgid "New" +msgstr "New" + +#: tfrmmain.mnu_filesave.caption +msgid "Save" +msgstr "Save" + +#: tfrmmain.mnu_help.caption +msgid "&Help" +msgstr "&Help" + +#: tfrmmain.mnu_helpabout.caption +msgid "About.." +msgstr "About.." + +#: tfrmmain.mnu_helpautoloadlastfile.caption +msgid "Autoload last file" +msgstr "" + +#: tfrmmain.mnu_helpdisablewarnings.caption +msgid "Disable warnings" +msgstr "Disable warnings" + +#: tfrmmain.mnu_helpshowhints.caption +msgid "Show Popup Hints" +msgstr "Show Popup Hints" + +#: tfrmmain.mnu_lang.caption +msgid "Languages.." +msgstr "Languages.." + +#: tfrmmain.mnu_lang_en.caption +msgid "English" +msgstr "English" + +#: tfrmmain.mnu_lang_es.caption +msgid "Español" +msgstr "Español" + +#: tfrmmain.saveasitem.caption +msgid "Save As..." +msgstr "Save As..." + +#: tfrmmain.sb_editname.caption +msgid "..." +msgstr "..." + +#: tfrmmain.sb_editname.hint +msgid "" +"Update Zip Name:\n" +"Click this to browse your system to find\n" +" an existing Update Zip\n" +msgstr "" +"Update Zip Name:\n" +"Click this to browse your system to find\n" +" an existing Update Zip\n" + +#: tfrmmain.spd_checkurl.caption +msgid "Check URL" +msgstr "Check URL" + +#: tfrmmain.spd_checkurl.hint +#, fuzzy +#| msgid "" +#| "Check URL:\n" +#| "Attempts to open the URL in your browser\n" +msgid "Attempts to open the URL in your browser" +msgstr "" +"Check URL:\n" +"Attempts to open the URL in your browser\n" + +#: umain.rsabout +msgid "About" +msgstr "About" + +#: umain.rscheckthisify +#, fuzzy +#| msgid "Check this if you don't want to incrememt the package version" +msgid "Check this if you don't want to increment the package version" +msgstr "Check this if you don't want to incrememt the package version" + +#: umain.rscompiledwith2 +msgid "Compiled with FPC V:%s and Lazarus V:%d.%d%s for the %s - %s platform%s%s" +msgstr "Compiled with FPC V:%s and Lazarus V:%d.%d%s for the %s - %s platform%s%s" + +#: umain.rsdownloadzipurld +msgid "- Download URL does not contain the zipfile name" +msgstr "- Download URL does not contain the zipfile name" + +#: umain.rsdownloadzipurli +msgid "- Download URL is too short or missing" +msgstr "- Download URL is too short or missing" + +#: umain.rsdownloadzipurli2 +msgid "- Download URL is incomplete" +msgstr "- Download URL is incomplete" + +#: umain.rsdownloadzipurls +msgid "- Download URL should start with \"http\"" +msgstr "- Download URL should start with \"http\"" + +#: umain.rsfilemaybeuns +msgid "JSON may be unsaved. Are you sure you want to quit?" +msgstr "JSON may be unsaved. Are you sure you want to quit?" + +#: umain.rsfilename +msgid "Filename: " +msgstr "Filename: " + +#: umain.rsfixthentryag +msgid "Fix, then try again." +msgstr "Fix, then try again." + +#: umain.rsformatisnnnn +msgid "Package version:%sFormat is: n.n.n.n" +msgstr "Package version:%sFormat is: n.n.n.n" + +#: umain.rshelpandinfor +msgid "Help and Information" +msgstr "Help and Information" + +#: umain.rshttpwwwupdat +msgid "http://www.updatesite.com/myupdate/mypackagename.zip" +msgstr "http://www.updatesite.com/myupdate/mypackagename.zip" + +#: umain.rsinternalvers +msgid "Internal Version: " +msgstr "Internal Version: " + +#: umain.rsinternalvers2 +msgid "Internal version number should not be Zero%s" +msgstr "Internal version number should not be Zero%s" + +#: umain.rslanguagechan +msgid "Language changed to \"%s\"." +msgstr "Language changed to \"%s\"." + +#: umain.rsmypackagelpk +#| msgid "mypackagename.zip" +msgctxt "umain.rsmypackagelpk" +msgid "mypackagename.lpk" +msgstr "mypackagename.lpk" + +#: umain.rsmypackagenam +msgctxt "umain.rsmypackagenam" +msgid "mypackagename.zip" +msgstr "mypackagename.zip" + +#: umain.rsnotifyupdate +msgid "Notify Update" +msgstr "Notify Update" + +#: umain.rsoneofthereq1 +msgid "One of the required fields is missing or wrong." +msgstr "One of the required fields is missing or wrong." + +#: umain.rsoneofthereqn +msgid "One or more of the required fields are missing or wrong." +msgstr "One or more of the required fields are missing or wrong." + +#: umain.rsopeningyourb +msgid "Opening your browser..." +msgstr "Opening your browser..." + +#: umain.rsoverwrite +msgid "Overwrite" +msgstr "Overwrite" + +#: umain.rspackagedinfo +msgid "Package #%d Information" +msgstr "Package #%d Information" + +#: umain.rssavedok +msgid "Saved OK" +msgstr "Saved OK" + +#: umain.rssaveunsucces +msgid "Save unsuccessful" +msgstr "Save unsuccessful" + +#: umain.rssorrycopyope +msgid "Sorry - copy operation was unsuccessful" +msgstr "Sorry - copy operation was unsuccessful" + +#: umain.rssorrythislan +msgid "Sorry, this language is unavailable at this time." +msgstr "Sorry, this language is unavailable at this time." + +#: umain.rsswassuccessf +msgid "%s was successfully copied to the %s folder" +msgstr "%s was successfully copied to the %s folder" + +#: umain.rsthelpkentryd +msgid "The .lpk entry #%d is missing the .lpk extension" +msgstr "The .lpk entry #%d is missing the .lpk extension" + +#: umain.rsthelpkentryd2 +msgid "The .lpk entry #%d is is absent" +msgstr "The .lpk entry #%d is is absent" + +#: umain.rsthepackagefi +msgid "The package filename (No path e.g. package.lpk)" +msgstr "The package filename (No path e.g. package.lpk)" + +#: umain.rsthereareoneo +msgid "- There are one or more .lpk entries with the same name.%s- Every .lpk entry must have a unique name." +msgstr "- There are one or more .lpk entries with the same name.%s- Every .lpk entry must have a unique name." + +#: umain.rstherewasapro +msgid "There was a problem loading \"%s\" - is it corrupted or in the wrong format?" +msgstr "There was a problem loading \"%s\" - is it corrupted or in the wrong format?" + +#: umain.rsthisoptionsh +#| msgid "This option should only be used for crucial updates or bug-fixed packages. Are you OK with that?" +msgid "This option should only be used for crucial updates or bug-fixed packages." +msgstr "This option should only be used for crucial updates or bug-fixed packages." + +#: umain.rsthiswilldisa +#, fuzzy +#| msgid "This will disable your package in OnlinePackageManager!%sAre you SURE you want to do this?" +msgid "This will disable your package in Online Package Manager!%sAre you SURE you want to do this?" +msgstr "This will disable your package in OnlinePackageManager!%sAre you SURE you want to do this?" + +#: umain.rsturnhintsoff +msgid "(You can toggle these hints on/off in the Help menu)" +msgstr "(You can toggle these hints on/off in the Help menu)" + +#: umain.rsupdate +msgid "Update" +msgstr "Update" + +#: umain.rsupdatejsonsf +msgid "Update file \"%s\" failed to load correctly." +msgstr "Update file \"%s\" failed to load correctly." + +#: umain.rsupdatezipnam +msgid "- Update zip name is too short or missing" +msgstr "- Update zip name is too short or missing" + +#: umain.rsupdatezipnam2 +msgid "- Update zip name missing extension \".zip\"" +msgstr "- Update zip name missing extension \".zip\"" + +#: umain.rsuseincombina +#, fuzzy +#| msgid "Use in combination with %s" +msgid "Use in combination with" +msgstr "Use in combination with %s" + +#: umain.rsversion +msgid "Version: " +msgstr "Version: " + +#: umain.rsversionforpa +msgid "Version for package %d is zero" +msgstr "Version for package %d is zero" + +#: umain.rswouldyoulike +msgid "Would you like to copy %s to the %s folder?" +msgstr "Would you like to copy %s to the %s folder?" + +#: umain.rsyoumayneedto +msgid "(You may need to restart the app to see the change)" +msgstr "(You may need to restart the app to see the change)" + diff --git a/components/everettrandom/latest_stable/locale/jsoneditor.es.po b/components/everettrandom/latest_stable/locale/jsoneditor.es.po new file mode 100644 index 000000000..39ee37ec4 --- /dev/null +++ b/components/everettrandom/latest_stable/locale/jsoneditor.es.po @@ -0,0 +1,383 @@ +msgid "" +msgstr "" +"Content-Type: text/plain; charset=UTF-8\n" +"Project-Id-Version: jsoneditor\n" +"POT-Creation-Date: \n" +"PO-Revision-Date: \n" +"Last-Translator: minesadorada <minesadorada@charcodelvalle.com>\n" +"Language-Team: \n" +"MIME-Version: 1.0\n" +"Content-Transfer-Encoding: 8bit\n" +"Language: es\n" +"X-Generator: Poedit 1.8.11\n" +"X-Poedit-SourceCharset: UTF-8\n" + +#: tfrmmain.chk_disableinopm.caption +msgid "Disable in OPM" +msgstr "Desactivar en OPM" + +#: tfrmmain.chk_disableinopm.hint +msgid "Warning! This will disable installing or updating your package in OPM" +msgstr "¡Advertencia! Esto deshabilitará la instalación o actualización de tu paquete en OPM" + +#: tfrmmain.cmd_addpackagefile.caption +msgctxt "tfrmmain.cmd_addpackagefile.caption" +msgid "Add" +msgstr "Agregar" + +#: tfrmmain.cmd_addpackagefile.hint +msgctxt "tfrmmain.cmd_addpackagefile.hint" +msgid "" +"Add Package File:\n" +"The update zip can contain more than one lpk file\n" +"deployed to the same place.\n" +msgstr "" +"Agregar archivo de paquete:\n" +"El zip de actualización puede contener mas que un archivo lpk\n" +"distribuido en el mismo lugar.\n" + +#: tfrmmain.cmd_close.caption +msgid "&Close" +msgstr "&Cerrar" + +#: tfrmmain.cmd_removelastpackagefile.caption +msgctxt "tfrmmain.cmd_removelastpackagefile.caption" +msgid "Remove" +msgstr "Quitar" + +#: tfrmmain.cmd_removelastpackagefile.hint +msgctxt "tfrmmain.cmd_removelastpackagefile.hint" +msgid "" +"Remove Package File:\n" +"Deletes the last entry from the list\n" +msgstr "" +"Quitar archivo de paquete:\n" +"Elimina la última entrada de la lista\n" + +#: tfrmmain.cmd_save.caption +msgid "&Save" +msgstr "&Guardar" + +#: tfrmmain.cmd_save.hint +msgid "" +"Save the current configuration to disk\n" +"as a JSON update file\n" +msgstr "" +"Guardar la configuración actual en el disco\n" +"como archivo de actualización JSON\n" + +#: tfrmmain.edt_downloadzipurl.hint +msgctxt "tfrmmain.edt_downloadzipurl.hint" +msgid "" +"Download URL:\n" +"Include the FULL url needed to download the package Zip file\n" +msgstr "" +"URL de Descarga:\n" +"Incluye la url COMPLETA necesaria para descargar el archivo zip del paquete\n" + +#: tfrmmain.edt_updatezipname.hint +msgctxt "tfrmmain.edt_updatezipname.hint" +msgid "" +"Update Zip Name:\n" +"This is just the filename (not including the path)\n" +"of your update zip. Type, or click the [...]\n" +msgstr "" +"Nombre del Zip de actualización:\n" +"Este es solo el nombre (no incluye la ruta)\n" +"de tu zip de actualización. Escribe o haz clic en [...]\n" + +#: tfrmmain.filemenu.caption +msgid "File" +msgstr "Archivo" + +#: tfrmmain.fileopen1.caption +msgid "&Open ..." +msgstr "&Abrir ..." + +#: tfrmmain.fileopen1.hint +msgid "Open" +msgstr "Abrir" + +#: tfrmmain.filesaveas1.caption +msgid "&Save As ..." +msgstr "&Guardar Como ..." + +#: tfrmmain.filesaveas1.hint +msgid "Save As" +msgstr "Guardar Como" + +#: tfrmmain.lbl_downloadzipurl.caption +msgctxt "tfrmmain.lbl_downloadzipurl.caption" +msgid "Download URL:" +msgstr "URL de Descarga:" + +#: tfrmmain.lbl_packagefiles.caption +msgctxt "tfrmmain.lbl_packagefiles.caption" +msgid "Package Files:" +msgstr "Archivos de Paquete:" + +#: tfrmmain.lbl_updatezipname.caption +msgctxt "tfrmmain.lbl_updatezipname.caption" +msgid "Update Zip Name:" +msgstr "Nombre del Zip de actualización:" + +#: tfrmmain.loaditem.caption +msgid "Load..." +msgstr "Cargar..." + +#: tfrmmain.mnu_fileexit.caption +msgid "E&xit" +msgstr "&Salir" + +#: tfrmmain.mnu_filenew.caption +msgid "New" +msgstr "Nuevo" + +#: tfrmmain.mnu_filesave.caption +msgid "Save" +msgstr "Guardar" + +#: tfrmmain.mnu_help.caption +msgid "&Help" +msgstr "&Ayuda" + +#: tfrmmain.mnu_helpabout.caption +msgid "About.." +msgstr "Acerca de.." + +#: tfrmmain.mnu_helpautoloadlastfile.caption +msgid "Autoload last file" +msgstr "" + +#: tfrmmain.mnu_helpdisablewarnings.caption +msgid "Disable warnings" +msgstr "Deshabilitar advertencias" + +#: tfrmmain.mnu_helpshowhints.caption +msgid "Show Popup Hints" +msgstr "Mostrar consejos" + +#: tfrmmain.mnu_lang.caption +msgid "Languages.." +msgstr "Idiomas.." + +#: tfrmmain.mnu_lang_en.caption +msgid "English" +msgstr "English" + +#: tfrmmain.mnu_lang_es.caption +msgid "Español" +msgstr "Español" + +#: tfrmmain.saveasitem.caption +msgid "Save As..." +msgstr "Guardar Como..." + +#: tfrmmain.sb_editname.caption +msgid "..." +msgstr "..." + +#: tfrmmain.sb_editname.hint +msgid "" +"Update Zip Name:\n" +"Click this to browse your system to find\n" +" an existing Update Zip\n" +msgstr "" +"Nombre del zip de actualización:\n" +"Haz clic aquí para explorar tu sistema para encontrar\n" +" un zip de actualización existente\n" + +#: tfrmmain.spd_checkurl.caption +msgid "Check URL" +msgstr "Verificar URL" + +#: tfrmmain.spd_checkurl.hint +msgid "Attempts to open the URL in your browser" +msgstr "Intentando Abrir URL en el navegador" + +#: umain.rsabout +msgid "About" +msgstr "Acerca de" + +#: umain.rscheckthisify +msgid "Check this if you don't want to increment the package version" +msgstr "Marca esto si no quieres incrementar la versión del paquete" + +#: umain.rscompiledwith2 +msgid "Compiled with FPC V:%s and Lazarus V:%d.%d%s for the %s - %s platform%s%s" +msgstr "Compilado con FPC V:%s y Lazarus V:%d.%d%s para la plataforma %s - %s%s%s" + +#: umain.rsdownloadzipurld +msgid "- Download URL does not contain the zipfile name" +msgstr "- La URL de descarga no contiene el nombre del zip" + +#: umain.rsdownloadzipurli +msgid "- Download URL is too short or missing" +msgstr "- URL de descarga es muy corta o está vacía" + +#: umain.rsdownloadzipurli2 +msgid "- Download URL is incomplete" +msgstr "- URL de descarga incompleta" + +#: umain.rsdownloadzipurls +msgid "- Download URL should start with \"http\"" +msgstr "- URL de descarga debe empezar con \"http\"" + +#: umain.rsfilemaybeuns +msgid "JSON may be unsaved. Are you sure you want to quit?" +msgstr "JSON puede estar sin guardar. ¿Está seguro que desea salir?" + +#: umain.rsfilename +msgid "Filename: " +msgstr "Archivo: " + +#: umain.rsfixthentryag +msgid "Fix, then try again." +msgstr "Arréglalo, luego intenta de nuevo." + +#: umain.rsformatisnnnn +msgid "Package version:%sFormat is: n.n.n.n" +msgstr "Versión del paquete:%sFormato es: n.n.n.n" + +#: umain.rshelpandinfor +msgid "Help and Information" +msgstr "Ayuda e Información" + +#: umain.rshttpwwwupdat +msgid "http://www.updatesite.com/myupdate/mypackagename.zip" +msgstr "http://www.sitioactualizacion.com/miactualizacion/nombredemipaquete.zip" + +#: umain.rsinternalvers +msgid "Internal Version: " +msgstr "Versión Interna: " + +#: umain.rsinternalvers2 +msgid "Internal version number should not be Zero%s" +msgstr "La versión interna no debe ser cero%s" + +#: umain.rslanguagechan +msgid "Language changed to \"%s\"." +msgstr "Idioma cambiado a \"%s\"." + +#: umain.rsmypackagelpk +msgctxt "umain.rsmypackagelpk" +msgid "mypackagename.lpk" +msgstr "nombredemipaquete.lpk" + +#: umain.rsmypackagenam +msgctxt "umain.rsmypackagenam" +msgid "mypackagename.zip" +msgstr "nombredemipaquete.zip" + +#: umain.rsnotifyupdate +msgid "Notify Update" +msgstr "Notificar Actualización" + +#: umain.rsoneofthereq1 +msgid "One of the required fields is missing or wrong." +msgstr "Uno de los campos requeridos esta vacío o mal." + +#: umain.rsoneofthereqn +msgid "One or more of the required fields are missing or wrong." +msgstr "Uno o mas de los capos requeridos esta vacío o mal." + +#: umain.rsopeningyourb +msgid "Opening your browser..." +msgstr "Abriendo tu navegador..." + +#: umain.rsoverwrite +msgid "Overwrite" +msgstr "Sobreescribir" + +#: umain.rspackagedinfo +msgid "Package #%d Information" +msgstr "Paquete #%d Información" + +#: umain.rssavedok +msgid "Saved OK" +msgstr "Guardado OK" + +#: umain.rssaveunsucces +msgid "Save unsuccessful" +msgstr "Guardado no satisfactorio" + +#: umain.rssorrycopyope +msgid "Sorry - copy operation was unsuccessful" +msgstr "Lo siento, operación de copia insatisfactoria" + +#: umain.rssorrythislan +msgid "Sorry, this language is unavailable at this time." +msgstr "Lo siento, este idioma no está disponible en este momento." + +#: umain.rsswassuccessf +msgid "%s was successfully copied to the %s folder" +msgstr "%s fue satisfactoriamente copiado a la carpeta %s" + +#: umain.rsthelpkentryd +msgid "The .lpk entry #%d is missing the .lpk extension" +msgstr "La entrada .lpk #%d no tiene la extensión .lpk" + +#: umain.rsthelpkentryd2 +msgid "The .lpk entry #%d is is absent" +msgstr "La entrada .lpk #%d está vacía" + +#: umain.rsthepackagefi +msgid "The package filename (No path e.g. package.lpk)" +msgstr "El nombre del paquete (Sin ruta ej. paquete.lpk)" + +#: umain.rsthereareoneo +msgid "- There are one or more .lpk entries with the same name.%s- Every .lpk entry must have a unique name." +msgstr "- Hay una o más entradas .lpk con el mismo nombre.%s- Cada entrada .lpk debe tener un nombre único." + +#: umain.rstherewasapro +msgid "There was a problem loading \"%s\" - is it corrupted or in the wrong format?" +msgstr "Hubo un problema cargando \"%s\" - está corrupto o el formato incorrecto?" + +#: umain.rsthisoptionsh +msgid "This option should only be used for crucial updates or bug-fixed packages." +msgstr "Esta opción debería solo ser usada para actualizaciones cruciales o paquetes con menos bugs." + +#: umain.rsthiswilldisa +msgid "This will disable your package in Online Package Manager!%sAre you SURE you want to do this?" +msgstr "¡Esto deshabilitará tu paquete en el Administrador de Paquetes en Línea!%s¿Seguro de que quieres hacer esto?" + +#: umain.rsturnhintsoff +msgid "(You can toggle these hints on/off in the Help menu)" +msgstr "(Puedes cambiar estos consejos en el menú Ayuda)" + +#: umain.rsupdate +msgid "Update" +msgstr "Actualización" + +#: umain.rsupdatejsonsf +msgid "Update file \"%s\" failed to load correctly." +msgstr "Archivo de actualización \"%s\" falló al cargarse." + +#: umain.rsupdatezipnam +msgid "- Update zip name is too short or missing" +msgstr "- El nombre del zip es muy corto o está vacío" + +#: umain.rsupdatezipnam2 +msgid "- Update zip name missing extension \".zip\"" +msgstr "- El nombre del zip no tiene la extensión \".zip\"" + +#: umain.rsuseincombina +msgid "Use in combination with" +msgstr "Usar en combinación con" + +#: umain.rsversion +msgid "Version: " +msgstr "Versión: " + +#: umain.rsversionforpa +msgid "Version for package %d is zero" +msgstr "La versión para el paquete %d es cero" + +#: umain.rswouldyoulike +msgid "Would you like to copy %s to the %s folder?" +msgstr "¿Quieres copiar %s a la carpeta %s?" + +#: umain.rsyoumayneedto +msgid "(You may need to restart the app to see the change)" +msgstr "(Quizás necesites reiniciar la aplicación para ver los cambios)" + diff --git a/components/everettrandom/latest_stable/locale/ueverettrandom.po b/components/everettrandom/latest_stable/locale/ueverettrandom.po new file mode 100644 index 000000000..cef2c7420 --- /dev/null +++ b/components/everettrandom/latest_stable/locale/ueverettrandom.po @@ -0,0 +1,27 @@ +msgid "" +msgstr "Content-Type: text/plain; charset=UTF-8" + +#: ueverettrandom.rsfailedquantu +msgid "Failed - Quantum server refused with code %d" +msgstr "" + +#: ueverettrandom.rsfailedquantu2 +msgid "Failed - Quantum server refused with code %s" +msgstr "" + +#: ueverettrandom.rsfailedtooman +msgid "Failed - Too many requests to the Quantum server%s%s" +msgstr "" + +#: ueverettrandom.rspleasewaitco +msgid "Please wait. Contacting Quantum Server" +msgstr "" + +#: ueverettrandom.rsquantumserve +msgid "Quantum server did not deliver a valid array" +msgstr "" + +#: ueverettrandom.rsssllibraries +msgid "SSL libraries unavailable and/or unable to be downloaded on this system. Please fix." +msgstr "" + diff --git a/components/everettrandom/latest_stable/open_ssl.pas b/components/everettrandom/latest_stable/open_ssl.pas new file mode 100644 index 000000000..cd499aa1f --- /dev/null +++ b/components/everettrandom/latest_stable/open_ssl.pas @@ -0,0 +1,93 @@ +unit open_ssl; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils,everett_httpclient,LazFileUtils,FileUtil,zipper; + +function CheckForOpenSSL:Boolean; +function OpenSSLInstalled:Boolean; + +implementation +Var FHTTPClient:TFPHttpClient; + +{$ifdef win64} +const + cOpenSSLURL = 'http://packages.lazarus-ide.org/openssl-1.0.2j-x64_86-win64.zip'; + cAltOpenSSLURL = 'http://indy.fulgan.com/SSL/openssl-1.0.2j-i386-win32.zip'; +{$endif} +{$ifdef win32} +const +cOpenSSLURL = 'http://packages.lazarus-ide.org/openssl-1.0.2j-i386-win32.zip'; +cAltOpenSSLURL = 'http://indy.fulgan.com/SSL/openssl-1.0.2j-x64_86-win64.zip'; +{$endif} + + +function OpenSSLInstalled:Boolean; +begin + {$IFDEF MSWINDOWS} + Result:= FileExistsUTF8(ExtractFilePath(ParamStr(0)) + 'libeay32.dll') and + FileExistsUTF8(ExtractFilePath(ParamStr(0)) + 'ssleay32.dll'); + // Look in Windows system dir? + {$ELSE} + Result:=True; + {$ENDIF} +end; + +Function CheckForOpenSSL:Boolean; +var + ZipFile: String; + UnZipper: TUnZipper; +begin + {$IFDEF MSWINDOWS} + Result:=FALSE; + if not OpenSSLInstalled then + begin + ZipFile := ExtractFilePath(ParamStr(0)) + ExtractFileName(cOpenSSLURL); + try + FHTTPClient.Get(cOpenSSLURL, ZipFile); + If (FHTTPClient.ResponseStatusCode <> 200) then + begin + ZipFile := ExtractFilePath(ParamStr(0)) + ExtractFileName(cAltOpenSSLURL); + FHTTPClient.Get(cOpenSSLURL, ZipFile); + end; + except + // Just leave + Exit; + end; + + if FileExistsUTF8(ZipFile) then + begin + UnZipper := TUnZipper.Create; + try + try + UnZipper.FileName := ZipFile; + UnZipper.Examine; + UnZipper.UnZipAllFiles; + except + end; + finally + UnZipper.Free; + end; + DeleteFileUTF8(ZipFile); + Result:=OpenSSLInstalled; + end; + end + else + Result:=True; + {$ELSE} + Result:=True; + {$ENDIF} +end; +initialization +begin + FHTTPClient:=TFPHttpClient.Create(nil); +end; +finalization +begin + FreeAndNil(FHTTPClient); +end; +end. + diff --git a/components/everettrandom/latest_stable/readme.txt b/components/everettrandom/latest_stable/readme.txt new file mode 100644 index 000000000..34bc1da12 --- /dev/null +++ b/components/everettrandom/latest_stable/readme.txt @@ -0,0 +1,55 @@ +================================================================================ +Description and purpose +======================= +The Everett interpretation of quantum mechanics ("Many Worlds") is that when +an interaction is made with an elementary wave function (such as an electron or +photon etc) the universe bifurcates. +ref: https://en.wikipedia.org/wiki/Many-worlds_interpretation + +This happens naturally of course (just via radioactive decays in atoms of your +body there are about 5000 bifucations per second) but this component brings into +the mix "Free Will". By requesting a random number from the online source, which +is a beam-splitter based in Austrailia you are bifurcating the Universe deliberately +- that is, based on your Free Will. +You may or may not find that interesting, but nevertheless this component gives +you this ability (to "play God" with the Universe) + +The random numbers returned are truly random (i.e. not pseudorandom via algorithm) + +This package is a wrapper for querying a quantum number generator based in Austrailia. + + +Usage +===== +Open everettrandom.lpk and compile it. +In your application, include everettrandom as a required package +In a form unit: +In the Uses clause, add ueverettrandom + +Code +==== +Declare as a variable: MyEverett: TEverett; +In form Create: MyEverett := TEverett.Create(Self); +If you don't want to show a dialog whilst querying the server: MyEverett.ShowWaitDialog:=FALSE; + +There are 3 functions that will retrieve a single integer: +// Fetch a single random number +function MyEverett.GetSingle8Bit: integer; +function MyEverett.GetSingle16Bit: integer; +function MyEverett.GetSingleHex: String; + +// Array functions will put results into: +// (GetInteger8BitArray, GetInteger16BitArray) populates MyEverett.IntegerArray[0..Pred(ArraySize)] +// (GetHexArray) populates MyEverett.HexArray[0..Pred(ArraySize)] +// First set the properties: +// MyEverett.ArraySize (default=1) +//..and for Hex results +// MyEverett.HexSize (default=1) e.g. 1=00->FF 2=0000->FFFF 3=000000->FFFFFF etc. +// Result for array functions is TRUE(Success) or FALSE(failure) +function MyEverett.GetInteger8BitArray:Boolean; +function MyEverett.GetInteger16BitArray:Boolean; +function MyEverett.GetHexArray:Boolean; + +Demo +==== +The Demo app shows the usage of everettrandom \ No newline at end of file diff --git a/components/everettrandom/latest_stable/ueverettrandom.pas b/components/everettrandom/latest_stable/ueverettrandom.pas new file mode 100644 index 000000000..6caa08146 --- /dev/null +++ b/components/everettrandom/latest_stable/ueverettrandom.pas @@ -0,0 +1,411 @@ +unit ueverettrandom; + +{ Random integer generation via beam-splitter quantum event generator + + Code copyright (C)2019 minesadorada@charcodelvalle.com + + This library is free software; you can redistribute it and/or modify it + under the terms of the GNU Library General Public License as published by + the Free Software Foundation; either version 2 of the License, or (at your + option) any later version with the following modification: + + As a special exception, the copyright holders of this library give you + permission to link this library with independent modules to produce an + executable, regardless of the license terms of these independent modules,and + to copy and distribute the resulting executable under terms of your choice, + provided that you also meet, for each linked independent module, the terms + and conditions of the license of that module. An independent module is a + module which is not derived from or based on this library. If you modify + this library, you may extend this exception to your version of the library, + but you are not obligated to do so. If you do not wish to do so, delete this + exception statement from your version. + + This program is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License + for more details. + + You should have received a copy of the GNU Library General Public License + along with this library; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. + +================================================================================ +Description and purpose +======================= +The Everett interpretation of quantum mechanics ("Many Worlds") is that when +an interaction is made with an elementary wave function (such as an electron or +photon etc) the universe bifurcates. +ref: https://en.wikipedia.org/wiki/Many-worlds_interpretation + +This happens naturally of course (just via radioactive decays in atoms of your +body there are about 5000 bifucations per second) but this component brings into +the mix "Free Will". By requesting a random number from the online source, which +is a beam-splitter based in Austrailia you are bifurcating the Universe deliberately +- that is, based on your Free Will. +You may or may not find that interesting, but nevertheless this component gives +you this ability (to "play God" with the Universe) + +The random numbers returned are truly random (i.e. not pseudorandom via algorithm) +Details of the online resource below: + +================================================================================ +webpage: https://qrng.anu.edu.au/ + +To get a set of numbers generated online by a quantum number generator: +Post to: https://qrng.anu.edu.au/API/jsonI.php?length=[array length]&type=[data type]&size=[block size] +If the request is successful, the random numbers are returned in a JSON encoded array named 'data' +(Note: block size parameter is only needed for data type=hex16) +The random numbers are generated in real-time in our lab by measuring the quantum fluctuations of the vacuum + +Example to get 10 numbers of range 0-255 is +https://qrng.anu.edu.au/API/jsonI.php?length=10&type=uint8 +JSON returned: +{"type":"uint8","length":10,"data":[241,83,235,48,81,154,222,4,77,120],"success":true} + +Example to get 10 numbers of range 0–65535 is +https://qrng.anu.edu.au/API/jsonI.php?length=10&type=uint16 +JSON returned: +{"type":"uint16","length":10,"data":[50546,25450,24289,44825,10457,49509,48848,30970,33829,47807],"success":true} + +Example to get 10 hexadecimal numbers of range 00–FF is +https://qrng.anu.edu.au/API/jsonI.php?length=10&type=hex16 +JSON returned: +{"type":"string","length":10,"size":1,"data":["5d","f9","aa","bf","5e","02","3c","55","6e","9e"],"success":true} + +Example to get 10 hexadecimal numbers of range 0000–FFFF (blocksize=2) is +https://qrng.anu.edu.au/API/jsonI.php?length=10&type=hex16&size=2 +JSON returned: +{"type":"string","length":10,"size":2,"data":["2138","592e","0643","8cdf","b955","e42f","eda6","c62a","2c66","f009"],"success":true} + +Example to get 10 hexadecimal numbers of range 000000–FFFFFF (blocksize=3) is +https://qrng.anu.edu.au/API/jsonI.php?length=10&type=hex16&size=3 +JSON returned: +{"type":"string","length":10,"size":3,"data":["add825","ac3530","79b708","ee8d42","683647","b6bb25","a92571","a8ae6a","963131","f62ec2"],"success":true} + + +Javascript: +var json = eval('('+ ajaxobject.responseText +')'); /* JSON is here*/ + document.getElementById('json_success').innerHTML = json.success; + document.getElementById('dataHere').innerHTML = ajaxobject.responseText; +================================================================================ +Version History: +V0.1.2.0 - initial commit +V0.1.3.0 - cleanup +} + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Dialogs, Controls, Forms, StdCtrls, Variants, + everett_httpclient, open_ssl, fpjson, fpjsonrtti; + +const + C_QUANTUMSERVERLIMIT = 1024; + C_URL = 'https://qrng.anu.edu.au/API/jsonI.php?length=%d&type=%s&size=%d'; + +resourcestring + rsSSLLibraries = 'SSL libraries unavailable and/or unable to be downloaded ' + + 'on this system. Please fix.'; + rsFailedTooMan = 'Failed - Too many requests to the Quantum server%s%s'; + rsFailedQuantu = 'Failed - Quantum server refused with code %d'; + rsQuantumServe = 'Quantum server did not deliver a valid array'; + rsFailedQuantu2 = 'Failed - Quantum server refused with code %s'; + rsPleaseWaitCo = 'Please wait. Contacting Quantum Server'; + +type + TQuantumNumberType = (uint8, uint16, hex16); + TQuantumNumberDataObject = class; // Forward declaration + + // This is a persistent class with an owner + { TEverett } + TEverett = class(TComponent) + private + fHttpClient: TFPHTTPClient; + fQuantumNumberType: TQuantumNumberType; + fQuantumNumberDataObject: TQuantumNumberDataObject; + fShowWaitDialog: boolean; + fWaitDialogCaption: string; + fArraySize,fHexSize:Integer; + procedure SetArraySize(AValue:Integer); + protected + // Main worker function + function FetchQuantumRandomNumbers(AQuantumNumberType: TQuantumNumberType; + Alength: integer; ABlocksize: integer = 1): boolean; virtual; + // Object that contains array results + property QuantumNumberDataObject: TQuantumNumberDataObject + read fQuantumNumberDataObject; + public + // (Dynamic) Array results + IntegerArray: array of integer; + HexArray: array of string; + + // TEverett should have an owner so that cleanup is easy + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + // Fetch a single random number + function GetSingle8Bit: integer; + function GetSingle16Bit: integer; + function GetSingleHex: String; + + // Array functions will put results into: + // (uint8, uint16) IntegerArray[0..Pred(ArraySize)] + // (hex16) HexArray[0..Pred(ArraySize)] + function GetInteger8BitArray:Boolean; + function GetInteger16BitArray:Boolean; + function GetHexArray:Boolean; + published + property NumberType: TQuantumNumberType read fQuantumNumberType + write fQuantumNumberType default uint8; + property ShowWaitDialog: boolean + read fShowWaitDialog write fShowWaitDialog default True; + property WaitDialogCaption: string read fWaitDialogCaption write fWaitDialogCaption; + property ArraySize:Integer read fArraySize write SetArraySize default 1; + property HexSize:Integer read fHexSize write fHexSize default 1; + end; + + // DeStreamer.JSONToObject populates all the properties + // Do not change any of the properties + TQuantumNumberDataObject = class(TObject) + private + fNumberType: string; + fNumberLength: integer; + fNumbersize: integer; + fNumberData: variant; + fNumberSuccess: string; + public + published + // Prefix property name with & to avoid using a reserved pascal word + // Note: This bugs out the JEDI code formatter + property &type: string read fNumberType write fNumberType; + property length: integer read fNumberLength write fNumberLength; + property size: integer read fNumbersize write fNumbersize; + // Note: property "data" must be lowercase. JEDI changes it to "Data" + property data: variant read fNumberData write fNumberData; + property success: string read fNumberSuccess write fNumberSuccess; + end; + +implementation + +procedure TEverett.SetArraySize(AValue: Integer); +// Property setter +begin + if Avalue <=C_QUANTUMSERVERLIMIT then + fArraySize:=AValue + else + fArraySize:=1; +end; + +// This is the core function. +// If successful, it populates either IntegerArray or HexArray +// Parameters: +// AQuantumNumberType can be uint8, uint16 or hex16 +// ALength is the size of the returned array +// ABlocksize is only relavent if AQuantumNumberType=hex16 +// it is the size of the hex number in HexArray (1=FF, 2=FFFF, 3=FFFFFF etc) +function TEverett.FetchQuantumRandomNumbers(AQuantumNumberType: TQuantumNumberType; + Alength: integer; ABlocksize: integer): boolean; +var + szURL: string; + JSON: TJSONStringType; + DeStreamer: TJSONDeStreamer; + ct: integer; + frmWaitDlg: TForm; + lbl_WaitDialog: TLabel; +begin + Result := False; // assume failure + // Reset arrays + SetLength(IntegerArray, 0); + SetLength(HexArray, 0); + // Parameter checks + if Alength > C_QUANTUMSERVERLIMIT then + Exit; + if ABlocksize > C_QUANTUMSERVERLIMIT then + Exit; + + // Is SSL installed? If not, download it. + // If this fails then just early return FALSE; + if not CheckForOpenSSL then + begin + ShowMessage(rsSSLLibraries); + exit; + end; + + // Make up the Quantum Server URL query + case AQuantumNumberType of + uint8: + szURL := Format(C_URL, [Alength, 'uint8', ABlocksize]); + uint16: + szURL := Format(C_URL, [Alength, 'uint16', ABlocksize]); + hex16: + szURL := Format(C_URL, [Alength, 'hex16', ABlocksize]); + else + exit; + end; + try + // Create the Wait Dialog + frmWaitDlg := TForm.CreateNew(nil); + with frmWaitDlg do + begin + // Set Dialog properties + Height := 100; + Width := 200; + position := poOwnerFormCenter; + borderstyle := bsNone; + Caption := ''; + formstyle := fsSystemStayOnTop; + lbl_WaitDialog := TLabel.Create(frmWaitDlg); + with lbl_WaitDialog do + begin + align := alClient; + alignment := tacenter; + Caption := fWaitDialogCaption; + ParentFont := True; + Cursor := crHourGlass; + parent := frmWaitDlg; + end; + Autosize := True; + // Show it or not + if fShowWaitDialog then + Show; + Application.ProcessMessages; + end; + with fhttpclient do + begin + // Set up the JSON destramer + DeStreamer := TJSONDeStreamer.Create(nil); + DeStreamer.Options := [jdoIgnorePropertyErrors]; + // Set up the http client + ResponseHeaders.NameValueSeparator := ':'; + AddHeader('Accept', 'application/json;charset=UTF-8'); + //DEBUG:ShowMessage(szURL); + + // Go get the data! + JSON := Get(szURL); + // DEBUG: ShowMessageFmt('Response code = %d',[ResponseStatusCode]); + + // Any response other than 200 is bad news + if (ResponseStatusCode <> 200) then + case ResponseStatusCode of + 429: + begin + ShowMessageFmt(rsFailedTooMan, + [LineEnding, JSON]); + Exit(False); + end; + else + begin + ShowMessageFmt(rsFailedQuantu, + [ResponseStatusCode]); + Exit(False); + end; + end; + try + // Stream it to the object list + DeStreamer.JSONToObject(JSON, fQuantumNumberDataObject); + // Populate IntegerArray/Hexarray + if VarIsArray(QuantumNumberDataObject.Data) then + begin + case AQuantumNumberType of + uint8, uint16: + begin + SetLength(IntegerArray, + fQuantumNumberDataObject.fNumberLength); + for ct := 0 to Pred(fQuantumNumberDataObject.fNumberLength) do + IntegerArray[ct] := + StrToInt(fQuantumNumberDataObject.Data[ct]); + end; + hex16: + begin + SetLength(HexArray, + fQuantumNumberDataObject.fNumberLength); + for ct := 0 to Pred(fQuantumNumberDataObject.fNumberLength) do + HexArray[ct] := + fQuantumNumberDataObject.Data[ct]; + end; + end; + end + else + begin + ShowMessage(rsQuantumServe); + Exit; + end; + except + On E: Exception do + showmessagefmt(rsFailedQuantu2, [E.Message]); + On E: Exception do + Result := False; + end; + end; + finally + // No matter what - free memory + DeStreamer.Free; + frmWaitDlg.Free; + end; + Result := True; //SUCCESS! + // DEBUG ShowMessage(fQuantumNumberDataObject.fNumberSuccess); +end; + +constructor TEverett.Create(AOwner: TComponent); +begin + inherited; + fQuantumNumberType := uint8; // default is 8-bit (byte) + fShowWaitDialog := True; // Show dialog whilst fetching data online + fWaitDialogCaption := rsPleaseWaitCo; + fHttpClient := TFPHTTPClient.Create(Self); + fQuantumNumberDataObject := TQuantumNumberDataObject.Create; + fArraySize:=1; // default + fHexSize:=1; // default + SetLength(IntegerArray, 0); + SetLength(HexArray, 0); +end; + +destructor TEverett.Destroy; +begin + FreeAndNil(fQuantumNumberDataObject); + FreeAndNil(fHttpClient); + inherited; +end; + +function TEverett.GetSingle8Bit: integer; +begin + Result := 0; + if FetchQuantumRandomNumbers(uint8, 1, 1) then + Result := IntegerArray[0]; +end; + +function TEverett.GetSingle16Bit: integer; +begin + Result := 0; + if FetchQuantumRandomNumbers(uint16, 1, 1) then + Result := IntegerArray[0]; +end; + +function TEverett.GetSingleHex: String; +begin + Result:='00'; + if FetchQuantumRandomNumbers(hex16, 1, 1) then + Result := HexArray[0]; +end; + +function TEverett.GetInteger8BitArray: Boolean; +// Populates IntegerArray +begin + Result:=FetchQuantumRandomNumbers(uint8, fArraySize, 1); +end; + +function TEverett.GetInteger16BitArray: Boolean; +// Populates IntegerArray +begin + Result:=FetchQuantumRandomNumbers(uint16, fArraySize, 1); +end; + +function TEverett.GetHexArray: Boolean; +// Populates HexArray +begin + Result:=FetchQuantumRandomNumbers(hex16, fArraySize, fHexSize); +end; + +end. diff --git a/components/everettrandom/latest_stable/updates/everettrandom.zip b/components/everettrandom/latest_stable/updates/everettrandom.zip new file mode 100644 index 000000000..e69de29bb