paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-06 06:57:54 +02:00
Code Issues Packages Projects Releases Wiki Activity

Opkman: Submit packages to remote server.

Browse Source 
git-svn-id: trunk@53885 -
This commit is contained in:
balazs 2017-01-04 13:51:11 +00:00
parent 27eb75ed6b
commit dbe254e132
13 changed files with 538 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -3316,6 +3316,7 @@ components/onlinepackagemanager/opkman_progressfrm.pas svneol=native#text/pascal
components/onlinepackagemanager/opkman_serializablepackages.pas svneol=native#text/pascal
components/onlinepackagemanager/opkman_timer.pas svneol=native#text/pascal
components/onlinepackagemanager/opkman_updates.pas svneol=native#text/pascal
components/onlinepackagemanager/opkman_uploader.pas svneol=native#text/pascal
components/onlinepackagemanager/opkman_visualtree.pas svneol=native#text/pascal
components/onlinepackagemanager/opkman_zipper.pas svneol=native#text/pascal
components/onlinepackagemanager/vst/include/carbon/opkman_delphicompat.inc svneol=native#text/plain

162
components/onlinepackagemanager/frames/opkman_createrepositorypackagefr.lfm
View File

@ -1,9 +1,9 @@
object CreateRepositoryPackagefr: TCreateRepositoryPackagefr
Left = 0
Height = 450
Height = 506
Top = 0
Width = 750
ClientHeight = 450
ClientHeight = 506
ClientWidth = 750
Color = clBtnFace
ParentColor = False
@ -12,7 +12,7 @@ object CreateRepositoryPackagefr: TCreateRepositoryPackagefr
DesignTop = 213
object pnMessage: TPanel
Left = 247
Height = 340
Height = 400
Top = 65
Width = 503
Align = alClient
@ -31,7 +31,7 @@ object CreateRepositoryPackagefr: TCreateRepositoryPackagefr
end
object pnPackages: TPanel
Left = 0
Height = 340
Height = 400
Top = 65
Width = 245
Align = alLeft
@ -81,23 +81,23 @@ object CreateRepositoryPackagefr: TCreateRepositoryPackagefr
end
object pnData: TPanel
Left = 247
Height = 340
Height = 400
Top = 65
Width = 503
Align = alClient
BevelOuter = bvNone
ClientHeight = 340
ClientHeight = 400
ClientWidth = 503
TabOrder = 2
object pnPackageData: TPanel
Left = 0
Height = 151
Height = 211
Top = 189
Width = 503
Align = alClient
BevelOuter = bvNone
BorderStyle = bsSingle
ClientHeight = 147
ClientHeight = 207
ClientWidth = 499
TabOrder = 0
Visible = False
@ -324,7 +324,7 @@ object CreateRepositoryPackagefr: TCreateRepositoryPackagefr
end
object spMain: TSplitter
Left = 245
Height = 340
Height = 400
Top = 65
Width = 2
AutoSnap = False
@ -334,75 +334,105 @@ object CreateRepositoryPackagefr: TCreateRepositoryPackagefr
end
object pnButtons: TPanel
Left = 0
Height = 45
Top = 405
Height = 41
Top = 465
Width = 750
Align = alBottom
BevelOuter = bvNone
BorderStyle = bsSingle
ClientHeight = 41
ClientHeight = 37
ClientWidth = 746
TabOrder = 5
object bCreate: TButton
Left = 584
Height = 26
Top = 8
Width = 75
Anchors = [akTop, akRight]
Caption = 'Create'
Enabled = False
OnClick = bCreateClick
TabOrder = 3
end
object bCancel: TButton
Left = 661
Height = 26
Top = 8
Width = 75
Anchors = [akTop, akRight]
Caption = 'Cancel'
Enabled = False
ModalResult = 2
OnClick = bCancelClick
TabOrder = 4
end
object cbOpen: TCheckBox
Left = 10
Height = 19
Top = 1
Width = 211
Caption = 'After create, open containing folder '
TabOrder = 0
end
object bOptions: TButton
Left = 507
Height = 26
Top = 8
Width = 75
Anchors = [akTop, akRight]
Caption = 'Options'
Enabled = False
OnClick = bOptionsClick
TabOrder = 2
end
object bHelp: TButton
Left = 430
Height = 26
Top = 8
Width = 75
Anchors = [akTop, akRight]
Caption = 'Help'
Enabled = False
OnClick = bHelpClick
TabOrder = 5
end
object cbJSONForUpdates: TCheckBox
Left = 10
Height = 19
Top = 21
Top = 9
Width = 148
Caption = 'Create JSON for updates'
TabOrder = 0
end
object pnB: TPanel
Left = 322
Height = 29
Top = 2
Width = 400
Anchors = [akTop, akRight]
BorderSpacing.InnerBorder = 1
BevelOuter = bvNone
ClientHeight = 29
ClientWidth = 400
TabOrder = 1
object bCancel: TButton
Left = 324
Height = 27
Top = 1
Width = 75
Align = alRight
BorderSpacing.Around = 1
Caption = 'Cancel'
Enabled = False
ModalResult = 2
OnClick = bCancelClick
ParentShowHint = False
ShowHint = True
TabOrder = 0
end
object bCreate: TButton
Left = 172
Height = 27
Top = 1
Width = 75
Align = alRight
BorderSpacing.Around = 1
Caption = 'Create'
Enabled = False
OnClick = bCreateClick
ParentShowHint = False
ShowHint = True
TabOrder = 1
end
object bSubmit: TButton
Left = 248
Height = 27
Top = 1
Width = 75
Align = alRight
BorderSpacing.Around = 1
Caption = 'Submit'
Enabled = False
OnClick = bSubmitClick
ParentShowHint = False
ShowHint = True
TabOrder = 2
end
object bOptions: TButton
Left = 96
Height = 27
Top = 1
Width = 75
Align = alRight
BorderSpacing.Around = 1
Caption = 'Options'
Enabled = False
OnClick = bOptionsClick
ParentShowHint = False
ShowHint = True
TabOrder = 3
end
object bHelp: TButton
Left = 20
Height = 27
Top = 1
Width = 75
Align = alRight
BorderSpacing.Around = 1
Caption = 'Help'
Enabled = False
OnClick = bHelpClick
ParentShowHint = False
ShowHint = True
TabOrder = 4
end
end
end
object imTree: TImageList

