From c31a0cde6506576625aab584c2c45aac9168f2dd Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Thu, 3 Jan 2019 22:11:17 +0300 Subject: [PATCH] Maps can be saved to zip --- src/editor/Editor.lpr | 1 + src/editor/f_main.pas | 79 +++----- src/editor/f_savemap.pas | 89 ++++----- src/editor/f_selectmap.pas | 50 +++-- src/editor/g_map.pas | 58 ++---- src/editor/g_resources.pas | 139 ++++++++++++- src/shared/dfzip.pas | 391 +++++++++++++++++++++++++++++++++++++ 7 files changed, 638 insertions(+), 169 deletions(-) create mode 100644 src/shared/dfzip.pas diff --git a/src/editor/Editor.lpr b/src/editor/Editor.lpr index 21d8fe5..ccbcb60 100644 --- a/src/editor/Editor.lpr +++ b/src/editor/Editor.lpr @@ -16,6 +16,7 @@ uses WADSTRUCT in '../shared/WADSTRUCT.pas', CONFIG in '../shared/CONFIG.pas', xstreams in '../shared/xstreams.pas', + dfzip in '../shared/dfzip.pas', sfs in '../sfs/sfs.pas', sfsPlainFS in '../sfs/sfsPlainFS.pas', sfsZipFS in '../sfs/sfsZipFS.pas', diff --git a/src/editor/f_main.pas b/src/editor/f_main.pas index 2dbada8..32c13a2 100644 --- a/src/editor/f_main.pas +++ b/src/editor/f_main.pas @@ -336,7 +336,7 @@ uses f_mapoptions, g_basic, f_about, f_mapoptimization, f_mapcheck, f_addresource_texture, g_textures, f_activationtype, f_keys, - MAPREADER, f_selectmap, f_savemap, WADEDITOR, WADSTRUCT, MAPDEF, + MAPREADER, f_selectmap, f_savemap, WADEDITOR, MAPDEF, g_map, f_saveminimap, f_addresource, CONFIG, f_packmap, f_addresource_sound, f_maptest, f_choosetype, g_language, f_selectlang, ClipBrd, g_resources; @@ -6157,69 +6157,48 @@ end; procedure TMainForm.aDeleteMap(Sender: TObject); var - WAD: TWADEditor_1; - MapList: SArray; - MapName: Char16; - a: Integer; - str: String; + res: Integer; + FileName: String; + MapName: String; begin OpenDialog.Filter := _lc[I_FILE_FILTER_WAD]; if not OpenDialog.Execute() then Exit; - WAD := TWADEditor_1.Create(); - - if not WAD.ReadFile(OpenDialog.FileName) then - begin - WAD.Free(); - Exit; - end; - - WAD.CreateImage(); - - MapList := WAD.GetResourcesList(''); - + FileName := OpenDialog.FileName; SelectMapForm.Caption := _lc[I_CAP_REMOVE]; SelectMapForm.lbMapList.Items.Clear(); + SelectMapForm.GetMaps(FileName); - if MapList <> nil then - for a := 0 to High(MapList) do - SelectMapForm.lbMapList.Items.Add(win2utf(MapList[a])); + if SelectMapForm.ShowModal() <> mrOK then + Exit; - if (SelectMapForm.ShowModal() = mrOK) then - begin - str := SelectMapForm.lbMapList.Items[SelectMapForm.lbMapList.ItemIndex]; - MapName := ''; - Move(str[1], MapName[0], Min(16, Length(str))); - - if MessageBox(0, PChar(Format(_lc[I_MSG_DELETE_MAP_PROMT], - [MapName, OpenDialog.FileName])), - PChar(_lc[I_MSG_DELETE_MAP]), - MB_ICONQUESTION or MB_YESNO or - MB_DEFBUTTON2) <> mrYes then - Exit; + MapName := SelectMapForm.lbMapList.Items[SelectMapForm.lbMapList.ItemIndex]; + if MessageBox(0, PChar(Format(_lc[I_MSG_DELETE_MAP_PROMT], [MapName, OpenDialog.FileName])), PChar(_lc[I_MSG_DELETE_MAP]), MB_ICONQUESTION or MB_YESNO or MB_DEFBUTTON2) <> mrYes then + Exit; - WAD.RemoveResource('', utf2win(MapName)); - - MessageBox(0, PChar(Format(_lc[I_MSG_MAP_DELETED_PROMT], - [MapName])), - PChar(_lc[I_MSG_MAP_DELETED]), - MB_ICONINFORMATION or MB_OK or - MB_DEFBUTTON1); + g_DeleteResource(FileName, '', utf2win(MapName), res); + if res <> 0 then + begin + MessageBox(0, PChar('Cant delete map res=' + IntToStr(res)), PChar('Map not deleted!'), MB_ICONINFORMATION or MB_OK or MB_DEFBUTTON1); + Exit + end; - WAD.SaveTo(OpenDialog.FileName); + MessageBox( + 0, + PChar(Format(_lc[I_MSG_MAP_DELETED_PROMT], [MapName])), + PChar(_lc[I_MSG_MAP_DELETED]), + MB_ICONINFORMATION or MB_OK or MB_DEFBUTTON1 + ); // Удалили текущую карту - сохранять по старому ее нельзя: - if OpenedMap = (OpenDialog.FileName+':\'+MapName) then - begin - OpenedMap := ''; - OpenedWAD := ''; - MainForm.Caption := FormCaption; - end; - end; - - WAD.Free(); + if OpenedMap = (FileName + ':\' + MapName) then + begin + OpenedMap := ''; + OpenedWAD := ''; + MainForm.Caption := FormCaption + end end; procedure TMainForm.vleObjectPropertyKeyDown(Sender: TObject; diff --git a/src/editor/f_savemap.pas b/src/editor/f_savemap.pas index f5feee3..14336d9 100644 --- a/src/editor/f_savemap.pas +++ b/src/editor/f_savemap.pas @@ -35,7 +35,7 @@ var implementation uses - BinEditor, MAPREADER, WADEDITOR, WADSTRUCT, MAPSTRUCT, g_language; + MAPREADER, MAPSTRUCT, g_language, g_resources, sfs; {$R *.lfm} @@ -85,67 +85,64 @@ begin end; procedure TSaveMapForm.GetMaps(FileName: String; placeName: Boolean); -var - WAD: TWADEditor_1; - a, max_num, j: Integer; - ResList: SArray; - Data: Pointer; - Len: Integer; - Sign: Array [0..2] of Char; - nm: String; - + var + nm: String; + data: Pbyte; + list: TSFSFileList; + i, j, len, max_num: Integer; + sign: Array [0..2] of Char; begin lbMapList.Items.Clear(); max_num := 1; - WAD := TWADEditor_1.Create(); - WAD.ReadFile(FileName); - ResList := WAD.GetResourcesList(''); - - if ResList <> nil then - for a := 0 to High(ResList) do + list := SFSFileList(FileName); + if list <> nil then + begin + for i := 0 to list.Count - 1 do begin - if not WAD.GetResource('', ResList[a], Data, Len) then - Continue; + g_ReadResource(FileName, list.Files[i].path, list.Files[i].name, data, len); - CopyMemory(@Sign[0], Data, 3); - FreeMem(Data); - - if Sign = MAP_SIGNATURE then + if len >= 3 then begin - nm := win2utf(ResList[a]); - lbMapList.Items.Add(nm); - - if placeName then + sign[0] := chr(data[0]); + sign[1] := chr(data[1]); + sign[2] := chr(data[2]); + if sign = MAP_SIGNATURE then begin - nm := UpperCase(nm); - if (nm[1] = 'M') and - (nm[2] = 'A') and - (nm[3] = 'P') then + nm := win2utf(list.Files[i].name); + lbMapList.Items.Add(nm); + if placeName then begin - nm := Trim(Copy(nm, 4, Length(nm)-3)); - j := StrToIntDef(nm, 0); - if j >= max_num then - max_num := j + 1; - end; - end; + nm := UpperCase(nm); + if (nm[1] = 'M') and (nm[2] = 'A') and (nm[3] = 'P') then + begin + nm := Trim(Copy(nm, 4, Length(nm)-3)); + j := StrToIntDef(nm, 0); + if j >= max_num then + max_num := j + 1; + end + end + end end; - Sign := ''; + if len > 0 then FreeMem(data) end; - WAD.Free(); + list.Destroy; + end; + if placeName then - begin - nm := IntToStr(max_num); - if Length(nm) < 2 then - nm := '0' + nm; - nm := 'MAP' + nm; - eMapName.Text := nm; - end + begin + nm := IntToStr(max_num); + if Length(nm) < 2 then + nm := '0' + nm; + eMapName.Text := 'MAP' + nm + end else - eMapName.Text := ''; + begin + eMapName.Text := '' + end end; end. diff --git a/src/editor/f_selectmap.pas b/src/editor/f_selectmap.pas index 46f365c..8d5eecc 100644 --- a/src/editor/f_selectmap.pas +++ b/src/editor/f_selectmap.pas @@ -32,7 +32,7 @@ var implementation uses - BinEditor, MAPREADER, WADEDITOR, WADSTRUCT, MAPSTRUCT; + MAPREADER, MAPSTRUCT, g_resources, sfs; {$R *.lfm} @@ -54,41 +54,35 @@ begin end; procedure TSelectMapForm.GetMaps(FileName: String); -var - WAD: TWADEditor_1; - a: Integer; - ResList: SArray; - Data: Pointer; - Len: Integer; - Sign: Array [0..2] of Char; - + var + data: PByte; + list: TSFSFileList; + sign: Array [0..2] of Char; + i, len: Integer; begin lbMapList.Items.Clear(); - WAD := TWADEditor_1.Create(); - if not WAD.ReadFile(FileName) then - begin - WAD.Free(); - Exit; - end; + list := SFSFileList(FileName); + if list = nil then Exit; - ResList := WAD.GetResourcesList(''); + for i := 0 to list.Count - 1 do + begin + writeln('GetMap "' + list.Files[i].path + '" "' + list.Files[i].name + '"'); + g_ReadResource(FileName, list.Files[i].path, list.Files[i].name, data, len); - if ResList <> nil then - for a := 0 to High(ResList) do + if len >= 3 then begin - if not WAD.GetResource('', ResList[a], Data, Len) then - Continue; - - CopyMemory(@Sign[0], Data, 3); - FreeMem(Data); - - if Sign = MAP_SIGNATURE then - lbMapList.Items.Add(win2utf(ResList[a])); - Sign := ''; + sign[0] := chr(data[0]); + sign[1] := chr(data[1]); + sign[2] := chr(data[2]); + if sign = MAP_SIGNATURE then + lbMapList.Items.Add(win2utf(list.Files[i].name)) end; - WAD.Free(); + if len > 0 then FreeMem(data) + end; + + list.Destroy end; end. diff --git a/src/editor/g_map.pas b/src/editor/g_map.pas index fa091de..15a83dc 100644 --- a/src/editor/g_map.pas +++ b/src/editor/g_map.pas @@ -246,7 +246,7 @@ implementation uses BinEditor, g_textures, Dialogs, SysUtils, CONFIG, f_main, - Forms, Math, f_addresource_texture, WADEDITOR, g_language; + Forms, Math, f_addresource_texture, WADEDITOR, g_language, g_resources; const OLD_ITEM_MEDKIT_SMALL = 1; @@ -1053,7 +1053,6 @@ end; function SaveMap(Res: String): Pointer; var - WAD: TWADEditor_1; MapWriter: TMapWriter_1; textures: TTexturesRec1Array; panels: TPanelsRec1Array; @@ -1071,7 +1070,6 @@ var Len: LongWord; begin - WAD := nil; textures := nil; panels := nil; items := nil; @@ -1083,17 +1081,6 @@ begin Data := nil; Len := 0; -// Открываем WAD, если надо: - if Res <> '' then - begin - WAD := TWADEditor_1.Create(); - g_ProcessResourceStr(Res, FileName, SectionName, ResName); - if not WAD.ReadFile(FileName) then - WAD.FreeWAD(); - - WAD.CreateImage(); - end; - MapWriter := TMapWriter_1.Create(); // Сохраняем заголовок: @@ -1350,19 +1337,17 @@ begin // Записываем в WAD, если надо: if Res <> '' then - begin - s := utf2win(ResName); - WAD.RemoveResource('', s); - WAD.AddResource(Data, Len, s, ''); - WAD.SaveTo(FileName); - - FreeMem(Data); - WAD.Free(); - - Result := nil; - end + begin + g_ProcessResourceStr(Res, FileName, SectionName, ResName); + g_AddResource(FileName, SectionName, utf2win(ResName), Data, Len, a); + ASSERT(a = 0); + FreeMem(Data); + Result := nil + end else - Result := Data; + begin + Result := Data + end end; procedure AddTexture(res: String; Error: Boolean); @@ -1383,7 +1368,6 @@ end; function LoadMap(Res: String): Boolean; var - WAD: TWADEditor_1; MapReader: TMapReader_1; Header: TMapHeaderRec_1; textures: TTexturesRec1Array; @@ -1423,24 +1407,10 @@ begin MainForm.lLoad.Caption := _lc[I_LOAD_WAD]; Application.ProcessMessages(); -// Открываем WAD: - WAD := TWADEditor_1.Create(); +// Читаем ресурс карты g_ProcessResourceStr(Res, FileName, SectionName, ResName); - - if not WAD.ReadFile(FileName) then - begin - WAD.Free(); - Exit; - end; - -// Читаем ресурс карты: - if not WAD.GetResource('', utf2win(ResName), pData, Len) then - begin - WAD.Free(); - Exit; - end; - - WAD.Free(); + g_ReadResource(FileName, SectionName, ResName, pData, Len); + if pData = nil then Exit; MapReader := TMapReader_1.Create(); diff --git a/src/editor/g_resources.pas b/src/editor/g_resources.pas index efed125..6b73f65 100644 --- a/src/editor/g_resources.pas +++ b/src/editor/g_resources.pas @@ -2,12 +2,149 @@ unit g_resources; interface + (** + g_ReadResource + Read whole file from wad + + g_ReadSubResource + Read whole file from folded wad + + g_DeleteResource + Delete file from wad, res = 0 when ok + + g_AddResource + Add/overwrite file to wad, res = 0 when ok + **) + procedure g_ReadResource (wad, section, name: String; out data: PByte; out len: Integer); procedure g_ReadSubResource (wad, section0, name0, section1, name1: String; out data: PByte; out len: Integer); + procedure g_DeleteResource (wad, section, name: String; out res: Integer); + procedure g_AddResource (wad, section, name: String; const data: PByte; len: Integer; out res: Integer); implementation - uses sfs, utils, Classes; + uses sfs, xstreams, dfzip, utils, Classes, SysUtils, WADEDITOR; + + procedure g_AddResourceToDFWAD (wad, section, name: String; const data: PByte; len: Integer; out res: Integer); + var f: TWADEditor_1; + begin + res := 1; (* error *) + f := TWADEditor_1.Create(); + if not f.ReadFile(wad) then + begin + (* do nothing *) + end; + f.CreateImage; + f.RemoveResource(section, name); + f.AddResource(data, len, name, section); + f.SaveTo(wad); + f.Free; + res := 0 + end; + + procedure g_AddResourceToZip (wad, section, name: String; const data: PByte; len: Integer; out res: Integer); + var + i, n, len0: Integer; + data0: PByte; + list: TSFSFileList; + tmp, entry: String; + ts: TFileStream; + dir: array of TFileInfo; + + procedure Add (name: String; data: PByte; len: Integer); + var ds: TSFSMemoryChunkStream; + begin + SetLength(dir, n + 1); + ds := TSFSMemoryChunkStream.Create(data, len, false); + dir[n] := dfzip.ZipOne(ts, name, ds); + ds.Free; + INC(n); + end; + + begin + res := 1; + wad := ExpandFileName(wad); + list := SFSFileList(wad); + tmp := wad + '.tmp' + IntToStr(Random(100000)); + ts := TFileStream.Create(tmp, fmCreate); + n := 0; + SetLength(dir, 0); + if list <> nil then + begin + for i := 0 to list.Count - 1 do + begin + if (list.Files[i].path <> section) or (list.Files[i].name <> section) then + begin + g_ReadResource(wad, list.Files[i].path, list.Files[i].name, data0, len0); + if list.Files[i].path = '' then + entry := list.Files[i].name + else + entry := list.Files[i].path + '/' + list.Files[i].name; + Add(entry, data0, len0); + FreeMem(data0) + end + end; + list.Destroy + end; + + if section = '' then + entry := name + else + entry := section + '/' + name; + + Add(entry, data, len); + dfzip.writeCentralDir(ts, dir); + ts.Free; + + if FileExists(wad) then + ASSERT(RenameFile(wad, wad + '.bak')); + ASSERT(RenameFile(tmp, wad)); + res := 0 + end; + + procedure g_AddResource (wad, section, name: String; const data: PByte; len: Integer; out res: Integer); + var ext: String; + begin + res := 2; (* unknown type *) + ext := LowerCase(SysUtils.ExtractFileExt(wad)); + if ext = '.wad' then + g_AddResourceToDFWAD(wad, section, name, data, len, res) + else if (ext = '.pk3') or (ext = '.zip') or (ext = '.dfzip') then + g_AddResourceToZip(wad, section, name, data, len, res) + end; + + procedure g_DeleteResourceFromDFWAD (wad, section, name: String; out res: Integer); + var f: TWADEditor_1; + begin + res := 1; (* error *) + f := TWADEditor_1.Create; + if not f.ReadFile(wad) then + begin + f.Free; + Exit + end; + f.CreateImage; + f.RemoveResource(section, name); + f.SaveTo(wad); + f.Free; + res := 0 (* ok *) + end; + + procedure g_DeleteResourceFromZip (wad, section, name: String; out res: Integer); + begin + res := 1 (* not implemented *) + end; + + procedure g_DeleteResource (wad, section, name: String; out res: Integer); + var ext: String; + begin + res := 2; (* unknown type *) + ext := LowerCase(SysUtils.ExtractFileExt(wad)); + if ext = '.wad' then + g_DeleteResourceFromDFWAD(wad, section, name, res) + else if (ext = '.pk3') or (ext = '.zip') or (ext = '.dfzip') then + g_DeleteResourceFromZip(wad, section, name, res) + end; procedure g_ReadResource (wad, section, name: String; out data: PByte; out len: Integer); var diff --git a/src/shared/dfzip.pas b/src/shared/dfzip.pas new file mode 100644 index 0000000..ade97a5 --- /dev/null +++ b/src/shared/dfzip.pas @@ -0,0 +1,391 @@ +(* Copyright (C) Doom 2D: Forever Developers + * + * This program 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 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) +{$INCLUDE ../shared/a_modes.inc} +unit dfzip; + + (** Based on WadCvt tool **) + +interface + + uses SysUtils, Classes; + + type + TFileInfo = class + public + name: AnsiString; + pkofs: Int64; // offset of file header + size: Int64; + pksize: Int64; + crc: LongWord; + method: Word; + + constructor Create (); + end; + + function ZipOne (ds: TStream; fname: AnsiString; st: TStream; dopack: Boolean=true): TFileInfo; + procedure writeCentralDir (ds: TStream; files: array of TFileInfo); + +implementation + + uses utils, xstreams, crc, paszlib, e_log; + + const + uni2wint: array [128..255] of Word = ( + $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F, + $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F, + $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407, + $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457, + $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F, + $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F, + $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F, + $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F + ); + +constructor TFileInfo.Create; +begin + name := ''; + pkofs := 0; + size := 0; + pksize := 0; + crc := crc32(0, nil, 0); + method := 0; +end; + +function toUtf8 (const s: AnsiString): AnsiString; +var + uc: PUnicodeChar; + xdc: PChar; + pos, f: Integer; +begin + GetMem(uc, length(s)*8); + GetMem(xdc, length(s)*8); + try + FillChar(uc^, length(s)*8, 0); + FillChar(xdc^, length(s)*8, 0); + pos := 0; + for f := 1 to length(s) do + begin + if ord(s[f]) < 128 then + uc[pos] := UnicodeChar(ord(s[f])) + else + uc[pos] := UnicodeChar(uni2wint[ord(s[f])]); + Inc(pos); + end; + FillChar(xdc^, length(s)*8, 0); + f := UnicodeToUtf8(xdc, length(s)*8, uc, pos); + while (f > 0) and (xdc[f-1] = #0) do Dec(f); + SetLength(result, f); + Move(xdc^, result[1], f); + finally + FreeMem(xdc); + FreeMem(uc); + end; +end; + +// returs crc +function zpack (ds: TStream; ss: TStream; var aborted: Boolean): LongWord; +const + IBSize = 65536; + OBSize = 65536; +var + zst: TZStream; + ib, ob: PByte; + err: Integer; + rd: Integer; + eof: Boolean; + crc: LongWord; + dstp, srcsize: Int64; +begin + result := 0; + //aborted := true; exit; + aborted := false; + crc := crc32(0, nil, 0); + GetMem(ib, IBSize); + GetMem(ob, OBSize); + ss.position := 0; + dstp := ds.position; + srcsize := ss.size; + try + zst.next_out := ob; + zst.avail_out := OBSize; + zst.next_in := ib; + zst.avail_in := 0; + err := deflateInit2(zst, Z_BEST_COMPRESSION, Z_DEFLATED, -15, 9, 0); + if err <> Z_OK then raise Exception.Create(zerror(err)); + try + eof := false; + repeat + if zst.avail_in = 0 then + begin + // read input buffer part + rd := ss.read(ib^, IBSize); + if rd < 0 then raise Exception.Create('reading error'); + //writeln(' read ', rd, ' bytes'); + eof := (rd = 0); + if rd <> 0 then begin crc := crc32(crc, Pointer(ib), rd); result := crc; end; + zst.next_in := ib; + zst.avail_in := rd; + end; + // now process the whole input + while zst.avail_in > 0 do + begin + err := deflate(zst, Z_NO_FLUSH); + if err <> Z_OK then raise Exception.Create(zerror(err)); + if zst.avail_out < OBSize then + begin + //writeln(' written ', OBSize-zst.avail_out, ' bytes'); + if ds.position+(OBSize-zst.avail_out)-dstp >= srcsize then + begin + // this will be overwritten anyway + aborted := true; + exit; + end; + ds.writeBuffer(ob^, OBSize-zst.avail_out); + zst.next_out := ob; + zst.avail_out := OBSize; + end; + end; + until eof; + // do leftovers + while true do + begin + zst.avail_in := 0; + err := deflate(zst, Z_FINISH); + if (err <> Z_OK) and (err <> Z_STREAM_END) then raise Exception.Create(zerror(err)); + if zst.avail_out < OBSize then + begin + //writeln(' .written ', OBSize-zst.avail_out, ' bytes'); + if ds.position+(OBSize-zst.avail_out)-dstp >= srcsize then + begin + // this will be overwritten anyway + aborted := true; + exit; + end; + ds.writeBuffer(ob^, OBSize-zst.avail_out); + zst.next_out := ob; + zst.avail_out := OBSize; + end; + if err <> Z_OK then break; + end; + // succesfully flushed? + if (err <> Z_STREAM_END) then raise Exception.Create(zerror(err)); + finally + deflateEnd(zst); + end; + finally + FreeMem(ob); + FreeMem(ib); + end; +end; + +// this will write "extra field length" and extra field itself +{$IFDEF UTFEXTRA} +const UtfFlags = 0; + +type + TByteArray = array of Byte; + +function buildUtfExtra (fname: AnsiString): TByteArray; +var + crc: LongWord; + fu: AnsiString; + sz: Word; +begin + fu := toUtf8(fname); + if fu = fname then begin result := nil; exit; end; // no need to write anything + crc := crc32(0, @fname[1], length(fname)); + sz := 2+2+1+4+length(fu); + SetLength(result, sz); + result[0] := ord('u'); + result[1] := ord('p'); + Dec(sz, 4); + result[2] := sz and $ff; + result[3] := (sz shr 8) and $ff; + result[4] := 1; + result[5] := crc and $ff; + result[6] := (crc shr 8) and $ff; + result[7] := (crc shr 16) and $ff; + result[8] := (crc shr 24) and $ff; + Move(fu[1], result[9], length(fu)); +end; +{$ELSE} +const UtfFlags = (1 shl 10); // bit 11 +{$ENDIF} + +function ZipOne (ds: TStream; fname: AnsiString; st: TStream; dopack: Boolean=true): TFileInfo; +var + oldofs, nfoofs, pkdpos, rd: Int64; + sign: packed array [0..3] of Char; + buf: PChar; + bufsz: Integer; + aborted: Boolean = false; +{$IFDEF UTFEXTRA} + ef: TByteArray; +{$ENDIF} +begin + result := TFileInfo.Create(); + result.pkofs := ds.position; + result.size := st.size; + if result.size > 0 then result.method := 8 else result.method := 0; + if not dopack then + begin + result.method := 0; + result.pksize := result.size; + end; +{$IFDEF UTFEXTRA} + result.name := fname; + ef := buildUtfExtra(result.name); +{$ELSE} + result.name := toUtf8(fname); +{$ENDIF} + // write local header + sign := 'PK'#3#4; + ds.writeBuffer(sign, 4); + writeInt(ds, Word($0A10)); // version to extract + writeInt(ds, Word(UtfFlags)); // flags + writeInt(ds, Word(result.method)); // compression method + writeInt(ds, Word(0)); // file time + writeInt(ds, Word(0)); // file date + nfoofs := ds.position; + writeInt(ds, LongWord(result.crc)); // crc32 + writeInt(ds, LongWord(result.pksize)); // packed size + writeInt(ds, LongWord(result.size)); // unpacked size + writeInt(ds, Word(length(fname))); // name length +{$IFDEF UTFEXTRA} + writeInt(ds, Word(length(ef))); // extra field length +{$ELSE} + writeInt(ds, Word(0)); // extra field length +{$ENDIF} + ds.writeBuffer(fname[1], length(fname)); +{$IFDEF UTFEXTRA} + if length(ef) > 0 then ds.writeBuffer(ef[0], length(ef)); +{$ENDIF} + if dopack then + begin + // now write packed data + if result.size > 0 then + begin + pkdpos := ds.position; + st.position := 0; + result.crc := zpack(ds, st, aborted); + result.pksize := ds.position-pkdpos; + if {result.pksize >= result.size} aborted then + begin + // there's no sence to pack this file, so just store it + st.position := 0; + ds.position := result.pkofs; + result.Free(); + // store it + result := ZipOne(ds, fname, st, false); + exit; + end + else + begin + // fix header + oldofs := ds.position; + ds.position := nfoofs; + writeInt(ds, LongWord(result.crc)); // crc32 + writeInt(ds, LongWord(result.pksize)); // crc32 + ds.position := oldofs; + end; + end; + end + else + begin + bufsz := 1024*1024; + GetMem(buf, bufsz); + try + st.position := 0; + result.crc := crc32(0, nil, 0); + result.pksize := 0; + while result.pksize < result.size do + begin + rd := result.size-result.pksize; + if rd > bufsz then rd := bufsz; + st.readBuffer(buf^, rd); + ds.writeBuffer(buf^, rd); + Inc(result.pksize, rd); + result.crc := crc32(result.crc, buf, rd); + end; + finally + FreeMem(buf); + end; + // fix header + oldofs := ds.position; + ds.position := nfoofs; + writeInt(ds, LongWord(result.crc)); // crc32 + ds.position := oldofs; + write('(S) '); + end; +end; + + +procedure writeCentralDir (ds: TStream; files: array of TFileInfo); +var + cdofs, cdend: Int64; + sign: packed array [0..3] of Char; + f: Integer; +{$IFDEF UTFEXTRA} + ef: TByteArray; +{$ENDIF} +begin + cdofs := ds.position; + for f := 0 to high(files) do + begin +{$IFDEF UTFEXTRA} + ef := buildUtfExtra(files[f].name); +{$ENDIF} + sign := 'PK'#1#2; + ds.writeBuffer(sign, 4); + writeInt(ds, Word($0A10)); // version made by + writeInt(ds, Word($0010)); // version to extract + writeInt(ds, Word(UtfFlags)); // flags + writeInt(ds, Word(files[f].method)); // compression method + writeInt(ds, Word(0)); // file time + writeInt(ds, Word(0)); // file date + writeInt(ds, LongWord(files[f].crc)); + writeInt(ds, LongWord(files[f].pksize)); + writeInt(ds, LongWord(files[f].size)); + writeInt(ds, Word(length(files[f].name))); // name length +{$IFDEF UTFEXTRA} + writeInt(ds, Word(length(ef))); // extra field length +{$ELSE} + writeInt(ds, Word(0)); // extra field length +{$ENDIF} + writeInt(ds, Word(0)); // comment length + writeInt(ds, Word(0)); // disk start + writeInt(ds, Word(0)); // internal attributes + writeInt(ds, LongWord(0)); // external attributes + writeInt(ds, LongWord(files[f].pkofs)); // header offset + ds.writeBuffer(files[f].name[1], length(files[f].name)); +{$IFDEF UTFEXTRA} + if length(ef) > 0 then ds.writeBuffer(ef[0], length(ef)); +{$ENDIF} + end; + cdend := ds.position; + // write end of central dir + sign := 'PK'#5#6; + ds.writeBuffer(sign, 4); + writeInt(ds, Word(0)); // disk number + writeInt(ds, Word(0)); // disk with central dir + writeInt(ds, Word(length(files))); // number of files on this dist + writeInt(ds, Word(length(files))); // number of files total + writeInt(ds, LongWord(cdend-cdofs)); // size of central directory + writeInt(ds, LongWord(cdofs)); // central directory offset + writeInt(ds, Word(0)); // archive comment length +end; + +end. -- 2.29.2