diff --git a/components/PascalScript/Source/x86.inc b/components/PascalScript/Source/x86.inc index b5466663af..e3f21675a6 100644 --- a/components/PascalScript/Source/x86.inc +++ b/components/PascalScript/Source/x86.inc @@ -389,14 +389,9 @@ var TempStr := StringOfChar(AnsiChar(#0),4); Pointer((@TempStr[1])^) := Pointer(fvar.Dta^); {$IFDEF FPC} - {$IF FPC_FULLVERSION < 30101} - // pass dyn. array on stack - UseReg := false; - {$ELSE} // pass dyn. arrays in registers when i386 register calling conventions are used // more details -> FPC r30870 UseReg := CallingConv = cdRegister; - {$ENDIF} {$ENDIF ~FPC} {$ELSE} Exit; diff --git a/components/chmhelp/lhelp/chmspecialparser.pas b/components/chmhelp/lhelp/chmspecialparser.pas index 7a6d9bdf61..f0e200e91e 100644 --- a/components/chmhelp/lhelp/chmspecialparser.pas +++ b/components/chmhelp/lhelp/chmspecialparser.pas @@ -141,7 +141,6 @@ begin NewNode := TContentTreeNode(fTreeView.Items.Insert(ANextNode, txt)) else NewNode := TContentTreeNode(fTreeView.Items.AddChild(AParentNode, txt)); - {$IF FPC_FULLVERSION>=30200} URL:=''; for x:=0 to AItem.SubItemcount-1 do begin @@ -152,9 +151,6 @@ begin if URL<>'' then break; end; - {$ELSE} - URL:=AItem.URL; - {$ENDIF} NewNode.Url := FixURL('/'+URL); NewNode.Data := fChm; if fTreeView.Images <> nil then diff --git a/components/chmhelp/lhelp/filecontentprovider.pas b/components/chmhelp/lhelp/filecontentprovider.pas index 7d37f55b01..f297309a06 100644 --- a/components/chmhelp/lhelp/filecontentprovider.pas +++ b/components/chmhelp/lhelp/filecontentprovider.pas @@ -43,7 +43,7 @@ begin if FileContentProviders = nil Then // Singleton begin FileContentProviders := TStringList.Create; - {$IF FPC_FULLVERSION>=30200}FileContentProviders.UseLocale := false;{$ENDIF} + FileContentProviders.UseLocale := false; end; Result := FileContentProviders; end; diff --git a/components/chmhelp/packages/idehelp/chmlangref.pas b/components/chmhelp/packages/idehelp/chmlangref.pas index a1168c55b4..7dd896f010 100644 Binary files a/components/chmhelp/packages/idehelp/chmlangref.pas and b/components/chmhelp/packages/idehelp/chmlangref.pas differ diff --git a/components/codetools/finddeclarationtool.pas b/components/codetools/finddeclarationtool.pas index c34d8efe2a..5a97d12aaf 100644 --- a/components/codetools/finddeclarationtool.pas +++ b/components/codetools/finddeclarationtool.pas @@ -1566,7 +1566,7 @@ begin inherited; FResults := TStringList.Create; FResults.CaseSensitive := True; // Why CaseSensitive? - {$IF FPC_FULLVERSION>=30200}FResults.UseLocale := False;{$ENDIF} + FResults.UseLocale := False; FResults.Duplicates := dupIgnore; FResults.Sorted := True; end; diff --git a/components/codetools/tests/runtestscodetools.inc b/components/codetools/tests/runtestscodetools.inc index 0440d192ee..4b5e668211 100644 --- a/components/codetools/tests/runtestscodetools.inc +++ b/components/codetools/tests/runtestscodetools.inc @@ -1,6 +1,4 @@ {$mode objfpc}{$H+} -{$IF FPC_FULLVERSION>30100} - {$warn 6058 off} // cannot inline -{$ENDIF} +{$warn 6058 off} // cannot inline diff --git a/components/codetools/tests/runtestscodetools.lpr b/components/codetools/tests/runtestscodetools.lpr index 9714df346c..40b61bb5d2 100644 --- a/components/codetools/tests/runtestscodetools.lpr +++ b/components/codetools/tests/runtestscodetools.lpr @@ -31,8 +31,6 @@ uses TestGlobals, // non Pascal TestCfgScript, TestCTH2Pas, TestCTXMLFixFragments, - {$IF FPC_FULLVERSION >= 30101} - {$ENDIF} {$IFDEF Darwin} fdt_objccategory, fdt_objcclass, {$ENDIF} @@ -56,11 +54,7 @@ type protected Options: TCodeToolsOptions; procedure AppendLongOpts; override; - {$IF FPC_FULLVERSION>=30100} function ParseOptions: Boolean; override; - {$ELSE} - procedure ParseOptions; override; - {$ENDIF} procedure WriteCustomHelp; override; procedure ExtendXmlDocument(Doc: TXMLDocument); override; @@ -78,15 +72,9 @@ begin LongOpts.Add('filemask:'); end; -{$IF FPC_FULLVERSION>=30100} function TCTTestRunner.ParseOptions: Boolean; begin Result:=inherited ParseOptions; -{$ELSE} -procedure TCTTestRunner.ParseOptions; -begin - inherited ParseOptions; -{$ENDIF} if Options=nil then Options:=TCodeToolsOptions.Create; diff --git a/components/datadict/reglazdatadict.pp b/components/datadict/reglazdatadict.pp index e9fcf5b92b..fc132181fe 100644 --- a/components/datadict/reglazdatadict.pp +++ b/components/datadict/reglazdatadict.pp @@ -23,10 +23,8 @@ uses ,fpcgdbcoll ,fpcgCreateDBF ,fpcgtiOPF -{$IF FPC_FULLVERSION>=30101} ,fpcgfieldmap ,fpcgtypesafedataset -{$ENDIF} {$ENDIF NOSTDCODEGENS} ; diff --git a/components/fpcunit/guitestrunner.pas b/components/fpcunit/guitestrunner.pas index 38741f1b13..a6f7da94fd 100644 --- a/components/fpcunit/guitestrunner.pas +++ b/components/fpcunit/guitestrunner.pas @@ -877,12 +877,7 @@ begin Format(rsException, [AFailure.ExceptionClassName])) as TMessageTreeNode; Node.ImageIndex := imgWarningSign; Node.SelectedIndex := imgWarningSign; - {$IF FPC_FULLVERSION <= 30001} - Node := TestTree.Items.AddChild(FailureNode, - Format('at line %d in <%s>', [AFailure.LineNumber, AFailure.UnitName])) as TMessageTreeNode; - {$ELSE} Node := TestTree.Items.AddChild(FailureNode, 'at ' + AFailure.LocationInfo) as TMessageTreeNode; - {$ENDIF} Node.ImageIndex := imgWarningSign; Node.SelectedIndex := imgWarningSign; PaintNodeFailure(FailureNode); @@ -933,13 +928,7 @@ begin Node.ImageIndex := imgWarningSign; Node.SelectedIndex := imgWarningSign; // line info details - {$IF FPC_FULLVERSION <= 30001} - Node := TestTree.Items.AddChild(ErrorNode, - Format('at line %d in <%s>', [AError.LineNumber, AError.UnitName])) as TMessageTreeNode; - - {$ELSE} node := TestTree.Items.AddChild(ErrorNode, 'at ' + AError.LocationInfo); - {$ENDIF} Node.ImageIndex := imgInfoSign; Node.SelectedIndex := imgInfoSign; // TODO : add stack trace info diff --git a/components/fpdebug/fpdbghardcodedfreepascalinfo.pas b/components/fpdebug/fpdbghardcodedfreepascalinfo.pas index 993ee0292a..704b2c4898 100644 --- a/components/fpdebug/fpdbghardcodedfreepascalinfo.pas +++ b/components/fpdebug/fpdbghardcodedfreepascalinfo.pas @@ -36,19 +36,11 @@ unit FpDbgHardcodedFreepascalInfo; {$mode objfpc}{$H+} {$IFDEF INLINE_OFF}{$INLINE OFF}{$ENDIF} -{$IF FPC_FULLVERSION>30100} - {$DEFINE HasGenObjDict} -{$ENDIF} - interface uses SysUtils, - {$IFDEF HasGenObjDict} generics.collections, - {$ELSE} - AvgLvlTree, - {$ENDIF} DbgIntfBaseTypes, fpDbgSymTable, FpdMemoryTools, @@ -57,11 +49,7 @@ uses type TDbgHardcodedFPCClassMember = class; TDbgHardcodedVariableValue = class; - {$IFDEF HasGenObjDict} TDbgHardcodedFPCClassMemberCollection = specialize TObjectDictionary; - {$ELSE} - TDbgHardcodedFPCClassMemberCollection = TStringToPointerTree; - {$ENDIF} { TDbgTypeSymbol } @@ -290,11 +278,7 @@ begin FieldTypeDef := TDbgTypeSymbol.Create('longint'); try FieldDef := TDbgHardcodedFPCClassMember.Create('HelpContext', skInteger, FieldTypeDef, 0); - {$IFDEF HasGenObjDict} FFields.Add(FieldDef.Name, FieldDef); - {$ELSE} - FFields[FieldDef.Name]:=FieldDef; - {$ENDIF} finally FieldTypeDef.ReleaseReference; end; @@ -302,11 +286,7 @@ begin FieldTypeDef := TDbgHardcodedFPCAnsistringTypeSymbol.Create('string'); try FieldDef := TDbgHardcodedFPCClassMember.Create('Message', skAnsiString, FieldTypeDef, 1); - {$IFDEF HasGenObjDict} FFields.Add(FieldDef.Name, FieldDef); - {$ELSE} - FFields[FieldDef.Name]:=FieldDef; - {$ENDIF} finally FieldTypeDef.ReleaseReference; end; @@ -539,18 +519,13 @@ function TDbgHardcodedFPCClassTypeSymbol.GetFields: TDbgHardcodedFPCClassMemberC begin if not Assigned(FFields) then begin - {$IFDEF HasGenObjDict} FFields := TDbgHardcodedFPCClassMemberCollection.Create; - {$ELSE} - FFields := TStringToPointerTree.Create(true); - {$ENDIF} FillFields; end; Result := FFields; end; function TDbgHardcodedFPCClassTypeSymbol.GetNestedSymbol(AIndex: Int64): TFpSymbol; -{$IFDEF HasGenObjDict} var Member: TDbgHardcodedFPCClassMember; begin @@ -562,25 +537,11 @@ begin Break; end; end; -{$ELSE} -var - Node: PStringToPointerTreeItem; -begin - Result := nil; - for Node in FFields do - if TDbgHardcodedFPCClassMember(Node^.Value).FieldIndex=AIndex then - exit(TDbgHardcodedFPCClassMember(Node^.Value)); -end; -{$ENDIF} function TDbgHardcodedFPCClassTypeSymbol.GetNestedSymbolByName( const AIndex: string): TFpSymbol; begin - {$IFDEF HasGenObjDict} Result := GetFields.Items[AIndex] - {$ELSE} - Result := TFpSymbol(FFields[AIndex]); - {$ENDIF} end; function TDbgHardcodedFPCClassTypeSymbol.GetNestedSymbolCount: Integer; @@ -589,21 +550,11 @@ begin end; destructor TDbgHardcodedFPCClassTypeSymbol.Destroy; -{$IFDEF HasGenObjDict} var Field: TDbgHardcodedFPCClassMember; -{$ELSE} -var - Node: PStringToPointerTreeItem; -{$ENDIF} begin - {$IFDEF HasGenObjDict} for Field in FFields.Values do Field.ReleaseReference; - {$ELSE} - for Node in FFields do - TDbgHardcodedFPCClassMember(Node^.Value).ReleaseReference; - {$ENDIF} FFields.Free; inherited Destroy; end; diff --git a/components/fpreport/design/frmfpreportvariables.pp b/components/fpreport/design/frmfpreportvariables.pp index bbdc955fe7..d3b7249918 100644 --- a/components/fpreport/design/frmfpreportvariables.pp +++ b/components/fpreport/design/frmfpreportvariables.pp @@ -21,11 +21,7 @@ interface uses Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, ButtonPanel, Buttons, Spin, EditBtn, ActnList, -{$IF FPC_FULLVERSION>=30101} fpexprpars, -{$ELSE} - fprepexprpars, -{$ENDIF} fpreport, reportdesignbaseforms; type diff --git a/components/fpreport/design/reportconns.pp b/components/fpreport/design/reportconns.pp index 4e66007892..add55ceefe 100644 --- a/components/fpreport/design/reportconns.pp +++ b/components/fpreport/design/reportconns.pp @@ -8,10 +8,7 @@ unit reportconns; {$DEFINE HASMYSQL4CONNECTION} {$DEFINE HASPQCONNECTION} {$DEFINE HASSQLITE3CONNECTION} - -{$IF (FPC_FULLVERSION>=30002) or not defined(win64)} - {$DEFINE HASORACLECONNECTION} -{$ENDIF} +{$DEFINE HASORACLECONNECTION} // MS SQL Server and Sybase ASE connectors were introduced in the FPC 2.7 development branch, // and backported to 2.6.1. Operating systems should match FPC packages\fcl-db\fpmake.pp diff --git a/components/fpweb/weblazideintf.pp b/components/fpweb/weblazideintf.pp index ed1948d9fc..2def80a7b8 100644 --- a/components/fpweb/weblazideintf.pp +++ b/components/fpweb/weblazideintf.pp @@ -25,14 +25,10 @@ uses Classes, SysUtils, fpWeb, fpHTML, fpdatasetform, extjsjson, extjsxml, fpjsonrpc, jstree,jsparser, fpextdirect,fpwebdata, fpwebfile, -{$IF FPC_FULLVERSION>=30004} fphttpclient, fphttpserver, -{$ENDIF} -{$IF FPC_FULLVERSION>=30100} fpoauth2, fpoauth2ini, -{$ENDIF} webjsonrpc, Controls, Dialogs, Forms, frmnewhttpapp, @@ -258,7 +254,6 @@ begin ]); end; -{$IF FPC_FULLVERSION>=30100} procedure RegisterTFPHTTPWebClient; begin end; @@ -270,22 +265,17 @@ procedure RegisterTFPOAuth2IniStore; begin RegisterComponents(fpWebTab,[TFPOAuth2IniStore]); end; -{$ENDIF} Procedure RegisterWebComponents; begin - {$IF FPC_FULLVERSION>=30004} RegisterComponents(fpWebTab,[TFPHTTPClient,TFPHTTPServer]); - {$ENDIF} RegisterUnit('fphtml',@RegisterHTMLComponents); RegisterUnit('fpdatasetform',@RegisterdatasetComponents); - {$IF FPC_FULLVERSION>=30100} RegisterUnit('fphttpwebclient',@RegisterTFPHTTPWebClient); RegisterUnit('fpoauth2',@RegisterTOAuth2Handler); RegisterUnit('fpoauth2ini',@RegisterTFPOAuth2IniStore); //classes.RegisterComponents(fpWebTab,[TFPHTTPWebClient,TOAuth2Handler,TFPOAuth2IniStore]); - {$ENDIF} end; procedure Register; diff --git a/components/ideintf/changeparentdlg.pas b/components/ideintf/changeparentdlg.pas index 6d19deced9..cb6a21e256 100644 --- a/components/ideintf/changeparentdlg.pas +++ b/components/ideintf/changeparentdlg.pas @@ -231,7 +231,7 @@ var begin ControlsCount := 0; CurParentNameList := TStringList.Create; - {$IF FPC_FULLVERSION>=30200}CurParentNameList.UseLocale := False;{$ENDIF} + CurParentNameList.UseLocale := False; for i:=0 to ASelection.Count-1 do if ASelection.Items[i] is TControl then diff --git a/components/ideintf/componentreg.pas b/components/ideintf/componentreg.pas index a41d116f40..3885875a6b 100644 --- a/components/ideintf/componentreg.pas +++ b/components/ideintf/componentreg.pas @@ -797,12 +797,12 @@ begin fComponentCache:=TAVLTree.Create(@CompareIDEComponentByClass); fOrigComponentPageCache:=TStringList.Create; fOrigComponentPageCache.OwnsObjects:=True; - {$IF FPC_FULLVERSION>=30200}fOrigComponentPageCache.UseLocale:=False;{$ENDIF} + fOrigComponentPageCache.UseLocale:=False; fOrigComponentPageCache.CaseSensitive:=True; fOrigComponentPageCache.Sorted:=True; fUserComponentPageCache:=TStringList.Create; fUserComponentPageCache.OwnsObjects:=True; - {$IF FPC_FULLVERSION>=30200}fUserComponentPageCache.UseLocale:=False;{$ENDIF} + fUserComponentPageCache.UseLocale:=False; fUserComponentPageCache.CaseSensitive:=True; fUserComponentPageCache.Sorted:=True; fOrigPageHelper:=TStringListUTF8Fast.Create; // Note: CaseSensitive = False diff --git a/components/ideintf/dbgridcolumnspropeditform.pas b/components/ideintf/dbgridcolumnspropeditform.pas index 4855a7e935..c49aaf813d 100644 --- a/components/ideintf/dbgridcolumnspropeditform.pas +++ b/components/ideintf/dbgridcolumnspropeditform.pas @@ -5,8 +5,7 @@ unit DBGridColumnsPropEditForm; interface uses - Classes, SysUtils, TypInfo, DB, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, TypInfo, DB, System.UITypes, // LCL LCLType, Dialogs, Forms, ComCtrls, StdCtrls, ActnList, DBGrids, // LazUtils diff --git a/components/ideintf/frmselectprops.pas b/components/ideintf/frmselectprops.pas index 21811a6801..757a4cc69d 100644 --- a/components/ideintf/frmselectprops.pas +++ b/components/ideintf/frmselectprops.pas @@ -141,7 +141,7 @@ var begin //debugln('TSelectPropertiesForm.SetSelectedProps'); L:=TStringList.Create; - {$IF FPC_FULLVERSION>=30200}L.UseLocale:=False;{$ENDIF} + L.UseLocale:=False; Try L.Delimiter:=';'; L.DelimitedText:=AValue; diff --git a/components/ideintf/graphpropedits.pas b/components/ideintf/graphpropedits.pas index e1665f2b7c..04a9d648bd 100644 --- a/components/ideintf/graphpropedits.pas +++ b/components/ideintf/graphpropedits.pas @@ -16,8 +16,7 @@ unit GraphPropEdits; interface uses - Types, Classes, TypInfo, SysUtils, Math, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Types, Classes, TypInfo, SysUtils, Math, System.UITypes, // LCL LCLType, Forms, Graphics, Buttons, Menus, Dialogs, Grids, ImgList, EditBtn, // LazUtils diff --git a/components/ideintf/idedialogs.pas b/components/ideintf/idedialogs.pas index 8ea903c892..65401d0873 100644 --- a/components/ideintf/idedialogs.pas +++ b/components/ideintf/idedialogs.pas @@ -17,8 +17,7 @@ unit IDEDialogs; interface uses - Classes, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, System.UITypes, // LCL Dialogs, // LazUtils diff --git a/components/ideintf/idetextconverter.pas b/components/ideintf/idetextconverter.pas index aa6faddfd3..d0107036f1 100644 --- a/components/ideintf/idetextconverter.pas +++ b/components/ideintf/idetextconverter.pas @@ -21,8 +21,7 @@ unit IDETextConverter; interface uses - Classes, SysUtils, TypInfo, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, TypInfo, System.UITypes, // LCL LCLProc, // LazUtils diff --git a/components/ideintf/lazideintf.pas b/components/ideintf/lazideintf.pas index 8c2dca181c..3a8202346d 100644 --- a/components/ideintf/lazideintf.pas +++ b/components/ideintf/lazideintf.pas @@ -16,8 +16,7 @@ unit LazIDEIntf; interface uses - Classes, SysUtils, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, System.UITypes, // LCL Forms, Controls, LazHelpHTML, // LazUtils diff --git a/components/ideintf/propedits.pp b/components/ideintf/propedits.pp index d783055e00..2a232513bc 100644 --- a/components/ideintf/propedits.pp +++ b/components/ideintf/propedits.pp @@ -2738,7 +2738,7 @@ var begin if not AutoFill then Exit; Values:=TStringList.Create; - {$IF FPC_FULLVERSION>=30200}Values.UseLocale := False;{$ENDIF} + Values.UseLocale := False; Values.Sorted:=paSortList in GetAttributes; try AddValue := @Values.Add; @@ -8220,9 +8220,7 @@ begin RegisterPropertyEditor(TypeInfo(TTabOrder), TControl, 'TabOrder', TTabOrderPropertyEditor); RegisterPropertyEditor(TypeInfo(ShortString), nil, '', TCaptionPropertyEditor); RegisterPropertyEditor(TypeInfo(TStrings), nil, '', TStringsPropertyEditor); - {$IF FPC_FULLVERSION > 30101} RegisterPropertyEditor(TypeInfo(TFileName), nil, '', TFileNamePropertyEditor); - {$ENDIF} RegisterPropertyEditor(TypeInfo(AnsiString), nil, 'SessionProperties', TSessionPropertiesPropertyEditor); RegisterPropertyEditor(TypeInfo(TModalResult), nil, 'ModalResult', TModalResultPropertyEditor); RegisterPropertyEditor(TypeInfo(TShortCut), nil, '', TShortCutPropertyEditor); diff --git a/components/ideintf/seledits.pas b/components/ideintf/seledits.pas index 305811ace1..bc76d504a5 100644 --- a/components/ideintf/seledits.pas +++ b/components/ideintf/seledits.pas @@ -62,11 +62,7 @@ begin FPanel := APanel; FControl := AControl; FPropType := TypeInfo(Integer); -{$if FPC_FULLVERSION<30101} - FPropInfo.PropType := FPropType; -{$else} FPropInfo.PropTypeRef := @FPropType; -{$endif} FPropInfo.Name := 'ControlIndex'; SetPropEntry(0, Nil, @FPropInfo); end; diff --git a/components/ideintf/texttools.pas b/components/ideintf/texttools.pas index 86e8722a18..5f6065f7d0 100644 --- a/components/ideintf/texttools.pas +++ b/components/ideintf/texttools.pas @@ -16,8 +16,7 @@ unit TextTools; interface uses - Classes, SysUtils, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, System.UITypes, // LCL LCLType; diff --git a/components/ideintf/unitresources.pas b/components/ideintf/unitresources.pas index 7339617882..25aa7ef692 100644 --- a/components/ideintf/unitresources.pas +++ b/components/ideintf/unitresources.pas @@ -19,8 +19,7 @@ unit UnitResources; interface uses - Classes, SysUtils, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, System.UITypes, // LCL LCLMemManager, Forms, LResources; diff --git a/components/jcf2/Parse/AsmKeywords.pas b/components/jcf2/Parse/AsmKeywords.pas index cb9b824617..fbb26f8254 100644 --- a/components/jcf2/Parse/AsmKeywords.pas +++ b/components/jcf2/Parse/AsmKeywords.pas @@ -53,7 +53,7 @@ begin } mcWords := TStringList.Create(); // Will compare with CompareText. - {$IF FPC_FULLVERSION>=30200}mcWords.UseLocale := False;{$ENDIF} + mcWords.UseLocale := False; mcWords.Add('RAX'); mcWords.Add('EAX'); diff --git a/components/jcf2/Parse/PreProcessor/PreProcessorParseTree.pas b/components/jcf2/Parse/PreProcessor/PreProcessorParseTree.pas index 08abb4d95c..176ade14db 100644 --- a/components/jcf2/Parse/PreProcessor/PreProcessorParseTree.pas +++ b/components/jcf2/Parse/PreProcessor/PreProcessorParseTree.pas @@ -160,7 +160,7 @@ begin fiCurrentTokenIndex := 0; fcDefinedSymbols := TStringList.Create; // Will compare with CompareText. - {$IF FPC_FULLVERSION>=30200}fcDefinedSymbols.UseLocale := False;{$ENDIF} + fcDefinedSymbols.UseLocale := False; fcDefinedSymbols.Sorted := True; fcDefinedSymbols.Duplicates := dupIgnore; diff --git a/components/jcf2/Settings/JcfRegistrySettings.pas b/components/jcf2/Settings/JcfRegistrySettings.pas index efb2232c01..7ec8aeb573 100644 --- a/components/jcf2/Settings/JcfRegistrySettings.pas +++ b/components/jcf2/Settings/JcfRegistrySettings.pas @@ -279,9 +279,9 @@ begin fcReg := TRegIniFile.Create(REG_ROOT_KEY); fcExclusionsFiles := TStringList.Create; // Will compare with CompareText. - {$IF FPC_FULLVERSION>=30200}fcExclusionsFiles.UseLocale := False;{$ENDIF} + fcExclusionsFiles.UseLocale := False; fcExclusionsDirs := TStringList.Create; - {$IF FPC_FULLVERSION>=30200}fcExclusionsDirs.UseLocale := False;{$ENDIF} + fcExclusionsDirs.UseLocale := False; end; destructor TJCFRegistrySettings.Destroy; diff --git a/components/jcf2/Settings/SetAnyWordCaps.pas b/components/jcf2/Settings/SetAnyWordCaps.pas index af5de08640..e00430ac8d 100644 --- a/components/jcf2/Settings/SetAnyWordCaps.pas +++ b/components/jcf2/Settings/SetAnyWordCaps.pas @@ -134,7 +134,7 @@ begin SetSection('SpecificWordCaps'); fcWords := TStringList.Create; // Will compare with CompareText. - {$IF FPC_FULLVERSION>=30200}fcWords.UseLocale := False;{$ENDIF} + fcWords.UseLocale := False; fcWords.Duplicates := dupIgnore; end; diff --git a/components/jcf2/Settings/SetClarify.pas b/components/jcf2/Settings/SetClarify.pas index 993de6cc3c..d3c6aee5e4 100644 --- a/components/jcf2/Settings/SetClarify.pas +++ b/components/jcf2/Settings/SetClarify.pas @@ -89,11 +89,11 @@ begin SetSection('Clarify'); fcIgnoreUnusedParams := TStringList.Create; // Will compare with CompareText. - {$IF FPC_FULLVERSION>=30200}fcIgnoreUnusedParams.UseLocale := False;{$ENDIF} + fcIgnoreUnusedParams.UseLocale := False; fcIgnoreUnusedParams.Duplicates := dupIgnore; fcFileExtensions := TStringList.Create; - {$IF FPC_FULLVERSION>=30200}fcFileExtensions.UseLocale := False;{$ENDIF} + fcFileExtensions.UseLocale := False; fcFileExtensions.Duplicates := dupIgnore; end; diff --git a/components/jcf2/Settings/SetPreProcessor.pas b/components/jcf2/Settings/SetPreProcessor.pas index 80ad6cc8e2..5a291284bf 100644 --- a/components/jcf2/Settings/SetPreProcessor.pas +++ b/components/jcf2/Settings/SetPreProcessor.pas @@ -78,12 +78,12 @@ begin SetSection('PreProcessor'); fcDefinedSymbols := TStringList.Create; // Will compare with CompareText. - {$IF FPC_FULLVERSION>=30200}fcDefinedSymbols.UseLocale := False;{$ENDIF} + fcDefinedSymbols.UseLocale := False; //fcDefinedSymbols.Sorted := True; fcDefinedSymbols.Duplicates := dupIgnore; fcDefinedOptions := TStringList.Create; - {$IF FPC_FULLVERSION>=30200}fcDefinedOptions.UseLocale := False;{$ENDIF} + fcDefinedOptions.UseLocale := False; //fcDefinedOptions.Sorted := True; fcDefinedOptions.Duplicates := dupIgnore; end; diff --git a/components/jcf2/Settings/SetReplace.pas b/components/jcf2/Settings/SetReplace.pas index 335fd5ae86..aaa40747b0 100644 --- a/components/jcf2/Settings/SetReplace.pas +++ b/components/jcf2/Settings/SetReplace.pas @@ -85,9 +85,9 @@ begin fcWords := TStringList.Create; fcLeftWords := TStringList.Create; // Will compare with CompareText. - {$IF FPC_FULLVERSION>=30200}fcLeftWords.UseLocale := False;{$ENDIF} + fcLeftWords.UseLocale := False; fcRightWords := TStringList.Create; - {$IF FPC_FULLVERSION>=30200}fcRightWords.UseLocale := False;{$ENDIF} + fcRightWords.UseLocale := False; end; destructor TSetReplace.Destroy; diff --git a/components/jcf2/Settings/SetWordList.pas b/components/jcf2/Settings/SetWordList.pas index a45e810b4f..273affc52d 100644 --- a/components/jcf2/Settings/SetWordList.pas +++ b/components/jcf2/Settings/SetWordList.pas @@ -84,7 +84,7 @@ begin SetSection(psSectionName); fcWords := TStringList.Create; // Will compare with CompareText. - {$IF FPC_FULLVERSION>=30200}fcWords.UseLocale := False;{$ENDIF} + fcWords.UseLocale := False; fcWords.Sorted := True; fcWords.Duplicates := dupIgnore; end; diff --git a/components/jitclasses/jitclass.pas b/components/jitclasses/jitclass.pas index 202010b0a4..5e9b347fb8 100644 --- a/components/jitclasses/jitclass.pas +++ b/components/jitclasses/jitclass.pas @@ -27,9 +27,6 @@ unit JitClass; {$PointerMath on} {.$Inline off} -{$IF FPC_FULLVERSION<30100} - {$DEFINE HasVMTParent} -{$ENDIF} {$WARN 4055 off : Conversion between ordinals and pointers is not portable} interface @@ -1195,12 +1192,8 @@ begin FJitPVmt^.vIntfTable:=@EmptyIntf; // A nil pointer stops the recursion // set vmtParent - {$IFDEF HasVMTParent} - FJitPVmt^.vParent:=AncestorVMT; - {$ELSE} GetMem(FJitPVmt^.vParentRef,SizeOf(Pointer)); FJitPVmt^.vParentRef^:=AncestorVMT; - {$ENDIF} // copy the methods part System.Move(Pointer(Pointer(AncestorVMT)+vmtMethodStart)^, @@ -1323,10 +1316,8 @@ begin Freemem(AJitPVmtMem.VmtPtr^.vMethodTable); if AJitPVmtMem.VmtPtr^.vClassName <> nil then Freemem(AJitPVmtMem.VmtPtr^.vClassName); - {$IFnDEF HasVMTParent} if AJitPVmtMem.VmtPtr^.vParentRef<> nil then Freemem(AJitPVmtMem.VmtPtr^.vParentRef); - {$ENDIF} AJitPVmtMem.DeAllocate; end; @@ -1434,11 +1425,7 @@ begin end; NameIdxMap.Free; - {$IFDEF HasVMTParent} - FVmtParentMemSize := 0; - {$ELSE} FVmtParentMemSize := SizeOf(Pointer); - {$ENDIF} (* vmtTypeInfo = pointer to TTypeInfo (Kind, Name) @@ -1451,12 +1438,8 @@ begin FJitPVmt^.vTypeInfo:=NewTypeInfo; FJitPVmt^.vInstanceSize := 0; // not yet ready - {$IFDEF HasVMTParent} - VmtParentMem := FAncestorClass.ClassInfo; - {$ELSE} VmtParentMem := Pointer(NewTypeInfo) + FTypeInfoMemSize; VmtParentMem^ :=FAncestorClass.ClassInfo; - {$ENDIF} FRttiWriterClass := TJitRttiWriterTkClass.Create(NewTypeInfo, FClassName, FClassUnit, TClass(FJitPVmt), VmtParentMem, diff --git a/components/jitclasses/jitrttiwriter.pas b/components/jitclasses/jitrttiwriter.pas index a1bb2a8d67..30de9cf6a8 100644 --- a/components/jitclasses/jitrttiwriter.pas +++ b/components/jitclasses/jitrttiwriter.pas @@ -24,9 +24,6 @@ unit JitRttiWriter; {$mode objfpc}{$H+} {$ModeSwitch typehelpers} -{$IF FPC_FULLVERSION<30100} - {$DEFINE HasVMTParent} -{$ENDIF} {$WARN 4055 off : Conversion between ordinals and pointers is not portable} interface @@ -848,11 +845,7 @@ begin inherited Create(ADestMem, AClassName, tkClass); FTypeData^.ClassType := AClass; - {$IFDEF HasVMTParent} - FTypeData^.ParentInfo := AnAnchestorInfo; - {$ELSE} FTypeData^.ParentInfoRef := AnAnchestorInfo; - {$ENDIF} FTypeData^.UnitName := AUnitName; FTypeData^.PropCount := ATotalPropCount; @@ -862,14 +855,9 @@ begin FCurDestMemPos := nil; end; -procedure TJitRttiWriterTkClass.WriteAnchestorInfo(AnAnchestorInfo: TypeInfoPtr - ); +procedure TJitRttiWriterTkClass.WriteAnchestorInfo(AnAnchestorInfo: TypeInfoPtr); begin - {$IFDEF HasVMTParent} - FTypeData^.ParentInfo := AnAnchestorInfo; - {$ELSE} FTypeData^.ParentInfoRef := AnAnchestorInfo; - {$ENDIF} end; procedure TJitRttiWriterTkClass.WriteTotalPropCount(APropCount: Integer); diff --git a/components/lazdebuggergdbmi/gdbmidebugger.pp b/components/lazdebuggergdbmi/gdbmidebugger.pp index 2a4b0d02db..6290d141e0 100644 --- a/components/lazdebuggergdbmi/gdbmidebugger.pp +++ b/components/lazdebuggergdbmi/gdbmidebugger.pp @@ -8262,12 +8262,12 @@ end; constructor TGDBMILineInfo.Create(const ADebugger: TDebuggerIntf); begin FSourceIndex := TStringList.Create; - {$IF FPC_FULLVERSION>=30200}FSourceIndex.UseLocale := False;{$ENDIF} + FSourceIndex.UseLocale := False; FSourceIndex.Sorted := True; FSourceIndex.Duplicates := dupError; FSourceIndex.CaseSensitive := True; FRequestedSources := TStringList.Create; - {$IF FPC_FULLVERSION>=30200}FRequestedSources.UseLocale := False;{$ENDIF} + FRequestedSources.UseLocale := False; FRequestedSources.Sorted := True; FRequestedSources.Duplicates := dupError; FRequestedSources.CaseSensitive := True; diff --git a/components/lazreport/source/addons/lrFclPDFExport/lr_e_fclpdf.pas b/components/lazreport/source/addons/lrFclPDFExport/lr_e_fclpdf.pas index dca204e2b1..05bd3ad177 100644 --- a/components/lazreport/source/addons/lrFclPDFExport/lr_e_fclpdf.pas +++ b/components/lazreport/source/addons/lrFclPDFExport/lr_e_fclpdf.pas @@ -399,9 +399,7 @@ end; begin if gTTFontCache.Count = 0 then begin - {$IF (FPC_FULLVERSION >= 30101)} gTTFontCache.BuildFontCacheIgnoresErrors:=true; - {$ENDIF} {$IFDEF WINDOWS} CreateFontDirList; {$ELSE} @@ -781,13 +779,11 @@ end; procedure TlrPdfExportFilter.WriteURL(X, Y, W, H: TPDFFloat; AUrlText: string); begin - {$IF (FPC_FULLVERSION >= 30101)} X := ConvetUnits(X); Y := ConvetUnits(Y); W := ConvetUnits(W); H := ConvetUnits(H); FCurPage.AddExternalLink(X, Y + H, W, H, AUrlText, false); - {$ENDIF} end; procedure TlrPdfExportFilter.DrawLine(X1, Y1, X2, Y2: TPDFFloat; diff --git a/components/lazreport/source/addons/lrFclPDFExport/lrpdfexport.pas b/components/lazreport/source/addons/lrFclPDFExport/lrpdfexport.pas index 0043766bef..b4d258f0c7 100644 --- a/components/lazreport/source/addons/lrFclPDFExport/lrpdfexport.pas +++ b/components/lazreport/source/addons/lrFclPDFExport/lrpdfexport.pas @@ -32,10 +32,6 @@ Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. } -{$IF (FPC_FULLVERSION < 30002)} -!!! This component compiled only FPC 3.1.1 or hight -{$ENDIF} - unit lrPDFExport; {$mode objfpc}{$H+} diff --git a/components/lazreport/source/lr_class.pas b/components/lazreport/source/lr_class.pas index 5c63312665..b570c20b4f 100644 --- a/components/lazreport/source/lr_class.pas +++ b/components/lazreport/source/lr_class.pas @@ -2494,11 +2494,7 @@ end; constructor TlrDetailReport.Create; begin inherited Create; - {$IF FPC_FULLVERSION >= 30101} FReportBody:=TStringStream.CreateRaw(''); - {$ELSE} - FReportBody:=TStringStream.Create(''); - {$ENDIF} end; destructor TlrDetailReport.Destroy; @@ -10205,11 +10201,7 @@ procedure TfrReport.WriteReportXML(Writer: TWriter); var st: TStringStream; begin - {$IF FPC_FULLVERSION >= 30101} st := TStringStream.CreateRaw(''); - {$ELSE} - st := TStringStream.Create(''); - {$ENDIF} SaveToXMLStream(st); Writer.WriteString(st.DataString); st.free; @@ -12070,11 +12062,7 @@ begin inherited Loaded; if FXMLReport<>'' then begin - {$IF FPC_FULLVERSION >= 30101} st := TStringStream.CreateRaw(FXMLReport); - {$ELSE} - st := TStringStream.Create(FXMLReport); - {$ENDIF} LoadFromXMLStream(st); st.free; FXMLReport := ''; diff --git a/components/lazutils/translations.pas b/components/lazutils/translations.pas index 73eb9fd986..2993b933f4 100644 --- a/components/lazutils/translations.pas +++ b/components/lazutils/translations.pas @@ -56,7 +56,7 @@ interface uses Classes, SysUtils, - {$IF FPC_FULLVERSION>=30001}jsonscanner,{$ENDIF} jsonparser, fpjson, + jsonscanner, jsonparser, fpjson, // LazUtils FileUtil, LazFileUtils, LazUTF8, LConvEncoding, LazLoggerBase, AvgLvlTree, StringHashList; @@ -1392,7 +1392,7 @@ var K, L: Integer; Data: TJSONData; begin - Parser := TJSONParser.Create(InputLines.Text{$IF FPC_FULLVERSION>=30001},jsonscanner.DefaultOptions{$ENDIF}); + Parser := TJSONParser.Create(InputLines.Text,jsonscanner.DefaultOptions); try JsonData := Parser.Parse as TJSONObject; try diff --git a/components/lazutils/utf8process.pp b/components/lazutils/utf8process.pp index f6e1c59800..1969a5e325 100644 --- a/components/lazutils/utf8process.pp +++ b/components/lazutils/utf8process.pp @@ -119,11 +119,7 @@ begin mib[0] := CTL_HW; mib[1] := HW_NCPU; len := sizeof(t); - {$if FPC_FULLVERSION >= 30101} fpsysctl(@mib, 2, @t, @len, Nil, 0); - {$else} - fpsysctl(pchar(@mib), 2, @t, @len, Nil, 0); - {$endif} Result:=t; end; {$ELSEIF defined(linux)} diff --git a/components/lclextensions/oleutils.pas b/components/lclextensions/oleutils.pas index 4ec4a53b4c..40a7f509fb 100644 --- a/components/lclextensions/oleutils.pas +++ b/components/lclextensions/oleutils.pas @@ -104,11 +104,7 @@ begin //soFrom* constants are equal to STREAM_SEEK_* constants. Assume it here liOffset.LowPart:=Offset; liOffset.HighPart:=0; - {$if FPC_FULLVERSION >= 30001} Res:=FSrcStream.Seek(QWord(liOffset), Origin, QWord(liResult)); - {$else} - Res:=FSrcStream.Seek(Int64(liOffset), Origin, Int64(liResult)); - {$endif} Result:=liResult.LowPart; if Res <> S_OK then Raise Exception.Create('TOLEStream - Error while seeking: '+ErrorString(Res)); diff --git a/components/messagecomposer/messagecomposer.pas b/components/messagecomposer/messagecomposer.pas index f373c0c3b8..d84a74289f 100644 --- a/components/messagecomposer/messagecomposer.pas +++ b/components/messagecomposer/messagecomposer.pas @@ -26,8 +26,7 @@ unit MessageComposer; interface uses - Classes, SysUtils, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, System.UITypes, // LCL LResources, LCLType, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls, Spin, Grids, ActnList, Buttons, EditBtn, diff --git a/components/onlinepackagemanager/fpcmod/opkman_httpclient.pas b/components/onlinepackagemanager/fpcmod/opkman_httpclient.pas deleted file mode 100644 index e25f0c66e8..0000000000 --- a/components/onlinepackagemanager/fpcmod/opkman_httpclient.pas +++ /dev/null @@ -1,2121 +0,0 @@ -{ - 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 opkman_httpclient; - -{ --------------------------------------------------------------------- - Todo: - * Proxy support ? - ---------------------------------------------------------------------} - -{$mode objfpc}{$H+} - -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; - FKeepConnection: 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; - FTerminated: Boolean; - FUserName: String; - FOnGetSocketHandler : TGetSocketHandlerEvent; - FProxy : TProxyData; - function CheckContentLength: Int64; - function CheckTransferEncoding: string; - function GetCookies: TStrings; - function GetProxy: TProxyData; - Procedure ResetResponse; - Procedure SetCookies(const AValue: TStrings); - procedure SetHTTPVersion(const AValue: String); - procedure SetKeepConnection(AValue: Boolean); - procedure SetProxy(AValue: TProxyData); - Procedure SetRequestHeaders(const AValue: TStrings); - procedure SetIOTimeout(AValue: Integer); - Procedure ExtractHostPort(AURI: TURI; Out AHost: String; Out APort: Word); - Procedure CheckConnectionCloseHeader; - protected - - Function NoContentAllowed(ACode : Integer) : Boolean; - // Peform a request, close connection. - Procedure DoNormalRequest(const AURI: TURI; const AMethod: string; - AStream: TStream; const AAllowedResponseCodes: array of Integer; - AHeadersOnly, AIsHttps: Boolean); virtual; - // Peform a request, try to keep connection. - Procedure DoKeepConnectionRequest(const AURI: TURI; const AMethod: string; - AStream: TStream; const AAllowedResponseCodes: array of Integer; - AHeadersOnly, AIsHttps: Boolean); virtual; - // Return True if FSocket is assigned - Function IsConnected: Boolean; virtual; - // 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(out S: String): Boolean; - // 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. - Function ReadResponse(Stream: TStream; const AllowedResponseCodes: array of Integer; HeadersOnly: Boolean = False): Boolean; 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; - // Return True if the "connection: close" header is present - Function HasConnectionClose: Boolean; virtual; - // Connect to the server. Must initialize FSocket. - Procedure ConnectToServer(const AHost: String; APort: Integer; UseSSL : Boolean=False); virtual; - // Re-connect to the server. Must reinitialize FSocket. - Procedure ReconnectToServer(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; - { Terminate the current request. - It will stop the client from trying to send and/or receive data after the current chunk is sent/received. } - Procedure Terminate; - // 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); - // Has Terminate been called ? - Property Terminated : Boolean Read FTerminated; - 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. - // Setting this to any other value than 1.1 will set KeepConnection to False. - Property HTTPversion : String Read FHTTPVersion Write SetHTTPVersion; - // 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; - // Is client connected? - Property Connected: Boolean read IsConnected; - // Keep-Alive support. Setting to true will set HTTPVersion to 1.1 - Property KeepConnection: Boolean Read FKeepConnection Write SetKeepConnection; - // 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; - - end; - - - TFPHTTPClient = Class(TFPCustomHTTPClient) - Published - Property KeepConnection; - Property Connected; - 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; - 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=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+':'+Password); -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 FPC302} - if Assigned(FSocket) then - FSocket.IOTimeout:=AValue; - {$ENDIF} -end; - -function TFPCustomHTTPClient.IsConnected: Boolean; -begin - Result := Assigned(FSocket); -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 IsConnected Then - DisconnectFromServer; // avoid memory leaks - if (Aport=0) then - if UseSSL then - Aport:=443 - else - Aport:=80; - G:=GetSocketHandler(UseSSL); - FSocket:=TInetSocket.Create(AHost,APort,G); - try - {$IFDEF FPC302} - if FIOTimeout<>0 then - FSocket.IOTimeout:=FIOTimeout; - {$ENDIF} - FSocket.Connect; - except - FreeAndNil(FSocket); - Raise; - end; -end; - -Procedure TFPCustomHTTPClient.ReconnectToServer(const AHost: String; - APort: Integer; UseSSL: Boolean); -begin - DisconnectFromServer; - ConnectToServer(AHost, APort, UseSSL); -end; - -procedure TFPCustomHTTPClient.DisconnectFromServer; - -begin - FreeAndNil(FSocket); -end; - -function TFPCustomHTTPClient.AllowHeader(var AHeader: String): Boolean; - -begin - Result:=(AHeader<>'') and (Pos(':',AHeader)<>0); -end; - -Function TFPCustomHTTPClient.HasConnectionClose: Boolean; -begin - Result := CompareText(GetHeader('Connection'), 'close') = 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)); - CheckConnectionCloseHeader; - 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; - if not Terminated then - FSocket.WriteBuffer(S[1],Length(S)); - If Assigned(FRequestBody) and not Terminated then - FSocket.CopyFrom(FRequestBody,FRequestBody.Size); -end; - -function TFPCustomHTTPClient.ReadString(out S: String): Boolean; - - Function FillBuffer: Boolean; - - Var - R : Integer; - - begin - if Terminated then - Exit(False); - SetLength(FBuffer,ReadBufLen); - r:=FSocket.Read(FBuffer[1],ReadBufLen); - If (r=0) or Terminated Then - Exit(False); - If (r<0) then - Raise EHTTPClient.Create(SErrReadingSocket); - if (r0; - end; - -Var - CheckLF: Boolean; - P,L : integer; - -begin - S:=''; - Result:=False; - CheckLF:=False; - Repeat - if Length(FBuffer)=0 then - if not FillBuffer then - Break; - if Length(FBuffer)=0 then - Result:=True - else if CheckLF then - begin - If (FBuffer[1]<>#10) then - S:=S+#13 - else - begin - System.Delete(FBuffer,1,1); - Result:=True; - end; - end; - if not Result then - begin - P:=Pos(#13#10,FBuffer); - If P=0 then - begin - L:=Length(FBuffer); - CheckLF:=FBuffer[L]=#13; - if CheckLF then - S:=S+Copy(FBuffer,1,L-1) - else - S:=S+FBuffer; - FBuffer:=''; - end - else - begin - S:=S+Copy(FBuffer,1,P-1); - System.Delete(FBuffer,1,P+1); - Result:=True; - end; - end; - until Result or Terminated; -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 - 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='') or Terminated; - end; - -Const - SetCookie = 'set-cookie'; - -Var - StatusLine,S : String; - -begin - if not ReadString(StatusLine) then - Exit(0); - Result:=ParseStatusLine(StatusLine); - Repeat - if ReadString(S) and (S<>'') then - begin - ResponseHeaders.Add(S); - If (LowerCase(Copy(S,1,Length(SetCookie)))=SetCookie) then - DoCookies(S); - end - Until (S='') or Terminated; - If Assigned(FOnHeaders) and not Terminated 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'1.1') then - KeepConnection:=False; -end; - -procedure TFPCustomHTTPClient.SetKeepConnection(AValue: Boolean); -begin - if FKeepConnection=AValue then Exit; - FKeepConnection:=AValue; - if AValue then - HTTPVersion:='1.1' - else if IsConnected then - DisconnectFromServer; - CheckConnectionCloseHeader; -end; - -procedure TFPCustomHTTPClient.SetProxy(AValue: TProxyData); -begin - if (AValue=FProxy) then exit; - Proxy.Assign(AValue); -end; - -Function TFPCustomHTTPClient.ReadResponse(Stream: TStream; - const AllowedResponseCodes: array of Integer; HeadersOnly: Boolean): 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 - Result:=False; - If Terminated then - exit; - 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 - // read ChunkSize - ChunkSize:=0; - repeat - 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 Terminated; - // read till line end - while (c<>#10) and not Terminated do - if ReadData(@c,1)<1 then exit; - if ChunkSize=0 then exit; - // read data - repeat - if Terminated then - exit; - 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 Not Terminated then - begin - 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 - end; - until Terminated; - end; - -Var - L : Int64; - LB,R : Integer; - -begin - FDataRead:=0; - FContentLength:=0; - SetLength(FBuffer,0); - FResponseStatusCode:=ReadResponseHeaders; - Result := FResponseStatusCode > 0; - if not Result then - Exit; - 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 - LB:=ReadBufLen; - If (LB>L) then - LB:=L; - R:=Transfer(LB); - L:=L-R; - until (L=0) or (R=0) or Terminated; - end - else if (L<0) and (Not NoContentAllowed(ResponseStatusCode)) then - begin - // No content-length, so we read till no more data available. - Repeat - R:=Transfer(ReadBufLen); - until (R=0) or Terminated; - end; - end; -end; - -Procedure TFPCustomHTTPClient.ExtractHostPort(AURI: TURI; Out AHost: String; - Out APort: Word); -Begin - if ProxyActive then - begin - AHost:=Proxy.Host; - APort:=Proxy.Port; - end - else - begin - AHost:=AURI.Host; - APort:=AURI.Port; - end; -End; - -procedure TFPCustomHTTPClient.CheckConnectionCloseHeader; - -Var - I : integer; - N,V : String; - -begin - V:=GetHeader('Connection'); - If FKeepConnection Then - begin - I:=IndexOfHeader(FRequestHeaders,'Connection'); - If i>-1 Then - begin - // It can be keep-alive, check value - FRequestHeaders.GetNameValue(I,N,V); - If CompareText(V,'close')=0 then - FRequestHeaders.Delete(i); - end - end - Else - AddHeader('Connection', 'close'); -end; - -Procedure TFPCustomHTTPClient.DoNormalRequest(const AURI: TURI; - const AMethod: string; AStream: TStream; - const AAllowedResponseCodes: array of Integer; - AHeadersOnly, AIsHttps: Boolean); - -Var - CHost: string; - CPort: Word; - -begin - ExtractHostPort(AURI, CHost, CPort); - ConnectToServer(CHost,CPort,AIsHttps); - Try - SendRequest(AMethod,AURI); - if not Terminated then - ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly); - Finally - DisconnectFromServer; - End; -end; - -Procedure TFPCustomHTTPClient.DoKeepConnectionRequest(const AURI: TURI; - const AMethod: string; AStream: TStream; - const AAllowedResponseCodes: array of Integer; - AHeadersOnly, AIsHttps: Boolean); - -Var - T: Boolean; - CHost: string; - CPort: Word; - -begin - ExtractHostPort(AURI, CHost, CPort); - T := False; - Repeat - If Not IsConnected Then - ConnectToServer(CHost,CPort,AIsHttps); - Try - if not Terminated then - SendRequest(AMethod,AURI); - if not Terminated then - begin - T := ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly); - If Not T Then - ReconnectToServer(CHost,CPort,AIsHttps); - end; - Finally - // On terminate, we close the request - If HasConnectionClose or Terminated Then - DisconnectFromServer; - End; - Until T or Terminated; -end; - -Procedure TFPCustomHTTPClient.DoMethod(Const AMethod, AURL: String; - Stream: TStream; Const AllowedResponseCodes: Array of Integer); - -Var - URI: TURI; - P: String; - IsHttps, HeadersOnly: Boolean; - -begin - ResetResponse; - URI:=ParseURI(AURL,False); - p:=LowerCase(URI.Protocol); - If Not ((P='http') or (P='https')) then - Raise EHTTPClient.CreateFmt(SErrInvalidProtocol,[URI.Protocol]); - IsHttps:=P='https'; - HeadersOnly:=CompareText(AMethod,'HEAD')=0; - if FKeepConnection then - DoKeepConnectionRequest(URI,AMethod,Stream,AllowedResponseCodes,HeadersOnly,IsHttps) - else - DoNormalRequest(URI,AMethod,Stream,AllowedResponseCodes,HeadersOnly,IsHttps); -end; - -constructor TFPCustomHTTPClient.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - // Infinite timeout on most platforms - FIOTimeout:=0; - FRequestHeaders:=TStringList.Create; - FRequestHeaders.NameValueSeparator:=':'; - FResponseHeaders:=TStringList.Create; - FResponseHeaders.NameValueSeparator:=':'; - HTTPVersion:='1.1'; - FMaxRedirects:=DefMaxRedirects; -end; - -destructor TFPCustomHTTPClient.Destroy; -begin - if IsConnected then - DisconnectFromServer; - 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.Terminate; -begin - FTerminated:=True; -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 - // Reset Terminated - FTerminated:=False; - L:=AURL; - RC:=0; - RR:=False; - M:=AMethod; - Repeat - if Not AllowRedirect then - DoMethod(M,L,Stream,AllowedResponseCodes) - else - begin - DoMethod(M,L,Stream,AllowedResponseCodes); - if IsRedirect(FResponseStatusCode) and not Terminated 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 Terminated or 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 - KeepConnection := False; - Get(AURL,Stream); - finally - Free; - end; -end; - - -class procedure TFPCustomHTTPClient.SimpleGet(const AURL: String; - const LocalFileName: String); - -begin - With Self.Create(nil) do - try - KeepConnection := False; - Get(AURL,LocalFileName); - finally - Free; - end; -end; - - -class procedure TFPCustomHTTPClient.SimpleGet(const AURL: String; - Response: TStrings); - -begin - With Self.Create(nil) do - try - KeepConnection := False; - 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 - KeepConnection := False; - Post(URL,Response); - finally - Free; - end; -end; - - -class procedure TFPCustomHTTPClient.SimplePost(const URL: string; - Response: TStrings); - -begin - With Self.Create(nil) do - try - KeepConnection := False; - Post(URL,Response); - finally - Free; - end; -end; - - -class procedure TFPCustomHTTPClient.SimplePost(const URL: string; - const LocalFileName: String); - -begin - With Self.Create(nil) do - try - KeepConnection := False; - Post(URL,LocalFileName); - finally - Free; - end; -end; - - -class function TFPCustomHTTPClient.SimplePost(const URL: string): String; - -begin - With Self.Create(nil) do - try - KeepConnection := False; - 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 - KeepConnection := False; - Put(URL,Response); - finally - Free; - end; -end; - -class procedure TFPCustomHTTPClient.SimplePut(const URL: string; - Response: TStrings); - -begin - With Self.Create(nil) do - try - KeepConnection := False; - Put(URL,Response); - finally - Free; - end; -end; - -class procedure TFPCustomHTTPClient.SimplePut(const URL: string; - const LocalFileName: String); - -begin - With Self.Create(nil) do - try - KeepConnection := False; - Put(URL,LocalFileName); - finally - Free; - end; -end; - -class function TFPCustomHTTPClient.SimplePut(const URL: string): String; - -begin - With Self.Create(nil) do - try - KeepConnection := False; - 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 - KeepConnection := False; - Delete(URL,Response); - finally - Free; - end; -end; - -class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string; - Response: TStrings); - -begin - With Self.Create(nil) do - try - KeepConnection := False; - Delete(URL,Response); - finally - Free; - end; -end; - -class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string; - const LocalFileName: String); - -begin - With Self.Create(nil) do - try - KeepConnection := False; - Delete(URL,LocalFileName); - finally - Free; - end; -end; - -class function TFPCustomHTTPClient.SimpleDelete(const URL: string): String; - -begin - With Self.Create(nil) do - try - KeepConnection := False; - 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 - KeepConnection := False; - Options(URL,Response); - finally - Free; - end; -end; - -class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string; - Response: TStrings); - -begin - With Self.Create(nil) do - try - KeepConnection := False; - Options(URL,Response); - finally - Free; - end; -end; - -class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string; - const LocalFileName: String); - -begin - With Self.Create(nil) do - try - KeepConnection := False; - Options(URL,LocalFileName); - finally - Free; - end; -end; - -class function TFPCustomHTTPClient.SimpleOptions(const URL: string): String; - -begin - With Self.Create(nil) do - try - KeepConnection := False; - Result:=Options(URL); - finally - Free; - end; -end; - -class procedure TFPCustomHTTPClient.Head(AURL: String; Headers: TStrings); -begin - With Self.Create(nil) do - try - KeepConnection := False; - 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 - KeepConnection := False; - 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 - KeepConnection := False; - 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 - KeepConnection := False; - 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 - KeepConnection := False; - FormPost(URL,FormData,Response); - Finally - Free; - end; -end; - -class function TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string - ): String; - -begin - With Self.Create(nil) do - try - KeepConnection := False; - 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 - KeepConnection := False; - 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 - KeepConnection := False; - FileFormPost(AURL,AFieldName,AFileName,Response); - Finally - Free; - end; -end; - -end. - diff --git a/components/onlinepackagemanager/fpcmod/opkman_zip.pas b/components/onlinepackagemanager/fpcmod/opkman_zip.pas deleted file mode 100644 index 2e4cde8460..0000000000 --- a/components/onlinepackagemanager/fpcmod/opkman_zip.pas +++ /dev/null @@ -1,3071 +0,0 @@ -{ - $Id: header,v 1.3 2013/05/26 06:33:45 michael Exp $ - This file is part of the Free Component Library (FCL) - Copyright (c) 1999-2014 by the Free Pascal development team - - 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. - - **********************************************************************} -{$mode objfpc} -{$h+} -unit opkman_zip; -{$warnings off} -{$hints off} -Interface - -Uses - {$IFDEF UNIX} - BaseUnix, - {$ENDIF} - SysUtils,Classes,zstream; - - -Const - { Signatures } - END_OF_CENTRAL_DIR_SIGNATURE = $06054B50; - ZIP64_END_OF_CENTRAL_DIR_SIGNATURE = $06064B50; - ZIP64_END_OF_CENTRAL_DIR_LOCATOR_SIGNATURE = $07064B50; - LOCAL_FILE_HEADER_SIGNATURE = $04034B50; - CENTRAL_FILE_HEADER_SIGNATURE = $02014B50; - ZIP64_HEADER_ID = $0001; - // infozip unicode path - INFOZIP_UNICODE_PATH_ID = $7075; - -const - OS_FAT = 0; //MS-DOS and OS/2 (FAT/VFAT/FAT32) - OS_UNIX = 3; - OS_OS2 = 6; //OS/2 HPFS - OS_NTFS = 10; - OS_VFAT = 14; - OS_OSX = 19; - - UNIX_MASK = $F000; - UNIX_FIFO = $1000; - UNIX_CHAR = $2000; - UNIX_DIR = $4000; - UNIX_BLK = $6000; - UNIX_FILE = $8000; - UNIX_LINK = $A000; - UNIX_SOCK = $C000; - - - UNIX_RUSR = $0100; - UNIX_WUSR = $0080; - UNIX_XUSR = $0040; - - UNIX_RGRP = $0020; - UNIX_WGRP = $0010; - UNIX_XGRP = $0008; - - UNIX_ROTH = $0004; - UNIX_WOTH = $0002; - UNIX_XOTH = $0001; - - UNIX_DEFAULT = UNIX_RUSR or UNIX_WUSR or UNIX_XUSR or UNIX_RGRP or UNIX_ROTH; - -Type - Local_File_Header_Type = Packed Record //1 per zipped file - Signature : LongInt; //4 bytes - Extract_Version_Reqd : Word; //if zip64: >= 45 - Bit_Flag : Word; //"General purpose bit flag in PKZip appnote - Compress_Method : Word; - Last_Mod_Time : Word; - Last_Mod_Date : Word; - Crc32 : LongWord; - Compressed_Size : LongWord; - Uncompressed_Size : LongWord; - Filename_Length : Word; - Extra_Field_Length : Word; //refers to Extensible data field size - end; - - Extensible_Data_Field_Header_Type = Packed Record - // Beginning of extra field - // after local file header - // after central directory header - Header_ID : Word; - //e.g. $0001 (ZIP64_HEADER_ID) Zip64 extended information extra field - // $0009 OS/2: extended attributes - // $000a NTFS: (Win32 really) - // $000d UNIX: uid, gid etc - Data_Size : Word; //size of following field data - //... field data should follow... - end; - - Zip64_Extended_Info_Field_Type = Packed Record //goes after Extensible_Data_Field_Header_Type - // overrides Local and Central Directory data - // stored in extra field - Original_Size : QWord; //Uncompressed file - Compressed_Size : QWord; //Compressed data - Relative_Hdr_Offset : QWord; //Offset that leads to local header record - Disk_Start_Number : LongWord; //on which disk this file starts - end; - - { Define the Central Directory record types } - - Central_File_Header_Type = Packed Record - Signature : LongInt; //4 bytes - MadeBy_Version : Word; //if zip64: lower byte >= 45 - Extract_Version_Reqd : Word; //if zip64: >=45 - Bit_Flag : Word; //General purpose bit flag in PKZip appnote - Compress_Method : Word; - Last_Mod_Time : Word; - Last_Mod_Date : Word; - Crc32 : LongWord; - Compressed_Size : LongWord; - Uncompressed_Size : LongWord; - Filename_Length : Word; - Extra_Field_Length : Word; - File_Comment_Length : Word; - Starting_Disk_Num : Word; - Internal_Attributes : Word; - External_Attributes : LongWord; - Local_Header_Offset : LongWord; // if zip64: 0xFFFFFFFF - End; - - End_of_Central_Dir_Type = Packed Record //End of central directory record - //1 per zip file, near end, before comment - Signature : LongInt; //4 bytes - Disk_Number : Word; - Central_Dir_Start_Disk : Word; - Entries_This_Disk : Word; - Total_Entries : Word; - Central_Dir_Size : LongWord; - Start_Disk_Offset : LongWord; - ZipFile_Comment_Length : Word; - end; - - Zip64_End_of_Central_Dir_type = Packed Record - Signature : LongInt; - Record_Size : QWord; - Version_Made_By : Word; //lower byte >= 45 - Extract_Version_Reqd : Word; //version >= 45 - Disk_Number : LongWord; - Central_Dir_Start_Disk : LongWord; - Entries_This_Disk : QWord; - Total_Entries : QWord; - Central_Dir_Size : QWord; - Start_Disk_Offset : QWord; - end; - - Zip64_End_of_Central_Dir_Locator_type = Packed Record //comes after Zip64_End_of_Central_Dir_type - Signature : LongInt; - Zip64_EOCD_Start_Disk : LongWord; //Starting disk for Zip64 End of Central Directory record - Central_Dir_Zip64_EOCD_Offset : QWord; //offset of Zip64 End of Central Directory record - Total_Disks : LongWord; //total number of disks (contained in zip) - end; - -Const - Crc_32_Tab : Array[0..255] of LongWord = ( - $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f, $e963a535, $9e6495a3, - $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91, - $1db71064, $6ab020f2, $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7, - $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, $fa0f3d63, $8d080df5, - $3b6e20c8, $4c69105e, $d56041e4, $a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, - $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59, - $26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f, - $2802b89e, $5f058808, $c60cd9b2, $b10be924, $2f6f7c87, $58684c11, $c1611dab, $b6662d3d, - $76dc4190, $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433, - $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01, - $6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457, - $65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65, - $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb, - $4369e96a, $346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9, - $5005713c, $270241aa, $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f, - $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad, - $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615, $73dc1683, - $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1, - $f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb, $196c3671, $6e6b06e7, - $fed41b76, $89d32be0, $10da7a5a, $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, - $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b, - $d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, $4669be79, - $cb61b38c, $bc66831a, $256fd2a0, $5268e236, $cc0c7795, $bb0b4703, $220216b9, $5505262f, - $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d, - $9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713, - $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21, - $86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777, - $88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69, $616bffd3, $166ccf45, - $a00ae278, $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, $4969474d, $3e6e77db, - $aed16a4a, $d9d65adc, $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9, - $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693, $54de5729, $23d967bf, - $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d - ); - -Type - - TProgressEvent = Procedure(Sender : TObject; Const Pct : Double) of object; - TProgressEventEx = Procedure(Sender : TObject; Const ATotPos, ATotSize: Int64) of object; - TOnEndOfFileEvent = Procedure(Sender : TObject; Const Ratio : Double) of object; - TOnStartFileEvent = Procedure(Sender : TObject; Const AFileName : String) of object; - -Type - - { TCompressor } - TCompressor = Class(TObject) - private - FTerminated: Boolean; - Protected - FInFile : TStream; { I/O file variables } - FOutFile : TStream; - FCrc32Val : LongWord; { CRC calculation variable } - FBufferSize : LongWord; - FOnPercent : Integer; - FOnProgress : TProgressEvent; - Procedure UpdC32(Octet: Byte); - Public - Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord); virtual; - Procedure Compress; Virtual; Abstract; - Class Function ZipID : Word; virtual; Abstract; - Class Function ZipVersionReqd: Word; virtual; Abstract; - Function ZipBitFlag: Word; virtual; Abstract; - Procedure Terminate; - Property BufferSize : LongWord read FBufferSize; - Property OnPercent : Integer Read FOnPercent Write FOnPercent; - Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress; - Property Crc32Val : LongWord Read FCrc32Val Write FCrc32Val; - Property Terminated : Boolean Read FTerminated; - end; - - { TDeCompressor } - TDeCompressor = Class(TObject) - Protected - FInFile : TStream; { I/O file variables } - FOutFile : TStream; - FCrc32Val : LongWord; { CRC calculation variable } - FBufferSize : LongWord; - FOnPercent : Integer; - FOnProgress : TProgressEvent; - FOnProgressEx: TProgressEventEx; - FTotPos : Int64; - FTotSize : Int64; - FTerminated : Boolean; - Procedure UpdC32(Octet: Byte); - Public - Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord); virtual; - Procedure DeCompress; Virtual; Abstract; - Procedure Terminate; - Class Function ZipID : Word; virtual; Abstract; - Property BufferSize : LongWord read FBufferSize; - Property OnPercent : Integer Read FOnPercent Write FOnPercent; - Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress; - Property OnProgressEx : TProgressEventEx Read FOnProgressEx Write FOnProgressEx; - Property Crc32Val : LongWord Read FCrc32Val Write FCrc32Val; - Property Terminated : Boolean Read FTerminated; - end; - - { TShrinker } - -Const - TABLESIZE = 8191; - FIRSTENTRY = 257; - -Type - CodeRec = Packed Record - Child : Smallint; - Sibling : Smallint; - Suffix : Byte; - end; - CodeArray = Array[0..TABLESIZE] of CodeRec; - TablePtr = ^CodeArray; - - FreeListPtr = ^FreeListArray; - FreeListArray = Array[FIRSTENTRY..TABLESIZE] of Word; - - BufPtr = PByte; - - TShrinker = Class(TCompressor) - Private - FBufSize : LongWord; - MaxInBufIdx : LongWord; { Count of valid chars in input buffer } - InputEof : Boolean; { End of file indicator } - CodeTable : TablePtr; { Points to code table for LZW compression } - FreeList : FreeListPtr; { Table of free code table entries } - NextFree : Word; { Index into free list table } - - ClearList : Array[0..1023] of Byte; { Bit mapped structure used in } - { during adaptive resets } - CodeSize : Byte; { Size of codes (in bits) currently being written } - MaxCode : Word; { Largest code that can be written in CodeSize bits } - InBufIdx, { Points to next char in buffer to be read } - OutBufIdx : LongWord; { Points to next free space in output buffer } - InBuf, { I/O buffers } - OutBuf : BufPtr; - FirstCh : Boolean; { Flag indicating the START of a shrink operation } - TableFull : Boolean; { Flag indicating a full symbol table } - SaveByte : Byte; { Output code buffer } - BitsUsed : Byte; { Index into output code buffer } - BytesIn : LongWord; { Count of input file bytes processed } - BytesOut : LongWord; { Count of output bytes } - FOnBytes : LongWord; - Procedure FillInputBuffer; - Procedure WriteOutputBuffer; - Procedure FlushOutput; - Procedure PutChar(B : Byte); - procedure PutCode(Code : Smallint); - Procedure InitializeCodeTable; - Procedure Prune(Parent : Word); - Procedure Clear_Table; - Procedure Table_Add(Prefix : Word; Suffix : Byte); - function Table_Lookup(TargetPrefix : Smallint; - TargetSuffix : Byte; - Out FoundAt : Smallint) : Boolean; - Procedure Shrink(Suffix : Smallint); - Procedure ProcessLine(Const Source : String); - Procedure DoOnProgress(Const Pct : Double); Virtual; - Public - Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord); override; - Destructor Destroy; override; - Procedure Compress; override; - Class Function ZipID : Word; override; - Class Function ZipVersionReqd : Word; override; - Function ZipBitFlag : Word; override; - end; - - { TDeflater } - - TDeflater = Class(TCompressor) - private - FCompressionLevel: TCompressionlevel; - Public - Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord);override; - Procedure Compress; override; - Class Function ZipID : Word; override; - Class Function ZipVersionReqd : Word; override; - Function ZipBitFlag : Word; override; - Property CompressionLevel : TCompressionlevel Read FCompressionLevel Write FCompressionLevel; - end; - - { TInflater } - - TInflater = Class(TDeCompressor) - Public - Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord);override; - Procedure DeCompress; override; - Class Function ZipID : Word; override; - end; - - { TZipFileEntry } - - TZipFileEntry = Class(TCollectionItem) - private - FArchiveFileName: String; //Name of the file as it appears in the zip file list - FUTF8FileName : UTF8String; - FUTF8DiskFileName : UTF8String; - FAttributes: LongWord; - FDateTime: TDateTime; - FDiskFileName: String; {Name of the file on disk (i.e. uncompressed. Can be empty if based on a stream.); - uses local OS/filesystem directory separators} - FHeaderPos: int64; - FNeedsZip64: Boolean; //flags whether filesize is big enough so we need a zip64 entry - FOS: Byte; - FSize: Int64; - FStream: TStream; - FCompressionLevel: TCompressionlevel; - function GetArchiveFileName: String; - function GetUTF8ArchiveFileName: UTF8String; - function GetUTF8DiskFileName: UTF8String; - procedure SetArchiveFileName(Const AValue: String); - procedure SetDiskFileName(Const AValue: String); - procedure SetUTF8ArchiveFileName(AValue: UTF8String); - procedure SetUTF8DiskFileName(AValue: UTF8String); - Protected - // For multi-disk support, a disk number property could be added here. - Property HdrPos : int64 Read FHeaderPos Write FheaderPos; - Property NeedsZip64 : boolean Read FNeedsZip64 Write FNeedsZip64; - Public - constructor Create(ACollection: TCollection); override; - function IsDirectory: Boolean; - function IsLink: Boolean; - Procedure Assign(Source : TPersistent); override; - Property Stream : TStream Read FStream Write FStream; - Published - Property ArchiveFileName : String Read GetArchiveFileName Write SetArchiveFileName; - Property UTF8ArchiveFileName : UTF8String Read GetUTF8ArchiveFileName Write SetUTF8ArchiveFileName; - Property DiskFileName : String Read FDiskFileName Write SetDiskFileName; - Property UTF8DiskFileName : UTF8String Read GetUTF8DiskFileName Write SetUTF8DiskFileName; - Property Size : Int64 Read FSize Write FSize; - Property DateTime : TDateTime Read FDateTime Write FDateTime; - property OS: Byte read FOS write FOS; - property Attributes: LongWord read FAttributes write FAttributes; - Property CompressionLevel: TCompressionlevel read FCompressionLevel write FCompressionLevel; - end; - - { TZipFileEntries } - - TZipFileEntries = Class(TCollection) - private - function GetZ(AIndex : Integer): TZipFileEntry; - procedure SetZ(AIndex : Integer; const AValue: TZipFileEntry); - Public - Function AddFileEntry(Const ADiskFileName : String): TZipFileEntry; - Function AddFileEntry(Const ADiskFileName, AArchiveFileName : String): TZipFileEntry; - Function AddFileEntry(Const AStream : TSTream; Const AArchiveFileName : String): TZipFileEntry; - Procedure AddFileEntries(Const List : TStrings); - Property Entries[AIndex : Integer] : TZipFileEntry Read GetZ Write SetZ; default; - end; - - { TZipper } - - TZipper = Class(TObject) - Private - FEntries : TZipFileEntries; - FTerminated: Boolean; - FZipping : Boolean; - FBufSize : LongWord; - FFileName : RawByteString; { Name of resulting Zip file } - FFileComment : String; - FFiles : TStrings; - FInMemSize : Int64; - FZipFileNeedsZip64 : Boolean; //flags whether at least one file is big enough to require a zip64 record - FOutStream : TStream; - FInFile : TStream; { I/O file variables } - LocalHdr : Local_File_Header_Type; - LocalZip64ExtHdr: Extensible_Data_Field_Header_Type; //Extra field header fixed to zip64 (i.e. .ID=1) - LocalZip64Fld : Zip64_Extended_Info_Field_Type; //header is in LocalZip64ExtHdr - CentralHdr : Central_File_Header_Type; - EndHdr : End_of_Central_Dir_Type; - FOnPercent : LongInt; - FOnProgress : TProgressEvent; - FOnEndOfFile : TOnEndOfFileEvent; - FOnStartFile : TOnStartFileEvent; - FCurrentCompressor : TCompressor; - function CheckEntries: Integer; - procedure SetEntries(const AValue: TZipFileEntries); - Protected - Procedure CloseInput(Item : TZipFileEntry); - Procedure StartZipFile(Item : TZipFileEntry); - Function UpdateZipHeader(Item : TZipFileEntry; FZip : TStream; ACRC : LongWord;AMethod : Word; AZipVersionReqd : Word; AZipBitFlag : Word) : Boolean; - Procedure BuildZipDirectory; //Builds central directory based on local headers - Procedure DoEndOfFile; - Procedure ZipOneFile(Item : TZipFileEntry); virtual; - Function OpenInput(Item : TZipFileEntry) : Boolean; - Procedure GetFileInfo; - Procedure SetBufSize(Value : LongWord); - Procedure SetFileName(Value : RawByteString); - Function CreateCompressor(Item : TZipFileEntry; AinFile,AZipStream : TStream) : TCompressor; virtual; - Property NeedsZip64 : boolean Read FZipFileNeedsZip64 Write FZipFileNeedsZip64; - Public - Constructor Create; - Destructor Destroy;override; - Procedure ZipAllFiles; virtual; - // Saves zip to file and changes FileName - Procedure SaveToFile(AFileName: RawByteString); - // Saves zip to stream - Procedure SaveToStream(AStream: TStream); - // Zips specified files into a zip with name AFileName - Procedure ZipFiles(AFileName : RawByteString; FileList : TStrings); - Procedure ZipFiles(FileList : TStrings); - // Zips specified entries into a zip with name AFileName - Procedure ZipFiles(AFileName : RawByteString; Entries : TZipFileEntries); - Procedure ZipFiles(Entries : TZipFileEntries); - Procedure Clear; - Procedure Terminate; - Public - Property BufferSize : LongWord Read FBufSize Write SetBufSize; - Property OnPercent : Integer Read FOnPercent Write FOnPercent; - Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress; - Property OnStartFile : TOnStartFileEvent Read FOnStartFile Write FOnStartFile; - Property OnEndFile : TOnEndOfFileEvent Read FOnEndOfFile Write FOnEndOfFile; - Property FileName : RawByteString Read FFileName Write SetFileName; - Property FileComment: String Read FFileComment Write FFileComment; - // Deprecated. Use Entries.AddFileEntry(FileName) or Entries.AddFileEntries(List) instead. - Property Files : TStrings Read FFiles; deprecated; - Property InMemSize : Int64 Read FInMemSize Write FInMemSize; - Property Entries : TZipFileEntries Read FEntries Write SetEntries; - Property Terminated : Boolean Read FTerminated; - end; - - { TFullZipFileEntry } - - TFullZipFileEntry = Class(TZipFileEntry) - private - FBitFlags: Word; - FCompressedSize: QWord; - FCompressMethod: Word; - FCRC32: LongWord; - Public - Property BitFlags : Word Read FBitFlags; - Property CompressMethod : Word Read FCompressMethod; - Property CompressedSize : QWord Read FCompressedSize; - property CRC32: LongWord read FCRC32 write FCRC32; - end; - - TOnCustomStreamEvent = Procedure(Sender : TObject; var AStream : TStream; AItem : TFullZipFileEntry) of object; - TCustomInputStreamEvent = Procedure(Sender: TObject; var AStream: TStream) of object; - - { TFullZipFileEntries } - - TFullZipFileEntries = Class(TZipFileEntries) - private - function GetFZ(AIndex : Integer): TFullZipFileEntry; - procedure SetFZ(AIndex : Integer; const AValue: TFullZipFileEntry); - Public - Property FullEntries[AIndex : Integer] : TFullZipFileEntry Read GetFZ Write SetFZ; default; - end; - - { TUnZipper } - - TUnZipper = Class(TObject) - Private - FOnCloseInputStream: TCustomInputStreamEvent; - FOnCreateStream: TOnCustomStreamEvent; - FOnDoneStream: TOnCustomStreamEvent; - FOnOpenInputStream: TCustomInputStreamEvent; - FUnZipping : Boolean; - FBufSize : LongWord; - FFileName : RawByteString; { Name of resulting Zip file } - FOutputPath : RawByteString; - FFileComment: String; - FEntries : TFullZipFileEntries; - FFiles : TStrings; - FUseUTF8: Boolean; - FZipStream : TStream; { I/O file variables } - LocalHdr : Local_File_Header_Type; //Local header, before compressed file data - LocalZip64Fld : Zip64_Extended_Info_Field_Type; //header is in LocalZip64ExtHdr - CentralHdr : Central_File_Header_Type; - FTotPos : Int64; - FTotSize : Int64; - FTerminated: Boolean; - FOnPercent : LongInt; - FOnProgress : TProgressEvent; - FOnProgressEx : TProgressEventEx; - FOnEndOfFile : TOnEndOfFileEvent; - FOnStartFile : TOnStartFileEvent; - FCurrentDecompressor: TDecompressor; - function CalcTotalSize(AllFiles: Boolean): Int64; - function IsMatch(I: TFullZipFileEntry): Boolean; - Protected - Procedure OpenInput; - Procedure CloseOutput(Item : TFullZipFileEntry; var OutStream: TStream); - Procedure CloseInput; - Procedure FindEndHeaders( - out AEndHdr: End_of_Central_Dir_Type; - out AEndHdrPos: Int64; - out AEndZip64Hdr: Zip64_End_of_Central_Dir_type; - out AEndZip64HdrPos: Int64); - Procedure ReadZipDirectory; - Procedure ReadZipHeader(Item : TFullZipFileEntry; out AMethod : Word); - Procedure DoEndOfFile; - Procedure UnZipOneFile(Item : TFullZipFileEntry); virtual; - Function OpenOutput(OutFileName : RawByteString; Out OutStream: TStream; Item : TFullZipFileEntry) : Boolean; - Procedure SetBufSize(Value : LongWord); - Procedure SetFileName(Value : RawByteString); - Procedure SetOutputPath(Value: RawByteString); - Function CreateDeCompressor(Item : TZipFileEntry; AMethod : Word;AZipFile,AOutFile : TStream) : TDeCompressor; virtual; - Public - Constructor Create; - Destructor Destroy;override; - Procedure UnZipAllFiles; virtual; - Procedure UnZipFiles(AFileName : RawByteString; FileList : TStrings); - Procedure UnZipFiles(FileList : TStrings); - Procedure UnZipAllFiles(AFileName : RawByteString); - Procedure Clear; - Procedure Examine; - Procedure Terminate; - Public - Property BufferSize : LongWord Read FBufSize Write SetBufSize; - Property OnOpenInputStream: TCustomInputStreamEvent read FOnOpenInputStream write FOnOpenInputStream; - Property OnCloseInputStream: TCustomInputStreamEvent read FOnCloseInputStream write FOnCloseInputStream; - Property OnCreateStream : TOnCustomStreamEvent Read FOnCreateStream Write FOnCreateStream; - Property OnDoneStream : TOnCustomStreamEvent Read FOnDoneStream Write FOnDoneStream; - Property OnPercent : Integer Read FOnPercent Write FOnPercent; - Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress; - Property OnProgressEx : TProgressEventEx Read FOnProgressEx Write FOnProgressEx; - Property OnStartFile : TOnStartFileEvent Read FOnStartFile Write FOnStartFile; - Property OnEndFile : TOnEndOfFileEvent Read FOnEndOfFile Write FOnEndOfFile; - Property FileName : RawByteString Read FFileName Write SetFileName; - Property OutputPath : RawByteString Read FOutputPath Write SetOutputPath; - Property FileComment: String Read FFileComment; - Property Files : TStrings Read FFiles; - Property Entries : TFullZipFileEntries Read FEntries; - Property UseUTF8 : Boolean Read FUseUTF8 Write FUseUTF8; - Property Terminated : Boolean Read FTerminated; - end; - - EZipError = Class(Exception); - -Implementation - -uses rtlconsts; - -ResourceString - SErrBufsizeChange = 'Changing buffer size is not allowed while (un)zipping.'; - SErrFileChange = 'Changing output file name is not allowed while (un)zipping.'; - SErrInvalidCRC = 'Invalid CRC checksum while unzipping %s.'; - SErrCorruptZIP = 'Corrupt ZIP file %s.'; - SErrUnsupportedCompressionFormat = 'Unsupported compression format %d.'; - SErrUnsupportedMultipleDisksCD = 'A central directory split over multiple disks is unsupported.'; - SErrMaxEntries = 'Encountered %d file entries; maximum supported is %d.'; - SErrMissingFileName = 'Missing filename in entry %d.'; - SErrMissingArchiveName = 'Missing archive filename in streamed entry %d.'; - SErrFileDoesNotExist = 'File "%s" does not exist.'; - SErrPosTooLarge = 'Position/offset %d is larger than maximum supported %d.'; - SErrNoFileName = 'No archive filename for examine operation.'; - SErrNoStream = 'No stream is opened.'; - SErrEncryptionNotSupported = 'Cannot unzip item "%s": encryption is not supported.'; - SErrPatchSetNotSupported = 'Cannot unzip item "%s": patch sets are not supported.'; - -{ --------------------------------------------------------------------- - Auxiliary - ---------------------------------------------------------------------} -Type - // A local version of TFileStream which uses rawbytestring. It - TFileStream = class(THandleStream) - Private - FFileName : RawBytestring; - public - constructor Create(const AFileName: RawBytestring; Mode: Word); - constructor Create(const AFileName: RawBytestring; Mode: Word; Rights: Cardinal); - destructor Destroy; override; - property FileName : RawBytestring Read FFilename; - end; - constructor TFileStream.Create(const AFileName: rawbytestring; Mode: Word); - - begin - Create(AFileName,Mode,438); - end; - - - constructor TFileStream.Create(const AFileName: rawbytestring; Mode: Word; Rights: Cardinal); - - Var - H : Thandle; - - begin - FFileName:=AFileName; - If (Mode and fmCreate) > 0 then - H:=FileCreate(AFileName,Mode,Rights) - else - H:=FileOpen(AFileName,Mode); - - If (H=feInvalidHandle) then - If Mode=fmcreate then - raise EFCreateError.createfmt(SFCreateError,[AFileName]) - else - raise EFOpenError.Createfmt(SFOpenError,[AFilename]); - Inherited Create(H); - end; - - - destructor TFileStream.Destroy; - - begin - FileClose(Handle); - end; - -{$IFDEF FPC_BIG_ENDIAN} -function SwapLFH(const Values: Local_File_Header_Type): Local_File_Header_Type; -begin - with Values do - begin - Result.Signature := SwapEndian(Signature); - Result.Extract_Version_Reqd := SwapEndian(Extract_Version_Reqd); - Result.Bit_Flag := SwapEndian(Bit_Flag); - Result.Compress_Method := SwapEndian(Compress_Method); - Result.Last_Mod_Time := SwapEndian(Last_Mod_Time); - Result.Last_Mod_Date := SwapEndian(Last_Mod_Date); - Result.Crc32 := SwapEndian(Crc32); - Result.Compressed_Size := SwapEndian(Compressed_Size); - Result.Uncompressed_Size := SwapEndian(Uncompressed_Size); - Result.Filename_Length := SwapEndian(Filename_Length); - Result.Extra_Field_Length := SwapEndian(Extra_Field_Length); - end; -end; - -function SwapEDFH(const Values: Extensible_Data_Field_Header_Type): Extensible_Data_Field_Header_Type; -begin - with Values do - begin - Result.Header_ID := SwapEndian(Header_ID); - Result.Data_Size := SwapEndian(Data_Size); - end; -end; - -function SwapZ64EIF(const Values: Zip64_Extended_Info_Field_Type): Zip64_Extended_Info_Field_Type; -begin - with Values do - begin - Result.Original_Size := SwapEndian(Original_Size); - Result.Compressed_Size := SwapEndian(Compressed_Size); - Result.Relative_Hdr_Offset := SwapEndian(Relative_Hdr_Offset); - Result.Disk_Start_Number := SwapEndian(Disk_Start_Number); - end; -end; - -function SwapCFH(const Values: Central_File_Header_Type): Central_File_Header_Type; -begin - with Values do - begin - Result.Signature := SwapEndian(Signature); - Result.MadeBy_Version := SwapEndian(MadeBy_Version); - Result.Extract_Version_Reqd := SwapEndian(Extract_Version_Reqd); - Result.Bit_Flag := SwapEndian(Bit_Flag); - Result.Compress_Method := SwapEndian(Compress_Method); - Result.Last_Mod_Time := SwapEndian(Last_Mod_Time); - Result.Last_Mod_Date := SwapEndian(Last_Mod_Date); - Result.Crc32 := SwapEndian(Crc32); - Result.Compressed_Size := SwapEndian(Compressed_Size); - Result.Uncompressed_Size := SwapEndian(Uncompressed_Size); - Result.Filename_Length := SwapEndian(Filename_Length); - Result.Extra_Field_Length := SwapEndian(Extra_Field_Length); - Result.File_Comment_Length := SwapEndian(File_Comment_Length); - Result.Starting_Disk_Num := SwapEndian(Starting_Disk_Num); - Result.Internal_Attributes := SwapEndian(Internal_Attributes); - Result.External_Attributes := SwapEndian(External_Attributes); - Result.Local_Header_Offset := SwapEndian(Local_Header_Offset); - end; -end; - -function SwapECD(const Values: End_of_Central_Dir_Type): End_of_Central_Dir_Type; -begin - with Values do - begin - Result.Signature := SwapEndian(Signature); - Result.Disk_Number := SwapEndian(Disk_Number); - Result.Central_Dir_Start_Disk := SwapEndian(Central_Dir_Start_Disk); - Result.Entries_This_Disk := SwapEndian(Entries_This_Disk); - Result.Total_Entries := SwapEndian(Total_Entries); - Result.Central_Dir_Size := SwapEndian(Central_Dir_Size); - Result.Start_Disk_Offset := SwapEndian(Start_Disk_Offset); - Result.ZipFile_Comment_Length := SwapEndian(ZipFile_Comment_Length); - end; -end; - -function SwapZ64ECD(const Values: Zip64_End_of_Central_Dir_Type): Zip64_End_of_Central_Dir_Type; -begin - with Values do - begin - Result.Signature := SwapEndian(Signature); - Result.Record_Size := SwapEndian(Record_Size); - Result.Version_Made_By := SwapEndian(Version_Made_By); - Result.Extract_Version_Reqd := SwapEndian(Extract_Version_Reqd); - Result.Disk_Number := SwapEndian(Disk_Number); - Result.Central_Dir_Start_Disk := SwapEndian(Central_Dir_Start_Disk); - Result.Entries_This_Disk := SwapEndian(Entries_This_Disk); - Result.Total_Entries := SwapEndian(Total_Entries); - Result.Central_Dir_Size := SwapEndian(Central_Dir_Size); - Result.Start_Disk_Offset := SwapEndian(Start_Disk_Offset); - end; -end; - -function SwapZ64ECDL(const Values: Zip64_End_of_Central_Dir_Locator_type): Zip64_End_of_Central_Dir_Locator_type; -begin - with Values do - begin - Result.Signature := SwapEndian(Signature); - Result.Zip64_EOCD_Start_Disk := SwapEndian(Zip64_EOCD_Start_Disk); - Result.Central_Dir_Zip64_EOCD_Offset := SwapEndian(Central_Dir_Zip64_EOCD_Offset); - Result.Total_Disks := SwapEndian(Total_Disks); - end; -end; -{$ENDIF FPC_BIG_ENDIAN} - -Procedure DateTimeToZipDateTime(DT : TDateTime; out ZD,ZT : Word); - -Var - Y,M,D,H,N,S,MS : Word; - -begin - DecodeDate(DT,Y,M,D); - DecodeTime(DT,H,N,S,MS); - if Y<1980 then - begin - // Invalid date/time; set to earliest possible - Y:=0; - M:=1; - D:=1; - H:=0; - N:=0; - S:=0; - MS:=0; - end - else - begin - Y:=Y-1980; - end; - ZD:=d+(32*M)+(512*Y); - ZT:=(S div 2)+(32*N)+(2048*h); -end; - -Procedure ZipDateTimeToDateTime(ZD,ZT : Word;out DT : TDateTime); - -Var - Y,M,D,H,N,S,MS : Word; - -begin - MS:=0; - S:=(ZT and 31) shl 1; - N:=(ZT shr 5) and 63; - H:=ZT shr 11; - D:=ZD and 31; - M:=(ZD shr 5) and 15; - Y:=((ZD shr 9) and 127)+1980; - - if M < 1 then M := 1; - if D < 1 then D := 1; - DT:=ComposeDateTime(EncodeDate(Y,M,D),EncodeTime(H,N,S,MS)); -end; - - - -function ZipUnixAttrsToFatAttrs(const Name: String; Attrs: Longint): Longint; -begin - Result := faArchive; - - if (Pos('.', Name) = 1) and (Name <> '.') and (Name <> '..') then - Result := Result + faHidden; - case (Attrs and UNIX_MASK) of - UNIX_DIR: Result := Result + faDirectory; - UNIX_LINK: Result := Result + faSymLink; - UNIX_FIFO, UNIX_CHAR, UNIX_BLK, UNIX_SOCK: - Result := Result + faSysFile; - end; - - if (Attrs and UNIX_WUSR) = 0 then - Result := Result + faReadOnly; -end; - -function ZipFatAttrsToUnixAttrs(Attrs: Longint): Longint; -begin - Result := UNIX_DEFAULT; - if (faReadOnly and Attrs) > 0 then - Result := Result and not (UNIX_WUSR); - - if (faSymLink and Attrs) > 0 then - Result := Result or UNIX_LINK - else - if (faDirectory and Attrs) > 0 then - Result := Result or UNIX_DIR - else - Result := Result or UNIX_FILE; -end; - -function CRC32Str(const s:string):DWord; -var - i:Integer; -begin - Result:=$FFFFFFFF; - if Length(S)>0 then - for i:=1 to Length(s) do - Result:=Crc_32_Tab[Byte(Result XOR LongInt(s[i]))] XOR ((Result SHR 8) AND $00FFFFFF); - Result:=not Result; -end; - -{ --------------------------------------------------------------------- - TDeCompressor - ---------------------------------------------------------------------} - - -Procedure TDeCompressor.UpdC32(Octet: Byte); - -Begin - FCrc32Val := Crc_32_Tab[Byte(FCrc32Val XOR LongInt(Octet))] XOR ((FCrc32Val SHR 8) AND $00FFFFFF); -end; - -constructor TDeCompressor.Create(AInFile, AOutFile: TStream; ABufSize: LongWord); -begin - FinFile:=AInFile; - FoutFile:=AOutFile; - FBufferSize:=ABufSize; - CRC32Val:=$FFFFFFFF; -end; - -procedure TDeCompressor.Terminate; -begin - FTerminated:=True; -end; - - -{ --------------------------------------------------------------------- - TCompressor - ---------------------------------------------------------------------} - - -Procedure TCompressor.UpdC32(Octet: Byte); - -Begin - FCrc32Val := Crc_32_Tab[Byte(FCrc32Val XOR LongInt(Octet))] XOR ((FCrc32Val SHR 8) AND $00FFFFFF); -end; - -constructor TCompressor.Create(AInFile, AOutFile: TStream; ABufSize: LongWord); -begin - FinFile:=AInFile; - FoutFile:=AOutFile; - FBufferSize:=ABufSize; - CRC32Val:=$FFFFFFFF; -end; - -procedure TCompressor.Terminate; -begin - FTerminated:=True; -end; - - -{ --------------------------------------------------------------------- - TDeflater - ---------------------------------------------------------------------} - -constructor TDeflater.Create(AInFile, AOutFile: TStream; ABufSize: LongWord); -begin - Inherited; - FCompressionLevel:=clDefault; -end; - - -procedure TDeflater.Compress; -Var - Buf : PByte; - I,Count,NewCount : integer; - C : TCompressionStream; - BytesNow : Int64; - NextMark : Int64; - OnBytes : Int64; - FSize : Int64; -begin - CRC32Val:=$FFFFFFFF; - Buf:=GetMem(FBufferSize); - if FOnPercent = 0 then - FOnPercent := 1; - OnBytes:=Round((FInFile.Size * FOnPercent) / 100); - BytesNow:=0; - NextMark := OnBytes; - FSize:=FInfile.Size; - Try - C:=TCompressionStream.Create(FCompressionLevel,FOutFile,True); - Try - if assigned(FOnProgress) then - fOnProgress(self,0); - Repeat - Count:=FInFile.Read(Buf^,FBufferSize); - For I:=0 to Count-1 do - UpdC32(Buf[i]); - NewCount:=Count; - while (NewCount>0) do - NewCount:=NewCount-C.Write(Buf^,NewCount); - inc(BytesNow,Count); - if BytesNow>NextMark Then - begin - if (FSize>0) and assigned(FOnProgress) Then - FOnProgress(self,100 * ( BytesNow / FSize)); - inc(NextMark,OnBytes); - end; - Until (Count=0) or Terminated; - Finally - C.Free; - end; - Finally - FreeMem(Buf); - end; - if assigned(FOnProgress) then - fOnProgress(self,100.0); - Crc32Val:=NOT Crc32Val; -end; - -class function TDeflater.ZipID: Word; -begin - Result:=8; -end; - -class function TDeflater.ZipVersionReqd: Word; -begin - Result:=20; -end; - -function TDeflater.ZipBitFlag: Word; -begin - case CompressionLevel of - clnone: Result := %110; - clfastest: Result := %100; - cldefault: Result := %000; - clmax: Result := %010; - else - Result := 0; - end; -end; - -{ --------------------------------------------------------------------- - TInflater - ---------------------------------------------------------------------} - -constructor TInflater.Create(AInFile, AOutFile: TStream; ABufSize: LongWord); -begin - Inherited; -end; - - -procedure TInflater.DeCompress; - -Var - Buf : PByte; - I,Count : Integer; - C : TDeCompressionStream; - BytesNow : Integer; - NextMark : Integer; - OnBytes : Integer; - FSize : Integer; - -begin - CRC32Val:=$FFFFFFFF; - if FOnPercent = 0 then - FOnPercent := 1; - OnBytes:=Round((FInFile.Size * FOnPercent) / 100); - BytesNow:=0; NextMark := OnBytes; - FSize:=FInfile.Size; - - If Assigned(FOnProgress) then - fOnProgress(self,0); - - Buf:=GetMem(FBufferSize); - Try - C:=TDeCompressionStream.Create(FInFile,True); - Try - Repeat - Count:=C.Read(Buf^,FBufferSize); - For I:=0 to Count-1 do - UpdC32(Buf[i]); - FOutFile.Write(Buf^,Count); - inc(BytesNow,Count); - if BytesNow>NextMark Then - begin - if (FSize>0) and assigned(FOnProgress) Then - FOnProgress(self,100 * ( BytesNow / FSize)); - if assigned(FOnProgressEx) Then - FOnProgressEx(Self, FTotPos + BytesNow, FTotSize); - inc(NextMark,OnBytes); - end; - Until (Count=0) or Terminated; - FTotPos := FTotPos + FOutFile.Size; - Finally - C.Free; - end; - Finally - FreeMem(Buf); - end; - if assigned(FOnProgress) then - fOnProgress(self,100.0); - if assigned(FOnProgressEx) then - FOnProgressEx(Self, FTotPos, FTotSize); - Crc32Val:=NOT Crc32Val; -end; - -class function TInflater.ZipID: Word; -begin - Result:=8; -end; - - -{ --------------------------------------------------------------------- - TShrinker - ---------------------------------------------------------------------} - -Const - DefaultInMemSize = 256*1024; { Files larger than 256k are processed on disk } - DefaultBufSize = 16384; { Use 16K file buffers } - MINBITS = 9; { Starting code size of 9 bits } - MAXBITS = 13; { Maximum code size of 13 bits } - SPECIAL = 256; { Special function code } - INCSIZE = 1; { Code indicating a jump in code size } - CLEARCODE = 2; { Code indicating code table has been cleared } - STDATTR = faAnyFile; { Standard file attribute for DOS Find First/Next } - -constructor TShrinker.Create(AInFile, AOutFile : TStream; ABufSize : LongWord); -begin - Inherited; - FBufSize:=ABufSize; - InBuf:=GetMem(FBUFSIZE); - OutBuf:=GetMem(FBUFSIZE); - CodeTable:=GetMem(SizeOf(CodeTable^)); - FreeList:=GetMem(SizeOf(FreeList^)); -end; - -destructor TShrinker.Destroy; -begin - FreeMem(CodeTable); - FreeMem(FreeList); - FreeMem(InBuf); - FreeMem(OutBuf); - inherited Destroy; -end; - -Procedure TShrinker.Compress; - -Var - OneString : String; - Remaining : Word; - -begin - BytesIn := 1; - BytesOut := 1; - InitializeCodeTable; - FillInputBuffer; - FirstCh:= TRUE; - Crc32Val:=$FFFFFFFF; - FOnBytes:=Round((FInFile.Size * FOnPercent) / 100); - While Not InputEof do - begin - Remaining:=Succ(MaxInBufIdx - InBufIdx); - If Remaining>255 then - Remaining:=255; - If Remaining=0 then - FillInputBuffer - else - begin - SetLength(OneString,Remaining); - Move(InBuf[InBufIdx], OneString[1], Remaining); - Inc(InBufIdx, Remaining); - ProcessLine(OneString); - end; - end; - Crc32Val := Not Crc32Val; - ProcessLine(''); -end; - -class function TShrinker.ZipID: Word; -begin - Result:=1; -end; - -class function TShrinker.ZipVersionReqd: Word; -begin - Result:=10; -end; - -function TShrinker.ZipBitFlag: Word; -begin - Result:=0; -end; - - -Procedure TShrinker.DoOnProgress(Const Pct: Double); - -begin - If Assigned(FOnProgress) then - FOnProgress(Self,Pct); -end; - - -Procedure TShrinker.FillInputBuffer; - -Begin - MaxInbufIDx:=FInfile.Read(InBuf[0], FBufSize); - If MaxInbufIDx=0 then - InputEof := TRUE - else - InputEOF := FALSE; - InBufIdx := 0; -end; - - -Procedure TShrinker.WriteOutputBuffer; -Begin - FOutFile.WriteBuffer(OutBuf[0], OutBufIdx); - OutBufIdx := 0; -end; - - -Procedure TShrinker.PutChar(B : Byte); - -Begin - OutBuf[OutBufIdx] := B; - Inc(OutBufIdx); - If OutBufIdx>=FBufSize then - WriteOutputBuffer; - Inc(BytesOut); -end; - -Procedure TShrinker.FlushOutput; -Begin - If OutBufIdx>0 then - WriteOutputBuffer; -End; - - -procedure TShrinker.PutCode(Code : Smallint); - -var - ACode : LongInt; - XSize : Smallint; - -begin - if (Code=-1) then - begin - if BitsUsed>0 then - PutChar(SaveByte); - end - else - begin - ACode := Longint(Code); - XSize := CodeSize+BitsUsed; - ACode := (ACode shl BitsUsed) or SaveByte; - while (XSize div 8) > 0 do - begin - PutChar(Lo(ACode)); - ACode := ACode shr 8; - Dec(XSize,8); - end; - BitsUsed := XSize; - SaveByte := Lo(ACode); - end; -end; - - -Procedure TShrinker.InitializeCodeTable; - -Var - I : Word; -Begin - For I := 0 to TableSize do - begin - With CodeTable^[I] do - begin - Child := -1; - Sibling := -1; - If (I<=255) then - Suffix := I; - end; - If (I>=257) then - FreeList^[I] := I; - end; - NextFree := FIRSTENTRY; - TableFull := FALSE; -end; - - -Procedure TShrinker.Prune(Parent : Word); - -Var - CurrChild : Smallint; - NextSibling : Smallint; -Begin - CurrChild := CodeTable^[Parent].Child; - { Find first Child that has descendants .. clear any that don't } - While (CurrChild <> -1) and (CodeTable^[CurrChild].Child = -1) do - begin - CodeTable^[Parent].Child := CodeTable^[CurrChild].Sibling; - CodeTable^[CurrChild].Sibling := -1; - { Turn on ClearList bit to indicate a cleared entry } - ClearList[CurrChild DIV 8] := (ClearList[CurrChild DIV 8] OR (1 SHL (CurrChild MOD 8))); - CurrChild := CodeTable^[Parent].Child; - end; - If CurrChild <> -1 then - begin { If there are any children left ...} - Prune(CurrChild); - NextSibling := CodeTable^[CurrChild].Sibling; - While NextSibling <> -1 do - begin - If CodeTable^[NextSibling].Child = -1 then - begin - CodeTable^[CurrChild].Sibling := CodeTable^[NextSibling].Sibling; - CodeTable^[NextSibling].Sibling := -1; - { Turn on ClearList bit to indicate a cleared entry } - ClearList[NextSibling DIV 8] := (ClearList[NextSibling DIV 8] OR (1 SHL (NextSibling MOD 8))); - NextSibling := CodeTable^[CurrChild].Sibling; - end - else - begin - CurrChild := NextSibling; - Prune(CurrChild); - NextSibling := CodeTable^[CurrChild].Sibling; - end; - end; - end; -end; - - -Procedure TShrinker.Clear_Table; -Var - Node : Word; -Begin - FillChar(ClearList, SizeOf(ClearList), $00); - For Node := 0 to 255 do - Prune(Node); - NextFree := Succ(TABLESIZE); - For Node := TABLESIZE downto FIRSTENTRY do - begin - If (ClearList[Node DIV 8] AND (1 SHL (Node MOD 8))) <> 0 then - begin - Dec(NextFree); - FreeList^[NextFree] := Node; - end; - end; - If NextFree <= TABLESIZE then - TableFull := FALSE; -end; - - -Procedure TShrinker.Table_Add(Prefix : Word; Suffix : Byte); -Var - FreeNode : Word; -Begin - If NextFree <= TABLESIZE then - begin - FreeNode := FreeList^[NextFree]; - Inc(NextFree); - CodeTable^[FreeNode].Child := -1; - CodeTable^[FreeNode].Sibling := -1; - CodeTable^[FreeNode].Suffix := Suffix; - If CodeTable^[Prefix].Child = -1 then - CodeTable^[Prefix].Child := FreeNode - else - begin - Prefix := CodeTable^[Prefix].Child; - While CodeTable^[Prefix].Sibling <> -1 do - Prefix := CodeTable^[Prefix].Sibling; - CodeTable^[Prefix].Sibling := FreeNode; - end; - end; - if NextFree > TABLESIZE then - TableFull := TRUE; -end; - -function TShrinker.Table_Lookup( TargetPrefix : Smallint; - TargetSuffix : Byte; - Out FoundAt : Smallint ) : Boolean; - -var TempPrefix : Smallint; - -begin - TempPrefix := TargetPrefix; - Table_lookup := False; - if CodeTable^[TempPrefix].Child <> -1 then - begin - TempPrefix := CodeTable^[TempPrefix].Child; - repeat - if CodeTable^[TempPrefix].Suffix = TargetSuffix then - begin - Table_lookup := True; - break; - end; - if CodeTable^[TempPrefix].Sibling = -1 then - break; - TempPrefix := CodeTable^[TempPrefix].Sibling; - until False; - end; - if Table_Lookup then - FoundAt := TempPrefix - else - FoundAt := -1; -end; - -Procedure TShrinker.Shrink(Suffix : Smallint); - -Const - LastCode : Smallint = 0; - -Var - WhereFound : Smallint; - -Begin - If FirstCh then - begin - SaveByte := $00; - BitsUsed := 0; - CodeSize := MINBITS; - MaxCode := (1 SHL CodeSize) - 1; - LastCode := Suffix; - FirstCh := FALSE; - end - else - begin - If Suffix <> -1 then - begin - If TableFull then - begin - Putcode(LastCode); - PutCode(SPECIAL); - Putcode(CLEARCODE); - Clear_Table; - Table_Add(LastCode, Suffix); - LastCode := Suffix; - end - else - begin - If Table_Lookup(LastCode, Suffix, WhereFound) then - begin - LastCode := WhereFound; - end - else - begin - PutCode(LastCode); - Table_Add(LastCode, Suffix); - LastCode := Suffix; - If (FreeList^[NextFree] > MaxCode) and (CodeSize < MaxBits) then - begin - PutCode(SPECIAL); - PutCode(INCSIZE); - Inc(CodeSize); - MaxCode := (1 SHL CodeSize) -1; - end; - end; - end; - end - else - begin - PutCode(LastCode); - PutCode(-1); - FlushOutput; - end; - end; -end; - -Procedure TShrinker.ProcessLine(Const Source : String); - -Var - I : Word; - -Begin - If Source = '' then - Shrink(-1) - else - For I := 1 to Length(Source) do - begin - Inc(BytesIn); - If (Pred(BytesIn) MOD FOnBytes) = 0 then - DoOnProgress(100 * ( BytesIn / FInFile.Size)); - UpdC32(Ord(Source[I])); - Shrink(Ord(Source[I])); - end; -end; - -{ --------------------------------------------------------------------- - TZipper - ---------------------------------------------------------------------} - - -Procedure TZipper.GetFileInfo; - -Var - F : TZipFileEntry; - Info : TSearchRec; - I : integer; //zip spec allows QWord but FEntries.Count does not support it -{$IFDEF UNIX} - UnixInfo: Stat; -{$ENDIF} -Begin - For I := 0 to FEntries.Count-1 do - begin - F:=FEntries[i]; - If F.Stream=Nil then - begin - If (F.DiskFileName='') then - Raise EZipError.CreateFmt(SErrMissingFileName,[I]); - If FindFirst(F.DiskFileName, STDATTR, Info)=0 then - try - F.Size:=Info.Size; - F.DateTime:=FileDateToDateTime(Info.Time); - {$IFDEF UNIX} - if fplstat(F.DiskFileName, @UnixInfo) = 0 then - F.Attributes := UnixInfo.st_mode; - {$ELSE} - F.Attributes := Info.Attr; - {$ENDIF} - finally - FindClose(Info); - end - else - Raise EZipError.CreateFmt(SErrFileDoesNotExist,[F.DiskFileName]); - end - else - begin - If (F.ArchiveFileName='') then - Raise EZipError.CreateFmt(SErrMissingArchiveName,[I]); - F.Size:=F.Stream.Size; - if (F.Attributes = 0) then - begin - {$IFDEF UNIX} - F.Attributes := UNIX_FILE or UNIX_DEFAULT; - {$ELSE} - F.Attributes := faArchive; - {$ENDIF} - end; - end; - end; -end; - - -procedure TZipper.SetEntries(const AValue: TZipFileEntries); -begin - if FEntries=AValue then exit; - FEntries.Assign(AValue); -end; - -Function TZipper.OpenInput(Item : TZipFileEntry) : Boolean; - -Begin - If (Item.Stream<>nil) then - FInFile:=Item.Stream - else - if Item.IsDirectory then - FInFile := TStringStream.Create('') - else - FInFile:=TFileStream.Create(Item.DiskFileName,fmOpenRead); - Result:=True; - If Assigned(FOnStartFile) then - FOnStartFile(Self,Item.ArchiveFileName); -End; - - -Procedure TZipper.CloseInput(Item : TZipFileEntry); - -Begin - If (FInFile<>Item.Stream) then - FreeAndNil(FInFile) - else - FinFile:=Nil; - DoEndOfFile; -end; - - -Procedure TZipper.StartZipFile(Item : TZipFileEntry); - -Begin - FillChar(LocalHdr,SizeOf(LocalHdr),0); - FillChar(LocalZip64Fld,SizeOf(LocalZip64Fld),0); - With LocalHdr do - begin - Signature := LOCAL_FILE_HEADER_SIGNATURE; - Extract_Version_Reqd := 20; //default value, v2.0 - Bit_Flag := 0; - Compress_Method := 1; - DateTimeToZipDateTime(Item.DateTime,Last_Mod_Date,Last_Mod_Time); - Crc32 := 0; - Compressed_Size := 0; - LocalZip64Fld.Compressed_Size := 0; - if Item.Size >= $FFFFFFFF then - begin - Uncompressed_Size := $FFFFFFFF; - LocalZip64Fld.Original_Size := Item.Size; - end - else - begin - Uncompressed_Size := Item.Size; - LocalZip64Fld.Original_Size := 0; - end; - FileName_Length := 0; - if (LocalZip64Fld.Original_Size>0) or - (LocalZip64Fld.Compressed_Size>0) or - (LocalZip64Fld.Disk_Start_Number>0) or - (LocalZip64Fld.Relative_Hdr_Offset>0) then - Extra_Field_Length := SizeOf(LocalZip64ExtHdr) + SizeOf(LocalZip64Fld) - else - Extra_Field_Length := 0; - end; -End; - - -function TZipper.UpdateZipHeader(Item: TZipFileEntry; FZip: TStream; - ACRC: LongWord; AMethod: Word; AZipVersionReqd: Word; AZipBitFlag: Word - ): Boolean; - // Update header for a single zip file (local header) -var - IsZip64 : boolean; //Must the local header be in zip64 format? - // Separate from zip64 status of entire zip file. - ZFileName : String; -Begin - ZFileName := Item.ArchiveFileName; - IsZip64 := false; - With LocalHdr do - begin - FileName_Length := Length(ZFileName); - Crc32 := ACRC; - if LocalZip64Fld.Original_Size > 0 then - Result := Not (FZip.Size >= LocalZip64Fld.Original_Size) - else - Result := Not (Compressed_Size >= Uncompressed_Size); - if Item.CompressionLevel=clNone - then Result:=false; //user wishes override or invalid compression - If Not Result then - begin - Compress_Method := 0; // No use for compression: change storage type & compression size... - if LocalZip64Fld.Original_Size>0 then - begin - IsZip64 := true; - Compressed_Size := $FFFFFFFF; - LocalZip64Fld.Compressed_Size := LocalZip64Fld.Original_Size; - end - else - begin - Compressed_Size := Uncompressed_Size; - LocalZip64Fld.Compressed_Size := 0; - end; - end - else { Using compression } - begin - Compress_method := AMethod; - Bit_Flag := Bit_Flag or AZipBitFlag; - if FZip.Size >= $FFFFFFFF then - begin - IsZip64 := true; - Compressed_Size := $FFFFFFFF; - LocalZip64Fld.Compressed_Size := FZip.Size; - end - else - begin - Compressed_Size := FZip.Size; - LocalZip64Fld.Compressed_Size := 0; - end; - if AZipVersionReqd > Extract_Version_Reqd then - Extract_Version_Reqd := AZipVersionReqd; - end; - if (IsZip64) and (Extract_Version_Reqd<45) then - Extract_Version_Reqd := 45; - end; - if IsZip64 then - LocalHdr.Extra_Field_Length:=SizeOf(LocalZip64ExtHdr)+SizeOf(LocalZip64Fld); - FOutStream.WriteBuffer({$IFDEF ENDIAN_BIG}SwapLFH{$ENDIF}(LocalHdr),SizeOf(LocalHdr)); - // Append extensible field header+zip64 extensible field if needed: - FOutStream.WriteBuffer(ZFileName[1],Length(ZFileName)); - if IsZip64 then - begin - LocalZip64ExtHdr.Header_ID:=ZIP64_HEADER_ID; - FOutStream.WriteBuffer({$IFDEF ENDIAN_BIG}SwapEDFH{$ENDIF}(LocalZip64ExtHdr),SizeOf(LocalZip64ExtHdr)); - FOutStream.WriteBuffer({$IFDEF ENDIAN_BIG}SwapZ64EIF{$ENDIF}(LocalZip64Fld),SizeOf(LocalZip64Fld)); - end; -End; - - -Procedure TZipper.BuildZipDirectory; -// Write out all central file headers using info from local headers -Var - SavePos : Int64; - HdrPos : Int64; //offset from disk where file begins to local header - CenDirPos : Int64; - ACount : QWord; //entry counter - ZFileName : string; //archive filename - IsZip64 : boolean; //local header=zip64 format? - MinReqdVersion: word; //minimum needed to extract - ExtInfoHeader : Extensible_Data_Field_Header_Type; - Zip64ECD : Zip64_End_of_Central_Dir_type; - Zip64ECDL : Zip64_End_of_Central_Dir_Locator_type; -Begin - ACount := 0; - MinReqdVersion:=0; - CenDirPos := FOutStream.Position; - FOutStream.Seek(0,soBeginning); { Rewind output file } - HdrPos := FOutStream.Position; - FOutStream.ReadBuffer(LocalHdr, SizeOf(LocalHdr)); -{$IFDEF FPC_BIG_ENDIAN} - LocalHdr := SwapLFH(LocalHdr); -{$ENDIF} - Repeat - SetLength(ZFileName,LocalHdr.FileName_Length); - FOutStream.ReadBuffer(ZFileName[1], LocalHdr.FileName_Length); - IsZip64:=(LocalHdr.Compressed_Size=$FFFFFFFF) or (LocalHdr.Uncompressed_Size=$FFFFFFFF) or (HdrPos>=$FFFFFFFF); - FillChar(LocalZip64Fld,SizeOf(LocalZip64Fld),0); // easier to check compressed length - if LocalHdr.Extra_Field_Length>0 then - begin - SavePos := FOutStream.Position; - if (IsZip64 and (LocalHdr.Extra_Field_Length>=SizeOf(LocalZip64ExtHdr)+SizeOf(LocalZip64Fld))) then - while FOutStream.PositionMinReqdVersion then - MinReqdVersion:=Extract_Version_Reqd; - Last_Mod_Time:=localHdr.Last_Mod_Time; - Last_Mod_Date:=localHdr.Last_Mod_Date; - File_Comment_Length := 0; - Starting_Disk_Num := 0; - Internal_Attributes := 0; - {$IFDEF UNIX} - External_Attributes := Entries[ACount].Attributes shl 16; - {$ELSE} - External_Attributes := Entries[ACount].Attributes; - {$ENDIF} - if HdrPos>=$FFFFFFFF then - begin - FZipFileNeedsZip64:=true; - IsZip64:=true; - Local_Header_offset := $FFFFFFFF; - // LocalZip64Fld will be written out as central dir extra field later - LocalZip64Fld.Relative_Hdr_Offset := HdrPos; - end - else - Local_Header_Offset := HdrPos; - end; - FOutStream.Seek(0,soEnd); - FOutStream.WriteBuffer({$IFDEF FPC_BIG_ENDIAN}SwapCFH{$ENDIF}(CentralHdr),SizeOf(CentralHdr)); - FOutStream.WriteBuffer(ZFileName[1],Length(ZFileName)); - if IsZip64 then - begin - FOutStream.Seek(0,soEnd); - FOutStream.WriteBuffer({$IFDEF FPC_BIG_ENDIAN}SwapEDFH{$ENDIF}(LocalZip64ExtHdr),SizeOf(LocalZip64ExtHdr)); - FOutStream.WriteBuffer({$IFDEF FPC_BIG_ENDIAN}SwapZ64EIF{$ENDIF}(LocalZip64Fld),SizeOf(LocalZip64Fld)); - end; - - Inc(ACount); - // Move past compressed file data to next header: - if Iszip64 then - FOutStream.Seek(SavePos + LocalZip64Fld.Compressed_Size,soBeginning) - else - FOutStream.Seek(SavePos + LocalHdr.Compressed_Size,soBeginning); - HdrPos:=FOutStream.Position; - FOutStream.ReadBuffer(LocalHdr, SizeOf(LocalHdr)); - {$IFDEF FPC_BIG_ENDIAN} - LocalHdr := SwapLFH(LocalHdr); - {$ENDIF} - Until LocalHdr.Signature = CENTRAL_FILE_HEADER_SIGNATURE ; - - FOutStream.Seek(0,soEnd); - FillChar(EndHdr,SizeOf(EndHdr),0); - - // Write end of central directory record - // We'll use the zip64 variants to store counts etc - // and copy to the old record variables if possible - // This seems to match expected behaviour of unzippers like - // unrar that only look at the zip64 record - FillChar(Zip64ECD, SizeOf(Zip64ECD), 0); - Zip64ECD.Signature:=ZIP64_END_OF_CENTRAL_DIR_SIGNATURE; - FillChar(Zip64ECDL, SizeOf(Zip64ECDL), 0); - Zip64ECDL.Signature:=ZIP64_END_OF_CENTRAL_DIR_LOCATOR_SIGNATURE; - Zip64ECDL.Total_Disks:=1; //default and no support for multi disks yet anyway - With EndHdr do - begin - Signature := END_OF_CENTRAL_DIR_SIGNATURE; - Disk_Number := 0; - Central_Dir_Start_Disk := 0; - - Zip64ECD.Entries_This_Disk:=ACount; - Zip64ECD.Total_Entries:=Acount; - if ACount>$FFFF then - begin - FZipFileNeedsZip64 := true; - Entries_This_Disk := $FFFF; - Total_Entries := $FFFF; - end - else - begin - Entries_This_Disk := Zip64ECD.Entries_This_Disk; - Total_Entries := Zip64ECD.Total_Entries; - end; - - Zip64ECD.Central_Dir_Size := FOutStream.Size-CenDirPos; - if (Zip64ECD.Central_Dir_Size)>$FFFFFFFF then - begin - FZipFileNeedsZip64 := true; - Central_Dir_Size := $FFFFFFFF; - end - else - begin - Central_Dir_Size := Zip64ECD.Central_Dir_Size; - end; - - Zip64ECD.Start_Disk_Offset := CenDirPos; - if Zip64ECD.Start_Disk_Offset>$FFFFFFFF then - begin - FZipFileNeedsZip64 := true; - Start_Disk_Offset := $FFFFFFFF; - end - else - begin - Start_Disk_Offset := Zip64ECD.Start_Disk_Offset; - end; - - ZipFile_Comment_Length := Length(FFileComment); - - if FZipFileNeedsZip64 then - begin - //Write zip64 end of central directory record if needed - if MinReqdVersion<45 then - MinReqdVersion := 45; - Zip64ECD.Extract_Version_Reqd := MinReqdVersion; - Zip64ECD.Version_Made_By := MinReqdVersion; - Zip64ECD.Record_Size := SizeOf(Zip64ECD)-12; //Assumes no variable length field following - Zip64ECDL.Central_Dir_Zip64_EOCD_Offset := FOutStream.Position; - Zip64ECDL.Zip64_EOCD_Start_Disk := 0; - FOutStream.WriteBuffer({$IFDEF FPC_BIG_ENDIAN}SwapZ64ECD{$ENDIF}(Zip64ECD), SizeOf(Zip64ECD)); - - //Write zip64 end of central directory locator if needed - FOutStream.WriteBuffer({$IFDEF FPC_BIG_ENDIAN}SwapZ64ECDL{$ENDIF}(Zip64ECDL), SizeOf(Zip64ECDL)); - end; - - FOutStream.WriteBuffer({$IFDEF FPC_BIG_ENDIAN}SwapECD{$ENDIF}(EndHdr), SizeOf(EndHdr)); - if Length(FFileComment) > 0 then - FOutStream.WriteBuffer(FFileComment[1],Length(FFileComment)); - end; -end; - -Function TZipper.CreateCompressor(Item : TZipFileEntry; AInFile,AZipStream : TStream) : TCompressor; - -begin - Result:=TDeflater.Create(AinFile,AZipStream,FBufSize); - (Result as TDeflater).CompressionLevel:=Item.CompressionLevel; - FCurrentCompressor:=Result; -end; - -Procedure TZipper.ZipOneFile(Item : TZipFileEntry); - -Var - CRC : LongWord; - ZMethod : Word; - ZVersionReqd : Word; - ZBitFlag : Word; - ZipStream : TStream; - TmpFileName : String; - -Begin - OpenInput(Item); - Try - StartZipFile(Item); - If (FInfile.Size<=FInMemSize) then - ZipStream:=TMemoryStream.Create - else - begin - TmpFileName:=ChangeFileExt(FFileName,'.tmp'); - if TmpFileName=FFileName then - TmpFileName:=TmpFileName+'.tmp'; - ZipStream:=TFileStream.Create(TmpFileName,fmCreate); - end; - Try - With CreateCompressor(Item, FinFile,ZipStream) do - Try - OnProgress:=Self.OnProgress; - OnPercent:=Self.OnPercent; - Compress; - CRC:=Crc32Val; - ZMethod:=ZipID; - ZVersionReqd:=ZipVersionReqd; - ZBitFlag:=ZipBitFlag; - Finally - FCurrentCompressor:=Nil; - Free; - end; - If UpdateZipHeader(Item,ZipStream,CRC,ZMethod,ZVersionReqd,ZBitFlag) then - // Compressed file smaller than original file. - FOutStream.CopyFrom(ZipStream,0) - else - begin - // Original file smaller than compressed file. - FInfile.Seek(0,soBeginning); - FOutStream.CopyFrom(FInFile,0); - end; - finally - ZipStream.Free; - If (TmpFileName<>'') then - DeleteFile(TmpFileName); - end; - Finally - CloseInput(Item); - end; -end; - -// Just like SaveToFile, but uses the FileName property -Procedure TZipper.ZipAllFiles; -begin - SaveToFile(FileName); -end; - -procedure TZipper.SaveToFile(AFileName: RawByteString); -var - lStream: TFileStream; -begin - FFileName:=AFileName; - lStream:=TFileStream.Create(FFileName,fmCreate); - try - SaveToStream(lStream); - finally - FreeAndNil(lStream); - end; -end; - -procedure TZipper.SaveToStream(AStream: TStream); -Var - I : integer; //could be qword but limited by FEntries.Count -begin - FTerminated:=False; - FOutStream := AStream; - If CheckEntries=0 then - Exit; - FZipping:=True; - Try - GetFileInfo; //get info on file entries in zip - I:=0; - While (I0) and not Terminated then - BuildZipDirectory; - finally - FZipping:=False; - // Remove entries that have been added by CheckEntries from Files. - for I:=0 to FFiles.Count-1 do - FEntries.Delete(FEntries.Count-1); - end; -end; - - -Procedure TZipper.SetBufSize(Value : LongWord); - -begin - If FZipping then - Raise EZipError.Create(SErrBufsizeChange); - If Value>=DefaultBufSize then - FBufSize:=Value; -end; - -Procedure TZipper.SetFileName(Value : RawByteString); - -begin - If FZipping then - Raise EZipError.Create(SErrFileChange); - FFileName:=Value; -end; - -Procedure TZipper.ZipFiles(AFileName : RawByteString; FileList : TStrings); - -begin - FFileName:=AFileName; - ZipFiles(FileList); -end; - -procedure TZipper.ZipFiles(FileList: TStrings); -begin - FFiles.Assign(FileList); - ZipAllFiles; -end; - -procedure TZipper.ZipFiles(AFileName: RawByteString; Entries: TZipFileEntries); -begin - FFileName:=AFileName; - ZipFiles(Entries); -end; - -procedure TZipper.ZipFiles(Entries: TZipFileEntries); -begin - FEntries.Assign(Entries); - ZipAllFiles; -end; - -Procedure TZipper.DoEndOfFile; - -Var - ComprPct : Double; - -begin - if (FZipFileNeedsZip64) and (LocalZip64Fld.Original_Size>0) then - ComprPct := (100.0 * (LocalZip64Fld.Original_size - LocalZip64Fld.Compressed_Size)) / LocalZip64Fld.Original_Size - else if (LocalHdr.Uncompressed_Size>0) then - ComprPct := (100.0 * (LocalHdr.Uncompressed_Size - LocalHdr.Compressed_Size)) / LocalHdr.Uncompressed_Size - else - ComprPct := 0; - If Assigned(FOnEndOfFile) then - FOnEndOfFile(Self,ComprPct); -end; - -Constructor TZipper.Create; - -begin - FBufSize:=DefaultBufSize; - FInMemSize:=DefaultInMemSize; - FFiles:=TStringList.Create; - FEntries:=TZipFileEntries.Create(TZipFileEntry); - FOnPercent:=1; - FZipFileNeedsZip64:=false; - LocalZip64ExtHdr.Header_ID:=ZIP64_HEADER_ID; - LocalZip64ExtHdr.Data_Size:=SizeOf(Zip64_Extended_Info_Field_Type); -end; - -Function TZipper.CheckEntries : Integer; - -Var - I : integer; //Could be QWord but limited by FFiles.Count - -begin - for I:=0 to FFiles.Count-1 do - FEntries.AddFileEntry(FFiles[i]); - - // Use zip64 when number of file entries - // or individual (un)compressed sizes - // require it. - if FEntries.Count >= $FFFF then - FZipFileNeedsZip64:=true; - - if not(FZipFileNeedsZip64) then - begin - for I:=0 to FFiles.Count-1 do - begin - if FEntries[i].FNeedsZip64 then - begin - FZipFileNeedsZip64:=true; - break; - end; - end; - end; - - Result:=FEntries.Count; -end; - - -Procedure TZipper.Clear; - -begin - FEntries.Clear; - FFiles.Clear; -end; - -procedure TZipper.Terminate; -begin - FTerminated:=True; - if Assigned(FCurrentCompressor) then - FCurrentCompressor.Terminate; -end; - -Destructor TZipper.Destroy; - -begin - Clear; - FreeAndNil(FEntries); - FreeAndNil(FFiles); - Inherited; -end; - -{ --------------------------------------------------------------------- - TUnZipper - ---------------------------------------------------------------------} - -procedure TUnZipper.OpenInput; - -Begin - if Assigned(FOnOpenInputStream) then - FOnOpenInputStream(Self, FZipStream); - if FZipStream = nil then - FZipStream:=TFileStream.Create(FFileName,fmOpenRead or fmShareDenyWrite); -End; - - -function TUnZipper.OpenOutput(OutFileName: RawByteString; - out OutStream: TStream; Item: TFullZipFileEntry): Boolean; -Var - Path: RawByteString; - OldDirectorySeparators: set of char; - -Begin - { the default RTL behavior is broken on Unix platforms - for Windows compatibility: it allows both '/' and '\' - as directory separator. We don't want that behavior - here, since 'abc\' is a valid file name under Unix. - - The zip standard appnote.txt says zip files must have '/' as path - separator, even on Windows: 4.4.17.1: - "The path stored MUST not contain a drive or device letter, or a leading - slash. All slashes MUST be forward slashes '/' as opposed to backwards - slashes '\'" See also mantis issue #15836 - However, old versions of FPC on Windows (and possibly other utilities) - created incorrect zip files with \ separator, so accept these as well as - they're not valid in Windows file names anyway. - } - OldDirectorySeparators:=AllowDirectorySeparators; - {$ifdef Windows} - // Explicitly allow / and \ regardless of what Windows supports - AllowDirectorySeparators:=['\','/']; - {$else} - // Follow the standard: only allow / regardless of actual separator on OS - AllowDirectorySeparators:=['/']; - {$endif} - Path:=ExtractFilePath(OutFileName); - OutStream:=Nil; - If Assigned(FOnCreateStream) then - FOnCreateStream(Self, OutStream, Item); - // If FOnCreateStream didn't create one, we create one now. - If (OutStream=Nil) then - begin - if (Path<>'') then - ForceDirectories(Path); - AllowDirectorySeparators:=OldDirectorySeparators; - OutStream:=TFileStream.Create(OutFileName,fmCreate); - - end; - - AllowDirectorySeparators:=OldDirectorySeparators; - Result:=True; - If Assigned(FOnStartFile) then - FOnStartFile(Self,OutFileName); -End; - - -procedure TUnZipper.CloseOutput(Item: TFullZipFileEntry; var OutStream: TStream - ); - -Begin - if Assigned(FOnDoneStream) then - begin - FOnDoneStream(Self, OutStream, Item); - OutStream := nil; - end - else - FreeAndNil(OutStream); - DoEndOfFile; -end; - - -procedure TUnZipper.CloseInput; - -Begin - if Assigned(FOnCloseInputStream) then - FOnCloseInputStream(Self, FZipStream); - FreeAndNil(FZipStream); -end; - - -procedure TUnZipper.ReadZipHeader(Item: TFullZipFileEntry; out AMethod: Word); -Var - S : String; - U : UTF8String; - D : TDateTime; - ExtraFieldHdr: Extensible_Data_Field_Header_Type; - SavePos: int64; //could be qword but limited by stream - // Infozip unicode path - Infozip_Unicode_Path_Ver:Byte; - Infozip_Unicode_Path_CRC32:DWord; -Begin - FZipStream.Seek(Item.HdrPos,soBeginning); - FZipStream.ReadBuffer(LocalHdr,SizeOf(LocalHdr)); -{$IFDEF FPC_BIG_ENDIAN} - LocalHdr := SwapLFH(LocalHdr); -{$ENDIF} - FillChar(LocalZip64Fld,SizeOf(LocalZip64Fld),0); //ensure no erroneous info - With LocalHdr do - begin - Item.FBitFlags:=Bit_Flag; - SetLength(S,Filename_Length); - FZipStream.ReadBuffer(S[1],Filename_Length); - Item.ArchiveFileName:=S; - Item.DiskFileName:=S; - SavePos:=FZipStream.Position; //after filename, before extra fields - if Extra_Field_Length>0 then - begin - SavePos := FZipStream.Position; - if (LocalHdr.Extra_Field_Length>=SizeOf(ExtraFieldHdr)) then - while FZipStream.Position 0 then - Item.CRC32 := Crc32; - AMethod:=Compress_method; - end; -End; - -procedure TUnZipper.FindEndHeaders( - out AEndHdr: End_of_Central_Dir_Type; - out AEndHdrPos: Int64; - out AEndZip64Hdr: Zip64_End_of_Central_Dir_type; - out AEndZip64HdrPos: Int64); -// Reads backwords from the end of the zip file, -// following end of central directory, and, if present -// zip64 end of central directory locator and -// zip64 end of central directory record - -// If valid regular end of directory found, AEndHdrPos>0 -// If valid zip64 end of directory found, AEndZip64HdrPos>0 -var - EndZip64Locator: Zip64_End_of_Central_Dir_Locator_type; - procedure SearchForSignature; - // Search for end of central directory record signature - // If failed, set AEndHdrPos to 0 - var - I: Integer; - Buf: PByte; - BufSize: Integer; - result: boolean; - begin - result:=false; - // scan the last (64k + something) bytes for the END_OF_CENTRAL_DIR_SIGNATURE - // (zip file comments are 64k max). - BufSize := 65536 + SizeOf(AEndHdr) + 128; - if FZipStream.Size < BufSize then - BufSize := FZipStream.Size; - - Buf := GetMem(BufSize); - try - FZipStream.Seek(FZipStream.Size - BufSize, soBeginning); - FZipStream.ReadBuffer(Buf^, BufSize); - - for I := BufSize - SizeOf(AEndHdr) downto 0 do - begin - if (Buf[I] or (Buf[I + 1] shl 8) or (Buf[I + 2] shl 16) or (Buf[I + 3] shl 24)) = END_OF_CENTRAL_DIR_SIGNATURE then - begin - Move(Buf[I], AEndHdr, SizeOf(AEndHdr)); - {$IFDEF FPC_BIG_ENDIAN} - AEndHdr := SwapECD(AEndHdr); - {$ENDIF} - if (AEndHdr.Signature = END_OF_CENTRAL_DIR_SIGNATURE) and - (I + SizeOf(AEndHdr) + AEndHdr.ZipFile_Comment_Length = BufSize) then - begin - AEndHdrPos := FZipStream.Size - BufSize + I; - FZipStream.Seek(AEndHdrPos + SizeOf(AEndHdr), soBeginning); - SetLength(FFileComment, AEndHdr.ZipFile_Comment_Length); - FZipStream.ReadBuffer(FFileComment[1], Length(FFileComment)); - result:=true; //found it - break; - end; - end; - end; - finally - FreeMem(Buf); - end; - if not(result) then - begin - AEndHdrPos := 0; - FillChar(AEndHdr, SizeOf(AEndHdr), 0); - end; - end; - - procedure ZeroData; - begin - AEndHdrPos := 0; - FillChar(AEndHdr, SizeOf(AEndHdr), 0); - AEndZip64HdrPos:=0; - FillChar(AEndZip64Hdr, SizeOf(AEndZip64Hdr), 0); - end; - -begin - // Zip64 records may not exist, so fill out default values - FillChar(AEndZip64Hdr,SizeOf(AEndZip64Hdr), 0); - AEndZip64HdrPos:=0; - // Look for end of central directory record from - // back of file based on signature (only way due to - // variable length zip comment etc) - FFileComment := ''; - // Zip file requires end of central dir header so - // is corrupt if it is smaller than that - if FZipStream.Size < SizeOf(AEndHdr) then - begin - ZeroData; - exit; - end; - - AEndHdrPos := FZipStream.Size - SizeOf(AEndHdr); - FZipStream.Seek(AEndHdrPos, soBeginning); - FZipStream.ReadBuffer(AEndHdr, SizeOf(AEndHdr)); - {$IFDEF FPC_BIG_ENDIAN} - AEndHdr := SwapECD(AEndHdr); - {$ENDIF} - // Search unless record is right at the end of the file: - if (AEndHdr.Signature <> END_OF_CENTRAL_DIR_SIGNATURE) or - (AEndHdr.ZipFile_Comment_Length <> 0) then - SearchForSignature; - if AEndHdrPos=0 then - begin - ZeroData; - exit; - end; - - // With a valid end of dir record, see if there's zip64 - // fields: - FZipStream.Seek(AEndHdrPos-SizeOf(Zip64_End_of_Central_Dir_Locator_type),soBeginning); - FZipStream.ReadBuffer(EndZip64Locator, SizeOf(EndZip64Locator)); - {$IFDEF FPC_BIG_ENDIAN} - EndZip64Locator := SwapZ64ECDL(EndZip64Locator); - {$ENDIF} - if EndZip64Locator.Signature=ZIP64_END_OF_CENTRAL_DIR_LOCATOR_SIGNATURE then - begin - //Read EndZip64Locator.Total_Disks when implementing multiple disks support - if EndZip64Locator.Central_Dir_Zip64_EOCD_Offset>High(Int64) then - raise EZipError.CreateFmt(SErrPosTooLarge,[EndZip64Locator.Central_Dir_Zip64_EOCD_Offset,High(Int64)]); - AEndZip64HdrPos:=EndZip64Locator.Central_Dir_Zip64_EOCD_Offset; - FZipStream.Seek(AEndZip64HdrPos, soBeginning); - FZipStream.ReadBuffer(AEndZip64Hdr, SizeOf(AEndZip64Hdr)); - {$IFDEF FPC_BIG_ENDIAN} - AEndZip64Hdr := SwapZ64ECD(AEndZip64Hdr); - {$ENDIF} - if AEndZip64Hdr.Signature<>ZIP64_END_OF_CENTRAL_DIR_SIGNATURE then - begin - //Corrupt header - ZeroData; - Exit; - end; - end - else - begin - // No zip64 data, so follow the offset in the end of central directory record - AEndZip64HdrPos:=0; - FillChar(AEndZip64Hdr, SizeOf(AEndZip64Hdr), 0); - end; -end; - -procedure TUnZipper.ReadZipDirectory; - -Var - EndHdr : End_of_Central_Dir_Type; - EndZip64Hdr : Zip64_End_of_Central_Dir_type; - i : integer; //could be Qword but limited to number of items in collection - EndHdrPos, - EndZip64HdrPos, - CenDirPos, - SavePos : Int64; //could be QWord but limited to stream maximums - ExtraFieldHeader : Extensible_Data_Field_Header_Type; - EntriesThisDisk : QWord; - Zip64Field: Zip64_Extended_Info_Field_Type; - NewNode : TFullZipFileEntry; - D : TDateTime; - S : String; - U : UTF8String; - // infozip unicode path - Infozip_unicode_path_ver : byte; // always 1 - Infozip_unicode_path_crc32 : DWord; -Begin - FindEndHeaders(EndHdr, EndHdrPos, - EndZip64Hdr, EndZip64HdrPos); - if EndHdrPos=0 then - raise EZipError.CreateFmt(SErrCorruptZIP,[FileName]); - if (EndZip64HdrPos>0) and (EndZip64Hdr.Start_Disk_Offset>0) then - begin - if EndZip64Hdr.Start_Disk_Offset>High(Int64) then - raise EZipError.CreateFmt(SErrPosTooLarge,[EndZip64Hdr.Start_Disk_Offset,High(Int64)]); - CenDirPos := EndZip64Hdr.Start_Disk_Offset; - end - else - CenDirPos := EndHdr.Start_Disk_Offset; - FZipStream.Seek(CenDirPos,soBeginning); - FEntries.Clear; - if (EndZip64HdrPos>0) and (EndZip64Hdr.Entries_This_Disk>0) then - begin - EntriesThisDisk := EndZip64Hdr.Entries_This_Disk; - if EntriesThisDisk<>EndZip64Hdr.Total_Entries then - raise EZipError.Create(SErrUnsupportedMultipleDisksCD); - end - else - begin - EntriesThisDisk :=EndHdr.Entries_This_Disk; - if EntriesThisDisk<>EndHdr.Total_Entries then - raise EZipError.Create(SErrUnsupportedMultipleDisksCD); - end; - - // Entries are added to a collection. The max number of items - // in a collection limits the entries we can process. - if EntriesThisDisk>MaxInt then - raise EZipError.CreateFmt(SErrMaxEntries,[EntriesThisDisk,MaxInt]); - - // Using while instead of for loop so qword can be used on 32 bit as well. - for i:=0 to EntriesThisDisk-1 do - begin - FZipStream.ReadBuffer(CentralHdr, SizeOf(CentralHdr)); -{$IFDEF FPC_BIG_ENDIAN} - CentralHdr := SwapCFH(CentralHdr); -{$ENDIF} - With CentralHdr do - begin - if Signature<>CENTRAL_FILE_HEADER_SIGNATURE then - raise EZipError.CreateFmt(SErrCorruptZIP,[FileName]); - NewNode:=FEntries.Add as TFullZipFileEntry; - // Header position will be corrected later with zip64 version, if needed.. - NewNode.HdrPos := Local_Header_Offset; - NewNode.FBitFlags:=Bit_Flag; - SetLength(S,Filename_Length); - FZipStream.ReadBuffer(S[1],Filename_Length); - SavePos:=FZipStream.Position; //After fixed part of central directory... - // and the filename; before any extra field(s) - NewNode.ArchiveFileName:=S; - // Size/compressed size will be adjusted by zip64 entries if needed... - NewNode.Size:=Uncompressed_Size; - NewNode.FCompressedSize:=Compressed_Size; - NewNode.CRC32:=CRC32; - NewNode.OS := MadeBy_Version shr 8; - if NewNode.OS = OS_UNIX then - NewNode.Attributes := External_Attributes shr 16 - else - NewNode.Attributes := External_Attributes; - ZipDateTimeToDateTime(Last_Mod_Date,Last_Mod_Time,D); - NewNode.DateTime:=D; - - // Go through any extra fields and extract any zip64 info - if Extra_Field_Length>0 then - begin - while (FZipStream.Position 0 then - NewNode.FCompressedSize := Zip64Field.Compressed_Size; - if Zip64Field.Original_Size>0 then - NewNode.Size := Zip64Field.Original_Size; - if Zip64Field.Relative_Hdr_Offset<>0 then - begin - if Zip64Field.Relative_Hdr_Offset>High(Int64) then - raise EZipError.CreateFmt(SErrPosTooLarge,[Zip64Field.Relative_Hdr_Offset,High(Int64)]); - NewNode.HdrPos := Zip64Field.Relative_Hdr_Offset; - end; - end - // infozip unicode path extra field - else if ExtraFieldHeader.Header_ID = INFOZIP_UNICODE_PATH_ID then - begin - FZipStream.ReadBuffer(Infozip_unicode_path_ver,1); - if Infozip_unicode_path_ver=1 then - begin - FZipStream.ReadBuffer(Infozip_unicode_path_crc32,sizeof(Infozip_unicode_path_crc32)); - {$IFDEF FPC_BIG_ENDIAN} - Infozip_unicode_path_crc32:=SwapEndian(Infozip_unicode_path_crc32); - {$ENDIF} - if CRC32Str(S)=Infozip_unicode_path_crc32 then - begin - SetLength(U,ExtraFieldHeader.Data_Size-5); - FZipStream.ReadBuffer(U[1],Length(U)); - NewNode.UTF8ArchiveFileName:=U; - end - else - FZipStream.Seek(ExtraFieldHeader.Data_Size-5,soFromCurrent); - end - else - FZipStream.Seek(ExtraFieldHeader.Data_Size-1,soFromCurrent); - end - else - begin - // Read past non-Zip64 extra field - FZipStream.Seek(ExtraFieldHeader.Data_Size,soFromCurrent); - end; - end; - end; - // Move past extra fields and file comment to next header - FZipStream.Seek(SavePos+Extra_Field_Length+File_Comment_Length,soFromBeginning); - end; - end; -end; - -function TUnZipper.CreateDeCompressor(Item: TZipFileEntry; AMethod: Word; - AZipFile, AOutFile: TStream): TDeCompressor; -begin - case AMethod of - 8 : - Result:=TInflater.Create(AZipFile,AOutFile,FBufSize); - else - raise EZipError.CreateFmt(SErrUnsupportedCompressionFormat,[AMethod]); - end; - FCurrentDecompressor:=Result; -end; - -procedure TUnZipper.UnZipOneFile(Item: TFullZipFileEntry); - -Var - ZMethod : Word; -{$ifdef unix} - LinkTargetStream: TStringStream; -{$endif} - OutputFileName: RawByteString; - FOutStream: TStream; - IsLink: Boolean; - IsCustomStream: Boolean; - U : UnicodeString; - - Procedure SetAttributes; - Var - Attrs : Longint; - begin - // set attributes - FileSetDate(OutputFileName, DateTimeToFileDate(Item.DateTime)); - if (Item.Attributes <> 0) then - begin - Attrs := 0; - {$IFDEF UNIX} - if (Item.OS in [OS_UNIX,OS_OSX]) then Attrs := Item.Attributes; - if (Item.OS in [OS_FAT,OS_NTFS,OS_OS2,OS_VFAT]) then - Attrs := ZipFatAttrsToUnixAttrs(Item.Attributes); - {$ELSE} - if (Item.OS in [OS_FAT,OS_NTFS,OS_OS2,OS_VFAT]) then Attrs := Item.Attributes; - if (Item.OS in [OS_UNIX,OS_OSX]) then - Attrs := ZipUnixAttrsToFatAttrs(ExtractFileName(Item.ArchiveFileName), Item.Attributes); - {$ENDIF} - if Attrs <> 0 then - begin - {$IFDEF UNIX} - FpChmod(OutputFileName, Attrs); - {$ELSE} - FileSetAttr(OutputFileName, Attrs); - {$ENDIF} - end; - end; - end; - - procedure DoUnzip(const Dest: TStream); - - begin - if ZMethod=0 then - begin - if (LocalHdr.Compressed_Size<>0) then - begin - if LocalZip64Fld.Compressed_Size>0 then - Dest.CopyFrom(FZipStream,LocalZip64Fld.Compressed_Size) - else - Dest.CopyFrom(FZipStream,LocalHdr.Compressed_Size); - {$warning TODO: Implement CRC Check} - end; - end - else - With CreateDecompressor(Item, ZMethod, FZipStream, Dest) do - Try - FTotPos := Self.FTotPos; - FTotSize := Self.FTotSize; - OnProgress:=Self.OnProgress; - OnProgressEx := Self.OnProgressEx; - OnPercent:=Self.OnPercent; - OnProgress:=Self.OnProgress; - OnPercent:=Self.OnPercent; - DeCompress; - Self.FTotPos := FTotPos; - if Item.CRC32 <> Crc32Val then - raise EZipError.CreateFmt(SErrInvalidCRC,[Item.ArchiveFileName]); - Finally - FCurrentDecompressor:=Nil; - Free; - end; - end; - - Procedure GetOutputFileName; - - Var - I : Integer; - - begin - if Not UseUTF8 then - OutputFileName:=StringReplace(Item.DiskFileName,'/',DirectorySeparator,[rfReplaceAll]) - else - begin - // Sets codepage. - OutputFileName:=Item.UTF8DiskFileName; - U:=UTF8Decode(OutputFileName); - // Do not use stringreplace, it will mess up the codepage. - if '/'<>DirectorySeparator then - For I:=1 to Length(U) do - if U[i]='/' then - U[i]:=DirectorySeparator; - OutputFileName:=UTF8Encode(U); - end; - if (Not IsCustomStream) and (FOutputPath<>'') then - begin - // Do not use IncludeTrailingPathdelimiter - OutputFileName:=FOutputPath+OutputFileName; - end; - end; - -Begin - ReadZipHeader(Item, ZMethod); - if (Item.BitFlags and 1)<>0 then - Raise EZipError.CreateFmt(SErrEncryptionNotSupported,[Item.ArchiveFileName]); - if (Item.BitFlags and (1 shl 5))<>0 then - Raise EZipError.CreateFmt(SErrPatchSetNotSupported,[Item.ArchiveFileName]); - // Normalize output filename to conventions of target platform. - // Zip file always has / path separators - IsCustomStream := Assigned(FOnCreateStream); - GetOutputFileName; - IsLink := Item.IsLink; -{$IFNDEF UNIX} - if IsLink and Not IsCustomStream then - begin - {$warning TODO: Implement symbolic link creation for non-unix, e.g. - Windows NTFS} - IsLink := False; - end; -{$ENDIF} - if IsCustomStream then - begin - try - OpenOutput(OutputFileName, FOutStream, Item); - if (IsLink = False) and (Item.IsDirectory = False) then - DoUnzip(FOutStream); - Finally - CloseOutput(Item, FOutStream); - end; - end - else - begin - if IsLink then - begin - {$IFDEF UNIX} - LinkTargetStream := TStringStream.Create(''); - try - DoUnzip(LinkTargetStream); - fpSymlink(PChar(LinkTargetStream.DataString), PChar(OutputFileName)); - finally - LinkTargetStream.Free; - end; - {$ENDIF} - end - else if Item.IsDirectory then - CreateDir(OutputFileName) - else - begin - try - OpenOutput(OutputFileName, FOutStream, Item); - DoUnzip(FOutStream); - Finally - CloseOutput(Item, FOutStream); - end; - end; - SetAttributes; - end; -end; - -Function TUnZipper.IsMatch(I : TFullZipFileEntry) : Boolean; - -begin - if UseUTF8 then - Result:=(FFiles.IndexOf(I.UTF8ArchiveFileName)<>-1) - else - Result:=(FFiles.IndexOf(I.ArchiveFileName)<>-1) -end; - -Function TUnZipper.CalcTotalSize(AllFiles : Boolean) : Int64; - -Var - I : Integer; - Item : TFullZipFileEntry; - -begin - Result:=0; - for i:=0 to FEntries.Count-1 do - begin - Item := FEntries[i]; - if AllFiles or IsMatch(Item) then - Result := Result + TZipFileEntry(Item).Size; - end; -end; - -procedure TUnZipper.UnZipAllFiles; - - -Var - Item : TFullZipFileEntry; - I : integer; //Really QWord but limited to FEntries.Count - AllFiles : Boolean; - -Begin - FTerminated:=False; - FUnZipping:=True; - Try - AllFiles:=(FFiles.Count=0); - OpenInput; - Try - ReadZipDirectory; - FTotPos := 0; - FTotSize := CalcTotalSize(AllFiles); - i:=0; - While (I=DefaultBufSize then - FBufSize:=Value; -end; - -procedure TUnZipper.SetFileName(Value: RawByteString); - -begin - If FUnZipping then - Raise EZipError.Create(SErrFileChange); - FFileName:=Value; -end; - -procedure TUnZipper.SetOutputPath(Value: RawByteString); - -Var - DS : RawByteString; - -begin - If FUnZipping then - Raise EZipError.Create(SErrFileChange); - FOutputPath:=Value; - If (FOutputPath<>'') and (FoutputPath[Length(FoutputPath)]<>DirectorySeparator) then - begin - // Preserve codepage of outputpath - DS:=DirectorySeparator; - SetCodePage(DS,StringCodePage(FoutputPath),False); - FOutputPath:=FoutputPath+DS; - end; -end; - -procedure TUnZipper.UnZipFiles(AFileName: RawByteString; FileList: TStrings); - -begin - FFileName:=AFileName; - UNzipFiles(FileList); -end; - -procedure TUnZipper.UnZipFiles(FileList: TStrings); -begin - FFiles.Assign(FileList); - UnZipAllFiles; -end; - -procedure TUnZipper.UnZipAllFiles(AFileName: RawByteString); - -begin - FFileName:=AFileName; - UnZipAllFiles; -end; - -procedure TUnZipper.DoEndOfFile; - -Var - ComprPct : Double; - Uncompressed: QWord; - Compressed: QWord; -begin - If LocalZip64Fld.Original_Size > 0 then - Uncompressed := LocalZip64Fld.Original_Size - else - Uncompressed := LocalHdr.Uncompressed_Size; - - If LocalZip64Fld.Compressed_Size > 0 then - Compressed := LocalZip64Fld.Compressed_Size - else - Compressed := LocalHdr.Compressed_Size; - - If (Compressed>0) and (Uncompressed>0) then - if (Compressed>Uncompressed) then - ComprPct := (-100.0 * (Compressed - Uncompressed)) / Uncompressed - else - ComprPct := (100.0 * (Uncompressed - Compressed)) / Uncompressed - else - ComprPct := 0; - If Assigned(FOnEndOfFile) then - FOnEndOfFile(Self,ComprPct); -end; - -constructor TUnZipper.Create; - -begin - FBufSize:=DefaultBufSize; - FFiles:=TStringList.Create; - TStringlist(FFiles).Sorted:=True; - FEntries:=TFullZipFileEntries.Create(TFullZipFileEntry); - FOnPercent:=1; -end; - -procedure TUnZipper.Clear; - -begin - FFiles.Clear; - FEntries.Clear; -end; - -procedure TUnZipper.Examine; -begin - if (FOnOpenInputStream = nil) and (FFileName='') then - Raise EZipError.Create(SErrNoFileName); - OpenInput; - If (FZipStream=nil) then - Raise EZipError.Create(SErrNoStream); - Try - ReadZipDirectory; - Finally - CloseInput; - end; -end; - -procedure TUnZipper.Terminate; -begin - FTerminated:=True; - if Assigned(FCurrentDecompressor) then - FCurrentDecompressor.Terminate; -end; - -destructor TUnZipper.Destroy; - -begin - Clear; - FreeAndNil(FFiles); - FreeAndNil(FEntries); - Inherited; -end; - -{ TZipFileEntry } - -function TZipFileEntry.GetArchiveFileName: String; -begin - Result:=FArchiveFileName; - If (Result='') then - Result:=FDiskFileName; -end; - -function TZipFileEntry.GetUTF8ArchiveFileName: UTF8String; -begin - Result:=FUTF8FileName; - If Result='' then - Result:=ArchiveFileName; -end; - -function TZipFileEntry.GetUTF8DiskFileName: UTF8String; -begin - Result:=FUTF8DiskFileName; - If Result='' then - Result:=DiskFileName; -end; - -constructor TZipFileEntry.Create(ACollection: TCollection); - -begin -{$IFDEF UNIX} - FOS := OS_UNIX; -{$ELSE} - FOS := OS_FAT; -{$ENDIF} - FCompressionLevel:=cldefault; - FDateTime:=now; - FNeedsZip64:=false; - FAttributes:=0; - - inherited create(ACollection); -end; - -function TZipFileEntry.IsDirectory: Boolean; -begin - Result := (DiskFileName <> '') and (DiskFileName[Length(DiskFileName)] = DirectorySeparator); - if Attributes <> 0 then - begin - case OS of - OS_FAT: Result := (faDirectory and Attributes) > 0; - OS_UNIX: Result := (Attributes and UNIX_MASK) = UNIX_DIR; - end; - end; -end; - -function TZipFileEntry.IsLink: Boolean; -begin - Result := False; - if Attributes <> 0 then - begin - case OS of - OS_FAT: Result := (faSymLink and Attributes) > 0; - OS_UNIX: Result := (Attributes and UNIX_MASK) = UNIX_LINK; - end; - end; -end; - -procedure TZipFileEntry.SetArchiveFileName(const AValue: String); - -begin - if FArchiveFileName=AValue then Exit; - // Zip standard: filenames inside the zip archive have / path separator - if DirectorySeparator='/' then - FArchiveFileName:=AValue - else - FArchiveFileName:=StringReplace(AValue, DirectorySeparator, '/', [rfReplaceAll]); -end; - -procedure TZipFileEntry.SetDiskFileName(const AValue: String); -begin - if FDiskFileName=AValue then Exit; - // Zip file uses / as directory separator on all platforms - // so convert to separator used on current OS - if DirectorySeparator='/' then - FDiskFileName:=AValue - else - FDiskFileName:=StringReplace(AValue,'/',DirectorySeparator,[rfReplaceAll]); -end; - -procedure TZipFileEntry.SetUTF8ArchiveFileName(AValue: UTF8String); -begin - FUTF8FileName:=AValue; - If ArchiveFileName='' then - if DefaultSystemCodePage<>CP_UTF8 then - ArchiveFileName:=Utf8ToAnsi(AValue) - else - ArchiveFileName:=AValue; -end; - -procedure TZipFileEntry.SetUTF8DiskFileName(AValue: UTF8String); -begin - FUTF8DiskFileName:=AValue; - If DiskFileName='' then - if DefaultRTLFileSystemCodePage<>CP_UTF8 then - DiskFileName:=Utf8ToAnsi(AValue) - else - DiskFileName:=AValue; -end; - - -procedure TZipFileEntry.Assign(Source: TPersistent); - -Var - Z : TZipFileEntry; - -begin - if Source is TZipFileEntry then - begin - Z:=Source as TZipFileEntry; - FArchiveFileName:=Z.FArchiveFileName; - FDiskFileName:=Z.FDiskFileName; - FSize:=Z.FSize; - FDateTime:=Z.FDateTime; - FStream:=Z.FStream; - FOS:=Z.OS; - FAttributes:=Z.Attributes; - end - else - inherited Assign(Source); -end; - -{ TZipFileEntries } - -function TZipFileEntries.GetZ(AIndex : Integer): TZipFileEntry; -begin - Result:=TZipFileEntry(Items[AIndex]); -end; - -procedure TZipFileEntries.SetZ(AIndex : Integer; const AValue: TZipFileEntry); -begin - Items[AIndex]:=AValue; -end; - -function TZipFileEntries.AddFileEntry(const ADiskFileName: String): TZipFileEntry; -begin - Result:=Add as TZipFileEntry; - Result.DiskFileName:=ADiskFileName; -end; - -function TZipFileEntries.AddFileEntry(const ADiskFileName, - AArchiveFileName: String): TZipFileEntry; -begin - Result:=AddFileEntry(ADiskFileName); - Result.ArchiveFileName:=AArchiveFileName; -end; - -function TZipFileEntries.AddFileEntry(const AStream: TSTream; - const AArchiveFileName: String): TZipFileEntry; -begin - Result:=Add as TZipFileEntry; - Result.Stream:=AStream; - Result.ArchiveFileName:=AArchiveFileName; -end; - -Procedure TZipFileEntries.AddFileEntries(Const List : TStrings); - -Var - I : integer; - -begin - For I:=0 to List.Count-1 do - AddFileEntry(List[i]); -end; - -{ TFullZipFileEntries } - -function TFullZipFileEntries.GetFZ(AIndex : Integer): TFullZipFileEntry; -begin - Result:=TFullZipFileEntry(Items[AIndex]); -end; - -procedure TFullZipFileEntries.SetFZ(AIndex : Integer; - const AValue: TFullZipFileEntry); -begin - Items[AIndex]:=AValue; -end; - -End. diff --git a/components/onlinepackagemanager/opkman_downloader.pas b/components/onlinepackagemanager/opkman_downloader.pas index 4c2c6b2946..a80f0c375d 100644 --- a/components/onlinepackagemanager/opkman_downloader.pas +++ b/components/onlinepackagemanager/opkman_downloader.pas @@ -29,10 +29,11 @@ unit opkman_downloader; interface uses - Classes, SysUtils, fpjson, LazIDEIntf, md5, + Classes, SysUtils, fpjson, md5, fphttpclient, opensslsockets, + // IdeIntf + LazIDEIntf, // OpkMan - opkman_common, opkman_serializablepackages, opkman_const, opkman_options, - {$IF FPC_FULLVERSION>=30200}fphttpclient, opensslsockets{$ELSE}opkman_httpclient{$ENDIF}; + opkman_common, opkman_serializablepackages, opkman_const, opkman_options; type TDownloadType = (dtJSON, dtPackage, dtUpdate); diff --git a/components/onlinepackagemanager/opkman_updates.pas b/components/onlinepackagemanager/opkman_updates.pas index ddc8de4cc0..c8235b4b86 100644 --- a/components/onlinepackagemanager/opkman_updates.pas +++ b/components/onlinepackagemanager/opkman_updates.pas @@ -30,16 +30,11 @@ interface uses {$IFDEF MSWINDOWS}windows, opkman_const,{$ENDIF} Classes, SysUtils, Controls, fpjson, fpjsonrtti, jsonparser, dateutils, + fphttpclient, opensslsockets, openssl, // LazUtils LazIDEIntf, LazFileUtils, // OpkMan - opkman_serializablepackages, opkman_options, opkman_common, opkman_visualtree, - opkman_OpenSSLfrm, - {$IF FPC_FULLVERSION>=30200} - zipper, fphttpclient, opensslsockets, openssl; - {$ELSE} - opkman_zip, opkman_httpclient; - {$ENDIF} + opkman_serializablepackages, opkman_options, opkman_common, opkman_visualtree; const OpkVersion = 1; @@ -130,7 +125,7 @@ var Updates: TUpdates = nil; implementation -uses opkman_mainfrm; + { TUpdatePackage } procedure TUpdatePackage.Clear; @@ -252,9 +247,7 @@ begin FreeOnTerminate := True; OnTerminate := @DoTerminated; FHTTPClient := TFPHTTPClient.Create(nil); - {$IF FPC_FULLVERSION>=30200} FHTTPClient.IOTimeout := Options.ConTimeOut*1000; - {$ENDIF} if Options.ProxyEnabled then begin FHTTPClient.Proxy.Host:= Options.ProxyServer; diff --git a/components/onlinepackagemanager/opkman_uploader.pas b/components/onlinepackagemanager/opkman_uploader.pas index f924489c75..6938b60245 100644 --- a/components/onlinepackagemanager/opkman_uploader.pas +++ b/components/onlinepackagemanager/opkman_uploader.pas @@ -29,10 +29,9 @@ unit opkman_uploader; interface uses - Classes, SysUtils, base64, + Classes, SysUtils, base64, fphttpclient, opensslsockets, // OpkMan - opkman_options, opkman_const, - {$IF FPC_FULLVERSION>=30200}fphttpclient, opensslsockets{$ELSE}opkman_httpclient{$ENDIF}; + opkman_options, opkman_const; type TOnUploadProgress = procedure(Sender: TObject; AFileName: String) of object; diff --git a/components/onlinepackagemanager/opkman_zipper.pas b/components/onlinepackagemanager/opkman_zipper.pas index b839690fbe..fe50a330ea 100644 --- a/components/onlinepackagemanager/opkman_zipper.pas +++ b/components/onlinepackagemanager/opkman_zipper.pas @@ -29,12 +29,11 @@ unit opkman_zipper; interface uses - Classes, SysUtils, strutils, + Classes, SysUtils, strutils, zipper, // LazUtils FileUtil, LazFileUtils, // OpkMan - opkman_serializablepackages, opkman_common, - {$IF FPC_FULLVERSION>=30200}zipper{$ELSE}opkman_zip{$ENDIF}; + opkman_serializablepackages, opkman_common; type TOnProgressEx = procedure(Sender : TObject; const ATotPos, ATotSize: Int64); diff --git a/components/projecttemplates/idetemplateproject.pp b/components/projecttemplates/idetemplateproject.pp index 0139fb2ef3..e3b5204312 100644 --- a/components/projecttemplates/idetemplateproject.pp +++ b/components/projecttemplates/idetemplateproject.pp @@ -277,7 +277,7 @@ begin Name:='Template Project'; FVariables:=TStringList.Create; FIgnoreExts:=TStringList.Create; - {$IF FPC_FULLVERSION>=30200}FIgnoreExts.UseLocale := false;{$ENDIF} + FIgnoreExts.UseLocale := false; FIgnoreExts.CommaText:='.lpr,.lps,.lfm,.lrs,.ico,.res,.lpi,.bak'; end; diff --git a/components/sparta/dockedformeditor/source/sparta_mainide.pas b/components/sparta/dockedformeditor/source/sparta_mainide.pas index 29cfc31717..a48eee8b3f 100644 --- a/components/sparta/dockedformeditor/source/sparta_mainide.pas +++ b/components/sparta/dockedformeditor/source/sparta_mainide.pas @@ -18,11 +18,7 @@ interface uses Classes, SysUtils, -{$IF FPC_FULLVERSION>=30200} Generics.Collections, Generics.Defaults, -{$ELSE} - sparta_Generics.Collections, sparta_Generics.Defaults, -{$ENDIF} contnrs, // LCL LCLIntf, LCLType, LMessages, ComCtrls, Controls, Forms, ExtCtrls, Graphics, diff --git a/components/sparta/mdi/source/sparta_basicfakecustom.pas b/components/sparta/mdi/source/sparta_basicfakecustom.pas index e802764f89..ec1e6144a0 100644 --- a/components/sparta/mdi/source/sparta_basicfakecustom.pas +++ b/components/sparta/mdi/source/sparta_basicfakecustom.pas @@ -205,16 +205,7 @@ procedure TFormImpl.SetRealBounds(AIndex: Integer; AValue: Integer); LFormRect := Rect(0, 0, 0, 0);; LCLIntf.GetClientRect(GetForm.Handle, LFormRect); LRealValue := GetRealBounds(AIndex); - {$IF FPC_FULLVERSION < 30101} - case AIndex of - 0: LValue := LFormRect.Left; - 1: LValue := LFormRect.Top; - 2: LValue := LFormRect.Right; - 3: LValue := LFormRect.Bottom; - end; - {$ELSE} LValue := LFormRect.Vector[AIndex]; - {$ENDIF} if LValue <> LRealValue then FDesignedRealForm.SetRealBounds(AIndex, AValue - (LRealValue - LValue)); diff --git a/components/sparta/mdi/source/sparta_multiplyresizer.pas b/components/sparta/mdi/source/sparta_multiplyresizer.pas index 0412101727..640b6cb0fc 100644 --- a/components/sparta/mdi/source/sparta_multiplyresizer.pas +++ b/components/sparta/mdi/source/sparta_multiplyresizer.pas @@ -7,11 +7,7 @@ interface uses Classes, SysUtils, Forms, Controls, LMessages, -{$IF FPC_FULLVERSION>=30200} Generics.Collections, -{$ELSE} - sparta_Generics.Collections, -{$ENDIF} sparta_AbstractResizer, sparta_InterfacesMDI, sparta_BasicResizeFrame; type diff --git a/components/sparta/smartformeditor/source/sparta_componentpalette.pas b/components/sparta/smartformeditor/source/sparta_componentpalette.pas index 7f7c95a4a3..1a51d4dbad 100644 --- a/components/sparta/smartformeditor/source/sparta_componentpalette.pas +++ b/components/sparta/smartformeditor/source/sparta_componentpalette.pas @@ -22,11 +22,7 @@ uses Controls, ComCtrls, ExtCtrls, Buttons, LResources, LCLType, Graphics, // LazUtils LazStringUtils, -{$IF FPC_FULLVERSION>=30200} Generics.Collections, -{$ELSE} - sparta_Generics.Collections, -{$ENDIF} // IdeIntf ComponentReg, LazIDEIntf, PropEdits, FormEditingIntf, IDEImagesIntf; diff --git a/components/sparta/toolsapi/source/designeditors.pas b/components/sparta/toolsapi/source/designeditors.pas index bf781196d7..5ff2403708 100644 --- a/components/sparta/toolsapi/source/designeditors.pas +++ b/components/sparta/toolsapi/source/designeditors.pas @@ -8,11 +8,7 @@ uses Classes, SysUtils, TypInfo, IniFiles, Menus, ComponentEditors, PropEdits, -{$IF FPC_FULLVERSION>=30200} Generics.Defaults, -{$ELSE} - sparta_Generics.Defaults, -{$ENDIF} DesignIntf, DesignMenus; type diff --git a/components/sqldb/registersqldb.pas b/components/sqldb/registersqldb.pas index 2b9abbf375..3ab8283ac7 100644 --- a/components/sqldb/registersqldb.pas +++ b/components/sqldb/registersqldb.pas @@ -32,10 +32,7 @@ unit registersqldb; {$DEFINE HASMYSQL4CONNECTION} {$DEFINE HASPQCONNECTION} {$DEFINE HASSQLITE3CONNECTION} - -{$IF (FPC_FULLVERSION>=30002) or not defined(win64)} - {$DEFINE HASORACLECONNECTION} -{$ENDIF} +{$DEFINE HASORACLECONNECTION} // MS SQL Server and Sybase ASE connectors were introduced in the FPC 2.7 development branch, // and backported to 2.6.1. Operating systems should match FPC packages\fcl-db\fpmake.pp diff --git a/components/sqldbrest/editor/schemaconns.pp b/components/sqldbrest/editor/schemaconns.pp index 282169a891..61711acc8b 100644 --- a/components/sqldbrest/editor/schemaconns.pp +++ b/components/sqldbrest/editor/schemaconns.pp @@ -8,10 +8,7 @@ unit schemaconns; {$DEFINE HASMYSQL4CONNECTION} {$DEFINE HASPQCONNECTION} {$DEFINE HASSQLITE3CONNECTION} - -{$IF (FPC_FULLVERSION>=30002) or not defined(win64)} - {$DEFINE HASORACLECONNECTION} -{$ENDIF} +{$DEFINE HASORACLECONNECTION} // MS SQL Server and Sybase ASE connectors were introduced in the FPC 2.7 development branch, // and backported to 2.6.1. Operating systems should match FPC packages\fcl-db\fpmake.pp diff --git a/components/synedit/synhighlighterany.pas b/components/synedit/synhighlighterany.pas index f51a3fecd4..a786a8d358 100644 --- a/components/synedit/synhighlighterany.pas +++ b/components/synedit/synhighlighterany.pas @@ -1139,7 +1139,7 @@ begin else HL.StringDelim:=sdSingleQuote; genlist:=TStringList.create; - {$IF FPC_FULLVERSION>=30200}genlist.UseLocale:=false;{$ENDIF} + genlist.UseLocale:=false; // read keywords hini.ReadSectionNames('Keywords',genlist); if genlist.count>0 then diff --git a/components/synedit/synhighlighterpas.pp b/components/synedit/synhighlighterpas.pp index b6962aa3ed..c1a226854d 100644 --- a/components/synedit/synhighlighterpas.pp +++ b/components/synedit/synhighlighterpas.pp @@ -5283,7 +5283,7 @@ var begin if KeywordsList = nil then begin KeywordsList := TStringList.Create; - {$IF FPC_FULLVERSION>=30200}KeywordsList.UseLocale := false;{$ENDIF} + KeywordsList.UseLocale := false; KeywordsList.CaseSensitive := true; for i := 1 to High(RESERVED_WORDS_TP) do KeywordsList.AddObject(RESERVED_WORDS_TP[i], TObject(pcmTP)); diff --git a/components/tachart/demo/fit/Main.pas b/components/tachart/demo/fit/Main.pas index fba7d7b35f..5899a746bb 100644 --- a/components/tachart/demo/fit/Main.pas +++ b/components/tachart/demo/fit/Main.pas @@ -479,12 +479,8 @@ end; procedure TfrmMain.FitCompleteHandler(Sender:TObject); const - {$IF FPC_FullVersion >= 30004} MASK = '%-4s %10s %10s %10s %10s'; CONF_MASK = '%-4s %10s %10s %10s'; - {$ELSE} - MASK = '%-4s %10s %10s %10s'; - {$IFEND} EXP_FMT = '%.3e'; STD_FMT = '%.3f'; PARAM_NAME: array[0..1] of String = ('a', 'b'); @@ -506,11 +502,7 @@ begin fitOK: begin Add('PARAMETERS'); - {$IF FPC_FullVersion >= 30004} Add(Format(MASK, ['Name', 'Value', 'Std.Error', 't value', 'p (>|t|)'])); - {$ELSE} - Add(Format(MASK, ['Name', 'Value', 'Std.Error', 't value'])); - {$IFEND} for i := 0 to FitSeries.ParamCount - 1 do begin case FitSeries.FitEquation of fePolynomial, feCustom: @@ -523,13 +515,10 @@ begin FloatToStrEx(FitSeries.Param[i], PRECISION, STD_FMT, EXP_FMT), FloatToStrEx(FitSeries.ParamError[i], PRECISION, STD_FMT, EXP_FMT), FloatToStrEx(FitSeries.Param_tValue[i], PRECISION, STD_FMT, EXP_FMT) - {$IF FPC_FullVersion >= 30004}, FloatToStrEx(FitSeries.Param_pValue[i], PRECISION, STD_FMT, EXP_FMT) - {$IFEND} ])); end; Add(''); - {$IF FPC_FullVersion >= 30004} Add('CONFIDENCE LIMITS'); Add(Format(CONF_MASK, ['Name', 'Value', 'Lower', 'Upper'])); for i := 0 to FitSeries.ParamCount - 1 do begin @@ -548,7 +537,6 @@ begin ])); end; Add(''); - {$IFEND} Add('ANALYSIS OF VARIANCE'); lbResults.Canvas.Font.Assign(lbResults.Font); FReportDecimals := 5; @@ -557,16 +545,13 @@ begin Add('VARIANCE-COVARIANCE MATRIX'); FitSeries.FitStatistics.Report_VarCovar(lbResults.Items); - {$IF FPC_FullVersion >= 30004} UpperConfIntervalSeries.OnCalculate := @FitSeries.GetUpperConfidenceInterval; LowerConfIntervalSeries.OnCalculate := @FitSeries.GetLowerConfidenceInterval; UpperPredIntervalSeries.OnCalculate := @FitSeries.GetUpperPredictionInterval; LowerPredIntervalSeries.OnCalculate := @FitSeries.GetLowerPredictionInterval; - {$IFEND} Add(''); Add('VALUES'); - {$IF FPC_FullVersion >= 30004} Add(Format('%8s %8s %8s %8s %8s %8s %8s', ['x', 'y', 'y hat', 'confL', 'confH', 'predL', 'predH'])); for i := 0 to FitSeries.Count-1 do begin @@ -578,15 +563,6 @@ begin FitSeries.XValue[i], FitSeries.YValue[i], FitSeries.Calculate(FitSeries.XValue[i]), confL, confH, predL, predH])); end; - {$ELSE} - Add(Format('%8s %8s %8s', ['x', 'y', 'y hat'])); - for i := 0 to FitSeries.Count-1 do - begin - Add(Format('%8.2f %8.2f %8.2f', [ - FitSeries.XValue[i], FitSeries.YValue[i], FitSeries.Calculate(FitSeries.XValue[i]) - ])); - end; - {$IFEND} ShowIntervalSeries(true); end; @@ -739,12 +715,10 @@ end; procedure TfrmMain.ShowIntervalSeries(AEnable: Boolean); begin - {$IF FPC_FullVersion > 30004} UpperConfIntervalSeries.Active := AEnable and cbShowConfidenceIntervals.Checked; LowerConfIntervalSeries.Active := AEnable and cbShowConfidenceIntervals.Checked; UpperPredIntervalSeries.Active := AEnable and cbShowPredictionIntervals.Checked; LowerPredIntervalSeries.Active := AEnable and cbShowPredictionIntervals.Checked; - {$IFEND} end; end. diff --git a/components/tachart/tafitutils.pas b/components/tachart/tafitutils.pas index ef05418d4b..b5210f4552 100644 --- a/components/tachart/tafitutils.pas +++ b/components/tachart/tafitutils.pas @@ -118,11 +118,9 @@ type property xBar: Double read fXBar; property SSx: Double read fSSx; public - {$IF FPC_FullVersion >= 30004} function Fcrit: Double; function pValue: Double; property tValue: Double read ftValue; - {$ENDIF} end; operator := (AEq: IFitEquationText): String; inline; @@ -439,10 +437,8 @@ end; procedure TFitStatistics.CalcTValue; begin fTValue := NaN; - {$IF FPC_FullVersion >= 30004} if (fAlpha > 0) and (fN > fM) then fTValue := invtdist(fAlpha, fN - fM, 2) - {$IFEND} end; { Total variance of data values minus calculated values, weighted by @@ -468,7 +464,6 @@ begin Result := NaN; end; -{$IF FPC_FullVersion >= 30004} function TFitStatistics.Fcrit: Double; begin if (M = 1) then @@ -476,14 +471,12 @@ begin else Result := InvFDist(FAlpha, M-1, N-M); end; -{$IFEND} function TFitStatistics.GetVarCovar(i, j: Integer): Double; begin Result := fVarCovar[i, j]; end; -{$IF FPC_FullVersion >= 30004} { Probability that the scatter of the data around the fitted curve is by chance. Should be several 0.1, the higher the better. According to Numerical Recipes, very small (<< 0.1) values mean @@ -499,7 +492,6 @@ begin else Result := NaN; end; -{$IFEND} { Variance normalized to the degrees of freedem. Should be about 1 for a "moderately" good fit. } @@ -547,10 +539,8 @@ begin AText.Add(Format('Fcrit(%d, %d)', [M-1, DOF]) + ASeparator + Format(IfThen(Fcrit < 1E-3, FMT, ANumFormat), [Fcrit])); } - {$IF FPC_FullVersion >= 30004} AText.Add(rsFitTValue + ASeparator + FloatToStrEx(FtValue, PRECISION, ANumFormat, AExpFormat, NaNStr)); AText.Add(rsFitPValue + ASeparator + FloatToStrEx(pValue, PRECISION, ANumFormat, AExpFormat, NaNStr)); - {$IFEND} end; procedure TFitStatistics.Report_VarCovar(AText: TStrings; ANumFormat: String = '%12.6f'); diff --git a/components/tachart/tafuncseries.pas b/components/tachart/tafuncseries.pas index 6590fac116..e4f86de62d 100644 --- a/components/tachart/tafuncseries.pas +++ b/components/tachart/tafuncseries.pas @@ -320,10 +320,8 @@ type procedure SetPen(AValue: TChartPen); procedure SetStep(AValue: TFuncSeriesStep); procedure SetUseCombinedExtentY(AValue: Boolean); - {$IF FPC_FullVersion >= 30004} procedure GetInterval(const Ax: Double; out AY: Double; IsUpper, IsPrediction: Boolean); function GetParam_pValue(AIndex: Integer): Double; - {$IFEND} strict protected procedure CalcXRange(out AXMin, AXMax: Double); function TransformX(AX: Double): Extended; inline; @@ -351,13 +349,11 @@ type function Extent: TDoubleRect; override; function EquationText: IFitEquationText; function FitParams: TDoubleDynArray; - {$IF FPC_FullVersion >= 30004} procedure GetConfidenceLimits(AIndex: Integer; out ALower, AUpper: Double); procedure GetLowerConfidenceInterval(const Ax: Double; out AY: Double); procedure GetUpperConfidenceInterval(const Ax: Double; out AY: Double); procedure GetLowerPredictionInterval(const Ax: Double; out AY: Double); procedure GetUpperPredictionInterval(const Ax: Double; out AY: Double); - {$IFEND} function GetNearestPoint( const AParams: TNearestPointParams; out AResults: TNearestPointResults): Boolean; override; @@ -366,9 +362,7 @@ type public // properties property Param[AIndex: Integer]: Double read GetParam; property ParamError[AIndex: Integer]: Double read GetParamError; - {$IF FPC_FullVersion >= 30004} property Param_pValue[AIndex: Integer]: Double read GetParam_pValue; - {$IFEND} property Param_tValue[AIndex: Integer]: Double read GetParam_tValue; property FitStatistics: TFitStatistics read FFitStatistics; property ConfidenceLevel: Double read FConfidenceLevel write SetConfidenceLevel; @@ -504,7 +498,7 @@ type implementation uses - {$IF FPC_FullVersion >= 30101}ipf{$ELSE}ipf_fix{$ENDIF}, + ipf, GraphType, GraphUtil, Math, spe, StrUtils, SysUtils, TAChartStrConsts, TAGeometry, TAGraph, TAMath; @@ -2010,7 +2004,6 @@ begin Result[i] := Param[i]; end; -{$IF FPC_FullVersion >= 30004} procedure TFitSeries.GetConfidenceLimits(AIndex: Integer; out ALower, AUpper: Double); var val, sig, t: Double; @@ -2082,7 +2075,6 @@ procedure TFitSeries.GetUpperPredictionInterval(const AX: Double; out AY: Double begin GetInterval(AX, AY, true, true); end; -{$IFEND} { Function removed, but left here commented to show useage of IEquationText. function TFitSeries.GetFitEquationString(ANumFormat: String; AXText: String; @@ -2183,7 +2175,6 @@ begin end; end; -{$IF FPC_FullVersion >= 30004} function TFitSeries.GetParam_pValue(AIndex: Integer): Double; var t: Double; @@ -2197,7 +2188,6 @@ begin else Result := tDist(t, FFitStatistics.DOF, 2); end; -{$IFEND} function TFitSeries.GetParam_RawError(AIndex: Integer): Double; var diff --git a/components/virtualtreeview/include/intf/laz.dummydragmanager.inc b/components/virtualtreeview/include/intf/laz.dummydragmanager.inc index 88ea3ca324..a2f919cdb0 100644 --- a/components/virtualtreeview/include/intf/laz.dummydragmanager.inc +++ b/components/virtualtreeview/include/intf/laz.dummydragmanager.inc @@ -533,8 +533,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TVTDataObject.SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; +function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; // Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement diff --git a/components/virtualtreeview/include/intf/win32/laz.vtvdragmanager.inc b/components/virtualtreeview/include/intf/win32/laz.vtvdragmanager.inc index e4c76c3411..3ba2b545e0 100644 --- a/components/virtualtreeview/include/intf/win32/laz.vtvdragmanager.inc +++ b/components/virtualtreeview/include/intf/win32/laz.vtvdragmanager.inc @@ -481,8 +481,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TVTDataObject.SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; +function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; // Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement diff --git a/components/virtualtreeview/laz.virtualtrees.pas b/components/virtualtreeview/laz.virtualtrees.pas index 2e7f023c1f..cf34e27945 100644 --- a/components/virtualtreeview/laz.virtualtrees.pas +++ b/components/virtualtreeview/laz.virtualtrees.pas @@ -851,8 +851,7 @@ type function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function GetDataHere(const {%H-}FormatEtc: TFormatEtc; out {%H-}Medium: TStgMedium): HResult; virtual; stdcall; function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; - function SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; + function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; end; @@ -14278,12 +14277,7 @@ asm PUSH EBX PUSH EDI PUSH ESI - {$if FPC_FULLVERSION >= 30100} MOV ESI, EDX - {$else} - MOV ECX, EDX //fpc < 3.1: count is in EDX. Move to ECX - MOV ESI, [EBP+8] //fpc < 3.1: TheArray is in EBP+8 - {$endif} MOV EDX, -1 JCXZ @@Finish // Empty list? INC EDX // init remaining entries counter diff --git a/components/virtualtreeview/units/carbon/laz.virtualdragmanager.pas b/components/virtualtreeview/units/carbon/laz.virtualdragmanager.pas index 54ce42a190..2642c3b510 100644 --- a/components/virtualtreeview/units/carbon/laz.virtualdragmanager.pas +++ b/components/virtualtreeview/units/carbon/laz.virtualdragmanager.pas @@ -265,8 +265,7 @@ type Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL; Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL; Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl; - Function SetData (Const pformatetc : FORMATETC; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} medium:STGMEDIUM; + Function SetData (Const pformatetc : FORMATETC; var medium:STGMEDIUM; FRelease : BOOL):HRESULT; StdCall; Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall; Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall; @@ -400,8 +399,7 @@ type function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; - function SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; + function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; end; @@ -1332,8 +1330,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TVTDataObject.SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; +function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; // Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement diff --git a/components/virtualtreeview/units/cocoa/laz.virtualdragmanager.pas b/components/virtualtreeview/units/cocoa/laz.virtualdragmanager.pas index f7edd99c4d..df64a1cbfc 100644 --- a/components/virtualtreeview/units/cocoa/laz.virtualdragmanager.pas +++ b/components/virtualtreeview/units/cocoa/laz.virtualdragmanager.pas @@ -265,8 +265,7 @@ type Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL; Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL; Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl; - Function SetData (Const pformatetc : FORMATETC; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} medium:STGMEDIUM; + Function SetData (Const pformatetc : FORMATETC; var medium:STGMEDIUM; FRelease : BOOL):HRESULT; StdCall; Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall; Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall; @@ -400,8 +399,7 @@ type function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; - function SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; + function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; end; diff --git a/components/virtualtreeview/units/gtk/laz.virtualdragmanager.pas b/components/virtualtreeview/units/gtk/laz.virtualdragmanager.pas index 9b76896f43..1d26ba4c0c 100644 --- a/components/virtualtreeview/units/gtk/laz.virtualdragmanager.pas +++ b/components/virtualtreeview/units/gtk/laz.virtualdragmanager.pas @@ -265,8 +265,7 @@ type Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL; Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL; Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl; - Function SetData (Const pformatetc : FORMATETC; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} medium:STGMEDIUM; + Function SetData (Const pformatetc : FORMATETC; var medium:STGMEDIUM; FRelease : BOOL):HRESULT; StdCall; Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall; Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall; @@ -400,8 +399,7 @@ type function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; - function SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; + function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; end; @@ -1332,8 +1330,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TVTDataObject.SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; +function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; // Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement diff --git a/components/virtualtreeview/units/gtk2/laz.virtualdragmanager.pas b/components/virtualtreeview/units/gtk2/laz.virtualdragmanager.pas index 54ce42a190..2642c3b510 100644 --- a/components/virtualtreeview/units/gtk2/laz.virtualdragmanager.pas +++ b/components/virtualtreeview/units/gtk2/laz.virtualdragmanager.pas @@ -265,8 +265,7 @@ type Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL; Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL; Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl; - Function SetData (Const pformatetc : FORMATETC; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} medium:STGMEDIUM; + Function SetData (Const pformatetc : FORMATETC; var medium:STGMEDIUM; FRelease : BOOL):HRESULT; StdCall; Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall; Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall; @@ -400,8 +399,7 @@ type function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; - function SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; + function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; end; @@ -1332,8 +1330,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TVTDataObject.SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; +function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; // Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement diff --git a/components/virtualtreeview/units/gtk3/laz.virtualdragmanager.pas b/components/virtualtreeview/units/gtk3/laz.virtualdragmanager.pas index ff7729bffd..d0ba243584 100644 --- a/components/virtualtreeview/units/gtk3/laz.virtualdragmanager.pas +++ b/components/virtualtreeview/units/gtk3/laz.virtualdragmanager.pas @@ -265,8 +265,7 @@ type Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL; Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL; Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl; - Function SetData (Const pformatetc : FORMATETC; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} medium:STGMEDIUM; + Function SetData (Const pformatetc : FORMATETC; var medium:STGMEDIUM; FRelease : BOOL):HRESULT; StdCall; Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall; Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall; @@ -400,8 +399,7 @@ type function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; - function SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; + function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; end; @@ -1332,8 +1330,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TVTDataObject.SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; +function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; // Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement diff --git a/components/virtualtreeview/units/laz.dummyactivex.inc b/components/virtualtreeview/units/laz.dummyactivex.inc index afac6164ee..a15e2d84f0 100644 --- a/components/virtualtreeview/units/laz.dummyactivex.inc +++ b/components/virtualtreeview/units/laz.dummyactivex.inc @@ -263,8 +263,7 @@ type Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL; Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL; Function GetCanonicalFormatEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl; - Function SetData (Const pformatetc : FORMATETC; - {$IF FPC_FullVersion >= 30200}var{$else}const{$IFEND} medium:STGMEDIUM; + Function SetData (Const pformatetc : FORMATETC; var medium:STGMEDIUM; FRelease : BOOL):HRESULT; StdCall; Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall; Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall; diff --git a/components/virtualtreeview/units/qt/laz.virtualdragmanager.pas b/components/virtualtreeview/units/qt/laz.virtualdragmanager.pas index 09c326d9db..f15d87fef4 100644 --- a/components/virtualtreeview/units/qt/laz.virtualdragmanager.pas +++ b/components/virtualtreeview/units/qt/laz.virtualdragmanager.pas @@ -265,8 +265,7 @@ type Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL; Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL; Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl; - Function SetData (Const pformatetc : FORMATETC; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} medium:STGMEDIUM; + Function SetData (Const pformatetc : FORMATETC; var medium:STGMEDIUM; FRelease : BOOL):HRESULT; StdCall; Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall; Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall; @@ -400,8 +399,7 @@ type function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; - function SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; + function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; end; @@ -1332,8 +1330,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TVTDataObject.SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; +function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; // Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement diff --git a/components/virtualtreeview/units/qt5/laz.virtualdragmanager.pas b/components/virtualtreeview/units/qt5/laz.virtualdragmanager.pas index b4729a8f38..4c809a44b1 100644 --- a/components/virtualtreeview/units/qt5/laz.virtualdragmanager.pas +++ b/components/virtualtreeview/units/qt5/laz.virtualdragmanager.pas @@ -265,8 +265,7 @@ type Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL; Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL; Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl; - Function SetData (Const pformatetc : FORMATETC; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} medium:STGMEDIUM; + Function SetData (Const pformatetc : FORMATETC; var medium:STGMEDIUM; FRelease : BOOL):HRESULT; StdCall; Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall; Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall; @@ -400,8 +399,7 @@ type function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; - function SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; + function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; end; @@ -1332,8 +1330,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TVTDataObject.SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; +function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; // Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement diff --git a/components/virtualtreeview/units/qt6/laz.virtualdragmanager.pas b/components/virtualtreeview/units/qt6/laz.virtualdragmanager.pas index 59b0c4f93e..5ae92599fc 100644 --- a/components/virtualtreeview/units/qt6/laz.virtualdragmanager.pas +++ b/components/virtualtreeview/units/qt6/laz.virtualdragmanager.pas @@ -265,8 +265,7 @@ type Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL; Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL; Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl; - Function SetData (Const pformatetc : FORMATETC; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} medium:STGMEDIUM; + Function SetData (Const pformatetc : FORMATETC; var medium:STGMEDIUM; FRelease : BOOL):HRESULT; StdCall; Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall; Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall; @@ -400,8 +399,7 @@ type function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; - function SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; + function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; end; @@ -1332,8 +1330,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TVTDataObject.SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; +function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; // Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement diff --git a/components/virtualtreeview/units/win32/laz.virtualdragmanager.pas b/components/virtualtreeview/units/win32/laz.virtualdragmanager.pas index 2daf97e668..21f7906ea0 100644 --- a/components/virtualtreeview/units/win32/laz.virtualdragmanager.pas +++ b/components/virtualtreeview/units/win32/laz.virtualdragmanager.pas @@ -145,8 +145,7 @@ type function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; - function SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; + function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; end; @@ -897,8 +896,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TVTDataObject.SetData(const FormatEtc: TFormatEtc; - {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium; +function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; // Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement diff --git a/components/wiki/lazwiki/wiki2chmconvert.pas b/components/wiki/lazwiki/wiki2chmconvert.pas index cfe3c8408b..6e5b8583b3 100644 --- a/components/wiki/lazwiki/wiki2chmconvert.pas +++ b/components/wiki/lazwiki/wiki2chmconvert.pas @@ -129,9 +129,7 @@ end; procedure TWiki2CHMConverter.AddIndexItem(AText, AUrl: String); var - {$IF FPC_FULLVERSION>=30200} x: integer; - {$ENDIF} AItem: TCHMSiteMapItem; i: Integer; txt, url, itemtxt, itemurl, itemlocal: String; @@ -148,7 +146,6 @@ begin for i:=0 to FIndexSiteMap.Items.Count-1 do begin AItem := FIndexSiteMap.Items.Item[i]; itemtxt := UTF8Lowercase(AItem.Text); - {$IF FPC_FULLVERSION>=30200} URL:=''; for x:=0 to AItem.SubItemcount-1 do begin @@ -159,9 +156,6 @@ begin if URL<>'' then break; end; - {$ELSE} - URL:=AItem.URL; - {$ENDIF} itemurl := UTF8Lowercase(URL); itemlocal := UTF8Lowercase(AItem.Local); if (txt = itemtxt) and ((url = itemurl) or (url = itemlocal)) then @@ -170,12 +164,7 @@ begin AItem := FIndexSiteMap.Items.NewItem; AItem.Text := UTF8Trim(AText); - {$IF FPC_FULLVERSION>=30200} AItem.AddLocal(AUrl); - {$ELSE} - AItem.Local := Trim(AUrl); - AItem.Keyword := UTF8Trim(AText); - {$ENDIF} end; procedure TWiki2CHMConverter.AddTocItem(ALevel: Integer; AText, AUrl: String); @@ -204,11 +193,7 @@ var item: TCHMSitemapItem; begin item := NewItemAtLevel(ALevel); - {$IF FPC_FULLVERSION>=30200} Item.AddLocal(AUrl); - {$ELSE} - item.Local := AUrl; - {$ENDIF} item.Text := EscapeToHTML(AText); item.ImageNumber := 0; end; diff --git a/components/wiki/wikiget.lpr b/components/wiki/wikiget.lpr index a065852182..0759246a33 100644 --- a/components/wiki/wikiget.lpr +++ b/components/wiki/wikiget.lpr @@ -37,12 +37,7 @@ uses CodeToolsStructs, // Wiki fphttpclient,HTTPDefs, - {$IF FPC_FULLVERSION >= 30200} opensslsockets, - {$ELSE} - fpopenssl, - openssl, - {$ENDIF} WikiParser, WikiFormat; const diff --git a/designer/jitforms.pp b/designer/jitforms.pp index 8905526d09..d6a48bd6c0 100644 --- a/designer/jitforms.pp +++ b/designer/jitforms.pp @@ -34,10 +34,6 @@ unit JITForms; {$I ide.inc} -{$IF FPC_FULLVERSION<30100} - {$DEFINE HasVMTParent} -{$ENDIF} - { $DEFINE VerboseJITForms} interface @@ -1535,12 +1531,8 @@ begin NewVMT^.vInstanceSize2:=-AncestorClass.InstanceSize; // set vmtParent - {$IFDEF HasVMTParent} - NewVMT^.vParent:=AncestorVMT; - {$ELSE} GetMem(NewVMT^.vParentRef,SizeOf(Pointer)); NewVMT^.vParentRef^:=AncestorVMT; - {$ENDIF} // set vmtClassName: create pointer to classname (PShortString) GetMem(ClassNamePShortString,SizeOf(ShortString)); @@ -1584,12 +1576,8 @@ begin // set TypeData (PropCount is the total number of properties, including ancestors) NewTypeData^.ClassType:=TClass(NewVMT); - {$IFDEF HasVMTParent} - NewTypeData^.ParentInfo:=AncestorClass.ClassInfo; - {$ELSE} GetMem(NewTypeData^.ParentInfoRef,SizeOf(Pointer)); NewTypeData^.ParentInfoRef^:=AncestorClass.ClassInfo; - {$ENDIF} NewTypeData^.PropCount:=GetTypeData(NewTypeData^.ParentInfo)^.PropCount; NewTypeData^.UnitName:=NewUnitName; AddedPropCount:=GetTypeDataPropCountAddr(NewTypeData); @@ -1637,9 +1625,7 @@ var OldFieldTable: PFieldTable; OldTypeInfo: PTypeInfo; OldMethodTable: PMethodNameTable; - {$IF FPC_FULLVERSION>=30100} OldTypeData: PTypeData; - {$ENDIF} begin // free TJITMethods JITMethods.DeleteAllOfClass(AClass); @@ -1654,9 +1640,7 @@ begin end; // set vmtParent - {$IFNDEF HasVMTParent} FreeMem(OldVMT^.vParentRef); - {$ENDIF} // free classname ClassNamePShortString:=Pointer(OldVMT^.vClassName); @@ -1669,12 +1653,10 @@ begin // free typeinfo OldTypeInfo:=PTypeInfo(OldVMT^.vTypeInfo); - {$IFNDEF HasVMTParent} // free ParentInfoRef OldTypeData:=GetTypeData(OldTypeInfo); FreeMem(OldTypeData^.ParentInfoRef); OldTypeData^.ParentInfoRef:=nil; - {$ENDIF} FreeMem(OldTypeInfo); // free vmt diff --git a/examples/jpeg_more/main.pas b/examples/jpeg_more/main.pas index 37ebf10294..0af5324f8c 100644 --- a/examples/jpeg_more/main.pas +++ b/examples/jpeg_more/main.pas @@ -135,9 +135,7 @@ begin try jpeg.LoadFromFile(filename); jpeg.CompressionQuality := SbQuality.Position; - {$IF FPC_FullVersion >= 30004} jpeg.GrayScale := CbGrayScale.Checked; - {$IFEND} jpeg.ProgressiveEncoding := CbProgressive.Checked; jpeg.SaveToFile(newFileName); finally @@ -171,9 +169,6 @@ begin LblProgressive.Caption := ''; BtnReadClick(nil); SbQualityChange(nil); - {$IF FPC_FullVersion < 30004} - CbGrayScale.Enabled := false; - {$ENDIF} end; function TForm1.GetFileName: String; diff --git a/ide/buildmodesmanager.pas b/ide/buildmodesmanager.pas index c35152ba5d..d1953edfe8 100644 --- a/ide/buildmodesmanager.pas +++ b/ide/buildmodesmanager.pas @@ -31,8 +31,7 @@ unit BuildModesManager; interface uses - Classes, SysUtils, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, System.UITypes, // LCL Forms, Dialogs, StdCtrls, Grids, Menus, ComCtrls, ButtonPanel, // LazUtils diff --git a/ide/compiler.pp b/ide/compiler.pp index e82d41c43b..089278b2ea 100644 --- a/ide/compiler.pp +++ b/ide/compiler.pp @@ -38,8 +38,7 @@ unit Compiler; interface uses - Classes, SysUtils, Contnrs, StrUtils, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, Contnrs, StrUtils, System.UITypes, // LazUtils FPCAdds, LazUTF8, LazFileUtils, LazUtilities, LazLoggerBase, // Codetools diff --git a/ide/compileroptions.pp b/ide/compileroptions.pp index f0a3160d73..b2d404e4e6 100644 --- a/ide/compileroptions.pp +++ b/ide/compileroptions.pp @@ -42,8 +42,7 @@ unit CompilerOptions; interface uses - Classes, SysUtils, Laz_AVL_Tree, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, Laz_AVL_Tree, System.UITypes, // LazUtils FileUtil, LazFileUtils, LazUTF8, Laz2_XMLCfg, Laz2_DOM, LazUtilities, LazTracer, LazStringUtils, FPCAdds, LazVersion, diff --git a/ide/customformeditor.pp b/ide/customformeditor.pp index a3461adaa1..6f721089f2 100644 --- a/ide/customformeditor.pp +++ b/ide/customformeditor.pp @@ -296,7 +296,7 @@ type procedure DefineBinaryProperty(const Name: string; {%H-}ReadData, {%H-}WriteData: TStreamProc; {%H-}HasData: Boolean); override; - procedure FlushBuffer; {$IF FPC_FULLVERSION >= 30200}override;{$ENDIF} + procedure FlushBuffer; override; property DefinePropertyNames: TStrings read FDefinePropertyNames; end; diff --git a/ide/dialogprocs.pas b/ide/dialogprocs.pas index 75c8406956..a09c7e822d 100644 --- a/ide/dialogprocs.pas +++ b/ide/dialogprocs.pas @@ -36,8 +36,7 @@ unit DialogProcs; interface uses - Classes, SysUtils, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, System.UITypes, // LCL LResources, Dialogs, ComCtrls, // LazUtils diff --git a/ide/diskdiffsdialog.pas b/ide/diskdiffsdialog.pas index 9c998a3b5f..58569785f7 100644 --- a/ide/diskdiffsdialog.pas +++ b/ide/diskdiffsdialog.pas @@ -29,8 +29,7 @@ interface uses // RTL + FCL - Classes, SysUtils, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, System.UITypes, // LCL Forms, StdCtrls, ExtCtrls, CheckLst, ButtonPanel, Buttons, // CodeTools diff --git a/ide/exttools.pas b/ide/exttools.pas index f9786dcf52..01bdb7e012 100644 --- a/ide/exttools.pas +++ b/ide/exttools.pas @@ -35,8 +35,7 @@ interface uses // RTL + FCL - Classes, SysUtils, math, process, Pipes, Laz_AVL_Tree, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, math, process, Pipes, Laz_AVL_Tree, System.UITypes, // LazUtils FileUtil, LazFileUtils, LazUtilities, LazLoggerBase, UTF8Process, LazUTF8, AvgLvlTree, diff --git a/ide/generatefppkgconfigurationdlg.pas b/ide/generatefppkgconfigurationdlg.pas index 08146c4fc5..2eeafba36c 100644 --- a/ide/generatefppkgconfigurationdlg.pas +++ b/ide/generatefppkgconfigurationdlg.pas @@ -319,17 +319,14 @@ begin end; function TGenerateFppkgConfigurationDialog.CheckFpcmkcfgQuality(out Note: string): TSDFilenameQuality; -{$IF FPC_FULLVERSION>30100} var FpcmkcfgExecutable: string; Proc: TProcessUTF8; S: string; Ver: TFPVersion; -{$ENDIF} begin Result := sddqCompatible; Note:=''; - {$IF FPC_FULLVERSION>30100} FpcmkcfgExecutable := FindFPCTool('fpcmkcfg'+GetExecutableExt, EnvironmentOptions.GetParsedCompilerFilename); if FpcmkcfgExecutable = '' then begin @@ -382,7 +379,6 @@ begin Proc.Free; end; end; - {$ENDIF} end; procedure TGenerateFppkgConfigurationDialog.FpcPrefixComboboxChange(Sender: TObject); @@ -417,11 +413,9 @@ end; procedure TGenerateFppkgConfigurationDialog.FppkgWriteConfigButtonClick(Sender: TObject); var Msg: string; -{$IF FPC_FULLVERSION>30100} FpcmkcfgExecutable, CompConfigFilename: string; Proc: TProcessUTF8; Fppkg: TFppkgHelper; -{$ENDIF} procedure ShowFpcmkcfgError; begin @@ -434,7 +428,6 @@ var end; begin - {$IF FPC_FULLVERSION>30100} try FpcmkcfgExecutable := FindFPCTool('fpcmkcfg'+GetExecutableExt, EnvironmentOptions.GetParsedCompilerFilename); if FpcmkcfgExecutable<>'' then @@ -497,7 +490,6 @@ begin fLastParsedFpcPrefix := ''; UpdateFppkgNote; - {$ENDIF} if CheckFppkgConfiguration(FFppkgCfgFilename, Msg)<>sddqCompatible then begin IDEMessageDialog(lisFppkgProblem, Format(lisFppkgWriteConfFailed, [Msg]), diff --git a/ide/ideinstances.pas b/ide/ideinstances.pas index 53af2ac013..6cc249a61f 100644 --- a/ide/ideinstances.pas +++ b/ide/ideinstances.pas @@ -37,12 +37,7 @@ unit IDEInstances; interface uses - Classes, sysutils, crc, Process, - {$IF (FPC_FULLVERSION >= 30101)} - AdvancedIPC, - {$ELSE} - LazAdvancedIPC, - {$ENDIF} + Classes, sysutils, crc, Process, AdvancedIPC, Controls, Dialogs, ExtCtrls, LCLIntf, LCLType, LazFileUtils, FileUtil, Laz2_XMLRead, Laz2_XMLWrite, Laz2_DOM, LazUTF8, UTF8Process, LazLoggerBase, diff --git a/ide/include/ide.inc b/ide/include/ide.inc index 3d500994bd..6aa2b3f93b 100644 --- a/ide/include/ide.inc +++ b/ide/include/ide.inc @@ -52,9 +52,7 @@ {$DEFINE EnableRedirectStdErr} {$ENDIF} -{$IF FPC_FULLVERSION>30100} - {$warn 6058 off} // cannot inline -{$ENDIF} +{$warn 6058 off} // cannot inline // end. diff --git a/ide/mainintf.pas b/ide/mainintf.pas index 0459078186..016f2c342c 100644 --- a/ide/mainintf.pas +++ b/ide/mainintf.pas @@ -59,8 +59,7 @@ uses {$IFDEF IDE_MEM_CHECK} MemCheck, {$ENDIF} - Classes, TypInfo, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, TypInfo, System.UITypes, // LCL Forms, // Codetools diff --git a/ide/multipastedlg.pas b/ide/multipastedlg.pas index 59b83a833e..2c2d6dddd4 100644 --- a/ide/multipastedlg.pas +++ b/ide/multipastedlg.pas @@ -92,9 +92,7 @@ var List: THistoryList; begin FContent := TStringList.Create; - {$IF FPC_FULLVERSION >= 30101} FContent.SkipLastLineBreak := True; - {$ENDIF} OnShow := @DoWatch; OnActivate := @DoWatch; diff --git a/ide/packages/ideconfig/environmentopts.pp b/ide/packages/ideconfig/environmentopts.pp index 2b0112d8c1..162a827e77 100644 --- a/ide/packages/ideconfig/environmentopts.pp +++ b/ide/packages/ideconfig/environmentopts.pp @@ -37,8 +37,7 @@ uses {$ifdef Windows} ShlObj, {$endif} - Classes, SysUtils, Contnrs, -{$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, Contnrs, System.UITypes, // LazUtils LazFileUtils, FileUtil, LazFileCache, LazConfigStorage, LazUTF8, LazStringUtils, Laz2_XMLCfg, Laz2_DOM, diff --git a/ide/publishmoduledlg.pas b/ide/publishmoduledlg.pas index 5c1c6052e9..ec054176a9 100644 --- a/ide/publishmoduledlg.pas +++ b/ide/publishmoduledlg.pas @@ -32,8 +32,7 @@ unit PublishModuleDlg; interface uses - Classes, SysUtils, StrUtils, Zipper, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, StrUtils, Zipper, System.UITypes, // LCL LCLType, Forms, StdCtrls, Dialogs, Buttons, ButtonPanel, LCLIntf, // LazUtils diff --git a/ide/sourcefilemanager.pas b/ide/sourcefilemanager.pas index 29a15434c4..bd5a71efb8 100644 --- a/ide/sourcefilemanager.pas +++ b/ide/sourcefilemanager.pas @@ -6021,9 +6021,7 @@ var ARestoreVisible: Boolean; NestedAncestorClass: TComponentClass; DsgControl: TCustomDesignControl; - {$IF (FPC_FULLVERSION >= 30003)} DsgDataModule: TDataModule; - {$ENDIF} AmbiguousClasses: TFPList; ResolvedClasses, ResolvedVars: TStringToPointerTree; begin @@ -6246,7 +6244,6 @@ begin end; DsgControl.PixelsPerInch := Screen.PixelsPerInch; end; - {$IF (FPC_FULLVERSION >= 30003)} // TDataModule.DesignPPI was added in FPC 3.0.3 if NewComponent is TDataModule then begin DsgDataModule := TDataModule(NewComponent); @@ -6262,7 +6259,6 @@ begin DsgDataModule.DesignPPI := Screen.PixelsPerInch; end; end; - {$ENDIF} if NewComponent<>nil then AnUnitInfo.ResourceBaseClass:=GetComponentBaseClass(NewComponent.ClassType); diff --git a/lcl/controls.pp b/lcl/controls.pp index 3d448e01f1..7ed05ac986 100644 --- a/lcl/controls.pp +++ b/lcl/controls.pp @@ -34,18 +34,10 @@ interface // {$DEFINE ASSERT_IS_ON} {$ENDIF} {$MACRO ON} - -{$IF FPC_FULLVERSION >= 30200} -{$DEFINE SysUITypes:=System.UITypes} -{$ELSE} -{$DEFINE SysUITypes:=UITypes} -{$ENDIF} - {$INTERFACES CORBA} uses - SysUITypes, - Classes, SysUtils, TypInfo, Types, Laz_AVL_Tree, + System.UITypes, Classes, SysUtils, TypInfo, Types, Laz_AVL_Tree, // LCL LCLStrConsts, LCLType, LCLProc, Graphics, LMessages, LCLIntf, InterfaceBase, ImgList, PropertyStorage, Menus, ActnList, LCLClasses, LResources, LCLPlatformDef, @@ -56,22 +48,22 @@ uses const // Used for ModalResult - mrNone = SysUITypes.mrNone; - mrOK = SysUITypes.mrOK; - mrCancel = SysUITypes.mrCancel; - mrAbort = SysUITypes.mrAbort; - mrRetry = SysUITypes.mrRetry; - mrIgnore = SysUITypes.mrIgnore; - mrYes = SysUITypes.mrYes; - mrNo = SysUITypes.mrNo; - mrAll = SysUITypes.mrAll; - mrNoToAll = SysUITypes.mrNoToAll; - mrYesToAll= SysUITypes.mrYesToAll; - mrClose = SysUITypes.mrClose; - mrLast = SysUITypes.mrLast; + mrNone = System.UITypes.mrNone; + mrOK = System.UITypes.mrOK; + mrCancel = System.UITypes.mrCancel; + mrAbort = System.UITypes.mrAbort; + mrRetry = System.UITypes.mrRetry; + mrIgnore = System.UITypes.mrIgnore; + mrYes = System.UITypes.mrYes; + mrNo = System.UITypes.mrNo; + mrAll = System.UITypes.mrAll; + mrNoToAll = System.UITypes.mrNoToAll; + mrYesToAll= System.UITypes.mrYesToAll; + mrClose = System.UITypes.mrClose; + mrLast = System.UITypes.mrLast; function GetModalResultStr(ModalResult: TModalResult): ShortString; - deprecated 'Use the ModalResultStr array from unit UITypes directly.'; + deprecated 'Use the ModalResultStr array from unit System.UITypes directly.'; property ModalResultStr[ModalResult: TModalResult]: shortstring read GetModalResultStr; const @@ -176,9 +168,9 @@ type TAlign = (alNone, alTop, alBottom, alLeft, alRight, alClient, alCustom); TAlignSet = set of TAlign; {$IF FPC_FULLVERSION >= 30300} - TAnchorKind = SysUITypes.TAnchorKind; - TAnchors = SysUITypes.TAnchors; - TAnchorSideReference = SysUITypes.TAnchorSideReference; + TAnchorKind = System.UITypes.TAnchorKind; + TAnchors = System.UITypes.TAnchors; + TAnchorSideReference = System.UITypes.TAnchorSideReference; {$ELSE} TAnchorKind = (akTop, akLeft, akRight, akBottom); TAnchors = set of TAnchorKind; @@ -187,14 +179,14 @@ type const {$IF FPC_FULLVERSION >= 30300} - akLeft = SysUITypes.akLeft; - akTop = SysUITypes.akTop; - akRight = SysUITypes.akRight; - akBottom = SysUITypes.akBottom; + akLeft = System.UITypes.akLeft; + akTop = System.UITypes.akTop; + akRight = System.UITypes.akRight; + akBottom = System.UITypes.akBottom; - asrTop = SysUITypes.asrTop; - asrBottom = SysUITypes.asrBottom; - asrCenter = SysUITypes.asrCenter; + asrTop = System.UITypes.asrTop; + asrBottom = System.UITypes.asrBottom; + asrCenter = System.UITypes.asrCenter; {$ENDIF} asrLeft = asrTop; @@ -219,18 +211,18 @@ type TBevelCut = TGraphicsBevelCut; {$IF FPC_FULLVERSION >= 30300} - TMouseButton = SysUITypes.TMouseButton; + TMouseButton = System.UITypes.TMouseButton; {$ELSE} TMouseButton = (mbLeft, mbRight, mbMiddle, mbExtra1, mbExtra2); {$ENDIF} const {$IF FPC_FULLVERSION >= 30300} - mbLeft = SysUITypes.mbLeft; - mbRight = SysUITypes.mbRight; - mbMiddle = SysUITypes.mbMiddle; - mbExtra1 = SysUITypes.mbExtra1; - mbExtra2 = SysUITypes.mbExtra2; + mbLeft = System.UITypes.mbLeft; + mbRight = System.UITypes.mbRight; + mbMiddle = System.UITypes.mbMiddle; + mbExtra1 = System.UITypes.mbExtra1; + mbExtra2 = System.UITypes.mbExtra2; {$ENDIF} fsAllStayOnTop = [fsStayOnTop, fsSystemStayOnTop]; @@ -468,10 +460,10 @@ type TDragObject = class; {$IF FPC_FULLVERSION >= 30300} - TDragKind = SysUITypes.TDragKind; - TDragMode = SysUITypes.TDragMode; - TDragState = SysUITypes.TDragState; - TDragMessage = SysUITypes.TDragMessage; + TDragKind = System.UITypes.TDragKind; + TDragMode = System.UITypes.TDragMode; + TDragState = System.UITypes.TDragState; + TDragMessage = System.UITypes.TDragMessage; {$ELSE} TDragKind = (dkDrag, dkDock); TDragMode = (dmManual , dmAutomatic); @@ -983,7 +975,7 @@ type TControlAutoSizePhases = set of TControlAutoSizePhase; {$IF FPC_FULLVERSION >= 30300} - TTabOrder = SysUITypes.TTabOrder; + TTabOrder = System.UITypes.TTabOrder; {$ELSE} TTabOrder = -1..32767; {$ENDIF} @@ -2786,22 +2778,22 @@ procedure Register; {$IF FPC_FULLVERSION >= 30300} const - dkDrag = SysUITypes.dkDrag; - dkDock = SysUITypes.dkDock; + dkDrag = System.UITypes.dkDrag; + dkDock = System.UITypes.dkDock; - dmManual = SysUITypes.dmManual; - dmAutomatic = SysUITypes.dmAutomatic; + dmManual = System.UITypes.dmManual; + dmAutomatic = System.UITypes.dmAutomatic; - dsDragEnter = SysUITypes.dsDragEnter; - dsDragLeave = SysUITypes.dsDragLeave; - dsDragMove = SysUITypes.dsDragMove; + dsDragEnter = System.UITypes.dsDragEnter; + dsDragLeave = System.UITypes.dsDragLeave; + dsDragMove = System.UITypes.dsDragMove; - dmDragEnter = SysUITypes.dmDragEnter; - dmDragLeave = SysUITypes.dmDragLeave; - dmDragMove = SysUITypes.dmDragMove; - dmDragDrop = SysUITypes.dmDragDrop; - dmDragCancel = SysUITypes.dmDragCancel; - dmFindTarget = SysUITypes.dmFindTarget; + dmDragEnter = System.UITypes.dmDragEnter; + dmDragLeave = System.UITypes.dmDragLeave; + dmDragMove = System.UITypes.dmDragMove; + dmDragDrop = System.UITypes.dmDragDrop; + dmDragCancel = System.UITypes.dmDragCancel; + dmFindTarget = System.UITypes.dmFindTarget; {$ENDIF} implementation @@ -3050,7 +3042,7 @@ end; function GetModalResultStr(ModalResult: TModalResult): ShortString; begin - Result := SysUITypes.ModalResultStr[ModalResult]; + Result := System.UITypes.ModalResultStr[ModalResult]; end; {------------------------------------------------------------------------------ @@ -4645,9 +4637,6 @@ end; initialization //DebugLn('controls.pp - initialization'); - {$IF FPC_FULLVERSION<30003} - RegisterPropertyToSkip(TDataModule, 'PPI', 'PPI was introduced in FPC 3.0.3', ''); - {$ENDIF} Mouse := TMouse.Create; DefaultDockManagerClass := TDockTree; DragManager := TDragManagerDefault.Create(nil); diff --git a/lcl/forms.pp b/lcl/forms.pp index af43b8120c..78650d3acf 100644 --- a/lcl/forms.pp +++ b/lcl/forms.pp @@ -33,20 +33,14 @@ interface uses // RTL + FCL - Classes, SysUtils, Types, TypInfo, Math, CustApp, + Classes, SysUtils, Types, TypInfo, Math, CustApp, System.UITypes, // LCL LCLStrConsts, LCLType, LCLProc, LCLIntf, LCLVersion, LCLClasses, InterfaceBase, LResources, Graphics, Menus, LMessages, CustomTimer, ActnList, ClipBrd, HelpIntfs, Controls, ImgList, Themes, // LazUtils LazFileUtils, LazUTF8, Maps, IntegerList, LazMethodList, LazLoggerBase, - LazUtilities, GraphType, - {$IF FPC_FULLVERSION >= 30200} - System.UITypes - {$ELSE} - UITypes - {$ENDIF} - ; + LazUtilities, GraphType; type TProcedure = procedure; @@ -482,13 +476,8 @@ type ); TFormState = set of TFormStateType; - {$IF FPC_FULLVERSION >= 30200} TModalResult = System.UITypes.TModalResult; PModalResult = ^System.UITypes.TModalResult; - {$ELSE} - TModalResult = UITypes.TModalResult; - PModalResult = ^UITypes.TModalResult; - {$ENDIF} TFormHandlerType = ( fhtFirstShow, diff --git a/lcl/graphics.pp b/lcl/graphics.pp index 994847b97d..b4ffc0487f 100644 --- a/lcl/graphics.pp +++ b/lcl/graphics.pp @@ -28,9 +28,6 @@ interface {$DEFINE HasFPCanvas1} {$DEFINE HasFPEndCap} {$DEFINE HasFPJoinStyle} -{$IF FPC_FULLVERSION>=30203} -{$DEFINE UseSystemUITypes} -{$ENDIF} uses // RTL + FCL @@ -50,9 +47,7 @@ uses {$IFNDEF DisableLCLGIF} FPReadGif, {$ENDIF} - {$IFDEF UseSystemUITypes} System.UITypes, - {$ENDIF} // LCL LCLVersion, LCLStrConsts, LCLType, LCLProc, LMessages, LResources, LCLResCache, IntfGraphics, IcnsTypes, WSReferences, @@ -60,7 +55,7 @@ uses GraphType, GraphMath, FPCAdds, LazLoggerBase, LazTracer, LazUtilities; type - PColor = {$IFDEF UseSystemUITypes}System.UITypes.PColor{$ELSE}^TColor{$ENDIF}; + PColor = System.UITypes.PColor; TColor = TGraphicsColor; {$IF FPC_FULLVERSION>=30300} @@ -1811,7 +1806,7 @@ type class function GetFileExtensions: string; override; public property CompressionQuality: TJPEGQualityRange read FQuality write SetCompressionQuality; - property GrayScale: Boolean read FGrayScale {$IF FPC_FullVersion >= 30004} write SetGrayScale{$IFEND}; + property GrayScale: Boolean read FGrayScale write SetGrayScale; property MinHeight: Integer read FMinHeight write FMinHeight; property MinWidth: Integer read FMinWidth write FMinWidth; property ProgressiveEncoding: boolean read FProgressiveEncoding write SetProgressiveEncoding; diff --git a/lcl/include/clipbrd.inc b/lcl/include/clipbrd.inc index 3b05955a33..c32e9424ba 100644 --- a/lcl/include/clipbrd.inc +++ b/lcl/include/clipbrd.inc @@ -879,12 +879,8 @@ begin exit; {$IFDEF WINDOWS} - {$IF FPC_FULLVERSION >= 30101} Stream := TStringStream.Create(InsertClipHeader(Html), DefaultSystemCodePage); {$ELSE} - Stream := TStringStream.Create(InsertClipHeader(Html)); - {$ENDIF} - {$ELSE} Stream := TStringStream.Create(Html); {$ENDIF} try diff --git a/lcl/include/icon.inc b/lcl/include/icon.inc index 3599b403a3..d18486e4b0 100644 --- a/lcl/include/icon.inc +++ b/lcl/include/icon.inc @@ -870,10 +870,6 @@ begin if QWord(PNGComn.Signature) = QWord(PNGSig) then begin - {$if FPC_FULLVERSION < 30200} - //workaround for fpc bug #0034185 (dangling FPalette pointer in TFPReaderPNG.InternalRead causes AV) - if Assigned(PNGReader) then FreeAndNil(PngReader); - {$ENDIF} if PNGReader = nil then PNGReader := TLazReaderPNG.Create; ImgReader := PNGReader; diff --git a/lcl/include/jpegimage.inc b/lcl/include/jpegimage.inc index 75ce4fbf56..89d988da89 100644 --- a/lcl/include/jpegimage.inc +++ b/lcl/include/jpegimage.inc @@ -95,9 +95,7 @@ begin if not(AWriter is TFPWriterJPEG) then Exit; TFPWriterJPEG(AWriter).ProgressiveEncoding := ProgressiveEncoding; TFPWriterJPEG(AWriter).CompressionQuality := CompressionQuality; - {$IF FPC_FullVersion >= 30004} TFPWriterJPEG(AWriter).GrayScale := GrayScale; - {$IFEND} end; procedure TJPEGImage.SetCompressionQuality(AValue: TJPEGQualityRange); diff --git a/lcl/inipropstorage.pas b/lcl/inipropstorage.pas index 8cf4b23e45..e72f354edf 100644 --- a/lcl/inipropstorage.pas +++ b/lcl/inipropstorage.pas @@ -93,7 +93,7 @@ begin end; FReadOnly:=ReadOnly; if not (csDesigning in ComponentState) then - FInifile:=IniFileClass.Create(GetIniFileName{$IF FPC_FULLVERSION>=30101}, TEncoding.UTF8{$ENDIF}); + FInifile:=IniFileClass.Create(GetIniFileName, TEncoding.UTF8); end; Inc(FCount); end; diff --git a/lcl/interfaces/cocoa/cocoa_extra.pas b/lcl/interfaces/cocoa/cocoa_extra.pas index 62a8c1c590..1fae75a4e8 100644 --- a/lcl/interfaces/cocoa/cocoa_extra.pas +++ b/lcl/interfaces/cocoa/cocoa_extra.pas @@ -27,19 +27,13 @@ uses // Libs MacOSAll, CocoaAll; -{$if FPC_FULLVERSION>=30200} {$define HASObjCBOOL} -{$endif} type // Due to backwards incompatible changes in FPC sources // (switching from Boolean to Boolean8), LCL has to adopt // either type, depending on FPC version - LCLObjCBoolean = {$ifdef HASObjCBOOL} - ObjCBOOL - {$else} - Boolean // FPC 3.0.4 and earlier are using "boolean" type - {$endif}; + LCLObjCBoolean = ObjCBOOL; type NSImageScaling = NSUInteger; @@ -75,13 +69,6 @@ type procedure setEnabled_(aenabled: ObjCBool); message 'setEnabled:'; end; -{$if FPC_FULLVERSION < 30200} - NSAppearance = objcclass external(NSObject) - function name: NSString; message 'name'; - class function currentAppearance: NSAppearance; message 'currentAppearance'; - end; -{$endif} - NSApplicationFix = objccategory external (NSApplication) {$ifdef BOOLFIX} procedure activateIgnoringOtherApps_(flag: ObjCBool); message 'activateIgnoringOtherApps:'; @@ -307,12 +294,10 @@ const NSTableViewAnimationSlideRight = $40; // Animates a row in by sliding from the right. Animates a row out by sliding towards the right. -{$if FPC_FULLVERSION >= 30200} // all of the sudden those are gone! in FPC 3.2.0rc const NSVariableStatusItemLength = -1; NSSquareStatusItemLength = -2; -{$endif} type NSSavePanelFix = objccategory external (NSSavePanel) diff --git a/lcl/interfaces/cocoa/cocoadefines.inc b/lcl/interfaces/cocoa/cocoadefines.inc index 11ecefc387..8c43f13fe5 100644 --- a/lcl/interfaces/cocoa/cocoadefines.inc +++ b/lcl/interfaces/cocoa/cocoadefines.inc @@ -15,12 +15,7 @@ {$define USE_IOS_VALUES} {$endif} -{$if FPC_FULLVERSION>=30200} {$undef BOOLFIX} -{$else} -{$define BOOLFIX} -{$endif} - // Originally LCL-Cocoa would override "run" method and have direct control // over the event loop. However that presumed to cause issues in macOS 10.15 diff --git a/lcl/interfaces/cocoa/cocoaint.pas b/lcl/interfaces/cocoa/cocoaint.pas index 39597f1666..c78110c8a0 100644 --- a/lcl/interfaces/cocoa/cocoaint.pas +++ b/lcl/interfaces/cocoa/cocoaint.pas @@ -98,7 +98,7 @@ type function runModalForWindow(theWindow: NSWindow): NSInteger; override; procedure lclSyncCheck(arg: id); message 'lclSyncCheck:'; {$ifdef COCOAPPRUNNING_OVERRIDEPROPERTY} - function isRunning: {$if FPC_FULLVERSION >= 30200}objc.ObjCBOOL{$else}Boolean{$endif}; override; + function isRunning: objc.ObjCBOOL; override; procedure stop(sender: id); override; {$endif} end; @@ -732,7 +732,7 @@ begin end; {$ifdef COCOAPPRUNNING_OVERRIDEPROPERTY} -function TCocoaApplication.isRunning: {$if FPC_FULLVERSION >= 30200}objc.ObjCBOOL{$else}Boolean{$endif}; +function TCocoaApplication.isRunning: objc.ObjCBOOL; begin Result:=not Stopped; end; diff --git a/lcl/interfaces/cocoa/cocoatables.pas b/lcl/interfaces/cocoa/cocoatables.pas index f0065b9479..498dda60e6 100644 --- a/lcl/interfaces/cocoa/cocoatables.pas +++ b/lcl/interfaces/cocoa/cocoatables.pas @@ -232,8 +232,8 @@ type procedure setCheckAction(aSelector: SEL); message 'setCheckAction:'; procedure setTextAction(aSelector: SEL); message 'setTextAction:'; procedure resizeSubviewsWithOldSize(oldSize: NSSize); override; - procedure setIdentifier(identifier_: NSString); message 'setIdentifier:'; {$if FPC_FULLVERSION >= 30200}override;{$endif} - function identifier: NSString; message 'identifier'; {$if FPC_FULLVERSION >= 30200}override;{$endif} + procedure setIdentifier(identifier_: NSString); message 'setIdentifier:'; override; + function identifier: NSString; message 'identifier'; override; function textFrame: NSRect; message 'textFrame'; procedure lclSetEnabled(AEnabled: Boolean); override; end; diff --git a/lcl/interfaces/customdrawn/customdrawnwinapi_win.inc b/lcl/interfaces/customdrawn/customdrawnwinapi_win.inc index df886c5719..3001ab29f0 100644 --- a/lcl/interfaces/customdrawn/customdrawnwinapi_win.inc +++ b/lcl/interfaces/customdrawn/customdrawnwinapi_win.inc @@ -1303,13 +1303,8 @@ begin Rec.LParam := LParam; Rec.CallBack := CallBack; LFW.lfFaceName := UTF8ToUTF16(FontName); - {$if fpc_fullversion < 30101} - Result := LongInt(Windows.EnumFontFamiliesExW(DC, - LFW, windows.FontEnumExProc(@EnumExProcRedirW), Windows.LParam(@Rec), Flags)); - {$else} Result := LongInt(Windows.EnumFontFamiliesExW(DC, LFW, windows.FontEnumExProcW(@EnumExProcRedirW), Windows.LParam(@Rec), Flags)); - {$ifend} end; (*{------------------------------------------------------------------------------ diff --git a/lcl/interfaces/gtk3/gtk3boxes.pas b/lcl/interfaces/gtk3/gtk3boxes.pas index 64cdd488df..f1a2d063d9 100644 --- a/lcl/interfaces/gtk3/gtk3boxes.pas +++ b/lcl/interfaces/gtk3/gtk3boxes.pas @@ -13,7 +13,7 @@ unit Gtk3Boxes; interface uses - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + System.UITypes, // LCL LCLType, LCLStrConsts,LCLProc, InterfaceBase, LazGtk3, LazGLib2, LazGObject2, LazGdk3, gtk3objects; diff --git a/lcl/interfaces/mui/muiglobal.pas b/lcl/interfaces/mui/muiglobal.pas index a0cadc0619..1b7d9ec341 100644 --- a/lcl/interfaces/mui/muiglobal.pas +++ b/lcl/interfaces/mui/muiglobal.pas @@ -44,14 +44,6 @@ const RPTAG_BGCOLOR = RPTAG_BPENCOLOR; RPTAG_PENMODE = TAG_IGNORE; {$endif} -{$if defined(Amiga68k) and (FPC_FULLVERSION<30101)} -const - IECODE_MBUTTON = $6A; - IECODE_UP_PREFIX = $80; - MIDDLEUP = IECODE_MBUTTON + IECODE_UP_PREFIX; - MIDDLEDOWN = IECODE_MBUTTON; -{$endif} - type THookFunc = function(Hook: PHook; Obj: PObject_; Msg: Pointer): LongInt; @@ -110,11 +102,7 @@ begin Result := nil; if Port <> nil then begin - {$if FPC_FULLVERSION<30101} - Result := Exec.AllocMem(Size, MEMF_CLEAR); - {$else} Result := ExecAllocMem(Size, MEMF_CLEAR); - {$endif} if Result <> nil then begin Result^.io_Message.mn_Node.ln_Type := 7; @@ -143,11 +131,7 @@ begin SigBit := AllocSignal(-1); if SigBit = -1 then Exit; - {$if FPC_FULLVERSION<30101} - Result := Exec.AllocMem(SizeOf(TMsgPort), MEMF_CLEAR); - {$else} Result := ExecAllocMem(SizeOf(TMsgPort), MEMF_CLEAR); - {$endif} if Result = nil then begin FreeSignal(SigBit); diff --git a/lcl/interfaces/win32/win32winapi.inc b/lcl/interfaces/win32/win32winapi.inc index d26b5c3209..ec207900ad 100644 --- a/lcl/interfaces/win32/win32winapi.inc +++ b/lcl/interfaces/win32/win32winapi.inc @@ -1390,13 +1390,8 @@ begin Rec.LParam := LParam; Rec.CallBack := CallBack; LFW.lfFaceName := UTF8ToUTF16(FontName); - {$if fpc_fullversion < 30101} - Result := LongInt(Windows.EnumFontFamiliesExW(DC, - LFW, windows.FontEnumExProc(@EnumExProcRedirW), Windows.LParam(@Rec), Flags)); - {$else} Result := LongInt(Windows.EnumFontFamiliesExW(DC, LFW, windows.FontEnumExProcW(@EnumExProcRedirW), Windows.LParam(@Rec), Flags)); - {$ifend} end; {------------------------------------------------------------------------------ diff --git a/lcl/lclproc.pas b/lcl/lclproc.pas index 18b3b5f308..c1645c16d6 100644 --- a/lcl/lclproc.pas +++ b/lcl/lclproc.pas @@ -1925,9 +1925,7 @@ initialization BackTraceStrFunc := @SysBackTraceStr; {$endif} {$ifdef AROS} - {$if FPC_FULLVERSION>=30101} - EnableBackTraceStr; - {$endif} + EnableBackTraceStr; {$endif} InterfaceInitializationHandlers := TFPList.Create; InterfaceFinalizationHandlers := TFPList.Create; diff --git a/lcl/lcltype.pp b/lcl/lcltype.pp index 2831822cfb..fe21d019e2 100644 --- a/lcl/lcltype.pp +++ b/lcl/lcltype.pp @@ -39,10 +39,6 @@ interface {$ASSERTIONS ON} {$endif} -{$if FPC_FULLVERSION >= 30203} -{$define UseSystemUITypes} -{$endif} - uses {$IFDEF USE_UTF8BIDI_LCL} UTF8BIDI, @@ -50,9 +46,7 @@ uses {$ifdef WINDOWS} windows, {$endif WINDOWS} -{$ifdef UseSystemUITypes} System.UITypes, -{$endif} Classes, SysUtils, WSReferences; @@ -1668,7 +1662,7 @@ const //============================================== type - COLORREF = {$ifdef UseSystemUITypes}System.UITypes.TColorRef{$else}Cardinal{$endif}; + COLORREF = System.UITypes.TColorRef; TColorRef = COLORREF; const diff --git a/lcl/lresources.pp b/lcl/lresources.pp index 8a5d41c80d..e07b812045 100644 --- a/lcl/lresources.pp +++ b/lcl/lresources.pp @@ -249,7 +249,7 @@ type procedure FlushStackToStream; procedure WriteToStream(const Buffer; Count: Longint); protected - procedure FlushBuffer; {$IF FPC_FULLVERSION >= 30200}override;{$ENDIF} + procedure FlushBuffer; override; procedure WriteValue(Value: TValueType); procedure WriteStr(const Value: String); procedure WriteIntegerContent(i: integer); diff --git a/lcl/widgetset/wslclclasses.pp b/lcl/widgetset/wslclclasses.pp index e090e12304..919c4a7469 100644 --- a/lcl/widgetset/wslclclasses.pp +++ b/lcl/widgetset/wslclclasses.pp @@ -397,11 +397,7 @@ begin ANode^.VClassName := '(V)' + ANode^.WSClass.ClassName; PPointer(ANode^.VClass + vmtClassName)^ := @ANode^.VClassName; // Adjust classparent - {$IF (FPC_FULLVERSION >= 30101)} PPointer(ANode^.VClass + vmtParent)^ := @ParentWSNode^.WSClass; - {$ELSE} - PPointer(ANode^.VClass + vmtParent)^ := ParentWSNode^.WSClass; - {$ENDIF} // Delete methodtable entry PPointer(ANode^.VClass + vmtMethodTable)^ := nil; end; diff --git a/packager/fppkghelper.pas b/packager/fppkghelper.pas index ff733109c8..74a7c306c4 100644 --- a/packager/fppkghelper.pas +++ b/packager/fppkghelper.pas @@ -7,12 +7,10 @@ interface uses Classes, SysUtils, - {$IF FPC_FULLVERSION>30100} pkgFppkg, fpmkunit, fprepos, LazarusIDEStrConsts, - {$ENDIF} // LazUtils LazLogger, LazFileCache, FileUtil, LazFileUtils; @@ -26,9 +24,7 @@ type TFppkgHelper = class private - {$IF FPC_FULLVERSION>30100} FFPpkg: TpkgFPpkg; - {$ENDIF} FIsProperlyConfigured: TFppkgPropConfigured; FConfStatusMessage: string; FOverrideConfigurationFilename: string; @@ -61,10 +57,6 @@ var { TFppkgHelper } procedure TFppkgHelper.InitializeFppkg; -{$IF NOT (FPC_FULLVERSION>30100)} -begin -end; -{$ELSE} var FPpkg: TpkgFPpkg; begin @@ -94,7 +86,6 @@ begin FPpkg.Free; end; end; -{$ENDIF FPC_FULLVERSION>30100} constructor TFppkgHelper.Create; begin @@ -103,9 +94,7 @@ end; destructor TFppkgHelper.Destroy; begin -{$IF FPC_FULLVERSION>30100} FFPpkg.Free; -{$ENDIF FPC_FULLVERSION>30100} inherited Destroy; end; @@ -117,14 +106,9 @@ begin end; function TFppkgHelper.HasPackage(const PackageName: string): Boolean; -{$IF FPC_FULLVERSION>30100} var Msg: string; -{$ENDIF} begin -{$IF NOT (FPC_FULLVERSION>30100)} - Result := HasFPCPackagesOnly(PackageName); -{$ELSE } if IsProperlyConfigured(Msg) then begin Result := @@ -146,18 +130,14 @@ begin end else Result := HasFPCPackagesOnly(PackageName); -{$ENDIF FPC_FULLVERSION>30100} end; procedure TFppkgHelper.ListPackages(AList: TStringList); -{$IF FPC_FULLVERSION>30100} var I, J: Integer; Repository: TFPRepository; -{$ENDIF FPC_FULLVERSION>30100} begin AList.Clear; -{$IF FPC_FULLVERSION>30100} if not Assigned(FFPpkg) then Exit; for I := 0 to FFPpkg.RepositoryList.Count -1 do @@ -168,23 +148,16 @@ begin AList.AddObject(Repository.Packages[J].Name, Repository.Packages[J]); end; end; -{$ENDIF FPC_FULLVERSION>30100} end; function TFppkgHelper.GetPackageUnitPath(const PackageName: string): string; -{$IF FPC_FULLVERSION>30100} var FppkgPackage: TFPPackage; {$IF not (FPC_FULLVERSION>30300)} PackageVariantsArray: TFppkgPackageVariantArray; {$ENDIF} i: Integer; -{$ENDIF FPC_FULLVERSION>30100} begin -{$IF NOT (FPC_FULLVERSION>30100)} - if PackageName='' then ; - Result := ''; -{$ELSE} if not Assigned(FFPpkg) then begin Result := ''; @@ -215,27 +188,18 @@ begin // be installed into, and use the corresponding packagestructure. Result := ''; end; -{$ENDIF FPC_FULLVERSION>30100} end; function TFppkgHelper.GetPackageVariantArray(const PackageName: string): TFppkgPackageVariantArray; -{$IF FPC_FULLVERSION>30100} var FppkgPackage: TFPPackage; UnitConfigFile: TStringList; PackageVariantStr, PackageVariant, UnitConfigFilename: String; PackageVariantOptions: TStringArray; i: Integer; -{$ENDIF FPC_FULLVERSION>30100} begin - {$IF FPC_FULLVERSION>30100} Result := []; - {$ELSE} - SetLength(Result, 0); - if PackageName='' then ; - {$ENDIF FPC_FULLVERSION>30100} - {$IF FPC_FULLVERSION>30100} if not Assigned(FFPpkg) then begin Result := []; @@ -270,17 +234,13 @@ begin end; end end - {$ENDIF FPC_FULLVERSION>30100} end; function TFppkgHelper.IsProperlyConfigured(out Message: string): Boolean; -{$IF FPC_FULLVERSION>30100} var CompilerFilename: string; -{$ENDIF FPC_FULLVERSION>30100} begin Message := ''; - {$IF FPC_FULLVERSION>30100} if Assigned(FFPpkg) and (FIsProperlyConfigured=fpcUnknown) then begin FIsProperlyConfigured := fpcYes; @@ -324,9 +284,6 @@ begin end; end; result := FIsProperlyConfigured=fpcYes; - {$ELSE} - result := True; - {$ENDIF FPC_FULLVERSION>30100} Message := FConfStatusMessage; end; @@ -468,31 +425,24 @@ end; function TFppkgHelper.GetCompilerFilename: string; begin Result := ''; - {$IF FPC_FULLVERSION>30100} if Assigned(FFPpkg) then begin Result := FFPpkg.CompilerOptions.Compiler; end; - {$ENDIF} end; procedure TFppkgHelper.ReInitialize; begin FIsProperlyConfigured := fpcUnknown; - {$IF FPC_FULLVERSION>30100} FreeAndNil(FFPpkg); - {$ENDIF} InitializeFppkg; end; function TFppkgHelper.GetCompilerConfigurationFileName: string; -{$IF FPC_FULLVERSION>30100} var FPpkg: TpkgFPpkg; -{$ENDIF} begin Result := ''; - {$IF FPC_FULLVERSION>30100} if Assigned(FFPpkg) then Result:=ConcatPaths([FFPpkg.Options.GlobalSection.CompilerConfigDir, FFPpkg.Options.CommandLineSection.CompilerConfig]) else @@ -510,7 +460,6 @@ begin FPpkg.Free; end; end - {$ENDIF} end; function TFppkgHelper.GetConfigurationFileName: string; diff --git a/packager/packagedefs.pas b/packager/packagedefs.pas index f14757b0a6..1975e603c4 100644 --- a/packager/packagedefs.pas +++ b/packager/packagedefs.pas @@ -39,7 +39,7 @@ interface uses // FCL Classes, SysUtils, Contnrs, TypInfo, Laz_AVL_Tree, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + System.UITypes, // LCL Forms, ImgList, // Codetools diff --git a/packager/projpackchecks.pas b/packager/projpackchecks.pas index 2352e6e421..d246784b7c 100644 --- a/packager/projpackchecks.pas +++ b/packager/projpackchecks.pas @@ -5,8 +5,7 @@ unit ProjPackChecks; interface uses - Classes, SysUtils, - {$IF FPC_FULLVERSION >= 30200}System.{$ENDIF}UITypes, + Classes, SysUtils, System.UITypes, // LCL Forms, Dialogs, // LazUtils diff --git a/test/lazutils/testavglvltree.pas b/test/lazutils/testavglvltree.pas index 587de67189..f82ab89306 100644 --- a/test/lazutils/testavglvltree.pas +++ b/test/lazutils/testavglvltree.pas @@ -38,10 +38,6 @@ type procedure TestIndexedAVLTreeAddsDeletes; end; - {$IF FPC_FULLVERSION<30101} - TAVLTreeClass = class of TAVLTree; - {$ENDIF} - { TTest_AVLTree - the FPC unit} TTest_AVLTree = class(TTestCase) @@ -49,9 +45,7 @@ type fTreeClass: TAVLTreeClass; function CreateTree(Args: array of const): TAVLTree; procedure TestSequence(Args: array of const); - {$IF FPC_FULLVERSION>=30101} procedure TestAscendingSequence(InitArgs: array of const; AscSeq: array of const); - {$ENDIF} procedure TestAVLTree; published procedure TestAVLTreeAddsDeletes; @@ -103,7 +97,6 @@ begin Tree.Free; end; -{$IF FPC_FULLVERSION>=30101} procedure TTest_AVLTree.TestAscendingSequence(InitArgs: array of const; AscSeq: array of const); var @@ -134,7 +127,6 @@ begin Tree.ConsistencyCheck; Tree.Free; end; -{$ENDIF} procedure TTest_AVLTree.TestAVLTree; begin @@ -165,7 +157,6 @@ begin TestSequence([1,2,3,-3,-1,-2]); TestSequence([1,2,3,-3,-2,-1]); - {$IF FPC_FULLVERSION>=30101} // test AddAscendingSequence TestAscendingSequence([],[1]); TestAscendingSequence([],[1,2]); @@ -176,7 +167,6 @@ begin TestAscendingSequence([2],[1,3,4,5]); TestAscendingSequence([3],[1,2,4,5,6]); TestAscendingSequence([3,4],[1,2,5,6,7]); - {$ENDIF} end; procedure TTest_AVLTree.TestAVLTreeAddsDeletes; diff --git a/tools/jsonviewer/frarest.pp b/tools/jsonviewer/frarest.pp index a55fb9651d..2630ee2f23 100644 --- a/tools/jsonviewer/frarest.pp +++ b/tools/jsonviewer/frarest.pp @@ -319,11 +319,7 @@ begin R.Content:=SERequestContent.Text else begin -{$IF FPC_FULLVERSION>30004} S:=TStringStream.Create('',CP_UTF8); -{$ELSE} - S:=TStringStream.Create(''); -{$ENDIF} try OnSendContent(Self,S); R.Content:=S.DataString; diff --git a/tools/jsonviewer/frmcreatecode.pp b/tools/jsonviewer/frmcreatecode.pp index 8ad3a801ab..1c72cdc1bf 100644 --- a/tools/jsonviewer/frmcreatecode.pp +++ b/tools/jsonviewer/frmcreatecode.pp @@ -75,10 +75,6 @@ end; procedure TCreateCodeForm.FormCreate(Sender: TObject); begin FGenerator:=TJSONToPascal.Create(Self); - {$IF FPC_FULLVERSION<=30004} - ETopLevelClassName.Enabled:=False; - ETopLevelClassName.Text:='TMyObject'; - {$ENDIF} end; procedure TCreateCodeForm.OKButtonClick(Sender: TObject); @@ -128,9 +124,7 @@ begin if CGoptions.Checked[Ord(T)] then Include(O,T); FGenerator.Options:=O; - {$IF FPC_FULLVERSION>30004} FGenerator.TopLevelObjectClassName:=ETopLevelClassName.Text; - {$ENDIF} FGenerator.DestUnitName:=EUnitName.Text; if (FGenerator.DestUnitName='') then FGenerator.DestUnitName:=ChangeFileExt(ExtractFileName(FECode.FileName),''); diff --git a/tools/jsonviewer/frmmain.pp b/tools/jsonviewer/frmmain.pp index 822111f64b..6aa5616486 100644 --- a/tools/jsonviewer/frmmain.pp +++ b/tools/jsonviewer/frmmain.pp @@ -38,11 +38,7 @@ type { TJSONTab } TViewerOptions = Class(TObject) - {$IF FPC_FULLVERSION>=30002} FOptions : TJSONOptions; - {$ELSE} - FStrict, - {$ENDIF} FQuoteStrings, FSortObjectMembers, FCompact, @@ -299,9 +295,7 @@ type procedure SaveToFile(const AFileName: string); procedure SetCaption; procedure ShowJSONDocument; - {$IF FPC_FULLVERSION>=30002} procedure ToggleOption(O: TJSONOption; Enable: Boolean); - {$ENDIF} Property CurrentJSONTab : TJSONTab Read GetCurrenTJSONTab; Property CurrentFind : TTreeNode Read GetCurrentFind Write setCurrentFind; Property CurrentRoot : TJSONData Read GetCurrentRoot; @@ -441,7 +435,6 @@ begin end; { TMainForm } -{$IF FPC_FULLVERSION>=30002} procedure TMainForm.ToggleOption(O : TJSONOption; Enable : Boolean); Var S : String; @@ -454,16 +447,10 @@ begin Delete(S,1,2); PSMain.StoredValue[S]:=IntToStr(Ord(Enable)); end; -{$ENDIF} procedure TMainForm.MIStrictClick(Sender: TObject); begin -{$IF FPC_FULLVERSION>=30002} ToggleOption(joStrict,(Sender as TMenuItem).Checked); -{$ELSE} - FStrict:=(Sender as TMenuItem).Checked; - PSMain.StoredValue['strict']:=IntToStr(Ord(Fstrict)); -{$ENDIF} end; procedure TMainForm.PCJSONCloseTabClicked(Sender: TObject); @@ -475,14 +462,11 @@ end; procedure TMainForm.PSMainStoredValues0Restore(Sender: TStoredValue; var Value: TStoredType); -{$IF FPC_FULLVERSION>=30002} Var S : String; o : integer; JO : TJSONOption; -{$ENDIF} begin - {$IF FPC_FULLVERSION>=30002} S:=Sender.Name; O:=GetEnumValue(TypeInfo(TJSONOption),'jo'+S); if O<>-1 then @@ -493,9 +477,6 @@ begin else Exclude(FOptions.Foptions,JO); end; - {$ELSE} - FStrict:=StrToIntDef(Value,0)=1 - {$ENDIF} end; procedure TMainForm.PSMainStoredValues1Restore(Sender: TStoredValue; @@ -874,9 +855,7 @@ end; procedure TMainForm.ACreateCodeExecute(Sender: TObject); begin - {$IF FPC_FULLVERSION>=30004} CreateCodeFromJSON(CurrentRoot); - {$endif} end; procedure TMainForm.ACreateCodeUpdate(Sender: TObject); @@ -1085,13 +1064,8 @@ Var begin D:=Nil; try -{$IF FPC_FULLVERSION>=30002} P:=TJSONParser.Create(Clipboard.AsText,[]); P.Options:=FOptions.FOptions; -{$ELSE} - P:=TJSONParser.Create(Clipboard.AsText); - P.Strict:=FStrict; -{$ENDIF} try D:=P.Parse; finally @@ -1509,13 +1483,6 @@ begin ShowMessage(Format(SErrCreatingConfigDir,[S])); FFavouritesFileName:=S+'favourites.json'; PSMain.Active:=True; -{$IF FPC_FULLVERSION<30002} - MIAllowTrailingComma.Visible:=False; - MIAllowComments.Visible:=False; -{$ENDIF} -{$IF FPC_FULLVERSION<30004} - ACreateCode.Visible:=False; -{$endif} end; procedure TMainForm.FormDestroy(Sender: TObject); @@ -1578,16 +1545,12 @@ end; procedure TMainForm.MIAllowTrailingCommaClick(Sender: TObject); begin - {$IF FPC_FULLVERSION>=30002} - ToggleOption(joIgnoreTrailingComma,(Sender as TMenuItem).Checked); - {$ENDIF} + ToggleOption(joIgnoreTrailingComma,(Sender as TMenuItem).Checked); end; procedure TMainForm.MIAllowCommentsClick(Sender: TObject); begin - {$IF FPC_FULLVERSION>=30002} - ToggleOption(joComments,(Sender as TMenuItem).Checked); - {$ENDIF} + ToggleOption(joComments,(Sender as TMenuItem).Checked); end; procedure TMainForm.ShowJSONDocument; @@ -1649,15 +1612,9 @@ Var begin S:=TFileStream.Create(AFileName,fmOpenRead or fmShareDenyWrite); try -{$IF FPC_FULLVERSION>=30002} P:=TJSONParser.Create(S,[]); -{$ELSE} - P:=TJSONParser.Create(S); -{$ENDIF} try -{$IF FPC_FULLVERSION>=30002} P.Options:=P.Options+[joStrict]; -{$ENDIF} D:=P.Parse; finally P.Free; @@ -1704,12 +1661,8 @@ begin if FSyn.Modified then begin try - {$IF FPC_FULLVERSION>=30002} P:=TJSONParser.Create(FSyn.Text,[]); P.Options:=P.Options+[joStrict, joComments]; - {$ELSE} - P:=TJSONParser.Create(FSyn.Text); - {$ENDIF} D:=P.Parse; Root:=D; Modified:=true; diff --git a/tools/lazdatadesktop/reglddfeatures.pp b/tools/lazdatadesktop/reglddfeatures.pp index cf339375df..8f7dddec30 100644 --- a/tools/lazdatadesktop/reglddfeatures.pp +++ b/tools/lazdatadesktop/reglddfeatures.pp @@ -28,10 +28,8 @@ uses fpddodbc, // Any ODBC supported fpddmssql, // code generators -{$IF FPC_FULLVERSION>=30200} fpcgfieldmap, fpcgtypesafedataset, -{$ENDIF} fpcgSQLConst, fpcgdbcoll, fpcgCreateDBF,