223
components/onlinepackagemanager/frames/opkman_createrepositorypackagefr.pas
View File

@ -7,7 +7,8 @@ interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, ExtCtrls, StdCtrls, Dialogs,
LazFileUtils, Graphics, Menus, Buttons, Laz2_XMLCfg, opkman_VirtualTrees,
md5, fpjson, LCLIntf, EditBtn, opkman_serializablepackages, opkman_zipper;
md5, fpjson, LCLIntf, EditBtn, opkman_serializablepackages, opkman_zipper,
opkman_uploader;
type
PData = ^TData;
@ -33,7 +34,7 @@ type
FSVNURL: String;
end;
TPackageOperation = (poCreate, poSubmit);
{ TCreateRepositoryPackagefr }
TCreateRepositoryPackagefr = class(TFrame)
@ -42,8 +43,8 @@ type
Bevel1: TBevel;
bHelp: TButton;
bOptions: TButton;
bSubmit: TButton;
cbJSONForUpdates: TCheckBox;
cbOpen: TCheckBox;
edCategories: TEdit;
edPackageDir: TDirectoryEdit;
edDownloadURL: TEdit;
@ -67,6 +68,7 @@ type
lbOF4: TLabel;
lbPackagedir: TLabel;
lbSupportedWidgetSet: TLabel;
pnB: TPanel;
pnButtons: TPanel;
pnCategories: TPanel;
pnPackageData: TPanel;
@ -82,6 +84,7 @@ type
procedure bCreateClick(Sender: TObject);
procedure bHelpClick(Sender: TObject);
procedure bOptionsClick(Sender: TObject);
procedure bSubmitClick(Sender: TObject);
procedure edPackageDirAcceptDirectory(Sender: TObject; var Value: String);
procedure edPackageDirButtonClick(Sender: TObject);
procedure pnBrowseResize(Sender: TObject);
@ -89,12 +92,12 @@ type
private
FVSTPackages: TVirtualStringTree;
FVSTPackageData: TVirtualStringTree;
FCreatePressed: Boolean;
FPackageZipper: TPackageZipper;
FPackageDir: String;
FPackageName: String;
FPackageFile: String;
FDestDir: String;
FPackageOperation: TPackageOperation;
procedure VSTPackagesGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; {%H-}TextType: TVSTTextType; var CellText: String);
procedure VSTPackagesGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode;
@ -118,9 +121,14 @@ type
procedure EnableDisableControls(const AEnable: Boolean);
procedure SaveExtraInfo(const ANode: PVirtualNode);
function TranslateCategories(const AStr: String): String;
procedure CreateJSONForUpdates;
function CanCreate: Boolean;
function CreateJSON(var AErrMsg: String): Boolean;
function CreateJSONForUpdates(var AErrMsg: String): Boolean;
procedure DoOnUploadProgress(Sender: TObject; AFileName: String);
procedure DoOnUploadError(Sender: TObject; AErrMsg: String);
procedure DoOnUploadCompleted(Sender: TObject);
public
procedure InitializeFrame;
procedure InitializeFrame(const ATyp: Integer = 0);
procedure FinalizeFrame;
end;
@ -131,11 +139,10 @@ uses opkman_const, opkman_common, opkman_options, opkman_categoriesfrm,
{ TCreateRepositoryPackagefr }
procedure TCreateRepositoryPackagefr.InitializeFrame;
procedure TCreateRepositoryPackagefr.InitializeFrame(const ATyp: Integer = 0);
begin
lbPackagedir.Caption := rsCreateRepositoryPackageFrm_lbPackageDir_Caption;
pnMessage.Caption := rsCreateRepositoryPackageFrm_pnMessage_Caption;
cbOpen.Caption := rsCreateRepositoryPackageFrm_cbOpen_Caption;
edCategories.Text := '';
lbLazCompatibility.Caption := rsCreateRepositoryPackageFrm_lbLazCompatibility_Caption;
lbFPCCompatibility.Caption := rsCreateRepositoryPackageFrm_lbFPCCompatibility_Caption;
@ -146,9 +153,19 @@ begin
lbDownloadURL.Caption := rsCreateRepositoryPackageFrm_lbDownloadURL_Caption;
lbSVNURL.Caption := rsCreateRepositoryPackageFrm_lbSVNURL_Caption;
bHelp.Caption := rsCreateRepositoryPackageFrm_bHelp_Caption;
bHelp.Hint := rsCreateRepositoryPackageFrm_bHelp_Hint;
bOptions.Caption := rsCreateRepositoryPackageFrm_bOptions_Caption;
bOptions.Hint := rsCreateRepositoryPackageFrm_bOptions_Hint;
bCreate.Caption := rsCreateRepositoryPackageFrm_bCreate_Caption;
bCreate.Hint := rsCreateRepositoryPackageFrm_bCreate_Hint;
bSubmit.Caption := rsCreateRepositoryPackageFrm_bSubmit_Caption;
bSubmit.Hint := rsCreateRepositoryPackageFrm_bSubmit_Hint;
bCancel.Caption := rsCreateRepositoryPackageFrm_bCancel_Caption;
bCancel.Hint := rsCreateRepositoryPackageFrm_bCancel_Hint;
bSubmit.Visible := ATyp = 0;
cbJSONForUpdates.Visible := ATyp = 0;
pnB.Height := bCreate.Height + 1;
pnB.Top := (pnButtons.Height - pnB.Height) div 2;
FVSTPackages := TVirtualStringTree.Create(nil);
with FVSTPackages do
@ -230,6 +247,15 @@ end;
procedure TCreateRepositoryPackagefr.FinalizeFrame;
begin
if Uploader <> nil then
begin
pnMessage.Caption := rsCreateRepositoryPackageFrm_Message10;
pnMessage.Invalidate;
Application.ProcessMessages;
Uploader.StopUpload;
Uploader.WaitFor;
Uploader := nil;
end;
FVSTPackages.Clear;
FVSTPackages.Free;
FVSTPackageData.Clear;
@ -355,11 +381,11 @@ procedure TCreateRepositoryPackagefr.EnableDisableControls(
const AEnable: Boolean);
begin
pnBrowse.Enabled := AEnable;
cbOpen.Enabled := AEnable;
cbJSONForUpdates.Enabled := AEnable;
bHelp.Enabled := AEnable;
bOptions.Enabled := AEnable;
bCreate.Enabled := (AEnable) and (FVSTPackages.CheckedCount > 0);
bSubmit.Enabled := (AEnable) and (FVSTPackages.CheckedCount > 0);
bCancel.Enabled := AEnable;
end;
@ -467,7 +493,7 @@ begin
end;
end;
procedure TCreateRepositoryPackagefr.bCreateClick(Sender: TObject);
function TCreateRepositoryPackagefr.CanCreate: Boolean;
procedure SelectAndFocusNode(const ANode: PVirtualNode);
begin
@ -479,7 +505,7 @@ var
Node: PVirtualNode;
Data: PData;
begin
FCreatePressed := True;
Result := False;
Node := FVSTPackages.GetFirstSelected;
if Node <> nil then
SaveExtraInfo(Node);
@ -525,21 +551,36 @@ begin
end;
Node := FVSTPackages.GetNext(Node);
end;
Result := True;
end;
procedure TCreateRepositoryPackagefr.bCreateClick(Sender: TObject);
var
RootNode: PVirtualNode;
RootData: PData;
begin
if not CanCreate then
Exit;
SDD.Title := rsCreateRepositoryPackageFrm_SDDTitleDst;
SDD.InitialDir := Options.LastPackagedirDst;
EnableDisableControls(False);
if SDD.Execute then
begin
FPackageOperation := poCreate;
Screen.Cursor := crHourGlass;
ShowHideControls(1);
fPackageZipper := TPackageZipper.Create;
fPackageZipper.OnZipError := @DoOnZippError;
fPackageZipper.OnZipCompleted := @DoOnZipCompleted;
FPackageZipper := TPackageZipper.Create;
FPackageZipper.OnZipError := @DoOnZippError;
FPackageZipper.OnZipCompleted := @DoOnZipCompleted;
FDestDir := AppendPathDelim(SDD.FileName);
Options.LastPackagedirDst := SDD.FileName;
Options.Changed := True;
FPackageName := StringReplace(FPackageName, ' ', '', [rfReplaceAll]);
RootNode := FVSTPackages.GetFirst;
RootData := FVSTPackages.GetNodeData(RootNode);
if RootData^.FDisplayName <> '' then
FPackageName := StringReplace(RootData^.FDisplayName, ' ', '', [rfReplaceAll])
else
FPackageName := StringReplace(RootData^.FName, ' ', '', [rfReplaceAll]);
FPackageFile := FDestDir + FPackageName + '.zip';
pnMessage.Caption := rsCreateRepositoryPackageFrm_Message4;
fPackageZipper.StartZip(FPackageDir, FPackageFile);
@ -548,6 +589,32 @@ begin
EnableDisableControls(True);
end;
procedure TCreateRepositoryPackagefr.bSubmitClick(Sender: TObject);
var
RootNode: PVirtualNode;
RootData: PData;
begin
if not CanCreate then
Exit;
FPackageOperation := poSubmit;
EnableDisableControls(False);
ShowHideControls(1);
Screen.Cursor := crHourGlass;
fPackageZipper := TPackageZipper.Create;
fPackageZipper.OnZipError := @DoOnZippError;
fPackageZipper.OnZipCompleted := @DoOnZipCompleted;
FDestDir := Options.LocalRepositoryUpdate;
RootNode := FVSTPackages.GetFirst;
RootData := FVSTPackages.GetNodeData(RootNode);
if RootData^.FDisplayName <> '' then
FPackageName := StringReplace(RootData^.FDisplayName, ' ', '', [rfReplaceAll])
else
FPackageName := StringReplace(RootData^.FName, ' ', '', [rfReplaceAll]);
FPackageFile := FDestDir + FPackageName + '.zip';
pnMessage.Caption := rsCreateRepositoryPackageFrm_Message4;
fPackageZipper.StartZip(FPackageDir, FPackageFile);
end;
procedure TCreateRepositoryPackagefr.bHelpClick(Sender: TObject);
begin
OpenURL(cHelpPage_CreateRepositoryPackage);
@ -803,7 +870,7 @@ begin
Result := AStr;
end;
procedure TCreateRepositoryPackagefr.CreateJSONForUpdates;
function TCreateRepositoryPackagefr.CreateJSONForUpdates(var AErrMsg: String): Boolean;
var
RootNode, Node: PVirtualNode;
RootData, Data: PData;
@ -811,9 +878,12 @@ var
Ms: TMemoryStream;
UpdatePackage: TUpdatePackage;
UpdatePackageFiles: TUpdatePackageFiles;
FileName: String;
ErrMsg: String;
begin
Result := False;
pnMessage.Caption := rsCreateRepositoryPackageFrm_Message6;
pnMessage.Invalidate;
Application.ProcessMessages;
Sleep(2000);
UpdatePackage := TUpdatePackage.Create;
try
RootNode := FVSTPackages.GetFirst;
@ -822,10 +892,6 @@ begin
RootData := FVSTPackages.GetNodeData(RootNode);
UpdatePackage.UpdatePackageData.Name := RootData^.FName;
UpdatePackage.UpdatePackageData.DownloadZipURL := RootData^.FDownloadURL;
if RootData^.FDisplayName <> '' then
FileName := FDestDir + 'update_' + RootData^.FDisplayName + '.json'
else
FileName := FDestDir + 'update_' + RootData^.FName + '.json';
Node := FVSTPackages.GetFirstChild(RootNode);
while Assigned(Node) do
begin
@ -849,23 +915,20 @@ begin
try
Ms.Write(Pointer(JSON)^, Length(JSON));
Ms.Position := 0;
Ms.SaveToFile(FileName);
Ms.SaveToFile(FDestDir + 'update_' + FPackageName + '.json');
finally
MS.Free;
end;
MessageDlgEx(rsCreateJSONForUpdatesFrm_Message4, mtInformation, [mbOk], TForm(Self.Parent));
Result := True;
end
else
begin
ErrMsg := StringReplace(UpdatePackage.LastError, '"', '', [rfReplaceAll]);
MessageDlgEx(rsCreateJSONForUpdatesFrm_Error1 + sLineBreak + '"' + ErrMsg + '"', mtError, [mbOk], TForm(Self.Parent));
end;
AErrMsg := rsCreateJSONForUpdatesFrm_Error1 + sLineBreak + '"' + StringReplace(UpdatePackage.LastError, '"', '', [rfReplaceAll]) + '"';
finally
UpdatePackage.Free;
end;
end;
procedure TCreateRepositoryPackagefr.DoOnZipCompleted(Sender: TObject);
function TCreateRepositoryPackagefr.CreateJSON(var AErrMsg: String): Boolean;
var
SerializablePackages: TSerializablePackages;
Package: TPackage;
@ -874,13 +937,12 @@ var
RootData, Data: PData;
JSON: TJSONStringType;
MS: TMemoryStream;
ErrMsg: String;
CanClose: Boolean;
begin
CanClose := False;
Result := False;
pnMessage.Caption := rsCreateRepositoryPackageFrm_Message5;
pnMessage.Invalidate;
Screen.Cursor := crDefault;
Application.ProcessMessages;
Sleep(2000);
SerializablePackages := TSerializablePackages.Create;
try
RootNode := FVSTPackages.GetFirst;
@ -927,8 +989,6 @@ begin
Node := FVSTPackages.GetNextSibling(Node);
end;
end;
ShowHideControls(2);
EnableDisableControls(True);
if SerializablePackages.Count > 0 then
begin
JSON := '';
@ -939,32 +999,99 @@ begin
MS.Write(Pointer(JSON)^, Length(JSON));
MS.Position := 0;
MS.SaveToFile(FDestDir + FPackageName + '.json');
MessageDlgEx(rsCreateRepositoryPackageFrm_Message6, mtInformation, [mbOk], TForm(Self.Parent));
CanClose := True;
Result := True;
finally
MS.Free;
end;
end
else
begin
ErrMsg := StringReplace(SerializablePackages.LastError, '"', '', [rfReplaceAll]);
MessageDlgEx(rsCreateRepositoryPackageFrm_Error2 + sLineBreak + '"' + ErrMsg + '"', mtError, [mbOk], TForm(Self.Parent));
end;
AErrMsg := rsCreateRepositoryPackageFrm_Error2 + sLineBreak + '"' + StringReplace(SerializablePackages.LastError, '"', '', [rfReplaceAll]) + '"'
end;
finally
SerializablePackages.Free;
end;
if cbJSONForUpdates.Checked then
CreateJSONForUpdates;
if CanClose then
end;
procedure TCreateRepositoryPackagefr.DoOnZipCompleted(Sender: TObject);
var
ErrMsg: String;
begin
ErrMsg := '';
if not CreateJSON(ErrMsg) then
begin
if cbOpen.Checked then
OpenDocument(FDestDir);
TForm(Self.Parent).ModalResult := mrOk;
TForm(Self.Parent).Close;
MessageDlgEx(ErrMsg, mtError, [mbOk], TForm(Self.Parent));
Exit;
end;
if cbJSONForUpdates.Checked then
begin
ErrMsg := '';
if not CreateJSONForUpdates(ErrMsg) then
begin
MessageDlgEx(ErrMsg, mtError, [mbOk], TForm(Self.Parent));
Exit;
end;
end;
case FPackageOperation of
poCreate:
begin
Screen.Cursor := crDefault;
ShowHideControls(2);
EnableDisableControls(True);
MessageDlgEx(rsCreateRepositoryPackageFrm_Message7, mtInformation, [mbOk], TForm(Self.Parent));
TForm(Self.Parent).ModalResult := mrOk;
TForm(Self.Parent).Close;
end;
poSubmit:
begin
Uploader := TUploader.Create;
Uploader.OnUploadProgress := @DoOnUploadProgress;
Uploader.OnUploadError := @DoOnUploadError;
Uploader.OnUploadCompleted := @DoOnUploadCompleted;
if cbJSONForUpdates.Checked then
Uploader.StartUpload(cSubmitURL_Zip, cSubmitURL_JSON, FPackageFile, FDestDir + FPackageName + '.json', FDestDir + 'update_' + FPackageName + '.json')
else
Uploader.StartUpload(cSubmitURL_Zip, cSubmitURL_JSON, FPackageFile, FDestDir + FPackageName + '.json', '')
end;
end;
end;
procedure TCreateRepositoryPackagefr.DoOnUploadProgress(Sender: TObject;
AFileName: String);
begin
pnMessage.Caption := Format(rsCreateRepositoryPackageFrm_Message8, [AFileName]);
pnMessage.Invalidate;
Application.ProcessMessages;
end;
procedure TCreateRepositoryPackagefr.DoOnUploadError(Sender: TObject;
AErrMsg: String);
begin
Screen.Cursor := crDefault;
ShowHideControls(2);
EnableDisableControls(True);
MessageDlgEx(AErrMsg, mtError, [mbOk], TForm(Self.Parent));
end;
procedure TCreateRepositoryPackagefr.DoOnUploadCompleted(Sender: TObject);
begin
Screen.Cursor := crDefault;
ShowHideControls(2);
EnableDisableControls(True);
Uploader := nil;
if FileExistsUTF8(FPackageFile) then
DeleteFileUTF8(FPackageFile);
if FileExistsUTF8(FDestDir + FPackageName + '.json') then
DeleteFileUTF8(FDestDir + FPackageName + '.json');
if FileExistsUTF8(FDestDir + 'update_' + FPackageName + '.json') then
DeleteFileUTF8(FDestDir + 'update_' + FPackageName + '.json');
MessageDlgEx(rsCreateRepositoryPackageFrm_Message9, mtInformation, [mbOk], TForm(Self.Parent));
TForm(Self.Parent).ModalResult := mrOk;
TForm(Self.Parent).Close;
end;
end.

6
components/onlinepackagemanager/onlinepackagemanager.lpk
View File

@ -20,7 +20,7 @@
<Description Value="Online package manger"/>
<License Value="GPL"/>
<Version Major="1"/>
<Files Count="19">
<Files Count="20">
<Item1>
<Filename Value="onlinepackagemanagerintf.pas"/>
<HasRegisterProc Value="True"/>
@ -103,6 +103,10 @@
<Filename Value="opkman_createjsonforupdates.pas"/>
<UnitName Value="opkman_createjsonforupdates"/>
</Item19>
<Item20>
<Filename Value="opkman_uploader.pas"/>
<UnitName Value="opkman_uploader"/>
</Item20>
</Files>
<i18n>
<EnableI18N Value="True"/>

2
components/onlinepackagemanager/onlinepackagemanager.pas
View File

@ -14,7 +14,7 @@ uses
opkman_installer, opkman_packagelistfrm, opkman_options,
opkman_createrepositorypackage, opkman_categoriesfrm,
opkman_packagedetailsfrm, opkman_updates, opkman_createjsonforupdates,
LazarusPackageIntf;
opkman_uploader, LazarusPackageIntf;
implementation

17
components/onlinepackagemanager/opkman_const.pas
View File

@ -53,6 +53,8 @@ const
cOpenSSLURL = 'http://packages.lazarus-ide.org/openssl-1.0.2j-i386-win32.zip';
{$endif}
cExtractDir = 'ExtractDir';
cSubmitURL_Zip = 'aHR0cDovL2xhemFydXNvcG0uMDAwd2ViaG9zdGFwcC5jb20vemlwLnBocA==';
cSubmitURL_JSON = 'aHR0cDovL2xhemFydXNvcG0uMDAwd2ViaG9zdGFwcC5jb20vanNvbi5waHA=';
resourcestring
//package manager
@ -287,7 +289,6 @@ resourcestring
//createrepositorypackage form
rsCreateRepositoryPackageFrm_Caption = 'Create repository package';
rsCreateRepositoryPackageFrm_pnMessage_Caption = 'Please wait...';
rsCreateRepositoryPackageFrm_cbOpen_Caption = 'Open containing folder after creation';
rsCreateRepositoryPackageFrm_lbPackageDir_Caption = 'Package directory:';
rsCreateRepositoryPackageFrm_pnCaption_Caption0 = 'Available packages';
rsCreateRepositoryPackageFrm_pnCaption_Caption1 = 'Description';
@ -306,24 +307,34 @@ resourcestring
rsCreateRepositoryPackageFrm_Error0 = 'Error reading package';
rsCreateRepositoryPackageFrm_Error1 = 'Cannot create zip file:';
rsCreateRepositoryPackageFrm_Error2 = 'Cannot create JSON file:';
rsCreateRepositoryPackageFrm_Error3 = 'Cannot send file: "%s"';
rsCreateRepositoryPackageFrm_Message0 = 'Please select a category for package:';
rsCreateRepositoryPackageFrm_Message1 = 'Please enter supported Lazarus versions for package:';
rsCreateRepositoryPackageFrm_Message2 = 'Please enter supported FPC versions for package:';
rsCreateRepositoryPackageFrm_Message3 = 'Please enter supported widgetsets for package:';
rsCreateRepositoryPackageFrm_Message4 = 'Compressing package. Please wait...';
rsCreateRepositoryPackageFrm_Message5 = 'Creating JSON. Please wait...';
rsCreateRepositoryPackageFrm_Message6 = 'Repository package successfully created.';
rsCreateRepositoryPackageFrm_Message6 = 'Creating JSON for updates. Please wait...';
rsCreateRepositoryPackageFrm_Message7 = 'Repository package successfully created.';
rsCreateRepositoryPackageFrm_Message8 = 'Sending files("%s"). Please wait...';
rsCreateRepositoryPackageFrm_Message9 = 'Files successfully sent. Thank you for submitting packages!' + sLineBreak + 'Your request will be processed in 24 hours.';
rsCreateRepositoryPackageFrm_Message10 = 'Canceling upload. Please wait...';
rsCreateRepositoryPackageFrm_bHelp_Caption = 'Help';
rsCreateRepositoryPackageFrm_bHelp_Hint = 'Open help';
rsCreateRepositoryPackageFrm_bOptions_Caption = 'Options';
rsCreateRepositoryPackageFrm_bOptions_Hint = 'Open options dialog';
rsCreateRepositoryPackageFrm_bCreate_Caption = 'Create';
rsCreateRepositoryPackageFrm_bCreate_Hint = 'Create files locally';
rsCreateRepositoryPackageFrm_bSubmit_Caption = 'Submit';
rsCreateRepositoryPackageFrm_bSubmit_Hint = 'Submit files to remote server';
rsCreateRepositoryPackageFrm_bCancel_Caption = 'Cancel';
rsCreateRepositoryPackageFrm_bCancel_Hint = 'Close this dialog';
//createupdatejson
rsCreateJSONForUpdatesFrm_Caption = 'Create update JSON for package:';
rsCreateJSONForUpdatesFrm_bHelp_Caption = 'Help';
rsCreateJSONForUpdatesFrm_bCreate_Caption = 'Create';
rsCreateJSONForUpdatesFrm_bClose_Caption = 'Cancel';
rsCreateJSONForUpdatesFrm_cbOpen_Caption = 'Open containing folder after creation';
rsCreateJSONForUpdatesFrm_lbLinkToZip_Caption = 'Link to the package zip file';
rsCreateJSONForUpdatesFrm_bTest_Caption = 'Test';
rsCreateJSONForUpdatesFrm_Column0_Text = 'PackageFileName';

