lazarus、delphi程序自动升级更新功能的实现

2023-08-09 11:59:59 2430

无论是windows、linux下还是android下,程序升级更新功能都是很常用的功能,本文介绍利用miniframe开源Web框架分别在lazarus、delphi下实现程序自动升级更新的功能。升级更新原理:先从服务器读取源文件的大小和修改时间和客户端对应的文件对比,任何一项不一至或客户端不存此文件,都要下载。下载时先压缩,传输采用二进制传输,客户端收到文件后再解压替换为新文件。说明:以下代码lazarus或delphi环境下都能使用。全部源码及Demo请到miniframe开源web框架下载: https://www.wyeditor.com/miniframe/或https://github.com/dajingshan/miniframe。

服务器端代码

要实现自动更新功能,肯定得先从服务器读取最新文件的大小、时间,以便与客户端已有文件对比,确定要更新哪些文件。

以下是服务器获取文件信息和下载一个文件的代码:

<%@//Script头、过程和函数定义
program codes;
%>

<%!//声明变量
var
i,lp: integer;
FileName, OldPath: string;
json: TminiJson;

function GetOneDirFileInfo(Json: TminiJson; Path: string): string;
var
Status: Integer;
SearchRec: TSearchRec;
json_sub: TminiJson;
begin
Path := PathWithSlash(Path);
SearchRec := TSearchRec.Create;
Status := FindFirst(Path + '*.*', faAnyFile, SearchRec);
try
while Status = 0 do
begin
if SearchRec.Attr and faDirectory = faDirectory then
begin
if (SearchRec.name <> '.') and (SearchRec.name <> '..') then
GetOneDirFileInfo(Json, Path + SearchRec.Name + '\');
end else
begin
FileName := Path + SearchRec.Name;
try
if FileExists(FileName) then
begin
json_sub := Pub.GetJson;
json_sub.SO; //初始化 或 json.Init;
json_sub.S['filename'] := SearchRec.name;
json_sub.S['RelativePath'] := GetDeliBack(FileName, OldPath);
json_sub.S['FileTime'] := FileGetFileTimeA(FileName);
json_sub.I['size'] := SearchRec.Size;
json.A['list'] := json_sub;
end;
except
//print(ExceptionParam)
end;//}
end;
Status := FindNext(SearchRec);
end;
finally
FindClose(SearchRec);
SearchRec.Free;
end;//*)
end;
%>
<%
begin
//程序升级更新程序思路:要在服务器有一个专门的文件夹存放最新文件,检查哪些文件更新时,
//客户端与之对应的文件如果修改时间不同,大小不同就要重新下载

OldPath := 'D:\code\delphi\sign\发行文件'; //待更新源

json := Pub.GetJson; //这样创建json对象不需要自己释放,系统自动管理
json.SO; //初始化 或 json.Init;

// 验证是否登录代码
{if not Request.IsLogin('Logined') then
begin
json.S['retcode'] := '300';
json.S['retmsg'] := '你还没有登录(no logined)!';
print(json.AsJson(true));
exit;
end;//}

json.S['retcode'] := '200';
json.S['retmsg'] := '成功!';
if Request.V('opr') = '1' then
begin //获取服务上指定目录的文件信息
GetOneDirFileInfo(Json, OldPath);
end else
if Request.V('opr') = '2' then
begin //压缩下载一个文件
Response.SendFileToClient(ZipOneFile(PathWithSlash(OldPath) + Request.V('RelativePath'), ''));
end;
print(json.AsJson(true));
end;
%>

客户端代码

客户收到文件后,进行解压,再替换为新文件。以下是客户端实现的主代码:


procedure TMainForm.Upgrade_Run(var ThreadRetInfo: TThreadRetInfo);
var
HTML, ToPath, RelativePath, FN, Tmp, TmpFileName, FailFiles, SuccFiles: string;
Json, TmpJson: TminiJson;
lp: integer;
Flag: boolean;
SL, SLDate: TStringlist;
MS: TMemoryStream;
procedure HintMsg(Msg: string);
begin
FMyMsg := Msg; // '正在获取文件列表。。。';
ThreadRetInfo.Self.Synchronize(ThreadRetInfo.Self, MyUpdateface); //为什么不直接用匿名,因为laz不支持
end;
begin
ToPath := 'D:\superhtml'; //如果是当前程序更新 ExtractFilePath(ParamStr(0))

ThreadRetInfo.Ok := false;

HintMsg('正在获取文件列表。。。');
if not HttpPost('/接口/程序升级更新文件.html?opr=1',
'', ThreadRetInfo.ErrStr, ThreadRetInfo.HTML) then exit;
if Pos('{', ThreadRetInfo.HTML) <> 1 then
begin
ThreadRetInfo.ErrStr :='请先检查脚本源码是否配置正确!';
exit;
end;
ToPath := Pub.PathWithSlash(ToPath);

Json := TminiJson.Create;
SL := TStringlist.Create;
SLDate := TStringlist.Create;
try
Json.LoadFromString(ThreadRetInfo.HTML);
if json.S['retcode'] = '200' then
begin
TmpJson := json.A['list'];
for lp := 0 to TmpJson.length - 1 do
begin
HintMsg(lp.ToString + '/' + TmpJson.length.ToString + '正在检查文件:' + RelativePath);
RelativePath := TmpJson[lp].S['RelativePath'];
if trim(RelativePath) = '' then Continue;
Flag := FileExists(ToPath + RelativePath);
if Flag then
begin
if (PubFile.FileGetFileTimeA(ToPath + RelativePath) = TmpJson[lp].S['FileTime']) and
(PubFile.FileGetFileSize(ToPath + RelativePath)=TmpJson[lp].I['Size']) then
else
Flag := false;
end;
if not Flag then //此文件需要更新
begin
SL.Add(RelativePath);
SLDate.Add(TmpJson[lp].S['FileTime']);
end;
end;

//开始下载
FailFiles := '';
SuccFiles := '';
HintMsg('需要更新的文件共有' + IntToStr(SL.Count) + '个。。。');
for lp := 0 to SL.Count - 1 do
begin
RelativePath := SL[lp];
if RelativePath[1] = '\' then RelativePath := Copy(RelativePath, 2, MaxInt);
//MS := TMemoryStream.Create;
try
HintMsg(IntToStr(lp + 1) + '/' + IntToStr(SL.Count) + ', 正在下载[' + RelativePath + ']' + '。。。');
if not HttpPost('/接口/程序升级更新文件.html?opr=2',
'RelativePath=' + UrlEncode(RelativePath), ThreadRetInfo.ErrStr, ThreadRetInfo.HTML, MS) then exit;
if json.S['retcode'] <> '200' then
begin
ThreadRetInfo.ErrStr := Json.S['retmsg'];
exit;
end;
if MS = nil then
begin
ThreadRetInfo.ErrStr := json.S['retmsg'];
exit;
end else
begin
FN := ToPath + RelativePath;
TmpFileName := PubFile.FileGetTemporaryFileName();
MS.Position := 0;
MS.SaveToFile(TmpFileName);
MS.Free;
MS := nil;

//解压到指定目录
ForceDirectories(ExtractFilePath(FN));
if FileExists(FN) then
DeleteFile(FN);
if FileExists(FN) then //删除不掉只能改名
begin
Tmp := ExtractFilePath(FN) + '_Old@_' + ExtractFileName(FN);
DeleteFile(Tmp);
RenameFile(FN, Tmp);
end;
if FileExists(FN) then //删除不掉,又改名不成功,不能更新!!!!
FailFiles := FailFiles + #13#10 + RelativePath
else
begin
UnZipFileToFolder(TmpFileName, ExtractFilePath(FN));
if FileExists(FN) then
begin
SuccFiles := SuccFiles + #13#10 + RelativePath;
//虽然是解压,但文件的修改必须要重置,否则可能会有问题
PubFile.FileChangeFileDate(Fn, SLDate[lp]);
end else
FailFiles := FailFiles + #13#10 + RelativePath;
end;
end;
finally
//MS.Free;
end;
end;
ThreadRetInfo.HTML := '';
if trim(SuccFiles) <> '' then
ThreadRetInfo.HTML := '本次更新了以下文件:'#13#10 + SuccFiles;
if trim(FailFiles) <> '' then
ThreadRetInfo.HTML := trim(ThreadRetInfo.HTML + #13#10'以下文件更新失败:'#13#10 + FailFiles);
end;
finally
SL.Free;
Json.Free;
SLDate.Free;
end;
ThreadRetInfo.Ok := true;
end;

以下是Demo运行界面: