1 {
2 ***************************************************************************
3 * *
4 * This source is free software; you can redistribute it and/or modify *
5 * it under the terms of the GNU General Public License as published by *
6 * the Free Software Foundation; either version 2 of the License, or *
7 * (at your option) any later version. *
8 * *
9 * This code is distributed in the hope that it will be useful, but *
10 * WITHOUT ANY WARRANTY; without even the implied warranty of *
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
12 * General Public License for more details. *
13 * *
14 * A copy of the GNU General Public License is available on the World *
15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
16 * obtain it by writing to the Free Software Foundation, *
17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
18 * *
19 ***************************************************************************
20
21 Author: Balázs Székely
22 Abstract:
23 Implementation of the package zipper class.
24 }
25 unit opkman_zipper;
26
27 {$mode objfpc}{$H+}
28
29 interface
30
31 uses
32 Classes, SysUtils, strutils,
33 // LazUtils
34 FileUtil, LazFileUtils,
35 // OpkMan
36 opkman_serializablepackages, opkman_common,
37 {$IF FPC_FULLVERSION>=30200}zipper{$ELSE}opkman_zip{$ENDIF};
38
39 type
40 TOnProgressEx = procedure(Sender : TObject; const ATotPos, ATotSize: Int64);
41 TOnZipProgress = procedure(Sender: TObject; AZipfile: String; ACnt, ATotCnt: Integer; ACurPos, ACurSize, ATotPos, ATotSize: Int64;
42 AElapsed, ARemaining, ASpeed: LongInt) of object;
43 TOnZipError = procedure(Sender: TObject; APackageName: String; const AErrMsg: String) of object;
44 TOnZipCompleted = TNotifyEvent;
45
46 { TPackageUnzipper }
47
48 TPackageUnzipper = class(TThread)
49 private
50 FSrcDir: String;
51 FDstDir: String;
52 FStarted: Boolean;
53 FNeedToBreak: Boolean;
54 FZipFile: String;
55 FCnt: Integer;
56 FTotCnt: Integer;
57 FCurPos: Int64;
58 FCurSize: Int64;
59 FTotPos: Int64;
60 FTotPosTmp: Int64;
61 FTotSize: Int64;
62 FElapsed: QWord;
63 FStartTime: QWord;
64 FRemaining: Integer;
65 FSpeed: Integer;
66 FErrMsg: String;
67 FIsUpdate: Boolean;
68 FUnZipper: TUnZipper;
69 FOnZipProgress: TOnZipProgress;
70 FOnZipError: TOnZipError;
71 FOnZipCompleted: TOnZipCompleted;
72 procedure DoOnProgressEx(Sender : TObject; const ATotPos, {%H-}ATotSize: Int64);
73 procedure DoOnZipProgress;
74 procedure DoOnZipError;
75 procedure DoOnZipCompleted;
GetZipSizenull76 function GetZipSize(var AIsDirZipped: Boolean; var ABaseDir: String): Int64;
77 protected
78 procedure Execute; override;
79 public
80 constructor Create;
81 destructor Destroy; override;
82 procedure StartUnZip(const ASrcDir, ADstDir: String; const AIsUpdate: Boolean = False);
83 procedure StopUnZip;
84 published
85 property OnZipProgress: TOnZipProgress read FOnZipProgress write FOnZipProgress;
86 property OnZipError: TOnZipError read FOnZipError write FOnZipError;
87 property OnZipCompleted: TOnZipCompleted read FOnZipCompleted write FOnZipCompleted;
88 end;
89
90 { TPackageZipper }
91
92 TPackageZipper = class(TThread)
93 private
94 FZipper: TZipper;
95 FSrcDir: String;
96 FZipFile: String;
97 FStarted: Boolean;
98 FNeedToBreak: Boolean;
99 FErrMsg: String;
100 FOnZipError: TOnZipError;
101 FOnZipCompleted: TOnZipCompleted;
102 procedure DoOnZipError;
103 procedure DoOnZipCompleted;
104 protected
105 procedure Execute; override;
106 public
107 constructor Create;
108 destructor Destroy; override;
109 procedure StartZip(const ASrcDir, AZipFile: String);
110 procedure StopZip;
111 published
112 property OnZipError: TOnZipError read FOnZipError write FOnZipError;
113 property OnZipCompleted: TOnZipCompleted read FOnZipCompleted write FOnZipCompleted;
114 end;
115
116 var
117 PackageUnzipper: TPackageUnzipper = nil;
118
119 implementation
120
121 { TPackageUnZipper }
122
123 procedure TPackageUnzipper.DoOnZipProgress;
124 begin
125 if Assigned(FOnZipProgress) then
126 FOnZipProgress(Self, FZipfile, FCnt, FTotCnt, FCurPos, FCurSize, FTotPosTmp, FTotSize, FElapsed, FRemaining, FSpeed);
127 end;
128
129 procedure TPackageUnzipper.DoOnZipError;
130 begin
131 if Assigned(FOnZipError) then
132 FOnZipError(Self, FZipFile, FErrMsg);
133 end;
134
135 procedure TPackageUnzipper.DoOnZipCompleted;
136 begin
137 if Assigned(FOnZipCompleted) then
138 FOnZipCompleted(Self);
139 end;
140
141 procedure TPackageUnzipper.Execute;
142 var
143 I: Integer;
144 DelDir: String;
145 MPkg: TMetaPackage;
146 begin
147 Sleep(50);
148 FCnt := 0;
149 FStartTime := GetTickCount64;
150 for I := 0 to SerializablePackages.Count - 1 do
151 begin
152 MPkg := SerializablePackages.Items[I];
153 if MPkg.IsExtractable then
154 begin
155 if FNeedToBreak then
156 Break;
157 Inc(FCnt);
158 FCurPos := 0;
159 FZipFile := MPkg.RepositoryFileName;
160 DelDir := FDstDir + MPkg.PackageBaseDir;
161 if FIsUpdate then
162 if DirectoryExists(DelDir) then
163 DeleteDirectory(DelDir, False);
164 try
165 FUnZipper.Clear;
166 FUnZipper.FileName := FSrcDir + MPkg.RepositoryFileName;
167 if MPkg.IsDirZipped then
168 FUnZipper.OutputPath := FDstDir
169 else
170 FUnZipper.OutputPath := FDstDir + MPkg.PackageBaseDir;
171 FUnZipper.OnProgressEx := @DoOnProgressEx;
172 FUnZipper.Examine;
173 FUnZipper.UnZipAllFiles;
174 MPkg.ChangePackageStates(ctAdd, psExtracted);
175 if (MPkg.IsDirZipped )
176 and (CompareText(MPkg.PackageBaseDir, MPkg.ZippedBaseDir) <> 0) then
177 begin
178 CopyDirTree(FUnZipper.OutputPath + MPkg.ZippedBaseDir, DelDir, [cffOverwriteFile]);
179 DeleteDirectory(FUnZipper.OutputPath + MPkg.ZippedBaseDir, False);
180 end;
181 Synchronize(@DoOnZipProgress);
182 FTotPos := FTotPos + FCurSize;
183 except
184 on E: Exception do
185 begin
186 FErrMsg := E.Message;
187 MPkg.ChangePackageStates(ctRemove, psExtracted);
188 MPkg.ChangePackageStates(ctAdd, psError);
189 DeleteDirectory(DelDir, False);
190 Synchronize(@DoOnZipError);
191 end;
192 end;
193 end;
194 end;
195 if (FNeedToBreak) then
196 begin
197 if DirectoryExists(DelDir) then
198 DeleteDirectory(DelDir, False)
199 end
200 else
201 begin
202 SerializablePackages.MarkRuntimePackages;
203 Synchronize(@DoOnZipCompleted);
204 end;
205 end;
206
207 constructor TPackageUnzipper.Create;
208 begin
209 inherited Create(True);
210 FreeOnTerminate := True;
211 FUnZipper := TUnZipper.Create;
212 end;
213
214 destructor TPackageUnzipper.Destroy;
215 begin
216 FUnZipper.Free;
217 inherited Destroy;
218 end;
219
220 procedure TPackageUnzipper.DoOnProgressEx(Sender : TObject; const ATotPos, ATotSize: Int64);
221 begin
222 FElapsed := GetTickCount64 - FStartTime;
223 if FElapsed < 1000 then
224 Exit;
225 FElapsed := FElapsed div 1000;
226
227 FCurPos := ATotPos;
228 FCurSize := ATotSize;
229 FTotPosTmp := FTotPos + FCurPos;
230 FSpeed := Round(FTotPosTmp/FElapsed);
231 if FSpeed > 0 then
232 FRemaining := Round((FTotSize - FTotPosTmp)/FSpeed);
233 Synchronize(@DoOnZipProgress);
234 Sleep(5);
235 end;
236
TPackageUnzipper.GetZipSizenull237 function TPackageUnzipper.GetZipSize(var AIsDirZipped: Boolean; var ABaseDir: String): Int64;
238 var
239 I: Integer;
240 Item: TFullZipFileEntry;
241 AllFiles: Boolean;
242 P: Integer;
243 begin
244 FUnZipper.Examine;
245 AllFiles := (FUnZipper.Files.Count = 0);
246 Result := 0;
247 if FUnZipper.Entries.Count > 0 then
248 begin
249 P := Pos('/', TZipFileEntry(FUnZipper.Entries.Items[0]).ArchiveFileName);
250 if P = 0 then
251 P := Pos('\', TZipFileEntry(FUnZipper.Entries.Items[0]).ArchiveFileName);
252 if P <> 0 then
253 ABaseDir := Copy(TZipFileEntry(FUnZipper.Entries.Items[0]).ArchiveFileName, 1, P);
254 end;
255 for I := 0 to FUnZipper.Entries.Count-1 do
256 begin
257 Item := FUnZipper.Entries[i];
258 if AllFiles or (FUnZipper.Files.IndexOf(Item.ArchiveFileName)<>-1) then
259 begin
260 Result := Result + TZipFileEntry(Item).Size;
261 if AIsDirZipped then
262 if Pos(ABaseDir, Item.ArchiveFileName) = 0 then
263 AIsDirZipped := False;
264 end;
265 end;
266 if not AIsDirZipped then
267 ABaseDir := ''
268 else
269 SetLength(ABaseDir, Length(ABaseDir)-1);
270 end;
271
272
273 procedure TPackageUnzipper.StartUnZip(const ASrcDir, ADstDir: String;
274 const AIsUpdate: Boolean);
275 var
276 I: Integer;
277 IsDirZipped: Boolean;
278 BaseDir: String;
279 begin
280 if FStarted then
281 Exit;
282 FDstDir := ADstDir;
283 FSrcDir := ASrcDir;
284 FTotCnt := 0;
285 FTotSize := 0;
286 FIsUpdate := AIsUpdate;
287 for I := 0 to SerializablePackages.Count - 1 do
288 begin
289 if SerializablePackages.Items[I].IsExtractable then
290 begin
291 try
292 FUnZipper.Clear;
293 FUnZipper.FileName := FSrcDir + SerializablePackages.Items[I].RepositoryFileName;
294 FUnZipper.Examine;
295 IsDirZipped := True;
296 BaseDir := '';
297 FTotSize := FTotSize + GetZipSize(IsDirZipped, BaseDir);
298 SerializablePackages.Items[I].IsDirZipped := IsDirZipped;
299 if BaseDir <> '' then
300 BaseDir := AppendPathDelim(BaseDir);
301 SerializablePackages.Items[I].ZippedBaseDir := BaseDir;
302 Inc(FTotCnt);
303 except
304 on E: Exception do
305 begin
306 FZipFile := SerializablePackages.Items[I].RepositoryFileName;
307 FErrMsg := E.Message;
308 Synchronize(@DoOnZipError);
309 end;
310 end
311 end;
312 end;
313 FStarted := True;
314 Start;
315 end;
316
317 procedure TPackageUnzipper.StopUnZip;
318 begin
319 if Assigned(FUnZipper) then
320 FUnZipper.Terminate;
321 FNeedToBreak := True;
322 FStarted := False;
323 end;
324
325
326 { TPackageZipper }
327
328 procedure TPackageZipper.DoOnZipError;
329 begin
330 if Assigned(FOnZipError) then
331 FOnZipError(Self, FZipFile, FErrMsg);
332 end;
333
334 procedure TPackageZipper.DoOnZipCompleted;
335 begin
336 if Assigned(FOnZipCompleted) then
337 FOnZipCompleted(Self);
338 end;
339
340 procedure TPackageZipper.Execute;
341 var
342 PathEntry: String;
343 ZipFileEntries: TZipFileEntries;
344 FileList: TStringList;
345 SrcDir: String;
346 P, I: Integer;
347 CanGo: Boolean;
348 begin
349 CanGo := True;
350 FZipper.Filename := FZipFile;
351 SrcDir := FSrcDir;
352 FZipper.Clear;
353 ZipFileEntries := TZipFileEntries.Create(TZipFileEntry);
354 try
355 if DirPathExists(SrcDir) then
356 begin
357 P := RPos(PathDelim, ChompPathDelim(SrcDir));
358 PathEntry := LeftStr(SrcDir, P);
359 FileList := TStringList.Create;
360 try
361 FindAllFilesEx(SrcDir, FileList);
362 for I := 0 to FileList.Count - 1 do
363 ZipFileEntries.AddFileEntry(FileList[I], CreateRelativePath(FileList[I], PathEntry));
364 finally
365 FileList.Free;
366 end;
367
368 if (ZipFileEntries.Count > 0) then
369 begin
370 try
371 FZipper.ZipFiles(ZipFileEntries);
372 except
373 on E: EZipError do
374 begin
375 CanGo := False;
376 FErrMsg := E.Message;
377 Synchronize(@DoOnZipError);
378 end;
379 end;
380 end;
381 end;
382 finally
383 ZipFileEntries.Free;
384 end;
385 if CanGo then
386 Synchronize(@DoOnZipCompleted);
387 end;
388
389 constructor TPackageZipper.Create;
390 begin
391 inherited Create(True);
392 FreeOnTerminate := True;
393 FZipper := TZipper.Create;
394 end;
395
396 destructor TPackageZipper.Destroy;
397 begin
398 FZipper.Free;
399 inherited Destroy;
400 end;
401
402 procedure TPackageZipper.StartZip(const ASrcDir, AZipFile: String);
403 begin
404 if FStarted then
405 Exit;
406 FSrcDir := ASrcDir;
407 FZipFile := AZipFile;
408 FStarted := True;
409 Start;
410 end;
411
412 procedure TPackageZipper.StopZip;
413 begin
414 if Assigned(FZipper) then
415 FZipper.Terminate;
416 FNeedToBreak := True;
417 FStarted := False;
418 end;
419
420 end.
421
422