14
components/onlinepackagemanager/opkman_createjsonforupdates.lfm
View File

@ -26,7 +26,7 @@ object CreateJSONForUpdatesFrm: TCreateJSONForUpdatesFrm
ClientWidth = 580
TabOrder = 1
object bCreate: TButton
Left = 414
Left = 415
Height = 26
Top = 8
Width = 75
@ -45,23 +45,15 @@ object CreateJSONForUpdatesFrm: TCreateJSONForUpdatesFrm
ModalResult = 2
TabOrder = 1
end
object cbOpen: TCheckBox
Left = 15
Height = 19
Top = 12
Width = 211
Caption = 'After create, open containing folder '
TabOrder = 2
end
object bHelp: TButton
Left = 336
Left = 339
Height = 26
Top = 8
Width = 75
Anchors = [akTop, akRight]
Caption = 'Help'
OnClick = bHelpClick
TabOrder = 3
TabOrder = 2
end
end
object pnTop: TPanel

6
components/onlinepackagemanager/opkman_createjsonforupdates.pas
View File

@ -18,7 +18,6 @@ type
bCreate: TButton;
bHelp: TButton;
bTest: TButton;
cbOpen: TCheckBox;
edLinkToZip: TEdit;
imTree: TImageList;
lbLinkToZip: TLabel;
@ -76,7 +75,6 @@ begin
bCreate.Caption := rsCreateJSONForUpdatesFrm_bCreate_Caption;
bHelp.Caption := rsCreateJSONForUpdatesFrm_bHelp_Caption;
bClose.Caption := rsCreateJSONForUpdatesFrm_bClose_Caption;
cbOpen.Caption := rsCreateJSONForUpdatesFrm_cbOpen_Caption;
FVST := TVirtualStringTree.Create(nil);
with FVST do
@ -225,11 +223,7 @@ begin
end;
end;
if CanClose then
begin
if cbOpen.Checked then
OpenDocument(ExtractFilePath(SD.FileName));
Close
end;
end;
procedure TCreateJSONForUpdatesFrm.bHelpClick(Sender: TObject);

22
components/onlinepackagemanager/opkman_createrepositorypackage.lfm
View File

@ -16,6 +16,28 @@ object CreateRepositoryPackagesFrm: TCreateRepositoryPackagesFrm
Position = poOwnerFormCenter
LCLVersion = '1.7'
inline frCreateRep: TCreateRepositoryPackagefr
Height = 450
Align = alClient
ClientHeight = 450
inherited pnMessage: TPanel
Height = 336
end
inherited pnPackages: TPanel
Height = 336
end
inherited pnData: TPanel
Height = 336
ClientHeight = 336
inherited pnPackageData: TPanel
Height = 147
ClientHeight = 143
end
end
inherited spMain: TSplitter
Height = 336
end
inherited pnButtons: TPanel
Top = 401
end
end
end

4
components/onlinepackagemanager/opkman_downloader.pas
View File

@ -30,9 +30,7 @@ interface
uses
Classes, SysUtils, fpjson, opkman_httpclient, opkman_timer, opkman_common,
opkman_serializablepackages,
dialogs;
opkman_serializablepackages;
type
TDownloadType = (dtJSON, dtPackage, dtUpdate);

2
components/onlinepackagemanager/opkman_options.pas
View File

@ -116,7 +116,7 @@ begin
FLocalUpdateDefault := LocalRepo + AppendPathDelim(cLocalRepositoryUpdate);
FXML := TXMLConfig.Create(AFileName);
if FileExists(AFileName) then
if FileExistsUTF8(AFileName) then
begin
Load;
if FLocalRepositoryPackages = '' then

2
components/onlinepackagemanager/opkman_serializablepackages.pas
View File

@ -1432,7 +1432,7 @@ begin
end;
paUpdate:
begin
if FileExists(Options.LocalRepositoryUpdate + Items[I].RepositoryFileName) then
if FileExistsUTF8(Options.LocalRepositoryUpdate + Items[I].RepositoryFileName) then
DeleteFile(Options.LocalRepositoryUpdate + Items[I].RepositoryFileName)
end;
end;

218
components/onlinepackagemanager/opkman_uploader.pas Normal file
View File

@ -0,0 +1,218 @@
{
***************************************************************************
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code is distributed in the hope that it will be useful, but *
* WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
Author: Balázs Székely
Abstract:
Implementation of the package uploader class.
}
unit opkman_uploader;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpjson, base64, LazFileUtils, opkman_httpclient,
dialogs;
type
TOnUploadProgress = procedure(Sender: TObject; AFileName: String) of object;
TOnUploadError = procedure(Sender: TObject; AErrMsg: String) of object;
{ TUploader }
TUploader = class(TThread)
private
FOnUploadProgress: TOnUploadProgress;
FOnUploadError: TOnUploadError;
FOnUploadCompleted: TNotifyEvent;
FHTTPClient: TFPHTTPClient;
FNeedToBreak: Boolean;
FFileName: String;
FURLZip: String;
FURLJSON: String;
FZip: String;
FJSON: String;
FJSONUpdate: String;
procedure DoOnUploadProgress;
procedure DoOnUploadError;
procedure DoOnUploadCompleted;
function PostFile(const AURL, AFieldName, AFileName: String): Boolean;
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
procedure StartUpload(AURLZip, AURLJSON, AZip, AJSON, AJSONUpdate: String);
procedure StopUpload;
published
property OnUploadProgress: TOnUploadProgress read FOnUploadProgress write FOnUploadProgress;
property OnUploadError: TOnUploadError read FOnUploadError write FOnUploadError;
property OnUploadCompleted: TNotifyEvent read FOnUploadCompleted write FOnUploadCompleted;
property NeedToBreak: Boolean read FNeedToBreak write FNeedToBreak;
end;
var
Uploader: TUploader = nil;
implementation
uses opkman_options, opkman_const;
{ TUploader }
procedure TUploader.DoOnUploadProgress;
begin
if Assigned(FOnUploadProgress) then
FOnUploadProgress(Self, FFileName);
end;
procedure TUploader.DoOnUploadError;
begin
if Assigned(FOnUploadError) then
FOnUploadError(Self, Format(rsCreateRepositoryPackageFrm_Error3, [FFileName]));
end;
procedure TUploader.DoOnUploadCompleted;
begin
if Assigned(FOnUploadCompleted) then
FOnUploadCompleted(Self);
end;
function TUploader.PostFile(const AURL, AFieldName, AFileName: String): Boolean;
var
SS: TStringStream;
begin
Result := False;
SS := TStringStream.Create('');
try
FHTTPClient := TFPHTTPClient.Create(nil);
try
if Options.ProxyEnabled then
begin
FHTTPClient.Proxy.Host:= Options.ProxyServer;
FHTTPClient.Proxy.Port:= Options.ProxyPort;
FHTTPClient.Proxy.UserName:= Options.ProxyUser;
FHTTPClient.Proxy.Password:= Options.ProxyPassword;
end;
try
FHttpClient.FileFormPost(AURL, AFieldName, AFileName, SS);
except
end;
case AFieldName of
'zip' : Result := SS.DataString = 'zipok';
'json': Result := SS.DataString = 'jsonok';
end;
finally
FHTTPClient.Free;
FHTTPClient := nil;
end;
finally
SS.Free;
end;
end;
procedure TUploader.Execute;
var
CanGo: Boolean;
begin
FFileName := ExtractFileName(FZip);
CanGo := FileExistsUTF8(FZip);
if CanGo then
begin
Synchronize(@DoOnUploadProgress);
CanGo := PostFile(FURLZip, 'zip', FZip);
end;
if (not CanGo) and (not FNeedToBreak) then
begin
Synchronize(@DoOnUploadError);
Exit;
end;
if FNeedToBreak then
Exit;
FFileName := ExtractFileName(FJSON);
CanGo := FileExistsUTF8(FJSON);
if CanGo then
begin
Synchronize(@DoOnUploadProgress);
CanGo := PostFile(FURLJSON, 'json', FJSON);
Sleep(2000);
end;
if (not CanGo) and (not FNeedToBreak) then
begin
Synchronize(@DoOnUploadError);
Exit;
end;
if FNeedToBreak then
Exit;
if FJSONUpdate <> '' then
begin
FFileName := ExtractFileName(FJSONUpdate);
CanGo := FileExistsUTF8(FJSONUpdate);
if CanGo then
begin
Synchronize(@DoOnUploadProgress);
CanGo := PostFile(FURLJSON, 'json', FJSONUpdate);
Sleep(2000);
end;
if (not CanGo) and (not FNeedToBreak) then
begin
Synchronize(@DoOnUploadError);
Exit;
end;
end;
if not FNeedToBreak then
Synchronize(@DoOnUploadCompleted);
end;
constructor TUploader.Create;
begin
inherited Create(True);
FreeOnTerminate := True;
end;
destructor TUploader.Destroy;
begin
//
inherited Destroy;
end;
procedure TUploader.StartUpload(AURLZip, AURLJSON, AZip, AJSON, AJSONUpdate: String);
begin
FURLZip := DecodeStringBase64(AURLZip);
FURLJSON := DecodeStringBase64(AURLJSON);
FZip := AZip;
FJSON := AJSON;
FJSONUpdate := AJSONUpdate;
Start;
end;
procedure TUploader.StopUpload;
begin
if Assigned(FHTTPClient) then
FHTTPClient.NeedToBreak := True;
FNeedToBreak := True;
end;
end.