Abbrevia is a compression toolkit for Embarcadero Delphi, C++ Builder, and Kylix, and FreePascal. It supports PKZip, Microsoft CAB, tar, gzip, bzip2 and zlib compression formats, and the creation of self-extracting executables. It includes several visual components that simplify displaying zip files.
Abbrevia 5.0 adds a number of new features and support for more platforms:
RAD Studio XE2 support, including both 64-bit Windows and OS X
FreePascal support on Windows, OS X, and Linux
TAbTreeView and TAbListView VCL controls that provide an Explorer/WinZip-like interface
ZIP64 support, for archives larger than 2GB
Improved split/spanned zip support
Expanded LZMA support
Unicode filenames in tar and gzip archives
This is a source-only release. It includes design-time and run-time packages for Delphi 6 through Delphi XE2, C++Builder 2009 through XE2, and Kylix 3. FreePascal is supported, but runtime/design time packages are not included. The LZMA, PPMd, and WavPack algorithms are only supported on Delphi/C++Builder for Windows (32 and 64-bit).
Unzip the release files into a directory (e.g., d:\abbrevia).
Start Delphi or C++Builder.
Add the source subdirectory (e.g. d:\abbrevia\source) to the Delphi Library path. When using XE2 or later, add it to all platforms.
If using C++Builder, add the source subdirectory to C++Builder's Include and Library paths.
Open the project group in the packages directory that corresponds to the IDE being used (e.g. "Delphi XE2.groupproj").
Start at the top of the project group and compile each package in turn. If using C++Builder, install each one after compiling.
Select the "AbbreviaVCLDesign" package and install it. The IDE should notify you that the components have been installed. If you are using Delphi 7 you can install "AbbreviaCLXDesign" as well to get CLX designtime support.
Make sure the PATH environmental variable contains the directory in which the compiled packages (i.e. BPL or DPL files) were placed.
Support forums are available on the SourceForge project site.
Bug reports can be entered in the bug tracker. If possible please include a small test case that reproduces the issue. Sample files can be attached to the bug report, and confidential data can be emailed to the project administrator.
If you have something you would like to see in the product feel free to add a feature request.
The current source code is available in the Subversion repository. The code here may not be as stable or tested as the official releases, but may include bug fixes or new features not yet included in the downloadable releases.
The repository also includes DUnit tests, the source code to the third-party libraries, and the Help source code.
If you want to help make Abbrevia better, there are several ways to get involved. We welcome help with features and bug fixes. Just look in the issue tracker to see what's needed. We're also looking for help for:
Abbrevia is licensed under the Mozilla Public License, version 1.1. It can be used in commercial and closed-source applications provided any changes to Abbrevia units are made available electronically.
The WavPack library used for zipx decompression has its own license, included as "WavPack License.txt". Redistribution requires a copyright notice in your documentation or elsewhere in your distribution. WavPack support can be removed by disabling the UnzipZipxSupport or UnzipWavPackSupport conditional define in AbDefine.inc.
These are the most significant features, fixes and changes made since v4.0. Information on earlier versions is available in the full changelog.
Features
Added support for Delphi/C++Builder XE2, including the 64-bit Windows and OS X platforms.
Added support for FreePascal 2.4/2.6 on Windows, OS X, and Linux.
Added TAbTreeView and TAbListView VCL controls that provide an Explorer/WinZip-like interface, and ComCtrlsDemo Delphi example to demonstrate their usage.
Added ZIP64 support (reading/writing zip archives larger than 2GB, containing files larger than 2GB, or containing more than 65K files).
Significantly improved split/spanned zip support.
Added LZMA buffer-to-buffer compression/decompression (LzmaEncodeBuffer and LzmaDecodeBuffer) and compression/decompression stream descendants (TAbLZMACompressionStream and TAbLZMADecompressionStream). Thanks to Pierre le Riche.
Added support for tar and gzip archives containing filenames encoded in the system ANSI and OEM codepage and UTF-8. New archives are written using UTF-8.
Added icon/text to RAD Studio's splash screen and about box. Thanks to Lance Rasmussen.
Added VCL TAbProgressBar control that can replace TAbMeter.
Added 64-bit COM dll and support for per-user registration.
API Changes
Renamed LzEncode/LzDecode to LzmaEncodeStream/LzmaDecodeStream.
Renamed LzmaDecode to LzmaDecodeStream.
Various changes due to split/spanned zip changes (see below).
Bug Fixes
Fixed support for opening paths with a "\\?\" prefix.
Fixed buffer overflow in AbUtils.pas.
Fixed freshening/replacing items using absolute paths.
Fixed CAB files created with Delphi 2009 and later incorrectly including the "has next volume" flag.
Fixed Delphi 6 support. Thanks to Peter Luijer.
Fixed AbFindFiles so it finds system and hidden folders if the SearchAttr parameter includes them [3372355].
Fixed hang when trying to extract files that cross CAB boundaries when the next cab is not available [3370538].
Fixed extracting CAB archives so OnProcessItemFailure isn't called after a successful extraction.
Fixed LZMA support for streams larger than 2GB.
Fixed AbGetDriveFreeSpace buffer overflow and fixed support for free space larger than 2GB.
Fixed support for modifying SFX zips with non-native stubs (Linux on Windows and vice versa).
Fixed TAbBitBucketStream so it doesn't fault on writes larger than the buffer size, and supports sizes over 2GB.
Zip local file headers are now preserved when copying unmodified files to a new archive.
Local file headers are no longer copies of the central directory headers, since many of the defined extra data fields have different values in the two locations.
Fixed IZipKit (COM) support for enumerations (for each).
Split/Spanned Zip Changes
Bug Fixes
Added support for reading/writing unequally sized spans.
Split/spanned zips are now written to the final location as they're compressed, rather than writing everything to a virtual memory stream first.
Fixed writing headers that can't be spanned so they trigger a new span if necessary.
API Changes
Converting from an unspanned archive to a spanned one is no longer supported.
OnRequestImage's span numbers are now 1-based instead of 0-based to match OnRequestNthDisk.
OnArchiveSaveProgress is now called at the same time as OnArchiveProgress, since there isn't a lengthy copy after a spanned archive is written.
TAbSpanStream has been replaced by TAbSpanReadStream and TAbSpanWriteStream.
================================================
FILE: lib/abbrevia/WavPack License.txt
================================================
Copyright (c) 1998 - 2009 Conifer Software
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
* Neither the name of Conifer Software nor the names of its contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
================================================
FILE: lib/abbrevia/examples/Delphi/Abbrexam.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: ABBREXAM.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program Abbrexam;
{$R *.res}
uses
Forms,
udemodlg in 'udemodlg.pas' {DemoDlg},
uexample in 'Uexample.pas' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TDemoDlg, DemoDlg);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/BaseDlgu.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
unit Basedlgu;
interface
uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
StdCtrls, FileCtrl, ExtCtrls;
type
TBaseDlg = class(TForm)
Bevel1: TBevel;
DirectoryListBox1: TDirectoryListBox;
CancelBtn: TButton;
OkBtn: TButton;
procedure DirectoryListBox1Change(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
BaseDirectory : string;
end;
var
BaseDlg: TBaseDlg;
implementation
{$R *.DFM}
procedure TBaseDlg.DirectoryListBox1Change(Sender: TObject);
begin
BaseDirectory := DirectoryListBox1.Directory;
end;
procedure TBaseDlg.FormShow(Sender: TObject);
begin
DirectoryListBox1.Directory := BaseDirectory;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/CabExt.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UNZIP.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program CabExt;
uses
Forms,
CabExt1 in 'CabExt1.pas' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/CabExt1.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: EXTCAB.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit CabExt1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
AbArcTyp, AbCBrows, ComCtrls, AbCabExt, AbCabTyp, AbBase, AbBrowse, AbMeter, AbUtils;
type
TForm1 = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
Memo1: TMemo;
Label1: TLabel;
Button2: TButton;
AbMeter1: TAbMeter;
AbCabExtractor1: TAbCabExtractor;
procedure Button1Click(Sender: TObject);
procedure AbCabExtractor1ConfirmProcessItem(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType;
var Confirm: Boolean);
procedure Button2Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const
MainCaption = 'Cabinet Extractor';
var
AbortFlag : Boolean;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then begin
with AbCabExtractor1 do begin
FileName := OpenDialog1.FileName;
BaseDirectory := ExtractFilePath(FileName);
Cursor := crHourglass;
try
ExtractFiles('*.*');
except {swallow exception if aborted}
end;
Cursor := crDefault;
end;
end;
Caption := MainCaption;
AbortFlag := False;
end;
procedure TForm1.AbCabExtractor1ConfirmProcessItem(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType; var Confirm: Boolean);
begin
Caption := 'Extracting ' + Item.Filename;
Confirm := not AbortFlag;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
AbortFlag := True;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
AbCabExtractor1.FileName := '';
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/CabFind.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: FINDER.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program CabFind;
uses
Forms,
CabFind1 in 'CabFind1.pas' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/CabFind1.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: CABFIND1.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit CabFind1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, FileCtrl, Buttons, ExtCtrls,
AbArcTyp, AbBrowse, AbCBrows, AbBase;
type
TForm1 = class(TForm)
Edit1: TEdit;
Label1: TLabel;
Memo1: TMemo;
DriveComboBox1: TDriveComboBox;
DirectoryListBox1: TDirectoryListBox;
FileListBox1: TFileListBox;
Memo2: TMemo;
Label2: TLabel;
AbCabBrowser1: TAbCabBrowser;
Button1: TButton;
Button2: TButton;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Edit1Change(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
Aborted: Boolean;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Aborted := True;
end;
procedure TForm1.Edit1Change(Sender: TObject);
begin
Button1.Enabled := Length( Edit1.Text ) > 0;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i : Integer;
CurFile : string;
begin
Button1.Enabled := False;
Memo1.Clear;
try
Button2.Enabled := True;
Aborted := False;
{look in the file list box for the file}
for i := 0 to pred( FileListBox1.Items.Count ) do begin
Application.ProcessMessages;
if Aborted then
break;
if CompareText( Edit1.Text, FileListBox1.Items[i] ) = 0 then begin
Memo1.Lines.Add( 'Found in ' + FileListBox1.Directory );
break;
end;
{now add search of zip and self extracting files}
CurFile := UpperCase( FileListBox1.Items[i] );
if ( Pos( '.CAB', CurFile ) > 0 ) then begin
try
AbCabBrowser1.FileName := FileListBox1.Items[i];
if AbCabBrowser1.FindFile(Edit1.Text) >= 0 then
Memo1.Lines.Add( 'Found in ' + FileListBox1.Items[i] );
except
end;
end;
end;
finally
Memo1.Lines.Add( 'Done!' );
Edit1.Enabled := True;
Button1.Enabled := True;
Button2.Enabled := False;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Aborted := True;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/CabView.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
program CabView;
uses
Forms,
CabView1 in 'CabView1.PAS' {Form1};
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/CabView1.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: CABVIEW1.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit CabView1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Grids, StdCtrls, ExtCtrls, Menus, FileCtrl,
AbArcTyp, AbCabTyp, AbMeter, AbDlgDir, AbView, AbCView, AbCBrows,
AbBrowse, AbCabMak, AbCabKit, AbBase, AbUtils;
type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;
Panel1: TPanel;
FontDialog1: TFontDialog;
MainMenu1: TMainMenu;
File1: TMenuItem;
Open1: TMenuItem;
Close1: TMenuItem;
N1: TMenuItem;
Print1: TMenuItem;
Exit1: TMenuItem;
ColorDialog1: TColorDialog;
CabView1: TMenuItem;
Attributes1: TMenuItem;
Itemname1: TMenuItem;
Packed1: TMenuItem;
Method1: TMenuItem;
Ratio1: TMenuItem;
CRC1: TMenuItem;
Fileattributes1: TMenuItem;
Filetype1: TMenuItem;
Encryption1: TMenuItem;
Timestamp1: TMenuItem;
Filesize1: TMenuItem;
Versionmade1: TMenuItem;
Versionneeded1: TMenuItem;
Path1: TMenuItem;
Display1: TMenuItem;
Columnlines1: TMenuItem;
Columnmoving1: TMenuItem;
Columnresizing1: TMenuItem;
MultiSelect1: TMenuItem;
Rowlines1: TMenuItem;
Thumbtracking1: TMenuItem;
Trackactiverow1: TMenuItem;
Sort1: TMenuItem;
Itemname2: TMenuItem;
Packed2: TMenuItem;
Ratio2: TMenuItem;
Timestamp2: TMenuItem;
Filesize2: TMenuItem;
Select1: TMenuItem;
SelectAll1: TMenuItem;
ClearSelections1: TMenuItem;
Rows1: TMenuItem;
Rowheight1: TMenuItem;
Headerheight1: TMenuItem;
Font1: TMenuItem;
Alternatecolors1: TMenuItem;
Action1: TMenuItem;
Extract1: TMenuItem;
ShowIcons1: TMenuItem;
Colors1: TMenuItem;
Selectedcolor: TMenuItem;
Selectedtextcolor: TMenuItem;
Alternatecolor1: TMenuItem;
Alternatetextcolor1: TMenuItem;
Panel2: TPanel;
AbMeter1: TAbMeter;
Label1: TLabel;
Label2: TLabel;
PopupMenu1: TPopupMenu;
Extract2: TMenuItem;
AbMeter2: TAbMeter;
AbCabView1: TAbCabView;
Extractoptions1: TMenuItem;
CreateDirs1: TMenuItem;
RestorePath1: TMenuItem;
AbCabKit1: TAbCabKit;
Additems1: TMenuItem;
procedure AbCabView1Click(Sender: TObject);
procedure AttributeClick(Sender: TObject);
procedure DisplayOptionClick(Sender: TObject);
procedure SortAttributeClick(Sender: TObject);
procedure SetAttribute(Attr : TAbViewAttribute; Value : Boolean);
procedure SetDisplayOption(Option : TAbDisplayOption; Value : Boolean);
procedure SetExtractOption(Option : TAbExtractOption; Value : Boolean);
procedure SetSortAttribute(Option : TAbSortAttribute; Value : Boolean);
procedure Open1Click(Sender: TObject);
procedure Close1Click(Sender: TObject);
procedure SelectAll1Click(Sender: TObject);
procedure ClearSelections1Click(Sender: TObject);
procedure Font1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure ExtractOptionClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Selected1Click(Sender: TObject);
procedure Selectedtext1Click(Sender: TObject);
procedure Rowheight1Click(Sender: TObject);
procedure Headerheight1Click(Sender: TObject);
procedure Extract1Click(Sender: TObject);
procedure AbCabKit1ConfirmProcessItem(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType;
var Confirm: Boolean);
procedure AbCabView1Change(Sender: TObject);
procedure Alternatecolor1Click(Sender: TObject);
procedure Alternatetextcolor1Click(Sender: TObject);
procedure AbCabKit1Save(Sender: TObject);
procedure Additems1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const
MainCaption = ' TAbCabView example';
{ -------------------------------------------------------------------------- }
procedure TForm1.SetAttribute(Attr : TAbViewAttribute; Value : Boolean);
procedure SetMenu(Item : TMenuItem);
begin
Item.Checked := Value;
if Item.Checked then
AbCabView1.Attributes := AbCabView1.Attributes + [Attr]
else
AbCabView1.Attributes := AbCabView1.Attributes - [Attr];
end;
begin
case Attr of
vaItemName : SetMenu(ItemName1);
vaPacked : SetMenu(Packed1);
vaMethod : SetMenu(Method1);
vaRatio : SetMenu(Ratio1);
vaCRC : SetMenu(CRC1);
vaFileAttributes : SetMenu(FileAttributes1);
vaFileType : SetMenu(FileType1);
vaEncryption : SetMenu(Encryption1);
vaTimeStamp : SetMenu(TimeStamp1);
vaFileSize : SetMenu(FileSize1);
vaVersionMade : SetMenu(VersionMade1);
vaVersionNeeded : SetMenu(VersionNeeded1);
vaPath : SetMenu(Path1);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.SetDisplayOption(Option : TAbDisplayOption; Value : Boolean);
procedure SetMenu(Item : TMenuItem);
begin
Item.Checked := Value;
if Item.Checked then
AbCabView1.DisplayOptions := AbCabView1.DisplayOptions + [Option]
else
AbCabView1.DisplayOptions := AbCabView1.DisplayOptions - [Option]
end;
begin
case Option of
doAlternateColors : SetMenu(AlternateColors1);
doColLines : SetMenu(ColumnLines1);
doColMove : SetMenu(ColumnMoving1);
doColSizing : SetMenu(ColumnResizing1);
doMultiSelect : SetMenu(MultiSelect1);
doRowLines : SetMenu(RowLines1);
doShowIcons : SetMenu(ShowIcons1);
doThumbTrack : SetMenu(ThumbTracking1);
doTrackActiveRow : SetMenu(TrackActiveRow1);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.SetExtractOption(Option : TAbExtractOption; Value : Boolean);
procedure SetMenu(Item : TMenuItem);
begin
Item.Checked := Value;
if Item.Checked then
AbCabKit1.ExtractOptions := AbCabKit1.ExtractOptions + [Option]
else
AbCabKit1.ExtractOptions := AbCabKit1.ExtractOptions - [Option]
end;
begin
case Option of
eoCreateDirs : SetMenu(CreateDirs1);
eoRestorePath : SetMenu(RestorePath1);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.SetSortAttribute(Option : TAbSortAttribute; Value : Boolean);
procedure SetMenu(Item : TMenuItem);
begin
Item.Checked := Value;
if Item.Checked then
AbCabView1.SortAttributes := AbCabView1.SortAttributes + [Option]
else
AbCabView1.SortAttributes := AbCabView1.SortAttributes - [Option];
end;
begin
case Option of
saItemName : SetMenu(ItemName2);
saPacked : SetMenu(Packed2);
saRatio : SetMenu(Ratio2);
saTimeStamp : SetMenu(TimeStamp2);
saFileSize : SetMenu(FileSize2);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.AbCabView1Click(Sender: TObject);
begin
Panel1.Caption := AbCabView1.Items[AbCabView1.ActiveRow].Filename;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Open1Click(Sender: TObject);
begin
OpenDialog1.Filename := '*.cab';
if OpenDialog1.Execute then begin
AbCabKit1.Filename := OpenDialog1.Filename;
{ AbCabKit1.BaseDirectory := ExtractFilePath(AbCabKit1.Filename);}
Caption := AbCabKit1.Filename +
' ' + IntToStr(AbCabView1.Count) + ' items';
Action1.Enabled := True;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Close1Click(Sender: TObject);
begin
AbCabKit1.Filename := '';
Caption := MainCaption;
Panel1.Caption := '';
Action1.Enabled := False;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.AttributeClick(Sender: TObject);
begin
with TMenuItem(Sender) do
SetAttribute(TAbViewAttribute(Tag), not Checked);
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.DisplayOptionClick(Sender: TObject);
begin
with TMenuItem(Sender) do
SetDisplayOption(TAbDisplayOption(Tag), not Checked);
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.SortAttributeClick(Sender: TObject);
begin
with TMenuItem(Sender) do
SetSortAttribute(TAbSortAttribute(Tag), not Checked);
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.SelectAll1Click(Sender: TObject);
begin
AbCabView1.SelectAll;
AbCabView1Click(nil);
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.ClearSelections1Click(Sender: TObject);
begin
AbCabView1.ClearSelections;
AbCabView1Click(nil);
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.ExtractOptionClick(Sender: TObject);
begin
with TMenuItem(Sender) do
SetExtractOption(TAbExtractOption(Tag), not Checked);
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Font1Click(Sender: TObject);
begin
FontDialog1.Font := AbCabView1.Font;
if FontDialog1.Execute then
AbCabView1.Font := FontDialog1.Font;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.FormCreate(Sender: TObject);
var
i : TAbViewAttribute;
j : TAbDisplayOption;
k : TAbSortAttribute;
m : TAbExtractOption;
begin
for i := Low(TAbViewAttribute) to High(TAbViewAttribute) do
SetAttribute(i, i in AbCabView1.Attributes);
for j := Low(TAbDisplayOption) to High(TAbDisplayOption) do
SetDisplayOption(j, j in AbCabView1.DisplayOptions);
for k := Low(TAbSortAttribute) to High(TAbSortAttribute) do
SetSortAttribute(k, k in AbCabView1.SortAttributes);
for m := Low(TAbExtractOption) to High(TAbExtractOption) do
SetExtractOption(m, m in AbCabKit1.ExtractOptions);
Caption := MainCaption;
Action1.Enabled := AbCabKit1.FileName <> '';
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Selected1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
AbCabView1.Colors.Selected := ColorDialog1.Color;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Selectedtext1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
AbCabView1.Colors.SelectedText := ColorDialog1.Color;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Rowheight1Click(Sender: TObject);
var
s : string;
begin
s := IntToStr(AbCabView1.DefaultRowHeight);
if InputQuery(MainCaption, 'Row Height', s) then
AbCabView1.DefaultRowHeight := StrToIntDef(s, 18);
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Headerheight1Click(Sender: TObject);
var
s : string;
begin
s := IntToStr(AbCabView1.HeaderRowHeight);
if InputQuery(MainCaption, 'Header Height', s) then
AbCabView1.HeaderRowHeight := StrToIntDef(s, 18);
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Extract1Click(Sender: TObject);
var
i : Longint;
Continue : Boolean;
begin
with TAbDirDlg.Create(Self) do begin
Caption := 'Directory';
AdditionalText := 'Select folder to extract into';
Continue := Execute;
if Continue then
AbCabKit1.BaseDirectory := SelectedFolder;
Free;
end;
if not Continue then
Exit;
Panel1.Caption := '';
with AbCabView1 do
for i := 0 to Pred(Count) do
Items[i].Tagged := Selected[i];
AbCabKit1.ExtractTaggedItems;
AbCabView1.ClearSelections;
Panel1.Caption := '';
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.AbCabKit1ConfirmProcessItem(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType; var Confirm: Boolean);
var
s : string;
begin
if (ProcessType = ptExtract) then
s := 'Extracting '
else
s := '??? ';
Panel1.Caption := s + Item.Filename;
Confirm := True;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.AbCabView1Change(Sender: TObject);
begin
Caption := AbCabKit1.Filename +
' ' + IntToStr(AbCabView1.Count) + ' items';
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Alternatecolor1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
AbCabView1.Colors.Alternate := ColorDialog1.Color;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Alternatetextcolor1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
AbCabView1.Colors.AlternateText := ColorDialog1.Color;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.AbCabKit1Save(Sender: TObject);
begin
Panel1.Caption := 'Saving ' + AbCabKit1.Filename;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Additems1Click(Sender: TObject);
var
i : Integer;
begin
with OpenDialog1 do begin
FileName := '*.*';
Title := 'Select files to add';
if Execute then
if (Files.Count > 0) then
for i := 0 to Pred(Files.Count) do
AbCabKit1.AddFiles(Files[i], 0);
end;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ComCtrlsDemo.dpr
================================================
program ComCtrlsDemo;
uses
Forms,
ComCtrlsMain in 'ComCtrlsMain.pas' {frmComCtrls};
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TfrmComCtrls, frmComCtrls);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ComCtrlsMain.dfm
================================================
object frmComCtrls: TfrmComCtrls
Left = 0
Top = 0
Caption = 'AbComCtrls Example'
ClientHeight = 524
ClientWidth = 699
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
Menu = MainMenu
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Splitter1: TSplitter
Left = 153
Top = 0
Height = 524
ExplicitLeft = 360
ExplicitTop = 240
ExplicitHeight = 100
end
object AbTreeView: TAbTreeView
Left = 0
Top = 0
Width = 153
Height = 524
Align = alLeft
Indent = 19
TabOrder = 0
Items.NodeData = {
0301000000200000000000000000000000FFFFFFFFFFFFFFFF00000000000000
000000000001015C00}
Archive = AbUnZipper
ListView = AbListView
end
object Panel1: TPanel
Left = 156
Top = 0
Width = 543
Height = 524
Align = alClient
Caption = 'Panel1'
TabOrder = 1
ExplicitLeft = 264
ExplicitTop = 272
ExplicitWidth = 185
ExplicitHeight = 41
object Splitter2: TSplitter
Left = 1
Top = 335
Width = 541
Height = 3
Cursor = crVSplit
Align = alBottom
ExplicitLeft = 539
ExplicitTop = 1
ExplicitWidth = 337
end
object Memo1: TMemo
Left = 1
Top = 338
Width = 541
Height = 185
Align = alBottom
Lines.Strings = (
'Memo1')
TabOrder = 0
ExplicitLeft = 354
ExplicitTop = 1
ExplicitWidth = 522
end
object AbListView: TAbListView
Left = 1
Top = 1
Width = 541
Height = 334
Align = alClient
Archive = AbUnZipper
TabOrder = 1
TreeView = AbTreeView
OnSelectItem = ListViewSelectItem
ExplicitLeft = 328
ExplicitTop = 112
ExplicitWidth = 250
ExplicitHeight = 150
end
end
object AbUnZipper: TAbUnZipper
Left = 96
Top = 24
end
object MainMenu: TMainMenu
Left = 16
Top = 24
object mnuFile: TMenuItem
Caption = 'File'
object mnuOpenArchive: TMenuItem
Caption = 'Open...'
OnClick = OpenArchiveClick
end
end
object mnuView: TMenuItem
Caption = 'View'
object mnuAllFiles: TMenuItem
AutoCheck = True
Caption = 'All Files (WinZip Style)'
GroupIndex = 1
RadioItem = True
OnClick = FolderStyleClick
end
object mnuFilesByFolder: TMenuItem
AutoCheck = True
Caption = 'Files By Folder (Explorer Style)'
Checked = True
GroupIndex = 1
RadioItem = True
OnClick = FolderStyleClick
end
object N1: TMenuItem
Caption = '-'
GroupIndex = 1
end
object mnuIcons: TMenuItem
AutoCheck = True
Caption = 'Icons'
Checked = True
GroupIndex = 2
RadioItem = True
OnClick = ViewStyleClick
end
object mnuList: TMenuItem
AutoCheck = True
Caption = 'List'
GroupIndex = 2
RadioItem = True
OnClick = ViewStyleClick
end
object mnuDetails: TMenuItem
AutoCheck = True
Caption = 'Details'
GroupIndex = 2
RadioItem = True
OnClick = ViewStyleClick
end
end
end
object OpenDialog: TOpenDialog
Filter = 'Archive Files|*.zip;*.tar;*.gz;*.tgz;*.bz2;*.tbz'
Options = [ofEnableSizing]
Left = 56
Top = 24
end
end
================================================
FILE: lib/abbrevia/examples/Delphi/ComCtrlsMain.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* Craig Peterson
*
* Portions created by the Initial Developer are Copyright (C) 2011
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* This demonstrates the TAbTreeView and TAbListView *}
{* components. By setting references to each other and *}
{* a shared TAbBaseBrowser descendant (e.g., TAbZipKit *}
{* you can have a WinZip/Explorer-like interface without *}
{* any code. *}
{*********************************************************}
unit ComCtrlsMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Menus, ComCtrls, AbComCtrls, AbBase, AbBrowse,
AbZBrows, AbUnzper;
type
TfrmComCtrls = class(TForm)
AbUnZipper: TAbUnZipper;
AbTreeView: TAbTreeView;
AbListView: TAbListView;
MainMenu: TMainMenu;
mnuFile: TMenuItem;
mnuOpenArchive: TMenuItem;
Splitter1: TSplitter;
Splitter2: TSplitter;
Memo1: TMemo;
OpenDialog: TOpenDialog;
mnuView: TMenuItem;
mnuAllFiles: TMenuItem;
mnuFilesByFolder: TMenuItem;
N1: TMenuItem;
mnuIcons: TMenuItem;
mnuList: TMenuItem;
mnuDetails: TMenuItem;
Panel1: TPanel;
procedure FolderStyleClick(Sender: TObject);
procedure ListViewSelectItem(Sender: TObject; Item: TListItem;
Selected: Boolean);
procedure OpenArchiveClick(Sender: TObject);
procedure ViewStyleClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmComCtrls: TfrmComCtrls;
implementation
{$R *.dfm}
procedure TfrmComCtrls.FolderStyleClick(Sender: TObject);
begin
AbTreeView.Visible := mnuFilesByFolder.Checked;
Splitter1.Visible := mnuFilesByFolder.Checked;
AbListView.FlatList := mnuAllFiles.Checked;
end;
procedure TfrmComCtrls.ListViewSelectItem(Sender: TObject; Item: TListItem;
Selected: Boolean);
var
Stream: TMemoryStream;
begin
if TAbListItem(Item).IsDirectory then
Memo1.Clear
else begin
Stream := TMemoryStream.Create;
try
AbUnZipper.ExtractToStream(TAbListItem(Item).ArchiveItem.FileName, Stream);
Stream.Position := 0;
Memo1.Lines.LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
end;
procedure TfrmComCtrls.OpenArchiveClick(Sender: TObject);
begin
if OpenDialog.Execute then
AbUnZipper.FileName := OpenDialog.FileName;
end;
procedure TfrmComCtrls.ViewStyleClick(Sender: TObject);
begin
if mnuIcons.Checked then
AbListView.ViewStyle := vsIcon
else if mnuList.Checked then
AbListView.ViewStyle := vsList
else
AbListView.ViewStyle := vsReport;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/CompPad.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: COMPPAD.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program CompPad;
uses
Forms,
ucomppad in 'UCOMPPAD.PAS' {Form1};
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/Contents.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: CONTENTS.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program Contents;
uses
Forms,
UContent in 'UCONTENT.PAS' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ExCBrows.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: CONTENTS.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program ExCBrows;
uses
Forms,
ExCBrowu in 'ExCBrowu.pas' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ExCBrowu.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UCONTENT.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit ExCBrowu;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls,
AbArcTyp, AbCBrows, AbMeter, AbBrowse, AbBase;
type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;
AbCabBrowser1: TAbCabBrowser;
Memo1: TMemo;
Panel1: TPanel;
Button1: TButton;
Button2: TButton;
Label1: TLabel;
Panel2: TPanel;
AbMeter1: TAbMeter;
AbMeter2: TAbMeter;
Label2: TLabel;
Label3: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure AbCabBrowser1Load(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const
BoolToStr : array[Boolean] of string = ('No', 'Yes');
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
AbCabBrowser1.FileName := OpenDialog1.FileName;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
AbCabBrowser1.Filename := '';
Memo1.Clear;
end;
procedure TForm1.AbCabBrowser1Load(Sender: TObject);
var
i : Integer;
LI : Longint;
DT : TDateTime;
s : string;
begin
Memo1.Clear;
with AbCabBrowser1 do begin
Memo1.Lines.Add(Filename);
Memo1.Lines.Add('----------------------------------------------');
Memo1.Lines.Add(' Size: ' + #9 + #9 + IntToStr(CabSize));
Memo1.Lines.Add(' Folders: ' + #9 + #9 + IntToStr(FolderCount));
Memo1.Lines.Add(' Files: ' + #9 + #9 + IntToStr(Count));
Memo1.Lines.Add(' SetID: ' + #9 + #9 + IntToStr(SetID));
Memo1.Lines.Add(' Cab #: ' + #9 + #9 + IntToStr(CurrentCab));
Memo1.Lines.Add(' hasPrev: ' + #9 + BoolToStr[HasPrev]);
Memo1.Lines.Add(' hasNext: ' + #9 + BoolToStr[HasNext]);
Memo1.Lines.Add(' ');
if (Count > 0) then begin
Memo1.Lines.Add('Files' + #9 + #9 + 'Size' +
#9 + 'Timestamp' + #9 + #9 + 'Attributes' + #9 +'Partial File');
Memo1.Lines.Add('--------------------------------------------' +
'--------------------------------------------' +
'--------------------------------------------');
for i := 0 to Pred(Count) do begin
LI := LongInt(Items[i].LastModFileDate) shl 16 +
Items[i].LastModFileTime;
DT := FileDateToDateTime(LI);
s := Items[i].FileName + #9 +
IntToStr(Items[i].UnCompressedSize) + #9 +
DateTimeToStr(DT) + #9 +
IntToStr(Items[i].ExternalFileAttributes) + #9 +
BoolToStr[Items[i].PartialFile];
Memo1.Lines.Add(s);
end;
end;
end;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ExCf.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
program ExCf;
uses
Forms,
uCfMain in 'uCfMain.pas' {fmCfMain},
uCfGenDg in 'uCfGenDg.pas' {frmCfGenDlg},
uCfNewDg in 'uCfNewDg.pas' {frmCfNewDlg};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TfmCfMain, fmCfMain);
Application.CreateForm(TfrmCfGenDlg, frmCfGenDlg);
Application.CreateForm(TfrmCfNewDlg, frmCfNewDlg);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ExFilter.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: EXFILTER.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program Exfilter;
uses
Forms,
Exfiltru in 'EXFILTRU.PAS' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ExFiltru.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: EXFILTRU.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit Exfiltru;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Gauges, Grids, ExtCtrls, FileCtrl,
AbZipper, AbArcTyp, AbZBrows, AbMeter, AbZipKit, AbView, AbZView, AbBrowse,
AbBase, AbUtils;
type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;
OpenBtn: TButton;
AbZipView1: TAbZipView;
CloseBtn: TButton;
AddGroup: TGroupBox;
Label1: TLabel;
FileMask1: TEdit;
Label2: TLabel;
FilterMask1: TEdit;
AddBtn: TButton;
Label3: TLabel;
DirectoryListBox1: TDirectoryListBox;
Bevel1: TBevel;
Label4: TLabel;
DeleteGroup: TGroupBox;
Label5: TLabel;
FileMask2: TEdit;
Label6: TLabel;
FilterMask2: TEdit;
DeleteBtn: TButton;
Bevel2: TBevel;
AbortBtn: TButton;
ExitBtn: TButton;
ExtractGroup: TGroupBox;
Label7: TLabel;
Label8: TLabel;
Label9: TLabel;
Bevel3: TBevel;
FileMask3: TEdit;
FilterMask3: TEdit;
ExtractBtn: TButton;
DirectoryListBox2: TDirectoryListBox;
AbZipKit1: TAbZipKit;
AbMeter1: TAbMeter;
procedure AddBtnClick(Sender: TObject);
procedure OpenBtnClick(Sender: TObject);
procedure DeleteBtnClick(Sender: TObject);
procedure CloseBtnClick(Sender: TObject);
procedure AbortBtnClick(Sender: TObject);
procedure ExitBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ExtractBtnClick(Sender: TObject);
procedure AbZipKit1ConfirmProcessItem(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType;
var Confirm: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const
MainCaption = ' ExFilter : Exception list example';
AddCaption = ' Add files to zip archive ';
DeleteCaption = ' Delete files from zip archive ';
ExtractCaption = ' Extract files from zip archive ';
var
AbortFlag : Boolean;
procedure TForm1.OpenBtnClick(Sender: TObject);
begin
AbZipKit1.Filename := '';
AddBtn.Enabled := False;
DeleteBtn.Enabled := False;
OpenDialog1.Filename := '*.zip';
if OpenDialog1.Execute then begin
AbZipKit1.Filename := OpenDialog1.Filename;
OpenBtn.Enabled := False;
CloseBtn.Enabled := True;
AddBtn.Enabled := True;
DeleteBtn.Enabled := True;
ExtractBtn.Enabled := True;
AbZipView1.Enabled := True;
Caption := ' ' + AbZipKit1.Filename;
end;
end;
procedure TForm1.CloseBtnClick(Sender: TObject);
begin
Screen.Cursor := crHourglass;
Caption := 'Saving ' + AbZipKit1.Filename;
AbZipKit1.CloseArchive;
Screen.Cursor := crDefault;
OpenBtn.Enabled := True;
CloseBtn.Enabled := False;
AddBtn.Enabled := False;
DeleteBtn.Enabled := False;
ExtractBtn.Enabled := False;
AbZipView1.Enabled := False;
Caption := MainCaption;
end;
procedure TForm1.AddBtnClick(Sender: TObject);
var
SavedColor : TColor;
begin
AbortFlag := False;
AbZipKit1.BaseDirectory := DirectoryListBox1.Directory;
SavedColor := AddGroup.Font.Color;
AddGroup.Font.Color := clRed;
try
AbZipKit1.AddFilesEx(FileMask1.Text, FilterMask1.Text, 0 );
AbZipKit1.Save;
finally
AddGroup.Font.Color := SavedColor;
AddGroup.Caption := AddCaption;
end;
end;
procedure TForm1.DeleteBtnClick(Sender: TObject);
var
SavedColor : TColor;
begin
AbortFlag := False;
SavedColor := DeleteGroup.Font.Color;
DeleteGroup.Font.Color := clRed;
try
AbZipKit1.DeleteFilesEx(FileMask2.Text, FilterMask2.Text);
AbZipKit1.Save;
finally
DeleteGroup.Font.Color := SavedColor;
DeleteGroup.Caption := DeleteCaption;
end;
end;
procedure TForm1.ExtractBtnClick(Sender: TObject);
var
SavedColor : TColor;
begin
AbortFlag := False;
AbZipKit1.BaseDirectory := DirectoryListBox2.Directory;
SavedColor := ExtractGroup.Font.Color;
ExtractGroup.Font.Color := clRed;
try
AbZipKit1.ExtractFilesEx(FileMask3.Text, FilterMask3.Text);
finally
ExtractGroup.Font.Color := SavedColor;
ExtractGroup.Caption := ExtractCaption;
end;
end;
procedure TForm1.AbortBtnClick(Sender: TObject);
begin
AbortFlag := True;
end;
procedure TForm1.ExitBtnClick(Sender: TObject);
begin
AbZipKit1.CloseArchive;
Close;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Caption := MainCaption;
AddGroup.Caption := AddCaption;
DeleteGroup.Caption := DeleteCaption;
ExtractGroup.Caption := ExtractCaption;
end;
procedure TForm1.AbZipKit1ConfirmProcessItem(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType; var Confirm: Boolean);
begin
case ProcessType of
ptAdd : AddGroup.Caption := ' Adding ' + Item.Filename + ' ';
ptDelete : DeleteGroup.Caption := ' Deleting ' + Item.Filename + ' ';
ptExtract : ExtractGroup.Caption := ' Extracting ' + Item.Filename + ' ';
end;
Confirm := not AbortFlag;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ExZipper.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
program ExZipper;
uses
Forms,
Exzippru in 'EXZIPPRU.PAS' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ExZippru.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: EXZIPPRU.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit ExZippru;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, FileCtrl,
AbArcTyp, AbZipOut, AbZBrows, AbZipper, AbBrowse, AbBase, AbMeter, AbUtils;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
OpenDialog1: TOpenDialog;
DirectoryListBox1: TDirectoryListBox;
DriveComboBox1: TDriveComboBox;
Label1: TLabel;
AbZipper1: TAbZipper;
Button3: TButton;
AbMeter1: TAbMeter;
procedure Button1Click(Sender: TObject);
procedure DirectoryListBox1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure AbZipper1ConfirmProcessItem(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType;
var Confirm: Boolean);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
DirectoryListBox1Change(nil);
AbZipper1.LogFile := ExtractFilePath(Application.ExeName) + 'Log.txt';
end;
procedure TForm1.DirectoryListBox1Change(Sender: TObject);
begin
AbZipper1.BaseDirectory := DirectoryListBox1.Directory;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
OpenDialog1.Filename := '*.zip';
OpenDialog1.InitialDir := DirectoryListBox1.Directory;
if OpenDialog1.Execute then
AbZipper1.Filename := OpenDialog1.Filename;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
AbZipper1.AddFiles('*.*', 0);
Caption := 'ExZipper';
end;
procedure TForm1.AbZipper1ConfirmProcessItem(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType; var Confirm: Boolean);
begin
Caption := 'adding ' + Item.Filename;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Cursor := crHourGlass;
AbZipper1.CloseArchive;
Cursor := crDefault;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/FCITest1.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
unit FCITest1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, AbCabKit{, TestCab};
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
OpenDialog1: TOpenDialog;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
OpenDialog1.Filename := '*.cab';
if OpenDialog1.Execute then begin
Memo1.Clear;
MakeCab(OpenDialog1.Filename);
Memo1.Lines.Assign(TestCab.AuditTrail);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
i : Integer;
begin
OpenDialog1.Filename := '*.*';
if OpenDialog1.Execute then
if OpenDialog1.Files.Count > 0 then
for i := 0 to Pred(OpenDialog1.Files.Count) do begin
try
AddFile(OpenDialog1.Files[i]);
finally
end;
end;
Memo1.Lines.Assign(TestCab.AuditTrail);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
CloseArchive;
Memo1.Lines.Assign(TestCab.AuditTrail);
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/Finder.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: FINDER.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program finder;
uses
Forms,
ufinder in 'ufinder.pas' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/MakeCab.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: MAKECAB.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program MakeCab;
uses
Forms,
MakeCab1 in 'MakeCab1.pas' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/MakeCab1.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: MAKECAB1.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit MakeCab1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Gauges, ExtCtrls, ComCtrls,
AbArcTyp, AbCBrows, AbCabMak, AbCabTyp, AbMeter, AbBrowse, AbBase;
type
TForm1 = class(TForm)
AddBtn: TButton;
OpenDialog1: TOpenDialog;
Label1: TLabel;
CreateBtn: TButton;
CloseBtn: TButton;
Panel1: TPanel;
NewFolderBtn: TButton;
Label2: TLabel;
NewCabBtn: TButton;
AbMeter1: TAbMeter;
AbMakeCab1: TAbMakeCab;
procedure AddBtnClick(Sender: TObject);
procedure CreateBtnClick(Sender: TObject);
procedure CloseBtnClick(Sender: TObject);
procedure NewFolderBtnClick(Sender: TObject);
procedure NewCabBtnClick(Sender: TObject);
procedure AbMakeCab1ArchiveItemProgress(Sender: TObject;
Item: TAbArchiveItem; Progress: Byte; var Abort: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const
MainCaption = 'Make Cabinet Archive';
procedure TForm1.CreateBtnClick(Sender: TObject);
begin
OpenDialog1.Filename := '*.Cab';
OpenDialog1.Title := 'Name of 1st cabinet';
if OpenDialog1.Execute then begin
Panel1.Caption := 'Creating ' + OpenDialog1.FileName;
AbMakeCab1.OpenArchive(OpenDialog1.FileName);
Caption := AbMakeCab1.FileName;
Panel1.Caption := 'Idle';
end;
end;
procedure TForm1.AddBtnClick(Sender: TObject);
var
i : Integer;
SC : TCursor;
FileList : TStringList;
begin
OpenDialog1.Filename := '*.*';
OpenDialog1.Title := 'Add files to cabinet';
if OpenDialog1.Execute then
if (OpenDialog1.Files.Count > 0) then begin
SC := Cursor;
Cursor := crHourglass;
FileList := TStringList.Create;
try
FileList.Assign(OpenDialog1.Files);
for i := 0 to Pred(FileList.Count) do
AbMakeCab1.AddFiles(FileList.Strings[i], 0);
finally
FileList.Free;
end;
Cursor := SC;
Panel1.Caption := 'Idle';
end;
end;
procedure TForm1.CloseBtnClick(Sender: TObject);
begin
Panel1.Caption := 'Closing ' + AbMakeCab1.FileName;
AbMakeCab1.CloseArchive;
Caption := MainCaption;
Panel1.Caption := 'Idle';
end;
procedure TForm1.NewFolderBtnClick(Sender: TObject);
begin
AbMakeCab1.StartNewFolder;
end;
procedure TForm1.NewCabBtnClick(Sender: TObject);
begin
AbMakeCab1.StartNewCabinet;
end;
procedure TForm1.AbMakeCab1ArchiveItemProgress(Sender: TObject;
Item: TAbArchiveItem; Progress: Byte; var Abort: Boolean);
begin
Panel1.Caption := 'Adding ' + ExtractFilename(Item.Filename);
Abort := False;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/SelfStbv.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: SELFEXV.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program Selfstbv;
uses
Forms,
Slfstbv1 in 'SLFSTBV1.PAS' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/SelfStub.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: SELFSTUB.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
(* This program creates a ZIP stub called SELFEX.EXE. This
stub can then be used to create self-extracting ZIP files.
For more information on self-extracting ZIPs and ZIP stubs see
page 112 in the Abbrevia manual. *)
program Selfstub;
{$APPTYPE CONSOLE}
uses
AbArcTyp,
AbUnzPrc,
AbUtils,
AbZipTyp,
SysUtils;
type
THelper = class
public
procedure UnzipProc(Sender : TObject;
Item : TAbArchiveItem;
const NewName : string);
end;
procedure THelper.UnzipProc(Sender : TObject;
Item : TAbArchiveItem;
const NewName : string);
begin
AbUnzip(Sender, TAbZipItem(Item), NewName);
end;
{Build this app using the Define "BuildingStub", to keep it smaller!}
var
ZipArchive : TAbZipArchive;
Helper : THelper;
begin
WriteLn( 'Abbrevia Self Extracting Archive' );
ZipArchive := TAbZipArchive.Create(ParamStr(0),
fmOpenRead or fmShareDenyNone);
ChDir( ExtractFilePath(ParamStr(0)));
Helper := THelper.Create;
try
ZipArchive.Load;
ZipArchive.ExtractHelper := Helper.UnzipProc;
ZipArchive.ExtractFiles('*.*');
finally
Helper.Free;
ZipArchive.Free;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/SlfStbv1.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: SLFSTBV1.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit Slfstbv1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
AbZBrows, AbUnZper, AbArcTyp, AbBrowse, AbBase, AbUtils;
type
TForm1 = class(TForm)
Button1: TButton;
AbUnZipper1: TAbUnZipper;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
AbUnzipper1.FileName := ExtractFilePath(Application.ExeName) + 'abtest.exe';
AbUnzipper1.ArchiveType := atSelfExtZip;
AbUnzipper1.ExtractFiles( '*.*' );
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/Streams.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: STREAMS.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program Streams;
uses
Forms,
Streams1 in 'Streams1.pas' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/Streams1.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: STREAMS1.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit Streams1;
interface
uses
Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids,
AbView, AbZView, Menus, AbArcTyp, AbZBrows, AbUnZper,
AbZipper, AbZipKit, AbBrowse, AbBase;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Open1: TMenuItem;
Exit1: TMenuItem;
Action1: TMenuItem;
Extract1: TMenuItem;
AbZipView1: TAbZipView;
Memo1: TMemo;
OpenDialog1: TOpenDialog;
Close1: TMenuItem;
N1: TMenuItem;
Add1: TMenuItem;
AbZipKit1: TAbZipKit;
Clearmemo1: TMenuItem;
procedure Open1Click(Sender: TObject);
procedure Extract1Click(Sender: TObject);
procedure Close1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure AbZipView1DblClick(Sender: TObject);
procedure Clearmemo1Click(Sender: TObject);
procedure Add1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const
MainCaption = ' Compressed Memo';
procedure TForm1.Open1Click(Sender: TObject);
begin
OpenDialog1.Filename := '*.zip';
if OpenDialog1.Execute then
AbZipKit1.OpenArchive(OpenDialog1.Filename);
end;
procedure TForm1.Extract1Click(Sender: TObject);
var
ToStream : TMemoryStream;
Item : TAbArchiveItem;
begin
Memo1.Clear;
ToStream := TMemoryStream.Create;
try
Item := AbZipView1.Items[AbZipView1.ActiveRow];
Caption := Item.Filename;
AbZipKit1.ExtractToStream(Item.FileName, ToStream);
ToStream.Position := 0;
Memo1.Lines.LoadFromStream(ToStream);
finally
ToStream.Free;
end;
end;
procedure TForm1.Close1Click(Sender: TObject);
begin
AbZipKit1.CloseArchive;
Caption := MainCaption;
end;
procedure TForm1.Exit1Click(Sender: TObject);
begin
Close1Click(nil);
Close;
end;
procedure TForm1.AbZipView1DblClick(Sender: TObject);
begin
Extract1Click(nil);
end;
procedure TForm1.Clearmemo1Click(Sender: TObject);
begin
Memo1.Clear;
end;
procedure TForm1.Add1Click(Sender: TObject);
var
FromStream : TMemoryStream;
FN : string;
begin
FromStream := TMemoryStream.Create;
try
Memo1.Lines.SaveToStream(FromStream);
if InputQuery('Streams', 'Give it a filename', FN) then begin
Caption := FN;
AbZipKit1.AddFromStream(FN, FromStream);
end;
finally
FromStream.Free;
end;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/StrmBmp.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: STRMBMP.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program StrmBmp;
uses
Forms,
StrmBmpU in 'StrmBmpU.pas' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/StrmBmpU.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: STRMBMPU.DPR *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit StrmBmpU;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
AbUnzPrc,
AbZipPrc;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
UStrm : TMemoryStream;
CStrm : TMemoryStream;
Image2 : TImage;
begin
{ Create the compressed stream and the uncompressed stream. }
UStrm := TMemoryStream.Create;
CStrm := TMemoryStream.Create;
{ Copy the bitmap image to the memory stream. }
Image1.Picture.Bitmap.SaveToStream(UStrm);
{ Set the stream position to the beginning. }
UStrm.Position := 0;
{ Compress the stream. }
DeflateStream(UStrm, CStrm);
{ Remove all data from the uncompressed stream. }
UStrm.Clear;
{ Reset the compressed stream back to the beginning. }
CStrm.Position := 0;
{ Decompress the stream back to the original uncompressed }
{ stream and then reset the stream position back to 0. }
InflateStream(CStrm, UStrm);
UStrm.Position := 0;
{ Now create a new TImage. Make it the same size as the }
{ original image but move it down and to the left. }
Image2 := TImage.Create(Self);
Image2.Top := Image1.Top + 20;
Image2.Left := Image1.Left + 20;
Image2.Width := Image1.Width;
Image2.Height := Image1.Height;
Image2.Parent := Self;
{ Delete the original TImage. }
Image1.Free;
{ Load the new bitmap with the data from the stream }
{ that contains the decompressed image. }
Image2.Picture.Bitmap.LoadFromStream(UStrm);
{ Free the memory streams. }
UStrm.Free;
CStrm.Free;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/StrmPad.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: STRMPAD.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program StrmPad;
uses
Forms,
Ustrpad in 'Ustrpad.pas' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/TpZip.RC
================================================
;{*********************************************************}
;{* ABBREVIA: TPZIP.RC *}
;{* Copyright (c) TurboPower Software Co 1997 *}
;{* All rights reserved. *}
;{*********************************************************}
;{* ABBREVIA Example program file *}
;{*********************************************************}
MAINICON ICON "tpzip.ico"
================================================
FILE: lib/abbrevia/examples/Delphi/TpZip.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: TPZIP.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program TPZip;
uses
Forms,
ubasedlg in 'UBASEDLG.PAS' {BaseDirDlg},
udemodlg in 'UDEMODLG.PAS' {DemoDlg},
dgAbout in 'DGABOUT.PAS' {dlgAboutBox},
usplash in 'USPLASH.PAS' {Splash},
UMain in 'Umain.pas' {Form1};
{$R *.R32}
begin
Application.Title := 'TP Zip';
Application.HelpFile := 'Tpzip31.hlp';
Application.CreateForm(TForm1, Form1);
Splash := TSplash.Create( Application );
Splash.Show;
Splash.Refresh;
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/UContent.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UCONTENT.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit UContent;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
AbZBrows, AbArcTyp, AbBrowse, AbBase;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
OpenDialog1: TOpenDialog;
AbZipBrowser1: TAbZipBrowser;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
i : Integer;
begin
ListBox1.Clear;
if OpenDialog1.Execute then begin
try
with AbZipBrowser1 do begin
FileName := OpenDialog1.FileName;
if Count > 0 then
for i := 0 to pred( Count ) do
ListBox1.Items.Add( Items[i].FileName );
end;
except
ListBox1.Items.Add( OpenDialog1.FileName + ' is not a valid archive.' );
end;
end;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/UMain.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UMAIN.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA: TPZip *}
{*********************************************************}
{$I AbDefine.inc}
unit UMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, ExtCtrls, FileCtrl, StdCtrls, Gauges, Buttons,
AbArcTyp, AbUtils, AbZipOut, AbMeter, AbBase, AbBrowse;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Open1: TMenuItem;
Save1: TMenuItem;
N1: TMenuItem;
Exit1: TMenuItem;
Items1: TMenuItem;
Help1: TMenuItem;
Contents1: TMenuItem;
N2: TMenuItem;
About1: TMenuItem;
Preferences1: TMenuItem;
View1: TMenuItem;
Attributes1: TMenuItem;
za0: TMenuItem;
za1: TMenuItem;
za8: TMenuItem;
Hierarchy1: TMenuItem;
Style1: TMenuItem;
Panel1: TPanel;
Panel2: TPanel;
za2: TMenuItem;
za3: TMenuItem;
za4: TMenuItem;
za5: TMenuItem;
za6: TMenuItem;
za7: TMenuItem;
za9: TMenuItem;
za10: TMenuItem;
N3: TMenuItem;
None1: TMenuItem;
All1: TMenuItem;
Panel3: TPanel;
Panel4: TPanel;
DriveComboBox1: TDriveComboBox;
FilterComboBox1: TFilterComboBox;
DirectoryListBox1: TDirectoryListBox;
FileListBox1: TFileListBox;
Panel5: TPanel;
FontDialog1: TFontDialog;
Font1: TMenuItem;
Panel6: TPanel;
OpenDialog1: TOpenDialog;
CompressionMethodToUse1: TMenuItem;
Store1: TMenuItem;
Deflate1: TMenuItem;
Best1: TMenuItem;
DeflationOption1: TMenuItem;
Maximum1: TMenuItem;
Normal1: TMenuItem;
Fast1: TMenuItem;
SuperFast1: TMenuItem;
ExtractOptions1: TMenuItem;
CreateDirs1: TMenuItem;
RestorePath1: TMenuItem;
Password1: TMenuItem;
StoreOptions1: TMenuItem;
RemoveDots1: TMenuItem;
RecurseTree1: TMenuItem;
StripPath1: TMenuItem;
AddFiles1: TMenuItem;
DeleteFiles1: TMenuItem;
ExtractFiles1: TMenuItem;
FreshenFiles1: TMenuItem;
PopupMenu1: TPopupMenu;
Delete1: TMenuItem;
Run1: TMenuItem;
Move1: TMenuItem;
Freshen1: TMenuItem;
Extract1: TMenuItem;
Confirmations1: TMenuItem;
Close1: TMenuItem;
Convert1: TMenuItem;
N4: TMenuItem;
Default1: TMenuItem;
Panel8: TPanel;
SpeedButton1: TSpeedButton;
SpeedButton2: TSpeedButton;
SpeedButton3: TSpeedButton;
SpeedButton4: TSpeedButton;
SpeedButton5: TSpeedButton;
SpeedButton7: TSpeedButton;
SpeedButton8: TSpeedButton;
SpeedButton9: TSpeedButton;
SpeedButton10: TSpeedButton;
SpeedButton11: TSpeedButton;
SpeedButton12: TSpeedButton;
SpeedButton13: TSpeedButton;
SpeedButton14: TSpeedButton;
Image1: TImage;
ArchiveLabel: TLabel;
Label1: TLabel;
Label2: TLabel;
FileComment1: TMenuItem;
sbNone: TSpeedButton;
sbAll: TSpeedButton;
sbDef: TSpeedButton;
Edit1: TEdit;
Label3: TLabel;
N5: TMenuItem;
OS3: TMenuItem;
OS4: TMenuItem;
OS2: TMenuItem;
OS1: TMenuItem;
OS6: TMenuItem;
OS5: TMenuItem;
AbbreviaontheWeb1: TMenuItem;
AbMeter1: TAbMeter;
AbMeter2: TAbMeter;
ShowEmptyfolders1: TMenuItem;
TempDirectory1: TMenuItem;
Logging1: TMenuItem;
AbZipOutline1: TAbZipOutline;
procedure AbZipOutline1Change(Sender: TObject);
procedure AbZipOutline1ConfirmSave(Sender: TObject;
var Confirm: Boolean);
procedure AbZipOutline1DblClick(Sender: TObject);
procedure AbZipOutline1DragDrop(Sender, Source: TObject; X,
Y: Integer);
procedure AbZipOutline1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure AbZipOutline1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure AbZipOutline1WindowsDrop(Sender: TObject;
FileName: string);
procedure All1Click(Sender: TObject);
procedure Best1Click(Sender: TObject);
procedure Confirmations1Click(Sender: TObject);
procedure CreateDirs1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure FileListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
procedure FileListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure Font1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Hierarchy1Click(Sender: TObject);
procedure None1Click(Sender: TObject);
procedure Open1Click(Sender: TObject);
procedure RestorePath1Click(Sender: TObject);
procedure Save1Click(Sender: TObject);
procedure StripPath1Click(Sender: TObject);
procedure SuperFast1Click(Sender: TObject);
procedure za10Click(Sender: TObject);
procedure Delete1Click(Sender: TObject);
procedure Extract1Click(Sender: TObject);
procedure Freshen1Click(Sender: TObject);
procedure Move1Click(Sender: TObject);
procedure Password1Click(Sender: TObject);
procedure AddFiles1Click(Sender: TObject);
procedure FreshenFiles1Click(Sender: TObject);
procedure SelectBaseDirectory1Click(Sender: TObject);
procedure AbZipOutline1ArchiveItemProgress(Sender: TObject;
Item: TAbArchiveItem; Progress: Byte; var Abort: Boolean);
procedure AbZipOutline1NeedPassword(Sender: TObject;
var NewPassword: AnsiString);
procedure DeleteFiles1Click(Sender: TObject);
procedure ExtractFiles1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Close1Click(Sender: TObject);
procedure AbZipOutline1Load(Sender: TObject);
procedure Convert1Click(Sender: TObject);
procedure AbZipOutline1ConfirmOverwrite(var Name: string;
var Confirm: Boolean);
procedure Default1Click(Sender: TObject);
procedure Contents1Click(Sender: TObject);
procedure About1Click(Sender: TObject);
procedure FileListBox1DblClick(Sender: TObject);
procedure AbZipOutline1EndDrag(Sender, Target: TObject; X, Y: Integer);
procedure FileListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FileListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure AbZipOutline1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
procedure Edit1Exit(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure OS5Click(Sender: TObject);
procedure AbZipOutline1ConfirmProcessItem(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType;
var Confirm: Boolean);
procedure AbZipOutline1ProcessItemFailure(Sender: TObject;
Item: TAbArchiveItem; const ProcessType: TAbProcessType;
ErrorClass: TAbErrorClass; ErrorCode: Integer);
procedure TurboPowerontheWeb1Click(Sender: TObject);
procedure AbbreviaontheWeb1Click(Sender: TObject);
procedure TempDirectory1Click(Sender: TObject);
procedure Logging1Click(Sender: TObject);
private
{ Private declarations }
OutlineX, OutlineY, FileX, FileY : Integer;
StubName : string;
IgnoreDuplicateWarning : Boolean;
procedure ReadIniSettings;
procedure SaveIniSettings;
procedure SetCaption;
procedure UpdateMenu;
procedure DoConfirm( Sender : TObject; Item : TAbArchiveItem;
var Confirm : Boolean; Caption : string );
procedure GetMinMaxInfo( var Msg: TWMGetMinMaxInfo );
message WM_GETMINMAXINFO;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
AbConst,
AbDlgDir,
AbDlgPwd,
AbZBrows,
AbZipTyp,
dgAbout,
IniFiles,
Outline,
ShellAPI,
UBaseDlg,
UDemoDlg,
uSplash;
procedure TForm1.All1Click(Sender: TObject);
var
i : Integer;
begin
for i := 0 to Ord( High( TAbZipAttribute ) ) do
Attributes1.Items[i].Checked := True;
AbZipOutline1.Attributes := [zaCompressedSize, zaCompressionMethod,
zaCompressionRatio, zaCRC, zaExternalFileAttributes,
zaInternalFileAttributes, zaEncryption, zaTimeStamp,
zaUncompressedSize, zaVersionMade, zaVersionNeeded,
zaComment];
AbZipOutline1.Update;
end;
procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ReadIniSettings;
SetCaption;
UpdateMenu;
if ParamCount > 0 then
try
AbZipOutline1.FileName := ParamStr( 1 );
except
end;
end;
procedure TForm1.Hierarchy1Click(Sender: TObject);
begin
Hierarchy1.Checked := not Hierarchy1.Checked;
AbZipOutline1.Hierarchy := Hierarchy1.Checked;
end;
procedure TForm1.None1Click(Sender: TObject);
var
i : Integer;
begin
for i := 0 to pred( Attributes1.Count ) do
Attributes1.Items[i].Checked := False;
AbZipOutline1.Attributes := [];
AbZipOutline1.Update;
end;
procedure TForm1.Save1Click(Sender: TObject);
begin
AbZipOutline1.Save;
end;
procedure TForm1.SetCaption;
begin
Caption := 'TPZip ' + AbZipOutline1.Version + ' - ' +
AbZipOutline1.FileName;
end;
procedure TForm1.UpdateMenu;
var
i : TAbZipAttribute;
begin
with AbZipOutline1 do begin
i := Low( TAbZipAttribute );
while i <> High( TAbZipAttribute ) do begin
Attributes1.Items[Ord(i)].Checked := i in Attributes;
i := succ( i );
end;
Hierarchy1.Checked := Hierarchy;
// OS1.Checked := Ord( OutlineStyle ) = 0;
// OS2.Checked := Ord( OutlineStyle ) = 1;
// OS3.Checked := Ord( OutlineStyle ) = 2;
// OS4.Checked := Ord( OutlineStyle ) = 3;
// OS5.Checked := Ord( OutlineStyle ) = 4;
// OS6.Checked := Ord( OutlineStyle ) = 5;
Best1.Checked := CompressionMethodToUse = smBestMethod;
Deflate1.Checked := CompressionMethodToUse = smDeflated;
Store1.Checked := CompressionMethodToUse = smStored;
{deflation options}
Normal1.Checked := DeflationOption = doNormal;
Maximum1.Checked := DeflationOption = doMaximum;
Fast1.Checked := DeflationOption = doFast;
SuperFast1.Checked := DeflationOption = doSuperFast;
{extractOptions}
CreateDirs1.Checked := eoCreateDirs in ExtractOptions;
RestorePath1.Checked := eoRestorePath in ExtractOptions;
{StoreOptions}
RecurseTree1.Checked := soRecurse in StoreOptions;
StripPath1.Checked := soStripPath in StoreOptions;
RemoveDots1.Checked := soRemoveDots in StoreOptions;
end;
end;
procedure TForm1.za10Click(Sender: TObject);
var
Item : TMenuItem;
begin
Item := (Sender as TMenuItem);
Item.Checked := not Item.Checked;
with AbZipOutline1 do
if Item.Checked then
Attributes := Attributes + [TAbZipAttribute( Item.Tag )]
else
Attributes := Attributes - [TAbZipAttribute( Item.Tag )];
AbZipOutline1.Update;
end;
procedure TForm1.Font1Click(Sender: TObject);
begin
if FontDialog1.Execute then
with FontDialog1 do begin
AbZipOutline1.Font := Font;
DirectoryListBox1.Font := Font;
FileListBox1.Font := Font;
DriveComboBox1.Font := Font;
FilterComboBox1.Font := Font;
end;
end;
procedure TForm1.Open1Click(Sender: TObject);
begin
if OpenDialog1.Execute then begin
AbZipOutline1.FileName := OpenDialog1.FileName;
end;
end;
procedure TForm1.AbZipOutline1DragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept := Source is TFileListBox;
end;
procedure TForm1.AbZipOutline1DragDrop(Sender, Source: TObject; X,
Y: Integer);
var
i, j : Integer;
ZB : TAbZipBrowser;
IsZip : Boolean;
ZipName : string;
begin
if Source is TFileListBox then
with (Source as TFileListBox ) do
if SelCount = 1 then begin
for i := 0 to pred( Items.Count ) do
if FileListBox1.Selected[i] then begin
IsZip := False;
ZB := TAbZipBrowser.Create( Self );
try
try
ZB.FileName := Directory + '\' + Items[i];
IsZip := True;
except
end;
finally
ZB.Free;
end;
if IsZip then
{only one file, and it is a zip file}
AbZipOutline1.FileName := Directory + '\' + Items[i]
else if AbZipOutline1.FileName <> '' then
{only one file, and it's not a zip file}
AbZipOutline1.AddFiles( Directory + '\' + Items[i], 0 )
else begin
if OpenDialog1.Execute then begin
AbZipOutline1.FileName := OpenDialog1.FileName;
AbZipOutline1.AddFiles( Directory + '\' + Items[i], 0 );
end;
end;
break;
end;
end
else begin
{multiple files dropped...}
IsZip := False;
ZB := TAbZipBrowser.Create( Self );
try
for i := 0 to pred( Items.Count ) do
if FileListBox1.Selected[i] then begin
try
ZB.FileName := Directory + '\' + Items[i];
IsZip := True;
ZipName := ZB.FileName;
break;
except
end;
end;
finally
ZB.Free;
end;
if IsZip and ( Application.MessageBox(
'One of the dropped files is a Zip Archive. Open it?',
'Open or Add Files?',
MB_YESNO ) = IDYES ) then
AbZipOutline1.FileName := ZipName
else begin
if AbZipOutline1.FileName <> '' then begin
for i := 0 to pred( Items.Count ) do
if FileListBox1.Selected[i] then
AbZipOutline1.AddFiles( Directory + '\' + Items[i], 0 );
end
else begin
if OpenDialog1.Execute then begin
AbZipOutline1.FileName := OpenDialog1.FileName;
for j := 0 to pred( Items.Count ) do
if FileListBox1.Selected[j] then
AbZipOutline1.AddFiles( Directory + '\' + Items[j], 0 )
end;
end;
end;
end;
end;
procedure TForm1.AbZipOutline1DblClick(Sender: TObject);
var
Restoring : Boolean;
zFileName : array[0..79] of Char;
TempDir, SaveDir : string;
TempPath : array [0..255] of Char;
TempName : string;
begin
GetTempPath( sizeof( TempPath ), TempPath );
SaveDir := StrPas( TempPath );
if SaveDir[Length(SaveDir)] = '\' then
Delete( SaveDir, Length(SaveDir), 1 );
StrPCopy( TempPath, SaveDir );
with AbZipOutline1 do begin
if SelectedZipItem <> nil then begin
TempDir := BaseDirectory;
Restoring := eoRestorePath in ExtractOptions;
ExtractOptions := ExtractOptions - [eoRestorePath];
BaseDirectory := SaveDir;
try
ExtractFiles( SelectedZipItem.FileName );
TempName := SelectedZipItem.FileName;
AbUnfixName( TempName );
ShellExecute( Application.MainForm.Handle, nil,
StrPCopy( zFileName, ExtractFileName( TempName ) ),
'', TempPath, SW_SHOWNORMAL );
finally
BaseDirectory := TempDir;
if Restoring then
ExtractOptions := ExtractOptions + [eoRestorePath];
end;
end;
end;
end;
procedure TForm1.AbZipOutline1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
i : Integer;
PS, PC : TPoint;
begin
if Button = mbLeft then begin
OutlineX := X;
OutlineY := Y;
end
else if Button = mbRight then begin
{enable appropriate popup menu items.}
{prepare popup menu}
if AbZipOutline1.Count > 0 then begin
{there are items in the outline - select the item under the mouse}
i := AbZipOutline1.GetOutlineItem( X, Y );
if i <> -1 then
AbZipOutline1.SelectedItem := i;
end;
if AbZipOutline1.SelectedZipItem <> nil then begin
PC.X := X;
PC.Y := Y;
PS := AbZipOutline1.ClientToScreen( PC );
AbZipOutline1.PopupMenu.Popup( PS.X, PS.Y );
end;
end;
end;
procedure TForm1.FileListBox1DragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept := Source is TAbZipOutline;
end;
procedure TForm1.FileListBox1DragDrop(Sender, Source: TObject; X,
Y: Integer);
var
TempDir : string;
begin
if Source is TAbZipOutline then
with (Source as TAbZipOutline ) do begin
TempDir := BaseDirectory;
BaseDirectory := FileListBox1.Directory;
try
ExtractFiles( SelectedZipItem.FileName );
FileListBox1.Update;
finally
BaseDirectory := TempDir;
end;
end;
end;
procedure TForm1.AbZipOutline1WindowsDrop(Sender: TObject;
FileName: string);
var
ZB : TAbZipBrowser;
IsZip : Boolean;
begin
IsZip := False;
ZB := TAbZipBrowser.Create( Self );
try
try
ZB.FileName := FileName;
IsZip := True;
except
end;
finally
ZB.Free;
end;
if IsZip and ( AbZipOutline1.FileName = '' ) then
AbZipOutline1.FileName := FileName
else if AbZipOutline1.FileName = '' then begin
if OpenDialog1.Execute then begin
AbZipOutline1.FileName := OpenDialog1.FileName;
AbZipOutline1.AddFiles( FileName, 0 );
end;
end
else begin
{This is a Zip file, but there's already an open archive}
if Application.MessageBox( 'Open this file as an archive?',
'Open or Add File', MB_YESNO ) = IDYES then
AbZipOutline1.FileName := FileName
else
AbZipOutline1.AddFiles( FileName, 0 );
end;
end;
procedure TForm1.Best1Click(Sender: TObject);
var
Item : TMenuItem;
begin
Store1.Checked := False;
Deflate1.Checked := False;
Best1.Checked := False;
Item := (Sender as TMenuItem);
Item.Checked := True;
AbZipOutline1.CompressionMethodToUse := TAbZipSupportedMethod( Item.Tag );
end;
procedure TForm1.SuperFast1Click(Sender: TObject);
var
Item : TMenuItem;
begin
Normal1.Checked := False;
Maximum1.Checked := False;
Fast1.Checked := False;
SuperFast1.Checked := False;
Item := (Sender as TMenuItem);
Item.Checked := True;
AbZipOutline1.DeflationOption := TAbZipDeflationOption( Item.Tag );
end;
procedure TForm1.CreateDirs1Click(Sender: TObject);
var
Item : TMenuItem;
begin
Item := Sender as TMenuItem;
Item.Checked := not Item.Checked;
if Item.Checked then
AbZipOutline1.ExtractOptions := AbZipOutline1.ExtractOptions +
[eoCreateDirs]
else
AbZipOutline1.ExtractOptions := AbZipOutline1.ExtractOptions -
[eoCreateDirs];
end;
procedure TForm1.RestorePath1Click(Sender: TObject);
var
Item : TMenuItem;
begin
Item := Sender as TMenuItem;
Item.Checked := not Item.Checked;
if Item.Checked then
AbZipOutline1.ExtractOptions := AbZipOutline1.ExtractOptions +
[eoRestorePath]
else
AbZipOutline1.ExtractOptions := AbZipOutline1.ExtractOptions -
[eoRestorePath];
end;
procedure TForm1.StripPath1Click(Sender: TObject);
var
Item : TMenuItem;
begin
Item := Sender as TMenuItem;
Item.Checked := not Item.Checked;
if Item.Checked then
AbZipOutline1.StoreOptions := AbZipOutline1.StoreOptions +
[TAbStoreOption(Item.Tag)]
else
AbZipOutline1.StoreOptions := AbZipOutline1.StoreOptions -
[TAbStoreOption(Item.Tag)];
end;
procedure TForm1.AbZipOutline1Change(Sender: TObject);
begin
if AbZipOutline1.FileName <> '' then
ArchiveLabel.Caption := Format( 'Archive %s contains %d items.',
[AbZipOutline1.FileName, AbZipOutline1.Count] )
else
ArchiveLabel.Caption := 'No Archive Open';
end;
procedure TForm1.Confirmations1Click(Sender: TObject);
begin
Confirmations1.Checked := not Confirmations1.Checked;
SpeedButton7.Down := Confirmations1.Checked;
end;
procedure TForm1.DoConfirm( Sender : TObject; Item : TAbArchiveItem;
var Confirm : Boolean; Caption : string );
var
pMessage : array [0..255] of Char;
pCaption : array [0..80] of Char;
begin
if Confirmations1.Checked then
Confirm := MessageBox( 0,
StrPCopy( pMessage,
Format( '%s %s?',
[Caption, Item.FileName] ) ),
StrPCopy( pCaption, 'Confirmation' ),
MB_ICONQUESTION or MB_OKCANCEL ) = IDOK;
end;
procedure TForm1.AbZipOutline1ConfirmSave(Sender: TObject;
var Confirm: Boolean);
var
pMessage : array [0..255] of Char;
pCaption : array [0..80] of Char;
begin
if Confirmations1.Checked then
Confirm := MessageBox( 0,
StrPCopy( pMessage,
Format( 'Save %s?',
[TAbZipOutline(Sender).FileName] ) ),
StrPCopy( pCaption, 'Confirmation' ),
MB_ICONQUESTION or MB_OKCANCEL ) = IDOK;
end;
procedure TForm1.Delete1Click(Sender: TObject);
begin
if AbZipOutline1.SelectedZipItem <> nil then
with AbZipOutline1 do begin
AbZipOutline1.ClearTags;
SelectedZipItem.Tagged := True;
try
DeleteTaggedItems;
finally
ClearTags;
end;
end;
end;
procedure TForm1.Extract1Click(Sender: TObject);
begin
if AbZipOutline1.SelectedZipItem <> nil then begin
BaseDirDlg := TBaseDirDlg.Create( Application );
try
with BaseDirDlg, AbZipOutline1 do begin
Caption := 'Extract Selected File';
Edit1.Text := SelectedZipItem.FileName;
Edit1.Enabled := False;
ActionLabel.Caption := 'Target Directory:';
if BaseDirectory <> '' then
DLB.Directory := BaseDirectory;
CheckBox1.Caption := 'Restore Path';
CheckBox1.Checked := eoRestorePath in ExtractOptions;
CheckBox2.Caption := 'Create Directories';
CheckBox2.Checked := eoCreateDirs in ExtractOptions;
ShowModal;
if ModalResult = mrOK then begin
BaseDirectory := DirLabel.Caption;
if CheckBox1.Checked then
ExtractOptions := ExtractOptions + [eoRestorePath]
else
ExtractOptions := ExtractOptions - [eoRestorePath];
if CheckBox2.Checked then
ExtractOptions := ExtractOptions + [eoCreateDirs]
else
ExtractOptions := ExtractOptions - [eoCreateDirs];
ClearTags;
SelectedZipItem.Tagged := True;
try
ExtractTaggedItems;
finally
ClearTags;
end;
FileListBox1.Update;
end;
end;
finally
BaseDirDlg.Free;
end;
end;
end;
procedure TForm1.Freshen1Click(Sender: TObject);
begin
if AbZipOutline1.SelectedZipItem <> nil then begin
BaseDirDlg := TBaseDirDlg.Create( Application );
try
with BaseDirDlg, AbZipOutline1 do begin
Caption := 'Freshen Selected File';
Edit1.Text := SelectedZipItem.FileName;
Edit1.Enabled := False;
ActionLabel.Caption := 'Source Directory:';
if BaseDirectory <> '' then
DLB.Directory := BaseDirectory;
CheckBox1.Caption := 'Recurse';
CheckBox1.Checked := soRecurse in StoreOptions;
CheckBox2.Caption := 'Strip Path';
CheckBox2.Checked := soStripPath in StoreOptions;
ShowModal;
if ModalResult = mrOK then begin
if CheckBox1.Checked then
StoreOptions := StoreOptions + [soRecurse]
else
StoreOptions := StoreOptions - [soRecurse];
if CheckBox2.Checked then
StoreOptions := StoreOptions + [soStripPath]
else
StoreOptions := StoreOptions - [soStripPath];
BaseDirectory := DirLabel.Caption;
ClearTags;
SelectedZipItem.Tagged := True;
try
FreshenTaggedItems;
finally
ClearTags;
end;
FileListBox1.Update;
end;
end;
finally
BaseDirDlg.Free;
end;
end;
end;
procedure TForm1.Move1Click(Sender: TObject);
begin
DemoDlg := TDemoDlg.Create( Application );
try
with DemoDlg do begin
Caption := 'Move File to New Path';
Edit1.Text := AbZipOutline1.SelectedZipItem.FileName;
ShowModal;
if ModalResult = mrOK then
AbZipOutline1.Move( AbZipOutline1.SelectedZipItem, Edit1.Text );
end;
finally
DemoDlg.Free;
end;
end;
procedure TForm1.Password1Click(Sender: TObject);
var
Dlg : TPassWordDlg;
begin
Dlg := TPassWordDlg.Create( Application );
try
Dlg.Edit1.Text := string(AbZipOutline1.Password);
Dlg.ShowModal;
if Dlg.ModalResult = mrOK then
AbZipOutline1.Password := AnsiString(Dlg.Edit1.Text);
finally
Dlg.Free;
end;
if Length( AbZipOutline1.Password ) > 0 then
Image1.Visible := True
else
Image1.Visible := False;
end;
procedure TForm1.AddFiles1Click(Sender: TObject);
begin
BaseDirDlg := TBaseDirDlg.Create( Application );
try
with BaseDirDlg, AbZipOutline1 do begin
Caption := 'Add Files with FileMask';
Edit1.Text := '*.*';
ActionLabel.Caption := 'Source Directory';
CheckBox1.Caption := 'Recurse';
CheckBox1.Checked := soRecurse in StoreOptions;
CheckBox2.Caption := 'Strip Path';
CheckBox2.Checked := soStripPath in StoreOptions;
if BaseDirectory <> '' then
DLB.Directory := BaseDirectory;
ShowModal;
if ModalResult = mrOK then begin
if CheckBox1.Checked then
StoreOptions := StoreOptions + [soRecurse]
else
StoreOptions := StoreOptions - [soRecurse];
if CheckBox2.Checked then
StoreOptions := StoreOptions + [soStripPath]
else
StoreOptions := StoreOptions - [soStripPath];
BaseDirectory := DirLabel.Caption;
AddFiles( Edit1.Text, 0 );
end;
end;
finally
BaseDirDlg.Free;
end;
end;
procedure TForm1.FreshenFiles1Click(Sender: TObject);
begin
BaseDirDlg := TBaseDirDlg.Create( Application );
try
with BaseDirDlg, AbZipOutline1 do begin
Caption := 'Freshen Files with FileMask';
Edit1.Text := '*.*';
ActionLabel.Caption := 'Source Directory';
CheckBox1.Caption := 'Recurse';
CheckBox1.Checked := soRecurse in StoreOptions;
CheckBox2.Caption := 'Strip Path';
CheckBox2.Checked := soStripPath in StoreOptions;
if BaseDirectory <> '' then
DLB.Directory := BaseDirectory;
ShowModal;
if ModalResult = mrOK then begin
if CheckBox1.Checked then
StoreOptions := StoreOptions + [soRecurse]
else
StoreOptions := StoreOptions - [soRecurse];
if CheckBox2.Checked then
StoreOptions := StoreOptions + [soStripPath]
else
StoreOptions := StoreOptions - [soStripPath];
BaseDirectory := DirLabel.Caption;
FreshenFiles( Edit1.Text );
end;
end;
finally
BaseDirDlg.Free;
end;
end;
procedure TForm1.SelectBaseDirectory1Click(Sender: TObject);
begin
with TAbDirDlg.Create(Self) do begin
Caption := 'Directory';
AdditionalText := 'Select folder to extract into';
if Execute then
AbZipOutline1.BaseDirectory := SelectedFolder;
Free;
end;
end;
procedure TForm1.AbZipOutline1ArchiveItemProgress(Sender: TObject;
Item: TAbArchiveItem; Progress: Byte; var Abort: Boolean);
var
ActionString : string;
begin
case Item.Action of
aaAdd : ActionString := 'Adding ';
aaFreshen : ActionString := 'Freshening ';
else
ActionString :='Extracting ';
end;
Panel5.Caption := ActionString + Item.FileName + ' ';
if Progress = 100 then begin
Panel5.Caption := 'Finished ';
end;
end;
procedure TForm1.AbZipOutline1NeedPassword(Sender: TObject;
var NewPassword: AnsiString);
var
Dlg : TPassWordDlg;
begin
Dlg := TPassWordDlg.Create( Application );
try
Dlg.ShowModal;
if Dlg.ModalResult = mrOK then
NewPassword := AnsiString(Dlg.Edit1.Text);
finally
Dlg.Free;
end;
if Length( NewPassword ) > 0 then
Image1.Visible := True;
end;
procedure TForm1.DeleteFiles1Click(Sender: TObject);
begin
DemoDlg := TDemoDlg.Create( Application );
try
with DemoDlg do begin
Caption := 'Delete Files with FileMask';
Edit1.Text := '*.*';
ShowModal;
if ModalResult = mrOK then
AbZipOutline1.DeleteFiles( Edit1.Text );
end;
finally
DemoDlg.Free;
end;
end;
procedure TForm1.ExtractFiles1Click(Sender: TObject);
begin
BaseDirDlg := TBaseDirDlg.Create( Application );
try
with BaseDirDlg, AbZipOutline1 do begin
Caption := 'Extract Files with FileMask';
Edit1.Text := '*.*';
ActionLabel.Caption := 'Target Directory:';
if BaseDirectory <> '' then
DLB.Directory := BaseDirectory;
CheckBox1.Caption := 'Restore Path';
CheckBox1.Checked := eoRestorePath in ExtractOptions;
CheckBox2.Caption := 'Create Directories';
CheckBox2.Checked := eoCreateDirs in ExtractOptions;
ShowModal;
if ModalResult = mrOK then begin
BaseDirectory := BaseDirDlg.DLB.Directory;
if CheckBox1.Checked then
ExtractOptions := ExtractOptions + [eoRestorePath]
else
ExtractOptions := ExtractOptions - [eoRestorePath];
if CheckBox2.Checked then
ExtractOptions := ExtractOptions + [eoCreateDirs]
else
ExtractOptions := ExtractOptions - [eoCreateDirs];
ExtractFiles( Edit1.Text );
FileListBox1.Update;
end;
end;
finally
BaseDirDlg.Free;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
AbZipOutline1.Save;
SaveIniSettings;
end;
procedure TForm1.ReadIniSettings;
var
Value : Integer;
Exists : Boolean;
begin
with TIniFile.Create( ChangeFileExt( Application.ExeName, '.INI' ) ) do begin
try
{view menu}
Exists := ReadBool( 'General', 'Exists', False );
if Exists then begin
AbZipOutline1.Attributes := [];
if ReadBool( 'View', 'CSize', False ) then
AbZipOutline1.Attributes := AbZipOutline1.Attributes +
[zaCompressedSize];
if ReadBool( 'View', 'CMethod', False ) then
AbZipOutline1.Attributes := AbZipOutline1.Attributes +
[zaCompressionMethod];
if ReadBool( 'View', 'CRatio', False ) then
AbZipOutline1.Attributes := AbZipOutline1.Attributes +
[zaCompressionRatio];
if ReadBool( 'View', 'CRC', False ) then
AbZipOutline1.Attributes := AbZipOutline1.Attributes +
[zaCRC];
if ReadBool( 'View', 'EFA', False ) then
AbZipOutline1.Attributes := AbZipOutline1.Attributes +
[zaExternalFileAttributes];
if ReadBool( 'View', 'IFA', False ) then
AbZipOutline1.Attributes := AbZipOutline1.Attributes +
[zaInternalFileAttributes];
if ReadBool( 'View', 'Encryption', False ) then
AbZipOutline1.Attributes := AbZipOutline1.Attributes +
[zaEncryption];
if ReadBool( 'View', 'TimeStamp', False ) then
AbZipOutline1.Attributes := AbZipOutline1.Attributes +
[zaTimeStamp];
if ReadBool( 'View', 'USize', False ) then
AbZipOutline1.Attributes := AbZipOutline1.Attributes +
[zaUnCompressedSize];
if ReadBool( 'View', 'MadeBy', False ) then
AbZipOutline1.Attributes := AbZipOutline1.Attributes +
[zaVersionMade];
if ReadBool( 'View', 'Needed', False ) then
AbZipOutline1.Attributes := AbZipOutline1.Attributes +
[zaVersionNeeded];
if ReadBool( 'View', 'Comment', False ) then
AbZipOutline1.Attributes := AbZipOutline1.Attributes +
[zaComment];
AbZipOutline1.Hierarchy := ReadBool( 'View', 'Hierarchy', True );
// Value := ReadInteger( 'View', 'OutlineStyle', -1 );
// if Value <> -1 then
// AbZipOutline1.OutlineStyle := TOutlineStyle( Value );
{preferences menu}
AbZipOutline1.BaseDirectory := ReadString( 'Preferences',
'BaseDirectory',
ExtractFilePath( Application.ExeName ) );
if not DirectoryExists( AbZipOutline1.BaseDirectory ) then
AbZipOutline1.BaseDirectory := ExtractFilePath( Application.ExeName );
Confirmations1.Checked := ReadBool( 'Preferences',
'Confirmations', False );
SpeedButton7.Down := Confirmations1.Checked;
Value := ReadInteger( 'Preferences',
'CompressionMethodToUse',
Ord( smBestMethod ) );
AbZipOutline1.CompressionMethodToUse := TAbZipSupportedMethod( Value );
Value := ReadInteger( 'Preferences', 'DeflationOption', Ord( doNormal));
AbZipOutline1.DeflationOption := TAbZipDeflationOption( Value );
AbZipOutline1.ExtractOptions := [];
if ReadBool( 'Preferences', 'CreateDirs', False ) then
AbZipOutline1.ExtractOptions := AbZipOutline1.ExtractOptions +
[eoCreateDirs];
if ReadBool( 'Preferences', 'RestorePath', False ) then
AbZipOutline1.ExtractOptions := AbZipOutline1.ExtractOptions +
[eoRestorePath];
AbZipOutline1.StoreOptions := [];
if ReadBool( 'Preferences', 'StripPath', False ) then
AbZipOutline1.StoreOptions := AbZipOutline1.StoreOptions +
[soStripPath];
if ReadBool( 'Preferences', 'RemoveDots', False ) then
AbZipOutline1.StoreOptions := AbZipOutline1.StoreOptions +
[soRemoveDots];
if ReadBool( 'Preferences', 'Recurse', False ) then
AbZipOutline1.StoreOptions := AbZipOutline1.StoreOptions +
[soRecurse];
StubName := ReadString( 'Self Extracting', 'StubName', 'selfex.exe' );
FilterComboBox1.Filter := ReadString( 'Navigator', 'Filter',
'All files (*.*)|*.*|Zip Files (*.ZIP)|*.ZIP|' +
'Executable Files (*.EXE)|*.EXE|Text files (*.TXT)|*.TXT|' +
'Pascal files (*.PAS)|*.PAS' );
end;
finally
Free;
end;
end;
end;
procedure TForm1.SaveIniSettings;
begin
with TIniFile.Create( ChangeFileExt( Application.ExeName, '.INI' ) ) do begin
try
{view menu}
WriteBool( 'General', 'Exists', True );
with AbZipOutline1 do begin
WriteBool( 'View', 'CSize', zaCompressedSize in Attributes );
WriteBool( 'View', 'CMethod', zaCompressionMethod in Attributes );
WriteBool( 'View', 'CRatio', zaCompressionRatio in Attributes );
WriteBool( 'View', 'CRC', zaCRC in Attributes );
WriteBool( 'View', 'EFA', zaExternalFileAttributes in Attributes );
WriteBool( 'View', 'IFA', zaInternalFileAttributes in Attributes );
WriteBool( 'View', 'Encryption', zaEncryption in Attributes );
WriteBool( 'View', 'TimeStamp', zaTimeStamp in Attributes );
WriteBool( 'View', 'USize', zaUnCompressedSize in Attributes );
WriteBool( 'View', 'MadeBy', zaVersionMade in Attributes );
WriteBool( 'View', 'Needed', zaVersionNeeded in Attributes );
WriteBool( 'View', 'Comment', zaComment in Attributes );
WriteBool( 'View', 'Hierarchy', Hierarchy );
// WriteInteger( 'View', 'OutlineStyle', Ord( OutlineStyle ) );
{preferences menu}
WriteString( 'Preferences', 'BaseDirectory', BaseDirectory );
WriteBool( 'Preferences', 'Confirmations', Confirmations1.Checked );
WriteInteger( 'Preferences', 'CompressionMethodToUse',
Ord( CompressionMethodToUse ) );
WriteInteger( 'Preferences', 'DeflationOption',
Ord( DeflationOption ));
WriteBool( 'Preferences', 'CreateDirs',
eoCreateDirs in ExtractOptions );
WriteBool( 'Preferences', 'RestorePath',
eoRestorePath in ExtractOptions );
WriteBool( 'Preferences', 'StripPath', soStripPath in StoreOptions );
WriteBool( 'Preferences', 'RemoveDots', soRemoveDots in StoreOptions );
WriteBool( 'Preferences', 'Recurse', soRecurse in StoreOptions );
end;
finally
Free;
end;
end;
end;
procedure TForm1.Close1Click(Sender: TObject);
begin
AbZipOutline1.FileName := '';
AbZipOutline1.Color := clBtnFace;
end;
procedure TForm1.AbZipOutline1Load(Sender: TObject);
begin
IgnoreDuplicateWarning := False;
AbZipOutline1.Color := clWindow;
SetCaption;
end;
procedure TForm1.Convert1Click(Sender: TObject);
var
ZipName : string;
ExeName : string;
StubSpec : string;
StubStream, ZipStream, SelfExtractingStream : TStream;
begin
AbZipOutline1.Save;
ZipName := ExpandFileName( AbZipOutline1.FileName );
AbZipOutline1.FileName := '';
ExeName := ChangeFileExt( ZipName, '.exe' );
StubSpec := ExtractFilePath( Application.ExeName ) + StubName;
StubStream := TFileStream.Create( StubSpec, fmOpenRead or fmShareDenyWrite );
ZipStream := TFileStream.Create( ZipName , fmOpenRead or fmShareDenyWrite );
SelfExtractingStream := TFileStream.Create( ExeName,
fmCreate or fmShareExclusive );
try
MakeSelfExtracting( StubStream, ZipStream, SelfExtractingStream );
finally
SelfExtractingStream.Free;
StubStream.Free;
ZipStream.Free;
end;
{and reload...}
AbZipOutline1.FileName := ExeName;
end;
procedure TForm1.GetMinMaxInfo( var Msg: TWMGetMinMaxInfo );
begin
with Msg.MinMaxInfo^ do begin
ptMinTrackSize := Point( 700, 400 );
ptMaxTrackSize := Point( 1600, 1200 );
end;
end;
procedure TForm1.AbZipOutline1ConfirmOverwrite(var Name: string;
var Confirm: Boolean);
var
pMessage : array [0..255] of Char;
pCaption : array [0..80] of Char;
begin
Confirm := MessageBox( 0,
StrPCopy( pMessage,
Format( 'Overwrite %s?',
[Name] ) ),
StrPCopy( pCaption, 'Confirmation' ),
MB_ICONQUESTION or MB_OKCANCEL ) = IDOK;
end;
procedure TForm1.Default1Click(Sender: TObject);
var
i : Integer;
begin
AbZipOutline1.Attributes := AbDefZipAttributes;
for i := 0 to Ord( High( TAbZipAttribute ) ) do
Attributes1.Items[i].Checked := TAbZipAttribute(i) in AbDefZipAttributes;
AbZipOutline1.Update;
end;
procedure TForm1.Contents1Click(Sender: TObject);
begin
Application.HelpCommand(HELP_CONTENTS, 0);
end;
procedure TForm1.About1Click(Sender: TObject);
begin
dlgAboutBox := TDlgAboutBox.Create( Self );
try
dlgAboutBox.ShowModal;
finally
dlgAboutBox.Free;
end;
end;
procedure TForm1.FileListBox1DblClick(Sender: TObject);
var
Browser : TAbZipBrowser;
Filename : string;
OK : Boolean;
begin
Filename := IncludeTrailingPathDelimiter(DirectoryListBox1.Directory) +
FileListBox1.Items[FileListBox1.ItemIndex];
if AbZipOutline1.FileName = '' then
try
AbZipOutline1.FileName := Filename;
except
AbZipOutline1.FileName := '';
end
else begin
Browser := TAbZipBrowser.Create( Self );
OK := True;
try
try
Browser.FileName := Filename;
except
OK := False;
end;
finally
Browser.Free;
end;
if OK then
AbZipOutline1.FileName := Filename;
end;
end;
procedure TForm1.AbZipOutline1EndDrag(Sender, Target: TObject; X,
Y: Integer);
begin
FileListBox1.Update;
end;
procedure TForm1.FileListBox1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then begin
FileX := X;
FileY := Y;
end;
end;
procedure TForm1.FileListBox1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
if ssLeft in Shift then
if ( ( X - FileX ) * ( X - FileX ) +
( Y - FileY ) * ( Y - FileY ) > 100 ) then
if FileListBox1.SelCount > 0 then
if ( not FileListBox1.Dragging ) then
FileListBox1.BeginDrag( True );
end;
procedure TForm1.AbZipOutline1MouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
if ssLeft in Shift then
if ( ( X - OutlineX ) * ( X - OutlineX ) +
( Y - OutlineY ) * ( Y - OutlineY ) > 100 ) then
if AbZipOutline1.SelectedZipItem <> nil then
if ( not FileListBox1.Dragging ) then
AbZipOutline1.BeginDrag( True );
end;
procedure TForm1.Edit1Exit(Sender: TObject);
begin
FileListBox1.ApplyFilePath(Edit1.Text);
end;
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if Key = #13 then
Edit1Exit( Self );
end;
procedure TForm1.OS5Click(Sender: TObject);
var
Item : TMenuItem;
begin
OS1.Checked := False;
OS2.Checked := False;
OS3.Checked := False;
OS4.Checked := False;
OS5.Checked := False;
OS6.Checked := False;
Item := (Sender as TMenuItem);
Item.Checked := True;
// AbZipOutline1.OutlineStyle := TOutlineStyle( Item.Tag );
end;
procedure TForm1.AbZipOutline1ConfirmProcessItem(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType;
var Confirm: Boolean);
var
Process : string;
begin
Confirm := True;
case ProcessType of
ptAdd : Process := 'Add';
ptDelete : Process := 'Delete';
ptExtract : Process := 'Extract';
ptFreshen : Process := 'Freshen';
ptMove : Process := 'Move';
end;
DoConfirm( Sender, Item, Confirm, Process );
end;
procedure TForm1.AbZipOutline1ProcessItemFailure(Sender: TObject;
Item: TAbArchiveItem; const ProcessType: TAbProcessType;
ErrorClass: TAbErrorClass; ErrorCode: Integer);
var
S : string;
pMessage : array [0..128] of Char;
begin
if ( ErrorClass = ecAbbrevia ) and
( ErrorCode = AbDuplicateName ) then begin
if not IgnoreDuplicateWarning then begin
if ProcessType = ptAdd then
s := 'Cannot add '
else
s := 'Cannot move ';
s := s + Item.FileName +
'. Would create a duplicate name. Ignore future warnings?';
if (Application.MessageBox( StrPCopy( pMessage, s ), 'Warning',
MB_YESNO ) = IDYES ) then
IgnoreDuplicateWarning := True;
end;
Exit;
end;
case ProcessType of
ptAdd :
ShowMessage( 'Cannot add ' + Item.FileName + ' to ' +
TAbZipOutline(Sender).FileName );
ptExtract :
ShowMessage( 'Cannot extract ' + Item.FileName + ' from ' +
TAbZipOutline(Sender).FileName );
ptFreshen :
ShowMessage( 'Cannot freshen ' + Item.FileName + ' in ' +
TAbZipOutline(Sender).FileName );
ptMove :
ShowMessage( 'Cannot move ' + Item.FileName + ' to ' +
TAbZipOutline(Sender).FileName );
end;
if ErrorClass = ecAbbrevia then
ShowMessage( AbStrRes(ErrorCode) );
end;
procedure TForm1.TurboPowerontheWeb1Click(Sender: TObject);
begin
if ShellExecute(0, 'open', 'http://www.turbopower.com', '', '', SW_SHOWNORMAL) <= 32 then
ShowMessage('Unable to start web browser. Make sure you have it properly set-up on your system.');
end;
procedure TForm1.AbbreviaontheWeb1Click(Sender: TObject);
begin
if ShellExecute(0, 'open', 'http://sf.net/projects/tpabbrevia', '', '', SW_SHOWNORMAL) <= 32 then
ShowMessage('Unable to start web browser. Make sure you have it properly set-up on your system.');
end;
procedure TForm1.TempDirectory1Click(Sender: TObject);
begin
with TAbDirDlg.Create(Self) do begin
Caption := 'Directory';
AdditionalText := 'Select temporary directory';
if Execute then
AbZipOutline1.TempDirectory := SelectedFolder;
Free;
end;
end;
procedure TForm1.Logging1Click(Sender: TObject);
var
E, F : string;
begin
AbZipOutline1.Logging := False;
Logging1.Checked := not Logging1.Checked;
if Logging1.Checked then with OpenDialog1 do begin
Title := 'Select Text File for Logging';
E := DefaultExt;
DefaultExt := '';
F := Filter;
Filter := '';
Filename := AbZipOutline1.LogFile;
if Execute then begin
AbZipOutline1.LogFile := Filename;
AbZipOutline1.Logging := True;
end;
DefaultExt := E;
Filter := F;
end;
Logging1.Checked := AbZipOutline1.Logging;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/Uexample.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UEXAMPLE.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit uexample;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, ExtCtrls, Gauges, StdCtrls,
AbZipOut, AbArcTyp, AbMeter, AbBase, AbUtils;
type
TForm1 = class(TForm)
BottomStatus: TPanel;
MainMenu1: TMainMenu;
File1: TMenuItem;
Open1: TMenuItem;
N1: TMenuItem;
Exit1: TMenuItem;
OpenDialog1: TOpenDialog;
TopStatus: TPanel;
PopupMenu1: TPopupMenu;
Add1: TMenuItem;
Delete1: TMenuItem;
Extract1: TMenuItem;
Freshen1: TMenuItem;
Move1: TMenuItem;
Panel1: TPanel;
Memo1: TMemo;
AbMeter1: TAbMeter;
AbMeter2: TAbMeter;
Label1: TLabel;
Label2: TLabel;
AbZipOutline1: TAbZipOutline;
procedure Open1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure AbZipOutline1Load(Sender: TObject);
procedure AbZipOutline1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Delete1Click(Sender: TObject);
procedure Extract1Click(Sender: TObject);
procedure Freshen1Click(Sender: TObject);
procedure Add1Click(Sender: TObject);
procedure Move1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure AbZipOutline1ProcessItemFailure(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType;
ErrorClass: TAbErrorClass; ErrorCode: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses udemodlg;
{$R *.DFM}
procedure TForm1.Open1Click(Sender: TObject);
begin
if OpenDialog1.Execute then begin
AbZipOutline1.OpenArchive(OpenDialog1.FileName);
end;
end;
procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.AbZipOutline1Load(Sender: TObject);
begin
TopStatus.Caption := ' ' + AbZipOutline1.FileName;
end;
procedure TForm1.AbZipOutline1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
i : LongInt;
begin
if Button = mbRight then begin
{prepare popup menu}
if AbZipOutline1.Count > 0 then begin
{there are items in the outline - select the item under the mouse}
i := AbZipOutline1.GetOutlineItem( X, Y );
if i <> -1 then
AbZipOutline1.SelectedItem := i;
end;
if AbZipOutline1.FileName <> '' then
Add1.Enabled := True
else
{archive has to be initialized before we can add to it}
Add1.Enabled := False;
if AbZipOutline1.SelectedZipItem <> nil then begin
{pointing at a file - allow file operations}
Delete1.Enabled := True;
Extract1.Enabled := True;
Freshen1.Enabled := True;
Move1.Enabled := True;
end
else begin
{pointing at a directory - don't allow file operations}
Delete1.Enabled := False;
Extract1.Enabled := False;
Freshen1.Enabled := False;
Move1.Enabled := False;
end;
end;
end;
procedure TForm1.Delete1Click(Sender: TObject);
begin
AbZipOutline1.DeleteFiles(AbZipOutline1.SelectedZipItem.FileName);
end;
procedure TForm1.Extract1Click(Sender: TObject);
begin
AbZipOutline1.ExtractFiles(AbZipOutline1.SelectedZipItem.FileName);
end;
procedure TForm1.Freshen1Click(Sender: TObject);
begin
AbZipOutline1.FreshenFiles(AbZipOutline1.SelectedZipItem.FileName);
end;
procedure TForm1.Add1Click(Sender: TObject);
begin
DemoDlg.Caption := 'Add Files with FileMask';
DemoDlg.Edit1.Text := '*.*';
DemoDlg.ShowModal;
if DemoDlg.ModalResult = mrOK then
AbZipOutline1.AddFiles(DemoDlg.Edit1.Text, 0);
end;
procedure TForm1.Move1Click(Sender: TObject);
begin
DemoDlg.Caption := 'Move File to New Name';
DemoDlg.Edit1.Text := AbZipOutline1.SelectedZipItem.FileName;
DemoDlg.ShowModal;
if DemoDlg.ModalResult = mrOK then
AbZipOutline1.Move(AbZipOutline1.SelectedZipItem, DemoDlg.Edit1.Text);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
AbZipOutline1.BaseDirectory := ExtractFilePath( Application.ExeName );
end;
procedure TForm1.AbZipOutline1ProcessItemFailure(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType;
ErrorClass: TAbErrorClass; ErrorCode: Integer);
begin
case ProcessType of
ptAdd : ShowMessage( 'Failed to add ' + Item.Filename );
ptExtract : ShowMessage('Failed to extract ' + Item.Filename);
ptFreshen : ShowMessage('Failed to freshen ' + Item.Filename);
end;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/Unzip.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UNZIP.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program Unzip;
uses
Forms,
Uunzip in 'Uunzip.pas' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/Unzip.dproj
================================================
{4193EA89-8316-4EA6-824B-CD35E8A098C8}Unzip.dprTrue
DebugWin32ApplicationVCLDCC3212.3true
trueBasetrue
trueBasetrue
false00400000WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)falsefalsefalsefalsefalseRELEASE;$(DCC_Define)0falseDEBUG;$(DCC_Define)falsetrueMainSourceCfg_2BaseBaseCfg_1BaseDelphi.Personality.12VCLApplicationUnzip.dprFalseFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0True12
================================================
FILE: lib/abbrevia/examples/Delphi/Unzip.dproj.2007
================================================
{4193EA89-8316-4EA6-824B-CD35E8A098C8}Unzip.dprTrue
DebugWin32ApplicationVCLDCC32true
trueBasetrue
trueBasetrue
falsefalse00400000falsefalsefalsefalseRELEASE;$(DCC_Define)0falseDEBUG;$(DCC_Define)falsetrueMainSourceCfg_2BaseBaseCfg_1BaseDelphi.Personality.12VCLApplicationUnzip.dprFalseFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0True12
================================================
FILE: lib/abbrevia/examples/Delphi/UsingApi.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: USINGAPI.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
{$APPTYPE CONSOLE}
program UsingAPI;
{Build this app using the Define "BuildingStub", to keep it smaller!}
uses
AbArcTyp, AbZipTyp, AbZipPrc, AbUnzPrc, Classes, SysUtils, AbUtils;
type
THelper = class
public
procedure UnzipProc( Sender : TObject; Item : TAbArchiveItem;
const NewName : string );
procedure ZipProc( Sender : TObject; Item : TAbArchiveItem;
OutStream : TStream );
procedure ArchiveItemProgress( Sender: TObject;
Item: TAbArchiveItem;
Progress: Byte;
var Abort: Boolean);
end;
procedure THelper.ArchiveItemProgress( Sender: TObject;
Item: TAbArchiveItem; Progress: Byte; var Abort: Boolean);
type
TMethodStrings = array [ cmStored..cmDCLImploded ] of string;
const
MethodStrings : TMethodStrings = ('UnStoring', 'UnShrinking', 'UnReducing',
'UnReducing', 'UnReducing', 'UnReducing',
'Exploding', 'DeTokenizing', 'Inflating',
'Enhanced Inflating', 'DCL Exploding');
var
ActionString : string;
CompMethod: TAbZipCompressionMethod;
begin
case Item.Action of
aaAdd : ActionString := 'Adding ';
aaFreshen : ActionString := 'Freshening ';
else begin
CompMethod := (Item as TAbZipItem).CompressionMethod;
if CompMethod in [cmStored..cmDCLImploded] then
ActionString := MethodStrings[(Item as TAbZipItem).CompressionMethod] +
' '
else
ActionString := 'Decompressing ';
end;
end;
WriteLn( ActionString + Item.FileName );
end;
procedure THelper.UnzipProc( Sender : TObject; Item : TAbArchiveItem;
const NewName : string );
begin
AbUnzip( Sender, TAbZipItem(Item), NewName );
end;
procedure THelper.ZipProc( Sender : TObject; Item : TAbArchiveItem;
OutStream : TStream );
begin
AbZip( TAbZipArchive(Sender), TAbZipItem(Item), OutStream );
end;
var
ZipFileName : string;
OutDirectory : string;
InDirectory : string;
Mask : string;
Archive : TAbZipArchive;
Helper : THelper;
begin
WriteLn;
{usage: UsingAPI ZipFileName InDirectory Mask OutDirectory}
if (ParamCount < 4) or
((ParamCount > 0) and (Pos('?', ParamStr(1))>0)) then begin
WriteLn;
WriteLn( ' Syntax: UsingAPI ZipFileName InDirectory Mask OutDirectory');
Halt;
end;
ZipFileName := ParamStr(1);
InDirectory := ParamStr(2);
Mask := ParamStr(3);
OutDirectory := ParamStr(4);
{open the file}
if FileExists( ZipFileName ) then begin
Archive := TAbZipArchive.Create( ZipFileName,
fmOpenReadWrite or fmShareDenyWrite );
Archive.Load;
end
else
Archive := TAbZipArchive.Create( ZipFileName,
fmCreate or fmShareDenyNone );
try
Helper := THelper.Create;
try
{set the event handlers}
Archive.InsertHelper := Helper.ZipProc;
Archive.ExtractHelper := Helper.UnzipProc;
Archive.OnArchiveItemProgress := Helper.ArchiveItemProgress;
{set the BaseDirectory for input files}
Archive.BaseDirectory := InDirectory;
{add all the files in the BaseDirectory to the archive}
Archive.AddFiles( Mask, 0 );
{save the files to the zipfile}
Archive.Save;
{now, change the base directory to the output}
Archive.BaseDirectory := OutDirectory;
Archive.ExtractFiles( Mask );
finally
Helper.Free;
end;
finally
Archive.Free;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/Ustrpad.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: USTRPAD.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit Ustrpad;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
Panel1: TPanel;
Memo2: TMemo;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
ZnfName : string;
TxtName : string;
ZnfStream : TFileStream;
TxtStream : TStream;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
AbUnzPrc,
AbZipPrc;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
ZnfName := ChangeFileExt(Application.ExeName, '.zst');
TxtName := ExtractFileName( ChangeFileExt(Application.ExeName, '.pad') );
ChDir( ExtractFilePath( Application.ExeName ) );
if FileExists( ZnfName ) then begin
TxtStream := TMemoryStream.Create;
try
ZnfStream := TFileStream.Create( ZnfName,
fmOpenRead or fmShareExclusive );
try
InflateStream( ZnfStream, TxtStream );
finally
ZnfStream.Free;
end;
TxtStream.Position := 0;
Memo1.Lines.LoadFromStream( TxtStream );
finally
TxtStream.Free;
end;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
TxtStream := TMemoryStream.Create;
try
Memo1.Lines.SaveToStream( TxtStream );
TxtStream.Position := 0;
if FileExists( ZnfName ) then
ZnfStream := TFileStream.Create( ZnfName,
fmOpenWrite or fmShareExclusive )
else
ZnfStream := TFileStream.Create( ZnfName,
fmCreate or fmShareExclusive );
try
DeflateStream( TxtStream, ZnfStream );
finally
ZnfStream.Free;
end;
finally
TxtStream.Free;
end;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/Uunzip.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UUNZIP.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit Uunzip;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
AbZBrows, AbUnZper, AbArcTyp, AbMeter, AbBrowse, AbBase;
type
TForm1 = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
AbUnZipper1: TAbUnZipper;
Memo1: TMemo;
AbMeter1: TAbMeter;
AbMeter2: TAbMeter;
Label1: TLabel;
Label2: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then begin
with AbUnzipper1 do begin
FileName := OpenDialog1.FileName;
BaseDirectory := ExtractFilePath( FileName );
ExtractFiles( '*.*' );
end;
end;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/Uzip.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UZIP.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit Uzip;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Gauges,
AbZipper, AbArcTyp, AbZBrows, AbMeter, AbBrowse, AbBase;
type
TForm1 = class(TForm)
AbZipper1: TAbZipper;
Button1: TButton;
OpenDialog1: TOpenDialog;
Memo1: TMemo;
AbMeter1: TAbMeter;
AbMeter2: TAbMeter;
Label1: TLabel;
Label2: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
AbZipper1.AddFiles( OpenDialog1.FileName, 0 );
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ZipReg.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: ZIPREG.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program ZipReg;
uses
Forms,
ZipReg1 in 'ZipReg1.pas' {ExZipAssociation};
begin
Application.CreateForm(TExZipAssociation, ExZipAssociation);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ZipReg.dproj
================================================
{623B6B04-BBC3-4044-85BC-8C225B160F0E}ZipReg.dprTrue
DebugWin32ApplicationVCLDCC3212.3true
trueBasetrue
trueBasetrue
false00400000WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)falsefalsefalsefalsefalseRELEASE;$(DCC_Define)0falseDEBUG;$(DCC_Define)falsetrueMainSourceCfg_2BaseBaseCfg_1BaseDelphi.Personality.12VCLApplicationZipReg.dprFalseFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0True12
================================================
FILE: lib/abbrevia/examples/Delphi/ZipReg.dproj.2007
================================================
{623B6B04-BBC3-4044-85BC-8C225B160F0E}ZipReg.dprTrue
DebugWin32ApplicationVCLDCC32true
trueBasetrue
trueBasetrue
falsefalse00400000falsefalsefalsefalseRELEASE;$(DCC_Define)0falseDEBUG;$(DCC_Define)falsetrueMainSourceCfg_2BaseBaseCfg_1BaseDelphi.Personality.12VCLApplicationZipReg.dprFalseFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0True12
================================================
FILE: lib/abbrevia/examples/Delphi/ZipReg1.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: ZIPREG1.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit ZipReg1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ExtCtrls, Buttons;
type
TExZipAssociation = class(TForm)
CheckZipReg: TButton;
RegZipExt: TButton;
Replace: TCheckBox;
ExitBtn: TButton;
GroupBox1: TGroupBox;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Icon1: TImage;
ID1: TEdit;
FileType1: TEdit;
App1: TEdit;
Browse1: TSpeedButton;
OpenDialog1: TOpenDialog;
procedure CheckZipRegClick(Sender: TObject);
procedure RegZipExtClick(Sender: TObject);
procedure ExitBtnClick(Sender: TObject);
procedure Browse1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
ExZipAssociation: TExZipAssociation;
implementation
{$R *.DFM}
uses
AbZipExt, ShellApi;
var
App, ID, FileType : string;
FN : array[0..255] of char;
IconIndex : Word;
procedure TExZipAssociation.CheckZipRegClick(Sender: TObject);
begin
App := '';
ID := '';
FileType := '';
if AbGetZipAssociation(App, ID, FileType) then begin
GroupBox1.Caption := ' ''zip'' is currently registered ';
StrPCopy(FN, App);
{$IFNDEF Win32}
Icon1.Picture.Icon.Handle := ExtractIcon(HInstance, FN, 0);
{$ELSE}
Icon1.Picture.Icon.Handle := ExtractAssociatedIcon(HInstance, FN, IconIndex);
{$ENDIF}
end else begin
GroupBox1.Caption := ' ''zip'' is not registered ';
Icon1.Picture.Icon.Handle := 0;
end;
ID1.Text := ID;
FileType1.Text := FileType;
App1.Text := App;
end;
procedure TExZipAssociation.RegZipExtClick(Sender: TObject);
begin
if (AbExistingZipAssociation and not Replace.Checked) then
CheckZipRegClick(nil)
else begin
App := App1.Text;
FileType := FileType1.Text;
ID := ID1.Text;
if AbRegisterZipExtension(App, ID, FileType, Replace.Checked) then
CheckZipRegClick(nil)
else begin
GroupBox1.Caption := ' Error occurred during registration ';
Icon1.Picture.Icon.Handle := 0;
end;
end;
end;
procedure TExZipAssociation.ExitBtnClick(Sender: TObject);
begin
Close;
end;
procedure TExZipAssociation.Browse1Click(Sender: TObject);
begin
OpenDialog1.Title := 'Select application to associate with ''zip'' files';
OpenDialog1.Filename := '*.exe';
if OpenDialog1.Execute then begin
App := OpenDialog1.Filename;
App1.Text := App;
end;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ZipView.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: ZIPVIEW.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program ZipView;
uses
Forms,
ZipView1 in 'ZipView1.PAS' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ZipView1.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: ZIPVIEW1.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit ZipView1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, StdCtrls, ExtCtrls, Menus, FileCtrl, Gauges, ComCtrls,
AbArcTyp, AbUtils, AbZipper, AbZipKit, AbZipTyp, AbZBrows, AbMeter,
AbDlgDir, AbView, AbZView, AbBrowse, AbBase;
type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;
Panel1: TPanel;
FontDialog1: TFontDialog;
MainMenu1: TMainMenu;
File1: TMenuItem;
Open1: TMenuItem;
Close1: TMenuItem;
N1: TMenuItem;
Print1: TMenuItem;
Exit1: TMenuItem;
ColorDialog1: TColorDialog;
ZipView1: TMenuItem;
Attributes1: TMenuItem;
Itemname1: TMenuItem;
Packed1: TMenuItem;
Method1: TMenuItem;
Ratio1: TMenuItem;
CRC1: TMenuItem;
Fileattributes1: TMenuItem;
Filetype1: TMenuItem;
Encryption1: TMenuItem;
Timestamp1: TMenuItem;
Filesize1: TMenuItem;
Versionmade1: TMenuItem;
Versionneeded1: TMenuItem;
Path1: TMenuItem;
Display1: TMenuItem;
Columnlines1: TMenuItem;
Columnmoving1: TMenuItem;
Columnresizing1: TMenuItem;
MultiSelect1: TMenuItem;
Rowlines1: TMenuItem;
Thumbtracking1: TMenuItem;
Trackactiverow1: TMenuItem;
Sort1: TMenuItem;
Itemname2: TMenuItem;
Packed2: TMenuItem;
Ratio2: TMenuItem;
Timestamp2: TMenuItem;
Filesize2: TMenuItem;
Select1: TMenuItem;
SelectAll1: TMenuItem;
ClearSelections1: TMenuItem;
Rows1: TMenuItem;
Rowheight1: TMenuItem;
Headerheight1: TMenuItem;
Font1: TMenuItem;
Alternatecolors1: TMenuItem;
Action1: TMenuItem;
Add1: TMenuItem;
Delete1: TMenuItem;
Extract1: TMenuItem;
Freshen1: TMenuItem;
AbZipView1: TAbZipView;
AbZipKit1: TAbZipKit;
ZipKit1: TMenuItem;
Compress1: TMenuItem;
N2: TMenuItem;
Store1: TMenuItem;
Stored1: TMenuItem;
Deflated1: TMenuItem;
Best1: TMenuItem;
Deflation1: TMenuItem;
Normal1: TMenuItem;
Maximum1: TMenuItem;
Fast1: TMenuItem;
SuperFast1: TMenuItem;
CreateDirs1: TMenuItem;
RestorePath1: TMenuItem;
StripPath1: TMenuItem;
RemoveDots1: TMenuItem;
Recurse1: TMenuItem;
ShowIcons1: TMenuItem;
Colors1: TMenuItem;
Selectedcolor: TMenuItem;
Selectedtextcolor: TMenuItem;
AlternateColor1: TMenuItem;
AlternateTextColor1: TMenuItem;
Freshen2: TMenuItem;
Panel2: TPanel;
AbMeter1: TAbMeter;
Label1: TLabel;
Label2: TLabel;
Moveselecteditem1: TMenuItem;
Replace1: TMenuItem;
PopupMenu1: TPopupMenu;
Delete2: TMenuItem;
Extract2: TMenuItem;
Freshen3: TMenuItem;
Move1: TMenuItem;
AbMeter2: TAbMeter;
Save1: TMenuItem;
Testselecteditems1: TMenuItem;
Logging1: TMenuItem;
DeletedColor1: TMenuItem;
DeletedTextColor1: TMenuItem;
procedure AbZipView1Click(Sender: TObject);
procedure AttributeClick(Sender: TObject);
procedure DisplayOptionClick(Sender: TObject);
procedure SortAttributeClick(Sender: TObject);
procedure Open1Click(Sender: TObject);
procedure Close1Click(Sender: TObject);
procedure SelectAll1Click(Sender: TObject);
procedure ClearSelections1Click(Sender: TObject);
procedure Font1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure Selected1Click(Sender: TObject);
procedure Selectedtext1Click(Sender: TObject);
procedure Rowheight1Click(Sender: TObject);
procedure Headerheight1Click(Sender: TObject);
procedure Add1Click(Sender: TObject);
procedure Delete1Click(Sender: TObject);
procedure Extract1Click(Sender: TObject);
procedure ExtractOptionClick(Sender: TObject);
procedure StoreOptionClick(Sender: TObject);
procedure MethodClick(Sender: TObject);
procedure DeflationOptionClick(Sender: TObject);
procedure AbZipKit1ConfirmProcessItem(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType;
var Confirm: Boolean);
procedure AbZipView1Change(Sender: TObject);
procedure AlternateColor1Click(Sender: TObject);
procedure AlternateTextColor1Click(Sender: TObject);
procedure Freshen1Click(Sender: TObject);
procedure Moveselecteditem1Click(Sender: TObject);
procedure AbZipKit1Save(Sender: TObject);
procedure Save1Click(Sender: TObject);
procedure Testselecteditems1Click(Sender: TObject);
procedure Logging1Click(Sender: TObject);
procedure DeletedColor1Click(Sender: TObject);
procedure DeletedTextColor1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const
MainCaption = ' TAbZipView example';
{ -------------------------------------------------------------------------- }
procedure TForm1.AbZipView1Click(Sender: TObject);
begin
Panel1.Caption := AbZipView1.Items[AbZipView1.ActiveRow].Filename;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Open1Click(Sender: TObject);
begin
OpenDialog1.Filename := '*.zip';
if OpenDialog1.Execute then begin
AbZipView1.BeginUpdate;
// AbZipKit1.FileName := '';
AbZipKit1.Filename := OpenDialog1.Filename;
Caption := AbZipKit1.Filename +
' ' + IntToStr(AbZipView1.Count) + ' items';
Action1.Enabled := True;
AbZipView1.EndUpdate;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Close1Click(Sender: TObject);
begin
AbZipKit1.Filename := '';
Caption := MainCaption;
Panel1.Caption := '';
Action1.Enabled := False;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.AttributeClick(Sender: TObject);
begin
with TMenuItem(Sender) do begin
Checked := not Checked;
if Checked then
AbZipView1.Attributes := AbZipView1.Attributes + [TAbViewAttribute(Tag)]
else
AbZipView1.Attributes := AbZipView1.Attributes - [TAbViewAttribute(Tag)];
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.DisplayOptionClick(Sender: TObject);
begin
with TMenuItem(Sender) do begin
Checked := not Checked;
if Checked then
AbZipView1.DisplayOptions := AbZipView1.DisplayOptions +
[TAbDisplayOption(Tag)]
else
AbZipView1.DisplayOptions := AbZipView1.DisplayOptions -
[TAbDisplayOption(Tag)]
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.SortAttributeClick(Sender: TObject);
begin
with TMenuItem(Sender) do begin
Checked := not Checked;
if Checked then
AbZipView1.SortAttributes := AbZipView1.SortAttributes +
[TAbSortAttribute(Tag)]
else
AbZipView1.SortAttributes := AbZipView1.SortAttributes -
[TAbSortAttribute(Tag)]
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.StoreOptionClick(Sender: TObject);
begin
with TMenuItem(Sender) do begin
Checked := not Checked;
if Checked then
AbZipKit1.StoreOptions := AbZipKit1.StoreOptions +
[TAbStoreOption(Tag)]
else
AbZipKit1.StoreOptions := AbZipKit1.StoreOptions -
[TAbStoreOption(Tag)]
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.ExtractOptionClick(Sender: TObject);
begin
with TMenuItem(Sender) do begin
Checked := not Checked;
if Checked then
AbZipKit1.ExtractOptions := AbZipKit1.ExtractOptions +
[TAbExtractOption(Tag)]
else
AbZipKit1.ExtractOptions := AbZipKit1.ExtractOptions -
[TAbExtractOption(Tag)]
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.MethodClick(Sender: TObject);
begin
with TMenuItem(Sender) do begin
Checked := true;
AbZipKit1.CompressionMethodToUse := TAbZipSupportedMethod(Tag);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.DeflationOptionClick(Sender: TObject);
begin
with TMenuItem(Sender) do begin
Checked := true;
AbZipKit1.DeflationOption := TAbZipDeflationOption(Tag);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.SelectAll1Click(Sender: TObject);
begin
AbZipView1.SelectAll;
AbZipView1Click(nil);
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.ClearSelections1Click(Sender: TObject);
begin
AbZipView1.ClearSelections;
AbZipView1Click(nil);
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Font1Click(Sender: TObject);
begin
FontDialog1.Font := AbZipView1.Font;
if FontDialog1.Execute then
AbZipView1.Font := FontDialog1.Font;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.DeletedColor1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
AbZipView1.Colors.Deleted := ColorDialog1.Color;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.DeletedTextColor1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
AbZipView1.Colors.DeletedText := ColorDialog1.Color;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Selected1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
AbZipView1.Colors.Selected := ColorDialog1.Color;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Selectedtext1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
AbZipView1.Colors.SelectedText := ColorDialog1.Color;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Rowheight1Click(Sender: TObject);
var
s : string;
begin
s := IntToStr(AbZipView1.DefaultRowHeight);
if InputQuery(MainCaption, 'Row Height', s) then
AbZipView1.DefaultRowHeight := StrToIntDef(s, 18);
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Headerheight1Click(Sender: TObject);
var
s : string;
begin
s := IntToStr(AbZipView1.HeaderRowHeight);
if InputQuery(MainCaption, 'Header Height', s) then
AbZipView1.HeaderRowHeight := StrToIntDef(s, 18);
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Add1Click(Sender: TObject);
var
i : Integer;
begin
with OpenDialog1 do begin
Filename := '*.*';
Options := Options + [ofAllowMultiSelect];
AbZipView1.BeginUpdate;
if Execute then for i := 0 to Pred(Files.Count) do
AbZipKit1.AddFiles(Files[i], 0);
AbZipView1.EndUpdate;
Panel1.Caption := '';
Options := Options - [ofAllowMultiSelect];
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Delete1Click(Sender: TObject);
var
i : Longint;
begin
Panel1.Caption := '';
with AbZipView1 do
for i := 0 to Pred(Count) do
Items[i].Tagged := Selected[i];
AbZipKit1.DeleteTaggedItems;
Panel1.Caption := '';
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Extract1Click(Sender: TObject);
var
i : Longint;
Continue : Boolean;
begin
{$IFDEF Win32}
with TAbDirDlg.Create(Self) do begin
Caption := 'Directory';
AdditionalText := 'Select folder to extract into';
SelectedFolder := AbZipKit1.BaseDirectory;
Continue := Execute;
if Continue then
AbZipKit1.BaseDirectory := SelectedFolder;
{$ELSE}
with TDirDlg.Create(Self) do begin
SelectedFolder := AbZipKit1.BaseDirectory;
Continue := (ShowModal = mrOK);
if Continue then
AbZipKit1.BaseDirectory := SelectedFolder;
{$ENDIF}
Free;
end;
if not Continue then
Exit;
Panel1.Caption := '';
with AbZipView1 do
for i := 0 to Pred(Count) do
Items[i].Tagged := Selected[i];
AbZipKit1.ExtractTaggedItems;
AbZipView1.ClearSelections;
Panel1.Caption := '';
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Freshen1Click(Sender: TObject);
var
i : Longint;
begin
Panel1.Caption := '';
with AbZipView1 do
for i := 0 to Pred(Count) do
Items[i].Tagged := Selected[i];
AbZipKit1.FreshenTaggedItems;
AbZipKit1.Save;
AbZipView1.ClearSelections;
Panel1.Caption := '';
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.TestSelecteditems1Click(Sender: TObject);
var
i : Longint;
begin
Panel1.Caption := '';
with AbZipView1 do
for i := 0 to Pred(Count) do
Items[i].Tagged := Selected[i];
AbZipKit1.TestTaggedItems;
AbZipView1.ClearSelections;
Panel1.Caption := '';
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.AbZipKit1ConfirmProcessItem(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType; var Confirm: Boolean);
var
s : string;
begin
case ProcessType of
ptAdd : s := 'Adding ';
ptDelete : s := 'Deleting ';
ptExtract : s := 'Extracting ';
ptFreshen : s := 'Freshening ';
else
s := '??? ';
end;
Panel1.Caption := s + Item.Filename;
Confirm := True;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.AbZipView1Change(Sender: TObject);
begin
Caption := AbZipKit1.Filename +
' ' + IntToStr(AbZipView1.Count) + ' items';
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.AlternateColor1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
AbZipView1.Colors.Alternate := ColorDialog1.Color;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.AlternateTextColor1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
AbZipView1.Colors.AlternateText := ColorDialog1.Color;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Moveselecteditem1Click(Sender: TObject);
var
i : Longint;
s : string;
begin
with AbZipView1 do
if (SelCount > 0) then begin
for i := 0 to Pred(Count) do
if Selected[i] then begin
s := Items[i].Filename;
if InputQuery(MainCaption, 'Rename file', s) then
AbZipKit1.Move(Items[i], s);
end;
AbZipKit1.Save;
AbZipView1.ClearSelections;
Panel1.Caption := '';
end;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.AbZipKit1Save(Sender: TObject);
begin
Panel1.Caption := 'Saving ' + AbZipKit1.Filename;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Save1Click(Sender: TObject);
begin
if (AbZipKit1.Filename <> '') then
AbZipKit1.Save;
end;
{ -------------------------------------------------------------------------- }
procedure TForm1.Logging1Click(Sender: TObject);
begin
Logging1.Checked := not Logging1.Checked;
if Logging1.Checked then begin
OpenDialog1.Title := 'Select log file';
if AbZipKit1.LogFile = '' then
OpenDialog1.Filename := '*.txt'
else
OpenDialog1.Filename := AbZipKit1.LogFile;
Logging1.Checked := OpenDialog1.Execute;
if Logging1.Checked then
AbZipKit1.LogFile := OpenDialog1.Filename;
end;
AbZipKit1.Logging := Logging1.Checked;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/Zipper.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: ZIPPER.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program zipper;
uses
Forms,
Uzip in 'Uzip.pas' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/Zipper.dproj
================================================
{3B87EA3D-333F-41D2-A7EE-A559DF4E7347}Zipper.dprTrue
DebugWin32ApplicationVCLDCC3212.3true
trueBasetrue
trueBasetrue
false00400000WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)falsefalsefalsefalsefalseRELEASE;$(DCC_Define)0falseDEBUG;$(DCC_Define)falsetrueMainSourceCfg_2BaseBaseCfg_1BaseDelphi.Personality.12VCLApplicationZipper.dprFalseFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0True12
================================================
FILE: lib/abbrevia/examples/Delphi/Zipper.dproj.2007
================================================
{3B87EA3D-333F-41D2-A7EE-A559DF4E7347}Zipper.dprTrue
DebugWin32ApplicationVCLDCC32true
trueBasetrue
trueBasetrue
falsefalse00400000falsefalsefalsefalseRELEASE;$(DCC_Define)0falseDEBUG;$(DCC_Define)falsetrueMainSourceCfg_2BaseBaseCfg_1BaseDelphi.Personality.12VCLApplicationZipper.dprFalseFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0True12
================================================
FILE: lib/abbrevia/examples/Delphi/dgAbout.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: DGABOUT.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit dgAbout;
interface
uses
Windows, Classes, Graphics, Forms, Controls, StdCtrls,
Buttons, ExtCtrls;
type
TdlgAboutBox = class(TForm)
Panel1: TPanel;
ProgramIcon: TImage;
Label7: TLabel;
Label8: TLabel;
Panel2: TPanel;
lnTitleShadow: TLabel;
lblTitle: TLabel;
Label5: TLabel;
OKButton: TButton;
Version: TLabel;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label6: TLabel;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
dlgAboutBox: TdlgAboutBox;
implementation
{$R *.DFM}
uses
AbConst;
procedure TdlgAboutBox.FormCreate(Sender: TObject);
begin
Version.Caption := 'Abbrevia ' + AbVersionS;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/makesfx.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: MAKESFX.DPR *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
program makesfx;
uses
Forms,
umakesfx in 'umakesfx.pas' {Form1};
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/spntst0.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
unit spntst0;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
{IpStrms,}
{StStrms,}
AbBufStm, AbBase, AbBrowse, AbZBrows, AbZipper, AbZipKit,
AbSpanSt, ExtCtrls;
type
TForm1 = class(TForm)
AbZipKit1: TAbZipKit;
Button1: TButton;
OpenDialog1: TOpenDialog;
Button3: TButton;
Bevel1: TBevel;
SaveDialog1: TSaveDialog;
procedure Button1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure DoRequestImage(Sender: TObject; ImageNumber: Integer;
var ImageName: String; var Abort: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
Span: TAbSpanStream;
SrcFile : TFileStream;
Src, Dest : string;
begin
OpenDialog1.FileName := '*.*';
OpenDialog1.Title := 'Select Source File';
if OpenDialog1.Execute then begin
Src := OpenDialog1.FileName;
OpenDialog1.Title := 'Specify Destination File';
if OpenDialog1.Execute then begin
Dest := OpenDialog1.FileName;
Span := TAbSpanStream.Create(Dest, fmCreate);
SrcFile := TFileStream.Create(Src, fmOpenRead);
Span.CopyFrom(SrcFile, SrcFile.Size);
Span.Free;
SrcFile.Free;
end;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
var
Span: TAbSpanStream;
DestFile : TFileStream;
Src, Dest : string;
begin
OpenDialog1.FileName := '*.*';
OpenDialog1.Title := 'Select Source File';
if OpenDialog1.Execute then begin
Src := OpenDialog1.FileName;
SaveDialog1.Title := 'Specify Destination File';
if SaveDialog1.Execute then begin
Dest := SaveDialog1.FileName;
Span := TAbSpanStream.Create(Src, fmOpenRead);
Span.SpanType := stLocal;
Span.OnRequestImage := DoRequestImage;
DestFile := TFileStream.Create(Dest, fmCreate);
DestFile.CopyFrom(Span, 3145728{Span.Size});
Span.Free;
DestFile.Free;
end;
end;
end;
procedure TForm1.DoRequestImage(Sender: TObject;
ImageNumber: Integer; var ImageName: String; var Abort: Boolean);
begin
Abort := not OpenDialog1.Execute;
if not Abort then
ImageName := OpenDialog1.FileName;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/uCfGenDg.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
unit uCfGenDg;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TfrmCfGenDlg = class(TForm)
Label1: TLabel;
Edit1: TEdit;
btnCancel: TButton;
btnOK: TButton;
procedure btnOKClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmCfGenDlg: TfrmCfGenDlg;
implementation
{$R *.DFM}
procedure TfrmCfGenDlg.btnOKClick(Sender: TObject);
begin
if Edit1.Text <> '' then
ModalResult := mrOK;
end;
procedure TfrmCfGenDlg.FormShow(Sender: TObject);
begin
Edit1.Text := '';
Edit1.SetFocus;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/uCfMain.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UCFMAIN.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit uCfMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, Menus, ImgList, ComCtrls,
AbHexVw, AbCompnd;
type
TfmCfMain = class(TForm)
StatusBar1: TStatusBar;
tvDirectory: TTreeView;
tvImages: TImageList;
OpenDialog1: TOpenDialog;
mnuMain: TMainMenu;
mnuFile: TMenuItem;
mnuFileNew: TMenuItem;
mnuFileOpen: TMenuItem;
N6: TMenuItem;
mnuFileExit: TMenuItem;
mnuEdit: TMenuItem;
mnuEditAddFile: TMenuItem;
mnuEditAddFolder: TMenuItem;
mnuEditDelete: TMenuItem;
N1: TMenuItem;
mnuEditChangeDir: TMenuItem;
mnuPopupMenu: TPopupMenu;
puAddFile: TMenuItem;
puAddFolder: TMenuItem;
puViewFile: TMenuItem;
puChangeDir: TMenuItem;
puViewCompoundFile: TMenuItem;
puDelete: TMenuItem;
Rename1: TMenuItem;
SaveDialog1: TSaveDialog;
OpenDialog2: TOpenDialog;
pnlHexView: TPanel;
procedure mnuFileNewClick(Sender: TObject);
procedure mnuFileOpenClick(Sender: TObject);
procedure mnuFileExitClick(Sender: TObject);
procedure mnuEditAddFileClick(Sender: TObject);
procedure mnuEditAddFolderClick(Sender: TObject);
procedure mnuEditDeleteClick(Sender: TObject);
procedure mnuEditChangeDirClick(Sender: TObject);
procedure puViewFileClick(Sender: TObject);
procedure puViewCompoundFileClick(Sender: TObject);
procedure Rename1Click(Sender: TObject);
procedure tvDirectoryClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
fmCfMain: TfmCfMain;
AbCompoundFile1 : TAbCompoundFile;
HexV : THexView;
implementation
uses uCfNewDg, uCfGenDg;
{$R *.DFM}
procedure TfmCfMain.mnuFileNewClick(Sender: TObject);
var
AllocSize : Integer;
begin
if SaveDialog1.Execute then begin
if frmCfNewDlg.ShowModal = mrOK then begin
if AbCompoundFile1 <> nil then
AbCompoundFile1.Free;
AllocSize := StrToInt(frmCfNewDlg.lbAllocSize.
Items[frmCfNewDlg.lbAllocSize.ItemIndex]);
AbCompoundFile1 := TAbCompoundFile.Create(SaveDialog1.FileName,
frmCfNewDlg.edtVolLbl.Text, AllocSize);
Caption := 'Abbrevia 3 Compound File Example (' + SaveDialog1.FileName + ')';
HexV := THexView.Create(Self);
HexV.BlockSize := AllocSize;
HexV.Parent := pnlHexView;
HexV.Align := alClient;
HexV.Stream := AbCompoundFile1.Stream;
AbCompoundFile1.PopulateTreeView(tvDirectory);
end;
end;
end;
procedure TfmCfMain.mnuFileOpenClick(Sender: TObject);
begin
{OpenExisting compound file}
if OpenDialog1.Execute then begin
if AbCompoundFile1 <> nil then
AbCompoundFile1.Free;
AbCompoundFile1 := TAbCompoundFile.Create('', '', 512);
AbCompoundFile1.Open(OpenDialog1.FileName);
Caption := 'Abbrevia 3 Compound File Example (' + OpenDialog1.FileName + ')';
HexV := THexView.Create(Self);
HexV.BlockSize := AbCompoundFile1.AllocationSize;
HexV.Parent := pnlHexView;
HexV.Align := alClient;
HexV.Stream := AbCompoundFile1.Stream;
AbCompoundFile1.PopulateTreeView(tvDirectory);
end;
end;
procedure TfmCfMain.mnuFileExitClick(Sender: TObject);
begin
Application.Terminate;
end;
procedure TfmCfMain.mnuEditAddFileClick(Sender: TObject);
var
i : Integer;
Strm : TFileStream;
begin
if OpenDialog2.Execute then begin
Strm := TFileStream.Create(OpenDialog2.FileName, fmOpenRead
or fmShareDenyNone);
AbCompoundFile1.AddFile(OpenDialog2.FileName, Strm, Strm.Size);
Strm.Free;
AbCompoundFile1.PopulateTreeView(tvDirectory);
for i := 0 to tvDirectory.Items.Count - 1 do
tvDirectory.Items.Item[i].Expand(True);
HexV.Stream := AbCompoundFile1.Stream;
end;
end;
procedure TfmCfMain.mnuEditAddFolderClick(Sender: TObject);
var
i : Integer;
begin
if frmCfGenDlg.ShowModal = mrOK then begin
AbCompoundFile1.AddFolder(frmCfGenDlg.Edit1.Text);
AbCompoundFile1.PopulateTreeView(tvDirectory);
for i := 0 to tvDirectory.Items.Count - 1 do
tvDirectory.Items.Item[i].Expand(True);
end;
HexV.Stream := AbCompoundFile1.Stream;
end;
procedure TfmCfMain.mnuEditDeleteClick(Sender: TObject);
var
i : Integer;
begin
if tvDirectory.Selected.ImageIndex = 0 then
AbCompoundFile1.DeleteFolder(tvDirectory.Selected.Text)
else
AbCompoundFile1.DeleteFile(tvDirectory.Selected.Text);
HexV.Stream := AbCompoundFile1.Stream;
AbCompoundFile1.PopulateTreeView(tvDirectory);
for i := 0 to tvDirectory.Items.Count - 1 do
tvDirectory.Items.Item[i].Expand(True);
end;
procedure TfmCfMain.mnuEditChangeDirClick(Sender: TObject);
begin
frmCfGenDlg.Caption := AbCompoundFile1.CurrentDirectory;
if frmCfGenDlg.ShowModal = mrOK then begin
AbCompoundFile1.CurrentDirectory := frmCfGenDlg.Edit1.Text;
StatusBar1.SimpleText := ' Current Directory: ' + AbCompoundFile1.CurrentDirectory;
end;
end;
procedure TfmCfMain.puViewFileClick(Sender: TObject);
var
Strm : TStream;
begin
Strm := TMemoryStream.Create;
AbCompoundFile1.OpenFile(tvDirectory.Selected.Text, Strm);
Hexv.SetStream(Strm);
Strm.Free;
end;
procedure TfmCfMain.puViewCompoundFileClick(Sender: TObject);
begin
HexV.Stream := AbCompoundFile1.Stream;
end;
procedure TfmCfMain.Rename1Click(Sender: TObject);
begin
frmCfGenDlg.Caption := 'Rename';
frmCfGenDlg.Label1.Caption := 'New Name';
if frmCfGenDlg.ShowModal = mrOK then begin
if tvDirectory.Selected.ImageIndex = 0 then
AbCompoundFile1.RenameFolder(tvDirectory.Selected.Text, frmCfGenDlg.Edit1.Text)
else
AbCompoundFile1.RenameFile(tvDirectory.Selected.Text, frmCfGenDlg.Edit1.Text);
end;
frmCfGenDlg.Caption := 'Change Directory';
frmCfGenDlg.Label1.Caption := 'New Directory';
end;
procedure TfmCfMain.tvDirectoryClick(Sender: TObject);
begin
if not Assigned(tvDirectory.Selected) then
tvDirectory.Selected := tvDirectory.TopItem;
if (tvDirectory.Selected.ImageIndex = 0) then begin
AbCompoundFile1.CurrentDirectory := tvDirectory.Selected.Text;
StatusBar1.SimpleText := ' Current Directory: ' + AbCompoundFile1.CurrentDirectory;
end;
end;
procedure TfmCfMain.FormDestroy(Sender: TObject);
begin
if AbCompoundFile1 <> nil then
AbCompoundFile1.Free;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/uCfNewDg.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
unit uCfNewDg;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TfrmCfNewDlg = class(TForm)
Label1: TLabel;
edtVolLbl: TEdit;
Label2: TLabel;
lbAllocSize: TListBox;
btnCancel: TButton;
btnOK: TButton;
procedure FormShow(Sender: TObject);
procedure btnOKClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmCfNewDlg: TfrmCfNewDlg;
implementation
{$R *.DFM}
procedure TfrmCfNewDlg.FormShow(Sender: TObject);
begin
lbAllocSize.ItemIndex := 2;
edtVolLbl.SetFocus;
end;
procedure TfrmCfNewDlg.btnOKClick(Sender: TObject);
begin
if edtVolLbl.Text = '' then begin
ShowMessage('Volume label required');
edtVolLbl.SetFocus;
end else
ModalResult := mrOK;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ubasedlg.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UBASEDLG.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit ubasedlg;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, FileCtrl;
type
TBaseDirDlg = class(TForm)
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
DriveComboBox1: TDriveComboBox;
DLB: TDirectoryListBox;
DirLabel: TLabel;
ActionLabel: TLabel;
CheckBox2: TCheckBox;
CheckBox1: TCheckBox;
Button3: TButton;
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
BaseDirDlg: TBaseDirDlg;
implementation
{$R *.DFM}
uses
AbUtils,
uDemoDlg;
procedure TBaseDirDlg.Button3Click(Sender: TObject);
begin
DemoDlg := TDemoDlg.Create( Self );
try
DemoDlg.Caption := 'Create Subdirectory';
DemoDlg.Edit1.Text := '';
DemoDlg.ShowModal;
if ( DemoDlg.ModalResult = mrOK ) and ( DemoDlg.Edit1.Text <> '' ) then
AbCreateDirectory( DLB.Directory + '\' + DemoDlg.Edit1.Text );
DLB.Update;
finally
DemoDlg.Free;
end;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ucomppad.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UCOMPPAD.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit ucomppad;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Menus, ExtCtrls,
AbZBrows, AbZipper, AbZipKit, AbArcTyp, AbBrowse, AbBase;
type
TForm1 = class(TForm)
Memo1: TMemo;
AbZipKit1: TAbZipKit;
Panel1: TPanel;
Memo2: TMemo;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
ZnfName : string;
TxtName : string;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
ZnfName := ChangeFileExt(Application.ExeName, '.zip');
TxtName := ExtractFileName( ChangeFileExt(Application.ExeName, '.txt') );
with AbZipKit1 do begin
BaseDirectory := ExtractFilePath( Application.ExeName );
ChDir( BaseDirectory );
FileName := ZnfName;
if Count > 0 then begin
ExtractFiles( TxtName );
Memo1.Lines.LoadFromFile( TxtName );
end;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Memo1.Lines.SaveToFile( TxtName );
with AbZipKit1 do begin
if Count = 0 then
AddFiles( TxtName, 0 )
else
FreshenFiles( TxtName );
Save;
end;
DeleteFile( TxtName );
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/udemodlg.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UDEMODLG.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit udemodlg;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TDemoDlg = class(TForm)
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
private
{ Private declarations }
public
{ Public declarations }
end;
var
DemoDlg: TDemoDlg;
implementation
{$R *.DFM}
end.
================================================
FILE: lib/abbrevia/examples/Delphi/ufinder.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UFINDER.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit ufinder;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, FileCtrl, Buttons, ExtCtrls,
AbZBrows, AbArcTyp, AbBrowse, AbBase;
type
TForm1 = class(TForm)
Edit1: TEdit;
Label1: TLabel;
Memo1: TMemo;
DriveComboBox1: TDriveComboBox;
DirectoryListBox1: TDirectoryListBox;
AbZipBrowser1: TAbZipBrowser;
Memo2: TMemo;
Label2: TLabel;
Button1: TButton;
Button2: TButton;
FileListBox1: TFileListBox;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Edit1Change(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
Aborted: Boolean;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Aborted := True;
end;
procedure TForm1.Edit1Change(Sender: TObject);
begin
Button1.Enabled := Length( Edit1.Text ) > 0;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i, j : Integer;
CurFile : string;
begin
Button1.Enabled := False;
Memo1.Clear;
try
Button2.Enabled := True;
Aborted := False;
{look in the file list box for the file}
for i := 0 to pred( FileListBox1.Items.Count ) do begin
Application.ProcessMessages;
if Aborted then
Break;
{now add search of zip and self extracting files}
try
AbZipBrowser1.FileName := FileListBox1.Directory + '\' + FileListBox1.Items[i];
for j := 0 to AbZipBrowser1.Count - 1 do
if AbZipBrowser1[j].MatchesStoredName(Edit1.Text) then begin
Memo1.Lines.Add( 'Found in ' + FileListBox1.Items[i] );
Break;
end;
except
end;
end;
finally
Memo1.Lines.Add( 'Done!' );
Edit1.Enabled := True;
Button1.Enabled := True;
Button2.Enabled := False;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Aborted := True;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/umakesfx.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: UMAKESFX.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit umakesfx;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
AbArcTyp, AbSelfEx, AbBase;
type
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
AbMakeSelfExe1: TAbMakeSelfExe;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure AbMakeSelfExe1GetStubExe(Sender: TObject;
var aFilename: string; var Abort: Boolean);
procedure AbMakeSelfExe1GetZipFile(Sender: TObject;
var aFilename: string; var Abort: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
AbZipTyp;
procedure TForm1.Button1Click(Sender: TObject);
begin
if AbMakeSelfExe1.Execute then
ShowMessage(AbMakeSelfExe1.SelfExe + ' has been created');
end;
procedure TForm1.AbMakeSelfExe1GetStubExe(Sender: TObject;
var aFilename: string; var Abort: Boolean);
begin
OpenDialog1.Title := 'Select executable stub';
OpenDialog1.Filename := '';
OpenDialog1.Filter := 'Exe files|*.exe';
Abort := not OpenDialog1.Execute;
if not Abort then
aFileName := OpenDialog1.Filename;
end;
procedure TForm1.AbMakeSelfExe1GetZipFile(Sender: TObject;
var aFilename: string; var Abort: Boolean);
begin
OpenDialog1.Title := 'Select Zip File';
OpenDialog1.Filename := '';
OpenDialog1.Filter := 'Zip files|*.zip';
Abort := not OpenDialog1.Execute;
if not Abort then
aFileName := OpenDialog1.Filename;
end;
end.
================================================
FILE: lib/abbrevia/examples/Delphi/usplash.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: USPLASH.PAS *}
{* Copyright (c) TurboPower Software Co 1997 *}
{* All rights reserved. *}
{*********************************************************}
{* ABBREVIA Example program file *}
{*********************************************************}
unit usplash;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
type
TSplash = class(TForm)
Image1: TImage;
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Splash: TSplash;
implementation
{$R *.DFM}
procedure TSplash.Timer1Timer(Sender: TObject);
begin
Close;
end;
end.
================================================
FILE: lib/abbrevia/localization/AbResString.pas.afr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Henri Hakl, Roman Kassebaum
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* Abbrevia: AbResString.pas *}
{*********************************************************}
{* Abbrevia: Resource strings, Africaans localization *}
{*********************************************************}
unit AbResString;
interface
resourcestring
AbErrZipInvalidS = 'Ongeldig - geen PKZIP bestaan nie';
AbZipVersionNeededS = 'Ler kannie ontpak word nie - kry nuwer weergawe van PKZIP';
AbUnknownCompressionMethodS = 'Ler kannie ontpak word nie - onbekende kompressiemetode';
AbNoExtractionMethodS = 'Ler kannie ontpak word nie - geen ondersteunende metode';
AbInvalidPasswordS = 'Ler kannie ontpak word nie - ongeldige paswoord';
AbNoInsertionMethodS = 'Ler kannie bygevoeg word nie - byvoeging is nie ondersteun nie';
AbInvalidFactorS = 'Ongeldige reduksiefaktoor';
AbDuplicateNameS = 'Ler kannie bygevoeg word nie - tweevoud by name gevind';
AbUnsupportedCompressionMethodS = 'Ler kannie bygevoeg word nie - nie ondersteunde kompressiemetode';
AbUserAbortS = 'Proses is deur gebruiker onderbreek';
AbArchiveBusyS = 'Argief is besig - kan nuwe aanvrag nie bewerk nie';
AbLastDiskRequestS = 'Benodig laaste skyf van gedeelde argief';
AbDiskRequestS = 'Benodig skyf';
AbImageRequestS = 'Benodig naam';
AbBadSpanStreamS = 'Gedeelde argief moet als bestandsstroom geopen word';
AbDiskNumRequestS = 'Benodig skyf %d van gedeelde argief';
AbImageNumRequestS = 'Benodig segment %d van gedeelde argief';
AbNoOverwriteSpanStreamS = 'Kannie bestaande gedeelde argief verander nie';
AbNoSpannedSelfExtractS = 'Kannie selfontpakkende gedeelde argief maak nie';
AbBlankDiskS = 'Benodig le skyf';
AbStreamFullS = 'Stroom skryffout';
AbNoSuchDirectoryS = 'Gids bestaan nie';
AbInflateBlockErrorS = 'Kannie blok ontpak nie';
AbBadStreamTypeS = 'Ongeldige stroom';
AbTruncateErrorS = 'Daar bestaan in afknottings fout in zip-ler';
AbZipBadCRCS = 'CRC kontroole his misluk';
AbZipBadStubS = 'Stomp moet uitvoerbaar wees';
AbFileNotFoundS = 'Ler nie gevind nie';
AbInvalidLFHS = 'Ongeldige lokaale ler obskrif element';
AbNoArchiveS = 'Argief bestaan nie';
AbReadErrorS = 'Leesfout in argief';
AbInvalidIndexS = 'Ongeldige indeks van argiefelement';
AbInvalidThresholdS = 'Ongeldige drempel van argiefgroote';
AbUnhandledFileTypeS = 'Onbekende argieftype';
AbSpanningNotSupportedS = 'Argief deeling is nie ondersteun nie';
AbLogCreateErrorS = 'Fout gedurende protokol skepping';
AbMoveFileErrorS = 'Fout gedurende verplasing van ler van %s na %s';
AbFileSizeTooBigS = 'Ler is te groot vir argieftype';
AbNoCabinetDllErrorS = 'Kannie ler cabinet.dll laai nie';
AbFCIFileOpenErrorS = 'FCI kannie ler oopmaak nie';
AbFCIFileReadErrorS = 'FCI kannie ler lees nie';
AbFCIFileWriteErrorS = 'FCI kannie ler skryf nie';
AbFCIFileCloseErrorS = 'FCI kannie ler toemaak nie';
AbFCIFileSeekErrorS = 'FCI kannie posisie verander nie';
AbFCIFileDeleteErrorS = 'FCI kannie ler verwyder nie';
AbFCIAddFileErrorS = 'FCI kannie ler byvoeg nie';
AbFCICreateErrorS = 'FCI kannie conteks skep nie';
AbFCIFlushCabinetErrorS = 'FCI kannie kabinet spoel nie';
AbFCIFlushFolderErrorS = 'FCI kannie gids spoel nie';
AbFDICopyErrorS = 'FDI kannie ler opsom nie';
AbFDICreateErrorS = 'FDI kannie konteks skep nie';
AbInvalidCabTemplateS = 'Ongeldige kabinet sjabloon';
AbInvalidCabFileS = 'Ongeldiger ler - geen kabinet bestaan nie';
AbZipStored = 'Opgeslagen';
AbZipShrunk = 'Gekrimp';
AbZipReduced = 'Verminder';
AbZipImploded = 'Gemplodeerd';
AbZipTokenized = 'In simboole gepak';
AbZipDeflated = 'Gedeflationeerd';
AbZipDeflate64 = 'Uitgebreid gedeflationeerd';
AbZipDCLImploded = 'DCL gemplodeerd';
AbZipBzip2 = 'Bzip2';
AbZipLZMA = 'LZMA';
AbZipIBMTerse = 'IBM Terse';
AbZipLZ77 = 'IBM LZ77';
AbZipJPEG = 'JPEG';
AbZipWavPack = 'WavPack';
AbZipPPMd = 'PPMd';
AbZipUnknown = 'Onbekend (%d)';
AbZipBestMethod = 'Beste metode';
AbVersionFormatS = 'Weergawe';
AbCompressedSizeFormatS = 'Gekomprimeerde groote: %d';
AbUncompressedSizeFormatS = 'Ongekomprimeerde groote: %d';
AbCompressionMethodFormatS = 'Kompressie metode: %s';
AbCompressionRatioFormatS = 'Kompressieverhouding: %2.0f%%';
AbCRCFormatS = 'CRC: %x';
AbReadOnlyS = 'r';
AbHiddenS = 'h';
AbSystemS = 's';
AbArchivedS = 'a';
AbEFAFormatS = 'Eksterne lerattribute: %s';
AbIFAFormatS = 'Lertype';
AbTextS = 'Teks';
AbBinaryS = 'Binre';
AbEncryptionFormatS = 'Versleuteling: %s';
AbEncryptedS = 'Versleuteld';
AbNotEncryptedS = 'Nie versleuteld nie';
AbUnknownS = 'Onbekend';
AbTimeStampFormatS = 'Tydstempel: %s';
AbMadeByFormatS = 'Gemaak met weergawe: %f';
AbNeededFormatS = 'Weergawe benodig vir ontpakking: %f';
AbCommentFormatS = 'Opmerking: %s';
AbDefaultExtS = '*.zip';
AbFilterS = 'PKZIP argief (*.zip)|*.zip|Selfontpakkende Argief (*.exe)|*.exe|Alle Lers (*.*)|*.*';
AbFileNameTitleS = 'Kies lernaam';
AbOKS = 'OK';
AbCancelS = 'Verlaat';
AbSelectDirectoryS = 'Kies ler';
AbEnterPasswordS = 'Voeg paswoord in';
AbPasswordS = '&Paswoord';
AbVerifyS = '&Verifiseer';
AbCabExtS = '*.cab';
AbCabFilterS = 'Kabinetsargiewe (*.cab)|*.CAB|Alle Lers (*.*)|*.*';
AbLogExtS = '*.txt';
AbLogFilterS = 'Tekslers (*.cab)|*.CAB|Alle Lers (*.*)|*.*';
AbExeExtS = '*.exe';
AbExeFilterS = 'Selfontpakkende Zip Lers (*.cab)|*.CAB|Alle Lers (*.*)|*.*';
AbVMSReadTooManyBytesS = 'VMS: Te veel byte gelees';
AbVMSInvalidOriginS = 'VMS: Ongeldige oorsprong %d, moet 0, 1 or 2 wees';
AbVMSErrorOpenSwapS = 'VMS: Kannie wisseller oopmaak nie';
AbVMSSeekFailS = 'VMS: Kannie wisseller posisie verander nie';
AbVMSReadFailS = 'VMS: Kan %d byte in wisseller nie lees nie';
AbVMSWriteFailS = 'VMS: Kan %d byte in wisseller nie skryf nie';
AbVMSWriteTooManyBytesS = 'VMS: Aanvraag om te veel byte [%d] te skryf';
AbBBSReadTooManyBytesS = 'BBS: Aanvraag om te veel byte [%d] te lees';
AbBBSSeekOutsideBufferS = 'BBS: Nuwe posisie is buite die buffer';
AbBBSInvalidOriginS = 'BBS: Ongeldige oorsprongswaarde';
AbBBSWriteTooManyBytesS = 'BBS: Aanvrag om te veel byte [%d] te skryf';
AbSWSNotEndofStreamS = 'TabSlidingWindowStream.Write: Nie by stroom einde nie';
AbSWSSeekFailedS = 'TabSlidingWindowStream.bsWriteChunk: Posisioneering misluk';
AbSWSWriteFailedS = 'TabSlidingWindowStream.bsWriteCunk: Skryf misluk';
AbSWSInvalidOriginS = 'TabSlidingWindowStream.Seek: Ongeldige oorsprong';
AbSWSInvalidNewOriginS = 'TabSlidingWindowStream.Seek: Ongeldige nuwe posisie';
AbItemNameHeadingS = 'Naam';
AbPackedHeadingS = 'Gepak';
AbMethodHeadingS = 'Metode';
AbRatioHeadingS ='Besparing (%)';
AbCRCHeadingS = 'CRC32';
AbFileAttrHeadingS = 'Attribuut';
AbFileFormatHeadingS = 'Formaat';
AbEncryptionHeadingS = 'Versleuteld';
AbTimeStampHeadingS = 'Tydstempel';
AbFileSizeHeadingS = 'Groote';
AbVersionMadeHeadingS = 'Gebruikte weergawe';
AbVersionNeededHeadingS = 'Benodigde weergawe';
AbPathHeadingS = 'Pad';
AbPartialHeadingS = 'Partieel';
AbExecutableHeadingS = 'Uitvoerbaar';
AbCabMethod0S = 'Geen';
AbCabMethod1S = 'MSZip';
AbLtAddS = ' toegevoegd ';
AbLtDeleteS = ' gewist ';
AbLtExtractS = ' ontpakt ';
AbLtFreshenS = ' geaktualiseerd ';
AbLtMoveS = ' verplaas ';
AbLtReplaceS = ' vervang ';
AbLtStartS = ' geprotocoleerd ';
AbGzipInvalidS = 'Ongeldige Gzip';
AbGzipBadCRCS = 'Ongeldige CRC';
AbGzipBadFileSizeS = 'Ongeldige bestaandsgroote';
AbTarInvalidS = 'Tar ongeldig';
AbTarBadFileNameS = 'Ler naam te lang';
AbTarBadLinkNameS = 'Skakel naam te lang';
AbTarBadOpS = 'Operasie nie ondersteun nie';
AbUnhandledEntityS = 'Nie behandelde entiteit';
{ pre-defined "operating system" (really more FILE system) identifiers for the
Gzip header }
AbGzOsFat = 'FAT Lersisteem (MS-DOS, OS/2, NT/Win32)';
AbGzOsAmiga = 'Amiga';
AbGzOsVMS = 'VMS (of OpenVMS)';
AbGzOsUnix = 'Unix';
AbGzOsVM_CMS = 'VM/CMS';
AbGzOsAtari = 'Atari TOS';
AbGzOsHPFS = 'HPFS Lersisteem (OS/2, NT)';
AbGzOsMacintosh = 'Macintosh';
AbGzOsZ_System = 'Z-System';
AbGzOsCP_M = 'CP/M';
AbGzOsTOPS_20 = 'TOPS-20';
AbGzOsNTFS = 'NTFS Lersisteem (NT)';
AbGzOsQDOS = 'QDOS';
AbGzOsAcornRISCOS = 'Acorn RISCOS';
AbGzOsVFAT = 'VFAT Lersisteem (Win95, NT)';
AbGzOsMVS = 'MVS';
AbGzOsBeOS = 'BeOS (BeBox of PowerMac)';
AbGzOsTandem = 'Tandem/NSK';
AbGzOsTHEOS = 'THEOS';
AbGzOsunknown = 'onbekend';
AbGzOsUndefined = 'ID is Gzip nie bekend nie';
{!!.03 - Moved from AbCompnd.inc }
{ Compound File specific error messages }
resourcestring
AbCmpndIndexOutOfBounds = 'Indeks buite toegelate bereik';
AbCmpndBusyUpdating = 'Saamgestelde ler word geaktualiseer';
AbCmpndInvalidFile = 'Ongeldige saamgestelde ler';
AbCmpndFileNotFound = 'Ler/gids nie gevind nie';
AbCmpndFolderNotEmpty = 'Gids nie leeg nie';
AbCmpndExceedsMaxFileSize = 'Lergroote oorskryf toegelate maksimum';
{!!.03 - End Moved }
implementation
end.
================================================
FILE: lib/abbrevia/localization/AbResString.pas.de
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Roman Kassebaum
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* Abbrevia: AbResString.pas *}
{*********************************************************}
{* Abbrevia: Resource strings, German localization *}
{*********************************************************}
unit AbResString;
interface
resourcestring
AbErrZipInvalidS = 'Ungltige Datei - keine PKZip Datei';
AbZipVersionNeededS = 'Kann die Datei nicht entpacken - neuere Version bentigt';
AbUnknownCompressionMethodS = 'Kann die Datei nicht entpacken - nicht untersttzte Kommpressionsmethode';
AbNoExtractionMethodS = 'Kann die Datei nicht entpacken - keine Entpackuntersttzung angeboten';
AbInvalidPasswordS = 'Kann die Datei nicht entpacken - ungltiges Passwort';
AbNoInsertionMethodS = 'Kann die Datei nicht entpacken - keine Einfgeuntersttzung angeboten';
AbInvalidFactorS = 'Ungltiger Reduzierungsfaktor';
AbDuplicateNameS = 'Kann die Datei nicht einfgen - doppelter gespeicherter Name';
AbUnsupportedCompressionMethodS = 'Kann die Datei nicht einfgen - nicht untersttzt Kompressionsmethode';
AbUserAbortS = 'Prozess wurde durch den Benutzer abgebrochen';
AbArchiveBusyS = 'Das Archiv ist beschftigt - kann nicht die neue Anforderung bearbeiten';
AbLastDiskRequestS = 'Legen Sie die letzte Diskette ein';
AbDiskRequestS = 'Diskette einlegen ';
AbImageRequestS = 'Name des Abbildes';
AbBadSpanStreamS = 'Segmentierte Archive mssen als Datei-Strom geffnet werden';
AbDiskNumRequestS = 'Legen Sie die Diskette %d des segmentierten Archivs ein';
AbImageNumRequestS = 'Legen Sie das Segment %d des segmentierten Archivs ein';
AbNoOverwriteSpanStreamS = 'Kann kein existierendes segmentiertes Archiv verndern';
AbNoSpannedSelfExtractS = 'Kann kein selbstentpackendes segmentiertes Archiv erstellen';
AbBlankDiskS = 'Legen Sie eine leere Diskette ein';
AbStreamFullS = 'Strom Schreibfehler';
AbNoSuchDirectoryS = 'Verzeichnis existiert nicht';
AbInflateBlockErrorS = 'Kann den Bereich nicht entpacken';
AbBadStreamTypeS = 'Ungltiger Strom';
AbTruncateErrorS = 'Fehler beim Abschneiden der zip Datei';
AbZipBadCRCS = 'Fehlgeschalgene CRC berprfung';
AbZipBadStubS = 'Der Stamm muss ausfhrbar sein';
AbFileNotFoundS = 'Datei nicht gefunden';
AbInvalidLFHS = 'Ungltiger lokaler Dateianfang';
AbNoArchiveS = 'Das Archiv existiert nicht- leerer Dateinahme';
AbReadErrorS = 'Fehler beim Lesen des Archivse';
AbInvalidIndexS = 'Ungltiger Archiv Element Eintrag';
AbInvalidThresholdS = 'Ungltige Archivgren Schwelle';
AbUnhandledFileTypeS = 'Unbekannter Archiv';
AbSpanningNotSupportedS = 'Aufteilen wird bei diesem Archivtyp nicht untersttzt';
AbLogCreateErrorS = 'Fehler beim Erzeugen der Protokolldatei';
AbMoveFileErrorS = 'Fehler beim Verschieben der Datei %s nach %s';
AbFileSizeTooBigS = 'Datei ist zu gro fr diesen Archivtypen';
AbNoCabinetDllErrorS = 'Kann die Datei cabinet.dll nicht laden';
AbFCIFileOpenErrorS = 'FCI kann die Datei nicht ffnen';
AbFCIFileReadErrorS = 'FCI kann die Datei nicht lesen';
AbFCIFileWriteErrorS = 'FCI kann die Datei nicht schreiben';
AbFCIFileCloseErrorS = 'FCI Fehler beim Schlieen der Datei';
AbFCIFileSeekErrorS = 'FCI Fehler beim Durchsuchen der Datei';
AbFCIFileDeleteErrorS = 'FCI Fehler beim Lschen der Datei';
AbFCIAddFileErrorS = 'FCI kann die Datei nicht hinzufgen';
AbFCICreateErrorS = 'FCI kann den Zusammenhang nicht erstellen';
AbFCIFlushCabinetErrorS = 'FCI kann das Cabinet-Archiv nicht leeren';
AbFCIFlushFolderErrorS = 'FCI kann das Verzeichnis nicht leeren';
AbFDICopyErrorS = 'FDI kann die Dateien nicht aufzhlen';
AbFDICreateErrorS = 'FDI kann den Zusammenhang nicht herstellen';
AbInvalidCabTemplateS = 'Ungltige Vorlage fr eine Cabinet-Datei';
AbInvalidCabFileS = 'Ungltige Datei - keine Kabinett Datei';
AbZipStored = 'Gespeichert';
AbZipShrunk = 'Geschrumpft';
AbZipReduced = 'Reduziert';
AbZipImploded = 'Implodiert';
AbZipTokenized = 'In Merkmale aufgeteilt';
AbZipDeflated = 'Gepackt';
AbZipDeflate64 = 'Strker gepackt';
AbZipDCLImploded = 'DCL Implodiert';
AbZipBzip2 = 'Bzip2';
AbZipLZMA = 'LZMA';
AbZipIBMTerse = 'IBM Terse';
AbZipLZ77 = 'IBM LZ77';
AbZipJPEG = 'JPEG';
AbZipWavPack = 'WavPack';
AbZipPPMd = 'PPMd';
AbZipUnknown = 'Unbekannt (%d)';
AbZipBestMethod = 'Beste Methode';
AbVersionFormatS = 'Version %s';
AbCompressedSizeFormatS = 'Komprimierte Gre: %d';
AbUncompressedSizeFormatS = 'Komprimierte Gre: %d';
AbCompressionMethodFormatS = 'Kompressions-Methode: %s';
AbCompressionRatioFormatS = 'Kompressions-Verhltnis: %2.0f%%';
AbCRCFormatS = 'CRC: %x';
AbReadOnlyS = 'r';
AbHiddenS = 'h';
AbSystemS = 's';
AbArchivedS = 'a';
AbEFAFormatS = 'Externe Datei Attribute: %s';
AbIFAFormatS = 'Dateityp: %s';
AbTextS = 'Text';
AbBinaryS = 'Binr';
AbEncryptionFormatS = 'Verschlsselung: %s';
AbEncryptedS = 'Verschlsselt';
AbNotEncryptedS = 'Nicht verschlsselt';
AbUnknownS = 'Unbekannt';
AbTimeStampFormatS = 'Zeitstemple: %s';
AbMadeByFormatS = 'Erzeugt mit der Version: %f';
AbNeededFormatS = 'Version bentigt zum Extrahieren: %f';
AbCommentFormatS = 'Kommentar: %s';
AbDefaultExtS = '*.zip';
AbFilterS = 'PKZip Archive (*.zip)|*.zip|Selbstentpackende Archive (*.exe)|*.exe|Alle Dateien (*.*)|*.*';
AbFileNameTitleS = 'Dateinamen auswhlen';
AbOKS = 'OK';
AbCancelS = 'Abbrechen';
AbSelectDirectoryS = 'Verzeichnis auswhlen';
AbEnterPasswordS = 'Passwort eingeben';
AbPasswordS = '&Passwort';
AbVerifyS = '&berprfen';
AbCabExtS = '*.cab';
AbCabFilterS = 'Cabinet Archive (*.cab)|*.CAB|Alle Dateien (*.*)|*.*';
AbLogExtS = '*.txt';
AbLogFilterS = 'Text Dateien (*.txt)|*.TXT|Alle Dateien (*.*)|*.*';
AbExeExtS = '*.exe';
AbExeFilterS = 'Selbstentpackende Zip Dateien (*.exe)|*.EXE|Alle Dateien (*.*)|*.*';
AbVMSReadTooManyBytesS = 'VMS: Anforderung, zu viele Bytes [%d] zu lesen';
AbVMSInvalidOriginS = 'VMS: Ungltiger Ursprung %d, sollte 0, 1, 2 sein';
AbVMSErrorOpenSwapS = 'VMS: Kann die Auslagerungsdatei %s nicht ffnen';
AbVMSSeekFailS = 'VMS: Konnte nicht in der Auslagerungsdatei %s suchen';
AbVMSReadFailS = 'VMS: Konnte nicht %d Bytes in der Auslagerungsdatei %s lesen';
AbVMSWriteFailS = 'VMS: Konnte nicht %d Bytes in die Auslagerungsdatei %s schreiben';
AbVMSWriteTooManyBytesS = 'VMS: Anforderung, zu viele Bytes [%d] zu schreiben';
AbBBSReadTooManyBytesS = 'BBS: Anforderung, zu viele Bytes [%d] zu lesen';
AbBBSSeekOutsideBufferS = 'BBS: Die neue Position ist auerhalb des Puffers';
AbBBSInvalidOriginS = 'BBS: Ungltiger Ursprungswert';
AbBBSWriteTooManyBytesS = 'BBS: Anforderung, zu viele Bytes [%d] zu schreiben';
AbSWSNotEndofStreamS = 'TabSlidingWindowStream.Write: Nicht am Ende des Datenstroms';
AbSWSSeekFailedS = 'TabSlidingWindowStream.bsWriteChunk: Suche fehlgeschlagen';
AbSWSWriteFailedS = 'TabSlidingWindowStream.bsWriteChunk: Schreiben fehlgeschlagen';
AbSWSInvalidOriginS = 'TabSlidingWindowStream.Seek: Ungltiger Ursprung';
AbSWSInvalidNewOriginS = 'TabSlidingWindowStream.Seek: Ungltige neue Position';
AbItemNameHeadingS = 'Name';
AbPackedHeadingS = 'Gepacked';
AbMethodHeadingS = 'Methode';
AbRatioHeadingS = 'Einsparung (%)';
AbCRCHeadingS = 'CRC32';
AbFileAttrHeadingS = 'Attribute';
AbFileFormatHeadingS = 'Format';
AbEncryptionHeadingS = 'Verschlsselt';
AbTimeStampHeadingS = 'Zeitstempel';
AbFileSizeHeadingS = 'Gre';
AbVersionMadeHeadingS = 'Version genutzt';
AbVersionNeededHeadingS = 'Version bentigt';
AbPathHeadingS = 'Pfad';
AbPartialHeadingS = 'Teilweise';
AbExecutableHeadingS = 'Ausfhrbar';
AbFileTypeHeadingS = 'Typ';
AbLastModifiedHeadingS = 'Modifiziert';
AbCabMethod0S = 'Keine';
AbCabMethod1S = 'MSZip';
AbLtAddS = ' hinzugefgt ';
AbLtDeleteS = ' gelscht ';
AbLtExtractS = ' extrahiert ';
AbLtFreshenS = ' aktualisiert ';
AbLtMoveS = ' verschoben ';
AbLtReplaceS = ' ersetzt ';
AbLtStartS = ' protokolliert ';
AbGzipInvalidS = 'Ungltiges Gzip';
AbGzipBadCRCS = 'Ungltiger CRC';
AbGzipBadFileSizeS = 'Ungltige Datei Gre';
AbTarInvalidS = 'Ungltiges Tar';
AbTarBadFileNameS = 'Dateiname zu lang';
AbTarBadLinkNameS = 'Linkname zu lang';
AbTarBadOpS = 'Nicht untersttzte Operation';
AbUnhandledEntityS = 'Nicht behandelte Entitt';
{ pre-defined "operating system" (really more FILE system) identifiers for the
Gzip header }
AbGzOsFat = 'FAT Datei-System (MS-DOS, OS/2, NT/Win32)';
AbGzOsAmiga = 'Amiga';
AbGzOsVMS = 'VMS (oder OpenVMS)';
AbGzOsUnix = 'Unix';
AbGzOsVM_CMS = 'VM/CMS';
AbGzOsAtari = 'Atari TOS';
AbGzOsHPFS = 'HPFS Datei-System (OS/2, NT)';
AbGzOsMacintosh = 'Macintosh';
AbGzOsZ_System = 'Z-System';
AbGzOsCP_M = 'CP/M';
AbGzOsTOPS_20 = 'TOPS-20';
AbGzOsNTFS = 'NTFS Datei-System (NT)';
AbGzOsQDOS = 'QDOS';
AbGzOsAcornRISCOS = 'Acorn RISCOS';
AbGzOsVFAT = 'VFAT Datei-System (Win95, NT)';
AbGzOsMVS = 'MVS';
AbGzOsBeOS = 'BeOS (BeBox oder PowerMac)';
AbGzOsTandem = 'Tandem/NSK';
AbGzOsTHEOS = 'THEOS';
AbGzOsunknown = 'unkekannt';
AbGzOsUndefined = 'ID ist Gzip nicht bekannt';
{!!.03 - Moved from AbCompnd.inc }
{ Compound File specific error messages }
resourcestring
AbCmpndIndexOutOfBounds = 'Index auerhalb des zulssigen Bereichs';
AbCmpndBusyUpdating = 'Verbindungsdatei wird aktualisiert';
AbCmpndInvalidFile = 'Ungltige Verbindungsdatei';
AbCmpndFileNotFound = 'Datei/Verzeichnis nicht gefunden';
AbCmpndFolderNotEmpty = 'Verzeichnis ist nicht leer';
AbCmpndExceedsMaxFileSize = 'Dateigre berschreitet das erlaubte Maximum';
{!!.03 - End Moved }
implementation
end.
================================================
FILE: lib/abbrevia/localization/AbResString.pas.fr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Hichem BOUKSANI, John Riche, Roman Kassebaum
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* Abbrevia: AbResString.pas *}
{*********************************************************}
{* Abbrevia: Resource strings *}
{*********************************************************}
unit AbResString;
interface
resourcestring
AbErrZipInvalidS = 'Fichier non valide - N''est pas un fichier PKZip';
AbZipVersionNeededS = 'Impossible d''extraire le fichier - nouvelle version requise';
AbUnknownCompressionMethodS = 'Impossible d''extraire le fichier - mthode de compression non supporte';
AbNoExtractionMethodS = 'Impossible d''extraire le fichier - aucun support d''extraction fourni';
AbInvalidPasswordS = 'Impossible d''extraire le fichier - Mot de passe incorrect';
AbNoInsertionMethodS = 'Imossible d''insrer le fichier - aucun support d''insertion fourni';
AbInvalidFactorS = 'Facteur de rduction Invalide';
AbDuplicateNameS = 'Impossible d''insrer le fichier - Nom du fichier existe en double';
AbUnsupportedCompressionMethodS = 'Impossible d''insrer le fichier - mthode de compression non suppote';
AbUserAbortS = 'Processus abandonn par l''utilisateur';
AbArchiveBusyS = 'Archivage en cours - ne peut traiter de nouvelles demandes';
AbLastDiskRequestS = 'Insrer la dernire disquette du jeu multi-disquettes';
AbDiskRequestS = 'Insrer une disquette';
AbImageRequestS = 'Nom du fichier image';
AbBadSpanStreamS = 'Archives multi-disquettes doivent tre ouvertes comme fichiers de flux';
AbDiskNumRequestS = 'Insrer la disquette %d du jeu multi-disquettes';
AbImageNumRequestS = 'Insrer la disquette %d du jeu multi-disquettes';
AbNoOverwriteSpanStreamS = 'Impossible de mettre jour un jeu multi-disquettes existant';
AbNoSpannedSelfExtractS = 'Impossible de crer un fichier auto-extractible partir d''une archive multi-disquettes';
AbBlankDiskS = 'Insrer une disquette vierge';
AbStreamFullS = 'Erreur d''criture du flux';
AbNoSuchDirectoryS = 'Dossier inexistant';
AbInflateBlockErrorS = 'Dcompression du bloc impossible';
AbBadStreamTypeS = 'Flux Invalide';
AbTruncateErrorS = 'Erreur de troncage du fichier ZIP';
AbZipBadCRCS = 'Echec du contrle CRC';
AbZipBadStubS = 'La souche doit tre un executable';
AbFileNotFoundS = 'Fichier inexistant';
AbInvalidLFHS = 'Entre de l''entte du fichier local invalide';
AbNoArchiveS = 'L''archive n''existe pas - Nom de fichier non spcifi';
AbReadErrorS = 'Erreur de l''ecture de l''archive';
AbInvalidIndexS = 'L''indice de l''lment de l''archive est invalide';
AbInvalidThresholdS = 'Le seuil de la taille de l''archive est invalide';
AbUnhandledFileTypeS = 'Type d''archive non support';
AbSpanningNotSupportedS = 'Multi-disquette non support par ce type d''archive';
AbLogCreateErrorS = 'Erreur de cration du fichier log';
AbMoveFileErrorS = 'Erreur de dplacement du fichier %s vers %s';
AbFileSizeTooBigS = 'Taille du fichier trop grande pour le type d''archive';
AbNoCabinetDllErrorS = 'Impossible de charger cabinet.dll';
AbFCIFileOpenErrorS = 'FCI impossible d''ouvrir le fichier';
AbFCIFileReadErrorS = 'FCI impossible de lire le fichier';
AbFCIFileWriteErrorS = 'FCI Ecriture impossible sur le fichier';
AbFCIFileCloseErrorS = 'FCI erreur de fermeture du fichier';
AbFCIFileSeekErrorS = 'FCI Erreur de recherche de fichier';
AbFCIFileDeleteErrorS = 'FCI erreur de suppression du fichier';
AbFCIAddFileErrorS = 'FCI impossible d''ajouter le fichier';
AbFCICreateErrorS = 'FCI impossible de crer le contexte';
AbFCIFlushCabinetErrorS = 'FCI impossible de vider le cabinet';
AbFCIFlushFolderErrorS = 'FCI Impossible de vider le dossier';
AbFDICopyErrorS = 'FDI impossible d''enumrer les fichiers';
AbFDICreateErrorS = 'FDI impossible de crer le contexte';
AbInvalidCabTemplateS = 'Modle du fichier CAB invalide';
AbInvalidCabFileS = 'Fichier invalide - n''est pas un fichier cabinet';
AbZipStored = 'Stock';
AbZipShrunk = 'Compact';
AbZipReduced = 'Rduit';
AbZipImploded = 'Implos';
AbZipTokenized = 'Divis en plusieurs parties';
AbZipDeflated = 'Dflation';
AbZipDeflate64 = 'Dflation amliore';
AbZipDCLImploded = 'DCL Implos';
AbZipBzip2 = 'Bzip2';
AbZipLZMA = 'LZMA';
AbZipIBMTerse = 'IBM Terse';
AbZipLZ77 = 'IBM LZ77';
AbZipJPEG = 'JPEG';
AbZipWavPack = 'WavPack';
AbZipPPMd = 'PPMd';
AbZipUnknown = 'Inconnu (%d)';
AbZipBestMethod = 'Meilleure Mthode';
AbVersionFormatS = 'Version %s';
AbCompressedSizeFormatS = 'Taille compresse: %d';
AbUncompressedSizeFormatS = 'Taille non compresse: %d';
AbCompressionMethodFormatS = 'Mthode de compression: %s';
AbCompressionRatioFormatS = 'Ratio de compression: %2.0f%%';
AbCRCFormatS = 'CRC: %x';
AbReadOnlyS = 'r';
AbHiddenS = 'h';
AbSystemS = 's';
AbArchivedS = 'a';
AbEFAFormatS = 'Attribut du fichier externe: %s';
AbIFAFormatS = 'Type du fichier: %s';
AbTextS = 'Text';
AbBinaryS = 'Binaire';
AbEncryptionFormatS = 'Crypt: %s';
AbEncryptedS = 'Crypt';
AbNotEncryptedS = 'Non crypt';
AbUnknownS = 'Inconnu';
AbTimeStampFormatS = 'Heure: %s';
AbMadeByFormatS = 'Version utilise: %f';
AbNeededFormatS = 'Version d''extraction: %f';
AbCommentFormatS = 'Commentaire: %s';
AbDefaultExtS = '*.zip';
AbFilterS = 'Archives PKZip (*.zip)|*.zip|Archives Auto extractibles (*.exe)|*.exe|Tous les fichiers (*.*)|*.*';
AbFileNameTitleS = 'Slectionner un fichier';
AbOKS = 'OK';
AbCancelS = 'Annuler';
AbSelectDirectoryS = 'Slectionner un Dossier';
AbEnterPasswordS = 'Saisir Mot de passe';
AbPasswordS = '&Mot de passe';
AbVerifyS = '&Vrifier';
AbCabExtS = '*.cab';
AbCabFilterS = 'Archives Cabinet (*.cab)|*.CAB|Tous les fichiers (*.*)|*.*';
AbLogExtS = '*.txt';
AbLogFilterS = 'Fichiers Text (*.txt)|*.TXT|Tous les fichiers (*.*)|*.*';
AbExeExtS = '*.exe';
AbExeFilterS = 'Fichiers Zip auto-extractibles (*.exe)|*.EXE|Tous les fichiers (*.*)|*.*';
AbVMSReadTooManyBytesS = VMS: Tentative de l''ecture de trop d''octets [%d]';
AbVMSInvalidOriginS = 'VMS: Origine invalide %d, doit tre 0, 1, 2';
AbVMSErrorOpenSwapS = 'VMS: Impossible d''ouvrir le fichier d''change %s';
AbVMSSeekFailS = 'VMS: Impossible de se dplacer dans le fichier d''change %s';
AbVMSReadFailS = 'VMS: impossible de lire %d octets du fichier d''change %s';
AbVMSWriteFailS = 'VMS: impossible d''crire %d octets dans le fichier d''change %s';
AbVMSWriteTooManyBytesS = 'VMS: tentative d''crire trop d''octets [%d]';
AbBBSReadTooManyBytesS = 'BBS: tentative de lecture de trop d''octets [%d]';
AbBBSSeekOutsideBufferS = 'BBS: la nouvelle position est en dehors du buffer';
AbBBSInvalidOriginS = 'BBS: Valeur d''origine invalide';
AbBBSWriteTooManyBytesS = 'BBS: tentative d''crire de trop d''octets [%d]';
AbSWSNotEndofStreamS = 'TabSlidingWindowStream.Write: Pas la fin du flux';
AbSWSSeekFailedS = 'TabSlidingWindowStream.bsWriteChunk: chec de recherche';
AbSWSWriteFailedS = 'TabSlidingWindowStream.bsWriteChunk: chec d''criture';
AbSWSInvalidOriginS = 'TabSlidingWindowStream.Seek: Origine incorrecte';
AbSWSInvalidNewOriginS = 'TabSlidingWindowStream.Seek: Nouvelle position incorrecte';
AbItemNameHeadingS = 'Nom';
AbPackedHeadingS = 'Compress';
AbMethodHeadingS = 'Mthode';
AbRatioHeadingS = 'Ratio (%)';
AbCRCHeadingS = 'CRC32';
AbFileAttrHeadingS = 'Attribut';
AbFileFormatHeadingS = 'Format';
AbEncryptionHeadingS = 'Crypt';
AbTimeStampHeadingS = 'Heure';
AbFileSizeHeadingS = 'Taille';
AbVersionMadeHeadingS = 'Version Utilise';
AbVersionNeededHeadingS = 'Version ncessaire';
AbPathHeadingS = 'Chemin';
AbPartialHeadingS = 'Partiel';
AbExecutableHeadingS = 'Excutable';
AbCabMethod0S = 'Aucune';
AbCabMethod1S = 'MSZip';
AbLtAddS = ' Ajout ';
AbLtDeleteS = ' Supprim ';
AbLtExtractS = ' Extrait ';
AbLtFreshenS = ' Rafraichir ';
AbLtMoveS = ' Dplac ';
AbLtReplaceS = ' Remplac ';
AbLtStartS = ' Connexion ';
AbGzipInvalidS = 'Gzip Invalide';
AbGzipBadCRCS = 'Mauvais CRC';
AbGzipBadFileSizeS = 'Taille du fichier errone';
AbTarInvalidS = 'Tar invalide';
AbTarBadFileNameS = 'Nom de fichier trop long';
AbTarBadLinkNameS = 'Chemin du lien symbolique trop long';
AbTarBadOpS = 'Opration non supporte';
AbUnhandledEntityS = 'Entit non prise en charge';
{ pre-defined "operating system" (really more FILE system) identifiers for the
Gzip header }
AbGzOsFat = 'Systme de fichier FAT (MS-DOS, OS/2, NT/Win32)';
AbGzOsAmiga = 'Amiga';
AbGzOsVMS = 'VMS (ou OpenVMS)';
AbGzOsUnix = 'Unix';
AbGzOsVM_CMS = 'VM/CMS';
AbGzOsAtari = 'Atari TOS';
AbGzOsHPFS = 'Systme de fichier HPFS (OS/2, NT)';
AbGzOsMacintosh = 'Macintosh';
AbGzOsZ_System = 'Z-System';
AbGzOsCP_M = 'CP/M';
AbGzOsTOPS_20 = 'TOPS-20';
AbGzOsNTFS = 'Systme de fichier NTFS (NT)';
AbGzOsQDOS = 'QDOS';
AbGzOsAcornRISCOS = 'Acorn RISCOS';
AbGzOsVFAT = 'Systme de fichier VFAT (Win95, NT)';
AbGzOsMVS = 'MVS';
AbGzOsBeOS = 'BeOS (BeBox ou PowerMac)';
AbGzOsTandem = 'Tandem/NSK';
AbGzOsTHEOS = 'THEOS';
AbGzOsunknown = 'Inconnu';
AbGzOsUndefined = 'ID non dfini par gzip';
{!!.03 - Moved from AbCompnd.inc }
{ Compound File specific error messages }
resourcestring
AbCmpndIndexOutOfBounds = 'Indice hors limite';
AbCmpndBusyUpdating = 'Fichier compos est occup par la mise jour';
AbCmpndInvalidFile = 'Fichier compos invalide';
AbCmpndFileNotFound = 'Fichier/Dossier introuvable';
AbCmpndFolderNotEmpty = 'Dossier n''est pas vide';
AbCmpndExceedsMaxFileSize = 'Taille du fichier dpasse la limite maximale';
{!!.03 - End Moved }
implementation
end.
================================================
FILE: lib/abbrevia/localization/AbResString.pas.nl
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Rudy Velthuis
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* Abbrevia: AbResString.pas 3.05 *}
{*********************************************************}
{* Abbrevia: Resource strings, Dutch localization *}
{*********************************************************}
unit AbResString;
interface
resourcestring
AbErrZipInvalidS = 'Ongeldig bestand - geen PKZip bestand';
AbZipVersionNeededS = 'Kan bestand niet ontpakken - nieuwere versie nodig';
AbUnknownCompressionMethodS = 'Kan bestand niet ontpakken - niet ondersteunde compressiemethode';
AbNoExtractionMethodS = 'Kan bestand niet ontpakken - ontpakken wordt niet ondersteund';
AbInvalidPasswordS = 'Kan bestand niet ontpakken - ongeldig paswoord';
AbNoInsertionMethodS = 'Kan bestand niet invoegen - invoegen wordt niet ondersteund';
AbInvalidFactorS = 'Ongeldige reductiefactor';
AbDuplicateNameS = 'Kan het bestand niet invoegen - dupliceert opgeslagen naam';
AbUnsupportedCompressionMethodS = 'Kan het bestand niet invoegen - niet ondersteunde compressiemethode';
AbUserAbortS = 'Proces werd door gebruiker afgebroken';
AbArchiveBusyS = 'Archief is bezig - kan nieuwe aanvraag niet bewerken';
AbLastDiskRequestS = 'Plaats laatste diskette van opgesplitst archief';
AbDiskRequestS = 'Plaats diskette';
AbImageRequestS = 'Bestandsnaam afbeelding';
AbBadSpanStreamS = 'Opgesplitste archieven moeten als bestandsstroom geopend worden';
AbDiskNumRequestS = 'Plaats diskette %d van opgesplitst archief';
AbImageNumRequestS = 'Plaats segment %d van opgesplitst archief';
AbNoOverwriteSpanStreamS = 'Kan bestaand opgesplitst archief niet veranderen';
AbNoSpannedSelfExtractS = 'Kan geen zelfontpakkend opgesplitst archief aanmaken';
AbBlankDiskS = 'Plaats een lege diskette';
AbStreamFullS = 'Schrijffout stroom';
AbNoSuchDirectoryS = 'Directory bestaat niet';
AbInflateBlockErrorS = 'Kan blok niet ontpakken';
AbBadStreamTypeS = 'Ongeldige stroom';
AbTruncateErrorS = 'Fout bij het afknotten van het zip bestand';
AbZipBadCRCS = 'Mislukte CRC controle';
AbZipBadStubS = 'Stomp moet uitvoerbaar bestand zijn';
AbFileNotFoundS = 'Bestand niet gevonden';
AbInvalidLFHS = 'Ongeldig Local File Header element';
AbNoArchiveS = 'Archief bestaat niet - lege bestandsnaam';
AbReadErrorS = 'Fout tijdens lezen van archief';
AbInvalidIndexS = 'Ongeldige index van archiefelement';
AbInvalidThresholdS = 'Ongeldige drempel van archiefgrootte';
AbUnhandledFileTypeS = 'Onbekend archieftype';
AbSpanningNotSupportedS = 'Opsplitsen wordt voor dit archieftype niet ondersteund';
AbLogCreateErrorS = 'Fout tijdens aanmaken van protocolbestand';
AbMoveFileErrorS = 'Fout tijdens het verplaatsen van bestand %s naar %s';
AbFileSizeTooBigS = 'Bestand is te groot voor dit archieftype';
AbNoCabinetDllErrorS = 'Kan bestand cabinet.dll niet laden';
AbFCIFileOpenErrorS = 'FCI kan bestand niet openen';
AbFCIFileReadErrorS = 'FCI kan bestand niet lezen';
AbFCIFileWriteErrorS = 'FCI kan bestand niet schrijven';
AbFCIFileCloseErrorS = 'FCI fout tijdens sluiten van bestand';
AbFCIFileSeekErrorS = 'FCI fout tijdens positioneren in bestand';
AbFCIFileDeleteErrorS = 'FCI fout tijdens wissen van bestand';
AbFCIAddFileErrorS = 'FCI kan bestand niet toevoegen';
AbFCICreateErrorS = 'FCI kan context niet aanmaken';
AbFCIFlushCabinetErrorS = 'FCI kan cabinet niet legen';
AbFCIFlushFolderErrorS = 'FCI kan folder niet legen';
AbFDICopyErrorS = 'FDI kann bestanden niet opsommen';
AbFDICreateErrorS = 'FDI kan context niet aanmaken';
AbInvalidCabTemplateS = 'Ongeldige sjabloon voor cabinetsbestand';
AbInvalidCabFileS = 'Ongeldig bestand - geen cabinetsbestand';
AbZipStored = 'Opgeslagen';
AbZipShrunk = 'Gekrompen';
AbZipReduced = 'Gereduceerd';
AbZipImploded = 'Gemplodeerd';
AbZipTokenized = 'In symbolen gepakt';
AbZipDeflated = 'Gedeflationeerd';
AbZipDeflate64 = 'Uitgebreid gedeflationeerd';
AbZipDCLImploded = 'DCL gemplodeerd';
AbZipBzip2 = 'Bzip2';
AbZipLZMA = 'LZMA';
AbZipIBMTerse = 'IBM Terse';
AbZipLZ77 = 'IBM LZ77';
AbZipJPEG = 'JPEG';
AbZipWavPack = 'WavPack';
AbZipPPMd = 'PPMd';
AbZipUnknown = 'Onbekend (%d)';
AbZipBestMethod = 'Beste methode';
AbVersionFormatS = 'Versie %s';
AbCompressedSizeFormatS = 'Gecomprimeerde grootte: %d';
AbUncompressedSizeFormatS = 'Ongecomprimeerde grootte: %d';
AbCompressionMethodFormatS = 'Compressiemethode: %s';
AbCompressionRatioFormatS = 'Compressieverhouding: %2.0f%%';
AbCRCFormatS = 'CRC: %x';
AbReadOnlyS = 'r';
AbHiddenS = 'h';
AbSystemS = 's';
AbArchivedS = 'a';
AbEFAFormatS = 'Externe bestandsattributen: %s';
AbIFAFormatS = 'Bestandstype: %s';
AbTextS = 'Tekst';
AbBinaryS = 'Binair';
AbEncryptionFormatS = 'Versleuteling: %s';
AbEncryptedS = 'Versleuteld';
AbNotEncryptedS = 'Niet versleuteld';
AbUnknownS = 'Onbekend';
AbTimeStampFormatS = 'Tijdstempel: %s';
AbMadeByFormatS = 'Gemaakt met versie: %f';
AbNeededFormatS = 'Versie benodigd voor ontpakken: %f';
AbCommentFormatS = 'Opmerking: %s';
AbDefaultExtS = '*.zip';
AbFilterS = 'PKZip Archieven (*.zip)|*.zip|Zelfontpakkende Archieven (*.exe)|*.exe|Alle Bestanden (*.*)|*.*';
AbFileNameTitleS = 'Bestandsnaam Kiezen';
AbOKS = 'OK';
AbCancelS = 'Verlaten';
AbSelectDirectoryS = 'Bestand kiezen';
AbEnterPasswordS = 'Paswoord ingeven';
AbPasswordS = '&Paswoord';
AbVerifyS = '&Verificeren';
AbCabExtS = '*.cab';
AbCabFilterS = 'Cabinetsarchieven (*.cab)|*.CAB|Alle Bestanden (*.*)|*.*';
AbLogExtS = '*.txt';
AbLogFilterS = 'Tekstbestanden (*.txt)|*.TXT|Alle Bestanden (*.*)|*.*';
AbExeExtS = '*.exe';
AbExeFilterS = 'Zelfontpakkende Zip Bestanden (*.exe)|*.EXE|Alle Bestanden (*.*)|*.*';
AbVMSReadTooManyBytesS = 'VMS: Anvraag om te veel byte [%d] te lezen';
AbVMSInvalidOriginS = 'VMS: Ongeldige oorsprong %d, moet 0, 1 of 2 zijn';
AbVMSErrorOpenSwapS = 'VMS: Kan wisselbestand %s niet openen';
AbVMSSeekFailS = 'VMS: Kon niet in wisselbestand %s positioneren';
AbVMSReadFailS = 'VMS: Kon %d byte in wisselbestand %s niet lezen';
AbVMSWriteFailS = 'VMS: Kon %d byte niet in wisselbestand %s schrijven';
AbVMSWriteTooManyBytesS = 'VMS: Anvraag om te veel byte [%d] te schrijven';
AbBBSReadTooManyBytesS = 'BBS: Anvraag om te veel byte [%d] te lezen';
AbBBSSeekOutsideBufferS = 'BBS: Nieuwe positie is buiten de buffer';
AbBBSInvalidOriginS = 'BBS: Ongeldige oorsprongswaarde';
AbBBSWriteTooManyBytesS = 'BBS: Anvraag om te veel byte [%d] te schrijven';
AbSWSNotEndofStreamS = 'TabSlidingWindowStream.Write: Niet aan eind van stroom';
AbSWSSeekFailedS = 'TabSlidingWindowStream.bsWriteChunk: Positioneren mislukt';
AbSWSWriteFailedS = 'TabSlidingWindowStream.bsWriteChunk: Schrijven mislukt';
AbSWSInvalidOriginS = 'TabSlidingWindowStream.Seek: Ongeldige oorsprong';
AbSWSInvalidNewOriginS = 'TabSlidingWindowStream.Seek: Ongeldige nieuwe positie';
AbItemNameHeadingS = 'Naam';
AbPackedHeadingS = 'Gepakt';
AbMethodHeadingS = 'Methode';
AbRatioHeadingS = 'Besparing (%)';
AbCRCHeadingS = 'CRC32';
AbFileAttrHeadingS = 'Attribuut';
AbFileFormatHeadingS = 'Formaat';
AbEncryptionHeadingS = 'Versleuteld';
AbTimeStampHeadingS = 'Tijdstempel';
AbFileSizeHeadingS = 'Grootte';
AbVersionMadeHeadingS = 'Gebruikte versie';
AbVersionNeededHeadingS = 'Benodigde versie';
AbPathHeadingS = 'Pad';
AbPartialHeadingS = 'Partieel';
AbExecutableHeadingS = 'Uitvoerbaar';
AbCabMethod0S = 'Geen';
AbCabMethod1S = 'MSZip';
AbLtAddS = ' toegevoegd ';
AbLtDeleteS = ' gewist ';
AbLtExtractS = ' ontpakt ';
AbLtFreshenS = ' geactualiseerd ';
AbLtMoveS = ' verplaatst ';
AbLtReplaceS = ' vervangen ';
AbLtStartS = ' geprotocolleerd ';
AbGzipInvalidS = 'Ongeldige Gzip';
AbGzipBadCRCS = 'Ongeldige CRC';
AbGzipBadFileSizeS = 'Ongeldige bestandsgrootte';
AbTarInvalidS = 'Ongeldige Tar';
AbTarBadFileNameS = 'Bestandsnaam te lang';
AbTarBadLinkNameS = 'Link naam te lang';
AbTarBadOpS = 'Niet ondersteunde functie';
AbUnhandledEntityS = 'Niet behandelde entiteit';
{ pre-defined "operating system" (really more FILE system) identifiers for the
Gzip header }
AbGzOsFat = 'FAT Bestandssysteem (MS-DOS, OS/2, NT/Win32)';
AbGzOsAmiga = 'Amiga';
AbGzOsVMS = 'VMS (oder OpenVMS)';
AbGzOsUnix = 'Unix';
AbGzOsVM_CMS = 'VM/CMS';
AbGzOsAtari = 'Atari TOS';
AbGzOsHPFS = 'HPFS Bestandssysteem (OS/2, NT)';
AbGzOsMacintosh = 'Macintosh';
AbGzOsZ_System = 'Z-System';
AbGzOsCP_M = 'CP/M';
AbGzOsTOPS_20 = 'TOPS-20';
AbGzOsNTFS = 'NTFS Bestandssysteem (NT)';
AbGzOsQDOS = 'QDOS';
AbGzOsAcornRISCOS = 'Acorn RISC OS';
AbGzOsVFAT = 'VFAT Bestandssysteem (Win95, NT)';
AbGzOsMVS = 'MVS';
AbGzOsBeOS = 'BeOS (BeBox of PowerMac)';
AbGzOsTandem = 'Tandem/NSK';
AbGzOsTHEOS = 'THEOS';
AbGzOsunknown = 'onbekend';
AbGzOsUndefined = 'ID is Gzip niet bekend';
{!!.03 - Moved from AbCompnd.inc }
{ Compound File specific error messages }
resourcestring
AbCmpndIndexOutOfBounds = 'Index niet in toegelaten bereik';
AbCmpndBusyUpdating = 'Samengesteld bestand wordt geactualiseerd';
AbCmpndInvalidFile = 'Ongeldig samengesteld bestand ';
AbCmpndFileNotFound = 'Bestand/directory niet gevonden';
AbCmpndFolderNotEmpty = 'Directory is niet leeg';
AbCmpndExceedsMaxFileSize = 'Bestandsgrootte overschrijdt toegelaten maximum';
{!!.03 - End Moved }
implementation
end.
================================================
FILE: lib/abbrevia/localization/AbResString.pas.ru
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Pavel Koptev, Roman Kassebaum
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* Abbrevia: AbResString.pas *}
{*********************************************************}
{* Abbrevia: Resource strings, Russian localization *}
{*********************************************************}
{* Warning: This file is UTF-8 encoded *}
{*********************************************************}
{* You need D2009 or higher to compile this unit *}
{*********************************************************}
unit AbResString;
interface
resourcestring
AbErrZipInvalidS = 'Формат архива не соответствует PKZip-формату';
AbZipVersionNeededS = 'Действие невозможно. Файл запакован более новой версией программы';
AbUnknownCompressionMethodS = 'Действие невозможно. Нераспознанный метод сжатия';
AbNoExtractionMethodS = 'Действие невозможно. Не доступен метод распаковки архива';
AbInvalidPasswordS = 'Действие невозможно. Неверный пароль';
AbNoInsertionMethodS = 'Действие невозможно. Архивом не поддерживается добавление новых файлов';
AbInvalidFactorS = 'Недействительный фактор сжатия';
AbDuplicateNameS = 'Действие невозможно. Файл с таким именем в архиве уже присутствует';
AbUnsupportedCompressionMethodS = 'Действие невозможно. Неподдерживаемый метод сжатия';
AbUserAbortS = 'Действие отменено пользователем';
AbArchiveBusyS = 'Действие невозможно. Архив поврежден';
AbLastDiskRequestS = 'Вставьте последнюю дискету в дисковод';
AbDiskRequestS = 'Вставьте дискету в дисковод';
AbImageRequestS = 'Имя образа';
AbBadSpanStreamS = 'Многотомные архивы открываются как файловый поток';
AbDiskNumRequestS = 'Вставьте %d дискету в дисковод';
AbImageNumRequestS = 'Укажите расположение %d тома архива';
AbNoOverwriteSpanStreamS = 'Невозможно изменить существующий многотомный архив';
AbNoSpannedSelfExtractS = 'Невозможно создать многотомный SFX-Архив';
AbBlankDiskS = 'Вставьте чистую дискету в дисковод';
AbStreamFullS = 'Ошибка записи в память';
AbNoSuchDirectoryS = 'Папка не существует';
AbInflateBlockErrorS = 'Блок данных не может быть распакован';
AbBadStreamTypeS = 'Недействительный поток';
AbTruncateErrorS = 'Ошибка при разделении Zip-Файла';
AbZipBadCRCS = 'Не верная контрольная сумма';
AbZipBadStubS = 'Корневой элемент архива должен быть исполняемым файлом';
AbFileNotFoundS = 'Файл не найден';
AbInvalidLFHS = 'Неверное начало файла';
AbNoArchiveS = 'Архив не существует';
AbReadErrorS = 'Ошибка чтения архива';
AbInvalidIndexS = 'Неверный индекс елемента архива';
AbInvalidThresholdS = 'Неверный размер частей архива';
AbUnhandledFileTypeS = 'Неизвестный архив';
AbSpanningNotSupportedS = 'Многотомность не поддерживается этим типом архивов';
AbLogCreateErrorS = 'Ошибка при создании файла протокола';
AbMoveFileErrorS = 'Ошибка при перемещении файла %s в %s';
AbFileSizeTooBigS = 'Файл слишком велик для выбранного типа архива';
AbNoCabinetDllErrorS = 'Библиотека cabinet.dll не может быть загружена';
AbFCIFileOpenErrorS = 'FCI невозможно открыть файл';
AbFCIFileReadErrorS = 'FCI невозможно прочитать файл';
AbFCIFileWriteErrorS = 'FCI невозможно записать файл';
AbFCIFileCloseErrorS = 'FCI ошибка при закрытии файла';
AbFCIFileSeekErrorS = 'FCI ошибка при поиске в файле';
AbFCIFileDeleteErrorS = 'FCI ошибка при удалении файла';
AbFCIAddFileErrorS = 'FCI невозможно добавить файл';
AbFCICreateErrorS = 'FCI ошибка создания';
AbFCIFlushCabinetErrorS = 'FCI Cabinet-архив не может быть создан';
AbFCIFlushFolderErrorS = 'FCI невозможно удалить все файлы из папки';
AbFDICopyErrorS = 'FDI невозможно пересчитать файлы';
AbFDICreateErrorS = 'FDI ошибка создания';
AbInvalidCabTemplateS = 'Неверный шаблон Cabinet-файла';
AbInvalidCabFileS = ' Неверный Cabinet-файл';
AbZipStored = 'Сохранено';
AbZipShrunk = 'Сжато';
AbZipReduced = 'Сжато';
AbZipImploded = 'Сжато';
AbZipTokenized = 'Разделен на части';
AbZipDeflated = 'Сжато';
AbZipDeflate64 = 'Лучшее сжатие';
AbZipDCLImploded = 'DCL Сжато';
AbZipBzip2 = 'Bzip2';
AbZipLZMA = 'LZMA';
AbZipIBMTerse = 'IBM Terse';
AbZipLZ77 = 'IBM LZ77';
AbZipJPEG = 'JPEG';
AbZipWavPack = 'WavPack';
AbZipPPMd = 'PPMd';
AbZipUnknown = 'Неизвестно (%d)';
AbZipBestMethod = 'Лучший метод';
AbVersionFormatS = 'Версия %s';
AbCompressedSizeFormatS = 'Размер в архиве: %d';
AbUncompressedSizeFormatS = 'Размер: %d';
AbCompressionMethodFormatS = 'Метод сжатия: %s';
AbCompressionRatioFormatS = 'Степень сжатия: %2.0f%%';
AbCRCFormatS = 'CRC: %x';
AbReadOnlyS = 'r';
AbHiddenS = 'h';
AbSystemS = 's';
AbArchivedS = 'a';
AbEFAFormatS = 'Внешние атрибуты файла: %s';
AbIFAFormatS = 'Тип файла: %s';
AbTextS = 'Текст';
AbBinaryS = 'Двоичный';
AbEncryptionFormatS = 'Шифрование: %s';
AbEncryptedS = 'Зашифрован';
AbNotEncryptedS = 'Не зашифрован';
AbUnknownS = 'Неизвестно';
AbTimeStampFormatS = 'Формат времени: %s';
AbMadeByFormatS = 'Версия программы создания: %f';
AbNeededFormatS = 'Для распаковки требуется версия: %f';
AbCommentFormatS = 'Комментарии: %s';
AbDefaultExtS = '*.zip';
AbFilterS = 'PKZip-архив (*.zip)|*.zip|SFX-Архив (*.exe)|*.exe|Все файлы (*.*)|*.*';
AbFileNameTitleS = 'Выберите имя файла';
AbOKS = 'OK';
AbCancelS = 'Отмена';
AbSelectDirectoryS = 'Выберете папку';
AbEnterPasswordS = 'Введите пароль';
AbPasswordS = '&Пароль';
AbVerifyS = '&Проверка';
AbCabExtS = '*.cab';
AbCabFilterS = 'Cabinet-архив (*.cab)|*.CAB|Все файлы (*.*)|*.*';
AbLogExtS = '*.txt';
AbLogFilterS = 'Текстовые файлы (*.txt)|*.TXT|Все файлы (*.*)|*.*';
AbExeExtS = '*.exe';
AbExeFilterS = 'SFX-архивы (*.exe)|*.EXE|Все файлы (*.*)|*.*';
AbVMSReadTooManyBytesS = 'VMS: попытка чтения слишком большого числа байт [%d]';
AbVMSInvalidOriginS = 'VMS: недействительный источник %d, разрешены 0, 1, 2';
AbVMSErrorOpenSwapS = 'VMS: Невозможно открыть файл %s';
AbVMSSeekFailS = 'VMS: Невозможно осуществить поиск в файле %s';
AbVMSReadFailS = 'VMS: Невозможно прочитать файл %s';
AbVMSWriteFailS = 'VMS: Невозможно %d байт записать в файл %s';
AbVMSWriteTooManyBytesS = 'VMS: попытка записи слишком большого числа байт [%d]';
AbBBSReadTooManyBytesS = 'BBS: попытка чтения слишком большого числа байт [%d]';
AbBBSSeekOutsideBufferS = 'BBS: позиция находится вне буфера';
AbBBSInvalidOriginS = 'BBS: недействительно предыдущее значение';
AbBBSWriteTooManyBytesS = 'BBS: попытка записи слишком большого числа байт [%d]';
AbSWSNotEndofStreamS = 'TabSlidingWindowStream.Write: попытка записи данных не в конец потока';
AbSWSSeekFailedS = 'TabSlidingWindowStream.bsWriteChunk: поиск не удался';
AbSWSWriteFailedS = 'TabSlidingWindowStream.bsWriteChunk: запись не удалась';
AbSWSInvalidOriginS = 'TabSlidingWindowStream.Seek: Недействительный источник';
AbSWSInvalidNewOriginS = 'TabSlidingWindowStream.Seek: недействительная новая позиция';
AbItemNameHeadingS = 'Имя';
AbPackedHeadingS = 'Сжато';
AbMethodHeadingS = 'Метод';
AbRatioHeadingS = 'Коэффициент сжатия (%)';
AbCRCHeadingS = 'CRC32';
AbFileAttrHeadingS = 'Атрибуты';
AbFileFormatHeadingS = 'Формат';
AbEncryptionHeadingS = 'Шифрование';
AbTimeStampHeadingS = 'Время';
AbFileSizeHeadingS = 'Размер';
AbVersionMadeHeadingS = 'Использована версия';
AbVersionNeededHeadingS = 'Необходима версия';
AbPathHeadingS = 'Путь';
AbPartialHeadingS = 'Частично';
AbExecutableHeadingS = 'Выполнимо';
AbCabMethod0S = 'нет';
AbCabMethod1S = 'MSZip';
AbLtAddS = ' вставлен ';
AbLtDeleteS = ' удален ';
AbLtExtractS = ' распакован ';
AbLtFreshenS = ' обновлен ';
AbLtMoveS = ' перемещен ';
AbLtReplaceS = ' заменено ';
AbLtStartS = ' запротоколировано ';
AbGzipInvalidS = 'Недействительный Gzip';
AbGzipBadCRCS = 'Недействительная контрольная сумма';
AbGzipBadFileSizeS = 'Недействительный размер файла';
AbTarInvalidS = 'Недествительный Tar-архив';
AbTarBadFileNameS = 'Слишком длинное имя файла';
AbTarBadLinkNameS = 'Слишком длинная ссылка';
AbTarBadOpS = 'Неподдерживаемая операция';
AbUnhandledEntityS = 'Необрабатываемый объект';
{ pre-defined "operating system" (really more FILE system) identifiers for the
Gzip header }
AbGzOsFat = 'FAT файловая система (MS-DOS, OS/2, NT/Win32)';
AbGzOsAmiga = 'Amiga';
AbGzOsVMS = 'VMS (или OpenVMS)';
AbGzOsUnix = 'Unix';
AbGzOsVM_CMS = 'VM/CMS';
AbGzOsAtari = 'Atari TOS';
AbGzOsHPFS = 'HPFS файловая система (OS/2, NT)';
AbGzOsMacintosh = 'Macintosh';
AbGzOsZ_System = 'Z-System';
AbGzOsCP_M = 'CP/M';
AbGzOsTOPS_20 = 'TOPS-20';
AbGzOsNTFS = 'NTFS файловая система (NT)';
AbGzOsQDOS = 'QDOS';
AbGzOsAcornRISCOS = 'Acorn RISCOS';
AbGzOsVFAT = 'VFAT файловая система (Win95, NT)';
AbGzOsMVS = 'MVS';
AbGzOsBeOS = 'BeOS (BeBox или PowerMac)';
AbGzOsTandem = 'Tandem/NSK';
AbGzOsTHEOS = 'THEOS';
AbGzOsunknown = 'неизвестно';
AbGzOsUndefined = 'Идентификационный номер для Gzip не известен';
{!!.03 - Moved from AbCompnd.inc }
{ Compound File specific error messages }
resourcestring
AbCmpndIndexOutOfBounds = 'Индекс выходит за пределы допустимого диапазона';
AbCmpndBusyUpdating = 'Обновляется файл связок';
AbCmpndInvalidFile = 'Недействительный файл связок';
AbCmpndFileNotFound = 'Файл или папка не найдены';
AbCmpndFolderNotEmpty = 'Папка не пуста';
AbCmpndExceedsMaxFileSize = 'Допустимый размер файла был превышен';
{!!.03 - End Moved }
implementation
end.
================================================
FILE: lib/abbrevia/localization/AbResString.pas.tr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Durali Kiraz 2014-05-06
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* Abbrevia: AbResString.pas *}
{*********************************************************}
{* Abbrevia: Resource strings, Turkish localization *}
{*********************************************************}
{* Encoded in Code Page 1252 (Windows Latin 5 Turkish) *}
{*********************************************************}
unit AbResString;
{$I AbDefine.inc}
interface
resourcestring
AbErrZipInvalidS = 'Geersiz dosya - bir PKZip dosyas deil';
AbZipVersionNeededS = 'Dosya Ayklanamyor - daha yeni bir srm gerekli.';
AbUnknownCompressionMethodS = 'Dosya Ayklanamyor - desteklenmeyen sktrma yntemi';
AbNoExtractionMethodS = 'Dosya Ayklanamyor - salanan bir karma destei yok';
AbInvalidPasswordS = 'Dosya Ayklanamyor - geersiz ifre';
AbNoInsertionMethodS = 'Dosya Eklenemiyor - salanan bir ekleme destei yok';
AbInvalidFactorS = 'Geersiz Faktr azaltn';
AbDuplicateNameS = 'Dosya Eklenemiyor - saklanan dosya ad ift';
AbUnsupportedCompressionMethodS = 'Dosya Eklenemiyor - desteklenmeyen sktrma yntemi';
AbUserAbortS = 'Sre kullanc tarafndan iptal edildi';
AbArchiveBusyS = 'Ariv megul - yeni istekleri ileyemiyor';
AbLastDiskRequestS = 'Yaylm disk setinde son diski yerletirin';
AbDiskRequestS = 'Disket takn';
AbImageRequestS = 'Kalp dosya ad';
AbBadSpanStreamS = 'Yaylm arivler dosya akkanlar gibi almaldr';
AbDiskNumRequestS = 'Yaylm disk setinin %d numaral diskini ekleyin';
AbImageNumRequestS = 'Yaylm dosya setinin aralkl %d numaral dosyasn ekleyin ';
AbNoOverwriteSpanStreamS = 'Varolan Yaylm disk seti gncelleme yaplamaz';
AbNoSpannedSelfExtractS = 'Bir kendi kendini ayklayan(exe dosyas) disk seti yaplamaz';
AbBlankDiskS = 'Bo bir disket ekle';
AbStreamFullS = 'Akkan yazma hatas';
AbNoSuchDirectoryS = 'Klasr mevcut deil';
AbInflateBlockErrorS = 'Blou iiremezsin (connot inflate)';
AbBadStreamTypeS = 'Geersiz Akkan';
AbTruncateErrorS = 'Zip dosyas hata ile kesiliyor';
AbZipBadCRCS = 'Baarsz CRC kontrol';
AbZipBadStubS = 'Stub bir altrlabilir(exe) olmal';
AbFileNotFoundS = 'Dosya bulunamad';
AbInvalidLFHS = 'Geersiz Yerel Dosya Bal giri';
AbNoArchiveS = 'Ariv mevcut deil - Dosyaad bo';
AbReadErrorS = 'Okuma hatas arivi';
AbInvalidIndexS = 'Geersiz ariv e Endeksi';
AbInvalidThresholdS = 'Geersiz ariv boyutu eii';
AbUnhandledFileTypeS = 'lenmeyen Ariv Tr';
AbSpanningNotSupportedS = 'Yaylma bu Ariv tr tarafndan desteklenmiyor ';
AbLogCreateErrorS = 'Gnlk Dosyas olutururken hata';
AbMoveFileErrorS = '%s kaynandan %s hedefine Dosya Tamada Hata';
AbFileSizeTooBigS = 'Dosya boyutu ariv tr iin ok byk';
AbNoCabinetDllErrorS = 'cabinet.dll yklenemedi';
AbFCIFileOpenErrorS = 'FCI dosya alamad';
AbFCIFileReadErrorS = 'FCI dosya okunmad';
AbFCIFileWriteErrorS = 'FCI dosya yazlamad';
AbFCIFileCloseErrorS = 'FCI dosya kapatmada hata';
AbFCIFileSeekErrorS = 'FCI dosya konumlanma hatas';
AbFCIFileDeleteErrorS = 'FCI dosya silme hatas';
AbFCIAddFileErrorS = 'FCI dosya eklenemedi';
AbFCICreateErrorS = 'FCI ierii oluturulamyor';
AbFCIFlushCabinetErrorS = 'FCI kabini flush yaplamyor';
AbFCIFlushFolderErrorS = 'FCI klasr flush yaplamyor';
AbFDICopyErrorS = 'FDI dosyalar numaralandrma yaplamyor';
AbFDICreateErrorS = 'FDI ierii oluturulamyor';
AbInvalidCabTemplateS = 'Geersiz cab dosya ablonu';
AbInvalidCabFileS = 'Geersiz Dosya - bir kabin dosyas deil';
AbZipStored = 'Depoland';
AbZipShrunk = 'Bzlm';
AbZipReduced = 'Azaltlm';
AbZipImploded = 'ine kt';
AbZipTokenized = 'Simgeletirilmi';
AbZipDeflated = 'nik';
AbZipDeflate64 = 'Gelitirilmi niklik';
AbZipDCLImploded = 'DCL Bzlm';
AbZipBzip2 = 'Bzip2';
AbZipLZMA = 'LZMA';
AbZipIBMTerse = 'IBM Terse';
AbZipLZ77 = 'IBM LZ77';
AbZipJPEG = 'JPEG';
AbZipWavPack = 'WavPack';
AbZipPPMd = 'PPMd';
AbZipUnknown = 'Bilinmeyen (%d)';
AbZipBestMethod = 'En yi Yntem';
AbVersionFormatS = 'Srm %s';
AbCompressedSizeFormatS = 'Sktrlm uzunluk: %d';
AbUncompressedSizeFormatS = 'Sktrlmam uzunluk: %d';
AbCompressionMethodFormatS = 'Sktrma Yntemi: %s';
AbCompressionRatioFormatS = 'Sktrma Oran: %2.0f%%';
AbCRCFormatS = 'CRC: %x';
AbReadOnlyS = 'r';
AbHiddenS = 'h';
AbSystemS = 's';
AbArchivedS = 'a';
AbEFAFormatS = 'Harici Dosya zellikleri: %s';
AbIFAFormatS = 'Dosya Tr: %s';
AbTextS = 'Text';
AbBinaryS = 'Binary';
AbEncryptionFormatS = 'ifreleme: %s';
AbEncryptedS = 'ifrelenmi';
AbNotEncryptedS = 'ifreli Deil';
AbUnknownS = 'Bilinmiyor';
AbTimeStampFormatS = 'Zaman Damgas: %s';
AbMadeByFormatS = 'Srm Yapan: %f';
AbNeededFormatS = 'Ayklamaya Gerekli Srm: %f';
AbCommentFormatS = 'Aklama: %s';
AbDefaultExtS = '*.zip';
AbFilterS = 'PKZip Arivleri (*.zip)|*.zip|Kendinden Ayklanabilen Arivler (*.exe)|*.exe|Tm Dosyalar (*.*)|*.*';
AbFileNameTitleS = 'Dosya Ad Se';
AbOKS = 'Tamam';
AbCancelS = 'Vazge';
AbSelectDirectoryS = 'Klasr Se';
AbEnterPasswordS = 'ifre Gir';
AbPasswordS = 'i&fre';
AbVerifyS = '&Dorula';
AbCabExtS = '*.cab';
AbCabFilterS = 'Kabin Arivleri (*.cab)|*.CAB|Tm Dosyalar (*.*)|*.*';
AbLogExtS = '*.txt';
AbLogFilterS = 'Metin Dosyalar (*.txt)|*.TXT|Tm Dosyalar (*.*)|*.*';
AbExeExtS = '*.exe';
AbExeFilterS = 'Kendinden-Ayklanabilen Zip Dosyalar (*.exe)|*.EXE|Tm Dosyalar (*.*)|*.*';
AbVMSReadTooManyBytesS = 'VMS: ok bayt okuma istei [%d]';
AbVMSInvalidOriginS = 'VMS: %d kkeni geersiz. Geerli deerler 0, 1, 2 olmaldr';
AbVMSErrorOpenSwapS = 'VMS: %s takas dosyas alamyor';
AbVMSSeekFailS = 'VMS: %s takas dosyasnda arama baarsz oldu';
AbVMSReadFailS = 'VMS: %d bayt %s takas dosyasndan okunurken baarsz oldu';
AbVMSWriteFailS = 'VMS: %d bayt %s takas dosyasndan yazlrken baarsz oldu';
AbVMSWriteTooManyBytesS = 'VMS: ok fazla bayt yazma istei [%d]';
AbBBSReadTooManyBytesS = 'BBS: ok fazla bayt okuma istei [%d]';
AbBBSSeekOutsideBufferS = 'BBS: Yeni konum arabellek dndadr';
AbBBSInvalidOriginS = 'BBS: Geersiz Kken deeri';
AbBBSWriteTooManyBytesS = 'BBS: ok fazla bayt yazma istei [%d]';
AbSWSNotEndofStreamS = 'TabSlidingWindowStream.Write: Akn sonunda deil';
AbSWSSeekFailedS = 'TabSlidingWindowStream.bsWriteChunk: Arama baarsz oldu';
AbSWSWriteFailedS = 'TabSlidingWindowStream.bsWriteChunk: Yazma baarsz oldu';
AbSWSInvalidOriginS = 'TabSlidingWindowStream.Seek: Geersiz kken';
AbSWSInvalidNewOriginS = 'TabSlidingWindowStream.Seek: Geersiz yeni konum';
AbItemNameHeadingS = 'Ad';
AbPackedHeadingS = 'Paketli';
AbMethodHeadingS = 'Yntemi';
AbRatioHeadingS = 'Oran (%)';
AbCRCHeadingS = 'CRC32';
AbFileAttrHeadingS = 'Nitelikler';
AbFileFormatHeadingS = 'Biim';
AbEncryptionHeadingS = 'ifrelenmi';
AbTimeStampHeadingS = 'Zaman Damgas';
AbFileSizeHeadingS = 'Uzunluk';
AbVersionMadeHeadingS = 'Srm Yapm';
AbVersionNeededHeadingS = 'Srm Gerekli';
AbPathHeadingS = 'Yolu';
AbPartialHeadingS = 'Ksmi';
AbExecutableHeadingS = 'altrlabilir';
AbFileTypeHeadingS = 'Tr';
AbLastModifiedHeadingS = 'Deitirilmi';
AbCabMethod0S = 'None';
AbCabMethod1S = 'MSZip';
AbLtAddS = ' eklendi ';
AbLtDeleteS = ' silindi ';
AbLtExtractS = ' aykland ';
AbLtFreshenS = ' tazelendi ';
AbLtMoveS = ' tand ';
AbLtReplaceS = ' deitirildi ';
AbLtStartS = ' gnlklendi ';
AbGzipInvalidS = 'Geersiz Gzip';
AbGzipBadCRCS = 'Bozuk CRC';
AbGzipBadFileSizeS = 'Bozuk Dosya Uzunluu';
AbTarInvalidS = 'Geersiz Tar';
AbTarBadFileNameS = 'Dosya ad ok uzun';
AbTarBadLinkNameS = 'ok uzun sembolik balant yolu';
AbTarBadOpS = 'Desteklenmeyen Operasyon';
AbUnhandledEntityS = 'lenmeyen Varlk';
{ pre-defined "operating system" (really more FILE system) identifiers for the
Gzip header }
AbGzOsFat = 'FAT Dosya Sistemi (MS-DOS, OS/2, NT/Win32)';
AbGzOsAmiga = 'Amiga';
AbGzOsVMS = 'VMS (veya OpenVMS)';
AbGzOsUnix = 'Unix';
AbGzOsVM_CMS = 'VM/CMS';
AbGzOsAtari = 'Atari TOS';
AbGzOsHPFS = 'HPFS Dosya Sistemi (OS/2, NT)';
AbGzOsMacintosh = 'Macintosh';
AbGzOsZ_System = 'Z-System';
AbGzOsCP_M = 'CP/M';
AbGzOsTOPS_20 = 'TOPS-20';
AbGzOsNTFS = 'NTFS Dosya Sistemi (NT)';
AbGzOsQDOS = 'QDOS';
AbGzOsAcornRISCOS = 'Acorn RISCOS';
AbGzOsVFAT = 'VFAT Dosya Sistemi (Win95, NT)';
AbGzOsMVS = 'MVS';
AbGzOsBeOS = 'BeOS (BeBox veya PowerMac)';
AbGzOsTandem = 'Tandem/NSK';
AbGzOsTHEOS = 'THEOS';
AbGzOsunknown = 'bilinmeyen';
AbGzOsUndefined = 'gzip tarafndan tanmsz ID';
{ Compound File specific error messages }
resourcestring
AbCmpndIndexOutOfBounds = 'Endeks araln dndadr';
AbCmpndBusyUpdating = 'Bileik dosya gncelleme ile megul';
AbCmpndInvalidFile = 'Geersiz bileik dosya';
AbCmpndFileNotFound = 'Dosya/Klasr bulunamad';
AbCmpndFolderNotEmpty = 'Klasr bo deil';
AbCmpndExceedsMaxFileSize = 'Dosya boyutu izin verilen Azami deeri ayor';
implementation
end.
================================================
FILE: lib/abbrevia/packages/Delphi XE/Abbrevia.dpk
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
package Abbrevia;
{$R *.res}
{$ALIGN 8}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO OFF}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS OFF}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$REFERENCEINFO OFF}
{$SAFEDIVIDE OFF}
{$STACKFRAMES OFF}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST ON}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$DESCRIPTION 'Abbrevia Run-time package - RTL XE'}
{$LIBSUFFIX '150'}
{$RUNONLY}
{$IMPLICITBUILD OFF}
requires
rtl;
contains
AbArcTyp in '..\..\source\AbArcTyp.pas',
AbBase in '..\..\source\AbBase.pas',
AbBitBkt in '..\..\source\AbBitBkt.pas',
AbBrowse in '..\..\source\AbBrowse.pas',
AbBzip2 in '..\..\source\AbBzip2.pas',
AbBzip2Typ in '..\..\source\AbBzip2Typ.pas',
AbCabExt in '..\..\source\AbCabExt.pas',
AbCabKit in '..\..\source\AbCabKit.pas',
AbCabMak in '..\..\source\AbCabMak.pas',
AbCabTyp in '..\..\source\AbCabTyp.pas',
AbCBrows in '..\..\source\AbCBrows.pas',
AbCharset in '..\..\source\AbCharset.pas',
AbConst in '..\..\source\AbConst.pas',
AbCrtl in '..\..\source\AbCrtl.pas',
AbDfBase in '..\..\source\AbDfBase.pas',
AbDfCryS in '..\..\source\AbDfCryS.pas',
AbDfDec in '..\..\source\AbDfDec.pas',
AbDfEnc in '..\..\source\AbDfEnc.pas',
AbDfHufD in '..\..\source\AbDfHufD.pas',
AbDfInW in '..\..\source\AbDfInW.pas',
AbDfOutW in '..\..\source\AbDfOutW.pas',
AbDfPkMg in '..\..\source\AbDfPkMg.pas',
AbDfStrm in '..\..\source\AbDfStrm.pas',
AbDfXlat in '..\..\source\AbDfXlat.pas',
AbExcept in '..\..\source\AbExcept.pas',
AbFciFdi in '..\..\source\AbFciFdi.pas',
AbGzTyp in '..\..\source\AbGzTyp.pas',
AbLzma in '..\..\source\AbLzma.pas',
AbPPMd in '..\..\source\AbPPMd.pas',
AbResString in '..\..\source\AbResString.pas',
AbSelfEx in '..\..\source\AbSelfEx.pas',
AbSpanSt in '..\..\source\AbSpanSt.pas',
AbSWStm in '..\..\source\AbSWStm.pas',
AbTarTyp in '..\..\source\AbTarTyp.pas',
AbUnzOutStm in '..\..\source\AbUnzOutStm.pas',
AbUnzper in '..\..\source\AbUnzper.pas',
AbUnzPrc in '..\..\source\AbUnzPrc.pas',
AbUtils in '..\..\source\AbUtils.pas',
AbVMStrm in '..\..\source\AbVMStrm.pas',
AbWavPack in '..\..\source\AbWavPack.pas',
AbZBrows in '..\..\source\AbZBrows.pas',
AbZipExt in '..\..\source\AbZipExt.pas',
AbZipKit in '..\..\source\AbZipKit.pas',
AbZipper in '..\..\source\AbZipper.pas',
AbZipPrc in '..\..\source\AbZipPrc.pas',
AbZipTyp in '..\..\source\AbZipTyp.pas',
AbZLTyp in '..\..\source\AbZLTyp.pas';
end.
================================================
FILE: lib/abbrevia/packages/Delphi XE/Abbrevia.dproj
================================================
{F41FD54F-C677-468D-B2F6-F7DEE8EEF36C}Abbrevia.dpkDebugDCC3212.2True
Win32PackageNoneWin32true
trueBasetrue
trueBasetrue
$(BDSCOMMONDIR)\BplAbbrevia.bplWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)truefalseAbbrevia Run-time package - RTL XEtruetruetruetrue150false000400000x86falseRELEASE;$(DCC_Define)0falseDEBUG;$(DCC_Define)MainSourceCfg_2BaseBaseCfg_1BaseDelphi.Personality.12PackageAbbrevia.dpkTrueFalse4000FalseFalseFalseFalseFalse10331252Abbrevia Components5.0.0.0Copyright (c) Abbrevia Group 2011Abbrevia5.0Microsoft Office 2000 Sample Automation Server Wrapper ComponentsMicrosoft Office XP Sample Automation Server Wrapper ComponentsTrue12
================================================
FILE: lib/abbrevia/packages/Delphi XE/AbbreviaVCL.dpk
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
package AbbreviaVCL;
{$R *.res}
{$ALIGN 8}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO OFF}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS OFF}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$REFERENCEINFO OFF}
{$SAFEDIVIDE OFF}
{$STACKFRAMES OFF}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST ON}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$DESCRIPTION 'Abbrevia Run-time package - VCLXE'}
{$LIBSUFFIX '150'}
{$RUNONLY}
{$IMPLICITBUILD OFF}
requires
rtl,
vcl,
vclx,
Abbrevia;
contains
AbBseVCL in '..\..\source\AbBseVCL.pas',
AbMeter in '..\..\source\AbMeter.pas',
AbView in '..\..\source\AbView.pas',
AbZipOut in '..\..\source\AbZipOut.pas',
AbCView in '..\..\source\AbCView.pas',
AbZView in '..\..\source\AbZView.pas',
AbCompnd in '..\..\source\AbCompnd.pas',
AbHexVw in '..\..\source\AbHexVw.pas',
AbComCtrls in '..\..\source\AbComCtrls.pas';
end.
================================================
FILE: lib/abbrevia/packages/Delphi XE/AbbreviaVCL.dproj
================================================
{8F5900DA-6C2D-4EFA-96A5-D5AD0C68D886}AbbreviaVCL.dpkDebugDCC3212.2True
Win32PackageVCLWin32true
trueBasetrue
trueBasetrue
C:\Users\Public\Documents\RAD Studio\7.0\Bpl\B305vr2010.bplWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)truefalseAbbrevia Run-time package - VCLXEtruetruetruetrue150false000400000x86falseRELEASE;$(DCC_Define)0falseDEBUG;$(DCC_Define)MainSourceCfg_2BaseBaseCfg_1BaseDelphi.Personality.12PackageAbbreviaVCL.dpkTrueFalse4000FalseFalseFalseFalseFalse10331252Abbrevia Components5.0.0.0Copyright (c) Abbrevia GroupAbbrevia5.0True12
================================================
FILE: lib/abbrevia/packages/Delphi XE/AbbreviaVCLDesign.dpk
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
package AbbreviaVCLDesign;
{$R *.res}
{$ALIGN 8}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO OFF}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS OFF}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$REFERENCEINFO OFF}
{$SAFEDIVIDE OFF}
{$STACKFRAMES OFF}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST ON}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$DESCRIPTION 'Abbrevia Design-time package - VCLXE'}
{$LIBSUFFIX '150'}
{$DESIGNONLY}
{$IMPLICITBUILD OFF}
requires
designide,
AbbreviaVCL;
contains
AbPeCol in '..\..\source\AbPeCol.pas',
AbPeDir in '..\..\source\AbPeDir.pas',
AbPeFn in '..\..\source\AbPeFn.pas',
AbPePass in '..\..\source\AbPePass.pas',
AbPeVer in '..\..\source\AbPeVer.pas',
AbRegVcl in '..\..\source\AbRegVcl.pas',
AbDlgDir in '..\..\source\AbDlgDir.pas' {DirDlg},
AbDlgPwd in '..\..\source\AbDlgPwd.pas' {PassWordDlg};
end.
================================================
FILE: lib/abbrevia/packages/Delphi XE/AbbreviaVCLDesign.dproj
================================================
{24BE4180-8AB3-4667-927F-163D8C1A0D54}AbbreviaVCLDesign.dpkDebugDCC3212.2True
Win32PackageNoneWin32true
trueBasetrue
trueBasetrue
..\..\..\..\..\..\Public\Documents\RAD Studio\7.0\Bpl\B305vd2010.bpltrueAbbrevia Design-time package - VCLXEWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)falsetrue150truetruetruefalse000400000x86falseRELEASE;$(DCC_Define)0falseDEBUG;$(DCC_Define)MainSourceCfg_2BaseBaseCfg_1BaseDelphi.Personality.12PackageAbbreviaVCLDesign.dpkTrueFalse4000FalseFalseFalseFalseFalse10331252Abbrevia Components5.0.0.0Copyright (c) Abbrevia GroupAbbrevia5.0True12
================================================
FILE: lib/abbrevia/packages/Delphi XE.groupproj
================================================
{3FC8294C-9FE8-49B9-9FF0-C33C59C18002}Default.Personality.12
================================================
FILE: lib/abbrevia/source/AbArcTyp.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbArcTyp.pas *}
{*********************************************************}
{* ABBREVIA: TABArchive, TABArchiveItem classes *}
{*********************************************************}
unit AbArcTyp;
{$I AbDefine.inc}
interface
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF MSWINDOWS}
Classes,
Types,
AbUtils;
{ ===== TAbArchiveItem ====================================================== }
type
TAbArchiveItem = class(TObject)
protected {private}
NextItem : TAbArchiveItem;
FAction : TAbArchiveAction;
FCompressedSize : Int64;
FCRC32 : Longint;
FDiskFileName : string;
FExternalFileAttributes : LongWord;
FFileName : string;
FIsEncrypted : Boolean;
FLastModFileTime : Word;
FLastModFileDate : Word;
FTagged : Boolean;
FUncompressedSize : Int64;
protected {property methods}
function GetCompressedSize : Int64; virtual;
function GetCRC32 : Longint; virtual;
function GetDiskPath : string;
function GetExternalFileAttributes : LongWord; virtual;
function GetFileName : string; virtual;
function GetIsDirectory: Boolean; virtual;
function GetIsEncrypted : Boolean; virtual;
function GetLastModFileDate : Word; virtual;
function GetLastModFileTime : Word; virtual;
function GetNativeFileAttributes : LongInt; virtual;
function GetStoredPath : string;
function GetUncompressedSize : Int64; virtual;
procedure SetCompressedSize(const Value : Int64); virtual;
procedure SetCRC32(const Value : Longint); virtual;
procedure SetExternalFileAttributes( Value : LongWord ); virtual;
procedure SetFileName(const Value : string); virtual;
procedure SetIsEncrypted(Value : Boolean); virtual;
procedure SetLastModFileDate(const Value : Word); virtual;
procedure SetLastModFileTime(const Value : Word); virtual;
procedure SetUncompressedSize(const Value : Int64); virtual;
function GetLastModTimeAsDateTime: TDateTime; virtual;
procedure SetLastModTimeAsDateTime(const Value: TDateTime); virtual;
public {methods}
constructor Create;
destructor Destroy; override;
function MatchesDiskName(const FileMask : string) : Boolean;
function MatchesStoredName(const FileMask : string) : Boolean;
function MatchesStoredNameEx(const FileMask : string) : Boolean;
public {properties}
property Action : TAbArchiveAction
read FAction
write FAction;
property CompressedSize : Int64
read GetCompressedSize
write SetCompressedSize;
property CRC32 : Longint
read GetCRC32
write SetCRC32;
property DiskFileName : string
read FDiskFileName
write FDiskFileName;
property DiskPath : string
read GetDiskPath;
property ExternalFileAttributes : LongWord
read GetExternalFileAttributes
write SetExternalFileAttributes;
property FileName : string
read GetFileName
write SetFileName;
property IsDirectory: Boolean
read GetIsDirectory;
property IsEncrypted : Boolean
read GetIsEncrypted
write SetIsEncrypted;
property LastModFileDate : Word
read GetLastModFileDate
write SetLastModFileDate;
property LastModFileTime : Word
read GetLastModFileTime
write SetLastModFileTime;
property NativeFileAttributes : LongInt
read GetNativeFileAttributes;
property StoredPath : string
read GetStoredPath;
property Tagged : Boolean
read FTagged
write FTagged;
property UncompressedSize : Int64
read GetUncompressedSize
write SetUncompressedSize;
property LastModTimeAsDateTime : TDateTime
read GetLastModTimeAsDateTime
write SetLastModTimeAsDateTime;
end;
{ ===== TAbArchiveListEnumerator ============================================ }
type
TAbArchiveList = class;
TAbArchiveListEnumerator = class
private
FIndex: Integer;
FList: TAbArchiveList;
public
constructor Create(aList: TAbArchiveList);
function GetCurrent: TAbArchiveItem;
function MoveNext: Boolean;
property Current: TAbArchiveItem read GetCurrent;
end;
{ ===== TAbArchiveList ====================================================== }
TAbArchiveList = class
protected {private}
FList : TList;
FOwnsItems: Boolean;
HashTable : array[0..1020] of TAbArchiveItem;
protected {methods}
function GenerateHash(const S : string) : LongInt;
function GetCount : Integer;
function Get(Index : Integer) : TAbArchiveItem;
procedure Put(Index : Integer; Item : TAbArchiveItem);
procedure UpdateHash(aItem: TAbArchiveItem; const aOldFileName: string);
public {methods}
constructor Create(AOwnsItems: Boolean);
destructor Destroy; override;
function Add(aItem : TAbArchiveItem): Integer;
procedure Clear;
procedure Delete(Index : Integer);
function Find(const FN : string) : Integer;
function GetEnumerator: TAbArchiveListEnumerator;
function IsActiveDupe(const FN : string) : Boolean;
public {properties}
property Count : Integer
read GetCount;
property Items[Index : Integer] : TAbArchiveItem
read Get
write Put; default;
end;
{ ===== TAbArchive specific types =========================================== }
type
TAbStoreOption =
(soStripDrive, soStripPath, soRemoveDots, soRecurse, soFreshen, soReplace);
TAbStoreOptions =
set of TAbStoreOption;
TAbExtractOption =
(eoCreateDirs, eoRestorePath);
TAbExtractOptions =
set of TAbExtractOption;
TAbArchiveStatus =
(asInvalid, asIdle, asBusy);
TAbArchiveEvent =
procedure(Sender : TObject) of object;
TAbArchiveConfirmEvent =
procedure (Sender : TObject; var Confirm : Boolean) of object;
TAbArchiveProgressEvent =
procedure(Sender : TObject; Progress : Byte; var Abort : Boolean) of object;
TAbArchiveItemEvent =
procedure(Sender : TObject; Item : TAbArchiveItem) of object;
TAbArchiveItemConfirmEvent =
procedure(Sender : TObject; Item : TAbArchiveItem;
ProcessType : TAbProcessType; var Confirm : Boolean) of object;
TAbConfirmOverwriteEvent =
procedure(var Name : string; var Confirm : Boolean) of object;
TAbArchiveItemFailureEvent =
procedure(Sender : TObject; Item : TAbArchiveItem;
ProcessType : TAbProcessType; ErrorClass : TAbErrorClass;
ErrorCode : Integer) of object;
TAbArchiveItemExtractEvent =
procedure(Sender : TObject; Item : TAbArchiveItem;
const NewName : string) of object;
TAbArchiveItemExtractToStreamEvent =
procedure(Sender : TObject; Item : TAbArchiveItem;
OutStream : TStream) of object;
TAbArchiveItemTestEvent =
procedure(Sender : TObject; Item : TAbArchiveItem) of object;
TAbArchiveItemInsertEvent =
procedure(Sender : TObject; Item : TAbArchiveItem;
OutStream : TStream) of object;
TAbArchiveItemInsertFromStreamEvent =
procedure(Sender : TObject; Item : TAbArchiveItem;
OutStream, InStream : TStream) of object;
TAbArchiveItemProgressEvent =
procedure(Sender : TObject; Item : TAbArchiveItem; Progress : Byte;
var Abort : Boolean) of object;
TAbProgressEvent =
procedure(Progress : Byte; var Abort : Boolean) of object;
TAbRequestDiskEvent =
procedure(Sender : TObject; var Abort : Boolean) of object;
TAbRequestImageEvent =
procedure(Sender : TObject; ImageNumber : Integer;
var ImageName : string; var Abort : Boolean) of object;
TAbRequestNthDiskEvent =
procedure(Sender : TObject; DiskNumber : Byte; var Abort : Boolean) of object;
type
TAbArchiveStreamHelper = class
protected
FStream : TStream;
public
constructor Create(AStream : TStream);
procedure ExtractItemData(AStream : TStream); virtual; abstract;
function FindFirstItem : Boolean; virtual; abstract;
function FindNextItem : Boolean; virtual; abstract;
procedure ReadHeader; virtual; abstract;
procedure ReadTail; virtual; abstract;
function SeekItem(Index : Integer): Boolean; virtual; abstract;
procedure WriteArchiveHeader; virtual; abstract;
procedure WriteArchiveItem(AStream : TStream); virtual; abstract;
procedure WriteArchiveTail; virtual; abstract;
function GetItemCount : Integer; virtual; abstract;
end;
{ ===== TAbArchive ========================================================== }
type
TAbArchive = class(TObject)
public
FStream : TStream;
FStatus : TAbArchiveStatus;
protected {property variables} //These break Encapsulation
FArchiveName : string;
FAutoSave : Boolean;
FBaseDirectory : string;
FCurrentItem : TAbArchiveItem;
FDOSMode : Boolean;
FExtractOptions : TAbExtractOptions;
FImageNumber : Word;
FInStream : TStream;
FIsDirty : Boolean;
FSpanningThreshold : Int64;
FItemList : TAbArchiveList;
FLogFile : string;
FLogging : Boolean;
FLogStream : TFileStream;
FMode : Word;
FOwnsStream : Boolean;
FSpanned : Boolean;
FStoreOptions : TAbStoreOptions;
FTempDir : string;
protected {event variables}
FOnProcessItemFailure : TAbArchiveItemFailureEvent;
FOnArchiveProgress : TAbArchiveProgressEvent;
FOnArchiveSaveProgress : TAbArchiveProgressEvent;
FOnArchiveItemProgress : TAbArchiveItemProgressEvent;
FOnConfirmProcessItem : TAbArchiveItemConfirmEvent;
FOnConfirmOverwrite : TAbConfirmOverwriteEvent;
FOnConfirmSave : TAbArchiveConfirmEvent;
FOnLoad : TAbArchiveEvent;
FOnProgress : TAbProgressEvent;
FOnRequestImage : TAbRequestImageEvent;
FOnSave : TAbArchiveEvent;
protected {methods}
constructor CreateInit;
procedure CheckValid;
function ConfirmPath(Item : TAbArchiveItem; const NewName : string;
out UseName : string) : Boolean;
procedure FreshenAt(Index : Integer);
function FreshenRequired(Item : TAbArchiveItem) : Boolean;
procedure GetFreshenTarget(Item : TAbArchiveItem);
function GetItemCount : Integer;
procedure MakeLogEntry(const FN: string; LT : TAbLogType);
procedure ReplaceAt(Index : Integer);
procedure SaveIfNeeded(aItem : TAbArchiveItem);
procedure SetBaseDirectory(Value : string);
procedure SetLogFile(const Value : string);
procedure SetLogging(Value : Boolean);
protected {abstract methods}
function CreateItem(const FileSpec : string): TAbArchiveItem;
virtual; abstract;
procedure ExtractItemAt(Index : Integer; const UseName : string);
virtual; abstract;
procedure ExtractItemToStreamAt(Index : Integer; aStream : TStream);
virtual; abstract;
procedure LoadArchive;
virtual; abstract;
procedure SaveArchive;
virtual; abstract;
procedure TestItemAt(Index : Integer);
virtual; abstract;
protected {virtual methods}
procedure DoProcessItemFailure(Item : TAbArchiveItem;
ProcessType : TAbProcessType; ErrorClass : TAbErrorClass;
ErrorCode : Integer);
virtual;
procedure DoArchiveSaveProgress(Progress : Byte; var Abort : Boolean);
virtual;
procedure DoArchiveProgress(Progress : Byte; var Abort : Boolean);
virtual;
procedure DoArchiveItemProgress(Item : TAbArchiveItem; Progress : Byte;
var Abort : Boolean);
virtual;
procedure DoConfirmOverwrite(var FileName : string; var Confirm : Boolean);
virtual;
procedure DoConfirmProcessItem(Item : TAbArchiveItem;
const ProcessType : TAbProcessType; var Confirm : Boolean);
virtual;
procedure DoConfirmSave(var Confirm : Boolean);
virtual;
procedure DoLoad;
virtual;
procedure DoProgress(Progress : Byte; var Abort : Boolean);
virtual;
procedure DoSave;
virtual;
function FixName(const Value : string) : string;
virtual;
function GetSpanningThreshold : Int64;
virtual;
function GetSupportsEmptyFolders : Boolean;
virtual;
procedure SetSpanningThreshold( Value : Int64 );
virtual;
protected {properties and events}
property InStream : TStream
read FInStream;
public {methods}
constructor Create(const FileName : string; Mode : Word);
virtual;
constructor CreateFromStream(aStream : TStream; const aArchiveName : string);
virtual;
destructor Destroy;
override;
procedure Add(aItem : TAbArchiveItem);
virtual;
procedure AddFiles(const FileMask : string; SearchAttr : Integer);
procedure AddFilesEx(const FileMask, ExclusionMask : string;
SearchAttr : Integer);
procedure AddFromStream(const NewName : string; aStream : TStream);
procedure ClearTags;
procedure Delete(aItem : TAbArchiveItem);
procedure DeleteAt(Index : Integer);
procedure DeleteFiles(const FileMask : string);
procedure DeleteFilesEx(const FileMask, ExclusionMask : string);
procedure DeleteTaggedItems;
procedure Extract(aItem : TAbArchiveItem; const NewName : string);
procedure ExtractAt(Index : Integer; const NewName : string);
procedure ExtractFiles(const FileMask : string);
procedure ExtractFilesEx(const FileMask, ExclusionMask : string);
procedure ExtractTaggedItems;
procedure ExtractToStream(const aFileName : string; aStream : TStream);
function FindFile(const aFileName : string): Integer;
function FindItem(aItem : TAbArchiveItem): Integer;
procedure Freshen(aItem : TAbArchiveItem);
procedure FreshenFiles(const FileMask : string);
procedure FreshenFilesEx(const FileMask, ExclusionMask : string);
procedure FreshenTaggedItems;
procedure Load; virtual;
procedure Move(aItem : TAbArchiveItem; const NewStoredPath : string);
virtual;
procedure Replace(aItem : TAbArchiveItem);
procedure Save;
virtual;
procedure TagItems(const FileMask : string);
procedure TestTaggedItems;
procedure UnTagItems(const FileMask : string);
procedure DoDeflateProgress(aPercentDone : integer);
virtual;
procedure DoInflateProgress(aPercentDone : integer);
virtual;
procedure DoSpanningMediaRequest(Sender : TObject; ImageNumber : Integer;
var ImageName : string; var Abort : Boolean); virtual;
public {properties}
property OnProgress : TAbProgressEvent
read FOnProgress write FOnProgress;
property ArchiveName : string
read FArchiveName;
property AutoSave : Boolean
read FAutoSave
write FAutoSave;
property BaseDirectory : string
read FBaseDirectory
write SetBaseDirectory;
property Count : Integer
read GetItemCount;
property DOSMode : Boolean
read FDOSMode
write FDOSMode;
property ExtractOptions : TAbExtractOptions
read FExtractOptions
write FExtractOptions;
property IsDirty : Boolean
read FIsDirty
write FIsDirty;
property ItemList : TAbArchiveList
read FItemList;
property LogFile : string
read FLogFile
write SetLogFile;
property Logging : Boolean
read FLogging
write SetLogging;
property Mode : Word
read FMode;
property Spanned : Boolean
read FSpanned;
property SpanningThreshold : Int64
read GetSpanningThreshold
write SetSpanningThreshold;
property Status : TAbArchiveStatus
read FStatus;
property StoreOptions : TAbStoreOptions
read FStoreOptions
write FStoreOptions;
property SupportsEmptyFolders : Boolean
read GetSupportsEmptyFolders;
property TempDirectory : string
read FTempDir
write FTempDir;
public {events}
property OnProcessItemFailure : TAbArchiveItemFailureEvent
read FOnProcessItemFailure
write FOnProcessItemFailure;
property OnArchiveProgress : TAbArchiveProgressEvent
read FOnArchiveProgress
write FOnArchiveProgress;
property OnArchiveSaveProgress : TAbArchiveProgressEvent
read FOnArchiveSaveProgress
write FOnArchiveSaveProgress;
property OnArchiveItemProgress : TAbArchiveItemProgressEvent
read FOnArchiveItemProgress
write FOnArchiveItemProgress;
property OnConfirmProcessItem : TAbArchiveItemConfirmEvent
read FOnConfirmProcessItem
write FOnConfirmProcessItem;
property OnConfirmOverwrite : TAbConfirmOverwriteEvent
read FOnConfirmOverwrite
write FOnConfirmOverwrite;
property OnConfirmSave : TAbArchiveConfirmEvent
read FOnConfirmSave
write FOnConfirmSave;
property OnLoad : TAbArchiveEvent
read FOnLoad
write FOnLoad;
property OnRequestImage : TAbRequestImageEvent
read FOnRequestImage
write FOnRequestImage;
property OnSave : TAbArchiveEvent
read FOnSave
write FOnSave;
end;
{ ===== TAbExtraField ======================================================= }
type
PAbExtraSubField = ^TAbExtraSubField;
TAbExtraSubField = packed record
ID : Word;
Len : Word;
Data : record end;
end;
TAbExtraField = class
private {fields}
FBuffer : TByteDynArray;
private {methods}
procedure DeleteField(aSubField : PAbExtraSubField);
function FindField(aID : Word; out aSubField : PAbExtraSubField) : Boolean;
function FindNext(var aCurField : PAbExtraSubField) : Boolean;
function GetCount : Integer;
function GetID(aIndex : Integer): Word;
procedure SetBuffer(const aValue : TByteDynArray);
protected {methods}
procedure Changed; virtual;
public {methods}
procedure Assign(aSource : TAbExtraField);
procedure Clear;
procedure CloneFrom(aSource : TAbExtraField; aID : Word);
procedure Delete(aID : Word);
function Get(aID : Word; out aData : Pointer; out aDataSize : Word) : Boolean;
function GetStream(aID : Word; out aStream : TStream): Boolean;
function Has(aID : Word): Boolean;
procedure LoadFromStream(aStream : TStream; aSize : Word);
procedure Put(aID : Word; const aData; aDataSize : Word);
public {properties}
property Count : Integer
read GetCount;
property Buffer : TByteDynArray
read FBuffer
write SetBuffer;
property IDs[aIndex : Integer]: Word
read GetID;
end;
const
AbDefAutoSave = False;
AbDefExtractOptions = [eoCreateDirs];
AbDefStoreOptions = [soStripDrive, soRemoveDots];
AbBufferSize = 32768;
AbLastDisk = -1;
AbLastImage = -1;
implementation
{.$R ABRES.R32}
uses
RTLConsts,
SysUtils,
AbExcept,
AbDfBase,
AbConst,
AbResString;
{ TAbArchiveItem implementation ============================================ }
{ TAbArchiveItem }
constructor TAbArchiveItem.Create;
begin
inherited Create;
FCompressedSize := 0;
FUncompressedSize := 0;
FFileName := '';
FAction := aaNone;
FLastModFileTime := 0;
FLastModFileDate := 0;
end;
{ -------------------------------------------------------------------------- }
destructor TAbArchiveItem.Destroy;
begin
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetCompressedSize : Int64;
begin
Result := FCompressedSize;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetCRC32 : LongInt;
begin
Result := FCRC32;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetDiskPath : string;
begin
Result := ExtractFilePath(DiskFileName);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetExternalFileAttributes : LongWord;
begin
Result := FExternalFileAttributes;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetFileName : string;
begin
Result := FFileName;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetIsDirectory: Boolean;
begin
Result := False;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetIsEncrypted : Boolean;
begin
Result := FIsEncrypted;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetLastModFileTime : Word;
begin
Result := FLastModFileTime;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetLastModFileDate : Word;
begin
Result := FLastModFileDate;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetNativeFileAttributes : LongInt;
begin
{$IFDEF MSWINDOWS}
if IsDirectory then
Result := faDirectory
else
Result := 0;
{$ENDIF}
{$IFDEF UNIX}
if IsDirectory then
Result := AB_FPERMISSION_GENERIC or AB_FPERMISSION_OWNEREXECUTE
else
Result := AB_FPERMISSION_GENERIC;
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetStoredPath : string;
begin
Result := ExtractFilePath(DiskFileName);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetUnCompressedSize : Int64;
begin
Result := FUnCompressedSize;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.MatchesDiskName(const FileMask : string) : Boolean;
var
DiskName, Mask : string;
begin
DiskName := DiskFileName;
AbUnfixName(DiskName);
Mask := FileMask;
AbUnfixName(Mask);
Result := AbFileMatch(DiskName, Mask);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.MatchesStoredName(const FileMask : string) : Boolean;
var
Value : string;
Drive, Dir, Name : string;
begin
Value := FileMask;
AbUnfixName(Value);
AbParseFileName(Value, Drive, Dir, Name);
Value := Dir + Name;
Name := FileName;
AbUnfixName(Name);
if IsDirectory then
Name := ExcludeTrailingPathDelimiter(Name);
Result := AbFileMatch(Name, Value);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.MatchesStoredNameEx(const FileMask : string) : Boolean;
var
I, J: Integer;
MaskPart: string;
begin
Result := True;
I := 1;
while I <= Length(FileMask) do begin
J := I;
while (I <= Length(FileMask)) and (FileMask[I] <> PathSep {';'}) do Inc(I);
MaskPart := Trim(Copy(FileMask, J, I - J));
if (I <= Length(FileMask)) and (FileMask[I] = PathSep {';'}) then Inc(I);
if MatchesStoredName(MaskPart) then Exit;
end;
Result := False;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetCompressedSize(const Value : Int64);
begin
FCompressedSize := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetCRC32(const Value : LongInt);
begin
FCRC32 := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetExternalFileAttributes( Value : LongWord );
begin
FExternalFileAttributes := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetFileName(const Value : string);
begin
FFileName := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetIsEncrypted(Value : Boolean);
begin
FIsEncrypted := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetLastModFileDate(const Value : Word);
begin
FLastModFileDate := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetLastModFileTime(const Value : Word);
begin
FLastModFileTime := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetUnCompressedSize(const Value : Int64);
begin
FUnCompressedSize := Value;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetLastModTimeAsDateTime: TDateTime;
begin
Result := AbDosFileDateToDateTime(LastModFileDate, LastModFileTime);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetLastModTimeAsDateTime(const Value: TDateTime);
var
FileDate : Integer;
begin
FileDate := AbDateTimeToDosFileDate(Value);
LastModFileTime := LongRec(FileDate).Lo;
LastModFileDate := LongRec(FileDate).Hi;
end;
{ -------------------------------------------------------------------------- }
{ TAbArchiveEnumeratorList implementation ================================== }
{ TAbArchiveEnumeratorList }
constructor TAbArchiveListEnumerator.Create(aList: TAbArchiveList);
begin
inherited Create;
FIndex := -1;
FList := aList;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveListEnumerator.GetCurrent: TAbArchiveItem;
begin
Result := FList[FIndex];
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveListEnumerator.MoveNext: Boolean;
begin
Result := FIndex < FList.Count - 1;
if Result then
Inc(FIndex);
end;
{ -------------------------------------------------------------------------- }
{ TAbArchiveList implementation ============================================ }
{ TAbArchiveList }
constructor TAbArchiveList.Create(AOwnsItems: Boolean);
begin
inherited Create;
FList := TList.Create;
FOwnsItems := AOwnsItems;
end;
{ -------------------------------------------------------------------------- }
destructor TAbArchiveList.Destroy;
begin
Clear;
FList.Free;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveList.Add(aItem : TAbArchiveItem) : Integer;
var
H : LongInt;
begin
if FOwnsItems then begin
H := GenerateHash(aItem.FileName);
aItem.NextItem := HashTable[H];
HashTable[H] := aItem;
end;
Result := FList.Add(aItem);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveList.Clear;
var
i : Integer;
begin
if FOwnsItems then
for i := 0 to Count - 1 do
TObject(FList[i]).Free;
FList.Clear;
FillChar(HashTable, SizeOf(HashTable), #0);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveList.Delete(Index: Integer);
var
Look : TAbArchiveItem;
Last : ^TAbArchiveItem;
FN : string;
begin
if FOwnsItems then begin
FN := TAbArchiveItem(FList[Index]).FileName;
Last := @HashTable[GenerateHash(FN)];
Look := Last^;
while Look <> nil do begin
if CompareText(Look.FileName, FN) = 0 then begin
Last^ := Look.NextItem;
Break;
end;
Last := @Look.NextItem;
Look := Last^;
end;
TObject(FList[Index]).Free;
end;
FList.Delete(Index);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveList.Find(const FN : string) : Integer;
var
Look : TAbArchiveItem;
I : Integer;
begin
if FOwnsItems then begin
Look := HashTable[GenerateHash(FN)];
while Look <> nil do begin
if CompareText(Look.FileName, FN) = 0 then begin
Result := FList.IndexOf(Look);
Exit;
end;
Look := Look.NextItem;
end;
end
else begin
for I := 0 to FList.Count - 1 do
if CompareText(Items[I].FileName, FN) = 0 then begin
Result := I;
Exit;
end;
end;
Result := -1;
end;
{ -------------------------------------------------------------------------- }
{$IFOPT Q+}{$DEFINE OVERFLOW_CHECKS_ON}{$Q-}{$ENDIF}
function TAbArchiveList.GenerateHash(const S : string) : LongInt;
var
G : LongInt;
I : Integer;
U : string;
begin
Result := 0;
U := AnsiUpperCase(S);
for I := 1 to Length(U) do begin
Result := (Result shl 4) + Ord(U[I]);
G := LongInt(Result and $F0000000);
if (G <> 0) then
Result := Result xor (G shr 24);
Result := Result and (not G);
end;
Result := Result mod 1021;
end;
{$IFDEF OVERFLOW_CHECKS_ON}{$Q+}{$ENDIF}
{ -------------------------------------------------------------------------- }
function TAbArchiveList.Get(Index : Integer): TAbArchiveItem;
begin
Result := TAbArchiveItem(FList[Index]);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveList.GetCount : Integer;
begin
Result := FList.Count;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveList.GetEnumerator: TAbArchiveListEnumerator;
begin
Result := TAbArchiveListEnumerator.Create(Self);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveList.IsActiveDupe(const FN : string) : Boolean;
var
Look : TAbArchiveItem;
I : Integer;
begin
if FOwnsItems then begin
Look := HashTable[GenerateHash(FN)];
while Look <> nil do begin
if (CompareText(Look.FileName, FN) = 0) and
(Look.Action <> aaDelete) then begin
Result := True;
Exit;
end;
Look := Look.NextItem;
end;
end
else begin
for I := 0 to Count - 1 do
if (CompareText(Items[I].FileName, FN) = 0) and
(Items[I].Action <> aaDelete) then begin
Result := True;
Exit;
end;
end;
Result := False;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveList.Put(Index : Integer; Item : TAbArchiveItem);
var
H : LongInt;
Look : TAbArchiveItem;
Last : ^TAbArchiveItem;
FN : string;
begin
if FOwnsItems then begin
FN := TAbArchiveItem(FList[Index]).FileName;
Last := @HashTable[GenerateHash(FN)];
Look := Last^;
{ Delete old index }
while Look <> nil do begin
if CompareText(Look.FileName, FN) = 0 then begin
Last^ := Look.NextItem;
Break;
end;
Last := @Look.NextItem;
Look := Last^;
end;
{ Free old instance }
TObject(FList[Index]).Free;
{ Add new index }
H := GenerateHash(Item.FileName);
Item.NextItem := HashTable[H];
HashTable[H] := Item;
end;
{ Replace pointer }
FList[Index] := Item;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveList.UpdateHash(aItem: TAbArchiveItem;
const aOldFileName: string);
var
H : LongInt;
Last : ^TAbArchiveItem;
Look : TAbArchiveItem;
begin
if FOwnsItems then begin
{ Remove from old hash position }
Last := @HashTable[GenerateHash(aOldFileName)];
Look := Last^;
while Look <> nil do begin
if Look = aItem then begin
Last^ := Look.NextItem;
Break
end;
Last := @Look.NextItem;
Look := Last^
end;
{ Add to new hash position }
H := GenerateHash(aItem.FileName);
aItem.NextItem := HashTable[H];
HashTable[H] := aItem
end;
end;
{ TAbArchive implementation ================================================ }
{ TAbArchive }
constructor TAbArchive.CreateInit;
begin
inherited Create;
FIsDirty := False;
FAutoSave := False;
FItemList := TAbArchiveList.Create(True);
StoreOptions := [];
ExtractOptions := [];
FStatus := asIdle;
FOnProgress := DoProgress;
BaseDirectory := ExtractFilePath(ParamStr(0));
end;
{ -------------------------------------------------------------------------- }
constructor TAbArchive.Create(const FileName : string; Mode : Word);
{create an archive by opening a filestream on filename with the given mode}
begin
FOwnsStream := True;
CreateFromStream(TFileStream.Create(FileName, Mode), FileName);
FMode := Mode;
end;
{ -------------------------------------------------------------------------- }
constructor TAbArchive.CreateFromStream(aStream : TStream; const aArchiveName : string);
{create an archive based on an existing stream}
begin
CreateInit;
FArchiveName := aArchiveName;
FStream := aStream;
end;
{ -------------------------------------------------------------------------- }
destructor TAbArchive.Destroy;
begin
FItemList.Free;
if FOwnsStream then
FStream.Free;
FLogStream.Free;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.Add(aItem : TAbArchiveItem);
var
Confirm, ItemAdded : Boolean;
begin
ItemAdded := False;
try
CheckValid;
if FItemList.IsActiveDupe(aItem.FileName) then begin
if (soFreshen in StoreOptions) then
Freshen(aItem)
else if (soReplace in StoreOptions) then
Replace(aItem)
else
DoProcessItemFailure(aItem, ptAdd, ecAbbrevia, AbDuplicateName);
Exit;
end;
DoConfirmProcessItem(aItem, ptAdd, Confirm);
if not Confirm then
Exit;
aItem.Action := aaAdd;
FItemList.Add(aItem);
ItemAdded := True;
FIsDirty := True;
if AutoSave then
Save;
finally
if not ItemAdded then
aItem.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.AddFiles(const FileMask : string; SearchAttr : Integer);
{Add files to the archive where the disk filespec matches}
begin
AddFilesEx(FileMask, '', SearchAttr);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.AddFilesEx(const FileMask, ExclusionMask : string;
SearchAttr : Integer);
{Add files matching Filemask except those matching ExclusionMask}
var
PathType : TAbPathType;
IsWild : Boolean;
SaveDir : string;
Mask : string;
MaskF : string;
procedure CreateItems(Wild, Recursing : Boolean);
var
i : Integer;
Files : TStrings;
FilterList : TStringList;
Item : TAbArchiveItem;
begin
FilterList := TStringList.Create;
try
if (MaskF <> '') then
AbFindFilesEx(MaskF, SearchAttr, FilterList, Recursing);
Files := TStringList.Create;
try
AbFindFilesEx(Mask, SearchAttr, Files, Recursing);
if (Files.Count > 0) then
for i := 0 to pred(Files.Count) do
if FilterList.IndexOf(Files[i]) < 0 then
if not Wild then begin
if (Files[i] <> FArchiveName) then begin
Item := CreateItem(Files[i]);
Add(Item);
end;
end else begin
if (AbAddBackSlash(FBaseDirectory) + Files[i]) <> FArchiveName
then begin
Item := CreateItem(Files[i]);
Add(Item);
end;
end;
finally
Files.Free;
end;
finally
FilterList.Free;
end;
end;
begin
if not SupportsEmptyFolders then
SearchAttr := SearchAttr and not faDirectory;
CheckValid;
IsWild := (Pos('*', FileMask) > 0) or (Pos('?', FileMask) > 0);
PathType := AbGetPathType(FileMask);
Mask := FileMask;
AbUnfixName(Mask);
MaskF := ExclusionMask;
AbUnfixName(MaskF);
case PathType of
ptNone, ptRelative :
begin
GetDir(0, SaveDir);
if BaseDirectory <> '' then
ChDir(BaseDirectory);
try
CreateItems(IsWild, soRecurse in StoreOptions);
finally
if BaseDirectory <> '' then
ChDir(SaveDir);
end;
end;
ptAbsolute :
begin
CreateItems(IsWild, soRecurse in StoreOptions);
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.AddFromStream(const NewName : string; aStream : TStream);
{Add an item to the archive directly from a TStream descendant}
var
Confirm : Boolean;
Item : TAbArchiveItem;
PT : TAbProcessType;
begin
Item := CreateItem(NewName);
CheckValid;
PT := ptAdd;
if FItemList.IsActiveDupe(NewName) then begin
if ((soFreshen in StoreOptions) or (soReplace in StoreOptions)) then begin
Item.Free;
Item := FItemList[FItemList.Find(NewName)];
PT := ptReplace;
end else begin
DoProcessItemFailure(Item, ptAdd, ecAbbrevia, AbDuplicateName);
Item.Free;
Exit;
end;
end;
DoConfirmProcessItem(Item, PT, Confirm);
if not Confirm then
Exit;
FInStream := aStream;
Item.Action := aaStreamAdd;
if (PT = ptAdd) then
FItemList.Add(Item);
FIsDirty := True;
Save;
FInStream := nil;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.CheckValid;
begin
if Status = asInvalid then
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.ClearTags;
{Clear all tags from the archive}
var
i : Integer;
begin
if Count > 0 then
for i := 0 to pred(Count) do
TAbArchiveItem(FItemList[i]).Tagged := False;
end;
{ -------------------------------------------------------------------------- }
function TAbArchive.ConfirmPath(Item : TAbArchiveItem; const NewName : string;
out UseName : string) : Boolean;
var
Path : string;
begin
if Item.IsDirectory and not (ExtractOptions >= [eoRestorePath, eoCreateDirs]) then begin
Result := False;
Exit;
end;
if (NewName = '') then begin
UseName := Item.FileName;
AbUnfixName(UseName);
if Item.IsDirectory then
UseName := ExcludeTrailingPathDelimiter(UseName);
if (not (eoRestorePath in ExtractOptions)) then
UseName := ExtractFileName(UseName);
end
else
UseName := NewName;
if (AbGetPathType(UseName) <> ptAbsolute) then
UseName := AbAddBackSlash(BaseDirectory) + UseName;
Path := ExtractFileDir(UseName);
if (Path <> '') and not DirectoryExists(Path) then
if (eoCreateDirs in ExtractOptions) then
AbCreateDirectory(Path)
else
raise EAbNoSuchDirectory.Create;
Result := True;
if not Item.IsDirectory and FileExists(UseName) then
DoConfirmOverwrite(UseName, Result);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.Delete(aItem : TAbArchiveItem);
{delete an item from the archive}
var
Index : Integer;
begin
CheckValid;
Index := FindItem(aItem);
if Index <> -1 then
DeleteAt(Index);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DeleteAt(Index : Integer);
{delete the item at the index from the archive}
var
Confirm : Boolean;
begin
CheckValid;
SaveIfNeeded(FItemList[Index]);
DoConfirmProcessItem(FItemList[Index], ptDelete, Confirm);
if not Confirm then
Exit;
TAbArchiveItem(FItemList[Index]).Action := aaDelete;
FIsDirty := True;
if AutoSave then
Save;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DeleteFiles(const FileMask : string);
{delete all files from the archive that match the file mask}
begin
DeleteFilesEx(FileMask, '');
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DeleteFilesEx(const FileMask, ExclusionMask : string);
{Delete files matching Filemask except those matching ExclusionMask}
var
i : Integer;
begin
CheckValid;
if Count > 0 then begin
for i := pred(Count) downto 0 do begin
with TAbArchiveItem(FItemList[i]) do
if MatchesStoredNameEx(FileMask) then
if not MatchesStoredNameEx(ExclusionMask) then
DeleteAt(i);
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DeleteTaggedItems;
{delete all tagged items from the archive}
var
i : Integer;
begin
CheckValid;
if Count > 0 then begin
for i := pred(Count) downto 0 do begin
with TAbArchiveItem(FItemList[i]) do
if Tagged then
DeleteAt(i);
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoProcessItemFailure(Item : TAbArchiveItem;
ProcessType : TAbProcessType; ErrorClass : TAbErrorClass;
ErrorCode : Integer);
begin
if Assigned(FOnProcessItemFailure) then
FOnProcessItemFailure(Self, Item, ProcessType, ErrorClass, ErrorCode);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoArchiveSaveProgress(Progress : Byte; var Abort : Boolean);
begin
Abort := False;
if Assigned(FOnArchiveSaveProgress) then
FOnArchiveSaveProgress(Self, Progress, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoArchiveProgress(Progress : Byte; var Abort : Boolean);
begin
Abort := False;
if Assigned(FOnArchiveProgress) then
FOnArchiveProgress(Self, Progress, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoArchiveItemProgress(Item : TAbArchiveItem;
Progress : Byte; var Abort : Boolean);
begin
Abort := False;
if Assigned(FOnArchiveItemProgress) then
FOnArchiveItemProgress(Self, Item, Progress, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoConfirmOverwrite(var FileName : string; var Confirm : Boolean);
begin
Confirm := True;
if Assigned(FOnConfirmOverwrite) then
FOnConfirmOverwrite(FileName, Confirm);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoConfirmProcessItem(Item : TAbArchiveItem;
const ProcessType : TAbProcessType; var Confirm : Boolean);
const
ProcessTypeToLogType : array[TAbProcessType] of TAbLogType =
(ltAdd, ltDelete, ltExtract, ltFreshen, ltMove, ltReplace, ltFoundUnhandled);
begin
Confirm := True;
if Assigned(FOnConfirmProcessItem) then
FOnConfirmProcessItem(Self, Item, ProcessType, Confirm);
if (Confirm and FLogging) then
MakeLogEntry(Item.Filename, ProcessTypeToLogType[ProcessType]);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoConfirmSave(var Confirm : Boolean);
begin
Confirm := True;
if Assigned(FOnConfirmSave) then
FOnConfirmSave(Self, Confirm);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoDeflateProgress(aPercentDone: integer);
var
Abort : Boolean;
begin
DoProgress(aPercentDone, Abort);
if Abort then
raise EAbAbortProgress.Create(AbUserAbortS);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoInflateProgress(aPercentDone: integer);
var
Abort : Boolean;
begin
DoProgress(aPercentDone, Abort);
if Abort then
raise EAbAbortProgress.Create(AbUserAbortS);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoLoad;
begin
if Assigned(FOnLoad) then
FOnLoad(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoProgress(Progress : Byte; var Abort : Boolean);
begin
Abort := False;
DoArchiveItemProgress(FCurrentItem, Progress, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoSave;
begin
if Assigned(FOnSave) then
FOnSave(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.Extract(aItem : TAbArchiveItem; const NewName : string);
{extract an item from the archive}
var
Index : Integer;
begin
CheckValid;
Index := FindItem(aItem);
if Index <> -1 then
ExtractAt(Index, NewName);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.ExtractAt(Index : Integer; const NewName : string);
{extract an item from the archive at Index}
var
Confirm : Boolean;
ErrorClass : TAbErrorClass;
ErrorCode : Integer;
UseName : string;
begin
CheckValid;
SaveIfNeeded(FItemList[Index]);
DoConfirmProcessItem(FItemList[Index], ptExtract, Confirm);
if not Confirm then
Exit;
if not ConfirmPath(FItemList[Index], NewName, UseName) then
Exit;
try
FCurrentItem := FItemList[Index];
ExtractItemAt(Index, UseName);
except
on E : Exception do begin
AbConvertException(E, ErrorClass, ErrorCode);
DoProcessItemFailure(FItemList[Index], ptExtract, ErrorClass, ErrorCode);
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.ExtractToStream(const aFileName : string;
aStream : TStream);
{extract an item from the archive at Index directly to a stream}
var
Confirm : Boolean;
ErrorClass : TAbErrorClass;
ErrorCode : Integer;
Index : Integer;
begin
CheckValid;
Index := FindFile(aFileName);
if (Index = -1) then
Exit;
SaveIfNeeded(FItemList[Index]);
DoConfirmProcessItem(FItemList[Index], ptExtract, Confirm);
if not Confirm then
Exit;
FCurrentItem := FItemList[Index];
try
ExtractItemToStreamAt(Index, aStream);
except
on E : Exception do begin
AbConvertException(E, ErrorClass, ErrorCode);
DoProcessItemFailure(FItemList[Index], ptExtract, ErrorClass, ErrorCode);
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.ExtractFiles(const FileMask : string);
{extract all files from the archive that match the mask}
begin
ExtractFilesEx(FileMask, '');
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.ExtractFilesEx(const FileMask, ExclusionMask : string);
{Extract files matching Filemask except those matching ExclusionMask}
var
i : Integer;
Abort : Boolean;
begin
CheckValid;
if Count > 0 then begin
for i := 0 to pred(Count) do begin
with TAbArchiveItem(FItemList[i]) do
if MatchesStoredNameEx(FileMask) and
not MatchesStoredNameEx(ExclusionMask) and
((eoCreateDirs in ExtractOptions) or not IsDirectory) then
ExtractAt(i, '');
DoArchiveProgress(AbPercentage(succ(i), Count), Abort);
if Abort then
raise EAbUserAbort.Create;
end;
DoArchiveProgress(100, Abort);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.ExtractTaggedItems;
{extract all tagged items from the archive}
var
i : Integer;
Abort : Boolean;
begin
CheckValid;
if Count > 0 then begin
for i := 0 to pred(Count) do begin
with TAbArchiveItem(FItemList[i]) do
if Tagged then
ExtractAt(i, '');
DoArchiveProgress(AbPercentage(succ(i), Count), Abort);
if Abort then
raise EAbUserAbort.Create;
end;
DoArchiveProgress(100, Abort);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.TestTaggedItems;
{test all tagged items in the archive}
var
i : Integer;
Abort : Boolean;
begin
CheckValid;
if Count > 0 then begin
for i := 0 to pred(Count) do begin
with TAbArchiveItem(FItemList[i]) do
if Tagged then begin
FCurrentItem := FItemList[i];
TestItemAt(i);
end;
DoArchiveProgress(AbPercentage(succ(i), Count), Abort);
if Abort then
raise EAbUserAbort.Create;
end;
DoArchiveProgress(100, Abort);
end;
end;
{ -------------------------------------------------------------------------- }
function TAbArchive.FindFile(const aFileName : string): Integer;
{find the index of the specified file}
begin
Result := FItemList.Find(aFileName);
end;
{ -------------------------------------------------------------------------- }
function TAbArchive.FindItem(aItem : TAbArchiveItem): Integer;
{find the index of the specified item}
begin
Result := FItemList.Find(aItem.FileName);
end;
{ -------------------------------------------------------------------------- }
function TAbArchive.FixName(const Value : string) : string;
var
lValue: string;
begin
lValue := Value;
{$IFDEF MSWINDOWS}
if DOSMode then begin
{Add the base directory to the filename before converting }
{the file spec to the short filespec format. }
if BaseDirectory <> '' then begin
{Does the filename contain a drive or a leading backslash? }
if not ((Pos(':', lValue) = 2) or (Pos(AbPathDelim, lValue) = 1)) then
{If not, add the BaseDirectory to the filename.}
lValue := AbAddBackSlash(BaseDirectory) + lValue;
end;
lValue := AbGetShortFileSpec(lValue);
end;
{$ENDIF}
{strip drive stuff}
if soStripDrive in StoreOptions then
AbStripDrive(lValue);
{check for a leading backslash}
if lValue[1] = AbPathDelim then
System.Delete(lValue, 1, 1);
if soStripPath in StoreOptions then begin
lValue := ExtractFileName(lValue);
end;
if soRemoveDots in StoreOptions then
AbStripDots(lValue);
Result := lValue;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.Freshen(aItem : TAbArchiveItem);
{freshen the item}
var
Index : Integer;
begin
CheckValid;
Index := FindItem(aItem);
if Index <> -1 then begin
{point existing item at the new file}
if AbGetPathType(aItem.DiskFileName) = ptAbsolute then
FItemList[Index].DiskFileName := aItem.DiskFileName;
FreshenAt(Index);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.FreshenAt(Index : Integer);
{freshen item at index}
var
Confirm : Boolean;
FR : Boolean;
ErrorClass : TAbErrorClass;
ErrorCode : Integer;
begin
CheckValid;
SaveIfNeeded(FItemList[Index]);
GetFreshenTarget(FItemList[Index]);
FR := False;
try
FR := FreshenRequired(FItemList[Index]);
except
on E : Exception do begin
AbConvertException(E, ErrorClass, ErrorCode);
DoProcessItemFailure(FItemList[Index], ptFreshen, ErrorClass, ErrorCode);
end;
end;
if not FR then
Exit;
DoConfirmProcessItem(FItemList[Index], ptFreshen, Confirm);
if not Confirm then
Exit;
TAbArchiveItem(FItemList[Index]).Action := aaFreshen;
FIsDirty := True;
if AutoSave then
Save;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.FreshenFiles(const FileMask : string);
{freshen all items that match the file mask}
begin
FreshenFilesEx(FileMask, '');
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.FreshenFilesEx(const FileMask, ExclusionMask : string);
{freshen all items that match the file mask}
var
i : Integer;
begin
CheckValid;
if Count > 0 then begin
for i := pred(Count) downto 0 do begin
with TAbArchiveItem(FItemList[i]) do
if MatchesStoredNameEx(FileMask) then
if not MatchesStoredNameEx(ExclusionMask) then
FreshenAt(i);
end;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbArchive.FreshenRequired(Item : TAbArchiveItem) : Boolean;
var
FS : TFileStream;
DateTime : LongInt;
FileTime : Word;
FileDate : Word;
Matched : Boolean;
SaveDir : string;
begin
GetDir(0, SaveDir);
if BaseDirectory <> '' then
ChDir(BaseDirectory);
try
FS := TFileStream.Create(Item.DiskFileName,
fmOpenRead or fmShareDenyWrite);
try
DateTime := FileGetDate(FS.Handle);
FileTime := LongRec(DateTime).Lo;
FileDate := LongRec(DateTime).Hi;
Matched := (Item.LastModFileDate = FileDate) and
(Item.LastModFileTime = FileTime) and
(Item.UncompressedSize = FS.Size);
Result := not Matched;
finally
FS.Free;
end;
finally
if BaseDirectory <> '' then
ChDir(SaveDir);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.FreshenTaggedItems;
{freshen all tagged items}
var
i : Integer;
begin
CheckValid;
if Count > 0 then begin
for i := pred(Count) downto 0 do begin
with TAbArchiveItem(FItemList[i]) do
if Tagged then
FreshenAt(i);
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.GetFreshenTarget(Item : TAbArchiveItem);
var
PathType : TAbPathType;
Files : TStrings;
SaveDir : string;
DName : string;
begin
PathType := AbGetPathType(Item.DiskFileName);
if (soRecurse in StoreOptions) and (PathType = ptNone) then begin
GetDir(0, SaveDir);
if BaseDirectory <> '' then
ChDir(BaseDirectory);
try
Files := TStringList.Create;
try
// even if archive supports empty folder we don't have to
// freshen it because there is no data, although, the timestamp
// can be update since the folder was added
AbFindFiles(Item.FileName, faAnyFile and not faDirectory, Files,
True);
if Files.Count > 0 then begin
DName := AbAddBackSlash(BaseDirectory) + Files[0];
AbUnfixName(DName);
Item.DiskFileName := DName;
end
else
Item.DiskFileName := '';
finally
Files.Free;
end;
finally
if BaseDirectory <> '' then
ChDir(SaveDir);
end;
end
else begin
if (BaseDirectory <> '') then
DName := AbAddBackSlash(BaseDirectory) + Item.FileName
else
if AbGetPathType(Item.DiskFileName) = ptAbsolute then
DName := Item.DiskFileName
else
DName := Item.FileName;
AbUnfixName(DName);
Item.DiskFileName := DName;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbArchive.GetSpanningThreshold : Int64;
begin
Result := FSpanningThreshold;
end;
{ -------------------------------------------------------------------------- }
function TAbArchive.GetSupportsEmptyFolders : Boolean;
begin
Result := False;
end;
{ -------------------------------------------------------------------------- }
function TAbArchive.GetItemCount : Integer;
begin
if Assigned(FItemList) then
Result := FItemList.Count
else
Result := 0;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.Load;
{load the archive}
begin
try
LoadArchive;
FStatus := asIdle;
finally
DoLoad;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.MakeLogEntry(const FN: string; LT : TAbLogType);
const
LogTypeRes : array[TAbLogType] of string =
(AbLtAddS, AbLtDeleteS, AbLtExtractS, AbLtFreshenS, AbLtMoveS, AbLtReplaceS,
AbLtStartS, AbUnhandledEntityS);
var
Buf : string;
begin
if Assigned(FLogStream) then begin
Buf := FN + LogTypeRes[LT] + DateTimeToStr(Now) + sLineBreak;
FLogStream.Write(Buf[1], Length(Buf) * SizeOf(Char));
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.Move(aItem : TAbArchiveItem; const NewStoredPath : string);
var
Confirm : Boolean;
Found : Boolean;
i : Integer;
FixedPath, OldFileName: string;
begin
CheckValid;
FixedPath := FixName(NewStoredPath);
Found := False;
if Count > 0 then
for i := 0 to pred(Count) do
if (ItemList[i] <> aItem) and SameText(FixedPath, ItemList[i].FileName) and
(ItemList[i].Action <> aaDelete) then begin
Found := True;
Break;
end;
if Found then begin
DoProcessItemFailure(aItem, ptMove, ecAbbrevia, AbDuplicateName);
{even if something gets done in the AddItemFailure, we don't
want to continue...}
Exit;
end;
SaveIfNeeded(aItem);
DoConfirmProcessItem(aItem, ptMove, Confirm);
if not Confirm then
Exit;
OldFileName := aItem.FileName;
aItem.FileName := FixedPath;
aItem.Action := aaMove;
ItemList.UpdateHash(aItem, OldFileName);
FIsDirty := True;
if AutoSave then
Save;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.Replace(aItem : TAbArchiveItem);
{replace the item}
var
Index : Integer;
begin
CheckValid;
Index := FindItem(aItem);
if Index <> -1 then begin
{point existing item at the new file}
if AbGetPathType(aItem.DiskFileName) = ptAbsolute then
FItemList[Index].DiskFileName := aItem.DiskFileName;
ReplaceAt(Index);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.ReplaceAt(Index : Integer);
{replace item at Index}
var
Confirm : Boolean;
begin
CheckValid;
SaveIfNeeded(FItemList[Index]);
GetFreshenTarget(FItemList[Index]);
DoConfirmProcessItem(FItemList[Index], ptReplace, Confirm);
if not Confirm then
Exit;
TAbArchiveItem(FItemList[Index]).Action := aaReplace;
FIsDirty := True;
if AutoSave then
Save;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.Save;
{save the archive}
var
Confirm : Boolean;
begin
if Status = asInvalid then
Exit;
if (not FIsDirty) and (Count > 0) then
Exit;
DoConfirmSave(Confirm);
if not Confirm then
Exit;
SaveArchive;
FIsDirty := False;
DoSave;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.SaveIfNeeded(aItem : TAbArchiveItem);
begin
if (aItem.Action <> aaNone) then
Save;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.SetBaseDirectory(Value : string);
begin
if (Value <> '') then
if Value[Length(Value)] = AbPathDelim then
if (Length(Value) > 1) and (Value[Length(Value) - 1] <> ':') then
System.Delete(Value, Length(Value), 1);
if (Length(Value) = 0) or DirectoryExists(Value) then
FBaseDirectory := Value
else
raise EAbNoSuchDirectory.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.SetSpanningThreshold( Value : Int64 );
begin
FSpanningThreshold := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.SetLogFile(const Value : string);
begin
FLogFile := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.SetLogging(Value : Boolean);
begin
FLogging := Value;
if Assigned(FLogStream) then begin
FLogStream.Free;
FLogStream := nil;
end;
if FLogging and (FLogFile <> '') then begin
try
FLogStream := TFileStream.Create(FLogFile, fmCreate or fmOpenWrite);
MakeLogEntry(FArchiveName, ltStart);
except
raise EAbException.Create(AbLogCreateErrorS);
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.TagItems(const FileMask : string);
{tag all items that match the mask}
var
i : Integer;
begin
if Count > 0 then
for i := 0 to pred(Count) do
with TAbArchiveItem(FItemList[i]) do begin
if MatchesStoredNameEx(FileMask) then
Tagged := True;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.UnTagItems(const FileMask : string);
{clear tags for all items that match the mask}
var
i : Integer;
begin
if Count > 0 then
for i := 0 to pred(Count) do
with TAbArchiveItem(FItemList[i]) do begin
if MatchesStoredNameEx(FileMask) then
Tagged := False;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.DoSpanningMediaRequest(Sender: TObject;
ImageNumber: Integer; var ImageName: string; var Abort: Boolean);
begin
raise EAbSpanningNotSupported.Create;
end;
{ -------------------------------------------------------------------------- }
{ TAbExtraField implementation ============================================= }
procedure TAbExtraField.Assign(aSource : TAbExtraField);
begin
SetBuffer(aSource.Buffer);
end;
{ -------------------------------------------------------------------------- }
procedure TAbExtraField.Changed;
begin
// No-op
end;
{ -------------------------------------------------------------------------- }
procedure TAbExtraField.Clear;
begin
FBuffer := nil;
Changed;
end;
{ -------------------------------------------------------------------------- }
procedure TAbExtraField.CloneFrom(aSource : TAbExtraField; aID : Word);
var
Data : Pointer;
DataSize : Word;
begin
if aSource.Get(aID, Data, DataSize) then
Put(aID, Data, DataSize)
else Delete(aID);
end;
{ -------------------------------------------------------------------------- }
procedure TAbExtraField.Delete(aID : Word);
var
SubField : PAbExtraSubField;
begin
if FindField(aID, SubField) then begin
DeleteField(SubField);
Changed;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbExtraField.DeleteField(aSubField : PAbExtraSubField);
var
Len, Offset : Integer;
begin
Len := SizeOf(TAbExtraSubField) + aSubField.Len;
Offset := PtrInt(aSubField) - PtrInt(Pointer(FBuffer));
if Offset + Len < Length(FBuffer) then
Move(FBuffer[Offset + Len], aSubField^, Length(FBuffer) - Offset - Len);
SetLength(FBuffer, Length(FBuffer) - Len);
end;
{ -------------------------------------------------------------------------- }
function TAbExtraField.FindField(aID : Word;
out aSubField : PAbExtraSubField) : Boolean;
begin
Result := False;
aSubField := nil;
while FindNext(aSubField) do
if aSubField.ID = aID then begin
Result := True;
Break;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbExtraField.FindNext(var aCurField : PAbExtraSubField) : Boolean;
var
BytesLeft : Integer;
begin
if aCurField = nil then begin
aCurField := PAbExtraSubField(FBuffer);
BytesLeft := Length(FBuffer);
end
else begin
BytesLeft := Length(FBuffer) -
Integer(PtrInt(aCurField) - PtrInt(Pointer(FBuffer))) -
SizeOf(TAbExtraSubField) - aCurField.Len;
aCurField := Pointer(PtrInt(aCurField) + aCurField.Len + SizeOf(TAbExtraSubField));
end;
Result := (BytesLeft >= SizeOf(TAbExtraSubField));
if Result and (BytesLeft < SizeOf(TAbExtraSubField) + aCurField.Len) then
aCurField.Len := BytesLeft - SizeOf(TAbExtraSubField);
end;
{ -------------------------------------------------------------------------- }
function TAbExtraField.Get(aID : Word; out aData : Pointer;
out aDataSize : Word) : Boolean;
var
SubField : PAbExtraSubField;
begin
Result := FindField(aID, SubField);
if Result then begin
aData := @SubField.Data;
aDataSize := SubField.Len;
end
else begin
aData := nil;
aDataSize := 0;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbExtraField.GetCount : Integer;
var
SubField : PAbExtraSubField;
begin
Result := 0;
SubField := nil;
while FindNext(SubField) do
Inc(Result);
end;
{ -------------------------------------------------------------------------- }
function TAbExtraField.GetID(aIndex : Integer): Word;
var
i: Integer;
SubField : PAbExtraSubField;
begin
i := 0;
SubField := nil;
while FindNext(SubField) do
if i = aIndex then begin
Result := SubField.ID;
Exit;
end
else
Inc(i);
raise EListError.CreateFmt(SListIndexError, [aIndex]);
end;
{ -------------------------------------------------------------------------- }
function TAbExtraField.GetStream(aID : Word; out aStream : TStream): Boolean;
var
Data: Pointer;
DataSize: Word;
begin
Result := Get(aID, Data, DataSize);
if Result then begin
aStream := TMemoryStream.Create;
aStream.WriteBuffer(Data^, DataSize);
aStream.Position := 0;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbExtraField.Has(aID : Word): Boolean;
var
SubField : PAbExtraSubField;
begin
Result := FindField(aID, SubField);
end;
{ -------------------------------------------------------------------------- }
procedure TAbExtraField.LoadFromStream(aStream : TStream; aSize : Word);
begin
SetLength(FBuffer, aSize);
if aSize > 0 then
aStream.ReadBuffer( FBuffer[0], aSize);
end;
{ -------------------------------------------------------------------------- }
procedure TAbExtraField.Put(aID : Word; const aData; aDataSize : Word);
var
Offset : Cardinal;
SubField : PAbExtraSubField;
begin
if FindField(aID, SubField) then begin
if SubField.Len = aDataSize then begin
Move(aData, SubField.Data, aDataSize);
Changed;
Exit;
end
else DeleteField(SubField);
end;
Offset := Length(FBuffer);
SetLength(FBuffer, Length(FBuffer) + SizeOf(TAbExtraSubField) + aDataSize);
SubField := PAbExtraSubField(@FBuffer[Offset]);
SubField.ID := aID;
SubField.Len := aDataSize;
Move(aData, SubField.Data, aDataSize);
Changed;
end;
{ -------------------------------------------------------------------------- }
procedure TAbExtraField.SetBuffer(const aValue : TByteDynArray);
begin
SetLength(FBuffer, Length(aValue));
if Length(FBuffer) > 0 then
Move(aValue[0], FBuffer[0], Length(FBuffer));
Changed;
end;
{ -------------------------------------------------------------------------- }
{ ========================================================================== }
{ TAbArchiveStreamHelper }
constructor TAbArchiveStreamHelper.Create(AStream: TStream);
begin
if Assigned(AStream) then
FStream := AStream
else
raise Exception.Create('nil stream');
end;
end.
================================================
FILE: lib/abbrevia/source/AbBase.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbBase.pas *}
{*********************************************************}
{* ABBREVIA: Base component class *}
{*********************************************************}
unit AbBase;
{$I AbDefine.inc}
interface
uses
Classes;
type
TAbBaseComponent = class(TComponent)
protected {methods}
function GetVersion : string;
procedure SetVersion(const Value : string);
protected {properties}
property Version : string
read GetVersion
write SetVersion
stored False;
end;
implementation
uses
AbConst;
{ -------------------------------------------------------------------------- }
function TAbBaseComponent.GetVersion : string;
begin
Result := AbVersionS;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseComponent.SetVersion(const Value : string);
begin
{NOP}
end;
end.
================================================
FILE: lib/abbrevia/source/AbBitBkt.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbBitBkt.pas *}
{*********************************************************}
{* ABBREVIA: Bit bucket memory stream class *}
{*********************************************************}
unit AbBitBkt;
{$I AbDefine.inc}
interface
uses
Classes,
AbUtils;
type
TAbBitBucketStream = class(TStream)
private
FBuffer : {$IFDEF UNICODE}PByte{$ELSE}PAnsiChar{$ENDIF};
FBufSize : longint;
FBufPosn : longint;
FPosn : Int64;
FSize : Int64;
FTail : longint;
protected
public
constructor Create(aBufSize : cardinal);
destructor Destroy; override;
function Read(var Buffer; Count : Longint) : Longint; override;
function Write(const Buffer; Count : Longint) : Longint; override;
function Seek(const Offset : Int64; Origin : TSeekOrigin) : Int64; override;
procedure ForceSize(aSize : Int64);
end;
implementation
uses
Math, SysUtils, AbExcept;
{Notes: The buffer is a circular queue without a head pointer; FTail
is where data is next going to be written and it wraps
indescriminately. The buffer can never be empty--it is always
full (initially it is full of binary zeros.
The class is designed to act as a bit bucket for the test
feature of Abbrevia's zip code; it is not intended as a
complete class with many possible applications. It is designed
to be written to in a steady progression with some reading
back in the recently written stream (the buffer size details
how far back the Seek method will work). Seeking outside this
buffer will result in exceptions being generated.
For testing deflated files, the buffer size should be 32KB,
for imploded files, either 8KB or 4KB. The Create constructor
limits the buffer size to these values.}
{===TAbBitBucketStream===============================================}
constructor TAbBitBucketStream.Create(aBufSize : cardinal);
begin
inherited Create;
if (aBufSize <> 4096) and
(aBufSize <> 8192) and
(aBufSize <> 32768) then
FBufSize := 32768
else
FBufSize := aBufSize;
{add a 1KB leeway}
inc(FBufSize, 1024);
GetMem(FBuffer, FBufSize);
end;
{--------}
destructor TAbBitBucketStream.Destroy;
begin
if (FBuffer <> nil) then
FreeMem(FBuffer, FBufSize);
inherited Destroy;
end;
{--------}
procedure TAbBitBucketStream.ForceSize(aSize : Int64);
begin
FSize := aSize;
end;
{--------}
function TAbBitBucketStream.Read(var Buffer; Count : Longint) : Longint;
var
Chunk2Size : longint;
Chunk1Size : longint;
OutBuffer : PByte;
begin
OutBuffer := @Buffer;
{we cannot read more bytes than there is buffer}
if (Count > FBufSize) then
raise EAbBBSReadTooManyBytes.Create(Count);
{calculate the size of the chunks}
if (FBufPosn <= FTail) then begin
Chunk1Size := FTail - FBufPosn;
if (Chunk1Size > Count) then
Chunk1Size := Count;
Chunk2Size := 0;
end
else begin
Chunk1Size := FBufSize - FBufPosn;
if (Chunk1Size > Count) then begin
Chunk1Size := Count;
Chunk2Size := 0;
end
else begin
Chunk2Size := FTail;
if (Chunk2Size > (Count - Chunk1Size)) then
Chunk2Size := Count - Chunk1Size;
end
end;
{we cannot read more bytes than there are available}
if (Count > (Chunk1Size + Chunk2Size)) then
raise EAbBBSReadTooManyBytes.Create(Count);
{perform the read}
if (Chunk1Size > 0) then begin
Move(FBuffer[FBufPosn], OutBuffer^, Chunk1Size);
inc(FBufPosn, Chunk1Size);
inc(FPosn, Chunk1Size);
end;
if (Chunk2Size > 0) then begin
{we've wrapped}
Move(FBuffer[0], PByte(PtrInt(OutBuffer) + PtrInt(Chunk1Size))^, Chunk2Size);
FBufPosn := Chunk2Size;
inc(FPosn, Chunk2Size);
end;
Result := Count;
end;
{--------}
function TAbBitBucketStream.Write(const Buffer; Count : Longint) : Longint;
var
Chunk2Size : longint;
Chunk1Size : longint;
InBuffer : PByte;
Overage : longint;
begin
Result := Count;
InBuffer := @Buffer;
{we cannot write more bytes than there is buffer}
while Count > FBufSize do begin
Overage := Min(FBufSize, Count - FBufSize);
Write(InBuffer^, Overage);
Inc(PtrInt(InBuffer), Overage);
Dec(Count, Overage);
end;
{calculate the size of the chunks}
Chunk1Size := FBufSize - FTail;
if (Chunk1Size > Count) then begin
Chunk1Size := Count;
Chunk2Size := 0;
end
else begin
Chunk2Size := Count - Chunk1Size;
end;
{write the first chunk}
if (Chunk1Size > 0) then begin
Move(InBuffer^, FBuffer[FTail], Chunk1Size);
inc(FTail, Chunk1Size);
end;
{if the second chunk size is not zero, write the second chunk; note
that we have wrapped}
if (Chunk2Size > 0) then begin
Move(PByte(PtrInt(InBuffer) + PtrInt(Chunk1Size))^, FBuffer[0], Chunk2Size);
FTail := Chunk2Size;
end;
{the stream size and position have changed}
inc(FSize, Count);
FPosn := FSize;
FBufPosn := FTail;
end;
{--------}
function TAbBitBucketStream.Seek(const Offset : Int64; Origin : TSeekOrigin): Int64;
var
Posn : Int64;
BytesBack : longint;
begin
{calculate the new position}
case Origin of
soBeginning :
Posn := Offset;
soCurrent :
Posn := FPosn + Offset;
soEnd :
if (Offset = 0) then begin
{special case: position at end of stream}
FBufPosn := FTail;
FPosn := FSize;
Result := FSize;
Exit;
end
else begin
Posn := FSize + Offset;
end;
else
raise EAbBBSInvalidOrigin.Create;
end;
{calculate whether the new position is within the buffer; if not,
raise exception}
if (Posn > FSize) or
(Posn <= (FSize - FBufSize)) then
raise EAbBBSSeekOutsideBuffer.Create;
{set the internal fields for the new position}
FPosn := Posn;
BytesBack := FSize - Posn;
if (BytesBack <= FTail) then
FBufPosn := FTail - BytesBack
else
FBufPosn := longint(FTail) + FBufSize - BytesBack;
{return the new position}
Result := Posn;
end;
{====================================================================}
end.
================================================
FILE: lib/abbrevia/source/AbBrowse.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbBrowse.pas *}
{*********************************************************}
{* ABBREVIA: Base Browser Component *}
{*********************************************************}
unit AbBrowse;
{$I AbDefine.inc}
interface
uses
Classes,
AbBase,
AbUtils,
AbArcTyp;
type
IAbProgressMeter = interface
['{4B766704-FD20-40BF-BA40-2EC2DD77B178}']
procedure DoProgress(Progress : Byte);
procedure Reset;
end;
TAbBaseBrowser = class(TAbBaseComponent)
public
FArchive : TAbArchive;
protected {private}
FSpanningThreshold : Longint;
FItemProgressMeter : IAbProgressMeter;
FArchiveProgressMeter : IAbProgressMeter;
FBaseDirectory : string;
FFileName : string;
FLogFile : string;
FLogging : Boolean;
FOnArchiveProgress : TAbArchiveProgressEvent;
FOnArchiveItemProgress : TAbArchiveItemProgressEvent;
FOnChange : TNotifyEvent;
FOnConfirmProcessItem : TAbArchiveItemConfirmEvent;
FOnLoad : TAbArchiveEvent;
FOnProcessItemFailure : TAbArchiveItemFailureEvent;
FOnRequestImage : TAbRequestImageEvent;
FTempDirectory : string;
{ detected compression type }
FArchiveType : TAbArchiveType;
FForceType : Boolean;
protected {private methods}
function GetCount : Integer;
function GetItem(Value : Longint) : TAbArchiveItem;
function GetSpanned : Boolean;
function GetStatus : TAbArchiveStatus;
procedure ResetMeters; virtual;
procedure SetArchiveProgressMeter(const Value: IAbProgressMeter);
procedure SetCompressionType(const Value: TAbArchiveType);
procedure SetBaseDirectory(const Value : string);
procedure SetItemProgressMeter(const Value: IAbProgressMeter);
procedure SetSpanningThreshold(Value : Longint);
procedure SetLogFile(const Value : string);
procedure SetLogging(Value : Boolean);
procedure SetTempDirectory(const Value : string);
procedure Loaded; override;
procedure Notification(Component: TComponent;
Operation: TOperation); override;
protected {virtual methods}
procedure DoArchiveItemProgress(Sender : TObject;
Item : TAbArchiveItem;
Progress : Byte;
var Abort : Boolean); virtual;
procedure DoArchiveProgress(Sender : TObject;
Progress : Byte;
var Abort : Boolean); virtual;
procedure DoChange; virtual;
procedure DoConfirmProcessItem(Sender : TObject;
Item : TAbArchiveItem;
ProcessType : TAbProcessType;
var Confirm : Boolean); virtual;
procedure DoLoad(Sender : TObject); virtual;
procedure DoProcessItemFailure(Sender : TObject;
Item : TAbArchiveItem;
ProcessType : TAbProcessType;
ErrorClass : TAbErrorClass;
ErrorCode : Integer); virtual;
procedure SetOnRequestImage(Value : TAbRequestImageEvent); virtual;
procedure InitArchive; virtual;
{This method must be defined in descendent classes}
procedure SetFileName(const aFileName : string); virtual; abstract;
protected {properties}
property Archive : TAbArchive
read FArchive;
property ArchiveProgressMeter : IAbProgressMeter
read FArchiveProgressMeter
write SetArchiveProgressMeter;
property BaseDirectory : string
read FBaseDirectory
write SetBaseDirectory;
property FileName : string
read FFileName
write SetFileName;
property SpanningThreshold : Longint
read FSpanningThreshold
write SetSpanningThreshold
default 0;
property ItemProgressMeter : IAbProgressMeter
read FItemProgressMeter
write SetItemProgressMeter;
property LogFile : string
read FLogFile
write SetLogFile;
property Logging : Boolean
read FLogging
write SetLogging
default False;
property Spanned : Boolean
read GetSpanned;
property TempDirectory : string
read FTempDirectory
write SetTempDirectory;
protected {events}
property OnArchiveProgress : TAbArchiveProgressEvent
read FOnArchiveProgress
write FOnArchiveProgress;
property OnArchiveItemProgress : TAbArchiveItemProgressEvent
read FOnArchiveItemProgress
write FOnArchiveItemProgress;
property OnConfirmProcessItem : TAbArchiveItemConfirmEvent
read FOnConfirmProcessItem
write FOnConfirmProcessItem;
property OnProcessItemFailure : TAbArchiveItemFailureEvent
read FOnProcessItemFailure
write FOnProcessItemFailure;
property OnRequestImage : TAbRequestImageEvent
read FOnRequestImage
write SetOnRequestImage;
public {methods}
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure ClearTags;
{Clear all tags from the archive}
function FindItem(aItem : TAbArchiveItem) : Integer;
function FindFile(const aFileName : string) : Integer;
procedure TagItems(const FileMask : string);
{tag all items that match the mask}
procedure UnTagItems(const FileMask : string);
{clear tags for all items that match the mask}
procedure CloseArchive;
{closes the archive by setting FileName to ''}
procedure OpenArchive(const aFileName : string);
{opens the archive}
public {properties}
property Count : Integer
read GetCount;
property Items[Index : Integer] : TAbArchiveItem
read GetItem; default;
property Status : TAbArchiveStatus
read GetStatus;
property ArchiveType : TAbArchiveType
read FArchiveType
write SetCompressionType
default atUnknown;
property ForceType : Boolean
read FForceType
write FForceType
default False;
public {events}
property OnChange : TNotifyEvent
read FOnChange
write FOnChange;
property OnLoad : TAbArchiveEvent
read FOnLoad
write FOnLoad;
end;
function AbDetermineArcType(const FN : string; AssertType : TAbArchiveType) : TAbArchiveType; overload;
function AbDetermineArcType(aStream: TStream) : TAbArchiveType; overload;
implementation
uses
SysUtils,
AbExcept,
{$IFDEF MSWINDOWS}
AbCabTyp,
{$ENDIF}
AbZipTyp,
AbTarTyp,
AbGzTyp,
AbBzip2Typ;
{ TAbBaseBrowser implementation ======================================= }
{ -------------------------------------------------------------------------- }
constructor TAbBaseBrowser.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
FLogFile := '';
FLogging := False;
FSpanningThreshold := 0;
FArchiveType := atUnknown;
FForceType := False;
end;
{ -------------------------------------------------------------------------- }
destructor TAbBaseBrowser.Destroy;
begin
FArchive.Free;
FArchive := nil;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.ClearTags;
{Clear all tags from the archive}
begin
if Assigned(FArchive) then
FArchive.ClearTags
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.CloseArchive;
{closes the archive by setting FileName to ''}
begin
if FFileName <> '' then
FileName := '';
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.DoArchiveItemProgress(Sender : TObject;
Item : TAbArchiveItem;
Progress : Byte;
var Abort : Boolean);
begin
Abort := False;
if Assigned(FItemProgressMeter) then
FItemProgressMeter.DoProgress(Progress);
if Assigned(FOnArchiveItemProgress) then
FOnArchiveItemProgress(Self, Item, Progress, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.DoArchiveProgress(Sender : TObject;
Progress : Byte;
var Abort : Boolean);
begin
Abort := False;
if Assigned(FArchiveProgressMeter) then
FArchiveProgressMeter.DoProgress(Progress);
if Assigned(FOnArchiveProgress) then
FOnArchiveProgress(Self, Progress, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.DoChange;
begin
if Assigned(FOnChange) then begin
FOnChange(Self);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.DoConfirmProcessItem(Sender : TObject;
Item : TAbArchiveItem;
ProcessType : TAbProcessType;
var Confirm : Boolean);
begin
Confirm := True;
if Assigned(FItemProgressMeter) then
FItemProgressMeter.Reset;
if Assigned(FOnConfirmProcessItem) then
FOnConfirmProcessItem(Self, Item, ProcessType, Confirm);
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.DoLoad(Sender : TObject);
begin
if Assigned(FOnLoad) then
FOnLoad(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.DoProcessItemFailure(Sender : TObject;
Item : TAbArchiveItem;
ProcessType : TAbProcessType;
ErrorClass : TAbErrorClass;
ErrorCode : Integer);
begin
if Assigned(FOnProcessItemFailure) then
FOnProcessItemFailure(Self, Item, ProcessType, ErrorClass, ErrorCode);
end;
{ -------------------------------------------------------------------------- }
function TAbBaseBrowser.FindItem(aItem : TAbArchiveItem) : Integer;
begin
if Assigned(FArchive) then
Result := FArchive.FindItem(aItem)
else
Result := -1;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseBrowser.FindFile(const aFileName : string) : Integer;
begin
if Assigned(FArchive) then
Result := FArchive.FindFile(aFileName)
else
Result := -1;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseBrowser.GetSpanned : Boolean;
begin
if Assigned(FArchive) then
Result := FArchive.Spanned
else
Result := False;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseBrowser.GetStatus : TAbArchiveStatus;
begin
if Assigned(FArchive) then
Result := FArchive.Status
else
Result := asInvalid;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseBrowser.GetCount : Integer;
begin
if Assigned(FArchive) then
Result := FArchive.Count
else
Result := 0;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseBrowser.GetItem(Value : Longint) : TAbArchiveItem;
begin
if Assigned(FArchive) then
Result := FArchive.ItemList[Value]
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.InitArchive;
begin
ResetMeters;
if Assigned(FArchive) then begin
{properties}
FArchive.SpanningThreshold := FSpanningThreshold;
FArchive.LogFile := FLogFile;
FArchive.Logging := FLogging;
FArchive.TempDirectory := FTempDirectory;
SetBaseDirectory(FBaseDirectory);
{events}
FArchive.OnArchiveProgress := DoArchiveProgress;
FArchive.OnArchiveItemProgress := DoArchiveItemProgress;
FArchive.OnConfirmProcessItem := DoConfirmProcessItem;
FArchive.OnLoad := DoLoad;
FArchive.OnProcessItemFailure := DoProcessItemFailure;
FArchive.OnRequestImage := FOnRequestImage;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.Loaded;
begin
inherited Loaded;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.Notification(Component: TComponent;
Operation: TOperation);
begin
inherited Notification(Component, Operation);
if (Operation = opRemove) then begin
if Assigned(ItemProgressMeter) and Component.IsImplementorOf(ItemProgressMeter) then
ItemProgressMeter := nil;
if Assigned(ArchiveProgressMeter) and Component.IsImplementorOf(ArchiveProgressMeter) then
ArchiveProgressMeter := nil;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.OpenArchive(const aFileName : string);
{opens the archive}
begin
FileName := AFileName;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.ResetMeters;
begin
if Assigned(FArchiveProgressMeter) then
FArchiveProgressMeter.Reset;
if Assigned(FItemProgressMeter) then
FItemProgressMeter.Reset;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.SetBaseDirectory(const Value : string);
begin
if Assigned(FArchive) then begin
FArchive.BaseDirectory := Value;
FBaseDirectory := FArchive.BaseDirectory;
end else
FBaseDirectory := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.SetSpanningThreshold(Value : Longint);
begin
FSpanningThreshold := Value;
if Assigned(FArchive) then
FArchive.SpanningThreshold := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.SetLogFile(const Value : string);
begin
FLogFile := Value;
if (csDesigning in ComponentState) then
Exit;
if Assigned(FArchive) then
FArchive.LogFile := Value;
SetLogging(Value <> '');
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.SetLogging(Value : Boolean);
begin
FLogging := Value;
if (csDesigning in ComponentState) then
Exit;
if Assigned(FArchive) then
FArchive.Logging:= Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.SetOnRequestImage(Value : TAbRequestImageEvent);
begin
FOnRequestImage := Value;
if Assigned(FArchive) then
FArchive.OnRequestImage := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.SetTempDirectory(const Value : string);
begin
FTempDirectory := Value;
if Assigned(FArchive) then
FArchive.TempDirectory := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.TagItems(const FileMask : string);
{tag all items that match the mask}
begin
if Assigned(FArchive) then
FArchive.TagItems(FileMask)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.UnTagItems(const FileMask : string);
{clear tags for all items that match the mask}
begin
if Assigned(FArchive) then
FArchive.UnTagItems(FileMask)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.SetCompressionType(const Value: TAbArchiveType);
begin
if not Assigned(FArchive) or (Status <> asInvalid) then
FArchiveType := Value
else
raise EAbArchiveBusy.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.SetArchiveProgressMeter(const Value: IAbProgressMeter);
begin
ReferenceInterface(FArchiveProgressMeter, opRemove);
FArchiveProgressMeter := Value;
ReferenceInterface(FArchiveProgressMeter, opInsert);
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseBrowser.SetItemProgressMeter(const Value: IAbProgressMeter);
begin
ReferenceInterface(FItemProgressMeter, opRemove);
FItemProgressMeter := Value;
ReferenceInterface(FItemProgressMeter, opInsert);
end;
{ -------------------------------------------------------------------------- }
function AbDetermineArcType(const FN : string; AssertType : TAbArchiveType) : TAbArchiveType;
var
Ext : string;
FS : TFileStream;
begin
Result := AssertType;
if Result = atUnknown then begin
{ Guess archive type based on it's extension }
Ext := UpperCase(ExtractFileExt(FN));
if (Ext = '.ZIP') or (Ext = '.JAR') then
Result := atZip;
if (Ext = '.EXE') then
Result := atSelfExtZip;
if (Ext = '.TAR') then
Result := atTar;
if (Ext = '.GZ') then
Result := atGzip;
if (Ext = '.TGZ') then
Result := atGzippedTar;
if (Ext = '.CAB') then
Result := atCab;
if (Ext = '.BZ2') then
Result := atBzip2;
if (Ext = '.TBZ') then
Result := atBzippedTar;
end;
{$IFNDEF MSWINDOWS}
if Result = atCab then
Result := atUnknown;
{$ENDIF}
if FileExists(FN) and (AbFileGetSize(FN) > 0) then begin
{ If the file doesn't exist (or is empty) presume to make one, otherwise
guess or verify the contents }
FS := TFileStream.Create(FN, fmOpenRead or fmShareDenyNone);
try
if Result = atUnknown then
Result := AbDetermineArcType(FS)
else begin
case Result of
atZip : begin
Result := VerifyZip(FS);
end;
atSelfExtZip : begin
Result := VerifySelfExtracting(FS);
end;
atTar : begin
Result := VerifyTar(FS);
end;
atGzip, atGzippedTar: begin
Result := VerifyGzip(FS);
end;
{$IFDEF MSWINDOWS}
atCab : begin
Result := VerifyCab(FS);
end;
{$ENDIF}
atBzip2, atBzippedTar: begin
Result := VerifyBzip2(FS);
end;
end;
end;
finally
FS.Free;
end;
end;
end;
{ -------------------------------------------------------------------------- }
function AbDetermineArcType(aStream: TStream): TAbArchiveType;
begin
{ VerifyZip returns true for self-extracting zips too, so test those first }
Result := VerifySelfExtracting(aStream);
if Result = atUnknown then
Result := VerifyZip(aStream);
if Result = atUnknown then
Result := VerifyTar(aStream);
if Result = atUnknown then
Result := VerifyGzip(aStream);
if Result = atUnknown then
Result := VerifyBzip2(aStream);
{$IFDEF MSWINDOWS}
if Result = atUnknown then
Result := VerifyCab(aStream);
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbBseCLX.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbBaseCLX.pas *}
{*********************************************************}
{* ABBREVIA: Base component class (CLX) *}
{*********************************************************}
unit AbBseCLX;
{$I AbDefine.inc}
interface
uses
Classes,
{$IFNDEF BuildingStub}
QControls,
{$ENDIF BuildingStub}
AbConst,
AbBase;
{$IFNDEF BuildingStub}
type
TAbBaseWinControl = class(TWidgetControl);
{$ENDIF BuildingStub}
implementation
end.
================================================
FILE: lib/abbrevia/source/AbBseVCL.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbBaseVCL.pas *}
{*********************************************************}
{* ABBREVIA: Base component class (VCL) *}
{*********************************************************}
unit AbBseVCL;
{$I AbDefine.inc}
interface
uses
Classes
{$IFNDEF BuildingStub}
, Controls
{$ENDIF BuildingStub}
;
{$IFNDEF BuildingStub}
type
TAbBaseWinControl = class(TWinControl);
{$ENDIF BuildingStub}
implementation
end.
================================================
FILE: lib/abbrevia/source/AbBzip2.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* This program, "bzip2", the associated library "libbzip2", and all
* documentation, are copyright (C) 1996-2007 Julian R Seward. All
* rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. The origin of this software must not be misrepresented; you must
* not claim that you wrote the original software. If you use this
* software in a product, an acknowledgment in the product
* documentation would be appreciated but is not required.
*
* 3. Altered source versions must be plainly marked as such, and must
* not be misrepresented as being the original software.
*
* 4. The name of the author may not be used to endorse or promote
* products derived from this software without specific prior written
* permission.
*
* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
* GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* Julian Seward, jseward@bzip.org
* bzip2/libbzip2 version 1.0.5 of 10 December 2007
*
* Pascal wrapper created by Edison Mera, version 1.04
* http://edisonlife.homelinux.com/
*
* Dynamic and runtime linking and Win64/OS X/Linux support by Craig Peterson
* http://tpabbrevia.sourceforge.net/
* ***** END LICENSE BLOCK ***** *)
unit AbBzip2;
{$I AbDefine.inc}
interface
uses
SysUtils, Classes;
type
TAlloc = function(opaque: Pointer; Items, Size: Integer): Pointer; cdecl;
TFree = procedure(opaque, Block: Pointer); cdecl;
// Internal structure. Ignore.
TBZStreamRec = record
next_in: PByte; // next input byte
avail_in: Integer; // number of bytes available at next_in
total_in_lo32: Integer; // total nb of input bytes read so far
total_in_hi32: Integer;
next_out: PByte; // next output byte should be put here
avail_out: Integer; // remaining free space at next_out
total_out_lo32: Integer; // total nb of bytes output so far
total_out_hi32: Integer;
state: Pointer;
bzalloc: TAlloc; // used to allocate the internal state
bzfree: TFree; // used to free the internal state
opaque: Pointer;
end;
// Abstract ancestor class
TCustomBZip2Stream = class(TStream)
private
FStrm: TStream;
FStrmPos: Int64;
FOnProgress: TNotifyEvent;
FBZRec: TBZStreamRec;
FBuffer: array[Word] of Byte;
protected
procedure Progress(Sender: TObject); dynamic;
property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
constructor Create(Strm: TStream);
end;
{ TBZCompressionStream compresses data on the fly as data is written to it, and
stores the compressed data to another stream.
TBZCompressionStream is write-only and strictly sequential. Reading from the
stream will raise an exception. Using Seek to move the stream pointer
will raise an exception.
Output data is cached internally, written to the output stream only when
the internal output buffer is full. All pending output data is flushed
when the stream is destroyed.
The Position property returns the number of uncompressed bytes of
data that have been written to the stream so far.
CompressionRate returns the on-the-fly percentage by which the original
data has been compressed: (1 - (CompressedBytes / UncompressedBytes)) * 100
If raw data size = 100 and compressed data size = 25, the CompressionRate
is 75%
The OnProgress event is called each time the output buffer is filled and
written to the output stream. This is useful for updating a progress
indicator when you are writing a large chunk of data to the compression
stream in a single call.}
TBlockSize100k = (bs1, bs2, bs3, bs4, bs5, bs6, bs7, bs8, bs9);
TBZCompressionStream = class(TCustomBZip2Stream)
private
function GetCompressionRate: Single;
public
constructor Create(BlockSize100k: TBlockSize100k; Dest: TStream);
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
property CompressionRate: Single read GetCompressionRate;
property OnProgress;
end;
{ TDecompressionStream decompresses data on the fly as data is read from it.
Compressed data comes from a separate source stream. TDecompressionStream
is read-only and unidirectional; you can seek forward in the stream, but not
backwards. The special case of setting the stream position to zero is
allowed. Seeking forward decompresses data until the requested position in
the uncompressed data has been reached. Seeking backwards, seeking relative
to the end of the stream, requesting the size of the stream, and writing to
the stream will raise an exception.
The Position property returns the number of bytes of uncompressed data that
have been read from the stream so far.
The OnProgress event is called each time the internal input buffer of
compressed data is exhausted and the next block is read from the input stream.
This is useful for updating a progress indicator when you are reading a
large chunk of data from the decompression stream in a single call.}
TBZDecompressionStream = class(TCustomBZip2Stream)
public
constructor Create(Source: TStream);
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
property OnProgress;
end;
{ CompressBuf compresses data, buffer to buffer, in one call.
In: InBuf = ptr to compressed data
InBytes = number of bytes in InBuf
Out: OutBuf = ptr to newly allocated buffer containing decompressed data
OutBytes = number of bytes in OutBuf }
procedure BZCompressBuf(const InBuf: Pointer; InBytes: Integer;
out OutBuf: Pointer; out OutBytes: Integer);
{ DecompressBuf decompresses data, buffer to buffer, in one call.
In: InBuf = ptr to compressed data
InBytes = number of bytes in InBuf
OutEstimate = zero, or est. size of the decompressed data
Out: OutBuf = ptr to newly allocated buffer containing decompressed data
OutBytes = number of bytes in OutBuf }
procedure BZDecompressBuf(const InBuf: Pointer; InBytes: Integer;
OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
type
EBZip2Error = class(Exception);
EBZCompressionError = class(EBZip2Error);
EBZDecompressionError = class(EBZip2Error);
implementation
// Compile for Win64 using MSVC
// \bin\x86_amd64\cl.exe -c -nologo -GS- -Z7 -wd4086 -Gs32768
// -DBZ_NO_STDIO blocksort.c huffman.c compress.c decompress.c bzlib.c
uses
{$IFDEF Bzip2Runtime}
{$IF DEFINED(FPC)}
dynlibs,
{$ELSEIF DEFINED(MSWINDOWS)}
Windows,
{$IFEND}
{$ENDIF}
AbUtils;
{$IFDEF Bzip2Static}
{$IF DEFINED(WIN32)}
{$L Win32\blocksort.obj}
{$L Win32\huffman.obj}
{$L Win32\compress.obj}
{$L Win32\decompress.obj}
{$L Win32\bzlib.obj}
{$ELSEIF DEFINED(WIN64)}
{$L Win64\blocksort.obj}
{$L Win64\huffman.obj}
{$L Win64\compress.obj}
{$L Win64\decompress.obj}
{$L Win64\bzlib.obj}
{$IFEND}
procedure BZ2_hbMakeCodeLengths; external;
procedure BZ2_blockSort; external;
procedure BZ2_hbCreateDecodeTables; external;
procedure BZ2_hbAssignCodes; external;
procedure BZ2_compressBlock; external;
procedure BZ2_decompress; external;
{$ENDIF}
type
TLargeInteger = record
case Integer of
0: (
LowPart: LongWord;
HighPart: LongWord);
1: (
QuadPart: Int64);
end;
const
BZ_RUN = 0;
BZ_FLUSH = 1;
BZ_FINISH = 2;
BZ_OK = 0;
BZ_RUN_OK = 1;
BZ_FLUSH_OK = 2;
BZ_FINISH_OK = 3;
BZ_STREAM_END = 4;
BZ_SEQUENCE_ERROR = (-1);
BZ_PARAM_ERROR = (-2);
BZ_MEM_ERROR = (-3);
BZ_DATA_ERROR = (-4);
BZ_DATA_ERROR_MAGIC = (-5);
BZ_IO_ERROR = (-6);
BZ_UNEXPECTED_EOF = (-7);
BZ_OUTBUFF_FULL = (-8);
BZ_BLOCK_SIZE_100K = 9;
{$IFDEF Bzip2Static}
BZ2_rNums: array[0..511] of Longint = (
619, 720, 127, 481, 931, 816, 813, 233, 566, 247,
985, 724, 205, 454, 863, 491, 741, 242, 949, 214,
733, 859, 335, 708, 621, 574, 73, 654, 730, 472,
419, 436, 278, 496, 867, 210, 399, 680, 480, 51,
878, 465, 811, 169, 869, 675, 611, 697, 867, 561,
862, 687, 507, 283, 482, 129, 807, 591, 733, 623,
150, 238, 59, 379, 684, 877, 625, 169, 643, 105,
170, 607, 520, 932, 727, 476, 693, 425, 174, 647,
73, 122, 335, 530, 442, 853, 695, 249, 445, 515,
909, 545, 703, 919, 874, 474, 882, 500, 594, 612,
641, 801, 220, 162, 819, 984, 589, 513, 495, 799,
161, 604, 958, 533, 221, 400, 386, 867, 600, 782,
382, 596, 414, 171, 516, 375, 682, 485, 911, 276,
98, 553, 163, 354, 666, 933, 424, 341, 533, 870,
227, 730, 475, 186, 263, 647, 537, 686, 600, 224,
469, 68, 770, 919, 190, 373, 294, 822, 808, 206,
184, 943, 795, 384, 383, 461, 404, 758, 839, 887,
715, 67, 618, 276, 204, 918, 873, 777, 604, 560,
951, 160, 578, 722, 79, 804, 96, 409, 713, 940,
652, 934, 970, 447, 318, 353, 859, 672, 112, 785,
645, 863, 803, 350, 139, 93, 354, 99, 820, 908,
609, 772, 154, 274, 580, 184, 79, 626, 630, 742,
653, 282, 762, 623, 680, 81, 927, 626, 789, 125,
411, 521, 938, 300, 821, 78, 343, 175, 128, 250,
170, 774, 972, 275, 999, 639, 495, 78, 352, 126,
857, 956, 358, 619, 580, 124, 737, 594, 701, 612,
669, 112, 134, 694, 363, 992, 809, 743, 168, 974,
944, 375, 748, 52, 600, 747, 642, 182, 862, 81,
344, 805, 988, 739, 511, 655, 814, 334, 249, 515,
897, 955, 664, 981, 649, 113, 974, 459, 893, 228,
433, 837, 553, 268, 926, 240, 102, 654, 459, 51,
686, 754, 806, 760, 493, 403, 415, 394, 687, 700,
946, 670, 656, 610, 738, 392, 760, 799, 887, 653,
978, 321, 576, 617, 626, 502, 894, 679, 243, 440,
680, 879, 194, 572, 640, 724, 926, 56, 204, 700,
707, 151, 457, 449, 797, 195, 791, 558, 945, 679,
297, 59, 87, 824, 713, 663, 412, 693, 342, 606,
134, 108, 571, 364, 631, 212, 174, 643, 304, 329,
343, 97, 430, 751, 497, 314, 983, 374, 822, 928,
140, 206, 73, 263, 980, 736, 876, 478, 430, 305,
170, 514, 364, 692, 829, 82, 855, 953, 676, 246,
369, 970, 294, 750, 807, 827, 150, 790, 288, 923,
804, 378, 215, 828, 592, 281, 565, 555, 710, 82,
896, 831, 547, 261, 524, 462, 293, 465, 502, 56,
661, 821, 976, 991, 658, 869, 905, 758, 745, 193,
768, 550, 608, 933, 378, 286, 215, 979, 792, 961,
61, 688, 793, 644, 986, 403, 106, 366, 905, 644,
372, 567, 466, 434, 645, 210, 389, 550, 919, 135,
780, 773, 635, 389, 707, 100, 626, 958, 165, 504,
920, 176, 193, 713, 857, 265, 203, 50, 668, 108,
645, 990, 626, 197, 510, 357, 358, 850, 858, 364,
936, 638
);
BZ2_crc32Table: array[0..255] of Longint = (
$00000000, $04C11DB7, $09823B6E, $0D4326D9,
$130476DC, $17C56B6B, $1A864DB2, $1E475005,
$2608EDB8, $22C9F00F, $2F8AD6D6, $2B4BCB61,
$350C9B64, $31CD86D3, $3C8EA00A, $384FBDBD,
$4C11DB70, $48D0C6C7, $4593E01E, $4152FDA9,
$5F15ADAC, $5BD4B01B, $569796C2, $52568B75,
$6A1936C8, $6ED82B7F, $639B0DA6, $675A1011,
$791D4014, $7DDC5DA3, $709F7B7A, $745E66CD,
-$67DC4920, -$631D54A9, -$6E5E7272, -$6A9F6FC7,
-$74D83FC4, -$70192275, -$7D5A04AE, -$799B191B,
-$41D4A4A8, -$4515B911, -$48569FCA, -$4C97827F,
-$52D0D27C, -$5611CFCD, -$5B52E916, -$5F93F4A3,
-$2BCD9270, -$2F0C8FD9, -$224FA902, -$268EB4B7,
-$38C9E4B4, -$3C08F905, -$314BDFDE, -$358AC26B,
-$0DC57FD8, -$09046261, -$044744BA, -$0086590F,
-$1EC1090C, -$1A0014BD, -$17433266, -$13822FD3,
$34867077, $30476DC0, $3D044B19, $39C556AE,
$278206AB, $23431B1C, $2E003DC5, $2AC12072,
$128E9DCF, $164F8078, $1B0CA6A1, $1FCDBB16,
$018AEB13, $054BF6A4, $0808D07D, $0CC9CDCA,
$7897AB07, $7C56B6B0, $71159069, $75D48DDE,
$6B93DDDB, $6F52C06C, $6211E6B5, $66D0FB02,
$5E9F46BF, $5A5E5B08, $571D7DD1, $53DC6066,
$4D9B3063, $495A2DD4, $44190B0D, $40D816BA,
-$535A3969, -$579B24E0, -$5AD80207, -$5E191FB2,
-$405E4FB5, -$449F5204, -$49DC74DB, -$4D1D696E,
-$7552D4D1, -$7193C968, -$7CD0EFBF, -$7811F20A,
-$6656A20D, -$6297BFBC, -$6FD49963, -$6B1584D6,
-$1F4BE219, -$1B8AFFB0, -$16C9D977, -$1208C4C2,
-$0C4F94C5, -$088E8974, -$05CDAFAB, -$010CB21E,
-$39430FA1, -$3D821218, -$30C134CF, -$3400297A,
-$2A47797D, -$2E8664CC, -$23C54213, -$27045FA6,
$690CE0EE, $6DCDFD59, $608EDB80, $644FC637,
$7A089632, $7EC98B85, $738AAD5C, $774BB0EB,
$4F040D56, $4BC510E1, $46863638, $42472B8F,
$5C007B8A, $58C1663D, $558240E4, $51435D53,
$251D3B9E, $21DC2629, $2C9F00F0, $285E1D47,
$36194D42, $32D850F5, $3F9B762C, $3B5A6B9B,
$0315D626, $07D4CB91, $0A97ED48, $0E56F0FF,
$1011A0FA, $14D0BD4D, $19939B94, $1D528623,
-$0ED0A9F2, -$0A11B447, -$075292A0, -$03938F29,
-$1DD4DF2E, -$1915C29B, -$1456E444, -$1097F9F5,
-$28D8444A, -$2C1959FF, -$215A7F28, -$259B6291,
-$3BDC3296, -$3F1D2F23, -$325E09FC, -$369F144D,
-$42C17282, -$46006F37, -$4B4349F0, -$4F825459,
-$51C5045E, -$550419EB, -$58473F34, -$5C862285,
-$64C99F3A, -$6008828F, -$6D4BA458, -$698AB9E1,
-$77CDE9E6, -$730CF453, -$7E4FD28C, -$7A8ECF3D,
$5D8A9099, $594B8D2E, $5408ABF7, $50C9B640,
$4E8EE645, $4A4FFBF2, $470CDD2B, $43CDC09C,
$7B827D21, $7F436096, $7200464F, $76C15BF8,
$68860BFD, $6C47164A, $61043093, $65C52D24,
$119B4BE9, $155A565E, $18197087, $1CD86D30,
$029F3D35, $065E2082, $0B1D065B, $0FDC1BEC,
$3793A651, $3352BBE6, $3E119D3F, $3AD08088,
$2497D08D, $2056CD3A, $2D15EBE3, $29D4F654,
-$3A56D987, -$3E97C432, -$33D4E2E9, -$3715FF60,
-$2952AF5B, -$2D93B2EE, -$20D09435, -$24118984,
-$1C5E343F, -$189F298A, -$15DC0F51, -$111D12E8,
-$0F5A42E3, -$0B9B5F56, -$06D8798D, -$0219643C,
-$764702F7, -$72861F42, -$7FC53999, -$7B042430,
-$6543742B, -$6182699E, -$6CC14F45, -$680052F4,
-$504FEF4F, -$548EF2FA, -$59CDD421, -$5D0CC998,
-$434B9993, -$478A8426, -$4AC9A2FD, -$4E08BF4C
);
procedure bz_internal_error(errcode: Integer); cdecl;
begin
raise EBZip2Error.CreateFmt('Compression Error %d', [errcode]);
end; { _bz_internal_error }
function malloc(size: Integer): Pointer; cdecl;
begin
GetMem(Result, Size);
end; { _malloc }
procedure free(block: Pointer); cdecl;
begin
FreeMem(block);
end; { _free }
{$ENDIF}
const
libbz2 = {$IF DEFINED(MSWINDOWS)}'libbz2.dll'
{$ELSEIF DEFINED(DARWIN)}'libbz2.dylib'
{$ELSE}'libbz2.so.1'{$IFEND};
{$IFDEF Bzip2Runtime}
var
hBzip2: HMODULE;
// deflate compresses data
BZ2_bzCompressInit: function(var strm: TBZStreamRec; blockSize100k: Integer;
verbosity: Integer; workFactor: Integer): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}
BZ2_bzCompress: function(var strm: TBZStreamRec; action: Integer): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}
BZ2_bzCompressEnd: function (var strm: TBZStreamRec): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}
BZ2_bzBuffToBuffCompress: function(dest: Pointer; var destLen: Integer;
source: Pointer; sourceLen, blockSize100k, verbosity, workFactor: Integer): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}
// inflate decompresses data
BZ2_bzDecompressInit: function(var strm: TBZStreamRec; verbosity: Integer;
small: Integer): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}
BZ2_bzDecompress: function(var strm: TBZStreamRec): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}
BZ2_bzDecompressEnd: function(var strm: TBZStreamRec): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}
BZ2_bzBuffToBuffDecompress: function(dest: Pointer; var destLen: Integer;
source: Pointer; sourceLen, small, verbosity: Integer): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}
{$ELSE}
// deflate compresses data
function BZ2_bzCompressInit(var strm: TBZStreamRec; blockSize100k: Integer;
verbosity: Integer; workFactor: Integer): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} external {$IFDEF Bzip2Dynamic}libbz2{$ENDIF}
{$IFDEF DARWIN}name '_BZ2_bzCompressInit'{$ENDIF};
function BZ2_bzCompress(var strm: TBZStreamRec; action: Integer): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} external {$IFDEF Bzip2Dynamic}libbz2{$ENDIF}
{$IFDEF DARWIN}name '_BZ2_bzCompress'{$ENDIF};
function BZ2_bzCompressEnd(var strm: TBZStreamRec): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} external {$IFDEF Bzip2Dynamic}libbz2{$ENDIF}
{$IFDEF DARWIN}name '_BZ2_bzCompressEnd'{$ENDIF};
function BZ2_bzBuffToBuffCompress(dest: Pointer; var destLen: Integer; source: Pointer;
sourceLen, blockSize100k, verbosity, workFactor: Integer): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} external {$IFDEF Bzip2Dynamic}libbz2{$ENDIF}
{$IFDEF DARWIN}name '_BZ2_bzBuffToBuffCompress'{$ENDIF};
// inflate decompresses data
function BZ2_bzDecompressInit(var strm: TBZStreamRec; verbosity: Integer;
small: Integer): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} external {$IFDEF Bzip2Dynamic}libbz2{$ENDIF}
{$IFDEF DARWIN}name '_BZ2_bzDecompressInit'{$ENDIF};
function BZ2_bzDecompress(var strm: TBZStreamRec): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} external {$IFDEF Bzip2Dynamic}libbz2{$ENDIF}
{$IFDEF DARWIN}name '_BZ2_bzDecompress'{$ENDIF};
function BZ2_bzDecompressEnd(var strm: TBZStreamRec): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} external {$IFDEF Bzip2Dynamic}libbz2{$ENDIF}
{$IFDEF DARWIN}name '_BZ2_bzDecompressEnd'{$ENDIF};
function BZ2_bzBuffToBuffDecompress(dest: Pointer; var destLen: Integer; source: Pointer;
sourceLen, small, verbosity: Integer): Integer;
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} external {$IFDEF Bzip2Dynamic}libbz2{$ENDIF}
{$IFDEF DARWIN}name '_BZ2_bzBuffToBuffDecompress'{$ENDIF};
{$ENDIF}
procedure LoadBzip2DLL;
begin
{$IFDEF Bzip2Runtime}
if hBzip2 <> 0 then
Exit;
hBzip2 := LoadLibrary(libbz2);
if hBzip2 = 0 then
raise EBZip2Error.Create('Bzip2 shared library not found');
@BZ2_bzCompressInit := GetProcAddress(hBzip2, 'BZ2_bzCompressInit');
@BZ2_bzCompress := GetProcAddress(hBzip2, 'BZ2_bzCompress');
@BZ2_bzCompressEnd := GetProcAddress(hBzip2, 'BZ2_bzCompressEnd');
@BZ2_bzBuffToBuffCompress := GetProcAddress(hBzip2, 'BZ2_bzBuffToBuffCompress');
@BZ2_bzDecompressInit := GetProcAddress(hBzip2, 'BZ2_bzDecompressInit');
@BZ2_bzDecompress := GetProcAddress(hBzip2, 'BZ2_bzDecompress');
@BZ2_bzDecompressEnd := GetProcAddress(hBzip2, 'BZ2_bzDecompressEnd');
@BZ2_bzBuffToBuffDecompress := GetProcAddress(hBzip2, 'BZ2_bzBuffToBuffDecompress');
{$ENDIF}
end;
function bzip2AllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl;
begin
GetMem(Result, Items * Size);
end; { bzip2AllocMem }
procedure bzip2FreeMem(AppData, Block: Pointer); cdecl;
begin
FreeMem(Block);
end; { bzip2FreeMem }
function CCheck(code: Integer): Integer;
begin
Result := code;
if code < 0 then
raise EBZCompressionError.CreateFmt('error %d', [code]); //!!
end; { CCheck }
function DCheck(code: Integer): Integer;
begin
Result := code;
if code < 0 then
raise EBZDecompressionError.CreateFmt('error %d', [code]); //!!
end; { DCheck }
procedure BZCompressBuf(const InBuf: Pointer; InBytes: Integer;
out OutBuf: Pointer; out OutBytes: Integer);
var
strm: TBZStreamRec;
P: Pointer;
begin
LoadBzip2DLL;
FillChar(strm, sizeof(strm), 0);
strm.bzalloc := bzip2AllocMem;
strm.bzfree := bzip2FreeMem;
OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255;
GetMem(OutBuf, OutBytes);
try
strm.next_in := InBuf;
strm.avail_in := InBytes;
strm.next_out := OutBuf;
strm.avail_out := OutBytes;
CCheck(BZ2_bzCompressInit(strm, 9, 0, 0));
try
while CCheck(BZ2_bzCompress(strm, BZ_FINISH)) <> BZ_STREAM_END do
begin
P := OutBuf;
Inc(OutBytes, 256);
ReallocMem(OutBuf, OutBytes);
strm.next_out := PByte(PtrInt(OutBuf)
+ (PtrInt(strm.next_out) - PtrInt(P)));
strm.avail_out := 256;
end;
finally
CCheck(BZ2_bzCompressEnd(strm));
end;
ReallocMem(OutBuf, strm.total_out_lo32);
OutBytes := strm.total_out_lo32;
except
FreeMem(OutBuf);
raise
end;
end;
procedure BZDecompressBuf(const InBuf: Pointer; InBytes: Integer;
OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
var
strm: TBZStreamRec;
P: Pointer;
BufInc: Integer;
begin
LoadBzip2DLL;
FillChar(strm, sizeof(strm), 0);
strm.bzalloc := bzip2AllocMem;
strm.bzfree := bzip2FreeMem;
BufInc := (InBytes + 255) and not 255;
if OutEstimate = 0 then
OutBytes := BufInc
else
OutBytes := OutEstimate;
GetMem(OutBuf, OutBytes);
try
strm.next_in := InBuf;
strm.avail_in := InBytes;
strm.next_out := OutBuf;
strm.avail_out := OutBytes;
DCheck(BZ2_bzDecompressInit(strm, 0, 0));
try
while DCheck(BZ2_bzDecompress(strm)) <> BZ_STREAM_END do
begin
P := OutBuf;
Inc(OutBytes, BufInc);
ReallocMem(OutBuf, OutBytes);
strm.next_out := PByte(PtrInt(OutBuf) + (PtrInt(strm.next_out) - PtrInt(P)));
strm.avail_out := BufInc;
end;
finally
DCheck(BZ2_bzDecompressEnd(strm));
end;
ReallocMem(OutBuf, strm.total_out_lo32);
OutBytes := strm.total_out_lo32;
except
FreeMem(OutBuf);
raise
end;
end;
// TCustomBZip2Stream
constructor TCustomBZip2Stream.Create(Strm: TStream);
begin
inherited Create;
FStrm := Strm;
FStrmPos := Strm.Position;
FBZRec.bzalloc := bzip2AllocMem;
FBZRec.bzfree := bzip2FreeMem;
end;
procedure TCustomBZip2Stream.Progress(Sender: TObject);
begin
if Assigned(FOnProgress) then FOnProgress(Sender);
end; { TCustomBZip2Stream }
// TBZCompressionStream
constructor TBZCompressionStream.Create(BlockSize100k: TBlockSize100k; Dest: TStream);
const
BlockSizes: array[TBlockSize100k] of ShortInt = (1, 2, 3, 4, 5, 6, 7, 8, 9);
begin
inherited Create(Dest);
LoadBzip2DLL;
FBZRec.next_out := @FBuffer[0];
FBZRec.avail_out := sizeof(FBuffer);
CCheck(BZ2_bzCompressInit(FBZRec, BlockSizes[BlockSize100k], 0, 0));
end;
destructor TBZCompressionStream.Destroy;
begin
if FBZRec.state <> nil then begin
FBZRec.next_in := nil;
FBZRec.avail_in := 0;
try
if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
while (CCheck(BZ2_bzCompress(FBZRec, BZ_FINISH)) <> BZ_STREAM_END)
and (FBZRec.avail_out = 0) do
begin
FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
FBZRec.next_out := @FBuffer[0];
FBZRec.avail_out := sizeof(FBuffer);
end;
if FBZRec.avail_out < sizeof(FBuffer) then
FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FBZRec.avail_out);
finally
BZ2_bzCompressEnd(FBZRec);
end;
end;
inherited Destroy;
end;
function TBZCompressionStream.Read(var Buffer; Count: Longint): Longint;
begin
raise EBZCompressionError.Create('Invalid stream operation');
end; { TBZCompressionStream }
function TBZCompressionStream.Write(const Buffer; Count: Longint): Longint;
begin
FBZRec.next_in := @Buffer;
FBZRec.avail_in := Count;
if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
while (FBZRec.avail_in > 0) do
begin
CCheck(BZ2_bzCompress(FBZRec, BZ_RUN));
if FBZRec.avail_out = 0 then
begin
FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
FBZRec.next_out := @FBuffer[0];
FBZRec.avail_out := sizeof(FBuffer);
FStrmPos := FStrm.Position;
end;
Progress(Self);
end;
Result := Count;
end; { TBZCompressionStream }
function TBZCompressionStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
var
conv64 : TLargeInteger;
begin
if (Offset = 0) and (Origin = soCurrent) then begin
conv64.LowPart := FBZRec.total_in_lo32;
conv64.HighPart := FBZRec.total_in_hi32;
Result := conv64.QuadPart
end
else
raise EBZCompressionError.Create('Invalid stream operation');
end; { TBZCompressionStream }
function TBZCompressionStream.GetCompressionRate: Single;
var
conv64In : TLargeInteger;
conv64Out: TLargeInteger;
begin
conv64In.LowPart := FBZRec.total_in_lo32;
conv64In.HighPart := FBZRec.total_in_hi32;
conv64Out.LowPart := FBZRec.total_out_lo32;
conv64Out.HighPart := FBZRec.total_out_hi32;
if conv64In.QuadPart = 0 then
Result := 0
else
Result := (1.0 - (conv64Out.QuadPart / conv64In.QuadPart)) * 100.0;
end; { TBZCompressionStream }
// TDecompressionStream
constructor TBZDecompressionStream.Create(Source: TStream);
begin
inherited Create(Source);
LoadBzip2DLL;
FBZRec.next_in := @FBuffer[0];
FBZRec.avail_in := 0;
DCheck(BZ2_bzDecompressInit(FBZRec, 0, 0));
end;
destructor TBZDecompressionStream.Destroy;
begin
if FBZRec.state <> nil then
BZ2_bzDecompressEnd(FBZRec);
inherited Destroy;
end;
function TBZDecompressionStream.Read(var Buffer; Count: Longint): Longint;
begin
FBZRec.next_out := @Buffer;
FBZRec.avail_out := Count;
if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
while (FBZRec.avail_out > 0) do
begin
if FBZRec.avail_in = 0 then
begin
FBZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer));
if FBZRec.avail_in = 0 then
begin
Result := Count - FBZRec.avail_out;
Exit;
end;
FBZRec.next_in := @FBuffer[0];
FStrmPos := FStrm.Position;
end;
CCheck(BZ2_bzDecompress(FBZRec));
Progress(Self);
end;
Result := Count;
end; { TBZDecompressionStream }
function TBZDecompressionStream.Write(const Buffer; Count: Longint): Longint;
begin
raise EBZDecompressionError.Create('Invalid stream operation');
end; { TBZDecompressionStream }
function TBZDecompressionStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
var
I : Integer;
Buf : array[0..4095] of Char;
conv64: TLargeInteger;
NewOff: Int64;
begin
conv64.LowPart := FBZRec.total_out_lo32;
conv64.HighPart := FBZRec.total_out_hi32;
if (Offset = 0) and (Origin = soBeginning) then
begin
DCheck(BZ2_bzDecompressEnd(FBZRec));
DCheck(BZ2_bzDecompressInit(FBZRec, 0, 0));
FBZRec.next_in := @FBuffer[0];
FBZRec.avail_in := 0;
FStrm.Position := 0;
FStrmPos := 0;
end
else if ((Offset >= 0) and (Origin = soCurrent)) or
(((Offset - conv64.QuadPart) > 0) and (Origin = soBeginning)) then
begin
NewOff := Offset;
if Origin = soBeginning then Dec(NewOff, conv64.QuadPart);
if NewOff > 0 then
begin
for I := 1 to NewOff div sizeof(Buf) do
ReadBuffer(Buf, sizeof(Buf));
ReadBuffer(Buf, NewOff mod sizeof(Buf));
end;
end
else
raise EBZDecompressionError.Create('Invalid stream operation');
Result := conv64.QuadPart;
end; { TBZDecompressionStream }
end.
================================================
FILE: lib/abbrevia/source/AbBzip2Typ.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* Joel Haynie
* Craig Peterson
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbBzip2Typ.pas *}
{*********************************************************}
{* ABBREVIA: TAbBzip2Archive, TAbBzip2Item classes *}
{*********************************************************}
{* Misc. constants, types, and routines for working *}
{* with Bzip2 files *}
{*********************************************************}
unit AbBzip2Typ;
{$I AbDefine.inc}
interface
uses
Classes,
AbArcTyp, AbTarTyp, AbUtils;
const
{ Default Stream Header for Bzip2s is 'BZhX', where X is the block size setting 1-9 in ASCII }
{ Each block has the following header: '1AY&SY', and are in units of 100kilobytes NOT 100kibiBytes }
AB_BZIP2_FILE_HEADER = 'BZh';
AB_BZIP2_BLOCK_SIZE = ['1','2','3','4','5','6','7','8','9'];
AB_BZIP2_BLOCK_HEADER = '1AY&SY'; { Note: $314159265359, BCD for Pi :) }
{ Note that Blocks are bit aligned, as such the only time you will "for sure" see
the block header is on the start of stream/File }
AB_BZIP2_FILE_TAIL =#23#114#36#83#133#9#0; { $1772245385090, BCD for sqrt(Pi) :) }
{ This is odd as the blocks are bit allgned so this is a string that is 13*4 bits = 52 bits }
type
PAbBzip2Header = ^TAbBzip2Header; { File Header }
TAbBzip2Header = packed record { SizeOf(TAbBzip2Header) = 10 }
FileHeader : array[0..2] of AnsiChar;{ 'BZh'; $42,5A,68 }
BlockSize : AnsiChar; { '1'..'9'; $31-$39 }
BlockHeader : array[0..5] of AnsiChar;{ '1AY&SY'; $31,41,59,26,53,59 }
end;
{ The Purpose for this Item is the placeholder for aaAdd and aaDelete Support. }
{ For all intents and purposes we could just use a TAbArchiveItem }
type
TAbBzip2Item = class(TabArchiveItem);
TAbBzip2ArchiveState = (gsBzip2, gsTar);
TAbBzip2Archive = class(TAbTarArchive)
private
FBzip2Stream : TStream; { stream for Bzip2 file}
FBzip2Item : TAbArchiveList; { item in bzip2 (only one, but need polymorphism of class)}
FTarStream : TStream; { stream for possible contained Tar }
FTarList : TAbArchiveList; { items in possible contained Tar }
FTarAutoHandle: Boolean;
FState : TAbBzip2ArchiveState;
FIsBzippedTar : Boolean;
procedure DecompressToStream(aStream: TStream);
procedure SetTarAutoHandle(const Value: Boolean);
procedure SwapToBzip2;
procedure SwapToTar;
protected
{ Inherited Abstract functions }
function CreateItem(const FileSpec : string): TAbArchiveItem; override;
procedure ExtractItemAt(Index : Integer; const NewName : string); override;
procedure ExtractItemToStreamAt(Index : Integer; aStream : TStream); override;
procedure LoadArchive; override;
procedure SaveArchive; override;
procedure TestItemAt(Index : Integer); override;
function GetSupportsEmptyFolders : Boolean; override;
public {methods}
constructor CreateFromStream(aStream : TStream; const aArchiveName : string); override;
destructor Destroy; override;
procedure DoSpanningMediaRequest(Sender : TObject; ImageNumber : Integer;
var ImageName : string; var Abort : Boolean); override;
{ Properties }
property TarAutoHandle : Boolean
read FTarAutoHandle write SetTarAutoHandle;
property IsBzippedTar : Boolean
read FIsBzippedTar write FIsBzippedTar;
end;
function VerifyBzip2(Strm : TStream) : TAbArchiveType;
implementation
uses
{$IFDEF MSWINDOWS}
Windows, // Fix inline warnings
{$ENDIF}
StrUtils, SysUtils,
AbBzip2, AbExcept, AbVMStrm, AbBitBkt;
{ ****************** Helper functions Not from Classes Above ***************** }
function VerifyHeader(const Header : TAbBzip2Header) : Boolean;
begin
Result := (Header.FileHeader = AB_BZIP2_FILE_HEADER) and
(Header.BlockSize in AB_BZIP2_BLOCK_SIZE) and
(Header.BlockHeader = AB_BZIP2_BLOCK_HEADER);
end;
{ -------------------------------------------------------------------------- }
function VerifyBzip2(Strm : TStream) : TAbArchiveType;
var
Hdr : TAbBzip2Header;
CurPos : int64;
DecompStream, TarStream: TStream;
begin
Result := atUnknown;
CurPos := Strm.Position;
Strm.Seek(0, soBeginning);
try
if (Strm.Read(Hdr, SizeOf(Hdr)) = SizeOf(Hdr)) and VerifyHeader(Hdr) then begin
Result := atBzip2;
{ Check for embedded TAR }
Strm.Seek(0, soBeginning);
DecompStream := TBZDecompressionStream.Create(Strm);
try
TarStream := TMemoryStream.Create;
try
TarStream.CopyFrom(DecompStream, 512 * 2);
TarStream.Seek(0, soBeginning);
if VerifyTar(TarStream) = atTar then
Result := atBzippedTar;
finally
TarStream.Free;
end;
finally
DecompStream.Free;
end;
end;
except
on EReadError do
Result := atUnknown;
end;
Strm.Position := CurPos; { Return to original position. }
end;
{ ****************************** TAbBzip2Archive ***************************** }
constructor TAbBzip2Archive.CreateFromStream(aStream: TStream;
const aArchiveName: string);
begin
inherited CreateFromStream(aStream, aArchiveName);
FState := gsBzip2;
FBzip2Stream := FStream;
FBzip2Item := FItemList;
FTarStream := TAbVirtualMemoryStream.Create;
FTarList := TAbArchiveList.Create(True);
end;
{ -------------------------------------------------------------------------- }
procedure TAbBzip2Archive.SwapToTar;
begin
FStream := FTarStream;
FItemList := FTarList;
FState := gsTar;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBzip2Archive.SwapToBzip2;
begin
FStream := FBzip2Stream;
FItemList := FBzip2Item;
FState := gsBzip2;
end;
{ -------------------------------------------------------------------------- }
function TAbBzip2Archive.CreateItem(const FileSpec: string): TAbArchiveItem;
begin
if IsBzippedTar and TarAutoHandle then begin
SwapToTar;
Result := inherited CreateItem(FileSpec);
end
else begin
SwapToBzip2;
Result := TAbBzip2Item.Create;
try
Result.DiskFileName := ExpandFileName(FileSpec);
Result.FileName := FixName(FileSpec);
except
Result.Free;
raise;
end;
end;
end;
{ -------------------------------------------------------------------------- }
destructor TAbBzip2Archive.Destroy;
begin
SwapToBzip2;
FTarList.Free;
FTarStream.Free;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBzip2Archive.ExtractItemAt(Index: Integer;
const NewName: string);
var
OutStream : TFileStream;
begin
if IsBzippedTar and TarAutoHandle then begin
SwapToTar;
inherited ExtractItemAt(Index, NewName);
end
else begin
SwapToBzip2;
OutStream := TFileStream.Create(NewName, fmCreate or fmShareDenyNone);
try
try
ExtractItemToStreamAt(Index, OutStream);
finally
OutStream.Free;
end;
{ Bz2 doesn't store the last modified time or attributes, so don't set them }
except
on E : EAbUserAbort do begin
FStatus := asInvalid;
if FileExists(NewName) then
DeleteFile(NewName);
raise;
end else begin
if FileExists(NewName) then
DeleteFile(NewName);
raise;
end;
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBzip2Archive.ExtractItemToStreamAt(Index: Integer;
aStream: TStream);
begin
if IsBzippedTar and TarAutoHandle then begin
SwapToTar;
inherited ExtractItemToStreamAt(Index, aStream);
end
else begin
SwapToBzip2;
{ Index ignored as there's only one item in a Bz2 }
DecompressToStream(aStream);
end;
end;
{ -------------------------------------------------------------------------- }
function TAbBzip2Archive.GetSupportsEmptyFolders : Boolean;
begin
Result := IsBzippedTar and TarAutoHandle;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBzip2Archive.LoadArchive;
var
Item: TAbBzip2Item;
Abort: Boolean;
ItemName: string;
begin
if FBzip2Stream.Size = 0 then
Exit;
if IsBzippedTar and TarAutoHandle then begin
{ Decompress and send to tar LoadArchive }
DecompressToStream(FTarStream);
SwapToTar;
inherited LoadArchive;
end
else begin
SwapToBzip2;
Item := TAbBzip2Item.Create;
Item.Action := aaNone;
{ Filename isn't stored, so constuct one based on the archive name }
ItemName := ExtractFileName(ArchiveName);
if ItemName = '' then
Item.FileName := 'unknown'
else if AnsiEndsText('.tbz', ItemName) or AnsiEndsText('.tbz2', ItemName) then
Item.FileName := ChangeFileExt(ItemName, '.tar')
else
Item.FileName := ChangeFileExt(ItemName, '');
Item.DiskFileName := Item.FileName;
FItemList.Add(Item);
end;
DoArchiveProgress(100, Abort);
FIsDirty := False;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBzip2Archive.SaveArchive;
var
CompStream: TStream;
i: Integer;
CurItem: TAbBzip2Item;
InputFileStream: TStream;
begin
if IsBzippedTar and TarAutoHandle then
begin
SwapToTar;
inherited SaveArchive;
FTarStream.Position := 0;
FBzip2Stream.Size := 0;
CompStream := TBZCompressionStream.Create(bs9, FBzip2Stream);
try
CompStream.CopyFrom(FTarStream, 0);
finally
CompStream.Free;
end;
end
else begin
{ Things we know: There is only one file per archive.}
{ Actions we have to address in SaveArchive: }
{ aaNone & aaMove do nothing, as the file does not change, only the meta data }
{ aaDelete could make a zero size file unless there are two files in the list.}
{ aaAdd, aaStreamAdd, aaFreshen, & aaReplace will be the only ones to take action. }
SwapToBzip2;
for i := 0 to pred(Count) do begin
FCurrentItem := ItemList[i];
CurItem := TAbBzip2Item(ItemList[i]);
case CurItem.Action of
aaNone, aaMove: Break;{ Do nothing; bz2 doesn't store metadata }
aaDelete: ; {doing nothing omits file from new stream}
aaAdd, aaFreshen, aaReplace, aaStreamAdd: begin
FBzip2Stream.Size := 0;
CompStream := TBZCompressionStream.Create(bs9, FBzip2Stream);
try
if CurItem.Action = aaStreamAdd then
CompStream.CopyFrom(InStream, 0){ Copy/compress entire Instream to FBzip2Stream }
else begin
InputFileStream := TFileStream.Create(CurItem.DiskFileName, fmOpenRead or fmShareDenyWrite );
try
CompStream.CopyFrom(InputFileStream, 0);{ Copy/compress entire Instream to FBzip2Stream }
finally
InputFileStream.Free;
end;
end;
finally
CompStream.Free;
end;
Break;
end; { End aaAdd, aaFreshen, aaReplace, & aaStreamAdd }
end; { End of CurItem.Action Case }
end; { End Item for loop }
end; { End Tar Else }
end;
{ -------------------------------------------------------------------------- }
procedure TAbBzip2Archive.SetTarAutoHandle(const Value: Boolean);
begin
if Value then
SwapToTar
else
SwapToBzip2;
FTarAutoHandle := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBzip2Archive.DecompressToStream(aStream: TStream);
const
BufSize = $F000;
var
DecompStream: TBZDecompressionStream;
Buffer: PByte;
N: Integer;
begin
DecompStream := TBZDecompressionStream.Create(FBzip2Stream);
try
GetMem(Buffer, BufSize);
try
N := DecompStream.Read(Buffer^, BufSize);
while N > 0 do begin
aStream.WriteBuffer(Buffer^, N);
N := DecompStream.Read(Buffer^, BufSize);
end;
finally
FreeMem(Buffer, BufSize);
end;
finally
DecompStream.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBzip2Archive.TestItemAt(Index: Integer);
var
Bzip2Type: TAbArchiveType;
BitBucket: TAbBitBucketStream;
begin
if IsBzippedTar and TarAutoHandle then begin
SwapToTar;
inherited TestItemAt(Index);
end
else begin
{ note Index ignored as there's only one item in a GZip }
Bzip2Type := VerifyBzip2(FBzip2Stream);
if not (Bzip2Type in [atBzip2, atBzippedTar]) then
raise EAbGzipInvalid.Create;// TODO: Add bzip2-specific exceptions }
BitBucket := TAbBitBucketStream.Create(1024);
try
DecompressToStream(BitBucket);
finally
BitBucket.Free;
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBzip2Archive.DoSpanningMediaRequest(Sender: TObject;
ImageNumber: Integer; var ImageName: string; var Abort: Boolean);
begin
Abort := False;
end;
end.
================================================
FILE: lib/abbrevia/source/AbCBrows.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbCBrows.pas *}
{*********************************************************}
{* ABBREVIA: Cabinet file browser component *}
{*********************************************************}
unit AbCBrows;
{$I AbDefine.inc}
interface
uses
Classes,
AbBrowse,
AbCabTyp;
type
TAbCustomCabBrowser = class(TAbBaseBrowser)
protected {private}
FSetID : Word;
function GetCabArchive : TAbCabArchive;
function GetCabSize : Longint;
function GetCurrentCab : Word;
function GetFolderCount : Word;
function GetItem(Index : Integer) : TAbCabItem; virtual;
function GetHasNext : Boolean;
function GetHasPrev : Boolean;
function GetSetID : Word;
procedure InitArchive;
override;
procedure SetFileName(const aFileName : string); override;
procedure SetSetID(Value : Word);
protected {properties}
property CabSize : Longint
read GetCabSize;
property CurrentCab : Word
read GetCurrentCab;
property FolderCount : Word
read GetFolderCount;
property HasNext : Boolean
read GetHasNext;
property HasPrev : Boolean
read GetHasPrev;
property SetID : Word
read GetSetID
write SetSetID;
public {methods}
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
public {properties}
property CabArchive : TAbCabArchive
read GetCabArchive;
property Items[Index : Integer] : TAbCabItem
read GetItem; default;
end;
type
{$IFDEF HasPlatformsAttribute}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
TAbCabBrowser = class(TAbCustomCabBrowser)
published
property ArchiveProgressMeter;
property BaseDirectory;
property CabSize;
property CurrentCab;
property FolderCount;
property HasNext;
property HasPrev;
property ItemProgressMeter;
property LogFile;
property Logging;
property OnArchiveProgress;
property OnArchiveItemProgress;
property OnChange;
property OnLoad;
property SetID;
property TempDirectory;
property Version;
property FileName; {must be after OnLoad}
end;
{.Z+}
implementation
uses
SysUtils,
AbArcTyp,
AbUtils;
{ TAbCustomCabBrowser ====================================================== }
constructor TAbCustomCabBrowser.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
FArchiveType := atCab;
end;
{ -------------------------------------------------------------------------- }
destructor TAbCustomCabBrowser.Destroy;
begin
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomCabBrowser.GetCabArchive : TAbCabArchive;
begin
if Assigned(Archive) then
Result := TAbCabArchive(Archive)
else
Result := nil;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomCabBrowser.GetCabSize : Longint;
begin
if Assigned(Archive) then
Result := TAbCabArchive(Archive).CabSize
else
Result := 0;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomCabBrowser.GetCurrentCab : Word;
begin
if Assigned(Archive) then
Result := TAbCabArchive(Archive).CurrentCab
else
Result := 0;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomCabBrowser.GetFolderCount : Word;
begin
if Assigned(Archive) then
Result := TAbCabArchive(Archive).FolderCount
else
Result := 0;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomCabBrowser.GetHasNext : Boolean;
begin
if Assigned(Archive) then
Result := TAbCabArchive(Archive).HasNext
else
Result := False;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomCabBrowser.GetHasPrev : Boolean;
begin
if Assigned(Archive) then
Result := TAbCabArchive(Archive).HasPrev
else
Result := False;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomCabBrowser.GetItem(Index : Integer) : TAbCabItem;
{return cabinet item}
begin
if Assigned(CabArchive) then
Result := CabArchive.Items[Index]
else
Result := nil;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomCabBrowser.GetSetID : Word;
begin
if Assigned(Archive) then
Result := TAbCabArchive(Archive).SetID
else
Result := 0;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabBrowser.InitArchive;
begin
inherited InitArchive;
if Assigned(Archive) then
TAbCabArchive(Archive).SetID := FSetID;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabBrowser.SetFileName(const aFileName : string);
{open/create cabinet archive}
begin
FFileName := aFileName;
if (csDesigning in ComponentState) then
Exit;
if Assigned(FArchive) then begin
FArchive.Free;
FArchive := nil;
end;
if (aFileName <> '') and
FileExists(aFilename) and
(AbDetermineArcType(aFileName, atCab) = atCab) then
begin
FArchive := TAbCabArchive.Create(aFileName, fmOpenRead);
InitArchive;
FArchive.Load;
end;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabBrowser.SetSetID(Value : Word);
begin
FSetID := Value;
if Assigned(Archive) then
TAbCabArchive(Archive).SetID := Value;
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbCView.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbCView.pas *}
{*********************************************************}
{* ABBREVIA: Cabinet archive viewer component *}
{* Use AbQCView.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
Unit AbCView;
{$ENDIF}
{$I AbDefine.inc}
interface
uses
Windows, Classes,
{$IFDEF UsingClx}
AbQView,
{$ELSE}
AbView,
{$ENDIF}
AbCBrows,
AbCabTyp, AbArcTyp;
type
TAbCabView = class(TAbBaseViewer)
protected
FCabComponent : TAbCustomCabBrowser;
FEmptyItemList: TAbArchiveList;
function GetItem(RowNum : Longint) : TAbCabItem;
procedure SetCabComponent(Value : TAbCustomCabBrowser);
procedure Notification(AComponent : TComponent; Operation : TOperation);
override;
procedure DoChange(Sender : TObject);
override;
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
property Items[RowNum : Longint] : TAbCabItem
read GetItem;
published {properties}
property Align;
property Attributes;
property BorderStyle;
property Color;
property Colors;
{$IFNDEF UsingClx}
property Ctl3D;
{$ENDIF}
property Cursor;
property Headings;
property DefaultColWidth;
property DefaultRowHeight;
property DisplayOptions;
property HeaderRowHeight;
property SortAttributes;
{$IFNDEF UsingClx}
property DragCursor;
{$ENDIF}
property DragMode;
property Enabled;
property Font;
property ParentColor;
{$IFNDEF UsingClx}
property ParentCtl3D;
{$ENDIF}
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Version;
property CabComponent : TAbCustomCabBrowser
read FCabComponent write SetCabComponent;
published {Events}
property OnChange;
property OnClick;
property OnDblClick;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnSorted;
property OnDrawSortArrow;
end;
implementation
type
TAbCabBrowserFriend = class(TAbCustomCabBrowser);
{ ===== TAbCabView ========================================================= }
constructor TAbCabView.Create(AOwner : TComponent);
begin
inherited;
FEmptyItemList := FItemList;
end;
{ -------------------------------------------------------------------------- }
destructor TAbCabView.Destroy;
begin
FItemList := FEmptyItemList;
inherited;
end;
{ -------------------------------------------------------------------------- }
function TAbCabView.GetItem(RowNum : Longint) : TAbCabItem;
begin
if Assigned(FItemList) then
Result := TAbCabItem(FItemList.Items[FRowMap[RowNum]])
else
Result := nil;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabView.Notification(AComponent : TComponent; Operation : TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
if Assigned(FCabComponent) and (AComponent = FCabComponent) then begin
FCabComponent := nil;
Refresh;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabView.SetCabComponent(Value : TAbCustomCabBrowser);
begin
FCabComponent := Value;
FCabComponent.OnChange := DoChange;
FCabComponent.OnLoad := DoLoad;
DoChange(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabView.DoChange(Sender : TObject);
begin
if Assigned(FCabComponent) and Assigned(TAbCabBrowserFriend(FCabComponent).Archive) then
FItemList := TAbCabBrowserFriend(FCabComponent).Archive.ItemList
else if FEmptyItemList <> nil then
FItemList := FEmptyItemList;
inherited DoChange(Sender);
end;
end.
================================================
FILE: lib/abbrevia/source/AbCabExt.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbCabExt.pas *}
{*********************************************************}
{* ABBREVIA: Cabinet file extractor component *}
{*********************************************************}
unit AbCabExt;
{$I AbDefine.inc}
interface
uses
Classes,
AbCBrows,
AbArcTyp;
type
TAbCustomCabExtractor = class(TAbCustomCabBrowser)
protected {private}
FExtractOptions : TAbExtractOptions;
FOnConfirmOverwrite : TAbConfirmOverwriteEvent;
procedure DoConfirmOverwrite(var Name : string;
var Confirm : Boolean);
procedure InitArchive;
override;
procedure SetExtractOptions( Value : TAbExtractOptions );
protected {properties}
property ExtractOptions : TAbExtractOptions
read FExtractOptions
write SetExtractOptions
default AbDefExtractOptions;
property OnConfirmOverwrite : TAbConfirmOverwriteEvent
read FOnConfirmOverwrite
write FOnConfirmOverwrite;
public
constructor Create( AOwner : TComponent ); override;
destructor Destroy; override;
procedure ExtractAt(Index : Integer; const NewName : string);
procedure ExtractFiles(const FileMask : string);
procedure ExtractFilesEx(const FileMask, ExclusionMask : string);
procedure ExtractTaggedItems;
end;
{$IFDEF HasPlatformsAttribute}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
TAbCabExtractor = class(TAbCustomCabExtractor)
published
property ArchiveProgressMeter;
property BaseDirectory;
property CabSize;
property CurrentCab;
property ExtractOptions;
property FolderCount;
property HasNext;
property HasPrev;
property ItemProgressMeter;
property OnArchiveProgress;
property OnArchiveItemProgress;
property OnChange;
property OnConfirmOverwrite;
property OnConfirmProcessItem;
property OnLoad;
property OnProcessItemFailure;
property OnRequestImage;
property SetID;
property TempDirectory;
property Version;
property FileName; {must be after OnLoad}
end;
{.Z+}
implementation
uses
AbExcept;
{ TAbCustomCabExtractor ==================================================== }
constructor TAbCustomCabExtractor.Create(AOwner : TComponent);
begin
inherited Create( AOwner );
ExtractOptions := AbDefExtractOptions;
end;
{ -------------------------------------------------------------------------- }
destructor TAbCustomCabExtractor.Destroy;
begin
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabExtractor.DoConfirmOverwrite
(var Name : string;
var Confirm : Boolean);
begin
if Assigned(FOnConfirmOverwrite) then
FOnConfirmOverwrite(Name, Confirm);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabExtractor.ExtractAt(Index : Integer;
const NewName : string);
{extract a file from the archive that match the index}
begin
if Assigned( CabArchive ) then
CabArchive.ExtractAt( Index, NewName )
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabExtractor.ExtractFiles(const FileMask : string);
{Extract files from the cabinet matching the filemask}
begin
if Assigned( CabArchive ) then
CabArchive.ExtractFiles( FileMask )
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabExtractor.ExtractFilesEx(const FileMask, ExclusionMask : string);
{Extract files from the cabinet matching the FileMask, exluding those
matching ExclusionMask}
begin
if Assigned( CabArchive ) then
CabArchive.ExtractFilesEx( FileMask, ExclusionMask )
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabExtractor.ExtractTaggedItems;
{Extract items in the archive that have been tagged}
begin
if Assigned( CabArchive ) then
CabArchive.ExtractTaggedItems
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabExtractor.InitArchive;
{Archive now points to the Cab file, update all Archive's properties...}
begin
inherited InitArchive;
if Assigned( CabArchive ) then begin
{poperties}
CabArchive.ExtractOptions := FExtractOptions;
{events}
CabArchive.OnConfirmOverwrite := DoConfirmOverwrite;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabExtractor.SetExtractOptions( Value : TAbExtractOptions );
begin
FExtractOptions := Value;
if Assigned( FArchive ) then
FArchive.ExtractOptions := Value;
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbCabKit.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbCabKit.PAS *}
{*********************************************************}
{* ABBREVIA: Cabinet file builder/extractor component *}
{*********************************************************}
unit AbCabKit;
{$I AbDefine.inc}
interface
uses
Classes, AbArcTyp,
AbCabMak;
type
TAbCustomCabKit = class(TAbCustomMakeCab)
protected {private}
FExtractOptions : TAbExtractOptions;
FOnConfirmOverwrite : TAbConfirmOverwriteEvent;
procedure DoConfirmOverwrite(var Name : string;
var Confirm : Boolean);
procedure InitArchive; override;
procedure SetExtractOptions( Value : TAbExtractOptions );
procedure SetFileName(const aFileName : string); override;
protected {properties}
property ExtractOptions : TAbExtractOptions
read FExtractOptions
write SetExtractOptions
default AbDefExtractOptions;
protected {events}
property OnConfirmOverwrite : TAbConfirmOverwriteEvent
read FOnConfirmOverwrite
write FOnConfirmOverwrite;
public {methods}
constructor Create( AOwner : TComponent ); override;
destructor Destroy; override;
procedure ExtractAt(Index : Integer; const NewName : string);
procedure ExtractFiles(const FileMask : string);
procedure ExtractFilesEx(const FileMask, ExclusionMask : string);
procedure ExtractTaggedItems;
end;
{$IFDEF HasPlatformsAttribute}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
TAbCabKit = class(TAbCustomCabKit)
published
property ArchiveProgressMeter;
property BaseDirectory;
property CabSize;
property CompressionType;
property CurrentCab;
property ExtractOptions;
property FolderCount;
property FolderThreshold;
property HasNext;
property HasPrev;
property ItemProgressMeter;
property OnArchiveProgress;
property OnArchiveItemProgress;
property OnChange;
property OnConfirmOverwrite;
property OnConfirmProcessItem;
property OnLoad;
property OnProcessItemFailure;
property OnRequestImage;
property OnSave;
property SetID;
property SpanningThreshold;
property TempDirectory;
property Version;
property FileName; {must be after OnLoad}
end;
implementation
uses
SysUtils,
AbExcept,
AbCabTyp,
AbCBrows;
{ TAbCustomCabKit ==================================================== }
constructor TAbCustomCabKit.Create(AOwner : TComponent);
begin
inherited Create( AOwner );
ExtractOptions := AbDefExtractOptions;
end;
{ -------------------------------------------------------------------------- }
destructor TAbCustomCabKit.Destroy;
begin
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabKit.DoConfirmOverwrite(var Name : string;
var Confirm : Boolean);
begin
if Assigned(FOnConfirmOverwrite) then
FOnConfirmOverwrite(Name, Confirm);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabKit.ExtractAt(Index : Integer; const NewName : string);
{extract a file from the archive that match the index}
begin
if Assigned( CabArchive ) then
CabArchive.ExtractAt( Index, NewName )
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabKit.ExtractFiles(const FileMask : string);
{Extract files from the cabinet matching the filemask}
begin
if Assigned(CabArchive) then
CabArchive.ExtractFiles(FileMask)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabKit.ExtractFilesEx(const FileMask, ExclusionMask : string);
{Extract files from the cabinet matching the FileMask, exluding those
matching ExclusionMask}
begin
if Assigned(CabArchive) then
CabArchive.ExtractFilesEx(FileMask, ExclusionMask)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabKit.ExtractTaggedItems;
{Extract items in the archive that have been tagged}
begin
if Assigned(CabArchive) then
CabArchive.ExtractTaggedItems
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabKit.InitArchive;
begin
inherited InitArchive;
if Assigned( CabArchive ) then begin
{poperties}
CabArchive.ExtractOptions := FExtractOptions;
{events}
CabArchive.OnConfirmOverwrite := DoConfirmOverwrite;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabKit.SetExtractOptions( Value : TAbExtractOptions );
begin
FExtractOptions := Value;
if Assigned( FArchive ) then
FArchive.ExtractOptions := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomCabKit.SetFileName(const aFileName : string);
{Create or open the specified cabinet file}
begin
FFilename := aFileName;
if csDesigning in ComponentState then
Exit;
if Assigned(FArchive) then begin
FArchive.Free;
FArchive := nil;
end;
if (aFileName <> '') then begin
if (aFileName <> '') and FileExists(aFilename) then
FArchive := TAbCabArchive.Create(aFileName, fmOpenRead)
else
FArchive := TAbCabArchive.Create(aFileName, fmOpenWrite);
InitArchive;
FArchive.Load;
end;
DoChange;
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbCabMak.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbCabMak.pas *}
{*********************************************************}
{* ABBREVIA: Cabinet builder component (VCL) *}
{* See AbQCabMk.pas for the CLX header *}
{*********************************************************}
unit AbCabMak;
{$I AbDefine.inc}
interface
uses
Classes,
AbCBrows,
AbArcTyp, AbCabTyp;
type
TAbCustomMakeCab = class(TAbCustomCabBrowser)
protected {private}
FFolderThreshold : Longint;
FCompressionType : TAbCabCompressionType;
FStoreOptions : TAbStoreOptions;
FOnSave : TAbArchiveEvent;
protected {methods}
procedure DoSave(Sender : TObject); virtual;
procedure InitArchive; override;
procedure SetFolderThreshold(Value : Longint);
procedure SetCompressionType(Value : TAbCabCompressionType);
procedure SetFileName(const aFileName : string); override;
procedure SetStoreOptions( Value : TAbStoreOptions );
protected {properties}
property CompressionType : TAbCabCompressionType
read FCompressionType
write SetCompressionType;
property FolderThreshold : Longint
read FFolderThreshold
write SetFolderThreshold;
property StoreOptions : TAbStoreOptions
read FStoreOptions
write SetStoreOptions
default AbDefStoreOptions;
protected {events}
property OnSave : TAbArchiveEvent
read FOnSave
write FOnSave;
public {methods}
constructor Create( AOwner : TComponent ); override;
procedure AddFiles(const FileMask : string; SearchAttr : Integer );
procedure AddFilesEx(const FileMask : string;
const ExclusionMask : string; SearchAttr : Integer );
procedure StartNewFolder;
procedure StartNewCabinet;
end;
type
{$IFDEF HasPlatformsAttribute}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
TAbMakeCab = class(TAbCustomMakeCab)
published
property ArchiveProgressMeter;
property BaseDirectory;
property CabSize;
property CompressionType;
property FolderThreshold;
property ItemProgressMeter;
property StoreOptions;
property OnArchiveProgress;
property OnArchiveItemProgress;
property OnChange;
property OnConfirmProcessItem;
property OnLoad;
property OnProcessItemFailure;
property OnRequestImage;
property OnSave;
property SetID;
property SpanningThreshold;
property TempDirectory;
property Version;
property FileName; {must be after OnLoad}
end;
{.Z+}
implementation
uses
SysUtils,
AbExcept,
AbUtils;
{ TAbCustomMakeCab ========================================================= }
constructor TAbCustomMakeCab.Create( AOwner : TComponent );
begin
inherited Create( AOwner );
FCompressionType := AbDefCompressionType;
FSpanningThreshold := AbDefCabSpanningThreshold;
FFolderThreshold := AbDefFolderThreshold;
FSetID := 0;
FStoreOptions := AbDefStoreOptions;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMakeCab.AddFiles(const FileMask : string; SearchAttr : Integer );
{Add files to the cabinet where the disk filespec matches}
begin
if Assigned(CabArchive) then
CabArchive.AddFiles(FileMask, SearchAttr)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMakeCab.AddFilesEx(const FileMask : string;
const ExclusionMask : string;
SearchAttr : Integer);
{Add files that match Filemask except those matching ExclusionMask}
begin
if Assigned(CabArchive) then
CabArchive.AddFilesEx(FileMask, ExclusionMask, SearchAttr)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMakeCab.DoSave(Sender : TObject);
begin
if Assigned(FOnSave) then
FOnSave(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMakeCab.InitArchive;
begin
inherited InitArchive;
if Assigned(CabArchive) then begin
{properties}
CabArchive.FolderThreshold := FFolderThreshold;
CabArchive.CompressionType := FCompressionType;
CabArchive.SetID := FSetID;
CabArchive.StoreOptions := FStoreOptions;
{events}
CabArchive.OnSave := DoSave;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMakeCab.SetCompressionType(Value : TAbCabCompressionType);
{Set the type of compression to use}
begin
FCompressionType := Value;
if Assigned(CabArchive) then
CabArchive.CompressionType := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMakeCab.SetFileName(const aFileName : string);
{Create the specified cabinet file}
begin
FFilename := aFileName;
if csDesigning in ComponentState then
Exit;
if Assigned(FArchive) then begin
FArchive.Free;
FArchive := nil;
end;
if (aFileName <> '') then begin
FArchive := TAbCabArchive.Create(aFileName, fmOpenWrite);
InitArchive;
FArchive.Load;
FArchiveType := atCab;
end;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMakeCab.SetFolderThreshold(Value : Longint);
{Set folder compression boundary}
begin
FFolderThreshold := Value;
if Assigned(CabArchive) then
CabArchive.FolderThreshold := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMakeCab.SetStoreOptions(Value : TAbStoreOptions);
begin
FStoreOptions := Value;
if Assigned(CabArchive) then
CabArchive.StoreOptions := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMakeCab.StartNewCabinet;
{Flush current cabinet and start a new one}
begin
if Assigned(CabArchive) then
CabArchive.NewCabinet
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMakeCab.StartNewFolder;
{Flush current folder and start a new one}
begin
if Assigned(CabArchive) then
CabArchive.NewFolder
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbCabTyp.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Craig Peterson
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbCabTyp.pas *}
{*********************************************************}
{* ABBREVIA: Cabinet Archive *}
{* Based on info from the FCI/FDI Library Description, *}
{* included in the Microsoft Cabinet SDK *}
{*********************************************************}
unit AbCabTyp;
{$I AbDefine.inc}
interface
uses
Windows, Classes, AbFciFdi, AbArcTyp, AbUtils;
type
TAbCabItem = class(TAbArchiveItem)
protected {private}
FPartialFile : Boolean;
FRawFileName : AnsiString;
public
property PartialFile : Boolean
read FPartialFile
write FPartialFile;
property RawFileName : AnsiString
read FRawFileName
write FRawFileName;
end;
type
TAbCabCompressionType = (ctNone, ctMSZIP, ctLZX);
TAbCabinetMode = (cmRead, cmWrite);
TAbCabStatus = (csFile, csFolder, csCabinet);
const
faExtractAndExecute = $040;
faUTF8Name = $080;
AbDefCabSpanningThreshold = 0;
AbDefFolderThreshold = 0;
AbDefCompressionType = ctMSZIP;
AbDefReserveHeaderSize = 0;
AbDefReserveFolderSize = 0;
AbDefReserveDataSize = 0;
AbDefLZXWindowSize = 18;
CompressionTypeMap : array[TAbCabCompressionType] of Word = (0, 1, 4611);
type
TAbCabArchive = class(TAbArchive)
protected {private}
{internal variables}
FCabName : AnsiString;
FCabPath : AnsiString;
FFCICabInfo : FCICabInfo;
FFCIContext : HFCI;
FFDIContext : HFDI;
FFDICabInfo : FDICabInfo;
FErrors : CabErrorRecord;
FItemInProgress : TAbCabItem;
FItemStream : TStream;
FIIPName : string;
FItemProgress : DWord;
FNextCabinet : string;
FNextDisk : string;
FTempFileID : Integer;
{property variables}
FCurrentCab : Word;
FCabSize : Longint;
FCompressionType : TAbCabCompressionType;
FFileCount : Word;
FFolderThreshold : LongWord;
FFolderCount : Word;
FHasPrev : Boolean;
FHasNext : Boolean;
FSetID : Word;
{internal methods}
procedure CloseCabFile;
procedure CreateCabFile;
function CreateItem( const FileSpec : string ): TAbArchiveItem;
override;
procedure DoCabItemProgress(BytesCompressed : DWord;
var Abort : Boolean);
procedure DoGetNextCabinet(CabIndex : Integer; var CabName : string;
var Abort : Boolean);
procedure ExtractItemAt(Index : Integer; const NewName : string);
override;
procedure ExtractItemToStreamAt(Index : Integer; OutStream : TStream);
override;
function GetItem(ItemIndex : Integer) : TAbCabItem;
procedure LoadArchive;
override;
procedure OpenCabFile;
procedure PutItem( Index : Integer; Value : TAbCabItem );
procedure SaveArchive;
override;
procedure SetFolderThreshold(Value : LongWord);
procedure SetSetID(Value : Word);
procedure SetSpanningThreshold(Value : Int64);
override;
procedure TestItemAt(Index : Integer);
override;
public {methods}
constructor Create(const FileName : string; Mode : Word);
override;
constructor CreateFromStream(aStream : TStream; const aArchiveName : string);
override;
destructor Destroy;
override;
procedure Add(aItem : TAbArchiveItem);
override;
procedure NewCabinet;
procedure NewFolder;
public {properties}
property CurrentCab : Word
read FCurrentCab;
property CabSize : Longint
read FCabSize;
property CompressionType : TAbCabCompressionType
read FCompressionType
write FCompressionType;
property FolderThreshold : LongWord
read FFolderThreshold
write SetFolderThreshold;
property FolderCount : Word
read FFolderCount;
property HasPrev : Boolean
read FHasPrev;
property HasNext : Boolean
read FHasNext;
property Items[Index : Integer] : TAbCabItem
read GetItem
write PutItem; default;
property ItemProgress : DWord
read FItemProgress
write FItemProgress;
property SetID : Word
read FSetID
write SetSetID;
end;
function VerifyCab(const Fn : string) : TAbArchiveType; overload;
function VerifyCab(Strm : TStream) : TAbArchiveType; overload;
implementation
uses
SysUtils,
{$IFDEF HasAnsiStrings}
System.AnsiStrings,
{$ENDIF}
AbCharset, AbConst, AbExcept;
{$WARN UNIT_PLATFORM OFF}
{$WARN SYMBOL_PLATFORM OFF}
type
PWord = ^Word;
PInteger = ^Integer;
{ == FDI/FCI Callback Functions - cdecl calling convention ================= }
function FXI_GetMem(uBytes : Integer) : Pointer;
cdecl;
{allocate memory}
begin
Result := nil;
if (uBytes > 0) then
GetMem(Result, uBytes);
end;
{ -------------------------------------------------------------------------- }
procedure FXI_FreeMem(lpBuffer : Pointer);
cdecl;
{free memory}
begin
FreeMem(lpBuffer);
end;
{ == FCI Callback Functions - cdecl calling convention ===================== }
function FCI_FileOpen(lpPathName: PAnsiChar; Flag, Mode: Integer;
PError: PInteger; Archive: TAbCabArchive) : PtrInt;
cdecl;
{open a file}
begin
Result := _lcreat(lpPathName, 0);
if (Result = -1) then
raise EAbFCIFileOpenError.Create;
end;
{ -------------------------------------------------------------------------- }
function FCI_FileRead(hFile: PtrInt; lpBuffer: Pointer;
uBytes: UINT; PError: PInteger; Archive: TAbCabArchive) : UINT;
cdecl;
{read from a file}
begin
Result := _lread(hFile, lpBuffer, uBytes);
if (Result = UINT(-1)) then
raise EAbFCIFileReadError.Create;
end;
{ -------------------------------------------------------------------------- }
function FCI_FileWrite(hFile: PtrInt; lpBuffer: Pointer;
uBytes: UINT; PError: PInteger; Archive: TAbCabArchive) : UINT;
cdecl;
{write to a file}
begin
Result := _lwrite(hFile, lpBuffer, uBytes);
if (Result = UINT(-1)) then
raise EAbFCIFileWriteError.Create;
end;
{ -------------------------------------------------------------------------- }
function FCI_FileClose(hFile: PtrInt; PError: PInteger;
Archive: TAbCabArchive) : Integer;
cdecl;
{close a file}
begin
Result := _lclose(hFile);
if (Result = -1) then
raise EAbFCIFileCloseError.Create;
end;
{ -------------------------------------------------------------------------- }
function FCI_FileSeek(hFile: PtrInt; Offset: Longint;
Origin: Integer; PError: PInteger; Archive: TAbCabArchive) : Longint;
cdecl;
{reposition file pointer}
begin
Result := _llseek(hFile, Offset, Origin);
if (Result = -1) then
raise EAbFCIFileSeekError.Create;
end;
{ -------------------------------------------------------------------------- }
function FCI_FileDelete(lpFilename: PAnsiChar; PError: PInteger;
Archive: TAbCabArchive) : Boolean;
cdecl;
{delete a file}
begin
Result := SysUtils.DeleteFile(string(lpFilename));
if not Result then
raise EAbFCIFileDeleteError.Create;
end;
{ -------------------------------------------------------------------------- }
function FCI_GetNextCab(lpCCab: PFCICabInfo; PrevCab: Longint;
Archive: TAbCabArchive) : Boolean;
cdecl;
{get next cabinet filename}
var
CabName : string;
Abort : Boolean;
begin
Abort := False;
with lpCCab^ do begin
CabName := string(szCab);
{obtain next cabinet. Make index zero-based}
Archive.DoGetNextCabinet(Pred(iCab), CabName, Abort);
if not Abort then
AbStrPLCopy(szCab, AnsiString(CabName), Length(szCab));
end;
Result := not Abort;
end;
{ -------------------------------------------------------------------------- }
function FCI_FileDest(PCCab: PFCICabInfo; PFilename: PAnsiChar; cbFile: Longint;
Continuation: Boolean; Archive: TAbCabArchive) : Integer;
cdecl;
{currently not used}
begin
Result := 0;
end;
{ -------------------------------------------------------------------------- }
function FCI_GetOpenInfo(lpPathname: Pointer; PDate, PTime, PAttribs : PWord;
PError: PInteger; Archive: TAbCabArchive) : PtrInt;
cdecl;
{open a file and return date/attributes}
var
AttrEx: TAbAttrExRec;
I, DT: Integer;
RawName: RawByteString;
begin
Result := FileOpen(string(lpPathname), fmOpenRead or fmShareDenyNone);
if (Result = -1) then
raise EAbFCIFileOpenError.Create;
if not AbFileGetAttrEx(string(lpPathname), AttrEx) then
raise EAbFileNotFound.Create;
PAttribs^ := AttrEx.Attr;
DT := DateTimeToFileDate(AttrEx.Time);
PDate^ := DT shr 16;
PTime^ := DT and $0FFFF;
Archive.ItemProgress := 0;
Archive.FItemInProgress.UncompressedSize := AttrEx.Size;
RawName := Archive.FItemInProgress.RawFileName;
for I := 1 to Length(RawName) do
if Ord(RawName[I]) > 127 then
PAttribs^ := PAttribs^ or faUTF8Name;
end;
{ -------------------------------------------------------------------------- }
function FCI_Status(Status: Word; cb1, cb2: DWord;
Archive: TAbCabArchive) : Longint; cdecl;
{keep archive informed}
var
Abort : Boolean;
begin
Result := 0;
if (Status = Word(csCabinet)) then begin
Archive.DoSave;
Archive.FCabSize := cb2;
Result := cb2;
end else if (Status = Word(csFolder)) then
Archive.FCabSize := Archive.FCabSize + Longint(cb2)
else if (Status = Word(csFile)) then begin
Archive.DoCabItemProgress(cb2, Abort);
Result := Longint(Abort);
end;
end;
{ -------------------------------------------------------------------------- }
function FCI_GetTempFile(lpTempName: PAnsiChar; TempNameSize: Integer;
Archive: TAbCabArchive) : PtrInt; cdecl;
{obtain temporary filename}
var
TempPath : array[0..255] of AnsiChar;
begin
Archive.FTempFileID := Archive.FTempFileID + 1;
if (Archive.TempDirectory <> '') then
AbStrPLCopy(TempPath, AnsiString(Archive.TempDirectory), Length(TempPath))
else
GetTempPathA(255, TempPath);
GetTempFileNameA(TempPath, 'VMS', Archive.FTempFileID, lpTempName);
Result := 1;
end;
{ == FDI Callback Functions - cdecl calling convention ===================== }
function FDI_FileOpen(lpPathName: PAnsiChar; Flag, Mode: Integer) : PtrInt;
cdecl;
{open a file}
begin
try
Result := PtrInt(TFileStream.Create(string(lpPathName), fmOpenRead or fmShareDenyWrite));
except on EFOpenError do
Result := -1;
end;
end;
{ -------------------------------------------------------------------------- }
function FDI_FileRead(hFile: PtrInt; lpBuffer: Pointer; uBytes: UINT) : UINT;
cdecl;
{read from a file}
begin
Result := TStream(hFile).Read(lpBuffer^, uBytes);
end;
{ -------------------------------------------------------------------------- }
function FDI_FileWrite(hFile: PtrInt; lpBuffer: Pointer; uBytes: UINT) : UINT;
cdecl;
{write to a file}
begin
Result := TStream(hFile).Write(lpBuffer^, uBytes);
end;
{ -------------------------------------------------------------------------- }
function FDI_FileClose(hFile : PtrInt) : Longint;
cdecl;
{close a file}
begin
try
TStream(hFile).Free;
Result := 0;
except
Result := -1;
end;
end;
{ -------------------------------------------------------------------------- }
function FDI_FileSeek(hFile : PtrInt; Offset : Longint; Origin : Integer) : Longint;
cdecl;
{reposition file pointer}
begin
Result := TStream(hFile).Seek(Offset, Origin);
end;
{ -------------------------------------------------------------------------- }
function FDI_EnumerateFiles(fdint : FDINOTIFICATIONTYPE;
pfdin : PFDINotification) : PtrInt;
cdecl;
{Enumerate the files and build the archive file list}
var
Item : TAbCabItem;
Archive : TAbCabArchive;
begin
Result := 0;
Archive := pfdin^.pv;
with Archive do case fdint of
FDINT_Cabinet_Info :
begin
FSetID := pfdin^.setID;
FCurrentCab := pfdin^.iCabinet;
FNextCabinet := string(pfdin^.psz1);
FNextDisk := string(pfdin^.psz2);
Result := 0;
end;
FDINT_Copy_File, FDINT_Partial_File :
begin
Item := TAbCabItem.Create;
with Item do begin
RawFileName := AnsiString(pfdin^.psz1);
if (pfdin^.attribs and faUTF8Name) = faUTF8Name then
Filename := UTF8ToString(RawFileName)
else
Filename := string(RawFileName);
UnCompressedSize := pfdin^.cb;
LastModFileDate := pfdin^.date;
LastModFileTime := pfdin^.time;
ExternalFileAttributes := pfdin^.attribs;
IsEncrypted := False; {encryption not implemented at this time}
PartialFile := (fdint = FDINT_Partial_File);
end;
FItemList.Add(Item);
Result := 0;
end;
end;
end;
{ -------------------------------------------------------------------------- }
function FDI_ExtractFiles(fdint : FDINOTIFICATIONTYPE;
pfdin : PFDINotification) : PtrInt;
cdecl;
{extract file from cabinet}
var
Archive : TAbCabArchive;
begin
Result := 0;
Archive := pfdin^.pv;
case fdint of
FDINT_Copy_File :
begin
if (AnsiString(pfdin^.psz1) = Archive.FItemInProgress.RawFileName) then
if Archive.FIIPName <> '' then
Result := Integer(TFileStream.Create(Archive.FIIPName, fmCreate))
else
Result := Integer(Archive.FItemStream)
else
Result := 0;
end;
FDINT_Next_Cabinet :
begin
if pfdin^.fdie = FDIError_None then
Result := 0
else
Result := -1;
end;
FDINT_Close_File_Info :
begin
if Archive.FIIPName <> '' then begin
FileSetDate(TFileStream(pfdin^.hf).Handle,
Longint(pfdin^.date) shl 16 + pfdin^.time);
TFileStream(pfdin^.hf).Free;
FileSetAttr(Archive.FIIPName, pfdin^.attribs);
end;
Result := 1;
end;
end;
end;
{ == TAbCabArchive ========================================================= }
function VerifyCab(const Fn : string) : TAbArchiveType;
var
Stream : TFileStream;
begin
Stream := TFileStream.Create(FN, fmOpenRead or fmShareDenyNone);
try
Result := VerifyCab(Stream);
finally
Stream.Free;
end;
end;
{ -------------------------------------------------------------------------- }
function VerifyCab(Strm : TStream) : TAbArchiveType; overload;
var
Context : HFDI;
Info : FDICabInfo;
Errors : CabErrorRecord;
StartPos : int64;
begin
Result := atUnknown;
Context := FDICreate(@FXI_GetMem, @FXI_FreeMem, @FDI_FileOpen,
@FDI_FileRead, @FDI_FileWrite, @FDI_FileClose, @FDI_FileSeek, cpuDefault,
@Errors);
if Context = nil then
Exit;
try
StartPos := Strm.Position;
if FDIIsCabinet(Context, Integer(Strm), @Info) then
Result := atCab;
Strm.Position := StartPos;
finally
FDIDestroy(Context);
end;
end;
{ == TAbCabArchive ========================================================= }
constructor TAbCabArchive.Create(const FileName : string; Mode : Word );
begin
{Mode is used to identify which interface to use: }
{ fmOpenWrite - FCI, fmOpenRead - FDI}
inherited CreateInit;
if (Mode and fmCreate) = fmCreate then FMode := fmOpenWrite
else FMode := Mode and fmOpenWrite;
FArchiveName := FileName;
FCabName := AnsiString(ExtractFileName(FileName));
FCabPath := AnsiString(ExtractFilePath(FileName));
SpanningThreshold := AbDefCabSpanningThreshold;
FFolderThreshold := AbDefFolderThreshold;
FItemInProgress := nil;
FItemProgress := 0;
end;
{ -------------------------------------------------------------------------- }
constructor TAbCabArchive.CreateFromStream(aStream : TStream;
const aArchiveName : string);
begin
raise EAbCabException.Create('TAbCabArchive does not support CreateFromStream');
end;
{ -------------------------------------------------------------------------- }
destructor TAbCabArchive.Destroy;
begin
CloseCabFile;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.Add(aItem : TAbArchiveItem);
{add a file to the cabinet}
var
Confirm, ItemAdded : Boolean;
Item : TAbCabItem;
begin
ItemAdded := False;
try
CheckValid;
if (FMode <> fmOpenWrite) then begin
DoProcessItemFailure(aItem, ptAdd, ecCabError, 0);
Exit;
end;
if FItemList.IsActiveDupe(aItem.FileName) then begin
DoProcessItemFailure(aItem, ptAdd, ecAbbrevia, AbDuplicateName);
Exit;
end;
DoConfirmProcessItem(aItem, ptAdd, Confirm);
if not Confirm then
Exit;
Item := TAbCabItem(aItem);
FItemInProgress := Item;
Item.Action := aaAdd;
Item.RawFileName := UTF8Encode(Item.FileName);
if not FCIAddFile(FFCIContext, Pointer(Item.DiskFileName),
PAnsiChar(Item.RawFileName), False, @FCI_GetNextCab, @FCI_Status,
@FCI_GetOpenInfo, CompressionTypeMap[FCompressionType]) then
raise EAbFCIAddFileError.Create;
FItemList.Add(Item);
ItemAdded := True;
FIsDirty := True;
finally
if not ItemAdded then
aItem.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.CloseCabFile;
{Make sure the Cabinet DLL is shut down}
var
Abort : Boolean;
begin
if (FFDIContext <> nil) then begin
FDIDestroy(FFDIContext);
FFDIContext := nil;
end;
if (FFCIContext <> nil) then begin
FCIFlushCabinet(FFCIContext, False, @FCI_GetNextCab, @FCI_Status);
FCIDestroy(FFCIContext);
FFCIContext := nil;
end;
DoArchiveProgress(0, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.CreateCabFile;
{create a new cabinet}
begin
{set cabinet parameters}
with FFCICabInfo do begin
if (SpanningThreshold > 0) then
cb := SpanningThreshold
else
cb := AbDefCabSpanningThreshold;
if (FolderThreshold > 0) then
cbFolderThresh := FolderThreshold
else
cbFolderThresh := AbDefFolderThreshold;
cbReserveCFHeader := AbDefReserveHeaderSize;
cbReserveCFFolder := AbDefReserveFolderSize;
cbReserveCFData := AbDefReserveDataSize;
iCab := 1;
iDisk := 0;
fFailOnIncompressible := 0;
setID := SetID;
AbStrPCopy(szDisk, '');
AbStrPLCopy(szCab, FCabName, Length(szCab));
AbStrPLCopy(szCabPath, FCabPath, Length(szCabPath));
end;
{obtain an FCI context}
FFCIContext := FCICreate(@FErrors, @FCI_FileDest, @FXI_GetMem, @FXI_FreeMem,
@FCI_FileOpen, @FCI_FileRead, @FCI_FileWrite, @FCI_FileClose, @FCI_FileSeek,
@FCI_FileDelete, @FCI_GetTempFile, @FFCICabInfo, Self);
if (FFCIContext = nil) then
if FErrors.ErrorPresent then begin
CloseCabFile;
raise EAbFCICreateError.Create;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbCabArchive.CreateItem( const FileSpec : string ): TAbArchiveItem;
{create a new item for the file list}
begin
Result := TAbCabItem.Create;
with TAbCabItem(Result) do begin
CompressedSize := 0;
DiskFileName := ExpandFileName(FileSpec);
FileName := FixName(FileSpec);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.DoCabItemProgress(BytesCompressed : DWord;
var Abort : Boolean);
{fire OnCabItemProgress event}
var
Progress : Byte;
begin
Abort := False;
if Assigned(FOnArchiveItemProgress) then begin
Inc(FItemProgress, BytesCompressed);
Progress := AbPercentage(FItemProgress,
FItemInProgress.UnCompressedSize);
FOnArchiveItemProgress(Self, FItemInProgress, Progress, Abort);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.DoGetNextCabinet(CabIndex : Integer;
var CabName : string; var Abort : Boolean);
{fire OnRequestImage event}
begin
Abort := False;
if Assigned(FOnRequestImage) then
FOnRequestImage(Self, CabIndex, CabName, Abort)
else
AbIncFilename(CabName, CabIndex);
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.ExtractItemAt(Index : Integer; const NewName : string);
{extract a file from the cabinet}
begin
FItemInProgress := GetItem(Index);
FIIPName := NewName;
try
if not FDICopy(FFDIContext, PAnsiChar(FCabName), PAnsiChar(FCabPath), 0,
@FDI_ExtractFiles, nil, Self) then
DoProcessItemFailure(FItemInProgress, ptExtract, ecCabError, FErrors.ErrorCode);
finally
FIIPName := '';
end;
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.ExtractItemToStreamAt(Index : Integer; OutStream : TStream);
begin
FItemInProgress := GetItem(Index);
FItemStream := OutStream;
try
if not FDICopy(FFDIContext, PAnsiChar(FCabName), PAnsiChar(FCabPath), 0,
@FDI_ExtractFiles, nil, Self) then
DoProcessItemFailure(FItemInProgress, ptExtract, ecCabError, FErrors.ErrorCode);
finally
FItemStream := nil;
end;
end;
{----------------------------------------------------------------------------}
function TAbCabArchive.GetItem(ItemIndex : Integer) : TAbCabItem;
{fetch an item from the file list}
begin
Result := TAbCabItem(FItemList.Items[ItemIndex]);
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.LoadArchive;
{Open existing cabinet or create a new one}
begin
if (FMode = fmOpenRead) then begin
FFDIContext := FDICreate(@FXI_GetMem, @FXI_FreeMem, @FDI_FileOpen,
@FDI_FileRead, @FDI_FileWrite, @FDI_FileClose, @FDI_FileSeek,
cpuDefault, @FErrors);
if (FFDIContext = nil) then
raise EAbFDICreateError.Create;
OpenCabFile;
end else
CreateCabFile;
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.NewCabinet;
{flush current cabinet and start a new one}
begin
if not FCIFlushCabinet(FFCIContext, True, @FCI_GetNextCab, @FCI_Status) then
raise EAbFCIFlushCabinetError.Create;
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.NewFolder;
{flush current folder and start a new one}
begin
if not FCIFlushFolder(FFCIContext, @FCI_GetNextCab, @FCI_Status) then
raise EAbFCIFlushFolderError.Create;
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.OpenCabFile;
{Open an existing cabinet}
var
Abort : Boolean;
Stream : TFileStream;
begin
{verify that the archive can be opened and is a cabinet}
Stream := TFileStream.Create(FArchiveName, fmOpenRead or fmShareDenyNone);
try
if not FDIIsCabinet(FFDIContext, PtrInt(Stream), @FFDICabInfo) then begin
CloseCabFile;
raise EAbInvalidCabFile.Create;
end;
finally
Stream.Free;
end;
{store information about the cabinet}
FCabSize := FFDICabInfo.cbCabinet;
FFolderCount := FFDICabInfo.cFolders;
FFileCount := FFDICabInfo.cFiles;
FCurrentCab := FFDICabInfo.iCabinet;
FHasPrev := FFDICabInfo.hasPrev;
FHasNext := FFDICabInfo.hasNext;
{Enumerate the files and build the file list}
if not FDICopy(FFDIContext, PAnsiChar(FCabName), PAnsiChar(FCabPath), 0,
@FDI_EnumerateFiles, nil, Self) then begin
CloseCabFile;
raise EAbFDICopyError.Create;
end;
DoArchiveProgress(100, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.PutItem( Index : Integer; Value : TAbCabItem );
{replace an existing item in the file list}
begin
FItemList.Items[Index] := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.SaveArchive;
begin
{ No-op; file is flushed in destructor }
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.SetFolderThreshold(Value : LongWord);
{set maximum compression boundary}
begin
if (Value > 0) then
FFolderThreshold := Value
else
FFolderThreshold := AbDefFolderThreshold;
FFCICabInfo.cbFolderThresh := FFolderThreshold;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.SetSetID(Value : Word);
{set cabinet SetID}
begin
FSetID := Value;
FFCICabInfo.SetID := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.SetSpanningThreshold(Value : Int64);
{set maximum cabinet size}
begin
if (Value > 0) then
FSpanningThreshold := Value
else
FSpanningThreshold := AbDefCabSpanningThreshold;
FFCICabInfo.cb := FSpanningThreshold;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.TestItemAt(Index : Integer);
begin
{not implemented for cabinet archives}
end;
end.
================================================
FILE: lib/abbrevia/source/AbCharset.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* Craig Peterson
*
* Portions created by the Initial Developer are Copyright (C) 2011
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbCharset.pas *}
{*********************************************************}
{* ABBREVIA: Types and routines for working with various *}
{* character encodings. *}
{*********************************************************}
unit AbCharset;
{$I AbDefine.inc}
interface
{$IFDEF MSWINDOWS}
uses
Windows;
{$ENDIF}
{ Unicode backwards compatibility types }
{$IF NOT DECLARED(RawByteString)}
type
RawByteString = AnsiString;
{$IFEND}
{$IF NOT DECLARED(UnicodeString)}
type
UnicodeString = WideString;
{$IFEND}
type
TAbCharSet = (csASCII, csANSI, csUTF8);
function AbDetectCharSet(const aValue: RawByteString): TAbCharSet;
function AbIsOEM(const aValue: RawByteString): Boolean;
function AbRawBytesToString(const aValue: RawByteString): string;
function AbStringToUnixBytes(const aValue: string): RawByteString;
function AbSysCharSetIsUTF8: Boolean;
{$IFDEF MSWINDOWS}
function AbTryEncode(const aValue: UnicodeString; aCodePage: UINT;
aAllowBestFit: Boolean; out aResult: AnsiString): Boolean;
{$ENDIF}
{ Unicode backwards compatibility functions }
{$IFNDEF UNICODE}
function UTF8ToString(const S: RawByteString): string;
{$ENDIF}
implementation
uses
{$IFDEF LibcAPI}
Libc,
{$ENDIF}
SysUtils;
function AbDetectCharSet(const aValue: RawByteString): TAbCharSet;
var
i, TrailCnt: Integer;
begin
Result := csASCII;
TrailCnt := 0;
for i := 1 to Length(aValue) do begin
if Byte(aValue[i]) >= $80 then
Result := csANSI;
if TrailCnt > 0 then
if Byte(aValue[i]) in [$80..$BF] then
Dec(TrailCnt)
else Exit
else if Byte(aValue[i]) in [$80..$BF] then
Exit
else
case Byte(aValue[i]) of
$C0..$C1, $F5..$FF: Exit;
$C2..$DF: TrailCnt := 1;
$E0..$EF: TrailCnt := 2;
$F0..$F4: TrailCnt := 3;
end;
end;
if (TrailCnt = 0) and (Result = csANSI) then
Result := csUTF8;
end;
{ -------------------------------------------------------------------------- }
function AbIsOEM(const aValue: RawByteString): Boolean;
// Detect whether a string of bytes is likely to be the system's ANSI or OEM codepage
{$IFDEF MSWINDOWS}
const
// Byte values of alpha-numeric characters in OEM and ANSI codepages.
// Excludes NBSP, ordinal indicators, exponents, the florin symbol, and, for
// ANSI codepages matched to certain OEM ones, the micro character.
//
// US (OEM 437, ANSI 1252)
Oem437AnsiChars =
[138, 140, 142, 154, 156, 158, 159, 181, 192..214, 216..246, 248..255];
Oem437OemChars =
[128..154, 160..165, 224..235, 237, 238];
// Arabic (OEM 720, ANSI 1256)
Oem720AnsiChars =
[129, 138, 140..144, 152, 154, 156, 159, 170, 181, 192..214, 216..239, 244,
249, 251, 252, 255];
Oem720OemChars =
[130, 131, 133, 135..140, 147, 149..155, 157..173, 224..239];
// Greek (OEM 737, ANSI 1253)
Oem737AnsiChars =
[162, 181, 184..186, 188, 190..209, 211..254];
Oem737OemChars =
[128..175, 224..240, 244, 245];
// Baltic Rim (OEM 775, ANSI 1257)
Oem775AnsiChars =
[168, 170, 175, 184, 186, 191..214, 216..246, 248..254];
Oem775OemChars =
[128..149, 151..155, 157, 160..165, 173, 181..184, 189, 190, 198, 199,
207..216, 224..238];
// Western European (OEM 850, ANSI 1252)
Oem850AnsiChars =
[138, 140, 142, 154, 156, 158, 159, 192..214, 216..246, 248..255];
Oem850OemChars =
[128..155, 157, 160..165, 181..183, 198, 199, 208..216, 222, 224..237];
// Central & Eastern European (OEM 852, ANSI 1250)
Oem852AnsiChars =
[138, 140..143, 154, 156..159, 163, 165, 170, 175, 179, 185, 186, 188,
190..214, 216..246, 248..254];
Oem852OemChars =
[128..157, 159..169, 171..173, 181..184, 189, 190, 198, 199, 208..216, 221,
222, 224..238, 251..253];
// Cyrillic (OEM 855, ANSI 1251)
Oem855AnsiChars =
[128, 129, 131, 138, 140..144, 154, 156..159, 161..163, 165, 168, 170, 175,
178..180, 184, 186, 188..255];
Oem855OemChars =
[128..173, 181..184, 189, 190, 198, 199, 208..216, 221, 222, 224..238,
241..252];
// Turkish (OEM 857, ANSI 1254)
Oem857AnsiChars =
[138, 140, 154, 156, 159, 192..214, 216..246, 248..255];
Oem857OemChars =
[128..155, 157..167, 181..183, 198, 199, 210..212, 214..216, 222, 224..230,
233..237];
// Hebrew (OEM 862, ANSI 1255)
Oem862AnsiChars =
[181, 212..214, 224..250];
Oem862OemChars =
[128..154, 160..165, 224..235, 237, 238];
// Cyrillic CIS (OEM 866, ANSI 1251)
Oem866AnsiChars =
[128, 129, 131, 138, 140..144, 154, 156..159, 161..163, 165, 168, 170, 175,
178..181, 184, 186, 188..255];
Oem866OemChars =
[128..175, 224..247];
var
AnsiChars, OemChars: set of Byte;
IsANSI: Boolean;
i: Integer;
begin
case GetOEMCP of
437:
begin
AnsiChars := Oem437AnsiChars;
OemChars := Oem437OemChars;
end;
720:
begin
AnsiChars := Oem720AnsiChars;
OemChars := Oem720OemChars;
end;
737:
begin
AnsiChars := Oem737AnsiChars;
OemChars := Oem737OemChars;
end;
775:
begin
AnsiChars := Oem775AnsiChars;
OemChars := Oem775OemChars;
end;
850:
begin
AnsiChars := Oem850AnsiChars;
OemChars := Oem850OemChars;
end;
852:
begin
AnsiChars := Oem852AnsiChars;
OemChars := Oem852OemChars;
end;
855:
begin
AnsiChars := Oem855AnsiChars;
OemChars := Oem855OemChars;
end;
857:
begin
AnsiChars := Oem857AnsiChars;
OemChars := Oem857OemChars;
end;
862:
begin
AnsiChars := Oem862AnsiChars;
OemChars := Oem862OemChars;
end;
866:
begin
AnsiChars := Oem866AnsiChars;
OemChars := Oem866OemChars;
end;
else
begin
Result := False;
Exit;
end;
end;
IsANSI := True;
Result := True;
for i := 0 to Length(aValue) do
if Ord(aValue[i]) >= $80 then
begin
if IsANSI then
IsANSI := Ord(aValue[i]) in AnsiChars;
if Result then
Result := Ord(aValue[i]) in OemChars;
if not IsANSI and not Result then
Break
end;
if IsANSI then
Result := False;
end;
{$ELSE !MSWINDOWS}
begin
Result := False;
end;
{$ENDIF !MSWINDOWS}
{ -------------------------------------------------------------------------- }
function AbSysCharSetIsUTF8: Boolean;
begin
{$IFDEF DARWIN}
Result := True;
{$ENDIF}
{$IFDEF MSWINDOWS}
Result := False;
{$ENDIF}
{$IFDEF LINUX}
Result := StrComp(nl_langinfo(_NL_CTYPE_CODESET_NAME), 'UTF-8') = 0;
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function AbRawBytesToString(const aValue: RawByteString): string;
// Detect encoding of raw bytes and convert to a string
begin
case AbDetectCharSet(aValue) of
csASCII:
Result := string(aValue);
csANSI: begin
{$IFDEF MSWINDOWS}
if AbIsOEM(aValue) then begin
SetLength(Result, Length(aValue));
OemToCharBuff(PAnsiChar(aValue), PChar(Result), Length(Result));
end
else
{$ENDIF}
Result := string(aValue);
end;
csUTF8:
Result := UTF8ToString(aValue);
end;
end;
{ -------------------------------------------------------------------------- }
function AbStringToUnixBytes(const aValue: string): RawByteString;
// Convert from a string to an appropriate encoding for Unix archive types (tar/gz)
// Based on testing the system encoding should be used on Linux, and UTF-8
// everywhere else. Windows apps don't agree on whether to use ANSI, OEM, or UTF-8.
begin
// Delphi XE2+ Posix platforms only support the UTF-8 locale
{$IF DEFINED(LINUX) AND (DEFINED(FPC) OR DEFINED(KYLIX))}
Result := AnsiString(aValue);
{$ELSE}
Result := UTF8Encode(aValue);
{$IFEND}
end;
{ -------------------------------------------------------------------------- }
{$IFDEF MSWINDOWS}
function AbTryEncode(const aValue: UnicodeString; aCodePage: UINT;
aAllowBestFit: Boolean; out aResult: AnsiString): Boolean;
// Try to encode the given Unicode string as the requested codepage
const
WC_NO_BEST_FIT_CHARS = $00000400;
Flags: array[Boolean] of DWORD = (WC_NO_BEST_FIT_CHARS, 0);
var
UsedDefault: BOOL;
begin
if not aAllowBestFit and not CheckWin32Version(4, 1) then
Result := False
else begin
SetLength(aResult, WideCharToMultiByte(aCodePage, Flags[aAllowBestFit],
PWideChar(aValue), Length(aValue), nil, 0, nil, @UsedDefault));
SetLength(aResult, WideCharToMultiByte(aCodePage, Flags[aAllowBestFit],
PWideChar(aValue), Length(aValue), PAnsiChar(aResult),
Length(aResult), nil, @UsedDefault));
Result := not UsedDefault;
end;
end;
{$ENDIF MSWINDOWS}
{ == Unicode backwards compatibility functions ============================= }
{$IFNDEF UNICODE}
function UTF8ToString(const S: RawByteString): string;
begin
Result := UTf8ToAnsi(S);
end;
{$ENDIF}
end.
================================================
FILE: lib/abbrevia/source/AbComCtrls.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is Craig Peterson
*
* Portions created by the Initial Developer are Copyright (C) 2011
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Craig Peterson
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbComCtrls.pas *}
{*********************************************************}
{* ABBREVIA: Listview and treeview components that work *}
{* with an archive component. The treeview can have a *}
{* listview associated, in which case the listview will*}
{* only show items in the selected folder. *}
{*********************************************************}
unit AbComCtrls;
interface
{$I AbDefine.inc}
uses
Windows, Messages, SysUtils, Classes, Controls, ComCtrls, Graphics, AbBrowse,
AbArcTyp;
const
AbTreeArchiveImage = 0;
AbTreeFolderImage = 1;
AbTreeFolderExpandedImage = 2;
type
{ ===== TAbListItem ========================================================= }
TAbListItem = class(TListItem)
protected {private}
FArchiveItem : TAbArchiveItem;
protected {methods}
function GetIsDirectory : Boolean;
function GetIsEncrypted : Boolean;
public {properties}
property ArchiveItem : TAbArchiveItem
read FArchiveItem
write FArchiveItem;
property IsDirectory : Boolean
read GetIsDirectory;
property IsEncrypted : Boolean
read GetIsEncrypted;
end;
{ ===== TAbListItems ======================================================== }
TAbListItems = class(TListItems)
protected {methods}
function GetItem(aIndex: Integer): TAbListItem;
procedure SetItem(aIndex: Integer; aValue: TAbListItem);
public {properties}
property Item[Index: Integer]: TAbListItem
read GetItem
write SetItem; default;
end;
{ ===== TAbCustomListView =================================================== }
type
TAbViewColumn =
(vcName, vcFileType, vcLastModified, vcSize, vcRatio,
vcPacked, vcCRC, vcAttributes, vcEncrypted, vcMethod, vcPath);
TAbViewColumns = set of TAbViewColumn;
const
AbDefVisibleColumns = [Low(TAbViewColumn)..High(TAbViewColumn)];
type
TAbCustomTreeView = class;
{$IF NOT DECLARED(TWindowProcPtr)}
TWindowProcPtr = Pointer;
{$IFEND}
TAbCustomListView = class(TCustomListView)
protected {private}
FArchive : TAbBaseBrowser;
FDefHeaderProc : TWindowProcPtr;
FFlatList: Boolean;
FHeaderHandle : HWND;
FHeaderImages : TImageList;
FHeaderInstance : Pointer;
FInUpdateSortArrows: Boolean;
FPath : string;
FSortAscending : Boolean;
FSortColIndex : Integer;
FSortColumn : TAbViewColumn;
FSortUpBmp : HBITMAP;
FSortDownBmp : HBITMAP;
FTreeView : TAbCustomTreeView;
FVisibleColumns : TAbViewColumns;
protected {methods}
procedure ColClick(aColumn: TListColumn);
override;
function CreateListItem: TListItem;
override;
function CreateListItems: TListItems;
override;
procedure CreateWnd;
override;
function CustomDrawSubItem(Item: TListItem; SubItem: Integer;
State: TCustomDrawState; Stage: TCustomDrawStage): Boolean;
override;
procedure DblClick;
override;
procedure DoChange(Sender : TObject);
virtual;
function GetListItems: TAbListItems;
function GetVersion: string;
procedure HeaderWndProc(var Msg: TMessage);
virtual;
function IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean;
override;
procedure Notification(aComponent : TComponent; aOperation : TOperation);
override;
procedure SetArchive(aValue : TAbBaseBrowser);
procedure SetFlatList(aValue : Boolean);
procedure SetPath(aValue : string);
procedure SetTreeView(aValue : TAbCustomTreeView);
procedure SetVisibleColumns(aValue : TAbViewColumns);
procedure UpdateColumns;
procedure UpdateSortArrow;
procedure UpdateView;
protected {properties}
property HeaderImages : TImageList
read FHeaderImages;
public {methods}
constructor Create(aOwner: TComponent);
override;
destructor Destroy;
override;
procedure Sort(aColumn: TAbViewColumn; aAscending: Boolean);
public {properties}
property Archive : TAbBaseBrowser
read FArchive
write SetArchive;
property Columns;
// Show only items in the current path
property FlatList : Boolean
read FFlatList
write SetFlatList;
property Items: TAbListItems
read GetListItems
stored False;
property TreeView : TAbCustomTreeView
read FTreeView
write SetTreeView;
property Path : string
read FPath
write SetPath;
property Version : string
read GetVersion
stored False;
property VisibleColumns : TAbViewColumns
read FVisibleColumns
write SetVisibleColumns
default AbDefVisibleColumns;
end;
{ ===== TAbListView ========================================================= }
TAbListView = class(TAbCustomListView)
published
property Action;
property Align;
property AllocBy;
property Anchors;
property Archive;
property BevelEdges;
property BevelInner;
property BevelOuter;
property BevelKind default bkNone;
property BevelWidth;
property BiDiMode;
property BorderStyle;
property BorderWidth;
property Checkboxes;
property Color;
property ColumnClick;
property Constraints;
property Ctl3D;
property DoubleBuffered;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property FlatScrollBars;
property FullDrag;
property GridLines;
{$IFDEF HasListViewGroups}
property Groups;
{$ENDIF}
property HideSelection;
property HotTrack;
property HotTrackStyles;
property HoverTime;
property IconOptions;
property Items;
property LargeImages;
property MultiSelect;
{$IFDEF HasListViewGroups}
property GroupHeaderImages;
property GroupView default False;
{$ENDIF}
property ReadOnly default False;
property RowSelect;
property ParentBiDiMode;
property ParentColor default False;
{$IFDEF HasParentDoubleBuffered}
property ParentDoubleBuffered;
{$ENDIF}
property ParentFont;
property ParentShowHint;
property Path;
property PopupMenu;
property ShowColumnHeaders;
property ShowWorkAreas;
property ShowHint;
property TabOrder;
property TabStop default True;
property TreeView;
property Version;
property ViewStyle;
property Visible;
property VisibleColumns;
property OnClick;
property OnColumnClick;
property OnColumnDragged;
property OnColumnRightClick;
property OnContextPopup;
property OnDblClick;
property OnEdited;
property OnEditing;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnDragDrop;
property OnDragOver;
property OnInfoTip;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
{$IFDEF HasOnMouseActivate}
property OnMouseActivate;
{$ENDIF}
property OnMouseDown;
{$IFDEF HasOnMouseEnter}
property OnMouseEnter;
property OnMouseLeave;
{$ENDIF}
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnSelectItem;
{$IFDEF HasListViewOnItemChecked}
property OnItemChecked;
{$ENDIF}
property OnStartDock;
property OnStartDrag;
end;
{ ===== TAbCustomTreeView =================================================== }
TAbCustomTreeView = class(TTreeView)
protected {private}
FArchive: TAbBaseBrowser;
FListView: TAbCustomListView;
FPath: string;
protected {methods}
procedure Change(aNode: TTreeNode);
override;
procedure DoChange(Sender : TObject);
virtual;
procedure GetSelectedIndex(aNode: TTreeNode);
override;
function GetVersion: string;
procedure Notification(aComponent : TComponent; aOperation : TOperation);
override;
procedure SelectPathNode;
procedure SetArchive(aValue: TAbBaseBrowser);
procedure SetListView(aValue: TAbCustomListView);
procedure SetPath(const aValue: string);
public {methods}
constructor Create(aOwner: TComponent);
override;
public {properties}
property Archive: TAbBaseBrowser
read FArchive
write SetArchive;
property HideSelection
default False;
property ListView: TAbCustomListView
read FListView
write SetListView;
property Path: string
read FPath
write SetPath;
property Version: string
read GetVersion
stored False;
end;
{ ===== TAbTreeView ========================================================= }
TAbTreeView = class(TAbCustomTreeView)
published
property Align;
property Anchors;
property Archive;
property AutoExpand;
property BevelEdges;
property BevelInner;
property BevelOuter;
property BevelKind default bkNone;
property BevelWidth;
property BiDiMode;
property BorderStyle;
property BorderWidth;
property ChangeDelay;
property Color;
property Ctl3D;
property Constraints;
property DoubleBuffered;
property DragKind;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property HotTrack;
property Indent;
property Items;
property ListView;
property ParentBiDiMode;
property ParentColor default False;
property ParentCtl3D;
{$IFDEF HasParentDoubleBuffered}
property ParentDoubleBuffered;
{$ENDIF}
property ParentFont;
property ParentShowHint;
property Path;
property PopupMenu;
property ReadOnly;
property RightClickSelect;
property RowSelect;
property ShowButtons;
property ShowHint;
property ShowLines;
property ShowRoot;
property TabOrder;
property TabStop default True;
property ToolTips;
property Version;
property Visible;
property OnChanging;
property OnClick;
property OnCollapsed;
property OnCollapsing;
property OnContextPopup;
property OnDblClick;
property OnDeletion;
property OnDragDrop;
property OnDragOver;
property OnEdited;
property OnEditing;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnExpanding;
property OnExpanded;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
{$IFDEF HasOnMouseActivate}
property OnMouseActivate;
{$ENDIF}
property OnMouseDown;
{$IFDEF HasOnMouseEnter}
property OnMouseEnter;
property OnMouseLeave;
{$ENDIF}
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
end;
{ ===== TAbProgressBar ====================================================== }
TAbProgressBar = class(TProgressBar, IAbProgressMeter)
protected {private}
function GetVersion : string;
public {methods}
procedure DoProgress(Progress : Byte);
procedure Reset;
published {properties}
property Version: string
read GetVersion
stored False;
end;
implementation
{$R AbComCtrls.res}
uses
CommCtrl, Contnrs, Forms, ShellAPI, StrUtils, AbConst, AbResString, AbUtils,
AbZipTyp;
const
HDF_SORTDOWN = $0200;
HDF_SORTUP = $0400;
{ -------------------------------------------------------------------------- }
{$IF NOT DECLARED(StartsText)}
function StartsText(const aSubText, aText: string): Boolean;
begin
Result := (Length(aText) > Length(aSubText)) and
SameText(aSubText, Copy(aText, 1, Length(aSubText)));
end;
{$IFEND}
{ -------------------------------------------------------------------------- }
function AbNormalizeFilename(const aFilename: string): string;
var
i: Integer;
begin
Result := aFilename;
for i := 1 to Length(Result) do
if IsDelimiter('\/', Result, i) then
Result[i] := PathDelim;
if IsDelimiter(PathDelim, Result, Length(Result)) then
SetLength(Result, Length(Result) - 1);
end;
{ -------------------------------------------------------------------------- }
var
ComCtl32MajorVer: Integer = -1;
function IsComCtl32Version6: Boolean;
type
PDllVersionInfo = ^TDllVersionInfo;
TDllVersionInfo = packed record
cbSize: DWORD;
dwMajorVersion: DWORD;
dwMinorVersion: DWORD;
dwBuildNumber: DWORD;
dwPlatformId: DWORD;
end;
var
DllGetVersion: function(pdvi: PDllVersionInfo): HRESULT; stdcall;
dvi: TDllVersionInfo;
hComCtl32: HMODULE;
begin
if ComCtl32MajorVer = -1 then begin
ComCtl32MajorVer := 0;
hComCtl32 := LoadLibrary(comctl32);
if hComCtl32 <> 0 then begin
DllGetVersion := GetProcAddress(hComCtl32, 'DllGetVersion');
if Assigned(DllGetVersion) then begin
dvi.cbSize := SizeOf(dvi);
if Succeeded(DllGetVersion(@dvi)) then
ComCtl32MajorVer := dvi.dwMajorVersion;
end;
FreeLibrary(hComCtl32);
end;
end;
Result := ComCtl32MajorVer >= 6;
end;
{ -------------------------------------------------------------------------- }
function SameEvent(const aEvent1, aEvent2: TNotifyEvent): Boolean;
begin
Result := (TMethod(aEvent1).Code = TMethod(aEvent2).Code) and
(TMethod(aEvent1).Data = TMethod(aEvent2).Data);
end;
{ ===== TAbListItem ========================================================= }
function TAbListItem.GetIsDirectory: Boolean;
begin
Result := (ArchiveItem = nil) or ArchiveItem.IsDirectory;
end;
{ -------------------------------------------------------------------------- }
function TAbListItem.GetIsEncrypted: Boolean;
begin
Result := (ArchiveItem <> nil) and ArchiveItem.IsEncrypted;
end;
{ ===== TAbListItems ======================================================== }
function TAbListItems.GetItem(aIndex: Integer): TAbListItem;
begin
Result := inherited Item[aIndex] as TAbListItem;
end;
{ -------------------------------------------------------------------------- }
procedure TAbListItems.SetItem(aIndex: Integer; aValue: TAbListItem);
begin
inherited Item[aIndex] := aValue;
end;
{ ===== TAbCustomListView =================================================== }
constructor TAbCustomListView.Create(aOwner: TComponent);
var
Bmp : TBitmap;
sfi: SHFILEINFO;
begin
inherited;
FHeaderInstance := MakeObjectInstance(HeaderWndProc);
// Load header image into an image list; the header's hbm property
// doesn't support transparency
FHeaderImages := TImageList.Create(Self);
Bmp := TBitmap.Create;
try
Bmp.LoadFromResourceName(HInstance, 'AbComCtrls_Lock');
FHeaderImages.AddMasked(Bmp, clFuchsia);
finally
Bmp.Free;
end;
// Load system image lists
LargeImages := TImageList.Create(Self);
LargeImages.ShareImages := True;
LargeImages.Handle := SHGetFileInfo('', 0, sfi, SizeOf(sfi),
SHGFI_LARGEICON or SHGFI_SYSICONINDEX);
SmallImages := TImageList.Create(Self);
SmallImages.ShareImages := True;
SmallImages.Handle := SHGetFileInfo('', 0, sfi, SizeOf(sfi),
SHGFI_SMALLICON or SHGFI_SYSICONINDEX);
// Load sort arrow bitmaps for older comctrl32.dll versions
FSortAscending := True;
FSortColumn := vcName;
if not IsComCtl32Version6 then begin
FSortUpBmp := LoadImage(HInstance, 'AbComCtrls_SortUp', IMAGE_BITMAP, 0, 0, LR_LOADMAP3DCOLORS);
FSortDownBmp := LoadImage(HInstance, 'AbComCtrls_SortDown', IMAGE_BITMAP, 0, 0, LR_LOADMAP3DColors);
end;
// Set default column visibility
VisibleColumns := AbDefVisibleColumns;
end;
{ -------------------------------------------------------------------------- }
destructor TAbCustomListView.Destroy;
begin
if FHeaderHandle <> 0 then
SetWindowLong(FHeaderHandle, GWL_WNDPROC, LongInt(FDefHeaderProc));
FreeObjectInstance(FHeaderInstance);
if FSortUpBmp <> 0 then
DeleteObject(FSortUpBmp);
if FSortDownBmp <> 0 then
DeleteObject(FSortDownBmp);
inherited;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.ColClick(aColumn: TListColumn);
var
Col: TAbViewColumn;
begin
inherited;
Col := TAbViewColumn(aColumn.Tag);
Sort(Col, (Col <> FSortColumn) or not FSortAscending);
end;
{ -------------------------------------------------------------------------- }
function TAbCustomListView.CreateListItem: TListItem;
begin
Result := TAbListItem.Create(Items);
end;
{ -------------------------------------------------------------------------- }
function TAbCustomListView.CreateListItems: TListItems;
begin
Result := TAbListItems.Create(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.CreateWnd;
begin
inherited;
FHeaderHandle := ListView_GetHeader(Handle);
if FHeaderHandle <> 0 then begin
FDefHeaderProc := TWindowProcPtr(GetWindowLong(FHeaderHandle, GWL_WNDPROC));
SetWindowLong(FHeaderHandle, GWL_WNDPROC, LongInt(FHeaderInstance));
end;
Header_SetImageList(ListView_GetHeader(Handle), FHeaderImages.Handle);
UpdateColumns;
UpdateView;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomListView.CustomDrawSubItem(Item: TListItem; SubItem: Integer;
State: TCustomDrawState; Stage: TCustomDrawStage): Boolean;
var
i: Integer;
R: TRect;
begin
Result := True;
if (Stage = cdPrePaint) and TAbListItem(Item).IsEncrypted then
if TAbViewColumn(Columns[SubItem].Tag) = vcEncrypted then begin
Result := False;
R := Item.DisplayRect(drBounds);
Inc(R.Left, 6);
for i := 0 to SubItem - 1 do
Inc(R.Left, Columns[i].Width);
HeaderImages.Draw(Canvas, R.Left, R.Top, 0);
end
else begin
Result := True;
// Fixed other columns drawing with wrong font after using TImageList.Draw
Canvas.Brush.Color := ColorToRGB(Color);
SetBkMode(Canvas.Handle, TRANSPARENT);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.DblClick;
begin
inherited;
if TAbListItem(Selected).IsDirectory then
if Path = '' then
Path := Selected.Caption
else
Path := Path + PathDelim + Selected.Caption;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.DoChange(Sender: TObject);
begin
UpdateView;
if (Sender = FArchive) and Assigned(FTreeView) then
FTreeView.DoChange(Self);
end;
{ -------------------------------------------------------------------------- }
function TAbCustomListView.GetListItems: TAbListItems;
begin
Result := inherited Items as TAbListItems;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomListView.GetVersion: string;
begin
Result := AbVersionS;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.HeaderWndProc(var Msg: TMessage);
const
FMT_MASK = HDF_BITMAP or HDF_BITMAP_ON_RIGHT or HDF_SORTDOWN or HDF_SORTUP;
var
Item: THDItem;
begin
if (Msg.Msg = HDM_SETITEM) and not FInUpdateSortArrows then begin
Item.Mask := HDI_FORMAT;
if Header_GetItem(FHeaderHandle, Msg.WParam, Item) then begin
PHDItem(Msg.LParam).Mask := PHDItem(Msg.LParam).Mask and not HDI_BITMAP;
PHDItem(Msg.LParam).fmt := PHDItem(Msg.LParam).fmt and not FMT_MASK
or (Item.fmt and FMT_MASK);
end;
end;
Msg.Result := CallWindowProc(FDefHeaderProc, FHeaderHandle, Msg.Msg,
Msg.WParam, Msg.LParam);
if Msg.Msg = WM_DESTROY then
FHeaderHandle := 0;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomListView.IsCustomDrawn(Target: TCustomDrawTarget;
Stage: TCustomDrawStage): Boolean;
begin
Result := (vcEncrypted in VisibleColumns) and (Stage = cdPrePaint) and
(Target = dtSubItem);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.Notification(aComponent: TComponent;
aOperation: TOperation);
begin
inherited;
if aOperation = opRemove then begin
if aComponent = FArchive then begin
FArchive := nil;
Clear;
end;
if aComponent = FTreeView then begin
if Assigned(FArchive) and SameEvent(FArchive.OnChange, FTreeView.DoChange) then
FArchive.OnChange := DoChange;
FTreeView := nil;
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.SetArchive(aValue: TAbBaseBrowser);
begin
if aValue <> FArchive then begin
if Assigned(FArchive) then begin
FArchive.RemoveFreeNotification(Self);
if SameEvent(FArchive.OnChange, DoChange) then
if Assigned(TreeView) and (TreeView.Archive = FArchive) then
FArchive.OnChange := TreeView.DoChange
else
FArchive.OnChange := nil;
end;
FArchive := aValue;
if Assigned(FArchive) then begin
FArchive.FreeNotification(Self);
FArchive.OnChange := DoChange;
DoChange(Self);
end
else
Items.Clear;
if Assigned(TreeView) then
TreeView.Archive := aValue;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.SetFlatList(aValue : Boolean);
begin
if aValue <> FFlatList then begin
FFlatList := aValue;
UpdateView;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.SetPath(aValue: string);
begin
if aValue <> FPath then begin
FPath := ExcludeTrailingPathDelimiter(aValue);
if Assigned(TreeView) then
TreeView.Path := aValue;
if not FlatList then
UpdateView;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.SetTreeView(aValue: TAbCustomTreeView);
begin
if aValue <> FTreeView then begin
if Assigned(FTreeView) then begin
FTreeView.RemoveFreeNotification(Self);
FTreeView.ListView := nil;
end;
FTreeView := aValue;
if Assigned(FTreeView) then begin
FTreeView.FreeNotification(Self);
if Assigned(FArchive) then
FTreeView.Archive := FArchive
else if Assigned(FTreeView.Archive) then
Archive := FTreeView.Archive;
FTreeView.ListView := Self;
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.SetVisibleColumns(aValue : TAbViewColumns);
begin
if aValue <> FVisibleColumns then begin
FVisibleColumns := aValue;
UpdateColumns;
UpdateView;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomListView_SortProc(aItem1, aItem2: TAbListItem;
aListView: TAbCustomListView): Integer; stdcall;
var
Item1, Item2: TAbArchiveItem;
Ratio1, Ratio2: Single;
begin
if aItem1.IsDirectory <> aItem2.IsDirectory then
if aItem1.IsDirectory then
Result := -1
else
Result := 1
else begin
Result := 0;
if aListView.FSortColumn in [vcFileType, vcPath] then begin
Result := CompareText(aItem1.SubItems[aListView.FSortColIndex],
aItem2.SubItems[aListView.FSortColIndex]);
end
else if not aItem1.IsDirectory then begin
// Don't do more advanced sorts for directories, since they may be
// implicitly stored and won't have corresponding archive items
Item1 := aItem1.ArchiveItem;
Item2 := aItem2.ArchiveItem;
case aListView.FSortColumn of
vcLastModified:
begin
if Item1.LastModTimeAsDateTime < Item2.LastModTimeAsDateTime then
Result := -1
else if Item1.LastModTimeAsDateTime > Item2.LastModTimeAsDateTime then
Result := 1;
end;
vcSize:
begin
if Item1.UncompressedSize < Item2.UncompressedSize then
Result := -1
else if Item1.UncompressedSize > Item2.UncompressedSize then
Result := 1;
end;
vcRatio:
begin
if Item1.UncompressedSize > 0 then
Ratio1 := Item1.CompressedSize / Item1.UncompressedSize
else
Ratio1 := 1;
if Item2.UncompressedSize > 0 then
Ratio2 := Item2.CompressedSize / Item2.UncompressedSize
else
Ratio2 := 1;
if Ratio1 > Ratio2 then
Result := -1
else if Ratio1 < Ratio2 then
Result := 1
end;
vcPacked:
begin
if Item1.CompressedSize < Item2.CompressedSize then
Result := -1
else if Item1.CompressedSize > Item2.CompressedSize then
Result := 1;
end;
vcCRC:
begin
if Longword(Item1.CRC32) < Longword(Item2.CRC32) then
Result := -1
else if Longword(Item1.CRC32) > Longword(Item2.CRC32) then
Result := 1;
end;
vcAttributes,
vcMethod:
begin
Result := CompareText(aItem1.SubItems[aListView.FSortColIndex],
aItem2.SubItems[aListView.FSortColIndex]);
end;
vcEncrypted:
begin
if not Item1.IsEncrypted and Item2.IsEncrypted then
Result := -1
else if Item1.IsEncrypted and not Item2.IsEncrypted then
Result := 1
end;
end;
end;
if Result = 0 then
Result := AnsiCompareText(aItem1.Caption, aItem2.Caption);
end;
if not aListView.FSortAscending then
Result := -Result;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.Sort(aColumn: TAbViewColumn; aAscending: Boolean);
begin
if (aColumn <> FSortColumn) or (aAscending <> FSortAscending) then begin
FSortColumn := aColumn;
FSortAscending := aAscending;
UpdateSortArrow;
CustomSort(TLVCompare(@TAbCustomListView_SortProc), LPARAM(Self));
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.UpdateColumns;
const
ColWidths: array[TAbViewColumn] of Integer = (
180{vcName}, 110{vcFileType}, 130{vcLastModified}, 80{vcSize}, 50{vcRatio},
80{vcPacked}, 70{vcCRC}, 30{vcAttributes}, 28{vcEncrypted}, 60{vcMethod},
300{vcPath});
var
Col: TAbViewColumn;
Column: TListColumn;
begin
if HandleAllocated then
Items.BeginUpdate;
Columns.BeginUpdate;
try
Columns.Clear;
for Col := Low(Col) to High(Col) do begin
if not (Col in FVisibleColumns) then
Continue;
Column := Columns.Add;
case Col of
vcName: Column.Caption := AbItemNameHeadingS;
vcFileType: Column.Caption := AbFileTypeHeadingS;
vcLastModified: Column.Caption := AbLastModifiedHeadingS;
vcSize: Column.Caption := AbFileSizeHeadingS;
vcRatio: Column.Caption := AbRatioHeadingS;
vcPacked: Column.Caption := AbPackedHeadingS;
vcCRC: Column.Caption := AbCRCHeadingS;
vcAttributes: Column.Caption := AbFileAttrHeadingS;
vcEncrypted: Column.ImageIndex := 0;
vcMethod: Column.Caption := AbMethodHeadingS;
vcPath: Column.Caption := AbPathHeadingS;
end;
Column.Width := ColWidths[Col];
Column.Tag := Ord(Col);
if Col in [vcSize, vcRatio, vcPacked] then
Column.Alignment := taRightJustify;
end;
finally
Columns.EndUpdate;
if HandleAllocated then
Items.EndUpdate;
end;
UpdateSortArrow;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.UpdateSortArrow;
var
i: Integer;
Item: THDITEM;
begin
if not HandleAllocated then
Exit;
FInUpdateSortArrows := True;
try
for i := 0 to Columns.Count - 1 do begin
FillChar(Item, SizeOf(Item), 0);
Item.Mask := HDI_FORMAT;
if not IsComCtl32Version6 then
Item.Mask := Item.Mask or HDI_BITMAP;
Header_GetItem(FHeaderHandle, Columns[i].Index, Item);
// Add sort arrow to requested column
if TAbViewColumn(Columns[i].Tag) = FSortColumn then begin
FSortColIndex := i - 1;
if IsComCtl32Version6 then begin
Item.fmt := Item.fmt and not (HDF_SORTDOWN or HDF_SORTUP);
if FSortAscending then
Item.fmt := Item.fmt or HDF_SORTUP
else
Item.fmt := Item.fmt or HDF_SORTDOWN;
end
else begin
Item.fmt := Item.fmt or HDF_BITMAP or HDF_BITMAP_ON_RIGHT;
if FSortAscending then
Item.hbm := FSortUpBmp
else
Item.hbm := FSortDownBmp;
end;
end
// Remove sort arrow from other columns
else begin
if IsComCtl32Version6 then
Item.fmt := Item.fmt and not (HDF_SORTDOWN or HDF_SORTUP)
else begin
Item.Mask := Item.Mask and not HDI_BITMAP;
Item.fmt := Item.fmt and not (HDF_BITMAP OR HDF_BITMAP_ON_RIGHT);
end;
end;
Header_SetItem(FHeaderHandle, Columns[i].Index, Item);
end;
finally
FInUpdateSortArrows := False;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomListView.UpdateView;
var
ArcItem: TAbArchiveItem;
Col: TAbViewColumn;
ColImage: Integer;
ColText, Filename, FolderName: string;
DOSAttr: Integer;
Folders: TStringList;
i, j: Integer;
ListItem: TAbListItem;
ParentDir: string;
sfi: SHFILEINFO;
begin
ListItem := nil; // Suppress compiler warning
if (Items.Count = 0) and (FArchive = nil) then
Exit;
Items.BeginUpdate;
try
Items.Clear;
if Assigned(FArchive) then begin
Folders := TStringList.Create;
try
for i := 0 to FArchive.Count - 1 do
if FArchive[i].Action <> aaDelete then begin
ArcItem := FArchive[i];
Filename := AbNormalizeFilename(ArcItem.FileName);
// Exclude unwanted items
if FlatList and ArcItem.IsDirectory then
Continue;
// Create new ListItem
ParentDir := ExtractFileDir(FileName);
if FlatList or (ParentDir = Path) then begin
// If an ListItem has already been created for a folder, use it
if ArcItem.IsDirectory then begin
FolderName := ExtractFileName(FileName);
if Folders.Find(FolderName, j) then
ListItem := Folders.Objects[j] as TAbListItem
else begin
ListItem := Items.Add as TAbListItem;
Folders.AddObject(FolderName, ListItem);
end
end
else
ListItem := Items.Add as TAbListItem;
ListItem.ArchiveItem := FArchive[i];
end
else if (Path = '') or StartsText(Path + PathDelim, ParentDir) then begin
// Create folder for implicitly stored directories,
// if one hasn't been created already
while ParentDir <> Path do begin
FileName := ParentDir;
ParentDir := ExtractFileDir(FileName);
end;
FolderName := ExtractFileName(FileName);
if Folders.IndexOf(FolderName) <> -1 then
Continue;
ListItem := Items.Add as TAbListItem;
Folders.AddObject(FolderName, ListItem);
ArcItem := nil;
end
else
// ListItem isn't below Path
Continue;
// Get file type information from the shell
if ListItem.IsDirectory then
DOSAttr := FILE_ATTRIBUTE_DIRECTORY
else
DOSAttr := FILE_ATTRIBUTE_NORMAL;
SHGetFileInfo(PChar(ExtractFileName(Filename)), DOSAttr, sfi, sizeof(sfi),
SHGFI_TYPENAME or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES);
// Fill in columns
ListItem.Caption := ExtractFileName(Filename);
ListItem.ImageIndex := sfi.iIcon;
ListItem.SubItems.Clear;
for Col := Succ(Low(Col)) to High(Col) do
if Col in FVisibleColumns then begin
ColText := '';
ColImage := -1;
case Col of
vcFileType:
ColText := sfi.szTypeName;
vcLastModified:
if ArcItem <> nil then
ColText := DateToStr(ArcItem.LastModTimeAsDateTime) + ' ' +
TimeToStr(ArcItem.LastModTimeAsDateTime);
vcSize:
if not ListItem.IsDirectory then
ColText := FormatFloat('#,##0', ArcItem.UncompressedSize);
vcRatio:
if not ListItem.IsDirectory then
if ArcItem.UncompressedSize > 0 then
ColText := Format('%d%%',
[100 - Round(ArcItem.CompressedSize * 100 / ArcItem.UncompressedSize)])
else
ColText := '0%';
vcPacked:
if not ListItem.IsDirectory then
ColText := FormatFloat('#,##0', ArcItem.CompressedSize);
vcCRC:
if not ListItem.IsDirectory then
ColText := IntToHex(ArcItem.CRC32, 8);
vcAttributes:
if ArcItem <> nil then begin
{$WARN SYMBOL_PLATFORM OFF}
if (faReadOnly and ArcItem.ExternalFileAttributes) = faReadOnly then
ColText := ColText + AbReadOnlyS;
if (faHidden and ArcItem.ExternalFileAttributes) = faHidden then
ColText := ColText + AbHiddenS;
if (faSysFile and ArcItem.ExternalFileAttributes) = faSysFile then
ColText := ColText + AbSystemS;
if (faArchive and ArcItem.ExternalFileAttributes) = faArchive then
ColText := ColText + AbArchivedS;
{$WARN SYMBOL_PLATFORM ON}
end;
vcMethod:
if ArcItem is TAbZipItem then
ColText := ZipCompressionMethodToString(
TAbZipItem(ArcItem).CompressionMethod);
vcPath:
ColText := ExtractFileDir(FileName);
end;
ListItem.SubItems.Add(ColText);
ListItem.SubItemImages[ListItem.SubItems.Count - 1] := ColImage;
end;
end;
finally
Folders.Free;
end;
CustomSort(TLVCompare(@TAbCustomListView_SortProc), LPARAM(Self));
end;
finally
Items.EndUpdate;
end;
end;
{ ===== TAbCustomTreeView =================================================== }
constructor TAbCustomTreeView.Create(aOwner: TComponent);
var
Bmp : TBitmap;
Icon : TIcon;
sfi: SHFILEINFO;
begin
inherited;
HideSelection := False;
Images := TImageList.Create(Self);
Bmp := TBitmap.Create;
try
Bmp.LoadFromResourceName(HInstance, 'AbComCtrls_Zip');
Images.AddMasked(Bmp, clFuchsia);
Icon := TIcon.Create;
try
// On Windows 7 an empty filename returns the drive icon instead of a folder
SHGetFileInfo('Folder', FILE_ATTRIBUTE_DIRECTORY, sfi, sizeof(sfi),
SHGFI_ICON or SHGFI_SMALLICON or SHGFI_USEFILEATTRIBUTES);
Icon.Handle := sfi.hIcon;
Bmp.PixelFormat := pf24bit;
Bmp.Canvas.Brush.Color := clWindow;
Bmp.Canvas.FillRect(Rect(0, 0, 16, 16));
Bmp.Canvas.Draw(0, 0, Icon);
Images.AddMasked(Bmp, clWindow);
SHGetFileInfo('Folder', FILE_ATTRIBUTE_DIRECTORY, sfi, sizeof(sfi),
SHGFI_ICON or SHGFI_OPENICON or SHGFI_SMALLICON or SHGFI_USEFILEATTRIBUTES);
Icon.Handle := sfi.hIcon;
Bmp.Canvas.FillRect(Rect(0, 0, 16, 16));
Bmp.Canvas.Draw(0, 0, Icon);
Images.AddMasked(Bmp, clWindow);
finally
Icon.Free;
end;
finally
Bmp.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomTreeView.Change(aNode: TTreeNode);
var
Filename: string;
begin
inherited;
if aNode.Selected then begin
Filename := '';
if aNode <> Items.GetFirstNode then begin
Filename := aNode.Text;
aNode := aNode.Parent;
while aNode <> Items.GetFirstNode do begin
Filename := aNode.Text + PathDelim + Filename;
aNode := aNode.Parent;
end;
end;
Path := Filename;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomTreeView.DoChange(Sender: TObject);
var
Nodes: TStringList;
ZipNode: TTreeNode;
function GetNode(const aFilename: string): TTreeNode;
var
i: Integer;
begin
if aFilename = '' then
Result := ZipNode
else if Nodes.Find(aFilename, i) then
Result := TTreeNode(Nodes.Objects[i])
else begin
Result := Items.AddChild(GetNode(ExtractFileDir(aFilename)),
ExtractFileName(aFilename));
{$IFDEF HasTreeViewExpandedImageIndex}
Result.ExpandedImageIndex := AbTreeFolderExpandedImage;
{$ENDIF}
Result.ImageIndex := AbTreeFolderImage;
Nodes.AddObject(aFilename, Result);
end;
end;
var
i: Integer;
Filename: string;
begin
Items.BeginUpdate;
try
Items.Clear;
if Assigned(FArchive) then begin
Nodes := TStringList.Create;
try
Nodes.Sorted := True;
if Archive.FArchive <> nil then
Filename := ExtractFileName(Archive.FArchive.ArchiveName)
else
Filename := PathDelim;
ZipNode := Items.AddChild(nil, Filename);
{$IFDEF HasTreeViewExpandedImageIndex}
ZipNode.ExpandedImageIndex := AbTreeArchiveImage;
{$ENDIF}
ZipNode.ImageIndex := AbTreeArchiveImage;
for i := 0 to FArchive.Count - 1 do
if FArchive[i].Action <> aaDelete then begin
Filename := AbNormalizeFilename(FArchive[i].FileName);
if not FArchive[i].IsDirectory then
Filename := ExtractFileDir(Filename);
GetNode(Filename);
end;
finally
Nodes.Free;
end;
Items.AlphaSort(True);
ZipNode.Expand(False);
SelectPathNode;
end;
finally
Items.EndUpdate;
end;
if (Sender = FArchive) and Assigned(FListView) then
FListView.DoChange(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomTreeView.GetSelectedIndex(aNode: TTreeNode);
begin
{$IFDEF HasTreeViewExpandedImageIndex}
if aNode.Expanded then
aNode.SelectedIndex := aNode.ExpandedImageIndex
else
{$ENDIF}
aNode.SelectedIndex := aNode.ImageIndex;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomTreeView.GetVersion: string;
begin
Result := AbVersionS;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomTreeView.Notification(aComponent: TComponent;
aOperation: TOperation);
begin
inherited;
if aOperation = opRemove then begin
if aComponent = FArchive then begin
FArchive := nil;
Items.Clear;
end;
if aComponent = FListView then begin
if Assigned(FArchive) and SameEvent(FArchive.OnChange, FListView.DoChange) then
FArchive.OnChange := DoChange;
FListView := nil;
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomTreeView.SelectPathNode;
var
Filename, Remaining: string;
i: Integer;
Node: TTreeNode;
begin
// Find selected node, expanding parents along the way
Node := Items.GetFirstNode;
Remaining := FPath;
if StartsText(PathDelim, Remaining) then
System.Delete(Remaining, 1, 1);
while Remaining <> '' do begin
Node.Expand(False);
i := Pos(PathDelim, Remaining);
if i = 0 then
i := Length(Remaining) + 1;
Filename := Copy(Remaining, 1, i - 1);
Remaining := Copy(Remaining, i + 1, MaxInt);
if Filename = '' then
Continue;
Node := Node.getFirstChild;
while (Node <> nil) and not SameText(Filename, Node.Text) do
Node := Node.getNextSibling;
if Node = nil then begin
Node := Items.GetFirstNode;
Break;
end;
end;
Selected := Node;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomTreeView.SetArchive(aValue: TAbBaseBrowser);
begin
if aValue <> FArchive then begin
if Assigned(FArchive) then begin
FArchive.RemoveFreeNotification(Self);
if SameEvent(FArchive.OnChange, DoChange) then
if Assigned(ListView) and (ListView.Archive = FArchive) then
FArchive.OnChange := ListView.DoChange
else
FArchive.OnChange := nil;
end;
FArchive := aValue;
if Assigned(FArchive) then begin
FArchive.FreeNotification(Self);
FArchive.OnChange := DoChange;
DoChange(Self);
end
else
Items.Clear;
if Assigned(ListView) then
ListView.Archive := aValue;
SelectPathNode;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomTreeView.SetListView(aValue: TAbCustomListView);
begin
if aValue <> FListView then begin
if Assigned(FListView) then begin
FListView.RemoveFreeNotification(Self);
FListView.TreeView := nil;
end;
FListView := aValue;
if Assigned(FListView) then begin
FListView.FreeNotification(Self);
if Assigned(FArchive) then
FListView.Archive := FArchive
else if Assigned(FListView.Archive) then
Archive := FListView.Archive;
FListView.TreeView := Self;
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomTreeView.SetPath(const aValue: string);
begin
if FPath <> aValue then begin
FPath := ExcludeTrailingPathDelimiter(aValue);
SelectPathNode;
if Assigned(FListView) then
FListView.Path := aValue;
end;
end;
{ ===== TAbProgressBar ====================================================== }
procedure TAbProgressBar.DoProgress(Progress : Byte);
begin
Position := Progress;
Application.ProcessMessages;
end;
{ -------------------------------------------------------------------------- }
function TAbProgressBar.GetVersion : string;
begin
Result := AbVersionS;
end;
{ -------------------------------------------------------------------------- }
procedure TAbProgressBar.Reset;
begin
DoProgress(0);
end;
end.
================================================
FILE: lib/abbrevia/source/AbCompnd.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbCompnd.pas *}
{*********************************************************}
{* ABBREVIA: Compound File classes and component *}
{* Use AbQCmpnd.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
unit AbCompnd;
{$ENDIF}
{$I AbDefine.inc}
interface
uses
Classes, SysUtils,
{$IFDEF UsingClx}
QComCtrls,
{$ELSE}
ComCtrls,
{$ENDIF}
AbBase, AbResString, AbDfDec, AbDfEnc, AbDfBase;
const
AbCompoundFileVersion = '3.1';
const
{SystemBlock constants}
sbSignatureSize = 40; {byte size of Signature field}
sbVolumeLabelSize = 40; {byte size of Volume Label field}
sbAllocationSizeSize = 4; {byte size of Allocation Size field}
sbVersionSize = 4; {byte size of Version field}
sbUpdateSize = 1; {byte size of Updating Flag field}
{Total size of System Block}
SizeOfSystemBlock = sbSignatureSize + sbVolumeLabelSize +
sbAllocationSizeSize + sbVersionSize + sbUpdateSize;
{RootDir constants}
rdEntryNameSize = 28; {byte size of Name field}
rdEntryIDSize = 4; {byte size of EntryID field}
rdParentFolderSize = 4; {byte size of ParentFolder field}
rdEntryTypeSize = 4; {byte size of EntryType field}
rdAttributesSize = 4; {byte size of Attributes field}
rdStartBlockSize = 4; {byte size of StartBlock field}
rdLastModifiedSize = 8; {byte size of LastModified field}
rdSizeSize = 4; {byte size of UncompressedSize field}
rdCompressedSizeSize = 4; {byte size of CompressedSize field}
{Total size of a single Root Directory Entry}
rdSizeOfDirEntry = rdEntryNameSize + rdEntryIDSize + rdParentFolderSize +
rdEntryTypeSize + rdAttributesSize + rdStartBlockSize +
rdLastModifiedSize + rdSizeSize + rdCompressedSizeSize;
rdUnUsed = -2; {Constant used to flag an RD entry as unused}
{Total size of a Root Directory entry}
SizeOfRootDirBlock = rdEntryNameSize + rdEntryIDSize + rdParentFolderSize +
rdEntryTypeSize + rdAttributesSize + rdStartBlockSize +
rdLastModifiedSize + rdSizeSize + rdCompressedSizeSize;
{FAT table constants}
ftEndOfBlock = -1; {End of Block}
ftUnusedBlock = -2; {Unused Block}
{General constants}
cfAllocationSize = 512; {Default AllocationSize (bytes)}
type
ECompoundFileError = class(Exception);
TrdEntryType = (etFolder, etFile);
{dynamic array parameter for returning FAT chain sequences}
type TFATChainArray = array of Integer;
{forwards}
{$M+}
TAbCompoundFile = class;
{$M-}
TBeforeDirDeleteEvent = procedure(Sender : TAbCompoundFile; Dir : AnsiString;
var AllowDelete : Boolean) of object;
TBeforeDirModifiedEvent = procedure(Sender : TAbCompoundFile; Dir : AnsiString;
var AllowModify : Boolean) of object;
TBeforeFileDeleteEvent = procedure(Sender : TAbCompoundFile;FileName : AnsiString;
var AllowDelete : Boolean) of object;
TBeforeFileModifiedEvent = procedure(Sender : TAbCompoundFile;
FileName : AnsiString; var AllowModify :
Boolean) of object;
TMultiNode = class(TObject)
protected {private}
FParent : Pointer; {pointer to the parent node}
FKey : AnsiString; {node identifier}
FChildren : TStringList; {list for child keys & nodes}
FData : TObject; {contained object}
function GetChildCount : Integer;
public
constructor Create(const Key : AnsiString);
destructor Destroy; override;
function AddChild(const Key : AnsiString) : TMultiNode;
procedure DeleteChild(Index : Integer);
function DeleteChildByName(const ChildKey : AnsiString) : Boolean;
function DeleteChildren : Boolean;
function GetChild(Index : integer) : TMultiNode;
function GetChildByName(const Key : AnsiString) : TMultiNode;
function HasParent : Boolean;
function HasChildren : Boolean;
function Contains(const Key : AnsiString) : Boolean;
property Parent : Pointer read FParent write FParent;
property ChildCount : Integer read GetChildCount;
property Children[Index : Integer] : TMultiNode read GetChild;
property Data : TObject read FData write FData;
property Key : AnsiString read FKey write FKey;
end;
TMultiTree = class(TObject)
protected {private}
FRoot : TMultiNode; {reference to root node}
FCount : Integer; {count of nodes in the tree}
FCurrentNode : TMultiNode; {analogous to current directory}
FSepChar : AnsiChar; {directory separator character}
FIDCount : Integer; {counter incremented during preorder trav.}
{(used to assign unique ID to each node)}
procedure VisitSubNodesPost(Node : TMultiNode; ID : Integer);
procedure VisitSubNodesPre(Node : TMultiNode; Strm : TStream);
procedure VisitNode(Node : TMultiNode; Strm : TStream);
procedure ParseDirStr(const Key : AnsiString; Lst : TStringList);
procedure PopulateSubNodes(ParentNode : TMultiNode;
TreeView : TTreeView; TreeNode : TTreeNode);
procedure TraversePost(ID : Integer);
procedure TraversePre(Strm : TStream);
public
constructor Create;
destructor Destroy; override;
function Insert(ParentNode : TMultiNode; const Key : AnsiString) : TMultiNode;
function GetNode(const Key : AnsiString) : TMultiNode;
function DeleteNode(const Key : AnsiString) : Boolean;
procedure ChangeDir(const Key : AnsiString);
function PopulateTreeView(TreeView : TTreeView) : Integer;
property Root : TMultiNode read FRoot;
property Count : Integer read FCount;
property CurrentNode : TMultiNode read FCurrentNode;
property SepChar : AnsiChar read FSepChar write FSepChar;
end;
TAbSystemBlock = class(TObject)
protected {private}
FSignature : AnsiString; {identifies the compound file structure}
FVolumeLabel : AnsiString; {file identification in addition to filename}
FAllocationSize : Integer; {size of allocation block}
FVersion : AnsiString; {version string identifier}
FUpdating : Boolean; {internal processing indicator}
{protected methods}
procedure BeginUpdate;
procedure EndUpdate;
procedure WriteToStream(Strm : TMemoryStream);
{properties}
property Signature : AnsiString read FSignature write FSignature;
property VolumeLabel : AnsiString read FVolumeLabel write FVolumeLabel;
property Updating : Boolean read FUpdating;
property AllocationSize : Integer
read FAllocationSize write FAllocationSize;
property Version : AnsiString read FVersion;
public
constructor Create(const VolLabel : AnsiString; AllocationSz : Integer);
end;
TAbDirectoryEntry = class(TObject)
protected {private}
FName : AnsiString; {name of file or folder}
FEntryID : Integer; {unique ID for this dir. entry}
FParentFolder : LongInt; {unique ID of parent folder}
FEntryType : TrdEntryType; {folder or file}
FAttributes : LongInt; {file system attributes}
FStartBlock : LongInt; {starting allocation block}
FLastModified : TDateTime; {last modification date/time}
FSize : LongInt; {uncompressed file size}
FCompressedSize : LongInt; {compressed file size}
procedure WriteToStream(Strm : TMemoryStream);
function IsReadOnly : Boolean;
function IsHidden : Boolean;
function IsSysFile : Boolean;
function IsVolumeID : Boolean;
function IsDirectory : Boolean;
function IsArchive : Boolean;
function GetIsFree : Boolean;
public
constructor Create(AsFile : Boolean);
property EntryName : AnsiString read FName write FName;
property ParentFolder : LongInt read FParentFolder write FParentFolder;
property Attributes : LongInt read FAttributes write FAttributes;
property StartBlock : LongInt read FStartBlock write FStartBlock;
property LastModified : TDateTime read FLastModified write FLastModified;
property Size : LongInt read FSize write FSize;
property CompressedSize : LongInt
read FCompressedSize write FCompressedSize;
property IsFree : Boolean read GetIsFree;
property EntryType : TrdEntryType read FEntryType write FEntryType;
end;
TAbRootDir = class(TMultiTree)
fAllocSize : Integer;
protected {private}
function AddFolder(FolderName : AnsiString) : TAbDirectoryEntry;
function AddFile(FileName : AnsiString) : TAbDirectoryEntry;
procedure DeleteFolder(FolderName : AnsiString);
procedure DeleteFile(FileName : AnsiString);
procedure WriteToStream(Strm : TMemoryStream);
procedure GoToEntryID(ID : Integer);
public
constructor Create(VolLabel : AnsiString; AllocSize : Integer);
destructor Destroy; override;
end;
TAbFATTable = class(TObject)
protected {private}
fFATArray : Array of Integer; {dynamic array for the FAT}
fAllocSize : Integer;
procedure WriteToStream(Strm : TMemoryStream);
public
constructor Create(AllocSize : Integer);
destructor Destroy; override;
function IsEndOfFile(Ndx : Integer) : Boolean;
function IsUnUsed(Ndx : Integer) : Boolean;
function GetNextUnusedBlock : Integer;
procedure GetNewChain(NumBytes : Integer;
var ChainArray : TFATChainArray);
procedure GetExistingChain(StartNdx : Integer;
var ChainArray : TFATChainArray);
procedure ClearExistingChain(StartNdx : Integer);
procedure GetRootDirChain(var ChainArray : TFATChainArray);
procedure GetFATChain(var ChainArray : TFATChainArray);
procedure GetNewRootDirChain(NumBytes : Integer;
var ChainArray : TFATChainArray);
procedure GetNewFATChain(NumBytes : Integer;
var ChainArray : TFATChainArray);
procedure ClearRootDirChain;
procedure ClearFATChain;
end;
TAbCompoundFile = class(TObject)
protected {private}
FSystemBlock : TAbSystemBlock; {system block}
FFATTable : TAbFATTable; {FAT table}
FRootDir : TAbRootDir; {root directory}
FDiskFile : string; {compound file name}
FSizeOnDisk : Integer; {sum total of compressed sizes +
uncompressed Sys, RootDir, & FAT blks}
FStream : TFileStream; {Compound file stream (*.cf)}
FOnAfterOpen : TNotifyEvent;
FOnBeforeClose : TNotifyEvent;
FOnBeforeDirDelete : TBeforeDirDeleteEvent;
FOnBeforeDirModified : TBeforeDirModifiedEvent;
FOnBeforeFileDelete : TBeforeFileDeleteEvent;
FOnBeforeFileModified : TBeforeFileModifiedEvent;
function GetVolumeLabel : AnsiString;
procedure SetVolumeLabel(Val : AnsiString);
function GetDirectoryEntries : Integer;
function GetSizeOnDisk : Integer;
procedure PersistFileData(FileData : TStream;
var ChainArray : TFATChainArray);
procedure PersistSystemBlock;
procedure PersistRootDirBlock;
procedure PersistFATBlock;
procedure BuildSysBlock;
procedure BuildFat;
procedure BuildRootDir;
procedure AddDirEntriesFromList(Lst : TStringList);
procedure Defrag; {not implemented}
public
constructor Create(const FileName : string; const VolLabel : AnsiString;
AllocSize : Integer); overload;
constructor Create(const FileName : string; const VolLabel : AnsiString;
AllocSize : Integer; const Signature: AnsiString); overload;
destructor Destroy; override;
procedure EnumerateFiles(Lst : TStringList);
procedure EnumerateFolders(Lst : TStringList);
procedure AddFile(FName : AnsiString; FileData : TStream; FileSize : Integer);
function AddFolder(FName : AnsiString) : Boolean;
procedure UpdateFile(FName : AnsiString; FData : TStream);
procedure DeleteFile(FName : AnsiString);
procedure DeleteFolder(FName : AnsiString);
procedure Open(const FName : string); overload;
procedure Open(const FName : string; const Signature: AnsiString); overload;
function OpenFile(FileName : AnsiString; var Strm : TStream) : Integer;
function PopulateTreeView(TreeView : TTreeView) : Integer;
procedure PopulateSubNodes(ParentNode : TMultiNode;
TreeView : TTreeView; TreeNode : TTreeNode);
procedure RenameFile(OrigName, NewName : AnsiString);
procedure RenameFolder(OrigName, NewName : AnsiString);
procedure SetCurrentDirectory(val : AnsiString);
function GetCurrentDirectory : AnsiString;
function GetAllocationSize : Integer;
property CurrentDirectory : AnsiString
read GetCurrentDirectory write SetCurrentDirectory;
property DirectoryEntries : Integer read GetDirectoryEntries;
property SizeOnDisk : Integer read GetSizeOnDisk;
property Stream : TFileStream read FStream write FStream;
published
property VolumeLabel : AnsiString read GetVolumeLabel write SetVolumeLabel;
property FileName : string read FDiskFile;
property AllocationSize : Integer read GetAllocationSize;
property OnAfterOpen : TNotifyEvent
read FOnAfterOpen write FOnAfterOpen;
property OnBeforeClose : TNotifyEvent
read FOnBeforeClose write FOnBeforeClose;
property OnBeforeDirDelete : TBeforeDirDeleteEvent
read FOnBeforeDirDelete write FOnBeforeDirDelete;
property OnBeforeDirModified : TBeforeDirModifiedEvent
read FOnBeforeDirModified write FOnBeforeDirModified;
property OnBeforeFileDelete : TBeforeFileDeleteEvent
read FOnBeforeFileDelete write FOnBeforeFileDelete;
property OnBeforeFileModified : TBeforeFileModifiedEvent
read FOnBeforeFileModified write FOnBeforeFileModified;
end;
implementation
uses
StrUtils,
{$IFDEF HasAnsiStrings}AnsiStrings,{$ENDIF}
ABUtils;
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
{TMultiNode}
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
constructor TMultiNode.Create(const Key : AnsiString);
{- Creates and initializes a new node}
begin
inherited Create;
FKey := Key;
FChildren := TStringList.Create;
FChildren.Sorted := True;
FChildren.Duplicates := dupError;
end;
{-----------------------------------------------------------------------------}
destructor TMultiNode.Destroy;
{- Destroys the node and all of the children}
var
i : integer;
begin
{free children}
for i := FChildren.Count - 1 downto 0 do
FChildren.Objects[i].Free;
FChildren.Free;
if Assigned(FData) then
TAbDirectoryEntry(FData).Free;
inherited Destroy;
end;
{-----------------------------------------------------------------------------}
function TMultiNode.AddChild(const Key : AnsiString) : TMultiNode;
{- Creates and adds a new node - returns the newly added node}
begin
if Contains(Key) then
Result := nil
else begin
Result := TMultiNode.Create(Key);
Result.Parent := self;
FChildren.AddObject(string(Key), Result);
end;
end;
{-----------------------------------------------------------------------------}
function TMultiNode.Contains(const Key : AnsiString) : Boolean;
{- Returns true if the node contains a child of the name specified by 'Key'}
begin
Result := (FChildren.IndexOf(string(Key)) >= 0);
end;
{-----------------------------------------------------------------------------}
procedure TMultiNode.DeleteChild(Index : Integer);
{- Deletes the child node specified by 'Index'}
begin
if ((Index < 0) or (Index > FChildren.Count - 1)) then
raise ECompoundFileError.Create(AbCmpndIndexOutOfBounds);
FChildren.Objects[Index].Free;
FChildren.Delete(Index);
end;
{-----------------------------------------------------------------------------}
function TMultiNode.DeleteChildByName(const ChildKey : AnsiString) : Boolean;
{- If node found, node is deleted and true is returned, else returns false}
begin
Result := Contains(ChildKey);
if Result then begin
FChildren.Objects[FChildren.IndexOf(string(ChildKey))].Free;
FChildren.Delete(FChildren.IndexOf(string(ChildKey)));
end;
end;
{-----------------------------------------------------------------------------}
function TMultiNode.DeleteChildren : Boolean;
{- Deletes all child nodes}
var
i : Integer;
begin
Result := FChildren.Count > 0;
for i := FChildren.Count - 1 downto 0 do begin
FChildren.Objects[i].Free;
FChildren.Delete(i);
end;
end;
{-----------------------------------------------------------------------------}
function TMultiNode.GetChild(Index : integer) : TMultiNode;
{- Returns the node specified by Index}
begin
if ((Index < 0) or (Index > FChildren.Count - 1)) then
raise ECompoundFileError.Create(AbCmpndIndexOutOfBounds);
Result := (FChildren.Objects[Index] as TMultiNode);
end;
{-----------------------------------------------------------------------------}
function TMultiNode.GetChildByName(const Key : AnsiString) : TMultiNode;
{- Returns the child node specified by 'Key'. If not found, result = nil}
begin
Result := nil;
if Contains(Key) then
Result := (FChildren.Objects[FChildren.IndexOf(string(Key))] as TMultiNode);
end;
{-----------------------------------------------------------------------------}
function TMultiNode.GetChildCount : Integer;
{- Returns the node's children count}
begin
Result := FChildren.Count;
end;
{-----------------------------------------------------------------------------}
function TMultiNode.HasParent : Boolean;
{- Returns true if parent is assigned, else returns false}
begin
Result := (FParent <> nil);
end;
{-----------------------------------------------------------------------------}
function TMultiNode.HasChildren : Boolean;
{- Returns true if the node contains 1 or more child nodes.}
begin
Result := (FChildren.Count > 0);
end;
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
{TMultiTree}
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
constructor TMultiTree.Create;
{- creates an empty tree}
begin
inherited Create;
FSepChar := '\';
end;
{-----------------------------------------------------------------------------}
destructor TMultiTree.Destroy;
{- destroys all nodes (post-order)}
var
Curr : TMultiNode;
begin
Curr := Root;
while Curr <> nil do begin
if Curr.HasChildren then
Curr := Curr.Children[0]
else
begin
if Curr = Root then begin
Curr.Free;
exit;
end else begin
Curr := Curr.Parent;
Curr.DeleteChild(0);
end;
end;
end;
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.ChangeDir(const Key : AnsiString);
{- Sets current directory of tree if path('Key') is valid}
var
Node : TMultiNode;
Lst : TStringList;
i, Ndx : integer;
NotFound : Boolean;
begin
if Root = nil then exit;
NotFound := False;
Lst := TStringList.Create;
try
ParseDirStr(Key, Lst);
Node := CurrentNode;
for i := 0 to Lst.Count - 1 do begin
if Lst.Strings[i] = '\' then begin
Node := Root;
Continue;
end
else if Lst.Strings[i] = '.' then
Continue
else if Lst.Strings[i] = '..' then begin
if Node <> Root then
Node := TMultiNode(Node.Parent);
end else begin
Ndx := Node.FChildren.IndexOf(Lst.Strings[i]);
if Ndx >= 0 then
Node := Node.GetChild(Ndx)
else begin
NotFound := True;
Break;
end;
end;
end;
finally
Lst.Free;
end;
if NotFound = false then
FCurrentNode := Node;
end;
{-----------------------------------------------------------------------------}
function TMultiTree.DeleteNode(const Key : AnsiString) : Boolean;
{- If node found, deletes the node & returns true, else returns false}
begin
Result := False;
if CurrentNode <> nil then
if CurrentNode.Contains(Key) then begin
Result := CurrentNode.DeleteChildByName(Key);
Dec(FCount);
end;
end;
{-----------------------------------------------------------------------------}
function TMultiTree.GetNode(const Key : AnsiString) : TMultiNode;
{- Returns the node if found, else returns nil}
begin
Result := nil;
if CurrentNode <> nil then
if CurrentNode.Contains(Key) then
Result := CurrentNode.GetChildByName(Key);
end;
{-----------------------------------------------------------------------------}
function TMultiTree.Insert(ParentNode : TMultiNode;
const Key : AnsiString) : TMultiNode;
{- Adds child node to specified ParentNode}
var
NewNode : TMultiNode;
begin
Result := nil;
if CurrentNode = nil then begin
{adding root node}
NewNode := TMultiNode.Create(Key);
FRoot := NewNode;
FCurrentNode := NewNode;
Result := NewNode;
end else begin
if not CurrentNode.Contains(Key) then begin
Result := CurrentNode.AddChild(Key);
Result.Parent := CurrentNode;
end;
end;
Inc(FCount);
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.ParseDirStr(const Key : AnsiString; Lst : TStringList);
{- parses Key into individual dir commands adding each to Lst}
var
LocKey : AnsiString;
Counter : integer;
begin
LocKey := Key;
Lst.Clear;
if LocKey = '' then
LocKey := '\';
{- are we to start from the root folder}
Counter := 0;
while LocKey[Counter+1] = '\' do
inc(Counter);
if Counter = 1 then
Lst.Add('\');
{- begin parsing}
while Length(LocKey) > 0 do begin
while LocKey[1] = '\' do
begin
Delete(LocKey, 1, 1);
if Length(LocKey) = 0 then
exit;
end;
if pos(SepChar,LocKey) > 0 then begin
Lst.Add(string(copy(LocKey, 1, Pos(SepChar, LocKey) - 1)));
Delete(LocKey, 1, Pos(SepChar, LocKey));
end else
if Length(LocKey) > 0 then begin
Lst.Add(string(LocKey));
LocKey := '';
end;
end;
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.PopulateSubNodes(ParentNode : TMultiNode;
TreeView : TTreeView; TreeNode : TTreeNode);
{- Visits sub-nodes recursively - pre order}
var
Curr : TMultiNode;
i : Integer;
Node : TTreeNode;
begin
Node := TreeView.Items.AddChild(TreeNode, string(ParentNode.Key));
Curr := ParentNode;
if Curr <> nil then begin
if Curr.HasChildren then begin
for i := 0 to Curr.ChildCount -1 do
PopulateSubNodes(Curr.Children[i], TreeView, Node);
end;
end;
end;
{-----------------------------------------------------------------------------}
function TMultiTree.PopulateTreeView(TreeView : TTreeView) : Integer;
{- Populates a user-supplied TTreeView with multiway tree nodes}
var
i : Integer;
TreeNode : TTreeNode;
begin
TreeView.Items.Clear;
if Root <> nil then begin
TreeNode := TreeView.Items.Add(nil, string(Root.Key));
if Root.HasChildren then begin
for i := 0 to Root.ChildCount - 1 do
PopulateSubNodes(Root.Children[i], TreeView, TreeNode);
end;
end;
Result := TreeView.Items.Count
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.TraversePost(ID : Integer);
{- Traverses tree post-order - CurrentNode after traversal will be the node
whose EntryID = ID}
var
i : Integer;
begin
if Root <> nil then begin
if Root.HasChildren then begin
for i := 0 to Root.ChildCount - 1 do
VisitSubNodesPost(Root.Children[i], ID);
end;
if (TAbDirectoryEntry(Root.FData).FEntryID = ID) then
FCurrentNode := Root;
end;
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.TraversePre(Strm : TStream);
{- Traverses tree pre-order}
var
i : Integer;
begin
if Root <> nil then begin
FIDCount := 1;
TAbDirectoryEntry(Root.Data).FEntryID := FIDCount;
VisitNode(Root, Strm);
if Root.HasChildren then begin
for i := 0 to Root.ChildCount - 1 do
VisitSubNodesPre(Root.Children[i], Strm);
end;
end;
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.VisitNode(Node : TMultiNode; Strm : TStream);
{- Called recursively from VisitSubNodesPre. Assigns unique entry ID's for
each directory entry to maintain hierarchy}
begin
if Node.Parent = nil then
TAbDirectoryEntry(Node.Data).ParentFolder := -1
else
TAbDirectoryEntry(Node.Data).ParentFolder :=
TAbDirectoryEntry(TMultiNode(Node.Parent).Data).FEntryID;
TAbDirectoryEntry(Node.Data).WriteToStream(TMemoryStream(Strm));
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.VisitSubNodesPost(Node : TMultiNode; ID : Integer);
{- Visits sub-nodes recursively - post order}
var
Curr : TMultiNode;
i : Integer;
begin
Curr := Node;
if Curr <> nil then begin
if Curr.HasChildren then begin
for i := 0 to Curr.ChildCount -1 do
VisitSubNodesPost(Curr.Children[i], ID);
end;
if (TAbDirectoryEntry(Curr.FData).FEntryID = ID) then
FCurrentNode := Curr;
end;
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.VisitSubNodesPre(Node : TMultiNode; Strm : TStream);
{- Visits sub-nodes recursively - pre order}
var
Curr : TMultiNode;
i : Integer;
begin
Curr := Node;
if Curr <> nil then begin
Inc(FIDCount);
TAbDirectoryEntry(Curr.Data).FEntryID := FIDCount;
VisitNode(Curr, Strm);
if Curr.HasChildren then begin
for i := 0 to Curr.ChildCount -1 do
VisitSubNodesPre(Curr.Children[i], Strm);
end;
end;
end;
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
{TAbSystemBlock}
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
constructor TAbSystemBlock.Create(const VolLabel : AnsiString; AllocationSz : Integer);
{- Creates the System block structure of the compound file}
begin
inherited Create;
FSignature := 'AbCompoundFile';
FVolumeLabel := VolLabel;
FAllocationSize := AllocationSz;
FVersion := AbCompoundFileVersion;
FUpdating := False;
end;
{-----------------------------------------------------------------------------}
procedure TAbSystemBlock.BeginUpdate;
{- Sets updating to true - temporarily blocking other actions}
begin
FUpdating := True;
end;
{-----------------------------------------------------------------------------}
procedure TAbSystemBlock.EndUpdate;
{- Clears updating flag & allows for other actions}
begin
FUpdating := False;
end;
{-----------------------------------------------------------------------------}
procedure TAbSystemBlock.WriteToStream(Strm : TMemoryStream);
{- writes the contents to the stream parameter}
var
Sig : Array[0..sbSignatureSize - 1] of AnsiChar;
VolLabel : Array[0..sbVolumeLabelSize - 1] of AnsiChar;
AllocSize : Integer;
Version : Array[0..sbVersionSize - 1] of AnsiChar;
Updt : Byte;
begin
FillChar(Sig, sbSignatureSize, #0);
AbStrPCopy(Sig, FSignature);
FillChar(VolLabel[0], sbVolumeLabelSize, #0);
AbStrPCopy(VolLabel, FVolumeLabel);
AllocSize := FAllocationSize;
FillChar(Version[0], sbVersionSize, #0);
AbStrPCopy(Version, FVersion);
if FUpdating then
Updt := $01
else
Updt := $00;
Strm.Write(Sig[0], sbSignatureSize);
Strm.Write(VolLabel[0], sbVolumeLabelSize);
Strm.Write(AllocSize, SizeOf(Integer));
Strm.Write(Version[0], sbVersionSize);
Strm.Write(Updt, sbUpdateSize);
end;
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
{TAbDirectoryEntry}
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
constructor TAbDirectoryEntry.Create(AsFile : Boolean);
{- Creates & initializes a new TAbDirectoryEntry}
begin
inherited Create;
FName := '';
FParentFolder := rdUnused;
if AsFile then begin
FEntryType := etFile;
{$WARN SYMBOL_PLATFORM OFF}
FAttributes := faArchive;
{$WARN SYMBOL_PLATFORM ON}
end else begin
FEntryType := etFolder;
FAttributes := faDirectory;
end;
FStartBlock := rdUnused;
FLastModified := 0;
FSize := rdUnused;
FCompressedSize := rdUnused;
end;
{-----------------------------------------------------------------------------}
function TAbDirectoryEntry.GetIsFree : Boolean;
{- returns true if the entry has been marked for deletion}
begin
Result := (FName = '');
end;
{-----------------------------------------------------------------------------}
function TAbDirectoryEntry.IsArchive : Boolean;
{- returns true if the entry is an archive}
begin
{$WARN SYMBOL_PLATFORM OFF}
Result := ((FAttributes and faArchive) > 0);
{$WARN SYMBOL_PLATFORM ON}
end;
{-----------------------------------------------------------------------------}
function TAbDirectoryEntry.IsDirectory : Boolean;
{- returns true if the entry is a directory}
begin
Result := ((FAttributes and faDirectory) > 0);
end;
{-----------------------------------------------------------------------------}
function TAbDirectoryEntry.IsHidden : Boolean;
{- returns true if the entry is hidden}
begin
{$WARN SYMBOL_PLATFORM OFF}
Result := ((FAttributes and faHidden) > 0);
{$WARN SYMBOL_PLATFORM ON}
end;
{-----------------------------------------------------------------------------}
function TAbDirectoryEntry.IsReadOnly : Boolean;
{- returns true if the entry is read-only}
begin
{$WARN SYMBOL_PLATFORM OFF}
Result := ((FAttributes and faReadOnly) > 0);
{$WARN SYMBOL_PLATFORM ON}
end;
{-----------------------------------------------------------------------------}
function TAbDirectoryEntry.IsSysFile : Boolean;
{- returns true if the entry is a system file}
begin
{$WARN SYMBOL_PLATFORM OFF}
Result := ((FAttributes and faSysFile) > 0);
{$WARN SYMBOL_PLATFORM ON}
end;
{-----------------------------------------------------------------------------}
function TAbDirectoryEntry.IsVolumeID : Boolean;
{- returns true if the entry is a volume ID}
begin
{$WARN SYMBOL_DEPRECATED OFF}
{$WARN SYMBOL_PLATFORM OFF}
Result := ((FAttributes and faVolumeID) > 0);
{$WARN SYMBOL_PLATFORM ON}
{$WARN SYMBOL_DEPRECATED ON}
end;
{-----------------------------------------------------------------------------}
procedure TAbDirectoryEntry.WriteToStream(Strm : TMemoryStream);
{- writes properties to stream}
var
EntryName : Array[0..rdEntryNameSize] of AnsiChar;
FType : Integer;
begin
FillChar(EntryName, rdEntryNameSize - 1, #0);
AbStrPCopy(EntryName, FName);
Strm.Write(EntryName[0], rdEntryNameSize);
Strm.Write(FEntryID, rdEntryIDSize);
Strm.Write(FParentFolder, rdParentFolderSize);
if EntryType = etFolder then
FType := $00000000
else
FType := $00000001;
Strm.Write(FType, rdEntryTypeSize);
Strm.Write(FAttributes, rdAttributesSize);
Strm.Write(FStartBlock, rdStartBlockSize);
Strm.Write(FLastModified, rdLastModifiedSize);
Strm.Write(FSize, rdSizeSize);
Strm.Write(FCompressedSize, rdCompressedSizeSize);
end;
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
{TAbRootDir}
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
constructor TAbRootDir.Create(VolLabel : AnsiString; AllocSize : Integer);
{- Creates a single-entry (vol-label) root directory structure}
begin
inherited Create;
fAllocSize := AllocSize;
if VolLabel <> '' then
AddFolder(VolLabel);
end;
{-----------------------------------------------------------------------------}
destructor TAbRootDir.Destroy;
{- Destroys the root dir.}
begin
inherited Destroy;
end;
{-----------------------------------------------------------------------------}
function TAbRootDir.AddFile(FileName : AnsiString) : TAbDirectoryEntry;
{- Adds a file to the current directory of the compound file}
var
NewNode : TMultiNode;
NewData : TAbDirectoryEntry;
begin
NewData := nil;
NewNode := Insert(CurrentNode, FileName);
if NewNode <> nil then begin
NewData := TAbDirectoryEntry.Create(True);
NewData.FName := FileName;
NewData.ParentFolder := 1;
{$WARN SYMBOL_PLATFORM OFF}
NewData.Attributes := faArchive;
{$WARN SYMBOL_PLATFORM ON}
NewData.StartBlock := 3;
NewData.LastModified := Now;
NewData.Size := 4;
NewData.CompressedSize := 5;
NewData.EntryType := etFile;
NewNode.Data := NewData;
end;
Result := NewData;
end;
{-----------------------------------------------------------------------------}
function TAbRootDir.AddFolder(FolderName : AnsiString) : TAbDirectoryEntry;
{- Adds a folder to the current directory of the compound file}
var
NewNode : TMultiNode;
NewData : TAbDirectoryEntry;
begin
Result := nil;
NewNode := Insert(CurrentNode, FolderName);
if NewNode <> nil then begin
NewData := TAbDirectoryEntry.Create(False);
NewData.FName := FolderName;
NewData.ParentFolder := 1;
NewData.Attributes := faDirectory;
NewData.StartBlock := rdUnUsed;
NewData.LastModified := Now;
NewData.Size := 0;
NewData.CompressedSize := 0;
NewData.EntryType := etFolder;
NewNode.Data := NewData;
Result :=NewData;
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbRootDir.DeleteFile(FileName : AnsiString);
{- Deletes the specified file if found}
begin
DeleteNode(FileName);
end;
{-----------------------------------------------------------------------------}
procedure TAbRootDir.DeleteFolder(FolderName : AnsiString);
{- Deletes the specifed folder if found & empty}
begin
if not CurrentNode.Contains(FolderName) then
raise ECompoundFileError.Create(AbCmpndFileNotFound);
if CurrentNode.ChildCount > 0 then
raise ECompoundFileError.Create(AbCmpndFolderNotEmpty);
DeleteFolder(FolderName);
end;
{-----------------------------------------------------------------------------}
procedure TAbRootDir.WriteToStream(Strm : TMemoryStream);
{- Streams and writes the root directory entries to the stream parameter}
begin
TraversePre(Strm);
end;
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
{TAbFATTable}
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
constructor TAbFATTable.Create(AllocSize : Integer);
{- Creates the FAT table structure}
var
i : Integer;
begin
{Sets FAT length equal to one allocation block}
fAllocSize := AllocSize;
SetLength(fFATArray, AllocSize div SizeOf(Integer));
for i := 0 to High(fFATArray) do
fFATArray[i] := ftUnusedBlock;
for i := 0 to 2 do
fFATArray[i] := ftEndOfBlock;
end;
{-----------------------------------------------------------------------------}
destructor TAbFATTable.Destroy;
{- Destroys the FAT table}
begin
Finalize(fFATArray);
end;
{-----------------------------------------------------------------------------}
procedure TAbFATTable.ClearExistingChain(StartNdx : Integer);
{- Sets all of the FAT entries pertaining to the sequence starting at StartNds
to ftUnUsedBlock}
var
ChainArray : TFATChainArray;
i : Integer;
begin
SetLength(ChainArray, 0);
GetExistingChain(StartNdx, ChainArray);
for i := 0 to High(ChainArray) do
fFATArray[ChainArray[i]] := ftUnUsedBlock;
end;
{-----------------------------------------------------------------------------}
procedure TAbFATTable.ClearFATChain;
{- Sets the FAT entries pertaining to the FAT table to unused}
begin
ClearExistingChain(2);
end;
{-----------------------------------------------------------------------------}
procedure TAbFATTable.ClearRootDirChain;
{- Sets the FAT entries pertaining the the RootDir to unused}
begin
ClearExistingChain(1);
end;
{-----------------------------------------------------------------------------}
procedure TAbFATTable.GetExistingChain(StartNdx : Integer;
var ChainArray : TFATChainArray);
{- Walks the FAT table starting at the index specified, and populates the
chain array parameter with the results}
var
BlkCount, i, ChainNdx : Integer;
begin
if fFATArray[StartNdx] = ftUnUsedBlock then begin
SetLength(ChainArray, 0);
exit;
end;
{determine count}
if StartNdx < 1 then
SetLength(ChainArray, 0)
else begin
BlkCount := 1;
i := StartNdx;
while fFATArray[i] <> ftEndOfBlock do begin
i := fFATArray[i];
Inc(BlkCount);
end;
{set up array}
SetLength(ChainArray, BlkCount);
for i := 0 to High(ChainArray) do
ChainArray[i] := ftUnusedBlock;
{walk FAT & populate array}
ChainNdx := 0;
ChainArray[ChainNdx] := StartNdx;
i := StartNdx;
while fFATArray[i] <> ftEndOfBlock do begin
Inc(ChainNdx);
ChainArray[ChainNdx] := fFATArray[i];
i := fFATArray[i];
end;
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbFATTable.GetFATChain(var ChainArray : TFATChainArray);
{- Returns the sequence of FAT blocks used by the FAT table in the
ChainArray parameter}
begin
GetExistingChain(2, ChainArray);
end;
{-----------------------------------------------------------------------------}
procedure TAbFATTable.GetNewChain(NumBytes : Integer;
var ChainArray : TFATChainArray);
{- Finds sequence of free blocks required of a file of size NumBytes
The new FAT chain is commited and passed back in the ChainArray parameter}
var
FirstBlock : Integer;
TotalBlocksRequired : Integer;
i, j, BlocksFound : Integer;
begin
if ((NumBytes mod fAllocSize) <> 0) then
TotalBlocksRequired := (NumBytes div fAllocSize) + 1
else
TotalBlocksRequired := (NumBytes div fAllocSize);
if TotalBlocksRequired = 0 then
exit;
FirstBlock := GetNextUnusedBlock;
{set up array}
SetLength(ChainArray, TotalBlocksRequired);
for i := 0 to High(ChainArray) do
ChainArray[i] := ftUnusedBlock;
ChainArray[0] := FirstBlock;
BlocksFound := 1;
i := FirstBlock + 1;
while BlocksFound < TotalBlocksRequired do begin
if ((fFATArray[i] = ftUnusedBlock) and (i > 2)) then begin
ChainArray[BlocksFound] := i;
inc(BlocksFound);
end;
Inc(i);
if i > High(fFATArray) then begin
{grow FAT (allocate another block)}
SetLength(fFATArray, Length(fFATArray) + (fAllocSize div SizeOf(Integer)));
for j := High(fFATArray) downto (Length(fFATArray) -
(fAllocSize div SizeOf(Integer))) do
fFATArray[j] := ftUnUsedBlock;
end;
end;
{Update FAT}
for i := 0 to High(ChainArray) do begin
if i = High(ChainArray) then
fFATArray[ChainArray[i]] := -1
else
fFATArray[ChainArray[i]] := ChainArray[i+1];
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbFATTable.GetNewFATChain(NumBytes : Integer;
var ChainArray : TFATChainArray);
{- Finds and commits a new chain starting at the 3rd block. The new chain is
returned in the ChainArray parameter}
var
FirstBlock : Integer;
TotalBlocksRequired : Integer;
i, j, BlocksFound : Integer;
begin
if ((NumBytes mod fAllocSize) <> 0) then
TotalBlocksRequired := (NumBytes div fAllocSize) + 1
else
TotalBlocksRequired := (NumBytes div fAllocSize);
if TotalBlocksRequired = 0 then
exit;
FirstBlock := 2;
{set up array}
SetLength(ChainArray, TotalBlocksRequired);
for i := 0 to High(ChainArray) do
ChainArray[i] := ftUnusedBlock;
ChainArray[0] := FirstBlock;
BlocksFound := 1;
i := FirstBlock + 1;
while BlocksFound < TotalBlocksRequired do begin
if ((fFATArray[i] = ftUnusedBlock) and (i > 2)) then begin
ChainArray[BlocksFound] := i;
inc(BlocksFound);
end;
Inc(i);
if i > High(fFATArray) then begin
{grow FAT (allocate another block)}
SetLength(fFATArray, Length(fFATArray) + (fAllocSize div SizeOf(Integer)));
for j := High(fFATArray) downto (Length(fFATArray) -
(fAllocSize div SizeOf(Integer))) do
fFATArray[j] := ftUnUsedBlock;
end;
end;
{Update FAT}
for i := 0 to High(ChainArray) do begin
if i = High(ChainArray) then
fFATArray[ChainArray[i]] := -1
else
fFATArray[ChainArray[i]] := ChainArray[i+1];
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbFATTable.GetNewRootDirChain(NumBytes : Integer;
var ChainArray : TFATChainArray);
{- Finds and commits a new chain starting at the 2nd block. The new chain is
returned in the ChainArray parameter}
var
FirstBlock : Integer;
TotalBlocksRequired : Integer;
i, j, BlocksFound : Integer;
begin
if ((NumBytes mod fAllocSize) <> 0) then
TotalBlocksRequired := (NumBytes div fAllocSize) + 1
else
TotalBlocksRequired := (NumBytes div fAllocSize);
if TotalBlocksRequired = 0 then
exit;
FirstBlock := 1;
{set up array}
SetLength(ChainArray, TotalBlocksRequired);
for i := 0 to High(ChainArray) do
ChainArray[i] := ftUnusedBlock;
ChainArray[0] := FirstBlock;
BlocksFound := 1;
i := FirstBlock + 1;
while BlocksFound < TotalBlocksRequired do begin
if ((fFATArray[i] = ftUnusedBlock) and (i > 2)) then begin
ChainArray[BlocksFound] := i;
inc(BlocksFound);
end;
Inc(i);
if i > High(fFATArray) then begin
{grow FAT (allocate another block)}
SetLength(fFATArray, Length(fFATArray) + (fAllocSize div SizeOf(Integer)));
for j := High(fFATArray) downto (Length(fFATArray) -
(fAllocSize div SizeOf(Integer))) do
fFATArray[j] := ftUnUsedBlock;
end;
end;
{Update FAT}
for i := 0 to High(ChainArray) do begin
if i = High(ChainArray) then
fFATArray[ChainArray[i]] := -1
else
fFATArray[ChainArray[i]] := ChainArray[i+1];
end;
end;
{-----------------------------------------------------------------------------}
function TAbFATTable.GetNextUnusedBlock : Integer;
{- Returns the index into the FAT table of the next block marked as unused}
var
i, j : Integer;
begin
if Length(fFATArray) = 0 then
Result := -1
else begin
Result := -1;
i := 3;
while i <= High(fFATArray) do begin
if fFATArray[i] = ftUnusedBlock then begin
Result := i;
exit;
end;
inc(i);
if i > High(fFATArray) then begin
{grow FAT (allocate another block)}
SetLength(fFATArray, Length(fFATArray) +
(fAllocSize div SizeOf(Integer)));
for j := High(fFATArray) downto (Length(fFATArray) -
(fAllocSize div SizeOf(Integer))) do
fFATArray[j] := ftUnUsedBlock;
end;
end;
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbFATTable.GetRootDirChain(var ChainArray : TFATChainArray);
{- Returns the sequence of FAT blocks used by the RootDir in the
ChainArray parameter}
begin
GetExistingChain(1, ChainArray);
end;
{-----------------------------------------------------------------------------}
function TAbFATTable.IsEndOfFile(Ndx : Integer) : Boolean;
{- Returns true if Ndx into FAT signifies end of file}
begin
if ((Ndx < 0) or (Ndx > High(fFATArray)) or
(Length(fFATArray) = 0)) then
raise ECompoundFileError.Create(AbCmpndIndexOutOfBounds)
else
Result := (fFATArray[Ndx] = ftEndOfBlock);
end;
{-----------------------------------------------------------------------------}
function TAbFATTable.IsUnUsed(Ndx : Integer) : Boolean;
{- Returns true if Ndx into FAT signifies an unused block}
begin
if ((Ndx < 0) or (Ndx > High(fFATArray)) or
(Length(fFATArray) = 0)) then
raise ECompoundFileError.Create(AbCmpndIndexOutOfBounds)
else
Result := (fFATArray[Ndx] = ftUnUsedBlock);
end;
{-----------------------------------------------------------------------------}
procedure TAbFATTable.WriteToStream(Strm : TMemoryStream);
{- Streams and writes the FAT entries to the stream parameter}
begin
Strm.Write(fFATArray[0], Length(fFATArray) * SizeOf(Integer));
end;
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
{TAbCompoundFile}
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
constructor TAbCompoundFile.Create(const FileName : string; const VolLabel : AnsiString;
AllocSize : Integer);
{- Creates a new instance}
var
Buff : Array of Byte;
begin
inherited Create;
FSystemBlock := TAbSystemBlock.Create(VolLabel, AllocSize);
FFATTable := TAbFATTable.Create(AllocSize);
FRootDir := TAbRootDir.Create(VolLabel, AllocSize);
{create file}
if FileName <> '' then begin
FDiskFile := FileName;
FStream := TFileStream.Create(FileName, fmOpenReadWrite or
fmCreate or fmShareDenyNone);
{fill first 3 blocks of file}
SetLength(Buff, 3 * AllocSize);
FStream.Write(Buff, 3 * AllocSize);
{write System, RootDir, and FAT blocks}
PersistSystemBlock;
PersistRootDirBlock;
PersistFATBlock;
if Assigned(FOnAfterOpen) then
FOnAfterOpen(self);
end;
end;
constructor TAbCompoundFile.Create(const FileName : string; const VolLabel : AnsiString;
AllocSize : Integer; const Signature: AnsiString);
{- Creates a new instance}
var
Buff : Array of Byte;
begin
inherited Create;
FSystemBlock := TAbSystemBlock.Create(VolLabel, AllocSize);
FSystemBlock.Signature := AbLeftStr(Signature, sbSignatureSize);
FFATTable := TAbFATTable.Create(AllocSize);
FRootDir := TAbRootDir.Create(VolLabel, AllocSize);
{create file}
if FileName <> '' then begin
FDiskFile := FileName;
FStream := TFileStream.Create(FileName, fmOpenReadWrite or
fmCreate or fmShareDenyNone);
{fill first 3 blocks of file}
SetLength(Buff, 3 * AllocSize);
FStream.Write(Buff, 3 * AllocSize);
{write System, RootDir, and FAT blocks}
PersistSystemBlock;
PersistRootDirBlock;
PersistFATBlock;
if Assigned(FOnAfterOpen) then
FOnAfterOpen(self);
end;
end;
{-----------------------------------------------------------------------------}
destructor TAbCompoundFile.Destroy;
{- Persists and then destroys the instance of the compound file}
begin
PersistSystemBlock;
PersistRootDirBlock;
PersistFATBlock;
if Assigned(FOnBeforeClose) then
FOnBeforeClose(self);
FSystemBlock.Free;
FFATTable.Free;
FRootDir.Free;
FStream.Free;
inherited;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.AddFile(FName : AnsiString; FileData : TStream;
FileSize : Integer);
function JustFilename(const PathName : AnsiString) : AnsiString;
{-Return just the filename and extension of a pathname.}
var
I : Cardinal;
begin
Result := '';
if PathName = '' then Exit;
I := Succ(Word(Length(PathName)));
repeat
Dec(I);
until (PathName[I] in ['\',':']) or (I = 0);
Result := System.Copy(PathName, Succ(I), rdEntryNameSize);
end;
{- Compresses, adds & persists the data (FileData)}
var
DirEntry : TAbDirectoryEntry;
CompStream : TStream;
CompHelper : TAbDeflateHelper;
ChainArray : TFATChainArray;
begin
FName := JustFileName(FName);
if ((FStream.Size + FileData.Size +
(4 * FSystemBlock.AllocationSize)) >= MaxLongInt) then
raise ECompoundFileError.Create(AbCmpndExceedsMaxFileSize);
if FSystemBlock.Updating then
raise ECompoundFileError.Create(AbCmpndBusyUpdating);
FSystemBlock.BeginUpdate;
CompStream := TMemoryStream.Create;
CompHelper := TAbDeflateHelper.Create;
try
DirEntry := FRootDir.AddFile(FName);
if DirEntry <> nil then begin
DirEntry.FSize := FileSize;
{compress & update dir entry's compressed size}
FileData.Seek(0, soBeginning);
Deflate(FileData, CompStream, CompHelper);
DirEntry.FCompressedSize := CompStream.Size;
{Get new FAT chain & persist the data}
SetLength(ChainArray, 0);
FFATTable.GetNewChain(CompStream.Size, ChainArray);
DirEntry.FStartBlock := ChainArray[0];
PersistFileData(CompStream, ChainArray);
PersistRootDirBlock;
PersistFATBlock;
end;
finally
CompStream.Free;
CompHelper.Free;
FSystemBlock.EndUpdate;
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.AddDirEntriesFromList(Lst : TStringList);
{- Add individual root directory entries to RootDir structure maintaining seq.}
var
i : Integer;
LstEntry : TAbDirectoryEntry;
Entry : TAbDirectoryEntry;
begin
for i := 0 to Lst.Count - 1 do begin
LstEntry := (Lst.Objects[i] as TAbDirectoryEntry);
{locate parent folder}
FRootDir.GoToEntryID(LstEntry.FParentFolder);
{Add file or folder}
if LstEntry.EntryType = etFolder then
Entry := FRootDir.AddFolder(LstEntry.FName)
else
Entry := FRootDir.AddFile(LstEntry.FName);
{assign values}
Entry.FName := LstEntry.FName;
Entry.FEntryID := LstEntry.FEntryID;
Entry.FParentFolder := LstEntry.FParentFolder;
Entry.FEntryType := LstEntry.FEntryType;
Entry.FAttributes := LstEntry.FAttributes;
Entry.FStartBlock := LstEntry.FStartBlock;
Entry.FLastModified := LstEntry.FLastModified;
Entry.FSize := LstEntry.FSize;
Entry.FCompressedSize := LstEntry.FCompressedSize;
end;
end;
{-----------------------------------------------------------------------------}
function TAbCompoundFile.AddFolder(FName : AnsiString) : Boolean;
{- Adds a new folder (directory) to the compound file}
var
EntryCount : Integer;
begin
if ((FStream.Size + FSystemBlock.AllocationSize) >= MaxLongInt) then
raise ECompoundFileError.Create(AbCmpndExceedsMaxFileSize);
EntryCount := FRootDir.Count;
FSystemBlock.BeginUpdate;
try
FRootDir.AddFolder(FName);
PersistRootDirBlock;
PersistFATBlock;
finally
FSystemBlock.EndUpdate;
end;
Result := ((FRootDir.Count - EntryCount) = 1);
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.BuildFat;
{- Extracts FAT from this string, writes it to DestStrm(TMemoryStream) and
ultimately updates/persists the FAT table}
var
Buff : Array of Integer;
IntBuff : Array[0..0] of Integer;
DestStrm : TMemoryStream;
i, CurrPos : Integer;
NextBlock : Integer;
begin
DestStrm := TMemoryStream.Create;
try
{Dim Buff to allocation block size}
SetLength(Buff, FSystemBlock.AllocationSize div SizeOf(Integer));
{Clear Buff}
for i := Low(Buff) to High(Buff) do
Buff[i] := ftUnusedBlock;
{read 1st FAT block into Buff -> Write Buff to DestStrm}
FStream.Seek(2 * FSystemBlock.AllocationSize, soBeginning);
FStream.Read(Buff[0], FSystemBlock.AllocationSize);
DestStrm.Write(Buff[0], FSystemBlock.AllocationSize);
{Determine next block of FAT chain}
NextBlock := Buff[2];
{read remaining FAT blocks if they exist}
While NextBlock <> ftEndOfBlock do begin
FStream.Seek((NextBlock) * FSystemBlock.AllocationSize, soBeginning);
{Clear buff}
for i := Low(Buff) to High(Buff) do
Buff[i] := ftUnusedBlock;
FStream.Read(Buff[0], FSystemBlock.AllocationSize);
DestStrm.Write(Buff[0], FSystemBlock.AllocationSize);
{Determine the next FAT block - we'll return to this position in stream}
CurrPos := DestStrm.Position;
DestStrm.Seek((NextBlock - 1) * SizeOf(Integer), soBeginning);
DestStrm.Read(IntBuff[0], SizeOf(Integer));
NextBlock := IntBuff[0];
DestStrm.Seek(CurrPos, soBeginning);
end;
{Set length of and populate the FFATTable.fFATArray in mem structure}
DestStrm.Seek(0, soBeginning);
SetLength(FFATTable.fFATArray, DestStrm.Size div SizeOf(Integer));
for i := 1 to DestStrm.Size div SizeOf(Integer) do begin
DestStrm.Read(IntBuff[0], SizeOf(Integer));
FFATTable.fFATArray[i-1] := IntBuff[0];
end;
finally
DestStrm.Free;
end;
PersistFATBlock;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.BuildRootDir;
{- Builds list of root directory entries & passes list to AddDirEntriesFromList}
var
ChainArray : TFATChainArray;
DestStrm : TMemoryStream;
Buff : Array of Byte;
i : Integer;
Entry : TAbDirectoryEntry;
Lst : TStringList;
{RootDirEntry buffers}
EName : Array[0..rdEntryNameSize - 1] of AnsiChar;
EID : Array[0..0] of Integer;
EPF : Array[0..0] of Integer;
EType : Array[0..0] of Integer;
EAttrib : Array[0..0] of Integer;
EStartBlk : Array[0..0] of Integer;
EMod : Array[0..0] of TDateTime;
ESz : Array[0..0] of Integer;
ECompSz : Array[0..0] of Integer;
begin
{Get RootDir FAT chain}
FFATTable.GetRootDirChain(ChainArray);
SetLength(Buff, FSystemBlock.AllocationSize);
DestStrm := TMemoryStream.Create;
Lst := TStringList.Create;
Lst.Duplicates := dupAccept;
Lst.Sorted := False;
try
{Read entire RotDir block to DestStrm}
for i := 0 to High(ChainArray) do begin
FStream.Seek(FSystemBlock.AllocationSize * ChainArray[i], soBeginning);
FStream.Read(Buff[0], FSystemBlock.AllocationSize);
DestStrm.Write(Buff[0], FSystemBlock.AllocationSize);
end;
{Reset DestStrm}
DestStrm.Seek(0, soBeginning);
{For all directory entries, read entry, create object, & add to Lst}
for i := 0 to (DestStrm.Size div rdSizeOfDirEntry) - 1 do begin
{read a single directory entry}
DestStrm.Read(EName[0], rdEntryNameSize);
if EName = '' then
continue;
DestStrm.Read(EID[0], SizeOf(Integer));
DestStrm.Read(EPF[0], SizeOf(Integer));
DestStrm.Read(EType[0], SizeOf(Integer));
DestStrm.Read(EAttrib[0], SizeOf(Integer));
DestStrm.Read(EStartBlk[0], SizeOf(Integer));
DestStrm.Read(EMod[0], SizeOf(TDateTime));
DestStrm.Read(ESz[0], SizeOf(Integer));
DestStrm.Read(ECompSz[0], SizeOf(Integer));
if EType[0] = 0 then
Entry := TAbDirectoryEntry.Create(False)
else
Entry := TAbDirectoryEntry.Create(True);
Entry.FName := EName;
Entry.FEntryID := EID[0];
Entry.FParentFolder := EPF[0];
if EType[0] = 0 then
Entry.FEntryType := etFolder
else
Entry.FEntryType := etFile;
Entry.FAttributes := EAttrib[0];
Entry.FStartBlock := EStartBlk[0];
Entry.FLastModified := EMod[0];
Entry.FSize := ESz[0];
Entry.FCompressedSize := ECompSz[0];
{Don't add an empty dir entry}
if Entry.FName <> '' then
Lst.AddObject(IntToStr(i), TObject(Entry));
end;
{Add individual root directory entries to RootDir structure maintaining seq.}
AddDirEntriesFromList(Lst);
finally
DestStrm.Free;
for i := 0 to Lst.Count - 1 do
if Lst.Objects[i] <> nil then
TAbDirectoryEntry(Lst.Objects[i]).Free;
Lst.Free;
end;
{Save updates}
PersistRootDirBlock;
PersistFATBlock;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.BuildSysBlock;
{- Constructs System block from the contents of FStream
(used when opening an existing compound file)}
var
Sig : Array[0..sbSignatureSize - 1] of AnsiChar;
VolLabel : Array[0..sbVolumeLabelSize - 1] of AnsiChar;
Version : Array[0..sbVersionSize - 1] of AnsiChar;
AllocationSz : Array[0..0] of Integer;
begin
FStream.Seek(0, soBeginning);
FStream.Read(Sig[0], sbSignatureSize);
FStream.Read(VolLabel[0], sbVolumeLabelSize);
FStream.Read(AllocationSz[0], sbAllocationSizeSize);
FStream.Read(Version[0], sbVersionSize);
FSystemBlock.Signature := Sig;
FSystemBlock.VolumeLabel := VolLabel;
FSystemBlock.AllocationSize := AllocationSz[0];
FSystemBlock.FVersion := Version;
PersistSystemBlock;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.Defrag;
{- Optimizes disk storage}
begin
{ not implemeneted }
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.DeleteFile(FName : AnsiString);
{- Deletes the file from the RootDirectory and FAT blocks (data remains)}
var
StartBlock : Integer;
Allow : Boolean;
AllowDirMod : Boolean;
begin
Allow := True;
AllowDirMod := True;
if not FRootDir.CurrentNode.Contains(FName) then
raise ECompoundFileError.Create(AbCmpndFileNotFound);
if Assigned(FOnBeforeFileDelete) then
FOnBeforeFileDelete(self, FName, Allow);
if Assigned(FOnBeforeDirModified) then
FOnBeforeDirModified(self, TMultiNode(FRootDir.CurrentNode.Parent).Key,
AllowDirMod);
if (Allow and AllowDirMod) then begin
StartBlock := TAbDirectoryEntry(FRootDir.GetNode(FName).FData).StartBlock;
FFATTable.ClearExistingChain(StartBlock);
FRootDir.DeleteFile(FName);
PersistRootDirBlock;
PersistFATBlock;
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.DeleteFolder(FName : AnsiString);
{- Deletes the folder from the RootDirectory block}
var
Allow : Boolean;
AllowDirMod : Boolean;
begin
Allow := True;
AllowDirMod := True;
if not FRootDir.CurrentNode.Contains(FName) then
raise ECompoundFileError.Create(AbCmpndFileNotFound);
if Assigned(FOnBeforeDirDelete) then
FOnBeforeDirDelete(self, FName, Allow);
if Assigned(FOnBeforeDirModified) then
FOnBeforeDirModified(self, TMultiNode(FRootDir.CurrentNode.Parent).Key,
AllowDirMod);
if (Allow and AllowDirMod) then begin
FRootDir.DeleteFolder(FName);
PersistRootDirBlock;
PersistFATBlock;
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.EnumerateFiles(Lst : TStringList);
var
i : Integer;
begin
Lst.Clear;
for i := 0 to FRootDir.CurrentNode.ChildCount - 1 do begin
if (FRootDir.CurrentNode.Children[i].Data as TAbDirectoryEntry).EntryType = etFile then
Lst.Add(string((FRootDir.CurrentNode.Children[i].Data as TAbDirectoryEntry).EntryName));
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.EnumerateFolders(Lst : TStringList);
var
i : Integer;
begin
Lst.Clear;
for i := 0 to FRootDir.CurrentNode.ChildCount - 1 do begin
if (FRootDir.CurrentNode.Children[i].Data as TAbDirectoryEntry).EntryType = etFolder then
Lst.Add(string((FRootDir.CurrentNode.Children[i].Data as TAbDirectoryEntry).EntryName));
end;
end;
{-----------------------------------------------------------------------------}
function TAbCompoundFile.GetAllocationSize : Integer;
{- Returns the block allocation size used by the compound file}
begin
result := FSystemBlock.AllocationSize;
end;
{-----------------------------------------------------------------------------}
function TAbCompoundFile.GetCurrentDirectory : AnsiString;
{- Returns the current directory}
begin
Result := FRootDir.CurrentNode.Key;
end;
{-----------------------------------------------------------------------------}
function TAbCompoundFile.GetDirectoryEntries : Integer;
{- Returns the total number of directory entries (files and folders)}
begin
Result := FRootDir.Count;
end;
{-----------------------------------------------------------------------------}
function TAbCompoundFile.GetSizeOnDisk : Integer;
{- Returns the compound file size (FStream.Size)}
begin
Result := FStream.Size;
end;
{-----------------------------------------------------------------------------}
function TAbCompoundFile.GetVolumeLabel : AnsiString;
{- Returns the volume label of the compound file}
begin
Result := FSystemBlock.VolumeLabel;
end;
{-----------------------------------------------------------------------------}
procedure TAbRootDir.GoToEntryID(ID : Integer);
{- Traverses tree and sets the current node to the node whose EntryID = ID}
begin
TraversePost(ID);
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.Open(const FName : string);
{- Opens an existing compound file and builds Sys, Root Dir, and FAT blocks}
var
Sig : Array[0..sbSignatureSize - 1] of AnsiChar;
begin
if FStream <> nil then
FStream.Free;
FStream := TFileStream.Create(FName, fmOpenReadWrite or fmShareDenyNone);
{Ensure valid signature}
FStream.Read(Sig[0], sbSignatureSize);
if Sig <> AbLeftStr(FSystemBlock.Signature, sbSignatureSize) then begin
raise ECompoundFileError.Create(AbCmpndInvalidFile);
exit;
end;
FDiskFile := FName;
{populate Compound File structure}
BuildSysBlock;
BuildFat;
BuildRootDir;
if Assigned(FOnAfterOpen) then
FOnAfterOpen(self);
end;
procedure TAbCompoundFile.Open(const FName : string; const Signature: AnsiString);
{- Opens an existing compound file and builds Sys, Root Dir, and FAT blocks}
var
Sig : Array[0..sbSignatureSize - 1] of AnsiChar;
begin
if FStream <> nil then
FStream.Free;
FStream := TFileStream.Create(FName, fmOpenReadWrite or fmShareDenyNone);
{Ensure valid signature}
FStream.Read(Sig[0], sbSignatureSize);
if Sig <> AbLeftStr(Signature, sbSignatureSize) then begin
raise ECompoundFileError.Create(AbCmpndInvalidFile);
exit;
end;
FDiskFile := FName;
{populate Compound File structure}
BuildSysBlock;
BuildFat;
BuildRootDir;
if Assigned(FOnAfterOpen) then
FOnAfterOpen(self);
end;
{-----------------------------------------------------------------------------}
function TAbCompoundFile.OpenFile(FileName : AnsiString; var Strm : TStream)
: Integer;
{- Opens the file and writes the file contents to Strm}
var
ChainArray : TFatChainArray;
i, j : Integer;
Buff : Array of Byte;
RemainingBytes : Integer;
CompStream : TStream;
CompHelper : TAbDeflateHelper;
begin
if not FRootDir.CurrentNode.Contains(FileName) then
raise ECompoundFileError.Create(AbCmpndFileNotFound);
CompStream := TMemoryStream.Create;
CompHelper := TAbDeflateHelper.Create;
try
{Read the existing (compressed) file into CompStream}
FFATTable.GetExistingChain((FRootDir.GetNode(FileName).FData
as TAbDirectoryEntry).StartBlock, ChainArray);
SetLength(Buff, FSystemBlock.AllocationSize);
for i := 0 to high(ChainArray) do begin
for j := 0 to Pred(FSystemBlock.AllocationSize) do
Buff[j] := Byte(chr(0));
FStream.Seek((ChainArray[i]) * FSystemBlock.AllocationSize, soBeginning);
if i <> High(ChainArray) then begin
FStream.Read(buff[0], FSystemBlock.AllocationSize);
CompStream.Write(Buff[0], FSystemBlock.AllocationSize);
end else begin
{read less than entire block}
RemainingBytes := (FRootDir.GetNode(FileName).FData as TAbDirectoryEntry).
CompressedSize mod FSystemBlock.AllocationSize;
FStream.Read(Buff[0], RemainingBytes);
CompStream.Write(Buff[0], RemainingBytes);
end;
end;
{CompStream now contains the entire compressed file stream}
CompStream.Seek(0, soBeginning);
Inflate(CompStream, Strm, CompHelper);
finally
CompStream.Free;
CompHelper.Free;
end;
Result := Strm.Size;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.PersistFATBlock;
{- Saves the FAT table to disk}
var
FATStrm : TMemoryStream;
Buff : Array of Byte;
i : Integer;
ChainArray : TFATChainArray;
begin
{Init Buffer}
SetLength(Buff, FSystemBlock.AllocationSize);
{Init & fill RootDir stream}
FATStrm := TMemoryStream.Create;
try
FFATTable.WriteToStream(FATStrm);
{prep FAT Table}
fFATTable.ClearFATChain;
fFATTable.GetNewFATChain(FATStrm.Size, ChainArray);
FATStrm.Seek(0, soBeginning);
for i := 0 to High(ChainArray) do begin
{Clear block contents}
FillChar(Buff[0], FSystemBlock.AllocationSize, #0);
FStream.Seek(FSystemBlock.FAllocationSize * ChainArray[i], soBeginning);
FStream.Write(Buff[0], FSystemBlock.AllocationSize);
{write new contents}
FATStrm.Read(Buff[0], FSystemBlock.AllocationSize);
FStream.Seek(FSystemBlock.FAllocationSize * ChainArray[i], soBeginning);
FStream.Write(Buff[0], FSystemBlock.AllocationSize);
end;
finally
FATStrm.Free;
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.PersistFileData(FileData : TStream;
var ChainArray : TFATChainArray);
{- Walks FAT chain and persists data (FileData) to the corresponding blocks}
var
Buff : Array of Byte;
i : Integer;
j : Integer;
begin
if FileData <> nil then begin
FileData.Seek(0, soBeginning);
SetLength(Buff, FSystemBlock.AllocationSize);
for i := 0 to High(ChainArray) do begin
for j := 0 to FSystemBlock.AllocationSize - 1 do
Buff[j] := Byte(chr(0));
FileData.Read(Buff[0], FSystemBlock.AllocationSize);
FStream.Seek(FSystemBlock.AllocationSize * ChainArray[i], soBeginning);
FStream.Write(Buff[0],FSystemBlock.AllocationSize);
end;
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.PersistRootDirBlock;
{- Saves the RootDirectory block to disk}
var
RdStrm : TMemoryStream;
Buff : Array of Byte;
i : Integer;
ChainArray : TFATChainArray;
begin
{Init Buffer}
SetLength(Buff, FSystemBlock.AllocationSize);
{Init & fill RootDir stream}
RdStrm := TMemoryStream.Create;
try
FRootDir.WriteToStream(RdStrm);
{prep FAT Table}
fFATTable.ClearRootDirChain;
fFATTable.GetNewRootDirChain(RdStrm.Size, ChainArray);
RdStrm.Seek(0, soBeginning);
for i := 0 to High(ChainArray) do begin
{Clear block contents}
FillChar(Buff[0], FSystemBlock.AllocationSize, #0);
FStream.Seek(FSystemBlock.FAllocationSize * ChainArray[i], soBeginning);
FStream.Write(Buff[0], FSystemBlock.AllocationSize);
{write new contents}
RdStrm.Read(Buff[0], FSystemBlock.AllocationSize);
FStream.Seek(FSystemBlock.FAllocationSize * ChainArray[i], soBeginning);
FStream.Write(Buff[0], FSystemBlock.AllocationSize);
end;
finally
RdStrm.Free;
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.PersistSystemBlock;
{- Saves the System block to disk}
var
Strm : TMemoryStream;
Buff : Array of Byte;
begin
SetLength(Buff, FSystemBlock.AllocationSize);
Strm := TMemoryStream.Create;
try
FSystemBlock.WriteToStream(Strm);
Strm.Seek(0, soBeginning);
Strm.Read(Buff[0], Strm.Size);
FStream.Seek(0, soBeginning);
FStream.Write(Buff[0], FSystemBlock.AllocationSize);
finally
Strm.Free;
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.SetCurrentDirectory(val : AnsiString);
{- Changes the current directory to the val parameter}
begin
FRootDir.ChangeDir(Val);
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.SetVolumeLabel(Val : AnsiString);
{- Sets the volume label of the compound file}
begin
FSystemBlock.VolumeLabel := Val;
PersistSystemBlock;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.UpdateFile(FName : AnsiString; FData : TStream);
var
StartBlk : Integer;
ChainArray : TFATChainArray;
DirEntry : TAbDirectoryEntry;
CompStream : TStream;
CompHelper : TAbDeflateHelper;
Allow : Boolean;
AllowDirMod : Boolean;
begin
Allow := True;
AllowDirMod := True;
if not FRootDir.CurrentNode.Contains(FName) then
raise ECompoundFileError.Create(AbCmpndFileNotFound);
if ((FStream.Size + FData.Size +
(4 * FSystemBlock.AllocationSize)) >= MaxLongInt) then
raise ECompoundFileError.Create(AbCmpndExceedsMaxFileSize);
if Assigned(FOnBeforeFileModified) then
FOnBeforeFileModified(self, FName, Allow);
if Assigned(FOnBeforeDirModified) then
FOnBeforeDirModified(self, TMultiNode(FRootDir.CurrentNode.Parent).Key,
AllowDirMod);
if (Allow and AllowDirMod) then begin
{get dir entry & start block}
DirEntry := TAbDirectoryEntry(FRootDir.CurrentNode.GetChildByName(FName).Data);
StartBlk := DirEntry.StartBlock;
CompStream := TMemoryStream.Create;
CompHelper := TAbDeflateHelper.Create;
try
{clear existing FAT chain}
FFATTable.ClearExistingChain(StartBlk);
SetLength(ChainArray, 0);
{Deflate data}
FData.Seek(0, soBeginning);
Deflate(FData, CompStream, CompHelper);
{Commit new FAT chain}
FFATTable.GetNewChain(CompStream.Size, ChainArray);
{update start block, size, compressed size}
DirEntry.FStartBlock := ChainArray[0];
DirEntry.Size := FData.Size;
DirEntry.CompressedSize := CompStream.Size;
{persist changes}
PersistFileData(CompStream, ChainArray);
PersistRootDirBlock;
PersistFATBlock;
finally
CompStream.Free;
CompHelper.Free;
end;
end;
end;
{-----------------------------------------------------------------------------}
function TAbCompoundFile.PopulateTreeView(TreeView : TTreeView) : Integer;
{- Populates the tree view parameter with all root directory entries}
var
i : Integer;
TreeNode : TTreeNode;
begin
TreeView.Items.Clear;
if FRootDir.Root <> nil then begin
TreeNode := TreeView.Items.Add(nil, string(FRootDir.Root.Key));
TreeNode.ImageIndex := 0;
TreeNode.SelectedIndex := 0;
if FRootDir.Root.HasChildren then begin
for i := 0 to FRootDir.Root.ChildCount - 1 do
PopulateSubNodes(FRootDir.Root.Children[i], TreeView, TreeNode);
end;
end;
Result := TreeView.Items.Count;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.PopulateSubNodes(ParentNode : TMultiNode;
TreeView : TTreeView; TreeNode : TTreeNode);
{- Visits sub-nodes recursively - pre order}
var
Curr : TMultiNode;
i : Integer;
Node : TTreeNode;
begin
Node := TreeView.Items.AddChild(TreeNode, string(ParentNode.Key));
if TAbDirectoryEntry(ParentNode.Data).EntryType = etFolder then begin
Node.ImageIndex := 0;
Node.SelectedIndex := 0;
end else begin
Node.ImageIndex := 1;
Node.SelectedIndex := 1;
end;
Curr := ParentNode;
if Curr <> nil then begin
if Curr.HasChildren then begin
for i := 0 to Curr.ChildCount -1 do
PopulateSubNodes(Curr.Children[i], TreeView, Node);
end;
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.RenameFile(OrigName, NewName : AnsiString);
{- Renames the file if file is found}
var
MultNode : TMultiNode;
Allow : Boolean;
AllowDirMod : Boolean;
begin
Allow := True;
AllowDirMod := True;
{confirm valid names}
if ((OrigName = '') or (NewName = '')) then exit;
{prevent duplicate names}
if ((FRootDir.FCurrentNode.Contains(NewName)) or
(FRootDir.FCurrentNode.Key = NewName)) then exit;
if Assigned(FOnBeforeFileModified) then
FOnBeforeFileModified(self, OrigName, Allow);
if Assigned(FOnBeforeDirModified) then
FOnBeforeDirModified(self, TMultiNode(FRootDir.CurrentNode.Parent).Key,
AllowDirMod);
if (Allow and AllowDirMod) then begin
if FRootDir.FCurrentNode.Contains(OrigName) then begin
MultNode := FRootDir.FCurrentNode.GetChildByName(OrigName);
MultNode.Key := NewName;
TAbDirectoryEntry(MultNode.Data).FName := NewName;
PersistRootDirBlock;
end else if FRootDir.FCurrentNode.Key = OrigName then begin
MultNode := FRootDir.FCurrentNode;
MultNode.Key := NewName;
TAbDirectoryEntry(MultNode.Data).FName := NewName;
PersistRootDirBlock;
end else
raise ECompoundFileError.Create(AbCmpndFileNotFound);
end;
end;
{-----------------------------------------------------------------------------}
procedure TAbCompoundFile.RenameFolder(OrigName, NewName : AnsiString);
{- Renames the folder if the folder is found}
var
MultNode : TMultiNode;
Allow : Boolean;
AllowDirMod : Boolean;
begin
Allow := True;
AllowDirMod := True;
{confirm valid names}
if ((OrigName = '') or (NewName = '')) then exit;
{prevent duplicate names}
if ((FRootDir.FCurrentNode.Contains(NewName)) or
(FRootDir.FCurrentNode.Key = NewName)) then exit;
if Assigned(FOnBeforeFileModified) then
FOnBeforeFileModified(self, OrigName, Allow);
if Assigned(FOnBeforeDirModified) then
FOnBeforeDirModified(self, TMultiNode(FRootDir.CurrentNode.Parent).Key,
AllowDirMod);
if (Allow and AllowDirMod) then begin
if FRootDir.FCurrentNode.Contains(OrigName) then begin
MultNode := FRootDir.FCurrentNode.GetChildByName(OrigName);
if (TAbDirectoryEntry(MultNode.Data).EntryType <> etFolder) then
exit;
MultNode.Key := NewName;
TAbDirectoryEntry(MultNode.Data).FName := NewName;
PersistRootDirBlock;
end else if FRootDir.FCurrentNode.Key = OrigName then begin
MultNode := FRootDir.FCurrentNode;
if (TAbDirectoryEntry(MultNode.Data).EntryType <> etFolder) then
exit;
MultNode.Key := NewName;
TAbDirectoryEntry(MultNode.Data).FName := NewName;
PersistRootDirBlock;
end else
raise ECompoundFileError.Create(AbCmpndFileNotFound);
end;
end;
{-----------------------------------------------------------------------------}
end.
================================================
FILE: lib/abbrevia/source/AbConst.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* Abbrevia: AbConst.pas *}
{*********************************************************}
{* Abbrevia: Constants *}
{*********************************************************}
unit AbConst;
{$I AbDefine.inc}
interface
const
AbVersion = 5.0;
AbVersionS = '5.0';
Ab_MessageLen = 255;
Ab_CaptionLen = 80;
AB_ZIPPATHDELIM = '/';
const
AbZipVersionNeeded = 1;
AbUnknownCompressionMethod = 2;
AbNoExtractionMethod = 3;
AbInvalidPassword = 4;
AbNoInsertionMethod = 5;
AbInvalidFactor = 6;
AbDuplicateName = 7;
AbUnsupportedCompressionMethod = 8;
AbUserAbort = 9;
AbArchiveBusy = 10;
AbBadSpanStream = 11;
AbNoOverwriteSpanStream = 12;
AbNoSpannedSelfExtract = 13;
AbStreamFull = 14;
AbNoSuchDirectory = 15;
AbInflateBlockError = 16;
AbBadStreamType = 17;
AbTruncateError = 18;
AbZipBadCRC = 19;
AbZipBadStub = 20;
AbFileNotFound = 21;
AbInvalidLFH = 22;
AbNoArchive = 23;
AbErrZipInvalid = 24;
AbReadError = 25;
AbInvalidIndex = 26;
AbInvalidThreshold = 27;
AbUnhandledFileType = 28;
AbSpanningNotSupported = 29;
AbBBSReadTooManyBytes = 40;
AbBBSSeekOutsideBuffer = 41;
AbBBSInvalidOrigin = 42;
AbBBSWriteTooManyBytes = 43;
AbNoCabinetDllError = 50;
AbFCIFileOpenError = 51;
AbFCIFileReadError = 52;
AbFCIFileWriteError = 53;
AbFCIFileCloseError = 54;
AbFCIFileSeekError = 55;
AbFCIFileDeleteError = 56;
AbFCIAddFileError = 57;
AbFCICreateError = 58;
AbFCIFlushCabinetError = 59;
AbFCIFlushFolderError = 60;
AbFDICopyError = 61;
AbFDICreateError = 62;
AbInvalidCabTemplate = 63;
AbInvalidCabFile = 64;
AbSWSNotEndofStream = 80;
AbSWSSeekFailed = 81;
AbSWSWriteFailed = 82;
AbSWSInvalidOrigin = 83;
AbSWSInvalidNewOrigin = 84;
AbVMSReadTooManyBytes = 100;
AbVMSInvalidOrigin = 101;
AbVMSErrorOpenSwap = 102;
AbVMSSeekFail = 103;
AbVMSReadFail = 104;
AbVMSWriteFail = 105;
AbVMSWriteTooManyBytes = 106;
AbGZipInvalid = 200;
AbGzipBadCRC = 201;
AbGzipBadFileSize = 202;
AbTarInvalid = 220;
AbTarBadFileName = 221;
AbTarBadLinkName = 222;
AbTarBadOp = 223;
function AbStrRes(Index : Integer) : string;
implementation
uses
AbResString;
type
AbStrRec = record
ID: Integer;
Str: string;
end;
const
AbStrArray : array [0..66] of AbStrRec = (
(ID: AbZipVersionNeeded; Str: AbZipVersionNeededS),
(ID: AbUnknownCompressionMethod; Str: AbUnknownCompressionMethodS),
(ID: AbNoExtractionMethod; Str: AbNoExtractionMethodS),
(ID: AbInvalidPassword; Str: AbInvalidPasswordS),
(ID: AbNoInsertionMethod; Str: AbNoInsertionMethodS),
(ID: AbInvalidFactor; Str: AbInvalidFactorS),
(ID: AbDuplicateName; Str: AbDuplicateNameS),
(ID: AbUnsupportedCompressionMethod; Str: AbUnsupportedCompressionMethodS),
(ID: AbUserAbort; Str: AbUserAbortS),
(ID: AbArchiveBusy; Str: AbArchiveBusyS),
(ID: AbBadSpanStream; Str: AbBadSpanStreamS),
(ID: AbNoOverwriteSpanStream; Str: AbNoOverwriteSpanStreamS),
(ID: AbNoSpannedSelfExtract; Str: AbNoSpannedSelfExtractS),
(ID: AbStreamFull; Str: AbStreamFullS),
(ID: AbNoSuchDirectory; Str: AbNoSuchDirectoryS),
(ID: AbInflateBlockError; Str: AbInflateBlockErrorS),
(ID: AbBadStreamType; Str: AbBadStreamTypeS),
(ID: AbTruncateError; Str: AbTruncateErrorS),
(ID: AbZipBadCRC; Str: AbZipBadCRCS),
(ID: AbZipBadStub; Str: AbZipBadStubS),
(ID: AbFileNotFound; Str: AbFileNotFoundS),
(ID: AbInvalidLFH; Str: AbInvalidLFHS),
(ID: AbNoArchive; Str: AbNoArchiveS),
(ID: AbErrZipInvalid; Str: AbErrZipInvalidS),
(ID: AbReadError; Str: AbReadErrorS),
(ID: AbInvalidIndex; Str: AbInvalidIndexS),
(ID: AbInvalidThreshold; Str: AbInvalidThresholdS),
(ID: AbUnhandledFileType; Str: AbUnhandledFileTypeS),
(ID: AbSpanningNotSupported; Str: AbSpanningNotSupportedS),
(ID: AbBBSReadTooManyBytes; Str: AbBBSReadTooManyBytesS),
(ID: AbBBSSeekOutsideBuffer; Str: AbBBSSeekOutsideBufferS),
(ID: AbBBSInvalidOrigin; Str: AbBBSInvalidOriginS),
(ID: AbBBSWriteTooManyBytes; Str: AbBBSWriteTooManyBytesS),
(ID: AbNoCabinetDllError; Str: AbNoCabinetDllErrorS),
(ID: AbFCIFileOpenError; Str: AbFCIFileOpenErrorS),
(ID: AbFCIFileReadError; Str: AbFCIFileReadErrorS),
(ID: AbFCIFileWriteError; Str: AbFCIFileWriteErrorS),
(ID: AbFCIFileCloseError; Str: AbFCIFileCloseErrorS),
(ID: AbFCIFileSeekError; Str: AbFCIFileSeekErrorS),
(ID: AbFCIFileDeleteError; Str: AbFCIFileDeleteErrorS),
(ID: AbFCIAddFileError; Str: AbFCIAddFileErrorS),
(ID: AbFCICreateError; Str: AbFCICreateErrorS),
(ID: AbFCIFlushCabinetError; Str: AbFCIFlushCabinetErrorS),
(ID: AbFCIFlushFolderError; Str: AbFCIFlushFolderErrorS),
(ID: AbFDICopyError; Str: AbFDICopyErrorS),
(ID: AbFDICreateError; Str: AbFDICreateErrorS),
(ID: AbInvalidCabTemplate; Str: AbInvalidCabTemplateS),
(ID: AbInvalidCabFile; Str: AbInvalidCabFileS),
(ID: AbSWSNotEndofStream; Str: AbSWSNotEndofStreamS),
(ID: AbSWSSeekFailed; Str: AbSWSSeekFailedS),
(ID: AbSWSWriteFailed; Str: AbSWSWriteFailedS),
(ID: AbSWSInvalidOrigin; Str: AbSWSInvalidOriginS),
(ID: AbSWSInvalidNewOrigin; Str: AbSWSInvalidNewOriginS),
(ID: AbVMSReadTooManyBytes; Str: AbVMSReadTooManyBytesS),
(ID: AbVMSInvalidOrigin; Str: AbVMSInvalidOriginS),
(ID: AbVMSErrorOpenSwap; Str: AbVMSErrorOpenSwapS),
(ID: AbVMSSeekFail; Str: AbVMSSeekFailS),
(ID: AbVMSReadFail; Str: AbVMSReadFailS),
(ID: AbVMSWriteFail; Str: AbVMSWriteFailS),
(ID: AbVMSWriteTooManyBytes; Str: AbVMSWriteTooManyBytesS),
(ID: AbGzipInvalid; Str: AbGzipInvalidS),
(ID: AbGzipBadCRC; Str: AbGzipBadCRCS),
(ID: AbGzipBadFileSize; Str: AbGzipBadFileSizeS),
(ID: AbTarInvalid; Str: AbTarInvalidS),
(ID: AbTarBadFileName; Str: AbTarBadFileNameS),
(ID: AbTarBadLinkName; Str: AbTarBadLinkNameS),
(ID: AbTarBadOp; Str: AbTarBadOpS)
);
function AbStrRes(Index : Integer) : string;
var
i : Integer;
begin
for i := Low(AbStrArray) to High(AbStrArray) do
if AbStrArray[i].ID = Index then
Result := AbStrArray[i].Str;
end;
end.
================================================
FILE: lib/abbrevia/source/AbCrtl.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Craig Peterson
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbCrtl.pas *}
{*********************************************************}
{* ABBREVIA: C++Builder C runtime functions *}
{*********************************************************}
unit AbCrtl;
{$I AbDefine.inc}
interface
uses
Windows;
type
UInt32 = LongWord;
size_t = {$IF defined(CPUX64)}Int64{$ELSE}Integer{$IFEND}; // NativeInt is 8 bytes in Delphi 2007
const
__turboFloat: LongInt = 0;
_fltused: LongInt = 0;
procedure abs; cdecl;
external 'msvcrt.dll';
procedure _llshl; cdecl;
external 'msvcrt.dll';
procedure _llushr; cdecl;
external 'msvcrt.dll';
procedure _ftol; cdecl;
external 'msvcrt.dll' {$IFDEF BCB}name '__ftol'{$ENDIF};
{ ctype.h declarations ===================================================== }
function isdigit(ch: Integer): Integer; cdecl;
{ string.h declarations ==================================================== }
function memcpy(Dest, Src: Pointer; Count: size_t): Pointer; cdecl;
function memmove(Dest, Src: Pointer; Count: size_t): Pointer; cdecl;
function memset(Dest: Pointer; Value: Byte; Count: size_t): Pointer; cdecl;
function strlen(P: PAnsiChar): Integer; cdecl;
function strcpy(Des, Src: PAnsiChar): PAnsiChar; cdecl;
function strncpy(Des, Src: PAnsiChar; MaxLen: Integer): PAnsiChar; cdecl;
function memcmp(s1,s2: Pointer; numBytes: LongWord): integer; cdecl;
external 'msvcrt.dll';
function wcscpy(strDestination, strSource: PWideChar): PWideChar; cdecl;
external 'msvcrt.dll';
{ stdlib.h declarations ==================================================== }
function malloc(Size: Integer): Pointer; cdecl;
procedure free(Ptr: Pointer); cdecl;
function realloc(Ptr: Pointer; Size: Integer): Pointer; cdecl;
{ intrin.h declarations ==================================================== }
procedure ___cpuid(CPUInfo: PInteger; InfoType: Integer); cdecl;
external 'msvcrt.dll';
{ stdio.h declarations ===================================================== }
function sprintf(S: PChar; const Format: PChar): Integer;
cdecl; varargs; external 'msvcrt.dll' {$IFDEF BCB}name '_sprintf'{$ENDIF};
{ process.h declarations =================================================== }
function _beginthreadex(security: Pointer; stack_size: Cardinal;
start_address: Pointer; arglist: Pointer; initflag: Cardinal;
var thrdaddr: Cardinal): THandle; cdecl;
{ MSVC/Win64 declarations ================================================== }
procedure __C_specific_handler; cdecl; external 'msvcrt.dll';
implementation
{ ctype.h declarations ===================================================== }
function isdigit(ch: Integer): Integer; cdecl;
begin
if AnsiChar(ch) in ['0'..'9'] then
Result := 1
else
Result := 0;
end;
{ string.h declarations ==================================================== }
function memcpy(Dest, Src: Pointer; Count: size_t): Pointer; cdecl;
begin
System.Move(Src^, Dest^, Count);
Result := Dest;
end;
{ -------------------------------------------------------------------------- }
function memmove(Dest, Src: Pointer; Count: size_t): Pointer; cdecl;
begin
System.Move(Src^, Dest^, Count);
Result := Dest;
end;
{ -------------------------------------------------------------------------- }
function memset(Dest: Pointer; Value: Byte; Count: size_t): Pointer; cdecl;
begin
FillChar(Dest^, Count, Value);
Result := Dest;
end;
{ -------------------------------------------------------------------------- }
function strlen(P: PAnsiChar): Integer; cdecl;
{$IF RTLVersion >= 20}
asm
jmp System.@PCharLen
end;
{$ELSE}
begin
Result := 0;
while P^ <> #0 do
Inc(P);
end;
{$IFEND}
{ -------------------------------------------------------------------------- }
function strcpy(Des, Src: PAnsiChar): PAnsiChar; cdecl;
begin
Result := Des;
Move(Src^, Des^, strlen(Src) + 1);
end;
{ -------------------------------------------------------------------------- }
function strncpy(Des, Src: PAnsiChar; MaxLen: Integer): PAnsiChar; cdecl;
var
Len: Integer;
begin
Len := strlen(Src);
if Len > MaxLen then
Len := MaxLen;
Move(Src^, Des^, Len);
if Len < MaxLen then
FillChar(Des[Len], MaxLen - Len, 0);
Result := Des;
end;
{ stdlib.h declarations ==================================================== }
function malloc(Size: Integer): Pointer; cdecl;
begin
GetMem(Result, Size);
end;
{ -------------------------------------------------------------------------- }
procedure free(Ptr: Pointer); cdecl;
begin
FreeMem(Ptr)
end;
{ -------------------------------------------------------------------------- }
function realloc(Ptr: Pointer; Size: Integer): Pointer; cdecl;
begin
Result := ReallocMemory(Ptr, Size);
end;
{ process.h declarations =================================================== }
function _beginthreadex(security: Pointer; stack_size: Cardinal;
start_address: Pointer; arglist: Pointer; initflag: Cardinal;
var thrdaddr: Cardinal): THandle; cdecl;
begin
Result := CreateThread(security, stack_size, start_address, arglist,
initflag, thrdaddr);
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbDefine.inc
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDefine.inc *}
{*********************************************************}
{* ABBREVIA: Compiler options/directives include file *}
{*********************************************************}
{NOTE: ABDEFINE.INC is included in all ABBREVIA units; hence you can
specify global compiler options here. ABDEFINE.INC is included
*before* each unit's own required compiler options, so options
specified here could be overridden by hardcoded options in the
unit source file.}
{====Compiler options that can be changed====}
{$A+ Force alignment on word/dword boundaries}
{$S- No stack checking}
{---Global compiler defines for 32-bit OS's---}
{====Global fixed compiler options (do NOT change)====}
{$B- Incomplete boolean evaluation}
{$H+ Long string support}
{$P- No open string parameters}
{$Q- Arithmetic overflow checking} {!! - Needs to be turned on!}
{$R- Range checking} {!! - Needs to be turned on!}
{$T+ No type-checked pointers}
{$V- No var string checking}
{$X+ Extended syntax}
{$Z1 Enumerations are byte sized}
{====Platform defines================================================}
{ map Delphi platform defines to FreePascal's (MSWINDOWS/UNIX/LINUX/DARWIN) }
{$IFNDEF FPC}
{$IF DEFINED(LINUX) AND (CompilerVersion < 15)}
{$DEFINE KYLIX}
{$DEFINE UNIX}
{$IFEND}
{$IFDEF MACOS}
{$DEFINE DARWIN}
{$ENDIF}
{$IFDEF POSIX}
{$DEFINE UNIX}
{$ENDIF}
{$ENDIF}
{ Unix API (Kylix/Delphi/FreePascal) }
{$IFDEF UNIX}
{$IF DEFINED(FPC)}
{$DEFINE FPCUnixAPI}
{$ELSEIF DEFINED(KYLIX)}
{$DEFINE LibcAPI}
{$ELSE}
{$DEFINE PosixAPI}
{$IFEND}
{$ENDIF}
{$IFDEF FPC}
{$MODE DELPHI}
{$PACKRECORDS C}
{$ENDIF}
{Activate this define to show CLX/LCL dialogs for spanning media requests. The
default behavior will abort the operation instead. This define is only safe
when using Abbrevia from the foreground thread. If using it from a background
thread override OnRequestLastDisk, OnRequestNthDisk, and OnRequestBlankDisk and
synchronize to the foreground yourself. The Windows version always MessageBox
so it's thread-safe.}
{.$DEFINE UnixDialogs}
{====RTL defines=====================================================}
{$IFNDEF FPC}
{$IF RTLVersion >= 18} // Delphi 2006
{$DEFINE HasAdvancedRecords}
{$IFEND}
{$IF RTLVersion >= 20} // Delphi 2009
{$DEFINE HasThreadFinished}
{$DEFINE HasInline}
{$IFEND}
{$IF RTLVersion >= 21} // Delphi 2010
{$DEFINE HasThreadStart}
{$IFEND}
{$IF RTLVersion >= 23} // Delphi XE2
{$DEFINE HasPlatformsAttribute}
{$IFEND}
{$ENDIF}
{====Widgetset defines===============================================}
{ VCL version specific defines }
{$IFNDEF FPC}
{$IF RTLVersion >= 17} // Delphi 2005
{$DEFINE HasOnMouseActivate}
{$IFEND}
{$IF RTLVersion >= 18} // Delphi 2006
{$DEFINE HasOnMouseEnter}
{$IFEND}
{$IF RTLVersion >= 20} // Delphi 2009
{$DEFINE HasListViewGroups}
{$DEFINE HasListViewOnItemChecked}
{$DEFINE HasParentDoubleBuffered}
{$DEFINE HasTreeViewExpandedImageIndex}
{$IFEND}
{$IF RTLVersion >= 21} // Delphi 2010
{$DEFINE HasGridDrawingStyle}
{$DEFINE HasTouch}
{$IFEND}
{$IF RTLVersion >= 24} // Delphi XE3
{$DEFINE HasUITypes}
{$IFEND}
{$IF RTLVersion >= 25} // Delphi XE4
{$DEFINE HasAnsiStrings}
{$IFEND}
{$ENDIF}
{====General defines=================================================}
{Activate the following define to include extra code to get rid of all
hints and warnings. Parts of ABBREVIA are written in such a way
that the hint/warning algorithms of the Delphi compilers are
fooled and report things like variables being used before
initialisation and so on when in reality the problem does not exist.}
{$DEFINE DefeatWarnings}
{ Disable warnings for explicit string casts }
{$IFDEF UNICODE}
{$WARN EXPLICIT_STRING_CAST OFF}
{$WARN EXPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
{ Disable hints on Delphi XE2/Mac to prevent unexpanded inline messages }
{$IFDEF POSIX}
{$HINTS OFF}
{$ENDIF}
{====Bzip2 defines===================================================}
{Activate this define to statically link bzip2 .obj files into the application.
Curerntly only supported by Delphi/Win32.}
{.$DEFINE Bzip2Static}
{Activate this define to dynamically link to a libbz2.dll/libbbz2.so.1}
{.$DEFINE Bzip2Dynamic}
{Activate this define to load libbz2.dll/libbz2.so.1 at runtime using LoadLibrary}
{.$DEFINE Bzip2Runtime}
{Pick an appropriate linking method if none of the above are activate}
{$IF NOT DEFINED(Bzip2Static) AND NOT DEFINED(Bzip2Dynamic) AND NOT DEFINED(Bzip2Runtime)}
{$IFDEF FPC}
{$DEFINE Bzip2Runtime}
{$ELSE}
{$IFDEF MSWINDOWS}
{$DEFINE Bzip2Static}
{$ELSE}
{$DEFINE Bzip2Dynamic}
{$ENDIF}
{$ENDIF}
{$IFEND}
{====Zip defines=====================================================}
{Activate the following define when you don't want Visual parts of
the VCL library included for a program using a TAbArchive or
TAbZipArchive}
{.$DEFINE BuildingStub}
{Activate the following define to include support for extracting files
using PKzip compatible unShrink.}
{.$DEFINE UnzipShrinkSupport}
{Activate the following define to include support for extracting files
using PKZip compatible unReduce.}
{.$DEFINE UnzipReduceSupport}
{Activate the following define to include support for extracting files
using PKZip compatible unImplode.}
{.$DEFINE UnzipImplodeSupport}
{Activate the following to include support for extracting files using
all older PKZip compatible methods (Shrink, Reduce, Implode}
{$DEFINE UnzipBackwardSupport}
{Activate the following to include support for extracting files using
BZIP2 compression. Added in AppNote.txt v4.6. }
{.$DEFINE UnzipBzip2Support}
{Activate the following to include support for extracting files using
7-zip compatible Lzma compression. Added in AppNote.txt v6.3.}
{.$DEFINE UnzipLzmaSupport}
{Activate the following to include support for extracting files using
zipx PPMd I compression. Added in AppNote.txt v6.3.}
{.$DEFINE UnzipPPMdSupport}
{Activate the following to include support for extracting .wav files
using zipx WavPack compression. Requires copyright notice in your
documentation. Check "WavPack License.txt" for details.
Added in AppNote.txt v6.3. }
{.$DEFINE UnzipWavPackSupport}
{Activate the following to include support for extracting files using
all newer (zipx) compatible methods (Bzip2, Lzma, PPMd, WavPack)}
{$DEFINE UnzipZipxSupport}
{Activate the following to include logging support in the deflate/
inflate code. Since this logging support is a by-product of assertion
checking, you should only activate it if that is also on: $C+}
{$IFOPT C+} //if Assertions are on
{.$DEFINE UseLogging}
{$ENDIF}
{
According to
http://www.gzip.org/zlib/rfc1952.txt
A compliant gzip compressor should calculate and set the CRC32 and ISIZE.
However, a compliant decompressor should not check these values.
If you want to check the the values of the CRC32 and ISIZE in a GZIP file
when decompressing enable the STRICTGZIP define below. }
{.$DEFINE STRICTGZIP}
{ The following define is ONLY used for Abbrevia Unit Tests.
It has no effect on the Abbrevia Library.
If defined it uses Winzip to create and test archives for compatability.
The winzip tests require Systools stSpawn.pas
It can be downloaded at http://sf.net/projects/tpsystools }
{$IFDEF MSWINDOWS}
{.$DEFINE WINZIPTESTS}
{$ENDIF}
{-------- !! DO NOT CHANGE DEFINES BELOW THIS LINE !! --------}
{$IFDEF UnzipBackwardSupport}
{$DEFINE UnzipShrinkSupport}
{$DEFINE UnzipReduceSupport}
{$DEFINE UnzipImplodeSupport}
{$ENDIF}
{$IFDEF UnzipZipxSupport}
{$DEFINE UnzipBzip2Support}
{$DEFINE UnzipLzmaSupport}
{$DEFINE UnzipPPMdSupport}
{$DEFINE UnzipWavPackSupport}
{$ENDIF}
{ Linking .obj files isn't currently supported in Kylix or FPC }
{$IF DEFINED(FPC) OR NOT DEFINED(MSWINDOWS)}
{$UNDEF UnzipLzmaSupport}
{$UNDEF UnzipPPMdSupport}
{$UNDEF UnzipWavPackSupport}
{$IFEND}
================================================
FILE: lib/abbrevia/source/AbDfBase.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfBase.pas *}
{*********************************************************}
{* Deflate base unit *}
{*********************************************************}
unit AbDfBase;
{$I AbDefine.inc}
interface
uses
SysUtils,
Classes;
type
PAbDfLongintList = ^TAbDfLongintList;
TAbDfLongintList =
array [0..pred(MaxInt div sizeof(longint))] of longint;
const
dfc_CodeLenCodeLength = 7;
dfc_LitDistCodeLength = 15;
dfc_MaxCodeLength = 15;
const
dfc_MaxMatchLen = 258; {lengths are 3..258 for deflate}
dfc_MaxMatchLen64 = 64 * 1024; {lengths are 3..65536 for deflate64}
const
dfc_LitExtraOffset = 257;
dfc_LitExtraBits : array [0..30] of byte =
(0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3,
4, 4, 4, 4, 5, 5, 5, 5, 16, 99, 99);
{ note: the last two are required to avoid going beyond the end}
{ of the array when generating static trees}
dfc_DistExtraOffset = 0;
dfc_DistExtraBits : array [0..31] of byte =
(0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9,
10, 10, 11, 11, 12, 12, 13, 13, 14, 14);
{ note: the last two are only use for deflate64}
dfc_LengthBase : array [0..28] of word =
(3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, 35, 43,
51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 3);
{ note: the final 3 is correct for deflate64; for symbol 285,}
{ lengths are stored as (length - 3)}
{ for deflate it's very wrong, but there's special code in}
{ the (de)compression code to cater for this}
dfc_DistanceBase : array [0..31] of word =
(1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, 257,
385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, 8193, 12289,
16385, 24577, 32769, 49153);
dfc_CodeLengthIndex : array [0..18] of byte =
(16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);
const
dfc_CanUseStored = $01;
dfc_CanUseStatic = $02;
dfc_CanUseDynamic = $04;
dfc_UseLazyMatch = $08;
dfc_UseDeflate64 = $10;
dfc_UseAdler32 = $20;
dfc_CanUseHuffman = dfc_CanUseStatic or dfc_CanUseDynamic;
dfc_TestOnly = $40000000;
type
TAbProgressStep = procedure (aPercentDone : integer) of object;
{-progress metering of deflate/inflate; abort with AbortProgress}
TAbDeflateHelper = class
private
FAmpleLength : longint;
FChainLength : longint;
FLogFile : string;
FMaxLazy : longint;
FOnProgressStep : TAbProgressStep;
FOptions : longint;
FPartSize : Int64;
FSizeCompressed : Int64;
FSizeNormal : Int64;
FStreamSize : Int64;
FWindowSize : longint;
FZipOption : AnsiChar;
protected
procedure dhSetAmpleLength(aValue : longint);
procedure dhSetChainLength(aValue : longint);
procedure dhSetLogFile(const aValue : string);
procedure dhSetMaxLazy(aValue : longint);
procedure dhSetOnProgressStep(aValue : TAbProgressStep);
procedure dhSetOptions(aValue : longint);
procedure dhSetWindowSize(aValue : longint);
procedure dhSetZipOption(aValue : AnsiChar);
public
constructor Create;
procedure Assign(aHelper : TAbDeflateHelper);
property AmpleLength : longint
read FAmpleLength write dhSetAmpleLength;
property ChainLength : longint
read FChainLength write dhSetChainLength;
property LogFile : string
read FLogFile write dhSetLogFile;
property MaxLazyLength : longint
read FMaxLazy write dhSetMaxLazy;
property Options : longint
read FOptions write dhSetOptions;
property PartialSize : Int64
read FPartSize write FPartSize;
property PKZipOption : AnsiChar
read FZipOption write dhSetZipOption;
property StreamSize : Int64
read FStreamSize write FStreamSize;
property WindowSize : longint
read FWindowSize write dhSetWindowSize;
property CompressedSize : Int64
read FSizeCompressed write FSizeCompressed;
property NormalSize : Int64
read FSizeNormal write FSizeNormal;
property OnProgressStep : TAbProgressStep
read FOnProgressStep write dhSetOnProgressStep;
end;
type
TAbLineDelimiter = (ldCRLF, ldLF);
TAbLogger = class(TStream)
private
FBuffer : PAnsiChar;
FCurPos : PAnsiChar;
FLineDelim : TAbLineDelimiter;
FStream : TFileStream;
protected
function logWriteBuffer : boolean;
public
constructor Create(const aLogName : string);
destructor Destroy; override;
function Read(var Buffer; Count : longint) : longint; override;
function Seek(const Offset : Int64; Origin : TSeekOrigin) : Int64; override;
function Write(const Buffer; Count : longint) : longint; override;
procedure WriteLine(const S : string);
procedure WriteStr(const S : string);
property LineDelimiter : TAbLineDelimiter
read FLineDelim write FLineDelim;
end;
type
TAbNodeManager = class
private
FFreeList : pointer;
FNodeSize : cardinal;
FNodesPerPage : cardinal;
FPageHead : pointer;
FPageSize : cardinal;
protected
function nmAllocNewPage : pointer;
public
constructor Create(aNodeSize : cardinal);
destructor Destroy; override;
function AllocNode : pointer;
function AllocNodeClear : pointer;
procedure FreeNode(aNode : pointer);
end;
{---exception classes---}
type
EAbAbortProgress = class(Exception);
EAbPartSizedInflate = class(Exception);
EAbInflatePasswordError = class(Exception);
EAbInternalInflateError = class(Exception);
EAbInflateError = class(Exception)
public
constructor Create(const aMsg : string);
constructor CreateUnknown(const aMsg : string;
const aErrorMsg : string);
end;
EAbInternalDeflateError = class(Exception);
EAbDeflateError = class(Exception)
public
constructor Create(const aMsg : string);
constructor CreateUnknown(const aMsg : string;
const aErrorMsg : string);
end;
{---aborting a process---}
procedure AbortProgress;
{---calculation of checksums---}
procedure AbUpdateAdlerBuffer(var aAdler : longint;
var aBuffer; aCount : integer);
procedure AbUpdateCRCBuffer(var aCRC : longint;
var aBuffer; aCount : integer);
implementation
uses
AbUtils;
{===TAbDeflateHelper=================================================}
constructor TAbDeflateHelper.Create;
begin
inherited Create;
FAmpleLength := 8;
FChainLength := 32;
{FLogFile := '';}
FMaxLazy := 16;
{FOnProgressStep := nil;}
FOptions := $F;
{FStreamSize := 0;}
FWindowSize := 32 * 1024;
FZipOption := 'n';
end;
{--------}
procedure TAbDeflateHelper.Assign(aHelper : TAbDeflateHelper);
begin
FAmpleLength := aHelper.FAmpleLength;
FChainLength := aHelper.FChainLength;
FLogFile := aHelper.FLogFile;
FMaxLazy := aHelper.FMaxLazy;
FOnProgressStep := aHelper.FOnProgressStep;
FOptions := aHelper.FOptions;
FPartSize := aHelper.FPartSize;
FStreamSize := aHelper.FStreamSize;
FWindowSize := aHelper.FWindowSize;
FZipOption := aHelper.FZipOption;
end;
{--------}
procedure TAbDeflateHelper.dhSetAmpleLength(aValue : longint);
begin
if (aValue <> AmpleLength) then begin
if (aValue <> -1) and (aValue < 4) then
aValue := 4;
FAmpleLength := aValue;
FZipOption := '?';
end;
end;
{--------}
procedure TAbDeflateHelper.dhSetChainLength(aValue : longint);
begin
if (aValue <> ChainLength) then begin
if (aValue <> -1) and (aValue < 4) then
aValue := 4;
FChainLength := aValue;
FZipOption := '?';
end;
end;
{--------}
procedure TAbDeflateHelper.dhSetLogFile(const aValue : string);
begin
FLogFile := aValue;
end;
{--------}
procedure TAbDeflateHelper.dhSetMaxLazy(aValue : longint);
begin
if (aValue <> MaxLazyLength) then begin
if (aValue <> -1) and (aValue < 4) then
aValue := 4;
FMaxLazy := aValue;
FZipOption := '?';
end;
end;
{--------}
procedure TAbDeflateHelper.dhSetOnProgressStep(aValue : TAbProgressStep);
begin
FOnProgressStep := aValue;
end;
{--------}
procedure TAbDeflateHelper.dhSetOptions(aValue : longint);
begin
if (aValue <> Options) then begin
FOptions := aValue;
FZipOption := '?';
end;
end;
{--------}
procedure TAbDeflateHelper.dhSetWindowSize(aValue : longint);
var
NewValue : longint;
begin
if (aValue <> WindowSize) then begin
{calculate the window size rounded to nearest 1024 bytes}
NewValue := ((aValue + 1023) div 1024) * 1024;
{if the new window size is greater than 32KB...}
if (NewValue > 32 * 1024) then
{if the Deflate64 option is set, force to 64KB}
if ((Options and dfc_UseDeflate64) <> 0) then
NewValue := 64 * 1024
{otherwise, force to 32KB}
else
NewValue := 32 * 1024;
{set the new window size}
FWindowSize := NewValue;
end;
end;
{--------}
procedure TAbDeflateHelper.dhSetZipOption(aValue : AnsiChar);
begin
{notes:
The original Abbrevia code used the following table for
setting the equivalent values:
Good Lazy Chain UseLazy Option
4 4 4 N s ^
4 5 8 N |
4 6 32 N f faster
4 4 16 Y slower
8 16 32 Y n |
8 16 128 Y |
8 32 256 Y |
32 128 1024 Y |
32 258 4096 Y x V
The new Abbrevia 3 code follows these values to a certain extent.
}
{force to lower case}
if ('A' <= aValue) and (aValue <= 'Z') then
aValue := AnsiChar(ord(aValue) + ord('a') - ord('A'));
{if the value has changed...}
if (aValue <> PKZipOption) then begin
{switch on the new value...}
case aValue of
'0' : {no compression}
begin
FZipOption := aValue;
FOptions := (FOptions and (not $0F)) or dfc_CanUseStored;
FAmpleLength := 8; { not actually needed}
FChainLength := 32; { not actually needed}
FMaxLazy := 16; { not actually needed}
end;
'2' : {hidden option: Abbrevia 2 compatibility}
begin
FZipOption := aValue;
FOptions := FOptions or $0F;
FAmpleLength := 8;
FChainLength := 32;
FMaxLazy := 16;
end;
'f' : {fast compression}
begin
FZipOption := aValue;
FOptions := FOptions or $07; { no lazy matching}
FAmpleLength := 4;
FChainLength := 32;
FMaxLazy := 6;
end;
'n' : {normal compression}
begin
FZipOption := aValue;
FOptions := FOptions or $0F;
FAmpleLength := 16;
FChainLength := 32;
FMaxLazy := 24;
end;
's' : {super fast compression}
begin
FZipOption := aValue;
FOptions := FOptions or $07; { no lazy matching}
FAmpleLength := 4;
FChainLength := 4;
FMaxLazy := 4;
end;
'x' : {maximum compression}
begin
FZipOption := aValue;
FOptions := FOptions or $0F;
FAmpleLength := 64;{32;}
FChainLength := 4096;
FMaxLazy := 258;
end;
end;
end;
end;
{====================================================================}
{===TAbLogger========================================================}
const
LogBufferSize = 4096;
{--------}
constructor TAbLogger.Create(const aLogName : string);
begin
Assert(aLogName <> '',
'TAbLogger.Create: a filename must be provided for the logger');
{create the ancestor}
inherited Create;
{set the default line terminator}
{$IFDEF MSWINDOWS}
FLineDelim := ldCRLF;
{$ENDIF}
{$IFDEF UNIX}
FLineDelim := ldLF;
{$ENDIF}
{create and initialize the buffer}
GetMem(FBuffer, LogBufferSize);
FCurPos := FBuffer;
{create the log file}
FStream := TFileStream.Create(aLogName, fmCreate);
end;
{--------}
destructor TAbLogger.Destroy;
begin
{if there is a buffer ensure that it is flushed before freeing it}
if (FBuffer <> nil) then begin
if (FCurPos <> FBuffer) then
logWriteBuffer;
FreeMem(FBuffer, LogBufferSize);
end;
{free the stream}
FStream.Free;
{destroy the ancestor}
inherited Destroy;
end;
{--------}
function TAbLogger.logWriteBuffer : boolean;
var
BytesToWrite : longint;
BytesWritten : longint;
begin
BytesToWrite := FCurPos - FBuffer;
BytesWritten := FStream.Write(FBuffer^, BytesToWrite);
if (BytesWritten = BytesToWrite) then begin
Result := true;
FCurPos := FBuffer;
end
else begin
Result := false;
if (BytesWritten <> 0) then begin
Move(FBuffer[BytesWritten], FBuffer^, BytesToWrite - BytesWritten);
FCurPos := FBuffer + (BytesToWrite - BytesWritten);
end;
end;
end;
{--------}
function TAbLogger.Read(var Buffer; Count : longint) : longint;
begin
Assert(false, 'TAbLogger.Read: loggers are write-only, no reading allowed');
Result := 0;
end;
{--------}
function TAbLogger.Seek(const Offset : Int64; Origin : TSeekOrigin) : Int64;
begin
case Origin of
soBeginning :
begin
end;
soCurrent :
if (Offset = 0) then begin
Result := FStream.Position + (FCurPos - FBuffer);
Exit;
end;
soEnd :
if (Offset = 0) then begin
Result := FStream.Position + (FCurPos - FBuffer);
Exit;
end;
end;
Assert(false, 'TAbLogger.Seek: loggers are write-only, no seeking allowed');
Result := 0;
end;
{--------}
function TAbLogger.Write(const Buffer; Count : longint) : longint;
var
UserBuf : PAnsiChar;
BytesToGo : longint;
BytesToWrite : longint;
begin
{reference the user's buffer as a PChar}
UserBuf := @Buffer;
{start the counter for the number of bytes written}
Result := 0;
{if needed, empty the internal buffer into the underlying stream}
if (LogBufferSize = FCurPos - FBuffer) then
if not logWriteBuffer then
Exit;
{calculate the number of bytes to copy this time from the user's
buffer to the internal buffer}
BytesToGo := Count;
BytesToWrite := LogBufferSize - (FCurPos - FBuffer);
if (BytesToWrite > BytesToGo) then
BytesToWrite := BytesToGo;
{copy the bytes}
Move(UserBuf^, FCurPos^, BytesToWrite);
{adjust the counters}
inc(FCurPos, BytesToWrite);
dec(BytesToGo, BytesToWrite);
inc(Result, BytesToWrite);
{while there are still more bytes to copy, do so}
while (BytesToGo <> 0) do begin
{advance the user's buffer}
inc(UserBuf, BytesToWrite);
{empty the internal buffer into the underlying stream}
if not logWriteBuffer then
Exit;
{calculate the number of bytes to copy this time from the user's
buffer to the internal buffer}
BytesToWrite := LogBufferSize;
if (BytesToWrite > BytesToGo) then
BytesToWrite := BytesToGo;
{copy the bytes}
Move(UserBuf^, FCurPos^, BytesToWrite);
{adjust the counters}
inc(FCurPos, BytesToWrite);
dec(BytesToGo, BytesToWrite);
inc(Result, BytesToWrite);
end;
end;
{--------}
procedure TAbLogger.WriteLine(const S : string);
const
cLF : AnsiChar = ^J;
cCRLF : array [0..1] of AnsiChar = ^M^J;
begin
if (length(S) > 0) then
Write(S[1], length(S));
case FLineDelim of
ldLF : Write(cLF, sizeof(cLF));
ldCRLF : Write(cCRLF, sizeof(cCRLF));
end;
end;
{--------}
procedure TAbLogger.WriteStr(const S : string);
begin
if (length(S) > 0) then
Write(S[1], length(S));
end;
{====================================================================}
{===Calculate checksums==============================================}
procedure AbUpdateAdlerBuffer(var aAdler : longint;
var aBuffer; aCount : integer);
var
S1 : LongWord;
S2 : LongWord;
i : integer;
Buffer : PAnsiChar;
BytesToUse : integer;
begin
{Note: this algorithm will *only* work if the buffer is 4KB or less,
which is why we go to such lengths to chop up the user buffer
into usable chunks of 4KB.
However, for Delphi 3 there is no proper 32-bit longword.
Although the additions pose no problems in this situation,
the mod operations below (especially for S2) will be signed
integer divisions, producing an (invalid) signed result. In
this case, the buffer is chopped up into 2KB chunks to avoid
any signed problems.}
{split the current Adler checksum into its halves}
S1 := LongWord(aAdler) and $FFFF;
S2 := LongWord(aAdler) shr 16;
{reference the user buffer as a PChar: it makes it easier}
Buffer := @aBuffer;
{while there's still data to checksum...}
while (aCount <> 0) do begin
{calculate the number of bytes to checksum this time}
{$IFDEF HasLongWord}
BytesToUse := 4096;
{$ELSE}
BytesToUse := 2048;
{$ENDIF}
if (BytesToUse > aCount) then
BytesToUse := aCount;
{checksum the bytes}
for i := 0 to pred(BytesToUse) do begin
inc(S1, ord(Buffer^));
inc(S2, S1);
inc(Buffer);
end;
{recalibrate the Adler checksum halves}
S1 := S1 mod 65521;
S2 := S2 mod 65521;
{calculate the number of bytes still to go}
dec(aCount, BytesToUse);
end;
{join the halves to produce the complete Adler checksum}
aAdler := longint((S2 shl 16) or S1);
end;
{--------}
procedure AbUpdateCRCBuffer(var aCRC : longint;
var aBuffer; aCount : integer);
var
i : integer;
CRC : LongWord;
Buffer : PAnsiChar;
begin
{$R-}{$Q-}
{reference the user buffer as a PChar: it makes it easier}
Buffer := @aBuffer;
{get the current CRC as a local variable, it's faster}
CRC := aCRC;
{checksum the bytes in the buffer}
for i := 0 to pred(aCount) do begin
CRC := AbCrc32Table[byte(CRC) xor byte(Buffer^)] xor (CRC shr 8);
inc(Buffer);
end;
{return the new CRC}
aCRC := CRC;
{$R+}{$Q+}
end;
{====================================================================}
{===EAbInflateError==================================================}
constructor EAbInflateError.Create(const aMsg : string);
begin
inherited Create(
'Abbrevia inflate error, possibly a corrupted compressed stream. ' +
'(Internal cause: ' + aMsg + ')');
end;
{--------}
constructor EAbInflateError.CreateUnknown(const aMsg : string;
const aErrorMsg : string);
begin
inherited Create(aMsg + ': ' + aErrorMsg);
end;
{====================================================================}
{===EAbDeflateError==================================================}
constructor EAbDeflateError.Create(const aMsg : string);
begin
inherited Create(
'Abbrevia deflate error. ' +
'(Internal cause: ' + aMsg + ')');
end;
{--------}
constructor EAbDeflateError.CreateUnknown(const aMsg : string;
const aErrorMsg : string);
begin
inherited Create(aMsg + ': ' + aErrorMsg);
end;
{====================================================================}
{===Node manager=====================================================}
const
PageSize = 8 * 1024;
type
PGenericNode = ^TGenericNode;
TGenericNode = packed record
gnNext : PGenericNode;
gnData : record end;
end;
{--------}
constructor TAbNodeManager.Create(aNodeSize : cardinal);
const
Gran = sizeof(pointer);
Mask = not (Gran - 1);
begin
{create the ancestor}
inherited Create;
{save the node size rounded to nearest 4 bytes}
if (aNodeSize <= sizeof(pointer)) then
aNodeSize := sizeof(pointer)
else
aNodeSize := (aNodeSize + Gran - 1) and Mask;
FNodeSize := aNodeSize;
{calculate the page size (default 1024 bytes) and the number of
nodes per page; if the default page size is not large enough for
two or more nodes, force a single node per page}
FNodesPerPage := (PageSize - sizeof(pointer)) div aNodeSize;
if (FNodesPerPage > 1) then
FPageSize := PageSize
else begin
FNodesPerPage := 1;
FPagesize := aNodeSize + sizeof(pointer);
end;
end;
{--------}
destructor TAbNodeManager.Destroy;
var
Temp : pointer;
begin
{dispose of all the pages, if there are any}
while (FPageHead <> nil) do begin
Temp := PGenericNode(FPageHead)^.gnNext;
FreeMem(FPageHead, FPageSize);
FPageHead := Temp;
end;
{destroy the ancestor}
inherited Destroy;
end;
{--------}
function TAbNodeManager.AllocNode : pointer;
begin
Result := FFreeList;
if (Result = nil) then
Result := nmAllocNewPage
else
FFreeList := PGenericNode(Result)^.gnNext;
end;
{--------}
function TAbNodeManager.AllocNodeClear : pointer;
begin
Result := FFreeList;
if (Result = nil) then
Result := nmAllocNewPage
else
FFreeList := PGenericNode(Result)^.gnNext;
FillChar(Result^, FNodeSize, 0);
end;
{--------}
procedure TAbNodeManager.FreeNode(aNode : pointer);
begin
{add the node (if non-nil) to the top of the free list}
if (aNode <> nil) then begin
PGenericNode(aNode)^.gnNext := FFreeList;
FFreeList := aNode;
end;
end;
{--------}
function TAbNodeManager.nmAllocNewPage : pointer;
var
NewPage : PAnsiChar;
i : integer;
FreeList : pointer;
NodeSize : integer;
begin
{allocate a new page and add it to the front of the page list}
GetMem(NewPage, FPageSize);
PGenericNode(NewPage)^.gnNext := FPageHead;
FPageHead := NewPage;
{now split up the new page into nodes and push them all onto the
free list; note that the first 4 bytes of the page is a pointer to
the next page, so remember to skip over it}
inc(NewPage, sizeof(pointer));
FreeList := FFreeList;
NodeSize := FNodeSize;
for i := 0 to pred(FNodesPerPage) do begin
PGenericNode(NewPage)^.gnNext := FreeList;
FreeList := NewPage;
inc(NewPage, NodeSize);
end;
{return the top of the list}
Result := FreeList;
FFreeList := PGenericNode(Result)^.gnNext;
end;
{====================================================================}
{====================================================================}
procedure AbortProgress;
begin
raise EAbAbortProgress.Create('Abort');
end;
{====================================================================}
end.
================================================
FILE: lib/abbrevia/source/AbDfCryS.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfCryS.pas *}
{*********************************************************}
{* Deflate encryption streams *}
{*********************************************************}
unit AbDfCryS;
{$I AbDefine.inc}
interface
uses
Classes;
type
TAbZipEncryptHeader = array [0..11] of byte;
TAbZipDecryptEngine = class
private
FReady : boolean;
FState : array [0..2] of longint;
protected
procedure zdeInitState(const aPassphrase : AnsiString);
public
constructor Create;
function Decode(aCh : byte) : byte;
{-decodes a byte}
procedure DecodeBuffer(var aBuffer; aCount : integer);
{-decodes a buffer}
function VerifyHeader(const aHeader : TAbZipEncryptHeader;
const aPassphrase : AnsiString;
aCheckValue : longint) : boolean;
{-validate an encryption header}
end;
TAbDfDecryptStream = class(TStream)
private
FCheckValue : longint;
FEngine : TAbZipDecryptEngine;
FOwnsStream : Boolean;
FPassphrase : AnsiString;
FReady : boolean;
FStream : TStream;
protected
public
constructor Create(aStream : TStream;
aCheckValue : longint;
const aPassphrase : AnsiString);
destructor Destroy; override;
function IsValid : boolean;
function Read(var aBuffer; aCount : longint) : longint; override;
function Seek(aOffset : longint; aOrigin : word) : longint; override;
function Write(const aBuffer; aCount : longint) : longint; override;
property OwnsStream : Boolean
read FOwnsStream
write FOwnsStream;
end;
TAbZipEncryptEngine = class
private
FReady : boolean;
FState : array [0..2] of longint;
protected
procedure zeeInitState(const aPassphrase : AnsiString);
public
constructor Create;
function Encode(aCh : byte) : byte;
{-encodes a byte}
procedure EncodeBuffer(var aBuffer; aCount : integer);
{-encodes a buffer}
procedure CreateHeader(var aHeader : TAbZipEncryptHeader;
const aPassphrase : AnsiString;
aCheckValue : longint);
{-generate an encryption header}
end;
TAbDfEncryptStream = class(TStream)
private
FBuffer : PAnsiChar;
FBufSize : integer;
FEngine : TAbZipEncryptEngine;
FStream : TStream;
protected
public
constructor Create(aStream : TStream;
aCheckValue : longint;
const aPassphrase : AnsiString);
destructor Destroy; override;
function Read(var aBuffer; aCount : longint) : longint; override;
function Seek(aOffset : longint; aOrigin : word) : longint; override;
function Write(const aBuffer; aCount : longint) : longint; override;
end;
implementation
{Notes: the ZIP spec defines a couple of primitive routines for
performing encryption. For speed Abbrevia inlines them into
the respective methods of the encryption/decryption engines
char crc32(long,char)
return updated CRC from current CRC and next char
update_keys(char):
Key(0) <- crc32(key(0),char)
Key(1) <- Key(1) + (Key(0) & 000000ffH)
Key(1) <- Key(1) * 134775813 + 1
Key(2) <- crc32(key(2),key(1) >> 24)
end update_keys
char decrypt_byte()
local unsigned short temp
temp <- Key(2) | 2
decrypt_byte <- (temp * (temp ^ 1)) >> 8
end decrypt_byte
}
uses
AbUtils;
{---magic numbers from ZIP spec---}
const
StateInit1 = 305419896;
StateInit2 = 591751049;
StateInit3 = 878082192;
MagicNumber = 134775813;
{===internal encryption class========================================}
constructor TAbZipDecryptEngine.Create;
begin
{create the ancestor}
inherited Create;
{we're not ready for decryption yet since a header hasn't been
properly verified with VerifyHeader}
FReady := false;
end;
{--------}
function TAbZipDecryptEngine.Decode(aCh : byte) : byte;
var
Temp : longint;
begin
{check for programming error}
Assert(FReady,
'TAbZipDecryptEngine.Decode: must successfully call VerifyHeader first');
{calculate the decoded byte (uses inlined decrypt_byte)}
Temp := (FState[2] and $FFFF) or 2;
Result := aCh xor ((Temp * (Temp xor 1)) shr 8);
{mix the decoded byte into the state (uses inlined update_keys)}
FState[0] := AbUpdateCrc32(Result, FState[0]);
FState[1] := FState[1] + (FState[0] and $FF);
FState[1] := (FState[1] * MagicNumber) + 1;
FState[2] := AbUpdateCrc32(FState[1] shr 24, FState[2]);
end;
{--------}
procedure TAbZipDecryptEngine.DecodeBuffer(var aBuffer; aCount : integer);
var
i : integer;
Temp : longint;
Buffer : PAnsiChar;
WorkState : array [0..2] of longint;
begin
{check for programming error}
Assert(FReady,
'TAbZipDecryptEngine.Decode: must successfully call VerifyHeader first');
{move the state to a local variable--for better speed}
WorkState[0] := FState[0];
WorkState[1] := FState[1];
WorkState[2] := FState[2];
{reference the buffer as a PChar--easier arithmetic}
Buffer := @aBuffer;
{for each byte in the buffer...}
for i := 0 to pred(aCount) do begin
{calculate the next decoded byte (uses inlined decrypt_byte)}
Temp := (WorkState[2] and $FFFF) or 2;
Buffer^ := AnsiChar(
byte(Buffer^) xor ((Temp * (Temp xor 1)) shr 8));
{mix the decoded byte into the state (uses inlined update_keys)}
WorkState[0] := AbUpdateCrc32(byte(Buffer^), WorkState[0]);
WorkState[1] := WorkState[1] + (WorkState[0] and $FF);
WorkState[1] := (WorkState[1] * MagicNumber) + 1;
WorkState[2] := AbUpdateCrc32(WorkState[1] shr 24, WorkState[2]);
{move onto the next byte}
inc(Buffer);
end;
{save the state}
FState[0] := WorkState[0];
FState[1] := WorkState[1];
FState[2] := WorkState[2];
end;
{--------}
function TAbZipDecryptEngine.VerifyHeader(const aHeader : TAbZipEncryptHeader;
const aPassphrase : AnsiString;
aCheckValue : longint) : boolean;
type
TLongAsBytes = packed record
L1, L2, L3, L4 : byte
end;
var
i : integer;
Temp : longint;
WorkHeader : TAbZipEncryptHeader;
begin
{check for programming errors}
Assert(aPassphrase <> '',
'TAbZipDecryptEngine.VerifyHeader: need a passphrase');
{initialize the decryption state}
zdeInitState(aPassphrase);
{decrypt the bytes in the header}
for i := 0 to 11 do begin
{calculate the next decoded byte (uses inlined decrypt_byte)}
Temp := (FState[2] and $FFFF) or 2;
WorkHeader[i] := aHeader[i] xor ((Temp * (Temp xor 1)) shr 8);
{mix the decoded byte into the state (uses inlined update_keys)}
FState[0] := AbUpdateCrc32(WorkHeader[i], FState[0]);
FState[1] := FState[1] + (FState[0] and $FF);
FState[1] := (FState[1] * MagicNumber) + 1;
FState[2] := AbUpdateCrc32(FState[1] shr 24, FState[2]);
end;
{the header is valid if the twelfth byte of the decrypted header
equals the fourth byte of the check value}
Result := WorkHeader[11] = TLongAsBytes(aCheckValue).L4;
{note: zips created with PKZIP prior to version 2.0 also checked
that the tenth byte of the decrypted header equals the third
byte of the check value}
FReady := Result;
end;
{--------}
procedure TAbZipDecryptEngine.zdeInitState(const aPassphrase : AnsiString);
var
i : integer;
begin
{initialize the decryption state}
FState[0] := StateInit1;
FState[1] := StateInit2;
FState[2] := StateInit3;
{mix in the passphrase to the state (uses inlined update_keys)}
for i := 1 to length(aPassphrase) do begin
FState[0] := AbUpdateCrc32(byte(aPassphrase[i]), FState[0]);
FState[1] := FState[1] + (FState[0] and $FF);
FState[1] := (FState[1] * MagicNumber) + 1;
FState[2] := AbUpdateCrc32(FState[1] shr 24, FState[2]);
end;
end;
{====================================================================}
{====================================================================}
constructor TAbDfDecryptStream.Create(aStream : TStream;
aCheckValue : longint;
const aPassphrase : AnsiString);
begin
{create the ancestor}
inherited Create;
{save the parameters}
FStream := aStream;
FCheckValue := aCheckValue;
FPassphrase := aPassphrase;
{create the decryption engine}
FEngine := TAbZipDecryptEngine.Create;
end;
{--------}
destructor TAbDfDecryptStream.Destroy; {new !!.02}
begin
FEngine.Free;
if FOwnsStream then
FStream.Free;
inherited Destroy;
end;
{--------}
function TAbDfDecryptStream.IsValid : boolean;
var
Header : TAbZipEncryptHeader;
begin
{read the header from the stream}
FStream.ReadBuffer(Header, sizeof(Header));
{check to see if the decryption engine agrees it's valid}
Result := FEngine.VerifyHeader(Header, FPassphrase, FCheckValue);
{if it isn't valid, reposition the stream, ready for the next try}
if not Result then begin
FStream.Seek(-sizeof(Header), soCurrent);
FReady := false;
end
{otherwise, the stream is ready for decrypting data}
else
FReady := true;
end;
{--------}
function TAbDfDecryptStream.Read(var aBuffer; aCount : longint) : longint;
begin
{check for programming error}
Assert(FReady,
'TAbDfDecryptStream.Read: the stream header has not been verified');
{read the data from the underlying stream}
Result := FStream.Read(aBuffer, aCount);
{decrypt the data}
FEngine.DecodeBuffer(aBuffer, Result);
end;
{--------}
function TAbDfDecryptStream.Seek(aOffset : longint; aOrigin : word) : longint;
begin
Result := FStream.Seek(aOffset, aOrigin);
end;
{--------}
function TAbDfDecryptStream.Write(const aBuffer; aCount : longint) : longint;
begin
{check for programming error}
Assert(false,
'TAbDfDecryptStream.Write: the stream is read-only');
Result := 0;
end;
{====================================================================}
{===TAbZipEncryptEngine==============================================}
constructor TAbZipEncryptEngine.Create;
begin
{create the ancestor}
inherited Create;
{we're not ready for encryption yet since a header hasn't been
properly generated with CreateHeader}
FReady := false;
end;
{--------}
procedure TAbZipEncryptEngine.CreateHeader(
var aHeader : TAbZipEncryptHeader;
const aPassphrase : AnsiString;
aCheckValue : longint);
type
TLongAsBytes = packed record
L1, L2, L3, L4 : byte
end;
var
Ch : byte;
i : integer;
Temp : longint;
WorkHeader : TAbZipEncryptHeader;
begin
{check for programming errors}
Assert(aPassphrase <> '',
'TAbZipEncryptEngine.CreateHeader: need a passphrase');
{set the first ten bytes of the header with random values (in fact,
we use a random value for each byte and mix it in with the state)}
{initialize the decryption state}
zeeInitState(aPassphrase);
{for the first ten bytes...}
for i := 0 to 9 do begin
{get a random value}
Ch := Random( 256 );
{calculate the XOR encoding byte (uses inlined decrypt_byte)}
Temp := (FState[2] and $FFFF) or 2;
Temp := (Temp * (Temp xor 1)) shr 8;
{mix the unencoded byte into the state (uses inlined update_keys)}
FState[0] := AbUpdateCrc32(Ch, FState[0]);
FState[1] := FState[1] + (FState[0] and $FF);
FState[1] := (FState[1] * MagicNumber) + 1;
FState[2] := AbUpdateCrc32(FState[1] shr 24, FState[2]);
{set the current byte of the header}
WorkHeader[i] := Ch xor Temp;
end;
{now encrypt the first ten bytes of the header (this merely sets up
the state so that we can encrypt the last two bytes)}
{reinitialize the decryption state}
zeeInitState(aPassphrase);
{for the first ten bytes...}
for i := 0 to 9 do begin
{calculate the XOR encoding byte (uses inlined decrypt_byte)}
Temp := (FState[2] and $FFFF) or 2;
Temp := (Temp * (Temp xor 1)) shr 8;
{mix the unencoded byte into the state (uses inlined update_keys)}
FState[0] := AbUpdateCrc32(WorkHeader[i], FState[0]);
FState[1] := FState[1] + (FState[0] and $FF);
FState[1] := (FState[1] * MagicNumber) + 1;
FState[2] := AbUpdateCrc32(FState[1] shr 24, FState[2]);
{set the current byte of the header}
WorkHeader[i] := WorkHeader[i] xor Temp;
end;
{now initialize byte 10 of the header, and encrypt it}
Ch := TLongAsBytes(aCheckValue).L3;
Temp := (FState[2] and $FFFF) or 2;
Temp := (Temp * (Temp xor 1)) shr 8;
FState[0] := AbUpdateCrc32(Ch, FState[0]);
FState[1] := FState[1] + (FState[0] and $FF);
FState[1] := (FState[1] * MagicNumber) + 1;
FState[2] := AbUpdateCrc32(FState[1] shr 24, FState[2]);
WorkHeader[10] := Ch xor Temp;
{now initialize byte 11 of the header, and encrypt it}
Ch := TLongAsBytes(aCheckValue).L4;
Temp := (FState[2] and $FFFF) or 2;
Temp := (Temp * (Temp xor 1)) shr 8;
FState[0] := AbUpdateCrc32(Ch, FState[0]);
FState[1] := FState[1] + (FState[0] and $FF);
FState[1] := (FState[1] * MagicNumber) + 1;
FState[2] := AbUpdateCrc32(FState[1] shr 24, FState[2]);
WorkHeader[11] := Ch xor Temp;
{we're now ready to encrypt}
FReady := true;
{return the header}
aHeader := WorkHeader;
end;
{--------}
function TAbZipEncryptEngine.Encode(aCh : byte) : byte;
var
Temp : longint;
begin
{check for programming error}
Assert(FReady,
'TAbZipEncryptEngine.Encode: must call CreateHeader first');
{calculate the encoded byte (uses inlined decrypt_byte)}
Temp := (FState[2] and $FFFF) or 2;
Result := aCh xor (Temp * (Temp xor 1)) shr 8;
{mix the unencoded byte into the state (uses inlined update_keys)}
FState[0] := AbUpdateCrc32(aCh, FState[0]);
FState[1] := FState[1] + (FState[0] and $FF);
FState[1] := (FState[1] * MagicNumber) + 1;
FState[2] := AbUpdateCrc32(FState[1] shr 24, FState[2]);
end;
{--------}
procedure TAbZipEncryptEngine.EncodeBuffer(var aBuffer; aCount : integer);
var
Ch : byte;
i : integer;
Temp : longint;
Buffer : PAnsiChar;
WorkState : array [0..2] of longint;
begin
{check for programming error}
Assert(FReady,
'TAbZipEncryptEngine.EncodeBuffer: must call CreateHeader first');
{move the state to a local variable--for better speed}
WorkState[0] := FState[0];
WorkState[1] := FState[1];
WorkState[2] := FState[2];
{reference the buffer as a PChar--easier arithmetic}
Buffer := @aBuffer;
{for each byte in the buffer...}
for i := 0 to pred(aCount) do begin
{calculate the next encoded byte (uses inlined decrypt_byte)}
Temp := (WorkState[2] and $FFFF) or 2;
Ch := byte(Buffer^);
Buffer^ := AnsiChar(Ch xor ((Temp * (Temp xor 1)) shr 8));
{mix the decoded byte into the state (uses inlined update_keys)}
WorkState[0] := AbUpdateCrc32(Ch, WorkState[0]);
WorkState[1] := WorkState[1] + (WorkState[0] and $FF);
WorkState[1] := (WorkState[1] * MagicNumber) + 1;
WorkState[2] := AbUpdateCrc32(WorkState[1] shr 24, WorkState[2]);
{move onto the next byte}
inc(Buffer);
end;
{save the state}
FState[0] := WorkState[0];
FState[1] := WorkState[1];
FState[2] := WorkState[2];
end;
{--------}
procedure TAbZipEncryptEngine.zeeInitState(const aPassphrase : AnsiString);
var
i : integer;
begin
{initialize the decryption state}
FState[0] := StateInit1;
FState[1] := StateInit2;
FState[2] := StateInit3;
{mix in the passphrase to the state (uses inlined update_keys)}
for i := 1 to length(aPassphrase) do begin
FState[0] := AbUpdateCrc32(byte(aPassphrase[i]), FState[0]);
FState[1] := FState[1] + (FState[0] and $FF);
FState[1] := (FState[1] * MagicNumber) + 1;
FState[2] := AbUpdateCrc32(FState[1] shr 24, FState[2]);
end;
end;
{====================================================================}
{===TAbDfEncryptStream===============================================}
constructor TAbDfEncryptStream.Create(aStream : TStream;
aCheckValue : longint;
const aPassphrase : AnsiString);
var
Header : TAbZipEncryptHeader;
begin
{create the ancestor}
inherited Create;
{save the stream parameter}
FStream := aStream;
{create the encryption engine}
FEngine := TAbZipEncryptEngine.Create;
{generate the encryption header, write it to the stream}
FEngine.CreateHeader(Header, aPassphrase, aCheckValue);
aStream.WriteBuffer(Header, sizeof(Header));
end;
{--------}
destructor TAbDfEncryptStream.Destroy;
begin
{free the internal buffer if used}
if (FBuffer <> nil) then
FreeMem(FBuffer);
{free the engine}
FEngine.Free;
{destroy the ancestor}
inherited Destroy;
end;
{--------}
function TAbDfEncryptStream.Read(var aBuffer; aCount : longint) : longint;
begin
{check for programming error}
Assert(false,
'TAbDfEncryptStream.Read: the stream is write-only');
Result := 0;
end;
{--------}
function TAbDfEncryptStream.Seek(aOffset : longint; aOrigin : word) : longint;
begin
Result := FStream.Seek(aOffset, aOrigin);
end;
{--------}
function TAbDfEncryptStream.Write(const aBuffer; aCount : longint) : longint;
begin
{note: since we cannot alter a const parameter, we should copy the
data to our own buffer, encrypt it and then write it}
{check that our buffer is large enough}
if (FBufSize < aCount) then begin
if (FBuffer <> nil) then
FreeMem(FBuffer);
GetMem(FBuffer, aCount);
FBufSize := aCount;
end;
{copy the data to our buffer}
Move(aBuffer, FBuffer^, aCount);
{encrypt the data in our buffer}
FEngine.EncodeBuffer(FBuffer^, aCount);
{write the data in our buffer to the underlying stream}
Result := FStream.Write(FBuffer^, aCount);
end;
{====================================================================}
end.
================================================
FILE: lib/abbrevia/source/AbDfDec.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfDec.pas *}
{*********************************************************}
{* Deflate decoding unit *}
{*********************************************************}
unit AbDfDec;
{$I AbDefine.inc}
interface
uses
Classes,
AbDfBase;
function Inflate(aSource : TStream; aDest : TStream;
aHelper : TAbDeflateHelper) : longint;
implementation
uses
SysUtils,
AbDfStrm,
AbDfHufD,
AbDfOutW,
AbDfCryS;
{===Helper routines==================================================}
procedure ReadLitDistCodeLengths(aInStrm : TAbDfInBitStream;
aCodeLenTree : TAbDfDecodeHuffmanTree;
var aCodeLens : array of integer;
aCount : integer;
var aTotalBits : integer);
var
i : integer;
SymbolCount : integer;
LookupValue : integer;
EncodedSymbol : longint;
Symbol : integer;
SymbolCodeLen : integer;
RepeatCount : integer;
BitBuffer : TAb32bit;
BitCount : integer;
begin
{$IFDEF UseLogging}
{we need to calculate the total number of bits in the code lengths
for reporting purposes, so zero the count}
aTotalBits := 0;
{$ENDIF}
{clear the code lengths array}
FillChar(aCodeLens, sizeof(aCodeLens), 0);
{read all the Symbols required in the bit stream}
SymbolCount := 0;
while (SymbolCount < aCount) do begin
{grab the lookup set of bits}
BitCount := aCodeLenTree.LookupBitLength + 7;
{$IFOPT C+}
BitBuffer := aInStrm.PeekBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
BitBuffer := aInStrm.PeekMoreBits(BitCount)
else
BitBuffer := aInStrm.BitBuffer and AbExtractMask[BitCount];
{$ENDIF}
LookupValue :=
BitBuffer and AbExtractMask[aCodeLenTree.LookupBitLength];
{get the encoded Symbol}
{$IFOPT C+} {if Assertions are on}
EncodedSymbol := aCodeLenTree.Decode(LookupValue);
{$ELSE}
EncodedSymbol := aCodeLenTree.Decodes^[LookupValue];
{$ENDIF}
{extract the data}
Symbol := EncodedSymbol and $FFFF;
SymbolCodeLen := (EncodedSymbol shr 16) and $FF;
{$IFDEF UseLogging}
{keep count of the total number of bits read}
inc(aTotalBits, SymbolCodeLen);
{$ENDIF}
{check that the symbol is between 0 and 18}
if not ((0 <= Symbol) and (Symbol <= 18)) then
raise EAbInternalInflateError.Create(
'decoded a symbol not between 0 and 18 {ReadLitDistCodeLengths}');
{check that the codelength is in range}
if not ((0 < SymbolCodeLen) and
(SymbolCodeLen <= aCodeLenTree.LookupBitLength)) then
raise EAbInternalInflateError.Create(
'decoded a code length out of range {ReadLitDistCodeLengths}');
{for a Symbol of 0..15, just save the value}
if (Symbol <= 15) then begin
aCodeLens[SymbolCount] := Symbol;
inc(SymbolCount);
{$IFOPT C+}
aInStrm.DiscardBits(SymbolCodeLen);
{$ELSE}
if (aInStrm.BitsLeft < SymbolCodeLen) then
aInStrm.DiscardMoreBits(SymbolCodeLen)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr SymbolCodeLen;
aInStrm.BitsLeft := aInStrm.BitsLeft - SymbolCodeLen;
end;
{$ENDIF}
end
{for a Symbol of 16, get two more bits and copy the previous
code length that many times + 3}
else if (Symbol = 16) then begin
RepeatCount := 3 + ((BitBuffer shr SymbolCodeLen) and $3);
Symbol := aCodeLens[SymbolCount-1];
for i := 0 to pred(RepeatCount) do
aCodeLens[SymbolCount+i] := Symbol;
inc(SymbolCount, RepeatCount);
BitCount := SymbolCodeLen + 2;
{$IFOPT C+}
aInStrm.DiscardBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
aInStrm.DiscardMoreBits(BitCount)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr BitCount;
aInStrm.BitsLeft := aInStrm.BitsLeft - BitCount;
end;
{$ENDIF}
{$IFDEF UseLogging}
inc(aTotalBits, 2);
{$ENDIF}
end
{for a Symbol of 17, get three more bits and copy a zero code
length that many times + 3}
else if (Symbol = 17) then begin
RepeatCount := 3 + ((BitBuffer shr SymbolCodeLen) and $7);
{note: the codelengths array was aet to zeros at the start so
the following two lines are not needed
for i := 0 to pred(RepeatCount) do
aCodeLens[SymbolCount+i] := 0;}
inc(SymbolCount, RepeatCount);
BitCount := SymbolCodeLen + 3;
{$IFOPT C+}
aInStrm.DiscardBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
aInStrm.DiscardMoreBits(BitCount)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr BitCount;
aInStrm.BitsLeft := aInStrm.BitsLeft - BitCount;
end;
{$ENDIF}
{$IFDEF UseLogging}
inc(aTotalBits, 3);
{$ENDIF}
end
{for a Symbol of 18, get seven more bits and copy a zero code
length that many times + 11}
else if (Symbol = 18) then begin
RepeatCount := 11 + ((BitBuffer shr SymbolCodeLen) and $7F);
{note: the codelengths array was aet to zeros at the start so
the following two lines are not needed
for i := 0 to pred(RepeatCount) do
aCodeLens[SymbolCount+i] := 0;}
inc(SymbolCount, RepeatCount);
BitCount := SymbolCodeLen + 7;
{$IFOPT C+}
aInStrm.DiscardBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
aInStrm.DiscardMoreBits(BitCount)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr BitCount;
aInStrm.BitsLeft := aInStrm.BitsLeft - BitCount;
end;
{$ENDIF}
{$IFDEF UseLogging}
inc(aTotalBits, 7);
{$ENDIF}
end;
end;
end;
{--------}
procedure DecodeData(aInStrm : TAbDfInBitStream;
aOutWindow : TAbDfOutputWindow;
aLiteralTree : TAbDfDecodeHuffmanTree;
aDistanceTree : TAbDfDecodeHuffmanTree;
aDeflate64 : boolean);
var
LookupValue : integer;
EncodedSymbol : longint;
Symbol : integer;
SymbolCodeLen : integer;
ExtraBitCount : integer;
Length : integer;
Distance : integer;
BitBuffer : TAb32bit;
BitCount : integer;
begin
{extract the first symbol (it's got to be a literal/length symbol)}
{..grab the lookup set of bits}
if aDeflate64 then
BitCount := aLiteralTree.LookupBitLength + 16
else
BitCount := aLiteralTree.LookupBitLength + 5;
{$IFOPT C+}
BitBuffer := aInStrm.PeekBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
BitBuffer := aInStrm.PeekMoreBits(BitCount)
else
BitBuffer := aInStrm.BitBuffer and AbExtractMask[BitCount];
{$ENDIF}
LookupValue :=
BitBuffer and AbExtractMask[aLiteralTree.LookupBitLength];
{..get the encoded symbol}
{$IFOPT C+} {if Assertions are on}
EncodedSymbol := aLiteralTree.Decode(LookupValue);
{$ELSE}
EncodedSymbol := aLiteralTree.Decodes^[LookupValue];
{$ENDIF}
{..extract the data}
Symbol := EncodedSymbol and $FFFF;
SymbolCodeLen := (EncodedSymbol shr 16) and $FF;
// ExtraBitCount := EncodedSymbol shr 24;
{repeat until we get the end-of-block symbol}
while ((Symbol <> 256) {and (ExtraBitCount <> 15)}) do begin
{for a literal, just output it to the sliding window}
if (Symbol < 256) then begin
aOutWindow.AddLiteral(AnsiChar(Symbol));
{$IFOPT C+}
aInStrm.DiscardBits(SymbolCodeLen);
{$ELSE}
if (aInStrm.BitsLeft < SymbolCodeLen) then
aInStrm.DiscardMoreBits(SymbolCodeLen)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr SymbolCodeLen;
aInStrm.BitsLeft := aInStrm.BitsLeft - SymbolCodeLen;
end;
{$ENDIF}
end
{for a length value, we need to get any extra bits, and then the
distance (plus any extra bits for that), and then add the
duplicated characters to the sliding window}
else begin
{check that the length symbol is less than or equal to 285}
if (Symbol > 285) then
raise EAbInternalInflateError.Create(
'decoded an invalid length symbol: greater than 285 [DecodeData]');
{calculate the length (if need be, by calculating the number of
extra bits that encode the length)}
if (not aDeflate64) and (Symbol = 285) then begin
Length := 258;
{$IFOPT C+}
aInStrm.DiscardBits(SymbolCodeLen);
{$ELSE}
if (aInStrm.BitsLeft < SymbolCodeLen) then
aInStrm.DiscardMoreBits(SymbolCodeLen)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr SymbolCodeLen;
aInStrm.BitsLeft := aInStrm.BitsLeft - SymbolCodeLen;
end;
{$ENDIF}
end
else begin
ExtraBitCount := EncodedSymbol shr 24;
if (ExtraBitCount = 0) then begin
Length := dfc_LengthBase[Symbol - 257];
{$IFOPT C+}
aInStrm.DiscardBits(SymbolCodeLen);
{$ELSE}
if (aInStrm.BitsLeft < SymbolCodeLen) then
aInStrm.DiscardMoreBits(SymbolCodeLen)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr SymbolCodeLen;
aInStrm.BitsLeft := aInStrm.BitsLeft - SymbolCodeLen;
end;
{$ENDIF}
end
else begin
Length := dfc_LengthBase[Symbol - 257] +
((BitBuffer shr SymbolCodeLen) and
AbExtractMask[ExtraBitCount]);
BitCount := SymbolCodeLen + ExtraBitCount;
{$IFOPT C+}
aInStrm.DiscardBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
aInStrm.DiscardMoreBits(BitCount)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr BitCount;
aInStrm.BitsLeft := aInStrm.BitsLeft - BitCount;
end;
{$ENDIF}
end;
end;
{extract the distance}
{..grab the lookup set of bits}
BitCount := aDistanceTree.LookupBitLength + 14;
{$IFOPT C+}
BitBuffer := aInStrm.PeekBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
BitBuffer := aInStrm.PeekMoreBits(BitCount)
else
BitBuffer := aInStrm.BitBuffer and AbExtractMask[BitCount];
{$ENDIF}
LookupValue :=
BitBuffer and AbExtractMask[aDistanceTree.LookupBitLength];
{..get the encoded symbol}
{$IFOPT C+} {if Assertions are on}
EncodedSymbol := aDistanceTree.Decode(LookupValue);
{$ELSE}
EncodedSymbol := aDistanceTree.Decodes^[LookupValue];
{$ENDIF}
{..extract the data}
Symbol := EncodedSymbol and $FFFF;
SymbolCodeLen := (EncodedSymbol shr 16) and $FF;
{check that the distance symbol is less than or equal to 29}
if (not aDeflate64) and (Symbol > 29) then
raise EAbInternalInflateError.Create(
'decoded an invalid distance symbol: greater than 29 [DecodeData]');
{..calculate the extra bits for the distance}
ExtraBitCount := EncodedSymbol shr 24;
{..calculate the distance}
if (ExtraBitCount = 0) then begin
Distance := dfc_DistanceBase[Symbol];
{$IFOPT C+}
aInStrm.DiscardBits(SymbolCodeLen);
{$ELSE}
if (aInStrm.BitsLeft < SymbolCodeLen) then
aInStrm.DiscardMoreBits(SymbolCodeLen)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr SymbolCodeLen;
aInStrm.BitsLeft := aInStrm.BitsLeft - SymbolCodeLen;
end;
{$ENDIF}
end
else begin
Distance := dfc_DistanceBase[Symbol] +
((BitBuffer shr SymbolCodeLen) and
AbExtractMask[ExtraBitCount]);
BitCount := SymbolCodeLen + ExtraBitCount;
{$IFOPT C+}
aInStrm.DiscardBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
aInStrm.DiscardMoreBits(BitCount)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr BitCount;
aInStrm.BitsLeft := aInStrm.BitsLeft - BitCount;
end;
{$ENDIF}
end;
{duplicate the characters in the sliding window}
aOutWindow.AddLenDist(Length, Distance);
end;
{extract the next symbol}
{..grab the lookup set of bits}
if aDeflate64 then
BitCount := aLiteralTree.LookupBitLength + 16
else
BitCount := aLiteralTree.LookupBitLength + 5;
{$IFOPT C+}
BitBuffer := aInStrm.PeekBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
BitBuffer := aInStrm.PeekMoreBits(BitCount)
else
BitBuffer := aInStrm.BitBuffer and AbExtractMask[BitCount];
{$ENDIF}
LookupValue :=
BitBuffer and AbExtractMask[aLiteralTree.LookupBitLength];
{..get the encoded symbol}
{$IFOPT C+} {if Assertions are on}
EncodedSymbol := aLiteralTree.Decode(LookupValue);
{$ELSE}
EncodedSymbol := aLiteralTree.Decodes^[LookupValue];
{$ENDIF}
{..extract the data}
Symbol := EncodedSymbol and $FFFF;
SymbolCodeLen := (EncodedSymbol shr 16) and $FF;
end;
{discard the bits for the end-of-block marker}
{$IFOPT C+}
aInStrm.DiscardBits(SymbolCodeLen);
{$ELSE}
if (aInStrm.BitsLeft < SymbolCodeLen) then
aInStrm.DiscardMoreBits(SymbolCodeLen)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr SymbolCodeLen;
aInStrm.BitsLeft := aInStrm.BitsLeft - SymbolCodeLen;
end;
{$ENDIF}
end;
{--------}
procedure InflateStoredBlock(aInStrm : TAbDfInBitStream;
aOutWindow : TAbDfOutputWindow;
aLog : TAbLogger);
const
BufferSize = 16 * 1024;
var
LenNotLen : packed record
Len : word;
NotLen : word;
end;
BytesToGo : integer;
BytesToWrite : integer;
Buffer : pointer;
begin
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then
aLog.WriteLine('....a stored block');
{$ENDIF}
{align the input bit stream to the nearest byte boundary}
aInStrm.AlignToByte;
{read the length of the stored data and the notted length}
aInStrm.ReadBuffer(LenNotLen, sizeof(LenNotLen));
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then
aLog.WriteLine(Format('..block length: %d (%-4x, NOT %-4x)',
[LenNotLen.Len, LenNotLen.Len, LenNotLen.NotLen]));
{$ENDIF}
{check that NOT of the length equals the notted length}
if ((not LenNotLen.Len) <> LenNotLen.NotLen) then
raise EAbInternalInflateError.Create(
'invalid stored block (length and NOT length do not match) [InflateStoredBlock]');
{calculate the number of bytes to copy from the stored block}
BytesToGo := LenNotLen.Len;
{allocate a large buffer}
GetMem(Buffer, BufferSize);
{copy all the data in the stored block to the output window}
try
{while there are still some bytes to copy...}
while (BytesToGo <> 0) do begin
{calculate the number of bytes this time}
if (BytesToGo > BufferSize) then
BytesToWrite := BufferSize
else
BytesToWrite := BytesToGo;
{read that many bytes and write them to the output window}
aInStrm.ReadBuffer(Buffer^, BytesToWrite);
aOutWindow.AddBuffer(Buffer^, BytesToWrite);
{calculate the number of bytes still to copy}
dec(BytesToGo, BytesToWrite);
end;
finally
FreeMem(Buffer);
end;
end;
{--------}
procedure InflateStaticBlock(aInStrm : TAbDfInBitStream;
aOutWindow : TAbDfOutputWindow;
aLog : TAbLogger;
aDeflate64 : boolean);
begin
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then
aLog.WriteLine('....a static huffman tree block');
{$ENDIF}
{decode the data with the static trees}
DecodeData(aInStrm, aOutWindow,
AbStaticLiteralTree, AbStaticDistanceTree, aDeflate64);
end;
{--------}
procedure InflateDynamicBlock(aInStrm : TAbDfInBitStream;
aOutWindow : TAbDfOutputWindow;
aLog : TAbLogger;
aDeflate64 : boolean);
var
i : integer;
LitCount : integer;
DistCount : integer;
CodeLenCount : integer;
CodeLens : array [0..285+32] of integer;
CodeLenTree : TAbDfDecodeHuffmanTree;
LiteralTree : TAbDfDecodeHuffmanTree;
DistanceTree : TAbDfDecodeHuffmanTree;
TotalBits : integer;
begin
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then
aLog.WriteLine('....a dynamic huffman tree block');
{$ENDIF}
{prepare for the try..finally}
CodeLenTree := nil;
LiteralTree := nil;
DistanceTree := nil;
try
{decode the number of literal, distance and codelength codes}
LitCount := aInStrm.ReadBits(5) + 257;
DistCount := aInStrm.ReadBits(5) + 1;
CodeLenCount := aInStrm.ReadBits(4) + 4;
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then begin
aLog.WriteLine(Format('Count of literals: %d', [LitCount]));
aLog.WriteLine(Format('Count of distances: %d', [DistCount]));
aLog.WriteLine(Format('Count of code lengths: %d', [CodeLenCount]));
end;
{$ENDIF}
{verify that the counts are valid}
if (LitCount > 286) then
raise EAbInternalInflateError.Create(
'count of literal codes in dynamic block is greater than 286 [InflateDynamicBlock]');
if (not aDeflate64) and (DistCount > 30) then
raise EAbInternalInflateError.Create(
'count of distance codes in dynamic block is greater than 30 [InflateDynamicBlock]');
{read the codelengths}
FillChar(CodeLens, 19 * sizeof(integer), 0);
for i := 0 to pred(CodeLenCount) do
CodeLens[dfc_CodeLengthIndex[i]] := aInStrm.ReadBits(3);
{$IFDEF UseLogging}
{log them}
if (aLog <> nil) then begin
aLog.WriteLine('CodeLength Huffman tree: code lengths');
for i := 0 to 18 do
aLog.WriteStr(Format('%-3d', [CodeLens[i]]));
aLog.WriteLine('');
aLog.WriteLine(Format('..total bits: %d', [CodeLenCount * 3]));
end;
{$ENDIF}
{create the codelength huffman tree}
CodeLenTree := TAbDfDecodeHuffmanTree.Create(19, 7, huDecoding);
CodeLenTree.Build(CodeLens, 0, 19, [0], $FFFF);
{$IFDEF UseLogging}
{log the tree}
if (aLog <> nil) then begin
aLog.WriteLine('Code lengths tree');
CodeLenTree.DebugPrint(aLog);
end;
{$ENDIF}
{read the codelengths for both the literal/length and distance
huffman trees}
ReadLitDistCodeLengths(aInStrm, CodeLenTree, CodeLens,
LitCount + DistCount, TotalBits);
{$IFDEF UseLoggingx}
{log them}
if (aLog <> nil) then begin
aLog.WriteLine('Literal/length & Dist Huffman trees: code lengths');
for i := 0 to pred(LitCount + DistCount) do
aLog.WriteLine(Format('%3d: %3d', [i, CodeLens[i]]));
aLog.WriteLine('');
aLog.WriteLine(Format('..total bits: %d', [TotalBits]));
end;
{$ENDIF}
{create the literal huffman tree}
LiteralTree := TAbDfDecodeHuffmanTree.Create(286, 15, huDecoding);
LiteralTree.Build(CodeLens, 0, LitCount,
dfc_LitExtraBits, dfc_LitExtraOffset);
{$IFDEF UseLogging}
{log the tree}
if (aLog <> nil) then begin
aLog.WriteLine('Literal/length tree');
LiteralTree.DebugPrint(aLog);
end;
{$ENDIF}
{create the distance huffman tree}
if aDeflate64 then
DistanceTree := TAbDfDecodeHuffmanTree.Create(32, 15, huDecoding)
else
DistanceTree := TAbDfDecodeHuffmanTree.Create(30, 15, huDecoding);
DistanceTree.Build(CodeLens, LitCount, DistCount,
dfc_DistExtraBits, dfc_DistExtraOffset);
{$IFDEF UseLogging}
{log the tree}
if (aLog <> nil) then begin
aLog.WriteLine('Distance tree');
DistanceTree.DebugPrint(aLog);
end;
{$ENDIF}
{using the literal and distance trees, decode the bit stream}
DecodeData(aInStrm, aOutWindow,
LiteralTree, DistanceTree, aDeflate64);
finally
CodeLenTree.Free;
LiteralTree.Free;
DistanceTree.Free;
end;
end;
{====================================================================}
{===Interfaced routine===============================================}
function Inflate(aSource : TStream; aDest : TStream;
aHelper : TAbDeflateHelper) : longint;
var
Helper : TAbDeflateHelper;
InBitStrm : TAbDfInBitStream;
OutWindow : TAbDfOutputWindow;
Log : TAbLogger;
UseDeflate64 : boolean;
UseCRC32 : boolean;
IsFinalBlock : boolean;
BlockType : integer;
TestOnly : boolean;
SourceStartPos : longint;
DestStartPos : longint;
{$IFDEF UseLogging}
StartPosn : longint;
{$ENDIF}
begin
{$IFDEF DefeatWarnings}
Result := 0;
SourceStartPos := 0;
DestStartPos := 0;
TestOnly := False;
{$ENDIF}
{$IFDEF UseLogging}
StartPosn := 0;
{$ENDIF}
{pre-conditions: streams must be allocated of course}
Assert(aSource <> nil, 'Deflate: aSource stream cannot be nil');
Assert(aDest <> nil, 'Deflate: aDest stream cannot be nil');
{prepare for the try..finally}
Helper := nil;
InBitStrm := nil;
OutWindow := nil;
Log := nil;
try {finally}
try {except}
{create our helper; assign the passed one to it}
Helper := TAbDeflateHelper.Create;
if (aHelper <> nil) then
Helper.Assign(aHelper);
{get the initial start positions of both streams}
SourceStartPos := aSource.Position;
DestStartPos := aDest.Position;
{if the helper's stream size is -1, and it has a progress event
handler, calculate the stream size from the stream itself}
if Assigned(Helper.OnProgressStep) then begin
if (Helper.StreamSize = -1) then
Helper.StreamSize := aSource.Size;
end
{otherwise we certainly can't do any progress reporting}
else begin
Helper.OnProgressStep := nil;
Helper.StreamSize := 0;
end;
{create the logger, if requested}
if (Helper.LogFile <> '') then begin
Log := TAbLogger.Create(Helper.LogFile);
Log.WriteLine('INFLATING STREAM...');
{$IFNDEF UseLogging}
Log.WriteLine('Need to recompile the app with UseLogging turned on');
{$ENDIF}
end;
InBitStrm := TAbDfInBitStream.Create(aSource,
Helper.OnProgressStep,
Helper.StreamSize);
{create the output sliding window}
UseDeflate64 := (Helper.Options and dfc_UseDeflate64) <> 0;
UseCRC32 := (Helper.Options and dfc_UseAdler32) = 0;
TestOnly := (Helper.Options and dfc_TestOnly) <> 0;
OutWindow := TAbDfOutputWindow.Create(
aDest, UseDeflate64, UseCRC32, Helper.PartialSize,
TestOnly, Log);
{start decoding the deflated stream}
repeat
{read the final block flag and the block type}
IsFinalBlock := InBitStrm.ReadBit;
BlockType := InBitStrm.ReadBits(2);
{$IFDEF UseLogging}
{log it}
if (Log <> nil) then begin
Log.WriteLine('');
Log.WriteLine('Starting new block');
Log.WriteLine(Format('..final block? %d', [ord(IsFinalBlock)]));
Log.WriteLine(Format('..block type? %d', [BlockType]));
StartPosn := OutWindow.Position;
end;
{$ENDIF}
case BlockType of
0 : InflateStoredBlock(InBitStrm, OutWindow, Log);
1 : InflateStaticBlock(InBitStrm, OutWindow, Log, UseDeflate64);
2 : InflateDynamicBlock(InBitStrm, OutWindow, Log, UseDeflate64);
else
raise EAbInternalInflateError.Create(
'starting new block, but invalid block type [Inflate]');
end;
{$IFDEF UseLogging}
{log it}
if (Log <> nil) then
Log.WriteLine(Format('---block end--- (decoded size %d bytes)',
[OutWindow.Position - StartPosn]));
{$ENDIF}
until IsFinalBlock;
{get the uncompressed stream's checksum}
Result := OutWindow.Checksum;
if TestOnly and (aHelper <> nil) then
aHelper.NormalSize := OutWindow.Position;
{$IFDEF UseLogging}
{log it}
if (Log <> nil) then
Log.WriteLine(Format('End of compressed stream, checksum %-8x',
[Result]));
{$ENDIF}
except
on E : EAbPartSizedInflate do begin
{nothing, just swallow the exception}
Result := 0;
end;
on E : EAbAbortProgress do begin
{nothing, just swallow the exception}
Result := 0;
end;
on E : EAbInternalInflateError do begin
if (Log <> nil) then
Log.WriteLine(Format('Internal exception raised: %s',
[E.Message]));
raise EAbInflateError.Create(E.Message);
end;
end;
finally
Helper.Free;
OutWindow.Free;
InBitStrm.Free;
Log.Free;
end;
{if there's a helper return the compressed and uncompressed sizes}
if (aHelper <> nil) then begin
if not TestOnly then
aHelper.NormalSize := aDest.Position - DestStartPos;
aHelper.CompressedSize := aSource.Position - SourceStartPos;
end;
{WARNING NOTE: the compiler will warn that the return value of this
function might be undefined. However, it is wrong: it
has been fooled by the code. If you don't want to see
this warning again, enable the DefeatWarnings
compiler define in AbDefine.inc.}
end;
{====================================================================}
end.
================================================
FILE: lib/abbrevia/source/AbDfEnc.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfEnc.pas *}
{*********************************************************}
{* Deflate encoding unit *}
{*********************************************************}
unit AbDfEnc;
{$I AbDefine.inc}
interface
uses
Classes,
AbDfBase;
function Deflate(aSource : TStream; aDest : TStream;
aHelper : TAbDeflateHelper) : longint;
implementation
uses
AbDfInW,
AbDfHufD,
AbDfStrm,
AbDfCryS,
AbDfPkMg;
{====================================================================}
function CalcDynamicBitCount(aUseDeflate64: boolean;
aLitBuckets : PAbDfLitBuckets;
aDistBuckets : PAbDfDistBuckets;
aCodeBuckets : PAbDfCodeLenBuckets;
const aCodeLens : array of integer;
const aCLCodeLens : array of integer;
aLitCount : integer;
aDistCount : integer;
aCodeCount : integer) : longint;
var
Symbol : integer;
LastSymbol : integer;
Inx : integer;
begin
{note: this routine calculates the number of bits required to
compress a given block}
{a dynamic block starts off with 5 bits of literal symbol count, 5
bits of distance symbol count, 4 bits of codelength symbol count,
and then 3 bits for every codelength symbol used}
Result := 5 + 5 + 4 +
(aCodeCount * 3);
{add in the bits needed to compress the literal and distance trees}
inc(Result, aCodeBuckets^[16] * (aCLCodeLens[16] + 2));
inc(Result, aCodeBuckets^[17] * (aCLCodeLens[16] + 3));
inc(Result, aCodeBuckets^[18] * (aCLCodeLens[16] + 7));
for Symbol := 3 to pred(aCodeCount) do begin
Inx := dfc_CodeLengthIndex[Symbol];
Assert(Inx <=15,
'CalcDynamicBitCount: the index array of codelengths is corrupted');
inc(Result, aCodeBuckets^[Inx] * aCLCodeLens[Inx])
end;
{make the literal symbol 285 a special case}
LastSymbol := pred(aLitCount);
if (LastSymbol = 285) then
LastSymbol := 284;
{add in all the bits needed to compress the literals (except 285)}
for Symbol := 0 to LastSymbol do
if (Symbol < dfc_LitExtraOffset) then
inc(Result, aLitBuckets^[Symbol] * aCodeLens[Symbol])
else
inc(Result, aLitBuckets^[Symbol] *
(aCodeLens[Symbol] +
dfc_LitExtraBits[Symbol - dfc_LitExtraOffset]));
{add in all the bits needed to compress the literal symbol 285}
if (pred(aLitCount) = 285) then
if (not aUseDeflate64) then
inc(Result, aLitBuckets^[285] * aCodeLens[285])
else
inc(Result, aLitBuckets^[285] * (aCodeLens[285] + 16));
{add in all the bits needed to compress the distances}
for Symbol := 0 to pred(aDistCount) do
inc(Result, aDistBuckets^[Symbol] *
(aCodeLens[aLitCount + Symbol] +
dfc_DistExtraBits[Symbol]));
end;
{====================================================================}
{====================================================================}
procedure OutputEndOfBlock(aBitStrm : TAbDfOutBitStream;
aLitTree : TAbDfDecodeHuffmanTree);
var
Code : longint;
begin
{note: this routine encodes the end-of-block character (symbol 256)
and then writes out the code to the bit stream}
{encode the end-of-block character as a symbol}
{$IFOPT C+} {if Assertions are on }
Code := aLitTree.Encode(256);
{$ELSE}
Code := aLitTree.Encodes^[256];
{$ENDIF}
{write the code out to the bit stream}
aBitStrm.WriteBits(Code and $FFFF, (Code shr 16) and $FF);
end;
{--------}
procedure EncodeLZStreamStored(aFinalBlock : boolean;
aStream : TAbDfLZStream;
aBitStrm : TAbDfOutBitStream;
aDataSize : integer;
aLog : TAbLogger);
var
BlockHeader : packed record
bhSize : word;
bhNotSize : word;
end;
Buffer : pointer;
Code : integer;
BlockSize : integer;
begin
{note: this routine writes out an incompressible block to the bit
stream (the store algorithm)}
{allocate the maximum buffer we can write at once}
GetMem(Buffer, 64 * 1024);
try
{while there's more incompressible data to store...}
while (aDataSize <> 0) do begin
{calculate the block size to write this time}
if (aDataSize > $FFFF) then begin
BlockSize := $FFFF;
dec(aDataSize, $FFFF);
end
else begin
BlockSize := aDataSize;
aDataSize := 0;
end;
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then begin
aLog.WriteLine('..Writing new block...');
aLog.WriteLine(Format('..final block? %d', [ord(aFinalBlock)]));
aLog.WriteLine('..block type? 0');
aLog.WriteLine(Format('..block size: %d', [BlockSize]));
end;
{$ENDIF}
{output the block information to the bit stream}
if aFinalBlock then
Code := 1 + (0 shl 1)
else
Code := 0 + (0 shl 1);
aBitStrm.WriteBits(Code, 3);
{align the bit stream to the nearest byte}
aBitStrm.AlignToByte;
{write the stored block header}
BlockHeader.bhSize := BlockSize;
BlockHeader.bhNotSize := not BlockHeader.bhSize;
aBitStrm.WriteBuffer(BlockHeader, sizeof(BlockHeader));
{get and write this block}
aStream.ReadStoredBuffer(Buffer^, BlockSize);
aBitStrm.WriteBuffer(Buffer^, BlockSize);
end;
finally
FreeMem(Buffer);
end;
{clear the stream, ready for the next block}
aStream.Clear;
end;
{--------}
procedure EncodeLZStreamStatic(aFinalBlock : boolean;
aUseDeflate64 : boolean;
aStream : TAbDfLZStream;
aBitStrm : TAbDfOutBitStream;
aLog : TAbLogger);
var
Code : integer;
begin
{note: this routine writes out the stream of LZ77 tokens for the
current block to the bit stream, using the static huffman
trees to encode the token symbols}
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then begin
aLog.WriteLine('..Writing new block...');
aLog.WriteLine(Format('..final block? %d', [ord(aFinalBlock)]));
aLog.WriteLine('..block type? 1');
end;
{$ENDIF}
{output the block information to the bit stream}
if aFinalBlock then
Code := 1 + (1 shl 1)
else
Code := 0 + (1 shl 1);
aBitStrm.WriteBits(Code, 3);
{encode the LZ77 stream}
aStream.Encode(aBitStrm,
AbStaticLiteralTree, AbStaticDistanceTree,
aUseDeflate64);
{output the end-of-block marker to the bit stream}
OutputEndOfBlock(aBitStrm, AbStaticLiteralTree);
{$IFDEF UseLogging}
if (aLog <> nil) then
aLog.WriteLine('Char: end-of-block marker (#256)');
{$ENDIF}
end;
{--------}
procedure EncodeLZStreamDynamic(aFinalBlock : boolean;
aUseDeflate64 : boolean;
aUseBest : boolean;
aStream : TAbDfLZStream;
aBitStrm : TAbDfOutBitStream;
aLog : TAbLogger);
var
i : integer;
LitTree : TAbDfDecodeHuffmanTree;
DistTree : TAbDfDecodeHuffmanTree;
CodeLenTree : TAbDfDecodeHuffmanTree;
CodeLenStream : TAbDfCodeLenStream;
CodeLens : array [0..285+32] of integer;
CLCodeLens : array [0..18] of integer;
LitCodeCount : integer;
DistCodeCount : integer;
LenCodeCount : integer;
BitCount : integer;
Code : integer;
StaticSize : integer;
StoredSize : integer;
begin
{note: this routine writes out the stream of LZ77 tokens for the
current block to the bit stream, using the dynamic huffman
trees to encode the token symbols; if the routine determines
that the data can better be compressed using the static
huffman trees or should be stored as is, it'll switch
algorithms}
{prepare for the try..finally}
LitTree := nil;
DistTree := nil;
CodeLenTree := nil;
CodeLenStream := nil;
try
{calculate the code lengths for the literal symbols}
GenerateCodeLengths(15, aStream.LitBuckets^, CodeLens, 0, aLog);
{calculate the number of the used codelengths for the literals}
LitCodeCount := 286;
repeat
dec(LitCodeCount);
until (CodeLens[LitCodeCount] <> 0);
inc(LitCodeCount);
{calculate the code lengths for the distance symbols}
GenerateCodeLengths(15, aStream.DistBuckets^, CodeLens,
LitCodeCount, aLog);
{calculate the number of the used codelengths for the distances}
DistCodeCount := 32;
repeat
dec(DistCodeCount);
until (CodeLens[DistCodeCount + LitCodeCount] <> 0);
inc(DistCodeCount);
{calculate the code lengths array as a stream of items}
CodeLenStream := TAbDfCodeLenStream.Create(aLog);
CodeLenStream.Build(CodeLens, LitCodeCount + DistCodeCount);
{calculate the codelengths for the code lengths}
GenerateCodeLengths(7, CodeLenStream.Buckets^, CLCodeLens, 0, nil);
{calculate the number of the used codelengths for the code lengths}
LenCodeCount := 19;
repeat
dec(LenCodeCount);
until (CLCodeLens[dfc_CodeLengthIndex[LenCodeCount]] <> 0);
inc(LenCodeCount);
{..there's a minimum of four, though}
if (LenCodeCount < 4) then
LenCodeCount := 4;
{if we have to work out and use the best method...}
if aUseBest then begin
{calculate the number of bits required for the compressed data
using dynamic huffman trees}
BitCount := CalcDynamicBitCount(aUseDeflate64,
aStream.LitBuckets,
aStream.DistBuckets,
CodeLenStream.Buckets,
CodeLens,
CLCodeLens,
LitCodeCount,
DistCodeCount,
LenCodeCount);
{choose the algorithm with the smallest size}
StaticSize := aStream.StaticSize;
StoredSize := (aStream.StoredSize + 4) * 8;
if (StaticSize < BitCount) then begin
if (StoredSize < StaticSize) then
EncodeLZStreamStored(aFinalBlock, aStream, aBitStrm,
(StoredSize div 8) - 4, aLog)
else
EncodeLZStreamStatic(aFinalBlock, aUseDeflate64,
aStream, aBitStrm, aLog);
Exit;
end
else if (StoredSize < BitCount) then begin
EncodeLZStreamStored(aFinalBlock, aStream, aBitStrm,
(StoredSize div 8) - 4, aLog);
Exit;
end;
end;
{create the code lengths tree}
CodeLenTree := TAbDfDecodeHuffmanTree.Create(19, 7, huEncoding);
CodeLenTree.Build(CLCodeLens, 0, 19, [0], $FFFF);
{$IFDEF UseLogging}
{log the tree}
if (aLog <> nil) then begin
aLog.WriteLine('Code lengths tree');
CodeLenTree.DebugPrint(aLog);
end;
{$ENDIF}
{calculate the literal encoding tree}
LitTree := TAbDfDecodeHuffmanTree.Create(286, 15, huEncoding);
LitTree.Build(CodeLens, 0, LitCodeCount,
dfc_LitExtraBits, dfc_LitExtraOffset);
{$IFDEF UseLogging}
{log the tree}
if (aLog <> nil) then begin
aLog.WriteLine('Literal/length tree');
LitTree.DebugPrint(aLog);
end;
{$ENDIF}
{calculate the distance tree}
if aUseDeflate64 then
DistTree := TAbDfDecodeHuffmanTree.Create(32, 15, huEncoding)
else
DistTree := TAbDfDecodeHuffmanTree.Create(30, 15, huEncoding);
DistTree.Build(CodeLens, LitCodeCount, DistCodeCount,
dfc_DistExtraBits, dfc_DistExtraOffset);
{$IFDEF UseLogging}
if (aLog <> nil) then begin
{log the tree}
aLog.WriteLine('Distance tree');
DistTree.DebugPrint(aLog);
{log the new block}
aLog.WriteLine('..Writing new block...');
aLog.WriteLine(Format('..final block? %d', [ord(aFinalBlock)]));
aLog.WriteLine('..block type? 2');
aLog.WriteLine(Format('Count of literals: %d', [LitCodeCount]));
aLog.WriteLine(Format('Count of distances: %d', [DistCodeCount]));
aLog.WriteLine(Format('Count of code lengths: %d', [LenCodeCount]));
end;
{$ENDIF}
{output the block information to the bit stream}
if aFinalBlock then
Code := 1 + (2 shl 1)
else
Code := 0 + (2 shl 1);
aBitStrm.WriteBits(Code, 3);
{output the various counts to the bit stream}
Code := (LitCodeCount - 257) +
((DistCodeCount - 1) shl 5) +
((LenCodeCount - 4) shl 10);
aBitStrm.WriteBits(Code, 14);
{output the code length codelengths to the bit stream}
for i := 0 to pred(LenCodeCount) do
aBitStrm.WriteBits(CLCodeLens[dfc_CodeLengthIndex[i]], 3);
{encode and write the codelength stream to the bit stream}
CodeLenStream.Encode(aBitStrm, CodeLenTree);
{encode and write the LZ77 stream to the bit stream}
aStream.Encode(aBitStrm, LitTree, DistTree, aUseDeflate64);
{output the end-of-block marker to the bit stream}
OutputEndOfBlock(aBitStrm, LitTree);
{$IFDEF UseLogging}
if (aLog <> nil) then
aLog.WriteLine('Char: end-of-block marker (#256)');
{$ENDIF}
finally
LitTree.Free;
DistTree.Free;
CodeLenTree.Free;
CodeLenStream.Free;
end;
end;
{====================================================================}
{===Single algorithm Static/Dynamic Huffman tree deflate=============}
function DeflateStaticDynamic(aStatic : boolean;
aUseBest: boolean;
aSource : TStream; aDest : TStream;
aHelper : TAbDeflateHelper;
aLog : TAbLogger) : longint;
var
i : integer;
SlideWin : TAbDfInputWindow;
BitStrm : TAbDfOutBitStream;
LZ77Stream : TAbDfLZStream;
KeyLen : integer;
Match : TAbDfMatch;
PrevMatch : TAbDfMatch;
UseDeflate64 : boolean;
UseCRC32 : boolean;
GotMatch : boolean;
LZStrmIsFull : boolean;
TestForBinary: boolean;
begin
{note: turn on the following define to see when and how the lazy
matching algorithm works}
{$IFDEF UseLogging}
{$DEFINE UseLazyMatchLogging}
{$ENDIF}
{$IFDEF UseLogging}
if (aLog <> nil) then
if aStatic then
aLog.WriteLine('..compressing source data with static huffman trees')
else
aLog.WriteLine('..compressing source data with dynamic huffman trees');
{$ENDIF}
{prepare for the try..finally}
SlideWin := nil;
BitStrm := nil;
LZ77Stream := nil;
try
{create the sliding window}
UseDeflate64 := (aHelper.Options and dfc_UseDeflate64) <> 0;
UseCRC32 := (aHelper.Options and dfc_UseAdler32) = 0;
SlideWin := TAbDfInputWindow.Create(aSource,
aHelper.StreamSize,
aHelper.WindowSize,
aHelper.ChainLength,
UseDeflate64, UseCRC32);
SlideWin.OnProgress := aHelper.OnProgressStep;
{create the bit stream}
BitStrm := TAbDfOutBitStream.Create(aDest);
{create the LZ77 stream}
LZ77Stream := TAbDfLZStream.Create(SlideWin, UseDeflate64, aLog);
LZStrmIsFull := false;
TestForBinary := true;
{set the previous match to be a literal character: this will
ensure that no lazy matching goes on with the first key read}
PrevMatch.maLen := 0;
{get the first key length}
KeyLen := SlideWin.GetNextKeyLength;
{while the current key is three characters long...}
while (KeyLen = 3) do begin
{tweak for binary/text}
{note: the test for whether a stream is binary or not is to
check whether there are any #0 characters in the first
1024 bytes: if there are the stream is binary.
this test and tweaking is based on experimentation
compression ratios for binary and text files based on the
PKZIP 'n' option.}
if TestForBinary and (LZ77Stream.StoredSize = 1024) then begin
if (aHelper.PKZipOption = 'n') then
if (LZ77Stream.LitBuckets^[0] = 0) then begin
aHelper.AmpleLength := aHelper.AmpleLength * 2;
aHelper.MaxLazyLength := aHelper.MaxLazyLength * 2;
aHelper.ChainLength := aHelper.ChainLength * 2;
SlideWin.ChainLen := aHelper.ChainLength;
end;
TestForBinary := false;
end;
{if the LZ77 stream is full, empty it}
if LZStrmIsFull then begin
if aStatic then
EncodeLZStreamStatic(false, UseDeflate64,
LZ77Stream, BitStrm, aLog)
else
EncodeLZStreamDynamic(false, UseDeflate64, aUseBest,
LZ77Stream, BitStrm, aLog);
LZ77Stream.Clear;
LZStrmIsFull := false;
end;
{try and find a match of three or more characters (note: this
has the side effect of adding the current key to the internal
hash table); this routine will only return true if it finds a
match greater than the previous match}
GotMatch := SlideWin.FindLongestMatch(aHelper.AmpleLength,
Match, PrevMatch);
{if the maximum match length were three and the distance exceeds
4096 bytes, it's most likely that we'll get better compression
by outputting the three literal bytes rather than by outputting
a length symbol, a distance symbol, and at least ten extra
bits for the extra distance value}
if (Match.maLen = 3) and (Match.maDist > 4096) then
GotMatch := false;
{if we found a match...}
if GotMatch then begin
{if there were no previous match, we can't do any lazy match
processing now, so save the current match details ready for
lazy matching the next time through, and advance the sliding
window}
if (PrevMatch.maLen = 0) then begin
PrevMatch.maLen := Match.maLen;
PrevMatch.maDist := Match.maDist;
PrevMatch.maLit := Match.maLit;
SlideWin.AdvanceByOne;
end
{otherwise the previous match is smaller than this one, so
we're going to accept this match in preference; throw away
the previous match, output the previous literal character
instead and save these match details}
else begin
{$IFDEF UseLazyMatchLogging}
if (aLog <> nil) then
aLog.WriteLine(
Format(
'..this match longer, rejecting previous one (%d,%d)',
[PrevMatch.maLen, PrevMatch.maDist]));
{$ENDIF}
LZStrmIsFull := LZ77Stream.AddLiteral(PrevMatch.maLit);
PrevMatch.maLen := Match.maLen;
PrevMatch.maDist := Match.maDist;
PrevMatch.maLit := Match.maLit;
SlideWin.AdvanceByOne;
end;
{if, by this point, we're storing up a match, check to see
if it equals or exceeds the maximum lazy match length; if
it does then output the match right now and avoid checking
for a lazy match}
if (PrevMatch.maLen >= aHelper.MaxLazyLength) then begin
{$IFDEF UseLazyMatchLogging}
if (aLog <> nil) then
if ((aHelper.Options and dfc_UseLazyMatch) <> 0) then
aLog.WriteLine('..match longer than max lazy match, using it');
{$ENDIF}
LZStrmIsFull :=
LZ77Stream.AddLenDist(PrevMatch.maLen, PrevMatch.maDist);
SlideWin.Advance(PrevMatch.maLen - 1, PrevMatch.maLen - 1);
PrevMatch.maLen := 0;
end;
end
{otherwise, we don't have a match at all: so we possibly just
need to output a literal character}
else begin
{if there was a previous match, output it and discard the
results of this match}
if (PrevMatch.maLen <> 0) then begin
LZStrmIsFull :=
LZ77Stream.AddLenDist(PrevMatch.maLen, PrevMatch.maDist);
SlideWin.Advance(PrevMatch.maLen - 1, PrevMatch.maLen - 2);
PrevMatch.maLen := 0;
end
{otherwise there was no previous match or it's already been
output, so output this literal}
else begin
LZStrmIsFull := LZ77Stream.AddLiteral(Match.maLit);
SlideWin.AdvanceByOne;
PrevMatch.maLen := 0;
end;
end;
{get the next key}
KeyLen := SlideWin.GetNextKeyLength;
end;
{if the last key read were one or two characters in length, save
them as literal character encodings}
if (KeyLen > 0) then begin
{if there's a match pending, it'll be of length 3: output it}
if (PrevMatch.maLen <> 0) then begin
Assert(PrevMatch.maLen = 3,
'DeflateStaticDynamic: previous match should be length 3');
LZ77Stream.AddLenDist(PrevMatch.maLen, PrevMatch.maDist);
end
{otherwise, output the one or two final literals}
else
for i := 1 to KeyLen do
LZ77Stream.AddLiteral(SlideWin.GetNextChar);
end;
{empty the LZ77 stream}
if aStatic then
EncodeLZStreamStatic(true, UseDeflate64,
LZ77Stream, BitStrm, aLog)
else
EncodeLZStreamDynamic(true, UseDeflate64, aUseBest,
LZ77Stream, BitStrm, aLog);
{calculate the checksum of the input stream}
Result := SlideWin.Checksum;
finally
{free the objects}
SlideWin.Free;
BitStrm.Free;
LZ77Stream.Free;
end;{try..finally}
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then
aLog.WriteLine(Format('..checksum: %8x', [Result]))
{$ENDIF}
end;
{====================================================================}
{===Simple storing===================================================}
function DeflateStored(aSource : TStream; aDest : TStream;
aHelper : TAbDeflateHelper;
aLog : TAbLogger) : longint;
const
StoredBlockSize = $FFFF;
var
Buffer : PAnsiChar;
BytesRead : LongWord;
ByteCount : Int64;
BytesToGo : Int64;
CurPos : Int64;
Size : Int64;
Percent : longint;
CheckSum : longint;
UseCRC32 : boolean;
BlockHeader : packed record
bhInfo : byte;
bhSize : word;
bhNotSize : word;
end;
begin
{note: this routine merely stores the aSource stream data, no
compression is attempted or done}
{$IFDEF UseLogging}
if (aLog <> nil) then
aLog.WriteLine('..storing source data to destination, no compression');
{$ENDIF}
{initialize}
ByteCount := 0;
UseCRC32 := (aHelper.Options and dfc_UseAdler32) = 0;
if UseCRC32 then
Checksum := -1 { CRC32 starts off with all bits set}
else
CheckSum := 1; { Adler32 starts off with a value of 1}
if (aHelper.StreamSize > 0) then
BytesToGo := aHelper.StreamSize
else begin
CurPos := aSource.Seek(0, soCurrent);
Size := aSource.Seek(0, soEnd);
aSource.Seek(CurPos, soBeginning);
BytesToGo := Size - CurPos;
end;
{get a buffer}
GetMem(Buffer, StoredBlockSize);
try
{while there is still data to be stored...}
while (BytesToGo <> 0) do begin
{read the next block}
BytesRead := aSource.Read(Buffer^, StoredBlockSize);
{fire the progress event}
if Assigned(aHelper.OnProgressStep) then begin
inc(ByteCount, BytesRead);
Percent := Round((100.0 * ByteCount) / aHelper.StreamSize);
aHelper.OnProgressStep(Percent);
end;
{update the checksum}
if UseCRC32 then
AbUpdateCRCBuffer(Checksum, Buffer^, BytesRead)
else
AbUpdateAdlerBuffer(Checksum, Buffer^, BytesRead);
{write the block header}
if (BytesRead = BytesToGo) then
BlockHeader.bhInfo := 1 {ie, final block, stored}
else
BlockHeader.bhInfo := 0; {ie, not final block, stored}
BlockHeader.bhSize := BytesRead;
BlockHeader.bhNotSize := not BlockHeader.bhSize;
aDest.WriteBuffer(BlockHeader, sizeof(BlockHeader));
{write the block of data}
aDest.WriteBuffer(Buffer^, BytesRead);
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then begin
if (BlockHeader.bhInfo = 0) then
aLog.WriteLine(Format('..block size: %d', [BytesRead]))
else
aLog.WriteLine(Format('..block size: %d (final block)',
[BytesRead]));
end;
{$ENDIF}
{decrement the number of bytes to go}
dec(BytesToGo, BytesRead);
end;
finally
FreeMem(Buffer);
end;
{return the checksum}
{note: the CRC32 checksum algorithm requires a post-conditioning
step after being calculated (the result is NOTted), whereas
Adler32 does not}
if UseCRC32 then
Result := not Checksum
else
Result := Checksum;
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then
aLog.WriteLine(Format('..checksum: %8x', [Result]))
{$ENDIF}
end;
{====================================================================}
{===Interfaced routine===============================================}
function Deflate(aSource : TStream; aDest : TStream;
aHelper : TAbDeflateHelper) : longint;
var
Helper : TAbDeflateHelper;
Log : TAbLogger;
SourceStartPos : longint;
DestStartPos : longint;
begin
{pre-conditions: streams are allocated,
options enable some kind of archiving}
Assert(aSource <> nil, 'Deflate: aSource stream cannot be nil');
Assert(aDest <> nil, 'Deflate: aDest stream cannot be nil');
Assert((aHelper = nil) or ((aHelper.Options and $07) <> 0),
'Deflate: aHelper.Options must enable some kind of archiving');
{$IFDEF DefeatWarnings}
Result := 0;
{$ENDIF}
{prepare for the try..finally}
Helper := nil;
Log := nil;
try {finally}
try {except}
{create our helper; assign the passed one to it}
Helper := TAbDeflateHelper.Create;
if (aHelper <> nil) then
Helper.Assign(aHelper);
{save the current positions of both streams}
SourceStartPos := aSource.Position;
DestStartPos := aDest.Position;
{if the helper's stream size is -1, and it has a progress event
handler, calculate the stream size from the stream itself}
if Assigned(Helper.OnProgressStep) then begin
if (Helper.StreamSize = -1) then
Helper.StreamSize := aSource.Size;
end
{otherwise we certainly can't do any progress reporting}
else begin
Helper.OnProgressStep := nil;
Helper.StreamSize := 0;
end;
{if lazy matching is not requested, ensure the maximum lazy
match length is zero: this make the LZ77 code a little easier
to understand}
if ((Helper.Options and dfc_UseLazyMatch) = 0) then
Helper.MaxLazyLength := 0;
{patch up the various lengths in the helper if they specify the
maximum (that is, are equal to -1)}
if (Helper.AmpleLength = -1) then
Helper.AmpleLength := MaxLongInt;
if (Helper.MaxLazyLength = -1) then
Helper.MaxLazyLength := MaxLongInt;
if (Helper.ChainLength = -1) then
Helper.ChainLength := MaxLongInt;
{create the logger, if requested}
if (Helper.LogFile <> '') then begin
Log := TAbLogger.Create(Helper.LogFile);
Log.WriteLine('DEFLATING STREAM...');
{$IFNDEF UseLogging}
Log.WriteLine('Need to recompile the app with UseLogging turned on');
{$ENDIF}
end;
{use the helper's options property to decide what to do}
case (Helper.Options and $07) of
dfc_CanUseStored :
Result := DeflateStored(aSource, aDest, Helper, Log);
dfc_CanUseStatic :
Result := DeflateStaticDynamic(true, false, aSource, aDest, Helper, Log);
dfc_CanUseDynamic :
Result := DeflateStaticDynamic(false, false, aSource, aDest, Helper, Log);
else
Result := DeflateStaticDynamic(false, true, aSource, aDest, Helper, Log);
end;
{save the uncompressed and compressed sizes}
if (aHelper <> nil) then begin
aHelper.NormalSize := aSource.Position - SourceStartPos;
aHelper.CompressedSize := aDest.Position - DestStartPos;
end;
except
on E : EAbInternalDeflateError do begin
{$IFDEF UseLogging}
if (Log <> nil) then
Log.WriteLine(Format('Internal exception raised: %s',
[E.Message]));
{$ENDIF}
raise EAbDeflateError.Create(E.Message);
end;
end;
finally
Helper.Free;
Log.Free;
end;
{WARNING NOTE: the compiler will warn that the return value of this
function might be undefined. However, it is wrong: it
has been fooled by the code. If you don't want to see
this warning again, enable the DefeatWarnings
compiler define in AbDefine.inc.}
end;
{====================================================================}
end.
================================================
FILE: lib/abbrevia/source/AbDfHufD.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfHufD.pas *}
{*********************************************************}
{* Deflate Huffman tree for decoder *}
{*********************************************************}
unit AbDfHufD;
{$I AbDefine.inc}
{Activate this compiler define and rebuild if you want the complete
huffman tree output to print to the current log. The output is
voluminous to say the least...}
{$IFDEF UseLogging}
{.$DEFINE EnableMegaLog}
{$ENDIF}
{Notes:
The object of this class is to build a decoder array, not to build a
Huffman tree particularly. We don't want to decode huffman strings bit
by bit. moving down the Huffman tree sometimes left, sometimes right.
Instead we want to grab a set of bits and look them up in an array.
Sometimes we'll grab too many bits, sure, but we can deal with that
later. So, the object of the exercise is to calculate the code for a
symbol, reverse it ('cos that's how the input bit stream will present
it to us) and set that element of the array to the decoded symbol
value (plus some extra information: bit lengths).
If the alphabet size were 19 (the codelengths huffman tree) and the
maximum code length 5, for example, the decoder array would be 2^5
elements long, much larger than the alphabet size. The user of this
class will be presenting sets of 5 bits for us to decode. We would
like to look up these 5 bits in the array (as an index) and have the
symbol returned. Now, since the alphabet size is much less than the
number of elements in the decoder array, we must set the other
elements in the array as well. Consider a symbol that has a code of
110 in this scenario. The reversed code is 011, or 3, so we'd be
setting element 3. However we should also be setting elements 01011,
10011, and 11011 to this symbol information as well, since the lookup
will be 5 bits long.
Because the code is a huffman code from a prefix tree, we won't get
any index clashes between actual codes by this "filling in" process.
For the codelength Huffman tree, the maximum code length is at most 7.
This equates to a 128 element array. For the literal and distance
trees, the max code length is at most 15. This equates to a 32768
element array.
For a given lookup value the decoder will return a 32-bit value. The
lower 16 bits is the decoded symbol, the next 8 bits is the code
length for that symbol, the last 8 bits (the most significant) are the
number of extra bits that must be extracted from the input bit stream.
}
interface
uses
AbDfBase;
type
TAbDfHuffmanUsage = ( {usage of a huffman decoder..}
huEncoding, {..encoding}
huDecoding, {..decoding}
huBoth); {..both (used for static trees)}
TAbDfDecodeHuffmanTree = class
private
FAlphaSize : integer;
FDecodes : PAbDfLongintList;
FDefMaxCodeLen : integer;
FEncodes : PAbDfLongintList;
{$IFOPT C+}
FMask : integer;
{$ENDIF}
FMaxCodeLen : integer;
FUsage : TAbDfHuffmanUsage;
protected
public
constructor Create(aAlphabetSize : integer;
aDefMaxCodeLen: integer;
aUsage : TAbDfHuffmanUsage);
destructor Destroy; override;
procedure Build(const aCodeLengths : array of integer;
aStartInx : integer;
aCount : integer;
const aExtraBits : array of byte;
aExtraOffset : integer);
function Decode(aLookupBits : integer) : longint;
function Encode(aSymbol : integer) : longint;
{$IFDEF UseLogging}
procedure DebugPrint(aLog : TAbLogger);
{$ENDIF}
property LookupBitLength : integer read FMaxCodeLen;
property Decodes : PAbDfLongintList read FDecodes;
property Encodes : PAbDfLongintList read FEncodes;
end;
var
AbStaticLiteralTree : TAbDfDecodeHuffmanTree;
AbStaticDistanceTree : TAbDfDecodeHuffmanTree;
implementation
uses
SysUtils;
const
PowerOfTwo : array [0..dfc_MaxCodeLength] of integer =
(1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048,
4096, 8192, 16384, 32768);
{===Debug helper routine=============================================}
{$IFDEF EnableMegaLog}
function CodeToStr(aCode : longint; aLen : integer) : string;
var
i : integer;
begin
if (aLen = 0) then
Result := 'no code'
else begin
SetLength(Result, 32);
FillChar(Result[1], 32, ' ');
for i := 32 downto (33-aLen) do begin
if Odd(aCode) then
Result[i] := '1'
else
Result[i] := '0';
aCode := aCode shr 1;
end;
end;
end;
{$ENDIF}
{====================================================================}
{===TAbDfDecodeHuffmanTree===========================================}
constructor TAbDfDecodeHuffmanTree.Create(
aAlphabetSize : integer;
aDefMaxCodeLen: integer;
aUsage : TAbDfHuffmanUsage);
begin
{protect against dumb programming mistakes}
Assert(aAlphabetSize >= 2,
'TAbDfDecodeHuffmanTree.Create: a huffman tree must be for at least two symbols');
{let the ancestor initialize}
inherited Create;
{save the alphabet size, etc}
FAlphaSize := aAlphabetSize;
FDefMaxCodeLen := aDefMaxCodeLen;
FUsage := aUsage;
{allocate the encoder array (needs to be initialized to zeros)}
if (aUsage <> huDecoding) then
FEncodes := AllocMem(FAlphaSize * sizeof(longint));
end;
{--------}
destructor TAbDfDecodeHuffmanTree.Destroy;
begin
{destroy the codes arrays}
if (FDecodes <> nil) then
FreeMem(FDecodes);
if (FEncodes <> nil) then
FreeMem(FEncodes);
{let the ancestor die}
inherited Destroy;
end;
{--------}
procedure TAbDfDecodeHuffmanTree.Build(
const aCodeLengths : array of integer;
aStartInx : integer;
aCount : integer;
const aExtraBits : array of byte;
aExtraOffset : integer);
const
ByteRevTable : array [0..255] of byte = (
$00, $80, $40, $C0, $20, $A0, $60, $E0, $10, $90, $50, $D0,
$30, $B0, $70, $F0, $08, $88, $48, $C8, $28, $A8, $68, $E8,
$18, $98, $58, $D8, $38, $B8, $78, $F8, $04, $84, $44, $C4,
$24, $A4, $64, $E4, $14, $94, $54, $D4, $34, $B4, $74, $F4,
$0C, $8C, $4C, $CC, $2C, $AC, $6C, $EC, $1C, $9C, $5C, $DC,
$3C, $BC, $7C, $FC, $02, $82, $42, $C2, $22, $A2, $62, $E2,
$12, $92, $52, $D2, $32, $B2, $72, $F2, $0A, $8A, $4A, $CA,
$2A, $AA, $6A, $EA, $1A, $9A, $5A, $DA, $3A, $BA, $7A, $FA,
$06, $86, $46, $C6, $26, $A6, $66, $E6, $16, $96, $56, $D6,
$36, $B6, $76, $F6, $0E, $8E, $4E, $CE, $2E, $AE, $6E, $EE,
$1E, $9E, $5E, $DE, $3E, $BE, $7E, $FE, $01, $81, $41, $C1,
$21, $A1, $61, $E1, $11, $91, $51, $D1, $31, $B1, $71, $F1,
$09, $89, $49, $C9, $29, $A9, $69, $E9, $19, $99, $59, $D9,
$39, $B9, $79, $F9, $05, $85, $45, $C5, $25, $A5, $65, $E5,
$15, $95, $55, $D5, $35, $B5, $75, $F5, $0D, $8D, $4D, $CD,
$2D, $AD, $6D, $ED, $1D, $9D, $5D, $DD, $3D, $BD, $7D, $FD,
$03, $83, $43, $C3, $23, $A3, $63, $E3, $13, $93, $53, $D3,
$33, $B3, $73, $F3, $0B, $8B, $4B, $CB, $2B, $AB, $6B, $EB,
$1B, $9B, $5B, $DB, $3B, $BB, $7B, $FB, $07, $87, $47, $C7,
$27, $A7, $67, $E7, $17, $97, $57, $D7, $37, $B7, $77, $F7,
$0F, $8F, $4F, $CF, $2F, $AF, $6F, $EF, $1F, $9F, $5F, $DF,
$3F, $BF, $7F, $FF);
var
i : integer;
Symbol : integer;
LengthCount : array [0..dfc_MaxCodeLength] of integer;
NextCode : array [0..dfc_MaxCodeLength] of integer;
Code : longint;
CodeLen : integer;
CodeData : longint;
DecoderLen : integer;
CodeIncr : integer;
Decodes : PAbDfLongintList;
Encodes : PAbDfLongintList;
{$IFDEF CPU386}
DecodesEnd : pointer;
{$ENDIF}
TablePtr : pointer;
begin
{count the number of instances of each code length and calculate the
maximum code length at the same time}
FillChar(LengthCount, sizeof(LengthCount), 0);
FMaxCodeLen := 0;
for i := 0 to pred(aCount) do begin
CodeLen := aCodeLengths[i + aStartInx];
Assert((CodeLen <= FDefMaxCodeLen),
Format('TAbDfDecodeHuffmanTree.Build: a code length is greater than %d',
[FDefMaxCodeLen]));
if (CodeLen > FMaxCodeLen) then
FMaxCodeLen := CodeLen;
inc(LengthCount[CodeLen]);
end;
{now we know the maximum code length we can allocate our decoder
array}
{$IFNDEF CPU386}
DecoderLen := 0;
{$ENDIF}
if (FUsage <> huEncoding) then begin
DecoderLen := PowerOfTwo[FMaxCodeLen];
GetMem(FDecodes, DecoderLen * sizeof(longint));
{$IFDEF CPU386}
DecodesEnd := PAnsiChar(FDecodes) + (DecoderLen * sizeof(longint));
{$ENDIF}
{$IFOPT C+}
FillChar(FDecodes^, DecoderLen * sizeof(longint), $FF);
FMask := not (DecoderLen - 1);
{$ENDIF}
end;
{calculate the start codes for each code length}
Code := 0;
LengthCount[0] := 0;
for i := 1 to FDefMaxCodeLen do begin
Code := (Code + LengthCount[i-1]) shl 1;
NextCode[i] := Code;
end;
{for speed and convenience}
Decodes := FDecodes;
Encodes := FEncodes;
TablePtr := @ByteRevTable;
{for each symbol...}
for Symbol := 0 to pred(aCount) do begin
{calculate the code length}
CodeLen := aCodeLengths[Symbol + aStartInx];
{if the code length were zero, just set the relevant entry in the
encoder array; the decoder array doesn't need anything}
if (CodeLen = 0) then begin
if (FUsage <> huDecoding) then
Encodes^[Symbol] := -1
end
{otherwise we need to fill elements in both the encoder and
decoder arrays}
else begin
{calculate *reversed* code}
Code := NextCode[CodeLen];
{$IFDEF CPU386}
asm
push esi
mov eax, Code
mov esi, TablePtr
xor ecx, ecx
xor edx, edx
mov cl, ah
mov dl, al
mov al, [esi+ecx]
mov ah, [esi+edx]
mov ecx, 16
pop esi
sub ecx, CodeLen
shr eax, cl
mov Code, eax
end;
{$ELSE}
CodeData:= Code;
LongRec(Code).Bytes[1]:= ByteRevTable[LongRec(CodeData).Bytes[0]];
LongRec(Code).Bytes[0]:= ByteRevTable[LongRec(CodeData).Bytes[1]];
Code:= Code shr (16-CodeLen);
{$ENDIF}
{set the code data (bit count, extra bits required, symbol),
everywhere the reversed code would appear in the decoder array;
set the code data in the encoder array as well}
if (Symbol >= aExtraOffset) then begin
if (FUsage <> huEncoding) then
CodeData := Symbol + { symbol}
(CodeLen shl 16) + { code length}
(aExtraBits[Symbol-aExtraOffset] shl 24);
{ extra bits required}
if (FUsage <> huDecoding) then
Encodes^[Symbol] := Code + { code}
(CodeLen shl 16) + { code length}
(aExtraBits[Symbol-aExtraOffset] shl 24)
{ extra bits required}
end
else begin
if (FUsage <> huEncoding) then
CodeData := Symbol + { symbol}
(CodeLen shl 16); { code length}
if (FUsage <> huDecoding) then
Encodes^[Symbol] := Code + { code}
(CodeLen shl 16); { code length}
end;
{OPTIMIZATION NOTE: the following code
CodeIncr := PowerOfTwo[CodeLen];
while Code < DecoderLen do begin
Decodes^[Code] := CodeData;
inc(Code, CodeIncr);
end;
was replaced by the asm code below to improve the speed. The
code in the loop is the big time sink in this routine so it was
best to replace it.}
if (FUsage <> huEncoding) then begin
{$IFDEF CPU386}
CodeIncr := PowerOfTwo[CodeLen] * sizeof(longint);
asm
push edi { save edi}
mov eax, Decodes { get the Decodes array}
mov edi, DecodesEnd { get the end of the Decodes array}
mov edx, Code { get Code and..}
shl edx, 1 { ..multiply by 4}
shl edx, 1
add eax, edx { eax => first element to be set}
mov edx, CodeData { get the CodeData}
mov ecx, CodeIncr { get the increment per loop}
@@1:
mov [eax], edx { set the element}
add eax, ecx { move to the next element}
cmp eax, edi { if we haven't gone past the end..}
jl @@1 { ..go back for the next one}
pop edi { retrieve edi}
end;
{$ELSE}
CodeIncr := PowerOfTwo[CodeLen];
while Code < DecoderLen do begin
Decodes^[Code] := CodeData;
inc(Code, CodeIncr);
end;
{$ENDIF}
end;
{we've used this code up for this symbol, so increment for the
next symbol at this code length}
inc(NextCode[CodeLen]);
end;
end;
end;
{--------}
{$IFDEF UseLogging}
procedure TAbDfDecodeHuffmanTree.DebugPrint(aLog : TAbLogger);
{$IFDEF EnableMegaLog}
var
i : integer;
Code : longint;
{$ENDIF}
begin
{to print the huffman tree, we must have a logger...}
Assert(aLog <> nil,
'TAbDfDecodeHuffmanTree.DebugPrint needs a logger object to which to print');
if (FUsage <> huEncoding) then begin
aLog.WriteLine('Huffman decoder array');
aLog.WriteLine(Format('Alphabet size: %d', [FAlphaSize]));
aLog.WriteLine(Format('Max codelength: %d', [FMaxCodeLen]));
{$IFDEF EnableMegaLog}
aLog.WriteLine('Index Len Xtra Symbol Reversed Code');
for i := 0 to pred(PowerOfTwo[FMaxCodeLen]) do begin
Code := FDecodes^[i];
if (Code = -1) then
aLog.WriteLine(Format('%5d%49s', [i, 'no code']))
else
aLog.WriteLine(Format('%5d%4d%5d%7d%33s',
[i,
((Code shr 16) and $FF),
((Code shr 24) and $FF),
(Code and $FFFF),
CodeToStr(i, ((Code shr 16) and $FF))]));
end;
aLog.WriteLine('---end decoder array---');
{$ENDIF}
end;
if (FUsage <> huDecoding) then begin
aLog.WriteLine('Huffman encoder array');
aLog.WriteLine(Format('Alphabet size: %d', [FAlphaSize]));
{$IFDEF EnableMegaLog}
aLog.WriteLine('Symbol Len Xtra Reversed Code');
for i := 0 to pred(FAlphaSize) do begin
Code := FEncodes^[i];
if (Code = -1) then
aLog.WriteLine(Format('%6d%42s', [i, 'no code']))
else
aLog.WriteLine(Format('%6d%4d%5d%33s',
[i,
((Code shr 16) and $FF),
((Code shr 24) and $FF),
CodeToStr((Code and $FFFF), ((Code shr 16) and $FF))]));
end;
aLog.WriteLine('---end encoder array---');
{$ENDIF}
end;
end;
{$ENDIF}
{--------}
function TAbDfDecodeHuffmanTree.Decode(aLookupBits : integer) : longint;
begin
{protect against dumb programming mistakes (note: FMask only exists
if assertions are on)}
{$IFOPT C+}
Assert((aLookupBits and FMask) = 0,
'TAbDfDecodeHuffmanTree.Decode: trying to decode too many bits, use LookupBitLength property');
{$ENDIF}
{return the code data}
Result := FDecodes^[aLookupBits];
end;
{--------}
function TAbDfDecodeHuffmanTree.Encode(aSymbol : integer) : longint;
begin
{protect against dumb programming mistakes}
Assert((0 <= aSymbol) and (aSymbol < FAlphaSize),
'TAbDfDecodeHuffmanTree.Encode: trying to encode a symbol that is not in the alphabet');
{return the code data}
Result := FEncodes^[aSymbol];
{if the result is -1, it's another programming mistake: the user is
attempting to get a code for a symbol that wasn't being used}
Assert(Result <> -1,
'TAbDfDecodeHuffmanTree.Encode: trying to encode a symbol that was not used');
end;
{====================================================================}
{===BuildStaticTrees=================================================}
procedure BuildStaticTrees;
var
i : integer;
CodeLens : array [0..287] of integer;
begin
{this routine builds the static huffman trees, those whose code
lengths are determined by the deflate spec}
{the static literal tree first}
for i := 0 to 143 do
CodeLens[i] := 8;
for i := 144 to 255 do
CodeLens[i] := 9;
for i := 256 to 279 do
CodeLens[i] := 7;
for i := 280 to 287 do
CodeLens[i] := 8;
AbStaticLiteralTree := TAbDfDecodeHuffmanTree.Create(288, 15, huBoth);
AbStaticLiteralTree.Build(CodeLens, 0, 288,
dfc_LitExtraBits, dfc_LitExtraOffset);
{the static distance tree afterwards}
for i := 0 to 31 do
CodeLens[i] := 5;
AbStaticDistanceTree := TAbDfDecodeHuffmanTree.Create(32, 15, huBoth);
AbStaticDistanceTree.Build(CodeLens, 0, 32,
dfc_DistExtraBits, dfc_DistExtraOffset);
end;
{====================================================================}
initialization
BuildStaticTrees;
finalization
AbStaticLiteralTree.Free;
AbStaticDistanceTree.Free;
end.
================================================
FILE: lib/abbrevia/source/AbDfInW.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfInW.pas *}
{*********************************************************}
{* Deflate input sliding window unit *}
{*********************************************************}
unit AbDfInW;
{$I AbDefine.inc}
interface
uses
Classes,
AbDfBase;
{Notes: TdfInputWindow implements a sliding window on data for the
LZ77 dictionary encoding.
The stream passed to the class is automatically read when
required to keep the internal buffer fully loaded.
}
type
TAbDfMatch = record
maLen : integer;
maDist : integer;
maLit : AnsiChar;
end;
type
PAbPointerList = ^TAbPointerList;
TAbPointerList = array[0..MaxInt div SizeOf(Pointer) - 1] of Pointer;
TAbDfInputWindow = class
private
FAdvanceStart : boolean;
FBuffer : PAnsiChar;
FBufferEnd : PAnsiChar;
FBytesUsed : longint;
FChainLen : integer;
FHashChains : PAbPointerList;
FHashHeads : PAbPointerList;
FHashIndex : integer;
FChecksum : longint;
FCurrent : PAnsiChar;
FLookAheadEnd : PAnsiChar;
FMaxMatchLen : integer;
FMustSlide : boolean;
FOnProgress : TAbProgressStep;
FSlidePoint : PAnsiChar;
FStart : PAnsiChar;
FStartOffset : longint;
FStream : TStream;
FStreamSize : Int64;
FUseCRC32 : boolean;
FUseDeflate64 : boolean;
FWinMask : integer;
FWinSize : integer;
protected
function iwGetChecksum : longint;
procedure iwReadFromStream;
procedure iwSetCapacity(aValue : longint);
procedure iwSlide;
public
constructor Create(aStream : TStream;
aStreamSize : Int64;
aWinSize : integer;
aChainLength : integer;
aUseDeflate64 : boolean;
aUseCRC32 : boolean);
destructor Destroy; override;
procedure Advance(aCount : integer;
aHashCount : integer);
procedure AdvanceByOne;
function FindLongestMatch(aAmpleLength : integer;
var aMatch : TAbDfMatch;
const aPrevMatch : TAbDfMatch) : boolean;
function GetNextChar : AnsiChar;
function GetNextKeyLength : integer;
function Position : longint;
procedure ReadBuffer(var aBuffer; aCount : longint;
aOffset : Int64);
property ChainLen : integer read FChainLen write FChainLen;
property Checksum : longint read iwGetChecksum;
property OnProgress : TAbProgressStep
read FOnProgress write FOnProgress;
end;
implementation
uses
SysUtils;
{Notes:
Meaning of the internal pointers:
|----------+===================+==+--------------------------|
| | | | |
FBuffer FStart FCurrent FLookAheadEnd FBufferEnd
FCurrent is the current match position. The valid data that
can be matched is between FStart and FLookAheadEnd, The data
between FStart and FCurrent has already been seen; the data
between FCurrent and FLookAheadEnd can be used for matching.
The buffer size depends on the requested window size (a
multiple of 1KB, up to 32KB for deflate, up to 64KB for
deflate64) and the lookahead size (up to 258 bytes for deflate
and 64KB for deflate64.)
The window of data continuously slides to the right, and is
slid back to FBuffer whenever FStart reaches a point 16KB
away, this point being given by FSlidePoint.
The hash table:
This is a chained hash table with some peculiarities. First
the table itself, FHashHeads. It contains pointers to strings
in the window buffer, not to chains. The chains are held is a
separate structure, FHashChains. The hash function on the
three-character keys is a Rabin-Karp function:
((((Ch1 shl 5) xor Ch2) shl 5) xor Ch3) and $3FFF
designed so that a running hash value can be kept and
calculated per character. The hash table is $4000 elements
long (obviously, given the hash function).
On insertion, the previous pointer in the hash table at the
calculated index is saved and replaced by the new pointer. The
old pointer is saved in the chains array. This has the same
number of elements as the sliding window has characters. The
pointer is placed at (Ptr and (WindowsSize-1)) overwriting the
value that's already there. In this fashion the individual
chains in the standard hash table are interwoven with each
other in this hash table, like a skein of threads.
}
const
c_HashCount = $4000; {the number of hash entries}
c_HashMask = c_HashCount - 1; {a mask for the hash function}
c_HashShift = 5; {shift value for the hash function}
{===TAbDfInputWindow=================================================}
constructor TAbDfInputWindow.Create(aStream : TStream;
aStreamSize : Int64;
aWinSize : integer;
aChainLength : integer;
aUseDeflate64 : boolean;
aUseCRC32 : boolean);
begin
{create the ancestor}
inherited Create;
{save parameters}
FStreamSize := aStreamSize;
FWinSize := aWinSize;
FWinMask := aWinSize - 1;
FStream := aStream;
FChainLen := aChainLength;
FUseDeflate64 := aUseDeflate64;
FUseCRC32 := aUseCRC32;
if aUseCRC32 then
FChecksum := -1 { CRC32 starts off with all bits set }
else
FCheckSum := 1; { Adler32 starts off with a value of 1 }
{set capacity of sliding window}
iwSetCapacity(aWinSize);
{create the hash table, first the hash table itself (and set all
entries to nil)}
FHashHeads := AllocMem(c_HashCount * sizeof(pointer));
{..now the chains (there's no need to set the entries to nil, since
the chain entries get fed from the head entries before searching)}
GetMem(FHashChains, aWinSize * sizeof(pointer));
{read the first chunk of data from the stream}
FMustSlide := true;
iwReadFromStream;
{if there are at least two bytes, prime the hash index}
if ((FLookAheadEnd - FBuffer) >= 2) then
FHashIndex := ((longint(FBuffer[0]) shl c_HashShift) xor
longint(FBuffer[1])) and
c_HashMask;
end;
{--------}
destructor TAbDfInputWindow.Destroy;
begin
{free the hash table}
FreeMem(FHashHeads);
FreeMem(FHashChains);
{free the buffer}
FreeMem(FBuffer);
{destroy the ancestor}
inherited Destroy;
end;
{--------}
procedure TAbDfInputWindow.Advance(aCount : integer;
aHashCount : integer);
var
i : integer;
ByteCount : integer;
Percent : integer;
HashChains: PAbPointerList;
HashHeads : PAbPointerList;
HashInx : integer;
CurPos : PAnsiChar;
begin
Assert((FLookAheadEnd - FCurrent) >= aCount,
'TAbDfInputWindow.Advance: seem to be advancing into the unknown');
Assert((aHashCount = aCount) or (aHashCount = pred(aCount)),
'TAbDfInputWindow.Advance: the parameters are plain wrong');
{use local var for speed}
CurPos := FCurrent;
{advance the current pointer if needed}
if (aCount > aHashCount) then
inc(CurPos);
{make sure we update the hash table; remember that the string[3] at
the current position has already been added to the hash table (for
notes on updating the hash table, see FindLongestMatch}
{use local vars for speed}
HashChains := FHashChains;
HashHeads := FHashHeads;
HashInx := FHashIndex;
{update the hash table}
for i := 0 to pred(aHashCount) do begin
HashInx :=
((HashInx shl c_HashShift) xor longint(CurPos[2])) and
c_HashMask;
HashChains^[longint(CurPos) and FWinMask] :=
HashHeads^[HashInx];
HashHeads^[HashInx] := CurPos;
inc(CurPos);
end;
{replace old values}
FHashChains := HashChains;
FHashHeads := HashHeads;
FHashIndex := HashInx;
FCurrent := CurPos;
{if we've seen at least FWinSize bytes...}
if FAdvanceStart then begin
{advance the start of the sliding window}
inc(FStart, aCount);
inc(FStartOffset, aCount);
{check to see if we have advanced into the slide zone}
if FMustSlide and (FStart >= FSlidePoint) then
iwSlide;
end
{otherwise check to see if we've seen at least FWinSize bytes}
else if ((CurPos - FStart) >= FWinSize) then begin
FAdvanceStart := true;
{note: we can't advance automatically aCount bytes here, we need
to calculate the actual count}
ByteCount := (CurPos - FWinSize) - FStart;
inc(FStart, ByteCount);
inc(FStartOffset, ByteCount);
end;
{show progress}
if Assigned(FOnProgress) then begin
inc(FBytesUsed, aCount);
if ((FBytesUsed and $FFF) = 0) then begin
Percent := Round((100.0 * FBytesUsed) / FStreamSize);
FOnProgress(Percent);
end;
end;
{check to see if we have advanced into the slide zone}
if (FStart >= FSlidePoint) then
iwSlide;
end;
{--------}
procedure TAbDfInputWindow.AdvanceByOne;
var
Percent : integer;
begin
{advance the current pointer}
inc(FCurrent);
{if we've seen at least FWinSize bytes...}
if FAdvanceStart then begin
{advance the start of the sliding window}
inc(FStart, 1);
inc(FStartOffset, 1);
{check to see if we have advanced into the slide zone}
if FMustSlide and (FStart >= FSlidePoint) then
iwSlide;
end
{otherwise check to see if we've seen FWinSize bytes}
else if ((FCurrent - FStart) = FWinSize) then
FAdvanceStart := true;
{show progress}
if Assigned(FOnProgress) then begin
inc(FBytesUsed, 1);
if ((FBytesUsed and $FFF) = 0) then begin
Percent := Round((100.0 * FBytesUsed) / FStreamSize);
FOnProgress(Percent);
end;
end;
end;
{--------}
function TAbDfInputWindow.FindLongestMatch(aAmpleLength : integer;
var aMatch : TAbDfMatch;
const aPrevMatch : TAbDfMatch)
: boolean;
{Note: this routine implements a greedy algorithm and is by far the
time sink for compression. There are two versions, one written
in Pascal for understanding, one in assembler for speed.
Activate one and only one of the following compiler defines.}
{$IFDEF CPU386}
{$DEFINE UseGreedyAsm}
{$ELSE}
{$DEFINE UseGreedyPascal}
{$ENDIF}
{Check to see that all is correct}
{$IFDEF UseGreedyAsm}
{$IFDEF UseGreedyPascal}
!! Compile Error: only one of the greedy compiler defines can be used
{$ENDIF}
{$ELSE}
{$IFNDEF UseGreedyPascal}
!! Compile Error: one of the greedy compiler defines must be used
{$ENDIF}
{$ENDIF}
type
PLongint = ^longint;
PWord = ^word;
var
MaxLen : longint;
MaxDist : longint;
MaxMatch : integer;
ChainLen : integer;
PrevStrPos : PAnsiChar;
CurPos : PAnsiChar;
{$IFDEF UseGreedyAsm}
CurWord : word;
MaxWord : word;
{$ENDIF}
{$IFDEF UseGreedyPascal}
Len : longint;
MatchStr : PAnsiChar;
CurrentCh : PAnsiChar;
CurCh : AnsiChar;
MaxCh : AnsiChar;
{$ENDIF}
begin
{calculate the hash index for the current position; using the
Rabin-Karp algorithm this is equal to the previous index less the
effect of the character just lost plus the effect of the character
just gained}
CurPos := FCurrent;
FHashIndex :=
((FHashIndex shl c_HashShift) xor longint(CurPos[2])) and
c_HashMask;
{get the head of the hash chain: this is the position in the sliding
window of the previous 3-character string with this hash value}
PrevStrPos := FHashHeads^[FHashIndex];
{set the head of the hash chain equal to our current position}
FHashHeads^[FHashIndex] := CurPos;
{update the chain itself: set the entry for this position equal to
the previous string position}
FHashChains^[longint(CurPos) and FWinMask] := PrevStrPos;
{calculate the maximum match we could do at this position}
MaxMatch := (FLookAheadEnd - CurPos);
if (MaxMatch > FMaxMatchLen) then
MaxMatch := FMaxMatchLen;
if (aAmpleLength > MaxMatch) then
aAmpleLength := MaxMatch;
{calculate the current match length}
if (aPrevMatch.maLen = 0) then
MaxLen := 2
else begin
if (MaxMatch < aPrevMatch.maLen) then begin
Result := false;
aMatch.maLen := 0;
aMatch.maLit := CurPos^;
Exit;
end;
MaxLen := aPrevMatch.maLen;
end;
{get the bytes at the current position and at the end of the maximum
match we have to better}
{$IFDEF UseGreedyAsm}
CurWord := PWord(CurPos)^;
MaxWord := PWord(CurPos + pred(MaxLen))^;
{$ENDIF}
{$IFDEF UseGreedyPascal}
CurCh := CurPos^;
MaxCh := (CurPos + pred(MaxLen))^;
{$ENDIF}
{set the chain length to search based on the current maximum match
(basically: if we've already satisfied the ample length
requirement, don't search as far)}
if (MaxLen >= aAmpleLength) then
ChainLen := FChainLen div 4
else
ChainLen := FChainLen;
{get ready for the loop}
{$IFDEF DefeatWarnings}
MaxDist := 0;
{$ENDIF}
{$IFDEF UseGreedyAsm} { slip into assembler for speed...}
asm
push ebx { save those registers we should}
push esi
push edi
mov ebx, Self { ebx will store the Self pointer}
mov edi, PrevStrPos { edi => previous string}
mov esi, CurPos { esi => current string}
@@TestThisPosition:
{ check previous string is in range}
or edi, edi
je @@Exit
cmp edi, [ebx].TAbDfInputWindow.FStart
jb @@Exit
cmp edi, CurPos
jae @@Exit
mov ax, [edi] { check previous string starts with same}
cmp CurWord, ax { two bytes as current}
jne @@GetNextPosition { ..nope, they don't match}
mov edx, edi { check previous string ends with same}
add edi, MaxLen { two bytes as current (by "ends" we}
dec edi { mean the last two bytes at the}
mov ax, [edi] { current match length)}
cmp MaxWord, ax
mov edi, edx
jne @@GetNextPosition { ..nope, they don't match}
push edi { compare the previous string with the}
push esi { current string}
mov eax, MaxMatch
add edi, 2 { (we've already checked that the first}
sub eax, 2 { two characters are the same)}
add esi, 2
mov ecx, eax
@@CmpQuads:
cmp ecx, 4
jb @@CmpSingles
mov edx, [esi]
cmp edx, [edi]
jne @@CmpSingles
add esi, 4
add edi, 4
sub ecx, 4
jnz @@CmpQuads
jmp @@MatchCheck
@@CmpSingles:
or ecx, ecx
jb @@MatchCheck
mov dl, [esi]
cmp dl, [edi]
jne @@MatchCheck
inc esi
inc edi
dec ecx
jnz @@CmpSingles
@@MatchCheck:
sub eax, ecx
add eax, 2
pop esi
pop edi
cmp eax, MaxLen { have we found a longer match?}
jbe @@GetNextPosition { ..no}
mov MaxLen, eax { ..yes, so save it}
mov eax, esi { calculate the dist for this new match}
sub eax, edi
mov MaxDist, eax
cmp eax, aAmpleLength { if this match is ample enough, exit}
jae @@Exit
mov eax, esi { calculate the two bytes at the end of}
add eax, MaxLen { this new match}
dec eax
mov ax, [eax]
mov MaxWord, ax
@@GetNextPosition:
mov eax, ChainLen { we've visited one more link on the}
dec eax { chain, if that's the last one we}
je @@Exit { should visit, exit}
mov ChainLen, eax
{ advance along the chain}
mov edx, [ebx].TAbDfInputWindow.FHashChains
mov eax, [ebx].TAbDfInputWindow.FWinMask
and edi, eax
shl edi, 2
mov edi, [edx+edi]
jmp @@TestThisPosition
@@Exit:
pop edi
pop esi
pop ebx
end;
{$ENDIF}
{$IFDEF UseGreedyPascal}
{for all possible hash nodes in the chain...}
while (FStart <= PrevStrPos) and (PrevStrPos < CurPos) do begin
{if the initial and maximal characters match...}
if (PrevStrPos[0] = CurCh) and
(PrevStrPos[pred(MaxLen)] = MaxCh) then begin
{compare more characters}
Len := 1;
CurrentCh := CurPos + 1;
MatchStr := PrevStrPos + 1;
{compare away, but don't go above the maximum length}
while (Len < MaxMatch) and (MatchStr^ = CurrentCh^) do begin
inc(CurrentCh);
inc(MatchStr);
inc(Len);
end;
{have we reached another maximum for the length?}
if (Len > MaxLen) then begin
MaxLen := Len;
{calculate the distance}
MaxDist := CurPos - PrevStrPos;
MaxCh := CurPos[pred(MaxLen)];
{is the new best length ample enough?}
if MaxLen >= aAmpleLength then
Break;
end;
end;
{have we reached the end of this chain?}
dec(ChainLen);
if (ChainLen = 0) then
Break;
{otherwise move onto the next position}
PrevStrPos := FHashChains^[longint(PrevStrPos) and FWinMask];
end;
{$ENDIF}
{based on the results of our investigation, return the match values}
if (MaxLen < 3) or (MaxLen <= aPrevMatch.maLen) then begin
Result := false;
aMatch.maLen := 0;
aMatch.maLit := CurPos^;
end
else begin
Result := true;
aMatch.maLen := MaxLen;
aMatch.maDist := MaxDist;
aMatch.maLit := CurPos^; { just in case...}
end;
end;
{--------}
function TAbDfInputWindow.GetNextChar : AnsiChar;
begin
Result := FCurrent^;
inc(FCurrent);
end;
{--------}
function TAbDfInputWindow.GetNextKeyLength : integer;
begin
Result := FLookAheadEnd - FCurrent;
if (Result > 3) then
Result := 3;
end;
{--------}
function TAbDfInputWindow.iwGetChecksum : longint;
begin
{the CRC32 checksum algorithm requires a post-conditioning step
after being calculated (the result is NOTted), whereas Adler32 does
not}
if FUseCRC32 then
Result := not FChecksum
else
Result := FChecksum;
end;
{--------}
procedure TAbDfInputWindow.iwReadFromStream;
var
BytesRead : longint;
BytesToRead : longint;
begin
{read some more data into the look ahead zone}
BytesToRead := FBufferEnd - FLookAheadEnd;
BytesRead := FStream.Read(FLookAheadEnd^, BytesToRead);
{if nothing was read, we reached the end of the stream; hence
there's no more need to slide the window since we have all the
data}
if (BytesRead = 0) then
FMustSlide := false
{otherwise something was actually read...}
else begin
{update the checksum}
if FUseCRC32 then
AbUpdateCRCBuffer(FChecksum, FLookAheadEnd^, BytesRead)
else
AbUpdateAdlerBuffer(FChecksum, FLookAheadEnd^, BytesRead);
{reposition the pointer for the end of the lookahead area}
inc(FLookAheadEnd, BytesRead);
end;
end;
{--------}
procedure TAbDfInputWindow.iwSetCapacity(aValue : longint);
var
ActualSize : integer;
begin
{calculate the actual size; this will be the value passed in, plus
the correct look ahead size, plus 16KB}
ActualSize := aValue + (16 * 1024);
if FUseDeflate64 then begin
inc(ActualSize, dfc_MaxMatchLen64);
FMaxMatchLen := dfc_MaxMatchLen64;
end
else begin
inc(ActualSize, dfc_MaxMatchLen);
FMaxMatchLen := dfc_MaxMatchLen;
end;
{get the new buffer}
GetMem(FBuffer, ActualSize);
{set the other buffer pointers}
FStart := FBuffer;
FCurrent := FBuffer;
FLookAheadEnd := FBuffer;
FBufferEnd := FBuffer + ActualSize;
FSlidePoint := FBuffer + (16 * 1024);
end;
{--------}
procedure TAbDfInputWindow.iwSlide;
type
PLongint = ^longint;
var
i : integer;
ByteCount : integer;
Buffer : longint;
ListItem : PLongint;
begin
{move current valid data back to the start of the buffer}
ByteCount := FLookAheadEnd - FStart;
Move(FStart^, FBuffer^, ByteCount);
{reset the various pointers}
ByteCount := FStart - FBuffer;
FStart := FBuffer;
dec(FCurrent, ByteCount);
dec(FLookAheadEnd, ByteCount);
{patch up the hash table: the head pointers}
Buffer := longint(FBuffer);
ListItem := PLongint(@FHashHeads^[0]);
for i := 0 to pred(c_HashCount) do begin
dec(ListItem^, ByteCount);
if (ListItem^ < Buffer) then
ListItem^ := 0;
inc(PAnsiChar(ListItem), sizeof(pointer));
end;
{..the chain pointers}
ListItem := PLongint(@FHashChains^[0]);
for i := 0 to pred(FWinSize) do begin
dec(ListItem^, ByteCount);
if (ListItem^ < Buffer) then
ListItem^ := 0;
inc(PAnsiChar(ListItem), sizeof(pointer));
end;
{now read some more data from the stream}
iwReadFromStream;
end;
{--------}
function TAbDfInputWindow.Position : longint;
begin
Result := (FCurrent - FStart) + FStartOffset;
end;
{--------}
procedure TAbDfInputWindow.ReadBuffer(var aBuffer; aCount : longint;
aOffset : Int64);
var
CurPos : Int64;
begin
CurPos := FStream.Seek(0, soCurrent);
FStream.Seek(aOffSet, soBeginning);
FStream.ReadBuffer(aBuffer, aCount);
FStream.Seek(CurPos, soBeginning);
end;
{====================================================================}
end.
================================================
FILE: lib/abbrevia/source/AbDfOutW.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfOutW.pas *}
{*********************************************************}
{* Deflate output sliding window *}
{*********************************************************}
unit AbDfOutW;
{$I AbDefine.inc}
interface
uses
Classes,
AbDfBase;
{Notes: TAbDfOutputWindow implements a sliding window on previously
written data for the LZ77 dictionary decoding.
AddLiteral will add a literal character at the current
position and advance by one. AddLenDist will copy the required
number of characters from the given position to the current
position, and advance the stream on by the length. The class
will periodically update the stream from the internal buffer.
For normal Deflate, the internal buffer is 48K + 512 bytes in
size. Once there is 48Kb worth of data, 16KB is written to
file, and the buffer is shifted left by 16KB. We need to keep
the last decoded 32KB in memory at all times.
For Deflate64, the internal buffer is 96K + 512 bytes in
size. Once there is 96Kb worth of data, 32KB is written to
file, and the buffer is shifted left by 32KB. We need to keep
the last decoded 64KB in memory at all times.
}
type
TAbDfOutputWindow = class
private
FBuffer : PAnsiChar;
FChecksum : longint;
FCurrent : PAnsiChar;
FLog : TAbLogger;
FPartSize : longint;
FSlideCount : integer;
FStream : TStream;
FStreamPos : longint;
FTestOnly : boolean;
FUseCRC32 : boolean;
FWritePoint : PAnsiChar;
protected
function swGetChecksum : longint;
procedure swWriteToStream(aFlush : boolean);
public
constructor Create(aStream : TStream;
aUseDeflate64 : boolean;
aUseCRC32 : boolean;
aPartSize : longint;
aTestOnly : boolean;
aLog : TAbLogger);
destructor Destroy; override;
procedure AddBuffer(var aBuffer; aCount : integer);
procedure AddLiteral(aCh : AnsiChar);
procedure AddLenDist(aLen : integer; aDist : integer);
function Position : longint;
property Checksum : longint read swGetChecksum;
property Log : TAbLogger read FLog;
end;
implementation
uses
SysUtils;
{Notes:
Meaning of the internal pointers:
|==============================+------------------------+----|
| | |
FBuffer FCurrent FWritePoint
Once FCurrent reaches or exceeds FWritePoint, FSlideCount
bytes of data from FBuffer are written to the stream and the
remaining data is moved back FSlideCount bytes, moving
FCurrent along with it as well.
}
{===TAbDfOutputWindow==================================================}
constructor TAbDfOutputWindow.Create(aStream : TStream;
aUseDeflate64 : boolean;
aUseCRC32 : boolean;
aPartSize : longint;
aTestOnly : boolean;
aLog : TAbLogger);
var
Size : integer;
LookAheadSize : integer;
begin
{allow the ancestor to initialize}
inherited Create;
{save parameters}
FLog := aLog;
FStream := aStream;
FTestOnly := aTestOnly;
if (aPartSize <= 0) then
FPartSize := 0
else
FPartSize := aPartSize;
FUseCRC32 := aUseCRC32;
if aUseCRC32 then
FChecksum := -1 { CRC32 starts off with all bits set}
else
FCheckSum := 1; { Adler32 starts off with a value of 1}
{set capacity of sliding window}
if aUseDeflate64 then begin
Size := 96 * 1024;
FSlideCount := 32 * 1024;
LookAheadSize := 64 * 1024;
end
else begin
Size := 64 * 1024;
FSlideCount := 32 * 1024;
LookAheadSize := 258;
end;
GetMem(FBuffer, Size + LookAheadSize);
{set the other internal pointers}
FCurrent := FBuffer;
FWritePoint := FBuffer + Size;
if (FPartSize > Size) then
FPartSize := Size;
end;
{--------}
destructor TAbDfOutputWindow.Destroy;
begin
{write remaining data and free the buffer}
if (FBuffer <> nil) then begin
if (FCurrent <> FBuffer) then
swWriteToStream(true);
FreeMem(FBuffer);
end;
{destroy the ancestor}
inherited Destroy;
end;
{--------}
procedure TAbDfOutputWindow.AddBuffer(var aBuffer; aCount : integer);
var
Buffer : PAnsiChar;
BytesToWrite : integer;
begin
{if we've advanced to the point when we need to write, do so}
if (FCurrent >= FWritePoint) then
swWriteToStream(false);
{cast the user buffer to a PChar, it's easier to use}
Buffer := @aBuffer;
{calculate the number of bytes to copy}
BytesToWrite := FWritePoint - FCurrent;
if (BytesToWrite > aCount) then
BytesToWrite := aCount;
{move this block of bytes}
Move(Buffer^, FCurrent^, BytesToWrite);
{advance pointers and counters}
inc(FCurrent, BytesToWrite);
dec(aCount, BytesToWrite);
{while there is still data to copy...}
while (aCount > 0) do begin
{advance the user buffer pointer}
inc(Buffer, BytesToWrite);
{write the sliding window chunk to the stream}
swWriteToStream(false);
{calculate the number of bytes to copy}
BytesToWrite := FWritePoint - FCurrent;
if (BytesToWrite > aCount) then
BytesToWrite := aCount;
{move this block of bytes}
Move(Buffer^, FCurrent^, BytesToWrite);
{advance pointers and counters}
inc(FCurrent, BytesToWrite);
dec(aCount, BytesToWrite);
end;
end;
{--------}
procedure AddLenDistToLog(aLog : TAbLogger;
aPosn : longint;
aLen : integer;
aDist : integer;
aOverLap : boolean);
begin
{NOTE the reason for this separate routine is to avoid string
allocations and try..finally blocks in the main method: an
optimization issue}
if aOverLap then
aLog.WriteLine(Format('%8x Len: %-3d, Dist: %-5d **overlap**',
[aPosn, aLen, aDist]))
else
aLog.WriteLine(Format('%8x Len: %-3d, Dist: %-5d',
[aPosn, aLen, aDist]));
end;
{--------}
procedure TAbDfOutputWindow.AddLenDist(aLen : integer; aDist : integer);
var
i : integer;
ToChar : PAnsiChar;
FromChar : PAnsiChar;
begin
{log it}
{$IFDEF UseLogging}
if (FLog <> nil) then
AddLenDistToLog(FLog, Position, aLen, aDist, (aLen > aDist));
{$ENDIF}
{if the length to copy is less than the distance, just do a move}
if (aLen <= aDist) then begin
Move((FCurrent - aDist)^ , FCurrent^, aLen);
end
{otherwise we have to use a byte-by-byte copy}
else begin
FromChar := FCurrent - aDist;
ToChar := FCurrent;
for i := 1 to aLen do begin
ToChar^ := FromChar^;
inc(FromChar);
inc(ToChar);
end;
end;
{increment the current pointer}
inc(FCurrent, aLen);
{if we've reached the point requested, abort}
if (FPartSize > 0) and ((FCurrent - FBuffer) >= FPartSize) then
raise EAbPartSizedInflate.Create(''); {NOTE: This exception is expected during detection of .GZ and .TGZ files. (VerifyGZip)}
{if we've advanced to the point when we need to write, do so}
if (FCurrent >= FWritePoint) then
swWriteToStream(false);
end;
{--------}
procedure AddLiteralToLog(aLog : TAbLogger;
aPosn : longint;
aCh : AnsiChar);
begin
{NOTE the reason for this separate routine is to avoid string
allocations and try..finally blocks in the main method: an
optimization issue}
if (' ' < aCh) and (aCh <= '~') then
aLog.WriteLine(Format('%8x Char: %3d $%2x [%s]', [aPosn, ord(aCh), ord(aCh), aCh]))
else
aLog.WriteLine(Format('%8x Char: %3d $%2x', [aPosn, ord(aCh), ord(aCh)]));
end;
{--------}
procedure TAbDfOutputWindow.AddLiteral(aCh : AnsiChar);
begin
{log it}
{$IFDEF UseLogging}
if (FLog <> nil) then
AddLiteralToLog(FLog, Position, aCh);
{$ENDIF}
{add the literal to the buffer}
FCurrent^ := aCh;
{increment the current pointer}
inc(FCurrent);
{if we've reached the point requested, abort}
if (FPartSize > 0) and ((FCurrent - FBuffer) >= FPartSize) then
raise EAbPartSizedInflate.Create('');
{if we've advanced to the point when we need to write, do so}
if (FCurrent >= FWritePoint) then
swWriteToStream(false);
end;
{--------}
function TAbDfOutputWindow.Position : longint;
begin
if FTestOnly then
Result := FStreamPos + (FCurrent - FBuffer)
else
Result := FStream.Position + (FCurrent - FBuffer);
end;
{--------}
function TAbDfOutputWindow.swGetChecksum : longint;
begin
{since the checksum is calculated by the method that flushes to the
stream, make sure any buffered data is written out first}
if (FCurrent <> FBuffer) then
swWriteToStream(true);
{the CRC32 checksum algorithm requires a post-conditioning step
after being calculated (the result is NOTted), whereas Adler32 does
not}
if FUseCRC32 then
Result := not FChecksum
else
Result := FChecksum;
end;
{--------}
procedure TAbDfOutputWindow.swWriteToStream(aFlush : boolean);
var
FromPtr : PAnsiChar;
begin
{if the request was to flush, write all remaining data after
updating the checksum}
if aFlush then begin
if FUseCRC32 then
AbUpdateCRCBuffer(FChecksum, FBuffer^, FCurrent - FBuffer)
else
AbUpdateAdlerBuffer(FChecksum, FBuffer^, FCurrent - FBuffer);
if FTestOnly then
inc(FStreamPos, FCurrent - FBuffer)
else
FStream.WriteBuffer(FBuffer^, FCurrent - FBuffer);
FCurrent := FBuffer;
end
{otherwise, update the checksum with the data in the sliding window
chunk, write it out to the stream, and move the rest of the buffer
back}
else begin
if FUseCRC32 then
AbUpdateCRCBuffer(FChecksum, FBuffer^, FSlideCount)
else
AbUpdateAdlerBuffer(FChecksum, FBuffer^, FSlideCount);
if FTestOnly then
inc(FStreamPos, FSlideCount)
else
FStream.WriteBuffer(FBuffer^, FSlideCount);
FromPtr := FBuffer + FSlideCount;
Move(FromPtr^, FBuffer^, FCurrent - FromPtr);
FCurrent := FCurrent - FSlideCount;
end;
end;
{====================================================================}
end.
================================================
FILE: lib/abbrevia/source/AbDfPkMg.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfPkMg.pas *}
{*********************************************************}
{* Deflate package-merge algorithm *}
{*********************************************************}
unit AbDfPkMg;
{$I AbDefine.inc}
interface
uses
AbDfBase;
procedure GenerateCodeLengths(aMaxCodeLen : integer;
const aWeights : array of integer;
var aCodeLengths : array of integer;
aStartInx : integer;
aLog : TAbLogger);
implementation
type
PPkgNode = ^TPkgNode;
TPkgNode = packed record
pnWeight : integer;
pnCount : integer;
pnLeft : PPkgNode;
pnRight : PPkgNode;
end;
PPkgNodeList = ^TPkgNodeList;
TPkgNodeList = array [0..pred(286 * 2)] of PPkgNode;
{Note: the "286" is the number of literal/length symbols, the
maximum number of weights we'll be calculating the optimal
code lengths for}
{===helper routines==================================================}
function IsCalcFeasible(aCount : integer;
aMaxCodeLen : integer) : boolean;
begin
{works out if length-limited codes can be calculated for a given
number of symbols and the maximum code length}
{return whether 2^aMaxCodeLen > aCount}
Result := (1 shl aMaxCodeLen) > aCount;
end;
{--------}
procedure QSS(aList : PPkgNodeList;
aFirst : integer;
aLast : integer);
var
L, R : integer;
Pivot : integer;
Temp : pointer;
begin
{while there are at least two items to sort}
while (aFirst < aLast) do begin
{the pivot is the middle item}
Pivot := aList^[(aFirst+aLast) div 2]^.pnWeight;
{set indexes and partition}
L := pred(aFirst);
R := succ(aLast);
while true do begin
repeat dec(R); until (aList^[R]^.pnWeight <= Pivot);
repeat inc(L); until (aList^[L]^.pnWeight >= Pivot);
if (L >= R) then Break;
Temp := aList^[L];
aList^[L] := aList^[R];
aList^[R] := Temp;
end;
{quicksort the first subfile}
if (aFirst < R) then
QSS(aList, aFirst, R);
{quicksort the second subfile - recursion removal}
aFirst := succ(R);
end;
end;
{--------}
procedure SortList(aList : PPkgNodeList; aCount : integer);
begin
QSS(aList, 0, pred(aCount));
end;
{--------}
procedure Accumulate(aNode : PPkgNode);
begin
while (aNode^.pnLeft <> nil) do begin
Accumulate(aNode^.pnLeft);
aNode := aNode^.pnRight;
end;
inc(aNode^.pnCount);
end;
{====================================================================}
{===Interfaced routine===============================================}
procedure GenerateCodeLengths(aMaxCodeLen : integer;
const aWeights : array of integer;
var aCodeLengths : array of integer;
aStartInx : integer;
aLog : TAbLogger);
var
i : integer;
Bit : integer;
WeightCount : integer;
OrigList : PPkgNodeList;
OrigListCount : integer;
MergeList : PPkgNodeList;
MergeListCount : integer;
PkgList : PPkgNodeList;
PkgListCount : integer;
OrigInx : integer;
PkgInx : integer;
Node : PPkgNode;
NodeMgr : TAbNodeManager;
begin
{calculate the number of weights}
WeightCount := succ(high(aWeights));
{check for dumb programming errors}
Assert((0 < aMaxCodeLen) and (aMaxCodeLen <= 15),
'GenerateCodeLengths: the maximum code length should be in the range 1..15');
Assert((1 <= WeightCount) and (WeightCount <= 286),
'GenerateCodeLengths: the weight array must have 1..286 elements');
Assert(IsCalcFeasible(WeightCount, aMaxCodeLen),
'GenerateCodeLengths: the package-merge algorithm should always be feasible');
{clear the code lengths array}
FillChar(aCodeLengths[aStartInx], WeightCount * sizeof(integer), 0);
{prepare for the try..finally}
OrigList := nil;
MergeList := nil;
PkgList := nil;
NodeMgr := nil;
try
{create the node manager}
NodeMgr := TAbNodeManager.Create(sizeof(TPkgNode));
{create the original list of nodes}
GetMem(OrigList, WeightCount * sizeof(PPkgNode));
OrigListCount := 0;
for i := 0 to pred(WeightCount) do
if (aWeights[i] <> 0) then begin
Node := NodeMgr.AllocNode;
Node^.pnLeft := nil; { this will indicate a leaf}
Node^.pnRight := pointer(i); { the index of the weight}
Node^.pnWeight := aWeights[i]; { the weight itself}
Node^.pnCount := 1; { how many times used}
OrigList^[OrigListCount] := Node;
inc(OrigListCount);
end;
{we need at least 2 items, so make anything less a special case}
if (OrigListCount <= 1) then begin
{if there are no items at all in the original list, we need to
pretend that there is one, since we shall eventually need to
calculate a Count-1 value that cannot be negative}
if (OrigListCount = 0) then begin
aCodeLengths[aStartInx] := 1;
Exit;
end;
{otherwise there is only one item: set its code length directly}
for i := 0 to pred(WeightCount) do
if (aWeights[i] <> 0) then begin
aCodeLengths[aStartInx + i] := 1;
Exit;
end;
end;
{there are at least 2 items in the list; so sort the list}
SortList(OrigList, OrigListCount);
{create the merge and package lists}
GetMem(MergeList, OrigListCount * 2 * sizeof(PPkgNode));
GetMem(PkgList, OrigListCount * 2 * sizeof(PPkgNode));
{initialize the merge list to have the same items as the
original list}
Move(OrigList^, MergeList^, OrigListCount * sizeof(PPkgNode));
MergeListCount := OrigListCount;
{do aMaxCodeLen - 2 times...}
for Bit := 1 to pred(aMaxCodeLen) do begin
{generate the package list from the merge list by grouping pairs
from the merge list and adding them to the package list}
PkgListCount := 0;
for i := 0 to pred(MergeListCount div 2) do begin
Node := NodeMgr.AllocNode;
Node^.pnLeft := MergeList^[i * 2];
Node^.pnRight := MergeList^[i * 2 + 1];
Node^.pnWeight := Node^.pnLeft^.pnWeight +
Node^.pnRight^.pnWeight;
{$IFOPT C+}
Node^.pnCount := 0;
{$ENDIF}
PkgList^[PkgListCount] := Node;
inc(PkgListCount);
end;
{merge the original list and the package list}
MergeListCount := 0;
OrigInx := 0;
PkgInx := 0;
{note the optimization here: the package list will *always* be
last to empty in the merge process since it will have at least
one item whose accumulated weight is greater than all of the
items in the original list}
while (OrigInx < OrigListCount) and (PkgInx < PkgListCount) do begin
if (OrigList^[OrigInx]^.pnWeight <= PkgList^[PkgInx]^.pnWeight) then begin
MergeList^[MergeListCount] := OrigList^[OrigInx];
inc(OrigInx);
end
else begin
MergeList^[MergeListCount] := PkgList^[PkgInx];
inc(PkgInx);
end;
inc(MergeListCount);
end;
if (OrigInx < OrigListCount) then begin
Move(OrigList^[OrigInx], MergeList^[MergeListCount],
(OrigListCount - OrigInx) * sizeof(PPkgNode));
inc(MergeListCount, (OrigListCount - OrigInx));
end
else begin
Move(PkgList^[PkgInx], MergeList^[MergeListCount],
(PkgListCount - PkgInx) * sizeof(PPkgNode));
inc(MergeListCount, (PkgListCount - PkgInx));
end;
end;
{calculate the code lengths}
for i := 0 to (OrigListCount * 2) - 3 do begin
Node := MergeList^[i];
if (Node^.pnLeft <> nil) then
Accumulate(Node);
end;
for i := 0 to pred(OrigListCount) do
aCodeLengths[aStartInx + integer(OrigList^[i].pnRight)] :=
OrigList^[i].pnCount;
finally
FreeMem(OrigList);
FreeMem(MergeList);
FreeMem(PkgList);
NodeMgr.Free;
end;
end;
{====================================================================}
end.
================================================
FILE: lib/abbrevia/source/AbDfStrm.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfStrm.pas *}
{*********************************************************}
{* Deflate streams unit for various streams *}
{*********************************************************}
unit AbDfStrm;
{$I AbDefine.inc}
interface
uses
Classes,
AbDfBase,
AbDfInW,
AbDfHufD;
type
TAb32bit = longint; { a 32-bit type}
PAbDfLitBuckets = ^TAbDfLitBuckets;
TAbDfLitBuckets = array [0..285] of integer;
PAbDfDistBuckets = ^TAbDfDistBuckets;
TAbDfDistBuckets = array [0..31] of integer;
PAbDfCodeLenBuckets = ^TAbDfCodeLenBuckets;
TAbDfCodeLenBuckets = array [0..18] of integer;
const
AbExtractMask : array [1..31] of TAb32bit =
($00000001, $00000003, $00000007, $0000000F,
$0000001F, $0000003F, $0000007F, $000000FF,
$000001FF, $000003FF, $000007FF, $00000FFF,
$00001FFF, $00003FFF, $00007FFF, $0000FFFF,
$0001FFFF, $0003FFFF, $0007FFFF, $000FFFFF,
$001FFFFF, $003FFFFF, $007FFFFF, $00FFFFFF,
$01FFFFFF, $03FFFFFF, $07FFFFFF, $0FFFFFFF,
$1FFFFFFF, $3FFFFFFF, $7FFFFFFF);
type
TAbDfInBitStream = class { input bit stream}
private
FBitBuffer : TAb32bit;
FBitsLeft : integer;
FBufEnd : PAnsiChar;
FBuffer : PAnsiChar;
FBufPos : PAnsiChar;
FByteCount : longint;
FFakeCount : integer;
FOnProgress: TAbProgressStep;
{$IFOPT C+}
FPeekCount : integer;
{$ENDIF}
FStream : TStream;
FStreamSize: longint;
protected
function ibsFillBuffer : boolean;
public
constructor Create(aStream : TStream;
aOnProgress : TAbProgressStep;
aStreamSize : longint);
destructor Destroy; override;
procedure AlignToByte;
procedure DiscardBits(aCount : integer);
procedure DiscardMoreBits(aCount : integer);
function PeekBits(aCount : integer) : integer;
function PeekMoreBits(aCount : integer) : integer;
function ReadBit : boolean;
function ReadBits(aCount : integer) : integer;
procedure ReadBuffer(var aBuffer; aCount : integer);
property BitBuffer : TAb32bit read FBitBuffer write FBitBuffer;
property BitsLeft : integer read FBitsLeft write FBitsLeft;
end;
type
TAbDfOutBitStream = class { output bit stream}
private
FBitBuffer : TAb32bit;
FBitsUsed : integer;
FBufEnd : PAnsiChar;
FBuffer : PAnsiChar;
FBufPos : PAnsiChar;
FStream : TStream;
protected
procedure obsEmptyBuffer;
public
constructor Create(aStream : TStream);
destructor Destroy; override;
procedure AlignToByte;
function Position : longint;
procedure WriteBit(aBit : boolean);
procedure WriteBits(aBits : integer; aCount : integer);
procedure WriteBuffer(var aBuffer; aCount : integer);
procedure WriteMoreBits(aBits : integer; aCount : integer);
property BitBuffer : TAb32bit read FBitBuffer write FBitBuffer;
property BitsUsed : integer read FBitsUsed write FBitsUsed;
end;
type
TAbDfLZStream = class { LZ77 token stream}
private
FCurPos : PAnsiChar;
FDistBuckets : PAbDfDistBuckets;
FDistCount : integer;
FLitBuckets : PAbDfLitBuckets;
FLitCount : integer;
FLog : TAbLogger;
FSlideWin : TAbDfInputWindow;
FStartOfs : Int64;
FStoredSize : LongWord;
FStream : PAnsiChar;
FStrmEnd : PAnsiChar;
{$IFDEF UseLogging}
FSWPos : longint;
{$ENDIF}
FUseDeflate64: boolean;
protected
function lzsGetApproxSize : LongWord;
function lzsGetStaticSize : integer;
function lzsGetStoredSize : integer;
function lzsIsFull : boolean;
public
constructor Create(aSlideWin : TAbDfInputWindow;
aUseDeflate64 : boolean;
aLog : TAbLogger);
destructor Destroy; override;
function AddLenDist(aLen : integer; aDist : integer) : boolean;
{ returns true if the stream is "full"}
function AddLiteral(aCh : AnsiChar) : boolean;
{ returns true if the stream is "full"}
procedure Clear;
procedure Encode(aBitStrm : TAbDfOutBitStream;
aLitTree : TAbDfDecodeHuffmanTree;
aDistTree : TAbDfDecodeHuffmanTree;
aUseDeflate64 : boolean);
procedure Rewind;
procedure ReadStoredBuffer(var aBuffer; aCount : integer);
property LenDistCount : integer read FDistCount;
property LiteralCount : integer read FLitCount;
property DistBuckets : PAbDfDistBuckets read FDistBuckets;
property LitBuckets : PAbDfLitBuckets read FLitBuckets;
property StaticSize : integer read lzsGetStaticSize;{ in bits}
property StoredSize : integer read lzsGetStoredSize;{ in bytes}
end;
type
TAbDfCodeLenStream = class { codelength token stream}
private
FBuckets : PAbDfCodeLenBuckets;
FPosition : PAnsiChar;
FStream : PAnsiChar; {array [0..285+32*2] of byte;}
FStrmEnd : PAnsiChar;
protected
public
constructor Create(aLog : TAbLogger);
destructor Destroy; override;
procedure Build(const aCodeLens : array of integer;
aCount : integer);
procedure Encode(aBitStrm : TAbDfOutBitStream;
aTree : TAbDfDecodeHuffmanTree);
property Buckets : PAbDfCodeLenBuckets read FBuckets;
end;
implementation
uses
SysUtils,
AbDfXlat;
type
PAb32bit = ^TAb32bit;
const
BitStreamBufferSize = 16*1024;
{===TAbDfInBitStream=================================================}
constructor TAbDfInBitStream.Create(aStream : TStream;
aOnProgress : TAbProgressStep;
aStreamSize : longint);
begin
{protect against dumb programming mistakes}
Assert(aStream <> nil,
'TAbDfInBitStream.Create: Cannot create a bit stream wrapping a nil stream');
{create the ancestor}
inherited Create;
{save the stream instance, allocate the buffer}
FStream := aStream;
GetMem(FBuffer, BitStreamBufferSize);
{save the on progress handler}
if Assigned(aOnProgress) and (aStreamSize > 0) then begin
FOnProgress := aOnProgress;
FStreamSize := aStreamSize;
end;
end;
{--------}
destructor TAbDfInBitStream.Destroy;
begin
{if we did some work...}
if (FBuffer <> nil) then begin
{reposition the underlying stream to the point where we stopped;
this position is equal to...
the position of the underlying stream, PLUS
the number of fake bytes we added, LESS
the number of bytes in the buffer, PLUS
the position in the buffer, PLUS
the number of complete bytes in the bit buffer}
FStream.Seek(FStream.Position +
FFakeCount -
(FBufEnd - FBuffer) +
(FBufPos - FBuffer) -
(FBitsLeft div 8), soBeginning);
{free the buffer}
FreeMem(FBuffer);
end;
{destroy the ancestor}
inherited Destroy;
end;
{--------}
procedure TAbDfInBitStream.AlignToByte;
begin
{get rid of the odd bits by shifting them out of the bit cache}
FBitBuffer := FBitBuffer shr (FBitsLeft mod 8);
dec(FBitsLeft, FBitsLeft mod 8);
end;
{--------}
procedure TAbDfInBitStream.DiscardBits(aCount : integer);
var
BitsToGo : integer;
begin
{aCount comes from a (possibly corrupt) stream, so check that it is
the correct range, 1..32}
if (aCount <= 0) or (aCount > 32) then
raise EAbInternalInflateError.Create(
'count of bits must be between 1 and 32 inclusive [TAbDfInBitStream.DiscardBits]');
{$IFOPT C+}
{verify that the count of bits to discard is less than or equal to
the recent count from PeekBits--a programming error}
Assert((aCount <= FPeekCount),
'TAbDfInBitStream.DiscardBits: discarding more bits than peeked');
{since we're discarding bits already peeked, reset the peek count}
FPeekCount := 0;
{$ENDIF}
{if we have more than enough bits in our bit buffer, update the
bitbuffer and the number of bits left}
if (aCount <= FBitsLeft) then begin
FBitBuffer := FBitBuffer shr aCount;
dec(FBitsLeft, aCount);
end
{otherwise we shall have to read another integer out of the buffer
to satisfy the request}
else begin
{check that there is data in the buffer, if not it's indicates a
corrupted stream: PeekBits should have filled it}
if (FBufPos = FBufEnd) then
raise EAbInternalInflateError.Create(
'no more compressed data in stream [TAbDfInBitStream.DiscardBits]');
{refill the bit buffer}
BitsToGo := aCount - FBitsLeft;
FBitBuffer := PAb32bit(FBufPos)^;
inc(FBufPos, sizeof(TAb32bit));
FBitBuffer := FBitBuffer shr BitsToGo;
FBitsLeft := 32 - BitsToGo;
end;
end;
{--------}
procedure TAbDfInBitStream.DiscardMoreBits(aCount : integer);
var
BitsToGo : integer;
begin
{aCount comes from a (possibly corrupt) stream, so check that it is
the correct range, 1..32}
if (aCount <= 0) or (aCount > 32) then
raise EAbInternalInflateError.Create(
'count of bits must be between 1 and 32 inclusive [TAbDfInBitStream.DiscardMoreBits]');
{$IFOPT C+}
{verify that the count of bits to discard is less than or equal to
the recent count from PeekBits--a programming error}
Assert((aCount <= FPeekCount),
'TAbDfInBitStream.DiscardBits: discarding more bits than peeked');
{since we're discarding bits already peeked, reset the peek count}
FPeekCount := 0;
{$ENDIF}
{check that there is data in the buffer, if not it's indicates a
corrupted stream: PeekBits/PeekMoreBits should have filled it}
if (FBufPos = FBufEnd) then
raise EAbInternalInflateError.Create(
'no more compressed data in stream [TAbDfInBitStream.DiscardBits]');
{refill the bit buffer}
BitsToGo := aCount - FBitsLeft;
FBitBuffer := PAb32bit(FBufPos)^;
inc(FBufPos, sizeof(TAb32bit));
FBitBuffer := FBitBuffer shr BitsToGo;
FBitsLeft := 32 - BitsToGo;
end;
{--------}
function TAbDfInBitStream.ibsFillBuffer : boolean;
var
BytesRead : longint;
BytesToRead : longint;
i : integer;
Percent : integer;
Buffer : PAnsiChar;
BufferCount : integer;
begin
{check for dumb programming mistakes: this routine should only be
called if there are less than 4 bytes unused in the buffer}
Assert((FBufEnd - FBufPos) < sizeof(longint),
'TAbDfInBitStream.ibsFillBuffer: the buffer should be almost empty');
{if there are still 1, 2, or three bytes unused, move them to the
front of the buffer}
Buffer := FBuffer;
while (FBufPos <> FBufEnd) do begin
Buffer^ := FBufPos^;
inc(FBufPos);
inc(Buffer);
end;
{fill the buffer}
BytesToRead := BitStreamBufferSize - (Buffer - FBuffer);
BytesRead := FStream.Read(Buffer^, BytesToRead);
{reset the internal pointers}
FBufPos := FBuffer;
FBufEnd := Buffer + BytesRead;
BufferCount := FBufEnd - FBuffer;
{if, as a result of the read, no data is in the buffer, return
false; the caller will decide what to do about the problem}
if (BufferCount = 0) then
Result := false
{otherwise there is data to be processed}
else begin
Result := true;
{if we didn't read anything from the stream, we need to make sure
that enough buffer is zeroed out so that reading longint values
don't produce (dreadfully) bogus values}
if (BytesRead = 0) and ((BufferCount mod 4) <> 0) then begin
FFakeCount := 4 - (BufferCount mod 4);
for i := 0 to pred(FFakeCount) do begin
FBufEnd^ := #0;
inc(FBufEnd);
end;
end;
{fire the progress event}
if Assigned(FOnProgress) then begin
inc(FByteCount, BytesRead);
Percent := Round((100.0 * FByteCount) / FStreamSize);
FOnProgress(Percent);
end;
end;
end;
{--------}
function TAbDfInBitStream.PeekBits(aCount : integer) : integer;
var
BitsToGo : integer;
TempBuffer : integer;
begin
{check that aCount is in the correct range 1..32}
Assert((0 <= aCount) and (aCount <= 32),
'TAbDfInBitStream.PeekBits: count of bits must be between 1 and 32 inclusive');
{if we have more than enough bits in our bit buffer, return as many
as needed}
if (aCount <= FBitsLeft) then
Result := FBitBuffer and AbExtractMask[aCount]
{otherwise we shall have to read another integer out of the buffer
to satisfy the request; note that this will fill the stream buffer
if required}
else begin
BitsToGo := aCount - FBitsLeft;
Result := FBitBuffer;
if ((FBufEnd - FBufPos) < sizeof(TAb32bit)) then
if not ibsFillBuffer then
TempBuffer := 0
else
TempBuffer := PAb32bit(FBufPos)^
else
TempBuffer := PAb32bit(FBufPos)^;
Result := Result +
((TempBuffer and AbExtractMask[BitsToGo]) shl FBitsLeft);
end;
{$IFOPT C+}
{save the number of bits peeked for an assertion check later}
FPeekCount := aCount;
{$ENDIF}
end;
{--------}
function TAbDfInBitStream.PeekMoreBits(aCount : integer) : integer;
var
BitsToGo : integer;
TempBuffer : integer;
begin
BitsToGo := aCount - FBitsLeft;
Result := FBitBuffer;
if ((FBufEnd - FBufPos) < sizeof(TAb32bit)) then
if not ibsFillBuffer then
TempBuffer := 0
else
TempBuffer := PAb32bit(FBufPos)^
else
TempBuffer := PAb32bit(FBufPos)^;
Result := Result +
((TempBuffer and AbExtractMask[BitsToGo]) shl FBitsLeft);
end;
{--------}
function TAbDfInBitStream.ReadBit : boolean;
begin
if (FBitsLeft = 0) then begin
if ((FBufEnd - FBufPos) < sizeof(TAb32bit)) then
if not ibsFillBuffer then
raise EAbInternalInflateError.Create(
'no more compressed data in stream [TAbDfInBitStream.ReadBit]');
FBitBuffer := PAb32bit(FBufPos)^;
inc(FBufPos, sizeof(TAb32bit));
FBitsLeft := 32;
end;
Result := Odd(FBitBuffer);
FBitBuffer := FBitBuffer shr 1;
dec(FBitsLeft);
end;
{--------}
function TAbDfInBitStream.ReadBits(aCount : integer) : integer;
var
BitsToGo : integer;
begin
{aCount comes from a (possibly corrupt) stream, so check that it is
the correct range, 1..16}
if (aCount <= 0) or (aCount > 16) then
raise EAbInternalInflateError.Create(
'count of bits must be between 1 and 16 inclusive [TAbDfInBitStream.ReadBits]');
{if we have more than enough bits in our bit buffer, return as many
as needed, and update the bitbuffer and the number of bits left}
if (aCount <= FBitsLeft) then begin
Result := FBitBuffer and AbExtractMask[aCount];
FBitBuffer := FBitBuffer shr aCount;
dec(FBitsLeft, aCount);
end
{if we have exactly enough bits in our bit buffer, return them all,
and update the bitbuffer and the number of bits left}
else if (aCount = FBitsLeft) then begin
Result := FBitBuffer;
FBitBuffer := 0;
FBitsLeft := 0;
end
{otherwise we shall have to read another integer out of the buffer
to satisfy the request}
else begin
BitsToGo := aCount - FBitsLeft;
Result := FBitBuffer;
if ((FBufEnd - FBufPos) < sizeof(TAb32bit)) then
if not ibsFillBuffer then
raise EAbInternalInflateError.Create(
'no more compressed data in stream [TAbDfInBitStream.ReadBits]');
FBitBuffer := PAb32bit(FBufPos)^;
inc(FBufPos, sizeof(TAb32bit));
Result := Result +
((FBitBuffer and AbExtractMask[BitsToGo]) shl FBitsLeft);
FBitBuffer := FBitBuffer shr BitsToGo;
FBitsLeft := 32 - BitsToGo;
end;
end;
{--------}
procedure TAbDfInBitStream.ReadBuffer(var aBuffer; aCount : integer);
var
i : integer;
Buffer : PAnsiChar;
BytesToRead : integer;
BytesInBuffer : integer;
begin
{this method is designed to read a set of bytes and this can only be
done if the stream has been byte aligned--if it isn't, it's a
programming error}
Assert((FBitsLeft mod 8) = 0,
'TAbDfInBitStream.ReadBuffer. cannot read a buffer unless the stream is byte-aligned');
{get the address of the user buffer as a PChar: easier arithmetic}
Buffer := @aBuffer;
{if we have some bits left in the bit buffer, we need to copy those
first}
if (FBitsLeft > 0) then begin
BytesToRead := FBitsLeft div 8;
for i := 0 to pred(BytesToRead) do begin
Buffer^ := AnsiChar(FBitBuffer and $FF);
inc(Buffer);
FBitBuffer := FBitBuffer shr 8;
end;
{calculate the count of bytes still to read}
dec(aCount, BytesToRead);
end;
{calculate the number of bytes to copy}
BytesInBuffer := FBufEnd - FBufPos;
if (aCount <= BytesInBuffer) then
BytesToRead := aCount
else
BytesToRead := BytesInBuffer;
{copy the data from our buffer to the user buffer}
Move(FBufPos^, Buffer^, BytesToRead);
{update variables}
dec(aCount, BytesToRead);
inc(FBufPos, BytesToRead);
{while there is still data to copy, keep on filling our internal
buffer and copy it to the user buffer}
while (aCount <> 0) do begin
{increment the user buffer pointer past the data just copied}
inc(Buffer, BytesToRead);
{fill our buffer}
if not ibsFillBuffer then
raise EAbInternalInflateError.Create(
'no more compressed data in stream [TAbDfInBitStream.ReadBuffer]');
{calculate the number of bytes to copy}
BytesInBuffer := FBufEnd - FBufPos;
if (aCount <= BytesInBuffer) then
BytesToRead := aCount
else
BytesToRead := BytesInBuffer;
{copy the data from our buffer to the user buffer}
Move(FBufPos^, Buffer^, BytesToRead);
{update variables}
dec(aCount, BytesToRead);
inc(FBufPos, BytesToRead);
end;
{now we've copied everything over, reset the bit variables: they're
empty and need refilling}
FBitBuffer := 0;
FBitsLeft := 0;
end;
{====================================================================}
{===TAbDfOutBitStream================================================}
constructor TAbDfOutBitStream.Create(aStream : TStream);
begin
{protect against dumb programming mistakes}
Assert(aStream <> nil,
'TAbDfOutBitStream.Create: Cannot create a bit stream wrapping a nil stream');
{create the ancestor}
inherited Create;
{save the stream instance, allocate the buffer}
FStream := aStream;
GetMem(FBuffer, BitStreamBufferSize);
FBufEnd := FBuffer + BitStreamBufferSize;
FBufPos := FBuffer;
end;
{--------}
destructor TAbDfOutBitStream.Destroy;
var
i : integer;
begin
{if the buffer was allocated...}
if (FBuffer <> nil) then begin
{if there are still some bits in the bit buffer...}
if (FBitsUsed <> 0) then begin
{pad the bit buffer to a byte boundary}
AlignToByte;
{empty the main buffer if there isn't enough room to copy over
the 1 to 4 bytes in the bit buffer}
if ((FBufEnd - FBufPos) < FBitsUsed div 8) then
obsEmptyBuffer;
{flush the bit buffer}
for i := 1 to (FBitsUsed div 8) do begin
FBufPos^ := AnsiChar(FBitBuffer);
FBitBuffer := FBitBuffer shr 8;
inc(FBufPos);
end;
end;
{if there is some data in the main buffer, empty it}
if (FBufPos <> FBuffer) then
obsEmptyBuffer;
{free the buffer}
FreeMem(FBuffer);
end;
{destroy the ancestor}
inherited Destroy;
end;
{--------}
procedure TAbDfOutBitStream.AlignToByte;
begin
{round up the number of bits used to the nearest 8}
FBitsUsed := (FBitsUsed + 7) and $F8;
{if the bit buffer is now full, flush it to the main buffer}
if (FBitsUsed = 32) then begin
if ((FBufEnd - FBufPos) < sizeof(TAb32bit)) then
obsEmptyBuffer;
PAb32bit(FBufPos)^ := FBitBuffer;
inc(FBufPos, sizeof(TAb32bit));
FBitBuffer := 0;
FBitsUsed := 0;
end;
end;
{--------}
procedure TAbDfOutBitStream.obsEmptyBuffer;
var
ByteCount : integer;
BytesWritten : longint;
begin
{empty the buffer}
ByteCount := FBufPos - FBuffer;
BytesWritten := FStream.Write(FBuffer^, ByteCount);
{if we couldn't write the correct number of bytes, it's an error}
if (BytesWritten <> ByteCount) then
raise EAbInternalDeflateError.Create(
'could not write to the output stream [TAbDfInBitStream.obsEmptyBuffer]');
{reset the pointers}
FBufPos := FBuffer;
end;
{--------}
function TAbDfOutBitStream.Position : longint;
begin
Assert(false,
'TAbDfOutBitStream.Position: not implemented yet!');
Result := -1;
end;
{--------}
procedure TAbDfOutBitStream.WriteBit(aBit : boolean);
begin
{only set the corresponding bit in the bit buffer if the passed bit
is set (the bit buffer is set to zero when emptied, so we don't
actually have to record clear bits)}
if aBit then
FBitBuffer := FBitBuffer or (1 shl FBitsUsed);
{we've now got one more bit}
inc(FBitsUsed);
{if the bit buffer is now full, flush it to the main buffer}
if (FBitsUsed = 32) then begin
if ((FBufEnd - FBufPos) < sizeof(TAb32bit)) then
obsEmptyBuffer;
PAb32bit(FBufPos)^ := FBitBuffer;
inc(FBufPos, sizeof(TAb32bit));
FBitBuffer := 0;
FBitsUsed := 0;
end;
end;
{--------}
procedure TAbDfOutBitStream.WriteBits(aBits : integer; aCount : integer);
begin
{protect against programming mistakes...}
{..the count should be in the range 1 to 16 (BTW, the latter is only
used once: Deflate64 with length symbol 258)}
Assert((0 < aCount) and (aCount <= 16),
'TAbDfOutBitStream.WriteBits: aCount should be from 1 to 16');
{..there shouldn't be more than aCount bits}
Assert((aBits shr aCount) = 0,
'TAbDfOutBitStream.WriteBits: aBits has more than aCount bits');
{copy as many bits as we can to the bit buffer}
FBitBuffer := FBitBuffer or (aBits shl FBitsUsed);
{increment the number of bits used}
inc(FBitsUsed, aCount);
{if we've overshot...}
if (FBitsUsed >= 32) then begin
{the bit buffer is now full, so flush it}
if ((FBufEnd - FBufPos) < sizeof(TAb32bit)) then
obsEmptyBuffer;
PAb32bit(FBufPos)^ := FBitBuffer;
inc(FBufPos, sizeof(TAb32bit));
{patch up the bit buffer and the number of bits used}
dec(FBitsUsed, 32);
FBitBuffer := aBits shr (aCount - FBitsUsed);
end;
end;
{--------}
procedure TAbDfOutBitStream.WriteBuffer(var aBuffer; aCount : integer);
var
Buffer : PAnsiChar;
BytesToCopy : integer;
begin
{guard against dumb programming errors: we must be byte aligned}
Assert((FBitsUsed and $7) = 0,
'TAbDfOutBitStream.WriteBuffer: must be byte aligned');
{use the user buffer as a PChar}
Buffer := @aBuffer;
{flush the bit buffer to the underlying stream}
while (FBitsUsed <> 0) do begin
if (FBufEnd = FBufPos) then
obsEmptyBuffer;
FBufPos^ := AnsiChar(FBitBuffer and $FF);
inc(FBufPos);
FBitBuffer := FBitBuffer shr 8;
dec(FBitsUsed, 8);
end;
{copy over the data to the underlying stream}
BytesToCopy := FBufEnd - FBufPos;
if (BytesToCopy > aCount) then
BytesToCopy := aCount;
Move(Buffer^, FBufPos^, BytesToCopy);
inc(FBufPos, BytesToCopy);
dec(aCount, BytesToCopy);
while (aCount <> 0) do begin
inc(Buffer, BytesToCopy);
obsEmptyBuffer;
BytesToCopy := FBufEnd - FBufPos;
if (BytesToCopy > aCount) then
BytesToCopy := aCount;
Move(Buffer^, FBufPos^, BytesToCopy);
inc(FBufPos, BytesToCopy);
dec(aCount, BytesToCopy);
end;
{finish with a flushed buffer}
obsEmptyBuffer;
end;
{--------}
procedure TAbDfOutBitStream.WriteMoreBits(aBits : integer; aCount : integer);
begin
{the bit buffer is now full, so flush it}
if ((FBufEnd - FBufPos) < sizeof(TAb32bit)) then
obsEmptyBuffer;
PAb32bit(FBufPos)^ := FBitBuffer;
inc(FBufPos, sizeof(TAb32bit));
{patch up the bit buffer and the number of bits used}
dec(FBitsUsed, 32);
FBitBuffer := aBits shr (aCount - FBitsUsed);
end;
{====================================================================}
{===TAbDfLZStream====================================================}
const
{Implementation note: this stream size has been chosen so that if
the data must be stored, a block size of about 64K will result}
StreamSize = 160 * 1024;
type
PWord = ^word;
{--------}
constructor TAbDfLZStream.Create(aSlideWin : TAbDfInputWindow;
aUseDeflate64 : boolean;
aLog : TAbLogger);
begin
{create the ancestor}
inherited Create;
{save the sliding window and the logger}
FSlideWin := aSlideWin;
FUseDeflate64 := aUseDeflate64;
FLog := aLog;
{create the buckets}
New(FDistBuckets);
New(FLitBuckets);
{create the memory stream, allocate its buffer, position at start}
GetMem(FStream, StreamSize);
Clear;
end;
{--------}
destructor TAbDfLZStream.Destroy;
begin
{free the buckets}
if (FDistBuckets <> nil) then
Dispose(FDistBuckets);
if (FLitBuckets <> nil) then
Dispose(FLitBuckets);
{free the memory stream}
if (FStream <> nil) then
FreeMem(FStream);
{destroy the ancestor}
inherited Destroy;
end;
{--------}
{$IFDEF UseLogging}
procedure AddLenDistToLog(aLog : TAbLogger;
aPosn : longint;
aLen : integer;
aDist : integer;
aOverLap : boolean);
begin
{NOTE the reason for this separate routine is to avoid string
allocations and try..finally blocks in the main method: an
optimization issue}
if aOverLap then
aLog.WriteLine(Format('%8x Len: %-3d, Dist: %-5d **overlap**',
[aPosn, aLen, aDist]))
else
aLog.WriteLine(Format('%8x Len: %-3d, Dist: %-5d',
[aPosn, aLen, aDist]));
end;
{$ENDIF}
{--------}
function TAbDfLZStream.AddLenDist(aLen : integer; aDist : integer)
: boolean;
var
LenSymbol : integer;
DistSymbol : integer;
CurPos : PAnsiChar;
begin
{$IFDEF UseLogging}
{log it}
if (FLog <> nil) then begin
if (aLen > aDist) then
AddLenDistToLog(FLog, FSWPos, aLen, aDist, true)
else
AddLenDistToLog(FLog, FSWPos, aLen, aDist, false);
inc(FSWPos, aLen);
end;
{$ENDIF}
{write a length/distance record to the stream}
CurPos := FCurPos;
CurPos^ := AnsiChar(false);
inc(CurPos);
PWord(CurPos)^ := word(aLen - 1);
inc(CurPos, sizeof(word));
PWord(CurPos)^ := word(aDist - 1);
inc(CurPos, sizeof(word));
FCurPos := CurPos;
{increment the various counters}
inc(FDistCount);
inc(FStoredSize, aLen);
{convert the length and distance to their symbols}
{$IFOPT C+} {if Assertions are on}
LenSymbol := AbSymbolTranslator.TranslateLength(aLen);
DistSymbol := AbSymbolTranslator.TranslateDistance(aDist);
{$ELSE}
if (3 <= aLen) and (aLen <= 258) then
LenSymbol := AbSymbolTranslator.LenSymbols[aLen-3] + 257
else
LenSymbol := 285;
if (aDist <= 256) then
DistSymbol := AbSymbolTranslator.ShortDistSymbols[aDist - 1]
else if (aDist <= 32768) then
DistSymbol := AbSymbolTranslator.MediumDistSymbols[((aDist - 1) div 128) - 2]
else
DistSymbol := AbSymbolTranslator.LongDistSymbols[((aDist - 1) div 16384) - 2];
{$ENDIF}
{increment the buckets}
inc(FLitBuckets^[LenSymbol]);
inc(FDistBuckets^[DistSymbol]);
{return whether the stream is full and needs encoding}
Result := lzsIsFull;
end;
{--------}
{$IFDEF UseLogging}
procedure AddLiteralToLog(aLog : TAbLogger;
aPosn : longint;
aCh : AnsiChar);
begin
{NOTE the reason for this separate routine is to avoid string
allocations and try..finally blocks in the main method: an
optimization issue}
if (' ' < aCh) and (aCh <= '~') then
aLog.WriteLine(Format('%8x Char: %3d $%2x [%s]', [aPosn, ord(aCh), ord(aCh), aCh]))
else
aLog.WriteLine(Format('%8x Char: %3d $%2x', [aPosn, ord(aCh), ord(aCh)]));
end;
{$ENDIF}
{--------}
function TAbDfLZStream.AddLiteral(aCh : AnsiChar) : boolean;
var
CurPos : PAnsiChar;
begin
{$IFDEF UseLogging}
{log it}
if (FLog <> nil) then begin
AddLiteralToLog(FLog, FSWPos, aCh);
inc(FSWPos);
end;
{$ENDIF}
{write a literal to the internal stream}
CurPos := FCurPos;
CurPos^ := AnsiChar(true);
inc(CurPos);
CurPos^ := aCh;
inc(CurPos);
FCurPos := CurPos;
{increment the various counters}
inc(FLitCount);
inc(FLitBuckets^[byte(aCh)]);
inc(FStoredSize);
{return whether the stream is full and needs encoding}
Result := lzsIsFull;
end;
{--------}
procedure TAbDfLZStream.Clear;
begin
{position the stream at the start}
Rewind;
{reset all variables}
FStrmEnd := nil;
FLitCount := 0;
FDistCount := 0;
FStartOfs := FSlideWin.Position;
FStoredSize := 0;
{$IFDEF UseLogging}
FSWPos := FStartOfs;
{$ENDIF}
{reset the buckets}
FillChar(FLitBuckets^, sizeof(FLitBuckets^), 0);
FLitBuckets^[256] := 1; { end-of-block marker: it's always there...}
FillChar(FDistBuckets^, sizeof(FDistBuckets^), 0);
end;
{--------}
procedure TAbDfLZStream.Encode(aBitStrm : TAbDfOutBitStream;
aLitTree : TAbDfDecodeHuffmanTree;
aDistTree : TAbDfDecodeHuffmanTree;
aUseDeflate64 : boolean);
var
Len : integer;
Dist : integer;
Symbol : integer;
CurPos : PAnsiChar;
StrmEnd : PAnsiChar;
Code : longint;
ExtraBits : longint;
begin
{rewind the LZ77 stream}
Rewind;
{for speed use local variables}
CurPos := FCurPos;
StrmEnd := FStrmEnd;
{while there are still items in the stream...}
while (CurPos < StrmEnd) do begin
{if the next item is a literal...}
if boolean(CurPos^) then begin
{encode the literal character as a symbol}
inc(CurPos);
{$IFOPT C+} {if Assertions are on}
Code := aLitTree.Encode(byte(CurPos^));
{$ELSE}
Code := aLitTree.Encodes^[byte(CurPos^)];
{$ENDIF}
inc(CurPos);
{write the code out to the bit stream}
{$IFOPT C+}
aBitStrm.WriteBits(Code and $FFFF, (Code shr 16) and $FF);
{$ELSE}
with aBitStrm do begin
BitBuffer := BitBuffer or ((Code and $FFFF) shl BitsUsed);
BitsUsed := BitsUsed + ((Code shr 16) and $FF);
if (BitsUsed >= 32) then
WriteMoreBits(Code and $FFFF, (Code shr 16) and $FF);
end;
{$ENDIF}
end
{otherwise it's a length/distance pair}
else begin
{DO THE LENGTH FIRST-------------------------------------------}
{get the length from the stream}
inc(CurPos);
Len := integer(PWord(CurPos)^) + 1;
inc(CurPos, sizeof(word));
{translate it to a symbol and convert that to a code using the
literal/length huffman tree}
{$IFOPT C+} {if Assertions are on}
Symbol := AbSymbolTranslator.TranslateLength(Len);
Code := aLitTree.Encode(Symbol);
{$ELSE}
if (3 <= Len) and (Len <= 258) then
Symbol := AbSymbolTranslator.LenSymbols[Len-3] + 257
else
Symbol := 285;
Code := aLitTree.Encodes^[Symbol];
{$ENDIF}
{output the length code}
{$IFOPT C+}
aBitStrm.WriteBits(Code and $FFFF, (Code shr 16) and $FF);
{$ELSE}
with aBitStrm do begin
BitBuffer := BitBuffer or ((Code and $FFFF) shl BitsUsed);
BitsUsed := BitsUsed + ((Code shr 16) and $FF);
if (BitsUsed >= 32) then
WriteMoreBits(Code and $FFFF, (Code shr 16) and $FF);
end;
{$ENDIF}
{if the length symbol were 285, its definition changes from Deflate
to Deflate64, so make it a special case: for Deflate there are no
extra bits, for Deflate64 output the (length - 3) as 16 bits}
if (Symbol = 285) then begin
if aUseDeflate64 then begin
{$IFOPT C+}
aBitStrm.WriteBits(Len - 3, 16);
{$ELSE}
with aBitStrm do begin
BitBuffer := BitBuffer or ((Len - 3) shl BitsUsed);
BitsUsed := BitsUsed + 16;
if (BitsUsed >= 32) then
WriteMoreBits(Len - 3, 16);
end;
{$ENDIF}
end;
end
{otherwise if there are extra bits to be output for this length,
calculate them and output them}
else begin
ExtraBits := Code shr 24;
if (ExtraBits <> 0) then begin
{$IFOPT C+}
aBitStrm.WriteBits((Len - dfc_LengthBase[Symbol - 257]),
ExtraBits);
{$ELSE}
with aBitStrm do begin
BitBuffer := BitBuffer or
((Len - dfc_LengthBase[Symbol - 257]) shl BitsUsed);
BitsUsed := BitsUsed + ExtraBits;
if (BitsUsed >= 32) then
WriteMoreBits((Len - dfc_LengthBase[Symbol - 257]),
ExtraBits);
end;
{$ENDIF}
end;
end;
{DO THE DISTANCE NEXT------------------------------------------}
{get the distance from the stream}
Dist := integer(PWord(CurPos)^) + 1;
inc(CurPos, sizeof(word));
{translate it to a symbol and convert that to a code using the
distance huffman tree}
{$IFOPT C+} {if Assertions are on}
Symbol := AbSymbolTranslator.TranslateDistance(Dist);
Assert(aUseDeflate64 or (Symbol < 30),
'TAbDfLZStream.Encode: a Deflate64 distance symbol has been generated for Deflate');
Code := aDistTree.Encode(Symbol);
{$ELSE}
if (Dist <= 256) then
Symbol := AbSymbolTranslator.ShortDistSymbols[Dist - 1]
else if (Dist <= 32768) then
Symbol := AbSymbolTranslator.MediumDistSymbols[((Dist - 1) div 128) - 2]
else
Symbol := AbSymbolTranslator.LongDistSymbols[((Dist - 1) div 16384) - 2];
Code := aDistTree.Encodes^[Symbol];
{$ENDIF}
{output the distance code}
{$IFOPT C+}
aBitStrm.WriteBits(Code and $FFFF, (Code shr 16) and $FF);
{$ELSE}
with aBitStrm do begin
BitBuffer := BitBuffer or ((Code and $FFFF) shl BitsUsed);
BitsUsed := BitsUsed + ((Code shr 16) and $FF);
if (BitsUsed >= 32) then
WriteMoreBits(Code and $FFFF, (Code shr 16) and $FF);
end;
{$ENDIF}
{if there are extra bits to be output for this distance, calculate
them and output them}
ExtraBits := Code shr 24;
if (ExtraBits <> 0) then begin
{$IFOPT C+}
aBitStrm.WriteBits((Dist - dfc_DistanceBase[Symbol]),
ExtraBits);
{$ELSE}
with aBitStrm do begin
BitBuffer := BitBuffer or
((Dist - dfc_DistanceBase[Symbol]) shl BitsUsed);
BitsUsed := BitsUsed + ExtraBits;
if (BitsUsed >= 32) then
WriteMoreBits((Dist - dfc_DistanceBase[Symbol]),
ExtraBits);
end;
{$ENDIF}
end;
end;
end;
{clear the stream; ready for some more items}
{ Clear;}
end;
{--------}
function TAbDfLZStream.lzsGetApproxSize : LongWord;
var
i : integer;
begin
{note: calculates an approximate compressed size without taking too
long about it. The average encoded bit length for literals
and lengths is assumed to be 8. Distances are assumed to
follow the static tree definition (ie, 5 bits per distance,
plus any extra bits).
There are FLitCount literals, FDistCount lengths, and
FDistCount distances}
Result := (13 * FDistCount) + (8 * FLitCount);
for i := 4 to 31 do
inc(Result, FDistBuckets^[i] * dfc_DistExtraBits[i]);
Result := Result div 8;
end;
{--------}
function TAbDfLZStream.lzsGetStaticSize : integer;
var
i : integer;
begin
Result := 0;
for i := 0 to 143 do
inc(Result, FLitBuckets^[i] * 8);
for i := 144 to 255 do
inc(Result, FLitBuckets^[i] * 9);
inc(Result, FLitBuckets^[256] * 7);
for i := 257 to 279 do
inc(Result, FLitBuckets^[i] *
(7 + dfc_LitExtraBits[i - dfc_LitExtraOffset]));
for i := 280 to 284 do
inc(Result, FLitBuckets^[i] *
(8 + dfc_LitExtraBits[i - dfc_LitExtraOffset]));
if FUseDeflate64 then
inc(Result, FLitBuckets^[285] * (8 + 16))
else
inc(Result, FLitBuckets^[285] * 8);
for i := 0 to 31 do
inc(Result, FDistBuckets^[i] * (5 + dfc_DistExtraBits[i]));
end;
{--------}
function TAbDfLZStream.lzsGetStoredSize : integer;
begin
Result := FStoredSize;
{Result := FSlideWin.Position - FStartOfs;}
end;
{--------}
function TAbDfLZStream.lzsIsFull : boolean;
begin
{if the number of hits on the (eventual) literal tree is a multiple
of 8192, the stream is full if the majority were straight literals
and we're getting approx 50% compression}
if (((FLitCount + FDistCount) and $1FFF) = 0) then begin
Result := (FDistCount < FLitCount) and
(lzsGetApproxSize < (FStoredSize div 2));
if Result then
Exit;
end;
{otherwise the stream is full if the number of hits on the literal
tree or on the distance tree is 32768}
{ Result := (FCurPos - FStream) > (StreamSIze - 100);}
Result := (FDistCount >= 32768) or
((FLitCount + FDistCount) >= 32768);
end;
{--------}
procedure TAbDfLZStream.ReadStoredBuffer(var aBuffer; aCount : integer);
begin
FSlideWin.ReadBuffer(aBuffer, aCount, FStartOfs);
inc(FStartOfs, aCount);
end;
{--------}
procedure TAbDfLZStream.Rewind;
begin
{position the stream at the beginning}
FStrmEnd := FCurPos;
FCurPos := FStream;
end;
{====================================================================}
{===TAbDfCodeLenStream===============================================}
constructor TAbDfCodeLenStream.Create(aLog : TAbLogger);
begin
{create the ancestor}
inherited Create;
{allocate the stream (to contain all literals and distances and
possible extra data}
GetMem(FStream, (285 + 32) * 2);
FPosition := FStream;
{allocate the buckets}
FBuckets := AllocMem(sizeof(TAbDfCodeLenBuckets));
end;
{--------}
destructor TAbDfCodeLenStream.Destroy;
begin
{free the stream}
if (FStream <> nil) then
FreeMem(FStream);
{free the buckets}
if (FBuckets <> nil) then
Dispose(FBuckets);
{destroy the ancestor}
inherited Destroy;
end;
{--------}
procedure TAbDfCodeLenStream.Build(const aCodeLens : array of integer;
aCount : integer);
var
i : integer;
State : (ScanStart, ScanNormal, Got2nd, Got3rd);
Count : integer;
ThisCount : integer;
CodeLen : integer;
PrevCodeLen : integer;
CurPos : PAnsiChar;
Buckets : PAbDfCodeLenBuckets;
begin
{start the automaton}
State := ScanStart;
CurPos := FStream;
Buckets := FBuckets;
Count := 0;
PrevCodeLen := 0;
{for all the codelengths in the array (plus a fake one at the end to
ensure all codeslengths are counted)...}
for i := 0 to aCount do begin
{get the current codelength}
if (i = aCount) then
CodeLen := -1
else
CodeLen := aCodeLens[i];
{switch based on the state...}
case State of
ScanStart :
begin
PrevCodeLen := CodeLen;
State := ScanNormal;
end;
ScanNormal :
begin
{if the current code is the same as the previous, move to
the next state}
if (CodeLen = PrevCodeLen) then
State := Got2nd
{otherwise output the previous code}
else begin
CurPos^ := AnsiChar(PrevCodeLen);
inc(CurPos);
inc(Buckets^[PrevCodeLen]);
PrevCodeLen := CodeLen;
end;
end;
Got2nd :
begin
{if the current code is the same as the previous, move to
the next state; we now have three similar codes in a row}
if (CodeLen = PrevCodeLen) then begin
State := Got3rd;
Count := 3;
end
{otherwise output the previous two similar codes, move back
to the initial state}
else begin
CurPos^ := AnsiChar(PrevCodeLen);
inc(CurPos);
CurPos^ := AnsiChar(PrevCodeLen);
inc(CurPos);
inc(Buckets^[PrevCodeLen], 2);
PrevCodeLen := CodeLen;
State := ScanNormal;
end;
end;
Got3rd:
begin
{if the current code is the same as the previous, increment
the count of similar codes}
if (CodeLen = PrevCodeLen) then
inc(Count)
{otherwise we need to output the repeat values...}
else begin
{if the previous code were a zero code...}
if (PrevCodeLen = 0) then begin
{while there are zero codes to be output...}
while (Count <> 0) do begin
{if there are less than three zero codes, output them
individually}
if (Count < 3) then begin
while (Count <> 0) do begin
CurPos^ := #0;
inc(CurPos);
inc(Buckets^[0]);
dec(Count);
end;
end
{if there are less than 11 successive zero codes,
output a 17 code and the count of zeros}
else if (Count < 11) then begin
CurPos^ := #17;
inc(CurPos);
inc(Buckets^[17]);
CurPos^ := AnsiChar(Count - 3);
inc(CurPos);
Count := 0;
end
{otherwise output an 18 code and the count of zeros}
else begin
ThisCount := Count;
if (ThisCount > 138) then
ThisCount := 138;
CurPos^ := #18;
inc(CurPos);
inc(Buckets^[18]);
CurPos^ := AnsiChar(ThisCount - 11);
inc(CurPos);
dec(Count, ThisCount);
end;
end;
end
{otherwise the previous code was a non-zero code...}
else begin
{output the first code}
CurPos^ := AnsiChar(PrevCodeLen);
inc(CurPos);
inc(Buckets^[PrevCodeLen]);
dec(Count);
{while there are more codes to be output...}
while (Count <> 0) do begin
{if there are less than three codes, output them
individually}
if (Count < 3) then begin
while (Count <> 0) do begin
CurPos^ := AnsiChar(PrevCodeLen);
inc(CurPos);
inc(Buckets^[PrevCodeLen]);
dec(Count);
end;
end
{otherwise output an 16 code and the count}
else begin
ThisCount := Count;
if (ThisCount > 6) then
ThisCount := 6;
CurPos^ := #16;
inc(CurPos);
inc(Buckets^[16]);
CurPos^ := AnsiChar(ThisCount - 3);
inc(CurPos);
dec(Count, ThisCount);
end;
end;
end;
{move back to the initial state}
PrevCodeLen := CodeLen;
State := ScanNormal;
end;
end;
end;
end;
{set the read position}
FStrmEnd := CurPos;
FPosition := FStream;
end;
{--------}
procedure TAbDfCodeLenStream.Encode(aBitStrm : TAbDfOutBitStream;
aTree : TAbDfDecodeHuffmanTree);
var
Symbol : integer;
ExtraData : integer;
Code : longint;
CurPos : PAnsiChar;
StrmEnd : PAnsiChar;
begin
{prepare for the loop}
CurPos := FPosition;
StrmEnd := FStrmEnd;
{while there are tokens in the stream...}
while (CurPos <> StrmEnd) do begin
{get the next symbol}
Symbol := ord(CurPos^);
inc(CurPos);
{if the symbol is 0..15, get the code and output it}
if (Symbol <= 15) then begin
{$IFOPT C+} {if Assertions are on}
Code := aTree.Encode(Symbol);
{$ELSE}
Code:= aTree.Encodes^[Symbol];
{$ENDIF}
aBitStrm.WriteBits(Code and $FFFF, (Code shr 16) and $FF);
end
{otherwise the symbol is 16, 17, or 18}
else begin
{get the extra data}
ExtraData := ord(CurPos^);
inc(CurPos);
{get the code and output it}
{$IFOPT C+} {if Assertions are on}
Code := aTree.Encode(Symbol);
{$ELSE}
Code:= aTree.Encodes^[Symbol];
{$ENDIF}
aBitStrm.WriteBits(Code and $FFFF, (Code shr 16) and $FF);
if (Symbol = 16) then
aBitStrm.WriteBits(ExtraData, 2)
else if (Symbol = 17) then
aBitStrm.WriteBits(ExtraData, 3)
else {Symbol = 18}
aBitStrm.WriteBits(ExtraData, 7);
end;
end;
end;
{====================================================================}
end.
================================================
FILE: lib/abbrevia/source/AbDfXlat.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfXlat.pas *}
{*********************************************************}
{* Deflate length/dist to symbol translator *}
{*********************************************************}
unit AbDfXlat;
{$I AbDefine.inc}
interface
uses
SysUtils;
type
TAbDfTranslator = class
private
FBuffer : PAnsiChar;
FLenSymbols : PByteArray;
{for lengths 3..258}
FLongDistSymbols : PByteArray;
{for distances 32769..65536 (deflate64)}
FMediumDistSymbols : PByteArray;
{for distances 257..32768}
FShortDistSymbols : PByteArray;
{for distances 1..256}
protected
procedure trBuild;
public
constructor Create;
destructor Destroy; override;
function TranslateLength(aLen : integer): integer;
function TranslateDistance(aDist : integer) : integer;
property LenSymbols : PByteArray read FLenSymbols;
property LongDistSymbols : PByteArray read FLongDistSymbols;
property MediumDistSymbols : PByteArray read FMediumDistSymbols;
property ShortDistSymbols : PByteArray read FShortDistSymbols;
end;
var
AbSymbolTranslator : TAbDfTranslator;
implementation
uses
AbDfBase;
{====================================================================}
constructor TAbDfTranslator.Create;
begin
{create the ancestor}
inherited Create;
{allocate the translation arrays (the buffer *must* be zeroed)}
FBuffer := AllocMem(256 + 2 + 256 + 256);
FLenSymbols := PByteArray(FBuffer);
FLongDistSymbols := PByteArray(FBuffer + 256);
FMediumDistSymbols := PByteArray(FBuffer + 256 + 2);
FShortDistSymbols := PByteArray(FBuffer + 256 + 2 + 256);
{build the translation arrays}
trBuild;
end;
{--------}
destructor TAbDfTranslator.Destroy;
begin
if (FBuffer <> nil) then
FreeMem(FBuffer);
inherited Destroy;
end;
{--------}
function TAbDfTranslator.TranslateDistance(aDist : integer) : integer;
begin
{save against dumb programming mistakes}
Assert((1 <= aDist) and (aDist <= 65536),
'TAbDfTranslator.Translate: distance should be 1..65536');
{translate the distance}
if (aDist <= 256) then
Result := FShortDistSymbols[aDist - 1]
else if (aDist <= 32768) then
Result := FMediumDistSymbols[((aDist - 1) div 128) - 2]
else
Result := FLongDistSymbols[((aDist - 1) div 16384) - 2];
end;
{--------}
function TAbDfTranslator.TranslateLength(aLen : integer): integer;
begin
{save against dumb programming mistakes}
Assert((3 <= aLen) and (aLen <= 65536),
'TAbDfTranslator.Translate: length should be 3..65536');
{translate the length}
dec(aLen, 3);
if (0 <= aLen) and (aLen <= 255) then
Result := FLenSymbols[aLen] + 257
else
Result := 285;
end;
{--------}
procedure TAbDfTranslator.trBuild;
var
i : integer;
Len : integer;
Dist : integer;
Value : integer;
begin
{initialize the length translation array; elements will contain
(Symbol - 257) for a given (length - 3)}
for i := low(dfc_LengthBase) to pred(high(dfc_LengthBase)) do begin
Len := dfc_LengthBase[i] - 3;
FLenSymbols[Len] := i;
end;
FLenSymbols[255] := 285 - 257;
Value := -1;
for i := 0 to 255 do begin
if (Value < FLenSymbols[i]) then
Value := FLenSymbols[i]
else
FLenSymbols[i] := Value;
end;
{initialize the short distance translation array: it will contain
the Symbol for a given (distance - 1) where distance <= 256}
for i := 0 to 15 do begin
Dist := dfc_DistanceBase[i] - 1;
FShortDistSymbols[Dist] := i;
end;
Value := -1;
for i := 0 to 255 do begin
if (Value < FShortDistSymbols[i]) then
Value := FShortDistSymbols[i]
else
FShortDistSymbols[i] := Value;
end;
{initialize the medium distance translation array: it will contain
the Symbol for a given (((distance - 1) div 128) - 2) where
distance is in the range 256..32768}
for i := 16 to 29 do begin
Dist := ((dfc_DistanceBase[i] - 1) div 128) - 2;
FMediumDistSymbols[Dist] := i;
end;
Value := -1;
for i := 0 to 255 do begin
if (Value < FMediumDistSymbols[i]) then
Value := FMediumDistSymbols[i]
else
FMediumDistSymbols[i] := Value;
end;
{initialize the long distance translation array: it will contain the
Symbol for a given ((distance - 1) div 16384) - 2) for distances
over 32768 in deflate64}
FLongDistSymbols[0] := 30;
FLongDistSymbols[1] := 31;
end;
{====================================================================}
initialization
AbSymbolTranslator := TAbDfTranslator.Create;
finalization
AbSymbolTranslator.Free;
end.
================================================
FILE: lib/abbrevia/source/AbDlgDir.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDlgDir.pas *}
{*********************************************************}
{* ABBREVIA: Dialog - Directory *}
{* Use AbQDgDir.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
unit AbDlgDir;
{$ENDIF}
{$I AbDefine.inc}
interface
uses
{$IFDEF MSWINDOWS}
Windows, Messages, ShlObj, ActiveX,
{$ENDIF}
SysUtils, Classes,
{$IFDEF UsingClx}
QButtons, QExtCtrls, QGraphics, QForms, QControls, QStdCtrls,
{$ELSE}
Buttons, ExtCtrls, Graphics, Forms, Controls, StdCtrls,
{$WARN UNIT_PLATFORM OFF}
FileCtrl,
{$WARN UNIT_PLATFORM ON}
{$ENDIF}
AbResString;
type
{$IFNDEF UsingClx}
TDirDlg = class(TForm)
OKBtn: TButton;
CancelBtn: TButton;
Bevel1: TBevel;
DriveComboBox1: TDriveComboBox;
DirectoryListBox1: TDirectoryListBox;
Panel1: TPanel;
procedure DirectoryListBox1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
public
SelectedFolder: string;
end;
{$ELSE}
TDirDlg = class(TForm)
OKBtn: TButton;
CancelBtn: TButton;
Bevel1: TBevel;
Panel1: TPanel;
procedure DirectoryListBox1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
public
SelectedFolder: string;
end;
{$ENDIF}
{$IFDEF MSWINDOWS}
type
TAbDirDlg = class(TComponent)
protected {private}
FAdditionalText : string;
FCaption : string;
FHandle : Integer;
FIDList : PItemIDList;
FSelectedFolder : string;
procedure SetSelectedFolder(const Value : string);
procedure FreeIDList;
public {properties}
property AdditionalText : string
read FAdditionalText
write FAdditionalText;
property Caption : string
read FCaption
write FCaption;
property Handle : Integer
read FHandle;
property IDList : PItemIDList
read FIDList;
property SelectedFolder : string
read FSelectedFolder
write SetSelectedFolder;
public {methods}
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
function Execute : Boolean;
end;
{$ENDIF}
var
DirDlg: TDirDlg;
implementation
{$IFNDEF UsingCLX}
{$R *.dfm}
{$ENDIF}
{== TAbDirDlg ========================================================}
{$IFDEF MSWINDOWS}
function AbDirDlgCallbackProc(hWnd : HWND; Msg : UINT; lParam : LPARAM;
Data : LPARAM): Integer; stdcall;
var
X, Y : Integer;
R : TRect;
Buf : array[0..MAX_PATH-1] of Char;
begin
Result := 0;
with TAbDirDlg(Data) do begin
case Msg of
BFFM_INITIALIZED :
begin
FHandle := hWnd;
if (FCaption <> '') then
SendMessage(hWnd, WM_SETTEXT, 0, Integer(PChar(FCaption)));
SendMessage(hWnd, BFFM_SETSELECTION, 1, Integer(PChar(SelectedFolder)));
GetWindowRect(hWnd, R);
X := (Screen.Width div 2) - ((R.Right - R.Left) div 2);
Y := (Screen.Height div 2) - ((R.Bottom - R.Top) div 2);
SetWindowPos(hWnd, 0, X, Y, 0, 0, SWP_NOSIZE or SWP_NOZORDER);
end;
BFFM_SELCHANGED :
if (FHandle <> 0) then begin
FIDList := PItemIDList(lParam);
SHGetPathFromIDList(IDList, Buf);
SelectedFolder := Buf;
end;
end;
end;
end;
{ -------------------------------------------------------------------------- }
constructor TAbDirDlg.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
end;
{ -------------------------------------------------------------------------- }
destructor TAbDirDlg.Destroy;
begin
if FIDList <> nil then
FreeIDList;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
function TAbDirDlg.Execute : Boolean;
var
Info : TBrowseInfo;
Buf : array[0..MAX_PATH-1] of Char;
begin
if (FIDList <> nil) then
FreeIDList;
{$IFNDEF UsingClx}
if (Owner is TWinControl) then
Info.hwndOwner := (Owner as TWinControl).Handle
else if Owner is TApplication then
Info.hwndOwner := (Owner as TApplication).Handle
else
{$ENDIF}
Info.hwndOwner := 0;
Info.pidlRoot := nil;
Info.pszDisplayName := Buf;
Info.lpszTitle := PChar(FAdditionalText);
Info.ulFlags := BIF_RETURNONLYFSDIRS;
Info.lpfn := AbDirDlgCallbackProc;
Info.lParam := Integer(Self);
Info.iImage := 0;
FIDList := SHBrowseForFolder(Info);
FHandle := 0;
Result := (FIDList <> nil);
end;
{ -------------------------------------------------------------------------- }
procedure TAbDirDlg.FreeIDList;
var
Malloc : IMalloc;
begin
if coGetMalloc(MEMCTX_TASK, Malloc) = NOERROR then begin
Malloc.Free(FIDList);
FIDList := nil;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbDirDlg.SetSelectedFolder(const Value : string);
begin
FSelectedFolder := Value;
if FSelectedFolder <> '' then
if FSelectedFolder[Length(FSelectedFolder)] = '\' then
Delete(FSelectedFolder, Length(FSelectedFolder), 1);
if (Length(FSelectedFolder) = 2) then
FSelectedFolder := FSelectedFolder + '\';
end;
{$ENDIF}
{== TDirDlg ========================================================}
{ TDirDlg }
procedure TDirDlg.FormCreate(Sender: TObject);
begin
DirectoryListBox1Change(nil);
OKBtn.Caption := AbOKS;
CancelBtn.Caption := AbCancelS;
Caption := AbSelectDirectoryS;
end;
{ -------------------------------------------------------------------------- }
procedure TDirDlg.DirectoryListBox1Change(Sender: TObject);
begin
{$IFNDEF UsingClx}
SelectedFolder := DirectoryListBox1.Directory;
{$ENDIF}
Panel1.Caption := SelectedFolder;
end;
end.
================================================
FILE: lib/abbrevia/source/AbDlgPwd.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDlgPwd.pas *}
{*********************************************************}
{* ABBREVIA: Dialog - Password *}
{* Use AbQDgPwd.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
unit AbDlgPwd;
{$R *.dfm}
{$ENDIF}
{$I AbDefine.inc}
interface
uses
SysUtils,
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
{$IFDEF LibcAPI}
Libc,
{$ENDIF}
{$IFDEF UsingClx}
QGraphics, QForms, QControls, QStdCtrls,
QButtons, QExtCtrls,
{$ELSE}
Graphics, Forms, Controls, StdCtrls,
Buttons, ExtCtrls,
{$ENDIF}
Classes;
type
TPassWordDlg = class(TForm)
OKBtn: TButton;
CancelBtn: TButton;
Bevel1: TBevel;
Edit1: TEdit;
{$IFDEF MSWINDOWS}
Edit2: TEdit;
{$ENDIF}
Label1: TLabel;
{$IFDEF MSWINDOWS}
Label2: TLabel;
{$ENDIF}
procedure Edit1Change(Sender: TObject);
procedure Edit2Change(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
PassWordDlg: TPassWordDlg;
implementation
uses
AbResString;
procedure TPassWordDlg.Edit1Change(Sender: TObject);
begin
{$IFDEF MSWINDOWS}
Edit2.Text := '';
OKBtn.Enabled := ( CompareStr( Edit1.Text, Edit2.Text ) = 0);
{$ELSE}
OKBtn.Enabled := true;
{$ENDIF}
end;
procedure TPassWordDlg.Edit2Change(Sender: TObject);
begin
{$IFDEF MSWINDOWS}
OKBtn.Enabled := ( CompareStr( Edit1.Text, Edit2.Text ) = 0);
{$ELSE}
OKBtn.Enabled := true;
{$ENDIF}
end;
procedure TPassWordDlg.FormActivate(Sender: TObject);
begin
{$IFDEF MSWINDOWS}
OKBtn.Enabled := ( CompareStr( Edit1.Text, Edit2.Text ) = 0);
{$ELSE}
OKBtn.Enabled := true;
{$ENDIF}
end;
procedure TPassWordDlg.FormCreate(Sender: TObject);
begin
Caption := AbEnterPasswordS;
OKBtn.Caption := AbOKS;
CancelBtn.Caption := AbCancelS;
Label1.Caption := AbPasswordS;
{$IFDEF MSWINDOWS}
Label2.Caption := AbVerifyS;
{$ENDIF}
end;
end.
================================================
FILE: lib/abbrevia/source/AbExcept.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbExcept.pas *}
{*********************************************************}
{* ABBREVIA: Exception classes *}
{*********************************************************}
unit AbExcept;
{$I AbDefine.inc}
interface
uses
SysUtils,
AbUtils;
type
EAbException = class( Exception )
public
ErrorCode : Integer;
end;
EAbArchiveBusy = class( EAbException )
public
constructor Create;
end;
EAbBadStream = class( EAbException )
protected
FInnerException : Exception;
public
constructor Create;
constructor CreateInner(aInnerException : Exception);
property InnerException : Exception read FInnerException;
end;
EAbDuplicateName = class( EAbException )
public
constructor Create;
end;
EAbFileNotFound = class( EAbException )
public
constructor Create;
end;
EAbNoArchive = class( EAbException )
public
constructor Create;
end;
EAbUserAbort = class( EAbException )
public
constructor Create;
end;
EAbNoSuchDirectory = class( EAbException )
public
constructor Create;
end;
EAbUnhandledType = class( EAbException )
public
constructor Create;
end;
EAbSpanningNotSupported = class (EAbException)
public
constructor Create;
end;
EAbInvalidSpanningThreshold = class ( EAbException )
public
constructor Create;
end;
EAbZipException = class( EAbException ); {Zip exception}
EAbCabException = class( EAbException ); {Cab exception}
EAbTarException = class( EAbException ); {Tar Exception}
EAbGzipException = class( EAbException); {GZip exception}
EAbZipBadSpanStream = class( EAbZipException )
public
constructor Create;
end;
EAbZipBadCRC = class( EAbZipException )
public
constructor Create;
end;
EAbZipInflateBlock = class( EAbZipException )
public
constructor Create;
end;
EAbZipInvalid = class( EAbZipException )
public
constructor Create;
end;
EAbInvalidIndex = class( EAbZipException )
public
constructor Create;
end;
EAbZipInvalidFactor = class( EAbZipException )
public
constructor Create;
end;
EAbZipInvalidLFH = class( EAbZipException )
public
constructor Create;
end;
EAbZipInvalidMethod = class( EAbZipException )
public
constructor Create;
end;
EAbZipInvalidPassword = class( EAbZipException )
public
constructor Create;
end;
EAbZipInvalidStub= class( EAbZipException )
public
constructor Create;
end;
EAbZipNoExtraction = class( EAbZipException )
public
constructor Create;
end;
EAbZipNoInsertion = class( EAbZipException )
public
constructor Create;
end;
EAbZipSpanOverwrite= class( EAbZipException )
public
constructor Create;
end;
EAbZipStreamFull = class( EAbZipException )
public
constructor Create;
end;
EAbZipTruncate = class( EAbZipException )
public
constructor Create;
end;
EAbZipUnsupported = class( EAbZipException )
public
constructor Create;
end;
EAbZipVersion = class( EAbZipException )
public
constructor Create;
end;
EAbReadError = class( EAbZipException )
public
constructor Create;
end;
EAbGzipBadCRC = class( EAbGZipException )
public
constructor Create;
end;
EAbGzipBadFileSize = class( EAbGZipException )
public
constructor Create;
end;
EAbGzipInvalid = class( EAbGZipException )
public
constructor Create;
end;
EAbTarInvalid = class( EAbTarException)
public
constructor Create;
end;
EAbTarBadFileName = class( EAbTarException)
public
constructor Create;
end;
EAbTarBadLinkName = class( EAbTarException)
public
constructor Create;
end;
EAbTarBadOp = class( EAbTarException)
public
constructor Create;
end;
EAbVMSInvalidOrigin = class( EAbZipException )
public
constructor Create( Value : Integer );
end;
EAbVMSErrorOpenSwap = class( EAbZipException )
public
constructor Create( const Value : string );
end;
EAbVMSSeekFail = class( EAbZipException )
public
constructor Create( const Value : string );
end;
EAbVMSReadFail = class( EAbZipException )
public
constructor Create( Count : Integer; const Value : string );
end;
EAbVMSWriteFail = class( EAbZipException )
public
constructor Create( Count : Integer; const Value : string );
end;
EAbVMSWriteTooManyBytes = class( EAbZipException )
public
constructor Create( Count : Integer );
end;
EAbBBSReadTooManyBytes = class( EAbZipException )
public
constructor Create(Count : Integer );
end;
EAbBBSSeekOutsideBuffer = class( EAbZipException )
public
constructor Create;
end;
EAbBBSInvalidOrigin = class( EAbZipException )
public
constructor Create;
end;
EAbBBSWriteTooManyBytes = class( EAbZipException )
public
constructor Create(Count : Integer );
end;
EAbSWSNotEndofStream = class( EAbZipException )
public
constructor Create;
end;
EAbSWSSeekFailed = class( EAbZipException )
public
constructor Create;
end;
EAbSWSWriteFailed = class( EAbZipException )
public
constructor Create;
end;
EAbSWSInvalidOrigin = class( EAbZipException )
public
constructor Create;
end;
EAbSWSInvalidNewOrigin = class( EAbZipException )
public
constructor Create;
end;
EAbNoCabinetDll = class( EAbCabException )
public
constructor Create;
end;
EAbFCIFileOpenError = class( EAbCabException )
public
constructor Create;
end;
EAbFCIFileReadError = class( EAbCabException )
public
constructor Create;
end;
EAbFCIFileWriteError = class( EAbCabException )
public
constructor Create;
end;
EAbFCIFileCloseError = class( EAbCabException )
public
constructor Create;
end;
EAbFCIFileSeekError = class( EAbCabException )
public
constructor Create;
end;
EAbFCIFileDeleteError = class( EAbCabException )
public
constructor Create;
end;
EAbFCIAddFileError = class( EAbCabException )
public
constructor Create;
end;
EAbFCICreateError = class( EAbCabException )
public
constructor Create;
end;
EAbFCIFlushCabinetError = class( EAbCabException )
public
constructor Create;
end;
EAbFCIFlushFolderError = class( EAbCabException )
public
constructor Create;
end;
EAbFDICopyError = class( EAbCabException )
public
constructor Create;
end;
EAbFDICreateError = class( EAbCabException )
public
constructor Create;
end;
EAbInvalidCabTemplate = class( EAbCabException )
public
constructor Create;
end;
EAbInvalidCabFile = class( EAbCabException )
public
constructor Create;
end;
EAbFileTooLarge = class(EAbException)
public
constructor Create;
end;
procedure AbConvertException( const E : Exception;
var eClass : TAbErrorClass;
var eErrorCode : Integer );
implementation
uses
Classes,
AbConst,
AbResString;
constructor EAbArchiveBusy.Create;
begin
inherited Create(AbArchiveBusyS);
ErrorCode := AbArchiveBusy;
end;
constructor EAbBadStream.Create;
begin
inherited Create(AbBadStreamTypeS);
FInnerException := nil;
ErrorCode := AbBadStreamType;
end;
constructor EAbBadStream.CreateInner(aInnerException: Exception);
begin
inherited Create(AbBadStreamTypeS + #13#10 + aInnerException.Message);
FInnerException := aInnerException;
ErrorCode := AbBadStreamType;
end;
constructor EAbDuplicateName.Create;
begin
inherited Create(AbDuplicateNameS);
ErrorCode := AbDuplicateName;
end;
constructor EAbNoSuchDirectory.Create;
begin
inherited Create(AbNoSuchDirectoryS);
ErrorCode := AbNoSuchDirectory;
end;
constructor EAbInvalidSpanningThreshold.Create;
begin
inherited Create(AbInvalidThresholdS);
ErrorCode := AbInvalidThreshold;
end;
constructor EAbFileNotFound.Create;
begin
inherited Create(AbFileNotFoundS);
ErrorCode := AbFileNotFound;
end;
constructor EAbNoArchive.Create;
begin
inherited Create(AbNoArchiveS);
ErrorCode := AbNoArchive;
end;
constructor EAbUserAbort.Create;
begin
inherited Create(AbUserAbortS);
ErrorCode := AbUserAbort;
end;
constructor EAbZipBadSpanStream.Create;
begin
inherited Create(AbBadSpanStreamS);
ErrorCode := AbBadSpanStream;
end;
constructor EAbZipBadCRC.Create;
begin
inherited Create(AbZipBadCRCS);
ErrorCode := AbZipBadCRC;
end;
constructor EAbZipInflateBlock.Create;
begin
inherited Create(AbInflateBlockErrorS);
ErrorCode := AbInflateBlockError;
end;
constructor EAbZipInvalid.Create;
begin
inherited Create(AbErrZipInvalidS);
ErrorCode := AbErrZipInvalid;
end;
constructor EAbInvalidIndex.Create;
begin
inherited Create(AbInvalidIndexS);
ErrorCode := AbInvalidIndex;
end;
constructor EAbZipInvalidFactor.Create;
begin
inherited Create(AbInvalidFactorS);
ErrorCode := AbInvalidFactor;
end;
constructor EAbZipInvalidLFH.Create;
begin
inherited Create(AbInvalidLFHS);
ErrorCode := AbInvalidLFH;
end;
constructor EAbZipInvalidMethod.Create;
begin
inherited Create(AbUnknownCompressionMethodS);
ErrorCode := AbUnknownCompressionMethod;
end;
constructor EAbZipInvalidPassword.Create;
begin
inherited Create(AbInvalidPasswordS);
ErrorCode := AbInvalidPassword;
end;
constructor EAbZipInvalidStub.Create;
begin
inherited Create(AbZipBadStubS);
ErrorCode := AbZipBadStub;
end;
constructor EAbZipNoExtraction.Create;
begin
inherited Create(AbNoExtractionMethodS);
ErrorCode := AbNoExtractionMethod;
end;
constructor EAbZipNoInsertion.Create;
begin
inherited Create(AbNoInsertionMethodS);
ErrorCode := AbNoInsertionMethod;
end;
constructor EAbZipSpanOverwrite.Create;
begin
inherited Create(AbNoOverwriteSpanStreamS);
ErrorCode := AbNoOverwriteSpanStream;
end;
constructor EAbZipStreamFull.Create;
begin
inherited Create(AbStreamFullS);
ErrorCode := AbStreamFull;
end;
constructor EAbZipTruncate.Create;
begin
inherited Create(AbTruncateErrorS);
ErrorCode := AbTruncateError;
end;
constructor EAbZipUnsupported.Create;
begin
inherited Create(AbUnsupportedCompressionMethodS);
ErrorCode := AbUnsupportedCompressionMethod;
end;
constructor EAbZipVersion.Create;
begin
inherited Create(AbZipVersionNeededS);
ErrorCode := AbZipVersionNeeded;
end;
constructor EAbReadError.Create;
begin
inherited Create(AbReadErrorS);
ErrorCode := AbReadError;
end;
constructor EAbVMSInvalidOrigin.Create( Value : Integer );
begin
inherited Create(Format(AbVMSInvalidOriginS, [Value]));
ErrorCode := AbVMSInvalidOrigin;
end;
constructor EAbBBSReadTooManyBytes.Create(Count : Integer );
begin
inherited Create(Format(AbBBSReadTooManyBytesS, [Count]));
ErrorCode := AbBBSReadTooManyBytes;
end;
constructor EAbBBSSeekOutsideBuffer.Create;
begin
inherited Create(AbBBSSeekOutsideBufferS);
ErrorCode := AbBBSSeekOutsideBuffer;
end;
constructor EAbBBSInvalidOrigin.Create;
begin
inherited Create(AbBBSInvalidOriginS);
ErrorCode := AbBBSInvalidOrigin;
end;
constructor EAbBBSWriteTooManyBytes.Create(Count : Integer);
begin
inherited Create(Format(AbBBSWriteTooManyBytesS, [Count]));
ErrorCode := AbBBSWriteTooManyBytes;
end;
constructor EAbVMSErrorOpenSwap.Create( const Value : string );
begin
inherited Create(Format(AbVMSErrorOpenSwapS, [Value]));
ErrorCode := AbVMSErrorOpenSwap;
end;
constructor EAbVMSSeekFail.Create( const Value : string );
begin
inherited Create(Format(AbVMSSeekFailS, [Value]));
ErrorCode := AbVMSSeekFail;
end;
constructor EAbVMSReadFail.Create( Count : Integer; const Value : string );
begin
inherited Create(Format(AbVMSReadFailS, [Count, Value]));
ErrorCode := AbVMSReadFail;
end;
constructor EAbVMSWriteFail.Create( Count : Integer; const Value : string );
begin
inherited Create(Format(AbVMSWriteFailS, [Count, Value]));
ErrorCode := AbVMSWriteFail;
end;
constructor EAbVMSWriteTooManyBytes.Create( Count : Integer );
begin
inherited Create(Format(AbVMSWriteTooManyBytesS, [Count]));
ErrorCode := AbVMSWriteTooManyBytes;
end;
constructor EAbSWSNotEndofStream.Create;
begin
inherited Create(AbSWSNotEndofStreamS);
ErrorCode := AbSWSNotEndofStream;
end;
constructor EAbSWSSeekFailed.Create;
begin
inherited Create(AbSWSSeekFailedS);
ErrorCode := AbSWSSeekFailed;
end;
constructor EAbSWSWriteFailed.Create;
begin
inherited Create(AbSWSWriteFailedS);
ErrorCode := AbSWSWriteFailed;
end;
constructor EAbSWSInvalidOrigin.Create;
begin
inherited Create(AbSWSInvalidOriginS);
ErrorCode := AbSWSInvalidOrigin;
end;
constructor EAbSWSInvalidNewOrigin.Create;
begin
inherited Create(AbSWSInvalidNewOriginS);
ErrorCode := AbSWSInvalidNewOrigin;
end;
constructor EAbFCIFileOpenError.Create;
begin
inherited Create(AbFCIFileOpenErrorS);
ErrorCode := AbFCIFileOpenError;
end;
constructor EAbNoCabinetDll.Create;
begin
inherited Create(AbNoCabinetDllErrorS);
ErrorCode := AbNoCabinetDllError;
end;
constructor EAbFCIFileReadError.Create;
begin
inherited Create(AbFCIFileReadErrorS);
ErrorCode := AbFCIFileReadError;
end;
constructor EAbFCIFileWriteError.Create;
begin
inherited Create(AbFCIFileWriteErrorS);
ErrorCode := AbFCIFileWriteError;
end;
constructor EAbFCIFileCloseError.Create;
begin
inherited Create(AbFCIFileCloseErrorS);
ErrorCode := AbFCIFileCloseError;
end;
constructor EAbFCIFileSeekError.Create;
begin
inherited Create(AbFCIFileSeekErrorS);
ErrorCode := AbFCIFileSeekError;
end;
constructor EAbFCIFileDeleteError.Create;
begin
inherited Create(AbFCIFileDeleteErrorS);
ErrorCode := AbFCIFileDeleteError;
end;
constructor EAbFCIAddFileError.Create;
begin
inherited Create(AbFCIAddFileErrorS);
ErrorCode := AbFCIAddFileError;
end;
constructor EAbFCICreateError.Create;
begin
inherited Create(AbFCICreateErrorS);
ErrorCode := AbFCICreateError;
end;
constructor EAbFCIFlushCabinetError.Create;
begin
inherited Create(AbFCIFlushCabinetErrorS);
ErrorCode := AbFCIFlushCabinetError;
end;
constructor EAbFCIFlushFolderError.Create;
begin
inherited Create(AbFCIFlushFolderErrorS);
ErrorCode := AbFCIFlushFolderError;
end;
constructor EAbFDICopyError.Create;
begin
inherited Create(AbFDICopyErrorS);
ErrorCode := AbFDICopyError;
end;
constructor EAbFDICreateError.Create;
begin
inherited Create(AbFDICreateErrorS);
ErrorCode := AbFDICreateError;
end;
constructor EAbInvalidCabTemplate.Create;
begin
inherited Create(AbInvalidCabTemplateS);
ErrorCode := AbInvalidCabTemplate;
end;
constructor EAbInvalidCabFile.Create;
begin
inherited Create(AbInvalidCabFileS);
ErrorCode := AbInvalidCabFile;
end;
procedure AbConvertException( const E : Exception;
var eClass : TAbErrorClass;
var eErrorCode : Integer );
begin
eClass := ecOther;
eErrorCode := 0;
if E is EAbException then begin
eClass := ecAbbrevia;
eErrorCode := (E as EAbException).ErrorCode;
end
else if E is EInOutError then begin
eClass := ecInOutError;
eErrorCode := (E as EInOutError).ErrorCode;
end
else if E is EFilerError then
eClass := ecFilerError
else if E is EFOpenError then
eClass := ecFileOpenError
else if E is EFCreateError then
eClass := ecFileCreateError;
end;
{ EAbUnhandledType }
constructor EAbUnhandledType.Create;
begin
inherited Create(AbUnhandledFileTypeS);
ErrorCode := AbUnhandledFileType;
end;
{ EAbGzipBadCRC }
constructor EAbGzipBadCRC.Create;
begin
inherited Create(AbGzipBadCRCS);
ErrorCode := AbGzipBadCRC;
end;
{ EAbGzipBadFileSize }
constructor EAbGzipBadFileSize.Create;
begin
inherited Create(AbGzipBadFileSizeS);
ErrorCode := AbGzipBadFileSize;
end;
{ EAbGzipInvalid }
constructor EAbGzipInvalid.Create;
begin
inherited Create(AbSpanningNotSupportedS);
ErrorCode := AbSpanningNotSupported;
end;
{ EAbTarInvalid }
constructor EAbTarInvalid.Create;
begin
inherited Create(AbTarInvalidS);
ErrorCode := AbTarInvalid;
end;
{ EAbTarBadFileName }
constructor EAbTarBadFileName.Create;
begin
inherited Create(AbTarBadFileNameS);
ErrorCode := AbTarBadFileName;
end;
{ EAbTarBadLinkName }
constructor EAbTarBadLinkName.Create;
begin
inherited Create(AbTarBadLinkNameS);
ErrorCode := AbTarBadLinkName;
end;
{ EAbTarBadOp }
constructor EAbTarBadOp.Create;
begin
inherited Create(AbTarBadOpS);
ErrorCode := AbTarBadOp;
end;
{ EAbSpanningNotSupported }
constructor EAbSpanningNotSupported.Create;
begin
inherited Create(AbSpanningNotSupportedS);
ErrorCode := AbSpanningNotSupported;
end;
{ EAbFileTooLarge }
constructor EAbFileTooLarge.Create;
begin
{TODO Create const and fix wording}
inherited Create(AbFileSizeTooBigS);
end;
end.
================================================
FILE: lib/abbrevia/source/AbFciFdi.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbFciFdi.pas *}
{*********************************************************}
{* ABBREVIA: Cabinet DLL wrapper *}
{* Based on info from the FCI/FDI Library Description, *}
{* included in the Microsoft Cabinet SDK *}
{*********************************************************}
unit AbFciFdi;
{$I AbDefine.inc}
interface
uses
Windows, AbUtils;
const
CabinetDLL = 'cabinet.dll';
cpuUnknown = -1;
cpu80286 = 0;
cpu80386 = 1;
cpuDefault = cpuUnknown;
type
{FDI errors}
FDIError =
(FDIError_None, FDIError_Cabinet_Not_Found,
FDIError_Not_A_Cabinet, FDIError_Unknown_Cabinet_Version,
FDIError_Corrupt_Cabinet, FDIError_Alloc_Fail,
FDIError_Bad_Compr_Type, FDIError_MDI_Fail,
FDIError_Target_File, FDIError_Reserve_Mismatch,
FDIError_Wrong_Cabinet, FDIError_User_Abort);
{FCI errors}
FCIError =
(FCIError_NONE, FCIError_Open_SRC,
FCIError_Read_SRC, FCIError_Alloc_Fail,
FCIError_Temp_File, FCIError_Bad_Compr_Type,
FCIError_Cab_File, FCIError_User_Abort,
FCIERRor_MCI_Fail);
{FDI notifications}
FDINotificationType =
(FDINT_Cabinet_Info, FDINT_Partial_File,
FDINT_Copy_File, FDINT_Close_File_Info,
FDINT_Next_Cabinet, FDINT_Enumerate);
{FDI/FCI error structure}
PCabErrorRecord = ^CabErrorRecord;
CabErrorRecord = record
ErrorCode : Integer;
ErrorType : Integer;
ErrorPresent : BOOL;
end;
{FDI cabinet information structure}
PFDICabInfo = ^FDICabInfo;
FDICabInfo = record
cbCabinet : Longint;
cFolders : Word;
cFiles : Word;
setID : Word;
iCabinet : Word;
fReserve : BOOL;
hasprev : BOOL;
hasnext : BOOL;
end;
{FCI cabinet information structure}
PFCICabInfo = ^FCICabInfo;
FCICabInfo = record
cb : Longint;
cbFolderThresh : Longint;
cbReserveCFHeader : Integer;
cbReserveCFFolder : Integer;
cbReserveCFData : Integer;
iCab : Integer;
iDisk : Integer;
fFailOnIncompressible : Integer;
setID : Word;
szDisk : array[0..255] of AnsiChar;
szCab : array[0..255] of AnsiChar;
szCabPath : array[0..255] of AnsiChar;
end;
{FDI notification structure}
PFDINotification = ^FDINotification;
FDINotification = record
cb : Longint;
psz1 : PAnsiChar;
psz2 : PAnsiChar;
psz3 : PAnsiChar;
pv : Pointer;
hf : PtrInt;
date : Word;
time : Word;
attribs : Word;
setID : Word;
iCabinet : Word;
iFolder : Word;
fdie : FDIERROR;
end;
{misc defines}
HFDI = Pointer;
HFCI = Pointer;
FARPROC = Pointer;
{== Cabinet DLL routine prototypes ==========================================}
type
TFDICreate =
function (pfnalloc, pfnfree, pfnopen, pfnread, pfnwrite, pfnclose,
pfnseek : FARPROC; cpuType : Integer; pError : PCabErrorRecord) : HFDI;
cdecl;
{----------------------------------------------------------------------------}
TFDIIsCabinet =
function(hfdi : HFDI; hf : PtrInt; pfdici : PFDICabInfo) : BOOL;
cdecl;
{----------------------------------------------------------------------------}
TFDICopy =
function(hfdi : HFDI; pszCabinet, pszCabPath : PAnsiChar;
flags : Integer; pfnfdin, pfnfdid : FARPROC; Archive : Pointer) : BOOL;
cdecl;
{----------------------------------------------------------------------------}
TFDIDestroy =
function(hfdi : HFDI) : BOOL;
cdecl;
{----------------------------------------------------------------------------}
TFCICreate =
function(pError : PCabErrorRecord; pfnfcifp, pfnalloc, pfnfree,
pfnopen, pfnread, pfnwrite, pfnclose, pfnseek, pfndelete,
pfnfcigtf : FARPROC; pccab : PFCICabInfo; Archive : Pointer) : HFCI;
cdecl;
{----------------------------------------------------------------------------}
TFCIAddFile =
function(hfci : HFCI; pszFilePath, pszFileName : PAnsiChar;
fExecute : BOOL; pfnfcignc, pfnfcis, pfnfcigoi : FARPROC;
typeCompress : Word) : BOOL;
cdecl;
{----------------------------------------------------------------------------}
TFCIFlushCabinet =
function(hfci : HFCI; fGetNextCab : BOOL;
pfnfcignc, pfnfcis : FARPROC) : BOOL;
cdecl;
{----------------------------------------------------------------------------}
TFCIFlushFolder =
function(hfci : HFCI; pfnfcignc, pfnfcis : FARPROC) : BOOL;
cdecl;
{----------------------------------------------------------------------------}
TFCIDestroy =
function(hfci : HFCI) : BOOL;
cdecl;
{== DLL routine wrappers ====================================================}
function FDICreate(pfnalloc, pfnfree, pfnopen, pfnread,
pfnwrite, pfnclose, pfnseek : FARPROC;
cpuType : Integer; pError : PCabErrorRecord) : HFDI;
{returns an FDI context for opening an existing cabinet}
{ pfnalloc - heap allocation callback function }
{ pfnfree - heap deallocation callback function }
{ pfnopen - open file callback function }
{ pfnwrite - write file callback function }
{ pfnclose - close file callback function }
{ pfnseek - reposition file pointer callback function }
{ cpuType - -1: unknown, 0: 80286, 1: 80386 }
{ pError - pointer to error record }
{----------------------------------------------------------------------------}
function FDIIsCabinet(hfdi : HFDI; hf : PtrInt;
pfdici : PFDICabInfo) : BOOL;
{checks cabinet file for validity}
{ hfdi - FDI context }
{ hf - cabinet file handle }
{ pfdici - pointer to FDI cabinet info structure }
{----------------------------------------------------------------------------}
function FDICopy(hfdi : HFDI; pszCabinet, pszCabPath : PAnsiChar;
flags : Integer; pfnfdin, pfnfdid : FARPROC;
Archive : Pointer) : BOOL;
{enumerates every file in the cabinet. The callback function }
{should indicate whether or not to extract a given file}
{ hfdi - FDI context }
{ pszCabinet - cabinet file name }
{ pszCabPath - cabinet file path }
{ flags - currently not used }
{ pfnfdin - FDI notifaction callback function }
{ pfnfdid - decryption callback (currently not used)}
{ Archive - the calling TAbCabArchive instance }
{----------------------------------------------------------------------------}
function FDIDestroy(hfdi : HFDI) : BOOL;
{releases FDI context and frees resources}
{ hfdi - FDI context }
{----------------------------------------------------------------------------}
function FCICreate(pError : PCabErrorRecord;
pfnfcifp, pfnalloc, pfnfree, pfnopen, pfnread, pfnwrite, pfnclose,
pfnseek, pfndelete, pfnfcigtf : FARPROC;
pccab : PFCICabInfo; Archive : Pointer) : HFCI;
{creates a new cabinet file and returns the FCI context}
{ pError - pointer to error record }
{ pfnfcifp - callback notification when file has been placed in cabinet }
{ pfnalloc - callback function to allocate memory }
{ pfnfree - callback function to free memory }
{ pfnopen - callback function to open a file }
{ pfnwrite - callback function to write to a file }
{ pfnclose - callback function to close a file }
{ pfnseek - callback function to reposition file pointer }
{ pfndelete - callback function to delete a file }
{ pfnfcigtf - callback function to obtain temp filename }
{ pccab - pointer to FCI cabinet infor structure }
{ Archive - the calling TAbCabArchive instance }
{----------------------------------------------------------------------------}
function FCIAddFile(hfci : HFCI; pszFilePath, pszFileName : PAnsiChar;
fExecute : BOOL; pfnfcignc, pfnfcis, pfnfcigoi : FARPROC;
typeCompress : Word) : BOOL;
{adds a file to the cabinet}
{ hfci - FCI context }
{ pszFilePath - full pathname of file being added }
{ pszFileName - just the file name }
{ fExecute - flag to indicate if file is executable }
{ pfnfcignc - callback function to obtain next cabinet info }
{ pfnfcis - callback function to relay progress }
{ pfnfcigoi - callback function to open file and get attributes }
{ typeCompress - compression type to use }
{----------------------------------------------------------------------------}
function FCIFlushCabinet(hfci : HFCI; fGetNextCab : BOOL;
pfnfcignc, pfnfcis : FARPROC) : BOOL;
{writes current cabinet file out to disk and optionally starts a new one}
{ hfci - FCI context }
{ fGetNextCab - flag indicating whether to start a new cabinet }
{ pfnfcignc - callback function to obtain next cabinet info }
{ pfnfcis - callback function to relay progress }
{----------------------------------------------------------------------------}
function FCIFlushFolder(hfci : HFCI;
pfnfcignc, pfnfcis : FARPROC) : BOOL;
{close current compression block and start a new one}
{ hfci - FCI context }
{ pfnfcignc - callback function to obtain next cabinet info }
{ pfnfcis - callback function to relay progress }
{----------------------------------------------------------------------------}
function FCIDestroy(hfci : HFCI) : BOOL;
{releases FCI context and frees resources}
{ hfdi - FDI context }
{----------------------------------------------------------------------------}
implementation
uses
AbExcept;
var
CabDLLLoaded : Boolean;
CabDLLHandle : THandle;
FDICreateProc : TFDICreate;
FDIIsCabinetProc : TFDIIsCabinet;
FDICopyProc : TFDICopy;
FDIDestroyProc : TFDIDestroy;
FCICreateProc : TFCICreate;
FCIAddFileProc : TFCIAddFile;
FCIFlushCabinetProc : TFCIFlushCabinet;
FCIFlushFolderProc : TFCIFlushFolder;
FCIDestroyProc : TFCIDestroy;
{============================================================================}
procedure LoadCabinetDLL;
begin
if CabDllLoaded then
Exit;
CabDllHandle := LoadLibrary(CabinetDLL);
if (CabDllHandle = 0) then
raise EAbNoCabinetDLL.Create;
@FDICreateProc := GetProcAddress(CabDllHandle, 'FDICreate');
@FDIIsCabinetProc := GetProcAddress(CabDllHandle, 'FDIIsCabinet');
@FDICopyProc := GetProcAddress(CabDllHandle, 'FDICopy');
@FDIDestroyProc := GetProcAddress(CabDllHandle, 'FDIDestroy');
@FCICreateProc := GetProcAddress(CabDllHandle, 'FCICreate');
@FCIAddFileProc := GetProcAddress(CabDllHandle, 'FCIAddFile');
@FCIFlushCabinetProc := GetProcAddress(CabDllHandle, 'FCIFlushCabinet');
@FCIFlushFolderProc := GetProcAddress(CabDllHandle, 'FCIFlushFolder');
@FCIDestroyProc := GetProcAddress(CabDllHandle, 'FCIDestroy');
CabDllLoaded := True;
end;
{----------------------------------------------------------------------------}
function FDICreate(pfnalloc, pfnfree, pfnopen, pfnread,
pfnwrite, pfnclose, pfnseek : FARPROC;
cpuType : Integer; pError : PCabErrorRecord) : HFDI;
begin
LoadCabinetDLL;
if Assigned(FDICreateProc) then
Result := FDICreateProc(pfnalloc, pfnfree, pfnopen, pfnread,
pfnwrite, pfnclose, pfnseek, cpuType, pError)
else
Result := nil;
end;
{----------------------------------------------------------------------------}
function FDIIsCabinet(hfdi : HFDI; hf : PtrInt;
pfdici : PFDICabInfo) : BOOL;
begin
LoadCabinetDLL;
if Assigned(FDIIsCabinetProc) then
Result := FDIIsCabinetProc(hfdi, hf, pfdici)
else
Result := False;
end;
{----------------------------------------------------------------------------}
function FDICopy(hfdi : HFDI; pszCabinet, pszCabPath : PAnsiChar;
flags : Integer; pfnfdin, pfnfdid : FARPROC;
Archive : Pointer) : BOOL;
begin
LoadCabinetDLL;
if Assigned(FDICopyProc) then
Result := FDICopyProc(hfdi, pszCabinet, pszCabPath, flags,
pfnfdin, pfnfdid, Archive)
else
Result := False;
end;
{----------------------------------------------------------------------------}
function FDIDestroy(hfdi : HFDI) : BOOL;
begin
LoadCabinetDLL;
if Assigned(FDIDestroyProc) then
Result := FDIDestroyProc(hfdi)
else
Result := False;
end;
{----------------------------------------------------------------------------}
function FCICreate(pError : PCabErrorRecord;
pfnfcifp, pfnalloc, pfnfree, pfnopen, pfnread, pfnwrite, pfnclose,
pfnseek, pfndelete, pfnfcigtf : FARPROC;
pccab : PFCICabInfo; Archive : Pointer) : HFCI;
begin
LoadCabinetDLL;
if Assigned(FCICreateProc) then
Result := FCICreateProc(pError, pfnfcifp, pfnalloc, pfnfree, pfnopen,
pfnread, pfnwrite, pfnclose, pfnseek, pfndelete, pfnfcigtf,
pccab, Archive)
else
Result := nil;
end;
{----------------------------------------------------------------------------}
function FCIAddFile(hfci : HFCI; pszFilePath, pszFileName : PAnsiChar;
fExecute : BOOL; pfnfcignc, pfnfcis, pfnfcigoi : FARPROC;
typeCompress : Word) : BOOL;
begin
LoadCabinetDLL;
if Assigned(FCIAddFileProc) then
Result := FCIAddFileProc(hfci, pszFilePath, pszFileName,
fExecute, pfnfcignc, pfnfcis, pfnfcigoi, typeCompress)
else
Result := False;
end;
{----------------------------------------------------------------------------}
function FCIFlushCabinet(hfci : HFCI; fGetNextCab : BOOL;
pfnfcignc, pfnfcis : FARPROC) : BOOL;
begin
LoadCabinetDLL;
if Assigned(FCIFlushCabinetProc) then
Result := FCIFlushCabinetProc(hfci, fGetNextCab, pfnfcignc, pfnfcis)
else
Result := False;
end;
{----------------------------------------------------------------------------}
function FCIFlushFolder(hfci : HFCI;
pfnfcignc, pfnfcis : FARPROC) : BOOL;
begin
LoadCabinetDLL;
if Assigned(FCIFlushFolderProc) then
Result := FCIFlushFolderProc(hfci, pfnfcignc, pfnfcis)
else
Result := False;
end;
{----------------------------------------------------------------------------}
function FCIDestroy(hfci : HFCI) : BOOL;
begin
LoadCabinetDLL;
if Assigned(FCIDestroyProc) then
Result := FCIDestroyProc(hfci)
else
Result := False;
end;
{----------------------------------------------------------------------------}
initialization
CabDllLoaded := False;
end.
================================================
FILE: lib/abbrevia/source/AbGzTyp.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Craig Peterson
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbGzTyp.pas *}
{*********************************************************}
{* ABBREVIA: TAbGzipArchive, TAbGzipItem classes *}
{*********************************************************}
{* Misc. constants, types, and routines for working *}
{* with GZip files *}
{* See: RFC 1952 *}
{* "GZIP file format specification version 4.3" *}
{* for more information on GZip *}
{* See "algorithm.doc" in Gzip source and "format.txt" *}
{* on gzip.org for differences from RFC *}
{*********************************************************}
unit AbGzTyp;
{$I AbDefine.inc}
interface
uses
Classes, AbUtils, AbArcTyp, AbTarTyp, AbVMStrm;
type
{ pre-defined "operating system" (really more FILE system)
types for the Gzip header }
TAbGzFileSystem =
(osFat, osAmiga, osVMS, osUnix, osVM_CMS, osAtariTOS,
osHPFS, osMacintosh, osZSystem, osCP_M, osTOPS20,
osNTFS, osQDOS, osAcornRISCOS, osVFAT, osMVS, osBeOS,
osTandem, osTHEOS, osUnknown, osUndefined);
type
PAbGzHeader = ^TAbGzHeader;
TAbGzHeader = packed record { SizeOf(TGzHeader) = 10}
ID1 : Byte; { ID Byte, should always be $1F}
ID2 : Byte; { ID Byte, should always be $8B}
CompMethod : Byte; { compression method used}
{ 0..7 reserved, 8 = deflate, others undefined as of this writing (4/27/2001)}
Flags : Byte; { misc flags}
{ Bit 0: FTEXT compressed file contains text, can be used for}
{ cross platform line termination translation}
{ Bit 1: FCONTINUATION file is a continuation of a multi-part gzip file}
{ RFC 1952 says this is the header CRC16 flag, but gzip}
{ reserves it and won't extract the file if this is set}
{ header data includes part number after header record}
{ Bit 2: FEXTRA header data contains Extra Data, starts after part}
{ number (if any)}
{ Bit 3: FNAME header data contains FileName, null terminated}
{ string starting immediately after Extra Data (if any)}
{ RFC 1952 says this is ISO 8859-1 encoded, but gzip}
{ always uses the system encoding}
{ Bit 4: FCOMMENT header data contains Comment, null terminated string}
{ starting immediately after FileName (if any)}
{ Bit 5: FENCRYPTED file is encrypted using zip-1.9 encryption }
{ header data contains a 12-byte encryption header }
{ starting immediately after Comment. Documented in}
{ "algorithm.doc", but unsupported in gzip}
{ Bits 6..7 are undefined and reserved as of this writing (8/25/2009)}
ModTime : LongInt; { File Modification (Creation) time,}
{ UNIX cdate format}
XtraFlags : Byte; { additional flags}
{ XtraFlags = 2 -- Deflate compressor used maximum compression algorithm}
{ XtraFlags = 4 -- Deflate compressor used fastest algorithm}
OS : Byte; { Operating system that created file,}
{ see GZOsToStr routine for values}
end;
TAbGzTailRec = packed record
CRC32 : LongInt; { crc for uncompressed data }
ISize : LongWord; { size of uncompressed data }
end;
TAbGzExtraFieldSubID = array[0..1] of AnsiChar;
type
TAbGzipExtraField = class(TAbExtraField)
private
FGZHeader : PAbGzHeader;
function GetID(aIndex : Integer): TAbGzExtraFieldSubID;
protected
procedure Changed; override;
public
constructor Create(aGZHeader : PAbGzHeader);
procedure Delete(aID : TAbGzExtraFieldSubID);
function Get(aID : TAbGzExtraFieldSubID;
out aData : Pointer; out aDataSize : Word) : Boolean;
procedure Put(aID : TAbGzExtraFieldSubID; const aData; aDataSize : Word);
public
property IDs[aIndex : Integer]: TAbGzExtraFieldSubID
read GetID;
end;
TAbGzipItem = class(TAbArchiveItem)
protected {private}
FGZHeader : TAbGzHeader;
FExtraField : TAbGzipExtraField;
FFileComment : AnsiString;
FRawFileName : AnsiString;
protected
function GetFileSystem: TAbGzFileSystem;
function GetHasExtraField: Boolean;
function GetHasFileComment: Boolean;
function GetHasFileName: Boolean;
function GetIsText: Boolean;
procedure SetFileComment(const Value : AnsiString);
procedure SetFileSystem(const Value: TAbGzFileSystem);
procedure SetIsText(const Value: Boolean);
function GetExternalFileAttributes : LongWord; override;
function GetIsEncrypted : Boolean; override;
function GetLastModFileDate : Word; override;
function GetLastModFileTime : Word; override;
function GetLastModTimeAsDateTime: TDateTime; override;
procedure SetExternalFileAttributes( Value : LongWord ); override;
procedure SetFileName(const Value : string); override;
procedure SetIsEncrypted(Value : Boolean); override;
procedure SetLastModFileDate(const Value : Word); override;
procedure SetLastModFileTime(const Value : Word); override;
procedure SetLastModTimeAsDateTime(const Value: TDateTime); override;
procedure SaveGzHeaderToStream(AStream : TStream);
procedure LoadGzHeaderFromStream(AStream : TStream);
public
property CompressionMethod : Byte
read FGZHeader.CompMethod;
property ExtraFlags : Byte {Default: 2}
read FGZHeader.XtraFlags write FGZHeader.XtraFlags;
property Flags : Byte
read FGZHeader.Flags;
property FileComment : AnsiString
read FFileComment write SetFileComment;
property FileSystem : TAbGzFileSystem {Default: osFat (Windows); osUnix (Linux)}
read GetFileSystem write SetFileSystem;
property ExtraField : TAbGzipExtraField
read FExtraField;
property IsEncrypted : Boolean
read GetIsEncrypted;
property HasExtraField : Boolean
read GetHasExtraField;
property HasFileName : Boolean
read GetHasFileName;
property HasFileComment : Boolean
read GetHasFileComment;
property IsText : Boolean
read GetIsText write SetIsText;
property GZHeader : TAbGzHeader
read FGZHeader;
constructor Create;
destructor Destroy; override;
end;
TAbGzipStreamHelper = class(TAbArchiveStreamHelper)
private
function GetGzCRC: LongInt;
function GetFileSize: LongInt;
protected {private}
FItem : TAbGzipItem;
FTail : TAbGzTailRec;
public
constructor Create(AStream : TStream);
destructor Destroy; override;
procedure ExtractItemData(AStream : TStream); override;
function FindFirstItem : Boolean; override;
function FindNextItem : Boolean; override;
function SeekItem(Index : Integer): Boolean; override;
procedure SeekToItemData;
procedure WriteArchiveHeader; override;
procedure WriteArchiveItem(AStream : TStream); override;
procedure WriteArchiveTail; override;
function GetItemCount : Integer; override;
procedure ReadHeader; override;
procedure ReadTail; override;
property CRC : LongInt
read GetGzCRC;
property FileSize : LongInt
read GetFileSize;
property TailCRC : LongInt
read FTail.CRC32;
property TailSize : LongWord
read FTail.ISize;
end;
TAbGzipArchiveState = (gsGzip, gsTar);
TAbGzipArchive = class(TAbTarArchive)
private
FGZStream : TStream; { stream for GZip file}
FGZItem : TAbArchiveList; { item in Gzip (only one, but need polymorphism of class)}
FTarStream : TAbVirtualMemoryStream; { stream for possible contained Tar }
FTarList : TAbArchiveList; { items in possible contained Tar }
FTarAutoHandle: Boolean;
FState : TAbGzipArchiveState;
FIsGzippedTar : Boolean;
procedure SetTarAutoHandle(const Value: Boolean);
function GetIsGzippedTar: Boolean;
procedure SwapToGzip;
procedure SwapToTar;
protected
function CreateItem(const FileSpec : string): TAbArchiveItem;
override;
procedure ExtractItemAt(Index : Integer; const UseName : string);
override;
procedure ExtractItemToStreamAt(Index : Integer; aStream : TStream);
override;
procedure LoadArchive;
override;
procedure SaveArchive;
override;
procedure TestItemAt(Index : Integer);
override;
function FixName(const Value : string) : string;
override;
function GetSupportsEmptyFolders : Boolean;
override;
function GetItem(Index: Integer): TAbGzipItem;
procedure PutItem(Index: Integer; const Value: TAbGzipItem);
public {methods}
constructor CreateFromStream(aStream : TStream; const aArchiveName : string);
override;
destructor Destroy;
override;
procedure DoSpanningMediaRequest(Sender : TObject; ImageNumber : Integer;
var ImageName : string; var Abort : Boolean); override;
property TarAutoHandle : Boolean
read FTarAutoHandle write SetTarAutoHandle;
property IsGzippedTar : Boolean
read GetIsGzippedTar write FIsGzippedTar;
property Items[Index : Integer] : TAbGzipItem
read GetItem
write PutItem; default;
end;
function VerifyGZip(Strm : TStream) : TAbArchiveType;
function GZOsToStr(OS: Byte) : string;
implementation
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
{$IFDEF HasAnsiStrings}
System.AnsiStrings,
{$ENDIF}
SysUtils, AbBitBkt, AbCharset, AbDfBase, AbDfDec, AbDfEnc, AbExcept, AbResString;
const
{ Header Signature Values}
AB_GZ_HDR_ID1 = $1F;
AB_GZ_HDR_ID2 = $8B;
{ Test bits for TGzHeader.Flags field }
AB_GZ_FLAG_FTEXT = $01;
AB_GZ_FLAG_FCONTINUATION = $02;
AB_GZ_FLAG_FEXTRA = $04;
AB_GZ_FLAG_FNAME = $08;
AB_GZ_FLAG_FCOMMENT = $10;
AB_GZ_FLAG_FENCRYPTED = $20;
AB_GZ_UNSUPPORTED_FLAGS = $E2;
{ GZip OS source flags }
AB_GZ_OS_ID_FAT = 0;
AB_GZ_OS_ID_Amiga = 1;
AB_GZ_OS_ID_VMS = 2;
AB_GZ_OS_ID_Unix = 3;
AB_GZ_OS_ID_VM_CMS = 4;
AB_GZ_OS_ID_AtariTOS = 5;
AB_GZ_OS_ID_HPFS = 6;
AB_GZ_OS_ID_Macintosh = 7;
AB_GZ_OS_ID_Z_System = 8;
AB_GZ_OS_ID_CP_M = 9;
AB_GZ_OS_ID_TOPS20 = 10;
AB_GZ_OS_ID_NTFS = 11;
AB_GZ_OS_ID_QDOS = 12;
AB_GZ_OS_ID_AcornRISCOS = 13;
AB_GZ_OS_ID_VFAT = 14;
AB_GZ_OS_ID_MVS = 15;
AB_GZ_OS_ID_BEOS = 16;
AB_GZ_OS_ID_TANDEM = 17;
AB_GZ_OS_ID_THEOS = 18;
AB_GZ_OS_ID_unknown = 255;
function GZOsToStr(OS: Byte) : string;
{
Return a descriptive string for TGzHeader.OS field
}
begin
case OS of
AB_GZ_OS_ID_FAT : Result := AbGzOsFat;
AB_GZ_OS_ID_Amiga : Result := AbGzOsAmiga;
AB_GZ_OS_ID_VMS : Result := AbGzOsVMS;
AB_GZ_OS_ID_Unix : Result := AbGzOsUnix;
AB_GZ_OS_ID_VM_CMS : Result := AbGzOsVM_CMS;
AB_GZ_OS_ID_AtariTOS : Result := AbGzOsAtari;
AB_GZ_OS_ID_HPFS : Result := AbGzOsHPFS;
AB_GZ_OS_ID_Macintosh : Result := AbGzOsMacintosh;
AB_GZ_OS_ID_Z_System : Result := AbGzOsZ_System;
AB_GZ_OS_ID_CP_M : Result := AbGzOsCP_M;
AB_GZ_OS_ID_TOPS20 : Result := AbGzOsTOPS_20;
AB_GZ_OS_ID_NTFS : Result := AbGzOsNTFS;
AB_GZ_OS_ID_QDOS : Result := AbGzOsQDOS;
AB_GZ_OS_ID_AcornRISCOS : Result := AbGzOsAcornRISCOS;
AB_GZ_OS_ID_VFAT : Result := AbGzOsVFAT;
AB_GZ_OS_ID_MVS : Result := AbGzOsMVS;
AB_GZ_OS_ID_BEOS : Result := AbGzOsBeOS;
AB_GZ_OS_ID_TANDEM : Result := AbGzOsTandem;
AB_GZ_OS_ID_THEOS : Result := AbGzOsTHEOS;
AB_GZ_OS_ID_unknown : Result := AbGzOsunknown;
else
Result := AbGzOsUndefined;
end;
end;
function VerifyHeader(const Header : TAbGzHeader) : Boolean;
begin
{ check id fields and if deflated (only handle deflate anyway)}
Result := (Header.ID1 = AB_GZ_HDR_ID1) and
(Header.ID2 = AB_GZ_HDR_ID2) and
(Header.CompMethod = 8 {deflate});
end;
function VerifyGZip(Strm : TStream) : TAbArchiveType;
var
GHlp : TAbGzipStreamHelper;
Hlpr : TAbDeflateHelper;
PartialTarData : TMemoryStream;
CurPos : Int64;
begin
Result := atUnknown;
CurPos := Strm.Position;
try
Strm.Seek(0, soBeginning);
{prepare for the try..finally}
Hlpr := nil;
PartialTarData := nil;
GHlp := TAbGzipStreamHelper.Create(Strm);
try
{create the stream helper and read the item header}
GHlp.ReadHeader;
{ check id fields and if deflated (only handle deflate anyway)}
if VerifyHeader(GHlp.FItem.FGZHeader) then begin
Result := atGZip; { provisional }
{ check if is actually a Gzipped Tar }
{ partial extract contents, verify vs. Tar }
PartialTarData := TMemoryStream.Create;
GHlp.SeekToItemData;
Hlpr := TAbDeflateHelper.Create;
Hlpr.PartialSize := 512;
PartialTarData.SetSize(512 * 2);
Inflate(Strm, PartialTarData, Hlpr);
{set to beginning of extracted data}
PartialTarData.Position := 0;
if (VerifyTar(PartialTarData) = atTar) then
Result := atGZippedTar;
end;
finally
GHlp.Free;
Hlpr.Free;
PartialTarData.Free;
end;
except
on EReadError do
Result := atUnknown;
end;
Strm.Position := CurPos;
end;
{ TAbGzipExtraField }
constructor TAbGzipExtraField.Create(aGZHeader : PAbGzHeader);
begin
inherited Create;
FGZHeader := aGZHeader;
end;
procedure TAbGzipExtraField.Changed;
begin
if Buffer = nil then
FGzHeader.Flags := FGzHeader.Flags and not AB_GZ_FLAG_FEXTRA
else
FGzHeader.Flags := FGzHeader.Flags or AB_GZ_FLAG_FEXTRA;
end;
procedure TAbGzipExtraField.Delete(aID : TAbGzExtraFieldSubID);
begin
inherited Delete(Word(aID));
end;
function TAbGzipExtraField.GetID(aIndex : Integer): TAbGzExtraFieldSubID;
begin
Result := TAbGzExtraFieldSubID(inherited IDs[aIndex]);
end;
function TAbGzipExtraField.Get(aID : TAbGzExtraFieldSubID; out aData : Pointer;
out aDataSize : Word) : Boolean;
begin
Result := inherited Get(Word(aID), aData, aDataSize);
end;
procedure TAbGzipExtraField.Put(aID : TAbGzExtraFieldSubID; const aData; aDataSize : Word);
begin
inherited Put(Word(aID), aData, aDataSize);
end;
{ TAbGzipStreamHelper }
constructor TAbGzipStreamHelper.Create(AStream : TStream);
begin
inherited Create(AStream);
FItem := TAbGzipItem.Create;
end;
destructor TAbGzipStreamHelper.Destroy;
begin
FItem.Free;
inherited;
end;
function ReadCStringInStream(AStream: TStream): AnsiString;
{
locate next instance of a null character in a stream
leaves stream positioned just past that,
or at end of stream if not found or null is last byte in stream.
Result is the entire read string.
}
const
BuffSiz = 1024;
var
Buff : array [0..BuffSiz-1] of AnsiChar;
Len, DataRead : LongInt;
begin
{ basically what this is supposed to do is...}
{
repeat
AStream.Read(C, 1);
Result := Result + C;
until (AStream.Position = AStream.Size) or (C = #0);
}
Result := '';
repeat
DataRead := AStream.Read(Buff, BuffSiz - 1);
Buff[DataRead] := #0;
Len := AbStrLen(Buff);
if Len > 0 then begin
SetLength(Result, Length(Result) + Len);
Move(Buff, Result[Length(Result) - Len + 1], Len);
end;
if Len < DataRead then begin
AStream.Seek(Len - DataRead + 1, soCurrent);
Break;
end;
until DataRead = 0;
end;
procedure TAbGzipStreamHelper.SeekToItemData;
{find end of header data, including FileName etc.}
begin
{** Seek to Compressed Data **}
FStream.Seek(0, soBeginning);
FItem.LoadGzHeaderFromStream(FStream);
end;
procedure TAbGzipStreamHelper.ExtractItemData(AStream: TStream);
var
Helper : TAbDeflateHelper;
begin
Helper := TAbDeflateHelper.Create;
try
SeekToItemData;
if (AStream is TAbBitBucketStream) then
Helper.Options := Helper.Options or dfc_TestOnly;
FItem.CRC32 := Inflate(FStream, AStream, Helper);
FItem.UncompressedSize := AStream.Size{Helper.NormalSize};
finally
Helper.Free;
end;
end;
function TAbGzipStreamHelper.FindFirstItem: Boolean;
var
GZH : TAbGzHeader;
DataRead : Integer;
begin
Result := False;
FStream.Seek(0, soBeginning);
DataRead := FStream.Read(GZH, SizeOf(TAbGzHeader));
if (DataRead = SizeOf(TAbGzHeader)) and VerifyHeader(GZH) then begin
FItem.FGZHeader := GZH;
Result := True;
end;
FStream.Seek(0, soBeginning);
end;
function TAbGzipStreamHelper.FindNextItem: Boolean;
begin
{ only one item in a GZip }
Result := False;
end;
function TAbGzipStreamHelper.SeekItem(Index: Integer): Boolean;
begin
if Index > 0 then
Result := False
else
Result := FindFirstItem;
end;
procedure TAbGzipStreamHelper.WriteArchiveHeader;
begin
FItem.SaveGzHeaderToStream(FStream);
end;
procedure TAbGzipStreamHelper.WriteArchiveItem(AStream: TStream);
var
Helper : TAbDeflateHelper;
begin
Helper := TAbDeflateHelper.Create;
try
FItem.CRC32 := Deflate(AStream, FStream, Helper);
FItem.UncompressedSize := AStream.Size;
finally
Helper.Free;
end;
end;
procedure TAbGzipStreamHelper.WriteArchiveTail;
var
Tail : TAbGzTailRec;
begin
Tail.CRC32 := FItem.CRC32;
Tail.ISize := FItem.UncompressedSize;
FStream.Write(Tail, SizeOf(TAbGzTailRec));
end;
function TAbGzipStreamHelper.GetItemCount: Integer;
begin
{ only one item in a gzip }
Result := 1;
end;
procedure TAbGzipStreamHelper.ReadHeader;
begin
FItem.LoadGzHeaderFromStream(FStream);
end;
procedure TAbGzipStreamHelper.ReadTail;
begin
FStream.Read(FTail, SizeOf(TAbGzTailRec));
end;
function TAbGzipStreamHelper.GetGzCRC: LongInt;
begin
Result := FItem.CRC32;
end;
function TAbGzipStreamHelper.GetFileSize: LongInt;
begin
Result := FItem.UncompressedSize;
end;
{ TAbGzipItem }
constructor TAbGzipItem.Create;
begin
inherited Create;
{ default ID fields }
FGzHeader.ID1 := AB_GZ_HDR_ID1;
FGzHeader.ID2 := AB_GZ_HDR_ID2;
{ compression method }
FGzHeader.CompMethod := 8; { deflate }
{ Maxium Compression }
FGzHeader.XtraFlags := 2;
FFileName := '';
FFileComment := '';
FExtraField := TAbGzipExtraField.Create(@FGzHeader);
{ source OS ID }
{$IFDEF LINUX } {assume EXT2 system }
FGzHeader.OS := AB_GZ_OS_ID_Unix;
{$ENDIF LINUX }
{$IFDEF MSWINDOWS } {assume FAT system }
FGzHeader.OS := AB_GZ_OS_ID_FAT;
{$ENDIF MSWINDOWS }
end;
destructor TAbGzipItem.Destroy;
begin
FExtraField.Free;
inherited;
end;
function TAbGzipItem.GetExternalFileAttributes: LongWord;
begin
{ GZip has no provision for storing attributes }
Result := 0;
end;
function TAbGzipItem.GetFileSystem: TAbGzFileSystem;
begin
case FGzHeader.OS of
0..18: Result := TAbGzFileSystem(FGzHeader.OS);
255: Result := osUnknown;
else
Result := osUndefined;
end; { case }
end;
function TAbGzipItem.GetIsEncrypted: Boolean;
begin
Result := (FGZHeader.Flags and AB_GZ_FLAG_FENCRYPTED) = AB_GZ_FLAG_FENCRYPTED;
end;
function TAbGzipItem.GetHasExtraField: Boolean;
begin
Result := (FGZHeader.Flags and AB_GZ_FLAG_FEXTRA) = AB_GZ_FLAG_FEXTRA;
end;
function TAbGzipItem.GetHasFileComment: Boolean;
begin
Result := (FGZHeader.Flags and AB_GZ_FLAG_FCOMMENT) = AB_GZ_FLAG_FCOMMENT;
end;
function TAbGzipItem.GetHasFileName: Boolean;
begin
Result := (FGZHeader.Flags and AB_GZ_FLAG_FNAME) = AB_GZ_FLAG_FNAME;
end;
function TAbGzipItem.GetIsText: Boolean;
begin
Result := (FGZHeader.Flags and AB_GZ_FLAG_FTEXT) = AB_GZ_FLAG_FTEXT;
end;
function TAbGzipItem.GetLastModFileDate: Word;
begin
{ convert to local DOS file Date }
Result := LongRec(AbDateTimeToDosFileDate(LastModTimeAsDateTime)).Hi;
end;
function TAbGzipItem.GetLastModFileTime: Word;
begin
{ convert to local DOS file Time }
Result := LongRec(AbDateTimeToDosFileDate(LastModTimeAsDateTime)).Lo;
end;
function TAbGzipItem.GetLastModTimeAsDateTime: TDateTime;
begin
Result := AbUnixTimeToLocalDateTime(FGZHeader.ModTime);
end;
procedure TAbGzipItem.LoadGzHeaderFromStream(AStream: TStream);
var
LenW : Word;
begin
AStream.Read(FGzHeader, SizeOf(TAbGzHeader));
if not VerifyHeader(FGzHeader) then
Exit;
{ Skip part number, if any }
if (FGzHeader.Flags and AB_GZ_FLAG_FCONTINUATION) = AB_GZ_FLAG_FCONTINUATION then
AStream.Seek(SizeOf(Word), soCurrent);
if HasExtraField then begin
{ get length of extra data }
AStream.Read(LenW, SizeOf(Word));
FExtraField.LoadFromStream(AStream, LenW);
end
else
FExtraField.Clear;
{ Get Filename, if any }
if HasFileName then begin
FRawFileName := ReadCStringInStream(AStream);
FFileName := AbRawBytesToString(FRawFileName)
end
else
FFileName := 'unknown';
{ any comment present? }
if HasFileComment then
FFileComment := ReadCStringInStream(AStream)
else
FFileComment := '';
{Assert: stream should now be located at start of compressed data }
{If file was compressed with 3.3 spec this will be invalid so use with care}
CompressedSize := AStream.Size - AStream.Position - SizeOf(TAbGzTailRec);
FDiskFileName := FileName;
AbUnfixName(FDiskFileName);
Action := aaNone;
Tagged := False;
end;
procedure TAbGzipItem.SaveGzHeaderToStream(AStream: TStream);
var
LenW : Word;
begin
{ default ID fields }
FGzHeader.ID1 := AB_GZ_HDR_ID1;
FGzHeader.ID2 := AB_GZ_HDR_ID2;
{ compression method }
FGzHeader.CompMethod := 8; { deflate }
{ reset unsupported flags }
FGzHeader.Flags := FGzHeader.Flags and not AB_GZ_UNSUPPORTED_FLAGS;
{ main header data }
AStream.Write(FGzHeader, SizeOf(TAbGzHeader));
{ add extra field if any }
if HasExtraField then begin
LenW := Length(FExtraField.Buffer);
AStream.Write(LenW, SizeOf(LenW));
if LenW > 0 then
AStream.Write(FExtraField.Buffer[0], LenW);
end;
{ add filename if any (and include final #0 from string) }
if HasFileName then
AStream.Write(FRawFileName[1], Length(FRawFileName) + 1);
{ add file comment if any (and include final #0 from string) }
if HasFileComment then
AStream.Write(FFileComment[1], Length(FFileComment) + 1);
end;
procedure TAbGzipItem.SetExternalFileAttributes(Value: LongWord);
begin
{ do nothing }
end;
procedure TAbGzipItem.SetFileComment(const Value: AnsiString);
begin
FFileComment := Value;
if FFileComment <> '' then
FGzHeader.Flags := FGzHeader.Flags or AB_GZ_FLAG_FCOMMENT
else
FGzHeader.Flags := FGzHeader.Flags and not AB_GZ_FLAG_FCOMMENT;
end;
procedure TAbGzipItem.SetFileName(const Value: string);
begin
FFileName := Value;
FRawFileName := AbStringToUnixBytes(Value);
if Value <> '' then
FGzHeader.Flags := FGzHeader.Flags or AB_GZ_FLAG_FNAME
else
FGzHeader.Flags := FGzHeader.Flags and not AB_GZ_FLAG_FNAME;
end;
procedure TAbGzipItem.SetFileSystem(const Value: TAbGzFileSystem);
begin
if Value = osUnknown then
FGzHeader.OS := 255
else
FGzHeader.OS := Ord(Value);
end;
procedure TAbGzipItem.SetIsEncrypted(Value: Boolean);
begin
{ do nothing }
end;
procedure TAbGzipItem.SetIsText(const Value: Boolean);
begin
if Value then
FGzHeader.Flags := FGzHeader.Flags or AB_GZ_FLAG_FTEXT
else
FGzHeader.Flags := FGzHeader.Flags and not AB_GZ_FLAG_FTEXT;
end;
procedure TAbGzipItem.SetLastModFileDate(const Value: Word);
begin
{ replace date, keep existing time }
LastModTimeAsDateTime :=
EncodeDate(
Value shr 9 + 1980,
Value shr 5 and 15,
Value and 31) +
Frac(LastModTimeAsDateTime);
end;
procedure TAbGzipItem.SetLastModFileTime(const Value: Word);
begin
{ keep current date, replace time }
LastModTimeAsDateTime :=
Trunc(LastModTimeAsDateTime) +
EncodeTime(
Value shr 11,
Value shr 5 and 63,
Value and 31 shl 1, 0);
end;
procedure TAbGzipItem.SetLastModTimeAsDateTime(const Value: TDateTime);
begin
FGZHeader.ModTime := AbLocalDateTimeToUnixTime(Value);
end;
{ TAbGzipArchive }
constructor TAbGzipArchive.CreateFromStream(aStream : TStream;
const aArchiveName : string);
begin
inherited CreateFromStream(aStream, aArchiveName);
FState := gsGzip;
FGZStream := FStream;
FGZItem := FItemList;
FTarStream := TAbVirtualMemoryStream.Create;
FTarList := TAbArchiveList.Create(True);
end;
procedure TAbGzipArchive.SwapToTar;
begin
FStream := FTarStream;
FItemList := FTarList;
FState := gsTar;
end;
procedure TAbGzipArchive.SwapToGzip;
begin
FStream := FGzStream;
FItemList := FGzItem;
FState := gsGzip;
end;
function TAbGzipArchive.CreateItem(const FileSpec: string): TAbArchiveItem;
var
GzItem : TAbGzipItem;
begin
if IsGZippedTar and TarAutoHandle then begin
SwapToTar;
Result := inherited CreateItem(FileSpec);
end
else begin
SwapToGzip;
GzItem := TAbGzipItem.Create;
try
GzItem.CompressedSize := 0;
GzItem.CRC32 := 0;
GzItem.DiskFileName := ExpandFileName(FileSpec);
GzItem.FileName := FixName(FileSpec);
Result := GzItem;
except
Result := nil;
end;
end;
end;
destructor TAbGzipArchive.Destroy;
begin
SwapToGzip;
FTarList.Free;
FTarStream.Free;
inherited Destroy;
end;
procedure TAbGzipArchive.ExtractItemAt(Index: Integer;
const UseName: string);
var
OutStream : TFileStream;
CurItem : TAbGzipItem;
begin
if IsGZippedTar and TarAutoHandle then begin
SwapToTar;
inherited ExtractItemAt(Index, UseName);
end
else begin
SwapToGzip;
if Index > 0 then Index := 0; { only one item in a GZip}
CurItem := TAbGzipItem(ItemList[Index]);
OutStream := TFileStream.Create(UseName, fmCreate or fmShareDenyNone);
try
try {OutStream}
ExtractItemToStreamAt(Index, OutStream);
finally {OutStream}
OutStream.Free;
end; {OutStream}
AbSetFileTime(UseName, CurItem.LastModTimeAsDateTime);
AbSetFileAttr(UseName, CurItem.NativeFileAttributes);
except
on E : EAbUserAbort do begin
FStatus := asInvalid;
if FileExists(UseName) then
DeleteFile(UseName);
raise;
end else begin
if FileExists(UseName) then
DeleteFile(UseName);
raise;
end;
end;
end;
end;
procedure TAbGzipArchive.ExtractItemToStreamAt(Index: Integer;
aStream: TStream);
var
GzHelp : TAbGzipStreamHelper;
begin
if IsGzippedTar and TarAutoHandle then begin
SwapToTar;
inherited ExtractItemToStreamAt(Index, aStream);
end
else begin
SwapToGzip;
{ note Index ignored as there's only one item in a GZip }
GZHelp := TAbGzipStreamHelper.Create(FGzStream);
try
{ read GZip Header }
GzHelp.ReadHeader;
{ extract copy data from GZip}
GzHelp.ExtractItemData(aStream);
{ Get validation data }
GzHelp.ReadTail;
{$IFDEF STRICTGZIP}
{ According to
http://www.gzip.org/zlib/rfc1952.txt
A compliant gzip compressor should calculate and set the CRC32 and ISIZE.
However, a compliant decompressor should not check these values.
If you want to check the the values of the CRC32 and ISIZE in a GZIP file
when decompressing enable the STRICTGZIP define contained in AbDefine.inc }
{ validate against CRC }
if GzHelp.FItem.Crc32 <> GzHelp.TailCRC then
raise EAbGzipBadCRC.Create;
{ validate against file size }
if GzHelp.FItem.UncompressedSize <> GZHelp.TailSize then
raise EAbGzipBadFileSize.Create;
{$ENDIF}
finally
GzHelp.Free;
end;
end;
end;
function TAbGzipArchive.FixName(const Value: string): string;
{ fix up fileaname for storage }
begin
if FState = gsTar then
Result := inherited FixName( Value )
else begin
{GZip files Always strip the file path}
StoreOptions := StoreOptions + [soStripDrive, soStripPath];
Result := '';
if Value <> '' then
Result := ExtractFileName(Value);
end;
end;
function TAbGzipArchive.GetIsGzippedTar: Boolean;
begin
Result := FIsGzippedTar;
end;
function TAbGzipArchive.GetItem(Index: Integer): TAbGzipItem;
begin
Result := nil;
if Index = 0 then
Result := TAbGzipItem(FItemList.Items[Index]);
end;
function TAbGzipArchive.GetSupportsEmptyFolders : Boolean;
begin
Result := IsGzippedTar and TarAutoHandle;
end;
procedure TAbGzipArchive.LoadArchive;
var
GzHelp : TAbGzipStreamHelper;
Item : TAbGzipItem;
Abort : Boolean;
begin
SwapToGzip;
if FGzStream.Size > 0 then begin
GzHelp := TAbGzipStreamHelper.Create(FGzStream);
try
if GzHelp.FindFirstItem then begin
Item := TAbGzipItem.Create;
Item.LoadGzHeaderFromStream(FGzStream);
FGzStream.Seek(-SizeOf(TAbGzTailRec), soEnd);
GZHelp.ReadTail;
Item.CRC32 := GZHelp.TailCRC;
Item.UncompressedSize := GZHelp.TailSize;
Item.Action := aaNone;
FGZItem.Add(Item);
if IsGzippedTar and TarAutoHandle then begin
{ extract Tar and set stream up }
FTarStream.SwapFileDirectory := FTempDir;
GzHelp.SeekToItemData;
GzHelp.ExtractItemData(FTarStream);
SwapToTar;
inherited LoadArchive;
end;
end;
DoArchiveProgress(100, Abort);
FIsDirty := False;
finally
{ Clean Up }
GzHelp.Free;
end;
end;
end;
procedure TAbGzipArchive.PutItem(Index: Integer; const Value: TAbGzipItem);
begin
if Index = 0 then
FItemList.Items[Index] := Value;
end;
procedure TAbGzipArchive.SaveArchive;
var
InGzHelp, OutGzHelp : TAbGzipStreamHelper;
Abort : Boolean;
i : Integer;
NewStream : TAbVirtualMemoryStream;
UncompressedStream : TStream;
SaveDir : string;
CurItem : TAbGzipItem;
begin
{prepare for the try..finally}
OutGzHelp := nil;
NewStream := nil;
try
InGzHelp := TAbGzipStreamHelper.Create(FGzStream);
try
{init new archive stream}
NewStream := TAbVirtualMemoryStream.Create;
OutGzHelp := TAbGzipStreamHelper.Create(NewStream);
{ create helper }
NewStream.SwapFileDirectory := FTempDir;
{ save the Tar data }
if IsGzippedTar and TarAutoHandle then begin
SwapToTar;
inherited SaveArchive;
if FGZItem.Count = 0 then begin
CurItem := TAbGzipItem.Create;
FGZItem.Add(CurItem);
end;
CurItem := FGZItem[0] as TAbGzipItem;
CurItem.Action := aaNone;
CurItem.LastModTimeAsDateTime := Now;
CurItem.SaveGzHeaderToStream(NewStream);
FTarStream.Position := 0;
OutGzHelp.WriteArchiveItem(FTarStream);
CurItem.CRC32 := OutGzHelp.CRC;
CurItem.UncompressedSize := OutGzHelp.FileSize;
OutGzHelp.WriteArchiveTail;
end
else begin
SwapToGzip;
{build new archive from existing archive}
for i := 0 to pred(Count) do begin
FCurrentItem := ItemList[i];
CurItem := TAbGzipItem(ItemList[i]);
InGzHelp.SeekToItemData;
case CurItem.Action of
aaNone, aaMove : begin
{just copy the file to new stream}
CurItem.SaveGzHeaderToStream(NewStream);
InGzHelp.SeekToItemData;
NewStream.CopyFrom(FGZStream, FGZStream.Size - FGZStream.Position);
end;
aaDelete: {doing nothing omits file from new stream} ;
aaAdd, aaFreshen, aaReplace, aaStreamAdd: begin
try
if (CurItem.Action = aaStreamAdd) then begin
{ adding from a stream }
CurItem.SaveGzHeaderToStream(NewStream);
CurItem.UncompressedSize := InStream.Size;
OutGzHelp.WriteArchiveItem(InStream);
OutGzHelp.WriteArchiveTail;
end
else begin
{ it's coming from a file }
GetDir(0, SaveDir);
try {SaveDir}
if (BaseDirectory <> '') then
ChDir(BaseDirectory);
CurItem.LastModTimeAsDateTime := AbGetFileTime(CurItem.DiskFileName);
UncompressedStream := TFileStream.Create(CurItem.DiskFileName,
fmOpenRead or fmShareDenyWrite );
finally {SaveDir}
ChDir( SaveDir );
end; {SaveDir}
try
CurItem.UncompressedSize := UncompressedStream.Size;
CurItem.SaveGzHeaderToStream(NewStream);
OutGzHelp.WriteArchiveItem(UncompressedStream);
OutGzHelp.WriteArchiveTail;
finally {UncompressedStream}
UncompressedStream.Free;
end; {UncompressedStream}
end;
except
ItemList[i].Action := aaDelete;
DoProcessItemFailure(ItemList[i], ptAdd, ecFileOpenError, 0);
end;
end;
end; {case}
end; { for }
end;
finally
InGzHelp.Free;
end;
{copy new stream to FStream}
SwapToGzip;
NewStream.Position := 0;
if (FStream is TMemoryStream) then
TMemoryStream(FStream).LoadFromStream(NewStream)
else if FOwnsStream then begin
{ need new stream to write }
FreeAndNil(FStream);
FGZStream := nil;
FStream := TFileStream.Create(FArchiveName, fmCreate or fmShareDenyWrite);
FGZStream := FStream;
FStream.CopyFrom(NewStream, NewStream.Size);
end
else begin
FStream.Size := 0;
FStream.Position := 0;
FStream.CopyFrom(NewStream, NewStream.Size);
end;
{update Items list}
for i := pred( Count ) downto 0 do begin
if ItemList[i].Action = aaDelete then
FItemList.Delete( i )
else if ItemList[i].Action <> aaFailed then
ItemList[i].Action := aaNone;
end;
if IsGzippedTar and TarAutoHandle then
SwapToTar;
DoArchiveSaveProgress( 100, Abort );
DoArchiveProgress( 100, Abort );
finally {NewStream}
OutGzHelp.Free;
NewStream.Free;
end;
end;
procedure TAbGzipArchive.SetTarAutoHandle(const Value: Boolean);
begin
if Value then
SwapToTar
else
SwapToGzip;
FTarAutoHandle := Value;
end;
procedure TAbGzipArchive.TestItemAt(Index: Integer);
var
SavePos : LongInt;
GZType : TAbArchiveType;
BitBucket : TAbBitBucketStream;
GZHelp : TAbGzipStreamHelper;
begin
if IsGzippedTar and TarAutoHandle then begin
inherited TestItemAt(Index);
end
else begin
{ note Index ignored as there's only one item in a GZip }
SavePos := FGzStream.Position;
GZType := VerifyGZip(FGZStream);
if not (GZType in [atGZip, atGZippedTar]) then
raise EAbGzipInvalid.Create;
BitBucket := nil;
GZHelp := nil;
try
BitBucket := TAbBitBucketStream.Create(1024);
GZHelp := TAbGzipStreamHelper.Create(FGZStream);
GZHelp.ExtractItemData(BitBucket);
GZHelp.ReadTail;
{ validate against CRC }
if GzHelp.FItem.Crc32 <> GZHelp.TailCRC then
raise EAbGzipBadCRC.Create;
{ validate against file size }
if GzHelp.FItem.UncompressedSize <> GZHelp.TailSize then
raise EAbGzipBadFileSize.Create;
finally
GZHelp.Free;
BitBucket.Free;
end;
FGzStream.Position := SavePos;
end;
end;
procedure TAbGzipArchive.DoSpanningMediaRequest(Sender: TObject;
ImageNumber: Integer; var ImageName: string; var Abort: Boolean);
begin
Abort := False;
end;
end.
================================================
FILE: lib/abbrevia/source/AbHexVw.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* Abbrevia: AbHexVw.pas *}
{*********************************************************}
{* Abbrevia: Hex View utility *}
{*********************************************************}
{$I AbDefine.inc}
{$IFNDEF UsingCLX}
unit AbHexVw;
{$ENDIF}
interface
uses
Classes,
{$IFDEF UsingCLX}
QStdCtrls, QGraphics,
{$ELSE}
StdCtrls, Graphics,
{$ENDIF}
SysUtils;
type
THexView = class(TMemo)
protected
FBlockSize : Integer;
public
procedure SetStream(Strm : TStream);
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
property Stream : TStream write SetStream;
property BlockSize : Integer read FBlockSize write FBlockSize;
end;
implementation
{$IFDEF HasUITypes}
uses
System.UITypes;
{$ENDIF}
constructor THexView.Create(AOwner : TComponent);
begin
Inherited Create(AOwner);
Font.Style := Font.Style + [fsBold];
ReadOnly := True;
ScrollBars := ssVertical;
WordWrap := False;
WantTabs := True;
FBlockSize := 512;
end;
destructor THexView.Destroy;
begin
inherited Destroy;
end;
procedure THexView.SetStream(Strm : TStream);
var
Buff : Array[0..15] of Byte;
i, j : Integer;
Str : String;
StrList : TStringList;
begin
Strm.Seek(0, soBeginning);
StrList := TStringList.Create;
Clear;
while Strm.Position < Strm.Size do begin
if ((Strm.Position mod FBlockSize) = 0) then
StrList.Add('===========================================================');
Str := '';
for j := 0 to 15 do
Buff[j] := Byte(chr(0));
Strm.Read(Buff, 16);
Str := Str + Format('%4.4X', [strm.Position - $10]) + ':' + #9;
for i := 0 to 15 do begin
Str := Str + Format('%2.2X', [Buff[i]]) + ' ';
if i = 7 then Str := Str + #9;
end;
Str := Str + #9;
for i := 0 to 15 do begin
if (Buff[i] < $30) then
Buff[i] := byte('.');
Str := Str + Char(Buff[i]);
end;
StrList.Add(Str);
end;
SetLines(StrList);
StrList.Free;
end;
end.
================================================
FILE: lib/abbrevia/source/AbLZMA.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is Craig Peterson
*
* Portions created by the Initial Developer are Copyright (C) 2011
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Craig Peterson
* Pierre le Riche
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbLZMA.pas *}
{*********************************************************}
{* ABBREVIA: Lzma compression/decompression procedures. *}
{*********************************************************}
unit AbLZMA;
{$I AbDefine.inc}
interface
uses
Classes, Windows, SysUtils, AbCrtl, AbUtils;
{ Raw LZMA decompression =================================================== }
{ Decompresses the LZMA compressed data in ASrc to ADes. ASrc should not have
the header used by the other compression/decompression routines, and
AProperties should contain any necessary data. }
procedure LzmaDecodeStream(AProperties: PByte; APropSize: Integer; ASrc, ADes: TStream;
AUncompressedSize: Int64 = -1); overload;
{ Stream compression and decompression (taken from LzmaUtil.c) ============= }
procedure LzmaDecodeStream(ASourceStream, ATargetStream: TStream); overload;
procedure LzmaEncodeStream(ASourceStream, ATargetStream: TStream; ASourceSize: Int64);
{ In-memory compression and decompression ================================== }
{ Given a pointer to the compressed data, this will return the size of the
decompressed data. }
function LzmaGetUncompressedSize(APCompressedData: Pointer; ACompressedSize: Integer): Integer;
{ Decompresses the LZMA compressed data at APCompressedData to the buffer
pointed to by APUncompressedData. The buffer at APUncompressedData should be
large enough to hold the number of bytes as returned by LzmaGetDecompressedSize. }
procedure LzmaDecodeBuffer(APCompressedData: Pointer; ACompressedSize: Integer;
APUncompressedData: Pointer);
{ Compresses the data at APUncompressedData to the buffer at APCompressedData,
and returns the number of bytes written. If ACompressedDataBufferCapacity is
less than the number of bytes required to store the entire compressed stream,
or any other error occurs, then an exception is raised. (A safe number for
ACompressedDataBufferCapacity is slightly more than AUncompressedDataBufferSize.)
Leave ACompressionLevel and ADictionarySize at -1 in order to use the default
values (5 and 16MB respectively). }
function LzmaEncodeBuffer(APUncompressedData: Pointer; AUncompressedSize: Integer;
APCompressedData: Pointer; ACompressedDataBufferCapacity: Integer;
ACompressionLevel: Integer = -1; ADictionarySize: Integer = -1): Integer;
{ Types.h declarations ===================================================== }
const
SZ_OK = 0;
SZ_ERROR_DATA = 1;
SZ_ERROR_MEM = 2;
SZ_ERROR_CRC = 3;
SZ_ERROR_UNSUPPORTED = 4;
SZ_ERROR_PARAM = 5;
SZ_ERROR_INPUT_EOF = 6;
SZ_ERROR_OUTPUT_EOF = 7;
SZ_ERROR_READ = 8;
SZ_ERROR_WRITE = 9;
SZ_ERROR_PROGRESS = 10;
SZ_ERROR_FAIL = 11;
SZ_ERROR_THREAD = 12;
SZ_ERROR_ARCHIVE = 16;
SZ_ERROR_NO_ARCHIVE = 17;
type
SRes = Integer;
ISeqInStream = packed record
Read: function(p: Pointer; var buf; var size: size_t): SRes; cdecl;
end;
PISeqInStream = ^ISeqInStream;
ISeqOutStream = packed record
Write: function(p: Pointer; const buf; size: size_t): size_t; cdecl;
end;
PISeqOutStream = ^ISeqOutStream;
ICompressProgress = packed record
Progress: function(p: Pointer; inSize, outSize: Int64): SRes; cdecl;
end;
PICompressProgress = ^ICompressProgress;
ISzAlloc = packed record
Alloc: function(p: Pointer; size: size_t): Pointer; cdecl;
Free: procedure(p: Pointer; address: Pointer); cdecl;
end;
PISzAlloc = ^ISzAlloc;
{ LzmaDec.h declarations =================================================== }
type
CLzmaProb = Word;
// LZMA Properties
const
LZMA_PROPS_SIZE = 5;
type
CLzmaProps = packed record
lc, lp, pb: Cardinal;
dicSize: UInt32;
end;
// LZMA Decoder state
const
LZMA_REQUIRED_INPUT_MAX = 20;
type
CLzmaDec = packed record
prop: CLzmaProps;
probs: ^CLzmaProb;
dic: PByte;
buf: PByte;
range, code: UInt32;
dicPos: size_t;
dicBufSize: size_t;
processedPos: UInt32;
checkDicSize: UInt32;
state: Cardinal;
reps: array[0..3] of UInt32;
remainLen: Cardinal;
needFlush: Integer;
needInitState: Integer;
numProbs: UInt32;
tempBufSize: Cardinal;
tempBuf: array[0..LZMA_REQUIRED_INPUT_MAX - 1] of Byte;
end;
type
ELzmaFinishMode = LongInt;
const
LZMA_FINISH_ANY = 0; // finish at any point
LZMA_FINISH_END = 1; // block must be finished at the end
type
ELzmaStatus = LongInt;
const
LZMA_STATUS_NOT_SPECIFIED = 0; // use main error code instead
LZMA_STATUS_FINISHED_WITH_MARK = 1; // stream was finished with end mark.
LZMA_STATUS_NOT_FINISHED = 3; // stream was not finished
LZMA_STATUS_NEEDS_MORE_INPUT = 4; // you must provide more input bytes
LZMA_STATUS_MAYBE_FINISHED_WITHOUT_MARK = 5; // there is probability that stream was finished without end mark
procedure LzmaDec_Construct(var p: CLzmaDec); cdecl;
procedure LzmaDec_Init(var p: CLzmaDec); cdecl; external;
function LzmaDec_DecodeToBuf(var p: CLzmaDec; dest: PByte; var destLen: size_t;
src: PByte; var srcLen: size_t; finishMode: ELzmaFinishMode;
var status: ELzmaStatus): SRes; cdecl; external;
function LzmaDec_Allocate(var state: CLzmaDec; prop: PByte; propsSize: Integer;
alloc: PISzAlloc): SRes; cdecl; external;
procedure LzmaDec_Free(var state: CLzmaDec; alloc: PISzAlloc); cdecl; external;
// One call decoding interface
function LzmaDecode(dest: PByte; var destLen: size_t; src: PByte;
var srcLen: size_t; propData: PByte; propSize: Integer;
finishMode: ELzmaFinishMode; var status: ELzmaStatus;
alloc: PISzAlloc): SRes; cdecl; external;
{ LzmaEnc.h declarations =================================================== }
type
CLzmaEncHandle = Pointer;
CLzmaEncProps = packed record
level: Integer; // 0 <= level <= 9
dictSize: UInt32; // (1 << 12) <= dictSize <= (1 << 27) for 32-bit version
// (1 << 12) <= dictSize <= (1 << 30) for 64-bit version
// default = (1 << 24)
lc: Integer; // 0 <= lc <= 8, default = 3
lp: Integer; // 0 <= lp <= 4, default = 0
pb: Integer; // 0 <= pb <= 4, default = 2
algo: Integer; // 0 - fast, 1 - normal, default = 1
fb: Integer; // 5 <= fb <= 273, default = 32
btMode: Integer; // 0 - hashChain Mode, 1 - binTree mode - normal, default = 1
numHashBytes: Integer; // 2, 3 or 4, default = 4
mc: UInt32; // 1 <= mc <= (1 << 30), default = 32
writeEndMark: Cardinal; // 0 - do not write EOPM, 1 - write EOPM, default = 0
numThreads: Integer; // 1 or 2, default = 2
end;
procedure LzmaEncProps_Init(var p: CLzmaEncProps); cdecl; external;
function LzmaEnc_Create(Alloc: PISzAlloc): CLzmaEncHandle; cdecl; external;
procedure LzmaEnc_Destroy(p: CLzmaEncHandle; Alloc, allocBig: PISzAlloc); cdecl; external;
function LzmaEnc_SetProps(p: CLzmaEncHandle; var props: CLzmaEncProps): SRes; cdecl; external;
function LzmaEnc_WriteProperties(p: CLzmaEncHandle; properties: PByte;
var size: size_t): SRes; cdecl; external;
function LzmaEnc_Encode(p: CLzmaEncHandle; outStream: PISeqOutStream;
inStream: PISeqInStream; Progress: PICompressProgress;
Alloc, allocBig: PISzAlloc): SRes; cdecl; external;
function LzmaEnc_MemEncode(p: CLzmaEncHandle; dest: PByte; var destLen: size_t;
src: PByte; srcLen: size_t; writeEndMark: Integer; Progress: PICompressProgress;
Alloc, allocBig: PISzAlloc): SRes; cdecl; external;
// One call encoding interface
function LzmaEncode(dest: PByte; var destLen: size_t; src: PByte;
srcLen: size_t; var props: CLzmaEncProps; propsEncoded: PByte;
var propsSize: size_t; writeEndMark: Integer; progress: PICompressProgress;
alloc: pISzAlloc; allocBig: PISzAlloc): SRes; cdecl; external;
{ LzFind.h declarations ==================================================== }
procedure MatchFinder_NeedMove; external;
procedure MatchFinder_GetPointerToCurrentPos; external;
procedure MatchFinder_MoveBlock; external;
procedure MatchFinder_ReadIfRequired; external;
procedure MatchFinder_Construct; external;
procedure MatchFinder_Create; external;
procedure MatchFinder_Free; external;
procedure MatchFinder_Normalize3; external;
procedure MatchFinder_ReduceOffsets; external;
procedure GetMatchesSpec1; external;
procedure MatchFinder_Init; external;
procedure MatchFinder_CreateVTable; external;
{ LzFindMt.h declarations ================================================== }
procedure MatchFinderMt_Construct; external;
procedure MatchFinderMt_Destruct; external;
procedure MatchFinderMt_Create; external;
procedure MatchFinderMt_CreateVTable; external;
procedure MatchFinderMt_ReleaseStream; external;
{ Lzma header fields ======================================================= }
type
// The condensed compression properties
TLZMAPropertyData = array[0..LZMA_PROPS_SIZE - 1] of Byte;
// The header usually stored in front of LZMA compressed data
TLZMAHeader = packed record
PropertyData: TLZMAPropertyData;
UncompressedSize: Int64;
end;
PLZMAHeader = ^TLZMAHeader;
{ Error handling =========================================================== }
type
EAbLZMAException = class(Exception);
procedure LzmaCheck(AResultCode: SRes);
procedure RaiseLzmaException(AResultCode: SRes);
{ Linker directives ======================================================== }
{$WARN BAD_GLOBAL_SYMBOL OFF}
{$IF DEFINED(WIN32)}
{$L Win32\LzFind.obj}
{$L Win32\LzFindMt.obj}
{$L Win32\LzmaDec.obj}
{$L Win32\LzmaEnc.obj}
{$L Win32\Threads.obj}
{$ELSEIF DEFINED(WIN64)}
{$L Win64\LzFind.obj}
{$L Win64\LzFindMt.obj}
{$L Win64\LzmaDec.obj}
{$L Win64\LzmaEnc.obj}
{$L Win64\Threads.obj}
{$IFEND}
implementation
{ Error handling =========================================================== }
procedure LzmaCheck(AResultCode: SRes);
begin
if AResultCode <> SZ_OK then
RaiseLzmaException(AResultCode);
end;
{ -------------------------------------------------------------------------- }
procedure RaiseLzmaException(AResultCode: SRes);
begin
case AResultCode of
SZ_ERROR_DATA: raise EAbLZMAException.Create('LZMA Data Error.');
SZ_ERROR_MEM: raise EAbLZMAException.Create('LZMA Memory Error.');
SZ_ERROR_CRC: raise EAbLZMAException.Create('LZMA CRC Error.');
SZ_ERROR_UNSUPPORTED: raise EAbLZMAException.Create('LZMA "Unsupported" Error.');
SZ_ERROR_PARAM: raise EAbLZMAException.Create('LZMA Parameter Error.');
SZ_ERROR_INPUT_EOF: raise EAbLZMAException.Create('LZMA Input EOF Error.');
SZ_ERROR_OUTPUT_EOF: raise EAbLZMAException.Create('LZMA Output EOF Error.');
SZ_ERROR_READ: raise EAbLZMAException.Create('LZMA Read Error.');
SZ_ERROR_WRITE: raise EAbLZMAException.Create('LZMA Write Error.');
SZ_ERROR_PROGRESS: raise EAbLZMAException.Create('LZMA Progress Error.');
SZ_ERROR_FAIL: raise EAbLZMAException.Create('LZMA "Fail" Error.');
SZ_ERROR_THREAD: raise EAbLZMAException.Create('LZMA Thread Error.');
SZ_ERROR_ARCHIVE: raise EAbLZMAException.Create('LZMA Archive Error.');
SZ_ERROR_NO_ARCHIVE: raise EAbLZMAException.Create('LZMA "No Archive" Error.');
else
raise EAbLZMAException.CreateFmt('Unknown LZMA error (%d)', [AResultCode]);
end;
end;
{ Helper Routines ========================================================== }
procedure LzmaDec_Construct(var p: CLzmaDec); cdecl;
begin
p.dic := nil;
p.probs := nil;
end;
{ -------------------------------------------------------------------------- }
function SzAlloc(p: Pointer; size: size_t): Pointer; cdecl;
begin
Result := GetMemory(size);
end;
{ -------------------------------------------------------------------------- }
procedure SzFree(p, address: Pointer); cdecl;
begin
FreeMemory(address);
end;
var
DelphiMMInterface: ISzAlloc = (Alloc: SzAlloc; Free: SzFree);
{ CSeq*Stream implementation =============================================== }
type
CSeqInStream = packed record
Intf: ISeqInStream;
Stream: TStream;
end;
CSeqOutStream = packed record
Intf: ISeqOutStream;
Stream: TStream;
end;
{ -------------------------------------------------------------------------- }
function ISeqInStream_Read(p: Pointer; var buf; var size: size_t): SRes; cdecl;
begin
try
size := CSeqInStream(p^).Stream.Read(buf, size);
Result := SZ_OK;
except
Result := SZ_ERROR_DATA;
end;
end;
{ -------------------------------------------------------------------------- }
function ISeqOutStream_Write(p: Pointer; const buf; size: size_t): size_t; cdecl;
begin
try
Result := CSeqOutStream(p^).Stream.Write(buf, size);
except
Result := 0;
end;
end;
{ Raw LZMA decompression =================================================== }
{ Decompress an Lzma compressed stream. Based on LzmaUtil.c::Decode2 }
function LzmaDecode2(var aState: CLzmaDec; aOutStream, aInStream: TStream;
aUncompressedSize: Int64 = -1): SRes;
const
IN_BUF_SIZE = 1 shl 16;
OUT_BUF_SIZE = 1 shl 16;
var
LHasSize: Boolean;
LInBuf: array [0..IN_BUF_SIZE - 1] of Byte;
LOutBuf: array [0..OUT_BUF_SIZE - 1] of Byte;
LInPos, LInSize, LOutPos: size_t;
LInProcessed, LOutProcessed: size_t;
LFinishMode: ELzmaFinishMode;
LStatus: ELzmaStatus;
begin
Result := 0;
LHasSize := aUncompressedSize <> -1;
LInPos := 0;
LInSize := 0;
LOutPos := 0;
LzmaDec_Init(aState);
while True do
begin
if LInPos = LInSize then
begin
LInSize := aInStream.Read(LInBuf, IN_BUF_SIZE);
LInPos := 0;
if LInSize = 0 then
Break;
end
else
begin
LInProcessed := LInSize - LInPos;
LOutProcessed := OUT_BUF_SIZE - LOutPos;
LFinishMode := LZMA_FINISH_ANY;
if LHasSize and (LOutProcessed > aUncompressedSize) then
begin
LOutProcessed := size_t(aUncompressedSize);
LFinishMode := LZMA_FINISH_END;
end;
Result := LzmaDec_DecodeToBuf(aState, @LOutBuf[LOutPos], LOutProcessed,
@LInBuf[LInPos], LInProcessed, LFinishMode, LStatus);
Inc(LInPos, LInProcessed);
Inc(LOutPos, LOutProcessed);
Dec(aUncompressedSize, LOutProcessed);
if (aOutStream <> nil) and (aOutStream.Write(LOutBuf, LOutPos) <> LOutPos) then
begin
Result := SZ_ERROR_WRITE;
Exit;
end;
LOutPos := 0;
if (Result <> SZ_OK) or (LHasSize and (aUncompressedSize = 0)) then
Exit;
if (LInProcessed = 0) and (LOutProcessed = 0) then
begin
if LHasSize or (LStatus <> LZMA_STATUS_FINISHED_WITH_MARK) then
Result := SZ_ERROR_DATA;
Exit;
end;
end;
end;
end;
{ -------------------------------------------------------------------------- }
{ Decompress an LZMA compressed stream. Pass AUncompressedSize = -1 if the
uncompressed size is not known. }
procedure LzmaDecodeStream(AProperties: PByte; APropSize: Integer;
ASrc, ADes: TStream; AUncompressedSize: Int64);
var
LLZMADecState: CLzmaDec;
begin
LzmaDec_Construct(LLZMADecState);
try
LzmaCheck(LzmaDec_Allocate(LLZMADecState, AProperties, APropSize, @DelphiMMInterface));
LzmaCheck(LzmaDecode2(LLZMADecState, ADes, ASrc, AUncompressedSize));
finally
LzmaDec_Free(LLZMADecState, @DelphiMMInterface);
end;
end;
{ Stream to stream compression and decompression =========================== }
{ Decompresses streams compressed with the LZMA SDK's LzmaUtil.exe.
Based on LzmaUtil.c::Decode }
procedure LzmaDecodeStream(ASourceStream, ATargetStream: TStream);
var
LUncompressedSize: Int64;
// Header: 5 bytes of LZMA properties and 8 bytes of uncompressed size
LHeader: TLZMAHeader;
begin
// Read and parse header
ASourceStream.ReadBuffer(LHeader, SizeOf(LHeader));
LUncompressedSize := LHeader.UncompressedSize;
LzmaDecodeStream(PByte(@LHeader.PropertyData), LZMA_PROPS_SIZE, ASourceStream,
ATargetStream, LUncompressedSize);
end;
{ -------------------------------------------------------------------------- }
{ Compresses a stream so it's compatible with the LZMA SDK's LzmaUtil.exe.
Based on LzmaUtil.c::Encode }
procedure LzmaEncodeStream(ASourceStream, ATargetStream: TStream; ASourceSize: Int64);
var
LEncHandle: CLzmaEncHandle;
LEncProps: CLzmaEncProps;
LHeader: TLZMAHeader;
LPropDataSize: size_t;
LInStreamRec: CSeqInStream;
LOutStreamRec: CSeqOutStream;
begin
LInStreamRec.Intf.Read := ISeqInStream_Read;
LInStreamRec.Stream := ASourceStream;
LOutStreamRec.Intf.Write := ISeqOutStream_Write;
LOutStreamRec.Stream := ATargetStream;
LEncHandle := LzmaEnc_Create(@DelphiMMInterface);
if LEncHandle = nil then
LzmaCheck(SZ_ERROR_MEM);
try
LzmaEncProps_Init(LEncProps);
LzmaCheck(LzmaEnc_SetProps(LEncHandle, LEncProps));
LPropDataSize := LZMA_PROPS_SIZE;
LzmaCheck(LzmaEnc_WriteProperties(LEncHandle, PByte(@LHeader.PropertyData),
LPropDataSize));
LHeader.UncompressedSize := ASourceSize;
ATargetStream.WriteBuffer(LHeader, SizeOf(LHeader));
LzmaCheck(LzmaEnc_Encode(LEncHandle, @LOutStreamRec.Intf,
@LInStreamRec.Intf, nil, @DelphiMMInterface, @DelphiMMInterface));
finally
LzmaEnc_Destroy(LEncHandle, @DelphiMMInterface, @DelphiMMInterface);
end;
end;
{ In-memory compression and decompression ================================== }
{ Given a pointer to the compressed data, this will return the size of the
decompressed data. }
function LzmaGetUncompressedSize(APCompressedData: Pointer; ACompressedSize: Integer): Integer;
begin
if ACompressedSize <= SizeOf(TLZMAHeader) then
raise EAbLZMAException.Create('The LZMA compressed data is invalid (not enough bytes)');
Result := PLZMAHeader(APCompressedData).UncompressedSize;
end;
{ -------------------------------------------------------------------------- }
{ Decompresses the LZMA compressed data at APCompressedData to the buffer
pointed to by APUncompressedData. The buffer at APUncompressedData should be
large enough to hold the number of bytes as returned by LzGetDecompressedSize. }
procedure LzmaDecodeBuffer(APCompressedData: Pointer; ACompressedSize: Integer;
APUncompressedData: Pointer);
var
LPropertyData: TLZMAPropertyData;
LUncompressedSize: Int64;
LInputByteCount, LOutputByteCount: size_t;
LStatus: ELzmaStatus;
begin
if ACompressedSize <= SizeOf(TLZMAHeader) then
raise EAbLZMAException.Create('The LZMA compressed data is invalid (not enough bytes)');
// Read the header from the compressed data.
LPropertyData := PLZMAHeader(APCompressedData).PropertyData;
LUncompressedSize := PLZMAHeader(APCompressedData).UncompressedSize;
Inc(PAnsiChar(APCompressedData), SizeOf(TLZMAHeader));
Dec(ACompressedSize, SizeOf(TLZMAHeader));
// Decompress from the input to the output buffer. This will change the byte
// count variables to the actual number of bytes consumed/written.
LInputByteCount := ACompressedSize;
LOutputByteCount := LUncompressedSize;
LzmaCheck(LzmaDecode(APUncompressedData, LOutputByteCount,
APCompressedData, LInputByteCount, PByte(@LPropertyData), LZMA_PROPS_SIZE,
LZMA_FINISH_END, LStatus, @DelphiMMInterface));
// Check that the input buffer was fully consumed and the output buffer was filled up.
if (LOutputByteCount <> LUncompressedSize) or (LInputByteCount <> ACompressedSize) then
raise EAbLZMAException.Create('LZMA decompression data error');
end;
{ -------------------------------------------------------------------------- }
{ Compresses the data at APUncompressedData to the buffer at APCompressedData,
and returns the number of bytes written. If ACompressedDataBufferCapacity is
less than the number of bytes required to store the entire compressed stream,
or any other error occurs, then an exception is raised. (A safe number for
ACompressedDataBufferCapacity is slightly more than AUncompressedDataBufferSize.)
Leave ACompressionLevel and ADictionarySize at -1 in order to use the default
values (5 and 16MB respectively). }
function LzmaEncodeBuffer(APUncompressedData: Pointer; AUncompressedSize: Integer;
APCompressedData: Pointer;
ACompressedDataBufferCapacity, ACompressionLevel, ADictionarySize: Integer): Integer;
var
LEncProps: CLzmaEncProps;
LPropsSize: size_t;
LPOutBuf: PByte;
LOutputBytes: size_t;
begin
if ACompressedDataBufferCapacity <= SizeOf(TLZMAHeader) then
raise EAbLZMAException.Create('LZMA output buffer too small');
// Set the uncompressed size in the header
PLZMAHeader(APCompressedData).UncompressedSize := AUncompressedSize;
// Set the properties
LzmaEncProps_Init(LEncProps);
if ACompressionLevel >= 0 then
LEncProps.level := ACompressionLevel;
if ADictionarySize >= 0 then
LEncProps.dictSize := ADictionarySize;
LPOutBuf := PByte(PtrUInt(APCompressedData) + SizeOf(TLZMAHeader));
LOutputBytes := ACompressedDataBufferCapacity - SizeOf(TLZMAHeader);
LPropsSize := LZMA_PROPS_SIZE;
LzmaCheck(LzmaEncode(LPOutBuf, LOutputBytes, APUncompressedData,
AUncompressedSize, LEncProps, APCompressedData, LPropsSize, 0, nil,
@DelphiMMInterface, @DelphiMMInterface));
Result := LOutputBytes + SizeOf(TLZMAHeader);
end;
initialization
// The LZMA routines are multithreaded and use the Delphi memory manager.
IsMultiThread := True;
end.
================================================
FILE: lib/abbrevia/source/AbLZMAStream.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is Pierre le Riche
*
* Portions created by the Initial Developer are Copyright (C) 2011
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Pierre le Riche
* Craig Peterson
*
* ***** END LICENSE BLOCK *****
Usage:
LZMA Compression:
1) Create a TAbLZMACompressionStream, passing as parameter to the constructor
the output stream where you want the compressed data stored.
2) Write the data that you want to compress to the TAbLZMACompressionStream.
Compression occurs in a background thread.
3) (Optional) Notify the background compression thread that no more data will
be written by calling NoMoreDataToCompress. Poll the IsBusy method to
determine whether the background thread is still busy.
4) Free the TAbLZMACompressionStream to finish up and release resources. The
compressed data will now be available in the output stream.
LZMA Decompression:
1) Create a TAbLZMADecompressionStream, passing as parameter to the constructor
the stream that contains the compressed data.
2) Read the decompressed data from TAbLZMADecompressionStream.
3) Free the TAbLZMADecompressionStream to finish up and release resources.
*)
unit AbLZMAStream;
{$I AbDefine.inc}
interface
uses
Windows, Classes, SysUtils, AbLZMA, AbUtils;
const
{The size of the intermediate buffers for compressed and decompressed data.}
CompressedDataBufferSize = 16 * 1024;
UncompressedDataBufferSize = 32 * 1024;
{When reading/writing very small blocks from/to a (de)compression stream an
intermediate buffer is used to buffer the small IO operations in order to
improve performance. Reads and writes larger than this size are unbuffered
and handled by the (de)compression algorithm directly. This value must be
smaller than the compressed and uncompressed data buffers.}
MaximumBlockSizeForBufferedIO = 1024;
type
{------------LZMA compression stream------------}
TAbLZMACompressionStream = class;
{The background compression thread.}
TAbLZMACompressionThread = class(TThread)
protected
FCompressionStream: TAbLZMACompressionStream;
{$IFNDEF HasThreadFinished}
FFinished: Boolean;
procedure DoTerminate; override;
property Finished: Boolean read FFinished;
{$ENDIF}
public
procedure Execute; override;
end;
{Buffers queued for compression by the background compression thread.}
PAbQueuedBuffer = ^TAbQueuedBuffer;
TAbQueuedBuffer = packed record
PreviousBuffer, NextBuffer: PAbQueuedBuffer;
DataSize: Integer;
{Adds this buffer to the compression queue for the given compression stream.
It is assumed that the compression stream has acquired the buffer critical
section.}
procedure QueueBuffer(ACompressionStream: TAbLZMACompressionStream);
{Removes this buffer from the compression queue}
procedure UnQueueBuffer;
{Returns a pointer to the data the given offset into the buffer}
function GetDataPointer(AOffset: Integer): Pointer;
end;
TAbLZMACompressionStream = class(TStream)
protected
FOutputStream: TStream;
{The critical section used to control access to the buffers that are queued
for compression. The main thread and the compression thread may not access
the buffer queue at the same time.}
FBufferCriticalSection: TRTLCriticalSection;
{This semaphore is signalled by the main thread when it added a workload
for the compression thread (usually when a buffer has been added to
compress).}
FPendingWorkSemaphore: THandle;
{The LZMA compression handle}
FLZMAEncHandle: CLzmaEncHandle;
{The background thread used to perform the compression}
FCompressionThread: TAbLZMACompressionThread;
{The error code returned by the compression method. 0 = Success.}
FCompressionErrorCode: Integer;
{The intermediate compression buffer used to aggregate small writes. When
NoMoreDataToCompress is called this buffer is freed, so no more data may
be written.}
FPIntermediateCompressionBuffer: PAbQueuedBuffer;
FIntermediateCompressionBufferAvailableBytes: Integer;
{The circular linked list of buffers that are queued for compression.}
FQueuedData: TAbQueuedBuffer;
{The number of bytes of buffer FQueuedData.NextBuffer that has already been
submitted to the compressor.}
FCurrentBufferBytesSubmitted: Integer;
{The position in the output stream where the uncompressed size must be
stored.}
FOutputStreamHeaderSizeFieldPosition: Int64;
{The total number of bytes written to the compression stream}
FTotalBytesWritten: Int64;
{Wakes up the compression thread by signalling the "pending work semaphore"}
procedure WakeCompressionThread; inline;
public
constructor Create(AOutputStream: TStream; ACompressionLevel: Integer = 5;
ADictionarySize: Integer = 65536);
destructor Destroy; override;
{Reading is not supported and will raise an exception.}
function Read(var ABuffer; ACount: Longint): Longint; override;
{Submits data to the compression queue.}
function Write(const ABuffer; ACount: Longint): Longint; override;
{Will raise an exception if an attempt is made to seek off the current
position.}
function Seek(AOffset: Integer; AOrigin: Word): Integer; override;
function Seek(const AOffset: Int64; AOrigin: TSeekOrigin): Int64; override;
{Signals the compression thread that no more data will be submitted.
Calling write after NoMoreDataToCompress has been called will raise an
exception.}
procedure NoMoreDataToCompress;
{Calls NoMoreDataToCompress and then waits for the background compression
process to complete, returning the value of ErrorCode (0 = success).}
function WaitForCompressionToFinish: Integer;
{Returns True if the background thread is still busy compressing data. Will
always return True until NoMoreDataToCompress is called.}
function IsBusy: Boolean;
{-------------Public properties---------------}
{The error code returned by the compression method. 0 = Success.}
property ErrorCode: Integer read FCompressionErrorCode;
end;
{------------LZMA decompression stream------------}
TAbLZMADecompressionStream = class(TStream)
protected
FSourceStream: TStream;
{The intermediate buffers for compressed and uncompressed data
respectively.}
FCompressedDataBuffer: array[0..CompressedDataBufferSize - 1] of Byte;
FUncompressedDataBuffer: array[0..UncompressedDataBufferSize - 1] of Byte;
{Read buffer control: Used to speed up frequent small reads via
FUncompressedDataBuffer.}
FReadBufferSize: Integer;
FReadBufferAvailableBytes: Integer;
{The current size and position into FCompressedDataBuffer}
FCompressedDataBufferSize: Integer;
FCompressedDataBufferPosition: Integer;
{The uncompressed size according to the header.}
FUncompressedSize: Int64;
{The total number of bytes that have been decompressed.}
FBytesDecompressed: Int64;
{The LZMA decompression state}
FLzmaState: CLzmaDec;
{Decompresses data from the compressed source to the buffer pointed to by
APBuffer. Returns the number of actual bytes stored (which may be less
than the requested size if the end of the compressed stream was reached).}
function InternalDecompressToBuffer(APBuffer: Pointer; ABufferSize: Integer): Integer;
{---Property getters/setters---}
function GetBytesRead: Int64;
function GetSize: Int64; override;
public
constructor Create(ASourceStream: TStream);
destructor Destroy; override;
function Read(var ABuffer; ACount: Integer): Integer; override;
{Writing to a decompression stream is not allowed}
function Write(const ABuffer; ACount: Integer): Integer; override;
{Will raise an exception if an attempt is made to seek off the current
position.}
function Seek(AOffset: Integer; AOrigin: Word): Integer; override;
function Seek(const AOffset: Int64; AOrigin: TSeekOrigin): Int64; override;
{---Public properties---}
{The number of decompressed bytes read from the decompression stream.}
property BytesRead: Int64 read GetBytesRead;
end;
implementation
uses
AbCrtl;
{------------Memory management-------------}
function SzAlloc(p: Pointer; size: size_t): Pointer; cdecl;
begin
Result := GetMemory(size);
end;
procedure SzFree(p, address: Pointer); cdecl;
begin
FreeMemory(address);
end;
var
DelphiMMInterface: ISzAlloc = (Alloc: SzAlloc; Free: SzFree);
{------------Compression "interface"-------------}
type
{The "interfaces" for the input and output streams}
CSeqInStream_Compress = packed record
Intf: ISeqInStream;
CompressionStream: TAbLZMACompressionStream;
end;
CSeqOutStream_Compress = packed record
Intf: ISeqOutStream;
OutputStream: TStream;
end;
function ISeqInStream_Compress_Read(p: Pointer; var buf; var size: size_t): SRes; cdecl;
var
LDoNotWaitForMoreData: Boolean;
LStream: TAbLZMACompressionStream;
LPSourceBuf, LPTargetBuf: PAnsiChar;
LTargetSpace, LSourceBytesAvail: Integer;
LPCurBuf: PAbQueuedBuffer;
begin
try
LTargetSpace := size;
LPTargetBuf := @buf;
LStream := CSeqInStream_Compress(p^).CompressionStream;
while True do
begin
{Copy any buffered data to the LZMA buffer, returning the number of bytes
written}
EnterCriticalSection(LStream.FBufferCriticalSection);
try
{If the write buffer has been freed that the main thread will not add
any more buffers for compression.}
LDoNotWaitForMoreData := LStream.FPIntermediateCompressionBuffer = nil;
{Copy as much queued data to the LZMA compression buffer as we have (or
will fit).}
while True do
begin
LPCurBuf := LStream.FQueuedData.NextBuffer;
{No buffers left? -> Break the loop}
if LPCurBuf = @LStream.FQueuedData then
Break;
{Can this buffer be submitted in its entirety, or only a part?}
LPSourceBuf := LPCurBuf.GetDataPointer(LStream.FCurrentBufferBytesSubmitted);
LSourceBytesAvail := LPCurBuf.DataSize - LStream.FCurrentBufferBytesSubmitted;
if LSourceBytesAvail > LTargetSpace then
begin
{Submit only part of the buffer}
System.Move(LPSourceBuf^, LPTargetBuf^, LTargetSpace);
Inc(LStream.FCurrentBufferBytesSubmitted, LTargetSpace);
LTargetSpace := 0;
Break;
end
else
begin
{Submit all the remaining bytes in the buffer and free it.}
System.Move(LPSourceBuf^, LPTargetBuf^, LSourceBytesAvail);
Inc(LPTargetBuf, LSourceBytesAvail);
Dec(LTargetSpace, LSourceBytesAvail);
LStream.FCurrentBufferBytesSubmitted := 0;
LPCurBuf.UnQueueBuffer;
FreeMem(LPCurBuf);
end;
end;
finally
LeaveCriticalSection(LStream.FBufferCriticalSection);
end;
{If data was submitted to the compressor, or the main thread indicated
that compression is complete then the loop is broken.}
if (LTargetSpace <> size) or LDoNotWaitForMoreData then
Break;
{No data currently queued, but there may still be more coming: Wait for
the main thread to notify this thread that more work is pending.}
WaitForSingleObject(LStream.FPendingWorkSemaphore, INFINITE);
end;
{Update the number of bytes written}
Dec(size, LTargetSpace);
Result := SZ_OK;
except
Result := SZ_ERROR_DATA;
end;
end;
function ISeqOutStream_Compress_Write(p: Pointer; const buf; size: size_t): size_t; cdecl;
begin
try
Result := CSeqOutStream_Compress(p^).OutputStream.Write(buf, size);
except
Result := 0;
end;
end;
{ TAbQueuedBuffer }
function TAbQueuedBuffer.GetDataPointer(AOffset: Integer): Pointer;
begin
Result := Pointer(PtrUInt(@Self) + SizeOf(TAbQueuedBuffer) + PtrUInt(AOffset));
end;
procedure TAbQueuedBuffer.QueueBuffer(ACompressionStream: TAbLZMACompressionStream);
begin
PreviousBuffer:= ACompressionStream.FQueuedData.PreviousBuffer;
NextBuffer:= @ACompressionStream.FQueuedData;
ACompressionStream.FQueuedData.PreviousBuffer.NextBuffer := @Self;
ACompressionStream.FQueuedData.PreviousBuffer := @Self;
end;
procedure TAbQueuedBuffer.UnQueueBuffer;
begin
PreviousBuffer.NextBuffer := NextBuffer;
NextBuffer.PreviousBuffer := PreviousBuffer;
PreviousBuffer := nil;
NextBuffer := nil;
end;
{ TAbLZMACompressionStream }
constructor TAbLZMACompressionStream.Create(AOutputStream: TStream; ACompressionLevel,
ADictionarySize: Integer);
var
LLZMAProps: CLzmaEncProps;
LLZMAPropData: TLZMAPropertyData;
LHeaderSize: size_t;
begin
inherited Create;
FOutputStream := AOutputStream;
{Initialize the linked list of buffers.}
FQueuedData.PreviousBuffer := @FQueuedData;
FQueuedData.NextBuffer := @FQueuedData;
{Allocate the intermediate compression buffer}
GetMem(FPIntermediateCompressionBuffer, UncompressedDataBufferSize + SizeOf(TAbQueuedBuffer));
FIntermediateCompressionBufferAvailableBytes := UncompressedDataBufferSize;
{Initialize the critical section used to control access to the queued data
buffer.}
InitializeCriticalSection(FBufferCriticalSection);
{Create the semaphore used to put the worker thread to sleep when the input
buffer is empty.}
FPendingWorkSemaphore := CreateSemaphore(nil, 0, 1, nil);
{Create the LZMA encoder}
FLZMAEncHandle := LzmaEnc_Create(@DelphiMMInterface);
if FLZMAEncHandle = nil then
raise Exception.Create('Unable to allocate memory for the LZMA compressor.');
{Set the compression properties}
LzmaEncProps_Init(LLZMAProps);
LLZMAProps.level := ACompressionLevel;
LLZMAProps.dictSize := ADictionarySize;
LzmaCheck(LzmaEnc_SetProps(FLZMAEncHandle, LLZMAProps));
{Store the header in the output stream, making note of the position in the
stream where the uncompressed size will be stored when compression is
completed.}
LHeaderSize := LZMA_PROPS_SIZE;
LzmaCheck(LzmaEnc_WriteProperties(FLZMAEncHandle, PByte(@LLZMAPropData), LHeaderSize));
FOutputStream.WriteBuffer(LLZMAPropData, LHeaderSize);
FOutputStreamHeaderSizeFieldPosition := FOutputStream.Position;
FOutputStream.WriteBuffer(FTotalBytesWritten, SizeOf(FTotalBytesWritten));
{Create and start the compression thread.}
FCompressionThread := TAbLZMACompressionThread.Create(True);
FCompressionThread.FCompressionStream := Self;
{$IFDEF HasThreadStart}
FCompressionThread.Start;
{$ELSE}
FCompressionThread.Resume;
{$ENDIF}
end;
destructor TAbLZMACompressionStream.Destroy;
var
LPBuf: PAbQueuedBuffer;
LOldPos: Int64;
begin
WaitForCompressionToFinish;
{If something went wrong during creation of this object before the thread was
created, then the encoder handle may be non-nil.}
if FLZMAEncHandle <> nil then
begin
LzmaEnc_Destroy(FLZMAEncHandle, @DelphiMMInterface, @DelphiMMInterface);
FLZMAEncHandle := nil;
end;
{Free the critical section and semaphore}
DeleteCriticalSection(FBufferCriticalSection);
CloseHandle(FPendingWorkSemaphore);
{Free the intermediate compression buffer if something went wrong before the
thread could be created.}
FreeMem(FPIntermediateCompressionBuffer);
{If compression failed there may be uncompressed data in the queue: free
those buffers.}
while True do
begin
LPBuf := FQueuedData.NextBuffer;
if LPBuf = @FQueuedData then
Break;
LPBuf.UnQueueBuffer;
FreeMem(LPBuf);
end;
{Unpdate the uncompressed size in the header}
if FTotalBytesWritten > 0 then
begin
LOldPos := FOutputStream.Position;
FOutputStream.Position := FOutputStreamHeaderSizeFieldPosition;
FOutputStream.WriteBuffer(FTotalBytesWritten, SizeOf(FTotalBytesWritten));
FOutputStream.Position := LOldPos;
end;
inherited Destroy;
end;
function TAbLZMACompressionStream.IsBusy: Boolean;
begin
Result := (FCompressionThread <> nil) and (not FCompressionThread.Finished);
end;
procedure TAbLZMACompressionStream.NoMoreDataToCompress;
var
LUnqueuedBytes: Integer;
begin
if FPIntermediateCompressionBuffer <> nil then
begin
EnterCriticalSection(FBufferCriticalSection);
try
{No more data may be submitted at this point. Set the flag to indicate
this, and wake the compression thread so that it can finish up.}
LUnqueuedBytes := UncompressedDataBufferSize - FIntermediateCompressionBufferAvailableBytes;
if LUnqueuedBytes > 0 then
begin
FPIntermediateCompressionBuffer.DataSize := LUnqueuedBytes;
FPIntermediateCompressionBuffer.QueueBuffer(Self);
end
else
FreeMem(FPIntermediateCompressionBuffer);
{The temporary buffer is always released, so no further writes may be
performed.}
FPIntermediateCompressionBuffer := nil;
finally
LeaveCriticalSection(FBufferCriticalSection);
end;
{Wake up the compression thread so it can finish the compression process.}
WakeCompressionThread;
end;
end;
function TAbLZMACompressionStream.Read(var ABuffer; ACount: Integer): Longint;
begin
raise Exception.Create('The compression stream does not support reading.');
end;
function TAbLZMACompressionStream.Seek(const AOffset: Int64;
AOrigin: TSeekOrigin): Int64;
begin
Result := FTotalBytesWritten;
if ((AOrigin <> soBeginning) or (AOffset <> Result))
and ((AOrigin = soBeginning) or (AOffset <> 0)) then
begin
raise Exception.Create('The compression stream does not support seeking away from the current position.');
end;
end;
function TAbLZMACompressionStream.Seek(AOffset: Integer; AOrigin: Word): Integer;
begin
Result := Seek(Int64(AOffset), TSeekOrigin(AOrigin));
end;
function TAbLZMACompressionStream.WaitForCompressionToFinish: Integer;
begin
if FCompressionThread <> nil then
begin
{Notify the thread that no further data will be submitted.}
NoMoreDataToCompress;
{Wait for the compression thread to complete normally and then free it.}
FCompressionThread.WaitFor;
FreeAndNil(FCompressionThread);
end;
Result := FCompressionErrorCode;
end;
procedure TAbLZMACompressionStream.WakeCompressionThread;
begin
ReleaseSemaphore(FPendingWorkSemaphore, 1, nil);
end;
function TAbLZMACompressionStream.Write(const ABuffer; ACount: Integer): Longint;
var
LPSource: PAnsiChar;
LPBufData: Pointer;
LPLargeBuf: PAbQueuedBuffer;
begin
if FPIntermediateCompressionBuffer = nil then
raise Exception.Create('Write may not be called after NoMoreDataToCompress.');
if ACount <= 0 then
begin
Result := 0;
Exit;
end;
LPSource := @ABuffer;
{Get a pointer to the position in the intermediate buffer to be written.}
LPBufData := FPIntermediateCompressionBuffer.GetDataPointer(
UncompressedDataBufferSize - FIntermediateCompressionBufferAvailableBytes);
if FIntermediateCompressionBufferAvailableBytes > ACount then
begin
{Copy the data into the intermediate buffer and exit.}
System.Move(LPSource^, LPBufData^, ACount);
Dec(FIntermediateCompressionBufferAvailableBytes, ACount);
Result := ACount;
end
else
begin
{Fill up the intermediate buffer}
System.Move(LPSource^, LPBufData^, FIntermediateCompressionBufferAvailableBytes);
Dec(ACount, FIntermediateCompressionBufferAvailableBytes);
Inc(LPSource, FIntermediateCompressionBufferAvailableBytes);
Result := FIntermediateCompressionBufferAvailableBytes;
{If we get here the current intermediate buffer is now full, and must be
queued.}
EnterCriticalSection(FBufferCriticalSection);
try
{Insert this buffer into the compression queue.}
FPIntermediateCompressionBuffer.DataSize := UncompressedDataBufferSize;
FPIntermediateCompressionBuffer.QueueBuffer(Self);
{Allocate a new intermediate compression buffer}
GetMem(FPIntermediateCompressionBuffer, UncompressedDataBufferSize + SizeOf(TAbQueuedBuffer));
FIntermediateCompressionBufferAvailableBytes := UncompressedDataBufferSize;
{Should the remaining data be copied into the intermediate compression
buffer, or is it too large and must it be queued separately?}
if ACount < UncompressedDataBufferSize then
begin
LPBufData := FPIntermediateCompressionBuffer.GetDataPointer(0);
System.Move(LPSource^, LPBufData^, ACount);
Dec(FIntermediateCompressionBufferAvailableBytes, ACount);
end
else
begin
{The remaining data is larger than the intermediate buffer: queue it
separately}
GetMem(LPLargeBuf, ACount + SizeOf(TAbQueuedBuffer));
LPLargeBuf.DataSize := ACount;
LPLargeBuf.QueueBuffer(Self);
{Copy the data across}
LPBufData := LPLargeBuf.GetDataPointer(0);
System.Move(LPSource^, LPBufData^, ACount);
end;
{Update the number of bytes written}
Inc(Result, ACount);
finally
LeaveCriticalSection(FBufferCriticalSection);
end;
{Wake up the compression thread to compress the newly queued data}
WakeCompressionThread;
end;
Inc(FTotalBytesWritten, Result);
end;
{ TAbLZMACompressionThread }
{$IFNDEF HasThreadFinished}
procedure TAbLZMACompressionThread.DoTerminate;
begin
inherited DoTerminate;
FFinished := True;
end;
{$ENDIF}
procedure TAbLZMACompressionThread.Execute;
var
LInStreamRec: CSeqInStream_Compress;
LOutStreamRec: CSeqOutStream_Compress;
begin
{Call the compression function and save the error code}
LInStreamRec.Intf.Read := ISeqInStream_Compress_Read;
LInStreamRec.CompressionStream := FCompressionStream;
LOutStreamRec.Intf.Write := ISeqOutStream_Compress_Write;
LOutStreamRec.OutputStream := FCompressionStream.FOutputStream;
FCompressionStream.FCompressionErrorCode := LzmaEnc_Encode(FCompressionStream.FLZMAEncHandle,
@LOutStreamRec.Intf, @LInStreamRec.Intf, nil, @DelphiMMInterface, @DelphiMMInterface);
{Free the compression handle}
LzmaEnc_Destroy(FCompressionStream.FLZMAEncHandle, @DelphiMMInterface, @DelphiMMInterface);
FCompressionStream.FLZMAEncHandle := nil;
end;
{ TAbLZMADecompressionStream }
constructor TAbLZMADecompressionStream.Create(ASourceStream: TStream);
var
LLZMAPropData: TLZMAPropertyData;
begin
inherited Create;
FSourceStream := ASourceStream;
{Read the header and uncompressed size from the compressed data stream.}
FSourceStream.ReadBuffer(LLZMAPropData, LZMA_PROPS_SIZE);
FSourceStream.ReadBuffer(FUncompressedSize, SizeOf(FUncompressedSize));
{Initialize the decompressor using the information from the header}
LzmaDec_Construct(FLzmaState);
LzmaCheck(LzmaDec_Allocate(FLzmaState, PByte(@LLZMAPropData), LZMA_PROPS_SIZE,
@DelphiMMInterface));
LzmaDec_Init(FLzmaState);
end;
destructor TAbLZMADecompressionStream.Destroy;
var
LUnusedBytes: Integer;
begin
{Release all decompression resources.}
LzmaDec_Free(FLzmaState, @DelphiMMInterface);
{Any unconsumed bytes in the compressed input buffer should be returned to
the source stream.}
LUnusedBytes := FCompressedDataBufferSize - FCompressedDataBufferPosition;
if LUnusedBytes > 0 then
FSourceStream.Position := FSourceStream.Position - LUnusedBytes;
inherited Destroy;
end;
function TAbLZMADecompressionStream.GetBytesRead: Int64;
begin
Result := FBytesDecompressed - FReadBufferAvailableBytes;
end;
function TAbLZMADecompressionStream.GetSize: Int64;
begin
Result := FUncompressedSize;
end;
function TAbLZMADecompressionStream.InternalDecompressToBuffer(APBuffer: Pointer;
ABufferSize: Integer): Integer;
var
LInputBytesProcessed, LOutputBytesProcessed: size_t;
LFinishMode: Integer;
LStatus: ELzmaStatus;
begin
Result := 0;
{Any more data to decompress to the output buffer?}
while ABufferSize > 0 do
begin
{Read more compressed data into the compressed data buffer, if required.}
if FCompressedDataBufferPosition >= FCompressedDataBufferSize then
begin
FCompressedDataBufferSize := FSourceStream.Read(FCompressedDataBuffer,
CompressedDataBufferSize);
FCompressedDataBufferPosition := 0;
end;
{Initialize the "processed byte count" variables to the sizes of the input
and output buffers.}
LInputBytesProcessed := FCompressedDataBufferSize - FCompressedDataBufferPosition;
LOutputBytesProcessed := ABufferSize;
{We may not read more bytes than the number of uncompressed bytes according
to the header.}
if (FUncompressedSize - FBytesDecompressed) <= LOutputBytesProcessed then
begin
LOutputBytesProcessed := FUncompressedSize - FBytesDecompressed;
LFinishMode := LZMA_FINISH_END;
end
else
LFinishMode := LZMA_FINISH_ANY;
{Decompress from the input to the output buffer}
LzmaCheck(LzmaDec_DecodeToBuf(FLzmaState, APBuffer,
LOutputBytesProcessed, @FCompressedDataBuffer[FCompressedDataBufferPosition],
LInputBytesProcessed, LFinishMode, LStatus));
{Update the input and output buffer stats}
Inc(FCompressedDataBufferPosition, LInputBytesProcessed);
Inc(PAnsiChar(APBuffer), LOutputBytesProcessed);
Dec(ABufferSize, LOutputBytesProcessed);
{Update the number of bytes decompressed}
Inc(Result, LOutputBytesProcessed);
Inc(FBytesDecompressed, LOutputBytesProcessed);
{Was all the data decompressed? If so, break the loop.}
if FUncompressedSize = FBytesDecompressed then
Break;
{Was nothing from the input or output streams processed? If so, then
something has gone wrong.}
if (LInputBytesProcessed = 0) and (LOutputBytesProcessed = 0) then
raise Exception.Create('LZMA decompression data error');
end;
end;
function TAbLZMADecompressionStream.Read(var ABuffer; ACount: Integer): Integer;
var
LBytesAlreadyRead: Integer;
begin
{Anything to read?}
if ACount > 0 then
begin
{Do we have enough data in the read buffer to satisfy the request?}
if FReadBufferAvailableBytes >= ACount then
begin
{Enough data in the buffer: Fill the output buffer.}
System.Move(PAnsiChar(@FUncompressedDataBuffer)[FReadBufferSize - FReadBufferAvailableBytes],
ABuffer, ACount);
{Subtract from the available bytes in the read buffer.}
Dec(FReadBufferAvailableBytes, ACount);
{Successfully read the number of bytes requested}
Result := ACount;
end
else
begin
{Not enough bytes available in the read buffer: Is there anything
available in the uncompressed data buffer? If so, then transfer what we
have.}
if FReadBufferAvailableBytes > 0 then
begin
{There is some data in the buffer: Read everything}
System.Move(PAnsiChar(@FUncompressedDataBuffer)[FReadBufferSize - FReadBufferAvailableBytes],
ABuffer, FReadBufferAvailableBytes);
LBytesAlreadyRead := FReadBufferAvailableBytes;
FReadBufferAvailableBytes := 0;
end
else
LBytesAlreadyRead := 0;
{If we get here it means the read buffer has been emptied and some data
still has to be read: Do we need to fill up the read buffer again, or do
we read directly into the target buffer? Large reads bypass the read
buffering mechanism.}
if ACount <= MaximumBlockSizeForBufferedIO then
begin
{Try to fill the read buffer again}
FReadBufferSize := InternalDecompressToBuffer(@FUncompressedDataBuffer, UncompressedDataBufferSize);
FReadBufferAvailableBytes := FReadBufferSize;
{No more data available? If so we're done.}
if FReadBufferAvailableBytes = 0 then begin
Result := LBytesAlreadyRead;
Exit;
end;
{Is enough data now available?}
if FReadBufferAvailableBytes >= (ACount - LBytesAlreadyRead) then
begin
{Enough data in the buffer: Fill the output buffer.}
System.Move(FUncompressedDataBuffer,
PAnsiChar(@ABuffer)[LBytesAlreadyRead],
ACount - LBytesAlreadyRead);
{Subtract from the available bytes in the read buffer and return the
number of bytes read.}
Dec(FReadBufferAvailableBytes, ACount - LBytesAlreadyRead);
{Successfully read the number of bytes requested}
Result := ACount;
end
else
begin
{Enough data is still not available (the end of the compressed stream
has been reached): Read what we can.}
System.Move(FUncompressedDataBuffer,
PAnsiChar(@ABuffer)[LBytesAlreadyRead],
FReadBufferAvailableBytes);
Inc(LBytesAlreadyRead, FReadBufferAvailableBytes);
FReadBufferAvailableBytes := 0;
Result := LBytesAlreadyRead;
end;
end
else
begin
{Decompress directly into the output buffer.}
Result := InternalDecompressToBuffer(
@PAnsiChar(@ABuffer)[LBytesAlreadyRead],
ACount - LBytesAlreadyRead) + LBytesAlreadyRead;
end;
end;
end
else
Result := 0;
end;
function TAbLZMADecompressionStream.Seek(const AOffset: Int64; AOrigin: TSeekOrigin): Int64;
begin
Result := GetBytesRead;
if ((AOrigin <> soBeginning) or (AOffset <> Result))
and ((AOrigin <> soCurrent) or (AOffset <> 0)) then
begin
raise Exception.Create('Decompression streams do not support seeking away '
+ 'from the current position.');
end;
end;
function TAbLZMADecompressionStream.Seek(AOffset: Integer; AOrigin: Word): Integer;
begin
Result := Seek(Int64(AOffset), TSeekOrigin(AOrigin));
end;
function TAbLZMADecompressionStream.Write(const ABuffer; ACount: Integer): Integer;
begin
raise Exception.Create('Writing to a LZMA decompression stream is not supported.');
end;
end.
================================================
FILE: lib/abbrevia/source/AbMeter.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbMeter.pas *}
{*********************************************************}
{* ABBREVIA: Progress meter *}
{* Use AbQMeter.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
unit AbMeter;
{$ENDIF}
{$I AbDefine.inc}
interface
uses
Classes,
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
{$IFDEF LibcAPI}
Libc,
{$ENDIF}
{$IFDEF UsingCLX }
QControls, QGraphics, QForms, QExtCtrls,
{$ELSE}
Controls, Graphics, Forms, ExtCtrls,
{$ENDIF}
AbBrowse;
type
TAbMeterOrientation = (moHorizontal, moVertical);
TAbCustomMeter = class(TGraphicControl, IAbProgressMeter)
{.Z+}
protected {private}
{property variables}
FBorderStyle : TBorderStyle;
FCtl3D : Boolean;
FOrientation : TAbMeterOrientation;
FPercent : Integer;
FTickMarks : Byte;
FUsedColor : TColor;
FUnusedColor : TColor;
{internal methods}
function GetVersion : string;
procedure Paint;
override;
procedure SetBorderStyle(const Value : TBorderStyle);
procedure SetCtl3D(const Value : Boolean);
procedure SetOrientation(const O : TAbMeterOrientation);
procedure SetTickMarks(const Value: Byte);
procedure SetUnusedColor(const C : TColor);
procedure SetUsedColor(const C : TColor);
procedure SetVersion(Value : string);
property Version : string
read GetVersion write SetVersion stored False;
{.Z-}
public {methods}
constructor Create(AOwner : TComponent);
override;
procedure DoProgress(Progress : Byte);
procedure Reset;
public {properties}
property BorderStyle : TBorderStyle
read FBorderStyle write SetBorderStyle default bsSingle;
property Ctl3D : Boolean
read FCtl3D write SetCtl3D default True;
property Orientation : TAbMeterOrientation
read FOrientation write SetOrientation;
property TickMarks: Byte
read FTickMarks write SetTickMarks default 10;
property UnusedColor : TColor
read FUnusedColor write SetUnusedColor;
property UsedColor : TColor
read FUsedColor write SetUsedColor;
end;
TAbMeter = class(TAbCustomMeter)
published
property Anchors;
property Constraints;
property Align;
property BorderStyle;
property Ctl3D;
property Font;
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property Orientation;
property ParentFont;
property ParentShowHint;
property ShowHint;
property TickMarks;
property UnusedColor;
property UsedColor;
property Version;
property Visible;
end;
{.Z+}
implementation
uses
Types, AbConst;
{ == TAbCustomMeter ======================================================== }
constructor TAbCustomMeter.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{$IFNDEF UsingCLX}
if NewStyleControls then
ControlStyle := ControlStyle + [csOpaque]
else
ControlStyle := ControlStyle + [csOpaque, csFramed];
{$ELSE}
ControlStyle := ControlStyle + [csOpaque, csFramed];
{$ENDIF}
FBorderStyle := bsSingle;
FCtl3D := True;
FOrientation := moHorizontal;
FTickMarks := 10;
FUnusedColor := clBtnFace;
FUsedColor := clNavy;
Width := 150;
Height := 16;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomMeter.GetVersion : string;
begin
Result := AbVersionS;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMeter.DoProgress(Progress : Byte);
begin
if (Progress <> FPercent) then begin
FPercent := Progress;
if (FPercent >= 100) then
FPercent := 0;
Refresh;
Application.ProcessMessages;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMeter.Paint;
const
VSpace = 2;
HSpace = 1;
LSpace = 1;
RSpace = 1;
var
ClRect, R : TRect;
ClWidth : Integer;
ClHeight : Integer;
BlockWidth : Integer;
BlockCount : Integer;
i : Integer;
begin
ClRect := ClientRect;
ClWidth := ClRect.Right - CLRect.Left + 1;
ClHeight := ClRect.Bottom - ClRect.Top + 1;
if (Orientation = moHorizontal) then
BlockWidth := ((ClWidth - LSpace - RSpace - (9 * VSpace)) div FTickMarks) + 1
else
BlockWidth := ((ClHeight - LSpace - RSpace - (9 * HSpace)) div FTickMarks) + 1;
BlockCount := FPercent div FTickMarks;
if not Assigned((Canvas as TControlCanvas).Control) then begin
TControlCanvas(Canvas).Control := self;
end;
with Canvas do begin
Brush.Color := FUnusedColor;
FillRect(Rect(ClRect.Left, ClRect.Top, ClRect.Left + ClWidth - 1,
ClRect.Top + ClHeight - 1));
Brush.Color := FUsedColor;
if (BlockCount > 0) then begin
if (Orientation = moHorizontal) then begin
R.Top := ClRect.Top + HSpace;
R.Bottom := ClRect.Bottom - HSpace;
for i := 0 to Pred(BlockCount) do begin
R.Left := ClRect.Left + LSpace + (i * VSpace) +
(i * BlockWidth);
R.Right := R.Left + BlockWidth;
FillRect(R);
end;
end else begin {moVertical}
R.Left := ClRect.Left + VSpace;
R.Right := ClRect.Right - VSpace;
for i := 0 to Pred(BlockCount) do begin
R.Bottom := ClRect.Bottom - LSpace - (i * HSpace) -
(i * BlockWidth);
R.Top := R.Bottom - BlockWidth;
FillRect(R);
end;
end;
end;
end;
{$IFNDEF LCL}
if (BorderStyle <> bsNone) then begin
if Ctl3D then
Frame3D(Canvas, ClRect, clBtnShadow, clBtnHighlight, 1)
else
Frame3D(Canvas, ClRect, clBlack, clBlack, 1);
end;
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMeter.Reset;
begin
DoProgress(0);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMeter.SetBorderStyle(const Value : TBorderStyle);
begin
if (Value <> FBorderStyle) then begin
FBorderStyle := Value;
Invalidate;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMeter.SetCtl3D(const Value : Boolean);
begin
if (Value <> FCtl3D) then begin
FCtl3D := Value;
Invalidate;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMeter.SetOrientation(const O : TAbMeterOrientation);
var
Temp : Integer;
begin
if (O <> FOrientation) then begin
FOrientation := O;
if not (csLoading in ComponentState) then begin
Temp := Width;
Width := Height;
Height := Temp;
end;
Invalidate;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMeter.SetTickMarks(const Value: Byte);
begin
if Value <= 0 then
FTickMarks := 10
else
FTickMarks := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMeter.SetUnusedColor(const C : TColor);
begin
if (C <> FUnusedColor) then begin
FUnusedColor := C;
Invalidate;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMeter.SetUsedColor(const C : TColor);
begin
if (C <> FUsedColor) then begin
FUsedColor := C;
Invalidate;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomMeter.SetVersion(Value : string);
begin
{NOP}
end;
end.
================================================
FILE: lib/abbrevia/source/AbPPMd.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is Craig Peterson
*
* Portions created by the Initial Developer are Copyright (C) 2011
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Craig Peterson
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbPPMd.pas *}
{*********************************************************}
{* ABBREVIA: PPMd decompression *}
{*********************************************************}
unit AbPPMd;
{$I AbDefine.inc}
interface
uses
Classes;
procedure DecompressPPMd(aSrc, aDes: TStream);
implementation
uses
AbCrtl,
SysUtils,
AbExcept;
// Compiled with:
// Release: bcc32 -q -c *.c
// Debug: bcc32 -q -c -v -y *.c
{ Linker derectives ======================================================== }
// Don't re-order these; it will cause linker errors
{$IF DEFINED(WIN32)}
{$L Win32\PPMdVariantI.obj}
{$L Win32\PPMdContext.obj}
{$L Win32\PPMdSubAllocatorVariantI.obj}
{$L Win32\CarrylessRangeCoder.obj}
{$ELSEIF DEFINED(WIN64)}
{$L Win64\PPMdVariantI.obj}
{$L Win64\PPMdContext.obj}
{$L Win64\PPMdSubAllocatorVariantI.obj}
{$L Win64\CarrylessRangeCoder.obj}
{$IFEND}
{ CarrylessRangeCoder.h ==================================================== }
type
PInStream = ^TInStream;
TInStream = record
nextByte: function(Self: PInStream): Byte; cdecl;
// Private data
stream: TStream;
InPos: Integer;
InCount: Integer;
InBuf: array[0..4097] of Byte;
end;
{ -------------------------------------------------------------------------- }
function TInStream_NextByte(Self: PInStream): Byte; cdecl;
begin
if Self.InPos = Self.InCount then begin
Self.InCount := Self.stream.Read(Self.InBuf, SizeOf(Self.InBuf));
if Self.InCount = 0 then
raise EAbReadError.Create;
Self.InPos := 0;
end;
Result := Self.InBuf[Self.InPos];
Inc(Self.InPos);
end;
{ -------------------------------------------------------------------------- }
function TInStream_Create(aStream: TStream): PInStream;
begin
GetMem(Result, SizeOf(TInStream));
Result.nextByte := TInStream_NextByte;
Result.stream := aStream;
Result.InPos := 0;
Result.InCount := 0;
end;
{ PPMdVariantI.h =========================================================== }
type
PPMdModelVariantI = Pointer;
function CreatePPMdModelVariantI(const input: TInStream;
suballocsize, maxorder, restoration: Integer): PPMdModelVariantI; cdecl; external;
procedure FreePPMdModelVariantI(Self: PPMdModelVariantI); cdecl; external;
function NextPPMdVariantIByte(Self: PPMdModelVariantI): Integer; cdecl; external;
{ Decompression routines =================================================== }
procedure DecompressPPMd(aSrc, aDes: TStream);
const
OutBufSize = 4096;
var
nextByte: Integer;
params: word;
ppmd: PPMdModelVariantI;
Src: PInStream;
OutBuf: PByteArray;
OutPos: Integer;
begin
Src := TInStream_Create(aSrc);
try
GetMem(OutBuf, OutBufSize);
try
OutPos := 0;
ASrc.ReadBuffer(Params, SizeOf(Params));// Pkzip stream header
ppmd := CreatePPMdModelVariantI(Src^,
(((Params shr 4) and $FF) + 1) shl 20,// sub-allocator size
(Params and $0F) + 1, // model order
Params shr 12); // model restoration method
try
while True do begin
nextByte := NextPPMdVariantIByte(ppmd);
if nextByte < 0 then Break;
OutBuf[OutPos] := Byte(nextByte);
Inc(OutPos);
if OutPos = OutBufSize then begin
aDes.WriteBuffer(OutBuf^, OutBufSize);
OutPos := 0;
end;
end;
if OutPos > 0 then
aDes.WriteBuffer(OutBuf^, OutPos);
finally
FreePPMdModelVariantI(ppmd);
end;
finally
FreeMem(OutBuf);
end;
finally
FreeMem(Src);
end;
end;
end.
================================================
FILE: lib/abbrevia/source/AbPeCol.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbPeCol.pas *}
{*********************************************************}
{* ABBREVIA: Property Editor - ZipView column headings *}
{* Use AbQPeCol.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
unit AbPeCol;
{$ENDIF}
{$I AbDefine.inc}
interface
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
{$IFDEF UsingClx}
QGraphics,
QForms,
QControls,
QStdCtrls,
QButtons,
QExtCtrls,
AbQView,
AbBseCLX,
{$ELSE}
Graphics,
Forms,
Controls,
StdCtrls,
Buttons,
ExtCtrls,
AbView,
AbBseVcl,
{$ENDIF}
DesignIntf,
DesignEditors,
AbConst,
SysUtils,
Classes;
type
TAbColHeadingsEditor = class(TForm)
Panel1: TPanel;
Label1: TLabel;
Attribute1: TComboBox;
Done1: TBitBtn;
Apply1: TBitBtn;
Label2: TLabel;
Heading1: TEdit;
Button1: TButton;
procedure FormShow(Sender: TObject);
procedure Attribute1Click(Sender: TObject);
procedure Apply1Click(Sender: TObject);
procedure Heading1Exit(Sender: TObject);
private
{ Private declarations }
public
Viewer : TAbBaseViewer;
end;
TAbColHeadingsProperty = class(TClassProperty)
public
procedure Edit; override;
function GetAttributes: TPropertyAttributes; override;
end;
var
AbColHeadingsEditor: TAbColHeadingsEditor;
implementation
uses
AbResString;
{$IFNDEF UsingCLX}
{$R *.dfm}
{$ENDIF}
type
TAbViewerFriend = class(TAbBaseViewer);
{===TAbColHeadingsProperty==========================================}
procedure TAbColHeadingsProperty.Edit;
var
hEditor : TAbColHeadingsEditor;
begin
hEditor := TAbColHeadingsEditor.Create(Application);
try
hEditor.Viewer := TAbViewerFriend(GetComponent(0));
hEditor.ShowModal;
Designer.Modified;
finally
hEditor.Free;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbColHeadingsProperty.GetAttributes: TPropertyAttributes;
begin
Result := inherited GetAttributes + [paDialog, paAutoUpdate];
end;
{===TAbColHeadingsEditor============================================}
procedure TAbColHeadingsEditor.FormShow(Sender: TObject);
const
cResString: array[TAbViewAttribute] of string = (AbItemNameHeadingS,
AbPackedHeadingS, AbMethodHeadingS, AbRatioHeadingS, AbCRCHeadingS,
AbFileAttrHeadingS, AbFileFormatHeadingS, AbEncryptionHeadingS,
AbTimeStampHeadingS, AbFileSizeHeadingS, AbVersionMadeHeadingS,
AbVersionNeededHeadingS, AbPathHeadingS);
var
i : TAbViewAttribute;
begin
with Attribute1 do begin
Clear;
for i := Low(TAbViewAttribute) to High(TAbViewAttribute) do
Items.Add(cResString[i]);
ItemIndex := 0;
end;
Attribute1Click(nil);
end;
procedure TAbColHeadingsEditor.Attribute1Click(Sender: TObject);
begin
if (Attribute1.ItemIndex > -1) then
Heading1.Text := TAbViewerFriend(Viewer).Headings[Attribute1.ItemIndex];
end;
procedure TAbColHeadingsEditor.Apply1Click(Sender: TObject);
begin
if (Attribute1.ItemIndex > -1) then begin
TAbViewerFriend(Viewer).Headings[Attribute1.ItemIndex] := Heading1.Text;
TAbViewerFriend(Viewer).InvalidateRow(0);
end;
end;
procedure TAbColHeadingsEditor.Heading1Exit(Sender: TObject);
begin
Apply1Click(nil);
end;
end.
================================================
FILE: lib/abbrevia/source/AbPeDir.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbPeDir.pas *}
{*********************************************************}
{* ABBREVIA: Property Editor - Directory *}
{* Use AbQPeDir.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
unit AbPeDir;
{$ENDIF}
{$I AbDefine.inc}
interface
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
{$IFDEF UsingClx}
QGraphics,
QForms,
QControls,
QStdCtrls,
QButtons,
QExtCtrls,
{$ELSE}
Graphics,
Forms,
Controls,
StdCtrls,
Buttons,
ExtCtrls,
{$ENDIF}
DesignIntf,
DesignEditors,
SysUtils,
Classes;
type
TAbDirectoryProperty = class( TStringProperty )
public
function GetAttributes: TPropertyAttributes;
override;
procedure Edit;
override;
end;
implementation
uses
{$IFDEF UsingClx}
AbQDgDir;
{$ELSE}
AbDlgDir;
{$ENDIF}
function TAbDirectoryProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog];
end;
{$IFDEF MSWINDOWS}
procedure TAbDirectoryProperty.Edit;
var
D : TAbDirDlg;
begin
D := TAbDirDlg.Create(Application);
try
D.Caption := 'Directory';
D.AdditionalText := 'Select Directory';
if D.Execute then
Value := D.SelectedFolder;
finally
D.Free;
end;
end;
{$ELSE}
procedure TAbDirectoryProperty.Edit;
var
D : TDirDlg;
begin
D := TDirDlg.Create(Application);
try
{$IFDEF MSWINDOWS}
D.DirectoryListBox1.Directory := Value;
{$ENDIF}
D.ShowModal;
if D.ModalResult = mrOK then
Value := D.SelectedFolder;
finally
D.Free;
end;
end;
{$ENDIF}
end.
================================================
FILE: lib/abbrevia/source/AbPeFn.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbPeFn.pas *}
{*********************************************************}
{* ABBREVIA: Property Editor - FileName *}
{* Use AbQPeFn.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
unit AbPeFn;
{$ENDIF}
{$I AbDefine.inc}
interface
uses
{$IFDEF UsingClx }
QDialogs, QForms,
{$ELSE}
Dialogs, Forms,
{$ENDIF}
DesignIntf,
DesignEditors,
SysUtils;
type
TAbFileNameProperty = class(TStringProperty)
public
function GetAttributes: TPropertyAttributes;
override;
procedure Edit;
override;
end;
TAbExeNameProperty = class(TStringProperty)
public
function GetAttributes: TPropertyAttributes;
override;
procedure Edit;
override;
end;
TAbCabNameProperty = class( TStringProperty )
public
function GetAttributes: TPropertyAttributes;
override;
procedure Edit;
override;
end;
TAbLogNameProperty = class( TStringProperty )
public
function GetAttributes: TPropertyAttributes;
override;
procedure Edit;
override;
end;
implementation
uses
AbResString,
AbArcTyp;
{ -------------------------------------------------------------------------- }
procedure AbGetFilename(const Ext : string;
const Filter : string;
const Title : string;
var aFilename : string);
var
D : TOpenDialog;
begin
D := TOpenDialog.Create( Application );
try
D.DefaultExt := Ext;
D.Filter := Filter;
D.FilterIndex := 0;
D.Options := [];
D.Title := Title;
D.FileName := aFilename;
if D.Execute then
aFilename := D.FileName;
finally
D.Free;
end;
end;
{ == for zip files ========================================================= }
function TAbFileNameProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog];
end;
{ -------------------------------------------------------------------------- }
procedure TAbFileNameProperty.Edit;
var
FN : string;
begin
FN := Value;
AbGetFilename(AbDefaultExtS, AbFilterS, AbFileNameTitleS, FN);
Value := FN;
end;
{ == for exe files ========================================================= }
function TAbExeNameProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog];
end;
{ -------------------------------------------------------------------------- }
procedure TAbExeNameProperty.Edit;
var
FN : string;
begin
FN := Value;
AbGetFilename(AbExeExtS, AbExeFilterS, AbFileNameTitleS, FN);
Value := FN;
end;
{ == for cab files ========================================================= }
function TAbCabNameProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog];
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabNameProperty.Edit;
var
FN : string;
begin
FN := Value;
AbGetFilename(AbCabExtS, AbCabFilterS, AbFileNameTitleS, FN);
Value := FN;
end;
{ == for log files ========================================================= }
function TAbLogNameProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog];
end;
{ -------------------------------------------------------------------------- }
procedure TAbLogNameProperty.Edit;
var
FN : string;
begin
FN := Value;
AbGetFilename(AbLogExtS, AbLogFilterS, AbFileNameTitleS, FN);
Value := FN;
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbPePass.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbPePass.pas *}
{*********************************************************}
{* ABBREVIA: Password property editor *}
{* Use AbQPePas.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
unit AbPePass;
{$ENDIF}
{$I AbDefine.inc}
interface
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
{$IFDEF UsingClx}
QGraphics,
QForms,
QControls,
QStdCtrls,
QButtons,
QExtCtrls,
{$ELSE}
Graphics,
Forms,
Controls,
StdCtrls,
Buttons,
ExtCtrls,
{$ENDIF}
DesignIntf,
DesignEditors,
SysUtils,
Classes;
type
TAbPasswordProperty = class( TStringProperty )
public
function GetAttributes: TPropertyAttributes;
override;
procedure Edit;
override;
end;
implementation
uses
{$IFDEF UsingClx}
AbQDgPwd;
{$ELSE}
AbDlgPwd;
{$ENDIF}
function TAbPasswordProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog];
end;
procedure TAbPasswordProperty.Edit;
var
D : TPasswordDlg;
begin
D := TPasswordDlg.Create( Application );
try
D.Edit1.Text := Value;
D.ShowModal;
if D.ModalResult = mrOK then
Value := D.Edit1.Text;
finally
D.Free;
end;
end;
end.
================================================
FILE: lib/abbrevia/source/AbPeVer.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbPeVer.pas *}
{*********************************************************}
{* ABBREVIA: Property Editor - Version *}
{* Use AbQPeVer.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
unit AbPeVer;
{$ENDIF}
{$I AbDefine.inc}
interface
uses
{$IFDEF MSWINDOWS}
Windows,
ShellAPI,
{$ENDIF}
{$IFDEF LibcAPI}
Libc,
{$ENDIF}
{$IFDEF UsingClx}
QGraphics,
QForms,
QControls,
QStdCtrls,
QButtons,
QExtCtrls,
QDialogs,
{$ELSE}
Graphics,
Forms,
Controls,
StdCtrls,
Buttons,
ExtCtrls,
Dialogs,
{$ENDIF}
DesignIntf,
DesignEditors,
SysUtils,
Classes;
type
TAbAboutBox = class(TForm)
lblVersion: TLabel;
Panel1: TPanel;
Image1: TImage;
btnOK: TButton;
Panel2: TPanel;
WebLbl: TLabel;
NewsLbl: TLabel;
Bevel1: TBevel;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label10: TLabel;
Label11: TLabel;
procedure FormCreate(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure WebLblClick(Sender: TObject);
procedure WebLblMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure NewsLblClick(Sender: TObject);
procedure NewsLblMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Panel2MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
TAbVersionProperty = class( TStringProperty )
public
function GetAttributes: TPropertyAttributes;
override;
procedure Edit;
override;
end;
var
AbAboutBox : TAbAboutBox;
implementation
{$IFNDEF UsingCLX}
{$R *.dfm}
{$ENDIF}
uses
AbArcTyp,
AbConst,
AbResString;
{$IFDEF LINUX}
const
{ String Constants }
sCannotStartBrowser = 'Unable to start web browser. Make sure you have it properly set-up on your system.';
const
MaxBrowsers = 1;
type
ECannotStartBrowser = class(Exception);
type
TBrowserStartCmd = record
Command : string [64];
Parameters : string [255];
XTerm : Boolean; { Start browser in an XTerm }
end;
const
{ The list of browsers we can launch. }
BrowserList : array [1..MaxBrowsers] of TBrowserStartCmd =
((Command : 'netscape'; Parameters : ''; Xterm : False));
procedure GetCurrentPath (PathList : TStringList);
var
WorkPath : PChar;
StartPos : PChar;
CurrentPath : PChar;
State : (Scanning, GotColon);
begin
WorkPath := getenv ('PATH');
PathList.Clear;
StartPos := WorkPath;
State := Scanning;
while (WorkPath^ <> #0) do begin
case State of
Scanning :
begin
if (WorkPath^ = ':') then begin
State := GotColon;
if (WorkPath <> StartPos) then begin
CurrentPath := StrAlloc(WorkPath - StartPos + 1);
StrLCopy(CurrentPath, StartPos, WorkPath-StartPos);
PathList.Add (CurrentPath);
StrDispose(CurrentPath);
end;
end;
end;
GotColon :
begin
if (WorkPath^ <> ':') then begin
StartPos := WorkPath;
State := Scanning;
end;
end;
end;{case}
inc(WorkPath);
end;
if (State = Scanning) and (WorkPath <> StartPos) then begin
CurrentPath := StrAlloc(WorkPath - StartPos + 1);
StrLCopy(CurrentPath, StartPos, WorkPath-StartPos);
PathList.Add (CurrentPath);
StrDispose(CurrentPath);
end;
end;
function IsBrowserPresent (PathList : TStringList;
Browser : string) : Boolean;
var
i : integer;
begin
Result := False;
for i := 0 to PathList.Count - 1 do begin
if FileExists (PathList[i] + '/' + Browser) then begin
Result := True;
exit;
end;
end;
end;
procedure CallBrowser (Browser : string;
Parameters : string;
Website : string;
XTerm : Boolean);
begin
if Pos ('', Parameters) > 0 then begin
Parameters := Copy (Parameters, 1, Pos ('', Parameters) - 1) +
Website +
Copy (Parameters, Pos ('', Parameters) + 6, 255);
end else
Parameters := Parameters + ' ' + Website;
if XTerm then begin
Parameters := '-e ' + Browser + ' ' + Parameters;
Browser := 'xterm';
end;
Libc.system (PChar (Browser + ' ' + Parameters + ' &'));
end;
procedure StartBrowser (Website : string);
var
PathList : TStringList;
i : integer;
begin
PathList := TStringList.Create;
try
GetCurrentPath (PathList);
for i := 1 to MaxBrowsers do begin
if IsBrowserPresent (PathList, BrowserList[i].Command) then begin
CallBrowser (BrowserList[i].Command, BrowserList[i].Parameters,
Website, BrowserList[i].XTerm);
exit;
end;
end;
raise ECannotStartBrowser.Create(sCannotStartBrowser);
finally
PathList.Free;
end;
end;
{$ENDIF}
procedure TAbAboutBox.FormCreate(Sender: TObject);
begin
Top := (Screen.Height - Height ) div 3;
Left := (Screen.Width - Width ) div 2;
lblVersion.Caption := Format(AbVersionFormatS, [AbVersionS] );
end;
function TAbVersionProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog, paReadOnly];
end;
procedure TAbVersionProperty.Edit;
begin
with TAbAboutBox.Create( Application ) do
try
ShowModal;
finally
Free;
end;
end;
procedure TAbAboutBox.btnOKClick(Sender: TObject);
begin
Close;
end;
procedure TAbAboutBox.WebLblClick(Sender: TObject);
begin
{$IFDEF MSWINDOWS }
if ShellExecute(0, 'open', 'http://www.sourceforge.net/projects/tpabbrevia', '', '',
SW_SHOWNORMAL) <= 32 then
ShowMessage('Unable to start web browser');
{$ENDIF MSWINDOWS }
{$IFDEF LINUX }
try
StartBrowser('http://www.sourceforge.net/projects/tpabbrevia');
except
on ECannotStartBrowser do
ShowMessage('Unable to start web browser');
end;
{$ENDIF LINUX }
WebLbl.Font.Color := clNavy;
end;
procedure TAbAboutBox.WebLblMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
WebLbl.Font.Color := clRed;
end;
procedure TAbAboutBox.NewsLblClick(Sender: TObject);
begin
{$IFDEF MSWINDOWS }
if ShellExecute(0, 'open', 'http://www.sourceforge.net/forum/forum.php?forum_id=241865', '', '',
SW_SHOWNORMAL) <= 32 then
ShowMessage('Unable to start web browser');
{$ENDIF MSWINDOWS }
{$IFDEF LINUX }
try
StartBrowser('http://www.sourceforge.net/forum/forum.php?forum_id=241865');
except
on ECannotStartBrowser do
ShowMessage('Unable to start web browser');
end;
{$ENDIF LINUX }
NewsLbl.Font.Color := clNavy;
end;
procedure TAbAboutBox.NewsLblMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
NewsLbl.Font.Color := clRed;
end;
procedure TAbAboutBox.Panel2MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
NewsLbl.Font.Color := clNavy;
end;
procedure TAbAboutBox.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
WebLbl.Font.Color := clNavy;
NewsLbl.Font.Color := clNavy;
end;
end.
================================================
FILE: lib/abbrevia/source/AbQCView.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQCView.pas *}
{*********************************************************}
{* ABBREVIA: Cabinet archive viewer component (CLX) *}
{* Use AbCView.pas for VCL *}
{*********************************************************}
Unit AbQCView;
{$DEFINE UsingCLX}
{$I AbCView.pas}
================================================
FILE: lib/abbrevia/source/AbQCmpnd.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQCmpnd.pas *}
{*********************************************************}
{* ABBREVIA: Compound File classes and component (CLX) *}
{* Use AbCompnd.pas for VCL *}
{*********************************************************}
unit AbQCmpnd;
{$DEFINE UsingCLX}
{$I AbCompnd.pas}
================================================
FILE: lib/abbrevia/source/AbQDgDir.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQDgDir.pas *}
{*********************************************************}
{* ABBREVIA: Dialog - Directory (CLX) *}
{* Use AbDlgDir.pas for VCL *}
{*********************************************************}
{$DEFINE UsingClx }
unit AbQDgDir;
{$R *.xfm}
{$I AbDlgDir.pas}
================================================
FILE: lib/abbrevia/source/AbQDgPwd.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQDgPwd.pas *}
{*********************************************************}
{* ABBREVIA: Dialog - Password (CLX) *}
{* Use AbDlgPwd.pas for VCL *}
{*********************************************************}
{$DEFINE UsingClx}
unit AbQDgPwd;
{$R *.xfm}
{$I AbDlgPwd.pas}
================================================
FILE: lib/abbrevia/source/AbQHexVw.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQCmpnd.pas *}
{*********************************************************}
{* ABBREVIA: Compound File classes and component (CLX) *}
{* Use AbCompnd.pas for VCL *}
{*********************************************************}
unit AbQHexVw;
{$DEFINE UsingCLX}
{$I AbHexVw.pas}
================================================
FILE: lib/abbrevia/source/AbQMeter.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQMeter.pas *}
{*********************************************************}
{* ABBREVIA: Progress meter (CLX) *}
{* Use AbMeter.pas for VCL *}
{*********************************************************}
{$DEFINE UsingCLX}
unit AbQMeter;
{$I AbMeter.pas}
================================================
FILE: lib/abbrevia/source/AbQPeCol.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQPeCol.pas *}
{*********************************************************}
{* ABBREVIA: Property Editor - ZipView column headings *}
{* (CLX) *}
{* Use AbPeCol.pas for VCL *}
{*********************************************************}
{$DEFINE UsingClx}
unit AbQPeCol;
{$R *.xfm}
{$I AbPeCol.pas}
================================================
FILE: lib/abbrevia/source/AbQPeDir.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbPeDir.pas *}
{*********************************************************}
{* ABBREVIA: Property Editor - Directory (CLX) *}
{* Use AbPeDir.pas for VCL *}
{*********************************************************}
{$DEFINE UsingCLX}
unit AbQPeDir;
{$I AbPeDir.pas}
================================================
FILE: lib/abbrevia/source/AbQPeFn.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQPeFn.PAS *}
{*********************************************************}
{* ABBREVIA: Property Editor - FileName (CLX) *}
{* Use AbPeFn.pas for VCL *}
{*********************************************************}
{$DEFINE UsingClx}
unit AbQPeFn;
{$I AbPeFn.pas}
================================================
FILE: lib/abbrevia/source/AbQPePas.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQPePas.pas *}
{*********************************************************}
{* ABBREVIA: Password property editor (CLX) *}
{* Use AbPePass.pas for VCL *}
{*********************************************************}
{$DEFINE UsingClx}
unit AbQPePas;
{$I AbPePass.pas}
================================================
FILE: lib/abbrevia/source/AbQPeVer.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQPeVer.pas *}
{*********************************************************}
{* ABBREVIA: Property Editor - Version (CLX) *}
{* See AbPeVer.pas for the VCL header *}
{*********************************************************}
{$DEFINE UsingClx}
unit AbQPeVer;
{$R *.xfm}
{$I AbPeVer.pas}
================================================
FILE: lib/abbrevia/source/AbQView.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQView.pas *}
{*********************************************************}
{* ABBREVIA: Base archive viewer component (CLX) *}
{* Use AbView.pas for VCL *}
{*********************************************************}
{$DEFINE UsingCLX}
unit AbQView;
{$I AbView.pas}
================================================
FILE: lib/abbrevia/source/AbQZView.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQZView.pas *}
{*********************************************************}
{* ABBREVIA: Zip archive viewer component (CLX) *}
{* Use AbZView.pas for VCL *}
{*********************************************************}
{$DEFINE UsingCLX}
unit AbQZView;
{$I AbZView.pas}
================================================
FILE: lib/abbrevia/source/AbQZpOut.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbQZpOut.pas *}
{*********************************************************}
{* ABBREVIA: Visual Component with Zip and unzip support *}
{* (CLX) *}
{* Use AbZipOut.pas for VCL *}
{*********************************************************}
{$DEFINE UsingCLX}
unit AbQZpOut;
{$I AbZipOut.pas}
================================================
FILE: lib/abbrevia/source/AbReg.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbReg.pas *}
{*********************************************************}
{* ABBREVIA: Registrations (VCL) *}
{*********************************************************}
unit AbReg;
{$I AbDefine.inc}
{$UNDEF UsingClx }
{$R AbReg.res}
interface
uses
Classes,
{$IFDEF LCL}
LResources,
{$ENDIF}
{$IFDEF MSWINDOWS}
AbCBrows, AbCabExt, AbCabMak, AbCabKit,
{$ENDIF}
AbZBrows, AbUnzper, AbZipper, AbZipKit, AbSelfEx;
procedure Register;
implementation
{$IFNDEF FPC}
uses
AbUtils,
AbPeDir,
AbPeFn,
AbPePass,
AbPeVer,
AbPeCol,
DesignIntf,
DesignEditors,
SysUtils;
{$ENDIF}
procedure Register;
begin
{$IFNDEF FPC}
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'SelfExe',
TAbExeNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'StubExe',
TAbExeNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'ZipFile',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'FileName',
TAbCabNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'FileName',
TAbCabNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'FileName',
TAbCabNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'FileName',
TAbCabNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'Version',
TAbVersionProperty );
{$ENDIF}
RegisterComponents( 'Abbrevia',
[ TAbZipBrowser,
TAbUnzipper,
TAbZipper,
TAbZipKit,
{$IFDEF MSWINDOWS}
TAbCabBrowser,
TAbCabExtractor,
TAbMakeCab,
TAbCabKit,
{$ENDIF}
TAbMakeSelfExe ]);
end;
{$IFDEF LCL}
initialization
{$I abbrevia.lrs}
{$ENDIF}
end.
================================================
FILE: lib/abbrevia/source/AbRegClx.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbRegClx.pas *}
{*********************************************************}
{* ABBREVIA: Registrations (CLX) *}
{*********************************************************}
unit AbRegClx;
{$I AbDefine.inc}
{$DEFINE UsingCLX}
{$R AbReg.res}
interface
{$IFDEF LINUX}
!! Error, this unit is for CLX on Windows, use AbRegLinux.pas for Linux
{$ENDIF}
uses
Classes,
AbCBrows, AbCabExt, AbCabMak, AbCabKit,
AbZBrows, AbUnzper, AbZipper, AbZipKit, AbSelfEx,
AbQCView, AbQZpOut, AbQView, AbQZView, AbQMeter;
procedure Register;
implementation
uses
AbUtils,
AbQPeDir,
AbQPeFn,
AbQPePas,
AbQPeVer,
AbQPeCol,
AbQDgDir,
AbQDgPwd,
DesignIntf,
DesignEditors,
SysUtils;
procedure Register;
begin
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'SelfExe',
TAbExeNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'StubExe',
TAbExeNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'ZipFile',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipView, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMeter, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( TAbColHeadings ), TAbZipView, 'Headings',
TAbColHeadingsProperty );
{$IFDEF MSWINDOWS}
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'FileName',
TAbCabNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'FileName',
TAbCabNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'FileName',
TAbCabNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'FileName',
TAbCabNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabView, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( TAbColHeadings ), TAbCabView, 'Headings',
TAbColHeadingsProperty );
{$ENDIF}
RegisterComponents( 'Abbrevia',
[ TAbZipBrowser,
TAbUnzipper,
TAbZipper,
TAbZipKit,
TAbZipView,
TAbZipOutline,
{$IFDEF MSWINDOWS}
TAbCabBrowser,
TAbCabExtractor,
TAbMakeCab,
TAbCabKit,
TAbCabView,
{$ENDIF}
TAbMeter,
TAbMakeSelfExe ]);
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipView, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( TAbColHeadings ), TAbZipView, 'Headings',
TAbColHeadingsProperty );
RegisterComponents( 'Abbrevia',
[
TAbMeter,
TAbCabView,
TAbZipView,
TAbZipOutline
]);
end;
end.
================================================
FILE: lib/abbrevia/source/AbRegLinux.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbRegLinux.pas *}
{*********************************************************}
{* ABBREVIA: Registrations *}
{*********************************************************}
unit AbRegLinux;
{$I AbDefine.inc}
{$R AbReg.res}
interface
{$IFDEF MSWINDOWS}
!! Error, this unit is for CLX on Linux, use AbRegClx.pas for Windows
{$ENDIF}
uses
Classes,
AbQZpOut, AbQView, AbQZView, AbQMeter;
procedure Register;
implementation
uses
AbUtils,
AbQPeDir,
AbQPeFn,
AbQPePas,
AbQPeVer,
AbQPeCol,
AbZBrows,
AbZipper,
AbUnzper,
AbZipKit,
AbSelfEx,
DesignIntf,
DesignEditors;
procedure Register;
begin
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'SelfExe',
TAbExeNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'StubExe',
TAbExeNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'ZipFile',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipView, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMeter, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( TAbColHeadings ), TAbZipView, 'Headings',
TAbColHeadingsProperty );
RegisterComponents( 'Abbrevia',
[TAbZipBrowser,
TAbUnzipper,
TAbZipper,
TAbZipKit,
TAbZipOutline,
TAbZipView,
TAbMeter,
TAbMakeSelfExe]);
end;
end.
================================================
FILE: lib/abbrevia/source/AbRegVcl.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbRegVcl.pas *}
{*********************************************************}
{* ABBREVIA: Registrations (VCL) *}
{*********************************************************}
unit AbRegVcl;
{$I AbDefine.inc}
{$UNDEF UsingClx }
{$R AbReg.res}
interface
uses
Classes,
AbCBrows, AbCabExt, AbCabMak, AbCabKit, AbCView,
AbCompnd, AbHexVw, AbZBrows, AbUnzper, AbZipper, AbZipKit, AbZipOut,
AbView, AbComCtrls, AbZView, AbMeter, AbSelfEx, AbZipExt;
procedure Register;
implementation
uses
AbConst,
AbUtils,
AbPeDir,
AbPeFn,
AbPePass,
AbPeVer,
AbPeCol,
DesignIntf,
DesignEditors,
Graphics,
ToolsAPI,
SysUtils,
Windows;
procedure Register;
begin
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'FileName',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'SelfExe',
TAbExeNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'StubExe',
TAbExeNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'ZipFile',
TAbFileNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbListView, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbTreeView, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipView, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMeter, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbProgressBar, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeSelfExe, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipBrowser, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipper, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbUnZipper, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipKit, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbZipOutline, 'Password',
TAbPasswordProperty );
RegisterPropertyEditor( TypeInfo( TAbColHeadings ), TAbZipView, 'Headings',
TAbColHeadingsProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'FileName',
TAbCabNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'FileName',
TAbCabNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'FileName',
TAbCabNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'FileName',
TAbCabNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'BaseDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'LogFile',
TAbLogNameProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'TempDirectory',
TAbDirectoryProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabBrowser, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbMakeCab, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabExtractor, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabKit, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( string ), TAbCabView, 'Version',
TAbVersionProperty );
RegisterPropertyEditor( TypeInfo( TAbColHeadings ), TAbCabView, 'Headings',
TAbColHeadingsProperty );
RegisterComponents( 'Abbrevia',
[ TAbZipBrowser,
TAbUnzipper,
TAbZipper,
TAbZipKit,
TAbZipView,
TAbZipOutline,
TAbTreeView,
TAbListView,
TAbCabBrowser,
TAbCabExtractor,
TAbMakeCab,
TAbCabKit,
TAbCabView,
TAbProgressBar,
TAbMeter,
TAbMakeSelfExe ]);
end;
{$IF DECLARED(IOTAAboutBoxServices)}
var
AboutBoxIndex: Integer = -1;
procedure RegisterAboutBox;
begin
SplashScreenServices.AddPluginBitmap(
'Abbrevia: Advanced data compression toolkit, v' + AbVersionS,
LoadBitmap(HInstance, 'SPLASH'));
AboutBoxIndex := (BorlandIDEServices as IOTAAboutBoxServices).AddPluginInfo(
'Abbrevia ' + AbVersionS,
'Abbrevia: Advanced data compression toolkit, v' + AbVersionS + sLineBreak +
'http://tpabbrevia.sourceforge.net/' + sLineBreak +
sLineBreak +
'Copyright (c) 1997-2011 Abbrevia development team' + sLineBreak +
'Covered under the Mozilla Public License (MPL) v1.1' + sLineBreak +
'Abbrevia includes source code from bzip2, the LZMA SDK,' + sLineBreak +
'Dag gren''s version of PPMd, and the WavPack SDK.',
LoadBitmap(HInstance, 'SPLASH'));
end;
procedure UnregisterAboutBox;
begin
if AboutBoxIndex <> -1 then
(BorlandIDEServices as IOTAAboutBoxServices).RemovePluginInfo(AboutBoxIndex);
end;
initialization
RegisterAboutBox;
finalization
UnRegisterAboutBox;
{$IFEND}
end.
================================================
FILE: lib/abbrevia/source/AbResString.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Roman Kassebaum
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* Abbrevia: AbResString.pas *}
{*********************************************************}
{* Abbrevia: Resource strings *}
{*********************************************************}
unit AbResString;
{$I AbDefine.inc}
interface
resourcestring
AbErrZipInvalidS = 'Invalid file - not a PKZip file';
AbZipVersionNeededS = 'Cannot extract file - newer version required';
AbUnknownCompressionMethodS = 'Cannot extract file - unsupported compression method';
AbNoExtractionMethodS = 'Cannot extract file - no extraction support provided';
AbInvalidPasswordS = 'Cannot extract file - invalid password';
AbNoInsertionMethodS = 'Cannot insert file - no insertion support provided';
AbInvalidFactorS = 'Invalid Reduce Factor';
AbDuplicateNameS = 'Cannot insert file - duplicates stored name';
AbUnsupportedCompressionMethodS = 'Cannot insert file - unsupported compression method';
AbUserAbortS = 'Process aborted by user';
AbArchiveBusyS = 'Archive is busy - cannot process new requests';
AbLastDiskRequestS = 'Insert the last disk in the spanned disk set';
AbDiskRequestS = 'Insert floppy';
AbImageRequestS = 'Image file name';
AbBadSpanStreamS = 'Spanned archives must be opened as file streams';
AbDiskNumRequestS = 'Insert disk number %d of the spanned disk set';
AbImageNumRequestS = 'Insert span number %d of the spanned file set';
AbNoOverwriteSpanStreamS = 'Cannot update an existing spanned disk set';
AbNoSpannedSelfExtractS = 'Cannot make a self-extracting spanned disk set';
AbBlankDiskS = 'Insert a blank floppy disk';
AbStreamFullS = 'Stream write error';
AbNoSuchDirectoryS = 'Directory does not exist';
AbInflateBlockErrorS = 'Cannot inflate block';
AbBadStreamTypeS = 'Invalid Stream';
AbTruncateErrorS = 'Error truncating Zip File';
AbZipBadCRCS = 'Failed CRC Check';
AbZipBadStubS = 'Stub must be an executable';
AbFileNotFoundS = 'File not found';
AbInvalidLFHS = 'Invalid Local File Header entry';
AbNoArchiveS = 'Archive does not exist - Filename is blank';
AbReadErrorS = 'Error reading archive';
AbInvalidIndexS = 'Invalid archive item index';
AbInvalidThresholdS = 'Invalid archive size threshold';
AbUnhandledFileTypeS = 'Unhandled Archive Type';
AbSpanningNotSupportedS = 'Spanning not supported by this Archive type';
AbLogCreateErrorS = 'Error creating Log File';
AbMoveFileErrorS = 'Error Moving File %s to %s';
AbFileSizeTooBigS = 'File size is too big for archive type';
AbNoCabinetDllErrorS = 'Cannot load cabinet.dll';
AbFCIFileOpenErrorS = 'FCI cannot open file';
AbFCIFileReadErrorS = 'FCI cannot read file';
AbFCIFileWriteErrorS = 'FCI cannot write file';
AbFCIFileCloseErrorS = 'FCI close file error';
AbFCIFileSeekErrorS = 'FCI file seek error';
AbFCIFileDeleteErrorS = 'FCI file delete error';
AbFCIAddFileErrorS = 'FCI cannot add file';
AbFCICreateErrorS = 'FCI cannot create context';
AbFCIFlushCabinetErrorS = 'FCI cannot flush cabinet';
AbFCIFlushFolderErrorS = 'FCI cannot flush folder';
AbFDICopyErrorS = 'FDI cannot enumerate files';
AbFDICreateErrorS = 'FDI cannot create context';
AbInvalidCabTemplateS = 'Invalid cab file template';
AbInvalidCabFileS = 'Invalid file - not a cabinet file';
AbZipStored = 'Stored';
AbZipShrunk = 'Shrunk';
AbZipReduced = 'Reduced';
AbZipImploded = 'Imploded';
AbZipTokenized = 'Tokenized';
AbZipDeflated = 'Deflated';
AbZipDeflate64 = 'Enhanced Deflation';
AbZipDCLImploded = 'DCL Imploded';
AbZipBzip2 = 'Bzip2';
AbZipLZMA = 'LZMA';
AbZipIBMTerse = 'IBM Terse';
AbZipLZ77 = 'IBM LZ77';
AbZipJPEG = 'JPEG';
AbZipWavPack = 'WavPack';
AbZipPPMd = 'PPMd';
AbZipUnknown = 'Unknown (%d)';
AbZipBestMethod = 'Best Method';
AbVersionFormatS = 'Version %s';
AbCompressedSizeFormatS = 'Compressed Size: %d';
AbUncompressedSizeFormatS = 'Uncompressed Size: %d';
AbCompressionMethodFormatS = 'Compression Method: %s';
AbCompressionRatioFormatS = 'Compression Ratio: %2.0f%%';
AbCRCFormatS = 'CRC: %x';
AbReadOnlyS = 'r';
AbHiddenS = 'h';
AbSystemS = 's';
AbArchivedS = 'a';
AbEFAFormatS = 'External File Attributes: %s';
AbIFAFormatS = 'File Type: %s';
AbTextS = 'Text';
AbBinaryS = 'Binary';
AbEncryptionFormatS = 'Encryption: %s';
AbEncryptedS = 'Encrypted';
AbNotEncryptedS = 'Not Encrypted';
AbUnknownS = 'Unknown';
AbTimeStampFormatS = 'Time Stamp: %s';
AbMadeByFormatS = 'Made by Version: %f';
AbNeededFormatS = 'Version Needed to Extract: %f';
AbCommentFormatS = 'Comment: %s';
AbDefaultExtS = '*.zip';
AbFilterS = 'PKZip Archives (*.zip)|*.zip|Self Extracting Archives (*.exe)|*.exe|All Files (*.*)|*.*';
AbFileNameTitleS = 'Select File Name';
AbOKS = 'OK';
AbCancelS = 'Cancel';
AbSelectDirectoryS = 'Select Directory';
AbEnterPasswordS = 'Enter Password';
AbPasswordS = '&Password';
AbVerifyS = '&Verify';
AbCabExtS = '*.cab';
AbCabFilterS = 'Cabinet Archives (*.cab)|*.CAB|All Files (*.*)|*.*';
AbLogExtS = '*.txt';
AbLogFilterS = 'Text Files (*.txt)|*.TXT|All Files (*.*)|*.*';
AbExeExtS = '*.exe';
AbExeFilterS = 'Self-Extracting Zip Files (*.exe)|*.EXE|All Files (*.*)|*.*';
AbVMSReadTooManyBytesS = 'VMS: request to read too many bytes [%d]';
AbVMSInvalidOriginS = 'VMS: invalid origin %d, should be 0, 1, 2';
AbVMSErrorOpenSwapS = 'VMS: Cannot open swap file %s';
AbVMSSeekFailS = 'VMS: Failed to seek in swap file %s';
AbVMSReadFailS = 'VMS: Failed to read %d bytes from swap file %s';
AbVMSWriteFailS = 'VMS: Failed to write %d bytes to swap file %s';
AbVMSWriteTooManyBytesS = 'VMS: request to write too many bytes [%d]';
AbBBSReadTooManyBytesS = 'BBS: request to read too many bytes [%d]';
AbBBSSeekOutsideBufferS = 'BBS: New position is outside the buffer';
AbBBSInvalidOriginS = 'BBS: Invalid Origin value';
AbBBSWriteTooManyBytesS = 'BBS: request to write too many bytes [%d]';
AbSWSNotEndofStreamS = 'TabSlidingWindowStream.Write: Not at end of stream';
AbSWSSeekFailedS = 'TabSlidingWindowStream.bsWriteChunk: seek failed';
AbSWSWriteFailedS = 'TabSlidingWindowStream.bsWriteChunk: write failed';
AbSWSInvalidOriginS = 'TabSlidingWindowStream.Seek: invalid origin';
AbSWSInvalidNewOriginS = 'TabSlidingWindowStream.Seek: invalid new position';
AbItemNameHeadingS = 'Name';
AbPackedHeadingS = 'Packed';
AbMethodHeadingS = 'Method';
AbRatioHeadingS = 'Ratio (%)';
AbCRCHeadingS = 'CRC32';
AbFileAttrHeadingS = 'Attributes';
AbFileFormatHeadingS = 'Format';
AbEncryptionHeadingS = 'Encrypted';
AbTimeStampHeadingS = 'Time Stamp';
AbFileSizeHeadingS = 'Size';
AbVersionMadeHeadingS = 'Version Made';
AbVersionNeededHeadingS = 'Version Needed';
AbPathHeadingS = 'Path';
AbPartialHeadingS = 'Partial';
AbExecutableHeadingS = 'Executable';
AbFileTypeHeadingS = 'Type';
AbLastModifiedHeadingS = 'Modified';
AbCabMethod0S = 'None';
AbCabMethod1S = 'MSZip';
AbLtAddS = ' added ';
AbLtDeleteS = ' deleted ';
AbLtExtractS = ' extracted ';
AbLtFreshenS = ' freshened ';
AbLtMoveS = ' moved ';
AbLtReplaceS = ' replaced ';
AbLtStartS = ' logging ';
AbGzipInvalidS = 'Invalid Gzip';
AbGzipBadCRCS = 'Bad CRC';
AbGzipBadFileSizeS = 'Bad File Size';
AbTarInvalidS = 'Invalid Tar';
AbTarBadFileNameS = 'File name too long';
AbTarBadLinkNameS = 'Symbolic link path too long';
AbTarBadOpS = 'Unsupported Operation';
AbUnhandledEntityS = 'Unhandled Entity';
{ pre-defined "operating system" (really more FILE system) identifiers for the
Gzip header }
AbGzOsFat = 'FAT File System (MS-DOS, OS/2, NT/Win32)';
AbGzOsAmiga = 'Amiga';
AbGzOsVMS = 'VMS (or OpenVMS)';
AbGzOsUnix = 'Unix';
AbGzOsVM_CMS = 'VM/CMS';
AbGzOsAtari = 'Atari TOS';
AbGzOsHPFS = 'HPFS File System (OS/2, NT)';
AbGzOsMacintosh = 'Macintosh';
AbGzOsZ_System = 'Z-System';
AbGzOsCP_M = 'CP/M';
AbGzOsTOPS_20 = 'TOPS-20';
AbGzOsNTFS = 'NTFS File System (NT)';
AbGzOsQDOS = 'QDOS';
AbGzOsAcornRISCOS = 'Acorn RISCOS';
AbGzOsVFAT = 'VFAT File System (Win95, NT)';
AbGzOsMVS = 'MVS';
AbGzOsBeOS = 'BeOS (BeBox or PowerMac)';
AbGzOsTandem = 'Tandem/NSK';
AbGzOsTHEOS = 'THEOS';
AbGzOsunknown = 'unknown';
AbGzOsUndefined = 'ID undefined by gzip';
{ Compound File specific error messages }
resourcestring
AbCmpndIndexOutOfBounds = 'Index out of bounds';
AbCmpndBusyUpdating = 'Compound file is busy updating';
AbCmpndInvalidFile = 'Invalid compound file';
AbCmpndFileNotFound = 'File/Directory not found';
AbCmpndFolderNotEmpty = 'Folder not empty';
AbCmpndExceedsMaxFileSize = 'File size exceeds maximum allowable';
implementation
end.
================================================
FILE: lib/abbrevia/source/AbSWStm.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbSWStm.pas *}
{*********************************************************}
{* ABBREVIA: TabSlidingWindowStream class *}
{*********************************************************}
unit AbSWStm;
{$I AbDefine.inc}
{Notes: The TabSlidingWindowStream class provides a simple buffered
stream for sliding window compression/decompression routines.
The sliding window stream is limited when compared with a true
buffered stream:
- it is assumed that the underlying stream is just going to
be written to and is initially empty
- the buffer is fixed in size to 40KB
- write operations can only occur at the end of the stream
- the stream can only be positioned with a certain limited
range
- we can only read up to 32KB
- we can only write up to 32KB
The stream is written as a wrapper around another stream
(presumably a file stream) which is used for actual reads to
the buffer and writes from the buffer.
The stream buffer is organized as five 8KB chunks in an
array. The last chunk is the only one used for writing, the
other four are a 32KB buffer for reading. As the final chunk
gets filled, the class will drop off the first chunk (writing
it to the underlying stream, and shift the other chunks in the
array.}
{Define this if you wish to see a trace of the stream usage in a file
called C:\SlideWin.LOG}
{.$DEFINE DebugTrace}
interface
uses
SysUtils,
Classes;
const
abSWChunkCount = 5;
type
TabSlidingWindowStream = class(TStream)
protected {private}
bsChunks : array [0..pred(abSWChunkCount)] of PByteArray;
bsBufferStart : longint;
bsLastPos : integer;
bsCurChunk : integer;
bsPosInChunk : integer;
bsPosInBuffer : longint;
bsSize : Longint; {count of bytes in stream}
bsDirty : boolean; {whether the buffer is dirty or not}
bsStream : TStream; {actual stream containing data}
{$IFDEF DebugTrace}
bsF : System.Text;
{$ENDIF}
protected
procedure bsWriteChunk(aIndex : integer);
procedure bsSlide;
public
constructor Create(aStream : TStream);
{-create the buffered stream}
destructor Destroy; override;
{-destroy the buffered stream}
procedure Flush;
{-ensures that all dirty buffered data is flushed}
function Read(var Buffer; Count : Longint) : Longint; override;
{-read from the stream into a buffer}
function Seek(Offset : Longint; Origin : Word) : Longint; override;
{-seek to a particular point in the stream}
function Write(const Buffer; Count : Longint) : Longint; override;
{-write to the stream from a buffer}
end;
implementation
const
ChunkSize = 8192; {cannot be greater than MaxInt}
{===Helper routines==================================================}
procedure RaiseException(const S : string);
begin
raise Exception.Create(S);
end;
{====================================================================}
{===TabSlidingWindowStream===========================================}
constructor TabSlidingWindowStream.Create(aStream : TStream);
var
i : integer;
begin
inherited Create;
{save the actual stream}
bsStream := aStream;
{allocate the chunks-they must be set to binary zeros}
for i := 0 to pred(abSWChunkCount) do
bsChunks[i] := AllocMem(ChunkSize);
{set the page/buffer variables to the start of the stream; remember
we only write to the last chunk--the previous chunks are set to
binary zeros}
aStream.Position := 0;
bsSize := 0;
bsBufferStart := -ChunkSize * pred(abSWChunkCount);
bsPosInBuffer := ChunkSize * pred(abSWChunkCount);
bsCurChunk := pred(abSWChunkCount);
bsPosInChunk := 0;
bsDirty := false;
{$IFDEF DebugTrace}
System.Assign(bsF, 'c:\SlideWin.LOG');
if FileExists('c:\SlideWin.LOG') then
System.Append(bsF)
else
System.Rewrite(bsF);
writeln(bsF, '---NEW LOG---');
{$ENDIF}
end;
{--------}
destructor TabSlidingWindowStream.Destroy;
var
i : integer;
begin
{destroy the buffer, after writing it to the actual stream}
if bsDirty then
Flush;
for i := 0 to pred(abSWChunkCount) do
if (bsChunks[i] <> nil) then
FreeMem(bsChunks[i], ChunkSize);
{$IFDEF DebugTrace}
System.Close(bsF);
{$ENDIF}
{let our ancestor clean up}
inherited Destroy;
end;
{--------}
procedure TabSlidingWindowStream.bsSlide;
var
SavePtr : PByteArray;
i : integer;
begin
{write out the first chunk}
bsWriteChunk(0);
{slide the chunks around}
SavePtr := bsChunks[0];
for i := 0 to abSWChunkCount-2 do
bsChunks[i] := bsChunks[i+1];
bsChunks[pred(abSWChunkCount)] := SavePtr;
{advance the buffer start position}
inc(bsBufferStart, ChunkSize);
{reset the write position}
bsPosInChunk := 0;
bsPosInBuffer := ChunkSize * pred(abSWChunkCount);
bsLastPos := 0;
end;
{--------}
procedure TabSlidingWindowStream.bsWriteChunk(aIndex : integer);
var
SeekResult : longint;
BytesWrit : longint;
Offset : longint;
BytesToWrite : integer;
begin
Offset := bsBufferStart + (longint(aIndex) * ChunkSize);
if (Offset >= 0) then begin
SeekResult := bsStream.Seek(Offset, 0);
if (SeekResult = -1) then
RaiseException('TabSlidingWindowStream.bsWriteChunk: seek failed');
if (aIndex <> pred(abSWChunkCount)) then
BytesToWrite := ChunkSize
else
BytesToWrite := bsLastPos;
BytesWrit := bsStream.Write(bsChunks[aIndex]^, BytesToWrite);
if (BytesWrit <> BytesToWrite) then
RaiseException('TabSlidingWindowStream.bsWriteChunk: write failed');
end;
end;
{--------}
procedure TabSlidingWindowStream.Flush;
var
i : integer;
begin
if bsDirty then begin
for i := 0 to pred(abSWChunkCount) do
bsWriteChunk(i);
bsDirty := false;
end;
end;
{--------}
function TabSlidingWindowStream.Read(var Buffer; Count : Longint) : Longint;
var
BufPtr : PByte;
BytesToGo : Longint;
BytesToRead : integer;
begin
BufPtr := @Buffer;
{$IFDEF DebugTrace}
System.Writeln(bsF, 'Read: ', Count, ' bytes');
{$ENDIF}
{we do not support reads greater than 32KB bytes}
if (Count > 32*1024) then
Count := 32*1024;
{reading is complicated by the fact we can only read in chunks of
ChunkSize: we need to partition out the overall read into a
read from part of the chunk, zero or more reads from complete
chunks and then a possible read from part of a chunk}
{calculate the actual number of bytes we can read - this depends on
the current position and size of the stream as well as the number
of bytes requested}
BytesToGo := Count;
if (bsSize < (bsBufferStart + bsPosInBuffer + Count)) then
BytesToGo := bsSize - (bsBufferStart + bsPosInBuffer);
if (BytesToGo <= 0) then begin
Result := 0;
Exit;
end;
{remember to return the result of our calculation}
Result := BytesToGo;
{calculate the number of bytes we can read prior to the loop}
BytesToRead := ChunkSize - bsPosInChunk;
if (BytesToRead > BytesToGo) then
BytesToRead := BytesToGo;
{copy from the stream buffer to the caller's buffer}
if (BytesToRead = 1) then
BufPtr^ := bsChunks[bsCurChunk]^[bsPosInChunk]
else
Move(bsChunks[bsCurChunk]^[bsPosInChunk], BufPtr^, BytesToRead);
{calculate the number of bytes still to read}
dec(BytesToGo, BytesToRead);
{while we have bytes to read, read them}
while (BytesToGo > 0) do begin
{advance the pointer for the caller's buffer}
inc(BufPtr, BytesToRead);
{as we've exhausted this chunk, advance to the next}
inc(bsCurChunk);
bsPosInChunk := 0;
{calculate the number of bytes we can read in this cycle}
BytesToRead := ChunkSize;
if (BytesToRead > BytesToGo) then
BytesToRead := BytesToGo;
{copy from the stream buffer to the caller's buffer}
Move(bsChunks[bsCurChunk]^, BufPtr^, BytesToRead);
{calculate the number of bytes still to read}
dec(BytesToGo, BytesToRead);
end;
{remember our new position}
inc(bsPosInChunk, BytesToRead);
end;
{--------}
function TabSlidingWindowStream.Seek(Offset : Longint;
Origin : Word) : Longint;
{$IFDEF DebugTrace}
const
OriginStr : array [0..2] of string[7] = ('start', 'current', 'end');
{$ENDIF}
var
NewPos : Longint;
begin
{$IFDEF DebugTrace}
System.Writeln(bsF, 'Seek: ', Offset, ' bytes from ', OriginStr[Origin]);
{$ENDIF}
{calculate the new position}
case Origin of
soFromBeginning : NewPos := Offset;
soFromCurrent : NewPos := bsBufferStart + bsPosInBuffer + Offset;
soFromEnd : NewPos := bsSize + Offset;
else
NewPos := 0;
RaiseException('TabSlidingWindowStream.Seek: invalid origin');
end;
{if the new position is invalid, say so}
if (NewPos < bsBufferStart) or (NewPos > bsSize) then
RaiseException('TabSlidingWindowStream.Seek: invalid new position');
{calculate the chunk number and the position in buffer & chunk}
bsPosInBuffer := NewPos - bsBufferStart;
bsCurChunk := bsPosInBuffer div ChunkSize;
bsPosInChunk := bsPosInBuffer mod ChunkSize;
{return the new position}
Result := NewPos;
end;
{--------}
function TabSlidingWindowStream.Write(const Buffer; Count : Longint) : Longint;
var
BufPtr : PByte;
BytesToGo : Longint;
BytesToWrite: integer;
begin
BufPtr := @Buffer;
{$IFDEF DebugTrace}
System.Writeln(bsF, 'Write: ', Count, ' bytes');
{$ENDIF}
{we ONLY write at the end of the stream}
if ((bsBufferStart + bsPosInBuffer) <> bsSize) then
RaiseException('TabSlidingWindowStream.Write: Not at end of stream');
{we do not support writes greater than 32KB bytes}
if (Count > 32*1024) then
Count := 32*1024;
{writing is complicated by the fact we write in chunks of Chunksize
bytes: we need to partition out the overall write into a write
to part of the chunk, zero or more writes to complete chunks and
then a possible write to part of a chunk; every time we fill a
chunk we have toi slide the buffer}
{when we write to this stream we always assume that we can write the
requested number of bytes: if we can't (eg, the disk is full) we'll
get an exception somewhere eventually}
BytesToGo := Count;
{remember to return the result of our calculation}
Result := BytesToGo;
{calculate the number of bytes we can write prior to the loop}
BytesToWrite := ChunkSize - bsPosInChunk;
if (BytesToWrite > BytesToGo) then
BytesToWrite := BytesToGo;
{copy from the caller's buffer to the stream buffer}
if (BytesToWrite = 1) then
bsChunks[pred(abSWChunkCount)]^[bsPosInChunk] := BufPtr^
else
Move(BufPtr^,
bsChunks[pred(abSWChunkCount)]^[bsPosInChunk],
BytesToWrite);
{mark our buffer as requiring a save to the actual stream}
bsDirty := true;
{calculate the number of bytes still to write}
dec(BytesToGo, BytesToWrite);
{while we have bytes to write, write them}
while (BytesToGo > 0) do begin
{slide the buffer}
bsSlide;
{advance the pointer for the caller's buffer}
inc(BufPtr, BytesToWrite);
{calculate the number of bytes we can write in this cycle}
BytesToWrite := ChunkSize;
if (BytesToWrite > BytesToGo) then
BytesToWrite := BytesToGo;
{copy from the caller's buffer to our buffer}
Move(BufPtr^,
bsChunks[pred(abSWChunkCount)]^,
BytesToWrite);
{calculate the number of bytes still to write}
dec(BytesToGo, BytesToWrite);
end;
{remember our new position}
inc(bsPosInChunk, BytesToWrite);
bsPosInBuffer := (longint(ChunkSize) * pred(abSWChunkCount)) + bsPosInChunk;
bsLastPos := bsPosInChunk;
{make sure the stream size is correct}
inc(bsSize, Result);
{if we're at the end of the chunk, slide the buffer ready for next
time we write}
if (bsPosInChunk = ChunkSize) then
bsSlide;
end;
{====================================================================}
end.
================================================
FILE: lib/abbrevia/source/AbSelfEx.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbSelfEx.pas *}
{*********************************************************}
{* ABBREVIA: Component for building self-extracting zips *}
{*********************************************************}
unit AbSelfEx;
{$I AbDefine.inc}
interface
uses
Classes,
AbBase;
type
TAbGetFileEvent = procedure(Sender : TObject; var aFilename : string;
var Abort : Boolean) of object;
type
TAbMakeSelfExe = class(TAbBaseComponent)
protected {private}
FStubExe : string;
FZipFile : string;
FSelfExe : string;
FStubStream : TFileStream;
FZipStream : TFileStream;
FSelfStream : TFileStream;
FOnGetStubExe : TAbGetFileEvent;
FOnGetZipFile : TAbGetFileEvent;
procedure DoGetStubExe(var Abort : Boolean);
procedure DoGetZipFile(var Abort : Boolean);
public
function Execute : Boolean;
published
property SelfExe : string
read FSelfExe
write FSelfExe;
property StubExe : string
read FStubExe
write FStubExe;
property ZipFile : string
read FZipFile
write FZipFile;
property OnGetStubExe : TAbGetFileEvent
read FOnGetStubExe
write FOnGetStubExe;
property OnGetZipFile : TAbGetFileEvent
read FOnGetZipFile
write FOnGetZipFile;
property Version;
end;
implementation
uses
SysUtils,
{$IFDEF LibcAPI}
Libc,
{$ENDIF}
AbExcept, AbZipTyp;
{ -------------------------------------------------------------------------- }
function TAbMakeSelfExe.Execute : Boolean;
var
Abort : Boolean;
begin
Abort := False;
if (FStubExe = '') then
DoGetStubExe(Abort);
if Abort then
raise EAbUserAbort.Create;
if not FileExists(FStubExe) then
raise EAbFileNotFound.Create;
if (FZipFile = '') then
DoGetZipFile(Abort);
if Abort then
raise EAbUserAbort.Create;
if not FileExists(FZipFile) then
raise EAbFileNotFound.Create;
FStubStream := TFileStream.Create(FStubExe, fmOpenRead or fmShareDenyWrite);
FZipStream := TFileStream.Create(FZipFile, fmOpenRead or fmShareDenyWrite);
if (FSelfExe = '') then
FSelfExe := ChangeFileExt(FZipFile, '.exe');
FSelfStream := TFileStream.Create(FSelfExe, fmCreate or fmShareExclusive);
try
MakeSelfExtracting(FStubStream, FZipStream, FSelfStream);
Result := True;
finally
FStubStream.Free;
FZipStream.Free;
FSelfStream.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbMakeSelfExe.DoGetStubExe(var Abort: Boolean);
begin
if Assigned(FOnGetStubExe) then
FOnGetStubExe(Self, FStubExe, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbMakeSelfExe.DoGetZipFile(var Abort : Boolean);
begin
if Assigned(FOnGetZipFile) then
FOnGetZipFile(Self, FZipFile, Abort);
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbSpanSt.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Craig Peterson
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbSpanSt.pas *}
{*********************************************************}
{* ABBREVIA: TAbSpan*Stream Classes *}
{*********************************************************}
{* Streams to handle splitting ZIP files or spanning *}
{* them to diskettes *}
{*********************************************************}
unit AbSpanSt;
{$I AbDefine.inc}
interface
uses
Classes,
AbArcTyp;
type
{ TAbSpanBaseStream interface ============================================== }
TAbSpanBaseStream = class(TStream)
protected {private}
FArchiveName: string;
FOnRequestImage: TAbRequestImageEvent;
protected {methods}
function GetImageName( ImageNumber: Integer ): string;
public {methods}
constructor Create( const ArchiveName: string );
public {events}
property OnRequestImage : TAbRequestImageEvent
read FOnRequestImage
write FOnRequestImage;
end;
{ TAbSpanReadStream interface ============================================== }
TAbSpanReadStream = class(TAbSpanBaseStream)
protected {private}
FCurrentImage: LongWord;
FIsSplit: Boolean;
FLastImage: LongWord;
FStream: TStream;
FOnRequestNthDisk : TAbRequestNthDiskEvent;
protected {methods}
procedure GotoImage( ImageNumber: Integer );
procedure SetOnRequestImage(Value: TAbRequestImageEvent);
public {methods}
constructor Create( const ArchiveName: string; CurrentImage: LongWord;
Stream: TStream );
destructor Destroy;
override;
function Read(var Buffer; Count: Longint): Longint;
override;
function Write(const Buffer; Count: Longint): Longint;
override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
override;
procedure SeekImage( Image: LongWord; const Offset: Int64);
public {events}
property OnRequestImage
write SetOnRequestImage;
property OnRequestNthDisk : TAbRequestNthDiskEvent
read FOnRequestNthDisk
write FOnRequestNthDisk;
end;
{ TAbSpanWriteStream interface ============================================= }
TAbSpanWriteStream = class(TAbSpanBaseStream)
protected {private}
FCurrentImage: LongWord;
FImageSize: Int64;
FStream: TStream;
FThreshold: Int64;
FOnRequestBlankDisk : TAbRequestDiskEvent;
protected {methods}
procedure NewImage;
public {methods}
constructor Create( const ArchiveName: string; Stream: TStream;
Threshold: Int64 );
destructor Destroy;
override;
function Read(var Buffer; Count: Longint): Longint;
override;
function Write(const Buffer; Count: Longint): Longint;
override;
function WriteUnspanned(const Buffer; Count: Longint;
FailOnSpan: Boolean = False): Boolean;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
override;
function ReleaseStream: TStream;
public {properties}
property CurrentImage : LongWord
read FCurrentImage;
public {events}
property OnRequestBlankDisk : TAbRequestDiskEvent
read FOnRequestBlankDisk
write FOnRequestBlankDisk;
end;
implementation
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
Math, RTLConsts, SysUtils, AbUtils, AbExcept;
{============================================================================}
{ TAbSpanBaseStream implementation ========================================= }
constructor TAbSpanBaseStream.Create( const ArchiveName: string );
begin
inherited Create;
FArchiveName := ArchiveName;
end;
{------------------------------------------------------------------------------}
function TAbSpanBaseStream.GetImageName( ImageNumber: Integer ): string;
var
Abort : Boolean;
Ext : string;
begin
{generate default name}
Ext := ExtractFileExt(FArchiveName);
if (Length(Ext) < 2) then
Ext := '.' + Format('%.2d', [ImageNumber])
else
Ext := Ext[1] + Ext[2] + Format('%.2d', [ImageNumber]);
Result := ChangeFileExt(FArchiveName, Ext);
{call event}
if Assigned(FOnRequestImage) then begin
Abort := False;
FOnRequestImage(Self, ImageNumber, Result, Abort);
if Abort then
raise EAbUserAbort.Create;
end;
end;
{============================================================================}
{ TAbSpanReadStream implementation ========================================= }
constructor TAbSpanReadStream.Create( const ArchiveName: string;
CurrentImage: LongWord; Stream: TStream );
begin
inherited Create(ArchiveName);
FCurrentImage := CurrentImage;
FIsSplit := FileExists(GetImageName(1)) or not AbDriveIsRemovable(ArchiveName);
FLastImage := CurrentImage;
FStream := Stream;
end;
{------------------------------------------------------------------------------}
destructor TAbSpanReadStream.Destroy;
begin
FreeAndNil(FStream);
inherited;
end;
{------------------------------------------------------------------------------}
procedure TAbSpanReadStream.GotoImage( ImageNumber: Integer );
var
Abort: Boolean;
ImageName: string;
begin
{ switch to the requested image. ImageNumber is passed in as 0-based to
match the zip spec, but all of the callbacks receive 1-based values. }
FreeAndNil(FStream);
FCurrentImage := ImageNumber;
Inc(ImageNumber);
ImageName := FArchiveName;
if FIsSplit then begin
{ the last image uses the original filename }
if FCurrentImage <> FLastImage then
ImageName := GetImageName(ImageNumber)
end
else if Assigned(FOnRequestNthDisk) then begin
Abort := False;
repeat
FOnRequestNthDisk(Self, ImageNumber, Abort);
if Abort then
raise EAbUserAbort.Create;
until AbGetDriveFreeSpace(ImageName) <> -1;
end
else
raise EAbUserAbort.Create;
FStream := TFileStream.Create(ImageName, fmOpenRead or fmShareDenyWrite);
end;
{------------------------------------------------------------------------------}
function TAbSpanReadStream.Read(var Buffer; Count: Longint): Longint;
var
BytesRead, BytesLeft: LongInt;
PBuf: PByte;
begin
{ read until the buffer's full, switching images if necessary }
Result := 0;
if FStream = nil then
Exit;
PBuf := @Buffer;
BytesLeft := Count;
while Result < Count do begin
BytesRead := FStream.Read(PBuf^, BytesLeft);
Inc(Result, BytesRead);
Inc(PBuf, BytesRead);
Dec(BytesLeft, BytesRead);
if BytesRead < BytesLeft then begin
if FCurrentImage <> FLastImage then
GotoImage(FCurrentImage + 1)
else
Break;
end;
end;
end;
{------------------------------------------------------------------------------}
function TAbSpanReadStream.Write(const Buffer; Count: Longint): Longint;
begin
raise EAbException.Create('TAbSpanReadStream.Write unsupported');
end;
{------------------------------------------------------------------------------}
function TAbSpanReadStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
if FStream = nil then
Result := 0
else if (Offset = 0) and (Origin = soCurrent) then
Result := FStream.Position
else
raise EAbException.Create('TAbSpanReadStream.Seek unsupported');
end;
{------------------------------------------------------------------------------}
procedure TAbSpanReadStream.SeekImage( Image: LongWord; const Offset: Int64);
begin
if FStream = nil then
Exit;
if FCurrentImage <> Image then
GotoImage(Image);
FStream.Position := Offset;
end;
{------------------------------------------------------------------------------}
procedure TAbSpanReadStream.SetOnRequestImage(Value: TAbRequestImageEvent);
begin
FOnRequestImage := Value;
FIsSplit := FileExists(GetImageName(1)) or not AbDriveIsRemovable(FArchiveName);
end;
{============================================================================}
{ TAbSpanWriteStream implementation ======================================== }
constructor TAbSpanWriteStream.Create( const ArchiveName: string;
Stream: TStream; Threshold: Int64 );
begin
inherited Create(ArchiveName);
FCurrentImage := 0;
FStream := Stream;
FThreshold := Threshold;
end;
{------------------------------------------------------------------------------}
destructor TAbSpanWriteStream.Destroy;
begin
FStream.Free;
inherited;
end;
{------------------------------------------------------------------------------}
procedure TAbSpanWriteStream.NewImage;
var
Abort: Boolean;
begin
{ start a new span or blank disk. FCurrentImage is 0-based to match the zip
spec, but all of the callbacks receive 1-based values. }
FreeAndNil(FStream);
Inc(FCurrentImage);
if FThreshold > 0 then
RenameFile(FArchiveName, GetImageName(FCurrentImage))
else begin
if Assigned(FOnRequestBlankDisk) then begin
Abort := False;
repeat
FOnRequestBlankDisk(Self, Abort);
if Abort then
raise EAbUserAbort.Create;
until AbGetDriveFreeSpace(FArchiveName) <> -1;
end
else
raise EAbUserAbort.Create;
AbSetSpanVolumeLabel(AbDrive(FArchiveName), FCurrentImage);
end;
FStream := TFileStream.Create(FArchiveName, fmCreate or fmShareDenyWrite);
FImageSize := 0;
end;
{------------------------------------------------------------------------------}
function TAbSpanWriteStream.Read(var Buffer; Count: Longint): Longint;
begin
raise EAbException.Create('TAbSpanWriteStream.Read unsupported');
end;
{------------------------------------------------------------------------------}
function TAbSpanWriteStream.Write(const Buffer; Count: Longint): Longint;
var
BytesWritten, BytesLeft: LongInt;
PBuf: PByte;
begin
{ write until the buffer is done, starting new spans if necessary }
Result := 0;
if FStream = nil then
Exit;
PBuf := @Buffer;
BytesLeft := Count;
while Result < Count do begin
if FThreshold > 0 then
BytesWritten := FStream.Write(PBuf^, Min(BytesLeft, FThreshold - FImageSize))
else
BytesWritten := FStream.Write(PBuf^, BytesLeft);
Inc(FImageSize, BytesWritten);
Inc(Result, BytesWritten);
Inc(PBuf, BytesWritten);
Dec(BytesLeft, BytesWritten);
if BytesWritten < BytesLeft then
NewImage;
end;
end;
{------------------------------------------------------------------------------}
function TAbSpanWriteStream.WriteUnspanned(const Buffer; Count: Longint;
FailOnSpan: Boolean = False): Boolean;
var
BytesWritten: LongInt;
begin
{ write as a contiguous block, starting a new span if there isn't room.
FailOnSpan (and result = false) can be used to update data before it's
written again }
if FStream = nil then
raise EWriteError.Create(SWriteError);
if (FThreshold > 0) and (FThreshold - FImageSize < Count) then
BytesWritten := 0
else
BytesWritten := FStream.Write(Buffer, Count);
if BytesWritten < Count then begin
if BytesWritten > 0 then
FStream.Size := FStream.Size - BytesWritten;
NewImage;
if FailOnSpan then
BytesWritten := 0
else begin
BytesWritten := Count;
FStream.WriteBuffer(Buffer, Count);
end;
end;
Inc(FImageSize, BytesWritten);
Result := (BytesWritten = Count);
end;
{------------------------------------------------------------------------------}
function TAbSpanWriteStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
if FStream = nil then
Result := 0
else if (Offset = 0) and (Origin = soCurrent) then
Result := FStream.Position
else
raise EAbException.Create('TAbSpanWriteStream.Seek unsupported');
end;
{------------------------------------------------------------------------------}
function TAbSpanWriteStream.ReleaseStream: TStream;
begin
Result := FStream;
FStream := nil;
end;
{------------------------------------------------------------------------------}
end.
================================================
FILE: lib/abbrevia/source/AbTarTyp.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Joel Haynie
* Craig Peterson
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbTarTyp.pas *}
{*********************************************************}
{* ABBREVIA: TAbTarArchive, TAbTarItem classes *}
{*********************************************************}
{* Misc. constants, types, and routines for working *}
{* with Tar files *}
{*********************************************************}
unit AbTarTyp;
{$I AbDefine.inc}
interface
uses
Classes,
AbUtils, AbArcTyp;
const
AB_TAR_RECORDSIZE = 512; {Note: SizeOf(TAbTarHeaderRec) = AB_TAR_RECORDSIZE}
AB_TAR_NAMESIZE = 100;
AB_TAR_V7_EMPTY_SIZE = 167;
AB_TAR_USTAR_PREFIX_SIZE = 155;
AB_TAR_STAR_PREFIX_SIZE = 131;
AB_TAR_OLD_GNU_EMPTY1_SIZE = 5;
AB_TAR_OLD_GNU_SPARSE_SIZE = 96;
AB_TAR_OLD_GNU_EMPTY2_SIZE = 17;
AB_TAR_SIZE_AFTER_STDHDR = 167;
AB_TAR_TUSRNAMELEN = 32;
AB_TAR_TGRPNAMELEN = 32;
{ The checksum field is filled with this while the checksum is computed. }
AB_TAR_CHKBLANKS = ' '; { 8 blank spaces(#20), no null }
AB_TAR_L_HDR_NAME = '././@LongLink'; { As seen in the GNU File Examples}
AB_TAR_L_HDR_USR_NAME='root'; { On Cygwin this is #0, Redhat it is 'root' }
AB_TAR_L_HDR_GRP_NAME='root'; { Same on all OS's }
AB_TAR_L_HDR_ARR8_0 ='0000000'#0; { 7 zeros and one null }
AB_TAR_L_HDR_ARR12_0 ='00000000000'#0;{ 11 zeros and one null }
AB_TAR_MAGIC_VAL = 'ustar'#0; { 5 chars & a nul }
AB_TAR_MAGIC_VER = '00'; { 2 chars }
AB_TAR_MAGIC_GNUOLD = 'ustar '#0; { 7 chars & a null }
AB_TAR_MAGIC_V7_NONE = #0#0#0#0#0#0#0#0;{ 8, #0 }
{ The linkflag defines the type of file(FH), and Meta Data about File(MDH) }
AB_TAR_LF_OLDNORMAL = #0; { FH, Normal disk file, Unix compatible } { Historically used for V7 }
AB_TAR_LF_NORMAL = '0'; { FH, Normal disk file }
AB_TAR_LF_LINK = '1'; { FH, Link to previously archived file }
AB_TAR_LF_SYMLINK = '2'; { FH, Symbolic(soft) link }
AB_TAR_LF_CHR = '3'; { FH, Character special file }{ Used for device nodes, Conditionally compiled into GNUTAR }
AB_TAR_LF_BLK = '4'; { FH, Block special file }{ Used for device nodes, Conditionally compiled into GNUTAR }
AB_TAR_LF_DIR = '5'; { FH, Directory, Zero size File }
AB_TAR_LF_FIFO = '6'; { FH, FIFO special file }{ Used for fifo files(pipe like), Conditionally complied into GNUTAR }
AB_TAR_LF_CONTIG = '7'; { FH, Contiguous file } { Normal File, but All blocks should be contiguos on the disk }
AB_TAR_LF_XHDR = 'x'; { MDH, POSIX, Next File has Extended Header }
AB_TAR_LF_XGL = 'g'; { MDH, POSIX, Global Extended Header }
AB_TAR_LF_DUMPDIR = 'D'; { FH, Extra GNU, Dump Directory} { Generated Dump of Files in a directory, has a size }
AB_TAR_LF_LONGLINK = 'K'; { MDH, Extra GNU, Next File has Long LinkName}
AB_TAR_LF_LONGNAME = 'L'; { MDH, Extra GNU, Next File has Long Name}
AB_TAR_LF_MULTIVOL = 'M'; { FH, Extra GNU, MultiVolume File Cont.}{ End of a file that spans multiple TARs }
AB_TAR_LF_SPARSE = 'S'; { FH, Extra GNU, Sparse File Cont.}
AB_TAR_LF_VOLHDR = 'V'; { FH, Extra GNU, File is Volume Header }
AB_TAR_LF_EXHDR = 'X'; { MDH, Extra GNU, Solaris Extended Header }
{ The only questionable MetaData type is 'V', file or meta-data? will treat as file header }
AB_SUPPORTED_F_HEADERS = [AB_TAR_LF_OLDNORMAL, AB_TAR_LF_NORMAL, AB_TAR_LF_LINK,
AB_TAR_LF_SYMLINK, AB_TAR_LF_DIR];
AB_UNSUPPORTED_F_HEADERS = [AB_TAR_LF_CHR, AB_TAR_LF_BLK, AB_TAR_LF_FIFO,
AB_TAR_LF_CONTIG, AB_TAR_LF_DUMPDIR, AB_TAR_LF_MULTIVOL,
AB_TAR_LF_SPARSE, AB_TAR_LF_VOLHDR];
AB_SUPPORTED_MD_HEADERS = [AB_TAR_LF_LONGNAME, AB_TAR_LF_LONGLINK];
AB_UNSUPPORTED_MD_HEADERS= [AB_TAR_LF_XHDR, AB_TAR_LF_XGL, AB_TAR_LF_EXHDR];
AB_GNU_MD_HEADERS = [AB_TAR_LF_LONGLINK, AB_TAR_LF_LONGNAME]; { If present then OLD_/GNU_FORMAT }
AB_PAX_MD_HEADERS = [AB_TAR_LF_XHDR, AB_TAR_LF_XGL]; { If present then POSIX_FORMAT }
AB_IGNORE_SIZE_HEADERS = [AB_TAR_LF_LINK, AB_TAR_LF_SYMLINK, AB_TAR_LF_CHR,
AB_TAR_LF_BLK, AB_TAR_LF_DIR, AB_TAR_LF_FIFO];
{ The rest of the Chars are unsupported and unknown types Treat those headers as File types }
{ Further link types may be defined later. }
{ Bits used in the mode field - values in octal }
AB_TAR_TSUID = $0800; { Set UID on execution }
AB_TAR_TSGID = $0400; { Set GID on execution }
AB_TAR_TSVTX = $0200; { Save text (sticky bit) }
type
Arr8 = array [0..7] of AnsiChar;
Arr12 = array [0..11] of AnsiChar;
Arr12B = array[0..11] of Byte;
ArrName = array [0..AB_TAR_NAMESIZE-1] of AnsiChar;
TAbTarHeaderFormat = (UNKNOWN_FORMAT, V7_FORMAT, OLDGNU_FORMAT, GNU_FORMAT,
USTAR_FORMAT, STAR_FORMAT, POSIX_FORMAT);
TAbTarItemType = (SUPPORTED_ITEM, UNSUPPORTED_ITEM, UNKNOWN_ITEM);
TAbTarHeaderType = (FILE_HEADER, META_DATA_HEADER, MD_DATA_HEADER, UNKNOWN_HEADER);
TAbTarMagicType = (GNU_OLD, NORMAL);
TAbTarMagicRec = packed record
case TAbTarMagicType of
GNU_OLD: (gnuOld : array[0..7] of AnsiChar); { Old GNU magic: (Magic.gnuOld) }
NORMAL : (value : array[0..5] of AnsiChar; { Magic value: (Magic.value)}
version: array[0..1] of AnsiChar); { Version: (Magic.version) }
end;
{ Notes from GNU Tar & POSIX Spec.: }
{All the first 345 bytes are the same. }
{ "USTAR_header": Prefix(155): 345-499,
empty(12): 500-511 }
{ "old_gnu_header": atime(12): 345-356,
ctime(12): 357-368,
offset(12): 369-380,
longnames(4): 381-384,
empty(1): 385,
sparse structs(4x(12+12)=96): 386-481,
isextended(1): 482,
realsize(12): 483-494,
empty(16): 495-511 }
{ "star_header": Prefix(131): 345-475,
atime(12): 476-487,
ctime(12): 488-499,
empty(12): 500-511 }
{ "star_in_header": prefix(1): 345,
empty(9): 346-354,
isextended(1): 355,
sparse structs(4x(12+12)=96): 356-451,
realsize(12): 452-463,
offset(12): 464-475,
atime(12): 476-487,
ctime(12): 488-499,
empty(8): 500-507,
xmagic(4): 508-511 }
{ "sparse_header": These two structs are the same, and they are Meta data about file. }
{"star_ext_header": sparse structs(21x(12+12)=504): 0-503,
isextended(1): 504 }
{POSIX(PAX) extended header: is a buffer packed with content of this form:
This if from the POSIX spec. References the C printf command string.
"%d %s=%s\n". Then they are simply concatenated. }
{ PAX Extended Header Keywords: }
{ 'atime', 'charset', 'comment', 'ctime', 'gid', 'gname', 'linkpath', 'mtime', 'path',
'realtime.', 'security.', 'size', 'uid', 'uname' }
{ GNU Added PAX Extended Header Keywords: }
{ 'GNU.sparse.name', 'GNU.sparse.major', 'GNU.sparse.minor',
'GNU.sparse.realsize', 'GNU.sparse.numblocks', 'GNU.sparse.size',
'GNU.sparse.offset', 'GNU.sparse.numbytes', 'GNU.sparse.map', 'GNU.dumpdir',
'GNU.volume.label', 'GNU.volume.filename', 'GNU.volume.size',
'GNU.volume.offset' }
{ V7 uses AB_TAR_LF_OLDNORMAL linkflag, has no magic field & no Usr/Grp Names }
{ V7 Format ends Empty(padded with zeros), as does the POSIX record. }
TAbTarEnd_Empty_Rec = packed record
Empty: array[0..AB_TAR_V7_EMPTY_SIZE-1] of Byte; { 345-511, $159-1FF, Empty Space }
end;
{ UStar End Format }
TAbTarEnd_UStar_Rec = packed record
Prefix: array[0..AB_TAR_USTAR_PREFIX_SIZE-1] of AnsiChar;
{ 345-499, $159-1F3, Prefix of file & path name, null terminated ASCII string }
Empty : Arr12B;{ 500-512, $1F4-1FF, Empty Space }
end;
{ Old GNU End Format }
TAbTarEnd_GNU_old_Rec = packed record
Atime : Arr12; { 345-356, $159-164, time of last access (UNIX Date in ASCII coded Octal)}
Ctime : Arr12; { 357-368, $165-170, time of last status change (UNIX Date in ASCII coded Octal)}
Offset: Arr12; { 369-380, $171-17C, Multirecord specific value }
Empty1: array[0..AB_TAR_OLD_GNU_EMPTY1_SIZE-1] of Byte;
{ 381-385, $17D-181, Empty Space, Once contained longname ref. }
Sparse: array[0..AB_TAR_OLD_GNU_SPARSE_SIZE-1] of Byte;
{ 386-481, $182-1E1, Sparse File specific values }
IsExtended: byte;{ 482, $ 1E2, Flag to signify Sparse file headers follow }
RealSize: Arr12;{ 483-494, $1E3-1EE, Real size of a Sparse File. }
Empty2: array[0..AB_TAR_OLD_GNU_EMPTY2_SIZE-1] of Byte;
{ 495-511, $1EF-1FF, Empty Space }
end;
{ Star End Format }
TAbTarEnd_Star_Rec = packed record
Prefix: array[0..AB_TAR_STAR_PREFIX_SIZE-1] of AnsiChar;
{ 345-499, $159-1F3, prefix of file & path name, null terminated ASCII string }
Atime : Arr12; { 476-487, $1DC-1E7, time of last access (UNIX Date in ASCII coded Octal)}
Ctime : Arr12; { 488-499, $1E8-1F3, time of last status change (UNIX Date in ASCII coded Octal)}
Empty : Arr12B;{ 500-512, $1F4-1FF, Empty Space }
end;
{ When support for sparse files is added, Add another record for sparse in header }
{ Note: SizeOf(TAbTarHeaderRec) = AB_TAR_RECORDSIZE by design }
PAbTarHeaderRec = ^TAbTarHeaderRec; { Declare pointer type for use in the list }
TAbTarHeaderRec = packed record
Name : ArrName; { 0- 99, $ 0- 63, filename, null terminated ASCII string, unless length is 100 }
Mode : Arr8; { 100-107, $ 64- 6B, file mode (UNIX style, ASCII coded Octal) }
uid : Arr8; { 108-115, $ 6C- 73, usrid # (UNIX style, ASCII coded Octal) }
gid : Arr8; { 116-123, $ 74- 7B, grpid # (UNIX style, ASCII coded Octal) }
Size : Arr12; { 124-135, $ 7C- 87, size of TARred file (ASCII coded Octal) }
ModTime : Arr12; { 136-147, $ 88- 93, time of last modification.(UNIX Date in ASCII coded Octal)
UTC time }
ChkSum : Arr8; { 148-155, $ 94- 9B, checksum of header (6 bytes ASCII coded Octal, #00, #20) }
LinkFlag: AnsiChar; { 156, $ 9C, type of item, one of the Link Flag constants from above }
LinkName: ArrName; { 157-256, $ 9D-100, name of link, null terminated ASCII string }
Magic : TAbTarMagicRec;
{ 257-264, $101-108, identifier, usually 'ustar'#00'00' }
UsrName : array [0..AB_TAR_TUSRNAMELEN-1] of AnsiChar;
{ 265-296, $109-128, username, null terminated ASCII string }
GrpName : array [0..AB_TAR_TGRPNAMELEN-1] of AnsiChar;
{ 297-328, $129-148, groupname, null terminated ASCII string }
DevMajor: Arr8; { 329-336, $149-150, major device ID (UNIX style, ASCII coded Octal) }
DevMinor: Arr8; { 337-344, $151-158, minor device ID (UNIX style, ASCII coded Octal) }
case TAbTarHeaderFormat of{ 345-511, $159-1FF See byte Definitions above.}
V7_FORMAT : ( v7 : TAbTarEnd_Empty_Rec );
OLDGNU_FORMAT: ( gnuOld: TAbTarEnd_GNU_old_Rec );
GNU_FORMAT : ( gnu : TAbTarEnd_GNU_old_Rec );
USTAR_FORMAT : ( ustar : TAbTarEnd_UStar_Rec );
STAR_FORMAT : ( star : TAbTarEnd_Star_Rec );
POSIX_FORMAT : ( pax : TAbTarEnd_Empty_Rec );
end;{ end TAbTarHeaderRec }
{ There are three main types of headers we will see in a Tar file }
{ TAbTarHeaderType = (STANDARD_HDR, SPARSE_HDR, POSIX_EXTENDED_HDR); }
{ The 1st is defined above, The later two are simply organized data types. }
TAbTarItemRec = record
{ Note: that the actual The name needs to be coherient with the name Inherited
from parent type TAbArchiveItem }
Name : string; { Path & File name. }
Mode : LongWord; { File Permissions }
uid : Integer; { User ID }
gid : Integer; { Group ID }
Size : Int64; { Tared File size }
ModTime : Int64; { Last time of Modification, in UnixTime }
ChkSumPass : Boolean; { Header Check sum found to be good }
LinkFlag : AnsiChar; { Link Flag, Echos the actual File Type of this Item. }
ItemType : TAbTarItemType; { Item Type Assigned from LinkFlag Header Types. }
LinkName : string; { Link Name }
Magic : AnsiString; { Magic value }
Version : Integer; { Version Number }
UsrName : string; { User Name, for User ID }
GrpName : string; { Group Name, for Group ID }
DevMajor : Integer; { Major Device ID }
DevMinor : Integer; { Minor Device ID }
{ Additional Types used for holding info. }
AccessTime : Int64; { Time of Last Access, in UnixTime }
ChangeTime : Int64; { Time of Last Status Change, in UnixTime }
ArchiveFormat: TAbTarHeaderFormat; { Type of Archive of this record }
StreamPosition: Int64; { Pointer to the top of the item in the file. }
Dirty : Boolean; { Indication if this record needs to have its headers CheckSum recalculated }
ItemReadOnly: Boolean; { Indication if this record is READ ONLY }
FileHeaderCount:Integer;{ Number of Headers in the Orginal TarHeaders in the File Stream }
end;
type
PTAbTarItem = ^TAbTarItem;
TAbTarItem = class(TAbArchiveItem)
private
{ The following private members are used for Stuffing FTarItem struct }
procedure ParseTarHeaders; { Error in header if }
procedure DetectHeaderFormat; { Helper to stuff HeaderFormat }
procedure GetFileNameFromHeaders; { Helper to pull name from Headers }
procedure GetLinkNameFromHeaders; { Helper to pull name from Headers }
function TestCheckSum: Boolean; { Helper to Calculate Checksum of a header. }
procedure DoGNUExistingLongNameLink(LinkFlag: AnsiChar; I: Integer; const Value: AnsiString);
procedure DoGNUNewLongNameLink(LinkFlag: AnsiChar; I: Integer; const Value: AnsiString);
protected {private}
PTarHeader: PAbTarHeaderRec;{ Points to FTarHeaderList.Items[FTarHeaderList.Count-1] }
FTarHeaderList: TList; { List of The Headers }
FTarHeaderTypeList: TList; { List of the Header Types }
FTarItem: TAbTarItemRec; { Data about current TAR Item }
protected
function GetDevMajor: Integer;
function GetDevMinor: Integer;
function GetGroupID: Integer;
function GetGroupName: string;
function GetLinkName: string;
function GetUserID: Integer;
function GetUserName: string;
function GetModTime: Int64;
function GetNumHeaders: Integer;
function GetMagic: string;
{ All Sets shall update the headers Or add headers as needed. }
procedure SetDevMajor(const Value: Integer);
procedure SetDevMinor(const Value: Integer);
procedure SetGroupID(const Value: Integer); { Extended Headers }
procedure SetGroupName(const Value: string); { Extended Headers }
procedure SetLinkFlag(Value: AnsiChar);
procedure SetLinkName(const Value: string); { Extended Headers }
procedure SetUserID(const Value: Integer); { Extended Headers }
procedure SetUserName(const Value: string); { Extended Headers }
procedure SetModTime(const Value: Int64);
Procedure SetMagic(const Value: string);
{ TODO: add support for Atime and Ctime here }
{ Overrides for Inherited Properties from type TAbArchiveItem }
function GetCompressedSize : Int64; override;
function GetExternalFileAttributes : LongWord; override;
function GetFileName : string; override;
function GetIsDirectory: Boolean; override;
function GetIsEncrypted : Boolean; override;
function GetLastModFileDate : Word; override;
function GetLastModFileTime : Word; override;
function GetLastModTimeAsDateTime: TDateTime; override;
function GetNativeFileAttributes : LongInt; override;
function GetUncompressedSize : Int64; override;
procedure SetCompressedSize(const Value : Int64); override; { Extended Headers }
procedure SetExternalFileAttributes( Value : LongWord ); override;
procedure SetFileName(const Value : string); override; { Extended Headers }
procedure SetIsEncrypted(Value : Boolean); override;
procedure SetLastModFileDate(const Value : Word); override; { Extended Headers }
procedure SetLastModFileTime(const Value : Word); override; { Extended Headers }
procedure SetLastModTimeAsDateTime(const Value: TDateTime); override;
procedure SetUncompressedSize(const Value : Int64); override; { Extended Headers }
procedure SaveTarHeaderToStream(AStream : TStream);
procedure LoadTarHeaderFromStream(AStream : TStream);
property Magic : string { Magic value }
read GetMagic write SetMagic;
public
{ property Name : STRING; Path & File name. Inherited from parent type TAbArchiveItem }
{ read GetFileName write SetFileName; overridden above}
property Mode : LongWord { File Permissions }
read GetExternalFileAttributes write SetExternalFileAttributes;
property UserID : Integer { User ID }
read GetUserID write SetUserID;
property GroupID : Integer { Group ID }
read GetGroupID write SetGroupID;
property ModTime : Int64
read GetModTime write SetModTime;
{ property UncompressedSize/CompressedSize(Size): Int64; File size (comp/uncomp) Inherited from parent type TAbArchiveItem }
{ read GetUncompressedSize, GetCompressedSize; overridden above }
{ write SetUncompressedSize, SetCompressedSize; overridden above }
{ property LastModFileTime/LastModFileDate(ModeTime): TDateTime; Last time of Modification Inherited from parent type TAbArchiveItem }
{ read GetLastModFileTime, GetLastModFileDate; overridden above }
{ write SetLastModFileTime, SetLastModFileDate; overridden above }
property CheckSumGood: Boolean
read FTarItem.ChkSumPass; { Header Check sum found to be good }
property LinkFlag : AnsiChar { Link Flag of File Header }
read FTarItem.LinkFlag write SetLinkFlag;
property LinkName : string { Link Name }
read GetLinkName write SetLinkName;
property UserName : string { User Name, for User ID }
read GetUserName write SetUserName;
property GroupName : string { Group Name, for Group ID }
read GetGroupName write SetGroupName;
property DevMajor : Integer { Major Device ID }
read GetDevMajor write SetDevMajor;
property DevMinor : Integer { Minor Device ID }
read GetDevMinor write SetDevMinor;
{ TODO: Add support ATime and CTime }
{AccessTime : TDateTime;} { Time of Last Access }
{ChangeTime : TDateTime;} { Time of Last Status Change }
{ Additional Types used for holding info. }
property ExternalFileAttributes;
property ArchiveFormat: TAbTarHeaderFormat
read FTarItem.ArchiveFormat write FTarItem.ArchiveFormat;
property ItemType: TAbTarItemType
read FTarItem.ItemType write FTarItem.ItemType;
property ItemReadOnly: Boolean
read FTarItem.ItemReadOnly write FTarItem.ItemReadOnly;
property FileHeaderCount: Integer
read FTarItem.FileHeaderCount;
property HeaderCount: Integer
read GetNumHeaders;
property StreamPosition: Int64
read FTarItem.StreamPosition write FTarItem.StreamPosition;
constructor Create;
destructor Destroy; override;
end; { end TAbArchiveItem }
TAbTarStreamHelper = class(TAbArchiveStreamHelper)
private
function FindItem: Boolean; { Tool for FindFirst/NextItem functions }
protected
FTarHeader : TAbTarHeaderRec; { Speed-up Buffer only }
FCurrItemSize : Int64; { Current Item size }
FCurrItemPreHdrs: Integer; { Number of Meta-data Headers before the Item }
public
destructor Destroy; override;
procedure ExtractItemData(AStream : TStream); override;
function FindFirstItem : Boolean; override;
function FindNextItem : Boolean; override;
procedure ReadHeader; override;
procedure ReadTail; override;
function SeekItem(Index : Integer): Boolean; override;
procedure WriteArchiveHeader; override;
procedure WriteArchiveItem(AStream : TStream); override;
procedure WriteArchiveItemSize(AStream : TStream; Size: Int64);
procedure WriteArchiveTail; override;
function GetItemCount : Integer; override;
end;
TAbTarArchive = class(TAbArchive)
private
FArchReadOnly : Boolean;
FArchFormat: TAbTarHeaderFormat;
protected
function CreateItem(const FileSpec : string): TAbArchiveItem;
override;
procedure ExtractItemAt(Index : Integer; const UseName : string);
override;
procedure ExtractItemToStreamAt(Index : Integer; aStream : TStream);
override;
procedure LoadArchive;
override;
procedure SaveArchive;
override;
procedure TestItemAt(Index : Integer);
override;
function FixName(const Value: string): string;
override;
function GetSupportsEmptyFolders: Boolean;
override;
function GetItem(Index: Integer): TAbTarItem;
procedure PutItem(Index: Integer; const Value: TAbTarItem);
public {methods}
constructor CreateFromStream(aStream : TStream; const aArchiveName : string);
override;
property UnsupportedTypesDetected : Boolean
read FArchReadOnly;
property Items[Index : Integer] : TAbTarItem
read GetItem
write PutItem; default;
end;
function VerifyTar(Strm : TStream) : TAbArchiveType;
implementation
uses
{$IFDEF MSWINDOWS}
Windows, // Fix inline warnings
{$ENDIF MSWINDOWS}
Math, RTLConsts, SysUtils,
{$IFDEF HasAnsiStrings}AnsiStrings, {$ENDIF}
AbCharset, AbVMStrm, AbExcept;
{ ****************** Helper functions Not from Classes Above ***************** }
function OctalToInt(const Oct : PAnsiChar; aLen : integer): Int64;
var
i : integer;
begin
Result := 0;
i := 0;
while (i < aLen) and (Oct[i] = ' ') do
inc(i);
if (i = aLen) then
Exit;
while (i < aLen) and (Oct[i] in ['0'..'7']) do begin
Result := (Result * 8) + (Ord(Oct[i]) - Ord('0'));
inc(i);
end;
end;
function IntToOctal(Value : Int64): AnsiString;
const
OctDigits : array[0..7] of AnsiChar = '01234567';
begin
if Value = 0 then
Result := '0'
else begin
Result := '';
while Value > 0 do begin
Result := OctDigits[Value and 7] + Result;
Value := Value shr 3;
end;
end;
end;
function CalcTarHeaderChkSum(const TarH : TAbTarHeaderRec): LongInt;
var
HdrBuffer : PAnsiChar;
HdrChkSum : LongInt;
j : Integer;
begin
{ prepare for the checksum calculation }
HdrBuffer := PAnsiChar(@TarH);
HdrChkSum := 0;
{calculate the checksum, a simple sum of the bytes in the header}
for j := 0 to Pred(SizeOf(TAbTarHeaderRec)) do
HdrChkSum := HdrChkSum + Ord(HdrBuffer[j]);
Result := HdrChkSum;
end;
function VerifyTar(Strm : TStream) : TAbArchiveType;
{ assumes Tar positioned correctly for test of item }
var
TarItem : TAbTarItem;
StartPos : Int64;
begin
StartPos := Strm.Position;
try
{ Verifies that the header checksum is valid, and Item type is understood.
This does not mean that extraction is supported. }
TarItem := TAbTarItem.Create;
try
{ get current Tar Header }
TarItem.LoadTarHeaderFromStream(Strm);
if TarItem.CheckSumGood then
Result := atTar
else
Result := atUnknown;
finally
TarItem.Free;
end;
except
on EReadError do
Result := atUnknown;
end;
Strm.Position := StartPos;
end;
function PadString(const S : AnsiString; Places : Integer) : AnsiString;
{
Pads a string (S) with one right space and as many left spaces as
needed to fill Places
If length S greater than Places, just returns S
Some TAR utilities evidently expect Octal numeric fields to be in
this format
}
begin
if Length(S) >= LongInt(Places) then
Result := S
else begin
Result := S + ' ';
Result := StringOfChar(AnsiChar(' '), Places - Length(Result)) + Result;
end;
end;
{ Round UP to the nearest Tar Block Boundary. }
function RoundToTarBlock(Size: Int64) : Int64;
begin
Result := (Size + (AB_TAR_RECORDSIZE - 1)) and
not (AB_TAR_RECORDSIZE - 1);
end;
{ ****************************** TAbTarItem ********************************** }
constructor TAbTarItem.Create;
begin
inherited Create;
FTarHeaderList := TList.Create;
FTarHeaderTypeList := TList.Create;
GetMem(PTarHeader, AB_TAR_RECORDSIZE); { PTarHeader is our new Header }
FillChar(PTarHeader^, AB_TAR_RECORDSIZE, #0);
FTarHeaderList.Add(PTarHeader);
FTarHeaderTypeList.Add(Pointer(FILE_HEADER));
FTarItem.FileHeaderCount := 1;
{ set defaults }
FTarItem.ArchiveFormat := UNKNOWN_FORMAT;
FileName := '';
Mode := AB_FPERMISSION_GENERIC;
UserID := 0;
GroupID := 0;
UncompressedSize := 0;
{ ModTime }
LinkFlag := AB_TAR_LF_OLDNORMAL;
{ Link Name }
PTarHeader.Magic.gnuOld := AB_TAR_MAGIC_V7_NONE; { Default to GNU type }
UserName := '';
GroupName := '';
DevMajor := 0;
DevMinor := 0;
{ TODO: atime, ctime }
FTarItem.ItemType := SUPPORTED_ITEM;
FTarItem.Dirty := True; { Checksum needs to be generated }
FTarItem.ItemReadOnly := False;
end;
destructor TAbTarItem.Destroy;
var
i : Integer;
begin
if Assigned(FTarHeaderList) then
begin
for i := 0 to FTarHeaderList.Count - 1 do
FreeMem(FTarHeaderList.Items[i]); { This list holds PAbTarHeaderRec's }
FTarHeaderList.Free;
end;
FTarHeaderTypeList.Free;
inherited Destroy;
end;
function TAbTarItem.GetCompressedSize: Int64;
{ TAR includes no internal compression, returns same value as GetUncompressedSize }
begin
Result := FTarItem.Size;
end;
function TAbTarItem.GetDevMajor: Integer;
begin
Result := FTarItem.DevMajor;
end;
function TAbTarItem.GetDevMinor: Integer;
begin
Result := FTarItem.DevMinor;
end;
function TAbTarItem.GetExternalFileAttributes: LongWord;
begin
Result := FTarItem.Mode;
end;
function TAbTarItem.GetFileName: string;
begin
Result := FTarItem.Name; { Inherited String from Parent Class }
end;
function TAbTarItem.GetGroupID: Integer;
begin
Result := FTarItem.gid;
end;
function TAbTarItem.GetGroupName: string;
begin
Result := FTarItem.GrpName;
end;
function TAbTarItem.GetIsDirectory: Boolean;
begin
Result := (LinkFlag = AB_TAR_LF_DIR);
end;
function TAbTarItem.GetIsEncrypted: Boolean;
begin
{ TAR has no native encryption }
Result := False;
end;
function TAbTarItem.GetLastModFileDate: Word;
begin
{ convert to local DOS file Date }
Result := LongRec(AbDateTimeToDosFileDate(LastModTimeAsDateTime)).Hi;
end;
function TAbTarItem.GetLastModFileTime: Word;
begin
{ convert to local DOS file Time }
Result := LongRec(AbDateTimeToDosFileDate(LastModTimeAsDateTime)).Lo;
end;
function TAbTarItem.GetLastModTimeAsDateTime: TDateTime;
begin
Result := AbUnixTimeToLocalDateTime(FTarItem.ModTime);
end;
function TAbTarItem.GetLinkName: string;
begin
Result := FTarItem.LinkName;
end;
function TAbTarItem.GetMagic: string;
begin
Result := string(FTarItem.Magic);
end;
function TAbTarItem.GetNativeFileAttributes : LongInt;
begin
Result := GetExternalFileAttributes;
{$IFDEF MSWINDOWS}
Result := AbUnix2DosFileAttributes(Result);
{$ENDIF}
end;
function TAbTarItem.GetUncompressedSize: Int64;
{ TAR includes no internal compression, returns same value as GetCompressedSize }
begin
Result := FTarItem.Size;
end;
function TAbTarItem.GetUserID: Integer;
begin
Result := FTarItem.uid;
end;
function TAbTarItem.GetUserName: string;
begin
Result := FTarItem.UsrName;
end;
function TAbTarItem.GetModTime: Int64;
begin
Result := FTarItem.ModTime;
end;
{ Get Number of tar headers currently for this item }
function TAbTarItem.GetNumHeaders: Integer;
begin
Result := FTarHeaderList.Count;
end;
{ Takes data from Supported Header types stored in TAbTarItem.FTarHeaderList }
{ and updates values in the TAbTarItem.FTarItem.X }
procedure TAbTarItem.DetectHeaderFormat;
begin
if FTarItem.ArchiveFormat <> UNKNOWN_FORMAT then
Exit;{ We have already set the format. }
{ In the previous header parsing if pax headers are detected the format is changed }
{ GNU_FORMAT is detected by the presence of GNU extended headers. }
{ These detections are similar to GNU tar's. }
if (PTarHeader.Magic.value = AB_TAR_MAGIC_VAL) then
begin { We have one of three types, STAR_FORMAT, USTAR_FORMAT, POSIX_FORMAT }
{ Detect STAR format. Leave disabled until explicit STAR support is added. }
{if (PTarHeader.star.Prefix[130] = #00) and
(PTarHeader.star.Atime[0] in ['0'..'7']) and
(PTarHeader.star.Atime[11] = #20) and
(PTarHeader.star.Ctime[0]in ['0'..'7']) and
(PTarHeader.star.Ctime[11] = #20) then
begin
FTarItme.ArchiveType := STAR_FORMAT;
end }
{ else if } { POSIX uses the existance of x headers }
{ This can define false positives, Pax headers/ STAR format could be detected as this }
FTarItem.ArchiveFormat := USTAR_FORMAT;
end
else if (PTarHeader.Magic.gnuOld = AB_TAR_MAGIC_GNUOLD) then
begin
FTarItem.ArchiveFormat := OLDGNU_FORMAT;
end
else { V7 uses AB_TAR_LF_OLDNORMAL linkflag, has no magic field & no Usr/Grp Names }
begin
FTarItem.ArchiveFormat := V7_FORMAT; { Lowest Common Denominator }
end;
end;
{ Extract the file name from the headers }
procedure TAbTarItem.GetFileNameFromHeaders;
var
I, J : Integer;
PHeader: PAbTarHeaderRec;
FoundName: Boolean;
NameLength : Int64;
NumMHeaders: integer;
ExtraName: integer;
RawFileName, TempStr: AnsiString;
begin
{ UNKNOWN_FORMAT, V7_FORMAT, OLDGNU_FORMAT, GNU_FORMAT, USTAR_FORMAT, STAR_FORMAT, POSIX_FORMAT }
FoundName := False;
I := 0;
while (not FoundName) and (I <= (FTarHeaderList.Count - 1)) do
begin
PHeader := FTarHeaderList.Items[I];
if PHeader.LinkFlag = AB_TAR_LF_LONGNAME then
begin
FoundName := True;
RawFileName := '';
NameLength := OctalToInt(PHeader.Size, SizeOf(PHeader.Size));
NumMHeaders := NameLength div AB_TAR_RECORDSIZE;
ExtraName := NameLength mod AB_TAR_RECORDSIZE; { Chars in the last Header }
{ NumMHeaders should never be zero }
{ It appears that it is not null terminated in the blocks }
for J := 1 to NumMHeaders do
begin
{ Copy entire content of Header to String }
PHeader := FTarHeaderList.Items[I+J];
SetString(TempStr, PAnsiChar(PHeader), AB_TAR_RECORDSIZE);
RawFileName := RawFileName + TempStr;
end;
if ExtraName <> 0 then
begin
PHeader := FTarHeaderList.Items[I+NumMHeaders+1];
SetString(TempStr, PAnsiChar(PHeader), ExtraName-1);
RawFileName := RawFileName + TempStr;
end
else { We already copied the entire name, but the string is still null terminated. }
begin
{ Removed the last zero }
SetLength(RawFileName, (Length(RawFileName)-1));
end;
end { end long filename link flag }
else
I := I + 1;
end; { End While }
if not FoundName then
begin
if (FTarItem.ArchiveFormat = USTAR_FORMAT) and
(PTarHeader.ustar.Prefix[0] <> #0) then
RawFileName := PTarHeader.ustar.Prefix+'/'+PTarHeader.Name
else
{ V7_FORMAT, OLDGNU_FORMAT }
RawFileName := PTarHeader.Name;
end; { End not FoundName }
FTarItem.Name := AbRawBytesToString(RawFileName);
end;
{ Extract the file name from the headers }
procedure TAbTarItem.GetLinkNameFromHeaders;
var
I, J : Integer;
PHeader: PAbTarHeaderRec;
FoundName: Boolean;
NameLength : Int64;
NumMHeaders: integer;
ExtraName: integer;
RawLinkName, TempStr: AnsiString;
begin
{ UNKNOWN_FORMAT, V7_FORMAT, OLDGNU_FORMAT, GNU_FORMAT, USTAR_FORMAT, STAR_FORMAT, POSIX_FORMAT }
PHeader := nil;
FoundName := False;
I := 0;
{ Note that: FTarHeaderList.Count <= 1, always }
while (not FoundName) and (I <= (FTarHeaderList.Count - 1)) do
begin
PHeader := FTarHeaderList.Items[I];
if PHeader.LinkFlag = AB_TAR_LF_LONGLINK then
begin
FoundName := True;
RawLinkName := '';
NameLength := OctalToInt(PHeader.Size, SizeOf(PHeader.Size));
NumMHeaders := NameLength div AB_TAR_RECORDSIZE;
ExtraName := NameLength mod AB_TAR_RECORDSIZE; { Chars in the last Header }
{ NumMHeaders should never be zero }
{ It appears that it is not null terminated in the blocks }
for J := 1 to NumMHeaders do
begin
{ Copy entire content of Header to String }
PHeader := FTarHeaderList.Items[I+J];
SetString(TempStr, PAnsiChar(PHeader), AB_TAR_RECORDSIZE);
RawLinkName := RawLinkName + TempStr;
end;
if ExtraName <> 0 then
begin
PHeader := FTarHeaderList.Items[I+NumMHeaders+1];
SetString(TempStr, PAnsiChar(PHeader), ExtraName-1);
RawLinkName := RawLinkName + TempStr;
end
else { We already copied the entire name, but the string is still null terminated. }
begin
{ Removed the last zero }
SetLength(RawLinkName, (Length(RawLinkName)-1));
end;
end { end long filename link flag }
else
I := I + 1;
end; { End While }
if not FoundName then
RawLinkName := PHeader.LinkName;
FTarItem.LinkName := AbRawBytesToString(RawLinkName);
end;
{ Return True if CheckSum passes out. }
function TAbTarItem.TestCheckSum : Boolean;
var
TarChkSum : LongInt;
TarChkSumArr : Arr8; { ChkSum field is Arr8 }
PHeader: PAbTarHeaderRec;
I: Integer;
begin
Result := True;
{ Check sums are in valid headers but NOT in the data headers. }
for I := 0 to FTarHeaderList.Count - 1 do
begin
if TAbTarHeaderType(FTarHeaderTypeList.Items[I]) in [FILE_HEADER, META_DATA_HEADER] then
begin
PHeader := FTarHeaderList.Items[i];
{ Save off old Check sum }
Move(PHeader.ChkSum, TarChkSumArr, SizeOf(PHeader.ChkSum));
TarChkSum := OctalToInt(TarChkSumArr, SizeOf(TarChkSumArr));
{ Set to Generator Value }
PHeader.ChkSum := AB_TAR_CHKBLANKS;
if CalcTarHeaderChkSum(PHeader^) <> TarChkSum then
Result := False; { Pass unless one miss-compares }
{ Save back old checksum }
Move(TarChkSumArr, PHeader.ChkSum, SizeOf(TarChkSumArr));
end;
end;
end;
procedure TAbTarItem.ParseTarHeaders;
begin
{ The final index is the Item index }
DetectHeaderFormat;
{ Long term this parsing is not correct, as the values in extended headers
override the later values in this header }
FTarItem.Mode := OctalToInt(PTarHeader.Mode, SizeOf(PTarHeader.Mode));
FTarItem.uid := OctalToInt(PTarHeader.uid, SizeOf(PTarHeader.uid)); { Extended in PAX Headers }
FTarItem.gid := OctalToInt(PTarHeader.gid, SizeOf(PTarHeader.gid)); { Extended in PAX Headers }
FTarItem.Size := OctalToInt(PTarHeader.Size, SizeOf(PTarHeader.Size)); { Extended in PAX Headers }
{ ModTime should be an Int64 but no tool support, No issues until Feb 6th, 2106 :) }
{ ModTime is Extended in PAX Headers }
FTarItem.ModTime := OctalToInt(PTarHeader.ModTime, SizeOf(PTarHeader.ModTime));
FTarItem.ChkSumPass := TestCheckSum();
FTarItem.LinkFlag := PTarHeader.LinkFlag;
GetLinkNameFromHeaders; { Extended in PAX Headers }
FTarItem.Magic := PTarHeader.Magic.value;
FTarItem.Version := OctalToInt(PTarHeader.Magic.version, SizeOf(PTarHeader.Magic.version));
FTarItem.UsrName := string(PTarHeader.UsrName); { Extended in PAX Headers }
FTarItem.GrpName := string(PTarHeader.GrpName); { Extended in PAX Headers }
FTarItem.DevMajor := OctalToInt(PTarHeader.DevMajor, SizeOf(PTarHeader.DevMajor));
FTarItem.DevMinor := OctalToInt(PTarHeader.DevMinor, SizeOf(PTarHeader.DevMinor));
GetFileNameFromHeaders;
{ FTarItem.ArchiveFormat; Already stuffed }
{ FTarItem.StreamPosition: Already Stuffed }
{ FTarItem.Dirty; Stuffed upon creaction }
end;
procedure TAbTarItem.LoadTarHeaderFromStream(AStream: TStream);
var
NumMHeaders : Integer;
I : Integer;
FoundItem : Boolean;
begin
{ Note: The SizeOf(TAbTarHeaderRec) = AB_TAR_RECORDSIZE }
{ We should expect FindNext/FirstItem, and next check for bounds. }
if FTarHeaderList.Count > 0 then
begin { We're Going to stomp over the headers that are already present }
{ We need to destory the memory we've used }
PTarHeader := nil;
for i := 0 to FTarHeaderList.Count - 1 do
FreeMem(FTarHeaderList.Items[i]); { This list holds PAbTarHeaderRec's }
FTarHeaderList.Clear;
FTarHeaderTypeList.Clear;
FTarItem.FileHeaderCount := 0;
{ All pointers should now be removed from those headers }
end;
{ Now lets start filling up that list. }
FTarItem.ItemType := UNKNOWN_ITEM; { We don't know what we have yet }
FoundItem := False;
while not FoundItem do
begin
{ Create a Header to be Stored in the Items List }
GetMem(PTarHeader, AB_TAR_RECORDSIZE);
AStream.ReadBuffer(PTarHeader^, AB_TAR_RECORDSIZE);
FTarHeaderList.Add(PTarHeader); { Store the Header to the list }
{ Parse header based on LinkFlag }
if PTarHeader.LinkFlag in (AB_SUPPORTED_MD_HEADERS+AB_UNSUPPORTED_MD_HEADERS) then
begin { This Header type is in the Set of un/supported Meta data type headers }
if PTarHeader.LinkFlag in AB_UNSUPPORTED_MD_HEADERS then
FTarItem.ItemReadOnly := True; { We don't fully support this meta-data type }
if (PTarHeader.LinkFlag in AB_PAX_MD_HEADERS) and (PTarHeader.Magic.value = AB_TAR_MAGIC_VAL) then
FTarItem.ArchiveFormat := POSIX_FORMAT; { We have a POSIX_FORMAT, has x headers, and Magic matches }
if PTarHeader.LinkFlag in AB_GNU_MD_HEADERS then
FTarItem.ArchiveFormat := OLDGNU_FORMAT; { We have a OLDGNU_FORMAT, has L/K headers }
{ There can be a unknown number of Headers of data }
{ We are for sure going to read at least one more header, but are we going to read more than that? }
FTarHeaderTypeList.Add(Pointer(META_DATA_HEADER));
NumMHeaders := Ceil(OctalToInt(PTarHeader.Size, SizeOf(PTarHeader.Size)) / AB_TAR_RECORDSIZE);
{ NumMHeasder should never be zero }
for I := 1 to NumMHeaders do
begin
GetMem(PTarHeader, AB_TAR_RECORDSIZE); { Create a new Header }
AStream.ReadBuffer(PTarHeader^, AB_TAR_RECORDSIZE); { Get the Meta Data }
FTarHeaderList.Add(PTarHeader); { Store the Header to the list }
FTarHeaderTypeList.Add(Pointer(MD_DATA_HEADER));
end;
{ Loop and reparse }
end
else if PTarHeader.LinkFlag in AB_SUPPORTED_F_HEADERS then
begin { This Header type is in the Set of supported File type Headers }
FoundItem := True; { Exit Criterion }
FTarItem.ItemType := SUPPORTED_ITEM;
if FTarItem.ItemReadOnly then { Since some of the Headers are read only. }
FTarItem.ItemType := UNSUPPORTED_ITEM; { This Item is unsupported }
FTarHeaderTypeList.Add(Pointer(FILE_HEADER));
end
else if PTarHeader.LinkFlag in AB_UNSUPPORTED_F_HEADERS then
begin { This Header type is in the Set of unsupported File type Headers }
FoundItem := True; { Exit Criterion }
FTarItem.ItemType := UNSUPPORTED_ITEM;
FTarHeaderTypeList.Add(Pointer(FILE_HEADER));
end
else { These are unknown header types }
begin { Note: Some of these unknown types could have known Meta-data headers }
FoundItem := True;
FTarItem.ItemType := UNKNOWN_ITEM;
FTarHeaderTypeList.Add(Pointer(UNKNOWN_HEADER));
end;{ end LinkFlag parsing }
end; { end Found Item While }
{ PTarHeader points to FTarHeaderList.Items[FTarHeaderList.Count-1]; }
{ Re-wind the Stream back to the begining of this Item inc. all headers }
AStream.Seek(-(FTarHeaderList.Count*AB_TAR_RECORDSIZE), soCurrent);
{ AStream.Position := FTarItem.StreamPosition; } { This should be equivalent as above }
FTarItem.FileHeaderCount := FTarHeaderList.Count;
if FTarItem.ItemType <> UNKNOWN_ITEM then
begin
ParseTarHeaders; { Update FTarItem values }
FFileName := FTarItem.Name; {FTarHeader.Name;}
FDiskFileName := FileName;
AbUnfixName(FDiskFileName);
end;
Action := aaNone;
Tagged := False;
end;
{ ****************** BEGIN SET ********************** }
procedure TAbTarItem.SaveTarHeaderToStream(AStream: TStream);
var
i : Integer;
j : Integer;
PHeader : PAbTarHeaderRec;
HdrChkSum : Integer;
HdrChkStr : AnsiString;
HdrBuffer : PAnsiChar;
SkipNextChkSum: Integer;
SkipChkSum: Boolean;
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
{ Note: The SizeOf(TAbTarHeaderRec) = AB_TAR_RECORDSIZE }
if FTarItem.Dirty then
SkipNextChkSum := 0
else
SkipNextChkSum := FTarHeaderList.Count; { Don't recalc any chkSums }
{ The first header in the Item list must have a checksum calculation }
for i := 0 to (FTarHeaderList.Count-1) do
begin
SkipChkSum := False;
PHeader := FTarHeaderList.Items[i];
if (SkipNextChkSum = 0) then
begin { We need to parse this header }
if PHeader.LinkFlag in (AB_SUPPORTED_MD_HEADERS+AB_UNSUPPORTED_MD_HEADERS) then
begin { We have a Meta-Data Header, Calculate how many headers to skip. }
{ These meta-data headers have non-Header buffers after this Header }
SkipNextChkSum := Ceil(OctalToInt(PHeader.Size, SizeOf(PHeader.Size)) / AB_TAR_RECORDSIZE);
{ Ceil will mandate one run through, and will handle 512 correctly }
end
else if PHeader.LinkFlag in AB_SUPPORTED_F_HEADERS then
begin
SkipNextChkSum := 0;
end
else
begin { Un-Supported Header type, Copy but do nothing to the data }
SkipNextChkSum := 0;
SkipChkSum := True;
end;{ end LinkFlag parsing }
end
else
begin { Do not calcuate the check sum on this meta Data header buffer }
SkipNextChkSum := SkipNextChkSum - 1;
SkipChkSum := True;
end;{ end SkipNextChkSum }
if not SkipChkSum then
begin { We are Calculating the Checksum for this Header }
{Tar ChkSum is "odd" The check sum field is filled with #20 chars as empty }
{ ChkSum field itself is #20'd and has an effect on the sum }
PHeader.ChkSum := AB_TAR_CHKBLANKS;
{ Set up the buffers }
HdrBuffer := PAnsiChar(PHeader);
HdrChkSum := 0;
{ Calculate the checksum, a simple sum of the bytes in the header }
for j := 0 to (AB_TAR_RECORDSIZE-1) do
HdrChkSum := HdrChkSum + Ord(HdrBuffer[j]);
{ set the checksum in the header }
HdrChkStr := PadString(IntToOctal(HdrChkSum), SizeOf(PHeader.ChkSum));
Move(HdrChkStr[1], PHeader.ChkSum, Length(HdrChkStr));
end; { end Skip Check Sum }
{ write header to the file }
AStream.Write(PHeader^, AB_TAR_RECORDSIZE);
end; { End for the number of headers in the list }
{ Updated here as the stream is now updated to the latest number of headers }
FTarItem.FileHeaderCount := FTarHeaderList.Count;
end;
procedure TAbTarItem.SetCompressedSize(const Value: Int64);
var
S : AnsiString;
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
{ Size is extendable in PAX Headers, Remember PAX extended Header Over Rule File Headers }
FTarItem.Size := Value; { Store our Vitrual Copy }
S := PadString(IntToOctal(Value), SizeOf(Arr12));{ Stuff to header }
Move(S[1], PTarHeader.Size, Length(S));
FTarItem.Dirty := True;
end;
procedure TAbTarItem.SetDevMajor(const Value: Integer);
var
S : AnsiString;
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
{ Dev Major and Minor are Only used for AB_TAR_LF_CHR, AB_TAR_LF_BLK }
{ Otherwise they are stuffed with #00 }
FTarItem.DevMajor := Value; { Store to the struct }
S := PadString(IntToOctal(Value), SizeOf(Arr8));
Move(S[1], PTarHeader.DevMajor, Length(S));
FTarItem.Dirty := True;
end;
procedure TAbTarItem.SetDevMinor(const Value: Integer);
var
S : AnsiString;
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
{ Dev Major and Minor are Only used for AB_TAR_LF_CHR, AB_TAR_LF_BLK }
{ Otherwise they are stuffed with #00 }
FTarItem.DevMinor := Value;
S := PadString(IntToOctal(Value), SizeOf(Arr8));
Move(S[1], PTarHeader.DevMinor, Length(S));
FTarItem.Dirty := True;
end;
procedure TAbTarItem.SetExternalFileAttributes(Value: LongWord);
var
S : AnsiString;
I: Integer;
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
FTarItem.Mode := Value;
S := PadString(IntToOctal(Value), SizeOf(Arr8));
for I := 0 to FTarHeaderList.Count - 1 do
if TAbTarHeaderType(FTarHeaderTypeList.Items[I]) in [FILE_HEADER, META_DATA_HEADER] then
Move(S[1], PAbTarHeaderRec(FTarHeaderList.Items[I]).Mode, Length(S));
FTarItem.Dirty := True;
end;
{ Add/Remove Headers as needed To/From Existing GNU Long (Link/Name) TarItems }
procedure TAbTarItem.DoGNUExistingLongNameLink(LinkFlag: AnsiChar; I: Integer; const Value: AnsiString);
var
PHeader: PAbTarHeaderRec;
J: Integer;
OldNameLength: Integer;
TotalOldNumHeaders: Integer;
TotalNewNumHeaders: Integer;
NumHeaders: Integer;
ExtraName: Integer;
tempStr: AnsiString;
begin
PHeader := FTarHeaderList.Items[I];
{ Need this data from the old header }
OldNameLength := OctalToInt(PHeader.Size, SizeOf(PHeader.Size));{ inlcudes Null termination }
{ Length(FTarItem.Name)+1 = OldNameLength; }{ This should be true, always }
{ Save off the new Length, so we don't have to change the pointers later. }
tempStr := PadString(IntToOctal(Length(Value)+1), SizeOf(PHeader.Size));
Move(tempStr[1], PHeader.Size, Length(tempStr));
TotalOldNumHeaders := Ceil(OldNameLength / AB_TAR_RECORDSIZE);
TotalNewNumHeaders := Ceil((Length(Value)+1) / AB_TAR_RECORDSIZE);{ Null terminated }
{Length(Value)+1: 1-512 = 1, 513-1024 = 2 ... }
J := TotalOldNumHeaders - TotalNewNumHeaders;
while J <> 0 do
begin
if J > 0 then
begin { Old > New, Have to many Headers, Remove }
FreeMem(FTarHeaderList.Items[I+J]); { Free the Memory for the extra Header }
FTarHeaderList.Delete(I+J); { Delete the List index }
FTarHeaderTypeList.Delete(I+J);
J := J - 1;
end
else { if J < 0 then }
begin { Old < New, Need more Headers, Insert }
GetMem(PHeader, AB_TAR_RECORDSIZE);
FTarHeaderList.Insert(I+1,PHeader);{ Insert: Inserts at index }
FTarHeaderTypeList.Insert(I+1,Pointer(MD_DATA_HEADER));{ We are only adding MD Data headers here }
J := J + 1;
end;
end;{ end numHeaders while }
{ Yes, GNU Tar adds a Nil filled MD data header if Length(Value) mod AB_TAR_RECORDSIZE = 0 }
NumHeaders := (Length(Value)+1) div AB_TAR_RECORDSIZE; { Include Null terminator }
ExtraName := (Length(Value)+1) mod AB_TAR_RECORDSIZE; { Chars in the last Header }
{ Now we have the number of headers set up, stuff the name in the Headers }
TempStr := AnsiString(Value);
for J := 1 to NumHeaders do
begin
{ Copy entire next AB_TAR_RECORDSIZE bytes of tempString to content of Header }
{ There may only be AB_TAR_RECORDSIZE-1 bytes if this is the last rounded header }
PHeader := FTarHeaderList.Items[I+J];
Move(TempStr[1], PHeader^, AB_TAR_RECORDSIZE);
if Length(TempStr) >= AB_TAR_RECORDSIZE then
Delete(TempStr, 1, AB_TAR_RECORDSIZE);{ Crop string }
end;
if ExtraName <> 0 then
begin
{ Copy whatever is left in tempStr into the rest of the buffer }
PHeader := FTarHeaderList.Items[I+NumHeaders+1];
FillChar(PHeader^, AB_TAR_RECORDSIZE, #0); { Zero the whole block }
Move(TempStr[1], PHeader^, ExtraName-1); { The string is null terminated }
end
else { We already copied the entire name, but it must be null terminated }
begin
FillChar(Pointer(PtrInt(PHeader)+AB_TAR_RECORDSIZE-1)^, 1, #0); { Zero rest of the block }
end;
{ Finally we need to stuff the file type Header. }
{ Note: Value.length > AB_TAR_NAMESIZE(100) }
if LinkFlag = AB_TAR_LF_LONGNAME then
Move(Value[1], PTarHeader.Name, AB_TAR_NAMESIZE)
else
Move(Value[1], PTarHeader.LinkName, AB_TAR_NAMESIZE);
end;
{ Always inserts the L/K Headers at index 0+ }
procedure TAbTarItem.DoGNUNewLongNameLink(LinkFlag: AnsiChar; I: Integer; const Value: AnsiString);
var
PHeader: PAbTarHeaderRec;
J: Integer;
NumHeaders: Integer;
ExtraName: Integer;
tempStr: AnsiString;
begin
{ We have a GNU_FORMAT, and no L/K Headers.}
{ Add a new MD Header and MD Data Headers }
{ Make an L/K header }
GetMem(PHeader, AB_TAR_RECORDSIZE);
FTarHeaderList.Insert(I, PHeader);{ Insert: Inserts at base index }
FTarHeaderTypeList.Insert(I, Pointer( META_DATA_HEADER));{ This is the L/K Header }
FillChar(PHeader^, AB_TAR_RECORDSIZE, #0); { Zero the whole block }
AbStrPCopy(PHeader.Name, AB_TAR_L_HDR_NAME); { Stuff L/K String Name }
AbStrPCopy(PHeader.Mode, AB_TAR_L_HDR_ARR8_0); { Stuff zeros }
AbStrPCopy(PHeader.uid, AB_TAR_L_HDR_ARR8_0); { Stuff zeros }
AbStrPCopy(PHeader.gid, AB_TAR_L_HDR_ARR8_0); { Stuff zeros }
tempStr := PadString(IntToOctal(Length(Value)+1), SizeOf(PHeader.Size)); { Stuff Size }
Move(tempStr[1], PHeader.Size, Length(tempStr));
AbStrPCopy(PHeader.ModTime, AB_TAR_L_HDR_ARR12_0); { Stuff zeros }
{ Check sum will be calculated as the Dirty flag is in caller. }
PHeader.LinkFlag := LinkFlag; { Stuff Link FlagSize }
AbStrPCopy(PHeader.Magic.gnuOld, AB_TAR_MAGIC_GNUOLD); { Stuff the magic }
AbStrPCopy(PHeader.UsrName, AB_TAR_L_HDR_USR_NAME);
AbStrPCopy(PHeader.GrpName, AB_TAR_L_HDR_GRP_NAME);
{ All else stays as Zeros. }
{ Completed with L/K Header }
{ OK, now we need to add the proper number of MD Data Headers, and intialize to new name }
{ Yes, GNU Tar adds an extra Nil filled MD data header if Length(Value) mod AB_TAR_RECORDSIZE = 0 }
NumHeaders := Ceil((Length(Value)+1) / AB_TAR_RECORDSIZE); { Include Null terminator }
ExtraName := (Length(Value)+1) mod AB_TAR_RECORDSIZE; { Chars in the last Header }
{ Now we have the number of headers set up, stuff the name in the Headers }
TempStr := AnsiString(Value);
for J := 1 to NumHeaders-1 do
begin
{ Make a buffer, and copy entire next AB_TAR_RECORDSIZE bytes of tempStr to content of Header }
{ There may only be AB_TAR_RECORDSIZE-1 bytes if this is the last rounded header }
GetMem(PHeader, AB_TAR_RECORDSIZE);
FTarHeaderList.Insert(J+I, PHeader);
FTarHeaderTypeList.Insert(J+I, Pointer(MD_DATA_HEADER));{ We are adding MD Data headers here }
Move(TempStr[1], PHeader^, AB_TAR_RECORDSIZE);
if Length(TempStr) >= AB_TAR_RECORDSIZE then
Delete(TempStr, 1, AB_TAR_RECORDSIZE);{ Crop string }
end;
if ExtraName <> 0 then
begin
{ Copy what ever is left in tempStr into the rest of the buffer }
{ Create the last MD Data Header }
GetMem(PHeader, AB_TAR_RECORDSIZE);
FTarHeaderList.Insert(I+NumHeaders, PHeader);{ Insert: Inserts at base index }
FTarHeaderTypeList.Insert(I+NumHeaders, Pointer(MD_DATA_HEADER));{ We are only adding MD Data headers here }
FillChar(PHeader^, AB_TAR_RECORDSIZE, #0); { Zero the whole block }
Move(TempStr[1], PHeader^, ExtraName-1); { The string is null terminated in the header }
end
else { We already copied the entire name, but it must be null terminated }
begin
FillChar(Pointer(PtrInt(PHeader)+AB_TAR_RECORDSIZE-1)^, 1, #0); { Zero rest of the block }
end;
{ Finally we need to stuff the file type Header. }
{ Note: Value.length > AB_TAR_NAMESIZE(100) }
if LinkFlag = AB_TAR_LF_LONGNAME then
Move(Value[1], PHeader.Name, AB_TAR_NAMESIZE)
else
Move(Value[1], PHeader.LinkName, AB_TAR_NAMESIZE);
end;
procedure TAbTarItem.SetFileName(const Value: string);
var
FoundMetaDataHeader: Boolean;
PHeader: PAbTarHeaderRec;
I, J: Integer;
TotalOldNumHeaders: Integer;
RawFileName: AnsiString;
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
{ Assume ItemReadOnly is set for all Unsupported Type. }
{ Cases:
New File Name is short, Length <= 100,
All formats: Zero Name field and move new name to field.
V7: Work complete, 1 header
USTAR: zero prefix field, 1 Header
OLD_GNU & GNU: Remove old name headers, 1 header.
STAR & PAX: And should not yet get here.
New File Name is Long, Length >=101
Note: The Header Parsing sets any V7 to GNU if 'L'/'K" Headers are present
V7: Raise an exception, as this can NOT be done, no change to header.
USTAR: if new length <= 254 zero fill header, update name fields, 1 updated Header
if new Length >= 255 raise an exception, as this can NOT be done, no change to header
if old was Short, Add files to match format,
OLD_GNU & GNU: Create new Name header, Add N Headers for name, Update name in file header, update name fields, min 3 headers
STAR & PAX: And should not yet get here.
if old was Long,
OLD_GNU & GNU: Add N Headers for name, Update name in MD header, update name field in File Headers, min 3 headers
Add headers to length of new Name Length, update name in file header, update name fields }
RawFileName := AbStringToUnixBytes(Value);
{ In all cases zero out the name fields in the File Header. }
if Length(RawFileName) > AB_TAR_NAMESIZE then begin { Must be null terminated except at 100 char length }
{ Look for long name meta-data headers already in the archive. }
FoundMetaDataHeader := False;
I := 0;
{ FTarHeaderList.Count <= 1 always }
while (not FoundMetaDataHeader) and (I <= (FTarHeaderList.Count - 1)) do begin
PHeader := FTarHeaderList.Items[I];
if PHeader.LinkFlag = AB_TAR_LF_LONGNAME then begin
{ We are growing or Shriking the Name MD Data fields. }
FoundMetaDataHeader := True;
DoGNUExistingLongNameLink(AB_TAR_LF_LONGNAME, I, RawFileName);
{ Need to copy the Name to the header. }
FTarItem.Name := Value;
end
else
I := I + 1;
end; { End While }
{ MD Headers & MD Data Headers have been stuffed if FoundMetaDataHeader }
{ Still need to stuff the File type header contents. }
if not FoundMetaDataHeader then
begin
case FTarItem.ArchiveFormat of
V7_FORMAT: raise EAbTarBadFileName.Create; { File Name to Long }
USTAR_FORMAT:
begin
{ Longest file name is AB_TAR_NAMESIZE(100) chars }
{ Longest Prefix is AB_TAR_USTAR_PREFIX_SIZE(155) chars }
{ These two fields are delimted by a '/' char }
{0123456789012345, Length = 15, NameLength = 5, PrefixLength = 9}
{ AAAA/BBBB/C.txt, Stored as Name := 'C.txt', Prefix := 'AAAA/BBBB' }
{ That means Theoretical maximum is 256 for Length(RawFileName) }
if Length(RawFileName) > (AB_TAR_NAMESIZE+AB_TAR_USTAR_PREFIX_SIZE+1) then { Check the obvious one. }
raise EAbTarBadFileName.Create; { File Name to Long }
for I := Length(RawFileName) downto Length(RawFileName)-AB_TAR_NAMESIZE-1 do begin
if RawFileName[I] = '/' then begin
if (I <= AB_TAR_USTAR_PREFIX_SIZE+1) and (Length(RawFileName)-I <= AB_TAR_NAMESIZE) then begin
{ We have a successfull parse. }
FillChar(PTarHeader.Name, SizeOf(PTarHeader.Name), #0);
FillChar(PTarHeader.ustar.Prefix, SizeOf(PTarHeader.ustar.Prefix), #0);
Move(RawFileName[I+1], PTarHeader.Name, Length(RawFileName)-I);
Move(RawFileName[1], PTarHeader.ustar.Prefix, I);
break;
end
else if (Length(RawFileName)-I > AB_TAR_NAMESIZE) then
raise EAbTarBadFileName.Create { File Name not splittable }
{ else continue; }
end;
end;{ End for I... }
end; { End USTAR Format }
OLDGNU_FORMAT: DoGNUNewLongNameLink(AB_TAR_LF_LONGNAME, 0, RawFileName); {GNU_FORMAT}
else begin
{ UNKNOWN_FORMAT, STAR_FORMAT, POSIX_FORMAT }
raise EAbTarBadOp.Create; { Unknown Archive Format }
end;{ End of Else for case statement }
end;{ End of case statement }
FTarItem.Name := Value;
end; { if no Meta data header found }
end { End "name length larger than 100" }
else
begin { Short new name, Simple Case Just put it in the Name Field & remove any headers }
{ PTarHeader Points to the File type Header }
{ Zero the Name field }
FillChar(PTarHeader.Name, SizeOf(PTarHeader.Name), #0);
if FTarItem.ArchiveFormat in [USTAR_FORMAT] then { Zero the prefix field }
FillChar(PTarHeader.ustar.Prefix, SizeOf(PTarHeader.ustar.Prefix), #0);
if FTarItem.ArchiveFormat in [GNU_FORMAT, OLDGNU_FORMAT] then
begin { We may have AB_TAR_LF_LONGNAME Headers to be removed }
{ Remove long file names Headers if they exist}
FoundMetaDataHeader := False;
I := 0;
while not FoundMetaDataHeader and (I <= (FTarHeaderList.Count - 1)) do
begin
PHeader := FTarHeaderList.Items[I];
if PHeader.LinkFlag in [AB_TAR_LF_LONGNAME] then
begin { Delete this Header, and the data Headers. }
FoundMetaDataHeader := True;
TotalOldNumHeaders := Ceil( OctalToInt(PHeader.Size, SizeOf(PHeader.Size)) / AB_TAR_RECORDSIZE);
for J := TotalOldNumHeaders downto 0 do
begin { Note 0 will delete the Long Link MD Header }
FreeMem(FTarHeaderList.Items[I+J]); { This list holds PAbTarHeaderRec's }
FTarHeaderList.Delete(I+J);
FTarHeaderTypeList.Delete(I+J);
end;
end
else
I := I + 1; { Got to next header }
end;{ End While not found... }
end; { End if GNU... }
{ Save off the new name and store to the Header }
FTarItem.Name := Value;
{ Must add Null Termination before we store to Header }
AbStrPLCopy(PTarHeader.Name, RawFileName, AB_TAR_NAMESIZE);
end;{ End else Short new name,... }
{ Update the inherited file names. }
FFileName := FTarItem.Name;
DiskFileName := FFileName;
AbUnfixName(FDiskFileName);
FTarItem.Dirty := True;
end;
procedure TAbTarItem.SetGroupID(const Value: Integer);
var
S : AnsiString;
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
{ gid is extendable in PAX Headers, Rember PAX extended Header Over Rule File Headers }
FTarItem.gid := Value;
S := PadString(IntToOctal(Value), SizeOf(Arr8));
Move(S[1], PTarHeader.gid, Length(S));
FTarItem.Dirty := True;
end;
procedure TAbTarItem.SetGroupName(const Value: string);
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
{ GrpName is extendable in PAX Headers, Rember PAX extended Header Over Rule File Headers }
FTarItem.GrpName := Value;
AbStrPLCopy(PTarHeader.GrpName, AnsiString(Value), SizeOf(PTarHeader.GrpName));
FTarItem.Dirty := True;
end;
procedure TAbTarItem.SetIsEncrypted(Value: Boolean);
begin
{ do nothing, TAR has no native encryption }
end;
procedure TAbTarItem.SetLastModFileDate(const Value: Word);
begin
{ replace date, keep existing time }
LastModTimeAsDateTime :=
EncodeDate(
Value shr 9 + 1980,
Value shr 5 and 15,
Value and 31) +
Frac(LastModTimeAsDateTime);
end;
procedure TAbTarItem.SetLastModFileTime(const Value: Word);
begin
{ keep current date, replace time }
LastModTimeAsDateTime :=
Trunc(LastModTimeAsDateTime) +
EncodeTime(
Value shr 11,
Value shr 5 and 63,
Value and 31 shl 1, 0);
end;
procedure TAbTarItem.SetLastModTimeAsDateTime(const Value: TDateTime);
begin
// TAR stores always Unix time.
SetModTime(AbLocalDateTimeToUnixTime(Value)); // also updates headers
end;
procedure TAbTarItem.SetLinkFlag(Value: AnsiChar);
begin
if FTarItem.ItemReadOnly then
Exit;
FTarItem.LinkFlag := Value;
PTarHeader.LinkFlag := Value;
FTarItem.Dirty := True;
end;
procedure TAbTarItem.SetLinkName(const Value: string);
var
FoundMetaDataHeader: Boolean;
PHeader: PAbTarHeaderRec;
I, J: Integer;
TotalOldNumHeaders: Integer;
RawLinkName: AnsiString;
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
{ Cases:
New Link Name is short, Length <= 100,
All formats: Zero Name field and move new name to field.
V7: Work complete, 1 header
USTAR: Work complete, 1 Header
OLD_GNU & GNU: Remove old link headers, 1 header.
STAR & PAX: And should not yet get here.
New File Name is Long, Length >=101
Note: The Header Parsing sets any V7 to GNU if 'L'/'K' Headers are present
V7: Raise an exception, as this can NOT be done, no change to header.
USTAR: Raise an exception, as this can NOT be done, no change to header.
if old was Short, Add files to match format,
OLD_GNU & GNU: Create new Link header, Add N Headers for name, Update name in file header, update name fields, min 3 headers
if old was Long,
OLD_GNU & GNU: Add N Headers for name, Update name in MD header, update name field in File Headers, min 3 headers
STAR & PAX: And should not yet get here.}
RawLinkName := AbStringToUnixBytes(Value);
if Length(RawLinkName) > AB_TAR_NAMESIZE then { Must be null terminated except at 100 char length }
begin
{ Look for long name meta-data headers already in the archive. }
FoundMetaDataHeader := False;
I := 0;
{ FTarHeaderList.Count <= 1 always }
while (not FoundMetaDataHeader) and (I <= (FTarHeaderList.Count - 1)) do begin
PHeader := FTarHeaderList.Items[I];
if PHeader.LinkFlag = AB_TAR_LF_LONGLINK then
begin { We are growing or Shriking the Name MD Data fields. }
FoundMetaDataHeader := True;
DoGNUExistingLongNameLink(AB_TAR_LF_LONGLINK, I, RawLinkName);
{ Need to copy the Name to the header. }
FTarItem.LinkName := Value;
end
else
I := I + 1;
end; { End While }
{ MD Headers & MD Data Headers have been stuffed if FoundMetaDataHeader }
{ Still need to stuff the File type header contents. }
if not FoundMetaDataHeader then
begin
case FTarItem.ArchiveFormat of
V7_FORMAT: raise EAbTarBadLinkName.Create; { Link Name to Long }
USTAR_FORMAT: raise EAbTarBadLinkName.Create; { Link Name to Long }
OLDGNU_FORMAT: DoGNUNewLongNameLink(AB_TAR_LF_LONGLINK, 0, RawLinkName); {GNU_FORMAT}
else
begin
{ UNKNOWN_FORMAT, STAR_FORMAT, POSIX_FORMAT }
raise EAbTarBadOp.Create; { Unknown Archive Format }
end;{ End of Else for case statement }
end;{ End of case statement }
FTarItem.LinkName := Value;
end; { if no Meta data header found }
end { End "name length larger than 100" }
else
begin { Short new name, Simple Case Just put it in the Link Field & remove any headers }
{ PTarHeader Points to the File type Header }
{ Zero the Link field }
FillChar(PTarHeader.LinkName, SizeOf(PTarHeader.LinkName), #0);
if FTarItem.ArchiveFormat in [GNU_FORMAT, OLDGNU_FORMAT] then
begin { We may have AB_TAR_LF_LONGNAME Headers to be removed }
{ Remove long file names Headers if they exist}
FoundMetaDataHeader := False;
I := 0;
while not FoundMetaDataHeader and (I <= (FTarHeaderList.Count - 1)) do
begin
PHeader := FTarHeaderList.Items[I];
if PHeader.LinkFlag in [AB_TAR_LF_LONGLINK] then
begin { Delete this Header, and the data Headers. }
FoundMetaDataHeader := True;
TotalOldNumHeaders := Ceil( OctalToInt(PHeader.Size, SizeOf(PHeader.Size)) / AB_TAR_RECORDSIZE);
for J := TotalOldNumHeaders downto 0 do
begin { Note 0 will delete the Long Link MD Header }
FreeMem(FTarHeaderList.Items[I+J]); { This list holds PAbTarHeaderRec's }
FTarHeaderList.Delete(I+J);
FTarHeaderTypeList.Delete(I+J);
end;
end
else
I := I + 1; { Got to next header }
end;{ End While not found... }
end; { End if GNU... }
{ Save off the new name and store to the Header }
FTarItem.LinkName := Value;
AbStrPLCopy(PTarHeader.LinkName, RawLinkName, AB_TAR_NAMESIZE);
end;{ End else Short new name,... }
FTarItem.Dirty := True;
end;
procedure TAbTarItem.SetMagic(const Value: String);
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
FTarItem.Magic := AnsiString(Value);
Move(Value[1], PTarHeader.Magic, SizeOf(TAbTarMagicRec));
FTarItem.Dirty := True;
end;
procedure TAbTarItem.SetUncompressedSize(const Value: Int64);
var
S : AnsiString;
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
{ Size is extendable in PAX Headers, Remember PAX extended Header Over Rule File Headers }
FTarItem.Size := Value; { Store our Vitrual Copy }
S := PadString(IntToOctal(Value), SizeOf(Arr12));{ Stuff to header }
Move(S[1], PTarHeader.Size, Length(S));
FTarItem.Dirty := True;
end;
procedure TAbTarItem.SetUserID(const Value: Integer);
var
S : AnsiString;
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
{ uid is extendable in PAX Headers, Remember PAX extended Header Over Rule File Headers }
FTarItem.uid := Value;
S := PadString(IntToOctal(Value), SizeOf(Arr8));
Move(S[1], PTarHeader.uid, Length(S));
FTarItem.Dirty := True;
end;
procedure TAbTarItem.SetUserName(const Value: string);
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
{ UsrName is extendable in PAX Headers, Remember PAX extended Header Over Rule File Headers }
FTarItem.UsrName := Value;
AbStrPLCopy(PTarHeader.UsrName, AnsiString(Value), SizeOf(PTarHeader.UsrName));
FTarItem.Dirty := True;
end;
procedure TAbTarItem.SetModTime(const Value: Int64);
var
S: AnsiString;
begin
if FTarItem.ItemReadOnly then { Read Only - Do Not Save }
Exit;
{ ModTime is extendable in PAX Headers, Remember PAX extended Header Over Rule File Headers }
FTarItem.ModTime := Value; { Store our Virtual Copy }
S := PadString(IntToOctal(Value), SizeOf(Arr12));{ Stuff to header }
Move(S[1], PTarHeader.ModTime, Length(S));
FTarItem.Dirty := True;
end;
{ ************************** TAbTarStreamHelper ****************************** }
destructor TAbTarStreamHelper.Destroy;
begin
inherited Destroy;
end;
{ This is slow, use the archive class instead }
procedure TAbTarStreamHelper.ExtractItemData(AStream: TStream);
begin
{ Note: The SizeOf(TAbTarHeaderRec) = AB_TAR_RECORDSIZE }
if FCurrItemSize <> 0 then
begin
{ copy stored data to output }
AStream.CopyFrom(FStream, FCurrItemSize);
{reset the stream to the start of the item}
FStream.Seek(-(FCurrItemPreHdrs*AB_TAR_RECORDSIZE+FCurrItemSize), soCurrent);
end;
{ else do nothing }
end;
{ This function Should only be used from LoadArchive, as it is slow. }
function TAbTarStreamHelper.FindItem: Boolean;
var
DataRead : LongInt;
FoundItem: Boolean;
SkipHdrs : Integer;
begin
{ Note: The SizeOf(TAbTarHeaderRec) = AB_TAR_RECORDSIZE }
{ Note: Standard LBA size of hard disks is 512 bytes = AB_TAR_RECORDSIZE }
FoundItem := False;
{ Getting an new Item reset these numbers }
FCurrItemSize := 0;
FCurrItemPreHdrs := 0;
DataRead := FStream.Read(FTarHeader, AB_TAR_RECORDSIZE); { Read in a header }
{ DataRead <> AB_TAR_RECORDSIZE means end of stream, and the End Of Archive
record is all #0's, which the StrLen(FTarHeader.Name) check will catch }
while (DataRead = AB_TAR_RECORDSIZE) and (AbStrLen(FTarHeader.Name) > 0) and not FoundItem do
begin { Either exit when we find a supported file or end of file or an invalid header name. }
if FTarHeader.LinkFlag in (AB_SUPPORTED_MD_HEADERS+AB_UNSUPPORTED_MD_HEADERS) then
begin { We have a un/supported Meta-Data Header }
{ FoundItem := False } { Value remains False. }
SkipHdrs := Ceil(OctalToInt(FTarHeader.Size, SizeOf(FTarHeader.Size))/AB_TAR_RECORDSIZE);
FStream.Seek(SkipHdrs*AB_TAR_RECORDSIZE, soCurrent);
{ Tally new Headers: Consumed + Current }
FCurrItemPreHdrs := FCurrItemPreHdrs + SkipHdrs + 1;
{ Read our next header, Loop, and re-parse }
DataRead := FStream.Read(FTarHeader, AB_TAR_RECORDSIZE);
end
else if FTarHeader.LinkFlag in (AB_SUPPORTED_F_HEADERS+AB_UNSUPPORTED_F_HEADERS) then
begin { We have a un/supported File Header. }
FoundItem := True;
if not (FTarHeader.LinkFlag in AB_IGNORE_SIZE_HEADERS) then
FCurrItemSize := OctalToInt(FTarHeader.Size, SizeOf(FTarHeader.Size))
else FCurrItemSize := 0; { Per The spec these Headers do not have file content }
FCurrItemPreHdrs := FCurrItemPreHdrs + 1; { Tally current header }
end
else
begin{ We Have an Unknown header }
FoundItem := True;
FCurrItemSize := 0;
{ We could have many un/supported headers before this unknown type }
FCurrItemPreHdrs := FCurrItemPreHdrs + 1; { Tally current header }
{ These Headers should throw exceptions when TAbTarItem.LoadTarHeaderFromStream is called }
end; { End of Link Flag parsing }
end;
{ Rewind to the "The Beginning" of this Item }
{ Really that means to the first supported Header Type before a supported Item Type }
if FoundItem then
FStream.Seek(-(FCurrItemPreHdrs*AB_TAR_RECORDSIZE), soCurrent);
Result := FoundItem;
end;
{ Should only be used from LoadArchive, as it is slow. }
function TAbTarStreamHelper.FindFirstItem: Boolean;
begin
FStream.Seek(0, soBeginning);
Result := FindItem;
end;
{ Should only be used from LoadArchive, as it is slow. }
function TAbTarStreamHelper.FindNextItem: Boolean;
begin
{ Fast Forward Past the current Item }
FStream.Seek((FCurrItemPreHdrs*AB_TAR_RECORDSIZE + RoundToTarBlock(FCurrItemSize)), soCurrent);
Result := FindItem;
end;
{ This is slow, use the archive class instead }
function TAbTarStreamHelper.GetItemCount : Integer;
var
Found : Boolean;
begin
Result := 0;
Found := FindFirstItem;
while Found do begin
Inc(Result);
Found := FindNextItem;
end;
end;
procedure TAbTarStreamHelper.ReadHeader;
begin
{ do nothing }
{ Tar archives have no overall header data }
end;
procedure TAbTarStreamHelper.ReadTail;
begin
{ do nothing }
{ Tar archives have no overall tail data }
end;
{ This is slow, use the archive class instead }
function TAbTarStreamHelper.SeekItem(Index: Integer): Boolean;
var
i : Integer;
begin
Result := FindFirstItem; { see if can get to first item }
i := 1;
while Result and (i < Index) do begin
Result := FindNextItem;
Inc(i);
end;
end;
procedure TAbTarStreamHelper.WriteArchiveHeader;
begin
{ do nothing }
{ Tar archives have no overall header data }
end;
procedure TAbTarStreamHelper.WriteArchiveItem(AStream: TStream);
begin
WriteArchiveItemSize(AStream, AStream.Size);
end;
procedure TAbTarStreamHelper.WriteArchiveItemSize(AStream: TStream; Size: Int64);
var
PadBuff : PAnsiChar;
PadSize : Integer;
begin
if Size = 0 then
Exit;
{ transfer actual item data }
FStream.CopyFrom(AStream, Size);
{ Pad to Next block }
PadSize := RoundToTarBlock(Size) - Size;
GetMem(PadBuff, PadSize);
FillChar(PadBuff^, PadSize, #0);
FStream.Write(PadBuff^, PadSize);
FreeMem(PadBuff, PadSize);
end;
procedure TAbTarStreamHelper.WriteArchiveTail;
var
PadBuff : PAnsiChar;
PadSize : Integer;
begin
{ append 2 terminating null blocks }
PadSize := AB_TAR_RECORDSIZE;
GetMem(PadBuff, PadSize);
try
FillChar(PadBuff^, PadSize, #0);
FStream.Write(PadBuff^, PadSize);
FStream.Write(PadBuff^, PadSize);
finally
FreeMem(PadBuff, PadSize);
end;
end;
{ ***************************** TAbTarArchive ******************************** }
constructor TAbTarArchive.CreateFromStream(aStream : TStream; const aArchiveName : string);
begin
inherited;
FArchFormat := V7_FORMAT; // Default for new archives
end;
function TAbTarArchive.CreateItem(const FileSpec: string): TAbArchiveItem;
var
Item : TAbTarItem;
S : String;
I: Integer;
begin
if FArchReadOnly then
raise EAbTarBadOp.Create; { Create Item Unsupported in this Archive }
S := FixName(FileSpec);
Item := TAbTarItem.Create;
try
// HeaderFormat = (UNKNOWN_FORMAT, V7_FORMAT, OLDGNU_FORMAT, GNU_FORMAT, USTAR_FORMAT, STAR_FORMAT, POSIX_FORMAT);
if FArchFormat in [OLDGNU_FORMAT, GNU_FORMAT] then
begin
Item.ArchiveFormat := FArchFormat;
Item.LinkFlag := AB_TAR_LF_NORMAL;
Item.Magic := AB_TAR_MAGIC_GNUOLD;
end
else if FArchFormat in [USTAR_FORMAT] then
begin
Item.ArchiveFormat := USTAR_FORMAT;
Item.LinkFlag := AB_TAR_LF_NORMAL;
Item.Magic := AB_TAR_MAGIC_VAL+AB_TAR_MAGIC_VER;
end
else if (FArchFormat = V7_FORMAT) and (Length(S) > 100) then
begin { Switch the rep over to GNU so it can have long file names. }
FArchFormat := OLDGNU_FORMAT;
Item.ArchiveFormat := OLDGNU_FORMAT;
{ Leave the Defaults for LinkFlag, and Magic }
{ Update all the rest so that it can transistion to GNU_FORMAT }
for I := 0 to FItemList.Count - 1 do
TAbTarItem(FItemList.Items[i]).ArchiveFormat := OLDGNU_FORMAT;
end;{ This should not execute... }{
else if FArchFormat in [STAR_FORMAT, POSIX_FORMAT] then
begin
Item.ArchiveFormat := FArchFormat;
Item.LinkFlag := AB_TAR_LF_NORMAL;
Item.Magic := AB_TAR_MAGIC_VAL+AB_TAR_MAGIC_VER;
end;
}{ else FArchFormat in [ UNKNOWN_FORMAT, V7_FORMAT and Length(S) <= 100 ] } { This is the default. }
{ Most others are initialized in the .Create }
Item.CRC32 := 0;
{ Note this can raise exceptions for file name lengths. }
Item.FileName := FixName(FileSpec);
Item.DiskFileName := ExpandFileName(FileSpec);
Item.Action := aaNone;
finally
Result := Item;
end;
end;
procedure TAbTarArchive.ExtractItemAt(Index: Integer; const UseName: string);
var
OutStream : TFileStream;
CurItem : TAbTarItem;
begin
{ Check the index is not out of range. }
if(Index >= ItemList.Count) then
raise EListError.CreateFmt(SListIndexError, [Index]);
CurItem := TAbTarItem(ItemList[Index]);
if CurItem.ItemType in [UNKNOWN_ITEM] then
raise EAbTarBadOp.Create; { Unsupported Type, Cannot Extract }
if (CurItem.ItemType = UNSUPPORTED_ITEM) and
((Length(CurItem.FileName) >= AB_TAR_NAMESIZE) or
(Length(CurItem.LinkName) >= AB_TAR_NAMESIZE)) then
raise EAbTarBadOp.Create; { Unsupported Type, Cannot Extract }
{ We will allow extractions if the file name/Link name are strickly less than 100 chars }
if CurItem.IsDirectory then
AbCreateDirectory(UseName)
else begin
OutStream := TFileStream.Create(UseName, fmCreate or fmShareDenyNone);
try
try {OutStream}
ExtractItemToStreamAt(Index, OutStream);
finally {OutStream}
OutStream.Free;
end; {OutStream}
except
if ExceptObject is EAbUserAbort then
FStatus := asInvalid;
DeleteFile(UseName);
raise;
end;
end;
AbSetFileTime(UseName, CurItem.LastModTimeAsDateTime);
AbSetFileAttr(UseName, CurItem.NativeFileAttributes);
end;
procedure TAbTarArchive.ExtractItemToStreamAt(Index: Integer;
aStream: TStream);
var
CurItem : TAbTarItem;
begin
if(Index >= ItemList.Count) then
raise EListError.CreateFmt(SListIndexError, [Index]);
CurItem := TAbTarItem(ItemList[Index]);
if CurItem.ItemType in [UNKNOWN_ITEM] then
raise EAbTarBadOp.Create; { Unsupported Type, Cannot Extract }
if (CurItem.ItemType = UNSUPPORTED_ITEM) and
((Length(CurItem.FileName) >= AB_TAR_NAMESIZE) or
(Length(CurItem.LinkName) >= AB_TAR_NAMESIZE)) then
raise EAbTarBadOp.Create; { Unsupported Type, Cannot Extract }
{ We will allow extractions if the file name is strictly less than 100 chars }
FStream.Position := CurItem.StreamPosition+CurItem.FileHeaderCount*AB_TAR_RECORDSIZE;
if CurItem.UncompressedSize <> 0 then
aStream.CopyFrom(FStream, CurItem.UncompressedSize);
{ Else there is nothing to copy. }
end;
procedure TAbTarArchive.LoadArchive;
var
TarHelp : TAbTarStreamHelper;
Item : TAbTarItem;
ItemFound : Boolean;
Abort : Boolean;
Confirm : Boolean;
i : Integer;
Progress : Byte;
begin
{ create helper }
TarHelp := TAbTarStreamHelper.Create(FStream);
try {TarHelp}
{build Items list from tar header records}
{ reset Tar }
ItemFound := (FStream.Size > 0) and TarHelp.FindFirstItem;
if ItemFound then FArchFormat := UNKNOWN_FORMAT
else FArchFormat := V7_FORMAT;
{ while more data in Tar }
while (FStream.Position < FStream.Size) and ItemFound do begin
{create new Item}
Item := TAbTarItem.Create;
Item.FTarItem.StreamPosition := FStream.Position;
try {Item}
Item.LoadTarHeaderFromStream(FStream);
if Item.ItemReadOnly then
FArchReadOnly := True; { Set Archive as Read Only }
if Item.ItemType in [SUPPORTED_ITEM, UNSUPPORTED_ITEM] then begin
{ List of supported Item/File Types. }
{ Add the New Supported Item to the List }
if FArchFormat < Item.ArchiveFormat then
FArchFormat := Item.ArchiveFormat; { Take the max format }
Item.Action := aaNone;
FItemList.Add(Item);
end { end if }
else begin
{ unhandled Tar file system entity, notify user, but otherwise ignore }
if Assigned(FOnConfirmProcessItem) then
FOnConfirmProcessItem(self, Item, ptFoundUnhandled, Confirm);
end;
{ show progress and allow for aborting }
Progress := (FStream.Position*100) div FStream.Size;
DoArchiveProgress(Progress, Abort);
if Abort then begin
FStatus := asInvalid;
raise EAbUserAbort.Create;
end;
{ get the next item }
ItemFound := TarHelp.FindNextItem;
except {Item}
raise EAbTarBadOp.Create; { Invalid Item }
end; {Item}
end; {end while }
{ All the items need to reflect this information. }
for i := 0 to FItemList.Count - 1 do
begin
TAbTarItem(FItemList.Items[i]).ArchiveFormat := FArchFormat;
TAbTarItem(FItemList.Items[i]).ItemReadOnly := FArchReadOnly;
end;
DoArchiveProgress(100, Abort);
FIsDirty := False;
finally {TarHelp}
{ Clean Up }
TarHelp.Free;
end; {TarHelp}
end;
function TAbTarArchive.FixName(const Value: string): string;
{ fixup filename for storage }
var
lValue : string;
begin
lValue := Value;
{$IFDEF MSWINDOWS}
if DOSMode then begin
{Add the base directory to the filename before converting }
{the file spec to the short filespec format. }
if BaseDirectory <> '' then begin
{Does the filename contain a drive or a leading backslash? }
if not ((Pos(':', lValue) = 2) or (Pos(AbPathDelim, lValue) = 1)) then
{If not, add the BaseDirectory to the filename.}
lValue := BaseDirectory + AbPathDelim + lValue;
end;
lValue := AbGetShortFileSpec( lValue );
end;
{$ENDIF MSWINDOWS}
{ Should always trip drive info if on a Win/Dos system }
StoreOptions := StoreOptions + [soStripDrive];
{ strip drive stuff }
if soStripDrive in StoreOptions then
AbStripDrive( lValue );
{ check for a leading slash }
if lValue[1] = AbPathDelim then
System.Delete( lValue, 1, 1 );
if soStripPath in StoreOptions then
lValue := ExtractFileName(lValue);
if soRemoveDots in StoreOptions then
AbStripDots(lValue);
AbFixName(lValue);
Result := lValue;
end;
function TAbTarArchive.GetItem(Index: Integer): TAbTarItem;
begin
Result := TAbTarItem(FItemList.Items[Index]);
end;
function TAbTarArchive.GetSupportsEmptyFolders: Boolean;
begin
Result := True;
end;
procedure TAbTarArchive.PutItem(Index: Integer; const Value: TAbTarItem);
begin
//TODO: Remove this from all archives
FItemList.Items[Index] := Value;
end;
procedure TAbTarArchive.SaveArchive;
var
OutTarHelp : TAbTarStreamHelper;
Abort : Boolean;
i : Integer;
NewStream : TAbVirtualMemoryStream;
TempStream : TStream;
SaveDir : string;
CurItem : TAbTarItem;
AttrEx : TAbAttrExRec;
begin
if FArchReadOnly then
raise EAbTarBadOp.Create; { Archive is read only }
{init new archive stream}
NewStream := TAbVirtualMemoryStream.Create;
OutTarHelp := TAbTarStreamHelper.Create(NewStream);
try {NewStream/OutTarHelp}
{ create helper }
NewStream.SwapFileDirectory := FTempDir;
{build new archive from existing archive}
for i := 0 to pred(Count) do begin
FCurrentItem := ItemList[i];
CurItem := TAbTarItem(ItemList[i]);
case CurItem.Action of
aaNone, aaMove : begin {just copy the file to new stream}
{ "Seek" to the Item Data } { SaveTarHeaders, Updates FileHeaderCount }
FStream.Position := CurItem.StreamPosition+CurItem.FileHeaderCount*AB_TAR_RECORDSIZE;
CurItem.StreamPosition := NewStream.Position;{ Reset the Stream Pointer. }
{ Flush The Headers to the new stream }
CurItem.SaveTarHeaderToStream(NewStream);
{ Copy to new Stream, Round to the AB_TAR_RECORDSIZE boundry, and Pad zeros}
outTarhelp.WriteArchiveItemSize(FStream, CurItem.UncompressedSize);
end;
aaDelete: {doing nothing omits file from new stream} ;
aaStreamAdd : begin
try
{ adding from a stream }
CurItem.StreamPosition := NewStream.Position;{ Reset the Stream Pointer. }
CurItem.UncompressedSize := InStream.Size;
CurItem.SaveTarHeaderToStream(NewStream);
OutTarHelp.WriteArchiveItemSize(InStream, InStream.Size);
except
ItemList[i].Action := aaDelete;
DoProcessItemFailure(ItemList[i], ptAdd, ecFileOpenError, 0);
end;
end;
aaAdd, aaFreshen, aaReplace: begin
try
{ it's coming from a file }
GetDir(0, SaveDir);
try {SaveDir}
if (BaseDirectory <> '') then
ChDir(BaseDirectory);
{ update metadata }
if not AbFileGetAttrEx(CurItem.DiskFileName, AttrEx) then
raise EAbFileNotFound.Create;
CurItem.ExternalFileAttributes := AttrEx.Mode;
CurItem.LastModTimeAsDateTime := AttrEx.Time;
{ TODO: uid, gid, uname, gname should be added here }
{ TODO: Add support for different types of files here }
if (AttrEx.Mode and AB_FMODE_DIR) <> 0 then begin
CurItem.LinkFlag := AB_TAR_LF_DIR;
CurItem.UncompressedSize := 0;
CurItem.SaveTarHeaderToStream(NewStream);
end
else begin
TempStream := TFileStream.Create(CurItem.DiskFileName,
fmOpenRead or fmShareDenyWrite );
try { TempStream }
CurItem.UncompressedSize := TempStream.Size;
CurItem.StreamPosition := NewStream.Position;{ Reset the Stream Pointer. }
CurItem.SaveTarHeaderToStream(NewStream);
OutTarHelp.WriteArchiveItemSize(TempStream, TempStream.Size);
finally { TempStream }
TempStream.Free;
end; { TempStream }
end;
finally {SaveDir}
ChDir( SaveDir );
end; {SaveDir}
except
ItemList[i].Action := aaDelete;
DoProcessItemFailure(ItemList[i], ptAdd, ecFileOpenError, 0);
end;
end; { aaAdd ... }
end; { case }
end; { for i ... }
if NewStream.Size <> 0 then
OutTarHelp.WriteArchiveTail; { Terminate the TAR }
{ Size of NewStream is still 0, and max of the stream will also be 0 }
{copy new stream to FStream}
NewStream.Position := 0;
if (FStream is TMemoryStream) then
TMemoryStream(FStream).LoadFromStream(NewStream)
else if (FStream is TAbVirtualMemoryStream) or not FOwnsStream then begin
FStream.Size := 0;
FStream.Position := 0;
FStream.CopyFrom(NewStream, NewStream.Size);
end
else begin
{ write to a new stream }
FreeAndNil(FStream);
FStream := TFileStream.Create(FArchiveName, fmCreate or fmShareDenyWrite);
FStream.CopyFrom(NewStream, NewStream.Size);
end;
{update Items list}
for i := pred( Count ) downto 0 do begin
if ItemList[i].Action = aaDelete then
FItemList.Delete( i )
else if ItemList[i].Action <> aaFailed then
ItemList[i].Action := aaNone;
end;
DoArchiveSaveProgress( 100, Abort );
DoArchiveProgress( 100, Abort );
finally {NewStream/OutTarHelp}
OutTarHelp.Free;
NewStream.Free;
end;
end;
{ This assumes that LoadArchive has been called. }
procedure TAbTarArchive.TestItemAt(Index: Integer);
begin
FStream.Position := TAbTarItem(FItemList[Index]).StreamPosition;
if VerifyTar(FStream) <> atTar then
raise EAbTarInvalid.Create; { Invalid Tar }
end;
end.
================================================
FILE: lib/abbrevia/source/AbUnzOutStm.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is Craig Peterson
*
* Portions created by the Initial Developer are Copyright (C) 2011
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Craig Peterson
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbUnzOutStm.pas *}
{*********************************************************}
{* ABBREVIA: UnZip output stream; progress and CRC32 *}
{*********************************************************}
unit AbUnzOutStm;
{$I AbDefine.inc}
interface
uses
SysUtils, Classes, AbArcTyp;
type
// Fixed-length read-only stream, limits reads to the range between
// the input stream's starting position and a specified size. Seek/Position
// are adjusted to be 0 based.
TAbUnzipSubsetStream = class( TStream )
private
FStream : TStream;
FStartPos: Int64;
FCurPos: Int64;
FEndPos: Int64;
public
constructor Create(aStream: TStream; aStreamSize: Int64);
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
end;
// Write-only output stream, computes CRC32 and calls progress event
TAbUnzipOutputStream = class( TStream )
private
FBytesWritten : Int64;
FCRC32 : LongInt;
FCurrentProgress : Byte;
FStream : TStream;
FUncompressedSize : Int64;
FOnProgress : TAbProgressEvent;
function GetCRC32 : LongInt;
public
constructor Create(aStream : TStream);
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
property CRC32 : LongInt
read GetCRC32;
property Stream : TStream
read FStream
write FStream;
property UncompressedSize : Int64
read FUncompressedSize
write FUncompressedSize;
property OnProgress : TAbProgressEvent
read FOnProgress
write FOnProgress;
end;
implementation
uses
Math, AbExcept, AbUtils;
{ TAbUnzipSubsetStream implementation ====================================== }
{ -------------------------------------------------------------------------- }
constructor TAbUnzipSubsetStream.Create(aStream: TStream; aStreamSize: Int64);
begin
inherited Create;
FStream := aStream;
FStartPos := FStream.Position;
FCurPos := FStartPos;
FEndPos := FStartPos + aStreamSize;
end;
{ -------------------------------------------------------------------------- }
function TAbUnzipSubsetStream.Read(var Buffer; Count: Longint): Longint;
begin
if Count > FEndPos - FCurPos then
Count := FEndPos - FCurPos;
if Count > 0 then begin
Result := FStream.Read(Buffer, Count);
Inc(FCurPos, Result);
end
else
Result := 0;
end;
{ -------------------------------------------------------------------------- }
function TAbUnzipSubsetStream.Write(const Buffer; Count: Longint): Longint;
begin
raise EAbException.Create('TAbUnzipSubsetStream.Write not supported');
end;
{ -------------------------------------------------------------------------- }
function TAbUnzipSubsetStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
var
OldPos: Int64;
begin
OldPos := FCurPos;
case Origin of
soBeginning: FCurPos := FStartPos + Offset;
soCurrent: FCurPos := FCurPos + Offset;
soEnd: FCurPos := FEndPos + Offset;
end;
if FCurPos < FStartPos then
FCurPos := FStartPos;
if FCurPos > FEndPos then
FCurPos := FEndPos;
if OldPos <> FCurPos then
FStream.Position := FCurPos;
Result := FCurPos - FStartPos;
end;
{ -------------------------------------------------------------------------- }
{ TAbUnzipOutputStream implementation ====================================== }
{ -------------------------------------------------------------------------- }
constructor TAbUnzipOutputStream.Create(aStream: TStream);
begin
inherited Create;
FStream := aStream;
FCRC32 := -1;
end;
{ -------------------------------------------------------------------------- }
function TAbUnzipOutputStream.Read(var Buffer; Count: Integer): Longint;
begin
raise EAbException.Create('TAbUnzipOutputStream.Read not supported');
end;
{ -------------------------------------------------------------------------- }
function TAbUnzipOutputStream.Write(const Buffer; Count: Longint): Longint;
var
Abort : Boolean;
NewProgress : Byte;
begin
AbUpdateCRC( FCRC32, Buffer, Count );
Result := FStream.Write(Buffer, Count);
Inc( FBytesWritten, Result );
if Assigned( FOnProgress ) then begin
Abort := False;
NewProgress := AbPercentage(FBytesWritten, FUncompressedSize);
if (NewProgress <> FCurrentProgress) then begin
FOnProgress( NewProgress, Abort );
FCurrentProgress := NewProgress;
end;
if Abort then
raise EAbUserAbort.Create;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbUnzipOutputStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
Result := FStream.Seek(Offset, Origin);
end;
{ -------------------------------------------------------------------------- }
function TAbUnzipOutputStream.GetCRC32: LongInt;
begin
Result := not FCRC32;
end;
end.
================================================
FILE: lib/abbrevia/source/AbUnzPrc.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Craig Peterson
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbUnzPrc.pas *}
{*********************************************************}
{* ABBREVIA: UnZip procedures *}
{*********************************************************}
unit AbUnzPrc;
{$I AbDefine.inc}
interface
uses
Classes,
AbArcTyp,
AbZipTyp;
type
TAbUnzipHelper = class( TObject )
protected {private}
{internal variables}
FOutWriter : TStream;
FOutStream : TStream;
FUnCompressedSize : LongInt;
FCompressionMethod : TAbZipCompressionMethod;
FDictionarySize : TAbZipDictionarySize;
FShannonFanoTreeCount : Byte;
FOutBuf : PAbByteArray; {output buffer}
FOutSent : LongInt; {number of bytes sent to output buffer}
FOutPos : Cardinal; {current position in output buffer}
FBitSValid : Byte; {Number of valid bits}
FInBuf : TAbByteArray4K;
FInPos : Integer; {current position in input buffer}
FInCnt : Integer; {number of bytes in input buffer}
FInEof : Boolean; {set when stream read returns 0}
FCurByte : Byte; {current input byte}
FBitsLeft : Byte; {bits left to process in FCurByte}
FZStream : TStream;
protected
procedure uzFlushOutBuf;
{-Flushes the output buffer}
function uzReadBits(Bits : Byte) : Integer;
{-Read the specified number of bits}
procedure uzReadNextPrim;
{-does less likely part of uzReadNext}
{$IFDEF UnzipImplodeSupport}
procedure uzUnImplode;
{-Extract an imploded file}
{$ENDIF}
{$IFDEF UnzipReduceSupport}
procedure uzUnReduce;
{-Extract a reduced file}
{$ENDIF}
{$IFDEF UnzipShrinkSupport}
procedure uzUnShrink;
{-Extract a shrunk file}
{$ENDIF}
procedure uzWriteByte(B : Byte);
{write to output}
public
constructor Create( InputStream, OutputStream : TStream );
destructor Destroy;
override;
procedure Execute;
property UnCompressedSize : LongInt
read FUncompressedSize
write FUncompressedSize;
property CompressionMethod : TAbZipCompressionMethod
read FCompressionMethod
write FCompressionMethod;
property DictionarySize : TAbZipDictionarySize
read FDictionarySize
write FDictionarySize;
property ShannonFanoTreeCount : Byte
read FShannonFanoTreeCount
write FShannonFanoTreeCount;
end;
procedure AbUnzipToStream( Sender : TObject; Item : TAbZipItem;
OutStream : TStream);
procedure AbUnzip(Sender : TObject; Item : TAbZipItem; const UseName : string);
procedure AbTestZipItem(Sender : TObject; Item : TAbZipItem);
procedure InflateStream(CompressedStream, UnCompressedStream : TStream);
{-Inflates everything in CompressedStream to UncompressedStream
no encryption is tried, no check on CRC is done, uses the whole
compressedstream - no Progress events - no Frills!}
implementation
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
SysUtils,
{$IFDEF UnzipBzip2Support}
AbBzip2,
{$ENDIF}
{$IFDEF UnzipLzmaSupport}
AbLzma,
{$ENDIF}
{$IFDEF UnzipPPMdSupport}
AbPPMd,
{$ENDIF}
{$IFDEF UnzipWavPackSupport}
AbWavPack,
{$ENDIF}
AbBitBkt,
AbConst,
AbDfBase,
AbDfCryS,
AbDfDec,
AbExcept,
AbSpanSt,
AbSWStm,
AbUnzOutStm,
AbUtils;
{ -------------------------------------------------------------------------- }
procedure AbReverseBits(var W : Word);
{-Reverse the order of the bits in W}
register;
const
RevTable : array[0..255] of Byte = ($00, $80, $40, $C0, $20, $A0, $60,
$E0, $10, $90, $50, $D0, $30, $B0, $70, $F0, $08, $88, $48, $C8, $28,
$A8, $68, $E8, $18, $98, $58, $D8, $38, $B8, $78, $F8, $04, $84, $44,
$C4, $24, $A4, $64, $E4, $14, $94, $54, $D4, $34, $B4, $74, $F4, $0C,
$8C, $4C, $CC, $2C, $AC, $6C, $EC, $1C, $9C, $5C, $DC, $3C, $BC, $7C,
$FC, $02, $82, $42, $C2, $22, $A2, $62, $E2, $12, $92, $52, $D2, $32,
$B2, $72, $F2, $0A, $8A, $4A, $CA, $2A, $AA, $6A, $EA, $1A, $9A, $5A,
$DA, $3A, $BA, $7A, $FA, $06, $86, $46, $C6, $26, $A6, $66, $E6, $16,
$96, $56, $D6, $36, $B6, $76, $F6, $0E, $8E, $4E, $CE, $2E, $AE, $6E,
$EE, $1E, $9E, $5E, $DE, $3E, $BE, $7E, $FE, $01, $81, $41, $C1, $21,
$A1, $61, $E1, $11, $91, $51, $D1, $31, $B1, $71, $F1, $09, $89, $49,
$C9, $29, $A9, $69, $E9, $19, $99, $59, $D9, $39, $B9, $79, $F9, $05,
$85, $45, $C5, $25, $A5, $65, $E5, $15, $95, $55, $D5, $35, $B5, $75,
$F5, $0D, $8D, $4D, $CD, $2D, $AD, $6D, $ED, $1D, $9D, $5D, $DD, $3D,
$BD, $7D, $FD, $03, $83, $43, $C3, $23, $A3, $63, $E3, $13, $93, $53,
$D3, $33, $B3, $73, $F3, $0B, $8B, $4B, $CB, $2B, $AB, $6B, $EB, $1B,
$9B, $5B, $DB, $3B, $BB, $7B, $FB, $07, $87, $47, $C7, $27, $A7, $67,
$E7, $17, $97, $57, $D7, $37, $B7, $77, $F7, $0F, $8F, $4F, $CF, $2F,
$AF, $6F, $EF, $1F, $9F, $5F, $DF, $3F, $BF, $7F, $FF);
begin
W := RevTable[Byte(W shr 8)] or Word(RevTable[Byte(W)] shl 8);
end;
{ TAbUnzipHelper implementation ============================================ }
{ -------------------------------------------------------------------------- }
constructor TAbUnzipHelper.Create( InputStream, OutputStream : TStream );
begin
inherited Create;
FOutBuf := AllocMem( AbBufferSize );
FOutPos := 0;
FZStream := InputStream;
FOutStream := OutputStream;
FUncompressedSize := 0;
FDictionarySize := dsInvalid;
FShannonFanoTreeCount := 0;
FCompressionMethod := cmDeflated;
end;
{ -------------------------------------------------------------------------- }
destructor TAbUnzipHelper.Destroy;
begin
FreeMem( FOutBuf, AbBufferSize );
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbUnzipHelper.Execute;
begin
{parent class handles exceptions via OnExtractFailure}
FBitsLeft := 0;
FCurByte := 0;
FInCnt := 0;
FOutSent := 0;
FOutPos := 0;
FInEof := False;
{set the output stream; for Imploded/Reduced files this has to be
buffered, for all other types of compression, the code buffers the
output data nicely and so the given output stream can be used.}
{$IFDEF UnzipImplodeSupport}
if (FCompressionMethod = cmImploded) then
FOutWriter := TabSlidingWindowStream.Create(FOutStream)
else
{$ENDIF}
{$IFDEF UnzipReduceSupport}
if (FCompressionMethod >= cmReduced1) and
(FCompressionMethod <= cmReduced4) then
FOutWriter := TabSlidingWindowStream.Create(FOutStream)
else
{$ENDIF}
FOutWriter := FOutStream;
FInPos := 1+SizeOf(FInBuf);
{ GetMem( FInBuf, SizeOf(FInBuf^) );}
try
{uncompress it with the appropriate method}
case FCompressionMethod of
{$IFDEF UnzipShrinkSupport}
cmShrunk : uzUnshrink;
{$ENDIF}
{$IFDEF UnzipReduceSupport}
cmReduced1..cmReduced4 : uzUnReduce;
{$ENDIF}
{$IFDEF UnzipImplodeSupport}
cmImploded : uzUnImplode;
{$ENDIF}
{cmTokenized}
{cmEnhancedDeflated}
{cmDCLImploded}
else
raise EAbZipInvalidMethod.Create;
end;
finally
uzFlushOutBuf;
{free any memory}
if (FOutWriter <> FOutStream) then
FOutWriter.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbUnzipHelper.uzReadNextPrim;
begin
FInCnt := FZStream.Read( FInBuf, sizeof( FInBuf ) );
FInEof := FInCnt = 0;
{load first byte in buffer and set position counter}
FCurByte := FInBuf[1];
FInPos := 2;
end;
{ -------------------------------------------------------------------------- }
procedure TAbUnzipHelper.uzFlushOutBuf;
{-flushes the output buffer}
begin
if (FOutPos <> 0) then begin
FOutWriter.Write( FOutBuf^, FOutPos );
Inc( FOutSent, FOutPos );
FOutPos := 0;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbUnzipHelper.uzWriteByte(B : Byte);
{-Write one byte to the output buffer}
begin
FOutBuf^[FOutPos] := B;
inc(FOutPos);
if (FOutPos = AbBufferSize) or
(LongInt(FOutPos) + FOutSent = FUncompressedSize) then
uzFlushOutBuf;
end;
{ -------------------------------------------------------------------------- }
function TAbUnzipHelper.uzReadBits(Bits : Byte) : Integer;
{-Read the specified number of bits}
var
SaveCurByte, Delta, SaveBitsLeft : Byte;
begin
{read next byte if we're out of bits}
if FBitsLeft = 0 then begin
{do we still have a byte buffered?}
if FInPos <= FInCnt then begin
{get next byte out of buffer and advance position counter}
FCurByte := FInBuf[FInPos];
Inc(FInPos);
end
{are there any left to read?}
else
uzReadNextPrim;
FBitsLeft := 8;
end;
if ( Bits < FBitsLeft ) then begin
Dec( FBitsLeft, Bits );
Result := ((1 shl Bits) - 1) and FCurByte;
FCurByte := FCurByte shr Bits;
end
else if ( Bits = FBitsLeft ) then begin
Result := FCurByte;
FCurByte := 0;
FBitsLeft := 0;
end
else begin
SaveCurByte := FCurByte;
SaveBitsLeft := FBitsLeft;
{number of additional bits that we need}
Delta := Bits - FBitsLeft;
{do we still have a byte buffered?}
if FInPos <= FInCnt then begin
{get next byte out of buffer and advance position counter}
FCurByte := FInBuf[FInPos];
Inc(FInPos);
end
{are there any left to read?}
else
uzReadNextPrim;
FBitsLeft := 8;
Result := ( uzReadBits( Delta ) shl SaveBitsLeft ) or SaveCurByte;
end;
end;
{$IFDEF UnzipImplodeSupport}
{ -------------------------------------------------------------------------- }
procedure TAbUnzipHelper.uzUnImplode;
{-Extract an imploded file}
const
szLengthTree = SizeOf(TAbSfTree)-(192*SizeOf(TAbSfEntry));
szDistanceTree = SizeOf(TAbSfTree)-(192*SizeOf(TAbSfEntry));
szLitTree = SizeOf(TAbSfTree);
var
Length : Integer;
DIndex : LongInt;
Distance : Integer;
SPos : LongInt;
MyByte : Byte;
DictBits : Integer; {number of bits used in sliding dictionary}
MinMatchLength : Integer; {minimum match length}
LitTree : PAbSfTree; {Literal tree}
LengthTree : PAbSfTree; {Length tree}
DistanceTree : PAbSfTree; {Distance tree}
procedure uzLoadTree(var T; TreeSize : Integer);
{-Load one Shannon-Fano tree}
var
I : Word;
Tree : TAbSfTree absolute T;
procedure GenerateTree;
{-Generate a Shannon-Fano tree}
var
C : Word;
CodeIncrement : Integer;
LastBitLength : Integer;
I : Integer;
begin
C := 0;
CodeIncrement := 0;
LastBitLength := 0;
for I := Tree.Entries-1 downto 0 do
with Tree.Entry[I] do begin
Inc(C, CodeIncrement);
if BitLength <> LastBitLength then begin
LastBitLength := BitLength;
CodeIncrement := 1 shl (16-LastBitLength);
end;
Code := C;
end;
end;
procedure SortLengths;
{-Sort the bit lengths in ascending order, while retaining the order
of the original lengths stored in the file}
var
XL : Integer;
XGL : Integer;
TXP : PAbSfEntry;
TXGP : PAbSfEntry;
X, Gap : Integer;
Done : Boolean;
LT : LongInt;
begin
Gap := Tree.Entries shr 1;
repeat
repeat
Done := True;
for X := 0 to (Tree.Entries-1)-Gap do begin
TXP := @Tree.Entry[X];
TXGP := @Tree.Entry[X+Gap];
XL := TXP^.BitLength;
XGL := TXGP^.BitLength;
if (XL > XGL) or
((XL = XGL) and (TXP^.Value > TXGP^.Value)) then begin
LT := TXP^.L;
TXP^.L := TXGP^.L;
TXGP^.L := LT;
Done := False;
end;
end;
until Done;
Gap := Gap shr 1;
until (Gap = 0);
end;
procedure uzReadLengths;
{-Read bit lengths for a tree}
var
TreeBytes : Integer;
I, J, K : Integer;
Num, Len : Integer;
B : Byte;
begin
{get number of bytes in compressed tree}
TreeBytes := uzReadBits(8)+1;
I := 0;
Tree.MaxLength := 0;
{High nibble: Number of values at this bit length + 1.
Low nibble: Bits needed to represent value + 1}
for J := 1 to TreeBytes do begin
B := uzReadBits(8);
Len := (B and $0F)+1;
Num := (B shr 4)+1;
for K := I to I+Num-1 do
with Tree, Entry[K] do begin
if Len > MaxLength then
MaxLength := Len;
BitLength := Len;
Value := K;
end;
Inc(I, Num);
end;
end;
begin
Tree.Entries := TreeSize;
uzReadLengths;
SortLengths;
GenerateTree;
for I := 0 to TreeSize-1 do
AbReverseBits(Tree.Entry[I].Code);
end;
function uzReadTree(var T) : Byte;
{-Read next byte using a Shannon-Fano tree}
var
Bits : Integer;
CV : Word;
E : Integer;
Cur : Integer;
var
Tree : TAbSfTree absolute T;
begin
Result := 0;
Bits := 0;
CV := 0;
Cur := 0;
E := Tree.Entries;
repeat
CV := CV or (uzReadBits(1) shl Bits);
Inc(Bits);
while Tree.Entry[Cur].BitLength < Bits do begin
Inc(Cur);
if Cur >= E then
Exit;
end;
while Tree.Entry[Cur].BitLength = Bits do begin
if Tree.Entry[Cur].Code = CV then begin
Result := Tree.Entry[Cur].Value;
Exit;
end;
Inc(Cur);
if Cur >= E then
Exit;
end;
until False;
end;
begin
{do we have an 8K dictionary?}
if FDictionarySize = ds8K then
DictBits := 7
else
DictBits := 6;
{allocate trees}
LengthTree := AllocMem(szLengthTree);
DistanceTree := AllocMem(szDistanceTree);
LitTree := nil;
try
{do we have a Literal tree?}
MinMatchLength := FShannonFanoTreeCount;
if MinMatchLength = 3 then begin
LitTree := AllocMem(szLitTree);
uzLoadTree(LitTree^, 256);
end;
{load the other two trees}
uzLoadTree(LengthTree^, 64);
uzLoadTree(DistanceTree^, 64);
while (not FInEof) and (FOutSent + LongInt(FOutPos) < FUncompressedSize) do
{is data literal?}
if Boolean(uzReadBits(1)) then begin
{if MinMatchLength = 3 then we have a Literal tree}
if (MinMatchLength = 3) then
uzWriteByte( uzReadTree(LitTree^) )
else
uzWriteByte( uzReadBits(8) );
end
else begin
{data is a sliding dictionary}
Distance := uzReadBits(DictBits);
{using the Distance Shannon-Fano tree, read and decode the
upper 6 bits of the Distance value}
Distance := Distance or (uzReadTree(DistanceTree^) shl DictBits);
{using the Length Shannon-Fano tree, read and decode the Length value}
Length := uzReadTree(LengthTree^);
if Length = 63 then
Inc(Length, uzReadBits(8));
Inc(Length, MinMatchLength);
{move backwards Distance+1 bytes in the output stream, and copy
Length characters from this position to the output stream.
(if this position is before the start of the output stream,
then assume that all the data before the start of the output
stream is filled with zeros)}
DIndex := (FOutSent + LongInt(FOutPos))-(Distance+1);
while Length > 0 do begin
if DIndex < 0 then
uzWriteByte(0)
else begin
uzFlushOutBuf;
SPos := FOutWriter.Position;
FOutWriter.Position := DIndex;
FOutWriter.Read( MyByte, 1 );
FOutWriter.Position := SPos;
uzWriteByte(MyByte);
end;
Inc(DIndex);
Dec(Length);
end;
end;
finally
if (LitTree <> nil) then
FreeMem(LitTree, szLitTree);
FreeMem(LengthTree, szLengthTree);
FreeMem(DistanceTree, szDistanceTree);
end;
end;
{$ENDIF UnzipImplodeSupport}
{ -------------------------------------------------------------------------- }
{$IFDEF UnzipReduceSupport}
procedure TAbUnzipHelper.uzUnReduce;
const
FactorMasks : array[1..4] of Byte = ($7F, $3F, $1F, $0F);
DLE = 144;
var
C, Last : Byte;
OpI : LongInt;
I, J, Sz : Integer;
D : Word;
SPos : LongInt;
MyByte : Byte;
Factor : Byte; {reduction Factor}
FactorMask : Byte; {bit mask to use based on Factor}
Followers : PAbFollowerSets; {array of follower sets}
State : Integer; {used while processing reduced files}
V : Integer; {"}
Len : Integer; {"}
function BitsNeeded( i : Byte ) : Word;
begin
dec( i );
Result := 0;
repeat
inc( Result );
i := i shr 1;
until i = 0;
end;
begin
GetMem(Followers, SizeOf(TAbFollowerSets));
try
Factor := Ord( FCompressionMethod ) - 1;
FactorMask := FactorMasks[Factor];
State := 0;
C := 0;
V := 0;
Len := 0;
D := 0;
{load follower sets}
for I := 255 downto 0 do begin
Sz := uzReadBits(6);
Followers^[I].Size := Sz;
Dec(Sz);
for J := 0 to Sz do
Followers^[I].FSet[J] := uzReadBits(8);
end;
while (not FInEof) and ((FOutSent + LongInt(FOutPos)) < FUncompressedSize) do begin
Last := C;
with Followers^[Last] do
if Size = 0 then
C := uzReadBits(8)
else begin
C := uzReadBits(1);
if C <> 0 then
C := uzReadBits(8)
else
C := FSet[uzReadBits(BitsNeeded(Size))];
end;
if FInEof then
Exit;
case State of
0 :
if C <> DLE then
uzWriteByte(C)
else
State := 1;
1 :
if C <> 0 then begin
V := C;
Len := V and FactorMask;
if Len = FactorMask then
State := 2
else
State := 3;
end
else begin
uzWriteByte(DLE);
State := 0;
end;
2 :
begin
Inc(Len, C);
State := 3;
end;
3 :
begin
case Factor of
1 : D := (V shr 7) and $01;
2 : D := (V shr 6) and $03;
3 : D := (V shr 5) and $07;
4 : D := (V shr 4) and $0f;
else
raise EAbZipInvalidFactor.Create;
end;
{Delphi raises compiler Hints here, saying D might
be undefined... If Factor is not in [1..4], the
exception gets raised, and we never execute the following
line}
OpI := (FOutSent + LongInt(FOutPos))-(Swap(D)+C+1);
for I := 0 to Len+2 do begin
if OpI < 0 then
uzWriteByte(0)
else if OpI >= FOutSent then
uzWriteByte(FOutBuf[OpI - FOutSent])
else begin
SPos := FOutWriter.Position;
FOutWriter.Position := OpI;
FOutWriter.Read( MyByte, 1 );
FOutWriter.Position := SPos;
uzWriteByte(MyByte);
end;
Inc(OpI);
end;
State := 0;
end;
end;
end;
finally
FreeMem(Followers, SizeOf(Followers^));
end;
end;
{$ENDIF UnzipReduceSupport}
{ -------------------------------------------------------------------------- }
{$IFDEF UnzipShrinkSupport}
procedure TAbUnzipHelper.uzUnShrink;
{-Extract a file that was shrunk}
const
MaxBits = 13;
InitBits = 9;
FirstFree = 257;
Clear = 256;
MaxCodeMax = 8192; {= 1 shl MaxBits}
Unused = -1;
var
CodeSize : SmallInt;
NextFree : SmallInt;
BaseChar : SmallInt;
NewCode : SmallInt;
OldCode : SmallInt;
SaveCode : SmallInt;
N, R : SmallInt;
I : Integer;
PrefixTable : PAbIntArray8K; {used while processing shrunk files}
SuffixTable : PAbByteArray8K; {"}
Stack : PAbByteArray8K; {"}
StackIndex : Integer; {"}
begin
CodeSize := InitBits;
{ MaxCode := (1 shl InitBits)-1;}
NextFree := FirstFree;
PrefixTable := nil;
SuffixTable := nil;
Stack := nil;
try
GetMem(PrefixTable, SizeOf(PrefixTable^));
SuffixTable := AllocMem(SizeOf(SuffixTable^));
GetMem(Stack, SizeOf(Stack^));
FillChar(PrefixTable^, SizeOf(PrefixTable^), $FF);
for NewCode := 255 downto 0 do begin
PrefixTable^[NewCode] := 0;
SuffixTable^[NewCode] := NewCode;
end;
OldCode := uzReadBits(CodeSize);
if FInEof then
Exit;
BaseChar := OldCode;
uzWriteByte(BaseChar);
StackIndex := 0;
while (not FInEof) do begin
NewCode := uzReadBits(CodeSize);
while (NewCode = Clear) and (not FInEof) do begin
case uzReadBits(CodeSize) of
1 : begin
Inc(CodeSize);
end;
2 : begin
{mark all nodes as potentially unused}
for I := FirstFree to pred( NextFree ) do
PrefixTable^[I] := PrefixTable^[I] or LongInt($8000);
{unmark those used by other nodes}
for N := FirstFree to NextFree-1 do begin
{reference to another node?}
R := PrefixTable^[N] and $7FFF;
{flag node as referenced}
if R >= FirstFree then
PrefixTable^[R] := PrefixTable^[R] and $7FFF;
end;
{clear the ones that are still marked}
for I := FirstFree to pred( NextFree ) do
if PrefixTable^[I] < 0 then
PrefixTable^[I] := -1;
{recalculate NextFree}
NextFree := FirstFree;
while (NextFree < MaxCodeMax) and
(PrefixTable^[NextFree] <> -1) do
Inc(NextFree);
end;
end;
NewCode := uzReadBits(CodeSize);
end;
if FInEof then
Exit;
{save current code}
SaveCode := NewCode;
{special case}
if PrefixTable^[NewCode] = Unused then begin
Stack^[StackIndex] := BaseChar;
Inc(StackIndex);
NewCode := OldCode;
end;
{generate output characters in reverse order}
while (NewCode >= FirstFree) do begin
if PrefixTable^[NewCode] = Unused then begin
Stack^[StackIndex] := BaseChar;
Inc(StackIndex);
NewCode := OldCode;
end else begin
Stack^[StackIndex] := SuffixTable^[NewCode];
Inc(StackIndex);
NewCode := PrefixTable^[NewCode];
end;
end;
BaseChar := SuffixTable^[NewCode];
uzWriteByte(BaseChar);
{put them out in forward order}
while (StackIndex > 0) do begin
Dec(StackIndex);
uzWriteByte(Stack^[StackIndex]);
end;
{add new entry to tables}
NewCode := NextFree;
if NewCode < MaxCodeMax then begin
PrefixTable^[NewCode] := OldCode;
SuffixTable^[NewCode] := BaseChar;
while (NextFree < MaxCodeMax) and
(PrefixTable^[NextFree] <> Unused) do
Inc(NextFree);
end;
{remember previous code}
OldCode := SaveCode;
end;
finally
FreeMem(PrefixTable, SizeOf(PrefixTable^));
FreeMem(SuffixTable, SizeOf(SuffixTable^));
FreeMem(Stack, SizeOf(Stack^));
end;
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
procedure RequestPassword(Archive : TAbZipArchive; var Abort : Boolean);
var
APassPhrase : AnsiString;
begin
APassPhrase := Archive.Password;
Abort := False;
if Assigned(Archive.OnNeedPassword) then begin
Archive.OnNeedPassword(Archive, APassPhrase);
if APassPhrase = '' then
Abort := True
else
Archive.Password := APassPhrase;
end;
end;
{ -------------------------------------------------------------------------- }
procedure CheckPassword(Archive : TAbZipArchive; var Tries : Integer; var Abort : Boolean);
begin
{ if current password empty }
if Archive.Password = '' then begin
{ request password }
RequestPassword(Archive, Abort);
{ increment tries }
Inc(Tries);
end;
{ if current password still empty }
if Archive.Password = '' then begin
{ abort }
raise EAbZipInvalidPassword.Create;
end;
end;
{ -------------------------------------------------------------------------- }
procedure DoInflate(Archive : TAbZipArchive; Item : TAbZipItem; InStream, OutStream : TStream);
var
Hlpr : TAbDeflateHelper;
begin
Hlpr := TAbDeflateHelper.Create;
try
if Item.CompressionMethod = cmEnhancedDeflated then
Hlpr.Options := Hlpr.Options or dfc_UseDeflate64;
Hlpr.StreamSize := Item.CompressedSize;
Inflate(InStream, OutStream, Hlpr);
finally
Hlpr.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure DoLegacyUnzip(Archive : TAbZipArchive; Item : TAbZipItem; InStream, OutStream : TStream);
var
Helper : TAbUnzipHelper;
begin
Helper := TAbUnzipHelper.Create(InStream, OutStream);
try {Helper}
Helper.DictionarySize := Item.DictionarySize;
Helper.UnCompressedSize := Item.UncompressedSize;
Helper.CompressionMethod := Item.CompressionMethod;
Helper.ShannonFanoTreeCount := Item.ShannonFanoTreeCount;
Helper.Execute;
finally
Helper.Free;
end;
end;
{ -------------------------------------------------------------------------- }
{$IFDEF UnzipBzip2Support}
procedure DoExtractBzip2(Archive : TAbZipArchive; Item : TAbZipItem; InStream, OutStream : TStream);
var
Bzip2Stream: TStream;
begin
Bzip2Stream := TBZDecompressionStream.Create(InStream);
try
OutStream.CopyFrom(Bzip2Stream, Item.UncompressedSize);
finally
Bzip2Stream.Free;
end;
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
{$IFDEF UnzipLzmaSupport}
procedure DoExtractLzma(Archive : TAbZipArchive; Item : TAbZipItem;
InStream, OutStream : TStream);
var
Header: packed record
MajorVer, MinorVer: Byte;
PropSize: Word;
end;
Properties: array of Byte;
begin
InStream.ReadBuffer(Header, SizeOf(Header));
SetLength(Properties, Header.PropSize);
InStream.ReadBuffer(Properties[0], Header.PropSize);
LzmaDecodeStream(PByte(Properties), Header.PropSize, InStream, OutStream,
Item.UncompressedSize);
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
function ExtractPrep(ZipArchive: TAbZipArchive; Item: TAbZipItem): TStream;
var
LFH : TAbZipLocalFileHeader;
Abort : Boolean;
Tries : Integer;
CheckValue : LongInt;
DecryptStream: TAbDfDecryptStream;
begin
{ validate }
if (Lo(Item.VersionNeededToExtract) > Ab_ZipVersion) then
raise EAbZipVersion.Create;
{ seek to compressed file }
if ZipArchive.FStream is TAbSpanReadStream then
TAbSpanReadStream(ZipArchive.FStream).SeekImage(Item.DiskNumberStart,
Item.RelativeOffset)
else
ZipArchive.FStream.Position := Item.RelativeOffset;
{ get local header info for Item}
LFH := TAbZipLocalFileHeader.Create;
try
{ select appropriate CRC value based on General Purpose Bit Flag }
{ also get whether the file is stored, while we've got the local file header }
LFH.LoadFromStream(ZipArchive.FStream);
if (LFH.GeneralPurposeBitFlag and AbHasDataDescriptorFlag = AbHasDataDescriptorFlag) then
{ if bit 3 is set, then the data descriptor record is appended
to the compressed data }
CheckValue := LFH.LastModFileTime shl $10
else
CheckValue := Item.CRC32;
finally
LFH.Free;
end;
Result := TAbUnzipSubsetStream.Create(ZipArchive.FStream,
Item.CompressedSize);
{ get decrypting stream }
if Item.IsEncrypted then begin
try
{ need to decrypt }
Tries := 0;
Abort := False;
CheckPassword(ZipArchive, Tries, Abort);
while True do begin
if Abort then
raise EAbUserAbort.Create;
{ check for valid password }
DecryptStream := TAbDfDecryptStream.Create(Result,
CheckValue, ZipArchive.Password);
if DecryptStream.IsValid then begin
DecryptStream.OwnsStream := True;
Result := DecryptStream;
Break;
end;
FreeAndNil(DecryptStream);
{ prompt again }
Inc(Tries);
if (Tries > ZipArchive.PasswordRetries) then
raise EAbZipInvalidPassword.Create;
RequestPassword(ZipArchive, Abort);
end;
except
Result.Free;
raise;
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure DoExtract(aZipArchive: TAbZipArchive; aItem: TAbZipItem;
aInStream, aOutStream: TStream);
var
OutStream : TAbUnzipOutputStream;
begin
if aItem.UncompressedSize = 0 then
Exit;
OutStream := TAbUnzipOutputStream.Create(aOutStream);
try
OutStream.UncompressedSize := aItem.UncompressedSize;
OutStream.OnProgress := aZipArchive.OnProgress;
{ determine storage type }
case aItem.CompressionMethod of
cmStored: begin
{ unstore aItem }
OutStream.CopyFrom(aInStream, aItem.UncompressedSize);
end;
cmDeflated, cmEnhancedDeflated: begin
{ inflate aItem }
DoInflate(aZipArchive, aItem, aInStream, OutStream);
end;
{$IFDEF UnzipBzip2Support}
cmBzip2: begin
DoExtractBzip2(aZipArchive, aItem, aInStream, OutStream);
end;
{$ENDIF}
{$IFDEF UnzipLzmaSupport}
cmLZMA: begin
DoExtractLzma(aZipArchive, aItem, aInStream, OutStream);
end;
{$ENDIF}
{$IFDEF UnzipPPMdSupport}
cmPPMd: begin
DecompressPPMd(aInStream, OutStream);
end;
{$ENDIF}
{$IFDEF UnzipWavPackSupport}
cmWavPack: begin
DecompressWavPack(aInStream, OutStream);
end;
{$ENDIF}
cmShrunk..cmImploded: begin
DoLegacyUnzip(aZipArchive, aItem, aInStream, OutStream);
end;
else
raise EAbZipInvalidMethod.Create;
end;
{ check CRC }
if OutStream.CRC32 <> aItem.CRC32 then
if Assigned(aZipArchive.OnProcessItemFailure) then
aZipArchive.OnProcessItemFailure(aZipArchive, aItem, ptExtract,
ecAbbrevia, AbZipBadCRC)
else
raise EAbZipBadCRC.Create;
finally
OutStream.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure AbUnzipToStream( Sender : TObject; Item : TAbZipItem; OutStream : TStream);
var
ZipArchive : TAbZipArchive;
InStream : TStream;
begin
ZipArchive := Sender as TAbZipArchive;
if not Assigned(OutStream) then
raise EAbBadStream.Create;
InStream := ExtractPrep(ZipArchive, Item);
try
DoExtract(ZipArchive, Item, InStream, OutStream);
finally
InStream.Free
end;
end;
{ -------------------------------------------------------------------------- }
procedure AbUnzip(Sender : TObject; Item : TAbZipItem; const UseName : string);
{create the output filestream and pass it to DoExtract}
var
InStream, OutStream : TStream;
ZipArchive : TAbZipArchive;
begin
ZipArchive := TAbZipArchive(Sender);
if Item.IsDirectory then
AbCreateDirectory(UseName)
else begin
InStream := ExtractPrep(ZipArchive, Item);
try
OutStream := TFileStream.Create(UseName, fmCreate or fmShareDenyWrite);
try
try {OutStream}
DoExtract(ZipArchive, Item, InStream, OutStream);
finally {OutStream}
OutStream.Free;
end; {OutStream}
except
if ExceptObject is EAbUserAbort then
ZipArchive.FStatus := asInvalid;
DeleteFile(UseName);
raise;
end;
finally
InStream.Free
end;
end;
AbSetFileTime(UseName, Item.LastModTimeAsDateTime);
AbSetFileAttr(UseName, Item.NativeFileAttributes);
end;
{ -------------------------------------------------------------------------- }
procedure AbTestZipItem(Sender : TObject; Item : TAbZipItem);
{extract item to bit bucket and verify its local file header}
var
BitBucket : TAbBitBucketStream;
FieldSize : Word;
LFH : TAbZipLocalFileHeader;
Zip64Field : PZip64LocalHeaderRec;
ZipArchive : TAbZipArchive;
begin
ZipArchive := TAbZipArchive(Sender);
if (Lo(Item.VersionNeededToExtract) > Ab_ZipVersion) then
raise EAbZipVersion.Create;
{ seek to compressed file }
if ZipArchive.FStream is TAbSpanReadStream then
TAbSpanReadStream(ZipArchive.FStream).SeekImage(Item.DiskNumberStart,
Item.RelativeOffset)
else
ZipArchive.FStream.Position := Item.RelativeOffset;
BitBucket := nil;
LFH := nil;
try
BitBucket := TAbBitBucketStream.Create(0);
LFH := TAbZipLocalFileHeader.Create;
{get the item's local file header}
ZipArchive.FStream.Seek(Item.RelativeOffset, soBeginning);
LFH.LoadFromStream(ZipArchive.FStream);
ZipArchive.FStream.Seek(Item.RelativeOffset, soBeginning);
{currently a single exception is raised for any LFH error}
if (LFH.VersionNeededToExtract <> Item.VersionNeededToExtract) then
raise EAbZipInvalidLFH.Create;
if (LFH.GeneralPurposeBitFlag <> Item.GeneralPurposeBitFlag) then
raise EAbZipInvalidLFH.Create;
if (LFH.LastModFileTime <> Item.LastModFileTime) then
raise EAbZipInvalidLFH.Create;
if (LFH.LastModFileDate <> Item.LastModFileDate) then
raise EAbZipInvalidLFH.Create;
if (LFH.CRC32 <> Item.CRC32) then
raise EAbZipInvalidLFH.Create;
if LFH.ExtraField.Get(Ab_Zip64SubfieldID, Pointer(Zip64Field), FieldSize) then begin
if (Zip64Field.CompressedSize <> Item.CompressedSize) then
raise EAbZipInvalidLFH.Create;
if (Zip64Field.UncompressedSize <> Item.UncompressedSize) then
raise EAbZipInvalidLFH.Create;
end
else begin
if (LFH.CompressedSize <> Item.CompressedSize) then
raise EAbZipInvalidLFH.Create;
if (LFH.UncompressedSize <> Item.UncompressedSize) then
raise EAbZipInvalidLFH.Create;
end;
if (LFH.FileName <> Item.RawFileName) then
raise EAbZipInvalidLFH.Create;
{any CRC errors will raise exception during extraction}
AbUnZipToStream(Sender, Item, BitBucket);
finally
BitBucket.Free;
LFH.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure InflateStream( CompressedStream, UnCompressedStream : TStream );
{-Inflates everything in CompressedStream to UncompressedStream
no encryption is tried, no check on CRC is done, uses the whole
compressedstream - no Progress events - no Frills!}
begin
Inflate(CompressedStream, UncompressedStream, nil);
end;
end.
================================================
FILE: lib/abbrevia/source/AbUnzper.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: ABUnzper.pas *}
{*********************************************************}
{* ABBREVIA: Non-visual Component with UnZip support *}
{*********************************************************}
unit AbUnzper;
{$I AbDefine.inc}
interface
uses
Classes,
AbZBrows, AbArcTyp, AbZipTyp;
type
TAbCustomUnZipper = class(TAbCustomZipBrowser)
protected {private}
FExtractOptions : TAbExtractOptions;
FOnConfirmOverwrite : TAbConfirmOverwriteEvent;
FOnNeedPassword : TAbNeedPasswordEvent;
FPasswordRetries : Byte;
protected {methods}
procedure DoConfirmOverwrite(var Name : string;
var Confirm : Boolean);
virtual;
procedure DoNeedPassword(Sender : TObject;
var NewPassword : AnsiString);
virtual;
procedure InitArchive; override;
procedure SetExtractOptions(Value : TAbExtractOptions);
procedure SetPasswordRetries(Value : Byte);
procedure UnzipProc(Sender : TObject; Item : TAbArchiveItem;
const NewName : string );
procedure UnzipToStreamProc(Sender : TObject; Item : TAbArchiveItem;
OutStream : TStream);
procedure TestItemProc(Sender : TObject; Item : TAbArchiveItem);
procedure SetFileName(const aFileName : string);
override;
protected {properties}
property ExtractOptions : TAbExtractOptions
read FExtractOptions
write SetExtractOptions
default AbDefExtractOptions;
property OnConfirmOverwrite : TAbConfirmOverwriteEvent
read FOnConfirmOverwrite
write FOnConfirmOverwrite;
property OnNeedPassword : TAbNeedPasswordEvent
read FOnNeedPassword
write FOnNeedPassword;
property PasswordRetries : Byte
read FPasswordRetries
write SetPasswordRetries
default AbDefPasswordRetries;
public {methods}
constructor Create( AOwner : TComponent );
override;
destructor Destroy;
override;
procedure ExtractAt(Index : Integer; const NewName : string);
procedure ExtractFiles(const FileMask : string);
procedure ExtractFilesEx(const FileMask, ExclusionMask : string);
procedure ExtractToStream(const aFileName : string; ToStream : TStream);
procedure ExtractTaggedItems;
procedure TestTaggedItems;
end;
TAbUnZipper = class(TAbCustomUnZipper)
published
property ArchiveProgressMeter;
property ItemProgressMeter;
property BaseDirectory;
property ExtractOptions;
property LogFile;
property Logging;
property OnArchiveProgress;
property OnArchiveItemProgress;
property OnChange;
property OnConfirmOverwrite;
property OnConfirmProcessItem;
property OnLoad;
property OnNeedPassword;
property OnRequestImage;
property OnProcessItemFailure;
property OnRequestLastDisk;
property OnRequestNthDisk;
property Password;
property PasswordRetries;
property TempDirectory;
property Version;
property FileName; {must be after OnLoad}
end;
implementation
uses
SysUtils,
AbUtils,
AbExcept,
AbUnzPrc;
{ -------------------------------------------------------------------------- }
constructor TAbCustomUnZipper.Create( AOwner : TComponent );
begin
inherited Create(AOwner);
ExtractOptions := AbDefExtractOptions;
PasswordRetries := AbDefPasswordRetries;
end;
{ -------------------------------------------------------------------------- }
destructor TAbCustomUnZipper.Destroy;
begin
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.DoConfirmOverwrite(var Name : string;
var Confirm : Boolean);
begin
Confirm := True;
if Assigned(FOnConfirmOverwrite) then
FOnConfirmOverwrite( Name, Confirm );
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.DoNeedPassword(Sender : TObject;
var NewPassword : AnsiString);
begin
if Assigned(FOnNeedPassword) then begin
FOnNeedPassword(Self, NewPassword);
Password := NewPassword;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.ExtractAt(Index : Integer; const NewName : string);
{extract a file from the archive that match the index}
begin
if (FArchive <> nil) then
FArchive.ExtractAt(Index, NewName)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.ExtractFiles(const FileMask : string);
{extract all files from the archive that match the mask}
begin
if (FArchive <> nil) then
FArchive.ExtractFiles( FileMask )
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.ExtractFilesEx(const FileMask, ExclusionMask : string);
{extract files matching FileMask except those matching ExclusionMask}
begin
if (FArchive <> nil) then
FArchive.ExtractFilesEx(FileMask, ExclusionMask)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.ExtractToStream(const aFileName : string;
ToStream : TStream);
begin
if (FArchive <> nil) then
FArchive.ExtractToStream(aFileName, ToStream)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.ExtractTaggedItems;
{extract all tagged items from the archive}
begin
if (FArchive <> nil) then
FArchive.ExtractTaggedItems
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.InitArchive;
begin
inherited InitArchive;
if FArchive <> nil then begin
FArchive.ExtractOptions := FExtractOptions;
FArchive.OnConfirmOverwrite := DoConfirmOverwrite;
end;
if FArchive is TAbZipArchive then begin
TAbZipArchive(FArchive).PasswordRetries := FPasswordRetries;
TAbZipArchive(FArchive).OnNeedPassword := DoNeedPassword;
TAbZipArchive(FArchive).TestHelper := TestItemProc;
TAbZipArchive(FArchive).ExtractHelper := UnzipProc;
TAbZipArchive(FArchive).ExtractToStreamHelper := UnzipToStreamProc;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.SetExtractOptions(Value : TAbExtractOptions);
begin
FExtractOptions := Value;
if (FArchive <> nil) then
FArchive.ExtractOptions := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.SetPasswordRetries(Value : Byte);
begin
FPasswordRetries := Value;
if FArchive is TAbZipArchive then
TAbZipArchive(FArchive).PasswordRetries := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.TestTaggedItems;
{Test specified items}
begin
if (FArchive <> nil) then
FArchive.TestTaggedItems
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.UnzipProc(Sender : TObject;
Item : TAbArchiveItem;
const NewName : string);
begin
AbUnzip( TAbZipArchive(Sender), TAbZipItem(Item), NewName);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.UnzipToStreamProc(Sender : TObject;
Item : TAbArchiveItem;
OutStream : TStream);
begin
AbUnzipToStream(TAbZipArchive(Sender), TAbZipItem(Item), OutStream);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.TestItemProc(Sender : TObject;
Item : TAbArchiveItem);
begin
AbTestZipItem(TAbZipArchive(Sender), TAbZipItem(Item));
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomUnZipper.SetFileName(const aFileName: string);
begin
if aFileName <> '' then
begin
if not FileExists(aFileName) then
raise EAbFileNotFound.Create;
if AbFileGetSize(aFileName) <= 0 then
raise EAbBadStream.Create;
end;
inherited SetFileName(aFileName);
end;
end.
================================================
FILE: lib/abbrevia/source/AbUtils.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbUtils.pas *}
{*********************************************************}
{* ABBREVIA: Utility classes and routines *}
{*********************************************************}
unit AbUtils;
{$I AbDefine.inc}
interface
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
{$IFDEF LibcAPI}
Libc,
{$ENDIF}
{$IFDEF FPCUnixAPI}
baseunix,
{$IFDEF Linux}
initc,
{$ENDIF}
unix,
{$ENDIF}
{$IFDEF PosixAPI}
Posix.SysStatvfs,
Posix.SysStat,
Posix.Utime,
Posix.Base,
Posix.Unistd,
Posix.Fcntl,
Posix.SysTypes,
{$ENDIF}
{$IFDEF UNIX}
DateUtils,
{$ENDIF}
{$IFDEF HasAnsiStrings}
System.AnsiStrings,
{$ENDIF}
SysUtils,
Classes,
AbCharset;
type
{describe the pending action for an archive item}
TAbArchiveAction =
(aaFailed, aaNone, aaAdd, aaDelete, aaFreshen, aaMove, aaReplace,
aaStreamAdd);
TAbProcessType =
(ptAdd, ptDelete, ptExtract, ptFreshen, ptMove, ptReplace, ptFoundUnhandled);
TAbLogType =
(ltAdd, ltDelete, ltExtract, ltFreshen, ltMove, ltReplace, ltStart, ltFoundUnhandled);
TAbErrorClass =
(ecAbbrevia, ecInOutError, ecFilerError, ecFileCreateError,
ecFileOpenError, ecCabError, ecOther);
const
AbPathDelim = PathDelim; { Delphi/Linux constant }
AbPathSep = PathSep; { Delphi/Linux constant }
AbDosPathDelim = '\';
AbUnixPathDelim = '/';
AbDosPathSep = ';';
AbUnixPathSep = ':';
AbDosAnyFile = '*.*';
AbUnixAnyFile = '*';
AbAnyFile = {$IFDEF UNIX} AbUnixAnyFile; {$ELSE} AbDosAnyFile; {$ENDIF}
AbThisDir = '.';
AbParentDir = '..';
type
TAbArchiveType = (atUnknown, atZip, atSpannedZip, atSelfExtZip,
atTar, atGzip, atGzippedTar, atCab, atBzip2, atBzippedTar);
{$IF NOT DECLARED(DWORD)}
type
DWORD = LongWord;
{$IFEND}
{$IF NOT DECLARED(PtrInt)}
type
// Delphi 7-2007 declared NativeInt incorrectly
{$IFDEF CPU386}
PtrInt = LongInt;
PtrUInt = LongWord;
{$ELSE}
PtrInt = NativeInt;
PtrUInt = NativeUInt;
{$ENDIF}
{$IFEND}
{ System-encoded SBCS string (formerly AnsiString) }
type
AbSysString = {$IFDEF Posix}UTF8String{$ELSE}AnsiString{$ENDIF};
const
AbCrc32Table : array[0..255] of DWord = (
$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
TAbPathType = ( ptNone, ptRelative, ptAbsolute );
{===Helper functions===}
function AbCopyFile(const Source, Destination: string; FailIfExists: Boolean): Boolean;
procedure AbCreateDirectory( const Path : string );
{creates the requested directory tree. CreateDir is insufficient,
because if you have a path x:\dir, and request x:\dir\sub1\sub2,
(/dir and /dir/sub1/sub2 on Unix) it fails.}
function AbCreateTempFile(const Dir : string) : string;
function AbGetTempDirectory : string;
{-Return the system temp directory}
function AbGetTempFile(const Dir : string; CreateIt : Boolean) : string;
function AbDrive(const ArchiveName : string) : Char;
function AbDriveIsRemovable(const ArchiveName : string) : Boolean;
function AbFileMatch(FileName : string; FileMask : string ) : Boolean;
{see if FileName matches FileMask}
procedure AbFindFiles(const FileMask : string; SearchAttr : Integer;
FileList : TStrings; Recurse : Boolean );
procedure AbFindFilesEx( const FileMask : string; SearchAttr : Integer;
FileList : TStrings; Recurse : Boolean );
function AbAddBackSlash(const DirName : string) : string;
function AbFindNthSlash( const Path : string; n : Integer ) : Integer;
{return the position of the character just before the nth backslash}
function AbGetDriveFreeSpace(const ArchiveName : string) : Int64;
{return the available space on the specified drive }
function AbGetPathType( const Value : string ) : TAbPathType;
{returns path type - none, relative or absolute}
{$IFDEF MSWINDOWS}
function AbGetShortFileSpec(const LongFileSpec : string ) : string;
{$ENDIF}
procedure AbIncFilename( var Filename : string; Value : Word );
procedure AbParseFileName( FileSpec : string;
out Drive : string;
out Path : string;
out FileName : string );
procedure AbParsePath( Path : string; SubPaths : TStrings );
{- break abart path into subpaths --- Path : abbrevia/examples ->
SubPaths[0] = abbrevia
SubPaths[1] = examples}
function AbPatternMatch(const Source : string; iSrc : Integer;
const Pattern : string; iPat : Integer ) : Boolean;
{ recursive routine to see if the source string matches
the pattern. Both ? and * wildcard characters are allowed.}
function AbPercentage(V1, V2 : Int64) : Byte;
{-Returns the ratio of V1 to V2 * 100}
procedure AbStripDots( var FName : string );
{-strips relative path information}
procedure AbStripDrive( var FName : string );
{-strips the drive off a filename}
procedure AbFixName( var FName : string );
{-changes backslashes to forward slashes}
procedure AbUnfixName( var FName : string );
{-changes forward slashes to backslashes}
procedure AbUpdateCRC( var CRC : LongInt; const Buffer; Len : Integer );
function AbUpdateCRC32(CurByte : Byte; CurCrc : LongInt) : LongInt;
{-Returns an updated crc32}
function AbCRC32Of( const aValue : RawByteString ) : LongInt;
function AbWriteVolumeLabel(const VolName : string;
Drive : Char) : Cardinal;
const
AB_SPAN_VOL_LABEL = 'PKBACK# %3.3d';
function AbGetVolumeLabel(Drive : Char) : string;
procedure AbSetSpanVolumeLabel(Drive: Char; VolNo : Integer);
function AbTestSpanVolumeLabel(Drive: Char; VolNo : Integer): Boolean;
procedure AbSetFileAttr(const aFileName : string; aAttr: Integer);
{-Sets platform-native file attributes (DOS attr or Unix mode)}
function AbFileGetSize(const aFileName : string) : Int64;
type
TAbAttrExRec = record
Time: TDateTime;
Size: Int64;
Attr: Integer;
Mode: {$IFDEF UNIX}mode_t{$ELSE}Cardinal{$ENDIF};
end;
function AbFileGetAttrEx(const aFileName: string; out aAttr: TAbAttrExRec) : Boolean;
function AbSwapLongEndianness(Value : LongInt): LongInt;
{ date and time stuff }
const
Date1900 {: LongInt} = $0001AC05; {Julian day count for 01/01/1900 -- TDateTime Start Date}
Date1970 {: LongInt} = $00020FE4; {Julian day count for 01/01/1970 -- Unix Start Date}
Unix0Date: TDateTime = 25569; {Date1970 - Date1900}
SecondsInDay = 86400; {Number of seconds in a day}
SecondsInHour = 3600; {Number of seconds in an hour}
SecondsInMinute = 60; {Number of seconds in a minute}
HoursInDay = 24; {Number of hours in a day}
MinutesInHour = 60; {Number of minutes in an hour}
MinutesInDay = 1440; {Number of minutes in a day}
function AbUnixTimeToLocalDateTime(UnixTime : LongInt) : TDateTime;
function AbLocalDateTimeToUnixTime(DateTime : TDateTime) : LongInt;
function AbDosFileDateToDateTime(FileDate, FileTime : Word) : TDateTime;
function AbDateTimeToDosFileDate(Value : TDateTime) : LongInt;
function AbGetFileTime(const aFileName: string): TDateTime;
function AbSetFileTime(const aFileName: string; aValue: TDateTime): Boolean;
{ file attributes }
function AbDOS2UnixFileAttributes(Attr: LongInt): LongInt;
function AbUnix2DosFileAttributes(Attr: LongInt): LongInt;
{ AnisStrings }
function AbLeftStr(const AText: AnsiString; const ACount: Integer): AnsiString; {$IFDEF HasInline}inline;{$ENDIF}
function AbStrLen(const Str: PAnsiChar): Cardinal; {$IFDEF HasInline}inline;{$ENDIF}
function AbStrPCopy(Dest: PAnsiChar; const Source: AnsiString): PAnsiChar; {$IFDEF HasInline}inline;{$ENDIF}
function AbStrPLCopy(Dest: PAnsiChar; const Source: AnsiString; MaxLen: Cardinal): PAnsiChar; {$IFDEF HasInline}inline;{$ENDIF}
{ UNIX File Types and Permissions }
const
AB_FMODE_FILE = $0000;
AB_FMODE_FIFO = $1000;
AB_FMODE_CHARSPECFILE = $2000;
AB_FMODE_DIR = $4000;
AB_FMODE_BLOCKSPECFILE = $6000;
AB_FMODE_FILE2 = $8000;
AB_FMODE_FILELINK = $A000;
AB_FMODE_SOCKET = $C000;
AB_FPERMISSION_OWNERREAD = $0100; { read by owner }
AB_FPERMISSION_OWNERWRITE = $0080; { write by owner }
AB_FPERMISSION_OWNEREXECUTE = $0040; { execute/search by owner }
AB_FPERMISSION_GROUPREAD = $0020; { read by group }
AB_FPERMISSION_GROUPWRITE = $0010; { write by group }
AB_FPERMISSION_GROUPEXECUTE = $0008; { execute/search by group }
AB_FPERMISSION_OTHERREAD = $0004; { read by other }
AB_FPERMISSION_OTHERWRITE = $0002; { write by other }
AB_FPERMISSION_OTHEREXECUTE = $0001; { execute/search by other }
AB_FPERMISSION_GENERIC =
AB_FPERMISSION_OWNERREAD or
AB_FPERMISSION_OWNERWRITE or
AB_FPERMISSION_GROUPREAD or
AB_FPERMISSION_OTHERREAD;
{ Unicode backwards compatibility functions }
{$IFNDEF UNICODE}
function CharInSet(C: AnsiChar; CharSet: TSysCharSet): Boolean;
{$ENDIF}
implementation
uses
StrUtils,
AbConst,
AbExcept;
{$IF DEFINED(FPCUnixAPI)}
function mktemp(template: PAnsiChar): PAnsiChar; cdecl;
external clib name 'mktemp';
{$ELSEIF DEFINED(PosixAPI)}
function mktemp(template: PAnsiChar): PAnsiChar; cdecl;
external libc name _PU + 'mktemp';
{$IFEND}
{$IF DEFINED(FPCUnixAPI) AND DEFINED(Linux)}
// FreePascal libc definitions
type
nl_item = cint;
const
__LC_CTYPE = 0;
_NL_CTYPE_CLASS = (__LC_CTYPE shl 16);
_NL_CTYPE_CODESET_NAME = (_NL_CTYPE_CLASS)+14;
function nl_langinfo(__item: nl_item): PAnsiChar; cdecl;
external clib name 'nl_langinfo';
{$IFEND}
{===platform independent routines for platform dependent stuff=======}
function ExtractShortName(const SR : TSearchRec) : string;
begin
{$IFDEF MSWINDOWS}
{$WARN SYMBOL_PLATFORM OFF}
if SR.FindData.cAlternateFileName[0] <> #0 then
Result := SR.FindData.cAlternateFileName
else
Result := SR.FindData.cFileName;
{$WARN SYMBOL_PLATFORM ON}
{$ENDIF}
{$IFDEF UNIX}
Result := SR.Name;
{$ENDIF}
end;
{====================================================================}
{ ========================================================================== }
function AbCopyFile(const Source, Destination: string; FailIfExists: Boolean): Boolean;
{$IFDEF UNIX}
var
DesStream, SrcStream: TFileStream;
{$ENDIF}
begin
{$IFDEF UNIX}
Result := False;
if not FailIfExists or not FileExists(Destination) then
try
SrcStream := TFileStream.Create(Source, fmOpenRead or fmShareDenyWrite);
try
DesStream := TFileStream.Create(Destination, fmCreate);
try
DesStream.CopyFrom(SrcStream, 0);
Result := True;
finally
DesStream.Free;
end;
finally
SrcStream.Free;
end;
except
// Ignore errors and just return false
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
Result := CopyFile(PChar(Source), PChar(Destination), FailIfExists);
{$ENDIF MSWINDOWS}
end;
{ -------------------------------------------------------------------------- }
procedure AbCreateDirectory( const Path : string );
{creates the requested directory tree. CreateDir is insufficient,
because if you have a path x:\dir, and request x:\dir\sub1\sub2,
(/dir and /dir/sub1/sub2 on Unix) it fails.}
var
iStartSlash : Integer;
i : Integer;
TempPath : string;
begin
if DirectoryExists( Path ) then
Exit;
{see how much of the path currently exists}
if Pos( '\\', Path ) > 0 then
{UNC Path \\computername\sharename\path1..\pathn}
iStartSlash := 5
else
{standard Path drive:\path1..\pathn}
iStartSlash := 2;
repeat
{find the Slash at iStartSlash}
i := AbFindNthSlash( Path, iStartSlash );
{get a temp path to try: drive:\path1}
TempPath := Copy( Path, 1, i );
{if it doesn't exist, create it}
if not DirectoryExists( TempPath ) then
MkDir( TempPath );
inc( iStartSlash );
until ( Length( TempPath ) = Length( Path ) );
end;
{ -------------------------------------------------------------------------- }
function AbCreateTempFile(const Dir : string) : string;
begin
Result := AbGetTempFile(Dir, True);
end;
{ -------------------------------------------------------------------------- }
function AbGetTempDirectory : string;
begin
{$IFDEF MSWiNDOWS}
SetLength(Result, MAX_PATH);
SetLength(Result, GetTempPath(Length(Result), PChar(Result)));
{$ENDIF}
{$IFDEF UNIX}
Result := '/tmp/';
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function AbGetTempFile(const Dir : string; CreateIt : Boolean) : string;
var
TempPath : string;
{$IFDEF MSWINDOWS}
FileNameZ : array [0..259] of char;
{$ENDIF}
{$IFDEF UNIX}
hFile: Integer;
FileName: AbSysString;
{$ENDIF}
begin
if DirectoryExists(Dir) then
TempPath := Dir
else
TempPath := AbGetTempDirectory;
{$IFDEF MSWINDOWS}
GetTempFileName(PChar(TempPath), 'VMS', Word(not CreateIt), FileNameZ);
Result := string(FileNameZ);
{$ENDIF}
{$IFDEF UNIX}
FileName := AbSysString(TempPath) + 'VMSXXXXXX';
mktemp(PAnsiChar(AbSysString(FileName)));
Result := string(FileName);
if CreateIt then begin
hFile := FileCreate(Result);
if hFile <> -1 then
FileClose(hFile);
end;
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function AbDrive(const ArchiveName : string) : Char;
var
iPos: Integer;
Path : string;
begin
Path := ExpandFileName(ArchiveName);
iPos := Pos(':', Path);
if (iPos <= 0) then
Result := 'A'
else
Result := Path[1];
end;
{ -------------------------------------------------------------------------- }
function AbDriveIsRemovable(const ArchiveName : string) : Boolean;
{$IFDEF MSWINDOWS}
var
Path: string;
{$ENDIF}
begin
{$IFDEF MSWINDOWS}
Path := ExpandFileName(ArchiveName);
if AnsiStartsText('\\?\UNC\', Path) then
Delete(Path, 1, 8)
else if AnsiStartsText('\\?\', Path) then
Delete(Path, 1, 4);
Path := IncludeTrailingPathDelimiter(ExtractFileDrive(Path));
Result := GetDriveType(PChar(Path)) = DRIVE_REMOVABLE;
{$ENDIF}
{$IFDEF LINUX}
{LINUX -- Following may not cover all the bases}
Result := AnsiStartsText('/mnt/floppy', ExtractFilePath(ExpandFileName(ArchiveName)));
{$ENDIF}
{$IFDEF DARWIN}
Result := False;
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function AbGetDriveFreeSpace(const ArchiveName : string) : Int64;
{ attempt to find free space (in bytes) on drive/volume,
returns -1 if fails for some reason }
{$IFDEF MSWINDOWS}
var
FreeAvailable, TotalSpace: Int64;
begin
if GetDiskFreeSpaceEx(PChar(ExtractFilePath(ExpandFileName(ArchiveName))),
FreeAvailable, TotalSpace, nil) then
Result := FreeAvailable
else
Result := -1;
{$ENDIF}
{$IFDEF UNIX}
var
FStats : {$IFDEF PosixAPI}_statvfs{$ELSE}TStatFs{$ENDIF};
begin
{$IF DEFINED(LibcAPI)}
if statfs(PAnsiChar(ExtractFilePath(ArchiveName)), FStats) = 0 then
Result := Int64(FStats.f_bAvail) * Int64(FStats.f_bsize)
{$ELSEIF DEFINED(FPCUnixAPI)}
if fpStatFS(PAnsiChar(ExtractFilePath(ArchiveName)), @FStats) = 0 then
Result := Int64(FStats.bAvail) * Int64(FStats.bsize)
{$ELSEIF DEFINED(PosixAPI)}
if statvfs(PAnsiChar(AbSysString(ExtractFilePath(ArchiveName))), FStats) = 0 then
Result := Int64(FStats.f_bavail) * Int64(FStats.f_bsize)
{$IFEND}
else
Result := -1;
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function AbFileMatch(FileName: string; FileMask: string ): Boolean;
{see if FileName matches FileMask}
var
DirMatch : Boolean;
MaskDir : string;
begin
FileName := UpperCase( FileName );
FileMask := UpperCase( FileMask );
MaskDir := ExtractFilePath( FileMask );
if MaskDir = '' then
DirMatch := True
else
DirMatch := AbPatternMatch( ExtractFilePath( FileName ), 1, MaskDir, 1 );
Result := DirMatch and AbPatternMatch( ExtractFileName( FileName ), 1,
ExtractFileName( FileMask ), 1 );
end;
{ -------------------------------------------------------------------------- }
procedure AbFindFiles( const FileMask : string; SearchAttr : Integer;
FileList : TStrings; Recurse : Boolean );
var
NewFile : string;
SR : TSearchRec;
Found : Integer;
NameMask: string;
begin
Found := FindFirst( FileMask, SearchAttr, SR );
if Found = 0 then begin
try
NameMask := UpperCase(ExtractFileName(FileMask));
while Found = 0 do begin
NewFile := ExtractFilePath( FileMask ) + SR.Name;
if (SR.Name <> AbThisDir) and
(SR.Name <> AbParentDir) and
AbPatternMatch(UpperCase(SR.Name), 1, NameMask, 1) then
if (SR.Attr and faDirectory) <> 0 then
FileList.Add( NewFile + PathDelim )
else
FileList.Add( NewFile );
Found := FindNext( SR );
end;
finally
FindClose( SR );
end;
end;
if not Recurse then
Exit;
NewFile := ExtractFilePath( FileMask );
if ( NewFile <> '' ) and ( NewFile[Length(NewFile)] <> AbPathDelim) then
NewFile := NewFile + AbPathDelim;
NewFile := NewFile + AbAnyFile;
Found := FindFirst( NewFile, faDirectory or SearchAttr, SR );
if Found = 0 then begin
try
while ( Found = 0 ) do begin
if ( SR.Name <> AbThisDir ) and
( SR.Name <> AbParentDir ) and
((SR.Attr and faDirectory) > 0 ) then
AbFindFiles( ExtractFilePath( NewFile ) + SR.Name + AbPathDelim +
ExtractFileName( FileMask ), SearchAttr,
FileList, True );
Found := FindNext( SR );
end;
finally
FindClose( SR );
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure AbFindFilesEx( const FileMask : string; SearchAttr : Integer;
FileList : TStrings; Recurse : Boolean );
var
I, J: Integer;
MaskPart: string;
begin
I := 1;
while I <= Length(FileMask) do begin
J := I;
while (I <= Length(FileMask)) and (FileMask[I] <> AbPathSep) do Inc(I);
MaskPart := Trim(Copy(FileMask, J, I - J));
if (I <= Length(FileMask)) and (FileMask[I] = AbPathSep) then Inc(I);
AbFindFiles(MaskPart, SearchAttr, FileList, Recurse);
end;
end;
{ -------------------------------------------------------------------------- }
function AbAddBackSlash(const DirName : string) : string;
{ Add a default slash to a directory name }
const
AbDelimSet : set of AnsiChar = [AbPathDelim, ':', #0];
begin
Result := DirName;
if Length(DirName) = 0 then
Exit;
if not CharInSet(DirName[Length(DirName)], AbDelimSet) then
Result := DirName + AbPathDelim;
end;
{ -------------------------------------------------------------------------- }
function AbFindNthSlash( const Path : string; n : Integer ) : Integer;
{ return the position of the character just before the nth slash }
var
i : Integer;
Len : Integer;
iSlash : Integer;
begin
Len := Length( Path );
Result := Len;
iSlash := 0;
i := 0;
while i <= Len do begin
if Path[i] = AbPathDelim then begin
inc( iSlash );
if iSlash = n then begin
Result := pred( i );
break;
end;
end;
inc( i );
end;
end;
{ -------------------------------------------------------------------------- }
function AbGetPathType( const Value : string ) : TAbPathType;
{ returns path type - none, relative or absolute }
begin
Result := ptNone;
{$IFDEF MSWINDOWS}
{check for drive/unc info}
if ( Pos( '\\', Value ) > 0 ) or ( Pos( ':', Value ) > 0 ) then
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
{ UNIX absolute paths start with a slash }
if (Value[1] = AbPathDelim) then
{$ENDIF UNIX}
Result := ptAbsolute
else if ( Pos( AbPathDelim, Value ) > 0 ) or ( Pos( AB_ZIPPATHDELIM, Value ) > 0 ) then
Result := ptRelative;
end;
{ -------------------------------------------------------------------------- }
{$IFDEF MSWINDOWS}
{$WARN SYMBOL_PLATFORM OFF}
function AbGetShortFileSpec(const LongFileSpec : string ) : string;
var
SR : TSearchRec;
Search : string;
Drive : string;
Path : string;
FileName : string;
Found : Integer;
SubPaths : TStrings;
i : Integer;
begin
AbParseFileName( LongFileSpec, Drive, Path, FileName );
SubPaths := TStringList.Create;
try
AbParsePath( Path, SubPaths );
Search := Drive;
Result := Search + AbPathDelim;
if SubPaths.Count > 0 then
for i := 0 to pred( SubPaths.Count ) do begin
Search := Search + AbPathDelim + SubPaths[i];
Found := FindFirst( Search, faHidden + faSysFile + faDirectory, SR );
if Found <> 0 then
raise EAbException.Create( 'Path not found' );
try
Result := Result + ExtractShortName(SR) + AbPathDelim;
finally
FindClose( SR );
end;
end;
Search := Search + AbPathDelim + FileName;
Found := FindFirst( Search,
faReadOnly + faHidden + faSysFile + faArchive, SR );
if Found <> 0 then
raise EAbFileNotFound.Create;
try
Result := Result + ExtractShortName(SR);
finally
FindClose( SR );
end;
finally
SubPaths.Free;
end;
end;
{$WARN SYMBOL_PLATFORM ON}
{$ENDIF}
{ -------------------------------------------------------------------------- }
procedure AbIncFilename( var Filename : string; Value : Word );
{ place value at the end of filename, e.g. Files.C04 }
var
Ext : string;
I : Word;
begin
I := (Value + 1) mod 100;
Ext := ExtractFileExt(Filename);
if (Length(Ext) < 2) then
Ext := '.' + Format('%.2d', [I])
else
Ext := Ext[1] + Ext[2] + Format('%.2d', [I]);
Filename := ChangeFileExt(Filename, Ext);
end;
{ -------------------------------------------------------------------------- }
procedure AbParseFileName( FileSpec : string;
out Drive : string;
out Path : string;
out FileName : string );
var
i : Integer;
iColon : Integer;
iStartSlash : Integer;
begin
if Pos( AB_ZIPPATHDELIM, FileSpec ) > 0 then
AbUnfixName( FileSpec );
FileName := ExtractFileName( FileSpec );
Path := ExtractFilePath( FileSpec );
{see how much of the path currently exists}
iColon := Pos( ':', Path );
if Pos( '\\', Path ) > 0 then begin
{UNC Path \\computername\sharename\path1..\pathn}
{everything up to the 4th slash is the drive}
iStartSlash := 4;
i := AbFindNthSlash( Path, iStartSlash );
Drive := Copy( Path, 1, i );
Delete( Path, 1, i + 1 );
end
else if iColon > 0 then begin
Drive := Copy( Path, 1, iColon );
Delete( Path, 1, iColon );
if Path[1] = AbPathDelim then
Delete( Path, 1, 1 );
end;
end;
{ -------------------------------------------------------------------------- }
procedure AbParsePath( Path : string; SubPaths : TStrings );
{ break abart path into subpaths --- Path : abbrevia/examples >
SubPaths[0] = abbrevia
SubPaths[1] = examples}
var
i : Integer;
iStart : Integer;
iStartSlash : Integer;
SubPath : string;
begin
if Path = '' then Exit;
if Path[ Length( Path ) ] = AbPathDelim then
Delete( Path, Length( Path ), 1 );
iStart := 1;
iStartSlash := 1;
repeat
{find the Slash at iStartSlash}
i := AbFindNthSlash( Path, iStartSlash );
{get the subpath}
SubPath := Copy( Path, iStart, i - iStart + 1 );
iStart := i + 2;
inc( iStartSlash );
SubPaths.Add( SubPath );
until ( i = Length( Path ) );
end;
{ -------------------------------------------------------------------------- }
function AbPatternMatch(const Source : string; iSrc : Integer;
const Pattern : string; iPat : Integer ) : Boolean;
{ recursive routine to see if the source string matches
the pattern. Both ? and * wildcard characters are allowed.
Compares Source from iSrc to Length(Source) to
Pattern from iPat to Length(Pattern)}
var
Matched : Boolean;
k : Integer;
begin
if Length( Source ) = 0 then begin
Result := Length( Pattern ) = 0;
Exit;
end;
if iPat = 1 then begin
if ( CompareStr( Pattern, AbDosAnyFile) = 0 ) or
( CompareStr( Pattern, AbUnixAnyFile ) = 0 ) then begin
Result := True;
Exit;
end;
end;
if Length( Pattern ) = 0 then begin
Result := (Length( Source ) - iSrc + 1 = 0);
Exit;
end;
while True do begin
if ( Length( Source ) < iSrc ) and
( Length( Pattern ) < iPat ) then begin
Result := True;
Exit;
end;
if Length( Pattern ) < iPat then begin
Result := False;
Exit;
end;
if Pattern[iPat] = '*' then begin
k := iPat;
if ( Length( Pattern ) < iPat + 1 ) then begin
Result := True;
Exit;
end;
while True do begin
Matched := AbPatternMatch( Source, k, Pattern, iPat + 1 );
if Matched or ( Length( Source ) < k ) then begin
Result := Matched;
Exit;
end;
inc( k );
end;
end
else begin
if ( (Pattern[iPat] = '?') and
( Length( Source ) <> iSrc - 1 ) ) or
( Pattern[iPat] = Source[iSrc] ) then begin
inc( iPat );
inc( iSrc );
end
else begin
Result := False;
Exit;
end;
end;
end;
end;
{ -------------------------------------------------------------------------- }
function AbPercentage(V1, V2 : Int64) : Byte;
{ Returns the ratio of V1 to V2 * 100 }
begin
if V2 <= 0 then
Result := 0
else if V1 >= V2 then
Result := 100
else
Result := (V1 * 100) div V2;
end;
{ -------------------------------------------------------------------------- }
procedure AbStripDots( var FName : string );
{ strips relative path information, e.g. ".."}
begin
while Pos( AbParentDir + AbPathDelim, FName ) = 1 do
System.Delete( FName, 1, 3 );
end;
{ -------------------------------------------------------------------------- }
procedure AbStripDrive( var FName : string );
{ strips the drive off a filename }
var
Drive, Path, Name : string;
begin
AbParseFileName( FName, Drive, Path, Name );
FName := Path + Name;
end;
{ -------------------------------------------------------------------------- }
procedure AbFixName( var FName : string );
{ changes backslashes to forward slashes }
var
i : Integer;
begin
for i := 1 to Length( FName ) do
if FName[i] = AbPathDelim then
FName[i] := AB_ZIPPATHDELIM;
end;
{ -------------------------------------------------------------------------- }
procedure AbUnfixName( var FName : string );
{ changes forward slashes to backslashes }
var
i : Integer;
begin
for i := 1 to Length( FName ) do
if FName[i] = AB_ZIPPATHDELIM then
FName[i] := AbPathDelim;
end;
{ -------------------------------------------------------------------------- }
procedure AbUpdateCRC( var CRC : LongInt; const Buffer; Len : Integer );
var
BufPtr : PByte;
i : Integer;
CRCTemp : DWORD;
begin
BufPtr := @Buffer;
CRCTemp := CRC;
for i := 0 to pred( Len ) do
begin
CRCTemp := AbCrc32Table[ Byte(CrcTemp) xor (BufPtr^) ] xor
((CrcTemp shr 8) and $00FFFFFF);
Inc(BufPtr);
end;
CRC := CRCTemp;
end;
{ -------------------------------------------------------------------------- }
function AbUpdateCRC32(CurByte : Byte; CurCrc : LongInt) : LongInt;
{ Return the updated 32bit CRC }
{ Normally a good candidate for basm, but Delphi32's code
generation couldn't be beat on this one!}
begin
Result := DWORD(AbCrc32Table[ Byte(CurCrc xor LongInt( CurByte ) ) ] xor
((CurCrc shr 8) and DWORD($00FFFFFF)));
end;
{ -------------------------------------------------------------------------- }
function AbCRC32Of( const aValue : RawByteString ) : LongInt;
begin
Result := -1;
AbUpdateCRC(Result, aValue[1], Length(aValue));
Result := not Result;
end;
{ -------------------------------------------------------------------------- }
function AbWriteVolumeLabel(const VolName : string;
Drive : Char) : Cardinal;
var
Temp : string;
Vol : array[0..11] of Char;
Root : array[0..3] of Char;
begin
Temp := VolName;
StrCopy(Root, '%:' + AbPathDelim);
Root[0] := Drive;
if Length(Temp) > 11 then
SetLength(Temp, 11);
StrPCopy(Vol, Temp);
{$IFDEF MSWINDOWS}
if Windows.SetVolumeLabel(Root, Vol) then
Result := 0
else Result := GetLastError;
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
{ Volume labels not supported on Unix }
Result := 0;
{$ENDIF UNIX}
end;
{ -------------------------------------------------------------------------- }
{$IFDEF MSWINDOWS}
function AbOffsetFromUTC: LongInt;
{ local timezone's offset from UTC in seconds (UTC = local + bias) }
var
TZI: TTimeZoneInformation;
begin
case GetTimeZoneInformation(TZI) of
TIME_ZONE_ID_UNKNOWN:
Result := TZI.Bias;
TIME_ZONE_ID_DAYLIGHT:
Result := TZI.Bias + TZI.DaylightBias;
TIME_ZONE_ID_STANDARD:
Result := TZI.Bias + TZI.StandardBias
else
Result := 0
end;
Result := Result * SecondsInMinute;
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
function AbUnixTimeToLocalDateTime(UnixTime : LongInt) : TDateTime;
{ convert UTC unix date to Delphi TDateTime in local timezone }
{$IFDEF MSWINDOWS}
var
Hrs, Mins, Secs : Word;
TodaysSecs : LongInt;
Time: TDateTime;
begin
UnixTime := UnixTime - AbOffsetFromUTC;
TodaysSecs := UnixTime mod SecondsInDay;
Hrs := TodaysSecs div SecondsInHour;
TodaysSecs := TodaysSecs - (Hrs * SecondsInHour);
Mins := TodaysSecs div SecondsInMinute;
Secs := TodaysSecs - (Mins * SecondsInMinute);
if TryEncodeTime(Hrs, Mins, Secs, 0, Time) then
Result := Unix0Date + (UnixTime div SecondsInDay) + Time
else
Result := 0;
{$ENDIF}
{$IFDEF UNIX}
begin
Result := FileDateToDateTime(UnixTime);
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function AbLocalDateTimeToUnixTime(DateTime : TDateTime) : LongInt;
{ convert local Delphi TDateTime to UTC unix date }
{$IFDEF MSWINDOWS}
var
Hrs, Mins, Secs, MSecs : Word;
Dt, Tm : TDateTime;
begin
Dt := Trunc(DateTime);
Tm := DateTime - Dt;
if Dt < Unix0Date then
Result := 0
else
Result := Trunc(Dt - Unix0Date) * SecondsInDay;
DecodeTime(Tm, Hrs, Mins, Secs, MSecs);
Result := Result + (Hrs * SecondsInHour) + (Mins * SecondsInMinute) + Secs;
Result := Result + AbOffsetFromUTC;
{$ENDIF}
{$IFDEF UNIX}
begin
Result := DateTimeToFileDate(DateTime);
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function AbDosFileDateToDateTime(FileDate, FileTime : Word) : TDateTime;
{$IFDEF MSWINDOWS}
var
Temp : LongInt;
begin
LongRec(Temp).Lo := FileTime;
LongRec(Temp).Hi := FileDate;
Result := FileDateToDateTime(Temp);
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
var
Yr, Mo, Dy : Word;
Hr, Mn, S : Word;
begin
Yr := FileDate shr 9 + 1980;
Mo := FileDate shr 5 and 15;
if Mo < 1 then Mo := 1;
if Mo > 12 then Mo := 12;
Dy := FileDate and 31;
if Dy < 1 then Dy := 1;
if Dy > DaysInAMonth(Yr, Mo) then
Dy := DaysInAMonth(Yr, Mo);
Hr := FileTime shr 11;
if Hr > 23 then Hr := 23;
Mn := FileTime shr 5 and 63;
if Mn > 59 then Mn := 59;
S := FileTime and 31 shl 1;
if S > 59 then S := 59;
Result :=
EncodeDate(Yr, Mo, Dy) +
EncodeTime(Hr, Mn, S, 0);
{$ENDIF UNIX}
end;
function AbDateTimeToDosFileDate(Value : TDateTime) : LongInt;
{$IFDEF MSWINDOWS}
begin
Result := DateTimeToFileDate(Value);
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
var
Yr, Mo, Dy : Word;
Hr, Mn, S, MS: Word;
begin
DecodeDate(Value, Yr, Mo, Dy);
if (Yr < 1980) or (Yr > 2107) then { outside DOS file date year range }
Yr := 1980;
DecodeTime(Value, Hr, Mn, S, MS);
LongRec(Result).Lo := (S shr 1) or (Mn shl 5) or (Hr shl 11);
LongRec(Result).Hi := Dy or (Mo shl 5) or (Word(Yr - 1980) shl 9);
{$ENDIF UNIX}
end;
{ -------------------------------------------------------------------------- }
function AbGetFileTime(const aFileName: string): TDateTime;
var
Attr: TAbAttrExRec;
begin
AbFileGetAttrEx(aFileName, Attr);
Result := Attr.Time;
end;
function AbSetFileTime(const aFileName: string; aValue: TDateTime): Boolean;
begin
{$IFDEF MSWINDOWS}
Result := FileSetDate(aFileName, AbDateTimeToDosFileDate(aValue)) = 0;
{$ENDIF}
{$IFDEF UNIX}
Result := FileSetDate(aFileName, AbLocalDateTimeToUnixTime(aValue)) = 0;
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function AbSwapLongEndianness(Value : LongInt): LongInt;
{ convert BigEndian <-> LittleEndian 32-bit value }
type
TCastArray = array [0..3] of Byte;
var
i : Integer;
begin
for i := 3 downto 0 do
TCastArray(Result)[3-i] := TCastArray(Value)[i];
end;
{ -------------------------------------------------------------------------- }
function AbDOS2UnixFileAttributes(Attr: LongInt): LongInt;
begin
{$WARN SYMBOL_PLATFORM OFF}
Result := { default permissions }
AB_FPERMISSION_OWNERREAD or
AB_FPERMISSION_GROUPREAD or
AB_FPERMISSION_OTHERREAD;
if (Attr and faReadOnly) = 0 then
Result := Result or AB_FPERMISSION_OWNERWRITE;
if (Attr and faDirectory) <> 0 then
Result := Result or AB_FMODE_DIR or AB_FPERMISSION_OWNEREXECUTE or
AB_FPERMISSION_GROUPEXECUTE or AB_FPERMISSION_OTHEREXECUTE
else
Result := Result or AB_FMODE_FILE;
{$WARN SYMBOL_PLATFORM ON}
end;
{ -------------------------------------------------------------------------- }
function AbUnix2DosFileAttributes(Attr: LongInt): LongInt;
begin
{$WARN SYMBOL_PLATFORM OFF}
Result := 0;
case (Attr and $F000) of
AB_FMODE_FILE, AB_FMODE_FILE2: { standard file }
Result := 0;
AB_FMODE_DIR: { directory }
Result := Result or faDirectory;
AB_FMODE_FIFO,
AB_FMODE_CHARSPECFILE,
AB_FMODE_BLOCKSPECFILE,
AB_FMODE_FILELINK,
AB_FMODE_SOCKET:
Result := Result or faSysFile;
end;
if (Attr and AB_FPERMISSION_OWNERWRITE) <> AB_FPERMISSION_OWNERWRITE then
Result := Result or faReadOnly;
{$WARN SYMBOL_PLATFORM ON}
end;
{ -------------------------------------------------------------------------- }
procedure AbSetFileAttr(const aFileName : string; aAttr: Integer);
begin
{$WARN SYMBOL_PLATFORM OFF}
{$IFDEF MSWINDOWS}
FileSetAttr(aFileName, aAttr);
{$ENDIF}
{$IF DEFINED(LibcAPI) OR DEFINED(PosixAPI)}
chmod(PAnsiChar(AbSysString(aFileName)), aAttr);
{$ELSEIF DEFINED(FPCUnixAPI)}
fpchmod(aFileName, aAttr);
{$IFEND}
{$WARN SYMBOL_PLATFORM ON}
end;
{ -------------------------------------------------------------------------- }
function AbFileGetSize(const aFileName : string) : Int64;
var
SR: TAbAttrExRec;
begin
if AbFileGetAttrEx(aFileName, SR) then
Result := SR.Size
else
Result := -1;
end;
{ -------------------------------------------------------------------------- }
function AbFileGetAttrEx(const aFileName: string; out aAttr: TAbAttrExRec) : Boolean;
var
{$IFDEF MSWINDOWS}
FileDate: LongRec;
FindData: TWin32FindData;
LocalFileTime: TFileTime;
{$ENDIF}
{$IFDEF FPCUnixAPI}
StatBuf: stat;
{$ENDIF}
{$IFDEF LibcAPI}
StatBuf: TStatBuf64;
{$ENDIF}
{$IFDEF PosixAPI}
StatBuf: _stat;
{$ENDIF}
begin
aAttr.Time := 0;
aAttr.Size := -1;
aAttr.Attr := -1;
aAttr.Mode := 0;
{$IFDEF MSWINDOWS}
Result := GetFileAttributesEx(PChar(aFileName), GetFileExInfoStandard, @FindData);
if Result then begin
if FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime) and
FileTimeToDosDateTime(LocalFileTime, FileDate.Hi, FileDate.Lo) then
aAttr.Time := FileDateToDateTime(Integer(FileDate));
LARGE_INTEGER(aAttr.Size).LowPart := FindData.nFileSizeLow;
LARGE_INTEGER(aAttr.Size).HighPart := FindData.nFileSizeHigh;
aAttr.Attr := FindData.dwFileAttributes;
aAttr.Mode := AbDOS2UnixFileAttributes(FindData.dwFileAttributes);
end;
{$ENDIF}
{$IFDEF UNIX}
{$IFDEF FPCUnixAPI}
Result := (FpStat(aFileName, StatBuf) = 0);
{$ENDIF}
{$IFDEF LibcAPI}
// Work around Kylix QC#2761: Stat64, et al., are defined incorrectly
Result := (__lxstat64(_STAT_VER, PAnsiChar(aFileName), StatBuf) = 0);
{$ENDIF}
{$IFDEF PosixAPI}
Result := (stat(PAnsiChar(AbSysString(aFileName)), StatBuf) = 0);
{$ENDIF}
if Result then begin
aAttr.Time := FileDateToDateTime(StatBuf.st_mtime);
aAttr.Size := StatBuf.st_size;
aAttr.Attr := AbUnix2DosFileAttributes(StatBuf.st_mode);
aAttr.Mode := StatBuf.st_mode;
end;
{$ENDIF UNIX}
end;
const
MAX_VOL_LABEL = 16;
function AbGetVolumeLabel(Drive : Char) : string;
{-Get the volume label for the specified drive.}
{$IFDEF MSWINDOWS}
var
Root : string;
Flags, MaxLength : DWORD;
NameSize : Integer;
VolName : string;
{$ENDIF}
begin
{$IFDEF MSWINDOWS}
NameSize := 0;
Root := Drive + ':\';
SetLength(VolName, MAX_VOL_LABEL);
Result := '';
if GetVolumeInformation(PChar(Root), PChar(VolName), Length(VolName),
nil, MaxLength, Flags, nil, NameSize)
then
Result := VolName;
{$ELSE}
Result := ''; //Stop Gap, spanning support needs to be rethought for Unix
{$ENDIF}
end;
procedure AbSetSpanVolumeLabel(Drive: Char; VolNo : Integer);
begin
AbWriteVolumeLabel(Format(AB_SPAN_VOL_LABEL,
[VolNo]), Drive);
end;
function AbTestSpanVolumeLabel(Drive: Char; VolNo : Integer): Boolean;
var
VolLabel, TestLabel : string;
begin
TestLabel := Format(AB_SPAN_VOL_LABEL, [VolNo]);
VolLabel := UpperCase(AbGetVolumeLabel(Drive));
Result := VolLabel = TestLabel;
end;
{ Unicode backwards compatibility functions }
{$IFNDEF UNICODE}
function CharInSet(C: AnsiChar; CharSet: TSysCharSet): Boolean;
begin
Result := C in CharSet;
end;
{$ENDIF}
function AbLeftStr(const AText: AnsiString; const ACount: Integer): AnsiString;
begin
{$IFDEF HasAnsiStrings}
Result := System.AnsiStrings.LeftStr(AText, ACount);
{$ELSE}
Result := StrUtils.LeftStr(AText, ACount);
{$ENDIF}
end;
function AbStrLen(const Str: PAnsiChar): Cardinal;
begin
{$IFDEF HasAnsiStrings}
Result := System.AnsiStrings.StrLen(Str);
{$ELSE}
Result := SysUtils.StrLen(Str);
{$ENDIF}
end;
function AbStrPCopy(Dest: PAnsiChar; const Source: AnsiString): PAnsiChar;
begin
{$IFDEF HasAnsiStrings}
Result := System.AnsiStrings.StrPCopy(Dest, Source);
{$ELSE}
Result := SysUtils.StrPCopy(Dest, Source);
{$ENDIF}
end;
function AbStrPLCopy(Dest: PAnsiChar; const Source: AnsiString; MaxLen: Cardinal): PAnsiChar;
begin
{$IFDEF HasAnsiStrings}
Result := System.AnsiStrings.StrPLCopy(Dest, Source, MaxLen);
{$ELSE}
Result := SysUtils.StrPLCopy(Dest, Source, MaxLen);
{$ENDIF}
end;
end.
================================================
FILE: lib/abbrevia/source/AbVMStrm.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbVMStrm.pas *}
{*********************************************************}
{* ABBREVIA: Virtual Memory Stream *}
{*********************************************************}
unit AbVMStrm;
{$I AbDefine.inc}
interface
uses
Classes;
const
AB_VMSPageSize = 4096; {must be a power of two}
AB_VMSMaxPages = 2048; {makes 8MB with the above value}
type
PvmsPage = ^TvmsPage;
TvmsPage = packed record
vpStmOfs : Int64; {value will be multiple of AB_VMSPageSize}
vpLRU : integer; {'time' page was last accessed}
vpDirty : Boolean; {has the page been changed?}
vpData : array [0..pred(AB_VMSPageSize)] of byte; {stream data}
end;
type
TAbVirtualMemoryStream = class(TStream)
protected {private}
vmsCachePage : PvmsPage; {the latest page used}
vmsLRU : Longint; {'tick' value}
vmsMaxMemToUse : Longword; {maximum memory to use for data}
vmsMaxPages : Integer; {maximum data pages}
vmsPageList : TList; {page array, sorted by offset}
vmsPosition : Int64; {position of stream}
vmsSize : Int64; {size of stream}
vmsSwapFileDir : string; {swap file directory}
vmsSwapFileName : string; {swap file name}
vmsSwapFileSize : Int64; {size of swap file}
vmsSwapStream : TFileStream;{swap file stream}
protected
procedure vmsSetMaxMemToUse(aNewMem : Longword);
function vmsAlterPageList(aNewMem : Longword) : Longword;
procedure vmsFindOldestPage(out OldestInx : Longint;
out OldestPage: PvmsPage);
function vmsGetNextLRU : Longint;
function vmsGetPageForOffset(aOffset : Int64) : PvmsPage;
procedure vmsSwapFileCreate;
procedure vmsSwapFileDestroy;
procedure vmsSwapFileRead(aPage : PvmsPage);
procedure vmsSwapFileWrite(aPage : PvmsPage);
public
constructor Create;
{-create the virtual memory stream}
destructor Destroy; override;
{-destroy the virtual memory stream}
function Read(var Buffer; Count : Longint) : Longint; override;
{-read from the stream into a buffer}
function Write(const Buffer; Count : Longint) : Longint; override;
{-write to the stream from a buffer}
function Seek(const Offset : Int64; Origin : TSeekOrigin) : Int64; override;
{-seek to a particular point in the stream}
procedure SetSize(const NewSize : Int64); override;
{-set the stream size}
property MaxMemToUse : Longword
read vmsMaxMemToUse write vmsSetMaxMemToUse;
{-maximum memory to use for data before swapping to disk}
property SwapFileDirectory : string
read vmsSwapFileDir write vmsSwapFileDir;
end;
implementation
uses
{$IFDEF MSWINDOWS}
Windows, // Fix warning about unexpanded inline functions
{$ENDIF}
SysUtils,
AbExcept,
AbUtils;
const
LastLRUValue = $7FFFFFFF;
{===TAbVirtualMemoryStream===========================================}
constructor TAbVirtualMemoryStream.Create;
var
Page : PvmsPage;
begin
inherited Create;
{create the page array}
vmsPageList := TList.Create;
{create the first page}
New(Page);
with Page^ do begin
vpStmOfs := 0;
vpLRU := vmsGetNextLRU;
vpDirty := False;
FillChar(vpData, AB_VMSPageSize, 0);
end;
vmsPageList.Insert(0, pointer(Page));
{prime the cache, from now on the cache will never be nil}
vmsCachePage := Page;
{default to using all allowed pages}
MaxMemToUse := AB_VMSMaxPages * AB_VMSPageSize;
end;
{--------}
destructor TAbVirtualMemoryStream.Destroy;
var
Inx : integer;
begin
{destroy the swap file}
vmsSwapFileDestroy;
{throw away all pages in the list}
if (vmsPageList <> nil) then begin
for Inx := 0 to pred(vmsPageList.Count) do
Dispose(PvmsPage(vmsPageList[Inx]));
vmsPageList.Destroy;
end;
{let our ancestor clean up}
inherited Destroy;
end;
{--------}
function TAbVirtualMemoryStream.Read(var Buffer; Count : Longint) : Longint;
var
BufPtr : PByte;
Page : PvmsPage;
PageDataInx : integer;
Posn : int64;
BytesToGo : int64;
BytesToRead : int64;
StartOfs : int64;
begin
{reading is complicated by the fact we can only read in chunks of
AB_VMSPageSize: we need to partition out the overall read into a read
from a partial page, zero or more reads from complete pages and
then a possible read from a partial page}
{initialise some variables, note that the complex calc in the
expression for PageDataInx is the offset of the start of the page
where Posn is found.}
BufPtr := @Buffer;
Posn := vmsPosition;
PageDataInx := Posn - (Posn and (not pred(AB_VMSPageSize)));
BytesToRead := AB_VMSPageSize - PageDataInx;
{calculate the actual number of bytes to read - this depends on the
current position and size of the stream}
BytesToGo := Count;
if (vmsSize < (vmsPosition + Count)) then
BytesToGo := vmsSize - vmsPosition;
if (BytesToGo < 0) then
BytesToGo := 0;
Result := BytesToGo;
{while we have bytes to read, read them}
while (BytesToGo <> 0) do begin
if (BytesToRead > BytesToGo) then
BytesToRead := BytesToGo;
StartOfs := Posn and (not pred(AB_VMSPageSize));
if (vmsCachePage^.vpStmOfs = StartOfs) then
Page := vmsCachePage
else
Page := vmsGetPageForOffset(StartOfs);
Move(Page^.vpData[PageDataInx], BufPtr^, BytesToRead);
dec(BytesToGo, BytesToRead);
inc(Posn, BytesToRead);
inc(BufPtr, BytesToRead);
PageDataInx := 0;
BytesToRead := AB_VMSPageSize;
end;
{remember our new position}
vmsPosition := Posn;
end;
{--------}
function TAbVirtualMemoryStream.Seek(const Offset : Int64;
Origin : TSeekOrigin) : Int64;
begin
case Origin of
soBeginning : vmsPosition := Offset;
soCurrent : inc(vmsPosition, Offset);
soEnd : vmsPosition := vmsSize + Offset;
else
raise EAbVMSInvalidOrigin.Create( Integer(Origin));
end;
Result := vmsPosition;
end;
{--------}
procedure TAbVirtualMemoryStream.SetSize(const NewSize : Int64);
var
Page : PvmsPage;
Inx : integer;
NewFileSize : Int64;
begin
if (NewSize < vmsSize) then begin
{go through the page list discarding pages whose offset is greater
than our new size; don't bother saving any data from them since
it be beyond the end of the stream anyway}
{never delete the last page here}
for Inx := pred(vmsPageList.Count) downto 1 do begin
Page := PvmsPage(vmsPageList[Inx]);
if (Page^.vpStmOfs >= NewSize) then begin
Dispose(Page);
vmsPageList.Delete(Inx);
end else begin
Break;
end;
end;
{ Reset cache to the first page in case the cached page was deleted. }
vmsCachePage := vmsPageList[0];
{force the swap file file size in range, it'll be a multiple of
AB_VMSPageSize}
NewFileSize := pred(NewSize + AB_VMSPageSize) and
(not pred(AB_VMSPageSize));
if (NewFileSize < vmsSwapFileSize) then
vmsSwapFileSize := NewFileSize;
{ignore the swap file itself}
end;
vmsSize := NewSize;
if (vmsPosition > NewSize) then
vmsPosition := NewSize;
end;
{--------}
function TAbVirtualMemoryStream.vmsAlterPageList(aNewMem : Longword) : Longword;
var
NumPages : Longint;
Page : PvmsPage;
i : integer;
OldestPageNum : Longint;
begin
{calculate the max number of pages required}
if aNewMem = 0 then
NumPages := 1 // always have at least one page
else
NumPages := pred(aNewMem + AB_VMSPageSize) div AB_VMSPageSize;
if (NumPages > AB_VMSMaxPages) then
NumPages := AB_VMSMaxPages;
{if the maximum number of pages means we have to shrink the current
list, do so, tossing out the oldest pages first}
if (NumPages < vmsPageList.Count) then
begin
for i := 1 to (vmsPageList.Count - NumPages) do begin
{find the oldest page}
vmsFindOldestPage(OldestPageNum, Page);
{if it is dirty, write it out to the swap file}
if Page^.vpDirty then begin
vmsSwapFileWrite(Page);
end;
{remove it from the page list}
vmsPageList.Delete(OldestPageNum);
{free the page memory}
Dispose(Page);
end;
{ Reset cache to the first page in case the cached page was deleted. }
vmsCachePage := vmsPageList[0];
end;
{remember our new max number of pages}
vmsMaxPages := NumPages;
Result := NumPages * AB_VMSPageSize;
end;
{--------}
procedure TAbVirtualMemoryStream.vmsFindOldestPage(out OldestInx : Longint;
out OldestPage: PvmsPage);
var
OldestLRU : Longint;
Inx : integer;
Page : PvmsPage;
begin
OldestInx := -1;
OldestLRU := LastLRUValue;
for Inx := 0 to pred(vmsPageList.Count) do begin
Page := PvmsPage(vmsPageList[Inx]);
if (Page^.vpLRU < OldestLRU) then begin
OldestInx := Inx;
OldestLRU := Page^.vpLRU;
OldestPage := Page;
end;
end;
end;
{--------}
function TAbVirtualMemoryStream.vmsGetNextLRU : Longint;
var
Inx : integer;
begin
if (vmsLRU = LastLRUValue) then begin
{reset all LRUs in list}
for Inx := 0 to pred(vmsPageList.Count) do
PvmsPage(vmsPageList[Inx])^.vpLRU := 0;
vmsLRU := 0;
end;
inc(vmsLRU);
Result := vmsLRU;
end;
{--------}
function TAbVirtualMemoryStream.vmsGetPageForOffset(aOffset : Int64) : PvmsPage;
var
Page : PvmsPage;
PageOfs : Int64;
L, M, R : integer;
OldestPageNum : integer;
CreatedNewPage: boolean;
begin
{using a sequential or a binary search (depending on the number of
pages), try to find the page in the cache; we'll do a sequential
search if the number of pages is very small, eg less than 4}
if (vmsPageList.Count < 4) then begin
L := vmsPageList.Count;
for M := 0 to pred(vmsPageList.Count) do begin
Page := PvmsPage(vmsPageList[M]);
PageOfs := Page^.vpStmOfs;
if (aOffset < PageOfs) then begin
L := M;
Break;
end;
if (aOffset = PageOfs) then begin
Page^.vpLRU := vmsGetNextLRU;
vmsCachePage := Page;
Result := Page;
Exit;
end;
end;
end
else {we need to do a binary search} begin
L := 0;
R := pred(vmsPageList.Count);
repeat
M := (L + R) div 2;
Page := PvmsPage(vmsPageList[M]);
PageOfs := Page^.vpStmOfs;
if (aOffset < PageOfs) then
R := pred(M)
else if (aOffset > PageOfs) then
L := succ(M)
else {aOffset = PageOfs} begin
Page^.vpLRU := vmsGetNextLRU;
vmsCachePage := Page;
Result := Page;
Exit;
end;
until (L > R);
end;
{if we get here the page for the offset is not present in the page
list, and once created/loaded, the page should be inserted at L}
{enter a try..except block so that if a new page is created and an
exception occurs, the page is freed}
CreatedNewPage := false;
Result := nil;
try
{if there is room to insert a new page, create one ready}
if (vmsPageList.Count < vmsMaxPages) then begin
New(Page);
CreatedNewPage := true;
end
{otherwise there is no room for the insertion, so find the oldest
page in the list and discard it}
else {vmsMaxPages <= vmsPageList.Count} begin
{find the oldest page}
vmsFindOldestPage(OldestPageNum, Page);
{if it is dirty, write it out to the swap file}
if Page^.vpDirty then begin
vmsSwapFileWrite(Page);
end;
{remove it from the page list}
vmsPageList.Delete(OldestPageNum);
{patch up the insertion point, in case the page just deleted was
before it}
if (OldestPageNum < L) then
dec(L);
end;
{set all the page fields}
with Page^ do begin
vpStmOfs := aOffset;
vpLRU := vmsGetNextLRU;
vpDirty := False;
vmsSwapFileRead(Page);
end;
{insert the page into the correct spot}
vmsPageList.Insert(L, pointer(Page));
{return the page, remembering to save it in the cache}
vmsCachePage := Page;
Result := Page;
except
if CreatedNewPage then
Dispose(Page);
end;{try..except}
end;
{--------}
procedure TAbVirtualMemoryStream.vmsSetMaxMemToUse(aNewMem : Longword);
begin
vmsMaxMemToUse := vmsAlterPageList(aNewMem);
end;
{--------}
procedure TAbVirtualMemoryStream.vmsSwapFileCreate;
begin
if (vmsSwapStream = nil) then begin
vmsSwapFileName := AbCreateTempFile(vmsSwapFileDir);
try
vmsSwapStream := TFileStream.Create(vmsSwapFileName, fmCreate);
except
DeleteFile(vmsSwapFileName);
raise EAbVMSErrorOpenSwap.Create( vmsSwapFileName );
end;
vmsSwapFileSize := 0;
end;
end;
{--------}
procedure TAbVirtualMemoryStream.vmsSwapFileDestroy;
begin
if (vmsSwapStream <> nil) then begin
FreeAndNil(vmsSwapStream);
DeleteFile(vmsSwapFileName);
end;
end;
{--------}
procedure TAbVirtualMemoryStream.vmsSwapFileRead(aPage : PvmsPage);
var
BytesRead : Longint;
SeekResult: Int64;
begin
if (vmsSwapStream = nil) or (aPage^.vpStmOfs >= vmsSwapFileSize) then begin
{there is nothing to be read from the disk (either the swap file
doesn't exist or it's too small) so zero out the page data}
FillChar(aPage^.vpData, AB_VMSPageSize, 0)
end
else {there is something to be read from the swap file} begin
SeekResult := vmsSwapStream.Seek(aPage^.vpStmOfs, soBeginning);
if (SeekResult = -1) then
raise EAbVMSSeekFail.Create( vmsSwapFileName );
BytesRead := vmsSwapStream.Read(aPage^.vpData, AB_VMSPageSize);
if (BytesRead <> AB_VMSPageSize) then
raise EAbVMSReadFail.Create( AB_VMSPageSize, vmsSwapFileName );
end;
end;
{--------}
procedure TAbVirtualMemoryStream.vmsSwapFileWrite(aPage : PvmsPage);
var
NewPos : Int64;
SeekResult: Int64;
BytesWritten : Longint;
begin
if (vmsSwapStream = nil) then
vmsSwapFileCreate;
SeekResult := vmsSwapStream.Seek(aPage^.vpStmOfs, soBeginning);
if (SeekResult = -1) then
raise EAbVMSSeekFail.Create( vmsSwapFileName );
BytesWritten := vmsSwapStream.Write(aPage^.vpData, AB_VMSPageSize);
if BytesWritten <> AB_VMSPageSize then
raise EAbVMSWriteFail.Create( AB_VMSPageSize, vmsSwapFileName );
NewPos := aPage^.vpStmOfs + AB_VMSPageSize;
if (NewPos > vmsSwapFileSize) then
vmsSwapFileSize := NewPos;
end;
{--------}
function TAbVirtualMemoryStream.Write(const Buffer; Count : Longint) : Longint;
var
BufPtr : PByte;
Page : PvmsPage;
PageDataInx : integer;
Posn : Int64;
BytesToGo : Int64;
BytesToWrite: Int64;
StartOfs : Int64;
begin
{writing is complicated by the fact we can only write in chunks of
AB_VMSPageSize: we need to partition out the overall write into a
write to a partial page, zero or more writes to complete pages and
then a possible write to a partial page}
{initialise some variables, note that the complex calc in the
expression for PageDataInx is the offset of the start of the page
where Posn is found.}
BufPtr := @Buffer;
Posn := vmsPosition;
PageDataInx := Posn - (Posn and (not pred(AB_VMSPageSize)));
BytesToWrite := AB_VMSPageSize - PageDataInx;
{calculate the actual number of bytes to write}
BytesToGo := Count;
Result := BytesToGo;
{while we have bytes to write, write them}
while (BytesToGo <> 0) do begin
if (BytesToWrite > BytesToGo) then
BytesToWrite := BytesToGo;
StartOfs := Posn and (not pred(AB_VMSPageSize));
if (vmsCachePage^.vpStmOfs = StartOfs) then
Page := vmsCachePage
else
Page := vmsGetPageForOffset(StartOfs);
Move(BufPtr^, Page^.vpData[PageDataInx], BytesToWrite);
Page^.vpDirty := True;
dec(BytesToGo, BytesToWrite);
inc(Posn, BytesToWrite);
inc(BufPtr, BytesToWrite);
PageDataInx := 0;
BytesToWrite := AB_VMSPageSize;
end;
{remember our new position}
vmsPosition := Posn;
{if we've grown the stream, make a note of it}
if (vmsPosition > vmsSize) then
vmsSize := vmsPosition;
end;
{====================================================================}
end.
================================================
FILE: lib/abbrevia/source/AbView.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbView.pas *}
{*********************************************************}
{* ABBREVIA: Base archive viewer component *}
{* Use AbQView.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
unit AbView;
{$ENDIF}
{$I AbDefine.inc}
interface
uses
Classes,
Types,
{$IFDEF MSWINDOWS}
Windows,
Messages,
{$ENDIF}
{$IFDEF LibcAPI}
Libc,
{$ENDIF}
{$IFDEF UsingCLX }
Qt,
QControls,
QGraphics,
QGrids,
{$ELSE}
Controls,
Graphics,
Grids,
{$ENDIF}
AbArcTyp;
type
TAbViewAttribute =
(vaItemName, vaPacked, vaMethod, vaRatio, vaCRC,
vaFileAttributes, vaFileType, vaEncryption, vaTimeStamp,
vaFileSize, vaVersionMade, vaVersionNeeded, vaPath);
TAbViewAttributes = set of TAbViewAttribute;
TAbDisplayOption =
(doAlternateColors, doColLines, doColMove, doColSizing, doMultiSelect,
doRowLines, doShowIcons, doThumbTrack, doTrackActiveRow);
TAbDisplayOptions = set of TAbDisplayOption;
TAbSortAttribute =
(saItemName, saPacked, saPath, saRatio, saTimeStamp, saFileSize);
TAbSortAttributes = set of TAbSortAttribute;
const
AbDefColWidth = 150;
AbDefRowHeight = 24;
AbHeaderRow = 0;
AbDefSelColor = clHighlight;
AbDefSelTextColor = clHighlightText;
AbDefHighColor = clAqua;
AbDefHighTextColor = clRed;
AbDefDelColor = clYellow;
AbDefDelTextColor = clNavy;
{ ===== TAbColors ========================================================== }
type
TAbColors = class(TPersistent)
protected {private}
FSelected : TColor;
FSelectedText : TColor;
FAlternate : TColor;
FAlternateText : TColor;
FDeleted : TColor;
FDeletedText : TColor;
FUpdating : Boolean;
FOnChange : TNotifyEvent;
procedure DoOnChange;
procedure SetSelected(Value : TColor);
procedure SetSelectedText(Value : TColor);
procedure SetAlternate(Value : TColor);
procedure SetAlternateText(Value : TColor);
procedure SetDeleted(Value : TColor);
procedure SetDeletedText(Value : TColor);
public
procedure BeginUpdate;
procedure EndUpdate;
property OnChange : TNotifyEvent
read FOnChange
write FOnChange;
published
property Selected : TColor
read FSelected
write SetSelected;
property SelectedText : TColor
read FSelectedText
write SetSelectedText;
property Alternate : TColor
read FAlternate
write SetAlternate;
property AlternateText : TColor
read FAlternateText
write SetAlternateText;
property Deleted : TColor
read FDeleted
write SetDeleted;
property DeletedText : TColor
read FDeletedText
write SetDeletedText;
end;
{ ===== TAbSelList ========================================================= }
type
TAbSelList = class
protected {private}
FList : TList;
FCurrent : Longint;
public {methods}
constructor Create;
destructor Destroy;
override;
procedure Clear;
procedure Deselect(Index : Longint);
function IsSelected(Index : Longint) : Boolean;
procedure Select(Index : Longint);
procedure SelectAll(Count : Longint);
function SelCount : Longint;
procedure Toggle(Index : Longint);
function FindFirst : Longint;
function FindNext : Longint;
end;
{ ===== TAbRowMap ========================================================== }
type
TAbRowMap = class
protected {private}
FRows : TList;
FInvRows : TList;
FSortAscending : Boolean;
function GetRow(RowNum : Longint) : Longint;
function GetInvRow(RowNum : Longint) : Longint;
procedure SortOnItemName(ItemList : TAbArchiveList);
procedure SortOnItemDir(ItemList : TAbArchiveList);
public {methods}
constructor Create;
destructor Destroy;
override;
procedure Clear;
procedure Init(RowCount : Longint);
procedure SortBy(Attr : TAbSortAttribute; ItemList : TAbArchiveList);
public {properties}
property Rows[RowNum : Longint] : Longint
read GetRow; default;
property InvRows[RowNum : Longint] : Longint
read GetInvRow;
property SortAscending : Boolean
read FSortAscending;
end;
{ ===== TAbBaseViewer ==================================================== }
type
TAbColHeadings = class(TStringList)
end;
TAbSortedEvent =
procedure (Sender : TObject; Attr : TAbViewAttribute) of object;
TAbDrawSortArrowEvent =
procedure (Sender : TObject; Column : Integer; Ascending: Boolean;
Cnv: TCanvas; Rect : TRect) of object;
TAbBaseViewer = class(TCustomGrid)
protected {private}
FAllowInvalidate : Boolean;
FAttributes : TAbViewAttributes;
FDisplayOptions : TAbDisplayOptions;
FSortAttributes : TAbSortAttributes;
FColMap : array[TAbViewAttribute] of Integer;
FColSizing : Boolean;
FColMoving : Boolean;
FHeadings : TAbColHeadings;
FItemList : TAbArchiveList;
FRowMap : TAbRowMap;
FFileName : string;
FFontSize : Integer;
FItemIndex : Longint;
FColors : TAbColors;
FButtonDown : Boolean;
FIcons : TStringList;
FSelList : TAbSelList;
FMultiSelecting : Boolean;
FShiftState : TShiftState;
FSortCol : Integer;
RowAnchor : Longint;
ViewMouseCoord : TGridCoord;
FOnChange : TNotifyEvent;
FOnClick : TNotifyEvent;
FOnDblClick : TNotifyEvent;
FOnSorted : TAbSortedEvent;
FOnDrawSortArrow : TAbDrawSortArrowEvent;
function AttrToSortAttribute(Attr : TAbViewAttribute;
var SortAttr : TAbSortAttribute) : Boolean;
function AttrToStr(Attr : TAbViewAttribute; aItem : TAbArchiveItem) : string;
function ColMap(ColNum : Integer) : Integer;
procedure ColorsChange(Sender : TObject);
procedure DrawHeaderButton(ACol : Integer; const AText : string);
procedure DrawSortArrow;
function DrawTextFormat(Attr : TAbViewAttribute; var Rect : TRect) : Word;
function GetCount : Longint;
function GetActiveRow : Longint;
function GetHeaderRowHeight : Integer;
{$IFDEF MSWINDOWS}
function GetIcon(const ItemName : string) : HIcon;
{$ENDIF}
{$IFDEF UsingClx}
{ no file type icons in Clx }
{$ENDIF}
function GetSelCount : Longint;
function GetSelected(RowNum : Longint) : Boolean;
function GetVersion : string;
procedure InitColMap;
procedure InvalidateRow(ARow: Longint);
procedure MoveColumn(FromCol, ToCol : Integer);
procedure RefreshCell(ARow, ACol: Longint);
procedure RefreshRow(ARow: Longint);
procedure SetActiveRow(RowNum : Longint);
procedure SetAttributes(Value : TAbViewAttributes);
procedure SetDisplayOptions(Value : TAbDisplayOptions);
procedure SetSortAttributes(Value : TAbSortAttributes);
procedure SetHeaderRowHeight(Value : Integer);
procedure SetHeadings(Value: TAbColHeadings);
procedure SetSelected(RowNum : Longint; Value : Boolean);
procedure SetVersion(const Value : string);
function UpdateColCount(Attributes : TAbViewAttributes) : Integer;
{$IFDEF UsingCLX}
procedure FontChanged; override;
procedure SizeChanged(OldColCount, OldRowCount: Longint); override;
{$ELSE}
procedure WMSize(var Msg: TWMSize);
message WM_SIZE;
procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd);
message WM_ERASEBKGND;
procedure CMFontChanged(var Message: TMessage);
message CM_FONTCHANGED;
{$ENDIF UsingCLX}
protected {overridden methods}
procedure Click;
override;
procedure DblClick;
override;
procedure KeyDown(var Key: Word; Shift: TShiftState);
override;
procedure KeyUp(var Key: Word; Shift: TShiftState);
override;
procedure Loaded;
override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y : Integer);
override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer);
override;
procedure ColumnMoved(FromIndex, ToIndex: Longint);
override;
{$IFDEF HasGridDrawingStyle}
procedure Paint;
override;
{$ENDIF}
procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
override;
procedure TopLeftChanged;
override;
protected {virtual methods}
procedure DoChange(Sender : TObject);
virtual;
procedure DoLoad(Sender : TObject);
virtual;
procedure DoSorted(Attr : TAbViewAttribute);
virtual;
protected {properties}
property Attributes : TAbViewAttributes
read FAttributes
write SetAttributes;
property DisplayOptions : TAbDisplayOptions
read FDisplayOptions
write SetDisplayOptions;
property HeaderRowHeight : Integer
read GetHeaderRowHeight
write SetHeaderRowHeight;
property Headings : TAbColHeadings
read FHeadings
write SetHeadings;
property ItemList : TAbArchiveList
read FItemList
write FItemList;
property SortAttributes : TAbSortAttributes
read FSortAttributes
write SetSortAttributes;
property Version : string
read GetVersion
write SetVersion
stored False;
protected {events}
property OnChange : TNotifyEvent
read FOnChange
write FOnChange;
property OnClick : TNotifyEvent
read FOnClick
write FOnClick;
property OnDblClick : TNotifyEvent
read FOnDblClick
write FOnDblClick;
property OnSorted : TAbSortedEvent
read FOnSorted
write FOnSorted;
property OnDrawSortArrow : TAbDrawSortArrowEvent
read FOnDrawSortArrow
write FOnDrawSortArrow;
public {methods}
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
procedure BeginUpdate;
procedure EndUpdate;
procedure ClearSelections;
procedure SelectAll;
public {run-time properties}
property ActiveRow : Longint
read GetActiveRow write SetActiveRow;
property Colors : TAbColors
read FColors write FColors;
property Count : Longint
read GetCount;
property SelCount : Longint
read GetSelCount;
property Selected[RowNum : Longint] : Boolean
read GetSelected write SetSelected;
property ColWidths;
property RowHeights;
published
property OnDragDrop;
property OnDragOver;
end;
implementation
uses
{$IFDEF MSWINDOWS}
ShellApi,
{$ENDIF}
{$IFDEF HasUITypes}
UITypes,
{$ENDIF}
SysUtils,
AbUtils,
AbConst,
AbResString,
AbZipTyp;
{ ===== TAbColors ========================================================== }
procedure TAbColors.BeginUpdate;
begin
FUpdating := True;
end;
{ -------------------------------------------------------------------------- }
procedure TAbColors.EndUpdate;
begin
FUpdating := False;
DoOnChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbColors.DoOnChange;
begin
if not FUpdating and Assigned(FOnChange) then
FOnChange(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbColors.SetSelected(Value : TColor);
begin
if (Value <> FSelected) then begin
FSelected := Value;
DoOnChange;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbColors.SetSelectedText(Value : TColor);
begin
if (Value <> FSelectedText) then begin
FSelectedText := Value;
DoOnChange;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbColors.SetAlternate(Value : TColor);
begin
if (Value <> FAlternate) then begin
FAlternate := Value;
DoOnChange;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbColors.SetAlternateText(Value : TColor);
begin
if (Value <> FAlternateText) then begin
FAlternateText := Value;
DoOnChange;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbColors.SetDeleted(Value : TColor);
begin
if (Value <> FDeleted) then begin
FDeleted := Value;
DoOnChange;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbColors.SetDeletedText(Value : TColor);
begin
if (Value <> FDeletedText) then begin
FDeletedText := Value;
DoOnChange;
end;
end;
{ ===== TAbSelList ========================================================= }
constructor TAbSelList.Create;
begin
FList := TList.Create;
FCurrent := -1;
end;
{ -------------------------------------------------------------------------- }
destructor TAbSelList.Destroy;
begin
FList.Free;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbSelList.Clear;
begin
FList.Clear;
FCurrent := -1;
end;
{ -------------------------------------------------------------------------- }
procedure TAbSelList.Select(Index: Longint);
begin
if FList.IndexOf(Pointer(Index)) < 0 then
FList.Add(Pointer(Index));
end;
{ -------------------------------------------------------------------------- }
procedure TAbSelList.Deselect(Index: Longint);
var
i : Longint;
begin
i := FList.IndexOf(Pointer(Index));
if (i >= 0) then
FList.Delete(i);
end;
{ -------------------------------------------------------------------------- }
function TAbSelList.IsSelected(Index : Longint) : Boolean;
begin
Result := FList.IndexOf(Pointer(Index)) >= 0;
end;
{ -------------------------------------------------------------------------- }
procedure TAbSelList.Toggle(Index: Longint);
begin
if IsSelected(Index) then
Deselect(Index)
else
Select(Index);
end;
{ -------------------------------------------------------------------------- }
function TAbSelList.SelCount : Longint;
begin
Result := FList.Count;
end;
{ -------------------------------------------------------------------------- }
procedure TAbSelList.SelectAll(Count : Longint);
var
i : Longint;
begin
for i := 0 to Pred(Count) do
Select(i);
end;
{ -------------------------------------------------------------------------- }
function TAbSelList.FindFirst : Longint;
begin
FCurrent := -1;
if (FList.Count > 0) then
Result := FindNext
else
Result := -1;
end;
{ -------------------------------------------------------------------------- }
function TAbSelList.FindNext : Longint;
begin
if (FList.Count > 0) and (FCurrent < Pred(FList.Count)) then begin
Inc(FCurrent);
Result := Longint(FList[FCurrent]);
end else
Result := -1;
end;
{ ===== TAbRowMap ========================================================== }
procedure TAbRowMap.Clear;
begin
FRows.Clear;
FInvRows.Clear;
end;
{ -------------------------------------------------------------------------- }
function TAbRowMap.GetRow(RowNum : Longint) : Longint;
begin
if (RowNum >= 0) and (RowNum < FRows.Count) then
Result := Longint(FRows[RowNum])
else
Result := 0;
end;
{ -------------------------------------------------------------------------- }
function TAbRowMap.GetInvRow(RowNum : Longint) : Longint;
begin
if (RowNum >= 0) and (RowNum < FInvRows.Count) then
Result := Longint(FInvRows[RowNum])
else
Result := 0;
end;
{ -------------------------------------------------------------------------- }
constructor TAbRowMap.Create;
begin
inherited Create;
FRows := TList.Create;
FInvRows := TList.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbRowMap.Init(RowCount : Longint);
var
i : Longint;
begin
Clear;
if (RowCount > 0) then
for i := 0 to Pred(RowCount) do begin
FRows.Add(Pointer(i));
FInvRows.Add(Pointer(i));
end;
end;
{ -------------------------------------------------------------------------- }
destructor TAbRowMap.Destroy;
begin
FRows.Free;
FInvRows.Free;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbRowMap.SortBy(Attr : TAbSortAttribute; ItemList : TAbArchiveList);
type
PSortRec = ^TSortRec;
TSortRec = record
Val : Double;
Index : Longint;
end;
var
i, LI : Longint;
SL : TList;
RowCount : Longint;
P : PSortRec;
DT : TDateTime;
aItem : TAbArchiveItem;
procedure QuickSort(SL : TList; L, R: Integer);
var
i, j: Integer;
P: PSortRec;
begin
i := L;
j := R;
P := SL[(L + R) shr 1];
repeat
while PSortRec(SL[i])^.Val < P^.Val do Inc(i);
while PSortRec(SL[j])^.Val > P^.Val do Dec(j);
if (i <= j) then
begin
SL.Exchange(i, j);
Inc(i);
Dec(j);
end;
until i > j;
if L < j then QuickSort(SL, L, j);
if i < R then QuickSort(SL, i, R);
end;
begin
if (ItemList.Count <= 0) then
Exit;
case Attr of
saItemName : SortOnItemName(ItemList);
saPath : SortOnItemDir(ItemList);
else begin
RowCount := ItemList.Count;
SL := TList.Create;
try {SL}
SL.Capacity := RowCount;
for i := 0 to Pred(RowCount) do begin
GetMem(P, SizeOf(TSortRec));
aItem := TAbArchiveItem(ItemList.Items[i]);
case Attr of
saPacked : P^.Val := aItem.CompressedSize;
saRatio :
begin
if (aItem is TAbZipItem) then
P^.Val := TAbZipItem(aItem).CompressionRatio
else
P^.Val := 0;
end;
saFileSize : P^.Val := aItem.UnCompressedSize;
saTimeStamp : begin
LI := LongInt(aItem.LastModFileDate) shl 16 +
aItem.LastModFileTime;
DT := FileDateToDateTime(LI);
P^.Val := Double(DT);
end;
end;
P^.Index := i;
SL.Add(P);
end;
QuickSort(SL, 0, Pred(SL.Count));
for i := 0 to Pred(SL.Count) do begin
if FSortAscending then
P := SL[i]
else
P := SL[Pred(SL.Count) - i];
FRows[i] := Pointer(P^.Index)
end;
finally {SL}
while (SL.Count > 0) do begin
FreeMem(SL[0], Sizeof(TSortRec));
SL.Delete(0);
end;
SL.Free;
end; {SL}
end;
end;
FSortAscending := not FSortAscending;
for i := 0 to Pred(ItemList.Count) do
FInvRows[Rows[i]] := Pointer(i);
end;
{ -------------------------------------------------------------------------- }
procedure TAbRowMap.SortOnItemName(ItemList : TAbArchiveList);
var
i, RowCount : Longint;
SL : TStringList;
FN : string;
begin
RowCount := ItemList.Count;
SL := TStringList.Create;
try {SL}
for i := 0 to Pred(RowCount) do begin
FN := TAbArchiveItem(ItemList.Items[i]).Filename;
AbUnFixName(FN);
SL.AddObject(ExtractFilename(FN), Pointer(i));
end;
SL.Sort;
for i := 0 to Pred(RowCount) do begin
if FSortAscending then
FRows[i] := SL.Objects[i]
else
FRows[i] := SL.Objects[Pred(RowCount) - i];
end;
finally {SL}
SL.Free;
end; {SL}
end;
{ -------------------------------------------------------------------------- }
procedure TAbRowMap.SortOnItemDir(ItemList : TAbArchiveList);
var
i, RowCount : Longint;
SL : TStringList;
FN : string;
begin
RowCount := ItemList.Count;
SL := TStringList.Create;
try {SL}
for i := 0 to Pred(RowCount) do begin
FN := TAbArchiveItem(ItemList.Items[i]).DiskPath;
AbUnFixName(FN);
SL.AddObject(ExtractFilePath(FN), Pointer(i));
end;
SL.Sort;
for i := 0 to Pred(RowCount) do begin
if FSortAscending then
FRows[i] := SL.Objects[i]
else
FRows[i] := SL.Objects[Pred(RowCount) - i];
end;
finally {SL}
SL.Free;
end; {SL}
end;
{===== TAbBaseViewer ===============================================}
constructor TAbBaseViewer.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
FItemList := TAbArchiveList.Create(False);
RowCount := 2;
FixedCols := 0;
FixedRows := 1; {Header Row}
FSortCol := -1;
Color := clWindow;
FColors := TAbColors.Create;
FColors.OnChange := ColorsChange;
FColors.Selected := AbDefSelColor;
FColors.SelectedText := AbDefSelTextColor;
FColors.Alternate := AbDefHighColor;
FColors.AlternateText := AbDefHighTextColor;
FColors.Deleted := AbDefDelColor;
FColors.DeletedText := AbDefDelTextColor;
DefaultColWidth := AbDefColWidth;
DefaultRowHeight := AbDefRowHeight;
DefaultDrawing := False;
ParentColor := False;
{$IFNDEF UsingCLX}
ParentCtl3D := True;
{$ENDIF}
ParentFont := True;
ParentShowHint := True;
FHeadings := TAbColHeadings.Create;
InitColMap;
FColSizing := False;
FColMoving := False;
FAllowInvalidate := True;
FRowMap := TAbRowMap.Create;
FIcons := TStringList.Create;
FSelList := TAbSelList.Create;
Attributes := [vaItemname, vaPacked, vaTimeStamp, vaFileSize, vaPath];
SetDisplayOptions([doColSizing]);
Visible := True;
end;
{ -------------------------------------------------------------------------- }
destructor TAbBaseViewer.Destroy;
begin
FRowMap.Free;
FHeadings.Free;
FColors.Free;
FIcons.Free;
FSelList.Free;
FItemList.Free;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseViewer.AttrToSortAttribute(Attr : TAbViewAttribute;
var SortAttr : TAbSortAttribute) : Boolean;
begin
Result := True;
case Attr of
vaItemName : SortAttr := saItemName;
vaPacked : SortAttr := saPacked;
vaFileSize : SortAttr := saFileSize;
vaRatio : SortAttr := saRatio;
vaTimeStamp : SortAttr := saTimeStamp;
vaPath : SortAttr := saPath;
else
Result := False;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseViewer.AttrToStr(Attr : TAbViewAttribute;
aItem : TAbArchiveItem) : string;
var
FN : string;
LI : Longint;
begin
Result := '';
if Attr in [vaItemName, vaPath] then begin
FN := aItem.Filename;
AbUnFixName(FN);
end;
{first take care of common attributes}
with aItem do case Attr of
vaCRC :
Result := IntToHex(CRC32, 8);
vaItemname :
Result := ExtractFilename(FN);
vaPacked :
Result := IntToStr(CompressedSize);
vaFileSize :
Result := IntToStr(UncompressedSize);
vaFileAttributes :
begin
{$IFDEF MSWINDOWS}
{$WARN SYMBOL_PLATFORM OFF}
if (faReadOnly and ExternalFileAttributes) = faReadOnly then
Result := Result + AbReadOnlyS;
if (faHidden and ExternalFileAttributes) = faHidden then
Result := Result + AbHiddenS;
if (faSysFile and ExternalFileAttributes) = faSysFile then
Result := Result + AbSystemS;
if (faArchive and ExternalFileAttributes) = faArchive then
Result := Result + AbArchivedS;
{$WARN SYMBOL_PLATFORM OFF}
{$ENDIF MSWINDOWS}
end;
vaEncryption :
if IsEncrypted then
Result := AbEncryptedS;
vaTimeStamp :
if (LastModFileDate + LastModFileTime = 0) then
Result := AbUnknownS
else begin
LI := LongInt(LastModFileDate) shl 16 + LastModFileTime;
Result := DateTimeToStr(FileDateToDateTime(LI));
end;
vaPath :
Result := DiskPath;
end;
{now handle the zip specific attributes}
if (aItem is TAbZipItem) then with TAbZipItem(aItem) do case Attr of
vaFileType :
if (InternalFileAttributes = 1) then
Result := AbTextS
else
Result := AbBinaryS;
vaMethod :
Result := ZipCompressionMethodToString(CompressionMethod);
vaRatio :
Result := IntToStr(Round(CompressionRatio));
vaVersionMade :
Result := IntToStr(Round(Lo(VersionMadeBy)/ 10.0));
vaVersionNeeded :
Result := IntToStr(Round(Lo(VersionNeededToExtract)/ 10.0));
end;
{$IFDEF LINUX}
Result := ' ' + Result;
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.BeginUpdate;
begin
FAllowInvalidate := False;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.EndUpdate;
begin
FAllowInvalidate := True;
Refresh;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.ClearSelections;
var
i : Longint;
begin
if (FSelList.SelCount > 0) then begin
i := FSelList.FindFirst;
repeat
InvalidateRow(FRowMap.InvRows[i]+1);
i := FSelList.FindNext;
until (i < 0);
FSelList.Clear;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.Click;
{Here is the logic for MultiSelect}
var
i : Longint;
begin
inherited Click;
if Assigned(FItemList) and (FItemList.Count > 0) then begin
if (ssCtrl in FShiftState) and (doMultiSelect in FDisplayOptions) then
Selected[ActiveRow] := not Selected[ActiveRow]
else begin
if not ((ssShift in FShiftState) and
(doMultiSelect in FDisplayOptions)) then begin
ClearSelections;
Selected[ActiveRow] := True;
end else begin
ClearSelections;
if (RowAnchor < ActiveRow) then
for i := RowAnchor to ActiveRow do
Selected[i] := True
else
for i := ActiveRow to RowAnchor do
Selected[i] := True;
end;
end;
Update;
if Assigned(FOnClick) then
FOnClick(Self);
end;
end;
{ -------------------------------------------------------------------------- }
{$IFDEF UsingCLX}
procedure TAbBaseViewer.FontChanged;
{$ELSE}
procedure TAbBaseViewer.CMFontChanged(var Message: TMessage);
{$ENDIF}
begin
inherited;
if not (csLoading in ComponentState) then begin
Canvas.Font := Font;
DefaultRowHeight := Canvas.TextHeight('W') + 2;
HeaderRowHeight := Canvas.TextHeight('W') + 4;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseViewer.ColMap(ColNum : Integer) : Integer;
begin
Result := FColMap[TAbViewAttribute(ColNum)];
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.ColorsChange(Sender : TObject);
begin
Invalidate;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.ColumnMoved(FromIndex, ToIndex : Longint);
begin
MoveColumn(FromIndex, ToIndex);
Invalidate;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.DblClick;
{Dont pass along the event if double click in header}
begin
inherited DblClick;
if (ViewMouseCoord.Y <> abHeaderRow) then
if Assigned(FItemList) and (FItemList.Count > 0) then
if Assigned(FOnDblClick) then
FOnDblClick(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.DoChange;
begin
RowCount := 2; {HeaderRow + 1}
FSelList.Clear;
if Assigned(FItemList) then begin
FRowMap.Init(FItemList.Count);
if (FItemList.Count > 0) then
RowCount := FItemList.Count + 1
else begin
{ RefreshRow(1);}
FSortCol := -1;
end;
end;
if FAllowInvalidate then
Refresh;
if Assigned(FOnChange) then
FOnChange(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.DoLoad;
begin
FIcons.Clear;
FSelList.Clear;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.DoSorted(Attr : TAbViewAttribute);
begin
DrawSortArrow;
if Assigned(FOnSorted) then
FOnSorted(Self, Attr);
end;
{ -------------------------------------------------------------------------- }
{$IFDEF HasGridDrawingStyle}
procedure TAbBaseViewer.Paint;
begin
DefaultDrawing := FInternalDrawingStyle <> gdsClassic;
inherited;
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState);
var
s : string;
aItem : TAbArchiveItem;
TxtRect : TRect;
Attr : TAbViewAttribute;
DTFormat : Word;
{$IFNDEF UsingClx}
H : Integer;
Icon : HIcon;
{$ENDIF}
begin
{$IFDEF LINUX}
if not DefaultDrawing then
DefaultDrawing := true;
{$ENDIF}
Canvas.Font := Font;
if (ARow = AbHeaderRow) then begin
DrawHeaderButton(ACol, FHeadings[ColMap(ACol)])
end else if not FAllowInvalidate then {waiting for EndUpdate}
Exit
else with Canvas do begin
if not (doColLines in DisplayOptions) then
ARect.Right := ARect.Right + 1;
Brush.Color := clWindow;
if (not Assigned(FItemList)) or (FItemList.Count = 0) then begin
if not DefaultDrawing then Canvas.FillRect(ARect);
Exit;
end;
aItem := FItemList.Items[FRowMap[ARow-1]];
Attr := TAbViewAttribute(ColMap(ACol));
S := AttrToStr(Attr, aItem);
if (gdSelected in AState) or FSelList.IsSelected(FRowMap[ARow-1]) then begin
if not DefaultDrawing then begin
Brush.Color := FColors.Selected;
Font.Color := FColors.SelectedText;
end
{$IFDEF HasGridDrawingStyle}
else begin
if DrawingStyle = gdsGradient then
Canvas.Font.Color := clHighlightText;
if not (gdSelected in AState) then begin
if (goRowSelect in Options) then
Include(AState, gdRowSelected);
DrawCellHighlight(ARect, AState, ACol, ARow);
end;
end;
{$ENDIF}
end else if aItem.Action = aaDelete then begin
Brush.Color := FColors.Deleted;
Font.Color := FColors.DeletedText;
end else if ((doAlternateColors in FDisplayOptions) and
not Odd(ARow)) then begin
Brush.Color := FColors.Alternate;
Font.Color := FColors.AlternateText;
end;
if not DefaultDrawing then
Canvas.FillRect(ARect);
Canvas.Brush.Style := bsClear;
TxtRect := ARect;
{$IFNDEF UsingCLX}
Icon := 0;
if (Attr = vaItemName) then
Icon := GetIcon(aItem.Filename);
if (Icon <> 0) then begin
H := ARect.Bottom - ARect.Top;
DrawIconEx(Canvas.Handle, ARect.Left+1, ARect.Top+1, Icon,
H - 2, H - 2, 0, 0, DI_NORMAL);
TxtRect.Left := TxtRect.Left + H;
end;
{$ENDIF}
DTFormat := DrawTextFormat(Attr, TxtRect);
{$IFNDEF UsingCLX}
DrawText(Canvas.Handle, PChar(s), -1, TxtRect, DTFormat);
{$ELSE}
Canvas.TextRect(TxtRect, TxtRect.Left, TxtRect.Top, s, DTFormat);
{$ENDIF}
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.DrawHeaderButton(ACol : Integer; const AText : string);
var
ARect : TRect;
DTFormat : Word;
begin
ARect := CellRect(ACol, 0);
if not DefaultDrawing then with Canvas do begin
Brush.Style := bsSolid;
Brush.Color := clBtnface;
FillRect(ARect);
if FButtonDown then
Pen.Color := clBtnHighlight
else
Pen.Color := clBtnShadow;
MoveTo(ARect.Left, ARect.Bottom - 1);
LineTo(ARect.Right - 1, ARect.Bottom - 1);
LineTo(ARect.Right - 1, ARect.Top -1);
if FButtonDown then
Pen.Color := clBtnShadow
else
Pen.Color := clBtnHighlight;
MoveTo(ARect.Left, ARect.Bottom - 2);
LineTo(ARect.Left, ARect.Top);
LineTo(ARect.Right - 1, ARect.Top);
Brush.Style := bsClear;
end;
ARect.Right := ARect.Left + ColWidths[ACol];
if FSortCol = ACol then
ARect.Right := ARect.Right - 5 - (2 * (ARect.Bottom - ARect.Top) div 10);
{$IFDEF UsingCLX}
{ prefix is off by default in Qt}
DTFormat := Integer(AlignmentFlags_AlignVCenter) or
Integer(AlignmentFlags_SingleLine) or
Integer(AlignmentFlags_AlignHCenter);
{$ELSE}
DTFormat := DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX or DT_CENTER;
{$ENDIF}
if FButtonDown then
ARect := Rect(ARect.Left+1, ARect.Top+1, ARect.Right, ARect.Bottom);
{$IFDEF UsingCLX}
Canvas.TextRect(ARect, ARect.Left, ARect.Top, AText, DTFormat);
{$ELSE}
DrawText(Canvas.Handle, PChar(AText), -1, ARect, DTFormat);
{$ENDIF}
if FSortCol = ACol then
DrawSortArrow;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.DrawSortArrow;
var
ARect : TRect;
SavedColor : TColor;
begin
if (FSortCol > -1) then begin
{ set up Rect for the OnDrawSortArrow event }
ARect := CellRect(FSortCol, 0);
ARect.Top := (ARect.Bottom - ARect.Top) div 10;
ARect.Bottom := ARect.Bottom - ARect.Top;
ARect.Right := ARect.Left + ColWidths[FSortCol] - 5;
ARect.Left := ARect.Right - ((ARect.Bottom - ARect.Top));
if Assigned(FOnDrawSortArrow) then begin
FOnDrawSortArrow(Self, FSortCol, FRowMap.SortAscending, Canvas, ARect);
Exit;
end;
{ make ARect smaller for our own drawing }
inc(ARect.Left, 10);
inc(ARect.Top, 5);
dec(ARect.Bottom, 5);
with Canvas do begin
Pen.Color := clBtnShadow;
SavedColor := Brush.Color;
Brush.Color := clBtnFace;
with ARect do
if FRowMap.SortAscending then begin
Polygon([Point(((Right-Left)div 2)+Left, Bottom), Point(Right, Top),
Point(Left, Top)]);
{$IFNDEF UsingCLX}
if Ctl3D then begin
Pen.Color := clBtnHighlight;
MoveTo(((Right-Left)div 2)+Left, Bottom);
LineTo(Right, Top);
end;
{$ENDIF}
end else begin
Polygon([Point(((Right-Left)div 2)+Left, Top), Point(Right, Bottom),
Point(Left, Bottom)]);
{$IFNDEF UsingCLX}
if Ctl3D then begin
Pen.Color := clBtnHighlight;
MoveTo(((Right-Left)div 2)+Left, Top);
LineTo(Right, Bottom);
LineTo(Left, Bottom);
Pen.Color := clBtnShadow;
LineTo(((Right-Left)div 2)+Left, Top);
end;
{$ENDIF}
end;
Brush.Color := SavedColor;
end;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseViewer.DrawTextFormat(Attr : TAbViewAttribute;
var Rect : TRect) : Word;
begin
{$IFDEF MSWINDOWS}
Result := DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
case Attr of
vaItemname : Result := Result or DT_LEFT;
vaPacked : Result := Result or DT_RIGHT;
vaFileSize : Result := Result or DT_RIGHT;
vaMethod : Result := Result or DT_CENTER;
vaRatio : Result := Result or DT_CENTER;
vaCRC : Result := Result or DT_CENTER;
vaFileAttributes : Result := Result or DT_CENTER;
vaFileType : Result := Result or DT_CENTER;
vaEncryption : Result := Result or DT_CENTER;
vaTimeStamp : Result := Result or DT_LEFT;
vaVersionMade : Result := Result or DT_CENTER;
vaVersionNeeded : Result := Result or DT_CENTER;
vaPath : Result := Result or DT_LEFT;
end;
if (Result and 3) = DT_LEFT then
OffsetRect(Rect, 5, 0)
else if (Result and 3) = DT_RIGHT then
OffsetRect(Rect, -5, 0);
{$ENDIF}
{$IFDEF LINUX}
Result := Integer(AlignmentFlags_AlignVCenter) or
Integer(AlignmentFlags_SingleLine);
case Attr of
vaItemname : Result := Result or Integer(AlignmentFlags_AlignLeft);
vaPacked : Result := Result or Integer(AlignmentFlags_AlignRight);
vaFileSize : Result := Result or Integer(AlignmentFlags_AlignRight);
vaMethod : Result := Result or Integer(AlignmentFlags_AlignCenter);
vaRatio : Result := Result or Integer(AlignmentFlags_AlignCenter);
vaCRC : Result := Result or Integer(AlignmentFlags_AlignCenter);
vaFileAttributes : Result := Result or Integer(AlignmentFlags_AlignCenter);
vaFileType : Result := Result or Integer(AlignmentFlags_AlignCenter);
vaEncryption : Result := Result or Integer(AlignmentFlags_AlignCenter);
vaTimeStamp : Result := Result or Integer(AlignmentFlags_AlignLeft);
vaVersionMade : Result := Result or Integer(AlignmentFlags_AlignCenter);
vaVersionNeeded : Result := Result or Integer(AlignmentFlags_AlignCenter);
vaPath : Result := Result or Integer(AlignmentFlags_AlignLeft);
end;
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function TAbBaseViewer.GetActiveRow : Longint;
begin
Result := Row - 1;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseViewer.GetCount : Longint;
begin
if Assigned(FItemList) then
Result := FItemList.Count
else
Result := 0;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseViewer.GetHeaderRowHeight : Integer;
begin
Result := RowHeights[AbHeaderRow];
end;
{ -------------------------------------------------------------------------- }
{$IFDEF MSWINDOWS}
function TAbBaseViewer.GetIcon(const ItemName : string) : HIcon;
var
i : Longint;
t : string;
sfi : SHFILEINFO;
begin
Result := 0;
if not (doShowIcons in FDisplayOptions) then
Exit;
t := ExtractFileExt(ItemName);
i := FIcons.IndexOf(t);
if (i > -1) then
Result := HIcon(FIcons.Objects[i])
else begin
SHGetFileInfo(PChar(t), FILE_ATTRIBUTE_NORMAL, sfi, sizeof(sfi),
SHGFI_ICON or SHGFI_USEFILEATTRIBUTES);
Result := sfi.hIcon;
FIcons.AddObject(t, Pointer(Result));
end;
end;
{$ENDIF}
{$IFDEF UsingCLX }
{ no file type icons in CLX }
{$ENDIF}
{ -------------------------------------------------------------------------- }
function TAbBaseViewer.GetSelCount : Longint;
begin
Result := FSelList.SelCount;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseViewer.GetSelected(RowNum : Longint) : Boolean;
begin
if Assigned(FItemList) then
Result := FSelList.IsSelected(FRowMap[RowNum])
else
Result := False;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseViewer.GetVersion : string;
begin
Result := AbVersionS;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.InitColMap;
const
cResString: array[TAbViewAttribute] of string = (AbItemNameHeadingS,
AbPackedHeadingS, AbMethodHeadingS, AbRatioHeadingS, AbCRCHeadingS,
AbFileAttrHeadingS, AbFileFormatHeadingS, AbEncryptionHeadingS,
AbTimeStampHeadingS, AbFileSizeHeadingS, AbVersionMadeHeadingS,
AbVersionNeededHeadingS, AbPathHeadingS);
var
i : TAbViewAttribute;
begin
FHeadings.Clear;
for i := Low(TAbViewAttribute) to High(TAbViewAttribute) do begin
FHeadings.Add(cResString[i]);
FColMap[i] := Ord(i);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.InvalidateRow(ARow: Longint);
var
Rect: TRect;
begin
if not HandleAllocated then
Exit;
if ((ARow < TopRow) or (ARow > TopRow + VisibleRowCount)) and (ARow <> 0) then
Exit;
Rect := CellRect(0, ARow);
Rect.Right := ClientWidth;
{$IFDEF UsingCLX}
InvalidateRect(Rect, False);
{$ELSE}
InvalidateRect(Handle, @Rect, True);
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.KeyDown(var Key: Word; Shift: TShiftState);
begin
FShiftState := Shift;
inherited KeyDown(Key, Shift);
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.KeyUp(var Key: Word; Shift: TShiftState);
begin
FShiftState := Shift;
inherited KeyUp(Key, Shift);
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.Loaded;
begin
inherited Loaded;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y : Integer);
function GetMinLen(Col: Integer): Word;
var
I, L : Integer;
s : String;
aItem : TAbArchiveItem;
Attr : TAbViewAttribute;
Sorted : Boolean;
begin
Attr := TAbViewAttribute(ColMap(Col));
Result := Canvas.TextWidth(FHeadings[ColMap(Col)]);
case Attr of
vaItemName : Sorted := saItemName in FSortAttributes;
vaPacked : Sorted := saPacked in FSortAttributes;
vaRatio : Sorted := saRatio in FSortAttributes;
vaTimeStamp: Sorted := saTimeStamp in FSortAttributes;
vaFileSize : Sorted := saFileSize in FSortAttributes;
vaPath : Sorted := saPath in FSortAttributes;
else Sorted := False;
end;
if Sorted then
Result := Result + RowHeights[0] + 16
else
Result := Result + 8;
if Assigned(FItemList) then
for I := 0 to (FItemList.Count-1) do begin
aItem := FItemList.Items[I];
S := AttrToStr(Attr, aItem);
L := Canvas.TextWidth(S) + 8;
if (doShowIcons in FDisplayOptions) and (Attr = vaItemName) then
inc(L, RowHeights[I]);
if L > Result then
Result := L;
end;
end;
var
ACol : Longint;
ARow : Longint;
Rect : TRect;
begin
ViewMouseCoord := MouseCoord(X, Y);
inherited MouseDown(Button, Shift, X, Y);
FShiftState := Shift;
{ handle double clicks on header row dividers }
if (ssDouble in FShiftState) and (ViewMouseCoord.Y = AbHeaderRow) then begin
FColSizing := True;
Rect := CellRect(ViewMouseCoord.X, ViewMouseCoord.Y);
Rect.Left := Rect.Right - 3;
if PtInRect(Rect, Point(X, Y)) then begin
ColWidths[MouseCoord(Rect.Left, Y).X] :=
GetMinLen(MouseCoord(Rect.Left, Y).X)
end
else begin
Rect := CellRect(ViewMouseCoord.X, ViewMouseCoord.Y);
Rect.Right := Rect.Left + 4;
if PtInRect(Rect, Point(X, Y)) then
ColWidths[MouseCoord(Rect.Left, Y).X-1] :=
GetMinLen(MouseCoord(Rect.Left, Y).X-1);
end;
end;
{ if grid is being resized }
if (FGridState = gsColSizing) then begin
FColSizing := True;
Exit; {dont press button when resizing column}
end;
{ refresh the headers}
if Assigned(FItemList) then
if (FItemList.Count > 0) then begin
ARow := ViewMouseCoord.Y;
ACol := ViewMouseCoord.X;
if (ARow = abHeaderRow) then begin
{if not (doColMove in FDisplayOptions) then}
if not (doColMove in FDisplayOptions) and not FColSizing then
FButtonDown := True;
RefreshCell(0, ACol);
end else if not (ssShift in Shift) then
RowAnchor := ActiveRow;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.MouseUp(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
ACol : Longint;
ARow : Longint;
Attr : TAbViewAttribute;
SortAttribute : TAbSortAttribute;
begin
inherited MouseUp(Button, Shift, X, Y);
if csDesigning in ComponentState then Exit;
FShiftState := Shift;
FButtonDown := False;
if FColSizing then begin
Refresh;
FColSizing := False;
end else
if Assigned(FItemList) then
if (FItemList.Count > 0) then begin
ARow := ViewMouseCoord.Y;
ACol := ViewMouseCoord.X;
if (ARow = abHeaderRow) then begin
Attr := TAbViewAttribute(ColMap(ACol));
if not FColMoving and
AttrToSortAttribute(Attr, SortAttribute) and
(SortAttribute in FSortAttributes) then begin
FSortCol := ACol;
FItemIndex := FRowMap[Row-1];
FRowMap.SortBy(SortAttribute, FItemList);
FButtonDown := False;
RefreshCell(0, ACol);
if (doTrackActiveRow in FDisplayOptions) then
Row := FRowMap.InvRows[FItemIndex] + 1;
Refresh;
DoSorted(Attr);
end else begin
FButtonDown := False;
RefreshCell(0, ACol);
end;
end else
Paint;
end;
FColMoving := False;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited MouseMove(Shift, X, Y);
if (FGridState = gsColMoving) then
FColMoving := True;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.MoveColumn(FromCol, ToCol : Integer);
var
temp, i : Integer;
begin
Temp := ColMap(FromCol);
if (FromCol < ToCol) then begin
for i := (FromCol + 1) to ToCol do
FColMap[TAbViewAttribute(i-1)] := FColMap[TAbViewAttribute(i)]; {Shift left}
end else begin
for i := (FromCol - 1) downto ToCol do
FColMap[TAbViewAttribute(i+1)] := FColMap[TAbViewAttribute(i)]; {Shift right}
end;
FColMap[TAbViewAttribute(ToCol)] := Temp;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.RefreshCell(ARow, ACol: Longint);
var
Rect: TRect;
begin
if not HandleAllocated then
Exit;
Rect := CellRect(ACol, ARow);
{$IFDEF UsingCLX}
InvalidateRect(Rect, False);
{$ELSE}
InvalidateRect(Handle, @Rect, False);
{$ENDIF}
Update;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.RefreshRow(ARow: Longint);
begin
InvalidateRow(ARow);
Update;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.SelectAll;
begin
if Assigned(FItemList) then
if (FItemList.Count > 0) then begin
FSelList.SelectAll(FItemList.Count);
Invalidate;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.SetActiveRow(RowNum : Longint);
begin
if Assigned(FItemList) then
if (RowNum >= 0) and (RowNum < FItemList.Count) then
Row := RowNum + 1;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.SetAttributes(Value : TAbViewAttributes);
begin
FAttributes := Value;
ColCount := UpdateColCount(FAttributes);
DoChange(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.SetDisplayOptions(Value : TAbDisplayOptions);
{maps DisplayOptions to TGridOptions}
begin
FDisplayOptions := Value;
Options := [goFixedVertLine, goFixedHorzLine, goRowSelect];
{$IFDEF HasGridDrawingStyle}
Options := Options + [goFixedRowClick]; // Highlight pressed header when themed
{$ENDIF}
if (doColLines in Value) then
Options := Options + [goVertLine];
if (doColMove in Value) then
Options := Options + [goColMoving];
if (doColSizing in Value) then
Options := Options + [goColSizing];
if (doRowLines in Value) then
Options := Options + [goHorzLine];
if (doThumbTrack in Value) then
Options := Options + [goThumbTracking];
DoChange(nil);
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.SetHeaderRowHeight(Value : Integer);
begin
RowHeights[abHeaderRow] := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.SetHeadings(Value: TAbColHeadings);
begin
Headings.Assign(Value);
Refresh;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.SetSortAttributes(Value : TAbSortAttributes);
begin
FSortAttributes := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.SetSelected(RowNum : Longint; Value: Boolean);
begin
if Assigned(FItemList) then
case Value of
True : FSelList.Select(FRowMap[RowNum]);
False : FSelList.Deselect(FRowMap[RowNum]);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.SetVersion(const Value : string);
begin
{NOP}
end;
{ -------------------------------------------------------------------------- }
procedure TAbBaseViewer.TopLeftChanged;
begin
if FAllowInvalidate then
Invalidate;
end;
{ -------------------------------------------------------------------------- }
function TAbBaseViewer.UpdateColCount(Attributes : TAbViewAttributes) : Integer;
var
i : TAbViewAttribute;
begin
Result := 0;
for i := Low(TAbViewAttribute) to High(TAbViewAttribute) do begin
if (i in Attributes) then begin
FColMap[TAbViewAttribute(Result)] := Ord(i);
Inc(Result);
end;
end;
end;
{ -------------------------------------------------------------------------- }
{$IFDEF UsingCLX}
procedure TAbBaseViewer.SizeChanged(OldColCount, OldRowCount: Longint);
begin
inherited SizeChanged(OldColCount, OldRowCount);
Refresh;
end;
{$ELSE}
procedure TAbBaseViewer.WMSize(var Msg: TWMSize);
begin
inherited;
Refresh;
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
{$IFNDEF UsingCLX}
procedure TAbBaseViewer.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
begin
Msg.Result := -1;
end;
{$ENDIF}
end.
================================================
FILE: lib/abbrevia/source/AbWavPack.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is Craig Peterson
*
* Portions created by the Initial Developer are Copyright (C) 2011
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Craig Peterson
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbWavPack.pas *}
{*********************************************************}
{* ABBREVIA: WavPack decompression procedures *}
{*********************************************************}
unit AbWavPack;
{$I AbDefine.inc}
interface
uses
Classes;
// Decompress a WavPack compressed stream from aSrc and write to aDes.
// aSrc must not allow reads past the compressed data.
procedure DecompressWavPack(aSrc, aDes: TStream);
implementation
uses
AbCrtl,
Math,
SysUtils;
// Compile using
// bcc32 -DWIN32 -DNO_USE_FSTREAMS -c -w-8004 -w-8012 -w-8017 -w-8057 -w-8065 *.c
//
// In wavpack_local.h remove the line "#define FASTCALL __fastcall"
{ C runtime library ======================================================== }
function fabs(x: Double): Double; cdecl;
begin
if x < 0 then Result := -1
else Result := x
end;
function floor(x: Double): Integer; cdecl;
begin
Result := Floor(x);
end;
function labs(n: Integer): Integer; cdecl;
begin
if n < 0 then Result := -n
else Result := n;
end;
function _stricmp(str1, str2: PAnsiChar): Integer; cdecl;
external 'msvcrt.dll' name '_stricmp';
function strncmp(str1, str2: PAnsiChar; num: Integer): Integer; cdecl;
external 'msvcrt.dll' {$IFDEF BCB}name '_strncmp'{$ENDIF};
{ Forward declarations ===================================================== }
// bits.c
procedure bs_open_read; external;
procedure bs_close_read; external;
procedure bs_open_write; external;
procedure bs_close_write; external;
procedure little_endian_to_native; external;
procedure native_to_little_endian; external;
// extra1.c
procedure execute_mono; external;
// extra2.c
procedure execute_stereo; external;
// float.c
procedure float_values; external;
procedure read_float_info; external;
procedure scan_float_data; external;
procedure send_float_data; external;
procedure WavpackFloatNormalize; external;
procedure write_float_info; external;
// metadata.c
procedure add_to_metadata; external;
procedure copy_metadata; external;
procedure free_metadata; external;
procedure process_metadata; external;
procedure read_metadata_buff; external;
procedure write_metadata_block; external;
// pack.c
procedure pack_block; external;
procedure pack_init; external;
// tags.c
procedure load_tag; external;
procedure valid_tag; external;
// unpack.c
procedure check_crc_error; external;
procedure free_tag; external;
procedure unpack_init; external;
procedure unpack_samples; external;
// unpack3.c
procedure free_stream3; external;
procedure get_version3; external;
procedure get_sample_index3; external;
procedure open_file3; external;
procedure seek_sample3; external;
procedure unpack_samples3; external;
// words.c
procedure exp2s; external;
procedure flush_word; external;
procedure get_word; external;
procedure get_words_lossless; external;
procedure init_words; external;
procedure log2s; external;
procedure log2buffer; external;
procedure nosend_word; external;
procedure read_hybrid_profile; external;
procedure read_entropy_vars; external;
procedure restore_weight; external;
procedure scan_word; external;
procedure send_word; external;
procedure send_words_lossless; external;
procedure store_weight; external;
procedure write_entropy_vars; external;
procedure write_hybrid_profile; external;
{ Linker derectives ======================================================== }
{$IF DEFINED(WIN32)}
{$L Win32\wv_bits.obj}
{$L Win32\wv_extra1.obj}
{$L Win32\wv_extra2.obj}
{$L Win32\wv_float.obj}
{$L Win32\wv_metadata.obj}
{$L Win32\wv_pack.obj}
{$L Win32\wv_tags.obj}
{$L Win32\wv_unpack.obj}
{$L Win32\wv_unpack3.obj}
{$L Win32\wv_words.obj}
{$L Win32\wv_wputils.obj}
{$ELSEIF DEFINED(WIN64)}
{$L Win64\wv_bits.obj}
{$L Win64\wv_extra1.obj}
{$L Win64\wv_extra2.obj}
{$L Win64\wv_float.obj}
{$L Win64\wv_metadata.obj}
{$L Win64\wv_pack.obj}
{$L Win64\wv_tags.obj}
{$L Win64\wv_unpack.obj}
{$L Win64\wv_unpack3.obj}
{$L Win64\wv_words.obj}
{$L Win64\wv_wputils.obj}
{$IFEND}
{ wavpack_local.h ========================================================== }
const
OPEN_WVC = $1; // open/read "correction" file
OPEN_TAGS = $2; // read ID3v1 / APEv2 tags (seekable file)
OPEN_WRAPPER = $4; // make audio wrapper available (i.e. RIFF)
OPEN_2CH_MAX = $8; // open multichannel as stereo (no downmix)
OPEN_NORMALIZE = $10; // normalize floating point data to +/- 1.0
OPEN_STREAMING = $20; // "streaming" mode blindly unpacks blocks
// w/o regard to header file position info
OPEN_EDIT_TAGS = $40; // allow editing of tags
type
int32_t = LongInt;
uint32_t = LongWord;
WavpackStreamReader = record
read_bytes: function(id, data: Pointer; bcount: int32_t): int32_t; cdecl;
get_pos: function(id: Pointer): uint32_t; cdecl;
set_pos_abs: function(id: Pointer; pos: uint32_t): Integer; cdecl;
set_pos_rel: function(id: Pointer; delta: int32_t; mode: Integer): Integer; cdecl;
push_back_byte: function(id: Pointer; c: Integer): Integer; cdecl;
get_length: function(id: Pointer): uint32_t; cdecl;
can_seek: function(id: Pointer): Integer; cdecl;
write_bytes: function(id, data: Pointer; bcount: int32_t): int32_t; cdecl;
end;
WavpackContext = Pointer;
{ wputils.c ================================================================ }
function WavpackOpenFileInputEx(const reader: WavpackStreamReader;
wv_id, wvc_id: Pointer; error: PAnsiChar; flags, norm_offset: Integer): WavpackContext;
cdecl; external;
function WavpackGetWrapperBytes(wpc: WavpackContext): uint32_t; cdecl; external;
function WavpackGetWrapperData(wpc: WavpackContext): PByte; cdecl; external;
procedure WavpackFreeWrapper (wpc: WavpackContext); cdecl; external;
procedure WavpackSeekTrailingWrapper(wpc: WavpackContext); cdecl; external;
function WavpackGetNumSamples(wpc: WavpackContext): uint32_t; cdecl; external;
function WavpackGetNumChannels(wpc: WavpackContext): Integer; cdecl; external;
function WavpackGetBytesPerSample (wpc: WavpackContext): Integer; cdecl; external;
function WavpackUnpackSamples(wpc: WavpackContext; buffer: Pointer;
samples: uint32_t): uint32_t; cdecl; external;
function WavpackCloseFile(wpc: WavpackContext): WavpackContext; cdecl; external;
{ TWavPackStream implementation ============================================ }
type
PWavPackStream = ^TWavPackStream;
TWavPackStream = record
HasPushedByte: Boolean;
PushedByte: Byte;
Stream: TStream;
end;
{ -------------------------------------------------------------------------- }
function TWavPackStream_read_bytes(id, data: Pointer; bcount: int32_t): int32_t; cdecl;
begin
if PWavPackStream(id).HasPushedByte then begin
PByte(data)^ := PWavPackStream(id).PushedByte;
PWavPackStream(id).HasPushedByte := False;
Inc(PByte(data));
Dec(bcount);
if bcount = 0 then
Result := 1
else
Result := PWavPackStream(id).Stream.Read(data^, bcount) + 1;
end
else
Result := PWavPackStream(id).Stream.Read(data^, bcount);
end;
{ -------------------------------------------------------------------------- }
function TWavPackStream_get_pos(id: Pointer): uint32_t; cdecl;
begin
Result := PWavPackStream(id).Stream.Position;
end;
{ -------------------------------------------------------------------------- }
function TWavPackStream_set_pos_abs(id: Pointer; pos: uint32_t): Integer; cdecl;
begin
PWavPackStream(id).Stream.Position := pos;
Result := 0;
end;
{ -------------------------------------------------------------------------- }
function TWavPackStream_set_pos_rel(id: Pointer; delta: int32_t;
mode: Integer): Integer; cdecl;
begin
PWavPackStream(id).Stream.Seek(delta, mode);
Result := 1;
end;
{ -------------------------------------------------------------------------- }
function TWavPackStream_push_back_byte(id: Pointer; c: Integer): Integer; cdecl;
begin
Assert(not PWavPackStream(id).HasPushedByte);
PWavPackStream(id).HasPushedByte := True;
PWavPackStream(id).PushedByte := Byte(c);
Result := 1;
end;
{ -------------------------------------------------------------------------- }
function TWavPackStream_get_length(id: Pointer): uint32_t; cdecl;
begin
Result := PWavPackStream(id).Stream.Size;
end;
{ -------------------------------------------------------------------------- }
function TWavPackStream_can_seek(id: Pointer): Integer; cdecl;
begin
Result := 1;
end;
{ -------------------------------------------------------------------------- }
function TWavPackStream_write_bytes(id, data: Pointer;
bcount: int32_t): int32_t; cdecl;
begin
Result := PWavPackStream(id).Stream.Write(data^, bcount);
end;
{ Decompression routines =================================================== }
{ -------------------------------------------------------------------------- }
// Reformat samples from longs in processor's native endian mode to
// little-endian data with (possibly) less than 4 bytes / sample.
//
// Based on wvunpack.c::format_samples.
// Conversions simplified since we only support little-endian processors
function FormatSamples(bps: Integer; dst, src: PByte; samcnt: uint32_t): PByte;
var
sample: LongWord;
begin
while samcnt > 0 do begin
Dec(samcnt);
// Get next sample
sample := PLongWord(src)^;
// Convert and write to output
case bps of
1: begin
dst^ := sample + 128;
end;
2: begin
PWord(dst)^ := sample;
end;
3: begin
PByteArray(dst)[0] := sample;
PByteArray(dst)[1] := sample shr 8;
PByteArray(dst)[2] := sample shr 16;
end;
4: begin
PLongWord(dst)^ := sample;
end;
end;
Inc(src, SizeOf(LongWord));
Inc(dst, bps);
end;
Result := dst;
end;
{ -------------------------------------------------------------------------- }
// Decompress a WavPack compressed stream from aSrc and write to aDes.
// aSrc must not allow reads past the compressed data.
//
// Based on wvunpack.c::unpack_file()
procedure DecompressWavPack(aSrc, aDes: TStream);
type
PtrInt = {$IF DEFINED(CPUX64)}Int64{$ELSE}LongInt{$IFEND};
const
OutputBufSize = 256 * 1024;
var
StreamReader: WavpackStreamReader;
Context: WavpackContext;
Src: TWavpackStream;
Error: array[0..79] of AnsiChar;
SamplesToUnpack, SamplesUnpacked: uint32_t;
NumChannels, bps, BytesPerSample: Integer;
OutputBuf, OutputPtr: PByte;
DecodeBuf: Pointer;
begin
OutputBuf := nil;
DecodeBuf := nil;
StreamReader.read_bytes := TWavPackStream_read_bytes;
StreamReader.get_pos := TWavPackStream_get_pos;
StreamReader.set_pos_abs := TWavPackStream_set_pos_abs;
StreamReader.set_pos_rel := TWavPackStream_set_pos_rel;
StreamReader.push_back_byte := TWavPackStream_push_back_byte;
StreamReader.get_length := TWavPackStream_get_length;
StreamReader.can_seek := TWavPackStream_can_seek;
StreamReader.write_bytes := TWavPackStream_write_bytes;
FillChar(Src, SizeOf(Src), 0);
Src.Stream := aSrc;
Context := WavpackOpenFileInputEx(StreamReader, @Src, nil, Error, OPEN_WRAPPER, 0);
if Context = nil then
raise Exception.Create('WavPack decompression failed: ' + Error);
try
// Write .wav header
if WavpackGetWrapperBytes(Context) > 0 then begin
aDes.WriteBuffer(WavpackGetWrapperData(Context)^, WavpackGetWrapperBytes(Context));
WavpackFreeWrapper(Context);
end;
NumChannels := WavpackGetNumChannels(Context);
bps := WavpackGetBytesPerSample(Context);
BytesPerSample := NumChannels * bps;
GetMem(OutputBuf, OutputBufSize);
OutputPtr := OutputBuf;
GetMem(DecodeBuf, 4096 * NumChannels * SizeOf(Integer));
repeat
// Unpack samples
SamplesToUnpack := (OutputBufSize - (PtrInt(OutputPtr) - PtrInt(OutputBuf))) div BytesPerSample;
if (SamplesToUnpack > 4096) then
SamplesToUnpack := 4096;
SamplesUnpacked := WavpackUnpackSamples(Context, DecodeBuf, SamplesToUnpack);
// Convert from 32-bit integers down to appriopriate bit depth
// and copy to output buffer.
if (SamplesUnpacked > 0) then
OutputPtr := FormatSamples(bps, OutputPtr, DecodeBuf,
SamplesUnpacked * uint32_t(NumChannels));
// Write output when it's full or when we're done
if (SamplesUnpacked = 0) or
((OutputBufSize - (PtrInt(OutputPtr) - PtrInt(OutputBuf))) < BytesPerSample) then begin
aDes.WriteBuffer(OutputBuf^, PtrInt(OutputPtr) - PtrInt(OutputBuf));
OutputPtr := OutputBuf;
end;
until (SamplesUnpacked = 0);
// Write .wav footer
while WavpackGetWrapperBytes(Context) > 0 do begin
try
aDes.WriteBuffer(WavpackGetWrapperData(Context)^,
WavpackGetWrapperBytes(Context));
finally
WavpackFreeWrapper(Context);
end;
// Check for more RIFF data
WavpackUnpackSamples (Context, DecodeBuf, 1);
end;
finally
if DecodeBuf <> nil then
FreeMemory(DecodeBuf);
if OutputBuf <> nil then
FreeMemory(OutputBuf);
WavpackCloseFile(Context);
end;
end;
end.
================================================
FILE: lib/abbrevia/source/AbZBrows.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Craig Peterson
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbZBrows.pas *}
{*********************************************************}
{* ABBREVIA: Zip file Browser Component *}
{*********************************************************}
unit AbZBrows;
{$I AbDefine.inc}
interface
uses
Classes,
AbArcTyp, AbBrowse, AbSpanSt, AbZipTyp;
type
TAbCustomZipBrowser = class(TAbBaseBrowser)
private
function GetTarAutoHandle: Boolean;
procedure SetTarAutoHandle(const Value: Boolean);
protected {private}
FPassword : AnsiString;
FOnRequestLastDisk : TAbRequestDiskEvent;
FOnRequestNthDisk : TAbRequestNthDiskEvent;
FOnRequestBlankDisk : TAbRequestDiskEvent;
FTarAutoHandle : Boolean;
protected {methods}
function GetItem(Index : Integer) : TAbZipItem; virtual;
function GetStream: TStream;
function GetZipfileComment : AnsiString;
procedure InitArchive;
override;
procedure SetFileName(const aFileName : string);
override;
procedure SetStream(aValue: TStream);
procedure SetOnRequestLastDisk(Value : TAbRequestDiskEvent);
procedure SetOnRequestNthDisk(Value : TAbRequestNthDiskEvent);
procedure SetOnRequestBlankDisk(Value : TAbRequestDiskEvent);
procedure SetPassword(const Value : AnsiString);
procedure SetZipfileComment(const Value : AnsiString);
virtual;
protected {properties}
property Password : AnsiString
read FPassword
write SetPassword;
protected {events}
property OnRequestLastDisk : TAbRequestDiskEvent
read FOnRequestLastDisk
write SetOnRequestLastDisk;
property OnRequestNthDisk : TAbRequestNthDiskEvent
read FOnRequestNthDisk
write SetOnRequestNthDisk;
property OnRequestBlankDisk : TAbRequestDiskEvent
read FOnRequestBlankDisk
write SetOnRequestBlankDisk;
public {methods}
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
public {properties}
property Items[Index : Integer] : TAbZipItem
read GetItem; default;
property Stream : TStream // This can be used instead of Filename
read GetStream write SetStream;
property ZipArchive : {TAbZipArchive} TAbArchive
read FArchive;
property ZipfileComment : AnsiString
read GetZipfileComment
write SetZipfileComment;
property TarAutoHandle : Boolean
read GetTarAutoHandle
write SetTarAutoHandle;
end;
TAbZipBrowser = class(TAbCustomZipBrowser)
published
property ArchiveProgressMeter;
property ItemProgressMeter;
property BaseDirectory;
property LogFile;
property Logging;
property OnArchiveProgress;
property OnArchiveItemProgress;
property OnChange;
property OnConfirmProcessItem;
property OnLoad;
property OnProcessItemFailure;
property OnRequestLastDisk;
property OnRequestNthDisk;
property Version;
property TarAutoHandle;
property FileName; {must be after OnLoad}
end;
implementation
uses
SysUtils, AbBzip2Typ, AbExcept, AbGzTyp, AbTarTyp, AbUtils;
{ TAbCustomZipBrowser implementation ======================================= }
{ -------------------------------------------------------------------------- }
constructor TAbCustomZipBrowser.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
end;
{ -------------------------------------------------------------------------- }
destructor TAbCustomZipBrowser.Destroy;
begin
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipBrowser.GetItem(Index : Integer) : TAbZipItem;
begin
Result := TAbZipItem(ZipArchive.ItemList[Index]);
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipBrowser.GetStream: TStream;
begin
if FArchive <> nil then
Result := FArchive.FStream
else
Result := nil
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipBrowser.GetTarAutoHandle: Boolean;
begin
Result := False;
if FArchive is TAbGzipArchive then
Result := TAbGzipArchive(FArchive).TarAutoHandle
else if FArchive is TAbBzip2Archive then
Result := TAbBzip2Archive(FArchive).TarAutoHandle;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipBrowser.GetZipfileComment : AnsiString;
begin
if FArchive is TAbZipArchive then
Result := TAbZipArchive(FArchive).ZipfileComment
else
Result := '';
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipBrowser.InitArchive;
begin
inherited InitArchive;
if FArchive is TAbZipArchive then begin
{properties}
TAbZipArchive(FArchive).Password := FPassword;
{events}
TAbZipArchive(FArchive).OnRequestLastDisk := FOnRequestLastDisk;
TAbZipArchive(FArchive).OnRequestNthDisk := FOnRequestNthDisk;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipBrowser.SetFileName(const aFileName : string);
var
ArcType : TAbArchiveType;
begin
FFileName := aFileName;
if csDesigning in ComponentState then
Exit;
try
if Assigned(FArchive) then begin
FArchive.Save;
end;
except
end;
FArchive.Free;
FArchive := nil;
if FileName <> '' then begin
if FileExists(FileName) then begin { open it }
ArcType := ArchiveType;
if not ForceType then
ArcType := AbDetermineArcType(FileName, atUnknown);
case ArcType of
atZip, atSpannedZip, atSelfExtZip : begin
FArchive := TAbZipArchive.Create(FileName, fmOpenRead or fmShareDenyNone);
InitArchive;
end;
atTar : begin
FArchive := TAbTarArchive.Create(FileName, fmOpenRead or fmShareDenyNone);
inherited InitArchive;
end;
atGZip : begin
FArchive := TAbGzipArchive.Create(FileName, fmOpenRead or fmShareDenyNone);
TAbGzipArchive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbGzipArchive(FArchive).IsGzippedTar := False;
inherited InitArchive;
end;
atGZippedTar : begin
FArchive := TAbGzipArchive.Create(FileName, fmOpenRead or fmShareDenyNone);
TAbGzipArchive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbGzipArchive(FArchive).IsGzippedTar := True;
inherited InitArchive;
end;
atBzip2 : begin
FArchive := TAbBzip2Archive.Create(FileName, fmOpenRead or fmShareDenyNone);
TAbBzip2Archive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbBzip2Archive(FArchive).IsBzippedTar := False;
inherited InitArchive;
end;
atBzippedTar : begin
FArchive := TAbBzip2Archive.Create(FileName, fmOpenRead or fmShareDenyNone);
TAbBzip2Archive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbBzip2Archive(FArchive).IsBzippedTar := True;
inherited InitArchive;
end;
else
raise EAbUnhandledType.Create;
end {case};
FArchive.Load;
FArchiveType := ArcType;
end;
end;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipBrowser.SetStream(aValue: TStream);
var
ArcType : TAbArchiveType;
begin
FFileName := '';
try
if FArchive <> nil then
FArchive.Save;
except
end;
FreeAndNil(FArchive);
if aValue <> nil then begin
ArcType := ArchiveType;
if not ForceType then
ArcType := AbDetermineArcType(aValue);
case ArcType of
atZip, atSpannedZip, atSelfExtZip : begin
FArchive := TAbZipArchive.CreateFromStream(aValue, '');
end;
atTar : begin
FArchive := TAbTarArchive.CreateFromStream(aValue, '');
end;
atGZip, atGZippedTar : begin
FArchive := TAbGzipArchive.CreateFromStream(aValue, '');
TAbGzipArchive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbGzipArchive(FArchive).IsGzippedTar := (ArcType = atGZippedTar);
end;
atBzip2, atBzippedTar : begin
FArchive := TAbBzip2Archive.CreateFromStream(aValue, '');
TAbBzip2Archive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbBzip2Archive(FArchive).IsBzippedTar := (ArcType = atBzippedTar);
end;
else
raise EAbUnhandledType.Create;
end {case};
InitArchive;
FArchive.Load;
FArchiveType := ArcType;
end;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipBrowser.SetOnRequestBlankDisk(Value : TAbRequestDiskEvent);
begin
FOnRequestBlankDisk := Value;
if FArchive is TAbZipArchive then
TAbZipArchive(FArchive).OnRequestBlankDisk := FOnRequestBlankDisk;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipBrowser.SetOnRequestLastDisk(Value : TAbRequestDiskEvent);
begin
FOnRequestLastDisk := Value;
if FArchive is TAbZipArchive then
TAbZipArchive(FArchive).OnRequestLastDisk := FOnRequestLastDisk;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipBrowser.SetOnRequestNthDisk(Value : TAbRequestNthDiskEvent);
begin
FOnRequestNthDisk := Value;
if FArchive is TAbZipArchive then
TAbZipArchive(FArchive).OnRequestNthDisk := FOnRequestNthDisk;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipBrowser.SetPassword(const Value : AnsiString);
begin
FPassword := Value;
if FArchive is TAbZipArchive then
TAbZipArchive(FArchive).Password := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipBrowser.SetTarAutoHandle(const Value: Boolean);
begin
FTarAutoHandle := Value;
if FArchive is TAbGzipArchive then begin
if TAbGzipArchive(FArchive).TarAutoHandle <> Value then begin
TAbGzipArchive(FArchive).TarAutoHandle := Value;
InitArchive;
FArchive.Load;
DoChange;
end;
end;
if FArchive is TAbBzip2Archive then begin
if TAbBzip2Archive(FArchive).TarAutoHandle <> Value then begin
TAbBzip2Archive(FArchive).TarAutoHandle := Value;
InitArchive;
FArchive.Load;
DoChange;
end;
end;
end;
procedure TAbCustomZipBrowser.SetZipfileComment(const Value : AnsiString);
begin
{NOP - descendents wishing to set this property should override}
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbZLTyp.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbZLTyp.pas *}
{*********************************************************}
{* ABBREVIA: TAbZlItem class *}
{*********************************************************}
{* Misc. constants, types, and routines for working *}
{* with ZLib compressed data *}
{* See: RFC 1950 *}
{* "ZLIB Compressed Data Format Specification *}
{* version 3.3" for more information on ZLib *}
{*********************************************************}
unit AbZLTyp;
{$I AbDefine.inc}
interface
uses
SysUtils, Classes, AbUtils, AbArcTyp, AbZipPrc, AbDfBase, AbDfDec, AbDfEnc;
const
AB_ZL_PRESET_DICT = $20;
AB_ZL_DEF_COMPRESSIONMETHOD = $8; { Deflate }
AB_ZL_DEF_COMPRESSIONINFO = $7; { 32k window for Deflate }
AB_ZL_FASTEST_COMPRESSION = $0;
AB_ZL_FAST_COMPRESSION = $1;
AB_ZL_DEFAULT_COMPRESSION = $2;
AB_ZL_MAXIMUM_COMPRESSION = $3;
AB_ZL_FCHECK_MASK = $1F;
AB_ZL_CINFO_MASK = $F0; { mask out leftmost 4 bits }
AB_ZL_FLEVEL_MASK = $C0; { mask out leftmost 2 bits }
AB_ZL_CM_MASK = $0F; { mask out rightmost 4 bits }
type
TAbZLHeader = packed record
CMF : Byte;
FLG : Byte;
end;
TAbZLItem = class(TAbArchiveItem)
private
function GetCompressionInfo: Byte;
function GetCompressionLevel: Byte;
function GetIsPresetDictionaryPresent: Boolean;
procedure SetCompressionInfo(Value: Byte);
procedure SetCompressionLevel(Value: Byte);
function GetCompressionMethod: Byte;
procedure SetCompressionMethod(Value: Byte);
function GetFCheck: Byte;
procedure MakeFCheck;
protected { private }
FZLHeader : TAbZlHeader;
FAdler32 : LongInt;
public
constructor Create;
property IsPresetDictionaryPresent : Boolean
read GetIsPresetDictionaryPresent;
property CompressionLevel : Byte
read GetCompressionLevel write SetCompressionLevel;
property CompressionInfo : Byte
read GetCompressionInfo write SetCompressionInfo;
property CompressionMethod : Byte
read GetCompressionMethod write SetCompressionMethod;
property Adler32 : LongInt
read FAdler32 write FAdler32;
property FCheck : Byte
read GetFCheck;
procedure SaveZLHeaderToStream(AStream : TStream);
procedure ReadZLHeaderFromStream(AStream : TStream);
end;
TAbZLStreamHelper = class(TAbArchiveStreamHelper)
protected { private }
FItem : TAbZLItem;
public
constructor Create(AStream : TStream);
destructor Destroy; override;
property Item : TAbZLItem
read FItem;
procedure ExtractItemData(AStream : TStream); override;
function FindFirstItem : Boolean; override;
function FindNextItem : Boolean; override;
procedure ReadHeader; override;
procedure ReadTail; override;
function SeekItem(Index : Integer): Boolean; override;
procedure WriteArchiveHeader; override;
procedure WriteArchiveItem(AStream : TStream); override;
procedure WriteArchiveTail; override;
function GetItemCount : Integer; override;
end;
implementation
{ TAbZLStreamHelper }
constructor TAbZLStreamHelper.Create(AStream: TStream);
begin
inherited Create(AStream);
FItem := TAbZLItem.Create;
end;
destructor TAbZLStreamHelper.Destroy;
begin
FItem.Free;
inherited Destroy;
end;
procedure TAbZLStreamHelper.ExtractItemData(AStream: TStream);
{ assumes already positioned appropriately }
var
Hlpr : TAbDeflateHelper;
begin
Hlpr := TAbDeflateHelper.Create;
Hlpr.Options := Hlpr.Options or dfc_UseAdler32;
if not FItem.IsPresetDictionaryPresent then
Inflate(FStream, AStream, Hlpr)
else
raise Exception.Create('preset dictionaries unsupported');
Hlpr.Free;
end;
function TAbZLStreamHelper.FindFirstItem: Boolean;
var
ZLH : TAbZLHeader;
begin
FStream.Seek(0, soBeginning);
Result := FStream.Read(ZLH, SizeOf(TAbZLHeader)) = SizeOf(TAbZLHeader);
FItem.FZLHeader := ZLH;
FStream.Seek(0, soBeginning);
end;
function TAbZLStreamHelper.FindNextItem: Boolean;
begin
{ only one item in a ZLib Stream }
Result := FindFirstItem;
end;
function TAbZLStreamHelper.GetItemCount: Integer;
begin
{ only one item in a ZLib Stream }
Result := 1;
end;
procedure TAbZLStreamHelper.ReadHeader;
{ assumes already positioned appropriately }
var
ZLH : TAbZLHeader;
begin
FStream.Read(ZLH, SizeOf(TAbZlHeader));
FItem.FZLHeader := ZLH;
end;
procedure TAbZLStreamHelper.ReadTail;
{ assumes already positioned appropriately }
var
Adler: LongInt;
begin
FStream.Read(Adler, SizeOf(LongInt));
FItem.Adler32 := Adler;
end;
function TAbZLStreamHelper.SeekItem(Index: Integer): Boolean;
begin
{ only one item in a ZLib Stream }
if Index <> 1 then
Result := False
else
Result := FindFirstItem;
end;
procedure TAbZLStreamHelper.WriteArchiveHeader;
begin
Item.SaveZLHeaderToStream(FStream);
end;
procedure TAbZLStreamHelper.WriteArchiveItem(AStream: TStream);
var
Hlpr : TAbDeflateHelper;
begin
{ Compress file }
Hlpr := TAbDeflateHelper.Create;
Hlpr.Options := Hlpr.Options or dfc_UseAdler32;
Item.Adler32 := AbDfEnc.Deflate(AStream, FStream, Hlpr);
Hlpr.Free;
end;
procedure TAbZLStreamHelper.WriteArchiveTail;
var
Ad32 : LongInt;
begin
Ad32 := AbSwapLongEndianness(Item.Adler32);
FStream.Write(Ad32, SizeOf(LongInt));
end;
{ TAbZLItem }
constructor TAbZLItem.Create;
begin
{ Set default Values for fields }
FillChar(FZLHeader, SizeOf(TAbZlHeader), #0);
FZLHeader.CMF := (AB_ZL_DEF_COMPRESSIONINFO shl 4); { 32k Window size }
FZLHeader.CMF := FZLHeader.CMF or AB_ZL_DEF_COMPRESSIONMETHOD; { Deflate }
FZLHeader.FLG := FZLHeader.FLG and not AB_ZL_PRESET_DICT; { no preset dictionary}
FZLHeader.FLG := FZLHeader.FLG or (AB_ZL_DEFAULT_COMPRESSION shl 6); { assume default compression }
MakeFCheck;
end;
function TAbZLItem.GetCompressionInfo: Byte;
begin
Result := FZLHeader.CMF shr 4;
end;
function TAbZLItem.GetCompressionLevel: Byte;
begin
Result := FZLHeader.FLG shr 6;
end;
function TAbZLItem.GetCompressionMethod: Byte;
begin
Result := FZLHeader.CMF and AB_ZL_CM_MASK;
end;
function TAbZLItem.GetFCheck: Byte;
begin
Result := FZLHeader.FLG and AB_ZL_FCHECK_MASK;
end;
function TAbZLItem.GetIsPresetDictionaryPresent: Boolean;
begin
Result := (FZLHeader.FLG and AB_ZL_PRESET_DICT) = AB_ZL_PRESET_DICT;
end;
procedure TAbZLItem.MakeFCheck;
{ create the FCheck value for the current Header }
var
zlh : Word;
begin
FZLHeader.FLG := FZLHeader.FLG and not AB_ZL_FCHECK_MASK;
zlh := (FZLHeader.CMF * 256) + FZLHeader.FLG;
Inc(FZLHeader.FLG, 31 - (zlh mod 31));
end;
procedure TAbZLItem.ReadZLHeaderFromStream(AStream: TStream);
begin
AStream.Read(FZLHeader, SizeOf(TAbZLHeader));
end;
procedure TAbZLItem.SaveZLHeaderToStream(AStream: TStream);
begin
MakeFCheck;
AStream.Write(FZLHeader, SizeOf(TAbZlHeader));
end;
procedure TAbZLItem.SetCompressionInfo(Value: Byte);
begin
FZLHeader.CMF := FZLHeader.CMF and not AB_ZL_CINFO_MASK;
FZLHeader.CMF := FZLHeader.CMF or (Value shl 4); { shift value and add to bit field }
end;
procedure TAbZLItem.SetCompressionLevel(Value: Byte);
var
Temp : Byte;
begin
Temp := Value;
if not Temp in [AB_ZL_FASTEST_COMPRESSION..AB_ZL_MAXIMUM_COMPRESSION] then
Temp := AB_ZL_DEFAULT_COMPRESSION;
FZLHeader.FLG := FZLHeader.FLG and not AB_ZL_FLEVEL_MASK;
FZLHeader.FLG := FZLHeader.FLG or (Temp shl 6); { shift value and add to bit field }
end;
procedure TAbZLItem.SetCompressionMethod(Value: Byte);
begin
if Value > AB_ZL_CM_MASK then Value := (Value shl 4) shr 4;
FZLHeader.CMF := FZLHeader.CMF and not AB_ZL_CM_MASK;
FZLHeader.CMF := FZLHeader.CMF or Value;
end;
end.
================================================
FILE: lib/abbrevia/source/AbZView.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbZView.pas *}
{*********************************************************}
{* ABBREVIA: Zip archive viewer component *}
{* Use AbQZView.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
unit AbZView;
{$ENDIF}
{$I AbDefine.inc}
interface
uses
Classes,
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
{$IFDEF UsingCLX }
QControls,
AbQView,
{$ELSE}
Controls,
AbView,
{$ENDIF}
AbZBrows,
AbZipTyp;
type
TAbIncludeItemEvent = procedure (Sender: TObject;
Item: TAbZipItem;
var Include: Boolean) of object;
TAbZipView = class(TAbBaseViewer)
protected
FZipComponent : TAbCustomZipBrowser;
FOnIncludeItem: TAbIncludeItemEvent;
function GetItem(RowNum : Longint) : TAbZipItem;
procedure SetZipComponent(Value : TAbCustomZipBrowser);
procedure Notification(AComponent : TComponent; Operation : TOperation);
override;
procedure DoChange(Sender : TObject);
override;
public
property Items[RowNum : Longint] : TAbZipItem
read GetItem;
published {properties}
property Align;
property Anchors;
property Attributes;
{$IFNDEF UsingCLX}
property BevelEdges;
property BevelInner;
property BevelKind;
property BevelOuter;
property BevelWidth;
{$ENDIF}
property BorderStyle;
property Color;
property Colors;
{$IFNDEF UsingCLX}
property Ctl3D;
property ParentCtl3D;
property DragCursor;
{$ENDIF}
property Cursor;
property Headings;
property DefaultColWidth;
property DefaultRowHeight;
property DisplayOptions;
property HeaderRowHeight;
property SortAttributes;
property DragMode;
{$IFDEF HasGridDrawingStyle}
property DrawingStyle;
{$ENDIF}
property Enabled;
property Font;
{$IFDEF HasGridDrawingStyle}
property GradientEndColor;
property GradientStartColor;
{$ENDIF}
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
{$IFDEF HasTouch}
property Touch;
{$ENDIF}
property Version;
property ZipComponent : TAbCustomZipBrowser
read FZipComponent write SetZipComponent;
published {Events}
property OnChange;
property OnClick;
property OnDblClick;
property OnEnter;
property OnExit;
{$IFDEF HasTouch}
property OnGesture;
{$ENDIF}
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
{$IFDEF HasOnMouseActivate}
property OnMouseActivate;
{$ENDIF}
property OnMouseDown;
{$IFDEF HasOnMouseEnter}
property OnMouseEnter;
property OnMouseLeave;
{$ENDIF}
property OnMouseMove;
property OnMouseUp;
property OnSorted;
property OnDrawSortArrow;
property OnIncludeItem: TAbIncludeItemEvent
read FOnIncludeItem
write FOnIncludeItem;
end;
implementation
uses
AbArcTyp;
{ ===== TAbZipView ========================================================= }
function TAbZipView.GetItem(RowNum : Longint) : TAbZipItem;
begin
if Assigned(FItemList) then
Result := TAbZipItem(FItemList.Items[FRowMap[RowNum]])
else
Result := nil;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipView.Notification(AComponent : TComponent; Operation : TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
if Assigned(FZipComponent) and (AComponent = FZipComponent) then begin
FZipComponent := nil;
Refresh;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipView.SetZipComponent(Value : TAbCustomZipBrowser);
begin
if Value <> nil then begin
FZipComponent := Value;
if not (csDesigning in ComponentState) then begin
FZipComponent.OnChange := DoChange;
FZipComponent.OnLoad := DoLoad;
DoChange(Self);
end;
end
else
FZipComponent := nil;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipView.DoChange(Sender : TObject);
var
i : Integer;
TheArchive : TAbArchive;
Include : Boolean;
begin
FItemList.Clear;
if Assigned(FZipComponent) then begin
{ let's make this a bit easier to read }
TheArchive := FZipComponent.FArchive;
if Assigned(TheArchive) then begin
for i := 0 to Pred(TheArchive.ItemList.Count) do begin
if Assigned(FOnIncludeItem) then begin
FOnIncludeItem(self, TAbZipItem(TheArchive.ItemList[i]), Include);
if Include then
FItemList.Add(TheArchive.ItemList[i]);
end
else begin
{ if it doesn't look like a folder place holder... }
if TAbZipItem(TheArchive.ItemList[i]).DiskFileName <>
TAbZipItem(TheArchive.ItemList[i]).DiskPath then
{ ...add it to the display list }
FItemList.Add(TheArchive.ItemList[i]);
end;
end;
end
else
FItemList.Clear;
end
else
FItemList.Clear;
inherited DoChange(Sender);
end;
end.
================================================
FILE: lib/abbrevia/source/AbZipExt.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbZipExt.pas *}
{*********************************************************}
{* ABBREVIA: Zip file registration *}
{*********************************************************}
unit AbZipExt;
{$I AbDefine.inc}
interface
uses
SysUtils, Classes;
function AbExistingZipAssociation : Boolean;
function AbGetZipAssociation(var App, ID, FileType : string) : Boolean;
function AbRegisterZipExtension(const App : string;
ID, FileType : string;
Replace : Boolean) : Boolean;
implementation
uses
{$IFDEF MSWINDOWS}
Windows,
Messages,
Registry,
ShellAPI,
{$ENDIF}
{$IFDEF LibcAPI}
Libc,
{$ENDIF}
AbConst;
const
ZipExt = '.zip';
DefZipID = 'Zip';
DefZipType = 'Zip File';
OpenCommand = 'Shell\Open\Command';
DefaultIcon = 'DefaultIcon';
var
Reg : TRegistry;
{ -------------------------------------------------------------------------- }
function AbExistingZipAssociation : Boolean;
var
App, ID, FileType : string;
begin
Result := False;
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CLASSES_ROOT;
Reg.OpenKey('',False);
if Reg.OpenKey(ZipExt, False) then begin
ID := Reg.ReadString('');
if Reg.OpenKey('\' + ID, False) then begin
FileType := Reg.ReadString('');
if Reg.OpenKey(OpenCommand, False) then begin
App := Reg.ReadString('');
if (App <> '') then
Result := True;
end;
end;
end;
Reg.Free;
end;
{ -------------------------------------------------------------------------- }
function AbGetZipAssociation(var App, ID, FileType : string) : Boolean;
begin
Result := False;
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CLASSES_ROOT;
Reg.OpenKey('',False);
if Reg.OpenKey(ZipExt, False) then begin
ID := Reg.ReadString('');
if Reg.OpenKey('\' + ID, False) then begin
FileType := Reg.ReadString('');
if Reg.OpenKey(OpenCommand, False) then begin
App := Reg.ReadString('');
Result := True;
end;
end;
end;
Reg.Free;
end;
{ -------------------------------------------------------------------------- }
function AbRegisterZipExtension(const App : string;
ID, FileType : string;
Replace : Boolean) : Boolean;
begin
Result := False;
if AbExistingZipAssociation and not Replace then
Exit;
try
if (ID = '') then
ID := DefZipID;
if (FileType = '') then
FileType := DefZipType;
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CLASSES_ROOT;
Reg.OpenKey('',False);
Reg.OpenKey(ZipExt, True);
Reg.WriteString('', ID);
Reg.OpenKey('\' + ID, True);
Reg.WriteString('', FileType);
Reg.OpenKey(OpenCommand, True);
Reg.WriteString('', App);
Reg.OpenKey('\' + DefaultIcon, True);
Reg.WriteString('', App + ',0');
Result := True;
finally
Reg.Free;
end;
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbZipKit.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbZipKit.pas *}
{*********************************************************}
{* ABBREVIA: TABZipKit component *}
{*********************************************************}
unit AbZipKit;
{$I AbDefine.inc}
interface
uses
Classes, AbZipper, AbArcTyp, AbZipTyp;
type
TAbCustomZipKit = class(TAbCustomZipper)
protected {private}
FExtractOptions : TAbExtractOptions;
FOnConfirmOverwrite : TAbConfirmOverwriteEvent;
FOnNeedPassword : TAbNeedPasswordEvent;
FPasswordRetries : Byte;
protected {methods}
procedure DoConfirmOverwrite(var Name : string; var Confirm : Boolean);
virtual;
procedure DoNeedPassword(Sender : TObject; var NewPassword : AnsiString);
virtual;
procedure InitArchive;
override;
procedure SetExtractOptions(Value : TAbExtractOptions);
procedure SetPasswordRetries(Value : Byte);
procedure UnzipProc(Sender : TObject; Item : TAbArchiveItem;
const NewName : string );
procedure UnzipToStreamProc(Sender : TObject; Item : TAbArchiveItem;
OutStream : TStream);
procedure TestItemProc(Sender : TObject; Item : TAbArchiveItem);
protected {properties}
property ExtractOptions : TAbExtractOptions
read FExtractOptions
write SetExtractOptions
default AbDefExtractOptions;
property PasswordRetries : Byte
read FPasswordRetries
write SetPasswordRetries
default AbDefPasswordRetries;
protected {events}
property OnConfirmOverwrite : TAbConfirmOverwriteEvent
read FOnConfirmOverwrite
write FOnConfirmOverwrite;
property OnNeedPassword : TAbNeedPasswordEvent
read FOnNeedPassword
write FOnNeedPassword;
public {methods}
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
procedure ExtractAt(Index : Integer; const NewName : string);
procedure ExtractFiles(const FileMask : string);
{extract all files from the archive that match the mask}
procedure ExtractFilesEx(const FileMask, ExclusionMask : string);
{extract files matching FileMask except those matching ExclusionMask}
procedure ExtractTaggedItems;
{extract all tagged items from the archive}
procedure ExtractToStream(const aFileName : string; ToStream : TStream);
{extract the specified item to TStream descendant}
procedure TestTaggedItems;
{test all tagged items in the archive}
public {property}
property Spanned;
end;
TAbZipKit = class(TAbCustomZipKit)
published
property ArchiveProgressMeter;
property ArchiveSaveProgressMeter;
property AutoSave;
property BaseDirectory;
property CompressionMethodToUse;
property DeflationOption;
{$IFDEF MSWINDOWS}
property DOSMode;
{$ENDIF}
property ExtractOptions;
property SpanningThreshold;
property ItemProgressMeter;
property LogFile;
property Logging;
property OnArchiveProgress;
property OnArchiveSaveProgress;
property OnArchiveItemProgress;
property OnChange;
property OnConfirmOverwrite;
property OnConfirmProcessItem;
property OnConfirmSave;
property OnLoad;
property OnNeedPassword;
property OnProcessItemFailure;
property OnRequestBlankDisk;
property OnRequestImage;
property OnRequestLastDisk;
property OnRequestNthDisk;
property OnSave;
property Password;
property PasswordRetries;
property StoreOptions;
property TempDirectory;
property Version;
property FileName; {must be after OnLoad}
end;
implementation
uses
AbExcept,
AbUnzPrc,
AbZBrows;
{ -------------------------------------------------------------------------- }
constructor TAbCustomZipKit.Create( AOwner : TComponent );
begin
inherited Create( AOwner );
PasswordRetries := AbDefPasswordRetries;
end;
{ -------------------------------------------------------------------------- }
destructor TAbCustomZipKit.Destroy;
begin
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.DoConfirmOverwrite( var Name : string;
var Confirm : Boolean );
begin
Confirm := True;
if Assigned( FOnConfirmOverwrite ) then
FOnConfirmOverwrite( Name, Confirm );
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.DoNeedPassword( Sender : TObject;
var NewPassword : AnsiString );
begin
if Assigned( FOnNeedPassword ) then begin
FOnNeedPassword( Self, NewPassword );
FPassword := NewPassword;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.ExtractAt(Index : Integer; const NewName : string);
{extract a file from the archive that match the index}
begin
if (FArchive <> nil) then
FArchive.ExtractAt( Index, NewName )
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.ExtractFiles(const FileMask : string);
{extract all files from the archive that match the mask}
begin
if (FArchive <> nil) then
FArchive.ExtractFiles( FileMask )
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.ExtractFilesEx(const FileMask, ExclusionMask : string);
{extract files matching FileMask except those matching ExclusionMask}
begin
if (FArchive <> nil) then
FArchive.ExtractFilesEx( FileMask, ExclusionMask )
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.ExtractTaggedItems;
{extract all tagged items from the archive}
begin
if (FArchive <> nil) then
FArchive.ExtractTaggedItems
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.ExtractToStream(const aFileName : string;
ToStream : TStream);
begin
if (FArchive <> nil) then
FArchive.ExtractToStream(aFileName, ToStream)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.InitArchive;
begin
inherited InitArchive;
if (FArchive <> nil) then begin
FArchive.ExtractOptions := FExtractOptions;
FArchive.OnConfirmOverwrite := DoConfirmOverwrite;
end;
if FArchive is TAbZipArchive then begin
{properties}
TAbZipArchive(FArchive).PasswordRetries := FPasswordRetries;
{events}
TAbZipArchive(FArchive).OnNeedPassword := DoNeedPassword;
TAbZipArchive(FArchive).ExtractHelper := UnzipProc;
TAbZipArchive(FArchive).ExtractToStreamHelper := UnzipToStreamProc;
TAbZipArchive(FArchive).TestHelper := TestItemProc;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.SetExtractOptions( Value : TAbExtractOptions );
begin
FExtractOptions := Value;
if (FArchive <> nil) then
FArchive.ExtractOptions := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.SetPasswordRetries( Value : Byte );
begin
FPasswordRetries := Value;
if (FArchive <> nil) then
(FArchive as TAbZipArchive).PasswordRetries := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.TestTaggedItems;
{test all tagged items in the archive}
begin
if (FArchive <> nil) then
FArchive.TestTaggedItems
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.UnzipProc( Sender : TObject; Item : TAbArchiveItem;
const NewName : string );
begin
AbUnzip( TAbZipArchive(Sender), TAbZipItem(Item), NewName);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.UnzipToStreamProc(Sender : TObject; Item : TAbArchiveItem;
OutStream : TStream);
begin
AbUnzipToStream(TAbZipArchive(Sender), TAbZipItem(Item), OutStream);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipKit.TestItemProc(Sender : TObject; Item : TAbArchiveItem);
begin
AbTestZipItem(TAbZipArchive(Sender), TAbZipItem(Item));
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbZipOut.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbZipOut.pas *}
{*********************************************************}
{* ABBREVIA: Visual Component with Zip and unzip support *}
{* Use AbQZpOut.pas for CLX *}
{*********************************************************}
{$IFNDEF UsingCLX}
unit AbZipOut;
{$ENDIF}
{$I AbDefine.inc}
interface
uses
Classes,
{$IFDEF MSWINDOWS}
Windows,
Messages,
{$ENDIF}
Types,
{$IFDEF UsingCLX}
QGraphics,
QComCtrls,
QImglist,
QControls,
QForms,
{$ELSE}
Graphics,
Controls,
Forms,
ComCtrls,
Imglist,
{$ENDIF}
AbArcTyp,
AbBrowse,
AbUtils,
AbZipTyp;
const
cBitmapHeight = 16;
cBitmapWidth = 16;
type
TAbZipAttribute =
(zaCompressedSize, zaCompressionMethod, zaCompressionRatio, zaCRC,
zaExternalFileAttributes, zaInternalFileAttributes, zaEncryption,
zaTimeStamp, zaUncompressedSize, zaVersionMade, zaVersionNeeded,
zaComment);
TAbZipAttributes = set of TAbZipAttribute;
const
AbDefZipAttributes =
[zaCompressedSize, zaCompressionMethod, zaCompressionRatio, zaCRC,
zaExternalFileAttributes, zaEncryption, zaTimeStamp, zaUncompressedSize];
AbDefColor = clWindow;
AbDefHierarchy = True;
AbDefParentColor = False;
{.Z+}
type
TTreeNodeFriend = class(TTreeNode)
end;
{.Z-}
type
TWindowsDropEvent =
procedure(Sender : TObject; FileName : string) of object;
{TAbZipDisplayOutline does not support Owner-Draw}
type
TAbZipDisplayOutline = class(TTreeView)
private
FDirBitMap : TBitMap;
FFileBitMap : TBitMap;
FAttrBitMap : TBitMap;
FDirBitMapSelected : TBitMap;
FFileBitMapSelected : TBitMap;
FAttrBitMapSelected : TBitMap;
FImageList : TImageList;
FFileIndex : integer;
FFileSelectedIndex : integer;
FDirectoryIndex : integer;
FDirSelectedIndex : integer;
FAttrIndex : integer;
FBitMapHeight : integer;
FBitMapWidth : integer;
FAttrSelectedIndex : integer;
FOnWindowsDrop : TWindowsDropEvent;
{$IFNDEF UsingCLX}
procedure WMDropFiles(var Msg : TWMDropFiles);
message WM_DROPFILES;
{$ENDIF}
procedure IndexBitmaps;
procedure SetDirectoryBitMap(Value : TBitmap);
procedure SetFileBitMap(Value : TBitmap);
procedure SetAttributeBitMap(Value : TBitmap);
procedure SetDirectoryBitMapSelected(Value : TBitmap);
procedure SetFileBitMapSelected(Value : TBitmap);
procedure SetAttributeBitMapSelected(Value : TBitmap);
procedure SetBitMapHeight(Value : Integer);
procedure SetBitMapWidth(Value : Integer);
protected
procedure DoOnWindowsDrop(FileName : string); virtual;
{$IFDEF UsingCLX}
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
const MousePos: TPoint): Boolean;
override;
{$ELSE}
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean;
override;
{$ENDIF}
procedure Loaded; override;
procedure SetOnWindowsDrop(Value : TWindowsDropEvent);
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
public
property zdPictureDirectory : TBitmap
read FDirBitMap
write SetDirectoryBitMap;
property zdPictureFile : TBitmap
read FFileBitMap
write SetFileBitMap;
property zdPictureZipAttribute : TBitmap
read FAttrBitMap
write SetAttributeBitMap;
property zdPictureDirectorySelected : TBitmap
read FDirBitMapSelected
write SetDirectoryBitMapSelected;
property zdPictureFileSelected : TBitmap
read FFileBitMapSelected
write SetFileBitMapSelected;
property zdPictureZipAttributeSelected : TBitmap
read FAttrBitMapSelected
write SetAttributeBitMapSelected;
property BitMapHeight : Integer
read FBitMapHeight
write SetBitMapHeight;
property BitMapWidth : Integer
read FBitMapWidth
write SetBitMapWidth;
property OnWindowsDrop : TWindowsDropEvent
read FOnWindowsDrop
write SetOnWindowsDrop;
end;
type
{$IFDEF UsingClx}
TAbCustomZipOutline = class(TWidgetControl)
{$ELSE}
TAbCustomZipOutline = class(TWinControl)
{$ENDIF}
protected {private}
FArchive : TAbZipArchive;
FItemProgressMeter : IAbProgressMeter;
FArchiveProgressMeter : IAbProgressMeter;
FAttributes : TAbZipAttributes;
FAutoSave : Boolean;
FBaseDirectory : string;
FCompressionMethodToUse : TAbZipSupportedMethod;
FDeflationOption : TAbZipDeflationOption;
{$IFDEF MSWINDOWS}
FDOSMode : Boolean;
{$ENDIF}
FFileName : string;
FExtractOptions : TAbExtractOptions;
FHierarchy : Boolean;
FLogFile : string;
FLogging : Boolean;
FSpanningThreshold : Longint;
FOutline : TAbZipDisplayOutline;
FPassword : AnsiString;
FPasswordRetries : Byte;
FStoreOptions : TAbStoreOptions;
FTempDirectory : string;
FOnProcessItemFailure : TAbArchiveItemFailureEvent;
FOnArchiveItemProgress : TAbArchiveItemProgressEvent;
FOnArchiveProgress : TAbArchiveProgressEvent;
FOnChange : TNotifyEvent;
FOnClick : TNotifyEvent;
FOnCollapse : TTVExpandedEvent;
FOnConfirmOverwrite : TAbConfirmOverwriteEvent;
FOnConfirmProcessItem : TAbArchiveItemConfirmEvent;
FOnConfirmSave : TAbArchiveConfirmEvent;
FOnDblClick : TNotifyEvent;
FOnDragDrop : TDragDropEvent;
FOnDragOver : TDragOverEvent;
FOnEndDrag : TEndDragEvent;
FOnEnter : TNotifyEvent;
FOnExit : TNotifyEvent;
FOnExpand : TTVExpandedEvent;
FOnKeyDown : TKeyEvent;
FOnKeyPress : TKeyPressEvent;
FOnKeyUp : TKeyEvent;
FOnLoad : TAbArchiveEvent;
FOnMouseDown : TMouseEvent;
FOnMouseMove : TMouseMoveEvent;
FOnMouseUp : TMouseEvent;
FOnNeedPassword : TAbNeedPasswordEvent;
FOnRequestImage : TAbRequestImageEvent;
FOnRequestLastDisk : TAbRequestDiskEvent;
FOnRequestNthDisk : TAbRequestNthDiskEvent;
FOnRequestBlankDisk : TAbRequestDiskEvent;
FOnSave : TAbArchiveEvent;
{$IFDEF MSWINDOWS}
FOnStartDrag : TStartDragEvent;
{$ENDIF MSWINDOWS}
FOnWindowsDrop : TWindowsDropEvent;
protected {methods}
procedure AddAttributeNodes(Item : TAbZipItem; oNode : TTreeNode);
procedure DoProcessItemFailure(Sender : TObject; Item : TAbArchiveItem;
ProcessType : TAbProcessType;
ErrorClass : TAbErrorClass;
ErrorCode : Integer); virtual;
procedure DoArchiveItemProgress(Sender : TObject; Item : TAbArchiveItem;
Progress : Byte; var Abort : Boolean); virtual;
procedure DoArchiveProgress(Sender : TObject; Progress : Byte;
var Abort : Boolean); virtual;
procedure DoChange; virtual;
procedure DoClick(Sender : TObject); virtual;
procedure DoCollapse(Sender : TObject; Node: TTreeNode); virtual;
procedure DoConfirmProcessItem(Sender : TObject; Item : TAbArchiveItem;
ProcessType : TAbProcessType;
var Confirm : Boolean); virtual;
procedure DoConfirmOverwrite(var Name : string; var Confirm : Boolean); virtual;
procedure DoConfirmSave(Sender : TObject; var Confirm : Boolean); virtual;
procedure DoDblClick(Sender : TObject); virtual;
procedure DoDragDrop(Sender, Source: TObject; X, Y: Integer); virtual;
procedure DoDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean); virtual;
procedure DoOnEndDrag(Sender, Target: TObject; X, Y: Integer); virtual;
procedure DoOnEnter(Sender : TObject); virtual;
procedure DoOnExit(Sender : TObject); virtual;
procedure DoExpand(Sender: TObject; Node : TTreeNode); virtual;
procedure DoKeyDown(Sender : TObject; var Key: Word; Shift: TShiftState);
virtual;
procedure DoKeyPress(Sender : TObject; var Key: Char); virtual;
procedure DoKeyUp(Sender : TObject; var Key: Word; Shift: TShiftState);
virtual;
procedure DoLoad(Sender : TObject); virtual;
procedure DoMouseDown(Sender : TObject; Button: TMouseButton;
Shift: TShiftState; X, Y : Integer); virtual;
procedure DoMouseMove(Sender : TObject; Shift: TShiftState; X, Y: Integer);
virtual;
procedure DoMouseUp(Sender : TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); virtual;
procedure DoNeedPassword(Sender : TObject; var NewPassword : AnsiString);
virtual;
procedure DoSave(Sender : TObject); virtual;
{$IFDEF MSWINDOWS}
procedure DoOnStartDrag(Sender: TObject; var DragObject: TDragObject);
virtual;
{$ENDIF}
procedure DoWindowsDrop(Sender : TObject; FileName : string); virtual;
function GetBorderStyle : TBorderStyle;
function GetCount : Integer;
function GetCursor : TCursor;
{$IFNDEF UsingCLX}
function GetDragCursor : TCursor;
{$ENDIF}
function GetDragMode : TDragMode;
function GetItem(Index : Integer) : TAbZipItem;
function GetPictureDirectory : TBitmap;
function GetPictureFile : TBitmap;
function GetPictureZipAttribute: TBitmap;
function GetPictureDirectorySelected : TBitmap;
function GetPictureFileSelected : TBitmap;
function GetPictureZipAttributeSelected : TBitmap;
function GetPictureHeight : Integer;
function GetPictureWidth : Integer;
function GetSelectedItem : LongInt;
function GetSelectedZipItem : TAbZipItem;
function GetStatus : TAbArchiveStatus;
function GetVersion : string;
function GetZipfileComment : AnsiString;
procedure InitArchive;
procedure Loaded; override;
procedure Notification(Component: TComponent; Operation: TOperation);
override;
procedure PutItem(Index : Integer; Value : TAbZipItem);
procedure SetArchiveProgressMeter(const Value: IAbProgressMeter);
procedure SetAttributes(Value : TAbZipAttributes);
procedure SetAutoSave(Value : Boolean);
procedure SetBaseDirectory(Value : string);
procedure SetBorderStyle(Value : TBorderStyle);
procedure SetCompressionMethodToUse(Value : TAbZipSupportedMethod);
procedure SetDeflationOption(Value : TAbZipDeflationOption);
{$IFDEF MSWINDOWS}
procedure SetDOSMode(Value : Boolean);
{$ENDIF}
procedure SetCursor(Value : TCursor);
{$IFNDEF UsingCLX}
procedure SetDragCursor(Value : TCursor);
{$ENDIF}
{$IFNDEF UsingCLX}
procedure SetDragMode(Value : TDragMode); override;
{$ENDIF}
procedure SetExtractOptions(Value : TAbExtractOptions);
procedure SetFileName(const aFileName : string); virtual;
procedure SetHierarchy(Value : Boolean);
procedure SetItemProgressMeter(const Value: IAbProgressMeter);
procedure SetLogFile(Value : string);
procedure SetLogging(Value : Boolean);
procedure SetOnRequestImage(Value : TAbRequestImageEvent);
procedure SetOnRequestLastDisk(Value : TAbRequestDiskEvent);
procedure SetOnRequestNthDisk(Value : TAbRequestNthDiskEvent);
procedure SetOnRequestBlankDisk(Value : TAbRequestDiskEvent);
procedure SetOnWindowsDrop(Value : TWindowsDropEvent);
procedure SetPassword(Value : AnsiString);
procedure SetPasswordRetries(Value : Byte);
procedure SetPictureDirectory(Value : TBitmap);
procedure SetPictureFile(Value : TBitmap);
procedure SetPictureZipAttribute(Value : TBitmap);
procedure SetPictureDirectorySelected(Value : TBitmap);
procedure SetPictureFileSelected(Value : TBitmap);
procedure SetPictureZipAttributeSelected(Value : TBitmap);
procedure SetPictureHeight(Value : Integer);
procedure SetPictureWidth(Value : Integer);
procedure SetSelectedItem(Value : LongInt);
procedure SetStoreOptions(Value : TAbStoreOptions);
procedure SetTempDirectory(Value : string);
procedure SetSpanningThreshold(Value : Longint);
procedure SetVersion(Value : string);
procedure SetZipfileComment(Value : AnsiString);
procedure TestItemProc(Sender : TObject; Item : TAbArchiveItem);
procedure UnzipProc(Sender : TObject; Item : TAbArchiveItem;
const NewName : string);
procedure UnzipToStreamProc(Sender : TObject; Item : TAbArchiveItem;
OutStream : TStream);
procedure UpdateOutline;
procedure ZipProc(Sender : TObject; Item : TAbArchiveItem;
OutStream : TStream);
procedure ZipFromStreamProc(Sender : TObject; Item : TAbArchiveItem;
OutStream, InStream : TStream);
protected {properties}
property ArchiveProgressMeter : IAbProgressMeter
read FArchiveProgressMeter
write SetArchiveProgressMeter;
property Attributes : TAbZipAttributes
read FAttributes
write SetAttributes
default AbDefZipAttributes;
property AutoSave : Boolean
read FAutoSave
write SetAutoSave
default AbDefAutoSave;
property BaseDirectory : string
read FBaseDirectory
write SetBaseDirectory;
property BorderStyle : TBorderStyle
read GetBorderStyle
write SetBorderStyle;
property CompressionMethodToUse : TAbZipSupportedMethod
read FCompressionMethodToUse
write SetCompressionMethodToUse
default AbDefCompressionMethodToUse;
property Cursor : TCursor
read GetCursor
write SetCursor;
property DeflationOption : TAbZipDeflationOption
read FDeflationOption
write SetDeflationOption
default AbDefDeflationOption;
{$IFDEF MSWINDOWS}
property DOSMode : Boolean
read FDOSMode
write SetDOSMode;
{$ENDIF}
{$IFNDEF UsingCLX}
property DragCursor : TCursor
read GetDragCursor
write SetDragCursor;
property DragMode : TDragMode
read GetDragMode
write SetDragMode;
{$ENDIF}
property ExtractOptions : TAbExtractOptions
read FExtractOptions
write SetExtractOptions
default AbDefExtractOptions;
property FileName : string
read FFileName
write SetFileName;
property Hierarchy : Boolean
read FHierarchy
write SetHierarchy
default AbDefHierarchy;
property SpanningThreshold : Longint
read FSpanningThreshold
write SetSpanningThreshold
default 0;
property ItemProgressMeter : IAbProgressMeter
read FItemProgressMeter
write SetItemProgressMeter;
property LogFile : string
read FLogFile
write SetLogFile;
property Logging : Boolean
read FLogging
write SetLogging;
property OnWindowsDrop : TWindowsDropEvent
read FOnWindowsDrop
write SetOnWindowsDrop;
property Password : AnsiString
read FPassword
write SetPassword;
property PasswordRetries : Byte
read FPasswordRetries
write SetPasswordRetries
default AbDefPasswordRetries;
property PictureDirectory : TBitmap
read GetPictureDirectory
write SetPictureDirectory;
property PictureFile : TBitmap
read GetPictureFile
write SetPictureFile;
property PictureZipAttribute : TBitmap
read GetPictureZipAttribute
write SetPictureZipAttribute;
property PictureDirectorySelected : TBitmap
read GetPictureDirectorySelected
write SetPictureDirectorySelected;
property PictureFileSelected : TBitmap
read GetPictureFileSelected
write SetPictureFileSelected;
property PictureZipAttributeSelected : TBitmap
read GetPictureZipAttributeSelected
write SetPictureZipAttributeSelected;
property PictureHeight : Integer
read GetPictureHeight
write SetPictureHeight;
property PictureWidth : Integer
read GetPictureWidth
write SetPictureWidth;
property StoreOptions : TAbStoreOptions
read FStoreOptions
write SetStoreOptions
default AbDefStoreOptions;
property Version : string
read GetVersion
write SetVersion
stored False;
protected {events}
property OnProcessItemFailure : TAbArchiveItemFailureEvent
read FOnProcessItemFailure
write FOnProcessItemFailure;
property OnArchiveItemProgress : TAbArchiveItemProgressEvent
read FOnArchiveItemProgress
write FOnArchiveItemProgress;
property OnArchiveProgress : TAbArchiveProgressEvent
read FOnArchiveProgress
write FOnArchiveProgress;
property OnChange : TNotifyEvent
read FOnChange
write FOnChange;
property OnClick : TNotifyEvent
read FOnClick
write FOnClick;
property OnConfirmProcessItem : TAbArchiveItemConfirmEvent
read FOnConfirmProcessItem
write FOnConfirmProcessItem;
property OnConfirmOverwrite : TAbConfirmOverwriteEvent
read FOnConfirmOverwrite
write FOnConfirmOverwrite;
property OnConfirmSave : TAbArchiveConfirmEvent
read FOnConfirmSave
write FOnConfirmSave;
property OnCollapse : TTVExpandedEvent
read FOnCollapse
write FOnCollapse;
property OnDblClick : TNotifyEvent
read FOnDblClick
write FOnDblClick;
property OnDragDrop : TDragDropEvent
read FOnDragDrop
write FOnDragDrop;
property OnDragOver : TDragOverEvent
read FOnDragOver
write FOnDragOver;
property OnEndDrag : TEndDragEvent
read FOnEndDrag
write FOnEndDrag;
property OnEnter : TNotifyEvent
read FOnEnter
write FOnEnter;
property OnExit : TNotifyEvent
read FOnExit
write FOnExit;
property OnExpand : TTVExpandedEvent
read FOnExpand
write FOnExpand;
property OnKeyDown : TKeyEvent
read FOnKeyDown
write FOnKeyDown;
property OnKeyPress : TKeyPressEvent
read FOnKeyPress
write FOnKeyPress;
property OnKeyUp : TKeyEvent
read FOnKeyUp
write FOnKeyUp;
property OnLoad : TAbArchiveEvent
read FOnLoad
write FOnLoad;
property OnMouseDown : TMouseEvent
read FOnMouseDown
write FOnMouseDown;
property OnMouseMove : TMouseMoveEvent
read FOnMouseMove
write FOnMouseMove;
property OnMouseUp : TMouseEvent
read FOnMouseUp
write FOnMouseUp;
property OnNeedPassword : TAbNeedPasswordEvent
read FOnNeedPassword
write FOnNeedPassword;
property OnRequestImage : TAbRequestImageEvent
read FOnRequestImage
write SetOnRequestImage;
property OnRequestLastDisk : TAbRequestDiskEvent
read FOnRequestLastDisk
write SetOnRequestLastDisk;
property OnRequestNthDisk : TAbRequestNthDiskEvent
read FOnRequestNthDisk
write SetOnRequestNthDisk;
property OnRequestBlankDisk : TAbRequestDiskEvent
read FOnRequestBlankDisk
write SetOnRequestBlankDisk;
property OnSave : TAbArchiveEvent
read FOnSave
write FOnSave;
{$IFDEF MSWINDOWS}
property OnStartDrag : TStartDragEvent
read FOnStartDrag
write FOnStartDrag;
{$ENDIF MSWINDOWS}
public {methods}
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure AddFiles(const FileMask : string; SearchAttr : Integer);
{Add files to the archive where the disk filespec matches}
procedure AddFilesEx(const FileMask, ExclusionMask : string;
SearchAttr : Integer);
{Add files that match Filemask except those matching ExclusionMask}
procedure AddFromStream(const NewName : string; FromStream : TStream);
{Create and add a zip item directly from a stream}
procedure ClearTags;
{Clear all tags from the archive}
procedure CloseArchive;
{closes the archive by setting FileName to ''}
procedure DeleteAt(Index : Integer);
{delete item specified by index}
procedure DeleteFiles(const FileMask : string);
{Delete all files from the archive that match the file mask}
procedure DeleteFilesEx(const FileMask, ExclusionMask : string);
{Delete files that match Filemask except those matching ExclusionMask}
procedure DeleteTaggedItems;
{delete all tagged items from the archive}
procedure ExtractAt(Index : Integer; const NewName : string);
{extract item specified by index}
procedure ExtractFiles(const FileMask : string);
{extract all files from the archive that match the mask}
procedure ExtractFilesEx(const FileMask, ExclusionMask : string);
{Extract files that match Filemask except those matching ExclusionMask}
procedure ExtractTaggedItems;
{extract all tagged items from the archive}
procedure ExtractToStream(const aFileName : string; ToStream : TStream);
{extract an item directly to a stream}
function FindItem(aItem : TAbArchiveItem) : Integer;
{extract specified item}
function FindFile(const aFileName : string) : Integer;
{find the item with the given file name}
procedure FreshenFiles(const FileMask : string);
{freshen all items that match the file mask}
procedure FreshenFilesEx(const FileMask, ExclusionMask : string);
{freshen items matching FileMask but not ExclusionMask}
procedure FreshenTaggedItems;
{freshen all tagged items}
procedure FullCollapse;
procedure FullExpand;
function GetTextItem(const Value: string): LongInt;
function GetOutLineItem(X, Y : Integer): LongInt;
procedure Move(aItem : TAbArchiveItem; NewStoredPath : string);
procedure OpenArchive(const aFileName : String);
{opens the archive}
procedure Replace(aItem : TAbArchiveItem);
procedure Save;
{saves the archive}
procedure TagItems(const FileMask : string);
procedure TestTaggedItems;
procedure UnTagItems(const FileMask : string);
public {properties}
property Count : Integer
read GetCount;
property Items[Index : Integer] : TAbZipItem
read GetItem
write PutItem; default;
property SelectedItem: LongInt
read GetSelectedItem
write SetSelectedItem;
property SelectedZipItem : TAbZipItem
read GetSelectedZipItem;
property Status : TAbArchiveStatus
read GetStatus;
property TempDirectory : string
read FTempDirectory
write SetTempDirectory;
property ZipfileComment : AnsiString
read GetZipfileComment
write SetZipfileComment;
end;
type
TAbZipOutline = class(TAbCustomZipOutline)
published
property Align;
property ArchiveProgressMeter;
property ItemProgressMeter;
property Attributes;
property AutoSave;
property BaseDirectory;
property BorderStyle;
property Color
default AbDefColor;
property CompressionMethodToUse;
property Count;
{$IFNDEF UsingCLX}
property Ctl3D;
{$ENDIF}
property Cursor;
property DeflationOption;
{$IFDEF MSWINDOWS}
property DOSMode;
{$ENDIF}
{$IFNDEF UsingCLX}
property DragCursor;
{$ENDIF}
property DragMode;
property Enabled;
property ExtractOptions;
property Font;
property Hierarchy;
property LogFile;
property Logging;
property OnProcessItemFailure;
property OnArchiveItemProgress;
property OnArchiveProgress;
property OnChange;
property OnClick;
property OnConfirmProcessItem;
property OnConfirmOverwrite;
property OnConfirmSave;
property OnCollapse;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnExpand;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnLoad;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
{$IFNDEF UsingCLX}
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
{$ENDIF}
property OnNeedPassword;
property OnRequestImage;
property OnRequestLastDisk;
property OnRequestNthDisk;
property OnRequestBlankDisk;
property OnSave;
{$IFDEF MSWINDOWS}
property OnStartDrag;
{$ENDIF MSWINDOWS}
property OnWindowsDrop;
property ParentColor
default AbDefParentColor;
{$IFNDEF UsingCLX}
property ParentCtl3D;
{$ENDIF}
property ParentFont;
property ParentShowHint;
property Password;
property PasswordRetries;
property PictureDirectory;
property PictureDirectorySelected;
property PictureFile;
property PictureFileSelected;
property PictureZipAttribute;
property PictureZipAttributeSelected;
property PopupMenu;
property ShowHint;
property StoreOptions;
property TabOrder;
property TabStop;
property SpanningThreshold;
property Version;
property TempDirectory;
property Visible;
property FileName; {must be after OnLoad}
end;
implementation
uses
{$IFDEF MSWINDOWS}
ShellApi,
{$ENDIF}
SysUtils,
AbConst,
AbExcept,
AbResString,
AbUnzPrc,
AbZipPrc;
{$R AbZipOut.res}
type
TAbZipArchiveFriend = class(TAbZipArchive)
end;
{ -------------------------------------------------------------------------- }
{ ========================================================================== }
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.IndexBitmaps;
begin
FImageList.Clear;
FImageList.Height := FBitMapHeight;
FImageList.Width := FBitMapWidth;
if not FAttrBitMap.Empty then
FAttrIndex := FImageList.Add( FAttrBitMap, nil );
if not FAttrBitMap.Empty then
FAttrSelectedIndex := FImageList.Add( FAttrBitMapSelected, nil );
if not FAttrBitMap.Empty then
FDirectoryIndex := FImageList.Add( FDirBitMap, nil );
if not FAttrBitMap.Empty then
FDirSelectedIndex := FImageList.Add( FDirBitMapSelected , nil );
if not FAttrBitMap.Empty then
FFileIndex := FImageList.Add( FFileBitMap, nil );
if not FAttrBitMap.Empty then
FFileSelectedIndex := FImageList.Add( FFileBitMapSelected, nil );
end;
{ -------------------------------------------------------------------------- }
constructor TAbZipDisplayOutline.Create(AOwner : TComponent);
begin
FBitMapHeight := cBitmapHeight;
FBitMapWidth := cBitmapWidth;
FDirBitMap := TBitMap.Create;
FFileBitMap := TBitMap.Create;
FAttrBitMap := TBitMap.Create;
FDirBitMapSelected := TBitMap.Create;
FFileBitMapSelected := TBitMap.Create;
FAttrBitMapSelected := TBitMap.Create;
FDirBitMap.LoadFromResourceName( HInstance, 'DIR' );
FFileBitMap.LoadFromResourceName( HInstance, 'FILEFIX' );
FAttrBitMap.LoadFromResourceName( HInstance, 'ATTR' );
FDirBitMapSelected.LoadFromResourceName ( HInstance, 'DIRS' );
FFileBitMapSelected.LoadFromResourceName( HInstance, 'FILES' );
FAttrBitMapSelected.LoadFromResourceName( HInstance, 'ATTRS' );
inherited Create(AOwner);
FImageList := TImageList.Create(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.Loaded;
begin
inherited Loaded;
{$IFNDEF UsingCLX}
if Assigned(FOnWindowsDrop) then
DragAcceptFiles(Handle, True);
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
destructor TAbZipDisplayOutline.Destroy;
begin
FImageList.Free;
FDirBitMap.Free;
FFileBitMap.Free;
FAttrBitMap.Free;
FDirBitMapSelected.Free;
FFileBitMapSelected.Free;
FAttrBitMapSelected.Free;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.SetAttributeBitMap(Value : TBitmap);
begin
if Value <> nil then begin
FAttrBitMap.assign( Value )
end else begin
FAttrBitMap.LoadFromResourceName( HInstance, 'ATTR' );
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.SetDirectoryBitMap(Value : TBitmap);
begin
if Value <> nil then begin
FDirBitMap.assign( Value )
end else begin
FDirBitMap.LoadFromResourceName( HInstance, 'DIR' );
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.SetFileBitMap(Value : TBitmap);
begin
if Value <> nil then begin
FFileBitMap.assign( Value )
end else begin
FFileBitMap.LoadFromResourceName( HInstance, 'FILEFIX' );
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.SetAttributeBitMapSelected(Value : TBitmap);
begin
if Value <> nil then
FAttrBitMapSelected.assign( Value )
else begin
FAttrBitMapSelected.LoadFromResourceName( HInstance, 'ATTRS' );
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.SetDirectoryBitMapSelected(Value : TBitmap);
begin
if Value <> nil then
FDirBitMapSelected.assign( Value )
else begin
FDirBitMapSelected.LoadFromResourceName ( HInstance, 'DIRS' );
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.SetFileBitMapSelected(Value : TBitmap);
begin
if Value <> nil then
FFileBitMapSelected.assign( Value )
else begin
FFileBitMapSelected.LoadFromResourceName( HInstance, 'FILES' );
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.SetBitMapHeight(Value : Integer);
begin
if FBitMapHeight <> Value then
FBitMapHeight := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.SetBitMapWidth(Value : Integer);
begin
if FBitMapWidth <> Value then
FBitMapWidth := Value;
end;
{$IFNDEF UsingCLX}
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.WMDropFiles(var Msg : TWMDropFiles);
var
FileName : string;
I : Integer;
NumFiles : Integer;
begin
Msg.Result := 1;
NumFiles := DragQueryFile(Msg.Drop, Cardinal(-1), nil, 0);
try
for I := 0 to pred(NumFiles) do begin
SetLength(FileName, DragQueryFile(Msg.Drop, I, nil, 0));
DragQueryFile(Msg.Drop, I, PChar(FileName), Length(FileName) + 1);
DoOnWindowsDrop(FileName);
end;
finally
DragFinish(Msg.Drop);
end;
if IsIconic(Application.Handle) then
ShowWindow(Application.Handle, SW_SHOWNORMAL)
else
BringWindowToTop(Handle);
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.DoOnWindowsDrop(FileName : string);
begin
if csDesigning in ComponentState then
Exit;
if csLoading in ComponentState then
Exit;
if Assigned(FOnWindowsDrop) then
FOnWindowsDrop(Self, FileName);
end;
{ -------------------------------------------------------------------------- }
{$IFDEF UsingCLX}
function TAbZipDisplayOutline.DoMouseWheel(Shift: TShiftState;
WheelDelta: Integer; const MousePos: TPoint): Boolean;
{$ELSE}
function TAbZipDisplayOutline.DoMouseWheel(Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint): Boolean;
{$ENDIF}
const
WHEEL_DELTA = 120;
var
oHold : TTreeNode;
oNode : TTreeNode;
begin
{ We always return true - if there's an event handler that returns }
{ false, we'll do the work; if it returns true, the work has been }
{ done, ergo this routine should return true. }
Result := True;
if not inherited DoMouseWheel(Shift, WheelDelta, MousePos) then begin
if Items.Count = 0 then
Exit;
if Selected = nil then
exit;
if Selected.HasChildren then
Selected.Expand( false );
oNode := nil;
oHold := Selected;
if WheelDelta < 0 then begin
if oHold.HasChildren then
oNode := oHold.getFirstChild;
if oNode = nil then
oNode := oHold.GetNextChild( oHold );
if oNode = nil then
oNode := oHold.GetNext;
end else begin
oNode := oHold.GetPrevChild( oHold );
if oNode <> nil then begin
if oNode.HasChildren then
oNode := oNode.GetLastChild;
end else
oNode := oHold.GetPrev;
end;
if oNode <> nil then
Selected := oNode;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDisplayOutline.SetOnWindowsDrop(Value : TWindowsDropEvent);
{$IFNDEF UsingCLX}
var
WasAccepting : Boolean;
{$ENDIF}
begin
{$IFNDEF UsingCLX}
WasAccepting := Assigned(FOnWindowsDrop);
FOnWindowsDrop := Value;
if csLoading in ComponentState then
Exit;
if csDestroying in ComponentState then
Exit;
if Assigned(Value) then
DragAcceptFiles(Handle, True)
else if WasAccepting then
DragAcceptFiles(Handle, False);
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
{ ========================================================================== }
{ -------------------------------------------------------------------------- }
constructor TAbCustomZipOutline.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
Width := 300;
Height := 143;
Color := AbDefColor;
ParentColor := AbDefParentColor;
FOutline := TAbZipDisplayOutline.Create(Self);
FOutline.Parent := Self;
FOutline.Visible := True;
FOutline.Align := alClient;
FOutline.ParentColor := True;
{$IFNDEF UsingCLX}
FOutline.ParentCtl3D := True;
{$ENDIF}
FOutline.ParentFont := True;
FOutline.ParentShowHint := True;
FOutline.Images := FOutline.FImageList;
AutoSave := AbDefAutoSave;
Attributes := AbDefZipAttributes;
CompressionMethodToUse := AbDefCompressionMethodToUse;
DeflationOption := AbDefDeflationOption;
ExtractOptions := AbDefExtractOptions;
Hierarchy := AbDefHierarchy;
PasswordRetries := AbDefPasswordRetries;
StoreOptions := AbDefStoreOptions;
end;
{ -------------------------------------------------------------------------- }
destructor TAbCustomZipOutline.Destroy;
begin
FArchive.Free;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.AddAttributeNodes( Item : TAbZipItem;
oNode : TTreeNode );
var
ExtAttrString : string;
dt : TDateTime;
li : LongInt;
s : string;
tmpNode : TTreeNode;
begin
with Item do begin
if zaCompressedSize in Attributes then begin
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbCompressedSizeFormatS,
[CompressedSize]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end;
if zaUnCompressedSize in Attributes then begin
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbUncompressedSizeFormatS,
[UncompressedSize]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end;
if zaCompressionMethod in Attributes then begin
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbCompressionMethodFormatS,
[ZipCompressionMethodToString(CompressionMethod)]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end;
if zaCompressionRatio in Attributes then begin
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbCompressionRatioFormatS,
[CompressionRatio]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end;
if zaCRC in Attributes then begin
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbCRCFormatS,
[CRC32]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end;
if zaExternalFileAttributes in Attributes then begin
ExtAttrString := '';
{$IFDEF MSWINDOWS}
{$WARN SYMBOL_PLATFORM OFF}
if (faReadOnly and ExternalFileAttributes) = faReadOnly then
ExtAttrString := ExtAttrString + AbReadOnlyS;
if (faHidden and ExternalFileAttributes) = faHidden then
ExtAttrString := ExtAttrString + AbHiddenS;
if (faSysFile and ExternalFileAttributes) = faSysFile then
ExtAttrString := ExtAttrString + AbSystemS;
if (faArchive and ExternalFileAttributes) = faArchive then
ExtAttrString := ExtAttrString + AbArchivedS;
{$WARN SYMBOL_PLATFORM ON}
{$ENDIF}
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbEFAFormatS,
[ExtAttrString]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end;
if zaInternalFileAttributes in Attributes then
if InternalFileAttributes = 1 then begin
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbIFAFormatS,
[AbTextS]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end else begin
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbIFAFormatS,
[AbBinaryS]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end;
if zaEncryption in Attributes then
if IsEncrypted then begin
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbEncryptionFormatS,
[AbEncryptedS]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end else begin
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbEncryptionFormatS,
[AbNotEncryptedS]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end;
if zaTimeStamp in Attributes then begin
if (LastModFileDate + LastModFileTime = 0) then
s := AbUnknownS
else begin
li := LongInt(LastModFileDate) shl 16 + LastModFileTime;
dt := FileDateToDateTime(li);
s := DateTimeToStr(dt);
end;
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbTimeStampFormatS, [s]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end;
if zaVersionMade in Attributes then begin
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbMadeByFormatS,
[Lo(VersionMadeBy)/ 10.0]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end;
if zaVersionNeeded in Attributes then begin
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbNeededFormatS,
[Lo(VersionNeededToExtract)/ 10.0]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end;
if zaComment in Attributes then begin
tmpNode := FOutline.Items.AddChild(oNode,
Format(AbCommentFormatS,
[FileComment]));
tmpNode.ImageIndex := FOutline.FAttrIndex;
tmpNode.SelectedIndex := FOutline.FAttrSelectedIndex;
end;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.AddFiles(const FileMask : string;
SearchAttr : Integer);
{Add files to the archive where the disk filespec matches}
begin
if Assigned(FArchive) then
FArchive.AddFiles(FileMask, SearchAttr)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.AddFilesEx(const FileMask, ExclusionMask : string;
SearchAttr : Integer);
{Add files that match Filemask except those matching ExclusionMask}
begin
if Assigned(FArchive) then
FArchive.AddFilesEx(FileMask, ExclusionMask, SearchAttr)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.AddFromStream(const NewName : string;
FromStream : TStream);
{Add zip item directly from TStream descendant}
begin
if Assigned(FArchive) then begin
FromStream.Position := 0;
FArchive.AddFromStream(NewName, FromStream);
end else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.ClearTags;
{Clear all tags from the archive}
begin
if Assigned(FArchive) then
FArchive.ClearTags
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DeleteAt(Index : Integer);
{delete item at Index}
begin
if Assigned( FArchive ) then
FArchive.DeleteAt( Index )
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DeleteFiles(const FileMask : string);
{delete all files from the archive that match the file mask}
begin
if Assigned(FArchive) then
FArchive.DeleteFiles(FileMask)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DeleteFilesEx(const FileMask, ExclusionMask : string);
{Delete files that match Filemask except those matching ExclusionMask}
begin
if Assigned(FArchive) then
FArchive.DeleteFilesEx(FileMask, ExclusionMask)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DeleteTaggedItems;
{delete all tagged items from the archive}
begin
if Assigned(FArchive) then
FArchive.DeleteTaggedItems
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoProcessItemFailure(Sender : TObject;
Item : TAbArchiveItem;
ProcessType : TAbProcessType;
ErrorClass : TAbErrorClass;
ErrorCode : Integer);
begin
if Assigned(FOnProcessItemFailure) then
FOnProcessItemFailure(Self, Item, ProcessType, ErrorClass, ErrorCode);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoArchiveItemProgress(Sender : TObject;
Item : TAbArchiveItem;
Progress : Byte;
var Abort : Boolean);
begin
Abort := False;
if Assigned(FItemProgressMeter) then
FItemProgressMeter.DoProgress(Progress);
if Assigned(FOnArchiveItemProgress) then
FOnArchiveItemProgress(Self, Item, Progress, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoArchiveProgress(Sender : TObject;
Progress : Byte;
var Abort : Boolean);
begin
Abort := False;
if Assigned(FArchiveProgressMeter) then
FArchiveProgressMeter.DoProgress(Progress);
if Assigned(FOnArchiveProgress) then
FOnArchiveProgress(Self, Progress, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoChange;
begin
{Archive now points to the new zip file}
UpdateOutline;
{then, call the FOnChange event...}
if Assigned(FOnChange) then
FOnChange(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoClick(Sender : TObject);
begin
if Assigned(FOnClick) then
FOnClick(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoCollapse(Sender: TObject; Node: TTreeNode);
begin
if Assigned(FOnCollapse) then
FOnCollapse(Self, Node);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoConfirmProcessItem(Sender : TObject;
Item : TAbArchiveItem;
ProcessType : TAbProcessType;
var Confirm : Boolean);
begin
Confirm := True;
if Assigned(FItemProgressMeter) then
FItemProgressMeter.Reset;
if Assigned(FOnConfirmProcessItem) then
FOnConfirmProcessItem(Self, Item, ProcessType, Confirm);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoConfirmOverwrite(var Name : string;
var Confirm : Boolean);
begin
Confirm := True;
if Assigned(FOnConfirmOverwrite) then
FOnConfirmOverwrite(Name, Confirm);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoConfirmSave(Sender : TObject;
var Confirm : Boolean);
begin
Confirm := True;
if Assigned(FOnConfirmSave) then
FOnConfirmSave(Self, Confirm);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoDblClick(Sender : TObject);
begin
if Assigned(FOnDblClick) then
FOnDblClick(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoDragDrop(Sender, Source: TObject; X, Y: Integer);
begin
if Assigned(FOnDragDrop) then
FOnDragDrop(Self, Source, X, Y);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := False;
if Assigned(FOnDragOver) then
FOnDragOver(Self, Source, X, Y, State, Accept);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoOnEndDrag(Sender, Target: TObject; X, Y: Integer);
begin
if Assigned(FOnEndDrag) then
FOnEndDrag(Self, Target, X, Y);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoOnEnter(Sender : TObject);
begin
if Assigned(FOnEnter) then
FOnEnter(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoOnExit(Sender : TObject);
begin
if Assigned(FOnExit) then
FOnExit(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoExpand(Sender: TObject; Node : TTreeNode);
begin
if Assigned(FOnExpand) then
FOnExpand(Self, Node);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoKeyDown(Sender : TObject; var Key: Word;
Shift: TShiftState);
begin
if Assigned(FOnKeyDown) then
FOnKeyDown(Self, Key, Shift);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoKeyPress(Sender : TObject; var Key: Char);
begin
if Assigned(FOnKeyPress) then
FOnKeyPress(Self, Key);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoKeyUp(Sender : TObject; var Key: Word;
Shift: TShiftState);
begin
if Assigned(FOnKeyUp) then
FOnKeyUp(Self, Key, Shift);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoLoad(Sender : TObject);
begin
if Assigned(FOnLoad) then
FOnLoad(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoMouseDown(Sender : TObject; Button: TMouseButton;
Shift: TShiftState;
X, Y : Integer);
begin
if Assigned(FOnMouseDown) then
FOnMouseDown(Self, Button, Shift, X, Y);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoMouseMove(Sender : TObject;
Shift: TShiftState; X, Y: Integer);
begin
if Assigned(FOnMouseMove) then
FOnMouseMove(Self, Shift, X, Y);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoMouseUp(Sender : TObject;
Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if Assigned(FOnMouseUp) then
FOnMouseUp(Self, Button, Shift, X, Y);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoNeedPassword(Sender : TObject;
var NewPassword : AnsiString);
begin
if Assigned(FOnNeedPassword) then begin
FOnNeedPassword(Sender, NewPassword);
Password := NewPassword;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoSave(Sender : TObject);
begin
if Assigned(FOnSave) then
FOnSave(Self);
end;
{ -------------------------------------------------------------------------- }
{$IFDEF MSWINDOWS}
procedure TAbCustomZipOutline.DoOnStartDrag(Sender: TObject;
var DragObject: TDragObject);
begin
if Assigned(FOnStartDrag) then
FOnStartDrag(Self, DragObject);
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.DoWindowsDrop(Sender : TObject;
FileName : string);
begin
if csDesigning in ComponentState then
Exit;
if csLoading in ComponentState then
Exit;
if Assigned(FOnWindowsDrop) then
FOnWindowsDrop(Self, FileName);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.ExtractAt(Index : Integer; const NewName : string);
{extract a file from the archive that match the index}
begin
if Assigned(FArchive) then
FArchive.ExtractAt(Index, NewName)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.ExtractFiles(const FileMask : string);
{extract all files from the archive that match the mask}
begin
if Assigned(FArchive) then
FArchive.ExtractFiles(FileMask)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.ExtractFilesEx(const FileMask, ExclusionMask : string);
{extract files that match FileMask except those matching ExclusionMask}
begin
if Assigned(FArchive) then
FArchive.ExtractFilesEx(FileMask, ExclusionMask)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.ExtractTaggedItems;
{extract all tagged items from the archive}
begin
if Assigned(FArchive) then
FArchive.ExtractTaggedItems
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.ExtractToStream(const aFileName : string;
ToStream : TStream);
begin
if Assigned(FArchive) then
FArchive.ExtractToStream(aFileName, ToStream)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.FindFile(const aFileName : string) : Integer;
begin
if Assigned(FArchive) then
Result := FArchive.FindFile(aFileName)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.FindItem(aItem : TAbArchiveItem) : Integer;
begin
if Assigned(FArchive) then
Result := FArchive.FindItem(aItem)
else
Result := -1;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.FreshenFiles(const FileMask : string);
{freshen all items that match the file mask}
begin
if Assigned(FArchive) then
FArchive.FreshenFiles(FileMask)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.FreshenFilesEx(const FileMask, ExclusionMask : string);
{freshen all items matching FileMask except those matching ExclusionMask}
begin
if Assigned(FArchive) then
FArchive.FreshenFilesEx(FileMask, ExclusionMask)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.FreshenTaggedItems;
{freshen all tagged items}
begin
if Assigned(FArchive) then
FArchive.FreshenTaggedItems
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.FullCollapse;
begin
FOutline.FullCollapse;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.FullExpand;
begin
FOutline.FullExpand;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetBorderStyle : TBorderStyle;
begin
Result := FOutline.BorderStyle;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetCount : Integer;
begin
if Assigned(FArchive) then
Result := FArchive.Count
else
Result := 0;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetCursor : TCursor;
begin
Result := FOutline.Cursor;
end;
{ -------------------------------------------------------------------------- }
{$IFNDEF UsingCLX}
function TAbCustomZipOutline.GetDragCursor : TCursor;
begin
Result := FOutline.DragCursor;
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetDragMode : TDragMode;
begin
Result := FOutline.DragMode;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetItem(Index : Integer) : TAbZipItem;
begin
if Assigned(FArchive) then
Result := TAbZipItem(FArchive.ItemList[Index])
else
Result := nil;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetPictureDirectory : TBitmap;
begin
Result := FOutline.zdPictureDirectory;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetPictureFile : TBitmap;
begin
Result := FOutline.zdPictureFile;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetPictureZipAttribute: TBitmap;
begin
Result := FOutline.zdPictureZipAttribute;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetPictureDirectorySelected : TBitmap;
begin
Result := FOutline.zdPictureDirectorySelected;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetPictureFileSelected : TBitmap;
begin
Result := FOutline.zdPictureFileSelected;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetPictureZipAttributeSelected: TBitmap;
begin
Result := FOutline.zdPictureZipAttributeSelected;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetPictureHeight: Integer;
begin
Result := FOutline.FBitMapHeight;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetPictureWidth: Integer;
begin
Result := FOutline.FBitMapWidth;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetSelectedItem : LongInt;
begin
Result := FOutline.Selected.AbsoluteIndex;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetSelectedZipItem : TAbZipItem;
begin
{returns nil if the currently selected item of the outline is a folder or
a zip attribute}
if FOutline.Items.Count > 0 then
Result := FOutline.Selected.Data
else
Result := nil;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetStatus : TAbArchiveStatus;
begin
if Assigned(FArchive) then
Result := FArchive.Status
else
Result := asInvalid;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetTextItem(const Value: string): LongInt;
var
oNode : TTreeNode;
oHold : TTreeNode;
begin
Result := -1;
if FOutline.Items.Count <= 0 then
exit;
oNode := FOutline.Items[0];
while oNode <> nil do begin
if oNode.Text = Value then
break;
oHold := oNode;
oNode := nil;
if oHold.HasChildren then
oNode := oHold.getFirstChild;
if oNode = nil then
oNode := oHold.GetNextChild( oHold );
if oNode = nil then
oNode := oHold.GetNext;
end;
if oNode <> nil then
Result := oNode.AbsoluteIndex
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetOutLineItem(X, Y : Integer): LongInt;
var
oNode : TTreeNode;
begin
oNode := FOutLine.GetNodeAt(X, X);
if oNode <> nil then
Result := oNode.AbsoluteIndex
else
Result := -1;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetVersion : string;
begin
Result := AbVersionS;
end;
{ -------------------------------------------------------------------------- }
function TAbCustomZipOutline.GetZipfileComment : AnsiString;
begin
if Assigned(FArchive) then
Result := TAbZipArchive(FArchive).ZipfileComment
else
Result := '';
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.InitArchive;
begin
if Assigned(FArchive) then begin
{properties}
FArchive.AutoSave := FAutoSave;
FArchive.CompressionMethodToUse := FCompressionMethodToUse;
SetBaseDirectory(FBaseDirectory);
FArchive.DeflationOption := FDeflationOption;
{$IFDEF MSWINDOWS}
FArchive.DOSMode := FDOSMode;
{$ENDIF}
FArchive.ExtractOptions := FExtractOptions;
FArchive.LogFile := FLogFile;
FArchive.Logging := FLogging;
FArchive.Password := FPassword;
FArchive.PasswordRetries := FPasswordRetries;
FArchive.StoreOptions := FStoreOptions;
FArchive.TempDirectory := FTempDirectory;
FArchive.SpanningThreshold := FSpanningThreshold;
{events}
TAbZipArchiveFriend(FArchive).ExtractHelper := UnzipProc;
TAbZipArchiveFriend(FArchive).ExtractToStreamHelper := UnzipToStreamProc;
TAbZipArchiveFriend(FArchive).InsertHelper := ZipProc;
TAbZipArchiveFriend(FArchive).InsertFromStreamHelper := ZipFromStreamProc;
FArchive.OnProcessItemFailure := DoProcessItemFailure;
FArchive.OnArchiveItemProgress := DoArchiveItemProgress;
FArchive.OnArchiveProgress := DoArchiveProgress;
FArchive.OnConfirmProcessItem := DoConfirmProcessItem;
FArchive.OnConfirmOverwrite := DoConfirmOverwrite;
FArchive.OnConfirmSave := DoConfirmSave;
FArchive.OnLoad := DoLoad;
FArchive.OnSave := DoSave;
FArchive.OnRequestImage := FOnRequestImage;
FArchive.OnNeedPassword := DoNeedPassword;
FArchive.OnRequestBlankDisk := FOnRequestBlankDisk;
FArchive.OnRequestLastDisk := FOnRequestLastDisk;
FArchive.OnRequestNthDisk := FOnRequestNthDisk;
TAbZipArchiveFriend(FArchive).TestHelper := TestItemProc;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.Loaded;
begin
inherited Loaded;
FOutline.OnClick := DoClick;
FOutline.OnCollapsed := DoCollapse;
FOutline.OnDblClick := DoDblClick;
FOutline.OnDragDrop := DoDragDrop;
FOutline.OnDragOver := DoDragOver;
FOutline.OnEndDrag := DoOnEndDrag;
FOutline.OnEnter := DoOnEnter;
FOutline.OnExit := DoOnExit;
FOutline.OnExpanded := DoExpand;
FOutline.OnKeyDown := DoKeyDown;
FOutline.OnKeyPress := DoKeyPress;
FOutline.OnKeyUp := DoKeyUp;
FOutline.OnMouseDown := DoMouseDown;
FOutline.OnMouseMove := DoMouseMove;
FOutline.OnMouseUp := DoMouseUp;
{$IFDEF MSWINDOWS}
FOutline.OnStartDrag := DoOnStartDrag;
{$ENDIF MSWINDOWS}
if Assigned(FOnWindowsDrop) then
FOutline.OnWindowsDrop := DoWindowsDrop
else
FOutline.OnWindowsDrop := nil;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.Move(aItem : TAbArchiveItem; NewStoredPath : string);
begin
if Assigned(FArchive) then
FArchive.Move(aItem, NewStoredPath)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.Notification(Component: TComponent;
Operation: TOperation);
begin
inherited Notification(Component, Operation);
if (Operation = opRemove) then begin
if Assigned(ItemProgressMeter) and Component.IsImplementorOf(ItemProgressMeter) then
ItemProgressMeter := nil;
if Assigned(ArchiveProgressMeter) and Component.IsImplementorOf(ArchiveProgressMeter) then
ArchiveProgressMeter := nil;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.PutItem(Index : Integer; Value : TAbZipItem);
begin
if Assigned(FArchive) then
FArchive.ItemList[Index] := Value
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.Replace(aItem : TAbArchiveItem);
{replace the item}
begin
if Assigned( FArchive ) then
FArchive.Replace( aItem )
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.Save;
begin
if Assigned(FArchive) then begin
FArchive.Save;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetArchiveProgressMeter(const Value: IAbProgressMeter);
begin
ReferenceInterface(FArchiveProgressMeter, opRemove);
FArchiveProgressMeter := Value;
ReferenceInterface(FArchiveProgressMeter, opInsert);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetAttributes(Value : TAbZipAttributes);
begin
FAttributes := Value;
UpdateOutline;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetAutoSave(Value : Boolean);
begin
FAutoSave := Value;
if Assigned(FArchive) then
FArchive.AutoSave := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetBaseDirectory(Value : string);
begin
if Assigned(FArchive) then begin
FArchive.BaseDirectory := Value;
FBaseDirectory := FArchive.BaseDirectory;
end
else
FBaseDirectory := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetBorderStyle(Value : TBorderStyle);
begin
FOutline.BorderStyle := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetCompressionMethodToUse(
Value : TAbZipSupportedMethod);
begin
FCompressionMethodToUse := Value;
if Assigned(FArchive) then
FArchive.CompressionMethodToUse := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetCursor(Value : TCursor);
begin
FOutline.Cursor := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetDeflationOption(Value : TAbZipDeflationOption);
begin
FDeflationOption := Value;
if Assigned(FArchive) then
FArchive.DeflationOption := Value;
end;
{ -------------------------------------------------------------------------- }
{$IFDEF MSWINDOWS}
procedure TAbCustomZipOutline.SetDOSMode(Value : Boolean);
begin
FDOSMode := Value;
if Assigned(FArchive) then
FArchive.DOSMode := Value;
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
{$IFNDEF UsingCLX}
procedure TAbCustomZipOutline.SetDragCursor(Value : TCursor);
begin
FOutline.DragCursor := Value;
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
{$IFNDEF UsingCLX}
procedure TAbCustomZipOutline.SetDragMode(Value : TDragMode);
begin
{$IFDEF MSWINDOWS}
inherited SetDragMode(Value);
{$ENDIF}
FOutline.DragMode := Value;
end;
{$ENDIF}
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetExtractOptions(Value : TAbExtractOptions);
begin
FExtractOptions := Value;
if Assigned(FArchive) then
FArchive.ExtractOptions := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetFileName(const aFileName : string);
begin
if Assigned(FArchive) and (Status = asBusy) then
raise EAbArchiveBusy.Create;
FFileName := aFileName;
try
if Assigned(FArchive) then
FArchive.Save;
except
end;
FArchive.Free;
FArchive := nil;
if FileName <> '' then
if FileExists(FileName) then begin
if csDesigning in ComponentState then
FArchive := TAbZipArchive.Create(FileName,
fmOpenRead or
fmShareDenyNone)
else begin
try
FArchive := TAbZipArchive.Create(FileName,
fmOpenReadWrite or
fmShareDenyWrite);
except
{deals with read-only files}
FArchive := TAbZipArchive.Create(FileName,
fmOpenRead or
fmShareDenyWrite);
end;
InitArchive;
end;
FArchive.Load;
end
else begin
FArchive := TAbZipArchive.Create(FileName,
fmCreate or fmShareDenyNone);
InitArchive;
try
FArchive.Load;
except
end;
end;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetHierarchy(Value : Boolean);
begin
FHierarchy := Value;
UpdateOutline;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetItemProgressMeter(const Value: IAbProgressMeter);
begin
ReferenceInterface(FItemProgressMeter, opRemove);
FItemProgressMeter := Value;
ReferenceInterface(FItemProgressMeter, opInsert);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetLogFile(Value : string);
begin
FLogFile := Value;
if (csDesigning in ComponentState) then
Exit;
if Assigned(FArchive) then
FArchive.LogFile := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetLogging(Value : Boolean);
begin
FLogging := Value;
if (csDesigning in ComponentState) then
Exit;
if Assigned(FArchive) then
FArchive.Logging:= Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetOnRequestImage(Value : TAbRequestImageEvent);
begin
FOnRequestImage := Value;
if Assigned(FArchive) then
FArchive.OnRequestImage := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetOnRequestLastDisk(Value : TAbRequestDiskEvent);
begin
FOnRequestLastDisk := Value;
if Assigned(FArchive) then
FArchive.OnRequestLastDisk := FOnRequestLastDisk;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetOnRequestNthDisk(Value : TAbRequestNthDiskEvent);
begin
FOnRequestNthDisk := Value;
if Assigned(FArchive) then
FArchive.OnRequestNthDisk := FOnRequestNthDisk;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetOnRequestBlankDisk(Value : TAbRequestDiskEvent);
begin
FOnRequestBlankDisk := Value;
if Assigned(FArchive) then
FArchive.OnRequestBlankDisk := FOnRequestBlankDisk;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetOnWindowsDrop(Value : TWindowsDropEvent);
begin
FOnWindowsDrop := Value;
if csLoading in ComponentState then
Exit;
if csDestroying in ComponentState then
Exit;
if Assigned(Value) then
FOutline.OnWindowsDrop := DoWindowsDrop
else
FOutline.OnWindowsDrop := nil;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetPassword(Value : AnsiString);
begin
FPassword := Value;
if Assigned(FArchive) then
FArchive.Password := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetPasswordRetries(Value : Byte);
begin
FPasswordRetries := Value;
if Assigned(FArchive) then
FArchive.PasswordRetries := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetPictureDirectory(Value : TBitmap);
begin
if Value <> nil then begin
if (Value.Height = FOutline.FBitMapHeight) and
(Value.Width = FOutline.FBitMapWidth) then
FOutline.zdPictureDirectory := Value;
end else
FOutline.zdPictureDirectory := nil;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetPictureFile(Value : TBitmap);
begin
if Value <> nil then begin
if (Value.Height = FOutline.FBitMapHeight) and
(Value.Width = FOutline.FBitMapWidth) then
FOutline.zdPictureFile := Value;
end else
FOutline.zdPictureFile := nil;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetPictureZipAttribute(Value : TBitmap);
begin
if Value <> nil then begin
if (Value.Height = FOutline.FBitMapHeight) and
(Value.Width = FOutline.FBitMapWidth) then
FOutline.zdPictureZipAttribute := Value;
end else
FOutline.zdPictureZipAttribute := nil;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetPictureDirectorySelected(Value : TBitmap);
begin
if Value <> nil then begin
if (Value.Height = FOutline.FBitMapHeight) and
(Value.Width = FOutline.FBitMapWidth) then
FOutline.zdPictureDirectorySelected := Value;
end else
FOutline.zdPictureDirectorySelected := nil;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetPictureFileSelected(Value : TBitmap);
begin
if Value <> nil then begin
if (Value.Height = FOutline.FBitMapHeight) and
(Value.Width = FOutline.FBitMapWidth) then
FOutline.zdPictureFileSelected := Value;
end else
FOutline.zdPictureFileSelected := nil;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetPictureZipAttributeSelected(Value : TBitmap);
begin
if Value <> nil then begin
if (Value.Height = FOutline.FBitMapHeight) and
(Value.Width = FOutline.FBitMapWidth) then
FOutline.zdPictureZipAttributeSelected := Value;
end else
FOutline.zdPictureZipAttributeSelected := nil;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetPictureHeight(Value : Integer);
begin
FOutline.FBitMapHeight := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetPictureWidth(Value : Integer);
begin
FOutline.FBitMapWidth := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetSelectedItem(Value : LongInt);
begin
if ( Value >= 0 ) and ( Value <= pred( FOutline.Items.Count )) then
FOutline.Selected := FOutline.Items[ Value ];
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetStoreOptions(Value : TAbStoreOptions);
begin
FStoreOptions := Value;
if Assigned(FArchive) then
FArchive.StoreOptions := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetTempDirectory(Value : string);
begin
FTempDirectory := Value;
if Assigned(FArchive) then
FArchive.TempDirectory := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetSpanningThreshold(Value : Longint);
begin
FSpanningThreshold := Value;
if Assigned(FArchive) then
FArchive.SpanningThreshold := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetVersion(Value : string);
begin
{NOP}
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.SetZipfileComment(Value : AnsiString);
begin
if Assigned(FArchive) then
TAbZipArchive(FArchive).ZipfileComment := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.TagItems(const FileMask : string);
{tag all items that match the mask}
begin
if Assigned(FArchive) then
FArchive.TagItems(FileMask)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.UnTagItems(const FileMask : string);
{clear tags for all items that match the mask}
begin
if Assigned(FArchive) then
FArchive.UnTagItems(FileMask)
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.UnzipProc(Sender : TObject;
Item : TAbArchiveItem;
const NewName : string);
begin
AbUnzip( TAbZipArchive(Sender), TAbZipItem(Item), NewName);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.UnzipToStreamProc(Sender : TObject;
Item : TAbArchiveItem;
OutStream : TStream);
begin
if Assigned(OutStream) then
AbUnzipToStream(TAbZipArchive(Sender), TAbZipItem(Item), OutStream);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.UpdateOutline;
var
Found : Boolean;
i : Integer;
CurRoot : TTreeNode;
CurParent : TTreeNode;
CurChild : TTreeNode;
RootNode : TTreeNode;
oNode : TTreeNode;
SubDir : string;
ItemString : string;
function GetSubDir(var ItemString : string) : string;
var
i : Integer;
begin
i := Pos(AbPathDelim, ItemString);
Result := '';
if i > 0 then begin
Result := Copy(ItemString, 1, pred(i));
System.Delete(ItemString, 1, i);
end;
end;
begin
RootNode := nil;
CurRoot := nil;
FOutline.Items.Clear;
if not Assigned(FArchive) then
Exit;
if FArchive.Count = 0 then
Exit;
FOutline.IndexBitmaps;
if Hierarchy then begin
for i := 0 to pred(FArchive.Count) do begin
{do not display deleted items...}
if FArchive.ItemList[i].Action = aaDelete then
continue;
ItemString := FArchive.ItemList[i].FileName;
AbUnfixName(ItemString);
if ItemString[ Length( ItemString )] = AbPathDelim then
Continue;
if ( FOutline.Items.Count <> 0 ) and ( CurRoot <> nil ) then begin
SubDir := GetSubDir(ItemString);
if RootNode = nil then
RootNode := FOutline.TopItem;
CurParent := RootNode;
while CurParent <> nil do begin
if CurParent.Text = SubDir then begin
CurRoot := CurParent;
break;
end else begin
CurParent := CurParent.getNextSibling;
end;
end;
if CurParent = nil then begin
ItemString := FArchive.ItemList[i].FileName;
AbUnfixName(ItemString);
end;
end else
CurParent := nil;
SubDir := GetSubDir(ItemString);
while SubDir <> '' do begin
if CurParent <> nil then begin
Found := False;
CurChild := CurParent.GetFirstChild;
while CurChild <> nil do begin
if CurChild.Text <> SubDir then
CurChild := CurParent.GetNextChild( CurChild )
else begin
Found := True;
break;
end;
end;
if Found then
CurParent := CurChild
else begin
if ItemString <> '' then begin
CurParent := FOutline.Items.AddChild( CurParent, SubDir );
CurParent.ImageIndex := FOutline.FDirectoryIndex;
CurParent.SelectedIndex := FOutline.FDirSelectedIndex;
end;
end;
end else begin
if ItemString <> '' then begin
CurRoot := FOutline.Items.Add( nil, SubDir );
if FOutline.Items.Count = 1 then
RootNode := CurRoot;
CurRoot.ImageIndex := FOutline.FDirectoryIndex;
CurRoot.SelectedIndex := FOutline.FDirSelectedIndex;
CurParent := CurRoot
end;
end;
SubDir := GetSubDir(ItemString);
end;
if ItemString <> '' then begin
oNode := FOutline.Items.AddChildObject(CurParent, ItemString,
FArchive.ItemList[i]);
if FOutline.Items.Count = 1 then
RootNode := oNode;
oNode.ImageIndex := FOutline.FFileIndex;
oNode.SelectedIndex := FOutline.FFileSelectedIndex;
AddAttributeNodes(TAbZipItem(FArchive.ItemList[i]), oNode);
end;
end;
end
else begin
for i := 0 to pred(FArchive.Count) do begin
ItemString := FArchive.ItemList[i].FileName;
AbUnfixName(ItemString);
oNode := FOutline.Items.AddObject(FOutline.Selected, ItemString,
FArchive.ItemList[i]);
oNode.ImageIndex := FOutline.FFileIndex;
oNode.SelectedIndex := FOutline.FFileSelectedIndex;
AddAttributeNodes(TAbZipItem(FArchive.ItemList[i]), oNode);
end;
end;
FullExpand;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.TestItemProc(Sender : TObject; Item : TAbArchiveItem);
begin
AbTestZipItem(TAbZipArchive(Sender), TAbZipItem(Item));
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.TestTaggedItems;
{Test specified items}
begin
if Assigned(FArchive) then
FArchive.TestTaggedItems
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.ZipProc(Sender : TObject;
Item : TAbArchiveItem;
OutStream : TStream);
begin
AbZip(TAbZipArchive(Sender), TAbZipItem(Item), OutStream);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.ZipFromStreamProc(Sender : TObject;
Item : TAbArchiveItem;
OutStream, InStream : TStream);
begin
if Assigned(InStream) then
AbZipFromStream(TAbZipArchive(Sender), TAbZipItem(Item),
OutStream, InStream)
else
raise EAbZipNoInsertion.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.CloseArchive;
{closes the archive by setting FileName to ''}
begin
if FFileName <> '' then
FileName := '';
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipOutline.OpenArchive(const aFileName : String);
{opens the archive}
begin
FileName := AFileName;
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbZipPrc.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbZipPrc.pas *}
{*********************************************************}
{* ABBREVIA: TABZipHelper class *}
{*********************************************************}
unit AbZipPrc;
{$I AbDefine.inc}
interface
uses
Classes,
AbZipTyp;
procedure AbZip( Sender : TAbZipArchive; Item : TAbZipItem;
OutStream : TStream );
procedure AbZipFromStream(Sender : TAbZipArchive; Item : TAbZipItem;
OutStream, InStream : TStream);
procedure DeflateStream( UncompressedStream, CompressedStream : TStream );
{-Deflates everything in UncompressedStream to CompressedStream
no encryption is tried, no check on CRC is done, uses the whole
compressedstream - no Progress events - no Frills! }
implementation
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
{$IFDEF LibcAPI}
Libc,
{$ENDIF}
SysUtils,
AbArcTyp,
AbExcept,
AbUtils,
AbDfCryS,
AbVMStrm,
AbDfBase,
AbDfEnc,
AbSpanSt;
{ ========================================================================== }
procedure DoDeflate(Archive : TAbZipArchive; Item : TAbZipItem; OutStream, InStream : TStream);
const
DEFLATE_NORMAL_MASK = $00;
DEFLATE_MAXIMUM_MASK = $02;
DEFLATE_FAST_MASK = $04;
DEFLATE_SUPERFAST_MASK = $06;
var
Hlpr : TAbDeflateHelper;
begin
Item.CompressionMethod := cmDeflated;
Hlpr := TAbDeflateHelper.Create;
{anything dealing with store options, etc. should already be done.}
try {Hlpr}
Hlpr.StreamSize := InStream.Size;
{ set deflation level desired }
Hlpr.PKZipOption := '0';
case Archive.DeflationOption of
doNormal : begin
Hlpr.PKZipOption := 'n';
Item.GeneralPurposeBitFlag :=
Item.GeneralPurposeBitFlag or DEFLATE_NORMAL_MASK;
end;
doMaximum : begin
Hlpr.PKZipOption := 'x';
Item.GeneralPurposeBitFlag :=
Item.GeneralPurposeBitFlag or DEFLATE_MAXIMUM_MASK;
end;
doFast : begin
Hlpr.PKZipOption := 'f';
Item.GeneralPurposeBitFlag :=
Item.GeneralPurposeBitFlag or DEFLATE_FAST_MASK;
end;
doSuperFast : begin
Hlpr.PKZipOption := 's';
Item.GeneralPurposeBitFlag :=
Item.GeneralPurposeBitFlag or DEFLATE_SUPERFAST_MASK;
end;
end;
{ attach progress notification method }
Hlpr.OnProgressStep := Archive.DoInflateProgress;
{ provide encryption check value }
Item.CRC32 := Deflate(InStream, OutStream, Hlpr);
finally {Hlpr}
Hlpr.Free;
end; {Hlpr}
end;
{ ========================================================================== }
procedure DoStore(Archive : TAbZipArchive; Item : TAbZipItem; OutStream, InStream : TStream);
var
CRC32 : LongInt;
Percent : LongInt;
LastPercent : LongInt;
InSize : Int64;
DataRead : Int64;
Total : Int64;
Abort : Boolean;
Buffer : array [0..8191] of byte;
begin
{ setup }
Item.CompressionMethod := cmStored;
Abort := False;
CRC32 := -1;
Total := 0;
Percent := 0;
LastPercent := 0;
InSize := InStream.Size;
{ get first bufferful }
DataRead := InStream.Read(Buffer, SizeOf(Buffer));
{ while more data has been read and we're not told to bail }
while (DataRead <> 0) and not Abort do begin
{report the progress}
if Assigned(Archive.OnProgress) then begin
Total := Total + DataRead;
Percent := Round((100.0 * Total) / InSize);
if (LastPercent <> Percent) then
Archive.OnProgress(Percent, Abort);
LastPercent := Percent;
end;
{ update CRC}
AbUpdateCRCBuffer(CRC32, Buffer, DataRead);
{ write data (encrypting if needed) }
OutStream.WriteBuffer(Buffer, DataRead);
{ get next bufferful }
DataRead := InStream.Read(Buffer, SizeOf(Buffer));
end;
{ finish CRC calculation }
Item.CRC32 := not CRC32;
{ show final progress increment }
if (Percent < 100) and Assigned(Archive.OnProgress) then
Archive.OnProgress(100, Abort);
{ User wants to bail }
if Abort then begin
raise EAbUserAbort.Create;
end;
end;
{ ========================================================================== }
procedure DoZipFromStream(Sender : TAbZipArchive; Item : TAbZipItem;
OutStream, InStream : TStream);
var
ZipArchive : TAbZipArchive;
InStartPos : LongInt;
TempOut : TAbVirtualMemoryStream;
DestStrm : TStream;
begin
ZipArchive := TAbZipArchive(Sender);
{ configure Item }
Item.UncompressedSize := InStream.Size;
Item.GeneralPurposeBitFlag := Item.GeneralPurposeBitFlag and AbLanguageEncodingFlag;
if ZipArchive.Password <> '' then { encrypt the stream }
DestStrm := TAbDfEncryptStream.Create(OutStream,
LongInt(Item.LastModFileTime shl $10),
ZipArchive.Password)
else
DestStrm := OutStream;
try
if InStream.Size > 0 then begin
{ determine how to store Item based on specified CompressionMethodToUse }
case ZipArchive.CompressionMethodToUse of
smDeflated : begin
{ Item is to be deflated regarless }
{ deflate item }
DoDeflate(ZipArchive, Item, DestStrm, InStream);
end;
smStored : begin
{ Item is to be stored regardless }
{ store item }
DoStore(ZipArchive, Item, DestStrm, InStream);
end;
smBestMethod : begin
{ Item is to be archived using method producing best compression }
TempOut := TAbVirtualMemoryStream.Create;
try
TempOut.SwapFileDirectory := Sender.TempDirectory;
{ save starting points }
InStartPos := InStream.Position;
{ try deflating item }
DoDeflate(ZipArchive, Item, TempOut, InStream);
{ if deflated size > input size then got negative compression }
{ so storing the item is more efficient }
if TempOut.Size > InStream.Size then begin { store item instead }
{ reset streams to original positions }
InStream.Position := InStartPos;
TempOut.Free;
TempOut := TAbVirtualMemoryStream.Create;
TempOut.SwapFileDirectory := Sender.TempDirectory;
{ store item }
DoStore(ZipArchive, Item, TempOut, InStream);
end {if};
TempOut.Seek(0, soBeginning);
DestStrm.CopyFrom(TempOut, TempOut.Size);
finally
TempOut.Free;
end;
end;
end; { case }
end
else begin
{ InStream is zero length}
Item.CRC32 := 0;
{ ignore any storage indicator and treat as stored }
DoStore(ZipArchive, Item, DestStrm, InStream);
end;
finally
if DestStrm <> OutStream then
DestStrm.Free;
end;
{ update item }
Item.CompressedSize := OutStream.Size;
Item.InternalFileAttributes := 0; { don't care }
if (ZipArchive.Password <> '') then
Item.GeneralPurposeBitFlag := Item.GeneralPurposeBitFlag
or AbFileIsEncryptedFlag or AbHasDataDescriptorFlag;
end;
{ -------------------------------------------------------------------------- }
procedure AbZipFromStream(Sender : TAbZipArchive; Item : TAbZipItem;
OutStream, InStream : TStream);
var
FileTimeStamp : LongInt;
begin
// Set item properties for non-file streams
Item.ExternalFileAttributes := 0;
FileTimeStamp := DateTimeToFileDate(SysUtils.Now);
Item.LastModFileTime := LongRec(FileTimeStamp).Lo;
Item.LastModFileDate := LongRec(FileTimeStamp).Hi;
DoZipFromStream(Sender, Item, OutStream, InStream);
end;
{ -------------------------------------------------------------------------- }
procedure AbZip( Sender : TAbZipArchive; Item : TAbZipItem;
OutStream : TStream );
var
UncompressedStream : TStream;
SaveDir : string;
AttrEx : TAbAttrExRec;
begin
UncompressedStream := nil;
GetDir(0, SaveDir);
try {SaveDir}
if (Sender.BaseDirectory <> '') then
ChDir(Sender.BaseDirectory);
if not AbFileGetAttrEx(Item.DiskFileName, AttrEx) then
raise EAbFileNotFound.Create;
if ((AttrEx.Attr and faDirectory) <> 0) then
UncompressedStream := TMemoryStream.Create
else
UncompressedStream :=
TFileStream.Create(Item.DiskFileName, fmOpenRead or fmShareDenyWrite);
finally {SaveDir}
ChDir( SaveDir );
end; {SaveDir}
try {UncompressedStream}
{$IFDEF UNIX}
Item.ExternalFileAttributes := LongWord(AttrEx.Mode) shl 16 + LongWord(AttrEx.Attr);
{$ELSE}
Item.ExternalFileAttributes := AttrEx.Attr;
{$ENDIF}
Item.LastModTimeAsDateTime := AttrEx.Time;
DoZipFromStream(Sender, Item, OutStream, UncompressedStream);
finally {UncompressedStream}
UncompressedStream.Free;
end; {UncompressedStream}
end;
{ -------------------------------------------------------------------------- }
procedure DeflateStream( UncompressedStream, CompressedStream : TStream );
{-Deflates everything in CompressedStream to UncompressedStream
no encryption is tried, no check on CRC is done, uses the whole
Uncompressedstream - no Progress events - no Frills!
}
begin
Deflate(UncompressedStream, CompressedStream, nil);
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/AbZipTyp.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Craig Peterson
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbZipTyp.pas *}
{*********************************************************}
{* ABBREVIA: PKZip types *}
{* Based on information from Appnote.txt, shipped with *}
{* PKWare's PKZip for Windows 2.5 *}
{*********************************************************}
unit AbZipTyp;
{$I AbDefine.inc}
interface
uses
Classes, AbArcTyp, AbUtils, AbSpanSt;
const
{ note #$50 = 'P', #$4B = 'K'}
Ab_ZipVersion = 63;
Ab_ZipLocalFileHeaderSignature : Longint = $04034B50;
Ab_ZipDataDescriptorSignature : Longint = $08074B50;
Ab_ZipCentralDirectoryFileHeaderSignature : Longint = $02014B50;
Ab_Zip64EndCentralDirectorySignature : Longint = $06064B50;
Ab_Zip64EndCentralDirectoryLocatorSignature:Longint = $07064B50;
Ab_ZipEndCentralDirectorySignature : Longint = $06054B50;
Ab_ZipSpannedSetSignature : Longint = $08074B50;
Ab_ZipPossiblySpannedSignature : Longint = $30304B50;
Ab_GeneralZipSignature : Word = $4B50;
Ab_ArchiveExtraDataRecord : Longint = $08064B50;
Ab_DigitalSignature : Longint = $05054B50;
Ab_WindowsExeSignature : Word = $5A4D;
Ab_LinuxExeSignature : Longint = $464C457F;
AbDefZipSpanningThreshold = 0;
AbDefPasswordRetries = 3;
AbFileIsEncryptedFlag = $0001;
AbHasDataDescriptorFlag = $0008;
AbLanguageEncodingFlag = $0800;
Ab_Zip64SubfieldID : Word = $0001;
Ab_InfoZipUnicodePathSubfieldID : Word = $7075;
Ab_XceedUnicodePathSubfieldID : Word = $554E;
Ab_XceedUnicodePathSignature : LongWord= $5843554E;
type
PAbByteArray4K = ^TAbByteArray4K;
TAbByteArray4K = array[1..4096] of Byte;
PAbByteArray8K = ^TAbByteArray8K;
TAbByteArray8K = array[0..8192] of Byte;
PAbIntArray8K = ^TAbIntArray8K;
TAbIntArray8K = array[0..8192] of SmallInt;
PAbWordArray = ^TAbWordArray;
TAbWordArray = array[0..65535 div SizeOf(Word)-1] of Word;
PAbByteArray = ^TAbByteArray;
TAbByteArray = array[0..65535-1] of Byte;
PAbSmallIntArray = ^TAbSmallIntArray;
TAbSmallIntArray = array[0..65535 div SizeOf(SmallInt)-1] of SmallInt;
PAbIntegerArray = ^TAbIntegerArray;
TAbIntegerArray = array[0..65535 div sizeof(integer)-1] of integer;
TAbZip64EndOfCentralDirectoryRecord = packed record
Signature : Longint;
RecordSize : Int64;
VersionMadeBy : Word;
VersionNeededToExtract : Word;
DiskNumber : LongWord;
StartDiskNumber : LongWord;
EntriesOnDisk : Int64;
TotalEntries : Int64;
DirectorySize : Int64;
DirectoryOffset : Int64;
end;
TAbZip64EndOfCentralDirectoryLocator = packed record
Signature : Longint;
StartDiskNumber : Longint;
RelativeOffset : Int64;
TotalDisks : Longint;
end;
TAbZipEndOfCentralDirectoryRecord = packed record
Signature : Longint;
DiskNumber : Word;
StartDiskNumber : Word;
EntriesOnDisk : Word;
TotalEntries : Word;
DirectorySize : LongWord;
DirectoryOffset : LongWord;
CommentLength : Word;
end;
TAbFollower = {used to expand reduced files}
packed record
Size : Byte; {size of follower set}
FSet : array[0..31] of Byte; {follower set}
end;
PAbFollowerSets = ^TAbFollowerSets;
TAbFollowerSets = array[0..255] of TAbFollower;
PAbSfEntry = ^TAbSfEntry;
TAbSfEntry = {entry in a Shannon-Fano tree}
packed record
case Byte of
0 : (Code : Word; Value, BitLength : Byte);
1 : (L : Longint);
end;
PAbSfTree = ^TAbSfTree;
TAbSfTree =
packed record {a Shannon-Fano tree}
Entries : SmallInt;
MaxLength : SmallInt;
Entry : array[0..256] of TAbSfEntry;
end;
PInfoZipUnicodePathRec = ^TInfoZipUnicodePathRec;
TInfoZipUnicodePathRec = packed record
Version: Byte;
NameCRC32: LongInt;
UnicodeName: array[0..0] of AnsiChar;
end;
PXceedUnicodePathRec = ^TXceedUnicodePathRec;
TXceedUnicodePathRec = packed record
Signature: LongWord;
Length: Integer;
UnicodeName: array[0..0] of WideChar;
end;
PZip64LocalHeaderRec = ^TZip64LocalHeaderRec;
TZip64LocalHeaderRec = packed record
UncompressedSize: Int64;
CompressedSize: Int64;
end;
type
TAbZipCompressionMethod =
(cmStored, cmShrunk, cmReduced1, cmReduced2, cmReduced3,
cmReduced4, cmImploded, cmTokenized, cmDeflated,
cmEnhancedDeflated, cmDCLImploded, cmBzip2 = 12, cmLZMA = 14,
cmIBMTerse = 18, cmLZ77, cmJPEG = 96, cmWavPack = 97, cmPPMd);
TAbZipSupportedMethod =
(smStored, smDeflated, smBestMethod);
{ExternalFileAttributes compatibility; aliases are Info-ZIP/PKZIP overlaps}
TAbZipHostOS =
(hosDOS, hosAmiga, hosVAX, hosUnix, hosVMCMS, hosAtari,
hosOS2, hosMacintosh, hosZSystem, hosCPM, hosNTFS, hosTOPS20 = hosNTFS,
hosMVS, hosWinNT = hosMVS, hosVSE, hosQDOS = hosVSE, hosRISC,
hosVFAT, hosAltMVS, hosBeOS, hosTandem, hosOS400, hosTHEOS = hosOS400,
hosDarwin, hosAtheOS = 30);
{for method 6 - imploding}
TAbZipDictionarySize =
(dsInvalid, ds4K, ds8K);
{for method 8 - deflating}
TAbZipDeflationOption =
(doInvalid, doNormal, doMaximum, doFast, doSuperFast );
type
TAbNeedPasswordEvent = procedure(Sender : TObject;
var NewPassword : AnsiString) of object;
const
AbDefCompressionMethodToUse = smBestMethod;
AbDefDeflationOption = doNormal;
type
TAbZipDataDescriptor = class( TObject )
protected {private}
FCRC32 : Longint;
FCompressedSize : Int64;
FUncompressedSize : Int64;
public {methods}
procedure SaveToStream( Stream : TStream );
public {properties}
property CRC32 : Longint
read FCRC32 write FCRC32;
property CompressedSize : Int64
read FCompressedSize write FCompressedSize;
property UncompressedSize : Int64
read FUncompressedSize write FUncompressedSize;
end;
type
{ TAbZipFileHeader interface =============================================== }
{ancestor class for ZipLocalFileHeader and DirectoryFileHeader}
TAbZipFileHeader = class( TObject )
protected {private}
FValidSignature : Longint;
FSignature : Longint;
FVersionNeededToExtract : Word;
FGeneralPurposeBitFlag : Word;
FCompressionMethod : Word;
FLastModFileTime : Word;
FLastModFileDate : Word;
FCRC32 : Longint;
FCompressedSize : LongWord;
FUncompressedSize : LongWord;
FFileName : AnsiString;
FExtraField : TAbExtraField;
protected {methods}
function GetCompressionMethod : TAbZipCompressionMethod;
function GetCompressionRatio : Double;
function GetDataDescriptor : Boolean;
function GetDeflationOption : TAbZipDeflationOption;
function GetDictionarySize : TAbZipDictionarySize;
function GetEncrypted : Boolean;
function GetIsUTF8 : Boolean;
function GetShannonFanoTreeCount : Byte;
function GetValid : Boolean;
procedure SetCompressionMethod( Value : TAbZipCompressionMethod );
procedure SetIsUTF8( Value : Boolean );
public {methods}
constructor Create;
destructor Destroy; override;
public {properties}
property Signature : Longint
read FSignature write FSignature;
property VersionNeededToExtract : Word
read FVersionNeededToExtract write FVersionNeededToExtract;
property GeneralPurposeBitFlag : Word
read FGeneralPurposeBitFlag write FGeneralPurposeBitFlag;
property CompressionMethod : TAbZipCompressionMethod
read GetCompressionMethod write SetCompressionMethod;
property LastModFileTime : Word
read FLastModFileTime write FLastModFileTime;
property LastModFileDate : Word
read FLastModFileDate write FLastModFileDate;
property CRC32 : Longint
read FCRC32 write FCRC32;
property CompressedSize : LongWord
read FCompressedSize write FCompressedSize;
property UncompressedSize : LongWord
read FUncompressedSize write FUncompressedSize;
property FileName : AnsiString
read FFileName write FFileName;
property ExtraField : TAbExtraField
read FExtraField;
property CompressionRatio : Double
read GetCompressionRatio;
property DeflationOption : TAbZipDeflationOption
read GetDeflationOption;
property DictionarySize : TAbZipDictionarySize
read GetDictionarySize;
property HasDataDescriptor : Boolean
read GetDataDescriptor;
property IsValid : Boolean
read GetValid;
property IsEncrypted : Boolean
read GetEncrypted;
property IsUTF8 : Boolean
read GetIsUTF8 write SetIsUTF8;
property ShannonFanoTreeCount : Byte
read GetShannonFanoTreeCount;
end;
{ TAbZipLocalFileHeader interface ========================================== }
TAbZipLocalFileHeader = class( TAbZipFileHeader )
public {methods}
constructor Create;
destructor Destroy; override;
procedure LoadFromStream( Stream : TStream );
procedure SaveToStream( Stream : TStream );
end;
{ TAbZipDirectoryFileHeader interface ====================================== }
TAbZipDirectoryFileHeader = class( TAbZipFileHeader )
protected {private}
FVersionMadeBy : Word;
FDiskNumberStart : Word;
FInternalFileAttributes : Word;
FExternalFileAttributes : LongWord;
FRelativeOffset : LongWord;
FFileComment : AnsiString;
public {methods}
constructor Create;
destructor Destroy; override;
procedure LoadFromStream( Stream : TStream );
procedure SaveToStream( Stream : TStream );
public {properties}
property VersionMadeBy : Word
read FVersionMadeBy write FVersionMadeBy;
property DiskNumberStart : Word
read FDiskNumberStart write FDiskNumberStart;
property InternalFileAttributes : Word
read FInternalFileAttributes write FInternalFileAttributes;
property ExternalFileAttributes : LongWord
read FExternalFileAttributes write FExternalFileAttributes;
property RelativeOffset : LongWord
read FRelativeOffset write FRelativeOffset;
property FileComment : AnsiString
read FFileComment write FFileComment;
end;
{ TAbZipDirectoryFileFooter interface ====================================== }
TAbZipDirectoryFileFooter = class( TObject )
protected {private}
FDiskNumber : LongWord;
FStartDiskNumber : LongWord;
FEntriesOnDisk : Int64;
FTotalEntries : Int64;
FDirectorySize : Int64;
FDirectoryOffset : Int64;
FZipfileComment : AnsiString;
function GetIsZip64: Boolean;
public {methods}
procedure LoadFromStream( Stream : TStream );
procedure LoadZip64FromStream( Stream : TStream );
procedure SaveToStream( Stream : TStream; aZip64TailOffset : Int64 = -1 );
public {properties}
property DiskNumber : LongWord
read FDiskNumber write FDiskNumber;
property EntriesOnDisk : Int64
read FEntriesOnDisk write FEntriesOnDisk;
property TotalEntries : Int64
read FTotalEntries write FTotalEntries;
property DirectorySize : Int64
read FDirectorySize write FDirectorySize;
property DirectoryOffset : Int64
read FDirectoryOffset write FDirectoryOffset;
property StartDiskNumber : LongWord
read FStartDiskNumber write FStartDiskNumber;
property ZipfileComment : AnsiString
read FZipfileComment write FZipfileComment;
property IsZip64: Boolean
read GetIsZip64;
end;
{ TAbZipItem interface ===================================================== }
TAbZipItem = class( TAbArchiveItem )
protected {private}
FItemInfo : TAbZipDirectoryFileHeader;
FDiskNumberStart : LongWord;
FLFHExtraField : TAbExtraField;
FRelativeOffset : Int64;
protected {methods}
function GetCompressionMethod : TAbZipCompressionMethod;
function GetCompressionRatio : Double;
function GetDeflationOption : TAbZipDeflationOption;
function GetDictionarySize : TAbZipDictionarySize;
function GetExtraField : TAbExtraField;
function GetFileComment : AnsiString;
function GetGeneralPurposeBitFlag : Word;
function GetHostOS: TAbZipHostOS;
function GetInternalFileAttributes : Word;
function GetRawFileName : AnsiString;
function GetShannonFanoTreeCount : Byte;
function GetVersionMadeBy : Word;
function GetVersionNeededToExtract : Word;
procedure SaveCDHToStream( Stream : TStream );
procedure SaveDDToStream( Stream : TStream );
procedure SaveLFHToStream( Stream : TStream );
procedure SetCompressionMethod( Value : TAbZipCompressionMethod );
procedure SetDiskNumberStart( Value : LongWord );
procedure SetFileComment(const Value : AnsiString );
procedure SetGeneralPurposeBitFlag( Value : Word );
procedure SetHostOS( Value : TAbZipHostOS );
procedure SetInternalFileAttributes( Value : Word );
procedure SetRelativeOffset( Value : Int64 );
procedure SetVersionMadeBy( Value : Word );
procedure SetVersionNeededToExtract( Value : Word );
procedure UpdateVersionNeededToExtract;
procedure UpdateZip64ExtraHeader;
protected {redefined property methods}
function GetCRC32 : Longint; override;
function GetExternalFileAttributes : LongWord; override;
function GetIsDirectory: Boolean; override;
function GetIsEncrypted : Boolean; override;
function GetLastModFileDate : Word; override;
function GetLastModFileTime : Word; override;
function GetNativeFileAttributes : LongInt; override;
procedure SetCompressedSize( const Value : Int64 ); override;
procedure SetCRC32( const Value : Longint ); override;
procedure SetExternalFileAttributes( Value : LongWord ); override;
procedure SetFileName(const Value : string ); override;
procedure SetLastModFileDate(const Value : Word ); override;
procedure SetLastModFileTime(const Value : Word ); override;
procedure SetUncompressedSize( const Value : Int64 ); override;
public {methods}
constructor Create;
destructor Destroy; override;
procedure LoadFromStream( Stream : TStream );
public {properties}
property CompressionMethod : TAbZipCompressionMethod
read GetCompressionMethod
write SetCompressionMethod;
property CompressionRatio : Double
read GetCompressionRatio;
property DeflationOption : TAbZipDeflationOption
read GetDeflationOption;
property DictionarySize : TAbZipDictionarySize
read GetDictionarySize;
property DiskNumberStart : LongWord
read FDiskNumberStart
write SetDiskNumberStart;
property ExtraField : TAbExtraField
read GetExtraField;
property FileComment : AnsiString
read GetFileComment
write SetFileComment;
property HostOS: TAbZipHostOS
read GetHostOS
write SetHostOS;
property InternalFileAttributes : Word
read GetInternalFileAttributes
write SetInternalFileAttributes;
property GeneralPurposeBitFlag : Word
read GetGeneralPurposeBitFlag
write SetGeneralPurposeBitFlag;
property LFHExtraField : TAbExtraField
read FLFHExtraField;
property RawFileName : AnsiString
read GetRawFileName;
property RelativeOffset : Int64
read FRelativeOffset
write SetRelativeOffset;
property ShannonFanoTreeCount : Byte
read GetShannonFanoTreeCount;
property VersionMadeBy : Word
read GetVersionMadeBy
write SetVersionMadeBy;
property VersionNeededToExtract : Word
read GetVersionNeededToExtract
write SetVersionNeededToExtract;
end;
{ TAbZipArchive interface ================================================== }
TAbZipArchive = class( TAbArchive )
protected {private}
FCompressionMethodToUse : TAbZipSupportedMethod;
FDeflationOption : TAbZipDeflationOption;
FInfo : TAbZipDirectoryFileFooter;
FIsExecutable : Boolean;
FPassword : AnsiString;
FPasswordRetries : Byte;
FStubSize : LongWord;
FExtractHelper : TAbArchiveItemExtractEvent;
FExtractToStreamHelper : TAbArchiveItemExtractToStreamEvent;
FTestHelper : TAbArchiveItemTestEvent;
FInsertHelper : TAbArchiveItemInsertEvent;
FInsertFromStreamHelper : TAbArchiveItemInsertFromStreamEvent;
FOnNeedPassword : TAbNeedPasswordEvent;
FOnRequestLastDisk : TAbRequestDiskEvent;
FOnRequestNthDisk : TAbRequestNthDiskEvent;
FOnRequestBlankDisk : TAbRequestDiskEvent;
protected {methods}
procedure DoExtractHelper(Index : Integer; const NewName : string);
procedure DoExtractToStreamHelper(Index : Integer; aStream : TStream);
procedure DoTestHelper(Index : Integer);
procedure DoInsertHelper(Index : Integer; OutStream : TStream);
procedure DoInsertFromStreamHelper(Index : Integer; OutStream : TStream);
function GetItem( Index : Integer ) : TAbZipItem;
function GetZipfileComment : AnsiString;
procedure PutItem( Index : Integer; Value : TAbZipItem );
procedure DoRequestDisk(const AMessage: string; var Abort : Boolean);
procedure DoRequestLastDisk( var Abort : Boolean );
virtual;
procedure DoRequestNthDisk(Sender: TObject; DiskNumber : Byte; var Abort : Boolean );
virtual;
procedure DoRequestBlankDisk(Sender: TObject; var Abort : Boolean );
virtual;
procedure ExtractItemAt(Index : Integer; const UseName : string);
override;
procedure ExtractItemToStreamAt(Index : Integer; aStream : TStream);
override;
procedure TestItemAt(Index : Integer);
override;
function FixName(const Value : string ) : string;
override;
function GetSupportsEmptyFolders: Boolean;
override;
procedure LoadArchive;
override;
procedure SaveArchive;
override;
procedure SetZipfileComment(const Value : AnsiString );
protected {properties}
property IsExecutable : Boolean
read FIsExecutable write FIsExecutable;
public {protected}
procedure DoRequestImage(Sender: TObject; ImageNumber: Integer;
var ImageName: string; var Abort: Boolean);
public {methods}
constructor CreateFromStream( aStream : TStream; const ArchiveName : string );
override;
destructor Destroy;
override;
function CreateItem(const FileName : string): TAbArchiveItem;
override;
public {properties}
property CompressionMethodToUse : TAbZipSupportedMethod
read FCompressionMethodToUse
write FCompressionMethodToUse;
property DeflationOption : TAbZipDeflationOption
read FDeflationOption
write FDeflationOption;
property ExtractHelper : TAbArchiveItemExtractEvent
read FExtractHelper
write FExtractHelper;
property ExtractToStreamHelper : TAbArchiveItemExtractToStreamEvent
read FExtractToStreamHelper
write FExtractToStreamHelper;
property TestHelper : TAbArchiveItemTestEvent
read FTestHelper
write FTestHelper;
property InsertHelper : TAbArchiveItemInsertEvent
read FInsertHelper
write FInsertHelper;
property InsertFromStreamHelper : TAbArchiveItemInsertFromStreamEvent
read FInsertFromStreamHelper
write FInsertFromStreamHelper;
property Password : AnsiString
read FPassword
write FPassword;
property PasswordRetries : Byte
read FPasswordRetries
write FPasswordRetries
default AbDefPasswordRetries;
property StubSize : LongWord
read FStubSize;
property ZipfileComment : AnsiString
read GetZipfileComment
write SetZipfileComment;
property Items[Index : Integer] : TAbZipItem
read GetItem
write PutItem; default;
public {events}
property OnNeedPassword : TAbNeedPasswordEvent
read FOnNeedPassword write FOnNeedPassword;
property OnRequestLastDisk : TAbRequestDiskEvent
read FOnRequestLastDisk write FOnRequestLastDisk;
property OnRequestNthDisk : TAbRequestNthDiskEvent
read FOnRequestNthDisk write FOnRequestNthDisk;
property OnRequestBlankDisk : TAbRequestDiskEvent
read FOnRequestBlankDisk write FOnRequestBlankDisk;
end;
{============================================================================}
procedure MakeSelfExtracting( StubStream, ZipStream,
SelfExtractingStream : TStream );
{-takes an executable stub, and a .zip format stream, and creates
a SelfExtracting stream. The stub should create a TAbZipArchive
passing itself as the file, using a read-only open mode. It should
then perform operations as needed - like ExtractFiles( '*.*' ).
This routine updates the RelativeOffset of each item in the archive}
function FindCentralDirectoryTail(aStream : TStream) : Int64;
function VerifyZip(Strm : TStream) : TAbArchiveType;
function VerifySelfExtracting(Strm : TStream) : TAbArchiveType;
function ZipCompressionMethodToString(aMethod: TAbZipCompressionMethod): string;
implementation
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
{$IFDEF LibcAPI}
Libc,
{$ENDIF}
{$IFDEF UnixDialogs}
{$IFDEF KYLIX}
QControls,
QDialogs,
{$ENDIF}
{$IFDEF LCL}
Controls,
Dialogs,
{$ENDIF}
{$ENDIF}
Math,
AbCharset,
AbResString,
AbExcept,
AbVMStrm,
SysUtils;
function VerifyZip(Strm : TStream) : TAbArchiveType;
{ determine if stream appears to be in PkZip format }
var
Footer : TAbZipEndOfCentralDirectoryRecord;
Sig : LongInt;
TailPosition : int64;
StartPos : int64;
begin
StartPos := Strm.Position;
Result := atUnknown;
try
Strm.Position := 0;
Strm.Read(Sig, SizeOf(Sig));
if (Sig = Ab_ZipSpannedSetSignature) then
Result := atSpannedZip
else begin
{ attempt to find Central Directory Tail }
TailPosition := FindCentralDirectoryTail( Strm );
if TailPosition <> -1 then begin
{ check Central Directory Signature }
Strm.ReadBuffer(Footer, SizeOf(Footer));
if Footer.Signature = Ab_ZipEndCentralDirectorySignature then
if Footer.DiskNumber = 0 then
Result := atZip
else
Result := atSpannedZip;
end;
end;
except
on EReadError do
Result := atUnknown;
end;
Strm.Position := StartPos;
end;
function VerifySelfExtracting(Strm : TStream) : TAbArchiveType;
{ determine if stream appears to be an executable with appended PkZip data }
var
FileSignature : Longint;
StartPos : Int64;
IsWinExe, IsLinuxExe : Boolean;
begin
StartPos := Strm.Position;
{ verify presence of executable stub }
{check file type of stub stream}
Strm.Position := 0;
Strm.Read( FileSignature, sizeof( FileSignature ) );
Result := atSelfExtZip;
{ detect executable type }
IsLinuxExe := FileSignature = Ab_LinuxExeSignature;
IsWinExe := LongRec(FileSignature).Lo = Ab_WindowsExeSignature;
if not (IsWinExe or IsLinuxExe) then
Result := atUnknown;
{ Check for central directory tail }
if VerifyZip(Strm) <> atZip then
Result := atUnknown;
Strm.Position := StartPos;
end;
{============================================================================}
function ZipCompressionMethodToString(aMethod: TAbZipCompressionMethod): string;
begin
case aMethod of
cmStored:
Result := AbZipStored;
cmShrunk:
Result := AbZipShrunk;
cmReduced1..cmReduced4:
Result := AbZipReduced;
cmImploded:
Result := AbZipImploded;
cmTokenized:
Result := AbZipTokenized;
cmDeflated:
Result := AbZipDeflated;
cmEnhancedDeflated:
Result := AbZipDeflate64;
cmDCLImploded:
Result := AbZipDCLImploded;
cmBzip2:
Result := AbZipBzip2;
cmLZMA:
Result := AbZipLZMA;
cmIBMTerse:
Result := AbZipIBMTerse;
cmLZ77:
Result := AbZipLZ77;
cmJPEG:
Result := AbZipJPEG;
cmWavPack:
Result := AbZipWavPack;
cmPPMd:
Result := AbZipPPMd;
else
Result := Format(AbZipUnknown, [Ord(aMethod)]);
end;
end;
{============================================================================}
function FindCentralDirectoryTail(aStream : TStream) : Int64;
{ search end of aStream looking for ZIP Central Directory structure
returns position in stream if found (otherwise returns -1),
leaves stream positioned at start of structure or at original
position if not found }
const
StartBufSize = 512;
MaxBufSize = 64 * 1024;
var
StartPos : Int64;
TailRec : TAbZipEndOfCentralDirectoryRecord;
Buffer : PAnsiChar;
Offset : Int64;
TestPos : PAnsiChar;
Done : boolean;
BytesRead : Int64;
BufSize : Int64;
CommentLen: integer;
begin
{save the starting position}
StartPos := aStream.Seek(0, soCurrent);
{start off with the majority case: no zip file comment, so the
central directory tail is the last thing in the stream and it's a
fixed size and doesn't indicate a zip file comment}
Result := aStream.Seek(-sizeof(TailRec), soEnd);
if (Result >= 0) then begin
aStream.ReadBuffer(TailRec, sizeof(TailRec));
if (TailRec.Signature = Ab_ZipEndCentralDirectorySignature) and
(TailRec.CommentLength = 0) then begin
aStream.Seek(Result, soBeginning);
Exit;
end;
end;
{the zip stream seems to have a comment, or it has null padding
bytes from some flaky program, or it's not even a zip formatted
stream; we need to search for the tail signature}
{get a buffer}
BufSize := StartBufSize;
GetMem(Buffer, BufSize);
try
{start out searching backwards}
Offset := -BufSize;
{while there is still data to search ...}
Done := false;
while not Done do begin
{seek to the search position}
Result := aStream.Seek(Offset, soEnd);
if (Result <= 0) then begin
Result := aStream.Seek(0, soBeginning);
Done := true;
end;
{read a buffer full}
BytesRead := aStream.Read(Buffer^, BufSize);
if BytesRead < sizeOf(TailRec) then begin
Result := -1;
Exit;
end;
{search backwards through the buffer looking for the signature}
TestPos := Buffer + BytesRead - sizeof(TailRec);
while (TestPos <> Buffer) and
(PLongint(TestPos)^ <> Ab_ZipEndCentralDirectorySignature) do
dec(TestPos);
{if we found the signature...}
if (PLongint(TestPos)^ = Ab_ZipEndCentralDirectorySignature) then begin
{get the tail record at this position}
Move(TestPos^, TailRec, sizeof(TailRec));
{if it's as valid a tail as we can check here...}
CommentLen := -Offset - (TestPos - Buffer + sizeof(TailRec));
if (TailRec.CommentLength <= CommentLen) then begin
{calculate its position and exit}
Result := Result + (TestPos - Buffer);
aStream.Seek(Result, soBeginning);
Exit;
end;
end;
{otherwise move back one step, doubling the buffer}
if (BufSize < MaxBufSize) then begin
FreeMem(Buffer);
BufSize := BufSize * 2;
if BufSize > MaxBufSize then
BufSize := MaxBufSize;
GetMem(Buffer, BufSize);
end;
dec(Offset, BufSize - SizeOf(TailRec));
end;
{if we reach this point, the CD tail is not present}
Result := -1;
aStream.Seek(StartPos, soBeginning);
finally
FreeMem(Buffer);
end;
end;
{============================================================================}
procedure MakeSelfExtracting( StubStream, ZipStream,
SelfExtractingStream : TStream );
{-takes an executable stub, and a .zip format stream, and creates
a SelfExtracting stream. The stub should create a TAbZipArchive
passing itself as the file, using a read-only open mode. It should
then perform operations as needed - like ExtractFiles( '*.*' ).
This routine updates the RelativeOffset of each item in the archive}
var
DirectoryStart : Int64;
FileSignature : Longint;
StubSize : LongWord;
TailPosition : Int64;
ZDFF : TAbZipDirectoryFileFooter;
ZipItem : TAbZipItem;
IsWinExe, IsLinuxExe : Boolean;
begin
{check file type of stub stream}
StubStream.Position := 0;
StubStream.Read(FileSignature, SizeOf(FileSignature));
{detect executable type }
IsLinuxExe := FileSignature = Ab_LinuxExeSignature;
IsWinExe := LongRec(FileSignature).Lo = Ab_WindowsExeSignature;
if not (IsWinExe or IsLinuxExe) then
raise EAbZipInvalidStub.Create;
StubStream.Position := 0;
StubSize := StubStream.Size;
ZipStream.Position := 0;
ZipStream.Read( FileSignature, sizeof( FileSignature ) );
if LongRec(FileSignature).Lo <> Ab_GeneralZipSignature then
raise EAbZipInvalid.Create;
ZipStream.Position := 0;
{copy the stub into the selfex stream}
SelfExtractingStream.Position := 0;
SelfExtractingStream.CopyFrom( StubStream, 0 );
TailPosition := FindCentralDirectoryTail( ZipStream );
if TailPosition = -1 then
raise EAbZipInvalid.Create;
{load the ZipDirectoryFileFooter}
ZDFF := TAbZipDirectoryFileFooter.Create;
try
ZDFF.LoadFromStream( ZipStream );
DirectoryStart := ZDFF.DirectoryOffset;
finally
ZDFF.Free;
end;
{copy everything up to the CDH into the SelfExtractingStream}
ZipStream.Position := 0;
SelfExtractingStream.CopyFrom( ZipStream, DirectoryStart );
ZipStream.Position := DirectoryStart;
repeat
ZipItem := TAbZipItem.Create;
try
ZipItem.LoadFromStream( ZipStream );
ZipItem.RelativeOffset := ZipItem.RelativeOffset + StubSize;
{save the modified entry into the Self Extracting Stream}
ZipItem.SaveCDHToStream( SelfExtractingStream );
finally
ZipItem.Free;
end;
until ZipStream.Position = TailPosition;
{save the CDH Footer.}
ZDFF := TAbZipDirectoryFileFooter.Create;
try
ZDFF.LoadFromStream( ZipStream );
ZDFF.DirectoryOffset := ZDFF.DirectoryOffset + StubSize;
ZDFF.SaveToStream( SelfExtractingStream );
finally
ZDFF.Free;
end;
end;
{============================================================================}
{ TAbZipDataDescriptor implementation ====================================== }
procedure TAbZipDataDescriptor.SaveToStream( Stream : TStream );
begin
Stream.Write( Ab_ZipDataDescriptorSignature, sizeof( Ab_ZipDataDescriptorSignature ) );
Stream.Write( FCRC32, sizeof( FCRC32 ) );
if (FCompressedSize >= $FFFFFFFF) or (FUncompressedSize >= $FFFFFFFF) then begin
Stream.Write( FCompressedSize, sizeof( FCompressedSize ) );
Stream.Write( FUncompressedSize, sizeof( FUncompressedSize ) );
end
else begin
Stream.Write( FCompressedSize, sizeof( LongWord ) );
Stream.Write( FUncompressedSize, sizeof( LongWord ) );
end;
end;
{ -------------------------------------------------------------------------- }
{ TAbZipFileHeader implementation ========================================== }
constructor TAbZipFileHeader.Create;
begin
inherited Create;
FExtraField := TAbExtraField.Create;
FValidSignature := $0;
end;
{ -------------------------------------------------------------------------- }
destructor TAbZipFileHeader.Destroy;
begin
FreeAndNil(FExtraField);
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
function TAbZipFileHeader.GetCompressionMethod : TAbZipCompressionMethod;
begin
Result := TAbZipCompressionMethod( FCompressionMethod );
end;
{ -------------------------------------------------------------------------- }
function TAbZipFileHeader.GetDataDescriptor : Boolean;
begin
Result := ( CompressionMethod = cmDeflated ) and
( ( FGeneralPurposeBitFlag and AbHasDataDescriptorFlag ) <> 0 );
end;
{ -------------------------------------------------------------------------- }
function TAbZipFileHeader.GetCompressionRatio : Double;
var
CompSize : Int64;
begin
{adjust for encrypted headers - ensures we never get negative compression
ratios for stored, encrypted files - no guarantees about negative
compression ratios in other cases}
if isEncrypted then
CompSize := CompressedSize - 12
else
CompSize := CompressedSize;
if UncompressedSize > 0 then
Result := 100.0 * ( 1 - ( ( 1.0 * CompSize ) / UncompressedSize ) )
else
Result := 0.0;
end;
{ -------------------------------------------------------------------------- }
function TAbZipFileHeader.GetDeflationOption : TAbZipDeflationOption;
begin
if CompressionMethod = cmDeflated then
if ( ( FGeneralPurposeBitFlag and $02 ) <> 0 ) then
if ( ( FGeneralPurposeBitFlag and $04 ) <> 0 ) then
Result := doSuperFast
else
Result := doMaximum
else
if ( ( FGeneralPurposeBitFlag and $04 ) <> 0 ) then
Result := doFast
else
Result := doNormal
else
Result := doInvalid;
end;
{ -------------------------------------------------------------------------- }
function TAbZipFileHeader.GetDictionarySize : TAbZipDictionarySize;
begin
if CompressionMethod = cmImploded then
if ( ( FGeneralPurposeBitFlag and $02 ) <> 0 ) then
Result := ds8K
else
Result := ds4K
else
Result := dsInvalid;
end;
{ -------------------------------------------------------------------------- }
function TAbZipFileHeader.GetEncrypted : Boolean;
begin
{bit 0 of the GeneralPurposeBitFlag}
Result := ( ( FGeneralPurposeBitFlag and AbFileIsEncryptedFlag ) <> 0 );
end;
{ -------------------------------------------------------------------------- }
function TAbZipFileHeader.GetIsUTF8 : Boolean;
begin
Result := ( ( GeneralPurposeBitFlag and AbLanguageEncodingFlag ) <> 0 );
end;
{ -------------------------------------------------------------------------- }
function TAbZipFileHeader.GetShannonFanoTreeCount : Byte;
begin
if CompressionMethod = cmImploded then
if ( ( FGeneralPurposeBitFlag and $04 ) <> 0 ) then
Result := 3
else
Result := 2
else
Result := 0;
end;
{ -------------------------------------------------------------------------- }
function TAbZipFileHeader.GetValid : Boolean;
begin
Result := ( FValidSignature = FSignature );
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipFileHeader.SetCompressionMethod( Value :
TAbZipCompressionMethod );
begin
FCompressionMethod := Ord( Value );
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipFileHeader.SetIsUTF8( Value : Boolean );
begin
if Value then
GeneralPurposeBitFlag := GeneralPurposeBitFlag or AbLanguageEncodingFlag
else
GeneralPurposeBitFlag := GeneralPurposeBitFlag and not AbLanguageEncodingFlag;
end;
{ -------------------------------------------------------------------------- }
{ TAbZipLocalFileHeader implementation ===================================== }
constructor TAbZipLocalFileHeader.Create;
begin
inherited Create;
FValidSignature := Ab_ZipLocalFileHeaderSignature;
end;
{ -------------------------------------------------------------------------- }
destructor TAbZipLocalFileHeader.Destroy;
begin
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipLocalFileHeader.LoadFromStream( Stream : TStream );
var
ExtraFieldLength, FileNameLength : Word;
begin
with Stream do begin
Read( FSignature, sizeof( FSignature ) );
Read( FVersionNeededToExtract, sizeof( FVersionNeededToExtract ) );
Read( FGeneralPurposeBitFlag, sizeof( FGeneralPurposeBitFlag ) );
Read( FCompressionMethod, sizeof( FCompressionMethod ) );
Read( FLastModFileTime, sizeof( FLastModFileTime ) );
Read( FLastModFileDate, sizeof( FLastModFileDate ) );
Read( FCRC32, sizeof( FCRC32 ) );
Read( FCompressedSize, sizeof( FCompressedSize ) );
Read( FUncompressedSize, sizeof( FUncompressedSize ) );
Read( FileNameLength, sizeof( FileNameLength ) );
Read( ExtraFieldLength, sizeof( ExtraFieldLength ) );
SetLength( FFileName, FileNameLength );
if FileNameLength > 0 then
Read( FFileName[1], FileNameLength );
FExtraField.LoadFromStream( Stream, ExtraFieldLength );
end;
if not IsValid then
raise EAbZipInvalid.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipLocalFileHeader.SaveToStream( Stream : TStream );
var
ExtraFieldLength, FileNameLength: Word;
begin
with Stream do begin
{write the valid signature from the constant}
Write( FValidSignature, sizeof( FValidSignature ) );
Write( FVersionNeededToExtract, sizeof( FVersionNeededToExtract ) );
Write( FGeneralPurposeBitFlag, sizeof( FGeneralPurposeBitFlag ) );
Write( FCompressionMethod, sizeof( FCompressionMethod ) );
Write( FLastModFileTime, sizeof( FLastModFileTime ) );
Write( FLastModFileDate, sizeof( FLastModFileDate ) );
Write( FCRC32, sizeof( FCRC32 ) );
Write( FCompressedSize, sizeof( FCompressedSize ) );
Write( FUncompressedSize, sizeof( FUncompressedSize ) );
FileNameLength := Word( Length( FFileName ) );
Write( FileNameLength, sizeof( FileNameLength ) );
ExtraFieldLength := Length(FExtraField.Buffer);
Write( ExtraFieldLength, sizeof( ExtraFieldLength ) );
if FileNameLength > 0 then
Write( FFileName[1], FileNameLength );
if ExtraFieldLength > 0 then
Write(FExtraField.Buffer[0], ExtraFieldLength);
end;
end;
{ -------------------------------------------------------------------------- }
{ TAbZipDirectoryFileHeader implementation ================================= }
constructor TAbZipDirectoryFileHeader.Create;
begin
inherited Create;
FValidSignature := Ab_ZipCentralDirectoryFileHeaderSignature;
end;
{ -------------------------------------------------------------------------- }
destructor TAbZipDirectoryFileHeader.Destroy;
begin
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDirectoryFileHeader.LoadFromStream( Stream : TStream );
var
ExtraFieldLength, FileCommentLength, FileNameLength : Word;
begin
with Stream do begin
Read( FSignature, sizeof( FSignature ) );
Read( FVersionMadeBy, sizeof( FVersionMadeBy ) );
Read( FVersionNeededToExtract, sizeof( FVersionNeededToExtract ) );
Read( FGeneralPurposeBitFlag, sizeof( FGeneralPurposeBitFlag ) );
Read( FCompressionMethod, sizeof( FCompressionMethod ) );
Read( FLastModFileTime, sizeof( FLastModFileTime ) );
Read( FLastModFileDate, sizeof( FLastModFileDate ) );
Read( FCRC32, sizeof( FCRC32 ) );
Read( FCompressedSize, sizeof( FCompressedSize ) );
Read( FUncompressedSize, sizeof( FUncompressedSize ) );
Read( FileNameLength, sizeof( FileNameLength ) );
Read( ExtraFieldLength, sizeof( ExtraFieldLength ) );
Read( FileCommentLength, sizeof( FileCommentLength ) );
Read( FDiskNumberStart, sizeof( FDiskNumberStart ) );
Read( FInternalFileAttributes, sizeof( FInternalFileAttributes ) );
Read( FExternalFileAttributes, sizeof( FExternalFileAttributes ) );
Read( FRelativeOffset, sizeof( FRelativeOffset ) );
SetLength( FFileName, FileNameLength );
if FileNameLength > 0 then
Read( FFileName[1], FileNameLength );
FExtraField.LoadFromStream( Stream, ExtraFieldLength );
SetLength( FFileComment, FileCommentLength );
if FileCommentLength > 0 then
Read( FFileComment[1], FileCommentLength );
end;
if not IsValid then
raise EAbZipInvalid.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDirectoryFileHeader.SaveToStream( Stream : TStream );
var
ExtraFieldLength, FileCommentLength, FileNameLength : Word;
begin
with Stream do begin
{write the valid signature from the constant}
Write( FValidSignature, sizeof( FValidSignature ) );
Write( FVersionMadeBy, sizeof( FVersionMadeBy ) );
Write( FVersionNeededToExtract, sizeof( FVersionNeededToExtract ) );
Write( FGeneralPurposeBitFlag, sizeof( FGeneralPurposeBitFlag ) );
Write( FCompressionMethod, sizeof( FCompressionMethod ) );
Write( FLastModFileTime, sizeof( FLastModFileTime ) );
Write( FLastModFileDate, sizeof( FLastModFileDate ) );
Write( FCRC32, sizeof( FCRC32 ) );
Write( FCompressedSize, sizeof( FCompressedSize ) );
Write( FUncompressedSize, sizeof( FUncompressedSize ) );
FileNameLength := Word( Length( FFileName ) );
Write( FileNameLength, sizeof( FileNameLength ) );
ExtraFieldLength := Length(FExtraField.Buffer);
Write( ExtraFieldLength, sizeof( ExtraFieldLength ) );
FileCommentLength := Word( Length( FFileComment ) );
Write( FileCommentLength, sizeof( FileCommentLength ) );
Write( FDiskNumberStart, sizeof( FDiskNumberStart ) );
Write( FInternalFileAttributes, sizeof( FInternalFileAttributes ) );
Write( FExternalFileAttributes, sizeof( FExternalFileAttributes ) );
Write( FRelativeOffset, sizeof( FRelativeOffset ) );
if FileNameLength > 0 then
Write( FFileName[1], FileNameLength );
if ExtraFieldLength > 0 then
Write( FExtraField.Buffer[0], ExtraFieldLength );
if FileCommentLength > 0 then
Write( FFileComment[1], FileCommentLength );
end;
end;
{ -------------------------------------------------------------------------- }
{ TAbZipDirectoryFileFooter implementation ================================= }
function TAbZipDirectoryFileFooter.GetIsZip64: Boolean;
begin
Result := (DiskNumber >= $FFFF) or
(StartDiskNumber >= $FFFF) or
(EntriesOnDisk >= $FFFF) or
(TotalEntries >= $FFFF) or
(DirectorySize >= $FFFFFFFF) or
(DirectoryOffset >= $FFFFFFFF);
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDirectoryFileFooter.LoadFromStream( Stream : TStream );
var
Footer: TAbZipEndOfCentralDirectoryRecord;
begin
Stream.ReadBuffer( Footer, SizeOf(Footer) );
if Footer.Signature <> Ab_ZipEndCentralDirectorySignature then
raise EAbZipInvalid.Create;
FDiskNumber := Footer.DiskNumber;
FStartDiskNumber := Footer.StartDiskNumber;
FEntriesOnDisk := Footer.EntriesOnDisk;
FTotalEntries := Footer.TotalEntries;
FDirectorySize := Footer.DirectorySize;
FDirectoryOffset := Footer.DirectoryOffset;
SetLength( FZipfileComment, Footer.CommentLength );
if Footer.CommentLength > 0 then
Stream.ReadBuffer( FZipfileComment[1], Footer.CommentLength );
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDirectoryFileFooter.LoadZip64FromStream( Stream : TStream );
{load the ZIP64 end of central directory record.
LoadFromStream() must be called first to load the standard record}
var
Footer: TAbZip64EndOfCentralDirectoryRecord;
begin
Stream.ReadBuffer( Footer, SizeOf(Footer) );
if Footer.Signature <> Ab_Zip64EndCentralDirectorySignature then
raise EAbZipInvalid.Create;
if FDiskNumber = $FFFF then
FDiskNumber := Footer.DiskNumber;
if FStartDiskNumber = $FFFF then
FStartDiskNumber := Footer.StartDiskNumber;
if FEntriesOnDisk = $FFFF then
FEntriesOnDisk := Footer.EntriesOnDisk;
if FTotalEntries = $FFFF then
FTotalEntries := Footer.TotalEntries;
if FDirectorySize = $FFFFFFFF then
FDirectorySize := Footer.DirectorySize;
if FDirectoryOffset = $FFFFFFFF then
FDirectoryOffset := Footer.DirectoryOffset;
{RecordSize, VersionMadeBy, and VersionNeededToExtract are currently ignored}
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipDirectoryFileFooter.SaveToStream( Stream : TStream;
aZip64TailOffset: Int64 = -1);
{write end of central directory record, along with Zip64 records if necessary.
aZip64TailOffset is the value to use for the Zip64 locator's directory
offset, and is only necessary when writing to an intermediate stream}
var
Footer: TAbZipEndOfCentralDirectoryRecord;
Zip64Footer: TAbZip64EndOfCentralDirectoryRecord;
Zip64Locator: TAbZip64EndOfCentralDirectoryLocator;
begin
if IsZip64 then begin
{setup Zip64 end of central directory record}
Zip64Footer.Signature := Ab_Zip64EndCentralDirectorySignature;
Zip64Footer.RecordSize := SizeOf(Zip64Footer) -
SizeOf(Zip64Footer.Signature) - SizeOf(Zip64Footer.RecordSize);
Zip64Footer.VersionMadeBy := 45;
Zip64Footer.VersionNeededToExtract := 45;
Zip64Footer.DiskNumber := DiskNumber;
Zip64Footer.StartDiskNumber := StartDiskNumber;
Zip64Footer.EntriesOnDisk := EntriesOnDisk;
Zip64Footer.TotalEntries := TotalEntries;
Zip64Footer.DirectorySize := DirectorySize;
Zip64Footer.DirectoryOffset := DirectoryOffset;
{setup Zip64 end of central directory locator}
Zip64Locator.Signature := Ab_Zip64EndCentralDirectoryLocatorSignature;
Zip64Locator.StartDiskNumber := DiskNumber;
if aZip64TailOffset = -1 then
Zip64Locator.RelativeOffset := Stream.Position
else
Zip64Locator.RelativeOffset := aZip64TailOffset;
Zip64Locator.TotalDisks := DiskNumber + 1;
{write Zip64 records}
Stream.WriteBuffer(Zip64Footer, SizeOf(Zip64Footer));
Stream.WriteBuffer(Zip64Locator, SizeOf(Zip64Locator));
end;
Footer.Signature := Ab_ZipEndCentralDirectorySignature;
Footer.DiskNumber := Min(FDiskNumber, $FFFF);
Footer.StartDiskNumber := Min(FStartDiskNumber, $FFFF);
Footer.EntriesOnDisk := Min(FEntriesOnDisk, $FFFF);
Footer.TotalEntries := Min(FTotalEntries, $FFFF);
Footer.DirectorySize := Min(FDirectorySize, $FFFFFFFF);
Footer.DirectoryOffset := Min(FDirectoryOffset, $FFFFFFFF);
Footer.CommentLength := Length( FZipfileComment );
Stream.WriteBuffer( Footer, SizeOf(Footer) );
if FZipfileComment <> '' then
Stream.Write( FZipfileComment[1], Length(FZipfileComment) );
end;
{ -------------------------------------------------------------------------- }
{ TAbZipItem implementation ================================================ }
constructor TAbZipItem.Create;
begin
inherited Create;
FItemInfo := TAbZipDirectoryFileHeader.Create;
FLFHExtraField := TAbExtraField.Create;
end;
{ -------------------------------------------------------------------------- }
destructor TAbZipItem.Destroy;
begin
FLFHExtraField.Free;
FItemInfo.Free;
FItemInfo := nil;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetCompressionMethod : TAbZipCompressionMethod;
begin
Result := FItemInfo.CompressionMethod;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetCompressionRatio : Double;
begin
Result := FItemInfo.CompressionRatio;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetCRC32 : Longint;
begin
Result := FItemInfo.CRC32;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetDeflationOption : TAbZipDeflationOption;
begin
Result := FItemInfo.DeflationOption;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetDictionarySize : TAbZipDictionarySize;
begin
Result := FItemInfo.DictionarySize;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetGeneralPurposeBitFlag : Word;
begin
Result := FItemInfo.GeneralPurposeBitFlag;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetHostOS: TAbZipHostOS;
begin
Result := TAbZipHostOS(Hi(VersionMadeBy));
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetExternalFileAttributes : LongWord;
begin
Result := FItemInfo.ExternalFileAttributes;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetExtraField : TAbExtraField;
begin
Result := FItemInfo.ExtraField;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetFileComment : AnsiString;
begin
Result := FItemInfo.FileComment;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetInternalFileAttributes : Word;
begin
Result := FItemInfo.InternalFileAttributes;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetIsDirectory: Boolean;
begin
Result := ((ExternalFileAttributes and faDirectory) <> 0) or
((FileName <> '') and CharInSet(Filename[Length(FFilename)], ['\','/']));
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetIsEncrypted : Boolean;
begin
Result := FItemInfo.IsEncrypted;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetLastModFileDate : Word;
begin
Result := FItemInfo.LastModFileDate;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetLastModFileTime : Word;
begin
Result := FItemInfo.LastModFileTime;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetNativeFileAttributes : LongInt;
begin
{$IFDEF MSWINDOWS}
if (HostOS = hosUnix) or (ExternalFileAttributes > $1FFFF) then
Result := AbUnix2DosFileAttributes(ExternalFileAttributes shr 16)
else
Result := Byte(ExternalFileAttributes);
{$ENDIF}
{$IFDEF UNIX}
if HostOS in [hosDOS, hosNTFS, hosWinNT] then
Result := AbDOS2UnixFileAttributes(ExternalFileAttributes)
else
Result := ExternalFileAttributes shr 16;
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetRawFileName : AnsiString;
begin
Result := FItemInfo.FileName;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetShannonFanoTreeCount : Byte;
begin
Result := FItemInfo.ShannonFanoTreeCount;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetVersionMadeBy : Word;
begin
Result := FItemInfo.VersionMadeBy;
end;
{ -------------------------------------------------------------------------- }
function TAbZipItem.GetVersionNeededToExtract : Word;
begin
Result := FItemInfo.VersionNeededToExtract;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.LoadFromStream( Stream : TStream );
var
FieldSize: Word;
FieldStream: TStream;
InfoZipField: PInfoZipUnicodePathRec;
UnicodeName: UnicodeString;
UTF8Name: AnsiString;
XceedField: PXceedUnicodePathRec;
begin
FItemInfo.LoadFromStream( Stream );
{ decode filename (ANSI/OEM/UTF-8) }
if FItemInfo.IsUTF8 or (AbDetectCharSet(FItemInfo.FileName) = csUTF8) then
FFileName := UTF8ToString(FItemInfo.FileName)
else if FItemInfo.ExtraField.Get(Ab_InfoZipUnicodePathSubfieldID, Pointer(InfoZipField), FieldSize) and
(FieldSize > SizeOf(TInfoZipUnicodePathRec)) and
(InfoZipField.Version = 1) and
(InfoZipField.NameCRC32 = AbCRC32Of(FItemInfo.FileName)) then begin
SetString(UTF8Name, InfoZipField.UnicodeName,
FieldSize - SizeOf(TInfoZipUnicodePathRec) + 1);
FFileName := UTF8ToString(UTF8Name);
end
else if FItemInfo.ExtraField.Get(Ab_XceedUnicodePathSubfieldID, Pointer(XceedField), FieldSize) and
(FieldSize > SizeOf(TXceedUnicodePathRec)) and
(XceedField.Signature = Ab_XceedUnicodePathSignature) and
(XceedField.Length * SizeOf(WideChar) = FieldSize - SizeOf(TXceedUnicodePathRec) + SizeOf(WideChar)) then begin
SetString(UnicodeName, XceedField.UnicodeName, XceedField.Length);
FFileName := string(UnicodeName);
end
{$IFDEF MSWINDOWS}
else if (GetACP <> GetOEMCP) and ((HostOS = hosDOS) or AbIsOEM(FItemInfo.FileName)) then begin
SetLength(FFileName, Length(FItemInfo.FileName));
OemToCharBuff(PAnsiChar(FItemInfo.FileName), PChar(FFileName), Length(FFileName));
end
{$ENDIF}
else
FFileName := string(FItemInfo.FileName);
{ read ZIP64 extended header }
FUncompressedSize := FItemInfo.UncompressedSize;
FCompressedSize := FItemInfo.CompressedSize;
FRelativeOffset := FItemInfo.RelativeOffset;
FDiskNumberStart := FItemInfo.DiskNumberStart;
if FItemInfo.ExtraField.GetStream(Ab_Zip64SubfieldID, FieldStream) then
try
if FItemInfo.UncompressedSize = $FFFFFFFF then
FieldStream.ReadBuffer(FUncompressedSize, SizeOf(Int64));
if FItemInfo.CompressedSize = $FFFFFFFF then
FieldStream.ReadBuffer(FCompressedSize, SizeOf(Int64));
if FItemInfo.RelativeOffset = $FFFFFFFF then
FieldStream.ReadBuffer(FRelativeOffset, SizeOf(Int64));
if FItemInfo.DiskNumberStart = $FFFF then
FieldStream.ReadBuffer(FDiskNumberStart, SizeOf(LongWord));
finally
FieldStream.Free;
end;
LastModFileTime := FItemInfo.LastModFileTime;
LastModFileDate := FItemInfo.LastModFileDate;
FDiskFileName := FileName;
AbUnfixName( FDiskFileName );
Action := aaNone;
Tagged := False;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SaveLFHToStream( Stream : TStream );
var
LFH : TAbZipLocalFileHeader;
Zip64Field: TZip64LocalHeaderRec;
begin
LFH := TAbZipLocalFileHeader.Create;
try
LFH.VersionNeededToExtract := VersionNeededToExtract;
LFH.GeneralPurposeBitFlag := GeneralPurposeBitFlag;
LFH.CompressionMethod := CompressionMethod;
LFH.LastModFileTime := LastModFileTime;
LFH.LastModFileDate := LastModFileDate;
LFH.CRC32 := CRC32;
LFH.FileName := RawFileName;
LFH.ExtraField.Assign(LFHExtraField);
LFH.ExtraField.CloneFrom(ExtraField, Ab_InfoZipUnicodePathSubfieldID);
LFH.ExtraField.CloneFrom(ExtraField, Ab_XceedUnicodePathSubfieldID);
{ setup sizes; unlike the central directory header, the ZIP64 local header
needs to store both compressed and uncompressed sizes if either needs it }
if (CompressedSize >= $FFFFFFFF) or (UncompressedSize >= $FFFFFFFF) then begin
LFH.UncompressedSize := $FFFFFFFF;
LFH.CompressedSize := $FFFFFFFF;
Zip64Field.UncompressedSize := UncompressedSize;
Zip64Field.CompressedSize := CompressedSize;
LFH.ExtraField.Put(Ab_Zip64SubfieldID, Zip64Field, SizeOf(Zip64Field));
end
else begin
LFH.UncompressedSize := UncompressedSize;
LFH.CompressedSize := CompressedSize;
LFH.ExtraField.Delete(Ab_Zip64SubfieldID);
end;
LFH.SaveToStream( Stream );
finally
LFH.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SaveCDHToStream( Stream : TStream );
{-Save a ZipCentralDirectorHeader entry to Stream}
begin
FItemInfo.SaveToStream( Stream );
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SaveDDToStream( Stream : TStream );
var
DD : TAbZipDataDescriptor;
begin
DD := TAbZipDataDescriptor.Create;
try
DD.CRC32 := CRC32;
DD.CompressedSize := CompressedSize;
DD.UncompressedSize := UncompressedSize;
DD.SaveToStream( Stream );
finally
DD.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetCompressedSize( const Value : Int64 );
begin
FCompressedSize := Value;
FItemInfo.CompressedSize := Min(Value, $FFFFFFFF);
UpdateZip64ExtraHeader;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetCompressionMethod( Value : TAbZipCompressionMethod );
begin
FItemInfo.CompressionMethod := Value;
UpdateVersionNeededToExtract;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetCRC32( const Value : Longint );
begin
FItemInfo.CRC32 := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetDiskNumberStart( Value : LongWord );
begin
FDiskNumberStart := Value;
FItemInfo.DiskNumberStart := Min(Value, $FFFF);
UpdateZip64ExtraHeader;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetExternalFileAttributes( Value : LongWord );
begin
FItemInfo.ExternalFileAttributes := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetFileComment(const Value : AnsiString );
begin
FItemInfo.FileComment := Value;
end;
{ -------------------------------------------------------------------------- }
{$IFDEF KYLIX}{$IFOPT O+}{$DEFINE OPTIMIZATIONS_ON}{$O-}{$ENDIF}{$ENDIF}
procedure TAbZipItem.SetFileName(const Value : string );
var
{$IFDEF MSWINDOWS}
AnsiName : AnsiString;
{$ENDIF}
UTF8Name : AnsiString;
FieldSize : Word;
I : Integer;
InfoZipField : PInfoZipUnicodePathRec;
UseExtraField: Boolean;
begin
inherited SetFileName(Value);
{$IFDEF MSWINDOWS}
FItemInfo.IsUTF8 := False;
HostOS := hosDOS;
if AbTryEncode(Value, CP_OEMCP, False, AnsiName) then
{no-op}
else if (GetACP <> GetOEMCP) and AbTryEncode(Value, CP_ACP, False, AnsiName) then
HostOS := hosWinNT
else if AbTryEncode(Value, CP_OEMCP, True, AnsiName) then
{no-op}
else if (GetACP <> GetOEMCP) and AbTryEncode(Value, CP_ACP, True, AnsiName) then
HostOS := hosWinNT
else
FItemInfo.IsUTF8 := True;
if FItemInfo.IsUTF8 then
FItemInfo.FileName := Utf8Encode(Value)
else
FItemInfo.FileName := AnsiName;
{$ENDIF}
{$IFDEF UNIX}
FItemInfo.FileName := AnsiString(Value);
FItemInfo.IsUTF8 := AbSysCharSetIsUTF8;
{$ENDIF}
UseExtraField := False;
if not FItemInfo.IsUTF8 then
for i := 1 to Length(Value) do begin
if Ord(Value[i]) > 127 then begin
UseExtraField := True;
Break;
end;
end;
if UseExtraField then begin
UTF8Name := AnsiToUTF8(Value);
FieldSize := SizeOf(TInfoZipUnicodePathRec) + Length(UTF8Name) - 1;
GetMem(InfoZipField, FieldSize);
try
InfoZipField.Version := 1;
InfoZipField.NameCRC32 := AbCRC32Of(FItemInfo.FileName);
Move(UTF8Name[1], InfoZipField.UnicodeName, Length(UTF8Name));
FItemInfo.ExtraField.Put(Ab_InfoZipUnicodePathSubfieldID, InfoZipField^, FieldSize);
finally
FreeMem(InfoZipField);
end;
end
else
FItemInfo.ExtraField.Delete(Ab_InfoZipUnicodePathSubfieldID);
FItemInfo.ExtraField.Delete(Ab_XceedUnicodePathSubfieldID);
end;
{$IFDEF OPTIMIZATIONS_ON}{$O+}{$ENDIF}
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetGeneralPurposeBitFlag( Value : Word );
begin
FItemInfo.GeneralPurposeBitFlag := Value;
UpdateVersionNeededToExtract;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetHostOS( Value : TAbZipHostOS );
begin
FItemInfo.VersionMadeBy := Low(FItemInfo.VersionMadeBy) or
Word(Ord(Value)) shl 8;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetInternalFileAttributes( Value : Word );
begin
FItemInfo.InternalFileAttributes := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetLastModFileDate( const Value : Word );
begin
FItemInfo.LastModFileDate := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetLastModFileTime( const Value : Word );
begin
FItemInfo.LastModFileTime := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetRelativeOffset( Value : Int64 );
begin
FRelativeOffset := Value;
FItemInfo.RelativeOffset := Min(Value, $FFFFFFFF);
UpdateZip64ExtraHeader;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetUncompressedSize( const Value : Int64 );
begin
FUncompressedSize := Value;
FItemInfo.UncompressedSize:= Min(Value, $FFFFFFFF);
UpdateZip64ExtraHeader;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetVersionMadeBy( Value : Word );
begin
FItemInfo.VersionMadeBy := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.SetVersionNeededToExtract( Value : Word );
begin
FItemInfo.VersionNeededToExtract := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.UpdateVersionNeededToExtract;
{calculates VersionNeededToExtract and VersionMadeBy based on used features}
begin
{According to AppNote.txt zipx compression methods should set the Version
Needed To Extract to the AppNote version the method was introduced in (e.g.,
6.3 for PPMd). Most utilities just set it to 2.0 and rely on the extractor
detecting unsupported compression methods, since it's easier to add support
for decompression methods without implementing the entire newer spec. }
if ExtraField.Has(Ab_Zip64SubfieldID) then
VersionNeededToExtract := 45
else if IsDirectory or IsEncrypted or not (CompressionMethod in [cmStored..cmImploded]) then
VersionNeededToExtract := 20
else
VersionNeededToExtract := 10;
VersionMadeBy := (VersionMadeBy and $FF00) + Max(20, VersionNeededToExtract);
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipItem.UpdateZip64ExtraHeader;
var
Changed: Boolean;
FieldStream: TMemoryStream;
begin
FieldStream := TMemoryStream.Create;
try
if UncompressedSize >= $FFFFFFFF then
FieldStream.WriteBuffer(FUncompressedSize, SizeOf(Int64));
if CompressedSize >= $FFFFFFFF then
FieldStream.WriteBuffer(FCompressedSize, SizeOf(Int64));
if RelativeOffset >= $FFFFFFFF then
FieldStream.WriteBuffer(FRelativeOffset, SizeOf(Int64));
if DiskNumberStart >= $FFFF then
FieldStream.WriteBuffer(FDiskNumberStart, SizeOf(LongWord));
Changed := (FieldStream.Size > 0) <> ExtraField.Has(Ab_Zip64SubfieldID);
if FieldStream.Size > 0 then
ExtraField.Put(Ab_Zip64SubfieldID, FieldStream.Memory^, FieldStream.Size)
else
ExtraField.Delete(Ab_Zip64SubfieldID);
if Changed then
UpdateVersionNeededToExtract;
finally
FieldStream.Free;
end;
end;
{ -------------------------------------------------------------------------- }
{ TAbZipArchive implementation ============================================= }
constructor TAbZipArchive.CreateFromStream( aStream : TStream;
const ArchiveName : string );
begin
inherited CreateFromStream( aStream, ArchiveName );
FCompressionMethodToUse := smBestMethod;
FInfo := TAbZipDirectoryFileFooter.Create;
StoreOptions := StoreOptions + [soStripDrive];
FDeflationOption := doNormal;
FPasswordRetries := AbDefPasswordRetries;
FTempDir := '';
SpanningThreshold := AbDefZipSpanningThreshold;
end;
{ -------------------------------------------------------------------------- }
destructor TAbZipArchive.Destroy;
begin
FInfo.Free;
FInfo := nil;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
function TAbZipArchive.CreateItem( const FileName : string ): TAbArchiveItem;
var
FileSpec : string;
begin
FileSpec := FileName;
Result := TAbZipItem.Create;
with TAbZipItem( Result ) do begin
CompressionMethod := cmDeflated;
GeneralPurposeBitFlag := 0;
CompressedSize := 0;
CRC32 := 0;
DiskFileName := ExpandFileName(FileSpec);
FileName := FixName(FileSpec);
RelativeOffset := 0;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.DoExtractHelper(Index : Integer; const NewName : string);
begin
if Assigned(FExtractHelper) then
FExtractHelper(Self, ItemList[Index], NewName)
else
raise EAbZipNoExtraction.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.DoExtractToStreamHelper(Index : Integer;
aStream : TStream);
begin
if Assigned(FExtractToStreamHelper) then
FExtractToStreamHelper(Self, ItemList[Index], aStream)
else
raise EAbZipNoExtraction.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.DoTestHelper(Index : Integer);
begin
if Assigned(FTestHelper) then
FTestHelper(Self, ItemList[Index])
else
raise EAbZipNoExtraction.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.DoInsertHelper(Index : Integer; OutStream : TStream);
begin
if Assigned(FInsertHelper) then
FInsertHelper(Self, ItemList[Index], OutStream)
else
raise EAbZipNoInsertion.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.DoInsertFromStreamHelper(Index : Integer;
OutStream : TStream);
begin
if Assigned(FInsertFromStreamHelper) then
FInsertFromStreamHelper(Self, ItemList[Index], OutStream, InStream)
else
raise EAbZipNoInsertion.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.DoRequestDisk(const AMessage: string; var Abort : Boolean);
begin
{$IFDEF MSWINDOWS}
Abort := Windows.MessageBox( 0, PChar(AMessage), PChar(AbDiskRequestS),
MB_TASKMODAL or MB_OKCANCEL ) = IDCANCEL;
{$ENDIF}
{$IFDEF UnixDialogs}
{$IFDEF KYLIX}
Abort := QDialogs.MessageDlg(AbDiskRequestS, AMessage, mtWarning,
mbOKCancel, 0) = mrCancel;
{$ENDIF}
{$IFDEF LCL}
Abort := Dialogs.MessageDlg(AbDiskRequestS, AMessage, mtWarning, mbOKCancel,
0) = mrCancel;
{$ENDIF}
{$ELSE}
Abort := True;
{$ENDIF}
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.DoRequestLastDisk( var Abort : Boolean );
begin
Abort := False;
if Assigned( FOnRequestLastDisk ) then
FOnRequestLastDisk( Self, Abort )
else
DoRequestDisk( AbLastDiskRequestS, Abort );
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.DoRequestNthDisk( Sender: TObject;
DiskNumber : Byte;
var Abort : Boolean );
begin
Abort := False;
if Assigned( FOnRequestNthDisk ) then
FOnRequestNthDisk( Self, DiskNumber, Abort )
else
DoRequestDisk( Format(AbDiskNumRequestS, [DiskNumber]), Abort );
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.DoRequestBlankDisk(Sender: TObject; var Abort : Boolean );
begin
Abort := False;
FSpanned := True;
if Assigned( FOnRequestBlankDisk ) then
FOnRequestBlankDisk( Self, Abort )
else
DoRequestDisk( AbBlankDiskS, Abort );
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.DoRequestImage(Sender: TObject; ImageNumber : Integer;
var ImageName : string ; var Abort : Boolean);
begin
if Assigned(FOnRequestImage) then
FOnRequestImage(Self, ImageNumber, ImageName, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.ExtractItemAt(Index : Integer; const UseName : string);
begin
DoExtractHelper(Index, UseName);
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.ExtractItemToStreamAt(Index : Integer;
aStream : TStream);
begin
DoExtractToStreamHelper(Index, aStream);
end;
{ -------------------------------------------------------------------------- }
function TAbZipArchive.FixName(const Value : string ) : string;
{-changes backslashes to forward slashes}
var
i : SmallInt;
lValue : string;
begin
lValue := Value;
{$IFDEF MSWINDOWS}
if DOSMode then begin
{Add the base directory to the filename before converting }
{the file spec to the short filespec format. }
if BaseDirectory <> '' then begin
{Does the filename contain a drive or a leading backslash? }
if not ((Pos(':', lValue) = 2) or (Pos(AbPathDelim, lValue) = 1)) then
{If not, add the BaseDirectory to the filename.}
lValue := AbAddBackSlash(BaseDirectory) + lValue;
end;
lValue := AbGetShortFileSpec( lValue );
end;
{$ENDIF MSWINDOWS}
{Zip files Always strip the drive path}
StoreOptions := StoreOptions + [soStripDrive];
{strip drive stuff}
if soStripDrive in StoreOptions then
AbStripDrive( lValue );
{check for a leading backslash}
if (Length(lValue) > 1) and (lValue[1] = AbPathDelim) then
System.Delete( lValue, 1, 1 );
if soStripPath in StoreOptions then begin
lValue := ExtractFileName( lValue );
end;
if soRemoveDots in StoreOptions then
AbStripDots( lValue );
for i := 1 to Length( lValue ) do
if lValue[i] = '\' then
lValue[i] := '/';
Result := lValue;
end;
{ -------------------------------------------------------------------------- }
function TAbZipArchive.GetItem( Index : Integer ) : TAbZipItem;
begin
Result := TAbZipItem(FItemList.Items[Index]);
end;
{ -------------------------------------------------------------------------- }
function TAbZipArchive.GetSupportsEmptyFolders: Boolean;
begin
Result := True;
end;
{ -------------------------------------------------------------------------- }
function TAbZipArchive.GetZipfileComment : AnsiString;
begin
Result := FInfo.ZipfileComment;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.LoadArchive;
var
Abort : Boolean;
TailPosition : int64;
Item : TAbZipItem;
Progress : Byte;
FileSignature : Longint;
Zip64Locator : TAbZip64EndOfCentralDirectoryLocator;
begin
Abort := False;
if FStream.Size = 0 then
Exit;
{Get signature info}
FStream.Position := 0;
FStream.Read( FileSignature, sizeof( FileSignature ) );
{Get Executable Type; allow non-native stubs}
IsExecutable :=
(LongRec(FileSignature).Lo = Ab_WindowsExeSignature) or
(FileSignature = Ab_LinuxExeSignature);
{ try to locate central directory tail }
TailPosition := FindCentralDirectoryTail( FStream );
if (TailPosition = -1) and (FileSignature = Ab_ZipSpannedSetSignature) and
FOwnsStream and AbDriveIsRemovable(ArchiveName) then begin
while TailPosition = -1 do begin
FreeAndNil(FStream);
DoRequestLastDisk(Abort);
if Abort then begin
FStatus := asInvalid; //TODO: Status updates are extremely inconsistent
raise EAbUserAbort.Create;
end;
FStream := TFileStream.Create( ArchiveName, Mode );
TailPosition := FindCentralDirectoryTail( FStream );
end;
end;
if TailPosition = -1 then begin
FStatus := asInvalid;
raise EAbZipInvalid.Create;
end;
{ load the ZipDirectoryFileFooter }
FInfo.LoadFromStream(FStream);
{ find Zip64 end of central directory locator; it will usually occur
immediately before the standard end of central directory record.
the actual Zip64 end of central directory may be on another disk }
if FInfo.IsZip64 then begin
Dec(TailPosition, SizeOf(Zip64Locator));
repeat
if TailPosition < 0 then
raise EAbZipInvalid.Create;
FStream.Position := TailPosition;
FStream.ReadBuffer(Zip64Locator, SizeOf(Zip64Locator));
Dec(TailPosition);
until Zip64Locator.Signature = Ab_Zip64EndCentralDirectoryLocatorSignature;
{ update current image number }
FInfo.DiskNumber := Zip64Locator.TotalDisks - 1;
end;
{ setup spanning support and move to the start of the central directory }
FSpanned := FInfo.DiskNumber > 0;
if FSpanned then begin
if FOwnsStream then begin
FStream := TAbSpanReadStream.Create( ArchiveName, FInfo.DiskNumber, FStream );
TAbSpanReadStream(FStream).OnRequestImage := DoRequestImage;
TAbSpanReadStream(FStream).OnRequestNthDisk := DoRequestNthDisk;
if FInfo.IsZip64 then begin
TAbSpanReadStream(FStream).SeekImage(Zip64Locator.StartDiskNumber,
Zip64Locator.RelativeOffset);
FInfo.LoadZip64FromStream(FStream);
end;
TAbSpanReadStream(FStream).SeekImage(FInfo.StartDiskNumber, FInfo.DirectoryOffset);
end
else
raise EAbZipBadSpanStream.Create;
end
else begin
if FInfo.IsZip64 then begin
FStream.Position := Zip64Locator.RelativeOffset;
FInfo.LoadZip64FromStream(FStream);
end;
FStream.Position := FInfo.DirectoryOffset;
end;
{ build Items list from central directory records }
FStubSize := High(LongWord);
while Count < FInfo.TotalEntries do begin
{ create new Item }
Item := TAbZipItem.Create;
try
Item.LoadFromStream(FStream);
Item.Action := aaNone;
FItemList.Add(Item);
except
Item.Free;
raise;
end;
if IsExecutable and (Item.DiskNumberStart = 0) and
(Item.RelativeOffset < FStubSize) then
FStubSize := Item.RelativeOffset;
Progress := (Count * 100) div FInfo.TotalEntries;
DoArchiveProgress( Progress, Abort );
if Abort then begin
FStatus := asInvalid;
raise EAbUserAbort.Create;
end;
end;
DoArchiveProgress(100, Abort);
FIsDirty := False;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.PutItem( Index : Integer; Value : TAbZipItem );
begin
FItemList.Items[Index] := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.SaveArchive;
{builds a new archive and copies it to FStream}
var
Abort : Boolean;
MemStream : TMemoryStream;
HasDataDescriptor : Boolean;
i : LongWord;
LFH : TAbZipLocalFileHeader;
NewStream : TStream;
WorkingStream : TAbVirtualMemoryStream;
CurrItem : TAbZipItem;
Progress : Byte;
begin
if Count = 0 then
Exit;
{shouldn't be trying to overwrite an existing spanned archive}
if Spanned then begin
for i := 0 to Pred(Count) do
if ItemList[i].Action <> aaFailed then
ItemList[i].Action := aaNone;
FIsDirty := False;
raise EAbZipSpanOverwrite.Create;
end;
{init new zip archive stream
can span only new archives, if SpanningThreshold > 0 or removable drive
spanning writes to original location, rather than writing to a temp stream first}
if FOwnsStream and (FStream.Size = 0) and not IsExecutable and
((SpanningThreshold > 0) or AbDriveIsRemovable(ArchiveName)) then begin
NewStream := TAbSpanWriteStream.Create(ArchiveName, FStream, SpanningThreshold);
FStream := nil;
TAbSpanWriteStream(NewStream).OnRequestBlankDisk := DoRequestBlankDisk;
TAbSpanWriteStream(NewStream).OnRequestImage := DoRequestImage;
end
else begin
NewStream := TAbVirtualMemoryStream.Create;
TAbVirtualMemoryStream(NewStream).SwapFileDirectory := FTempDir;
end;
try {NewStream}
{copy the executable stub over to the output}
if IsExecutable then
NewStream.CopyFrom( FStream, StubSize )
{assume spanned for spanning stream}
else if NewStream is TAbSpanWriteStream then
NewStream.Write(Ab_ZipSpannedSetSignature,
SizeOf(Ab_ZipSpannedSetSignature));
{build new zip archive from existing archive}
for i := 0 to pred( Count ) do begin
CurrItem := (ItemList[i] as TAbZipItem);
FCurrentItem := ItemList[i];
case CurrItem.Action of
aaNone, aaMove: begin
{just copy the file to new stream}
Assert(not (NewStream is TAbSpanWriteStream));
FStream.Position := CurrItem.RelativeOffset;
CurrItem.DiskNumberStart := 0;
CurrItem.RelativeOffset := NewStream.Position;
{toss old local file header}
LFH := TAbZipLocalFileHeader.Create;
try {LFH}
LFH.LoadFromStream( FStream );
if CurrItem.LFHExtraField.Count = 0 then
CurrItem.LFHExtraField.Assign(LFH.ExtraField);
finally {LFH}
LFH.Free;
end; {LFH}
{write out new local file header and append compressed data}
CurrItem.SaveLFHToStream( NewStream );
if (CurrItem.CompressedSize > 0) then
NewStream.CopyFrom(FStream, CurrItem.CompressedSize);
end;
aaDelete: begin
{doing nothing omits file from new stream}
end;
aaAdd, aaFreshen, aaReplace, aaStreamAdd: begin
{compress the file and add it to new stream}
try
WorkingStream := TAbVirtualMemoryStream.Create;
try {WorkingStream}
WorkingStream.SwapFileDirectory := FTempDir;
{compress the file}
if (CurrItem.Action = aaStreamAdd) then
DoInsertFromStreamHelper(i, WorkingStream)
else
DoInsertHelper(i, WorkingStream);
{write local header}
if NewStream is TAbSpanWriteStream then begin
MemStream := TMemoryStream.Create;
try
CurrItem.SaveLFHToStream(MemStream);
TAbSpanWriteStream(NewStream).WriteUnspanned(
MemStream.Memory^, MemStream.Size);
{calculate positions after the write in case it triggered a new span}
CurrItem.DiskNumberStart := TAbSpanWriteStream(NewStream).CurrentImage;
CurrItem.RelativeOffset := NewStream.Position - MemStream.Size;
finally
MemStream.Free;
end;
end
else begin
CurrItem.DiskNumberStart := 0;
CurrItem.RelativeOffset := NewStream.Position;
CurrItem.SaveLFHToStream(NewStream);
end;
{copy compressed data}
NewStream.CopyFrom(WorkingStream, 0);
if CurrItem.IsEncrypted then
CurrItem.SaveDDToStream(NewStream);
finally
WorkingStream.Free;
end;
except
on E : Exception do
begin
{ Exception was caused by a User Abort and Item Failure should not be called
Question: Do we want an New Event when this occurs or should the
exception just be re-raised [783614] }
if (E is EAbUserAbort) then
raise;
CurrItem.Action := aaDelete;
DoProcessItemFailure(CurrItem, ptAdd, ecFileOpenError, 0);
end;
end;
end;
end; { case }
{ TODO: Check HasDataDescriptior behavior; seems like it's getting
written twice for encrypted files }
{Now add the data descriptor record to new stream}
HasDataDescriptor := (CurrItem.CompressionMethod = cmDeflated) and
((CurrItem.GeneralPurposeBitFlag and AbHasDataDescriptorFlag) <> 0);
if (CurrItem.Action <> aaDelete) and HasDataDescriptor then
CurrItem.SaveDDToStream(NewStream);
Progress := AbPercentage(9 * succ( i ), 10 * Count);
DoArchiveSaveProgress(Progress, Abort);
DoArchiveProgress(Progress, Abort);
if Abort then
raise EAbUserAbort.Create;
end;
{write the central directory}
if NewStream is TAbSpanWriteStream then
FInfo.DiskNumber := TAbSpanWriteStream(NewStream).CurrentImage
else
FInfo.DiskNumber := 0;
FInfo.StartDiskNumber := FInfo.DiskNumber;
FInfo.DirectoryOffset := NewStream.Position;
FInfo.DirectorySize := 0;
FInfo.EntriesOnDisk := 0;
FInfo.TotalEntries := 0;
MemStream := TMemoryStream.Create;
try
{write central directory entries}
for i := 0 to Count - 1 do begin
if not (FItemList[i].Action in [aaDelete, aaFailed]) then begin
(FItemList[i] as TAbZipItem).SaveCDHToStream(MemStream);
if NewStream is TAbSpanWriteStream then begin
TAbSpanWriteStream(NewStream).WriteUnspanned(MemStream.Memory^, MemStream.Size);
{update tail info on span change}
if FInfo.DiskNumber <> TAbSpanWriteStream(NewStream).CurrentImage then begin
FInfo.DiskNumber := TAbSpanWriteStream(NewStream).CurrentImage;
FInfo.EntriesOnDisk := 0;
if FInfo.TotalEntries = 0 then begin
FInfo.StartDiskNumber := FInfo.DiskNumber;
FInfo.DirectoryOffset := NewStream.Position - MemStream.Size;
end;
end;
end
else
NewStream.WriteBuffer(MemStream.Memory^, MemStream.Size);
FInfo.DirectorySize := FInfo.DirectorySize + MemStream.Size;
FInfo.EntriesOnDisk := FInfo.EntriesOnDisk + 1;
FInfo.TotalEntries := FInfo.TotalEntries + 1;
MemStream.Clear;
end;
end;
{append the central directory footer}
FInfo.SaveToStream(MemStream, NewStream.Position);
if NewStream is TAbSpanWriteStream then begin
{update the footer if writing it would trigger a new span}
if not TAbSpanWriteStream(NewStream).WriteUnspanned(MemStream.Memory^,
MemStream.Size) then begin
FInfo.DiskNumber := TAbSpanWriteStream(NewStream).CurrentImage;
FInfo.EntriesOnDisk := 0;
FInfo.SaveToStream(NewStream);
end;
end
else
NewStream.WriteBuffer(MemStream.Memory^, MemStream.Size);
finally {MemStream}
MemStream.Free;
end; {MemStream}
FSpanned := (FInfo.DiskNumber > 0);
{update output stream}
if NewStream is TAbSpanWriteStream then begin
{zip has already been written to target location}
FStream := TAbSpanWriteStream(NewStream).ReleaseStream;
if Spanned then begin
{switch to read stream}
FStream := TAbSpanReadStream.Create(ArchiveName, FInfo.DiskNumber, FStream);
TAbSpanReadStream(FStream).OnRequestImage := DoRequestImage;
TAbSpanReadStream(FStream).OnRequestNthDisk := DoRequestNthDisk;
end
else begin
{replace spanned signature}
FStream.Position := 0;
FStream.Write(Ab_ZipPossiblySpannedSignature,
SizeOf(Ab_ZipPossiblySpannedSignature));
end;
end
else begin
{copy new stream to FStream (non-spanned only)}
NewStream.Position := 0;
if (FStream is TMemoryStream) then
TMemoryStream(FStream).LoadFromStream(NewStream)
else begin
if FOwnsStream then begin
{need new stream to write}
FreeAndNil(FStream);
FStream := TFileStream.Create(FArchiveName,
fmOpenReadWrite or fmShareDenyWrite);
end;
FStream.Size := 0;
FStream.Position := 0;
FStream.CopyFrom(NewStream, 0)
end;
end;
{update Items list}
for i := pred( Count ) downto 0 do begin
if FItemList[i].Action = aaDelete then
FItemList.Delete( i )
else if FItemList[i].Action <> aaFailed then
FItemList[i].Action := aaNone;
end;
DoArchiveSaveProgress( 100, Abort );
DoArchiveProgress( 100, Abort );
finally {NewStream}
NewStream.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.SetZipfileComment(const Value : AnsiString );
begin
FInfo.FZipfileComment := Value;
FIsDirty := True;
end;
{ -------------------------------------------------------------------------- }
procedure TAbZipArchive.TestItemAt(Index : Integer);
begin
DoTestHelper(Index);
end;
end.
================================================
FILE: lib/abbrevia/source/AbZipper.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbZipper.pas *}
{*********************************************************}
{* ABBREVIA: Non-visual Component with Zip support *}
{*********************************************************}
unit AbZipper;
{$I AbDefine.inc}
interface
uses
Classes,
AbBrowse, AbZBrows, AbArcTyp, AbZipTyp;
type
TAbCustomZipper = class(TAbCustomZipBrowser)
protected {private}
FAutoSave : Boolean;
FCompressionMethodToUse : TAbZipSupportedMethod;
FDeflationOption : TAbZipDeflationOption;
FDOSMode : Boolean;
FOnConfirmSave : TAbArchiveConfirmEvent;
FOnSave : TAbArchiveEvent;
FOnArchiveSaveProgress : TAbArchiveProgressEvent;
FArchiveSaveProgressMeter : IAbProgressMeter;
FStoreOptions : TAbStoreOptions;
protected {methods}
procedure DoConfirmSave(Sender : TObject; var Confirm : Boolean);
virtual;
procedure DoSave(Sender : TObject);
virtual;
procedure DoArchiveSaveProgress(Sender : TObject; Progress : Byte;
var Abort : Boolean);
procedure InitArchive;
override;
procedure SetAutoSave(Value : Boolean);
procedure SetCompressionMethodToUse(Value : TAbZipSupportedMethod);
procedure SetDeflationOption(Value : TAbZipDeflationOption);
procedure SetDOSMode( Value : Boolean );
procedure SetFileName(const aFileName : string);
override;
procedure SetStoreOptions( Value : TAbStoreOptions );
procedure SetArchiveSaveProgressMeter(const Value: IAbProgressMeter);
procedure SetZipfileComment(const Value : AnsiString);
override;
procedure ZipProc(Sender : TObject; Item : TAbArchiveItem;
OutStream : TStream);
procedure ZipFromStreamProc(Sender : TObject; Item : TAbArchiveItem;
OutStream, InStream : TStream );
procedure Notification(Component: TComponent;
Operation: TOperation); override;
procedure ResetMeters; override;
protected {properties}
property AutoSave : Boolean
read FAutoSave
write SetAutoSave;
property CompressionMethodToUse : TAbZipSupportedMethod
read FCompressionMethodToUse
write SetCompressionMethodToUse
default AbDefCompressionMethodToUse;
property DeflationOption : TAbZipDeflationOption
read FDeflationOption
write SetDeflationOption
default AbDefDeflationOption;
property DOSMode : Boolean
read FDOSMode
write SetDOSMode;
property StoreOptions : TAbStoreOptions
read FStoreOptions
write SetStoreOptions
default AbDefStoreOptions;
property ArchiveSaveProgressMeter : IAbProgressMeter
read FArchiveSaveProgressMeter
write SetArchiveSaveProgressMeter;
protected {events}
property OnConfirmSave : TAbArchiveConfirmEvent
read FOnConfirmSave
write FOnConfirmSave;
property OnSave : TAbArchiveEvent
read FOnSave
write FOnSave;
property OnArchiveSaveProgress : TAbArchiveProgressEvent
read FOnArchiveSaveProgress
write FOnArchiveSaveProgress;
public {methods}
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
procedure AddFiles(const FileMask : string; SearchAttr : Integer);
procedure AddFilesEx(const FileMask, ExclusionMask : string; SearchAttr : Integer);
procedure AddFromStream(const NewName : string; FromStream : TStream);
procedure DeleteAt(Index : Integer);
procedure DeleteFiles(const FileMask : string);
procedure DeleteFilesEx(const FileMask, ExclusionMask : string);
procedure DeleteTaggedItems;
procedure FreshenFiles(const FileMask : string);
procedure FreshenFilesEx(const FileMask, ExclusionMask : string);
procedure FreshenTaggedItems;
procedure Move(aItem : TAbArchiveItem; const NewStoredPath : string);
procedure Save;
procedure Replace(aItem : TAbArchiveItem);
end;
type
TAbZipper = class(TAbCustomZipper)
published
property ArchiveProgressMeter;
property ArchiveSaveProgressMeter;
property ItemProgressMeter;
property AutoSave;
property BaseDirectory;
property CompressionMethodToUse;
property DeflationOption;
property DOSMode;
property SpanningThreshold;
property LogFile;
property Logging;
property OnArchiveProgress;
property OnArchiveSaveProgress;
property OnArchiveItemProgress;
property OnChange;
property OnConfirmProcessItem;
property OnConfirmSave;
property OnLoad;
property OnProcessItemFailure;
property OnRequestBlankDisk;
property OnRequestImage;
property OnRequestLastDisk;
property OnRequestNthDisk;
property OnSave;
property Password;
property StoreOptions;
property TempDirectory;
property Version;
property FileName; {must be after OnLoad}
end;
implementation
uses
SysUtils, AbUtils, AbTarTyp, AbGzTyp, AbBzip2Typ, AbExcept, AbZipPrc;
{ -------------------------------------------------------------------------- }
constructor TAbCustomZipper.Create( AOwner : TComponent );
begin
inherited Create( AOwner );
CompressionMethodToUse := AbDefCompressionMethodToUse;
DeflationOption := AbDefDeflationOption;
StoreOptions := AbDefStoreOptions;
end;
{ -------------------------------------------------------------------------- }
destructor TAbCustomZipper.Destroy;
begin
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.AddFiles(const FileMask : string; SearchAttr : Integer);
{Add files to the archive where the disk filespec matches}
begin
if (FArchive <> nil) then
FArchive.AddFiles(FileMask, SearchAttr)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.AddFilesEx(const FileMask, ExclusionMask : string;
SearchAttr : Integer);
{Add files that match Filemask except those matching ExclusionMask}
begin
if (FArchive <> nil) then
FArchive.AddFilesEx(FileMask, ExclusionMask, SearchAttr)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.AddFromStream(const NewName : string;
FromStream : TStream);
{Add stream directly to archive}
begin
if (FArchive <> nil) then begin
FromStream.Position := 0;
FArchive.AddFromStream(NewName, FromStream);
end else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.DeleteFiles(const FileMask : string);
{delete all files from the archive that match the file mask}
begin
if (FArchive <> nil) then
FArchive.DeleteFiles( FileMask )
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.DeleteAt(Index : Integer);
{delete item at Index}
begin
if (FArchive <> nil) then
FArchive.DeleteAt( Index )
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.DeleteFilesEx(const FileMask, ExclusionMask : string);
{Delete files that match Filemask except those matching ExclusionMask}
begin
if (FArchive <> nil) then
FArchive.DeleteFilesEx(FileMask, ExclusionMask)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.DeleteTaggedItems;
{delete all tagged items from the archive}
begin
if (FArchive <> nil) then
FArchive.DeleteTaggedItems
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.DoConfirmSave(Sender : TObject; var Confirm : Boolean);
begin
Confirm := True;
if Assigned(FOnConfirmSave) then
FOnConfirmSave(Self, Confirm);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.DoSave(Sender : TObject);
begin
if Assigned(FOnSave) then
FOnSave(Self);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.FreshenFiles(const FileMask : string);
{freshen all items that match the file mask}
begin
if (FArchive <> nil) then
FArchive.FreshenFiles( FileMask )
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.FreshenFilesEx(const FileMask, ExclusionMask : string);
{freshen all items matching FileMask except those matching ExclusionMask}
begin
if (FArchive <> nil) then
FArchive.FreshenFilesEx( FileMask, ExclusionMask )
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.FreshenTaggedItems;
{freshen all tagged items}
begin
if (FArchive <> nil) then
FArchive.FreshenTaggedItems
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.InitArchive;
begin
inherited InitArchive;
if FArchive <> nil then begin
{properties}
FArchive.AutoSave := FAutoSave;
FArchive.DOSMode := FDOSMode;
FArchive.StoreOptions := FStoreOptions;
{events}
FArchive.OnArchiveSaveProgress := DoArchiveSaveProgress;
FArchive.OnConfirmSave := DoConfirmSave;
FArchive.OnSave := DoSave;
end;
if (FArchive is TAbZipArchive) then begin
{properties}
TAbZipArchive(FArchive).CompressionMethodToUse := FCompressionMethodToUse;
TAbZipArchive(FArchive).DeflationOption := FDeflationOption;
{events}
TAbZipArchive(FArchive).OnRequestBlankDisk := OnRequestBlankDisk;
TAbZipArchive(FArchive).InsertHelper := ZipProc;
TAbZipArchive(FArchive).InsertFromStreamHelper := ZipFromStreamProc;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.Move(aItem : TAbArchiveItem; const NewStoredPath : string);
{renames the item}
begin
if (FArchive <> nil) then
FArchive.Move(aItem, NewStoredPath)
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.Replace(aItem : TAbArchiveItem);
{replace the item}
begin
if (FArchive <> nil) then
FArchive.Replace( aItem )
else
raise EAbNoArchive.Create;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.Save;
begin
if (FArchive <> nil) then begin
FArchive.Save;
DoChange;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.SetAutoSave(Value : Boolean);
begin
FAutoSave := Value;
if (FArchive <> nil) then
FArchive.AutoSave := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.SetCompressionMethodToUse(
Value : TAbZipSupportedMethod);
begin
FCompressionMethodToUse := Value;
if (FArchive is TAbZipArchive) then
TAbZipArchive(FArchive).CompressionMethodToUse := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.SetDeflationOption(Value : TAbZipDeflationOption);
begin
FDeflationOption := Value;
if (FArchive is TAbZipArchive) then
TAbZipArchive(FArchive).DeflationOption := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.SetDOSMode(Value : Boolean);
begin
FDOSMode := Value;
if (FArchive <> nil) then
FArchive.DOSMode := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.SetFileName(const aFileName : string);
var
ArcType : TAbArchiveType;
begin
FFileName := aFileName;
if (csDesigning in ComponentState) then
Exit;
if Assigned(FArchive) then
begin
FArchive.Save;
FreeAndNil(FArchive);
end;
ArcType := ArchiveType;
if (FileName <> '') then
if FileExists(FileName) then begin { open it }
if not ForceType then
ArcType := AbDetermineArcType(FileName, atUnknown);
case ArcType of
atZip, atSpannedZip, atSelfExtZip : begin
FArchive := TAbZipArchive.Create(FileName, fmOpenRead or fmShareDenyNone);
InitArchive;
end;
atTar : begin
FArchive := TAbTarArchive.Create(FileName, fmOpenReadWrite or fmShareDenyNone);
inherited InitArchive;
end;
atGZip : begin
FArchive := TAbGzipArchive.Create(FileName, fmOpenReadWrite or fmShareDenyNone);
TAbGzipArchive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbGzipArchive(FArchive).IsGzippedTar := False;
inherited InitArchive;
end;
atGZippedTar : begin
FArchive := TAbGzipArchive.Create(FileName, fmOpenReadWrite or fmShareDenyNone);
TAbGzipArchive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbGzipArchive(FArchive).IsGzippedTar := True;
inherited InitArchive;
end;
atBzip2 : begin
FArchive := TAbBzip2Archive.Create(FileName, fmOpenReadWrite or fmShareDenyNone);
TAbBzip2Archive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbBzip2Archive(FArchive).IsBzippedTar := False;
inherited InitArchive;
end;
atBzippedTar : begin
FArchive := TAbBzip2Archive.Create(FileName, fmOpenReadWrite or fmShareDenyNone);
TAbBzip2Archive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbBzip2Archive(FArchive).IsBzippedTar := True;
inherited InitArchive;
end;
else
raise EAbUnhandledType.Create;
end {case};
FArchive.Load;
FArchiveType := ArcType;
end else begin { file doesn't exist, so create a new one }
if not ForceType then
ArcType := AbDetermineArcType(FileName, atUnknown);
case ArcType of
atZip : begin
FArchive := TAbZipArchive.Create(FileName, fmCreate);
InitArchive;
end;
atTar : begin
FArchive := TAbTarArchive.Create(FileName, fmCreate or fmShareDenyNone);
inherited InitArchive;
end;
atGZip : begin
FArchive := TAbGzipArchive.Create(FileName, fmCreate or fmShareDenyNone);
TAbGzipArchive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbGzipArchive(FArchive).IsGzippedTar := False;
inherited InitArchive;
end;
atGZippedTar : begin
FArchive := TAbGzipArchive.Create(FileName, fmCreate or fmShareDenyNone);
TAbGzipArchive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbGzipArchive(FArchive).IsGzippedTar := True;
inherited InitArchive;
end;
atBzip2 : begin
FArchive := TAbBzip2Archive.Create(FileName, fmCreate or fmShareDenyNone);
TAbBzip2Archive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbBzip2Archive(FArchive).IsBzippedTar := False;
inherited InitArchive;
end;
atBzippedTar : begin
FArchive := TAbBzip2Archive.Create(FileName, fmCreate or fmShareDenyNone);
TAbBzip2Archive(FArchive).TarAutoHandle := FTarAutoHandle;
TAbBzip2Archive(FArchive).IsBzippedTar := True;
inherited InitArchive;
end;
else
raise EAbUnhandledType.Create;
end {case};
FArchiveType := ArcType;
end;
DoChange;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.SetStoreOptions(Value : TAbStoreOptions);
begin
FStoreOptions := Value;
if (FArchive <> nil) then
FArchive.StoreOptions := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.SetArchiveSaveProgressMeter(const Value: IAbProgressMeter);
begin
ReferenceInterface(FArchiveSaveProgressMeter, opRemove);
FArchiveSaveProgressMeter := Value;
ReferenceInterface(FArchiveSaveProgressMeter, opInsert);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.SetZipfileComment(const Value : AnsiString);
begin
if (FArchive is TAbZipArchive) then
TAbZipArchive(FArchive).ZipfileComment := Value
else
raise EAbNoArchive.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.ZipProc(Sender : TObject; Item : TAbArchiveItem;
OutStream : TStream);
begin
AbZip(TAbZipArchive(Sender), TAbZipItem(Item), OutStream);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.ZipFromStreamProc(Sender : TObject; Item : TAbArchiveItem;
OutStream, InStream : TStream);
begin
if Assigned(InStream) then
AbZipFromStream(TAbZipArchive(Sender), TAbZipItem(Item),
OutStream, InStream)
else
raise EAbZipNoInsertion.Create;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.DoArchiveSaveProgress(Sender : TObject;
Progress : Byte;
var Abort : Boolean);
begin
Abort := False;
if Assigned(FArchiveSaveProgressMeter) then
FArchiveSaveProgressMeter.DoProgress(Progress);
if Assigned(FOnArchiveSaveProgress) then
FOnArchiveSaveProgress(Self, Progress, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.Notification(Component: TComponent;
Operation: TOperation);
begin
inherited Notification(Component, Operation);
if (Operation = opRemove) then
if Assigned(ArchiveSaveProgressMeter) and Component.IsImplementorOf(ArchiveSaveProgressMeter) then
ArchiveSaveProgressMeter := nil
end;
{ -------------------------------------------------------------------------- }
procedure TAbCustomZipper.ResetMeters;
begin
inherited ResetMeters;
if Assigned(FArchiveSaveProgressMeter) then
FArchiveSaveProgressMeter.Reset;
end;
{ -------------------------------------------------------------------------- }
end.
================================================
FILE: lib/abbrevia/source/COM/Abbrevia.dpr
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
library Abbrevia;
uses
ComServ,
_ZipKit in '_ZipKit.pas',
_ZipItem in '_ZipItem.pas',
_GZipItem in '_GZipItem.pas',
_TarItem in '_TarItem.pas',
Abbrevia_TLB in 'Abbrevia_TLB.pas';
exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer,
DllInstall;
{$R *.TLB}
{$R *.RES}
begin
end.
================================================
FILE: lib/abbrevia/source/COM/Abbrevia.dproj
================================================
{EDA07E3C-7B07-4B14-9B53-64A70EF3F00A}Abbrevia.dprTrue
Release3LibraryNone13.4Win32true
trueBasetrue
trueBasetrue
trueBasetrue
trueCfg_1truetrue
trueCfg_1truetrue
trueBasetrue
trueCfg_2truetrue
trueCfg_2truetrue
.\$(Platform)..\;$(DCC_UnitSearchPath)Nonetrue51033falseCompanyName=;FileDescription=Abbrevia COM components;FileVersion=5.0.0.0;InternalName=;LegalCopyright=Copyright (c) Abbrevia Group 2011;LegalTrademarks=;OriginalFilename=;ProductName=Abbrevia;ProductVersion=5.0;Comments=System;Xml;Data;Datasnap;Web;Soap;System.Win;Winapi;Vcl;$(DCC_Namespace)00400000falsetruefalsefalsefalseData.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=Abbrevia_Icon.ico/i:user /n Abbrevia.dllC:\Windows\System32\regsvr32.exeData.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=falsefalse0RELEASE;$(DCC_Define)CompanyName=;FileDescription=Abbrevia COM components;FileVersion=5.0;InternalName=;LegalCopyright=Copyright (c) 2011 Abbrevia Group;LegalTrademarks=;OriginalFilename=Abbrevia.dll;ProductName=Abbrevia;ProductVersion=5.0;Comments=http://tpabbrevia.sourceforge.net/CompanyName=;FileDescription=Abbrevia COM components;FileVersion=5.0;InternalName=;LegalCopyright=Copyright (c) 2011 Abbrevia Group;LegalTrademarks=;OriginalFilename=Abbrevia.dll;ProductName=Abbrevia;ProductVersion=5.0;Comments=http://tpabbrevia.sourceforge.net/DEBUG;$(DCC_Define)falsetruetruetrueCompanyName=;FileDescription=;FileVersion=5.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=MainSourceCfg_2BaseBaseCfg_1BaseDelphi.Personality.12Abbrevia.dprFalseFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0TrueFalseTrue112
================================================
FILE: lib/abbrevia/source/COM/Abbrevia.ridl
================================================
// ************************************************************************ //
// WARNING
// -------
// This file is generated by the Type Library importer or Type Libary Editor.
// Barring syntax errors, the Editor will parse modifications made to the file.
// However, when applying changes via the Editor this file will be regenerated
// and comments or formatting changes will be lost.
// ************************************************************************ //
// File generated on 12/6/2011 11:22:23 AM (- $Rev: 12980 $, 51698824).
[
uuid(AF804E20-4043-499E-BB14-237B9F26F89F),
version(3.0),
helpstring("TurboPower Abbrevia Compression Library v3.03"),
helpfile("C:\\Abbrevia\\COM\\abrv-com.hlp"),
helpcontext(0x00000001)
]
library Abbrevia
{
importlib("stdole2.tlb");
interface IZipItem;
interface IGZipItem;
interface ITarItem;
interface IZipKit;
dispinterface IZipKitEvents;
coclass ZipItem;
coclass GZipItem;
coclass TarItem;
coclass ZipKit;
[
uuid(6CABD61B-653C-4CEB-807C-C80E8DE8163D),
version(3.0)
]
enum TArchiveAction
{
aaFailed = 0,
aaNone = 1,
aaAdd = 2,
aaDelete = 3,
aaFreshen = 4,
aaMove = 5,
aaStreamAdd = 6
};
[
uuid(148F84A1-2B70-4A63-B561-FF0EE49E74B3),
version(3.0)
]
enum TArchiveStatus
{
asInvalid = 0,
asIdle = 1,
asBusy = 2
};
[
uuid(5D495174-DB09-4C59-A26D-FEBDE3EAE100),
version(3.0)
]
enum TErrorClass
{
eclAbbrevia = 0,
eclInOutError = 1,
eclFileError = 2,
eclFileCreateError = 3,
eclFileOpenError = 4,
eclOther = 5
};
[
uuid(6A4738B9-69F1-4717-8393-681FF21E8DB7),
version(3.0)
]
enum TFileAttributes
{
faReadOnly = 1,
faHidden = 2,
faSysFile = 4,
faVolumeID = 8,
faDirectory = 16,
faArchive = 32
};
[
uuid(F77BBE04-0859-4F18-9DEA-B2887C1F6AF7),
version(3.0)
]
enum TProcessType
{
ptAdd = 0,
ptDelete = 1,
ptExtract = 2,
ptFreshen = 3,
ptMove = 4,
ptReplace = 5
};
[
uuid(D78287A7-65FA-4391-8F5A-C7D3A11E9970),
version(3.0)
]
enum TStoreOptions
{
soStripDrive = 1,
soStripPath = 2,
soRemoveDots = 4,
soRecurse = 8,
soFreshen = 16,
soReplace = 32
};
[
uuid(192C6697-A38D-4F48-B32B-F33500460E62),
version(3.0)
]
enum TZipCompressionMethod
{
cmStored = 0,
cmShrunk = 1,
cmReduced1 = 2,
cmReduced2 = 3,
cmReduced3 = 4,
cmReduced4 = 5,
cmImploded = 6,
cmTokenized = 7,
cmDeflated = 8,
cmEnhancedDeflated = 9,
cmDCLImploded = 10,
cmBestMethod = 11
};
[
uuid(800F8CDC-2F0F-4020-BCBB-FEDA82D0EFEF),
version(3.0)
]
enum TZipDeflateOption
{
doInvalid = 0,
doNormal = 1,
doMaximum = 2,
doFast = 3,
doSuperFast = 4
};
[
uuid(D697ED2A-F088-409F-962A-57D8324EEDD6),
version(3.0)
]
enum TZipDictionarySize
{
dsInvalid = 0,
ds4K = 1,
ds8K = 2
};
[
uuid(B9889806-26F9-47E7-AC1F-906AA161B078),
version(3.0)
]
enum TZipExtractOptions
{
eoCreateDirs = 0,
eoRestorePath = 1
};
[
uuid(D40E0708-AE71-4A44-A6C8-430EDF760DE2),
version(3.0)
]
enum TZipSupportMethod
{
smStored = 0,
smDeflated = 1,
smBestMethod = 2
};
[
uuid(EFD2C909-BF04-4C54-9ACB-38D872B95C9F),
version(3.0)
]
enum TErrorCode
{
ecDuplicateName = 0,
ecInvalidPassword = 1,
ecNoSuchDirectory = 2,
ecUnknownCompressionMethod = 3,
ecUserAbort = 4,
ecZipBadCRC = 5,
ecZipVersionNumber = 6,
ecSpannedItemNotFound = 7
};
[
uuid(44EB05F9-CED9-46D0-84E2-BD3362977437),
version(3.0)
]
enum TArchiveType
{
atUnknown = 0,
atZip = 1,
atSelfExtZip = 2,
atTar = 3,
atGZip = 4,
atGZippedTar = 5,
atCab = 6
};
[
uuid(36568A72-3B4B-41C4-8E34-19931A8EAF63),
version(3.0)
]
enum TFileSystem
{
fsFAT = 0,
fsAmiga = 1,
fsVMS = 2,
fsUnix = 3,
fsVM_CMS = 4,
fsAtariTOS = 5,
fsHPFS = 6,
fsMacintosh = 7,
fsZSystem = 8,
fsCP_M = 9,
fsTOPS20 = 10,
fsNTFS = 11,
fsQDOS = 12,
fsAcornRISCOS = 13,
fsUnknown = 14,
fsUndefined = 15
};
[
uuid(851699A1-422A-4C65-8E08-D0499ACDD834),
version(3.0),
helpstring("Dispatch interface for ZipItem Object"),
helpcontext(0x00000005),
dual,
oleautomation
]
interface IZipItem: IDispatch
{
[propget, id(0x00000001)]
HRESULT _stdcall Action([out, retval] enum TArchiveAction* Value);
[propget, id(0x00000002)]
HRESULT _stdcall CompressedSize([out, retval] long* Value);
[propget, id(0x00000003)]
HRESULT _stdcall CRC32([out, retval] long* Value);
[propget, id(0x00000004)]
HRESULT _stdcall DiskFileName([out, retval] BSTR* Value);
[propget, id(0x00000005)]
HRESULT _stdcall DiskPath([out, retval] BSTR* Value);
[propget, id(0x00000006)]
HRESULT _stdcall ExternalFileAttributes([out, retval] enum TFileAttributes* Value);
[propput, id(0x00000006)]
HRESULT _stdcall ExternalFileAttributes([in] enum TFileAttributes Value);
[propget, id(0x00000007)]
HRESULT _stdcall FileName([out, retval] BSTR* Value);
[propput, id(0x00000007)]
HRESULT _stdcall FileName([in] BSTR Value);
[propget, id(0x00000008)]
HRESULT _stdcall IsEncrypted([out, retval] VARIANT_BOOL* Value);
[propget, id(0x00000009)]
HRESULT _stdcall LastModFileDateTime([out, retval] DATE* Value);
[propget, id(0x0000000A)]
HRESULT _stdcall StoredPath([out, retval] BSTR* Value);
[propget, id(0x0000000B)]
HRESULT _stdcall Tagged([out, retval] VARIANT_BOOL* Value);
[propput, id(0x0000000B)]
HRESULT _stdcall Tagged([in] VARIANT_BOOL Value);
[propget, id(0x0000000C)]
HRESULT _stdcall UnCompressedSize([out, retval] long* Value);
[propget, id(0x0000000D)]
HRESULT _stdcall CRC32St([out, retval] BSTR* Value);
[propget, id(0x0000000E)]
HRESULT _stdcall Password([out, retval] BSTR* Value);
[propput, id(0x0000000E)]
HRESULT _stdcall Password([in] BSTR Value);
[propget, id(0x0000000F)]
HRESULT _stdcall CompressionMethod([out, retval] enum TZipCompressionMethod* Value);
[propget, id(0x00000010)]
HRESULT _stdcall CompressionRatio([out, retval] double* Value);
[propget, id(0x00000011)]
HRESULT _stdcall DeflateOption([out, retval] enum TZipDeflateOption* Value);
[propget, id(0x00000012)]
HRESULT _stdcall DictionarySize([out, retval] enum TZipDictionarySize* Value);
[propget, id(0x00000013)]
HRESULT _stdcall DiskNumberStart([out, retval] long* Value);
[propget, id(0x00000014)]
HRESULT _stdcall ExtraField([out, retval] BSTR* Value);
[propput, id(0x00000014)]
HRESULT _stdcall ExtraField([in] BSTR Value);
[propget, id(0x00000015)]
HRESULT _stdcall FileComment([out, retval] BSTR* Value);
[propput, id(0x00000015)]
HRESULT _stdcall FileComment([in] BSTR Value);
[propget, id(0x00000016)]
HRESULT _stdcall InternalFileAttributes([out, retval] long* Value);
[propput, id(0x00000016)]
HRESULT _stdcall InternalFileAttributes([in] long Value);
[propget, id(0x00000017)]
HRESULT _stdcall VersionMadeBy([out, retval] long* Value);
[propget, id(0x00000018)]
HRESULT _stdcall VersionNeededToExtract([out, retval] long* Value);
};
[
uuid(8FA78CE0-FD29-441E-9777-93B63EF1A9EE),
version(3.0),
dual,
oleautomation
]
interface IGZipItem: IDispatch
{
[propget, id(0x00000001)]
HRESULT _stdcall Action([out, retval] enum TArchiveAction* Value);
[propget, id(0x00000002)]
HRESULT _stdcall CompressedSize([out, retval] long* Value);
[propget, id(0x00000003)]
HRESULT _stdcall CRC32([out, retval] long* Value);
[propget, id(0x00000004)]
HRESULT _stdcall DiskFileName([out, retval] BSTR* Value);
[propget, id(0x00000005)]
HRESULT _stdcall DiskPath([out, retval] BSTR* Value);
[propget, id(0x00000006)]
HRESULT _stdcall ExternalFileAttributes([out, retval] enum TFileAttributes* Value);
[propput, id(0x00000006)]
HRESULT _stdcall ExternalFileAttributes([in] enum TFileAttributes Value);
[propget, id(0x00000007)]
HRESULT _stdcall FileName([out, retval] BSTR* Value);
[propput, id(0x00000007)]
HRESULT _stdcall FileName([in] BSTR Value);
[propget, id(0x00000008)]
HRESULT _stdcall IsEncrypted([out, retval] VARIANT_BOOL* Value);
[propget, id(0x00000009)]
HRESULT _stdcall LastModFileDateTime([out, retval] DATE* Value);
[propget, id(0x0000000A)]
HRESULT _stdcall StoredPath([out, retval] BSTR* Value);
[propget, id(0x0000000B)]
HRESULT _stdcall Tagged([out, retval] VARIANT_BOOL* Value);
[propput, id(0x0000000B)]
HRESULT _stdcall Tagged([in] VARIANT_BOOL Value);
[propget, id(0x0000000C)]
HRESULT _stdcall UnCompressedSize([out, retval] long* Value);
[propget, id(0x0000000D)]
HRESULT _stdcall CRC32St([out, retval] BSTR* Value);
[propget, id(0x0000000E)]
HRESULT _stdcall Password([out, retval] BSTR* Value);
[propput, id(0x0000000E)]
HRESULT _stdcall Password([in] BSTR Value);
[propget, id(0x0000000F)]
HRESULT _stdcall CompressionMethod([out, retval] unsigned char* Value);
[propput, id(0x0000000F)]
HRESULT _stdcall CompressionMethod([in] unsigned char Value);
[propget, id(0x00000010)]
HRESULT _stdcall ExtraField([out, retval] BSTR* Value);
[propput, id(0x00000010)]
HRESULT _stdcall ExtraField([in] BSTR Value);
[propget, id(0x00000011)]
HRESULT _stdcall ExtraFlags([out, retval] unsigned char* Value);
[propput, id(0x00000011)]
HRESULT _stdcall ExtraFlags([in] unsigned char Value);
[propget, id(0x00000012)]
HRESULT _stdcall FileComment([out, retval] BSTR* Value);
[propput, id(0x00000012)]
HRESULT _stdcall FileComment([in] BSTR Value);
[propget, id(0x00000013)]
HRESULT _stdcall FileSystem([out, retval] enum TFileSystem* Value);
[propput, id(0x00000013)]
HRESULT _stdcall FileSystem([in] enum TFileSystem Value);
[propget, id(0x00000014)]
HRESULT _stdcall Flags([out, retval] unsigned char* Value);
[propput, id(0x00000014)]
HRESULT _stdcall Flags([in] unsigned char Value);
[propget, id(0x00000015)]
HRESULT _stdcall HeaderCRC([out, retval] long* Value);
};
[
uuid(729E9F52-C489-4A41-A770-4E2C5282AE39),
version(3.0),
dual,
oleautomation
]
interface ITarItem: IDispatch
{
[propget, id(0x00000001)]
HRESULT _stdcall Action([out, retval] enum TArchiveAction* Value);
[propget, id(0x00000002)]
HRESULT _stdcall CompressedSize([out, retval] long* Value);
[propget, id(0x00000003)]
HRESULT _stdcall CRC32([out, retval] long* Value);
[propget, id(0x00000004)]
HRESULT _stdcall DiskFileName([out, retval] BSTR* Value);
[propget, id(0x00000005)]
HRESULT _stdcall DiskPath([out, retval] BSTR* Value);
[propget, id(0x00000006)]
HRESULT _stdcall ExternalFileAttributes([out, retval] enum TFileAttributes* Value);
[propput, id(0x00000006)]
HRESULT _stdcall ExternalFileAttributes([in] enum TFileAttributes Value);
[propget, id(0x00000007)]
HRESULT _stdcall FileName([out, retval] BSTR* Value);
[propput, id(0x00000007)]
HRESULT _stdcall FileName([in] BSTR Value);
[propget, id(0x00000008)]
HRESULT _stdcall IsEncrypted([out, retval] VARIANT_BOOL* Value);
[propget, id(0x00000009)]
HRESULT _stdcall LastModFileDateTime([out, retval] DATE* Value);
[propget, id(0x0000000A)]
HRESULT _stdcall StoredPath([out, retval] BSTR* Value);
[propget, id(0x0000000B)]
HRESULT _stdcall Tagged([out, retval] VARIANT_BOOL* Value);
[propput, id(0x0000000B)]
HRESULT _stdcall Tagged([in] VARIANT_BOOL Value);
[propget, id(0x0000000C)]
HRESULT _stdcall UnCompressedSize([out, retval] long* Value);
[propget, id(0x0000000D)]
HRESULT _stdcall CRC32St([out, retval] BSTR* Value);
[propget, id(0x0000000E)]
HRESULT _stdcall Password([out, retval] BSTR* Value);
[propput, id(0x0000000E)]
HRESULT _stdcall Password([in] BSTR Value);
[propget, id(0x0000000F)]
HRESULT _stdcall DevMajor([out, retval] long* Value);
[propput, id(0x0000000F)]
HRESULT _stdcall DevMajor([in] long Value);
[propget, id(0x00000010)]
HRESULT _stdcall DevMinor([out, retval] long* Value);
[propput, id(0x00000010)]
HRESULT _stdcall DevMinor([in] long Value);
[propget, id(0x00000011)]
HRESULT _stdcall GroupID([out, retval] long* Value);
[propput, id(0x00000011)]
HRESULT _stdcall GroupID([in] long Value);
[propget, id(0x00000012)]
HRESULT _stdcall GroupName([out, retval] BSTR* Value);
[propput, id(0x00000012)]
HRESULT _stdcall GroupName([in] BSTR Value);
[propget, id(0x00000013)]
HRESULT _stdcall LinkFlag([out, retval] unsigned char* Value);
[propput, id(0x00000013)]
HRESULT _stdcall LinkFlag([in] unsigned char Value);
[propget, id(0x00000014)]
HRESULT _stdcall LinkName([out, retval] BSTR* Value);
[propput, id(0x00000014)]
HRESULT _stdcall LinkName([in] BSTR Value);
[propget, id(0x00000015)]
HRESULT _stdcall Mode([out, retval] long* Value);
[propput, id(0x00000015)]
HRESULT _stdcall Mode([in] long Value);
[propget, id(0x00000016)]
HRESULT _stdcall UserID([out, retval] long* Value);
[propput, id(0x00000016)]
HRESULT _stdcall UserID([in] long Value);
[propget, id(0x00000017)]
HRESULT _stdcall UserName([out, retval] BSTR* Value);
[propput, id(0x00000017)]
HRESULT _stdcall UserName([in] BSTR Value);
};
[
uuid(B7480A7F-4E27-4B45-9FE6-224B60295A0C),
version(3.0),
helpstring("Dispatch interface for ZipKit Object"),
helpcontext(0x00000006),
dual,
oleautomation
]
interface IZipKit: IDispatch
{
[id(0x00000001)]
HRESULT _stdcall Add([in] BSTR FileMask, [in] BSTR ExclusionMask, [in] long SearchAttr);
[id(0x00000007)]
HRESULT _stdcall AddFromStream([in] BSTR FileName, [in] VARIANT Stream);
[propget, id(0x00000003)]
HRESULT _stdcall AutoSave([out, retval] VARIANT_BOOL* Value);
[propput, id(0x00000003)]
HRESULT _stdcall AutoSave([in] VARIANT_BOOL Value);
[propget, id(0x00000004)]
HRESULT _stdcall BaseDirectory([out, retval] BSTR* Value);
[propput, id(0x00000004)]
HRESULT _stdcall BaseDirectory([in] BSTR Value);
[id(0x00000005)]
HRESULT _stdcall ClearTags(void);
[propget, id(0x00000006)]
HRESULT _stdcall CompressionMethodToUse([out, retval] enum TZipSupportMethod* Value);
[propput, id(0x00000006)]
HRESULT _stdcall CompressionMethodToUse([in] enum TZipSupportMethod Value);
[propget, id(0x00000002)]
HRESULT _stdcall Count([out, retval] long* Value);
[propget, id(0x00000008)]
HRESULT _stdcall DeflateOption([out, retval] enum TZipDeflateOption* Value);
[propput, id(0x00000008)]
HRESULT _stdcall DeflateOption([in] enum TZipDeflateOption Value);
[id(0x00000009)]
HRESULT _stdcall Delete([in] BSTR FileMask, [in] BSTR ExclusionMask);
[id(0x0000000A)]
HRESULT _stdcall DeleteAt([in] long Index);
[id(0x0000000B)]
HRESULT _stdcall DeleteTaggedItems(void);
[propget, id(0x0000000C)]
HRESULT _stdcall DOSMode([out, retval] VARIANT_BOOL* Value);
[propput, id(0x0000000C)]
HRESULT _stdcall DOSMode([in] VARIANT_BOOL Value);
[id(0x0000000D)]
HRESULT _stdcall Extract([in] BSTR FileMask, [in] BSTR ExclusionMask);
[id(0x0000000E)]
HRESULT _stdcall ExtractAt([in] long Index, [in] BSTR NewName);
[propget, id(0x0000000F)]
HRESULT _stdcall ExtractOptions([out, retval] enum TZipExtractOptions* Value);
[propput, id(0x0000000F)]
HRESULT _stdcall ExtractOptions([in] enum TZipExtractOptions Value);
[id(0x00000010)]
HRESULT _stdcall ExtractTaggedItems(void);
[propget, id(0x00000011)]
HRESULT _stdcall FileName([out, retval] BSTR* Value);
[propput, id(0x00000011)]
HRESULT _stdcall FileName([in] BSTR Value);
[id(0x00000012)]
HRESULT _stdcall Find([in] BSTR FileName, [out, retval] long* Value);
[id(0x00000013)]
HRESULT _stdcall Freshen([in] BSTR FileMask, [in] BSTR ExclusionMask);
[id(0x00000014)]
HRESULT _stdcall FreshenTaggedItems(void);
[propget, id(0x00000000)]
HRESULT _stdcall Item([in] long Index, [out, retval] IDispatch** Value);
[propget, id(0x00000017)]
HRESULT _stdcall LogFile([out, retval] BSTR* Value);
[propput, id(0x00000017)]
HRESULT _stdcall LogFile([in] BSTR Value);
[propget, id(0x00000018)]
HRESULT _stdcall Logging([out, retval] VARIANT_BOOL* Value);
[propput, id(0x00000018)]
HRESULT _stdcall Logging([in] VARIANT_BOOL Value);
[propget, id(0x00000019)]
HRESULT _stdcall Password([out, retval] BSTR* Value);
[propput, id(0x00000019)]
HRESULT _stdcall Password([in] BSTR Value);
[propget, id(0x0000001A)]
HRESULT _stdcall PasswordRetries([out, retval] unsigned char* Value);
[propput, id(0x0000001A)]
HRESULT _stdcall PasswordRetries([in] unsigned char Value);
[id(0x0000001B)]
HRESULT _stdcall Replace([in] BSTR FileMask);
[id(0x0000001C)]
HRESULT _stdcall Save(void);
[propget, id(0x0000001D)]
HRESULT _stdcall Spanned([out, retval] VARIANT_BOOL* Value);
[propget, id(0x0000001E)]
HRESULT _stdcall SpanningThreshold([out, retval] long* Value);
[propput, id(0x0000001E)]
HRESULT _stdcall SpanningThreshold([in] long Value);
[propget, id(0x0000001F)]
HRESULT _stdcall Status([out, retval] enum TArchiveStatus* Value);
[propget, id(0x00000020)]
HRESULT _stdcall StoreOptions([out, retval] enum TStoreOptions* Value);
[propput, id(0x00000020)]
HRESULT _stdcall StoreOptions([in] enum TStoreOptions Value);
[id(0x00000021)]
HRESULT _stdcall TagItems([in] BSTR FileMask);
[propget, id(0x00000022)]
HRESULT _stdcall TempDirectory([out, retval] BSTR* Value);
[propput, id(0x00000022)]
HRESULT _stdcall TempDirectory([in] BSTR Value);
[id(0x00000023)]
HRESULT _stdcall TestTaggedItems(void);
[id(0x00000024)]
HRESULT _stdcall UntagItems([in] BSTR FileMask);
[propget, id(0x00000025)]
HRESULT _stdcall ZipFileComment([out, retval] BSTR* Value);
[propput, id(0x00000025)]
HRESULT _stdcall ZipFileComment([in] BSTR Value);
[id(0x00000026)]
HRESULT _stdcall License([in] BSTR Key, [out, retval] VARIANT_BOOL* Value);
[propget, id(0xFFFFFFFC), restricted, hidden]
HRESULT _stdcall _NewEnum([out, retval] IUnknown** Value);
[id(0x00000015)]
HRESULT _stdcall ExtractToStream([in] BSTR FileName, [out, retval] VARIANT* Value);
[propget, id(0x00000028)]
HRESULT _stdcall CompressionType([out, retval] enum TArchiveType* Value);
[propput, id(0x00000028)]
HRESULT _stdcall CompressionType([in] enum TArchiveType Value);
[propget, id(0x00000029)]
HRESULT _stdcall TarAutoHandle([out, retval] VARIANT_BOOL* Value);
[propput, id(0x00000029)]
HRESULT _stdcall TarAutoHandle([in] VARIANT_BOOL Value);
};
[
uuid(F094D5F4-3A52-45AE-9D86-4409611DD29E),
version(3.0),
helpstring("Events interface for ZipKit Object")
]
dispinterface IZipKitEvents
{
properties:
methods:
[id(0x00000001)]
void OnArchiveItemProgress([in] IDispatch* Item, [in] unsigned char Progress, [in, out] VARIANT_BOOL* Abort);
[id(0x00000002)]
void OnArchiveProgress([in] unsigned char Progress, [in, out] VARIANT_BOOL* Abort);
[id(0x00000003)]
void OnChange(void);
[id(0x00000004)]
void OnConfirmOverwrite([in, out] BSTR* Name, [in, out] VARIANT_BOOL* Confirm);
[id(0x00000005)]
void OnConfirmProcessItem([in] IDispatch* Item, [in] enum TProcessType ProcessType, [in, out] VARIANT_BOOL* Confirm);
[id(0x00000006)]
void OnConfirmSave([in, out] VARIANT_BOOL* Confirm);
[id(0x00000007)]
void OnLoad(void);
[id(0x00000008)]
void OnNeedPassword([in, out] BSTR* NewPassword);
[id(0x00000009)]
void OnProcessItemFailure([in] IDispatch* Item, [in] enum TProcessType ProcessType, [in] enum TErrorClass ErrorClass, [in] enum TErrorCode ErrorCode, [in] BSTR ErrorString);
[id(0x0000000A)]
void OnRequestBlankDisk([in, out] VARIANT_BOOL* Abort);
[id(0x0000000B)]
void OnRequestImage([in] long ImageNumber, [in, out] BSTR* ImageName, [in, out] VARIANT_BOOL* Abort);
[id(0x0000000C)]
void OnRequestLastDisk([in, out] VARIANT_BOOL* Abort);
[id(0x0000000D)]
void OnRequestNthDisk([in] long DiskNumber, [in, out] VARIANT_BOOL* Abort);
[id(0x0000000E)]
void OnSave(void);
};
[
uuid(650989D8-F0FF-4C71-83C3-92556F4329F5),
version(3.0)
]
coclass ZipItem
{
[default] interface IZipItem;
};
[
uuid(2B35BB50-D9C7-4669-B18E-943B5199FD8E),
version(3.0)
]
coclass GZipItem
{
[default] interface IGZipItem;
};
[
uuid(2DF3E624-0E6C-42CF-8041-676B9A06375E),
version(3.0)
]
coclass TarItem
{
[default] interface ITarItem;
};
[
uuid(730B4B32-9127-492A-BF02-196A7E6B4E1B),
version(3.0),
helpstring("ZipKit Object"),
helpcontext(0x00000006)
]
coclass ZipKit
{
[default] interface IZipKit;
[default, source] dispinterface IZipKitEvents;
};
};
================================================
FILE: lib/abbrevia/source/COM/Abbrevia_TLB.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
unit Abbrevia_TLB;
// ************************************************************************ //
// WARNING
// -------
// The types declared in this file were generated from data read from a
// Type Library. If this type library is explicitly or indirectly (via
// another type library referring to this type library) re-imported, or the
// 'Refresh' command of the Type Library Editor activated while editing the
// Type Library, the contents of this file will be regenerated and all
// manual modifications will be lost.
// ************************************************************************ //
// $Rev: 491 $
// File generated on 7/23/2009 9:45:45 PM from Type Library described below.
// ************************************************************************ //
// Type Lib: C:\Abbrevia\COM\abbrevia.dll
// LIBID: {AF804E20-4043-499E-BB14-237B9F26F89F}
// LCID: 0
// Helpfile: C:\Abbrevia\COM\abrv-com.hlp
// HelpString: TurboPower Abbrevia Compression Library v3.03
// DepndLst:
// (1) v2.0 stdole, (C:\WINDOWS\System32\stdole2.tlb)
// ************************************************************************ //
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}
{$VARPROPSETTER ON}
interface
uses Windows, ActiveX, Classes, Graphics, StdVCL, Variants;
// *********************************************************************//
// GUIDS declared in the TypeLibrary. Following prefixes are used:
// Type Libraries : LIBID_xxxx
// CoClasses : CLASS_xxxx
// DISPInterfaces : DIID_xxxx
// Non-DISP interfaces: IID_xxxx
// *********************************************************************//
const
// TypeLibrary Major and minor versions
AbbreviaMajorVersion = 5;
AbbreviaMinorVersion = 0;
LIBID_Abbrevia: TGUID = '{AF804E20-4043-499E-BB14-237B9F26F89F}';
IID_IZipItem: TGUID = '{851699A1-422A-4C65-8E08-D0499ACDD834}';
IID_IGZipItem: TGUID = '{8FA78CE0-FD29-441E-9777-93B63EF1A9EE}';
IID_ITarItem: TGUID = '{729E9F52-C489-4A41-A770-4E2C5282AE39}';
IID_IZipKit: TGUID = '{B7480A7F-4E27-4B45-9FE6-224B60295A0C}';
DIID_IZipKitEvents: TGUID = '{F094D5F4-3A52-45AE-9D86-4409611DD29E}';
CLASS_ZipItem: TGUID = '{650989D8-F0FF-4C71-83C3-92556F4329F5}';
CLASS_GZipItem: TGUID = '{2B35BB50-D9C7-4669-B18E-943B5199FD8E}';
CLASS_TarItem: TGUID = '{2DF3E624-0E6C-42CF-8041-676B9A06375E}';
CLASS_ZipKit: TGUID = '{730B4B32-9127-492A-BF02-196A7E6B4E1B}';
// *********************************************************************//
// Declaration of Enumerations defined in Type Library
// *********************************************************************//
// Constants for enum TArchiveAction
type
TArchiveAction = TOleEnum;
const
aaFailed = $00000000;
aaNone = $00000001;
aaAdd = $00000002;
aaDelete = $00000003;
aaFreshen = $00000004;
aaMove = $00000005;
aaStreamAdd = $00000006;
// Constants for enum TArchiveStatus
type
TArchiveStatus = TOleEnum;
const
asInvalid = $00000000;
asIdle = $00000001;
asBusy = $00000002;
// Constants for enum TErrorClass
type
TErrorClass = TOleEnum;
const
eclAbbrevia = $00000000;
eclInOutError = $00000001;
eclFileError = $00000002;
eclFileCreateError = $00000003;
eclFileOpenError = $00000004;
eclOther = $00000005;
// Constants for enum TFileAttributes
type
TFileAttributes = TOleEnum;
const
faReadOnly = $00000001;
faHidden = $00000002;
faSysFile = $00000004;
faVolumeID = $00000008;
faDirectory = $00000010;
faArchive = $00000020;
// Constants for enum TProcessType
type
TProcessType = TOleEnum;
const
ptAdd = $00000000;
ptDelete = $00000001;
ptExtract = $00000002;
ptFreshen = $00000003;
ptMove = $00000004;
ptReplace = $00000005;
// Constants for enum TStoreOptions
type
TStoreOptions = TOleEnum;
const
soStripDrive = $00000001;
soStripPath = $00000002;
soRemoveDots = $00000004;
soRecurse = $00000008;
soFreshen = $00000010;
soReplace = $00000020;
// Constants for enum TZipCompressionMethod
type
TZipCompressionMethod = TOleEnum;
const
cmStored = $00000000;
cmShrunk = $00000001;
cmReduced1 = $00000002;
cmReduced2 = $00000003;
cmReduced3 = $00000004;
cmReduced4 = $00000005;
cmImploded = $00000006;
cmTokenized = $00000007;
cmDeflated = $00000008;
cmEnhancedDeflated = $00000009;
cmDCLImploded = $0000000A;
cmBestMethod = $0000000B;
// Constants for enum TZipDeflateOption
type
TZipDeflateOption = TOleEnum;
const
doInvalid = $00000000;
doNormal = $00000001;
doMaximum = $00000002;
doFast = $00000003;
doSuperFast = $00000004;
// Constants for enum TZipDictionarySize
type
TZipDictionarySize = TOleEnum;
const
dsInvalid = $00000000;
ds4K = $00000001;
ds8K = $00000002;
// Constants for enum TZipExtractOptions
type
TZipExtractOptions = TOleEnum;
const
eoCreateDirs = $00000000;
eoRestorePath = $00000001;
// Constants for enum TZipSupportMethod
type
TZipSupportMethod = TOleEnum;
const
smStored = $00000000;
smDeflated = $00000001;
smBestMethod = $00000002;
// Constants for enum TErrorCode
type
TErrorCode = TOleEnum;
const
ecDuplicateName = $00000000;
ecInvalidPassword = $00000001;
ecNoSuchDirectory = $00000002;
ecUnknownCompressionMethod = $00000003;
ecUserAbort = $00000004;
ecZipBadCRC = $00000005;
ecZipVersionNumber = $00000006;
ecSpannedItemNotFound = $00000007;
// Constants for enum TArchiveType
type
TArchiveType = TOleEnum;
const
atUnknown = $00000000;
atZip = $00000001;
atSelfExtZip = $00000002;
atTar = $00000003;
atGZip = $00000004;
atGZippedTar = $00000005;
atCab = $00000006;
// Constants for enum TFileSystem
type
TFileSystem = TOleEnum;
const
fsFAT = $00000000;
fsAmiga = $00000001;
fsVMS = $00000002;
fsUnix = $00000003;
fsVM_CMS = $00000004;
fsAtariTOS = $00000005;
fsHPFS = $00000006;
fsMacintosh = $00000007;
fsZSystem = $00000008;
fsCP_M = $00000009;
fsTOPS20 = $0000000A;
fsNTFS = $0000000B;
fsQDOS = $0000000C;
fsAcornRISCOS = $0000000D;
fsUnknown = $0000000E;
fsUndefined = $0000000F;
type
// *********************************************************************//
// Forward declaration of types defined in TypeLibrary
// *********************************************************************//
IZipItem = interface;
IZipItemDisp = dispinterface;
IGZipItem = interface;
IGZipItemDisp = dispinterface;
ITarItem = interface;
ITarItemDisp = dispinterface;
IZipKit = interface;
IZipKitDisp = dispinterface;
IZipKitEvents = dispinterface;
// *********************************************************************//
// Declaration of CoClasses defined in Type Library
// (NOTE: Here we map each CoClass to its Default Interface)
// *********************************************************************//
ZipItem = IZipItem;
GZipItem = IGZipItem;
TarItem = ITarItem;
ZipKit = IZipKit;
// *********************************************************************//
// Interface: IZipItem
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {851699A1-422A-4C65-8E08-D0499ACDD834}
// *********************************************************************//
IZipItem = interface(IDispatch)
['{851699A1-422A-4C65-8E08-D0499ACDD834}']
function Get_Action: TArchiveAction; safecall;
function Get_CompressedSize: Integer; safecall;
function Get_CRC32: Integer; safecall;
function Get_DiskFileName: WideString; safecall;
function Get_DiskPath: WideString; safecall;
function Get_ExternalFileAttributes: TFileAttributes; safecall;
procedure Set_ExternalFileAttributes(Value: TFileAttributes); safecall;
function Get_FileName: WideString; safecall;
procedure Set_FileName(const Value: WideString); safecall;
function Get_IsEncrypted: WordBool; safecall;
function Get_LastModFileDateTime: TDateTime; safecall;
function Get_StoredPath: WideString; safecall;
function Get_Tagged: WordBool; safecall;
procedure Set_Tagged(Value: WordBool); safecall;
function Get_UnCompressedSize: Integer; safecall;
function Get_CRC32St: WideString; safecall;
function Get_Password: WideString; safecall;
procedure Set_Password(const Value: WideString); safecall;
function Get_CompressionMethod: TZipCompressionMethod; safecall;
function Get_CompressionRatio: Double; safecall;
function Get_DeflateOption: TZipDeflateOption; safecall;
function Get_DictionarySize: TZipDictionarySize; safecall;
function Get_DiskNumberStart: Integer; safecall;
function Get_ExtraField: WideString; safecall;
procedure Set_ExtraField(const Value: WideString); safecall;
function Get_FileComment: WideString; safecall;
procedure Set_FileComment(const Value: WideString); safecall;
function Get_InternalFileAttributes: Integer; safecall;
procedure Set_InternalFileAttributes(Value: Integer); safecall;
function Get_VersionMadeBy: Integer; safecall;
function Get_VersionNeededToExtract: Integer; safecall;
property Action: TArchiveAction read Get_Action;
property CompressedSize: Integer read Get_CompressedSize;
property CRC32: Integer read Get_CRC32;
property DiskFileName: WideString read Get_DiskFileName;
property DiskPath: WideString read Get_DiskPath;
property ExternalFileAttributes: TFileAttributes read Get_ExternalFileAttributes write Set_ExternalFileAttributes;
property FileName: WideString read Get_FileName write Set_FileName;
property IsEncrypted: WordBool read Get_IsEncrypted;
property LastModFileDateTime: TDateTime read Get_LastModFileDateTime;
property StoredPath: WideString read Get_StoredPath;
property Tagged: WordBool read Get_Tagged write Set_Tagged;
property UnCompressedSize: Integer read Get_UnCompressedSize;
property CRC32St: WideString read Get_CRC32St;
property Password: WideString read Get_Password write Set_Password;
property CompressionMethod: TZipCompressionMethod read Get_CompressionMethod;
property CompressionRatio: Double read Get_CompressionRatio;
property DeflateOption: TZipDeflateOption read Get_DeflateOption;
property DictionarySize: TZipDictionarySize read Get_DictionarySize;
property DiskNumberStart: Integer read Get_DiskNumberStart;
property ExtraField: WideString read Get_ExtraField write Set_ExtraField;
property FileComment: WideString read Get_FileComment write Set_FileComment;
property InternalFileAttributes: Integer read Get_InternalFileAttributes write Set_InternalFileAttributes;
property VersionMadeBy: Integer read Get_VersionMadeBy;
property VersionNeededToExtract: Integer read Get_VersionNeededToExtract;
end;
// *********************************************************************//
// DispIntf: IZipItemDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {851699A1-422A-4C65-8E08-D0499ACDD834}
// *********************************************************************//
IZipItemDisp = dispinterface
['{851699A1-422A-4C65-8E08-D0499ACDD834}']
property Action: TArchiveAction readonly dispid 1;
property CompressedSize: Integer readonly dispid 2;
property CRC32: Integer readonly dispid 3;
property DiskFileName: WideString readonly dispid 4;
property DiskPath: WideString readonly dispid 5;
property ExternalFileAttributes: TFileAttributes dispid 6;
property FileName: WideString dispid 7;
property IsEncrypted: WordBool readonly dispid 8;
property LastModFileDateTime: TDateTime readonly dispid 9;
property StoredPath: WideString readonly dispid 10;
property Tagged: WordBool dispid 11;
property UnCompressedSize: Integer readonly dispid 12;
property CRC32St: WideString readonly dispid 13;
property Password: WideString dispid 14;
property CompressionMethod: TZipCompressionMethod readonly dispid 15;
property CompressionRatio: Double readonly dispid 16;
property DeflateOption: TZipDeflateOption readonly dispid 17;
property DictionarySize: TZipDictionarySize readonly dispid 18;
property DiskNumberStart: Integer readonly dispid 19;
property ExtraField: WideString dispid 20;
property FileComment: WideString dispid 21;
property InternalFileAttributes: Integer dispid 22;
property VersionMadeBy: Integer readonly dispid 23;
property VersionNeededToExtract: Integer readonly dispid 24;
end;
// *********************************************************************//
// Interface: IGZipItem
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {8FA78CE0-FD29-441E-9777-93B63EF1A9EE}
// *********************************************************************//
IGZipItem = interface(IDispatch)
['{8FA78CE0-FD29-441E-9777-93B63EF1A9EE}']
function Get_Action: TArchiveAction; safecall;
function Get_CompressedSize: Integer; safecall;
function Get_CRC32: Integer; safecall;
function Get_DiskFileName: WideString; safecall;
function Get_DiskPath: WideString; safecall;
function Get_ExternalFileAttributes: TFileAttributes; safecall;
procedure Set_ExternalFileAttributes(Value: TFileAttributes); safecall;
function Get_FileName: WideString; safecall;
procedure Set_FileName(const Value: WideString); safecall;
function Get_IsEncrypted: WordBool; safecall;
function Get_LastModFileDateTime: TDateTime; safecall;
function Get_StoredPath: WideString; safecall;
function Get_Tagged: WordBool; safecall;
procedure Set_Tagged(Value: WordBool); safecall;
function Get_UnCompressedSize: Integer; safecall;
function Get_CRC32St: WideString; safecall;
function Get_Password: WideString; safecall;
procedure Set_Password(const Value: WideString); safecall;
function Get_CompressionMethod: Byte; safecall;
procedure Set_CompressionMethod(Value: Byte); safecall;
function Get_ExtraField: WideString; safecall;
procedure Set_ExtraField(const Value: WideString); safecall;
function Get_ExtraFlags: Byte; safecall;
procedure Set_ExtraFlags(Value: Byte); safecall;
function Get_FileComment: WideString; safecall;
procedure Set_FileComment(const Value: WideString); safecall;
function Get_FileSystem: TFileSystem; safecall;
procedure Set_FileSystem(Value: TFileSystem); safecall;
function Get_Flags: Byte; safecall;
procedure Set_Flags(Value: Byte); safecall;
function Get_HeaderCRC: Integer; safecall;
property Action: TArchiveAction read Get_Action;
property CompressedSize: Integer read Get_CompressedSize;
property CRC32: Integer read Get_CRC32;
property DiskFileName: WideString read Get_DiskFileName;
property DiskPath: WideString read Get_DiskPath;
property ExternalFileAttributes: TFileAttributes read Get_ExternalFileAttributes write Set_ExternalFileAttributes;
property FileName: WideString read Get_FileName write Set_FileName;
property IsEncrypted: WordBool read Get_IsEncrypted;
property LastModFileDateTime: TDateTime read Get_LastModFileDateTime;
property StoredPath: WideString read Get_StoredPath;
property Tagged: WordBool read Get_Tagged write Set_Tagged;
property UnCompressedSize: Integer read Get_UnCompressedSize;
property CRC32St: WideString read Get_CRC32St;
property Password: WideString read Get_Password write Set_Password;
property CompressionMethod: Byte read Get_CompressionMethod write Set_CompressionMethod;
property ExtraField: WideString read Get_ExtraField write Set_ExtraField;
property ExtraFlags: Byte read Get_ExtraFlags write Set_ExtraFlags;
property FileComment: WideString read Get_FileComment write Set_FileComment;
property FileSystem: TFileSystem read Get_FileSystem write Set_FileSystem;
property Flags: Byte read Get_Flags write Set_Flags;
property HeaderCRC: Integer read Get_HeaderCRC;
end;
// *********************************************************************//
// DispIntf: IGZipItemDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {8FA78CE0-FD29-441E-9777-93B63EF1A9EE}
// *********************************************************************//
IGZipItemDisp = dispinterface
['{8FA78CE0-FD29-441E-9777-93B63EF1A9EE}']
property Action: TArchiveAction readonly dispid 1;
property CompressedSize: Integer readonly dispid 2;
property CRC32: Integer readonly dispid 3;
property DiskFileName: WideString readonly dispid 4;
property DiskPath: WideString readonly dispid 5;
property ExternalFileAttributes: TFileAttributes dispid 6;
property FileName: WideString dispid 7;
property IsEncrypted: WordBool readonly dispid 8;
property LastModFileDateTime: TDateTime readonly dispid 9;
property StoredPath: WideString readonly dispid 10;
property Tagged: WordBool dispid 11;
property UnCompressedSize: Integer readonly dispid 12;
property CRC32St: WideString readonly dispid 13;
property Password: WideString dispid 14;
property CompressionMethod: Byte dispid 15;
property ExtraField: WideString dispid 16;
property ExtraFlags: Byte dispid 17;
property FileComment: WideString dispid 18;
property FileSystem: TFileSystem dispid 19;
property Flags: Byte dispid 20;
property HeaderCRC: Integer readonly dispid 21;
end;
// *********************************************************************//
// Interface: ITarItem
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {729E9F52-C489-4A41-A770-4E2C5282AE39}
// *********************************************************************//
ITarItem = interface(IDispatch)
['{729E9F52-C489-4A41-A770-4E2C5282AE39}']
function Get_Action: TArchiveAction; safecall;
function Get_CompressedSize: Integer; safecall;
function Get_CRC32: Integer; safecall;
function Get_DiskFileName: WideString; safecall;
function Get_DiskPath: WideString; safecall;
function Get_ExternalFileAttributes: TFileAttributes; safecall;
procedure Set_ExternalFileAttributes(Value: TFileAttributes); safecall;
function Get_FileName: WideString; safecall;
procedure Set_FileName(const Value: WideString); safecall;
function Get_IsEncrypted: WordBool; safecall;
function Get_LastModFileDateTime: TDateTime; safecall;
function Get_StoredPath: WideString; safecall;
function Get_Tagged: WordBool; safecall;
procedure Set_Tagged(Value: WordBool); safecall;
function Get_UnCompressedSize: Integer; safecall;
function Get_CRC32St: WideString; safecall;
function Get_Password: WideString; safecall;
procedure Set_Password(const Value: WideString); safecall;
function Get_DevMajor: Integer; safecall;
procedure Set_DevMajor(Value: Integer); safecall;
function Get_DevMinor: Integer; safecall;
procedure Set_DevMinor(Value: Integer); safecall;
function Get_GroupID: Integer; safecall;
procedure Set_GroupID(Value: Integer); safecall;
function Get_GroupName: WideString; safecall;
procedure Set_GroupName(const Value: WideString); safecall;
function Get_LinkFlag: Byte; safecall;
procedure Set_LinkFlag(Value: Byte); safecall;
function Get_LinkName: WideString; safecall;
procedure Set_LinkName(const Value: WideString); safecall;
function Get_Mode: Integer; safecall;
procedure Set_Mode(Value: Integer); safecall;
function Get_UserID: Integer; safecall;
procedure Set_UserID(Value: Integer); safecall;
function Get_UserName: WideString; safecall;
procedure Set_UserName(const Value: WideString); safecall;
property Action: TArchiveAction read Get_Action;
property CompressedSize: Integer read Get_CompressedSize;
property CRC32: Integer read Get_CRC32;
property DiskFileName: WideString read Get_DiskFileName;
property DiskPath: WideString read Get_DiskPath;
property ExternalFileAttributes: TFileAttributes read Get_ExternalFileAttributes write Set_ExternalFileAttributes;
property FileName: WideString read Get_FileName write Set_FileName;
property IsEncrypted: WordBool read Get_IsEncrypted;
property LastModFileDateTime: TDateTime read Get_LastModFileDateTime;
property StoredPath: WideString read Get_StoredPath;
property Tagged: WordBool read Get_Tagged write Set_Tagged;
property UnCompressedSize: Integer read Get_UnCompressedSize;
property CRC32St: WideString read Get_CRC32St;
property Password: WideString read Get_Password write Set_Password;
property DevMajor: Integer read Get_DevMajor write Set_DevMajor;
property DevMinor: Integer read Get_DevMinor write Set_DevMinor;
property GroupID: Integer read Get_GroupID write Set_GroupID;
property GroupName: WideString read Get_GroupName write Set_GroupName;
property LinkFlag: Byte read Get_LinkFlag write Set_LinkFlag;
property LinkName: WideString read Get_LinkName write Set_LinkName;
property Mode: Integer read Get_Mode write Set_Mode;
property UserID: Integer read Get_UserID write Set_UserID;
property UserName: WideString read Get_UserName write Set_UserName;
end;
// *********************************************************************//
// DispIntf: ITarItemDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {729E9F52-C489-4A41-A770-4E2C5282AE39}
// *********************************************************************//
ITarItemDisp = dispinterface
['{729E9F52-C489-4A41-A770-4E2C5282AE39}']
property Action: TArchiveAction readonly dispid 1;
property CompressedSize: Integer readonly dispid 2;
property CRC32: Integer readonly dispid 3;
property DiskFileName: WideString readonly dispid 4;
property DiskPath: WideString readonly dispid 5;
property ExternalFileAttributes: TFileAttributes dispid 6;
property FileName: WideString dispid 7;
property IsEncrypted: WordBool readonly dispid 8;
property LastModFileDateTime: TDateTime readonly dispid 9;
property StoredPath: WideString readonly dispid 10;
property Tagged: WordBool dispid 11;
property UnCompressedSize: Integer readonly dispid 12;
property CRC32St: WideString readonly dispid 13;
property Password: WideString dispid 14;
property DevMajor: Integer dispid 15;
property DevMinor: Integer dispid 16;
property GroupID: Integer dispid 17;
property GroupName: WideString dispid 18;
property LinkFlag: Byte dispid 19;
property LinkName: WideString dispid 20;
property Mode: Integer dispid 21;
property UserID: Integer dispid 22;
property UserName: WideString dispid 23;
end;
// *********************************************************************//
// Interface: IZipKit
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {B7480A7F-4E27-4B45-9FE6-224B60295A0C}
// *********************************************************************//
IZipKit = interface(IDispatch)
['{B7480A7F-4E27-4B45-9FE6-224B60295A0C}']
procedure Add(const FileMask: WideString; const ExclusionMask: WideString; SearchAttr: Integer); safecall;
procedure AddFromStream(const FileName: WideString; Stream: OleVariant); safecall;
function Get_AutoSave: WordBool; safecall;
procedure Set_AutoSave(Value: WordBool); safecall;
function Get_BaseDirectory: WideString; safecall;
procedure Set_BaseDirectory(const Value: WideString); safecall;
procedure ClearTags; safecall;
function Get_CompressionMethodToUse: TZipSupportMethod; safecall;
procedure Set_CompressionMethodToUse(Value: TZipSupportMethod); safecall;
function Get_Count: Integer; safecall;
function Get_DeflateOption: TZipDeflateOption; safecall;
procedure Set_DeflateOption(Value: TZipDeflateOption); safecall;
procedure Delete(const FileMask: WideString; const ExclusionMask: WideString); safecall;
procedure DeleteAt(Index: Integer); safecall;
procedure DeleteTaggedItems; safecall;
function Get_DOSMode: WordBool; safecall;
procedure Set_DOSMode(Value: WordBool); safecall;
procedure Extract(const FileMask: WideString; const ExclusionMask: WideString); safecall;
procedure ExtractAt(Index: Integer; const NewName: WideString); safecall;
function Get_ExtractOptions: TZipExtractOptions; safecall;
procedure Set_ExtractOptions(Value: TZipExtractOptions); safecall;
procedure ExtractTaggedItems; safecall;
function Get_FileName: WideString; safecall;
procedure Set_FileName(const Value: WideString); safecall;
function Find(const FileName: WideString): Integer; safecall;
procedure Freshen(const FileMask: WideString; const ExclusionMask: WideString); safecall;
procedure FreshenTaggedItems; safecall;
function Get_Item(Index: Integer): IDispatch; safecall;
function Get_LogFile: WideString; safecall;
procedure Set_LogFile(const Value: WideString); safecall;
function Get_Logging: WordBool; safecall;
procedure Set_Logging(Value: WordBool); safecall;
function Get_Password: WideString; safecall;
procedure Set_Password(const Value: WideString); safecall;
function Get_PasswordRetries: Byte; safecall;
procedure Set_PasswordRetries(Value: Byte); safecall;
procedure Replace(const FileMask: WideString); safecall;
procedure Save; safecall;
function Get_Spanned: WordBool; safecall;
function Get_SpanningThreshold: Integer; safecall;
procedure Set_SpanningThreshold(Value: Integer); safecall;
function Get_Status: TArchiveStatus; safecall;
function Get_StoreOptions: TStoreOptions; safecall;
procedure Set_StoreOptions(Value: TStoreOptions); safecall;
procedure TagItems(const FileMask: WideString); safecall;
function Get_TempDirectory: WideString; safecall;
procedure Set_TempDirectory(const Value: WideString); safecall;
procedure TestTaggedItems; safecall;
procedure UntagItems(const FileMask: WideString); safecall;
function Get_ZipFileComment: WideString; safecall;
procedure Set_ZipFileComment(const Value: WideString); safecall;
function License(const Key: WideString): WordBool; safecall;
function Get__NewEnum: IUnknown; safecall;
function ExtractToStream(const FileName: WideString): OleVariant; safecall;
function Get_CompressionType: TArchiveType; safecall;
procedure Set_CompressionType(Value: TArchiveType); safecall;
function Get_TarAutoHandle: WordBool; safecall;
procedure Set_TarAutoHandle(Value: WordBool); safecall;
property AutoSave: WordBool read Get_AutoSave write Set_AutoSave;
property BaseDirectory: WideString read Get_BaseDirectory write Set_BaseDirectory;
property CompressionMethodToUse: TZipSupportMethod read Get_CompressionMethodToUse write Set_CompressionMethodToUse;
property Count: Integer read Get_Count;
property DeflateOption: TZipDeflateOption read Get_DeflateOption write Set_DeflateOption;
property DOSMode: WordBool read Get_DOSMode write Set_DOSMode;
property ExtractOptions: TZipExtractOptions read Get_ExtractOptions write Set_ExtractOptions;
property FileName: WideString read Get_FileName write Set_FileName;
property Item[Index: Integer]: IDispatch read Get_Item;
property LogFile: WideString read Get_LogFile write Set_LogFile;
property Logging: WordBool read Get_Logging write Set_Logging;
property Password: WideString read Get_Password write Set_Password;
property PasswordRetries: Byte read Get_PasswordRetries write Set_PasswordRetries;
property Spanned: WordBool read Get_Spanned;
property SpanningThreshold: Integer read Get_SpanningThreshold write Set_SpanningThreshold;
property Status: TArchiveStatus read Get_Status;
property StoreOptions: TStoreOptions read Get_StoreOptions write Set_StoreOptions;
property TempDirectory: WideString read Get_TempDirectory write Set_TempDirectory;
property ZipFileComment: WideString read Get_ZipFileComment write Set_ZipFileComment;
property _NewEnum: IUnknown read Get__NewEnum;
property CompressionType: TArchiveType read Get_CompressionType write Set_CompressionType;
property TarAutoHandle: WordBool read Get_TarAutoHandle write Set_TarAutoHandle;
end;
// *********************************************************************//
// DispIntf: IZipKitDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {B7480A7F-4E27-4B45-9FE6-224B60295A0C}
// *********************************************************************//
IZipKitDisp = dispinterface
['{B7480A7F-4E27-4B45-9FE6-224B60295A0C}']
procedure Add(const FileMask: WideString; const ExclusionMask: WideString; SearchAttr: Integer); dispid 1;
procedure AddFromStream(const FileName: WideString; Stream: OleVariant); dispid 7;
property AutoSave: WordBool dispid 3;
property BaseDirectory: WideString dispid 4;
procedure ClearTags; dispid 5;
property CompressionMethodToUse: TZipSupportMethod dispid 6;
property Count: Integer readonly dispid 2;
property DeflateOption: TZipDeflateOption dispid 8;
procedure Delete(const FileMask: WideString; const ExclusionMask: WideString); dispid 9;
procedure DeleteAt(Index: Integer); dispid 10;
procedure DeleteTaggedItems; dispid 11;
property DOSMode: WordBool dispid 12;
procedure Extract(const FileMask: WideString; const ExclusionMask: WideString); dispid 13;
procedure ExtractAt(Index: Integer; const NewName: WideString); dispid 14;
property ExtractOptions: TZipExtractOptions dispid 15;
procedure ExtractTaggedItems; dispid 16;
property FileName: WideString dispid 17;
function Find(const FileName: WideString): Integer; dispid 18;
procedure Freshen(const FileMask: WideString; const ExclusionMask: WideString); dispid 19;
procedure FreshenTaggedItems; dispid 20;
property Item[Index: Integer]: IDispatch readonly dispid 0;
property LogFile: WideString dispid 23;
property Logging: WordBool dispid 24;
property Password: WideString dispid 25;
property PasswordRetries: Byte dispid 26;
procedure Replace(const FileMask: WideString); dispid 27;
procedure Save; dispid 28;
property Spanned: WordBool readonly dispid 29;
property SpanningThreshold: Integer dispid 30;
property Status: TArchiveStatus readonly dispid 31;
property StoreOptions: TStoreOptions dispid 32;
procedure TagItems(const FileMask: WideString); dispid 33;
property TempDirectory: WideString dispid 34;
procedure TestTaggedItems; dispid 35;
procedure UntagItems(const FileMask: WideString); dispid 36;
property ZipFileComment: WideString dispid 37;
function License(const Key: WideString): WordBool; dispid 38;
property _NewEnum: IUnknown readonly dispid $FFFFFFFC;
function ExtractToStream(const FileName: WideString): OleVariant; dispid 21;
property CompressionType: TArchiveType dispid 40;
property TarAutoHandle: WordBool dispid 41;
end;
// *********************************************************************//
// DispIntf: IZipKitEvents
// Flags: (4096) Dispatchable
// GUID: {F094D5F4-3A52-45AE-9D86-4409611DD29E}
// *********************************************************************//
IZipKitEvents = dispinterface
['{F094D5F4-3A52-45AE-9D86-4409611DD29E}']
procedure OnArchiveItemProgress(const Item: IDispatch; Progress: Byte; var Abort: WordBool); dispid 1;
procedure OnArchiveProgress(Progress: Byte; var Abort: WordBool); dispid 2;
procedure OnChange; dispid 3;
procedure OnConfirmOverwrite(var Name: WideString; var Confirm: WordBool); dispid 4;
procedure OnConfirmProcessItem(const Item: IDispatch; ProcessType: TProcessType;
var Confirm: WordBool); dispid 5;
procedure OnConfirmSave(var Confirm: WordBool); dispid 6;
procedure OnLoad; dispid 7;
procedure OnNeedPassword(var NewPassword: WideString); dispid 8;
procedure OnProcessItemFailure(const Item: IDispatch; ProcessType: TProcessType;
ErrorClass: TErrorClass; ErrorCode: TErrorCode;
const ErrorString: WideString); dispid 9;
procedure OnRequestBlankDisk(var Abort: WordBool); dispid 10;
procedure OnRequestImage(ImageNumber: Integer; var ImageName: WideString; var Abort: WordBool); dispid 11;
procedure OnRequestLastDisk(var Abort: WordBool); dispid 12;
procedure OnRequestNthDisk(DiskNumber: Integer; var Abort: WordBool); dispid 13;
procedure OnSave; dispid 14;
end;
// *********************************************************************//
// The Class CoZipItem provides a Create and CreateRemote method to
// create instances of the default interface IZipItem exposed by
// the CoClass ZipItem. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoZipItem = class
class function Create: IZipItem;
class function CreateRemote(const MachineName: string): IZipItem;
end;
// *********************************************************************//
// The Class CoGZipItem provides a Create and CreateRemote method to
// create instances of the default interface IGZipItem exposed by
// the CoClass GZipItem. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoGZipItem = class
class function Create: IGZipItem;
class function CreateRemote(const MachineName: string): IGZipItem;
end;
// *********************************************************************//
// The Class CoTarItem provides a Create and CreateRemote method to
// create instances of the default interface ITarItem exposed by
// the CoClass TarItem. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoTarItem = class
class function Create: ITarItem;
class function CreateRemote(const MachineName: string): ITarItem;
end;
// *********************************************************************//
// The Class CoZipKit provides a Create and CreateRemote method to
// create instances of the default interface IZipKit exposed by
// the CoClass ZipKit. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoZipKit = class
class function Create: IZipKit;
class function CreateRemote(const MachineName: string): IZipKit;
end;
implementation
uses ComObj;
class function CoZipItem.Create: IZipItem;
begin
Result := CreateComObject(CLASS_ZipItem) as IZipItem;
end;
class function CoZipItem.CreateRemote(const MachineName: string): IZipItem;
begin
Result := CreateRemoteComObject(MachineName, CLASS_ZipItem) as IZipItem;
end;
class function CoGZipItem.Create: IGZipItem;
begin
Result := CreateComObject(CLASS_GZipItem) as IGZipItem;
end;
class function CoGZipItem.CreateRemote(const MachineName: string): IGZipItem;
begin
Result := CreateRemoteComObject(MachineName, CLASS_GZipItem) as IGZipItem;
end;
class function CoTarItem.Create: ITarItem;
begin
Result := CreateComObject(CLASS_TarItem) as ITarItem;
end;
class function CoTarItem.CreateRemote(const MachineName: string): ITarItem;
begin
Result := CreateRemoteComObject(MachineName, CLASS_TarItem) as ITarItem;
end;
class function CoZipKit.Create: IZipKit;
begin
Result := CreateComObject(CLASS_ZipKit) as IZipKit;
end;
class function CoZipKit.CreateRemote(const MachineName: string): IZipKit;
begin
Result := CreateRemoteComObject(MachineName, CLASS_ZipKit) as IZipKit;
end;
end.
================================================
FILE: lib/abbrevia/source/COM/Readme.txt
================================================
The COM DLLs for v5.0 are compiled using Delphi XE2 (including extended RTTI) and include zipx support. Recompiling with Delphi 2009 and without zipx support should roughly halve the size of the 32-bit DLL.
They can be registered for all users (requires admin rights) using:
regsvr32 Abbrevia.dll
And for the current user using:
regsvr32 /i:user /n Abbrevia.dll
To uninstall use:
regsvr32 /u Abbrevia.dll
or
regsvr32 /i:user /n /u Abbrevia.dll
================================================
FILE: lib/abbrevia/source/COM/_GZipItem.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
unit _GZipItem;
interface
uses
ComObj, Abbrevia_TLB, AbGzTyp, AbZipKit;
type
TGZipItem = class(TAutoIntfObject, IGZipItem)
private
FOwner : TAbGzipItem;
FParent : TAbZipKit;
public
constructor Create(AOwner : TAbGzipItem; AParent : TAbZipKit);
protected
{IArchiveItem}
function Get_Action: TArchiveAction; safecall;
function Get_CompressedSize: Integer; safecall;
function Get_CRC32: Integer; safecall;
function Get_CRC32St: WideString; safecall;
function Get_DiskFileName: WideString; safecall;
function Get_DiskPath: WideString; safecall;
function Get_ExternalFileAttributes: TFileAttributes; safecall;
procedure Set_ExternalFileAttributes(Value: TFileAttributes); safecall;
function Get_FileName: WideString; safecall;
procedure Set_FileName(const Value: WideString); safecall;
function Get_IsEncrypted: WordBool; safecall;
function Get_LastModFileDateTime: TDateTime; safecall;
function Get_StoredPath: WideString; safecall;
function Get_Tagged: WordBool; safecall;
procedure Set_Tagged(Value: WordBool); safecall;
function Get_UnCompressedSize: Integer; safecall;
function Get_Password: WideString; safecall;
procedure Set_Password(const Value: WideString); safecall;
{IGZipItem}
function Get_CompressionMethod: Byte; safecall;
procedure Set_CompressionMethod(Value: Byte); safecall;
function Get_ExtraField: WideString; safecall;
procedure Set_ExtraField(const Value: WideString); safecall;
function Get_ExtraFlags: Byte; safecall;
procedure Set_ExtraFlags(Value: Byte); safecall;
function Get_FileComment: WideString; safecall;
procedure Set_FileComment(const Value: WideString); safecall;
function Get_FileSystem: TFileSystem; safecall;
procedure Set_FileSystem(Value: TFileSystem); safecall;
function Get_Flags: Byte; safecall;
procedure Set_Flags(Value: Byte); safecall;
function Get_HeaderCRC: Integer; safecall;
end;
implementation
uses
ComServ, {StStrL,} SysUtils;
{------------------------------------------------------------------------------}
constructor TGzipItem.Create(AOwner : TAbGzipItem; AParent : TAbZipKit);
begin
inherited Create(ComServer.TypeLib, IGZipItem);
FOwner := AOwner;
FParent := AParent;
end;
{------------------------------------------------------------------------------}
{IArchiveItem}
{------------------------------------------------------------------------------}
function TGzipItem.Get_Action: TArchiveAction;
begin
Result := TArchiveAction(FOwner.Action);
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_CompressedSize: Integer;
begin
result := FOwner.CompressedSize;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_CRC32: Integer;
begin
result := FOwner.CRC32;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_CRC32St: WideString;
begin
result := IntToHex(FOwner.CRC32, 8);
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_DiskFileName: WideString;
begin
result := FOwner.DiskFileName;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_DiskPath: WideString;
begin
result := FOwner.DiskPath;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_ExternalFileAttributes: TFileAttributes;
begin
result := TFileAttributes(FOwner.ExternalFileAttributes);
end;
{------------------------------------------------------------------------------}
procedure TGzipItem.Set_ExternalFileAttributes(Value: TFileAttributes);
begin
FOwner.ExternalFileAttributes := LongInt(Value);
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_FileName: WideString;
begin
result := FOwner.FileName;
end;
{------------------------------------------------------------------------------}
procedure TGzipItem.Set_FileName(const Value: WideString);
begin
FOwner.FileName := Value;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_IsEncrypted: WordBool;
begin
result := FOwner.IsEncrypted;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_LastModFileDateTime: TDateTime;
begin
result := FileDateToDateTime((FOwner.LastModFileDate shl 16) + FOwner.LastModFileTime);
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_StoredPath: WideString;
begin
result := FOwner.StoredPath;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_Tagged: WordBool;
begin
result := FOwner.Tagged;
end;
{------------------------------------------------------------------------------}
procedure TGzipItem.Set_Tagged(Value: WordBool);
begin
FOwner.Tagged := Value;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_UnCompressedSize: Integer;
begin
result := FOwner.UncompressedSize;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_Password: WideString;
begin
{!!!}
//result := FOwner.Password;
end;
{------------------------------------------------------------------------------}
procedure TGzipItem.Set_Password(const Value: WideString);
begin
{!!!}
//FOwner.Password := Value;
//FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
{IGZipItem}
{------------------------------------------------------------------------------}
function TGzipItem.Get_CompressionMethod: Byte;
begin
result := FOwner.CompressionMethod;
end;
{------------------------------------------------------------------------------}
procedure TGzipItem.Set_CompressionMethod(Value: Byte);
begin
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_ExtraField: WideString;
begin
result := '';
end;
{------------------------------------------------------------------------------}
procedure TGzipItem.Set_ExtraField(const Value: WideString);
begin
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_ExtraFlags: Byte;
begin
result := FOwner.ExtraFlags;
end;
{------------------------------------------------------------------------------}
procedure TGzipItem.Set_ExtraFlags(Value: Byte);
begin
FOwner.ExtraFlags := Value;
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_FileComment: WideString;
begin
result := WideString(FOwner.FileComment);
end;
{------------------------------------------------------------------------------}
procedure TGzipItem.Set_FileComment(const Value: WideString);
begin
FOwner.FileComment := AnsiString(Value);
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_FileSystem: TFileSystem;
begin
result := TFileSystem(FOwner.FileSystem);
end;
{------------------------------------------------------------------------------}
procedure TGzipItem.Set_FileSystem(Value: TFileSystem);
begin
FOwner.FileSystem := TAbGzFileSystem(Value);
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_Flags: Byte;
begin
result := FOwner.Flags;
end;
{------------------------------------------------------------------------------}
procedure TGzipItem.Set_Flags(Value: Byte);
begin
end;
{------------------------------------------------------------------------------}
function TGzipItem.Get_HeaderCRC: Integer;
begin
result := 0;
end;
{------------------------------------------------------------------------------}
end.
================================================
FILE: lib/abbrevia/source/COM/_TarItem.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
unit _TarItem;
interface
uses
ComObj, Abbrevia_TLB, AbTarTyp, AbZipKit;
type
TTarItem = class(TAutoIntfObject, ITarItem)
private
FOwner : TAbTarItem;
FParent : TAbZipKit;
public
constructor Create(AOwner : TAbTarItem; AParent : TAbZipKit);
protected
{IArchiveItem}
function Get_Action: TArchiveAction; safecall;
function Get_CompressedSize: Integer; safecall;
function Get_CRC32: Integer; safecall;
function Get_CRC32St: WideString; safecall;
function Get_DiskFileName: WideString; safecall;
function Get_DiskPath: WideString; safecall;
function Get_ExternalFileAttributes: TFileAttributes; safecall;
procedure Set_ExternalFileAttributes(Value: TFileAttributes); safecall;
function Get_FileName: WideString; safecall;
procedure Set_FileName(const Value: WideString); safecall;
function Get_IsEncrypted: WordBool; safecall;
function Get_LastModFileDateTime: TDateTime; safecall;
function Get_StoredPath: WideString; safecall;
function Get_Tagged: WordBool; safecall;
procedure Set_Tagged(Value: WordBool); safecall;
function Get_UnCompressedSize: Integer; safecall;
function Get_Password: WideString; safecall;
procedure Set_Password(const Value: WideString); safecall;
{ITarItem}
function Get_DevMajor: Integer; safecall;
procedure Set_DevMajor(Value: Integer); safecall;
function Get_DevMinor: Integer; safecall;
procedure Set_DevMinor(Value: Integer); safecall;
function Get_GroupID: Integer; safecall;
procedure Set_GroupID(Value: Integer); safecall;
function Get_GroupName: WideString; safecall;
procedure Set_GroupName(const Value: WideString); safecall;
function Get_LinkFlag: Byte; safecall;
procedure Set_LinkFlag(Value: Byte); safecall;
function Get_LinkName: WideString; safecall;
procedure Set_LinkName(const Value: WideString); safecall;
function Get_Mode: Integer; safecall;
procedure Set_Mode(Value: Integer); safecall;
function Get_UserID: Integer; safecall;
procedure Set_UserID(Value: Integer); safecall;
function Get_UserName: WideString; safecall;
procedure Set_UserName(const Value: WideString); safecall;
end;
implementation
uses
ComServ, {StStrL,} SysUtils;
{------------------------------------------------------------------------------}
constructor TTarItem.Create(AOwner : TAbTarItem; AParent : TAbZipKit);
begin
inherited Create(ComServer.TypeLib, ITarItem);
FOwner := AOwner;
FParent := AParent;
end;
{------------------------------------------------------------------------------}
{IArchiveItem}
{------------------------------------------------------------------------------}
function TTarItem.Get_Action: TArchiveAction;
begin
Result := TArchiveAction(FOwner.Action);
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_CompressedSize: Integer;
begin
result := FOwner.CompressedSize;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_CRC32: Integer;
begin
result := FOwner.CRC32;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_CRC32St: WideString;
begin
result := IntToHex(FOwner.CRC32, 8);
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_DiskFileName: WideString;
begin
result := FOwner.DiskFileName;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_DiskPath: WideString;
begin
result := FOwner.DiskPath;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_ExternalFileAttributes: TFileAttributes;
begin
result := TFileAttributes(FOwner.ExternalFileAttributes);
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_ExternalFileAttributes(Value: TFileAttributes);
begin
FOwner.ExternalFileAttributes := LongInt(Value);
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_FileName: WideString;
begin
result := FOwner.FileName;
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_FileName(const Value: WideString);
begin
FOwner.FileName := Value;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_IsEncrypted: WordBool;
begin
result := FOwner.IsEncrypted;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_LastModFileDateTime: TDateTime;
begin
result := FileDateToDateTime((FOwner.LastModFileDate shl 16) + FOwner.LastModFileTime);
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_StoredPath: WideString;
begin
result := FOwner.StoredPath;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_Tagged: WordBool;
begin
result := FOwner.Tagged;
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_Tagged(Value: WordBool);
begin
FOwner.Tagged := Value;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_UnCompressedSize: Integer;
begin
result := FOwner.UncompressedSize;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_Password: WideString;
begin
{!!!}
//result := FOwner.Password;
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_Password(const Value: WideString);
begin
{!!!}
//FOwner.Password := Value;
//FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
{ITarItem}
{------------------------------------------------------------------------------}
function TTarItem.Get_DevMajor: Integer;
begin
result := FOwner.DevMajor;
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_DevMajor(Value: Integer);
begin
FOwner.DevMajor := Value;
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_DevMinor: Integer;
begin
result := FOwner.DevMinor;
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_DevMinor(Value: Integer);
begin
FOwner.DevMinor := Value;
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_GroupID: Integer;
begin
result := FOwner.GroupID;
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_GroupID(Value: Integer);
begin
FOwner.GroupID := Value;
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_GroupName: WideString;
begin
result := FOwner.GroupName;
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_GroupName(const Value: WideString);
begin
FOwner.GroupName := Value;
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_LinkFlag: Byte;
begin
result := Byte(FOwner.LinkFlag);
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_LinkFlag(Value: Byte);
begin
FOwner.LinkFlag := AnsiChar(Value);
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_LinkName: WideString;
begin
result := FOwner.LinkName;
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_LinkName(const Value: WideString);
begin
FOwner.LinkName := Value;
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_Mode: Integer;
begin
result := FOwner.Mode;
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_Mode(Value: Integer);
begin
FOwner.Mode := Value;
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_UserID: Integer;
begin
result := FOwner.UserID;
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_UserID(Value: Integer);
begin
FOwner.UserID := Value;
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TTarItem.Get_UserName: WideString;
begin
result := FOwner.UserName;
end;
{------------------------------------------------------------------------------}
procedure TTarItem.Set_UserName(const Value: WideString);
begin
FOwner.UserName := Value;
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
end.
================================================
FILE: lib/abbrevia/source/COM/_ZipItem.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
unit _ZipItem;
interface
uses
ComObj, Abbrevia_TLB, AbZipTyp, AbZipKit;
type
TZipItem = class(TAutoIntfObject, IZipItem)
private
FOwner : TAbZipItem;
FParent : TAbZipKit;
public
constructor Create(AOwner : TAbZipItem; AParent : TAbZipKit);
protected
{IArchiveItem}
function Get_Action: TArchiveAction; safecall;
function Get_CompressedSize: Integer; safecall;
function Get_CRC32: Integer; safecall;
function Get_CRC32St: WideString; safecall;
function Get_DiskFileName: WideString; safecall;
function Get_DiskPath: WideString; safecall;
function Get_ExternalFileAttributes: TFileAttributes; safecall;
procedure Set_ExternalFileAttributes(Value: TFileAttributes); safecall;
function Get_FileName: WideString; safecall;
procedure Set_FileName(const Value: WideString); safecall;
function Get_IsEncrypted: WordBool; safecall;
function Get_LastModFileDateTime: TDateTime; safecall;
function Get_StoredPath: WideString; safecall;
function Get_Tagged: WordBool; safecall;
procedure Set_Tagged(Value: WordBool); safecall;
function Get_UnCompressedSize: Integer; safecall;
function Get_Password: WideString; safecall;
procedure Set_Password(const Value: WideString); safecall;
{IZipItem}
function Get_CompressionMethod: TZipCompressionMethod; safecall;
function Get_CompressionRatio: Double; safecall;
function Get_DeflateOption: TZipDeflateOption; safecall;
function Get_DictionarySize: TZipDictionarySize; safecall;
function Get_DiskNumberStart: Integer; safecall;
function Get_ExtraField: WideString; safecall;
procedure Set_ExtraField(const Value: WideString); safecall;
function Get_FileComment: WideString; safecall;
procedure Set_FileComment(const Value: WideString); safecall;
function Get_InternalFileAttributes: Integer; safecall;
procedure Set_InternalFileAttributes(Value: Integer); safecall;
function Get_VersionMadeBy: Integer; safecall;
function Get_VersionNeededToExtract: Integer; safecall;
end;
implementation
uses
ComServ, SysUtils;
{------------------------------------------------------------------------------}
constructor TZipItem.Create(AOwner : TAbZipItem; AParent : TAbZipKit);
begin
inherited Create(ComServer.TypeLib, IZipItem);
FOwner := AOwner;
FParent := AParent;
end;
{------------------------------------------------------------------------------}
{IArchiveItem}
{------------------------------------------------------------------------------}
function TZipItem.Get_Action: TArchiveAction;
begin
Result := TArchiveAction(FOwner.Action);
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_CompressedSize: Integer;
begin
result := FOwner.CompressedSize;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_CRC32: Integer;
begin
result := FOwner.CRC32;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_CRC32St: WideString;
begin
result := IntToHex(FOwner.CRC32, 8);
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_DiskFileName: WideString;
begin
result := FOwner.DiskFileName;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_DiskPath: WideString;
begin
result := FOwner.DiskPath;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_ExternalFileAttributes: TFileAttributes;
begin
result := TFileAttributes(FOwner.ExternalFileAttributes);
end;
{------------------------------------------------------------------------------}
procedure TZipItem.Set_ExternalFileAttributes(Value: TFileAttributes);
begin
FOwner.ExternalFileAttributes := LongInt(Value);
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_FileName: WideString;
begin
result := FOwner.FileName;
end;
{------------------------------------------------------------------------------}
procedure TZipItem.Set_FileName(const Value: WideString);
begin
FOwner.FileName := Value;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_IsEncrypted: WordBool;
begin
result := FOwner.IsEncrypted;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_LastModFileDateTime: TDateTime;
begin
result := FileDateToDateTime((FOwner.LastModFileDate shl 16) + FOwner.LastModFileTime);
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_StoredPath: WideString;
begin
result := FOwner.StoredPath;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_Tagged: WordBool;
begin
result := FOwner.Tagged;
end;
{------------------------------------------------------------------------------}
procedure TZipItem.Set_Tagged(Value: WordBool);
begin
FOwner.Tagged := Value;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_UnCompressedSize: Integer;
begin
result := FOwner.UncompressedSize;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_Password: WideString;
begin
Result := WideString(FParent.Password);
end;
{------------------------------------------------------------------------------}
procedure TZipItem.Set_Password(const Value: WideString);
begin
FParent.Password := AnsiString(Value);
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
{IZipItem}
{------------------------------------------------------------------------------}
function TZipItem.Get_CompressionMethod: TZipCompressionMethod;
begin
Result := TZipCompressionMethod(FOwner.CompressionMethod);
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_CompressionRatio: Double;
begin
result := FOwner.CompressionRatio;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_DeflateOption: TZipDeflateOption;
begin
result := TZipDeflateOption(FOwner.DeflationOption);
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_DictionarySize: TZipDictionarySize;
begin
result := TZipDictionarySize(FOwner.DictionarySize);
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_DiskNumberStart: Integer;
begin
result := FOwner.DiskNumberStart;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_ExtraField: WideString;
begin
result := '';
end;
{------------------------------------------------------------------------------}
procedure TZipItem.Set_ExtraField(const Value: WideString);
begin
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_FileComment: WideString;
begin
result := WideString(FOwner.FileComment);
end;
{------------------------------------------------------------------------------}
procedure TZipItem.Set_FileComment(const Value: WideString);
begin
FOwner.FileComment := AnsiString(Value);
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_InternalFileAttributes: Integer;
begin
result := FOwner.InternalFileAttributes;
end;
{------------------------------------------------------------------------------}
procedure TZipItem.Set_InternalFileAttributes(Value: Integer);
begin
FOwner.InternalFileAttributes := Value;
FParent.ZipArchive.IsDirty := True;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_VersionMadeBy: Integer;
begin
result := FOwner.VersionMadeBy;
end;
{------------------------------------------------------------------------------}
function TZipItem.Get_VersionNeededToExtract: Integer;
begin
result := FOwner.VersionNeededToExtract;
end;
{------------------------------------------------------------------------------}
end.
================================================
FILE: lib/abbrevia/source/COM/_ZipKit.pas
================================================
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
unit _ZipKit;
interface
uses
ComObj, Classes, Windows, Abbrevia_TLB, ActiveX, axctrls, AbZipKit, AbArcTyp,
AbUtils, _ZipItem, _GZipItem, _TarItem, AbZipTyp, AbTarTyp, AbGzTyp,
AbConst, AbBrowse;
type
{$IFNDEF VER130}{$WARN SYMBOL_PLATFORM OFF}{$ENDIF}
TZipKit = class(TAutoObject, IConnectionPointContainer, IEnumVariant, IZipKit)
private
{private declarations}
FConnectionPoints : TConnectionPoints;
FEvents : IZipKitEvents;
FOwner : TAbZipKit;
FEnumPos : Integer;
{Events for FOwner}
procedure _OnArchiveItemProgress(Sender : TObject; Item : TAbArchiveItem; Progress : Byte; var Abort : Boolean);
procedure _OnArchiveProgress(Sender : TObject; Progress : Byte; var Abort : Boolean);
procedure _OnChange(Sender : TObject);
procedure _OnConfirmOverwrite(var Name : string; var confirm : Boolean);
procedure _OnConfirmProcessItem(Sender : TObject; Item : TAbArchiveItem; ProcessType : TAbProcessType; var Confirm : Boolean);
procedure _OnConfirmSave(Sender : TObject; var Confirm : Boolean);
procedure _OnLoad(Sender : TObject);
procedure _OnNeedPassword(Sender : TObject; var NewPassword : AnsiString);
procedure _OnProcessItemFailure(Sender : TObject; Item : TAbArchiveItem; ProcessType : TAbProcessType; ErrorClass : TAbErrorClass; ErrorCode : Integer);
procedure _OnRequestBlankDisk(Sender : TObject; var Abort : Boolean);
procedure _OnRequestImage(Sender : TObject; ImageNumber : Integer; var ImageName : string; var Abort : Boolean);
procedure _OnRequestLastDisk(Sender : TObject; var Abort : Boolean);
procedure _OnRequestNthDisk(Sender : TObject; DiskNumber : Byte; var Abort : Boolean);
procedure _OnSave(Sender : TObject);
public
procedure Initialize; override;
destructor Destroy; override;
protected
{IConnectionPointContainer}
property ConnectionPoints: TConnectionPoints read FConnectionPoints
implements IConnectionPointContainer;
procedure EventSinkChanged(const EventSink: IUnknown); override;
{IEnumVariant}
function Next(celt: LongWord; var rgvar : OleVariant; out pceltFetched: LongWord): HResult; stdcall;
function Skip(celt: LongWord): HResult; stdcall;
function Reset: HResult; stdcall;
function Clone(out Enum: IEnumVariant): HResult; stdcall;
{IZipKit}
procedure Add(const FileMask: WideString; const ExclusionMask: WideString; SearchAttr: Integer); safecall;
procedure AddFromStream(const FileName: WideString; Stream: OleVariant); safecall;
function Get_AutoSave: WordBool; safecall;
procedure Set_AutoSave(Value: WordBool); safecall;
function Get_BaseDirectory: WideString; safecall;
procedure Set_BaseDirectory(const Value: WideString); safecall;
procedure ClearTags; safecall;
function Get_CompressionMethodToUse: TZipSupportMethod; safecall;
procedure Set_CompressionMethodToUse(Value: TZipSupportMethod); safecall;
function Get_Count: Integer; safecall;
function Get_DeflateOption: TZipDeflateOption; safecall;
procedure Set_DeflateOption(Value: TZipDeflateOption); safecall;
procedure Delete(const FileMask: WideString; const ExclusionMask: WideString); safecall;
procedure DeleteAt(Index: Integer); safecall;
procedure DeleteTaggedItems; safecall;
function Get_DOSMode: WordBool; safecall;
procedure Set_DOSMode(Value: WordBool); safecall;
procedure Extract(const FileMask: WideString; const ExclusionMask: WideString); safecall;
procedure ExtractAt(Index: Integer; const NewName: WideString); safecall;
function Get_ExtractOptions: TZipExtractOptions; safecall;
procedure Set_ExtractOptions(Value: TZipExtractOptions); safecall;
procedure ExtractTaggedItems; safecall;
function Get_FileName: WideString; safecall;
procedure Set_FileName(const Value: WideString); safecall;
function Find(const FileName: WideString): Integer; safecall;
procedure Freshen(const FileMask: WideString; const ExclusionMask: WideString); safecall;
procedure FreshenTaggedItems; safecall;
function Get_Item(Index: Integer): IDispatch; safecall;
function Get_LogFile: WideString; safecall;
procedure Set_LogFile(const Value: WideString); safecall;
function Get_Logging: WordBool; safecall;
procedure Set_Logging(Value: WordBool); safecall;
function Get_Password: WideString; safecall;
procedure Set_Password(const Value: WideString); safecall;
function Get_PasswordRetries: Byte; safecall;
procedure Set_PasswordRetries(Value: Byte); safecall;
procedure Replace(const FileMask: WideString); safecall;
procedure Save; safecall;
function Get_Spanned: WordBool; safecall;
function Get_SpanningThreshold: Integer; safecall;
procedure Set_SpanningThreshold(Value: Integer); safecall;
function Get_Status: TArchiveStatus; safecall;
function Get_StoreOptions: TStoreOptions; safecall;
procedure Set_StoreOptions(Value: TStoreOptions); safecall;
procedure TagItems(const FileMask: WideString); safecall;
function Get_TempDirectory: WideString; safecall;
procedure Set_TempDirectory(const Value: WideString); safecall;
procedure TestTaggedItems; safecall;
procedure UntagItems(const FileMask: WideString); safecall;
function Get_ZipFileComment: WideString; safecall;
procedure Set_ZipFileComment(const Value: WideString); safecall;
function License(const Key: WideString): WordBool; safecall;
function Get__NewEnum: IUnknown; safecall;
function ExtractToStream(const FileName: WideString): OleVariant; safecall;
function Get_CompressionType: TArchiveType; safecall;
procedure Set_CompressionType(Value: TArchiveType); safecall;
function Get_TarAutoHandle: WordBool; safecall;
procedure Set_TarAutoHandle(Value: WordBool); safecall;
end;
implementation
uses
ComServ;
{------------------------------------------------------------------------------}
{IConnectionPointContainer}
{------------------------------------------------------------------------------}
procedure TZipKit.EventSinkChanged(const EventSink: IUnknown);
begin
FEvents := EventSink as IZipKitEvents;
end;
{------------------------------------------------------------------------------}
{IEnumVariant}
{------------------------------------------------------------------------------}
function TZipKit.Next(celt: LongWord; var rgvar : OleVariant; out pceltFetched: LongWord): HResult; stdcall;
var
V : OleVariant;
I : Integer;
begin
Result := S_FALSE;
try
if @pceltFetched <> nil then
pceltFetched := 0;
for I := 0 to celt - 1 do begin
if FEnumPos >= FOwner.Count then begin
FEnumPos := 0;
Exit;
end;
V := Get_Item(FEnumPos);
PVariantArgList(@rgvar)[I] := TVariantArg(V);
{ Prevent COM garbage collection }
TVarData(V).VType := varEmpty;
TVarData(V).VInteger := 0;
Inc(FEnumPos);
if @pceltFetched <> nil then
Inc(pceltFetched);
end;
except
end;
if (@pceltFetched = nil) or (pceltFetched = celt) then
Result := S_OK;
end;
{------------------------------------------------------------------------------}
function TZipKit.Skip(celt: LongWord): HResult;
begin
Inc(FEnumPos, celt);
Result := S_OK;
end;
{------------------------------------------------------------------------------}
function TZipKit.Reset: HResult;
begin
FEnumPos := 0;
Result := S_OK;
end;
{------------------------------------------------------------------------------}
function TZipKit.Clone(out Enum: IEnumVariant): HResult;
begin
Enum := nil;
Result := S_OK;
try
Enum := Self.Create;
TZipKit(Enum).FOwner := FOwner;
except
Result := E_OUTOFMEMORY;
end;
end;
{------------------------------------------------------------------------------}
{IZipKit}
{------------------------------------------------------------------------------}
procedure TZipKit.Add(const FileMask: WideString; const ExclusionMask: WideString; SearchAttr: Integer);
begin
FOwner.AddFilesEx(FileMask, ExclusionMask, SearchAttr);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.AddFromStream(const FileName: WideString; Stream: OleVariant);
var
InStream : TMemoryStream;
Info : array of Byte;
begin
Info := nil;
InStream := TMemoryStream.Create;
try
Info := Stream;
InStream.Write(Info[0], Length(Info));
InStream.Position := 0;
FOwner.AddFromStream(FileName, InStream);
finally
InStream.Free;
end;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_AutoSave: WordBool;
begin
Result := FOwner.AutoSave;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_AutoSave(Value: WordBool);
begin
FOwner.AutoSave := Value;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_BaseDirectory: WideString;
begin
Result := FOwner.BaseDirectory;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_BaseDirectory(const Value: WideString);
begin
FOwner.BaseDirectory := Value;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.ClearTags;
begin
FOwner.ClearTags;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_CompressionMethodToUse: TZipSupportMethod;
begin
Result := TZipCompressionMethod(FOwner.CompressionMethodToUse);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_CompressionMethodToUse(Value: TZipSupportMethod);
begin
FOwner.CompressionMethodToUse := TAbZipSupportedMethod(Value);
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_Count: Integer;
begin
Result := FOwner.Count;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_DeflateOption: TZipDeflateOption;
begin
Result := TZipDeflateOption(FOwner.DeflationOption);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_DeflateOption(Value: TZipDeflateOption);
begin
FOwner.DeflationOption := TAbZipDeflationOption(Value);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Delete(const FileMask: WideString; const ExclusionMask: WideString);
begin
FOwner.DeleteFilesEx(FileMask, ExclusionMask);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.DeleteAt(Index: Integer);
begin
FOwner.DeleteAt(Index);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.DeleteTaggedItems;
begin
FOwner.DeleteTaggedItems;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_DOSMode: WordBool;
begin
Result := FOwner.DOSMode;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_DOSMode(Value: WordBool);
begin
FOwner.DOSMode := Value;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Extract(const FileMask: WideString; const ExclusionMask: WideString);
begin
FOwner.ExtractFilesEx(FileMask, ExclusionMask);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.ExtractAt(Index: Integer; const NewName: WideString);
begin
FOwner.ExtractAt(Index, NewName);
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_ExtractOptions: TZipExtractOptions;
begin
Result := 0;
if TAbExtractOption(eoCreateDirs) in FOwner.ExtractOptions then
Result := Result + TZipExtractOptions(eoCreateDirs);
if TAbExtractOption(eoRestorePath) in FOwner.ExtractOptions then
Result := Result + TZipExtractOptions(eoRestorePath);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_ExtractOptions(Value: TZipExtractOptions);
var
TempOptions : TAbExtractOptions;
begin
TempOptions := [];
if (Value or Abbrevia_TLB.eoCreateDirs) = Value then
Include(TempOptions, AbArcTyp.eoCreateDirs);
if (Value or Abbrevia_TLB.eoRestorePath) = Value then
Include(TempOptions, AbArcTyp.eoRestorePath);
FOwner.ExtractOptions := TempOptions
end;
{------------------------------------------------------------------------------}
procedure TZipKit.ExtractTaggedItems;
begin
FOwner.ExtractTaggedItems;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_FileName: WideString;
begin
Result := FOwner.FileName;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_FileName(const Value: WideString);
begin
FOwner.FileName := Value;
end;
{------------------------------------------------------------------------------}
function TZipKit.Find(const FileName: WideString): Integer;
begin
Result := FOwner.FindFile(FileName);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Freshen(const FileMask: WideString; const ExclusionMask: WideString);
begin
FOwner.FreshenFilesEx(FileMask, ExclusionMask);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.FreshenTaggedItems;
begin
FOwner.FreshenTaggedItems;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_Item(Index: Integer): IDispatch;
begin
Result := TZipItem.Create(FOwner.Items[Index], FOwner);
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_LogFile: WideString;
begin
Result := FOwner.LogFile;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_LogFile(const Value: WideString);
begin
FOwner.LogFile := Value;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_Logging: WordBool;
begin
Result := FOwner.Logging;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_Logging(Value: WordBool);
begin
FOwner.Logging := Value;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_Password: WideString;
begin
Result := WideString(FOwner.Password);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_Password(const Value: WideString);
begin
FOwner.Password := AnsiString(Value);
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_PasswordRetries: Byte;
begin
Result := FOwner.PasswordRetries;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_PasswordRetries(Value: Byte);
begin
FOwner.PasswordRetries := Value;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Replace(const FileMask: WideString);
begin
FOwner.Replace(FOwner.Items[FOwner.FindFile(FileMask)]);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Save;
begin
FOwner.Save;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_Spanned: WordBool;
begin
Result := FOwner.Spanned;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_SpanningThreshold: Integer;
begin
Result := FOwner.SpanningThreshold;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_SpanningThreshold(Value: Integer);
begin
FOwner.SpanningThreshold := Value;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_Status: TArchiveStatus;
begin
Result := TArchiveStatus(FOwner.Status);
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_StoreOptions: TStoreOptions;
begin
Result := 0;
if TAbStoreOption(soStripDrive) in FOwner.StoreOptions then
Result := Result + TStoreOptions(soStripDrive);
if TAbStoreOption(soStripPath) in FOwner.StoreOptions then
Result := Result + TStoreOptions(soStripPath);
if TAbStoreOption(soRemoveDots) in FOwner.StoreOptions then
Result := Result + TStoreOptions(soRemoveDots);
if TAbStoreOption(soRecurse) in FOwner.StoreOptions then
Result := Result + TStoreOptions(soRecurse);
if TAbStoreOption(soFreshen) in FOwner.StoreOptions then
Result := Result + TStoreOptions(soFreshen);
if TAbStoreOption(soReplace) in FOwner.StoreOptions then
Result := Result + TStoreOptions(soReplace);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_StoreOptions(Value: TStoreOptions);
var
TempOptions : TAbStoreOptions;
begin
TempOptions := [];
if (Value or Abbrevia_TLB.soStripDrive) = Value then
Include(TempOptions, AbArcTyp.soStripDrive);
if (Value or Abbrevia_TLB.soStripPath) = Value then
Include(TempOptions, AbArcTyp.soStripPath);
if (Value or Abbrevia_TLB.soRemoveDots) = Value then
Include(TempOptions, AbArcTyp.soRemoveDots);
if (Value or Abbrevia_TLB.soRecurse) = Value then
Include(TempOptions, AbArcTyp.soRecurse);
if (Value or Abbrevia_TLB.soFreshen) = Value then
Include(TempOptions, AbArcTyp.soFreshen);
if (Value or Abbrevia_TLB.soReplace) = Value then
Include(TempOptions, AbArcTyp.soReplace);
FOwner.StoreOptions := TempOptions
end;
{------------------------------------------------------------------------------}
procedure TZipKit.TagItems(const FileMask: WideString);
begin
FOwner.TagItems(FileMask);
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_TempDirectory: WideString;
begin
Result := FOwner.TempDirectory;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_TempDirectory(const Value: WideString);
begin
FOwner.TempDirectory := Value;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.TestTaggedItems;
begin
FOwner.TestTaggedItems;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.UntagItems(const FileMask: WideString);
begin
FOwner.UnTagItems(FileMask);
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_ZipFileComment: WideString;
begin
Result := WideString(FOwner.ZipFileComment);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_ZipFileComment(const Value: WideString);
begin
FOwner.ZipfileComment := AnsiString(Value);
end;
{------------------------------------------------------------------------------}
function TZipKit.License(const Key: WideString): WordBool;
begin
Result := True;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get__NewEnum: IUnknown;
begin
Result := Self;
end;
{------------------------------------------------------------------------------}
function TZipKit.ExtractToStream(const FileName: WideString): OleVariant;
var
Stream : TMemoryStream;
Info : array of Byte;
begin
Stream := TMemoryStream.Create;
try
FOwner.ExtractToStream(FileName, Stream);
Stream.Position := 0;
SetLength(Info, Stream.Size);
Stream.Read(Info[0], Stream.Size);
Result := Info;
finally
Stream.Free;
end;
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_CompressionType: TArchiveType;
begin
Result := TArchiveType((FOwner as TAbBaseBrowser).ArchiveType);
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_CompressionType(Value: TArchiveType);
begin
(FOwner as TAbBaseBrowser).ArchiveType := TAbArchiveType(ord(Value));
end;
{------------------------------------------------------------------------------}
function TZipKit.Get_TarAutoHandle: WordBool;
begin
Result := FOwner.TarAutoHandle;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Set_TarAutoHandle(Value: WordBool);
begin
FOwner.TarAutoHandle := Value;
end;
{------------------------------------------------------------------------------}
{TZipKit Events}
{------------------------------------------------------------------------------}
procedure TZipKit._OnArchiveItemProgress(Sender : TObject; Item : TAbArchiveItem;
Progress : Byte; var Abort : Boolean);
var
FAbort : WordBool;
begin
FAbort := Abort;
if Assigned(FEvents) then begin
if ((FOwner as TAbBaseBrowser).ArchiveType = atZip) then
FEvents.OnArchiveItemProgress(TZipItem.Create(TAbZipItem(Item), FOwner),
Progress, FAbort)
else if ((FOwner as TAbBaseBrowser).ArchiveType = atTar) then
FEvents.OnArchiveItemProgress(TTarItem.Create(TAbTarItem(Item), FOwner),
Progress, FAbort)
else if ((FOwner as TAbBaseBrowser).ArchiveType = atGZip) then
FEvents.OnArchiveItemProgress(TGZipItem.Create(TAbGZipItem(Item), FOwner),
Progress, FAbort);
end;
Abort := FAbort;
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnArchiveProgress(Sender : TObject; Progress : Byte;
var Abort : Boolean);
var
FAbort : WordBool;
begin
FAbort := Abort;
if Assigned(FEvents) then
FEvents.OnArchiveProgress(Progress, FAbort);
Abort := FAbort;
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnChange(Sender : TObject);
begin
if Assigned(FEvents) then
FEvents.OnChange;
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnConfirmOverwrite(var Name : string; var confirm : Boolean);
var
FConfirm : WordBool;
FName : WideString;
begin
FConfirm := Confirm;
FName := Name;
if Assigned(FEvents) then
FEvents.OnConfirmOverwrite(FName, FConfirm);
Name := FName;
Confirm := FConfirm;
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnConfirmProcessItem(Sender : TObject; Item : TAbArchiveItem;
ProcessType : TAbProcessType; var Confirm : Boolean);
var
FConfirm : WordBool;
begin
FConfirm := Confirm;
if Assigned(FEvents) then begin
if ((FOwner as TAbBaseBrowser).ArchiveType = atZip) then
FEvents.OnConfirmProcessItem(TZipItem.Create(TAbZipItem(Item), FOwner),
TProcessType(ProcessType), FConfirm)
else if ((FOwner as TAbBaseBrowser).ArchiveType = atTar) then
FEvents.OnConfirmProcessItem(TTarItem.Create(TAbTarItem(Item), FOwner),
TProcessType(ProcessType), FConfirm)
else if ((FOwner as TAbBaseBrowser).ArchiveType = atGZip) then
FEvents.OnConfirmProcessItem(TGZipItem.Create(TAbGZipItem(Item), FOwner),
TProcessType(ProcessType), FConfirm);
end;
Confirm := FConfirm
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnConfirmSave(Sender : TObject; var Confirm : Boolean);
var
FConfirm : WordBool;
begin
FConfirm := Confirm;
if Assigned(FEvents) then
FEvents.OnConfirmSave(FConfirm);
Confirm := FConfirm;
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnLoad(Sender : TObject);
begin
if Assigned(FEvents) then
FEvents.OnLoad;
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnNeedPassword(Sender : TObject; var NewPassword : AnsiString);
var
FNewPassword : WideString;
begin
FNewPassword := WideString(NewPassword);
if Assigned(FEvents) then
FEvents.OnNeedPassword(FNewPassword);
NewPassword := AnsiString(FNewPassword);
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnProcessItemFailure(Sender : TObject; Item : TAbArchiveItem;
ProcessType : TAbProcessType; ErrorClass : TAbErrorClass;
ErrorCode : Integer);
begin
if Assigned(FEvents) then begin
if ((FOwner as TAbBaseBrowser).ArchiveType = atZip) then
FEvents.OnProcessItemFailure(TZipItem.Create(TAbZipItem(Item), FOwner),
TProcessType(ProcessType), TErrorClass(ErrorClass),
TErrorCode(ErrorCode), AbStrRes(ErrorCode))
else if ((FOwner as TAbBaseBrowser).ArchiveType = atTar) then
FEvents.OnProcessItemFailure(TTarItem.Create(TAbTarItem(Item), FOwner),
TProcessType(ProcessType), TErrorClass(ErrorClass),
TErrorCode(ErrorCode),AbStrRes(ErrorCode))
else if ((FOwner as TAbBaseBrowser).ArchiveType = atGZip) then
FEvents.OnProcessItemFailure(TGZipItem.Create(TAbGZipItem(Item), FOwner),
TProcessType(ProcessType), TErrorClass(ErrorClass),
TErrorCode(ErrorCode),AbStrRes(ErrorCode));
end;
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnRequestBlankDisk(Sender : TObject; var Abort : Boolean);
var
FAbort : WordBool;
begin
FAbort := Abort;
if Assigned(FEvents) then
FEvents.OnRequestBlankDisk(FAbort);
Abort := FAbort;
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnRequestImage(Sender : TObject; ImageNumber : Integer; var ImageName : string; var Abort : Boolean);
var
FImageName : WideString;
FAbort : WordBool;
begin
FImageName := ImageName;
FAbort := Abort;
if Assigned(FEvents) then
FEvents.OnRequestImage(ImageNumber, FImageName, FAbort);
Abort := FAbort;
ImageName := FImageName;
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnRequestLastDisk(Sender : TObject; var Abort : Boolean);
var
FAbort : WordBool;
begin
FAbort := Abort;
if Assigned(FEvents) then
FEvents.OnRequestLastDisk(FAbort);
Abort := FAbort;
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnRequestNthDisk(Sender : TObject; DiskNumber : Byte; var Abort : Boolean);
var
FAbort : WordBool;
begin
FAbort := Abort;
if Assigned(FEvents) then
FEvents.OnRequestNthDisk(DiskNumber, FAbort);
Abort := FAbort;
end;
{------------------------------------------------------------------------------}
procedure TZipKit._OnSave(Sender : TObject);
begin
if Assigned(FEvents) then
FEvents.OnSave;
end;
{------------------------------------------------------------------------------}
procedure TZipKit.Initialize;
begin
inherited Initialize;
FConnectionPoints := TConnectionPoints.Create(Self);
if AutoFactory.EventTypeInfo <> nil then
FConnectionPoints.CreateConnectionPoint(AutoFactory.EventIID,
ckSingle, EventConnect);
FOwner := AbZipKit.TAbZipKit.Create(nil);
FOwner.OnArchiveItemProgress := _OnArchiveItemProgress;
FOwner.OnArchiveProgress := _OnArchiveProgress;
FOwner.OnChange := _OnChange;
FOwner.OnConfirmOverwrite := _OnConfirmOverwrite;
FOwner.OnConfirmProcessItem := _OnConfirmProcessItem;
FOwner.OnConfirmSave := _OnConfirmSave;
FOwner.OnLoad := _OnLoad;
FOwner.OnNeedPassword := _OnNeedPassword;
FOwner.OnProcessItemFailure := _OnProcessItemFailure;
FOwner.OnRequestBlankDisk := _OnRequestBlankDisk;
FOwner.OnRequestImage := _OnRequestImage;
FOwner.OnRequestLastDisk := _OnRequestLastDisk;
FOwner.OnRequestNthDisk := _OnRequestNthDisk;
FOwner.OnSave := _OnSave;
FEnumPos := 0;
end;
{------------------------------------------------------------------------------}
destructor TZipKit.Destroy;
begin
FOwner.Free;
inherited Destroy;
end;
{------------------------------------------------------------------------------}
initialization
TAutoObjectFactory.Create(ComServer, TZipKit, Class_ZipKit, ciMultiInstance, tmBoth);
end.
================================================
FILE: lib/mte/CRC32.pas
================================================
unit CRC32;
interface
type
Long = record
LoWord: Word;
HiWord: Word;
end;
// exported functions
function FileCRC32(FileName: string): string;
function StrCRC32(input: string): string;
const
CRCPOLY = $EDB88320;
var
CRCTable: array[0..512] Of Longint;
implementation
{$WARNINGS OFF}
uses
SysUtils;
procedure BuildCRCTable;
var
i, j: Word;
r: Longint;
begin
FillChar(CRCTable, SizeOf(CRCTable), 0);
for i := 0 to 255 do
begin
r := i shl 1;
for j := 8 downto 0 do
if (r and 1) <> 0 then
r := (r Shr 1) xor CRCPOLY
else
r := r shr 1;
CRCTable[i] := r;
end;
end;
function RecountCRC(b: byte; CrcOld: Longint): Longint;
begin
RecountCRC := CRCTable[byte(CrcOld xor Longint(b))] xor ((CrcOld shr 8) and $00FFFFFF)
end;
function HextW(w: Word): string;
const
h: array[0..15] Of char = '0123456789ABCDEF';
begin
HextW := '';
HextW := h[Hi(w) shr 4] + h[Hi(w) and $F] + h[Lo(w) shr 4]+h[Lo(w) and $F];
end;
function HextL(l: Longint): string;
begin
with Long(l) do
HextL := HextW(HiWord) + HextW(LoWord);
end;
function FileCRC32(FileName: string): string;
var
Buffer: PChar;
F: File of Byte;
B: array[0..255] of Byte;
CRC: Longint;
e, i: Integer;
begin
BuildCRCTable;
CRC := $FFFFFFFF;
AssignFile(F, FileName);
FileMode := 0;
Reset(F);
GetMem(Buffer, SizeOf(B));
repeat
FillChar(B, SizeOf(B), 0);
BlockRead(F, B, SizeOf(B), e);
for i := 0 to (e-1) do
CRC := RecountCRC(b[i], CRC);
until (e < 255) or (IOresult <> 0);
FreeMem(Buffer, SizeOf(B));
CloseFile(F);
CRC := Not CRC;
Result := HextL(CRC);
end;
function StrCRC32(input: string): string;
var
B: TArray;
CRC: Longint;
i: Integer;
begin
BuildCRCTable;
CRC := $FFFFFFFF;
B := TEncoding.UTF8.GetBytes(input);
for i := 0 to Pred(Length(B)) do
CRC := RecountCRC(B[i], CRC);
CRC := Not CRC;
Result := HextL(CRC);
end;
end.
================================================
FILE: lib/mte/RttiIni.pas
================================================
unit RttiIni;
interface
uses
SysUtils, Classes, Rtti, TypInfo, IniFiles;
type
IniSectionAttribute = class(TCustomAttribute)
private
FSection: string;
public
constructor Create(const aSection: String);
property Section: string read FSection write FSection;
end;
TRttiIni = class (TObject)
private
class function ReadValue(section: string; var ini: TMemIniFile;
field: TRttiField): TValue;
class procedure WriteValue(section: string; var ini: TMemIniFile;
field: TRttiField; aValue: TValue);
class function GetIniAttribute(Obj: TRttiObject): IniSectionAttribute;
public
class procedure Load(filename: string; obj: TObject);
class procedure Save(filename: string; obj: TObject);
end;
implementation
{ TIniSection }
constructor IniSectionAttribute.Create(const aSection: String);
begin
FSection := aSection;
end;
{ TIniPersist }
class function TRttiIni.GetIniAttribute(Obj: TRttiObject): IniSectionAttribute;
var
Attr: TCustomAttribute;
begin
for Attr in Obj.GetAttributes do begin
if Attr is IniSectionAttribute then
exit(IniSectionAttribute(Attr));
end;
result := nil;
end;
class procedure TRttiIni.Load(filename: string; obj: TObject);
var
ctx: TRttiContext;
objType: TRttiType;
Field: TRttiField;
IniSection: IniSectionAttribute;
Ini: TMemIniFile;
CurrentSection: string;
value: TValue;
begin
ctx := TRttiContext.Create;
try
Ini := TMemIniFile.Create(FileName);
try
objType := ctx.GetType(Obj.ClassInfo);
for Field in objType.GetFields do begin
IniSection := GetIniAttribute(Field);
if Assigned(IniSection) then
CurrentSection := IniSection.Section;
value := ReadValue(CurrentSection, ini, Field);
if not value.IsEmpty then
field.SetValue(obj, value);
end;
finally
Ini.Free;
end;
finally
ctx.Free;
end;
end;
class function TRttiIni.ReadValue(section: string; var ini: TMemIniFile;
field: TRttiField): TValue;
var
fieldType: string;
begin
Result := TValue.Empty;
fieldType := field.FieldType.Name;
// exit if value doesn't exist in ini being loaded
// this allows us to use default values from the object's constructor
if not ini.ValueExists(section, field.Name) then
exit;
// load string, Integer, and Boolean fields from ini
if fieldType = 'string' then
Result := TValue.From(ini.ReadString(section, field.Name, ''))
else if fieldType = 'Integer' then
Result := TValue.From(ini.ReadInteger(section, field.Name, 0))
else if fieldType = 'Int64' then
Result := TValue.From(ini.ReadInteger(section, field.Name, 0))
else if fieldType = 'TDateTime' then
Result := TValue.From(ini.ReadFloat(section, field.Name, 0))
else if fieldType = 'Boolean' then
Result := TValue.From(ini.ReadBool(section, field.Name, false));
end;
class procedure TRttiIni.WriteValue(section: string; var ini: TMemIniFile;
field: TRttiField; aValue: TValue);
var
fieldType: string;
begin
fieldType := field.FieldType.Name;
if fieldType = 'string' then
ini.WriteString(section, field.Name, aValue.AsString)
else if fieldType = 'Integer' then
ini.WriteInteger(section, field.Name, aValue.AsInteger)
else if fieldType = 'Int64' then
ini.WriteInteger(section, field.Name, aValue.AsInt64)
else if fieldType = 'TDateTime' then
ini.WriteFloat(section, field.Name, aValue.AsType)
else if fieldType = 'Boolean' then
ini.WriteBool(section, field.Name, aValue.AsBoolean)
end;
class procedure TRttiIni.Save(filename: string; obj: TObject);
var
ctx: TRttiContext;
objType: TRttiType;
field: TRttiField;
IniSection: IniSectionAttribute;
ini: TMemIniFile;
CurrentSection: string;
begin
ctx := TRttiContext.Create;
try
ini := TMemIniFile.Create(FileName);
try
objType := ctx.GetType(Obj.ClassInfo);
for field in objType.GetFields do begin
IniSection := GetIniAttribute(Field);
if Assigned(IniSection) then
CurrentSection := IniSection.Section;
WriteValue(CurrentSection, ini, field, Field.GetValue(obj));
end;
finally
Ini.UpdateFile;
Ini.Free;
end;
finally
ctx.Free;
end;
end;
end.
================================================
FILE: lib/mte/RttiJson.pas
================================================
unit RttiJson;
interface
uses
SysUtils, Rtti,
// superobject json library
superobject;
type
TRttiJson = class (TObject)
public
class function ToJson(obj: TObject): string;
class function FromJson(json: string; classType: TClass): TObject;
end;
implementation
class function TRttiJson.ToJson(obj: TObject): string;
var
rtype: TRTTIType;
field: TRTTIField;
fieldType: string;
jsonObj: ISuperObject;
date: TDateTime;
begin
jsonObj := SO;
rtype := TRTTIContext.Create.GetType(obj.ClassType);
// loop through fields
for field in rType.GetFields do begin
fieldType := field.FieldType.ToString;
// handle datatypes I use
if (fieldType = 'string') then
jsonObj.S[field.Name] := field.GetValue(obj).ToString
else if (fieldType = 'Integer') then
jsonObj.I[field.Name] := field.GetValue(obj).AsInteger
else if (fieldType = 'TDateTime') then begin
date := StrToFloat(field.GetValue(obj).ToString);
jsonObj.S[field.Name] := DateTimeToStr(date);
end;
end;
Result := jsonObj.AsJSon;
end;
{
Example usage:
report := TReport(FromJson(reportJson, TReport));
}
class function TRttiJson.FromJson(json: string; classType: TClass): TObject;
var
rtype: TRTTIType;
field: TRTTIField;
fieldType: string;
context: TRTTIContext;
jsonObj: ISuperObject;
date: TDateTime;
begin
jsonObj := SO(PChar(json));
context := TRTTIContext.Create;
rtype := context.GetType(classType);
Result := classType.Create;
// loop through fields
for field in rType.GetFields do begin
fieldType := field.FieldType.ToString;
// handle datatypes I use
if (fieldType = 'string') then
field.SetValue(Result, jsonObj.S[field.Name])
else if (fieldType = 'Integer') then
field.SetValue(Result, jsonObj.I[field.Name])
else if (fieldType = 'TDateTime') then begin
date := StrToDateTime(jsonObj.S[field.Name]);
field.SetValue(Result, TValue.From(date));
end;
end;
context.Free;
end;
end.
================================================
FILE: lib/mte/RttiTranslation.pas
================================================
unit RttiTranslation;
interface
uses
SysUtils, Classes, StdCtrls, ComCtrls, Buttons, Menus, Rtti, TypInfo;
type
FormPrefixAttribute = class(TCustomAttribute)
private
FPrefix: string;
public
constructor Create(const aPrefix: String);
property Prefix: string read FPrefix write FPrefix;
end;
FormSectionAttribute = class(TCustomAttribute)
private
FSection: string;
public
constructor Create(const aSection: String);
property Section: string read FSection write FSection;
end;
TRttiTranslation = class (TObject)
private
class function ReadValue(section: string; var sl: TStringList;
field: TRttiField; subfield: string): string;
class procedure WriteValue(section: string; value: string; var sl: TStringList;
field: TRttiField; subfield: string);
class function GetPrefixAttribute(Obj: TRttiObject): FormPrefixAttribute;
class function GetSectionAttribute(Obj: TRttiObject): FormSectionAttribute;
public
class procedure Load(filename: string; obj: TObject); overload;
class procedure Load(var sl: TStringList; obj: TObject); overload;
class procedure Save(filename: string; obj: TObject);
end;
implementation
{ FormPrefixAttribute }
constructor FormPrefixAttribute.Create(const aPrefix: String);
begin
FPrefix := aPrefix;
end;
{ FormSectionAttribute }
constructor FormSectionAttribute.Create(const aSection: String);
begin
FSection := aSection;
end;
{ TRttiTranslation }
class function TRttiTranslation.GetPrefixAttribute(Obj: TRttiObject): FormPrefixAttribute;
var
Attr: TCustomAttribute;
begin
for Attr in Obj.GetAttributes do begin
if Attr is FormPrefixAttribute then
exit(FormPrefixAttribute(Attr));
end;
result := nil;
end;
class function TRttiTranslation.GetSectionAttribute(Obj: TRttiObject): FormSectionAttribute;
var
Attr: TCustomAttribute;
begin
for Attr in Obj.GetAttributes do begin
if Attr is FormSectionAttribute then
exit(FormSectionAttribute(Attr));
end;
result := nil;
end;
class procedure TRttiTranslation.Load(filename: string; obj: TObject);
var
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.LoadFromFile(filename);
TRttiTranslation.Load(sl, obj);
finally
sl.Free;
end;
end;
class procedure TRttiTranslation.Load(var sl: TStringList; obj: TObject);
var
ctx: TRttiContext;
objType: TRttiType;
Field: TRttiField;
FormPrefix: FormPrefixAttribute;
FormSection: FormSectionAttribute;
CurrentPrefix, CurrentSection, FieldName, value: string;
aCheckBox: TCheckBox;
aButton: TButton;
aLabel: TLabel;
aTabSheet: TTabSheet;
aGroupBox: TGroupBox;
aSpeedButton: TSpeedButton;
aMenuItem: TMenuItem;
aComboBox: TComboBox;
aListView: TListView;
i: Integer;
begin
FormPrefix := nil;
ctx := TRttiContext.Create;
try
objType := ctx.GetType(Obj.ClassInfo);
for Field in objType.GetFields do begin
// START BY FINDING FORM PREFIX, SKIP FIELDS UNTIL FOUND
if not Assigned(FormPrefix) then begin
FormPrefix := GetPrefixAttribute(Field);
if Assigned(FormPrefix) then
CurrentPrefix := FormPrefix.Prefix
else
continue;
end;
// IF FORM SECTION, DUMP SECTION
FormSection := GetSectionAttribute(Field);
if Assigned(FormSection) then
CurrentSection := FormSection.Section;
// SKIP ALL ITEMS IN 'DontTranslate' SECTION
if CurrentSection = 'DontTranslate' then
continue;
// LOAD VALUES
FieldName := Field.FieldType.Name;
if FieldName = 'TCheckBox' then begin
aCheckBox := TCheckBox(field.GetValue(obj).AsType);
if Assigned(aCheckBox) then begin
value := ReadValue(CurrentPrefix, sl, Field, 'Caption');
if value <> '' then aCheckBox.Caption := value;
value := ReadValue(CurrentPrefix, sl, Field, 'Hint');
aCheckBox.ShowHint := value <> '';
if aCheckBox.ShowHint then aCheckBox.Hint := value;
end;
end
else if FieldName = 'TButton' then begin
aButton := TButton(field.GetValue(obj).AsType);
if Assigned(aButton) then begin
value := ReadValue(CurrentPrefix, sl, Field, 'Caption');
if value <> '' then aButton.Caption := value;
value := ReadValue(CurrentPrefix, sl, Field, 'Hint');
aButton.ShowHint := value <> '';
if aButton.ShowHint then aButton.Hint := value;
end;
end
else if FieldName = 'TLabel' then begin
aLabel := TLabel(field.GetValue(obj).AsType);
if Assigned(aLabel) then begin
value := ReadValue(CurrentPrefix, sl, Field, 'Caption');
if value <> '' then aLabel.Caption := value;
value := ReadValue(CurrentPrefix, sl, Field, 'Hint');
aLabel.ShowHint := value <> '';
if aLabel.ShowHint then aLabel.Hint := value;
end;
end
else if FieldName = 'TTabSheet' then begin
aTabSheet := TTabSheet(field.GetValue(obj).AsType);
if Assigned(aTabSheet) then begin
value := ReadValue(CurrentPrefix, sl, Field, 'Caption');
if value <> '' then aTabSheet.Caption := value;
value := ReadValue(CurrentPrefix, sl, Field, 'Hint');
aTabSheet.ShowHint := value <> '';
if aTabSheet.ShowHint then aTabSheet.Hint := value;
end;
end
else if FieldName = 'TGroupBox' then begin
aGroupBox := TGroupBox(field.GetValue(obj).AsType);
if Assigned(aGroupBox) then begin
value := ReadValue(CurrentPrefix, sl, Field, 'Caption');
if value <> '' then aGroupBox.Caption := value;
value := ReadValue(CurrentPrefix, sl, Field, 'Hint');
aGroupBox.ShowHint := value <> '';
if aGroupBox.ShowHint then aGroupBox.Hint := value;
end;
end
else if FieldName = 'TSpeedButton' then begin
aSpeedButton := TSpeedButton(field.GetValue(obj).AsType);
if Assigned(aSpeedButton) then begin
value := ReadValue(CurrentPrefix, sl, Field, 'Hint');
aSpeedButton.ShowHint := value <> '';
if aSpeedButton.ShowHint then aSpeedButton.Hint := value;
end;
end
else if FieldName = 'TMenuItem' then begin
aMenuItem := TMenuItem(field.GetValue(obj).AsType);
if Assigned(aMenuItem) then begin
value := ReadValue(CurrentPrefix, sl, Field, 'Caption');
if value <> '' then aMenuItem.Caption := value;
end;
end
else if FieldName = 'TComboBox' then begin
aComboBox := TComboBox(field.GetValue(obj).AsType);
if Assigned(aComboBox) then begin
for i := 0 to Pred(aComboBox.Items.Count) do begin
value := ReadValue(CurrentPrefix, sl, Field, 'Item'+IntToStr(i));
if value <> '' then aComboBox.Items[i] := value;
end;
end;
end
else if FieldName = 'TListView' then begin
aListView := TListView(field.GetValue(obj).AsType);
if Assigned(aListView) then begin
if not aListView.ShowColumnHeaders then
continue;
for i := 0 to Pred(aListView.Columns.Count) do begin
value := ReadValue(CurrentPrefix, sl, Field, 'Column'+IntToStr(i));
if value <> '' then aListView.Columns[i].Caption := value;
end;
end;
end;
end;
finally
ctx.Free;
end;
end;
class function TRttiTranslation.ReadValue(section: string; var sl: TStringList;
field: TRttiField; subfield: string): string;
var
name: string;
begin
// load value from stringlist
name := Format('%s_%s_%s', [section, field.Name, subfield]);
Result := StringReplace(sl.Values[name], '#13#10', #13#10, [rfReplaceAll]);
end;
class procedure TRttiTranslation.WriteValue(section: string; value: string; var sl: TStringList;
field: TRttiField; subfield: string);
var
name: string;
begin
if value = '' then
exit;
name := Format('%s_%s_%s', [section, field.Name, subfield]);
sl.Values[name] := StringReplace(value, #13#10, '#13#10', [rfReplaceAll]);
end;
class procedure TRttiTranslation.Save(filename: string; obj: TObject);
var
ctx: TRttiContext;
objType: TRttiType;
Field: TRttiField;
FormPrefix: FormPrefixAttribute;
FormSection: FormSectionAttribute;
sl: TStringList;
i: Integer;
Header, CurrentPrefix, CurrentSection, FieldName: string;
bNewObject: boolean;
aCheckBox: TCheckBox;
aButton: TButton;
aLabel: TLabel;
aTabSheet: TTabSheet;
aGroupBox: TGroupBox;
aSpeedButton: TSpeedButton;
aMenuItem: TMenuItem;
aComboBox: TComboBox;
aListView: TListView;
begin
FormPrefix := nil;
ctx := TRttiContext.Create;
try
// LOAD FILE IF IT EXISTS
sl := TStringList.Create;
if FileExists(filename) then
sl.LoadFromFile(filename);
// ADD HEADER IF NEW OBJECT
Header := Format('{ %s }', [obj.ClassName]);
bNewObject := sl.IndexOf(Header) = -1;
if bNewObject then sl.Add(Header);
try
objType := ctx.GetType(Obj.ClassInfo);
for Field in objType.GetFields do begin
// START BY FINDING FORM PREFIX, SKIP FIELDS UNTIL FOUND
if not Assigned(FormPrefix) then begin
FormPrefix := GetPrefixAttribute(Field);
if Assigned(FormPrefix) then
CurrentPrefix := FormPrefix.Prefix
else
continue;
end;
// IF FORM SECTION, DUMP SECTION
FormSection := GetSectionAttribute(Field);
if Assigned(FormSection) then begin
CurrentSection := FormSection.Section;
if CurrentSection = 'DontTranslate' then
continue;
Header := Format('{ ## %s ## }', [FormSection.Section]);
if (sl.IndexOf(Header) = -1) then sl.Add(Header);
end;
// SKIP ALL ITEMS IN 'DontTranslate' SECTION
if CurrentSection = 'DontTranslate' then
continue;
// HANDLE COMPONENTS
FieldName := Field.FieldType.Name;
// Handle TCheckBox
if FieldName = 'TCheckBox' then begin
aCheckBox := TCheckBox(field.GetValue(obj).AsType);
if Assigned(aCheckBox) then begin
WriteValue(CurrentPrefix, aCheckBox.Caption, sl, field, 'Caption');
WriteValue(CurrentPrefix, aCheckBox.Hint, sl, field, 'Hint');
end;
end
// Handle TButton
else if FieldName = 'TButton' then begin
aButton := TButton(field.GetValue(obj).AsType);
if Assigned(aButton) then begin
WriteValue(CurrentPrefix, aButton.Caption, sl, field, 'Caption');
WriteValue(CurrentPrefix, aButton.Hint, sl, field, 'Hint');
end;
end
// Handle TLabel
else if FieldName = 'TLabel' then begin
aLabel := TLabel(field.GetValue(obj).AsType);
if Assigned(aLabel) then begin
WriteValue(CurrentPrefix, aLabel.Caption, sl, field, 'Caption');
WriteValue(CurrentPrefix, aLabel.Hint, sl, field, 'Hint');
end;
end
// Handle TTabSheet
else if FieldName = 'TTabSheet' then begin
aTabSheet := TTabSheet(field.GetValue(obj).AsType);
if Assigned(aTabSheet) then begin
WriteValue(CurrentPrefix, aTabSheet.Caption, sl, field, 'Caption');
WriteValue(CurrentPrefix, aTabSheet.Hint, sl, field, 'Hint');
end;
end
// Handle TGroupBox
else if FieldName = 'TGroupBox' then begin
aGroupBox := TGroupBox(field.GetValue(obj).AsType);
if Assigned(aGroupBox) then begin
WriteValue(CurrentPrefix, aGroupBox.Caption, sl, field, 'Caption');
WriteValue(CurrentPrefix, aGroupBox.Hint, sl, field, 'Hint');
end;
end
// Handle TSpeedButton
else if FieldName = 'TSpeedButton' then begin
aSpeedButton := TSpeedButton(field.GetValue(obj).AsType);
if Assigned(aSpeedButton) then begin
WriteValue(CurrentPrefix, aSpeedButton.Caption, sl, field, 'Caption');
WriteValue(CurrentPrefix, aSpeedButton.Hint, sl, field, 'Hint');
end;
end
// Handle TMenuItem
else if FieldName = 'TMenuItem' then begin
aMenuItem := TMenuItem(field.GetValue(obj).AsType);
if Assigned(aMenuItem) then
WriteValue(CurrentPrefix, aMenuItem.Caption, sl, field, 'Caption');
end
// Handle TComboBox
else if FieldName = 'TComboBox' then begin
aComboBox := TComboBox(field.GetValue(obj).AsType);
if Assigned(aComboBox) then
for i := 0 to Pred(aComboBox.Items.Count) do
WriteValue(CurrentPrefix, aComboBox.Items[i], sl, field, 'Item'+IntToStr(i));
end
// Handle TListView
else if FieldName = 'TListView' then begin
aListView := TListView(field.GetValue(obj).AsType);
if Assigned(aListView) then begin
if not aListView.ShowColumnHeaders then
continue;
for i := 0 to Pred(aListView.Columns.Count) do
WriteValue(CurrentPrefix, aListView.Columns[i].Caption, sl, field, 'Column'+IntToStr(i));
end;
end;
end;
finally
if bNewObject then sl.Add(' ');
ForceDirectories(ExtractFilePath(filename));
sl.SaveToFile(fileName);
sl.Free;
end;
finally
ctx.Free;
end;
end;
end.
================================================
FILE: lib/mte/W7Taskbar.pas
================================================
unit W7Taskbar;
interface
uses
Forms, Types, Windows, SysUtils, ComObj, Controls, Graphics;
type
TTaskBarProgressState = (tbpsNone, tbpsIndeterminate, tbpsNormal, tbpsError,
tbpsPaused);
function InitializeTaskbarAPI: boolean;
function SetTaskbarProgressState(const AState: TTaskBarProgressState): boolean;
function SetTaskbarProgressValue(const ACurrent: UInt64; const AMax: UInt64): boolean;
function SetTaskbarOverlayIcon(const AIcon: THandle; const ADescription: String): boolean;
implementation
const
TASKBAR_CID: TGUID = '{56FDF344-FD6D-11d0-958A-006097C9A090}';
TBPF_NOPROGRESS = 0;
TBPF_INDETERMINATE = 1;
TBPF_NORMAL = 2;
TBPF_ERROR = 4;
TBPF_PAUSED = 8;
type
ITaskBarList3 = interface(IUnknown)
['{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}']
function HrInit(): HRESULT; stdcall;
function AddTab(hwnd: THandle): HRESULT; stdcall;
function DeleteTab(hwnd: THandle): HRESULT; stdcall;
function ActivateTab(hwnd: THandle): HRESULT; stdcall;
function SetActiveAlt(hwnd: THandle): HRESULT; stdcall;
function MarkFullscreenWindow(hwnd: THandle; fFullscreen: Boolean): HRESULT; stdcall;
function SetProgressValue(hwnd: THandle; ullCompleted: UInt64; ullTotal: UInt64): HRESULT; stdcall;
function SetProgressState(hwnd: THandle; tbpFlags: Cardinal): HRESULT; stdcall;
function RegisterTab(hwnd: THandle; hwndMDI: THandle): HRESULT; stdcall;
function UnregisterTab(hwndTab: THandle): HRESULT; stdcall;
function SetTabOrder(hwndTab: THandle; hwndInsertBefore: THandle): HRESULT; stdcall;
function SetTabActive(hwndTab: THandle; hwndMDI: THandle; tbatFlags: Cardinal): HRESULT; stdcall;
function ThumbBarAddButtons(hwnd: THandle; cButtons: Cardinal; pButtons: Pointer): HRESULT; stdcall;
function ThumbBarUpdateButtons(hwnd: THandle; cButtons: Cardinal; pButtons: Pointer): HRESULT; stdcall;
function ThumbBarSetImageList(hwnd: THandle; himl: THandle): HRESULT; stdcall;
function SetOverlayIcon(hwnd: THandle; hIcon: THandle; pszDescription: PChar): HRESULT; stdcall;
function SetThumbnailTooltip(hwnd: THandle; pszDescription: PChar): HRESULT; stdcall;
function SetThumbnailClip(hwnd: THandle; var prcClip: TRect): HRESULT; stdcall;
end;
var
TaskBarInterface: ITaskBarList3;
function InitializeTaskbarAPI: Boolean;
var
Unknown: IInterface;
Temp: ITaskBarList3;
begin
// return true and exit if already initialized
if Assigned(TaskBarInterface) then begin
Result := True;
Exit;
end;
// create COM object for taskbar CID
try
Unknown := CreateComObject(TASKBAR_CID);
if Assigned(Unknown) then begin
Temp := Unknown as ITaskBarList3;
if Temp.HrInit() = S_OK then
TaskBarInterface := Temp;
end;
except
TaskBarInterface := nil;
end;
// if we got the interface, return true
Result := Assigned(TaskBarInterface);
end;
{ Check to see if the API has been initialized }
function CheckAPI: boolean;
begin
Result := Assigned(TaskBarInterface);
end;
function SetTaskbarProgressState(const AState: TTaskBarProgressState): boolean;
var
Flag: Cardinal;
begin
Result := False;
// exit if api not initialized
if not CheckAPI then
exit;
// check if state is valid, else use no progress
case AState of
tbpsIndeterminate: Flag := TBPF_INDETERMINATE;
tbpsNormal: Flag := TBPF_NORMAL;
tbpsError: Flag := TBPF_ERROR;
tbpsPaused: Flag := TBPF_PAUSED;
else
Flag := TBPF_NOPROGRESS;
end;
// set progress state
Result := TaskBarInterface.SetProgressState(Application.Handle, Flag) = S_OK;
end;
function SetTaskbarProgressValue(const ACurrent:UInt64; const AMax: UInt64): boolean;
begin
Result := False;
// exit if api not initialized
if not CheckAPI then
exit;
// set progress value
Result := TaskBarInterface.SetProgressValue(Application.Handle, ACurrent, AMax) = S_OK;
end;
function SetTaskbarOverlayIcon(const AIcon: THandle; const ADescription: String): boolean;
begin
Result := False;
// exit if api not initialized
if not CheckAPI then
exit;
// set icon
Result := TaskBarInterface.SetOverlayIcon(Application.Handle, AIcon, PWideChar(ADescription)) = S_OK;
end;
initialization
TaskBarInterface := nil;
finalization
TaskBarInterface := nil;
end.
================================================
FILE: lib/mte/mteBase.pas
================================================
unit mteBase;
interface
uses
Classes, Menus,
// third party libraries
superobject,
// mte units
mteTracker,
// xEdit units
wbHelpers, wbInterface, wbImplementation;
type
TSmashType = ( stUnknown, stRecord, stString, stInteger, stFlag, stFloat,
stStruct, stUnsortedArray, stUnsortedStructArray, stSortedArray,
stSortedStructArray, stByteArray, stUnion );
TBasePlugin = class(TObject)
public
_File: IwbFile;
hasData: boolean;
hash: string;
fileSize: Int64;
dateModified: string;
filename: string;
numRecords: Integer;
numOverrides: Integer;
author: string;
dataPath: string;
description: TStringList;
masters: TStringList;
requiredBy: TStringList;
constructor Create; virtual;
destructor Destroy; override;
procedure GetData(var lst: TList);
procedure UpdateData; virtual;
procedure GetHash;
function GetFormIndex: Integer;
end;
TPluginHelpers = class
class function CreateNewBasePlugin(var list: TList; filename: string): TBasePlugin;
class function BasePluginByFilename(var list: TList; filename: string): TBasePlugin;
class function BasePluginLoadOrder(var list: TList; filename: string): integer;
end;
THeaderHelpers = class
class procedure LoadPluginHeaders(var sl: TStringList);
class procedure GetPluginMasters(filename: string; var sl: TStringList);
class procedure GetPluginDependencies(filename: string; var sl: TStringList);
end;
{ General Helper Functions }
function etToString(et: TwbElementType): string;
function dtToString(dt: TwbDefType): string;
function ctToString(ct: TConflictThis): string;
function stToString(st: TSmashType): string;
function SmashType(def: IwbNamedDef): TSmashtype;
function GetSmashType(element: IwbElement): TSmashType;
function ElementByIndexedPath(e: IwbElement; ip: string): IwbElement;
function IndexedPath(e: IwbElement): string;
function GetAllValues(e: IwbElement): string;
function IsSortedDef(def: IwbNamedDef): boolean;
function IsSorted(e: IwbElement): boolean;
function HasStructChildren(e: IwbElement): boolean;
function HasStructChildrenDef(def: IwbNamedDef): boolean;
function WinningOverrideInFiles(rec: IwbMainRecord;
var sl: TStringList): IwbMainRecord;
function IsOverride(aRecord: IwbMainRecord): boolean;
function ExtractFormID(filename: string): string;
function RemoveFileIndex(formID: string): string;
function LocalFormID(aRecord: IwbMainRecord): integer;
function LoadOrderPrefix(aRecord: IwbMainRecord): integer;
function CountOverrides(aFile: IwbFile): integer;
function OverrideCountInFiles(rec: IwbMainRecord; var files: TStringList): Integer;
procedure AddRequiredBy(var lst: TList; filename: string;
var masters: TStringList);
procedure GetMasters(aFile: IwbFile; var sl: TStringList);
procedure AddMasters(aFile: IwbFile; var sl: TStringList);
function RemoveSelfOrContainer(const aElement: IwbElement): boolean;
procedure UndeleteAndDisable(const aRecord: IwbMainRecord);
function LoadOrderCompare(List: TStringList; Index1, Index2: Integer): Integer;
{ Record Prototyping Functions }
function GetElementObj(var obj: ISuperObject; name: string): ISuperObject;
function CreateRecordObj(var tree: ISuperObject; rec: IwbMainRecord): ISuperObject;
function GetRecordObj(var tree: ISuperObject; name: string): ISuperObject;
function GetRecordDef(sig: TwbSignature): TwbRecordDefEntry;
function BuildDef(def: IwbNamedDef; name: string): ISuperObject;
function BuildRecordDef(sName: string; mrDef: IwbRecordDef; out recObj: ISuperObject): boolean; overload;
function BuildRecordDef(sName: string; out recObj: ISuperObject): boolean; overload;
function GetEditableFileContainer: IwbContainerElementRef;
{ Plugin Error Functions }
function FixErrors(const aElement: IwbElement; lastRecord: IwbMainRecord;
var errors: TStringList): IwbMainRecord;
function CheckForErrors(const aElement: IwbElement; lastRecord: IwbMainRecord;
var errors: TStringList): IwbMainRecord;
{ Asset Handling Functions }
procedure ExtractBSA(ContainerName, folder, destination: string); overload;
procedure ExtractBSA(ContainerName, destination: string; var ignore: TStringList); overload;
function BSAExists(filename: string): boolean;
function INIExists(filename: string): boolean;
function TranslationExists(filename: string): boolean;
function FaceDataExists(filename: string): boolean;
function VoiceDataExists(filename: string): boolean;
function FragmentsExist(f: IwbFile): boolean;
function ReferencesSelf(f: IwbFile): boolean;
var
PluginsList: TList;
HeaderList: TList;
implementation
uses
SysUtils, Dialogs,
mteHelpers,
msConfiguration;
constructor TBasePlugin.Create;
begin
hasData := false;
dataPath := wbDataPath;
description := TStringList.Create;
masters := TStringList.Create;
requiredBy := TStringList.Create;
end;
destructor TBasePlugin.Destroy;
begin
description.Free;
masters.Free;
requiredBy.Free;
end;
procedure TBasePlugin.GetData(var lst: TList);
var
Container: IwbContainer;
s: string;
begin
hasData := true;
// get data
filename := _File.FileName;
Container := _File as IwbContainer;
Container := Container.Elements[0] as IwbContainer;
author := Container.GetElementEditValue('CNAM - Author');
// we have to subtract 1 because this count includes the
// file header for some reason
numRecords := Container.GetElementNativeValue('HEDR - Header\Number of Records') - 1;
// get masters, required by
GetMasters(_File, masters);
AddRequiredBy(lst, filename, masters);
// get description
s := Container.GetElementEditValue('SNAM - Description');
description.Text := Wordwrap(s, 80);
// get file attributes
fileSize := GetFileSize(wbDataPath + filename);
dateModified := DateTimeToStr(GetLastModified(wbDataPath + filename));
end;
procedure TBasePlugin.UpdateData;
begin
// virtual method to be overridden
end;
procedure TBasePlugin.GetHash;
begin
hash := IntToHex(wbCRC32File(wbDataPath + filename), 8);
end;
function TBasePlugin.GetFormIndex: Integer;
var
Container, MasterFiles: IwbContainer;
begin
Result := 0;
Container := self._File as IwbContainer;
Container := Container.Elements[0] as IwbContainer;
if Container.ElementExists['Master Files'] then begin
MasterFiles := Container.ElementByPath['Master Files'] as IwbContainer;
Result := MasterFiles.ElementCount;
end;
end;
{*****************************************************************************}
{ PLUGIN HELPERS
Helper methods for dealing with TBasePlugins.
}
{*****************************************************************************}
{ Create a new plugin }
class function TPluginHelpers.CreateNewBasePlugin(var list: TList; filename: string): TBasePlugin;
var
aFile: IwbFile;
LoadOrder: integer;
plugin: TBasePlugin;
begin
Result := nil;
LoadOrder := PluginsList.Count + 1;
// fail if maximum load order reached
if LoadOrder > 254 then begin
Tracker.Write('Maximum load order reached! Can''t create file '+filename);
exit;
end;
// create new plugin file
SysUtils.FormatSettings.DecimalSeparator := '.';
aFile := wbNewFile(wbDataPath + filename, LoadOrder);
aFile._AddRef;
// create new plugin object
plugin := TBasePlugin.Create;
plugin.filename := filename;
plugin._File := aFile;
Result := plugin;
end;
{ Gets the load order of the plugin matching the given name }
class function TPluginHelpers.BasePluginLoadOrder(var list: TList; filename: string): integer;
var
i: integer;
plugin: TBasePlugin;
begin
Result := -1;
for i := 0 to Pred(list.Count) do begin
plugin := TBasePlugin(list[i]);
if plugin.filename = filename then begin
Result := i;
exit;
end;
end;
end;
{ Gets a plugin matching the given name. }
class function TPluginHelpers.BasePluginByFilename(var list: TList; filename: string): TBasePlugin;
var
i: integer;
plugin: TBasePlugin;
begin
Result := nil;
for i := 0 to Pred(list.count) do begin
plugin := TBasePlugin(list[i]);
if plugin.filename = filename then begin
Result := plugin;
exit;
end;
end;
end;
class procedure THeaderHelpers.LoadPluginHeaders(var sl: TStringList);
var
i: Integer;
aFile: IwbFile;
plugin: TBasePlugin;
begin
// create header list
HeaderList := TList.Create;
// load plugin headers for each plugin in @sl
for i := 0 to Pred(sl.Count) do try
aFile := wbFile(wbDataPath + sl[i], -1, '', False, True);
plugin := TBasePlugin.Create;
plugin._File := aFile;
HeaderList.Add(plugin);
except
on x: Exception do begin
Tracker.Write('Failed to load '+sl[i]);
end;
end;
// get data for each plugin in the header list
for i := 0 to Pred(HeaderList.Count) do begin
plugin := TBasePlugin(HeaderList[i]);
plugin.GetData(HeaderList);
end;
end;
class procedure THeaderHelpers.GetPluginMasters(filename: string;
var sl: TStringList);
var
plugin: TBasePlugin;
i: integer;
begin
// get plugin
plugin := TPluginHelpers.BasePluginByFilename(HeaderList, filename);
if not Assigned(plugin) then exit;
// add its masters to @sl
for i := 0 to Pred(plugin.masters.Count) do begin
if sl.IndexOf(plugin.masters[i]) > -1 then continue;
sl.Add(plugin.masters[i]);
GetPluginMasters(plugin.masters[i], sl);
end;
end;
class procedure THeaderHelpers.GetPluginDependencies(filename: string;
var sl: TStringList);
var
plugin: TBasePlugin;
i: integer;
begin
// get plugin
plugin := TPluginHelpers.BasePluginByFilename(HeaderList, filename);
if not Assigned(plugin) then exit;
// add its required by to @sl
for i := 0 to Pred(plugin.requiredBy.Count) do begin
if sl.IndexOf(plugin.requiredBy[i]) > -1 then continue;
sl.Add(plugin.requiredBy[i]);
GetPluginDependencies(plugin.requiredBy[i], sl);
end;
end;
{******************************************************************************}
{ General Helper Functions
Set of functions that read bethesda plugin files for various attributes.
List of functions:
- etToString
- dtToString
- ctToString
- stToString
- GetSmashType
- ElementByIndexedPath
- IndexedPath
- GetAllValues
- IsSorted
- HasStructChildren
- WinningOverrideInFiles
- IsOverride
- LocalFormID
-LoadOrderPrefix
- CountOverrides
- GetMasters
- AddMasters
- BSAExists
- TranslationExists
- FaceDataExists
- VoiceDataExists
- FragmentsExist
- ExtractBSA
- CheckForErorrsLinear
- CheckForErrors
- PluginsModified
- CreatSEQFile
}
{*****************************************************************************}
{ Converts a TwbElementType to a string }
function etToString(et: TwbElementType): string;
begin
case Ord(et) of
Ord(etFile): Result := 'etFile';
Ord(etMainRecord): Result := 'etMainRecord';
Ord(etGroupRecord): Result := 'etGroupRecord';
Ord(etSubRecord): Result := 'etSubRecord';
Ord(etSubRecordStruct): Result := 'etSubRecordStruct';
Ord(etSubRecordArray): Result := 'etSubRecordArray';
Ord(etSubRecordUnion): Result := 'etSubRecordUnion';
Ord(etArray): Result := 'etArray';
Ord(etStruct): Result := 'etStruct';
Ord(etValue): Result := 'etValue';
Ord(etFlag): Result := 'etFlag';
Ord(etStringListTerminator): Result := 'etStringListTerminator';
Ord(etUnion): Result := 'etUnion';
end;
end;
{ Converts a TwbDefType to a string }
function dtToString(dt: TwbDefType): string;
begin
case Ord(dt) of
Ord(dtRecord): Result := 'dtRecord';
Ord(dtSubRecord): Result := 'dtSubRecord';
Ord(dtSubRecordArray): Result := 'dtSubRecordArray';
Ord(dtSubRecordStruct): Result := 'dtSubRecordStruct';
Ord(dtSubRecordUnion): Result := 'dtSubRecordUnion';
Ord(dtString): Result := 'dtString';
Ord(dtLString): Result := 'dtLString';
Ord(dtLenString): Result := 'dtLenString';
Ord(dtByteArray): Result := 'dtByteArray';
Ord(dtInteger): Result := 'dtInteger';
Ord(dtIntegerFormater): Result := 'dtIntegerFormatter';
Ord(dtFloat): Result := 'dtFloat';
Ord(dtArray): Result := 'dtArray';
Ord(dtStruct): Result := 'dtStruct';
Ord(dtUnion): Result := 'dtUnion';
Ord(dtEmpty): Result := 'dtEmpty';
end;
end;
function ctToString(ct: TConflictThis): string;
begin
case Ord(ct) of
Ord(ctUnknown): Result := 'ctUnknown';
Ord(ctIgnored): Result := 'ctIgnored';
Ord(ctNotDefined): Result := 'ctNotDefined';
Ord(ctIdenticalToMaster): Result := 'ctIdenticalToMaster';
Ord(ctOnlyOne): Result := 'ctOnlyOne';
Ord(ctHiddenByModGroup): Result := 'ctHiddenByModGroup';
Ord(ctMaster): Result := 'ctMaster';
Ord(ctConflictBenign): Result := 'ctConflictBenign';
Ord(ctOverride): Result := 'ctOverride';
Ord(ctIdenticalToMasterWinsConflict): Result := 'ctIdenticalToMasterWinsConflict';
Ord(ctConflictWins): Result := 'ctConflictWins';
Ord(ctConflictLoses): Result := 'ctConflictLoses';
end;
end;
function stToString(st: TSmashType): string;
begin
case Ord(st) of
Ord(stUnknown): Result := 'Unknown';
Ord(stRecord): Result := 'Record';
Ord(stString): Result := 'String';
Ord(stInteger): Result := 'Integer';
Ord(stFlag): Result := 'Flag';
Ord(stFloat): Result := 'Float';
Ord(stStruct): Result := 'Struct';
Ord(stUnsortedArray): Result := 'Unsorted Array';
Ord(stUnsortedStructArray): Result := 'Unsorted Struct Array';
Ord(stSortedArray): Result := 'Sorted Array';
Ord(stSortedStructArray): Result := 'Sorted Struct Array';
Ord(stByteArray): Result := 'Byte Array';
Ord(stUnion): Result := 'Union';
else Result := 'Unknown';
end;
end;
function SmashType(def: IwbNamedDef): TSmashtype;
var
subDef: IwbSubRecordDef;
dt: TwbDefType;
bIsSorted, bHasStructChildren: boolean;
begin
dt := def.DefType;
if Supports(def, IwbSubrecordDef, subDef) then
dt := subDef.GetValue.DefType;
case Ord(dt) of
Ord(dtRecord): Result := stRecord;
Ord(dtSubRecord): Result := stUnknown;
Ord(dtSubRecordStruct): Result := stStruct;
Ord(dtSubRecordUnion): Result := stUnion;
Ord(dtString): Result := stString;
Ord(dtLString): Result := stString;
Ord(dtLenString): Result := stString;
Ord(dtByteArray): Result := stByteArray;
Ord(dtInteger): Result := stInteger;
Ord(dtIntegerFormater): Result := stInteger;
Ord(dtIntegerFormaterUnion): Result := stInteger;
Ord(dtFlag): Result := stFlag;
Ord(dtFloat): Result := stFloat;
Ord(dtSubRecordArray), Ord(dtArray): begin
bIsSorted := IsSortedDef(def);
bHasStructChildren := HasStructChildrenDef(def);
if bIsSorted then begin
if bHasStructChildren then
Result := stSortedStructArray
else
Result := stSortedArray;
end
else begin
if bHasStructChildren then
Result := stUnsortedStructArray
else
Result := stUnsortedArray;
end;
end;
Ord(dtStruct): Result := stStruct;
Ord(dtUnion): Result := stUnion;
Ord(dtEmpty): Result := stUnknown;
Ord(dtStructChapter): Result := stStruct;
else Result := stUnknown;
end;
end;
function GetSmashType(element: IwbElement): TSmashType;
begin
Result := SmashType(element.Def);
end;
function ElementByIndexedPath(e: IwbElement; ip: string): IwbElement;
var
i, index: integer;
path: TStringList;
c: IwbContainerElementRef;
begin
// replace forward slashes with backslashes
ip := StringReplace(ip, '/', '\', [rfReplaceAll]);
// prepare path stringlist delimited by backslashes
path := TStringList.Create;
path.Delimiter := '\';
path.StrictDelimiter := true;
path.DelimitedText := ip;
// treat e as a container
if not Supports(e, IwbContainerElementRef, c) then
exit;
// traverse path
for i := 0 to Pred(path.count) do begin
if Pos('[', path[i]) > 0 then begin
index := StrToInt(GetTextIn(path[i], '[', ']'));
e := c.Elements[index];
if not Supports(e, IwbContainerElementRef, c) then
exit;
end
else begin
e := c.ElementByPath[path[i]];
if not Supports(e, IwbContainerElementRef, c) then
exit;
end;
end;
// set result
Result := e;
end;
function IndexedPath(e: IwbElement): string;
var
c: IwbContainer;
a: string;
begin
c := e.Container;
while (e.ElementType <> etMainRecord) do begin
if c.ElementType = etSubRecordArray then
a := '['+IntToStr(c.IndexOf(e))+']'
else
a := e.Name;
if Result <> '' then
Result := a + '\' + Result
else
Result := a;
e := c;
c := e.Container;
end;
end;
{ Returns a string hash of all of the values contained in an element }
function GetAllValues(e: IwbElement): string;
var
i: integer;
c: IwbContainerElementRef;
begin
Result := e.EditValue;
if not Supports(e, IwbContainerElementRef, c) then
exit;
// loop through children elements
for i := 0 to Pred(c.ElementCount) do begin
if (Result <> '') then
Result := Result + ';' + GetAllValues(c.Elements[i])
else
Result := GetAllValues(c.Elements[i]);
end;
end;
function IsSortedDef(def: IwbNamedDef): boolean;
var
sraDef: IwbSubRecordArrayDef;
arDef: IwbArrayDef;
begin
Result := false;
if Supports(def, IwbSubRecordArrayDef, sraDef) then
Result := Supports(sraDef.Element, IwbHasSortKeyDef)
else if Supports(def, IwbArrayDef, arDef) then
Result := Supports(arDef.Element, IwbHasSortKeyDef);
end;
{ Returns true if @e is a sorted container }
function IsSorted(e: IwbElement): boolean;
var
Container: IwbSortableContainer;
begin
Result := false;
if Supports(e, IwbSortableContainer, Container) then
Result := Container.Sorted;
end;
function HasStructChildrenDef(def: IwbNamedDef): boolean;
begin
Result := Supports(def, IwbSubRecordArrayDef);
end;
{ Returns true if @e is a container with struct children }
function HasStructChildren(e: IwbElement): boolean;
var
Container: IwbContainerElementRef;
begin
Result := false;
if Supports(e, IwbContainerElementRef, Container)
and (Container.ElementCount > 0) then
Result := GetSmashType(Container.Elements[0]) = stStruct;
end;
{ Returns the most-winning override of @rec from the
files listed in @sl }
function WinningOverrideInFiles(rec: IwbMainRecord;
var sl: TStringList): IwbMainRecord;
var
i: Integer;
ovr: IwbMainRecord;
begin
Result := rec;
for i := Pred(rec.OverrideCount) downto 0 do begin
ovr := rec.Overrides[i];
if sl.IndexOf(ovr._file.FileName) > -1 then begin
Result := ovr;
exit;
end;
end;
end;
{ Returns true if the input record is an override record }
function IsOverride(aRecord: IwbMainRecord): boolean;
begin
Result := not aRecord.IsMaster;
end;
function ExtractFormID(filename: string): string;
const
HexChars = ['0'..'9', 'A'..'F', 'a'..'f'];
var
i, counter: Integer;
begin
counter := 0;
// we loop from the back because the formID is usually at the
// end of the filename
for i := Length(filename) downto 1 do begin
if (filename[i] in HexChars) then
Inc(counter)
else
counter := 0;
// set result and exit if counter has reached 8
if counter = 8 then begin
Result := Copy(filename, i, 8);
exit;
end;
end;
end;
function RemoveFileIndex(formID: string): string;
begin
if Length(formID) <> 8 then
raise Exception.Create('RemoveFileIndex: FormID must be 8 characters long');
Result := '00' + Copy(formID, 3, 6);
end;
{ Gets the local formID of a record (so no load order prefix) }
function LocalFormID(aRecord: IwbMainRecord): integer;
begin
Result := aRecord.LoadOrderFormID and $00FFFFFF;
end;
{ Gets the load order prefix from the FormID of a record }
function LoadOrderPrefix(aRecord: IwbMainRecord): integer;
begin
Result := aRecord.LoadOrderFormID and $FF000000;
end;
{ Returns the number of override records in a file }
function CountOverrides(aFile: IwbFile): integer;
var
i: Integer;
aRecord: IwbMainRecord;
begin
Result := 0;
for i := 0 to Pred(aFile.GetRecordCount) do begin
aRecord := aFile.GetRecord(i);
if IsOverride(aRecord) then
Inc(Result);
end;
end;
{ Returns the number of overrides of the specified record in the specified file set }
function OverrideCountInFiles(rec: IwbMainRecord; var files: TStringList): Integer;
var
i: Integer;
ovr: IwbMainRecord;
begin
Result := 0;
for i := 0 to Pred(rec.OverrideCount) do begin
ovr := rec.Overrides[i];
if files.IndexOf(ovr._File.FileName) > -1 then
Inc(Result);
end;
end;
{ Populates required by field of @masters that are required by plugin
@filename }
procedure AddRequiredBy(var lst: TList; filename: string;
var masters: TStringList);
var
i: Integer;
plugin: TBasePlugin;
begin
for i := 0 to Pred(masters.Count) do begin
plugin := TPluginHelpers.BasePluginByFilename(lst, masters[i]);
if not Assigned(plugin) then
continue;
plugin.requiredBy.Add(filename);
end;
end;
{ Gets the masters in an IwbFile and puts them into a stringlist }
procedure GetMasters(aFile: IwbFile; var sl: TStringList);
var
Container, MasterFiles, MasterFile: IwbContainer;
i, iLoadOrder: integer;
filename: string;
begin
Container := aFile as IwbContainer;
Container := Container.Elements[0] as IwbContainer;
if Container.ElementExists['Master Files'] then begin
MasterFiles := Container.ElementByPath['Master Files'] as IwbContainer;
for i := 0 to MasterFiles.ElementCount - 1 do begin
MasterFile := MasterFiles.Elements[i] as IwbContainer;
filename := MasterFile.GetElementEditValue('MAST - Filename');
if sl.IndexOf(filename) = -1 then begin
iLoadOrder := TPluginHelpers.BasePluginLoadOrder(PluginsList, filename);
sl.AddObject(filename, TObject(iLoadOrder));
end;
end;
end;
end;
{ Gets the masters in an IwbFile and puts them into a stringlist }
procedure AddMasters(aFile: IwbFile; var sl: TStringList);
var
i: integer;
begin
for i := 0 to Pred(sl.Count) do begin
if Lowercase(aFile.FileName) = Lowercase(sl[i]) then
continue;
aFile.AddMasterIfMissing(sl[i]);
end;
end;
{ Checks if a BSA exists associated with the given filename }
function BSAExists(filename: string): boolean;
var
bsaFilename, ContainerName: string;
begin
Result := false;
bsaFilename := ChangeFileExt(filename, '.bsa');
if FileExists(wbDataPath + bsaFilename) then begin
ContainerName := wbDataPath + bsaFilename;
if not wbContainerHandler.ContainerExists(ContainerName) then
wbContainerHandler.AddBSA(ContainerName);
Result := true;
end;
end;
{ Check if an INI exists associated with the given filename }
function INIExists(filename: string): boolean;
var
iniFilename: string;
begin
iniFilename := ChangeFileExt(filename, '.ini');
Result := FileExists(wbDataPath + iniFilename);
end;
{ Returns true if a file exists at @path matching @filename }
function MatchingFileExists(path: string; filename: string): boolean;
var
info: TSearchRec;
begin
Result := false;
filename := Lowercase(filename);
if FindFirst(path, faAnyFile, info) = 0 then begin
repeat
if Pos(filename, Lowercase(info.Name)) > 0 then begin
Result := true;
exit;
end;
until FindNext(info) <> 0;
FindClose(info);
end;
end;
{ Return true if MCM translation files for @filename are found }
function TranslationExists(filename: string): boolean;
var
searchPath, bsaFilename, ContainerName: string;
ResourceList: TStringList;
begin
searchPath := wbDataPath + 'Interface\translations\*';
Result := MatchingFileExists(searchPath, ChangeFileExt(filename, ''));
if Result then exit;
// check in BSA
if BSAExists(filename) then begin
bsaFilename := ChangeFileExt(filename, '.bsa');
ContainerName := wbDataPath + bsaFilename;
ResourceList := TStringList.Create;
wbContainerHandler.ContainerResourceList(ContainerName, ResourceList, 'Interface\translations');
Result := ResourceList.Count > 0;
end;
end;
{ Return true if file-specific FaceGenData files for @filename are found }
function FaceDataExists(filename: string): boolean;
var
facetintDir, facegeomDir, bsaFilename, ContainerName: string;
ResourceList: TStringList;
facetint, facegeom: boolean;
begin
facetintDir := 'textures\actors\character\facegendata\facetint\' + filename;
facegeomDir := 'meshes\actors\character\facegendata\facegeom\' + filename;
facetint := DirectoryExists(wbDataPath + facetintDir);
facegeom := DirectoryExists(wbDataPath + facegeomDir);
Result := facetint or facegeom;
if Result then exit;
// check in BSA
if BSAExists(filename) then begin
bsaFilename := ChangeFileExt(filename, '.bsa');
ContainerName := wbDataPath + bsaFilename;
ResourceList := TStringList.Create;
wbContainerHandler.ContainerResourceList(ContainerName, ResourceList, facetintDir);
wbContainerHandler.ContainerResourceList(ContainerName, ResourceList, facegeomDir);
Result := ResourceList.Count > 0;
end;
end;
{ Return true if file-specific Voice files for @filename are found }
function VoiceDataExists(filename: string): boolean;
var
voiceDir, bsaFilename, ContainerName: string;
ResourceList: TStringList;
begin
voiceDir := 'sound\voice\' + filename;
Result := DirectoryExists(wbDataPath + voiceDir);
if Result then exit;
// check in BSA
if BSAExists(filename) then begin
bsaFilename := ChangeFileExt(filename, '.bsa');
ContainerName := wbDataPath + bsaFilename;
ResourceList := TStringList.Create;
wbContainerHandler.ContainerResourceList(ContainerName, ResourceList, voiceDir);
Result := ResourceList.Count > 0;
end;
end;
{ Returns true if Topic Info Fragments exist in @f }
function TopicInfoFragmentsExist(f: IwbFile): boolean;
const
infoFragmentsPath = 'VMAD - Virtual Machine Adapter\Data\Info VMAD\Script Fragments Info';
var
rec: IwbMainRecord;
group: IwbGroupRecord;
subgroup, container: IwbContainer;
element, fragments: IwbElement;
i, j: Integer;
begin
Result := false;
// exit if no DIAL records in file
if not f.HasGroup('DIAL') then
exit;
// find all DIAL records
group := f.GroupBySignature['DIAL'];
for i := 0 to Pred(group.ElementCount) do begin
element := group.Elements[i];
// find all INFO records
if not Supports(element, IwbContainer, subgroup) then
continue;
for j := 0 to Pred(subgroup.ElementCount) do begin
if not Supports(subgroup.Elements[j], IwbMainRecord, rec) then
continue;
if not rec.IsMaster then
continue;
if not Supports(rec, IwbContainer, container) then
continue;
fragments := container.ElementByPath[infoFragmentsPath];
if not Assigned(fragments) then
continue;
Result := true;
end;
end;
end;
{ Returns true if Quest Fragments exist in @f }
function QuestFragmentsExist(f: IwbFile): boolean;
const
questFragmentsPath = 'VMAD - Virtual Machine Adapter\Data\Quest VMAD\Script Fragments Quest';
var
rec: IwbMainRecord;
group: IwbGroupRecord;
container: IwbContainer;
fragments: IwbElement;
i: Integer;
begin
Result := false;
// exit if no QUST records in file
if not f.HasGroup('QUST') then
exit;
// find all QUST records
group := f.GroupBySignature['QUST'];
for i := 0 to Pred(group.ElementCount) do begin
if not Supports(group.Elements[i], IwbMainRecord, rec) then
continue;
if not rec.IsMaster then
continue;
if not Supports(rec, IwbContainer, container) then
continue;
fragments := container.ElementByPath[questFragmentsPath];
if not Assigned(fragments) then
continue;
Result := true;
end;
end;
{ Returns true if Quest Fragments exist in @f }
function SceneFragmentsExist(f: IwbFile): boolean;
const
sceneFragmentsPath = 'VMAD - Virtual Machine Adapter\Data\Quest VMAD\Script Fragments Quest';
var
rec: IwbMainRecord;
group: IwbGroupRecord;
container: IwbContainer;
fragments: IwbElement;
i: Integer;
begin
Result := false;
// exit if no SCEN records in file
if not f.HasGroup('SCEN') then
exit;
// find all SCEN records
group := f.GroupBySignature['SCEN'];
for i := 0 to Pred(group.ElementCount) do begin
if not Supports(group.Elements[i], IwbMainRecord, rec) then
continue;
if not rec.IsMaster then
continue;
if not Supports(rec, IwbContainer, container) then
continue;
fragments := container.ElementByPath[sceneFragmentsPath];
if not Assigned(fragments) then
continue;
Result := true;
end;
end;
{ Returns true if file-specific Script Fragments for @f are found }
function FragmentsExist(f: IwbFile): boolean;
begin
Result := TopicInfoFragmentsExist(f) or QuestFragmentsExist(f)
or SceneFragmentsExist(f);
end;
{ References self }
function ReferencesSelf(f: IwbFile): boolean;
var
i: Integer;
filename, source: string;
scripts: IwbGroupRecord;
container: IwbContainerElementRef;
rec: IwbMainRecord;
begin
// exit if has no script records in file
Result := false;
if not f.HasGroup('SCPT') then
exit;
// get scripts, and check them all for self-reference
filename := f.FileName;
scripts := f.GroupBySignature['SCPT'];
if not Supports(scripts, IwbContainerElementRef, container) then
exit;
for i := 0 to Pred(container.ElementCount) do begin
if not Supports(container.Elements[i], IwbMainRecord, rec) then
continue;
source := rec.ElementEditValues['SCTX - Script Source'];
if Pos(filename, source) > 0 then begin
Result := true;
break;
end;
end;
end;
{ Extracts assets from @folder in the BSA @filename to @destination }
procedure ExtractBSA(ContainerName, folder, destination: string);
var
ResourceList: TStringList;
i: Integer;
begin
if not wbContainerHandler.ContainerExists(ContainerName) then begin
Tracker.Write(' '+ContainerName+' not loaded.');
exit;
end;
ResourceList := TStringList.Create;
wbContainerHandler.ContainerResourceList(ContainerName, ResourceList, folder);
for i := 0 to Pred(ResourceList.Count) do
wbContainerHandler.ResourceCopy(ContainerName, ResourceList[i], destination);
end;
{ Extracts assets from the BSA @filename to @destination, ignoring assets
matching items in @ignore }
procedure ExtractBSA(ContainerName, destination: string; var ignore: TStringList);
var
ResourceList: TStringList;
i, j: Integer;
skip: boolean;
begin
if not wbContainerHandler.ContainerExists(ContainerName) then begin
Tracker.Write(' '+ContainerName+' not loaded.');
exit;
end;
ResourceList := TStringList.Create;
wbContainerHandler.ContainerResourceList(ContainerName, ResourceList, '');
for i := 0 to Pred(ResourceList.Count) do begin
skip := false;
for j := 0 to Pred(ignore.Count) do begin
skip := Pos(ignore[j], ResourceList[i]) > 0;
if skip then break;
end;
if skip then continue;
wbContainerHandler.ResourceCopy(ContainerName, ResourceList[i], destination);
end;
end;
function RemoveSelfOrContainer(const aElement: IwbElement): Boolean;
var
cElement: IwbElement;
begin
Result := false;
if aElement.IsRemoveable then begin
aElement.Remove;
Result := true;
end
else begin
if not Assigned(aElement.Container) then begin
Tracker.Write(' Element has no container!');
exit;
end;
// if element isn't removable, try removing its container
if Supports(aElement.Container, IwbMainRecord) then begin
Tracker.Write(' Reached main record, cannot remove element');
exit;
end;
Tracker.Write(' Failed to remove '+aElement.Path+', removing container');
if Supports(aElement.Container, IwbElement, cElement) then
Result := RemoveSelfOrContainer(cElement);
end;
end;
procedure UndeleteAndDisable(const aRecord: IwbMainRecord);
var
xesp: IwbElement;
sig: string;
container: IwbContainerElementRef;
begin
try
sig := aRecord.Signature;
// undelete
aRecord.IsDeleted := true;
aRecord.IsDeleted := false;
// set persistence flag depending on game
if (wbGameMode in [gmFO3,gmFNV,gmTES5])
and ((sig = 'ACHR') or (sig = 'ACRE')) then
aRecord.IsPersistent := true
else if wbGameMode = gmTES4 then
aRecord.IsPersistent := false;
// place it below the ground
if not aRecord.IsPersistent then
aRecord.ElementNativeValues['DATA\Position\Z'] := -30000;
// remove elements
aRecord.RemoveElement('Enable Parent');
aRecord.RemoveElement('XTEL');
// add enabled opposite of player (true - silent)
xesp := aRecord.Add('XESP', True);
if Assigned(xesp) and Supports(xesp, IwbContainerElementRef, container) then begin
container.ElementNativeValues['Reference'] := $14; // Player ref
container.ElementNativeValues['Flags'] := 1; // opposite of parent flag
end;
// set to disable
aRecord.IsInitiallyDisabled := true;
except
on x: Exception do
Tracker.Write(' Exception: '+x.Message);
end;
end;
function FixErrors(const aElement: IwbElement; lastRecord: IwbMainRecord;
var errors: TStringList): IwbMainRecord;
const
cUDR = 'Record marked as deleted but contains:';
cUnresolved = '< Error: Could not be resolved >';
cNULL = 'Found a NULL reference, expected:';
var
Error: string;
Container: IwbContainerElementRef;
i: Integer;
begin
if Tracker.Cancel then
exit;
// update progress based on number of main records processed
if Supports(aElement, IwbMainRecord) then
Tracker.UpdateProgress(1);
Error := aElement.Check;
if Error <> '' then begin
Result := aElement.ContainingMainRecord;
// fix record marked as deleted errors (UDRs)
if Pos(cUDR, Error) = 1 then begin
if Assigned(Result) then begin
Tracker.Write(' Fixing UDR: '+Result.Name);
UndeleteAndDisable(Result);
end;
end
else begin
// fix unresolved FormID errors by NULLing them out
if Pos(cUnresolved, Error) > 0 then begin
Tracker.Write(' Fixing Unresolved FormID: '+aElement.Path);
aElement.NativeValue := 0;
// we may end up with an invalid NULL reference, so we Check again
Error := aElement.Check;
if Error = '' then exit;
end;
// fix invalid NULL references by removal
if Pos(cNULL, Error) = 1 then begin
Tracker.Write(' Removing NULL reference: '+aElement.Path);
if RemoveSelfOrContainer(aElement) then exit;
end;
// unhandled error
Tracker.Write(Format(' Unhandled error: %s -> %s', [aElement.Path, error]));
if Assigned(Result) and (lastRecord <> Result) then begin
lastRecord := Result;
errors.Add(Result.Name);
end;
errors.Add(' '+aElement.Path + ' -> ' + Error);
end;
end;
// done if element doesn't have children
if not Supports(aElement, IwbContainerElementRef, Container) then
exit;
// recurse through children elements
for i := Pred(Container.ElementCount) downto 0 do begin
Result := FixErrors(Container.Elements[i], Result, errors);
// break if container got deleted
if not Assigned(Container) then break;
end;
end;
function CheckForErrors(const aElement: IwbElement; lastRecord: IwbMainRecord;
var errors: TStringList): IwbMainRecord;
var
Error, msg: string;
Container: IwbContainerElementRef;
i: Integer;
begin
if Tracker.Cancel then
exit;
// update progress based on number of main records processed
if Supports(aElement, IwbMainRecord) then
Tracker.UpdateProgress(1);
Error := aElement.Check;
// log errors
if Error <> '' then begin
Result := aElement.ContainingMainRecord;
if Assigned(Result) and (Result <> LastRecord) then begin
Tracker.Write(' '+Result.Name);
errors.Add(Result.Name);
end;
msg := ' '+aElement.Path + ' -> ' + Error;
Tracker.Write(' '+msg);
errors.Add(msg);
end;
// recursion
if Supports(aElement, IwbContainerElementRef, Container) then
for i := Pred(Container.ElementCount) downto 0 do
Result := CheckForErrors(Container.Elements[i], Result, errors);
end;
{ Comparator for sorting plugins }
function LoadOrderCompare(List: TStringList; Index1, Index2: Integer): Integer;
var
LO1, LO2: Integer;
begin
LO1 := Integer(List.Objects[Index1]);
LO2 := Integer(List.Objects[Index2]);
Result := LO1 - LO2;
end;
{******************************************************************************}
{ Record Prototyping Functions
- GetElementObj
- CreateRecordObj
- GetRecordObj
- GetRecordDef
- BuildElementDef
- BuildRecordDef
- GetEditableFileContainer
}
{******************************************************************************}
{
GetElementObj:
Gets the child json object from a node in a TSmashSetting tree
@obj matching @name. Returns nil if a matching child is not
found.
}
function GetElementObj(var obj: ISuperObject; name: string): ISuperObject;
var
item: ISuperObject;
begin
Result := nil;
if not Assigned(obj) then
exit;
if not Assigned(obj['c']) then
exit;
for item in obj['c'] do begin
if item.S['n'] = name then begin
Result := item;
exit;
end;
end;
end;
function CreateRecordObj(var tree: ISuperObject; rec: IwbMainRecord): ISuperObject;
var
item: ISuperObject;
begin
item := SO;
item.S['n'] := rec.Signature;
item.I['t'] := Ord(stRecord);
tree.A['records'].Add(item);
Result := item;
end;
function GetRecordObj(var tree: ISuperObject; name: string): ISuperObject;
var
aSignature: TwbSignature;
item: ISuperObject;
begin
Result := nil;
aSignature := StrToSignature(name);
for item in tree['records'] do begin
if StrToSignature(item.S['n']) = aSignature then
Result := item;
end;
end;
function GetRecordDef(sig: TwbSignature): TwbRecordDefEntry;
var
i: Integer;
def: TwbRecordDefEntry;
begin
for i := Low(wbRecordDefs) to High(wbRecordDefs) do begin
def := wbRecordDefs[i];
if def.rdeSignature = sig then begin
Result := def;
exit;
end;
end;
end;
function BuildElementDef(element: IwbElement): ISuperObject;
var
container: IwbContainerElementRef;
i: Integer;
childElement: IwbElement;
begin
// release object if something goes wrong
Result := SO;
try
Result.S['n'] := element.Name;
Result.I['t'] := Ord(GetSmashType(element));
// populate element children, if it supports them
if not Supports(element, IwbContainerElementRef, container) then
exit;
// assign to container if it doesn't have element but can hold them
if (container.ElementCount = 0)
and container.CanAssign(High(Integer), nil, false) then try
container.Assign(High(Integer), nil, false);
except
// oops, container assignment failed
// this catches an assertion error when assigning to a DOBJ record
on x: Exception do
exit;
end;
// if we have children, make children array and recurse
if container.ElementCount > 0 then begin
Result.O['c'] := SA([]);
// traverse children
for i := 0 to Pred(container.ElementCount) do begin
childElement := container.Elements[i];
Result.A['c'].Add(BuildElementDef(childElement));
end;
end;
except
on x: Exception do begin
Result._Release;
raise x;
end;
end;
end;
function IsUnionDef(def: IwbNamedDef; out unionDef: IwbUnionDef): Boolean;
var
subDef: IwbSubRecordDef;
begin
if Supports(def, IwbSubRecordDef, subDef) then
Result := Supports(subDef.GetValue, IwbUnionDef, unionDef)
else
Result := Supports(def, IwbUnionDef, unionDef);
end;
function HasDef(recObj: ISuperObject; name: String): Boolean;
var
i: Integer;
begin
Result := False;
for i := 0 to Pred(recObj.A['c'].Length) do
if recObj.A['c'].O[i].S['n'] = name then begin
Result := True;
exit;
end;
end;
procedure AddDefIfMissing(recObj: ISuperObject; def: IwbNamedDef; name: String);
begin
if not HasDef(recObj, name) then
recObj.A['c'].Add(BuildDef(def, name));
end;
function SigToStr(sig: TwbSignature): String;
var
i: Integer;
begin
for i := Low(sig) to High(sig) do
if Ord(sig[i]) < 32 then
sig[i] := AnsiChar(Ord('a') + Ord(sig[i]));
Result := sig;
end;
procedure BuildChildDef(def: IwbNamedDef; recObj: ISuperObject);
var
i: Integer;
unionDef: IwbUnionDef;
sigDef: IwbSignatureDef;
recDef: IwbRecordDef;
name: String;
begin
if IsUnionDef(def, unionDef) then begin
for i := 0 to Pred(unionDef.MemberCount) do
BuildChildDef(unionDef.Members[i] as IwbNamedDef, recObj);
end
else if Supports(def, IwbSubRecordUnionDef) and Supports(def, IwbRecordDef, recDef) then begin
for i := 0 to Pred(recDef.MemberCount) do
BuildChildDef(recDef.Members[i] as IwbNamedDef, recObj);
end
else if Supports(def, IwbSignatureDef, sigDef) then begin
name := SigToStr(sigDef.DefaultSignature) + ' - ' + sigDef.Name;
AddDefIfMissing(recObj, def, name);
end
else
AddDefIfMissing(recObj, def, def.Name);
end;
procedure BuildChildDefs(obj: ISuperObject; def: IwbNamedDef);
var
i: Integer;
subDef: IwbSubRecordDef;
recDef: IwbRecordDef;
unionDef: IwbUnionDef;
structDef: IwbStructDef;
intDef: IwbIntegerDefFormaterUnion;
sraDef: IwbSubRecordArrayDef;
aDef: IwbArrayDef;
begin
// try SubRecordDef ValueDef
if Supports(def, IwbSubRecordDef, subDef) then
BuildChildDefs(obj, subDef.GetValue as IwbNamedDef)
// try IwbRecordDef
else if Supports(def, IwbRecordDef, recDef) then begin
if recDef.MemberCount = 0 then exit;
obj.O['c'] := SA([]);
for i := 0 to Pred(recDef.MemberCount) do
BuildChildDef(recDef.Members[i] as IwbNamedDef, obj);
end
// try IwbUnionDef
else if Supports(def, IwbUnionDef, unionDef) then begin
if unionDef.MemberCount = 0 then exit;
obj.O['c'] := SA([]);
for i := 0 to Pred(unionDef.MemberCount) do
BuildChildDef(unionDef.Members[i] as IwbNamedDef, obj);
end
// try IwbStructDef
else if Supports(def, IwbStructDef, structDef) then begin
if structDef.MemberCount = 0 then exit;
obj.O['c'] := SA([]);
for i := 0 to Pred(structDef.MemberCount) do
BuildChildDef(structDef.Members[i] as IwbNamedDef, obj);
end
// try IwbIntegerDefFormaterUnion
else if Supports(def, IwbIntegerDefFormaterUnion, intDef) then begin
if intDef.MemberCount = 0 then exit;
obj.O['c'] := SA([]);
for i := 0 to Pred(intDef.MemberCount) do
BuildChildDef(intDef.Members[i] as IwbNamedDef, obj);
end
// try IwbSubRecordArrayDef
else if Supports(def, IwbSubRecordArrayDef, sraDef) then begin
obj.O['c'] := SA([]);
BuildChildDef(sraDef.Element as IwbNamedDef, obj);
end
// try IwbArrayDef
else if Supports(def, IwbArrayDef, aDef) then begin
obj.O['c'] := SA([]);
BuildChildDef(aDef.Element as IwbNamedDef, obj);
end;
end;
function BuildDef(def: IwbNamedDef; name: string): ISuperObject;
begin
// release object if something goes wrong
Result := SO;
try
Result.S['n'] := name;
Result.I['t'] := Ord(SmashType(def));
BuildChildDefs(Result, def);
except
on x: Exception do begin
Result._Release;
raise x;
end;
end;
end;
function BuildRecordDef(sName: string; mrDef: IwbRecordDef; out recObj: ISuperObject): boolean; overload;
var
i: Integer;
begin
recObj := SO;
try
recObj.S['n'] := sName;
recObj.I['t'] := Ord(stRecord);
recObj.O['c'] := SA([]);
for i := 0 to Pred(mrDef.MemberCount) do
BuildChildDef(mrDef.Members[i] as IwbNamedDef, recObj);
except
on x: Exception do begin
recObj._Release;
raise x;
end;
end;
// if everything completed, result is object we made
Result := true;
end;
function BuildRecordDef(sName: string; out recObj: ISuperObject): boolean;
var
def: TwbRecordDefEntry;
begin
def := GetRecordDef(StrToSignature(sName));
Result := BuildRecordDef(sName, def.rdeDef, recObj);
end;
function GetEditableFileContainer: IwbContainerElementRef;
var
i: Integer;
aPlugin: TBasePlugin;
aFile: IwbFile;
Container: IwbContainerElementRef;
begin
Result := nil;
i := 0;
repeat
// exit if max index reached
if i > Pred(PluginsList.Count) then
exit;
// get next plugin
aPlugin := TBasePlugin(PluginsList[i]);
Inc(i);
// exit if file is invalid
aFile := aPlugin._File;
if not Supports(aFile, IwbContainerElementRef, Container) then
exit;
until Container.IsElementEditable(nil);
Result := Container;
end;
procedure PopulateAddList(var AddItem: TMenuItem; Event: TNotifyEvent);
var
i: Integer;
RecordDef: PwbRecordDef;
item: TMenuItem;
begin
// populate wbGroupOrder to additem
with TStringList.Create do try
Sorted := True;
Duplicates := dupIgnore;
// initialize list contents
AddStrings(wbGroupOrder);
Sorted := False;
// get record def names, if available
for i := Pred(Count) downto 0 do
if wbFindRecordDef(AnsiString(Strings[i]), RecordDef) then
Strings[i] := Strings[i] + ' - ' + RecordDef.Name
else
Delete(i);
// populate menu items
for i := 0 to Pred(Count) do begin
if Length(Strings[i]) < 4 then
continue;
item := TMenuItem.Create(AddItem);
item.Caption := Strings[i];
item.OnClick := Event;
AddItem.Add(item);
end;
finally
Free;
end;
end;
initialization
begin
PluginsList := TList.Create;
end;
finalization
begin
FreeList(PluginsList);
end;
end.
================================================
FILE: lib/mte/mteChangeLogForm.dfm
================================================
object ChangeLogForm: TChangeLogForm
Left = 0
Top = 0
Caption = 'Update Available'
ClientHeight = 342
ClientWidth = 366
Color = clBtnFace
Constraints.MaxHeight = 1000
Constraints.MaxWidth = 382
Constraints.MinHeight = 300
Constraints.MinWidth = 382
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object LabelPrompt: TLabel
Left = 8
Top = 8
Width = 51
Height = 13
Caption = 'Changelog'
WordWrap = True
end
object ScrollBox: TScrollBox
Left = 8
Top = 27
Width = 350
Height = 276
HorzScrollBar.Visible = False
VertScrollBar.Tracking = True
Align = alCustom
Anchors = [akLeft, akTop, akRight, akBottom]
TabOrder = 0
end
object ButtonInstall: TButton
Left = 202
Top = 309
Width = 75
Height = 25
Align = alCustom
Anchors = [akRight, akBottom]
Caption = 'Install'
ModalResult = 1
TabOrder = 1
end
object ButtonSkip: TButton
Left = 283
Top = 309
Width = 75
Height = 25
Align = alCustom
Anchors = [akRight, akBottom]
Caption = 'Skip'
ModalResult = 2
TabOrder = 2
end
end
================================================
FILE: lib/mte/mteChangeLogForm.pas
================================================
unit mteChangeLogForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,
// mte units
mteHelpers, RttiTranslation, mteLogger;
type
TChangeLogForm = class(TForm)
[FormPrefix('mpCha')]
ScrollBox: TScrollBox;
LabelPrompt: TLabel;
ButtonInstall: TButton;
ButtonSkip: TButton;
procedure FormCreate(Sender: TObject);
procedure CreateVersionLabel(line: string; var top: Integer);
procedure CreateLabel(line: string; var top: Integer);
procedure DisplayChangelog;
private
{ Private declarations }
public
{ Public declarations }
end;
// public entry point
function ChangeLogPrompt(AOwner: TComponent): boolean;
const
spacing = 5;
bTranslationDump = false;
var
clChangeLogForm: TChangeLogForm;
clChangelog: TStringList;
clProgramVersion: string;
implementation
{$R *.dfm}
procedure TChangeLogForm.FormCreate(Sender: TObject);
begin
{// do a translation dump?
if bTranslationDump then
TRttiTranslation.Save('lang\english.lang', self);
// load translation
TRttiTranslation.Load(language, self);}
// display changelog
DisplayChangelog;
end;
function IsVersionLine(line: string): boolean;
begin
Result := Pos('Version ', line) = 1;
end;
procedure TChangeLogForm.CreateVersionLabel(line: string; var top: Integer);
var
lbl: TLabel;
begin
// make version label
lbl := TLabel.Create(ScrollBox);
lbl.Parent := ScrollBox;
lbl.Autosize := true;
lbl.Top := top;
lbl.Left := 8;
lbl.Caption := line;
lbl.Font.Style := [fsBold];
// increment top for next label
Inc(top, lbl.Height + spacing);
end;
procedure TChangeLogForm.CreateLabel(line: string; var top: Integer);
var
lbl: TLabel;
begin
// make label
lbl := TLabel.Create(ScrollBox);
lbl.Parent := ScrollBox;
lbl.AutoSize := true;
lbl.WordWrap := true;
lbl.Top := top;
lbl.Left := 20;
lbl.Width := ScrollBox.ClientWidth - 36;
lbl.Caption := Trim(line);
// increment top for next label
Inc(top, lbl.Height + spacing);
end;
procedure TChangeLogForm.DisplayChangelog;
var
i, top, start: Integer;
line, lineVersion: string;
begin
// find start line
start := 0;
if not Assigned(clChangelog) then
exit;
for i := 0 to Pred(clChangelog.Count) do begin
line := clChangelog[i];
if not IsVersionLine(line) then
continue;
// identify start of changelog as first version newer than current version
lineVersion := Copy(line, 9, Length(line));
if VersionCompare(clProgramVersion, lineVersion) then begin
start := i;
break;
end;
end;
// loop through the changelog, creating labels in scrollbox
// as necessary to render text
top := 8;
for i := start to Pred(clChangelog.Count) do begin
line := clChangelog[i];
if IsVersionLine(line) then
CreateVersionLabel(line, top)
else
CreateLabel(line, top);
end;
end;
procedure LoadChangelog(var changelog: TStringList);
begin
// load changelog
if not Assigned(changelog) then
changelog := TStringList.Create;
// don't attempt to load changelog if it doesn't exist
if not FileExists('changelog.txt') then begin
Logger.Write('GENERAL', 'Changelog', 'No changelog found');
exit;
end;
// load changelog
changelog.LoadFromFile('changelog.txt');
end;
function ChangeLogPrompt(AOwner: TComponent): boolean;
var
clForm: TChangeLogForm;
begin
Result := false;
// if we don't have a changelog, exit returning false
if not FileExists('changelog.txt') then
exit;
// create change log form
LoadChangelog(clChangelog);
clForm := TChangeLogForm.Create(AOwner);
Result := clForm.ShowModal = mrOK;
clForm.Free;
end;
end.
================================================
FILE: lib/mte/mteHelpers.pas
================================================
unit mteHelpers;
interface
uses
Windows, SysUtils, Forms, Classes, ComCtrls, Grids, StdCtrls, Types;
type
TCallback = procedure of object;
TAppHelpers = class
class procedure GetHelp(var Msg: TMsg; var Handled: Boolean);
class function HandleHelp(Command: Word; Data: Integer; var CallHelp: Boolean): Boolean;
end;
{ General functions }
function ShortenVersion(vs: string; numClauses: Integer): string;
function IfThenInt(AValue: boolean; ATrue: Integer = 1; AFalse: Integer = 0): Integer;
function TitleCase(sText: String): String;
function SentenceCase(sText: string): string;
function csvText(s: string): string;
function CopyFromTo(str: string; first, last: Integer): string;
function GetTextIn(str: string; open, close: char): string;
function FormatByteSize(const bytes: Int64): string;
function DateBuiltString(date: TDateTime): string;
function DateTimeToSQL(date: TDateTime): string;
function SQLToDateTime(date: string): TDateTime;
function RateStr(date: TDateTime): string;
function TimeStr(date: TDateTime): string;
function AppendIfMissing(str, substr: string): string;
function StrEndsWith(s1, s2: string): boolean;
function RemoveFromEnd(s1, s2: string): string;
function IntegerListSum(list: TStringList; maxIndex: integer): integer;
function Wordwrap(s: string; charCount: integer): string;
function ExtractPath(path: string; levels: integer): string;
function ContainsMatch(var sl: TStringList; const s: string): boolean;
procedure DeleteMatchingItems(item: string; var sl: TStringList);
function IsURL(s: string): boolean;
function IsDotFile(fn: string): boolean;
procedure SaveStringToFile(s: string; fn: string);
function ApplyTemplate(const template: string; var map: TStringList): string;
function VersionCompare(v1, v2: string): boolean;
procedure TryToFree(obj: TObject);
procedure FreeList(var lst: TList);
{ Windows API functions }
procedure ForceForeground(hWnd: THandle);
function GetDriveList: TStringDynArray;
function DOSDrive(const sDrive: String ): Integer;
function DriveReady(const sDrive: String): Boolean;
function TryRegistryKeys(var keys: TStringList): string;
function FileNameValid(filename: string): boolean;
function DirectoryValid(dir: string): boolean;
function UpDirectory(sPath: string): string;
function DeleteToRecycleBin(const path: string; Confirm: Boolean): Boolean;
procedure ExecNewProcess(ProgramName: string; synchronous: Boolean);
procedure BrowseForFile(var ed: TEdit; filter, initDir: string);
procedure BrowseForFolder(var ed: TEdit; initDir: string);
function GetCSIDLShellFolder(CSIDLFolder: integer): string;
function GetFileSize(const aFilename: String): Int64;
function GetLastModified(const aFileName: String): TDateTime;
function SearchPathsForFile(sPaths, sFileName: string): string;
function MultFileSearch(paths, filenames, ignore: array of string;
maxDepth: integer): string;
function RecursiveFileSearch(aPath: string; filenames, ignore: array of string;
maxDepth: integer): string;
procedure CopyDirectory(src, dst: string; fIgnore, dIgnore: TStringList);
procedure GetFilesList(path: string; var fIgnore, dIgnore, list: TStringList);
procedure CopyFiles(src, dst: string; var list: TStringList);
function GetVersionMem: string;
function FileVersion(const FileName: string): String;
procedure DeleteDirectory(const path: string);
procedure PerformFileSystemTests(sBasePath: string);
{ GUI Helper Functions }
procedure StringGrid_CorrectWidth(var sg: TStringGrid);
procedure ListView_CorrectWidth(var lv: TListView);
function ListView_NextMatch(ListView: TListView; sSearch: string;
iIndex: Integer): Integer;
procedure ListView_HandleMatch(ListView: TListView; iFoundIndex: Integer;
var sBuffer: string; sTempBuffer: string);
const
wndBorderSide = 8;
wndBorderTop = 30;
// TIME TRACKING
days = 1.0;
hours = 1.0 / 24.0;
minutes = hours / 60.0;
seconds = minutes / 60.0;
var
bAllowHelp: boolean;
enFormatSettings: TFormatSettings;
implementation
uses
Controls, Masks, Dialogs, StrUtils, FileCtrl, ShellApi,
Messages, CommCtrl, DateUtils, shlObj, IOUtils, Registry;
{******************************************************************************}
{ Application Helpers
General helpers for applications
}
{******************************************************************************}
class procedure TAppHelpers.GetHelp(var Msg: TMsg; var Handled: Boolean);
var
control: TControl;
sKeyword: string;
begin
if (Msg.message = WM_KEYDOWN) and (LoWord(Msg.wParam) = VK_F1) then begin
Screen.Cursor := crHelp;
Handled := true;
end
else if (Msg.message = WM_LBUTTONDOWN) and (Screen.Cursor = crHelp) then begin
// get control the user clicked on
control := FindVCLWindow(Mouse.CursorPos);
// if we found a control, jump to help keyword for that control
if Assigned(control) then begin
bAllowHelp := true;
sKeyword := control.HelpKeyword;
while (sKeyword = '') and Assigned(control.Parent) do begin
control := control.Parent;
sKeyword := control.HelpKeyword;
end;
Application.HelpKeyword(sKeyword);
Screen.Cursor := crDefault;
Handled := true;
end;
end;
end;
class function TAppHelpers.HandleHelp(Command: Word; Data: Integer;
var CallHelp: Boolean): Boolean;
begin
CallHelp := bAllowHelp;
bAllowHelp := false;
Result := true;
end;
{******************************************************************************}
{ General functions
Set of functions that help with converting data types and handling strings.
List of functions:
- IfThenInt
- TitleCase
- SentenceCase
- csvText
- CopyFromTo
- GetTextIn
- FormatByteSize
- DateBuiltString
- DateTimeToSQL
- SQLToDateTime
- RateStr
- TimeStr
- AppendIfMissing
- StrEndsWith
- RemoveFromEnd
- IntegerListSum
- Wordwrap
- ExtractPath
- ContainsMatch
- IsURL
- IsDotFile
- SaveStringToFile
- ApplyTemplate
}
{*****************************************************************************}
function ShortenVersion(vs: string; numClauses: Integer): string;
var
i, numDots: Integer;
begin
Result := '';
numDots := 0;
for i := 1 to Pred(Length(vs)) do begin
if vs[i] = '.' then
Inc(numDots);
if numDots = numClauses then
break;
Result := Result + vs[i];
end;
end;
{ Returns one of two integers based on a boolean argument.
Like IfThen from StrUtils, but returns an Integer. }
function IfThenInt(AValue: boolean; ATrue: Integer = 1; AFalse: Integer = 0): Integer;
begin
if AValue then
Result := ATrue
else
Result := AFalse;
end;
{ Capitalizes the first letter of each word }
function TitleCase(sText: String): String;
const
cDelimiters = [#9, #10, #13, ' ', ',', '.', ':', ';', '"',
'\', '/', '(', ')', '[', ']', '{', '}'];
var
iLoop: Integer;
begin
Result := sText;
if (Result <> '') then begin
Result := LowerCase(Result);
Result[1] := UpCase(Result[1]);
for iLoop := 2 to Length(Result) do
if (Result[iLoop - 1] in cDelimiters) then
Result[iLoop] := UpCase(Result[iLoop]);
end;
end;
{ Capitalizes first character of each sentence }
function SentenceCase(sText: string): string;
const
cTerminators = ['!', '.', '?'];
var
iLoop: Integer;
bTerminated: boolean;
begin
Result := sText;
if (Result <> '') then begin
Result := LowerCase(Result);
Result[1] := UpCase(Result[1]);
bTerminated := false;
for iLoop := 2 to Length(Result) do begin
if (Result[iLoop - 1] in cTerminators) then
bTerminated := true;
if bTerminated and (Result[iLoop] <> ' ') then
Result[iLoop] := UpCase(Result[iLoop]);
end;
end;
end;
{ Replaces newlines with a comma and space }
function csvText(s: string): string;
begin
result := StringReplace(Trim(s), #13, ', ', [rfReplaceAll]);
end;
{ Copies a substring in a string between two indexes }
function CopyFromTo(str: string; first, last: Integer): string;
begin
Result := Copy(str, first, (last - first) + 1);
end;
{ Returns a substring of @str between characters @open and @close }
function GetTextIn(str: string; open, close: char): string;
var
i, openIndex: integer;
bOpen: boolean;
begin
Result := '';
bOpen := false;
openIndex := 0;
for i := 0 to Length(str) do begin
if not bOpen and (str[i] = open) then begin
openIndex := i;
bOpen := true;
end;
if bOpen and (str[i] = close) then begin
Result := CopyFromTo(str, openIndex + 1, i - 1);
break;
end;
end;
end;
{ Format file byte size }
function FormatByteSize(const bytes: Int64): string;
const
B = 1; //byte
KB = 1024 * B; //kilobyte
MB = 1024 * KB; //megabyte
GB = 1024 * MB; //gigabyte
begin
if bytes > GB then
result := FormatFloat('#.## GB', bytes / GB)
else
if bytes > MB then
result := FormatFloat('#.## MB', bytes / MB)
else
if bytes > KB then
result := FormatFloat('#.## KB', bytes / KB)
else
if bytes > 0 then
result := FormatFloat('#.## bytes', bytes)
else
result := '0 bytes';
end;
{ Converts a TDateTime to a string, with 0 being the string 'Never' }
function DateBuiltString(date: TDateTime): string;
begin
if date = 0 then
Result := 'Never'
else begin
Result := DateTimeToStr(date);
end;
end;
function DateTimeToSQL(date: TDateTime): string;
begin
Result := FormatDateTime('yyyy-mm-dd hh:mm:ss', date);
end;
function SQLToDateTime(date: string): TDateTime;
var
fs: TFormatSettings;
begin
GetLocaleFormatSettings(GetThreadLocale, fs);
fs.DateSeparator := '-';
fs.ShortDateFormat := 'yyyy-mm-dd';
fs.TimeSeparator := ':';
fs.LongTimeFormat := 'hh:nn:ss';
Result := StrToDateTime(date, fs);
end;
{ Converts a TDateTime to a rate string, e.g. Every 24.0 hours }
function RateStr(date: TDateTime): string;
begin
if date > 1.0 then
Result := Format('Every %0.2f days', [date])
else if date * 24.0 > 1.0 then
Result := Format('Every %0.1f hours', [date * 24.0])
else if date * 24.0 * 60.0 > 1.0 then
Result := Format('Every %0.1f minutes', [date * 24.0 * 60.0])
else
Result := Format('Every %0.1f seconds', [date * 24.0 * 60.0 * 60.0]);
end;
{ Converts a TDateTime to a time string, e.g. 19d 20h 3m 30s }
function TimeStr(date: TDateTime): string;
begin
Result := Format('%dd %dh %dm', [Trunc(date), HourOf(date), MinuteOf(date)]);
end;
{
StrEndsWith:
Checks to see if a string ends with an entered substring.
Example usage:
s := 'This is a sample string.';
if StrEndsWith(s, 'string.') then
AddMessage('It works!');
}
function StrEndsWith(s1, s2: string): boolean;
var
n1, n2: integer;
begin
Result := false;
n1 := Length(s1);
n2 := Length(s2);
if n1 < n2 then exit;
Result := (Copy(s1, n1 - n2 + 1, n2) = s2);
end;
{
AppendIfMissing:
Appends substr to the end of str if it's not already there.
Example usage:
s := 'This is a sample string.';
Logger.Write(AppendIfMissing(s, 'string.')); //'This is a sample string.'
Logger.Write(AppendIfMissing(s, ' Hello.')); //'This is a sample string. Hello.'
}
function AppendIfMissing(str, substr: string): string;
begin
Result := str;
if not StrEndsWith(str, substr) then
Result := str + substr;
end;
{
RemoveFromEnd:
Creates a new string with s1 removed from the end of s2, if found.
Example usage:
s := 'This is a sample string.';
AddMessage(RemoveFromEnd(s, 'string.')); //'This is a sample '
}
function RemoveFromEnd(s1, s2: string): string;
begin
Result := s1;
if StrEndsWith(s1, s2) then
Result := Copy(s1, 1, Length(s1) - Length(s2));
end;
{ Calculates the integer sum of all values in a TStringList to maxIndex }
function IntegerListSum(list: TStringList; maxIndex: integer): integer;
var
i: Integer;
begin
Result := 0;
for i := 0 to maxIndex do
Inc(result, StrToInt(list[i]));
end;
{ Inserts line breaks in string @s before @charCount has been exceeded }
function Wordwrap(s: string; charCount: integer): string;
var
i, lastSpace, counter: Integer;
begin
counter := 0;
lastSpace := 0;
for i := 1 to Length(s) - 1 do begin
Inc(counter);
if (s[i] = ' ') or (s[i] = ',') then
lastSpace := i;
if (s[i] = #13) or (s[i] = #10)
or (s[i + 1] = #13) or (s[i + 1] = #10) then begin
lastSpace := 0;
counter := 0;
end;
if (counter = charCount) and (lastSpace > 0) then begin
Insert(#13#10, s, lastSpace + 1);
lastSpace := 0;
counter := 0;
end;
end;
Result := s;
end;
{ Like ExtractFilePath, but will allow the user to specify how many @levels
they want to traverse back. Specifying @levels = 0 is equivalent to
ExtractFilePath.
Example usage:
path := 'C:\Program Files (x86)\Test\Test.exe';
ShowMessage(ExtractPath(path, 0)); // 'C:\Program Files (x86)\Test\'
ShowMessage(ExtractPath(path, 1)); // 'C:\Program Files (x86)\'
ShowMessage(ExtractPath(path, 2)); // 'C:\'
}
function ExtractPath(path: string; levels: integer): string;
var
i, n: integer;
begin
n := 0;
for i := Length(path) downto 1 do
if IsPathDelimiter(path, i) then begin
if n = levels then
break
else
Inc(n);
end;
Result := Copy(path, 1, i);
end;
{ Checks to see if any mask in @sl matches the string @s }
function ContainsMatch(var sl: TStringList; const s: string): boolean;
var
i: Integer;
begin
Result := false;
for i := 0 to Pred(sl.Count) do
if MatchesMask(s, sl[i]) then begin
Result := true;
break;
end;
end;
{ Deletes items from @sl that match the input string @item }
procedure DeleteMatchingItems(item: string; var sl: TStringList);
var
i: Integer;
begin
for i := Pred(sl.Count) downto 0 do begin
if sl[i] = item then
sl.Delete(i);
end;
end;
{ Returns true if the string is an http:// or https:// url }
function IsURL(s: string): boolean;
begin
Result := (Pos('http://', s) = 1) or (Pos('https://', s) = 1);
end;
{ Returns true if @fn is . or .. }
function IsDotFile(fn: string): boolean;
begin
Result := (fn = '.') or (fn = '..');
end;
{ Saves a string @s to a file at @fn }
procedure SaveStringToFile(s: string; fn: string);
var
sl: TStringList;
begin
sl := TStringList.Create;
sl.Text := s;
sl.SaveToFile(fn);
sl.Free;
end;
function ApplyTemplate(const template: string; var map: TStringList): string;
const
openTag = '{{';
closeTag = '}}';
var
i: Integer;
name, value: string;
begin
Result := template;
for i := 0 to Pred(map.Count) do begin
name := map.Names[i];
value := map.ValueFromIndex[i];
Result := StringReplace(Result, openTag + name + closeTag, value, [rfReplaceAll]);
end;
end;
function VersionCompare(v1, v2: string): boolean;
var
sl1, sl2: TStringList;
i, c1, c2: integer;
begin
Result := false;
// parse versions with . as delimiter
sl1 := TStringList.Create;
sl1.LineBreak := '.';
sl1.Text := v1;
sl2 := TStringList.Create;
sl2.LineBreak := '.';
sl2.Text := v2;
// look through each version clause and perform comparisons
i := 0;
while (i < sl1.Count) and (i < sl2.Count) do begin
c1 := StrToInt(sl1[i]);
c2 := StrToInt(sl2[i]);
if (c1 < c2) then begin
Result := true;
break;
end
else if (c1 > c2) then begin
Result := false;
break;
end;
Inc(i);
end;
// free ram
sl1.Free;
sl2.Free;
end;
procedure TryToFree(obj: TObject);
begin
if Assigned(obj) then try
obj.Free;
except
on x: Exception do // nothing
end;
end;
procedure FreeList(var lst: TList);
var
i: Integer;
obj: TObject;
begin
for i := Pred(lst.Count) downto 0 do begin
obj := TObject(lst[i]);
TryToFree(obj);
end;
lst.Free;
end;
{******************************************************************************}
{ Windows API functions
Set of functions that help deal with the Windows File System.
List of functions:
- ForceForeground
- FileNameValid
- RecycleDirectory
- ExecNewProcess
- BrowseForFile
- BrowseForFolder
- GetCSIDLShellFolder
- GetFileSize
- GetLastModified
- MultFileSearch
- RecursiveFileSearch
- CopyDirectory
- GetFilesList
- CopyFiles
- CorrectListViewWidth
- GetVersionMem
- FileVersion
- DeleteDirectory
}
{******************************************************************************}
{
ForceForeground:
Forces a hWnd to the foreground.
}
procedure ForceForeground(hWnd: THandle);
begin
SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOMOVE);
SetWindowPos(hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOMOVE);
end;
{
GetDriveList:
Returns an array filled wit the assigned
drive letters on the current computer.
}
function GetDriveList: TStringDynArray;
var
Buff: array[0..128] of Char;
ptr: PChar;
Idx: Integer;
begin
if (GetLogicalDriveStrings(Length(Buff), Buff) = 0) then
RaiseLastOSError;
// There can't be more than 26 lettered drives (A..Z).
SetLength(Result, 26);
Idx := 0;
ptr := @Buff;
while StrLen(ptr) > 0 do
begin
Result[Idx] := ptr;
ptr := StrEnd(ptr);
Inc(ptr);
Inc(Idx);
end;
SetLength(Result, Idx);
end;
{
DOSDrive:
Converts a drive letter into the integer drive #
required by DiskSize().
}
function DOSDrive( const sDrive: String ): Integer;
begin
if (Length(sDrive) < 1) then
Result := -1
else
Result := (Ord(UpCase(sDrive[1])) - 64);
end;
{
DriveReady:
Tests the status of a drive to see if it's ready
to access.
}
function DriveReady(const sDrive: String): Boolean;
var
ErrMode: Word;
begin
ErrMode := SetErrorMode(0);
SetErrorMode(ErrMode or SEM_FAILCRITICALERRORS);
try
Result := (DiskSize(DOSDrive(sDrive)) > -1);
finally
SetErrorMode(ErrMode);
end;
end;
{
TryRegistryKeys:
Tries to load various registry keys.
}
function TryRegistryKeys(var keys: TStringList): string;
var
i: Integer;
path, name: string;
begin
Result := '';
with TRegistry.Create do try
RootKey := HKEY_LOCAL_MACHINE;
// try all keys
for i := 0 to Pred(keys.Count) do begin
path := ExtractFilePath(keys[i]);
name := ExtractFileName(keys[i]);
if OpenKeyReadOnly(path) then begin
Result := ReadString(name);
break;
end;
end;
finally
Free;
end;
end;
{
DirectoryValid:
Returns true if the input directory path is valid.
}
function DirectoryValid(dir: string): boolean;
begin
Result := false;
if (dir = '') then
exit;
dir := ExcludeTrailingPathDelimiter(dir);
{$IFDEF MSWINDOWS}
if (Length(dir) < 3) or (ExtractFilePath(dir) = dir) then
exit; // avoid 'xyz:\' problem.
{$ENDIF}
{$IFDEF POSIX}
if (dir = '') then
exit;
{$ENDIF POSIX};
Result := true;
end;
{
UpDirectory:
Returns the path of the directory holding a directory.
}
function UpDirectory(sPath: string): string;
begin
if not StrEndsWith(sPath, '\') then
sPath := ExtractFilePath(sPath);
Result := ExtractFilePath(RemoveFromEnd(sPath, '\'));
end;
{
FileNameValid:
Returns true if the input filename is valid.
}
function FileNameValid(filename: string): boolean;
begin
Result := (Length(Trim(filename)) > 0) and
TPath.HasValidFileNameChars(filename, false);
end;
{
ExecNewProcess:
Create a new synchronous or asynchronous process.
}
procedure ExecNewProcess(ProgramName: string; synchronous: Boolean);
var
StartInfo : TStartupInfo;
ProcInfo : TProcessInformation;
CreateOK : Boolean;
begin
{ fill with known state }
FillChar(StartInfo, SizeOf(TStartupInfo), #0);
FillChar(ProcInfo, SizeOf(TProcessInformation), #0);
StartInfo.cb := SizeOf(TStartupInfo);
CreateOK := CreateProcess(PChar(ProgramName), nil, nil, nil,False,
CREATE_NEW_PROCESS_GROUP+NORMAL_PRIORITY_CLASS,
nil, nil, StartInfo, ProcInfo);
// check if successful
if CreateOK then begin
if synchronous then
WaitForSingleObject(ProcInfo.hProcess, INFINITE);
end
else
ShowMessage('Unable to run '+ProgramName);
// close handles
CloseHandle(ProcInfo.hProcess);
CloseHandle(ProcInfo.hThread);
end;
{
BrowseForFile:
Links a file selection through a TOpenDialog to the text stored in @ed,
applying filter @filter.
}
procedure BrowseForFile(var ed: TEdit; filter, initDir: string);
var
openDialog: TOpenDialog;
begin
openDialog := TOpenDialog.Create(ed.Parent);
if FileExists(ed.Text) then
openDialog.InitialDir := ExtractFilePath(ed.Text)
else if DirectoryExists(ed.Text) then
openDialog.InitialDir := ed.Text
else
openDialog.InitialDir := initDir;
openDialog.Filter := filter;
if openDialog.Execute then
ed.Text := openDialog.FileName;
end;
{
BrowseForFolder:
Links a file selection through a TOpenDialog to the text stored in @ed,
applying filter @filter
}
procedure BrowseForFolder(var ed: TEdit; initDir: string);
var
s: string;
begin
// start in current directory value if valid
if DirectoryExists(ed.Text) then
s := ed.Text
else
s := initDir;
// prompt user to select a directory
SelectDirectory('Select a directory', '', s, []);
// save text to TEdit
if s <> '' then
ed.Text := AppendIfMissing(s, '\');
end;
{
GetCSIDLShellFolder:
Gets a folder by its integer CSID.
}
function GetCSIDLShellFolder(CSIDLFolder: integer): string;
begin
SetLength(Result, MAX_PATH);
SHGetSpecialFolderPath(0, PChar(Result), CSIDLFolder, True);
SetLength(Result, StrLen(PChar(Result)));
if (Result <> '') then
Result := IncludeTrailingBackslash(Result);
end;
{
GetFileSize:
Gets the size of a file at @aFilename through the windows API.
}
function GetFileSize(const aFilename: String): Int64;
var
info: TWin32FileAttributeData;
begin
result := -1;
if NOT GetFileAttributesEx(PWideChar(aFileName), GetFileExInfoStandard, @info) then
EXIT;
result := Int64(info.nFileSizeLow) or Int64(info.nFileSizeHigh shl 32);
end;
{
GetLastModified:
Gets the last time a file was modified.
}
function GetLastModified(const aFileName: String): TDateTime;
var
info: TWin32FileAttributeData;
FileTime: TFileTime;
LocalTime, SystemTime: TSystemTime;
begin
result := 0;
// exit if can't get attributes
if not GetFileAttributesEx(PWideChar(aFileName), GetFileExInfoStandard, @info) then
exit;
// get last modified
FileTime := info.ftLastWriteTime;
// convert to system time
if not FileTimeToSystemTime(FileTime, SystemTime) then
RaiseLastOSError;
if not SystemTimeToTzSpecificLocalTime(nil, SystemTime, LocalTime) then
RaiseLastOSError;
Result := SystemTimeToDateTime(LocalTime);
end;
{
SearchPathsForFile:
Searches for a file @sFileName in each path in @sPaths.
}
function SearchPathsForFile(sPaths, sFileName: string): string;
var
slPaths: TStringList;
i: Integer;
info: TSearchRec;
begin
slPaths := TStringList.Create;
try
while (Pos(';', sPaths) > 0) do begin
slPaths.Add(Copy(sPaths, 1, Pos(';', sPaths) - 1));
sPaths := Copy(sPaths, Pos(';', sPaths) + 1, Length(sPaths));
end;
for i := 0 to slPaths.Count - 1 do begin
if FindFirst(slPaths[i] + '\*', faDirectory, info) = 0 then begin
repeat
Result := FileSearch(sFileName, slPaths[i] + '\' + info.Name);
if (Result <> '') then
break;
until FindNext(info) <> 0;
FindClose(info);
// break if we found it
if (Result <> '') then
break;
end;
end;
finally
slPaths.Free;
end;
end;
{
MultFileSearch:
Wraps around RecursiveFileSearch, allowing the searching of multiple paths.
}
function MultFileSearch(paths, filenames, ignore: array of string; maxDepth: integer): string;
var
i: Integer;
path: string;
begin
for i := Low(paths) to High(paths) do begin
path := RecursiveFileSearch(paths[i], filenames, ignore, maxDepth);
if path <> '' then
break;
end;
Result := path;
end;
{
RecursiveFileSearch:
Recursively searches a path for a file matching @filenames, ignoring
directories in @ignore, and not traversing deeper than maxDepth.
Example usage:
p := RecursiveFileSearch(GamePath, filenames, ignore, 1);
AddMessage(p);
}
function RecursiveFileSearch(aPath: string; filenames, ignore: array of string;
maxDepth: integer): string;
var
skip: boolean;
i: integer;
info: TSearchRec;
begin
Result := '';
aPath := AppendIfMissing(aPath, PathDelim);
if Result <> '' then exit;
// exit if no files in path
if FindFirst(aPath + '*', faAnyFile, info) <> 0 then
exit;
// else loop through all files in path
repeat
if IsDotFile(info.Name) then
continue; // skip . and ..
skip := false;
for i := Low(ignore) to High(ignore) do begin
skip := Lowercase(info.Name) = ignore[i];
if skip then
break;
end;
if not skip then begin
if ((info.attr and faDirectory) = faDirectory) and (maxDepth > 0) then begin
Result := RecursiveFileSearch(aPath+info.Name, filenames, ignore, maxDepth - 1);
end
else if MatchStr(info.Name, filenames) then
Result := aPath + info.Name;
end;
if (Result <> '') then break;
until FindNext(info) <> 0;
FindClose(info);
end;
{
CopyDirectory:
Recursively copies all of the contents of a directory.
Example usage:
slIgnore := TStringList.Create;
slIgnore.Add('mteFunctions.pas');
CopyDirectory(ScriptsPath, 'C:\ScriptsBackup', slIgnore);
}
procedure CopyDirectory(src, dst: string; fIgnore, dIgnore: TStringList);
var
info: TSearchRec;
isDirectory: boolean;
begin
src := AppendIfMissing(src, PathDelim);
dst := AppendIfMissing(dst, PathDelim);
// if no files in source path, exit
if (FindFirst(src + '*', faAnyFile, info) <> 0) then
exit;
repeat
isDirectory := (info.Attr and faDirectory = faDirectory);
// skip . and ..
if (info.Name = '.') or (info.Name = '..') then
continue;
// skip if ignored
if isDirectory and ContainsMatch(dIgnore, info.Name) then
continue
else if ContainsMatch(fIgnore, info.Name) then
continue;
// copy the file or recurse
ForceDirectories(dst);
if isDirectory then
CopyDirectory(src+info.Name, dst+info.Name, fIgnore, dIgnore)
else
CopyFile(PChar(src+info.Name), PChar(dst+info.Name), false);
until FindNext(info) <> 0;
FindClose(info);
end;
{
GetFilesList:
Searches @path, recursively traversing subdirectories that don't match a mask
in @dIgnore, adding files that don't match a mask in @fIgnore to @list.
Example usage:
FilesList := TStringList.Create;
fileIgnore := TStringList.Create;
fileIgnore.Add('*.esp');
dirIgnore := TStringList.Create;
dirIgnore.Add('translations');
GetFilesList(wbDataPath, fileIgnore, dirIgnore, FilesList);
}
procedure GetFilesList(path: string; var fIgnore, dIgnore, list: TStringList);
var
info: TSearchRec;
isDirectory: boolean;
begin
path := AppendIfMissing(path, PathDelim);
// if no files in source path, exit
if (FindFirst(path + '*', faAnyFile, info) <> 0) then
exit;
repeat
isDirectory := (info.Attr and faDirectory = faDirectory);
// skip . and ..
if (info.Name = '.') or (info.Name = '..') then
continue;
// skip if ignored
if isDirectory then begin
if ContainsMatch(dIgnore, info.Name) then
continue;
end
else if ContainsMatch(fIgnore, info.Name) then
continue;
// copy the file or recurse
if isDirectory then
GetFilesList(path + info.Name, fIgnore, dIgnore, list)
else
list.Add(path + info.Name);
until FindNext(info) <> 0;
FindClose(info);
end;
{ Copies files in @list from @src to @dst }
procedure CopyFiles(src, dst: string; var list: TStringList);
var
i: Integer;
srcFile, dstFile: string;
begin
src := AppendIfMissing(src, PathDelim);
dst := AppendIfMissing(dst, PathDelim);
for i := 0 to Pred(list.Count) do begin
srcFile := list[i];
dstFile := StringReplace(srcFile, src, dst, []);
ForceDirectories(ExtractFilePath(dstFile));
CopyFile(PChar(srcFile), PChar(dstFile), false);
end;
end;
{ Get program version from memory }
function GetVersionMem: string;
var
verblock: PVSFIXEDFILEINFO;
versionMS, versionLS, verlen: cardinal;
rs: TResourceStream;
m: TMemoryStream;
begin
m := TMemoryStream.Create;
try
rs := TResourceStream.CreateFromID(HInstance, 1, RT_VERSION);
try
m.CopyFrom(rs, rs.Size);
finally
rs.Free;
end;
m.Position := 0;
if VerQueryValue(m.Memory, '\', Pointer(verblock), verlen) then begin
VersionMS := verblock.dwFileVersionMS;
VersionLS := verblock.dwFileVersionLS;
Result := Format('%s.%s.%s.%s', [IntToStr(versionMS shr 16),
IntToStr(versionMS and $FFFF), IntToStr(VersionLS shr 16),
IntToStr(VersionLS and $FFFF)]);
end;
finally
m.Free;
end;
end;
{ Get program version from disk }
function FileVersion(const FileName: string): String;
var
VerInfoSize: Cardinal;
VerValueSize: Cardinal;
Dummy: Cardinal;
PVerInfo: Pointer;
PVerValue: PVSFixedFileInfo;
begin
Result := '';
VerInfoSize := GetFileVersionInfoSize(PChar(FileName), Dummy);
GetMem(PVerInfo, VerInfoSize);
try
if GetFileVersionInfo(PChar(FileName), 0, VerInfoSize, PVerInfo) then
if VerQueryValue(PVerInfo, '\', Pointer(PVerValue), VerValueSize) then
with PVerValue^ do
Result := Format('%d.%d.%d.%d', [
HiWord(dwFileVersionMS), //Major
LoWord(dwFileVersionMS), //Minor
HiWord(dwFileVersionLS), //Release
LoWord(dwFileVersionLS)]); //Build
finally
FreeMem(PVerInfo, VerInfoSize);
end;
end;
{ Sends the file/directory at @path to the recycle bin }
function DeleteToRecycleBin(const path: string; Confirm: Boolean): Boolean;
var
sh: TSHFileOpStruct;
begin
FillChar(sh, SizeOf(sh), 0);
with sh do begin
Wnd := 0;
wFunc := FO_DELETE;
pFrom := PChar(path + #0);
fFlags := FOF_SILENT or FOF_ALLOWUNDO;
if not Confirm then
fFlags := fFlags or FOF_NOCONFIRMATION;
end;
Result := SHFileOperation(sh) = 0;
end;
{ Deletes the directory at @path and all files it contains }
procedure DeleteDirectory(const path: string);
var
ShOp: TSHFileOpStruct;
begin
ShOp.Wnd := 0;
ShOp.wFunc := FO_DELETE;
ShOp.pFrom := PChar(path + #0);
ShOp.pTo := nil;
ShOp.fFlags := FOF_NOCONFIRMATION or FOF_ALLOWUNDO or FOF_NO_UI;
SHFileOperation(ShOp);
end;
{ Performs tests of directory creation and deletion, and file creation,
reading, writing, and deletion at the specified @sBasePath }
procedure PerformFileSystemTests(sBasePath: string);
var
sl1, sl2: TStringList;
sExceptionBase, sPath, sTask: string;
begin
// initialize stringlists
sl1 := TStringList.Create;
sl2 := TStringList.Create;
sExceptionBase := 'Could not %s at path "%s"';
try
// try to create a new directory
sTask := 'create directory';
sPath := sBasePath + 'test\';
ForceDirectories(sPath);
if not DirectoryExists(sPath) then
raise Exception.Create(Format(sExceptionBase, [sTask, sPath]));
// try to create a new file
sTask := 'create file';
sPath := sBasePath + 'test\Test.txt';
sl1.Text := sBasePath;
sl1.SaveToFile(sPath);
// if file doesn't exist after saving, raise an exception
if not FileExists(sPath) then
raise Exception.Create(Format(sExceptionBase, [sTask, sPath]));
// try to read the file
sTask := 'read file';
sl2.LoadFromFile(sPath);
if sl2.Text <> sl1.Text then
raise Exception.Create(Format(sExceptionBase, [sTask, sPath]));
// try to write to the file
sTask := 'write to file';
sl1.Text := 'Testing 123abc';
sl1.SaveToFile(sPath);
sl2.LoadFromFile(sPath);
if sl2.Text <> sl1.Text then
raise Exception.Create(Format(sExceptionBase, [sTask, sPath]));
// try to delete the file
sTask := 'delete file';
DeleteFile(sPath);
if FileExists(sPath) then
raise Exception.Create(Format(sExceptionBase, [sTask, sPath]));
// try to delete the directory
sTask := 'delete directory';
sPath := sBasePath + 'test\';
DeleteDirectory(sPath);
if DirectoryExists(sPath) then
raise Exception.Create(Format(sExceptionBase, [sTask, sPath]));
finally
// always free memory
sl1.Free;
sl2.Free;
end;
end;
{******************************************************************************}
{ GUI Helper Functions
- ListView_CorrectWidth
- ListView_FindNextMatch
- ListView_HandleMatch
}
{******************************************************************************}
procedure StringGrid_CorrectWidth(var sg: TStringGrid);
var
w: Integer;
begin
w := sg.ClientWidth;
Dec(w, sg.ColWidths[0]);
sg.ColWidths[1] := w;
end;
{ Fixes @lv's width to fit client width if it has autosizable columns,
which resolves an issue where autosize doesn't work on virtual vsReport
TListViews when a scroll bar becomes visible. }
procedure ListView_CorrectWidth(var lv: TListView);
var
i, w: Integer;
col: TListColumn;
AutoSizedColumns: TList;
begin
AutoSizedColumns := TList.Create;
w := lv.ClientWidth;
// loop through columns keeping track of remaining width
for i := 0 to Pred(lv.Columns.Count) do begin
col := lv.Columns[i];
if col.AutoSize then
AutoSizedColumns.Add(col)
else
Dec(w, ListView_GetColumnWidth(lv.Handle, i));
end;
// set auotsized columns to fit client width
for i := 0 to Pred(AutoSizedColumns.Count) do begin
col := TListColumn(AutoSizedColumns[i]);
col.Width := w div AutoSizedColumns.Count;
end;
// clean up
AutoSizedColumns.Free;
end;
{ If @iIndex = 0, returns the index of the next @ListView item
matching the input @sSearch string. Else returns the index
of the next @ListView subitem at index @iIndex - 1 matching
the input @sSearch string. }
function ListView_NextMatch(ListView: TListView; sSearch: string;
iIndex: Integer): Integer;
var
i, iStart: Integer;
ListItem: TListITem;
sCaption, sCompare: string;
begin
Result := -1;
// Start at selected item's index, if there
// is an item selected
if Assigned(ListView.Selected) then
iStart := ListView.Selected.Index
// Else start at 0, the first item
else
iStart := 0;
// Loop through items looking for a match
for i := iStart to Pred(ListView.Items.Count) do begin
ListItem := ListView.Items[i];
if iIndex = 0 then
sCaption := ListItem.Caption
else
sCaption := ListItem.SubItems[iIndex - 1];
sCompare := Copy(sCaption, 1, Length(sSearch));
if SameText(sSearch, sCompare) then begin
Result := i;
break;
end;
end;
end;
{ Sets @sBuffer to @sTempBuffer, then selects and jumps to the item
at @iFoundIndex in @ListView }
procedure ListView_HandleMatch(ListView: TListView; iFoundIndex: Integer;
var sBuffer: string; sTempBuffer: string);
begin
// Set the actual buffer to our temporary buffer
// and jump to the item we found
sBuffer := sTempBuffer;
if Assigned(ListView.Selected) then
ListView.ClearSelection;
ListView.Selected := ListView.Items[iFoundIndex];
ListView.Items[iFoundIndex].MakeVisible(false);
end;
initialization
begin
bAllowHelp := false;
enFormatSettings := TFormatSettings.Create('en-us');
enFormatSettings.DecimalSeparator := '.';
enFormatSettings.ThousandSeparator := ',';
end;
end.
================================================
FILE: lib/mte/mteLogger.pas
================================================
unit mteLogger;
interface
uses Classes, SysUtils;
type
TLogEvent = procedure(const group, &label, text: string) of object;
TLogger = class
private
FLogEvent : TLogEvent;
public
procedure Write(const group, &label, text: string);
property OnLogEvent: TLogEvent read FLogEvent write FLogEvent;
end;
var Logger : TLogger;
implementation
procedure TLogger.Write(const group, &label, text: string);
begin
if Assigned(FLogEvent) then
FLogEvent(group, &label, text);
end;
initialization
Logger := TLogger.Create;
finalization
FreeAndNil(Logger);
end.
================================================
FILE: lib/mte/mteLogging.pas
================================================
{
mteLogging
created by matortheeternal
This unit contains the TFilter and TLogMessage types which offer filterable
logging for Delphi VCL applications. Log messages have a group and a label,
and filters can apply to groups or labels.
}
unit mteLogging;
interface
uses
Classes, SysUtils, Forms,
// mte units
mteProgressForm, mteHelpers;
type
TFilter = class(TObject)
public
group: string;
&label: string;
enabled: boolean;
constructor Create(group: string; enabled: boolean); Overload;
constructor Create(group, &label: string; enabled: boolean); Overload;
end;
TLogMessage = class (TObject)
public
time: string;
appTime: string;
group: string;
&label: string;
text: string;
constructor Create(time, appTime, group, &label, text: string); Overload;
end;
{ Log methods }
procedure RebuildLog;
procedure SaveLog(var Log: TList);
function MessageEnabled(msg: TLogMessage): boolean;
procedure ShowProgressForm(parent: TForm; var pf: TProgressForm;
sCaption, sLogSubPath: string);
var
BaseLog, Log, LabelFilters, GroupFilters: TList;
LogPath: string;
TimeCosts: TStringList;
AppStartTime: TDateTime;
implementation
{ TFilter }
constructor TFilter.Create(group: string; enabled: boolean);
begin
self.group := group;
self.enabled := enabled;
end;
constructor TFilter.Create(group, &label: string; enabled: boolean);
begin
self.group := group;
self.&label := &label;
self.enabled := enabled;
end;
{ TLogMessage }
constructor TLogMessage.Create(time, appTime, group, &label, text: string);
begin
self.time := time;
self.appTime := appTime;
self.group := group;
self.&label := &label;
self.text := text;
end;
{******************************************************************************}
{ Log methods
Set of methods for logging
List of methods:
- InitLog
- RebuildLog
- SaveLog
- MessageGroupEnabled
}
{******************************************************************************}
procedure RebuildLog;
var
i: Integer;
msg: TLogMessage;
begin
Log.Clear;
for i := 0 to Pred(BaseLog.Count) do begin
msg := TLogMessage(BaseLog[i]);
if MessageEnabled(msg) then
Log.Add(msg);
end;
end;
procedure SaveLog(var Log: TList);
var
sl: TStringList;
i: Integer;
msg: TLogMessage;
fdt: string;
begin
sl := TStringList.Create;
for i := 0 to Pred(Log.Count) do begin
msg := TLogMessage(Log[i]);
sl.Add(Format('[%s] (%s) %s: %s', [msg.time, msg.group, msg.&label, msg.text]));
end;
fdt := FormatDateTime('mmddyy_hhnnss', TDateTime(Now));
ForceDirectories(LogPath+'main\');
sl.SaveToFile(LogPath+'main\log_'+fdt+'.txt');
sl.Free;
end;
function GetGroupFilter(msg: TLogMessage): TFilter;
var
i: Integer;
filter: TFilter;
begin
Result := nil;
for i := 0 to Pred(GroupFilters.Count) do begin
filter := TFilter(GroupFilters[i]);
if filter.group = msg.group then begin
Result := filter;
exit;
end;
end;
end;
function GetLabelFilter(msg: TLogMessage): TFilter;
var
i: Integer;
filter: TFilter;
begin
Result := nil;
for i := 0 to Pred(LabelFilters.Count) do begin
filter := TFilter(LabelFilters[i]);
if (filter.&label = msg.&label) and (filter.group = msg.group) then begin
Result := filter;
exit;
end;
end;
end;
function MessageEnabled(msg: TLogMessage): boolean;
var
GroupFilter, LabelFilter: TFilter;
begin
Result := true;
GroupFilter := GetGroupFilter(msg);
LabelFilter := GetLabelFilter(msg);
if GroupFilter <> nil then
Result := Result and GroupFilter.enabled;
if LabelFilter <> nil then
Result := Result and LabelFilter.enabled;
end;
procedure ShowProgressForm(parent: TForm; var pf: TProgressForm;
sCaption, sLogSubPath: string);
begin
pf := TProgressForm.Create(parent);
pf.pfLogPath := LogPath + sLogSubPath + '\';
pf.PopupParent := parent;
pf.Caption := sCaption;
pf.SetMaxProgress(IntegerListSum(timeCosts, Pred(timeCosts.Count)));
pf.Show;
end;
initialization
begin
BaseLog := TList.Create;
Log := TList.Create;
LabelFilters := TList.Create;
GroupFilters := TList.Create;
end;
finalization
begin
FreeList(BaseLog);
Log.Free;
end;
end.
================================================
FILE: lib/mte/mtePluginSelectionForm.dfm
================================================
object PluginSelectionForm: TPluginSelectionForm
Left = 0
Top = 0
HelpType = htKeyword
HelpKeyword = 'Plugin Selection Window'
Caption = 'Plugin Selection'
ClientHeight = 647
ClientWidth = 504
Color = clBtnFace
Constraints.MinHeight = 400
Constraints.MinWidth = 400
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnClose = FormClose
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object lvPlugins: TListView
Left = 8
Top = 8
Width = 488
Height = 600
HelpType = htKeyword
HelpKeyword = 'Plugin Selection Styles'
Align = alCustom
Anchors = [akLeft, akTop, akRight, akBottom]
Columns = <>
ColumnClick = False
DoubleBuffered = True
MultiSelect = True
OwnerData = True
OwnerDraw = True
ReadOnly = True
RowSelect = True
ParentDoubleBuffered = False
ParentShowHint = False
PopupMenu = PluginsPopupMenu
ShowHint = False
StateImages = StateImages
TabOrder = 0
ViewStyle = vsReport
OnChange = lvPluginsChange
OnData = lvPluginsData
OnDrawItem = lvPluginsDrawItem
OnKeyPress = lvPluginsKeyPress
OnMouseDown = lvPluginsMouseDown
OnMouseMove = lvPluginsMouseMove
end
object btnCancel: TButton
Left = 421
Top = 614
Width = 75
Height = 25
HelpType = htKeyword
HelpKeyword = 'Plugin Selection Actions'
Align = alCustom
Anchors = [akRight, akBottom]
Caption = 'Cancel'
ModalResult = 2
TabOrder = 1
end
object btnOK: TButton
Left = 340
Top = 614
Width = 75
Height = 25
HelpType = htKeyword
HelpKeyword = 'Plugin Selection Actions'
Align = alCustom
Anchors = [akRight, akBottom]
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 2
OnClick = btnOKClick
end
object PluginsPopupMenu: TPopupMenu
OnPopup = PluginsPopupMenuPopup
Left = 48
Top = 24
object CheckAllItem: TMenuItem
Caption = 'Check all'
OnClick = CheckAllItemClick
end
object UncheckAllItem: TMenuItem
Caption = 'Uncheck all'
OnClick = UncheckAllItemClick
end
object ToggleAllItem: TMenuItem
Caption = 'Toggle all'
OnClick = ToggleAllItemClick
end
object N1: TMenuItem
Caption = '-'
end
object MastersItem: TMenuItem
Caption = 'Masters'
object CheckMastersItem: TMenuItem
Caption = 'Check masters'
OnClick = CheckMastersItemClick
end
object UncheckMastersItem: TMenuItem
Caption = 'Uncheck masters'
OnClick = UncheckMastersItemClick
end
end
object DependenciesItem: TMenuItem
Caption = 'Dependencies'
object CheckDependenciesItem: TMenuItem
Caption = 'Check dependencies'
OnClick = CheckDependenciesItemClick
end
object UncheckDependenciesItem: TMenuItem
Caption = 'Uncheck dependencies'
OnClick = UncheckDependenciesItemClick
end
end
end
object StateImages: TImageList
Height = 17
Width = 17
Left = 136
Top = 24
Bitmap = {
494C010103003400600011001100FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600
0000000000003600000028000000440000001100000001002000000000001012
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000008F8F8E008F8F
8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F
8E008F8F8E008F8F8E008F8F8E00000000000000000000000000000000008F8F
8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F
8E008F8F8E008F8F8E008F8F8E008F8F8E000000000000000000000000000000
00008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F
8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E0000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000008F8F8E00F4F4F400F4F4F400F4F4F400F5F5F500F9F9
F900F8F8F800F5F5F500F4F4F400F4F4F400F4F4F400F4F4F4008F8F8E000000
00000000000000000000000000008F8F8E00F4F4F400F4F4F400F4F4F400F5F5
F500F9F9F900F8F8F800F5F5F500F4F4F400F4F4F400F4F4F400F4F4F4008F8F
8E00000000000000000000000000000000008F8F8E00F4F4F400F4F4F400F4F4
F400F4F4F400F4F4F400F4F4F400F4F4F400F4F4F400F4F4F400F4F4F400F4F4
F4008F8F8E000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000008F8F8E00F4F4
F400CCCBCA00DBDADA00E9E2DF00BA998C00BD9D9000F6F3F200EDEDEC00ECEB
EB00EAE9E900F4F4F4008F8F8E00000000000000000000000000000000008F8F
8E00F4F4F400CCCBCA00DBDADA00E9E2DF00BA998C00BD9D9000F6F3F200EDED
EC00ECEBEB00EAE9E900F4F4F4008F8F8E000000000000000000000000000000
00008F8F8E00F4F4F400CCCBCA00D5D4D400DCDBDB00E1E1E000E7E7E600EBEB
EA00ECECEB00ECEBEB00EAE9E900F4F4F4008F8F8E0000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000008F8F8E00F4F4F400CAC8C600F0ECEA00BB998B00975F
4A0098614C00D1B9B000F9F9F900F6F6F600E6E6E600F4F4F4008F8F8E000000
00000000000000000000000000008F8F8E00F4F4F400CAC8C600F0ECEA00BB99
8B00975F4A0098614C00D1B9B000F9F9F900F6F6F600E6E6E600F4F4F4008F8F
8E00000000000000000000000000000000008F8F8E00F4F4F400C6C4C200E9E9
E900EDEDED00F0F0F000F4F4F400F6F6F600F6F6F600F6F6F600E6E6E600F4F4
F4008F8F8E000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000008F8F8E00F4F4
F400D1CFCD00E9E1DE00955D4800965F490097604B00A4736100FAF9F800F4F4
F400E2E2E100F4F4F4008F8F8E00000000000000000000000000000000008F8F
8E00F4F4F400D1CFCD00E9E1DE00955D4800965F490097604B00A4736100FAF9
F800F4F4F400E2E2E100F4F4F4008F8F8E000000000000000000000000000000
00008F8F8E00F4F4F400C2BFBC00E5E4E300E9E9E900EDEDED00F2F2F200F4F4
F400F5F5F500F4F4F400E2E2E100F4F4F4008F8F8E0000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000008F8F8E00F4F4F400E1E0DE00AA7F6E00945C4700E2D4
CF00A778670097604B00D5BFB700F6F6F600DEDDDC00F4F4F4008F8F8E000000
00000000000000000000000000008F8F8E00F4F4F400E1E0DE00AA7F6E00945C
4700E2D4CF00A778670097604B00D5BFB700F6F6F600DEDDDC00F4F4F4008F8F
8E00000000000000000000000000000000008F8F8E00F4F4F400BFBBB800E1DF
DD00E5E5E400EAEAEA00EFEFEF00F2F2F200F2F2F200F2F2F200DEDDDC00F4F4
F4008F8F8E000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000008F8F8E00F4F4
F400CDC9C500DDCFC900C8AEA300EEEEED00D5C1BA00965E4900A5766400F8F8
F800D6D5D500F4F4F4008F8F8E00000000000000000000000000000000008F8F
8E00F4F4F400CDC9C500DDCFC900C8AEA300EEEEED00D5C1BA00965E4900A576
6400F8F8F800D6D5D500F4F4F4008F8F8E000000000000000000000000000000
00008F8F8E00F4F4F400BCB7B200DCD8D500DFDCDA00E3E1E000E8E8E800ECEC
EC00EDEDED00EDEDED00D6D5D400F4F4F4008F8F8E0000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000008F8F8E00F4F4F400B9B3AE00DDD9D500E5E2DF00DCD8
D500F4F3F200A1715E00945C4700D6C3BC00DCDCDB00F4F4F4008F8F8E000000
00000000000000000000000000008F8F8E00F4F4F400B9B3AE00DDD9D500E5E2
DF00DCD8D500F4F3F200A1715E00945C4700D6C3BC00DCDCDB00F4F4F4008F8F
8E00000000000000000000000000000000008F8F8E00F4F4F400B9B3AE00D7D1
CD00D9D4D000DBD7D400DFDDDB00E3E2E100E6E6E500E8E8E800CDCDCC00F4F4
F4008F8F8E000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000008F8F8E00F4F4
F400B9B3AE00D5CFCB00D5CFCB00D6D1CD00E6E2E000CFB8AF00925A4500A577
6500E8E7E700F4F4F4008F8F8E00000000000000000000000000000000008F8F
8E00F4F4F400B9B3AE00D5CFCB00D5CFCB00D6D1CD00E6E2E000CFB8AF00925A
4500A5776500E8E7E700F4F4F4008F8F8E000000000000000000000000000000
00008F8F8E00F4F4F400B9B3AE00D5CFCB00D5CFCB00D6D1CD00DAD5D200DEDB
D800E1DFDD00E4E3E200C8C7C600F4F4F4008F8F8E0000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000008F8F8E00F4F4F400B9B3AE00D5CFCB00D5CFCB00D5CF
CB00D6D0CC00F1EEED009D6A5700925A4400D0BFB900F6F6F6008F8F8E000000
00000000000000000000000000008F8F8E00F4F4F400B9B3AE00D5CFCB00D5CF
CB00D5CFCB00D6D0CC00F1EEED009D6A5700925A4400D0BFB900F6F6F6008F8F
8E00000000000000000000000000000000008F8F8E00F4F4F400B9B3AE00D5CF
CB00D5CFCB00D5CFCB00D5CFCB00D8D3D000DCD8D500DFDDDB00C5C3C100F4F4
F4008F8F8E000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000008F8F8E00F4F4
F400B9B3AE00B9B3AE00B9B3AE00B9B3AE00B9B3AE00D0CCC900C0A79D00AB86
7700E4DFDC00F5F5F5008F8F8E00000000000000000000000000000000008F8F
8E00F4F4F400B9B3AE00B9B3AE00B9B3AE00B9B3AE00B9B3AE00D0CCC900C0A7
9D00AB867700E4DFDC00F5F5F5008F8F8E000000000000000000000000000000
00008F8F8E00F4F4F400B9B3AE00B9B3AE00B9B3AE00B9B3AE00B9B3AE00B9B3
AE00BAB4AF00BDB9B400C1BEBB00F4F4F4008F8F8E0000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000008F8F8E00F4F4F400F4F4F400F4F4F400F4F4F400F4F4
F400F4F4F400F4F4F400F8F8F800F9F9F900F6F6F600F4F4F4008F8F8E000000
00000000000000000000000000008F8F8E00F4F4F400F4F4F400F4F4F400F4F4
F400F4F4F400F4F4F400F4F4F400F8F8F800F9F9F900F6F6F600F4F4F4008F8F
8E00000000000000000000000000000000008F8F8E00F4F4F400F4F4F400F4F4
F400F4F4F400F4F4F400F4F4F400F4F4F400F4F4F400F4F4F400F4F4F400F4F4
F4008F8F8E000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000008F8F8E008F8F
8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F
8E008F8F8E008F8F8E008F8F8E00000000000000000000000000000000008F8F
8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F
8E008F8F8E008F8F8E008F8F8E008F8F8E000000000000000000000000000000
00008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F
8E008F8F8E008F8F8E008F8F8E008F8F8E008F8F8E0000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000424D3E000000000000003E00000028000000440000001100000001000100
00000000CC0000000000000000000000000000000000000000000000FFFFFF00
FFFFFFFFFFFFE00000000000FFFFFFFFFFFFE00000000000C001E000F0006000
00000000C001E000F000600000000000C001E000F000600000000000C001E000
F000600000000000C001E000F000600000000000C001E000F000600000000000
C001E000F000600000000000C001E000F000600000000000C001E000F0006000
00000000C001E000F000600000000000C001E000F000600000000000C001E000
F000600000000000C001E000F000600000000000FFFFFFFFFFFFE00000000000
FFFFFFFFFFFFE000000000000000000000000000000000000000000000000000
0000}
end
end
================================================
FILE: lib/mte/mtePluginSelectionForm.pas
================================================
unit mtePluginSelectionForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, CommCtrl, Menus, ComCtrls, ImgList;
type
TPluginListItem = class(TObject)
public
StateIndex: Integer;
Fields: TStringList;
constructor Create; virtual;
destructor Destroy; override;
end;
TStringFunction = function(s: string): string of object;
TStringListProcedure = procedure(fn: string; var sl: TStringList) of object;
TPluginSelectionForm = class(TForm)
lvPlugins: TListView;
btnCancel: TButton;
btnOK: TButton;
PluginsPopupMenu: TPopupMenu;
CheckAllItem: TMenuItem;
UncheckAllItem: TMenuItem;
ToggleAllItem: TMenuItem;
StateImages: TImageList;
MastersItem: TMenuItem;
N1: TMenuItem;
CheckMastersItem: TMenuItem;
UncheckMastersItem: TMenuItem;
CheckDependenciesItem: TMenuItem;
UncheckDependenciesItem: TMenuItem;
DependenciesItem: TMenuItem;
procedure LoadFields(aListItem: TPluginListItem; sPlugin: string);
procedure UpdateDisabled;
procedure FormShow(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure CheckAllItemClick(Sender: TObject);
procedure UncheckAllItemClick(Sender: TObject);
procedure ToggleAllItemClick(Sender: TObject);
procedure lvPluginsMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure lvPluginsChange(Sender: TObject; Item: TListItem;
Change: TItemChange);
procedure lvPluginsKeyPress(Sender: TObject; var Key: Char);
procedure DrawCheckbox(aCanvas: TCanvas; var x, y: Integer; state: Integer);
procedure DrawSubItems(ListView: TListView; var R: TRect; Item: TListItem);
procedure DrawItem(ListView: TListView; var R: TRect; Item: TListItem);
procedure lvPluginsDrawItem(Sender: TCustomListView; Item: TListItem;
Rect: TRect; State: TOwnerDrawState);
procedure lvPluginsMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
function GetMasterStatus(filename: string): Integer;
procedure lvPluginsData(Sender: TObject; Item: TListItem);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CheckMastersItemClick(Sender: TObject);
procedure UncheckMastersItemClick(Sender: TObject);
procedure CheckDependenciesItemClick(Sender: TObject);
procedure UncheckDependenciesItemClick(Sender: TObject);
procedure PluginsPopupMenuPopup(Sender: TObject);
private
{ Private declarations }
slMasters, slDependencies, slMissing, slDisabled: TStringList;
ListItems: TList;
sLastHint: string;
sBuffer: string;
fLastBufferTime: TDateTime;
public
{ Public declarations }
GetPluginInfo: TStringFunction;
GetPluginMasters: TStringListProcedure;
GetPluginDependencies: TStringListProcedure;
sColumns: string;
slAllPlugins, slCheckedPlugins: TStringList;
end;
var
PluginSelectionForm: TPluginSelectionForm;
implementation
uses
mteHelpers;
const
// delay for clearing keystroke buffer when
// performing a text search on a list view
fBufferDelay = 1.1 * seconds;
// checkbox states
cChecked = 1;
cUnChecked = 2;
// master states
mstNone = 0;
mstMaster = 1;
mstDependency = 2;
mstBoth = 3;
mstMissing = 4;
mstDisabled = 5;
{$R *.dfm}
constructor TPluginListItem.Create;
begin
StateIndex := cUnChecked;
Fields := TStringList.Create;
end;
destructor TPluginListItem.Destroy;
begin
Fields.Free;
end;
procedure TPluginSelectionForm.btnOKClick(Sender: TObject);
var
i: Integer;
ListItem: TListItem;
begin
// clear checked plugins list
slCheckedPlugins.Clear;
// add checked plugins to slCheckedPlugins
for i := 0 to Pred(lvPlugins.Items.Count) do begin
ListItem := lvPlugins.Items[i];
if ListItem.StateIndex = cChecked then
slCheckedPlugins.Add(ListItem.Caption);
end;
end;
procedure TPluginSelectionForm.LoadFields(aListItem: TPluginListItem;
sPlugin: string);
var
sl: TStringList;
i: Integer;
begin
// add plugin filename
aListItem.fields.Add(sPlugin);
// get comma separated plugin info in a TStringList
sl := TStringList.Create;
sl.StrictDelimiter := true;
try
sl.CommaText := GetPluginInfo(sPlugin);
for i := 0 to Pred(sl.Count) do
aListItem.Fields.Add(sl[i]);
finally
sl.Free;
end;
end;
procedure TPluginSelectionForm.UpdateDisabled;
var
i, j, index: Integer;
filename: string;
ListItem, MasterItem: TPluginListItem;
sl: TStringList;
begin
// update slDisabled
slDisabled.Clear;
sl := TStringList.Create;
try
for i := 0 to Pred(lvPlugins.Items.Count) do begin
ListItem := TPluginListItem(ListItems[i]);
filename := ListItem.Fields[0];
// if unchecked, skip
if ListItem.StateIndex = cUnChecked then
continue;
// if checked, make sure its masters are checked
GetPluginMasters(filename, sl);
for j := 0 to Pred(sl.Count) do begin
index := slAllPlugins.IndexOf(sl[j]);
// if master is not found, continue
if (index = -1) then
continue;
// if master is unchecked, add to slDisabled
MasterItem := TPluginListItem(ListItems[index]);
if MasterItem.StateIndex = cUnChecked then
slDisabled.Add(sl[j]);
end;
// clear masters
sl.Clear;
end;
finally
sl.Free;
end;
// disable OK button if there are any disabled masters
btnOK.Enabled := slDisabled.Count = 0;
end;
procedure ToggleState(ListItem: TPluginListItem);
begin
case ListItem.StateIndex of
cChecked: ListItem.StateIndex := cUnChecked;
cUnChecked: ListItem.StateIndex := cChecked;
end;
end;
procedure TPluginSelectionForm.lvPluginsChange(Sender: TObject; Item: TListItem;
Change: TItemChange);
var
i: Integer;
filename: string;
begin
// update slMasters and slDependencies
slMasters.Clear;
slDependencies.Clear;
for i := 0 to Pred(lvPlugins.Items.Count) do begin
filename := TPluginListItem(ListItems[i]).Fields[0];
with lvPlugins.Items[i] do
if Selected then begin
GetPluginMasters(filename, slMasters);
GetPluginDependencies(filename, slDependencies);
end;
end;
// repaint to update master/dependency colors
lvPlugins.Repaint;
end;
function TPluginSelectionForm.GetMasterStatus(filename: string): Integer;
var
bIsDependency, bIsMaster: boolean;
begin
// if file has masters that are missing from slAllPlugins,
// return mstMissing
if slMissing.IndexOf(filename) > -1 then begin
Result := mstMissing;
exit;
end;
// if file has masters that are disabled,
// return mstDisabled
if slDisabled.IndexOf(filename) > -1 then begin
Result := mstDisabled;
exit;
end;
// compute master or dependency status based on selection
bIsMaster := slMasters.IndexOf(filename) > -1;
bIsDependency := slDependencies.IndexOf(filename) > -1;
Result := IfThenInt(bIsMaster, 1, 0) + IfThenInt(bIsDependency, 2, 0);
end;
procedure TPluginSelectionForm.lvPluginsData(Sender: TObject; Item: TListItem);
var
aListItem: TPluginListItem;
MasterStatus: Integer;
i: Integer;
begin
// get item data
aListItem := ListItems[Item.Index];
Item.Caption := aListItem.Fields[0];
Item.StateIndex := aListItem.StateIndex;
// get subitems
for i := 1 to Pred(aListItem.fields.Count) do
Item.SubItems.Add(aListItem.fields[i]);
// set font color based on master status of item
lvPlugins.Canvas.Font.Style := [fsBold];
MasterStatus := GetMasterStatus(Item.Caption);
case MasterStatus of
mstNone: begin
lvPlugins.Canvas.Font.Style := [];
lvPlugins.Canvas.Font.Color := clBlack;
end;
mstMaster: lvPlugins.Canvas.Font.Color := clGreen;
mstDependency: lvPlugins.Canvas.Font.Color := clMaroon;
mstBoth: lvPlugins.Canvas.Font.Color := clPurple;
mstMissing: begin
lvPlugins.Canvas.Font.Style := [fsItalic];
lvPlugins.Canvas.Font.Color := clGray;
end;
mstDisabled: begin
lvPlugins.Canvas.Font.Style := [fsItalic];
lvPlugins.Canvas.Font.Color := clRed;
end;
end;
end;
procedure TPluginSelectionForm.DrawCheckbox(aCanvas: TCanvas; var x, y: Integer;
state: Integer);
var
icon: TIcon;
begin
if state = 0 then
exit;
icon := TIcon.Create;
StateImages.GetIcon(state, icon);
aCanvas.Draw(x, y, icon);
Inc(x, 17);
icon.Free;
end;
procedure TPluginSelectionForm.DrawSubItems(ListView: TListView; var R: TRect;
Item: TListItem);
var
i: Integer;
begin
for i := 0 to Pred(Item.SubItems.Count) do begin
// redefine rect to draw in the space for the column
// use trailing padding to keep items lined up on columns
R.Left := R.Right;
R.Right := R.Left + ListView_GetColumnWidth(ListView.Handle, i) - 3;
// padding between items
Inc(R.Left, 3);
// draw text
ListView.Canvas.TextRect(R, R.Left, R.Top, Item.SubItems[i]);
end;
end;
procedure TPluginSelectionForm.DrawItem(ListView: TListView; var R: TRect;
Item: TListItem);
begin
// redefine rect to draw until the end of the first column
// use trailing padding to keep items lined up on columns
R.Right := R.Left + ListView.Columns[0].Width - 3;
// draw the checkbox
DrawCheckbox(ListView.Canvas, R.Left, R.Top, Item.StateIndex);
// move text down 1 pixel
Inc(R.Top, 1);
// padding between checkbox and text
Inc(R.Left, 6);
// draw text
ListView.Canvas.TextRect(R, R.Left, R.Top, Item.Caption);
end;
procedure TPluginSelectionForm.lvPluginsDrawItem(Sender: TCustomListView;
Item: TListItem; Rect: TRect; State: TOwnerDrawState);
var
ListView: TListView;
begin
// draw background color
ListView := TListView(Sender);
if Item.Selected then begin
ListView.Canvas.Brush.Color := $FFEEDD;
ListView.Canvas.FillRect(Rect);
end;
// draw item
DrawItem(ListView, Rect, Item);
// draw subitem
DrawSubItems(ListView, Rect, Item);
end;
procedure TPluginSelectionForm.lvPluginsKeyPress(Sender: TObject;
var Key: Char);
var
i, iFoundIndex: Integer;
ListItem: TListItem;
fBufferDiff: Real;
sTempBuffer: string;
begin
// Calculate time between current keystroke and last
// keystroke we buffered
fBufferDiff := Now - fLastBufferTime;
// If we are within the buffer delay append the key to a
// temporary buffer and search for next item matching the
// buffer in the list view items.
if fBufferDiff < fBufferDelay then begin
fLastBufferTime := Now;
sTempBuffer := sBuffer + Key;
iFoundIndex := ListView_NextMatch(lvPlugins, sTempBuffer, 0);
// If we found a match, handle it
if iFoundIndex > -1 then begin
ListView_HandleMatch(lvPlugins, iFoundIndex, sBuffer, sTempBuffer);
Key := #0;
end;
end
else begin
// Allow user to use space to toggle checkbox state
// for all selected items
if Key = ' ' then begin
for i := 0 to Pred(lvPlugins.Items.Count) do begin
ListItem := lvPlugins.Items[i];
if ListItem.Selected then
if slMissing.IndexOf(slAllPlugins[i]) = -1 then
ToggleState(TPluginListItem(ListItems[i]));
end;
// repaint to show updated checkbox state and exit
UpdateDisabled;
lvPlugins.Repaint;
exit;
end;
// Restart buffering if we didn't have an active buffer
// or press space
fLastBufferTime := Now;
sTempBuffer := Key;
lvPlugins.ClearSelection;
iFoundIndex := ListView_NextMatch(lvPlugins, sTempBuffer, 0);
// If we found a match, handle it
if iFoundIndex > -1 then begin
ListView_HandleMatch(lvPlugins, iFoundIndex, sBuffer, sTempBuffer);
Key := #0;
end;
end;
end;
function OnStateIcon(X, Y: Integer): Boolean;
begin
Result := (x >= 2) and (x <= 14);
end;
procedure TPluginSelectionForm.lvPluginsMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
ListItem: TListItem;
begin
// toggle checkbox state
ListItem := lvPlugins.GetItemAt(X, Y);
if OnStateIcon(X, Y) then begin
if slMissing.IndexOf(slAllPlugins[ListItem.Index]) = -1 then
ToggleState(TPluginListItem(ListItems[ListItem.Index]));
// repaint to show updated checkbox state
UpdateDisabled;
lvPlugins.Repaint;
end;
end;
procedure TPluginSelectionForm.lvPluginsMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
var
pt: TPoint;
li : TListItem;
hint, str: string;
slTempMasters, slTempReq: TStringList;
i: Integer;
begin
// get list item at mouse position
li := lvPlugins.GetItemAt(X, Y);
// if mouse not over an item, exit
if not Assigned(li) then
exit;
slTempMasters := TStringList.Create;
try
GetPluginMasters(li.Caption, slTempMasters);
if slMissing.IndexOf(li.Caption) > -1 then begin
str := '';
for i := 0 to Pred(slTempMasters.Count) do
if slAllPlugins.IndexOf(slTempMasters[i]) = -1 then
str := str + slTempMasters[i] + #13#10;
hint := Format('Missing masters:'#13#10'%s', [str]);
end
else if slTempMasters.Count > 0 then
hint := Format('Masters:'#13#10'%s'#13#10, [slTempMasters.Text]);
finally
slTempMasters.Free;
end;
// get plugin dependencies and display them if they're present
slTempReq := TStringList.Create;
try
GetPluginDependencies(li.Caption, slTempReq);
if slTempReq.Count > 0 then
hint := hint + Format('Required By:'#13#10'%s', [slTempReq.Text]);
finally
slTempReq.Free;
end;
// trim the hint
hint := Trim(hint);
// activate hint if it differs from previously displayed hint
if (hint <> sLastHint) then begin
sLastHint := hint;
lvPlugins.ShowHint := True;
lvPlugins.Hint := hint;
Application.ActivateHint(Mouse.CursorPos);
end;
end;
procedure TPluginSelectionForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
slMasters.Free;
slDependencies.Free;
slMissing.Free;
slDisabled.Free;
ListItems.Free;
end;
procedure TPluginSelectionForm.FormShow(Sender: TObject);
var
i, j, iColumnSize: Integer;
aListItem: TPluginListItem;
sPlugin: string;
sl: TStringList;
aColumn: TListColumn;
begin
// create lists
slMasters := TStringList.Create;
slDependencies := TStringList.Create;
slMissing := TStringList.Create;
slDisabled := TStringList.Create;
ListItems := TList.Create;
// create columns
sl := TStringList.Create;
try
sl.CommaText := sColumns;
iColumnSize := (lvPlugins.ClientWidth - 300) div (sl.Count - 1);
for i := 0 to Pred(sl.Count) do begin
aColumn := lvPlugins.Columns.Add;
aColumn.Caption := sl[i];
aColumn.Width := IfThenInt(i = 0, 300, iColumnSize);
end;
// make first column autosize
lvPlugins.Columns[0].AutoSize := true;
finally
sl.Free;
end;
// add plugin items to list
for i := 0 to Pred(slAllPlugins.Count) do begin
sPlugin := slAllPlugins[i];
aListItem := TPluginListItem.Create;
// check ListItem if it's in the CheckedPlugins list
if slCheckedPlugins.IndexOf(sPlugin) > -1 then
aListItem.StateIndex := cChecked;
// add patch subitems
LoadFields(aListItem, sPlugin);
ListItems.Add(aListItem);
end;
// determine which plugins can't be loaded because their masters
// are missing
sl := TStringList.Create;
try
for i := 0 to Pred(slAllPlugins.Count) do begin
sPlugin := slAllPlugins[i];
aListItem := TPluginListItem(ListItems[i]);
GetPluginMasters(sPlugin, sl);
for j := 0 to Pred(sl.Count) do
if slAllPlugins.IndexOf(sl[j]) = -1 then begin
slMissing.Add(sPlugin);
aListItem.StateIndex := cUnChecked;
break;
end;
sl.Clear;
end;
finally
sl.Free;
end;
// set plugin count for display
lvPlugins.Items.Count := slAllPlugins.Count;
ListView_CorrectWidth(lvPlugins);
// update disabled
UpdateDisabled;
lvPlugins.Repaint;
end;
procedure TPluginSelectionForm.PluginsPopupMenuPopup(Sender: TObject);
var
bHasMasters, bHasDependencies: Boolean;
begin
bHasMasters := slMasters.Count > 0;
bHasDependencies := slDependencies.Count > 0;
MastersItem.Enabled := bHasMasters;
DependenciesItem.Enabled := bHasDependencies;
end;
procedure TPluginSelectionForm.CheckAllItemClick(Sender: TObject);
var
i: Integer;
begin
for i := 0 to Pred(lvPlugins.Items.Count) do
if slMissing.IndexOf(slAllPlugins[i]) = -1 then
TPluginListItem(ListItems[i]).StateIndex := cChecked;
// repaint to show updated checkbox state
UpdateDisabled;
lvPlugins.Repaint;
end;
procedure TPluginSelectionForm.UncheckAllItemClick(Sender: TObject);
var
i: Integer;
begin
for i := 0 to Pred(lvPlugins.Items.Count) do
TPluginListItem(ListItems[i]).StateIndex := cUnChecked;
// repaint to show updated checkbox state
UpdateDisabled;
lvPlugins.Repaint;
end;
procedure TPluginSelectionForm.ToggleAllItemClick(Sender: TObject);
var
i: Integer;
begin
for i := 0 to Pred(lvPlugins.Items.Count) do
if slMissing.IndexOf(slAllPlugins[i]) = -1 then
ToggleState(TPluginListItem(ListItems[i]));
// repaint to show updated checkbox state
UpdateDisabled;
lvPlugins.Repaint;
end;
procedure TPluginSelectionForm.CheckMastersItemClick(Sender: TObject);
var
i, index: Integer;
begin
// loop through masters of selected plugins
for i := 0 to Pred(slMasters.Count) do begin
index := slAllPlugins.IndexOf(slMasters[i]);
// if the masters isn't loaded, skip it
if index = -1 then
continue;
// else check it
TPluginListItem(ListItems[index]).StateIndex := cChecked;
end;
// repaint to show updated checkbox state
UpdateDisabled;
lvPlugins.Repaint;
end;
procedure TPluginSelectionForm.UncheckMastersItemClick(Sender: TObject);
var
i, index: Integer;
begin
// loop through masters of selected plugins
for i := 0 to Pred(slMasters.Count) do begin
index := slAllPlugins.IndexOf(slMasters[i]);
// if the masters isn't loaded, skip it
if index = -1 then
continue;
// else uncheck it
TPluginListItem(ListItems[index]).StateIndex := cUnChecked;
end;
// repaint to show updated checkbox state
UpdateDisabled;
lvPlugins.Repaint;
end;
procedure TPluginSelectionForm.CheckDependenciesItemClick(Sender: TObject);
var
i, index: Integer;
begin
// loop through dependencies of selected plugins
for i := 0 to Pred(slDependencies.Count) do begin
index := slAllPlugins.IndexOf(slDependencies[i]);
// check it
TPluginListItem(ListItems[index]).StateIndex := cChecked;
end;
// repaint to show updated checkbox state
UpdateDisabled;
lvPlugins.Repaint;
end;
procedure TPluginSelectionForm.UncheckDependenciesItemClick(Sender: TObject);
var
i, index: Integer;
begin
// loop through dependencies of selected plugins
for i := 0 to Pred(slDependencies.Count) do begin
index := slAllPlugins.IndexOf(slDependencies[i]);
// uncheck it
TPluginListItem(ListItems[index]).StateIndex := cUnChecked;
end;
// repaint to show updated checkbox state
UpdateDisabled;
lvPlugins.Repaint;
end;
end.
================================================
FILE: lib/mte/mteProgressForm.dfm
================================================
object ProgressForm: TProgressForm
Left = 0
Top = 0
Caption = 'Progress'
ClientHeight = 342
ClientWidth = 624
Color = clBtnFace
DoubleBuffered = True
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poMainFormCenter
OnClose = FormClose
OnCloseQuery = FormCloseQuery
OnCreate = FormCreate
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object ProgressLabel: TLabel
Left = 8
Top = 8
Width = 608
Height = 13
Align = alCustom
Anchors = [akLeft, akTop, akRight]
AutoSize = False
Caption = 'Progress message'
end
object DetailsMemo: TMemo
Left = 8
Top = 58
Width = 608
Height = 245
Align = alCustom
Anchors = [akLeft, akTop, akRight, akBottom]
ReadOnly = True
ScrollBars = ssVertical
TabOrder = 0
end
object DetailsButton: TButton
Left = 428
Top = 309
Width = 91
Height = 25
Align = alCustom
Anchors = [akRight, akBottom]
Caption = 'Hide details'
TabOrder = 1
OnClick = ToggleDetails
end
object ProgressBar: TProgressBar
Left = 8
Top = 27
Width = 608
Height = 25
Align = alCustom
Anchors = [akLeft, akTop, akRight]
TabOrder = 2
end
object CancelButton: TButton
Left = 525
Top = 309
Width = 91
Height = 25
Align = alCustom
Anchors = [akRight, akBottom]
Caption = 'Cancel'
TabOrder = 3
OnClick = CancelButtonClick
end
end
================================================
FILE: lib/mte/mteProgressForm.pas
================================================
unit mteProgressForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls,
// mte components
W7Taskbar, mteTracker;
type
TProgressForm = class(TForm)
DetailsMemo: TMemo;
DetailsButton: TButton;
ProgressBar: TProgressBar;
ProgressLabel: TLabel;
CancelButton: TButton;
procedure UpdateProgress(const i: Integer);
procedure StatusMessage(const s: string);
procedure Write(const s: string);
procedure SaveLog;
procedure SetProgress(const i: Integer);
procedure SetMaxProgress(const i: Integer);
function GetProgress: Integer;
function GetMaxProgress: Integer;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ToggleDetails(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure CancelButtonClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
bDetailsVisible: boolean;
pfLogPath: string;
end;
implementation
var
lastHeight: integer;
{$R *.dfm}
procedure TProgressForm.ToggleDetails(Sender: TObject);
begin
bDetailsVisible := not bDetailsVisible;
if bDetailsVisible then begin
self.Height := lastHeight;
DetailsMemo.Visible := true;
DetailsButton.Caption := 'Hide details';
DetailsMemo.Height := self.Height - 135;
end
else begin
DetailsMemo.Visible := false;
DetailsButton.Caption := 'Show details';
lastHeight := self.Height;
self.Height := 129;
end;
end;
procedure TProgressForm.CancelButtonClick(Sender: TObject);
begin
Close;
end;
procedure TProgressForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
SetTaskbarProgressState(tbpsNone);
Tracker.OnSetMaxEvent := nil;
Tracker.OnUpdateEvent := nil;
Tracker.OnLogEvent := nil;
Tracker.OnSetEvent := nil;
Tracker.OnGetEvent := nil;
Tracker.OnGetMaxEvent := nil;
Tracker.OnStatusEvent := nil;
end;
procedure TProgressForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := (fsModal in FormState);
//Tracker.Write('CanClose = '+BoolToStr(CanClose, true));
if not (CanClose or Tracker.Cancel) then begin
Tracker.Write('Cancelling...');
SetTaskbarProgressState(tbpsError);
Tracker.Cancel := true;
end;
end;
procedure TProgressForm.FormCreate(Sender: TObject);
begin
lastHeight := 380;
SetTaskbarProgressState(tbpsNormal);
bDetailsVisible := true;
DetailsMemo.ReadOnly := true;
Tracker.OnSetMaxEvent := SetMaxProgress;
Tracker.OnUpdateEvent := UpdateProgress;
Tracker.OnLogEvent := Write;
Tracker.OnSetEvent := SetProgress;
Tracker.OnStatusEvent := StatusMessage;
Tracker.OnGetEvent := GetProgress;
Tracker.OnGetMaxEvent := GetMaxProgress;
end;
procedure TProgressForm.FormShow(Sender: TObject);
begin
if (fsModal in FormState) then begin
CancelButton.Caption := 'Close';
if not bDetailsVisible then
ToggleDetails(nil);
end
else if not bDetailsVisible then begin
bDetailsVisible := false;
DetailsMemo.Visible := false;
DetailsButton.Caption := 'Show details';
lastHeight := self.Height;
self.Height := 129;
end;
end;
procedure TProgressForm.SetProgress(const i: Integer);
begin
ProgressBar.Position := i;
SetTaskbarProgressValue(ProgressBar.Position, ProgressBar.Max);
end;
procedure TProgressForm.SetMaxProgress(const i: Integer);
begin
ProgressBar.Max := i;
end;
function TProgressForm.GetProgress: Integer;
begin
Result := ProgressBar.Position;
end;
function TProgressForm.GetMaxProgress: Integer;
begin
Result := ProgressBar.Max;
end;
procedure TProgressForm.UpdateProgress(const i: Integer);
begin
ProgressBar.StepBy(i);
SetTaskbarProgressValue(ProgressBar.Position, ProgressBar.Max);
end;
procedure TProgressForm.SaveLog;
var
fdt: string;
begin
try
ForceDirectories(pfLogPath);
fdt := FormatDateTime('mmddyy_hhnnss', TDateTime(Now));
DetailsMemo.Lines.SaveToFile(pfLogPath + 'log_'+fdt+'.txt');
except on Exception do
// nothing to do
end;
end;
procedure TProgressForm.StatusMessage(const s: string);
begin
ProgressLabel.Caption := s;
end;
procedure TProgressForm.Write(const s: string);
begin
if Pos(' ', s) <> 1 then
ProgressLabel.Caption := s;
DetailsMemo.SelLength := 0;
DetailsMemo.Lines.Add(s);
end;
end.
================================================
FILE: lib/mte/mteTaskHandler.pas
================================================
unit mteTaskHandler;
interface
uses
Classes, SysUtils,
// mte components
mteLogger, mteHelpers;
type
TProcedure = procedure of object;
TTask = class (TObject)
private
FExecute : TProcedure;
public
name: string;
rate: real;
lastExecuted: TDateTime;
constructor Create(name: string; rate: real; FExecute: TProcedure); Overload;
property OnExecute: TProcedure read FExecute write FExecute;
procedure Execute;
end;
TTaskHandler = class(TObject)
public
TaskList: TList;
bExecutingTasks: boolean;
procedure RemoveTask(taskName: string);
procedure AddTask(task: TTask);
procedure ExecTasks;
constructor Create; Overload;
end;
var
bLogTasks: boolean;
implementation
procedure TTaskHandler.AddTask(task: TTask);
begin
TaskList.Add(task);
end;
procedure TTaskHandler.RemoveTask(taskName: string);
var
i: Integer;
task: TTask;
begin
if not Assigned(TaskList) then
exit;
for i := Pred(TaskList.Count) downto 0 do begin
task := TTask(TaskList[i]);
if task.name = taskName then begin
TaskList.Delete(i);
break;
end;
end;
end;
procedure TTaskHandler.ExecTasks;
var
i: Integer;
task: TTask;
begin
// exit if we're currently executing tasks
if bExecutingTasks then
exit;
bExecutingTasks := true;
// loop through task list, executing tasks that are ready to be executed
for i := Pred(TaskList.Count) downto 0 do begin
task := TTask(TaskList[i]);
if (Now - task.lastExecuted >= task.rate) then begin
if bLogTasks and (task.rate > 60.0 * seconds) then
Logger.Write('TASK', 'Execute', task.name);
task.lastExecuted := Now;
task.Execute;
end;
end;
// no longer executing tasks
bExecutingTasks := false;
end;
constructor TTaskHandler.Create;
begin
TaskList := TList.Create;
end;
{******************************************************************************}
{ Task methods
Object methods for TTask
}
{******************************************************************************}
constructor TTask.Create(name: string; rate: real; FExecute: TProcedure);
begin
if bLogTasks then
Logger.Write('TASK', 'Init', Format('%s, Rate: %s', [name, RateStr(rate)]));
self.name := name;
self.rate := rate;
self.FExecute := FExecute;
self.lastExecuted := Now;
end;
procedure TTask.Execute;
begin
if Assigned(FExecute) then
FExecute;
end;
end.
================================================
FILE: lib/mte/mteTracker.pas
================================================
unit mteTracker;
interface
uses Classes, SysUtils;
type
TUpdateEvent = procedure(const i: integer) of object;
TReadEvent = function: Integer of object;
TLogEvent = procedure(const s: string) of object;
TProgressTracker = class
private
FUpdateEvent : TUpdateEvent;
FSetEvent : TUpdateEvent;
FGetEvent : TReadEvent;
FMaxEvent : TUpdateEvent;
FGetMaxEvent : TReadEvent;
FLogEvent : TLogEvent;
FStatusEvent : TLogEvent;
public
Cancel: boolean;
procedure SetMaxProgress(const i: integer);
property OnSetMaxEvent: TUpdateEvent read FMaxEvent write FMaxEvent;
procedure SetProgress(const i: integer);
property OnSetEvent: TUpdateEvent read FSetEvent write FSetEvent;
function GetProgress: Integer;
property OnGetEvent: TReadEvent read FGetEvent write FGetEvent;
function GetMaxProgress: Integer;
property OnGetMaxEvent: TReadEvent read FGetMaxEvent write FGetMaxEvent;
procedure UpdateProgress(const i: integer);
property OnUpdateEvent: TUpdateEvent read FUpdateEvent write FUpdateEvent;
procedure StatusMessage(const s: string);
property OnStatusEvent: TLogEvent read FStatusEvent write FStatusEvent;
procedure Write(const s: string);
property OnLogEvent: TLogEvent read FLogEvent write FLogEvent;
end;
var
Tracker: TProgressTracker;
implementation
procedure TProgressTracker.SetMaxProgress(const i: Integer);
begin
if Assigned(FMaxEvent) then
FMaxEvent(i);
end;
procedure TProgressTracker.StatusMessage(const s: string);
begin
if Assigned(FStatusEvent) then
FStatusEvent(s);
end;
procedure TProgressTracker.SetProgress(const i: integer);
begin
if Assigned(FSetEvent) then
FSetEvent(i);
end;
function TProgressTracker.GetProgress: Integer;
begin
Result := FGetEvent();
end;
function TProgressTracker.GetMaxProgress: Integer;
begin
Result := FGetMaxEvent();
end;
procedure TProgressTracker.UpdateProgress(const i: integer);
begin
if Assigned(FUpdateEvent) then
FUpdateEvent(i);
end;
procedure TProgressTracker.Write(const s: string);
begin
if s = '' then
exit;
if Assigned(FLogEvent) then
FLogEvent(s);
end;
initialization
Tracker := TProgressTracker.Create;
finalization
FreeAndNil(Tracker);
end.
================================================
FILE: lib/superobject/superobject.pas
================================================
(*
* Super Object Toolkit
*
* Usage allowed under the restrictions of the Lesser GNU General Public License
* or alternatively the restrictions of the Mozilla Public License 1.1
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
* the specific language governing rights and limitations under the License.
*
* Unit owner : Henri Gourvest
* Web site : http://www.progdigy.com
*
* This unit is inspired from the json c lib:
* Michael Clark
* http://oss.metaparadigm.com/json-c/
*
* CHANGES:
* v1.2
* + support of currency data type
* + right trim unquoted string
* + read Unicode Files and streams (Litle Endian with BOM)
* + Fix bug on javadate functions + windows nt compatibility
* + Now you can force to parse only the canonical syntax of JSON using the stric parameter
* + Delphi 2010 RTTI marshalling
* v1.1
* + Double licence MPL or LGPL.
* + Delphi 2009 compatibility & Unicode support.
* + AsString return a string instead of PChar.
* + Escaped and Unascaped JSON serialiser.
* + Missed FormFeed added \f
* - Removed @ trick, uses forcepath() method instead.
* + Fixed parse error with uppercase E symbol in numbers.
* + Fixed possible buffer overflow when enlarging array.
* + Added "delete", "pack", "insert" methods for arrays and/or objects
* + Multi parametters when calling methods
* + Delphi Enumerator (for obj1 in obj2 do ...)
* + Format method ex: obj.format('<%name%>%tab[1]%')
* + ParseFile and ParseStream methods
* + Parser now understand hexdecimal c syntax ex: \xFF
* + Null Object Design Patern (ex: for obj in values.N['path'] do ...)
* v1.0
* + renamed class
* + interfaced object
* + added a new data type: the method
* + parser can now evaluate properties and call methods
* - removed obselet rpc class
* - removed "find" method, now you can use "parse" method instead
* v0.6
* + refactoring
* v0.5
* + new find method to get or set value using a path syntax
* ex: obj.s['obj.prop[1]'] := 'string value';
* obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary
* v0.4
* + bug corrected: AVL tree badly balanced.
* v0.3
* + New validator partially based on the Kwalify syntax.
* + extended syntax to parse unquoted fields.
* + Freepascal compatibility win32/64 Linux32/64.
* + JavaToDelphiDateTime and DelphiToJavaDateTime improved for UTC.
* + new TJsonObject.Compare function.
* v0.2
* + Hashed string list replaced with a faster AVL tree
* + JsonInt data type can be changed to int64
* + JavaToDelphiDateTime and DelphiToJavaDateTime helper fonctions
* + from json-c v0.7
* + Add escaping of backslash to json output
* + Add escaping of foward slash on tokenizing and output
* + Changes to internal tokenizer from using recursion to
* using a depth state structure to allow incremental parsing
* v0.1
* + first release
*)
{$IFDEF FPC}
{$MODE OBJFPC}{$H+}
{$ENDIF}
{$DEFINE SUPER_METHOD}
{$DEFINE WINDOWSNT_COMPATIBILITY}
{.$DEFINE DEBUG} // track memory leack
unit superobject;
interface
uses
Classes
{$IFDEF VER210}
,Generics.Collections, RTTI, TypInfo
{$ENDIF}
;
type
{$IFNDEF FPC}
PtrInt = longint;
PtrUInt = Longword;
{$ENDIF}
SuperInt = Int64;
{$if (sizeof(Char) = 1)}
SOChar = WideChar;
SOIChar = Word;
PSOChar = PWideChar;
SOString = WideString;
{$else}
SOChar = Char;
SOIChar = Word;
PSOChar = PChar;
SOString = string;
{$ifend}
const
SUPER_ARRAY_LIST_DEFAULT_SIZE = 32;
SUPER_TOKENER_MAX_DEPTH = 64;
SUPER_AVL_MAX_DEPTH = sizeof(longint) * 8;
SUPER_AVL_MASK_HIGH_BIT = not ((not longword(0)) shr 1);
type
// forward declarations
TSuperObject = class;
ISuperObject = interface;
TSuperArray = class;
(* AVL Tree
* This is a "special" autobalanced AVL tree
* It use a hash value for fast compare
*)
{$IFDEF SUPER_METHOD}
TSuperMethod = procedure(const This, Params: ISuperObject; var Result: ISuperObject);
{$ENDIF}
TSuperAvlBitArray = set of 0..SUPER_AVL_MAX_DEPTH - 1;
TSuperAvlSearchType = (stEQual, stLess, stGreater);
TSuperAvlSearchTypes = set of TSuperAvlSearchType;
TSuperAvlIterator = class;
TSuperAvlEntry = class
private
FGt, FLt: TSuperAvlEntry;
FBf: integer;
FHash: Cardinal;
FName: SOString;
FPtr: Pointer;
function GetValue: ISuperObject;
procedure SetValue(const val: ISuperObject);
public
class function Hash(const k: SOString): Cardinal; virtual;
constructor Create(const AName: SOString; Obj: Pointer); virtual;
property Name: SOString read FName;
property Ptr: Pointer read FPtr;
property Value: ISuperObject read GetValue write SetValue;
end;
TSuperAvlTree = class
private
FRoot: TSuperAvlEntry;
FCount: Integer;
function balance(bal: TSuperAvlEntry): TSuperAvlEntry;
protected
procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); virtual;
function CompareNodeNode(node1, node2: TSuperAvlEntry): integer; virtual;
function CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; virtual;
function Insert(h: TSuperAvlEntry): TSuperAvlEntry; virtual;
function Search(const k: SOString; st: TSuperAvlSearchTypes = [stEqual]): TSuperAvlEntry; virtual;
public
constructor Create; virtual;
destructor Destroy; override;
function IsEmpty: boolean;
procedure Clear(all: boolean = false); virtual;
procedure Pack(all: boolean);
function Delete(const k: SOString): ISuperObject;
function GetEnumerator: TSuperAvlIterator;
property count: Integer read FCount;
end;
TSuperTableString = class(TSuperAvlTree)
protected
procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); override;
procedure PutO(const k: SOString; const value: ISuperObject);
function GetO(const k: SOString): ISuperObject;
procedure PutS(const k: SOString; const value: SOString);
function GetS(const k: SOString): SOString;
procedure PutI(const k: SOString; value: SuperInt);
function GetI(const k: SOString): SuperInt;
procedure PutD(const k: SOString; value: Double);
function GetD(const k: SOString): Double;
procedure PutB(const k: SOString; value: Boolean);
function GetB(const k: SOString): Boolean;
{$IFDEF SUPER_METHOD}
procedure PutM(const k: SOString; value: TSuperMethod);
function GetM(const k: SOString): TSuperMethod;
{$ENDIF}
procedure PutN(const k: SOString; const value: ISuperObject);
function GetN(const k: SOString): ISuperObject;
procedure PutC(const k: SOString; value: Currency);
function GetC(const k: SOString): Currency;
public
property O[const k: SOString]: ISuperObject read GetO write PutO; default;
property S[const k: SOString]: SOString read GetS write PutS;
property I[const k: SOString]: SuperInt read GetI write PutI;
property D[const k: SOString]: Double read GetD write PutD;
property B[const k: SOString]: Boolean read GetB write PutB;
{$IFDEF SUPER_METHOD}
property M[const k: SOString]: TSuperMethod read GetM write PutM;
{$ENDIF}
property N[const k: SOString]: ISuperObject read GetN write PutN;
property C[const k: SOString]: Currency read GetC write PutC;
function GetValues: ISuperObject;
function GetNames: ISuperObject;
end;
TSuperAvlIterator = class
private
FTree: TSuperAvlTree;
FBranch: TSuperAvlBitArray;
FDepth: LongInt;
FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] of TSuperAvlEntry;
public
constructor Create(tree: TSuperAvlTree); virtual;
procedure Search(const k: SOString; st: TSuperAvlSearchTypes = [stEQual]);
procedure First;
procedure Last;
function GetIter: TSuperAvlEntry;
procedure Next;
procedure Prior;
// delphi enumerator
function MoveNext: Boolean;
property Current: TSuperAvlEntry read GetIter;
end;
TSuperObjectArray = array[0..(high(PtrInt) div sizeof(TSuperObject))-1] of ISuperObject;
PSuperObjectArray = ^TSuperObjectArray;
TSuperArray = class
private
FArray: PSuperObjectArray;
FLength: Integer;
FSize: Integer;
procedure Expand(max: Integer);
protected
function GetO(const index: integer): ISuperObject;
procedure PutO(const index: integer; const Value: ISuperObject);
function GetB(const index: integer): Boolean;
procedure PutB(const index: integer; Value: Boolean);
function GetI(const index: integer): SuperInt;
procedure PutI(const index: integer; Value: SuperInt);
function GetD(const index: integer): Double;
procedure PutD(const index: integer; Value: Double);
function GetC(const index: integer): Currency;
procedure PutC(const index: integer; Value: Currency);
function GetS(const index: integer): SOString;
procedure PutS(const index: integer; const Value: SOString);
{$IFDEF SUPER_METHOD}
function GetM(const index: integer): TSuperMethod;
procedure PutM(const index: integer; Value: TSuperMethod);
{$ENDIF}
function GetN(const index: integer): ISuperObject;
procedure PutN(const index: integer; const Value: ISuperObject);
public
constructor Create; virtual;
destructor Destroy; override;
function Add(const Data: ISuperObject): Integer;
function Delete(index: Integer): ISuperObject;
procedure Insert(index: Integer; const value: ISuperObject);
procedure Clear(all: boolean = false);
procedure Pack(all: boolean);
property Length: Integer read FLength;
property N[const index: integer]: ISuperObject read GetN write PutN;
property O[const index: integer]: ISuperObject read GetO write PutO; default;
property B[const index: integer]: boolean read GetB write PutB;
property I[const index: integer]: SuperInt read GetI write PutI;
property D[const index: integer]: Double read GetD write PutD;
property C[const index: integer]: Currency read GetC write PutC;
property S[const index: integer]: SOString read GetS write PutS;
{$IFDEF SUPER_METHOD}
property M[const index: integer]: TSuperMethod read GetM write PutM;
{$ENDIF}
// property A[const index: integer]: TSuperArray read GetA;
end;
TSuperWriter = class
public
// abstact methods to overide
function Append(buf: PSOChar; Size: Integer): Integer; overload; virtual; abstract;
function Append(buf: PSOChar): Integer; overload; virtual; abstract;
procedure Reset; virtual; abstract;
end;
TSuperWriterString = class(TSuperWriter)
private
FBuf: PSOChar;
FBPos: integer;
FSize: integer;
public
function Append(buf: PSOChar; Size: Integer): Integer; overload; override;
function Append(buf: PSOChar): Integer; overload; override;
procedure Reset; override;
procedure TrimRight;
constructor Create; virtual;
destructor Destroy; override;
function GetString: SOString;
property Data: PSOChar read FBuf;
property Size: Integer read FSize;
property Position: integer read FBPos;
end;
TSuperWriterStream = class(TSuperWriter)
private
FStream: TStream;
public
function Append(buf: PSOChar): Integer; override;
procedure Reset; override;
constructor Create(AStream: TStream); reintroduce; virtual;
end;
TSuperAnsiWriterStream = class(TSuperWriterStream)
public
function Append(buf: PSOChar; Size: Integer): Integer; override;
end;
TSuperUnicodeWriterStream = class(TSuperWriterStream)
public
function Append(buf: PSOChar; Size: Integer): Integer; override;
end;
TSuperWriterFake = class(TSuperWriter)
private
FSize: Integer;
public
function Append(buf: PSOChar; Size: Integer): Integer; override;
function Append(buf: PSOChar): Integer; override;
procedure Reset; override;
constructor Create; reintroduce; virtual;
property size: integer read FSize;
end;
TSuperWriterSock = class(TSuperWriter)
private
FSocket: longint;
FSize: Integer;
public
function Append(buf: PSOChar; Size: Integer): Integer; override;
function Append(buf: PSOChar): Integer; override;
procedure Reset; override;
constructor Create(ASocket: longint); reintroduce; virtual;
property Socket: longint read FSocket;
property Size: Integer read FSize;
end;
TSuperTokenizerError = (
teSuccess,
teContinue,
teDepth,
teParseEof,
teParseUnexpected,
teParseNull,
teParseBoolean,
teParseNumber,
teParseArray,
teParseObjectKeyName,
teParseObjectKeySep,
teParseObjectValueSep,
teParseString,
teParseComment,
teEvalObject,
teEvalArray,
teEvalMethod,
teEvalInt
);
TSuperTokenerState = (
tsEatws,
tsStart,
tsFinish,
tsNull,
tsCommentStart,
tsComment,
tsCommentEol,
tsCommentEnd,
tsString,
tsStringEscape,
tsIdentifier,
tsEscapeUnicode,
tsEscapeHexadecimal,
tsBoolean,
tsNumber,
tsArray,
tsArrayAdd,
tsArraySep,
tsObjectFieldStart,
tsObjectField,
tsObjectUnquotedField,
tsObjectFieldEnd,
tsObjectValue,
tsObjectValueAdd,
tsObjectSep,
tsEvalProperty,
tsEvalArray,
tsEvalMethod,
tsParamValue,
tsParamPut,
tsMethodValue,
tsMethodPut
);
PSuperTokenerSrec = ^TSuperTokenerSrec;
TSuperTokenerSrec = record
state, saved_state: TSuperTokenerState;
obj: ISuperObject;
current: ISuperObject;
field_name: SOString;
parent: ISuperObject;
gparent: ISuperObject;
end;
TSuperTokenizer = class
public
str: PSOChar;
pb: TSuperWriterString;
depth, is_double, floatcount, st_pos, char_offset: Integer;
err: TSuperTokenizerError;
ucs_char: Word;
quote_char: SOChar;
stack: array[0..SUPER_TOKENER_MAX_DEPTH-1] of TSuperTokenerSrec;
line, col: Integer;
public
constructor Create; virtual;
destructor Destroy; override;
procedure ResetLevel(adepth: integer);
procedure Reset;
end;
// supported object types
TSuperType = (
stNull,
stBoolean,
stDouble,
stCurrency,
stInt,
stObject,
stArray,
stString
{$IFDEF SUPER_METHOD}
,stMethod
{$ENDIF}
);
TSuperValidateError = (
veRuleMalformated,
veFieldIsRequired,
veInvalidDataType,
veFieldNotFound,
veUnexpectedField,
veDuplicateEntry,
veValueNotInEnum,
veInvalidLength,
veInvalidRange
);
TSuperFindOption = (
foCreatePath,
foPutValue,
foDelete
{$IFDEF SUPER_METHOD}
,foCallMethod
{$ENDIF}
);
TSuperFindOptions = set of TSuperFindOption;
TSuperCompareResult = (cpLess, cpEqu, cpGreat, cpError);
TSuperOnValidateError = procedure(sender: Pointer; error: TSuperValidateError; const objpath: SOString);
TSuperEnumerator = class
private
FObj: ISuperObject;
FObjEnum: TSuperAvlIterator;
FCount: Integer;
public
constructor Create(const obj: ISuperObject); virtual;
destructor Destroy; override;
function MoveNext: Boolean;
function GetCurrent: ISuperObject;
property Current: ISuperObject read GetCurrent;
end;
ISuperObject = interface
['{4B86A9E3-E094-4E5A-954A-69048B7B6327}']
function GetEnumerator: TSuperEnumerator;
function GetDataType: TSuperType;
function GetProcessing: boolean;
procedure SetProcessing(value: boolean);
function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;
function GetO(const path: SOString): ISuperObject;
procedure PutO(const path: SOString; const Value: ISuperObject);
function GetB(const path: SOString): Boolean;
procedure PutB(const path: SOString; Value: Boolean);
function GetI(const path: SOString): SuperInt;
procedure PutI(const path: SOString; Value: SuperInt);
function GetD(const path: SOString): Double;
procedure PutC(const path: SOString; Value: Currency);
function GetC(const path: SOString): Currency;
procedure PutD(const path: SOString; Value: Double);
function GetS(const path: SOString): SOString;
procedure PutS(const path: SOString; const Value: SOString);
{$IFDEF SUPER_METHOD}
function GetM(const path: SOString): TSuperMethod;
procedure PutM(const path: SOString; Value: TSuperMethod);
{$ENDIF}
function GetA(const path: SOString): TSuperArray;
// Null Object Design patern
function GetN(const path: SOString): ISuperObject;
procedure PutN(const path: SOString; const Value: ISuperObject);
// Writers
function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;
function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;
function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;
function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
function CalcSize(indent: boolean = false; escape: boolean = true): integer;
// convert
function AsBoolean: Boolean;
function AsInteger: SuperInt;
function AsDouble: Double;
function AsCurrency: Currency;
function AsString: SOString;
function AsArray: TSuperArray;
function AsObject: TSuperTableString;
{$IFDEF SUPER_METHOD}
function AsMethod: TSuperMethod;
{$ENDIF}
function AsJSon(indent: boolean = false; escape: boolean = true): SOString;
procedure Clear(all: boolean = false);
procedure Pack(all: boolean = false);
property N[const path: SOString]: ISuperObject read GetN write PutN;
property O[const path: SOString]: ISuperObject read GetO write PutO; default;
property B[const path: SOString]: boolean read GetB write PutB;
property I[const path: SOString]: SuperInt read GetI write PutI;
property D[const path: SOString]: Double read GetD write PutD;
property C[const path: SOString]: Currency read GetC write PutC;
property S[const path: SOString]: SOString read GetS write PutS;
{$IFDEF SUPER_METHOD}
property M[const path: SOString]: TSuperMethod read GetM write PutM;
{$ENDIF}
property A[const path: SOString]: TSuperArray read GetA;
{$IFDEF SUPER_METHOD}
function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload;
function call(const path, param: SOString): ISuperObject; overload;
{$ENDIF}
// clone a node
function Clone: ISuperObject;
function Delete(const path: SOString): ISuperObject;
// merges tow objects of same type, if reference is true then nodes are not cloned
procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;
procedure Merge(const str: SOString); overload;
// validate methods
function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
// compare
function Compare(const obj: ISuperObject): TSuperCompareResult; overload;
function Compare(const str: SOString): TSuperCompareResult; overload;
// the data type
function IsType(AType: TSuperType): boolean;
property DataType: TSuperType read GetDataType;
property Processing: boolean read GetProcessing write SetProcessing;
function GetDataPtr: Pointer;
procedure SetDataPtr(const Value: Pointer);
property DataPtr: Pointer read GetDataPtr write SetDataPtr;
end;
TSuperObject = class(TObject, ISuperObject)
private
FRefCount: Integer;
FProcessing: boolean;
FDataType: TSuperType;
FDataPtr: Pointer;
{.$if true}
FO: record
case TSuperType of
stBoolean: (c_boolean: boolean);
stDouble: (c_double: double);
stCurrency: (c_currency: Currency);
stInt: (c_int: SuperInt);
stObject: (c_object: TSuperTableString);
stArray: (c_array: TSuperArray);
{$IFDEF SUPER_METHOD}
stMethod: (c_method: TSuperMethod);
{$ENDIF}
end;
{.$ifend}
FOString: SOString;
function GetDataType: TSuperType;
function GetDataPtr: Pointer;
procedure SetDataPtr(const Value: Pointer);
protected
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
function _AddRef: Integer; virtual; stdcall;
function _Release: Integer; virtual; stdcall;
function GetO(const path: SOString): ISuperObject;
procedure PutO(const path: SOString; const Value: ISuperObject);
function GetB(const path: SOString): Boolean;
procedure PutB(const path: SOString; Value: Boolean);
function GetI(const path: SOString): SuperInt;
procedure PutI(const path: SOString; Value: SuperInt);
function GetD(const path: SOString): Double;
procedure PutD(const path: SOString; Value: Double);
procedure PutC(const path: SOString; Value: Currency);
function GetC(const path: SOString): Currency;
function GetS(const path: SOString): SOString;
procedure PutS(const path: SOString; const Value: SOString);
{$IFDEF SUPER_METHOD}
function GetM(const path: SOString): TSuperMethod;
procedure PutM(const path: SOString; Value: TSuperMethod);
{$ENDIF}
function GetA(const path: SOString): TSuperArray;
function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; virtual;
public
function GetEnumerator: TSuperEnumerator;
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
class function NewInstance: TObject; override;
property RefCount: Integer read FRefCount;
function GetProcessing: boolean;
procedure SetProcessing(value: boolean);
// Writers
function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;
function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;
function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
function CalcSize(indent: boolean = false; escape: boolean = true): integer;
function AsJSon(indent: boolean = false; escape: boolean = true): SOString;
// parser ... owned!
class function ParseString(s: PSOChar; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
class function ParseStream(stream: TStream; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
class function ParseFile(const FileName: string; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
class function ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; strict: Boolean; const this: ISuperObject = nil;
options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
// constructors / destructor
constructor Create(jt: TSuperType = stObject); overload; virtual;
constructor Create(b: boolean); overload; virtual;
constructor Create(i: SuperInt); overload; virtual;
constructor Create(d: double); overload; virtual;
constructor CreateCurrency(c: Currency); overload; virtual;
constructor Create(const s: SOString); overload; virtual;
{$IFDEF SUPER_METHOD}
constructor Create(m: TSuperMethod); overload; virtual;
{$ENDIF}
destructor Destroy; override;
// convert
function AsBoolean: Boolean; virtual;
function AsInteger: SuperInt; virtual;
function AsDouble: Double; virtual;
function AsCurrency: Currency; virtual;
function AsString: SOString; virtual;
function AsArray: TSuperArray; virtual;
function AsObject: TSuperTableString; virtual;
{$IFDEF SUPER_METHOD}
function AsMethod: TSuperMethod; virtual;
{$ENDIF}
procedure Clear(all: boolean = false); virtual;
procedure Pack(all: boolean = false); virtual;
function GetN(const path: SOString): ISuperObject;
procedure PutN(const path: SOString; const Value: ISuperObject);
function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;
property N[const path: SOString]: ISuperObject read GetN write PutN;
property O[const path: SOString]: ISuperObject read GetO write PutO; default;
property B[const path: SOString]: boolean read GetB write PutB;
property I[const path: SOString]: SuperInt read GetI write PutI;
property D[const path: SOString]: Double read GetD write PutD;
property C[const path: SOString]: Currency read GetC write PutC;
property S[const path: SOString]: SOString read GetS write PutS;
{$IFDEF SUPER_METHOD}
property M[const path: SOString]: TSuperMethod read GetM write PutM;
{$ENDIF}
property A[const path: SOString]: TSuperArray read GetA;
{$IFDEF SUPER_METHOD}
function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; virtual;
function call(const path, param: SOString): ISuperObject; overload; virtual;
{$ENDIF}
// clone a node
function Clone: ISuperObject; virtual;
function Delete(const path: SOString): ISuperObject;
// merges tow objects of same type, if reference is true then nodes are not cloned
procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;
procedure Merge(const str: SOString); overload;
// validate methods
function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
// compare
function Compare(const obj: ISuperObject): TSuperCompareResult; overload;
function Compare(const str: SOString): TSuperCompareResult; overload;
// the data type
function IsType(AType: TSuperType): boolean;
property DataType: TSuperType read GetDataType;
// a data pointer to link to something ele, a treeview for example
property DataPtr: Pointer read GetDataPtr write SetDataPtr;
property Processing: boolean read GetProcessing;
end;
{$IFDEF VER210}
TSuperRttiContext = class;
TSerialFromJson = function(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
TSerialToJson = function(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
TSuperAttribute = class(TCustomAttribute)
private
FName: string;
public
constructor Create(const AName: string);
property Name: string read FName;
end;
SOName = class(TSuperAttribute);
SODefault = class(TSuperAttribute);
TSuperRttiContext = class
private
class function GetFieldName(r: TRttiField): string;
class function GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;
public
Context: TRttiContext;
SerialFromJson: TDictionary;
SerialToJson: TDictionary;
constructor Create; virtual;
destructor Destroy; override;
function FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; var Value: TValue): Boolean; virtual;
function ToJson(var value: TValue; const index: ISuperObject): ISuperObject; virtual;
function AsType(const obj: ISuperObject): T;
function AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject;
end;
TSuperObjectHelper = class helper for TObject
public
function ToJson(ctx: TSuperRttiContext = nil): ISuperObject;
constructor FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); overload;
constructor FromJson(const str: string; ctx: TSuperRttiContext = nil); overload;
end;
{$ENDIF}
TSuperObjectIter = record
key: SOString;
val: ISuperObject;
Ite: TSuperAvlIterator;
end;
function ObjectIsError(obj: TSuperObject): boolean;
function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;
function ObjectGetType(const obj: ISuperObject): TSuperType;
function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;
function ObjectFindNext(var F: TSuperObjectIter): boolean;
procedure ObjectFindClose(var F: TSuperObjectIter);
function SO(const s: SOString = '{}'): ISuperObject; overload;
function SO(const value: Variant): ISuperObject; overload;
function SO(const Args: array of const): ISuperObject; overload;
function SA(const Args: array of const): ISuperObject; overload;
function JavaToDelphiDateTime(const dt: int64): TDateTime;
function DelphiToJavaDateTime(const dt: TDateTime): int64;
{$IFDEF VER210}
type
TSuperInvokeResult = (
irSuccess,
irMethothodError, // method don't exist
irParamError, // invalid parametters
irError // other error
);
function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; const method: string; const params: ISuperObject; var Return: ISuperObject): TSuperInvokeResult; overload;
function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext = nil): ISuperObject; overload;
function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext = nil): ISuperObject; overload;
{$ENDIF}
implementation
uses sysutils,
{$IFDEF UNIX}
baseunix, unix, DateUtils
{$ELSE}
Windows
{$ENDIF}
{$IFDEF FPC}
,sockets
{$ELSE}
,WinSock
{$ENDIF};
{$IFDEF DEBUG}
var
debugcount: integer = 0;
{$ENDIF}
const
super_number_chars_set = ['0'..'9','.','+','-','e','E'];
super_hex_chars: PSOChar = '0123456789abcdef';
super_hex_chars_set = ['0'..'9','a'..'f','A'..'F'];
ESC_BS: PSOChar = '\b';
ESC_LF: PSOChar = '\n';
ESC_CR: PSOChar = '\r';
ESC_TAB: PSOChar = '\t';
ESC_FF: PSOChar = '\f';
ESC_QUOT: PSOChar = '\"';
ESC_SL: PSOChar = '\\';
ESC_SR: PSOChar = '\/';
ESC_ZERO: PSOChar = '\u0000';
TOK_CRLF: PSOChar = #13#10;
TOK_SP: PSOChar = #32;
TOK_BS: PSOChar = #8;
TOK_TAB: PSOChar = #9;
TOK_LF: PSOChar = #10;
TOK_FF: PSOChar = #12;
TOK_CR: PSOChar = #13;
// TOK_SL: PSOChar = '\';
// TOK_SR: PSOChar = '/';
TOK_NULL: PSOChar = 'null';
TOK_CBL: PSOChar = '{'; // curly bracket left
TOK_CBR: PSOChar = '}'; // curly bracket right
TOK_ARL: PSOChar = '[';
TOK_ARR: PSOChar = ']';
TOK_ARRAY: PSOChar = '[]';
TOK_OBJ: PSOChar = '{}'; // empty object
TOK_COM: PSOChar = ','; // Comma
TOK_DQT: PSOChar = '"'; // Double Quote
TOK_TRUE: PSOChar = 'true';
TOK_FALSE: PSOChar = 'false';
{$if (sizeof(Char) = 1)}
function StrLComp(const Str1, Str2: PSOChar; MaxLen: Cardinal): Integer;
var
P1, P2: PWideChar;
I: Cardinal;
C1, C2: WideChar;
begin
P1 := Str1;
P2 := Str2;
I := 0;
while I < MaxLen do
begin
C1 := P1^;
C2 := P2^;
if (C1 <> C2) or (C1 = #0) then
begin
Result := Ord(C1) - Ord(C2);
Exit;
end;
Inc(P1);
Inc(P2);
Inc(I);
end;
Result := 0;
end;
function StrComp(const Str1, Str2: PSOChar): Integer;
var
P1, P2: PWideChar;
C1, C2: WideChar;
begin
P1 := Str1;
P2 := Str2;
while True do
begin
C1 := P1^;
C2 := P2^;
if (C1 <> C2) or (C1 = #0) then
begin
Result := Ord(C1) - Ord(C2);
Exit;
end;
Inc(P1);
Inc(P2);
end;
end;
function StrLen(const Str: PSOChar): Cardinal;
var
p: PSOChar;
begin
Result := 0;
if Str <> nil then
begin
p := Str;
while p^ <> #0 do inc(p);
Result := (p - Str);
end;
end;
{$ifend}
function CurrToStr(c: Currency): SOString;
var
p: PSOChar;
i, len: Integer;
begin
Result := IntToStr(Abs(PInt64(@c)^));
len := Length(Result);
SetLength(Result, len+1);
if c <> 0 then
begin
while len <= 4 do
begin
Result := '0' + Result;
inc(len);
end;
p := PSOChar(Result);
inc(p, len-1);
i := 0;
repeat
if p^ <> '0' then
begin
len := len - i + 1;
repeat
p[1] := p^;
dec(p);
inc(i);
until i > 3;
Break;
end;
dec(p);
inc(i);
if i > 3 then
begin
len := len - i + 1;
Break;
end;
until false;
p[1] := '.';
SetLength(Result, len);
if c < 0 then
Result := '-' + Result;
end;
end;
{$IFDEF UNIX}
{$linklib c}
{$ENDIF}
function gcvt(value: Double; ndigit: longint; buf: PAnsiChar): PAnsiChar; cdecl;
external {$IFDEF MSWINDOWS} 'msvcrt.dll' name '_gcvt'{$ENDIF};
{$IFDEF UNIX}
type
ptm = ^tm;
tm = record
tm_sec: Integer; (* Seconds: 0-59 (K&R says 0-61?) *)
tm_min: Integer; (* Minutes: 0-59 *)
tm_hour: Integer; (* Hours since midnight: 0-23 *)
tm_mday: Integer; (* Day of the month: 1-31 *)
tm_mon: Integer; (* Months *since* january: 0-11 *)
tm_year: Integer; (* Years since 1900 *)
tm_wday: Integer; (* Days since Sunday (0-6) *)
tm_yday: Integer; (* Days since Jan. 1: 0-365 *)
tm_isdst: Integer; (* +1 Daylight Savings Time, 0 No DST, -1 don't know *)
end;
function mktime(p: ptm): LongInt; cdecl; external;
function gmtime(const t: PLongint): ptm; cdecl; external;
function localtime (const t: PLongint): ptm; cdecl; external;
function DelphiToJavaDateTime(const dt: TDateTime): Int64;
var
p: ptm;
l, ms: Integer;
v: Int64;
begin
v := Round((dt - 25569) * 86400000);
ms := v mod 1000;
l := v div 1000;
p := localtime(@l);
Result := Int64(mktime(p)) * 1000 + ms;
end;
function JavaToDelphiDateTime(const dt: int64): TDateTime;
var
p: ptm;
l, ms: Integer;
begin
l := dt div 1000;
ms := dt mod 1000;
p := gmtime(@l);
Result := EncodeDateTime(p^.tm_year+1900, p^.tm_mon+1, p^.tm_mday, p^.tm_hour, p^.tm_min, p^.tm_sec, ms);
end;
{$ELSE}
{$IFDEF WINDOWSNT_COMPATIBILITY}
function DayLightCompareDate(const date: PSystemTime;
const compareDate: PSystemTime): Integer;
var
limit_day, dayinsecs, weekofmonth: Integer;
First: Word;
begin
if (date^.wMonth < compareDate^.wMonth) then
begin
Result := -1; (* We are in a month before the date limit. *)
Exit;
end;
if (date^.wMonth > compareDate^.wMonth) then
begin
Result := 1; (* We are in a month after the date limit. *)
Exit;
end;
(* if year is 0 then date is in day-of-week format, otherwise
* it's absolute date.
*)
if (compareDate^.wYear = 0) then
begin
(* compareDate.wDay is interpreted as number of the week in the month
* 5 means: the last week in the month *)
weekofmonth := compareDate^.wDay;
(* calculate the day of the first DayOfWeek in the month *)
First := (6 + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod 7 + 1;
limit_day := First + 7 * (weekofmonth - 1);
(* check needed for the 5th weekday of the month *)
if (limit_day > MonthDays[(date^.wMonth=2) and IsLeapYear(date^.wYear)][date^.wMonth - 1]) then
dec(limit_day, 7);
end
else
limit_day := compareDate^.wDay;
(* convert to seconds *)
limit_day := ((limit_day * 24 + compareDate^.wHour) * 60 + compareDate^.wMinute ) * 60;
dayinsecs := ((date^.wDay * 24 + date^.wHour) * 60 + date^.wMinute ) * 60 + date^.wSecond;
(* and compare *)
if dayinsecs < limit_day then
Result := -1 else
if dayinsecs > limit_day then
Result := 1 else
Result := 0; (* date is equal to the date limit. *)
end;
function CompTimeZoneID(const pTZinfo: PTimeZoneInformation;
lpFileTime: PFileTime; islocal: Boolean): LongWord;
var
ret: Integer;
beforeStandardDate, afterDaylightDate: Boolean;
llTime: Int64;
SysTime: TSystemTime;
ftTemp: TFileTime;
begin
llTime := 0;
if (pTZinfo^.DaylightDate.wMonth <> 0) then
begin
(* if year is 0 then date is in day-of-week format, otherwise
* it's absolute date.
*)
if ((pTZinfo^.StandardDate.wMonth = 0) or
((pTZinfo^.StandardDate.wYear = 0) and
((pTZinfo^.StandardDate.wDay < 1) or
(pTZinfo^.StandardDate.wDay > 5) or
(pTZinfo^.DaylightDate.wDay < 1) or
(pTZinfo^.DaylightDate.wDay > 5)))) then
begin
SetLastError(ERROR_INVALID_PARAMETER);
Result := TIME_ZONE_ID_INVALID;
Exit;
end;
if (not islocal) then
begin
llTime := PInt64(lpFileTime)^;
dec(llTime, Int64(pTZinfo^.Bias + pTZinfo^.DaylightBias) * 600000000);
PInt64(@ftTemp)^ := llTime;
lpFileTime := @ftTemp;
end;
FileTimeToSystemTime(lpFileTime^, SysTime);
(* check for daylight savings *)
ret := DayLightCompareDate(@SysTime, @pTZinfo^.StandardDate);
if (ret = -2) then
begin
Result := TIME_ZONE_ID_INVALID;
Exit;
end;
beforeStandardDate := ret < 0;
if (not islocal) then
begin
dec(llTime, Int64(pTZinfo^.StandardBias - pTZinfo^.DaylightBias) * 600000000);
PInt64(@ftTemp)^ := llTime;
FileTimeToSystemTime(lpFileTime^, SysTime);
end;
ret := DayLightCompareDate(@SysTime, @pTZinfo^.DaylightDate);
if (ret = -2) then
begin
Result := TIME_ZONE_ID_INVALID;
Exit;
end;
afterDaylightDate := ret >= 0;
Result := TIME_ZONE_ID_STANDARD;
if( pTZinfo^.DaylightDate.wMonth < pTZinfo^.StandardDate.wMonth ) then
begin
(* Northern hemisphere *)
if( beforeStandardDate and afterDaylightDate) then
Result := TIME_ZONE_ID_DAYLIGHT;
end else (* Down south *)
if( beforeStandardDate or afterDaylightDate) then
Result := TIME_ZONE_ID_DAYLIGHT;
end else
(* No transition date *)
Result := TIME_ZONE_ID_UNKNOWN;
end;
function GetTimezoneBias(const pTZinfo: PTimeZoneInformation;
lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean;
var
bias: LongInt;
tzid: LongWord;
begin
bias := pTZinfo^.Bias;
tzid := CompTimeZoneID(pTZinfo, lpFileTime, islocal);
if( tzid = TIME_ZONE_ID_INVALID) then
begin
Result := False;
Exit;
end;
if (tzid = TIME_ZONE_ID_DAYLIGHT) then
inc(bias, pTZinfo^.DaylightBias)
else if (tzid = TIME_ZONE_ID_STANDARD) then
inc(bias, pTZinfo^.StandardBias);
pBias^ := bias;
Result := True;
end;
function SystemTimeToTzSpecificLocalTime(
lpTimeZoneInformation: PTimeZoneInformation;
lpUniversalTime, lpLocalTime: PSystemTime): BOOL;
var
ft: TFileTime;
lBias: LongInt;
llTime: Int64;
tzinfo: TTimeZoneInformation;
begin
if (lpTimeZoneInformation <> nil) then
tzinfo := lpTimeZoneInformation^ else
if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then
begin
Result := False;
Exit;
end;
if (not SystemTimeToFileTime(lpUniversalTime^, ft)) then
begin
Result := False;
Exit;
end;
llTime := PInt64(@ft)^;
if (not GetTimezoneBias(@tzinfo, @ft, False, @lBias)) then
begin
Result := False;
Exit;
end;
(* convert minutes to 100-nanoseconds-ticks *)
dec(llTime, Int64(lBias) * 600000000);
PInt64(@ft)^ := llTime;
Result := FileTimeToSystemTime(ft, lpLocalTime^);
end;
function TzSpecificLocalTimeToSystemTime(
const lpTimeZoneInformation: PTimeZoneInformation;
const lpLocalTime: PSystemTime; lpUniversalTime: PSystemTime): BOOL;
var
ft: TFileTime;
lBias: LongInt;
t: Int64;
tzinfo: TTimeZoneInformation;
begin
if (lpTimeZoneInformation <> nil) then
tzinfo := lpTimeZoneInformation^
else
if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then
begin
Result := False;
Exit;
end;
if (not SystemTimeToFileTime(lpLocalTime^, ft)) then
begin
Result := False;
Exit;
end;
t := PInt64(@ft)^;
if (not GetTimezoneBias(@tzinfo, @ft, True, @lBias)) then
begin
Result := False;
Exit;
end;
(* convert minutes to 100-nanoseconds-ticks *)
inc(t, Int64(lBias) * 600000000);
PInt64(@ft)^ := t;
Result := FileTimeToSystemTime(ft, lpUniversalTime^);
end;
{$ELSE}
function TzSpecificLocalTimeToSystemTime(
lpTimeZoneInformation: PTimeZoneInformation;
lpLocalTime, lpUniversalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll';
function SystemTimeToTzSpecificLocalTime(
lpTimeZoneInformation: PTimeZoneInformation;
lpUniversalTime, lpLocalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll';
{$ENDIF}
function JavaToDelphiDateTime(const dt: int64): TDateTime;
var
t: TSystemTime;
begin
DateTimeToSystemTime(25569 + (dt / 86400000), t);
SystemTimeToTzSpecificLocalTime(nil, @t, @t);
Result := SystemTimeToDateTime(t);
end;
function DelphiToJavaDateTime(const dt: TDateTime): int64;
var
t: TSystemTime;
begin
DateTimeToSystemTime(dt, t);
TzSpecificLocalTimeToSystemTime(nil, @t, @t);
Result := Round((SystemTimeToDateTime(t) - 25569) * 86400000)
end;
{$ENDIF}
function SO(const s: SOString): ISuperObject; overload;
begin
Result := TSuperObject.ParseString(PSOChar(s), False);
end;
function SA(const Args: array of const): ISuperObject; overload;
type
TByteArray = array[0..sizeof(integer) - 1] of byte;
PByteArray = ^TByteArray;
var
j: Integer;
intf: IInterface;
begin
Result := TSuperObject.Create(stArray);
for j := 0 to length(Args) - 1 do
with Result.AsArray do
case TVarRec(Args[j]).VType of
vtInteger : Add(TSuperObject.Create(TVarRec(Args[j]).VInteger));
vtInt64 : Add(TSuperObject.Create(TVarRec(Args[j]).VInt64^));
vtBoolean : Add(TSuperObject.Create(TVarRec(Args[j]).VBoolean));
vtChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VChar)));
vtWideChar: Add(TSuperObject.Create(SOChar(TVarRec(Args[j]).VWideChar)));
vtExtended: Add(TSuperObject.Create(TVarRec(Args[j]).VExtended^));
vtCurrency: Add(TSuperObject.CreateCurrency(TVarRec(Args[j]).VCurrency^));
vtString : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VString^)));
vtPChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VPChar^)));
vtAnsiString: Add(TSuperObject.Create(SOString(AnsiString(TVarRec(Args[j]).VAnsiString))));
vtWideString: Add(TSuperObject.Create(SOString(PWideChar(TVarRec(Args[j]).VWideString))));
vtInterface:
if TVarRec(Args[j]).VInterface = nil then
Add(nil) else
if IInterface(TVarRec(Args[j]).VInterface).QueryInterface(ISuperObject, intf) = 0 then
Add(ISuperObject(intf)) else
Add(nil);
vtPointer :
if TVarRec(Args[j]).VPointer = nil then
Add(nil) else
Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
vtVariant:
Add(SO(TVarRec(Args[j]).VVariant^));
vtObject:
if TVarRec(Args[j]).VPointer = nil then
Add(nil) else
Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
vtClass:
if TVarRec(Args[j]).VPointer = nil then
Add(nil) else
Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
{$if declared(vtUnicodeString)}
vtUnicodeString:
Add(TSuperObject.Create(SOString(string(TVarRec(Args[j]).VUnicodeString))));
{$ifend}
else
assert(false);
end;
end;
function SO(const Args: array of const): ISuperObject; overload;
var
j: Integer;
arr: ISuperObject;
begin
Result := TSuperObject.Create(stObject);
arr := SA(Args);
with arr.AsArray do
for j := 0 to (Length div 2) - 1 do
Result.AsObject.PutO(O[j*2].AsString, O[(j*2) + 1]);
end;
function SO(const value: Variant): ISuperObject; overload;
begin
with TVarData(value) do
case VType of
varNull: Result := nil;
varEmpty: Result := nil;
varSmallInt: Result := TSuperObject.Create(VSmallInt);
varInteger: Result := TSuperObject.Create(VInteger);
varSingle: Result := TSuperObject.Create(VSingle);
varDouble: Result := TSuperObject.Create(VDouble);
varCurrency: Result := TSuperObject.CreateCurrency(VCurrency);
varDate: Result := TSuperObject.Create(DelphiToJavaDateTime(vDate));
varOleStr: Result := TSuperObject.Create(SOString(VOleStr));
varBoolean: Result := TSuperObject.Create(VBoolean);
varShortInt: Result := TSuperObject.Create(VShortInt);
varByte: Result := TSuperObject.Create(VByte);
varWord: Result := TSuperObject.Create(VWord);
varLongWord: Result := TSuperObject.Create(VLongWord);
varInt64: Result := TSuperObject.Create(VInt64);
varString: Result := TSuperObject.Create(SOString(AnsiString(VString)));
{$if declared(varUString)}
varUString: Result := TSuperObject.Create(SOString(string(VUString)));
{$ifend}
else
raise Exception.CreateFmt('Unsuported variant data type: %d', [VType]);
end;
end;
function ObjectIsError(obj: TSuperObject): boolean;
begin
Result := PtrUInt(obj) > PtrUInt(-4000);
end;
function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;
begin
if obj <> nil then
Result := typ = obj.DataType else
Result := typ = stNull;
end;
function ObjectGetType(const obj: ISuperObject): TSuperType;
begin
if obj <> nil then
Result := obj.DataType else
Result := stNull;
end;
function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;
var
i: TSuperAvlEntry;
begin
if ObjectIsType(obj, stObject) then
begin
F.Ite := TSuperAvlIterator.Create(obj.AsObject);
F.Ite.First;
i := F.Ite.GetIter;
if i <> nil then
begin
f.key := i.Name;
f.val := i.Value;
Result := true;
end else
Result := False;
end else
Result := False;
end;
function ObjectFindNext(var F: TSuperObjectIter): boolean;
var
i: TSuperAvlEntry;
begin
F.Ite.Next;
i := F.Ite.GetIter;
if i <> nil then
begin
f.key := i.FName;
f.val := i.Value;
Result := true;
end else
Result := False;
end;
procedure ObjectFindClose(var F: TSuperObjectIter);
begin
F.Ite.Free;
F.val := nil;
end;
{$IFDEF VER210}
function serialtoboolean(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
begin
Result := TSuperObject.Create(TValueData(value).FAsSLong <> 0);
end;
function serialtodatetime(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
begin
Result := TSuperObject.Create(DelphiToJavaDateTime(TValueData(value).FAsDouble));
end;
function serialtoguid(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
var
g: TGUID;
begin
value.ExtractRawData(@g);
Result := TSuperObject.Create(
format('%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x',
[g.D1, g.D2, g.D3,
g.D4[0], g.D4[1], g.D4[2],
g.D4[3], g.D4[4], g.D4[5],
g.D4[6], g.D4[7]])
);
end;
function serialfromboolean(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
var
o: ISuperObject;
begin
case ObjectGetType(obj) of
stBoolean:
begin
TValueData(Value).FAsSLong := obj.AsInteger;
Result := True;
end;
stInt:
begin
TValueData(Value).FAsSLong := ord(obj.AsInteger <> 0);
Result := True;
end;
stString:
begin
o := SO(obj.AsString);
if not ObjectIsType(o, stString) then
Result := serialfromboolean(ctx, SO(obj.AsString), Value) else
Result := False;
end;
else
Result := False;
end;
end;
function serialfromdatetime(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
var
dt: TDateTime;
begin
case ObjectGetType(obj) of
stInt:
begin
TValueData(Value).FAsDouble := JavaToDelphiDateTime(obj.AsInteger);
Result := True;
end;
stString:
begin
if TryStrToDateTime(obj.AsString, dt) then
begin
TValueData(Value).FAsDouble := dt;
Result := True;
end else
Result := False;
end;
else
Result := False;
end;
end;
function UuidFromString(const s: PSOChar; Uuid: PGUID): Boolean;
const
hex2bin: array[#0..#102] of short = (
-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x00 *)
-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x10 *)
-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x20 *)
0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1, (* 0x30 *)
-1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x40 *)
-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x50 *)
-1,10,11,12,13,14,15); (* 0x60 *)
var
i: Integer;
begin
if (strlen(s) <> 36) then Exit(False);
if ((s[8] <> '-') or (s[13] <> '-') or (s[18] <> '-') or (s[23] <> '-')) then
Exit(False);
for i := 0 to 35 do
begin
if not i in [8,13,18,23] then
if ((s[i] > 'f') or ((hex2bin[s[i]] = -1) and (s[i] <> ''))) then
Exit(False);
end;
uuid.D1 := ((hex2bin[s[0]] shl 28) or (hex2bin[s[1]] shl 24) or (hex2bin[s[2]] shl 20) or (hex2bin[s[3]] shl 16) or
(hex2bin[s[4]] shl 12) or (hex2bin[s[5]] shl 8) or (hex2bin[s[6]] shl 4) or hex2bin[s[7]]);
uuid.D2 := (hex2bin[s[9]] shl 12) or (hex2bin[s[10]] shl 8) or (hex2bin[s[11]] shl 4) or hex2bin[s[12]];
uuid.D3 := (hex2bin[s[14]] shl 12) or (hex2bin[s[15]] shl 8) or (hex2bin[s[16]] shl 4) or hex2bin[s[17]];
uuid.D4[0] := (hex2bin[s[19]] shl 4) or hex2bin[s[20]];
uuid.D4[1] := (hex2bin[s[21]] shl 4) or hex2bin[s[22]];
uuid.D4[2] := (hex2bin[s[24]] shl 4) or hex2bin[s[25]];
uuid.D4[3] := (hex2bin[s[26]] shl 4) or hex2bin[s[27]];
uuid.D4[4] := (hex2bin[s[28]] shl 4) or hex2bin[s[29]];
uuid.D4[5] := (hex2bin[s[30]] shl 4) or hex2bin[s[31]];
uuid.D4[6] := (hex2bin[s[32]] shl 4) or hex2bin[s[33]];
uuid.D4[7] := (hex2bin[s[34]] shl 4) or hex2bin[s[35]];
Result := True;
end;
function serialfromguid(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
begin
case ObjectGetType(obj) of
stNull:
begin
FillChar(Value.GetReferenceToRawData^, SizeOf(TGUID), 0);
Result := True;
end;
stString: Result := UuidFromString(PSOChar(obj.AsString), Value.GetReferenceToRawData);
else
Result := False;
end;
end;
function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext): ISuperObject; overload;
var
owned: Boolean;
begin
if ctx = nil then
begin
ctx := TSuperRttiContext.Create;
owned := True;
end else
owned := False;
try
if TrySOInvoke(ctx, obj, method, params, Result) <> irSuccess then
raise Exception.Create('Invalid method call');
finally
if owned then
ctx.Free;
end;
end;
function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext): ISuperObject; overload;
begin
Result := SOInvoke(obj, method, so(params), ctx)
end;
function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue;
const method: string; const params: ISuperObject;
var Return: ISuperObject): TSuperInvokeResult;
var
t: TRttiInstanceType;
m: TRttiMethod;
a: TArray;
ps: TArray;
v: TValue;
index: ISuperObject;
function GetParams: Boolean;
var
i: Integer;
begin
case ObjectGetType(params) of
stArray:
for i := 0 to Length(ps) - 1 do
if (pfOut in ps[i].Flags) then
TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else
if not ctx.FromJson(ps[i].ParamType.Handle, params.AsArray[i], a[i]) then
Exit(False);
stObject:
for i := 0 to Length(ps) - 1 do
if (pfOut in ps[i].Flags) then
TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else
if not ctx.FromJson(ps[i].ParamType.Handle, params.AsObject[ps[i].Name], a[i]) then
Exit(False);
stNull: ;
else
Exit(False);
end;
Result := True;
end;
procedure SetParams;
var
i: Integer;
begin
case ObjectGetType(params) of
stArray:
for i := 0 to Length(ps) - 1 do
if (ps[i].Flags * [pfVar, pfOut]) <> [] then
params.AsArray[i] := ctx.ToJson(a[i], index);
stObject:
for i := 0 to Length(ps) - 1 do
if (ps[i].Flags * [pfVar, pfOut]) <> [] then
params.AsObject[ps[i].Name] := ctx.ToJson(a[i], index);
end;
end;
begin
Result := irSuccess;
index := SO;
case obj.Kind of
tkClass:
begin
t := TRttiInstanceType(ctx.Context.GetType(obj.AsObject.ClassType));
m := t.GetMethod(method);
if m = nil then Exit(irMethothodError);
ps := m.GetParameters;
SetLength(a, Length(ps));
if not GetParams then Exit(irParamError);
if m.IsClassMethod then
begin
v := m.Invoke(obj.AsObject.ClassType, a);
Return := ctx.ToJson(v, index);
SetParams;
end else
begin
v := m.Invoke(obj, a);
Return := ctx.ToJson(v, index);
SetParams;
end;
end;
tkClassRef:
begin
t := TRttiInstanceType(ctx.Context.GetType(obj.AsClass));
m := t.GetMethod(method);
if m = nil then Exit(irMethothodError);
ps := m.GetParameters;
SetLength(a, Length(ps));
if not GetParams then Exit(irParamError);
if m.IsClassMethod then
begin
v := m.Invoke(obj, a);
Return := ctx.ToJson(v, index);
SetParams;
end else
Exit(irError);
end;
else
Exit(irError);
end;
end;
{$ENDIF}
{ TSuperEnumerator }
constructor TSuperEnumerator.Create(const obj: ISuperObject);
begin
FObj := obj;
FCount := -1;
if ObjectIsType(FObj, stObject) then
FObjEnum := FObj.AsObject.GetEnumerator else
FObjEnum := nil;
end;
destructor TSuperEnumerator.Destroy;
begin
if FObjEnum <> nil then
FObjEnum.Free;
end;
function TSuperEnumerator.MoveNext: Boolean;
begin
case ObjectGetType(FObj) of
stObject: Result := FObjEnum.MoveNext;
stArray:
begin
inc(FCount);
if FCount < FObj.AsArray.Length then
Result := True else
Result := False;
end;
else
Result := false;
end;
end;
function TSuperEnumerator.GetCurrent: ISuperObject;
begin
case ObjectGetType(FObj) of
stObject: Result := FObjEnum.Current.Value;
stArray: Result := FObj.AsArray.GetO(FCount);
else
Result := FObj;
end;
end;
{ TSuperObject }
constructor TSuperObject.Create(jt: TSuperType);
begin
inherited Create;
{$IFDEF DEBUG}
InterlockedIncrement(debugcount);
{$ENDIF}
FProcessing := false;
FDataPtr := nil;
FDataType := jt;
case FDataType of
stObject: FO.c_object := TSuperTableString.Create;
stArray: FO.c_array := TSuperArray.Create;
stString: FOString := '';
else
FO.c_object := nil;
end;
end;
constructor TSuperObject.Create(b: boolean);
begin
Create(stBoolean);
FO.c_boolean := b;
end;
constructor TSuperObject.Create(i: SuperInt);
begin
Create(stInt);
FO.c_int := i;
end;
constructor TSuperObject.Create(d: double);
begin
Create(stDouble);
FO.c_double := d;
end;
constructor TSuperObject.CreateCurrency(c: Currency);
begin
Create(stCurrency);
FO.c_currency := c;
end;
destructor TSuperObject.Destroy;
begin
{$IFDEF DEBUG}
InterlockedDecrement(debugcount);
{$ENDIF}
case FDataType of
stObject: FO.c_object.Free;
stArray: FO.c_array.Free;
end;
inherited;
end;
function TSuperObject.Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;
function DoEscape(str: PSOChar; len: Integer): Integer;
var
pos, start_offset: Integer;
c: SOChar;
buf: array[0..5] of SOChar;
type
TByteChar = record
case integer of
0: (a, b: Byte);
1: (c: WideChar);
end;
begin
if str = nil then
begin
Result := 0;
exit;
end;
pos := 0; start_offset := 0;
with writer do
while pos < len do
begin
c := str[pos];
case c of
#8,#9,#10,#12,#13,'"','\','/':
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
if(c = #8) then Append(ESC_BS, 2)
else if (c = #9) then Append(ESC_TAB, 2)
else if (c = #10) then Append(ESC_LF, 2)
else if (c = #12) then Append(ESC_FF, 2)
else if (c = #13) then Append(ESC_CR, 2)
else if (c = '"') then Append(ESC_QUOT, 2)
else if (c = '\') then Append(ESC_SL, 2)
else if (c = '/') then Append(ESC_SR, 2);
inc(pos);
start_offset := pos;
end;
else
if (SOIChar(c) > 255) then
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
buf[0] := '\';
buf[1] := 'u';
buf[2] := super_hex_chars[TByteChar(c).b shr 4];
buf[3] := super_hex_chars[TByteChar(c).b and $f];
buf[4] := super_hex_chars[TByteChar(c).a shr 4];
buf[5] := super_hex_chars[TByteChar(c).a and $f];
Append(@buf, 6);
inc(pos);
start_offset := pos;
end else
if (c < #32) or (c > #127) then
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
buf[0] := '\';
buf[1] := 'u';
buf[2] := '0';
buf[3] := '0';
buf[4] := super_hex_chars[ord(c) shr 4];
buf[5] := super_hex_chars[ord(c) and $f];
Append(buf, 6);
inc(pos);
start_offset := pos;
end else
inc(pos);
end;
end;
if(pos - start_offset > 0) then
writer.Append(str + start_offset, pos - start_offset);
Result := 0;
end;
function DoMinimalEscape(str: PSOChar; len: Integer): Integer;
var
pos, start_offset: Integer;
c: SOChar;
type
TByteChar = record
case integer of
0: (a, b: Byte);
1: (c: WideChar);
end;
begin
if str = nil then
begin
Result := 0;
exit;
end;
pos := 0; start_offset := 0;
with writer do
while pos < len do
begin
c := str[pos];
case c of
#0:
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
Append(ESC_ZERO, 6);
inc(pos);
start_offset := pos;
end;
'"':
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
Append(ESC_QUOT, 2);
inc(pos);
start_offset := pos;
end;
'\':
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
Append(ESC_SL, 2);
inc(pos);
start_offset := pos;
end;
'/':
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
Append(ESC_SR, 2);
inc(pos);
start_offset := pos;
end;
else
inc(pos);
end;
end;
if(pos - start_offset > 0) then
writer.Append(str + start_offset, pos - start_offset);
Result := 0;
end;
procedure _indent(i: shortint; r: boolean);
begin
inc(level, i);
if r then
with writer do
begin
{$IFDEF MSWINDOWS}
Append(TOK_CRLF, 2);
{$ELSE}
Append(TOK_LF, 1);
{$ENDIF}
for i := 0 to level - 1 do
Append(TOK_SP, 1);
end;
end;
var
k,j: Integer;
iter: TSuperObjectIter;
st: AnsiString;
val: ISuperObject;
fbuffer: array[0..31] of AnsiChar;
const
ENDSTR_A: PSOChar = '": ';
ENDSTR_B: PSOChar = '":';
begin
if FProcessing then
begin
Result := writer.Append(TOK_NULL, 4);
Exit;
end;
FProcessing := true;
with writer do
try
case FDataType of
stObject:
if FO.c_object.FCount > 0 then
begin
k := 0;
Append(TOK_CBL, 1);
if indent then _indent(1, false);
if ObjectFindFirst(Self, iter) then
repeat
{$IFDEF SUPER_METHOD}
if (iter.val = nil) or not ObjectIsType(iter.val, stMethod) then
begin
{$ENDIF}
if (iter.val = nil) or (not iter.val.Processing) then
begin
if(k <> 0) then
Append(TOK_COM, 1);
if indent then _indent(0, true);
Append(TOK_DQT, 1);
if escape then
doEscape(PSOChar(iter.key), Length(iter.key)) else
DoMinimalEscape(PSOChar(iter.key), Length(iter.key));
if indent then
Append(ENDSTR_A, 3) else
Append(ENDSTR_B, 2);
if(iter.val = nil) then
Append(TOK_NULL, 4) else
iter.val.write(writer, indent, escape, level);
inc(k);
end;
{$IFDEF SUPER_METHOD}
end;
{$ENDIF}
until not ObjectFindNext(iter);
ObjectFindClose(iter);
if indent then _indent(-1, true);
Result := Append(TOK_CBR, 1);
end else
Result := Append(TOK_OBJ, 2);
stBoolean:
begin
if (FO.c_boolean) then
Result := Append(TOK_TRUE, 4) else
Result := Append(TOK_FALSE, 5);
end;
stInt:
begin
str(FO.c_int, st);
Result := Append(PSOChar(SOString(st)));
end;
stDouble:
Result := Append(PSOChar(SOString(gcvt(FO.c_double, 15, fbuffer))));
stCurrency:
begin
Result := Append(PSOChar(CurrToStr(FO.c_currency)));
end;
stString:
begin
Append(TOK_DQT, 1);
if escape then
doEscape(PSOChar(FOString), Length(FOString)) else
DoMinimalEscape(PSOChar(FOString), Length(FOString));
Append(TOK_DQT, 1);
Result := 0;
end;
stArray:
if FO.c_array.FLength > 0 then
begin
Append(TOK_ARL, 1);
if indent then _indent(1, true);
k := 0;
j := 0;
while k < FO.c_array.FLength do
begin
val := FO.c_array.GetO(k);
{$IFDEF SUPER_METHOD}
if not ObjectIsType(val, stMethod) then
begin
{$ENDIF}
if (val = nil) or (not val.Processing) then
begin
if (j <> 0) then
Append(TOK_COM, 1);
if(val = nil) then
Append(TOK_NULL, 4) else
val.write(writer, indent, escape, level);
inc(j);
end;
{$IFDEF SUPER_METHOD}
end;
{$ENDIF}
inc(k);
end;
if indent then _indent(-1, false);
Result := Append(TOK_ARR, 1);
end else
Result := Append(TOK_ARRAY, 2);
stNull:
Result := Append(TOK_NULL, 4);
else
Result := 0;
end;
finally
FProcessing := false;
end;
end;
function TSuperObject.IsType(AType: TSuperType): boolean;
begin
Result := AType = FDataType;
end;
function TSuperObject.AsBoolean: boolean;
begin
case FDataType of
stBoolean: Result := FO.c_boolean;
stInt: Result := (FO.c_int <> 0);
stDouble: Result := (FO.c_double <> 0);
stCurrency: Result := (FO.c_currency <> 0);
stString: Result := (Length(FOString) <> 0);
stNull: Result := False;
else
Result := True;
end;
end;
function TSuperObject.AsInteger: SuperInt;
var
code: integer;
cint: SuperInt;
begin
case FDataType of
stInt: Result := FO.c_int;
stDouble: Result := round(FO.c_double);
stCurrency: Result := round(FO.c_currency);
stBoolean: Result := ord(FO.c_boolean);
stString:
begin
Val(FOString, cint, code);
if code = 0 then
Result := cint else
Result := 0;
end;
else
Result := 0;
end;
end;
function TSuperObject.AsDouble: Double;
var
code: integer;
cdouble: double;
begin
case FDataType of
stDouble: Result := FO.c_double;
stCurrency: Result := FO.c_currency;
stInt: Result := FO.c_int;
stBoolean: Result := ord(FO.c_boolean);
stString:
begin
Val(FOString, cdouble, code);
if code = 0 then
Result := cdouble else
Result := 0.0;
end;
else
Result := 0.0;
end;
end;
function TSuperObject.AsCurrency: Currency;
var
code: integer;
cdouble: double;
begin
case FDataType of
stDouble: Result := FO.c_double;
stCurrency: Result := FO.c_currency;
stInt: Result := FO.c_int;
stBoolean: Result := ord(FO.c_boolean);
stString:
begin
Val(FOString, cdouble, code);
if code = 0 then
Result := cdouble else
Result := 0.0;
end;
else
Result := 0.0;
end;
end;
function TSuperObject.AsString: SOString;
begin
if FDataType = stString then
Result := FOString else
Result := AsJSon(false, false);
end;
function TSuperObject.GetEnumerator: TSuperEnumerator;
begin
Result := TSuperEnumerator.Create(Self);
end;
procedure TSuperObject.AfterConstruction;
begin
InterlockedDecrement(FRefCount);
end;
procedure TSuperObject.BeforeDestruction;
begin
if RefCount <> 0 then
raise Exception.Create('Invalid pointer');
end;
function TSuperObject.AsArray: TSuperArray;
begin
if FDataType = stArray then
Result := FO.c_array else
Result := nil;
end;
function TSuperObject.AsObject: TSuperTableString;
begin
if FDataType = stObject then
Result := FO.c_object else
Result := nil;
end;
function TSuperObject.AsJSon(indent, escape: boolean): SOString;
var
pb: TSuperWriterString;
begin
pb := TSuperWriterString.Create;
try
if(Write(pb, indent, escape, 0) < 0) then
begin
Result := '';
Exit;
end;
if pb.FBPos > 0 then
Result := pb.FBuf else
Result := '';
finally
pb.Free;
end;
end;
class function TSuperObject.ParseString(s: PSOChar; strict: Boolean; partial: boolean; const this: ISuperObject;
options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;
var
tok: TSuperTokenizer;
obj: ISuperObject;
begin
tok := TSuperTokenizer.Create;
obj := ParseEx(tok, s, -1, strict, this, options, put, dt);
if(tok.err <> teSuccess) or (not partial and (s[tok.char_offset] <> #0)) then
Result := nil else
Result := obj;
tok.Free;
end;
class function TSuperObject.ParseStream(stream: TStream; strict: Boolean;
partial: boolean; const this: ISuperObject; options: TSuperFindOptions;
const put: ISuperObject; dt: TSuperType): ISuperObject;
const
BUFFER_SIZE = 1024;
var
tok: TSuperTokenizer;
buffera: array[0..BUFFER_SIZE-1] of AnsiChar;
bufferw: array[0..BUFFER_SIZE-1] of SOChar;
bom: array[0..1] of byte;
unicode: boolean;
j, size: Integer;
st: string;
begin
st := '';
tok := TSuperTokenizer.Create;
if (stream.Read(bom, sizeof(bom)) = 2) and (bom[0] = $FF) and (bom[1] = $FE) then
begin
unicode := true;
size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);
end else
begin
unicode := false;
stream.Seek(0, soFromBeginning);
size := stream.Read(buffera, BUFFER_SIZE);
end;
while size > 0 do
begin
if not unicode then
for j := 0 to size - 1 do
bufferw[j] := SOChar(buffera[j]);
ParseEx(tok, bufferw, size, strict, this, options, put, dt);
if tok.err = teContinue then
begin
if not unicode then
size := stream.Read(buffera, BUFFER_SIZE) else
size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);
end else
Break;
end;
if(tok.err <> teSuccess) or (not partial and (st[tok.char_offset] <> #0)) then
Result := nil else
Result := tok.stack[tok.depth].current;
tok.Free;
end;
class function TSuperObject.ParseFile(const FileName: string; strict: Boolean;
partial: boolean; const this: ISuperObject; options: TSuperFindOptions;
const put: ISuperObject; dt: TSuperType): ISuperObject;
var
stream: TFileStream;
begin
stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite);
try
Result := ParseStream(stream, strict, partial, this, options, put, dt);
finally
stream.Free;
end;
end;
class function TSuperObject.ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer;
strict: Boolean; const this: ISuperObject; options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;
const
spaces = [#32,#8,#9,#10,#12,#13];
delimiters = ['"', '.', '[', ']', '{', '}', '(', ')', ',', ':', #0];
reserved = delimiters + spaces;
path = ['a'..'z', 'A'..'Z', '.', '_'];
function hexdigit(x: SOChar): byte;
begin
if x <= '9' then
Result := byte(x) - byte('0') else
Result := (byte(x) and 7) + 9;
end;
function min(v1, v2: integer): integer; begin if v1 < v2 then result := v1 else result := v2 end;
var
obj: ISuperObject;
v: SOChar;
{$IFDEF SUPER_METHOD}
sm: TSuperMethod;
{$ENDIF}
numi: SuperInt;
numd: Double;
code: integer;
TokRec: PSuperTokenerSrec;
evalstack: integer;
p: PSOChar;
function IsEndDelimiter(v: AnsiChar): Boolean;
begin
if tok.depth > 0 then
case tok.stack[tok.depth - 1].state of
tsArrayAdd: Result := v in [',', ']', #0];
tsObjectValueAdd: Result := v in [',', '}', #0];
else
Result := v = #0;
end else
Result := v = #0;
end;
label out, redo_char;
begin
evalstack := 0;
obj := nil;
Result := nil;
TokRec := @tok.stack[tok.depth];
tok.char_offset := 0;
tok.err := teSuccess;
repeat
if (tok.char_offset = len) then
begin
if (tok.depth = 0) and (TokRec^.state = tsEatws) and
(TokRec^.saved_state = tsFinish) then
tok.err := teSuccess else
tok.err := teContinue;
goto out;
end;
v := str^;
case v of
#10:
begin
inc(tok.line);
tok.col := 0;
end;
#9: inc(tok.col, 4);
else
inc(tok.col);
end;
redo_char:
case TokRec^.state of
tsEatws:
begin
if (SOIChar(v) < 256) and (AnsiChar(v) in spaces) then {nop} else
if (v = '/') then
begin
tok.pb.Reset;
tok.pb.Append(@v, 1);
TokRec^.state := tsCommentStart;
end else begin
TokRec^.state := TokRec^.saved_state;
goto redo_char;
end
end;
tsStart:
case v of
'"',
'''':
begin
TokRec^.state := tsString;
tok.pb.Reset;
tok.quote_char := v;
end;
'-':
begin
TokRec^.state := tsNumber;
tok.pb.Reset;
tok.is_double := 0;
tok.floatcount := -1;
goto redo_char;
end;
'0'..'9':
begin
if (tok.depth = 0) then
case ObjectGetType(this) of
stObject:
begin
TokRec^.state := tsIdentifier;
TokRec^.current := this;
goto redo_char;
end;
end;
TokRec^.state := tsNumber;
tok.pb.Reset;
tok.is_double := 0;
tok.floatcount := -1;
goto redo_char;
end;
'{':
begin
TokRec^.state := tsEatws;
TokRec^.saved_state := tsObjectFieldStart;
TokRec^.current := TSuperObject.Create(stObject);
end;
'[':
begin
TokRec^.state := tsEatws;
TokRec^.saved_state := tsArray;
TokRec^.current := TSuperObject.Create(stArray);
end;
{$IFDEF SUPER_METHOD}
'(':
begin
if (tok.depth = 0) and ObjectIsType(this, stMethod) then
begin
TokRec^.current := this;
TokRec^.state := tsParamValue;
end;
end;
{$ENDIF}
'N',
'n':
begin
TokRec^.state := tsNull;
tok.pb.Reset;
tok.st_pos := 0;
goto redo_char;
end;
'T',
't',
'F',
'f':
begin
TokRec^.state := tsBoolean;
tok.pb.Reset;
tok.st_pos := 0;
goto redo_char;
end;
else
TokRec^.state := tsIdentifier;
tok.pb.Reset;
goto redo_char;
end;
tsFinish:
begin
if(tok.depth = 0) then goto out;
obj := TokRec^.current;
tok.ResetLevel(tok.depth);
dec(tok.depth);
TokRec := @tok.stack[tok.depth];
goto redo_char;
end;
tsNull:
begin
tok.pb.Append(@v, 1);
if (StrLComp(TOK_NULL, PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then
begin
if (tok.st_pos = 4) then
if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
TokRec^.state := tsIdentifier else
begin
TokRec^.current := TSuperObject.Create(stNull);
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
goto redo_char;
end;
end else
begin
TokRec^.state := tsIdentifier;
tok.pb.FBuf[tok.st_pos] := #0;
dec(tok.pb.FBPos);
goto redo_char;
end;
inc(tok.st_pos);
end;
tsCommentStart:
begin
if(v = '*') then
begin
TokRec^.state := tsComment;
end else
if (v = '/') then
begin
TokRec^.state := tsCommentEol;
end else
begin
tok.err := teParseComment;
goto out;
end;
tok.pb.Append(@v, 1);
end;
tsComment:
begin
if(v = '*') then
TokRec^.state := tsCommentEnd;
tok.pb.Append(@v, 1);
end;
tsCommentEol:
begin
if (v = #10) then
TokRec^.state := tsEatws else
tok.pb.Append(@v, 1);
end;
tsCommentEnd:
begin
tok.pb.Append(@v, 1);
if (v = '/') then
TokRec^.state := tsEatws else
TokRec^.state := tsComment;
end;
tsString:
begin
if (v = tok.quote_char) then
begin
TokRec^.current := TSuperObject.Create(SOString(tok.pb.GetString));
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
end else
if (v = '\') then
begin
TokRec^.saved_state := tsString;
TokRec^.state := tsStringEscape;
end else
begin
tok.pb.Append(@v, 1);
end
end;
tsEvalProperty:
begin
if (TokRec^.current = nil) and (foCreatePath in options) then
begin
TokRec^.current := TSuperObject.Create(stObject);
TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)
end else
if not ObjectIsType(TokRec^.current, stObject) then
begin
tok.err := teEvalObject;
goto out;
end;
tok.pb.Reset;
TokRec^.state := tsIdentifier;
goto redo_char;
end;
tsEvalArray:
begin
if (TokRec^.current = nil) and (foCreatePath in options) then
begin
TokRec^.current := TSuperObject.Create(stArray);
TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)
end else
if not ObjectIsType(TokRec^.current, stArray) then
begin
tok.err := teEvalArray;
goto out;
end;
tok.pb.Reset;
TokRec^.state := tsParamValue;
goto redo_char;
end;
{$IFDEF SUPER_METHOD}
tsEvalMethod:
begin
if ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then
begin
tok.pb.Reset;
TokRec^.obj := TSuperObject.Create(stArray);
TokRec^.state := tsMethodValue;
goto redo_char;
end else
begin
tok.err := teEvalMethod;
goto out;
end;
end;
tsMethodValue:
begin
case v of
')':
TokRec^.state := tsIdentifier;
else
if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
begin
tok.err := teDepth;
goto out;
end;
inc(evalstack);
TokRec^.state := tsMethodPut;
inc(tok.depth);
tok.ResetLevel(tok.depth);
TokRec := @tok.stack[tok.depth];
goto redo_char;
end;
end;
tsMethodPut:
begin
TokRec^.obj.AsArray.Add(obj);
case v of
',':
begin
tok.pb.Reset;
TokRec^.saved_state := tsMethodValue;
TokRec^.state := tsEatws;
end;
')':
begin
if TokRec^.obj.AsArray.Length = 1 then
TokRec^.obj := TokRec^.obj.AsArray.GetO(0);
dec(evalstack);
tok.pb.Reset;
TokRec^.saved_state := tsIdentifier;
TokRec^.state := tsEatws;
end;
else
tok.err := teEvalMethod;
goto out;
end;
end;
{$ENDIF}
tsParamValue:
begin
case v of
']':
TokRec^.state := tsIdentifier;
else
if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
begin
tok.err := teDepth;
goto out;
end;
inc(evalstack);
TokRec^.state := tsParamPut;
inc(tok.depth);
tok.ResetLevel(tok.depth);
TokRec := @tok.stack[tok.depth];
goto redo_char;
end;
end;
tsParamPut:
begin
dec(evalstack);
TokRec^.obj := obj;
tok.pb.Reset;
TokRec^.saved_state := tsIdentifier;
TokRec^.state := tsEatws;
if v <> ']' then
begin
tok.err := teEvalArray;
goto out;
end;
end;
tsIdentifier:
begin
if (this = nil) then
begin
if (SOIChar(v) < 256) and IsEndDelimiter(AnsiChar(v)) then
begin
if not strict then
begin
tok.pb.TrimRight;
TokRec^.current := TSuperObject.Create(tok.pb.Fbuf);
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
goto redo_char;
end else
begin
tok.err := teParseString;
goto out;
end;
end else
if (v = '\') then
begin
TokRec^.saved_state := tsIdentifier;
TokRec^.state := tsStringEscape;
end else
tok.pb.Append(@v, 1);
end else
begin
if (SOIChar(v) < 256) and (AnsiChar(v) in reserved) then
begin
TokRec^.gparent := TokRec^.parent;
if TokRec^.current = nil then
TokRec^.parent := this else
TokRec^.parent := TokRec^.current;
case ObjectGetType(TokRec^.parent) of
stObject:
case v of
'.':
begin
TokRec^.state := tsEvalProperty;
if tok.pb.FBPos > 0 then
TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
end;
'[':
begin
TokRec^.state := tsEvalArray;
if tok.pb.FBPos > 0 then
TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
end;
'(':
begin
TokRec^.state := tsEvalMethod;
if tok.pb.FBPos > 0 then
TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
end;
else
if tok.pb.FBPos > 0 then
TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
if (foPutValue in options) and (evalstack = 0) then
begin
TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, put);
TokRec^.current := put
end else
if (foDelete in options) and (evalstack = 0) then
begin
TokRec^.current := TokRec^.parent.AsObject.Delete(tok.pb.Fbuf);
end else
if (TokRec^.current = nil) and (foCreatePath in options) then
begin
TokRec^.current := TSuperObject.Create(dt);
TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current);
end;
TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
TokRec^.state := tsFinish;
goto redo_char;
end;
stArray:
begin
if TokRec^.obj <> nil then
begin
if not ObjectIsType(TokRec^.obj, stInt) or (TokRec^.obj.AsInteger < 0) then
begin
tok.err := teEvalInt;
TokRec^.obj := nil;
goto out;
end;
numi := TokRec^.obj.AsInteger;
TokRec^.obj := nil;
TokRec^.current := TokRec^.parent.AsArray.GetO(numi);
case v of
'.':
if (TokRec^.current = nil) and (foCreatePath in options) then
begin
TokRec^.current := TSuperObject.Create(stObject);
TokRec^.parent.AsArray.PutO(numi, TokRec^.current);
end else
if (TokRec^.current = nil) then
begin
tok.err := teEvalObject;
goto out;
end;
'[':
begin
if (TokRec^.current = nil) and (foCreatePath in options) then
begin
TokRec^.current := TSuperObject.Create(stArray);
TokRec^.parent.AsArray.Add(TokRec^.current);
end else
if (TokRec^.current = nil) then
begin
tok.err := teEvalArray;
goto out;
end;
TokRec^.state := tsEvalArray;
end;
'(': TokRec^.state := tsEvalMethod;
else
if (foPutValue in options) and (evalstack = 0) then
begin
TokRec^.parent.AsArray.PutO(numi, put);
TokRec^.current := put;
end else
if (foDelete in options) and (evalstack = 0) then
begin
TokRec^.current := TokRec^.parent.AsArray.Delete(numi);
end else
TokRec^.current := TokRec^.parent.AsArray.GetO(numi);
TokRec^.state := tsFinish;
goto redo_char
end;
end else
begin
case v of
'.':
begin
if (foPutValue in options) then
begin
TokRec^.current := TSuperObject.Create(stObject);
TokRec^.parent.AsArray.Add(TokRec^.current);
end else
TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
end;
'[':
begin
if (foPutValue in options) then
begin
TokRec^.current := TSuperObject.Create(stArray);
TokRec^.parent.AsArray.Add(TokRec^.current);
end else
TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
TokRec^.state := tsEvalArray;
end;
'(':
begin
if not (foPutValue in options) then
TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1) else
TokRec^.current := nil;
TokRec^.state := tsEvalMethod;
end;
else
if (foPutValue in options) and (evalstack = 0) then
begin
TokRec^.parent.AsArray.Add(put);
TokRec^.current := put;
end else
if tok.pb.FBPos = 0 then
TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
TokRec^.state := tsFinish;
goto redo_char
end;
end;
end;
{$IFDEF SUPER_METHOD}
stMethod:
case v of
'.':
begin
TokRec^.current := nil;
sm := TokRec^.parent.AsMethod;
sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
TokRec^.obj := nil;
end;
'[':
begin
TokRec^.current := nil;
sm := TokRec^.parent.AsMethod;
sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
TokRec^.state := tsEvalArray;
TokRec^.obj := nil;
end;
'(':
begin
TokRec^.current := nil;
sm := TokRec^.parent.AsMethod;
sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
TokRec^.state := tsEvalMethod;
TokRec^.obj := nil;
end;
else
if not (foPutValue in options) or (evalstack > 0) then
begin
TokRec^.current := nil;
sm := TokRec^.parent.AsMethod;
sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
TokRec^.obj := nil;
TokRec^.state := tsFinish;
goto redo_char
end else
begin
tok.err := teEvalMethod;
TokRec^.obj := nil;
goto out;
end;
end;
{$ENDIF}
end;
end else
tok.pb.Append(@v, 1);
end;
end;
tsStringEscape:
case v of
'b',
'n',
'r',
't',
'f':
begin
if(v = 'b') then tok.pb.Append(TOK_BS, 1)
else if(v = 'n') then tok.pb.Append(TOK_LF, 1)
else if(v = 'r') then tok.pb.Append(TOK_CR, 1)
else if(v = 't') then tok.pb.Append(TOK_TAB, 1)
else if(v = 'f') then tok.pb.Append(TOK_FF, 1);
TokRec^.state := TokRec^.saved_state;
end;
'u':
begin
tok.ucs_char := 0;
tok.st_pos := 0;
TokRec^.state := tsEscapeUnicode;
end;
'x':
begin
tok.ucs_char := 0;
tok.st_pos := 0;
TokRec^.state := tsEscapeHexadecimal;
end
else
tok.pb.Append(@v, 1);
TokRec^.state := TokRec^.saved_state;
end;
tsEscapeUnicode:
begin
if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then
begin
inc(tok.ucs_char, (Word(hexdigit(v)) shl ((3-tok.st_pos)*4)));
inc(tok.st_pos);
if (tok.st_pos = 4) then
begin
tok.pb.Append(@tok.ucs_char, 1);
TokRec^.state := TokRec^.saved_state;
end
end else
begin
tok.err := teParseString;
goto out;
end
end;
tsEscapeHexadecimal:
begin
if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then
begin
inc(tok.ucs_char, (Word(hexdigit(v)) shl ((1-tok.st_pos)*4)));
inc(tok.st_pos);
if (tok.st_pos = 2) then
begin
tok.pb.Append(@tok.ucs_char, 1);
TokRec^.state := TokRec^.saved_state;
end
end else
begin
tok.err := teParseString;
goto out;
end
end;
tsBoolean:
begin
tok.pb.Append(@v, 1);
if (StrLComp('true', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then
begin
if (tok.st_pos = 4) then
if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
TokRec^.state := tsIdentifier else
begin
TokRec^.current := TSuperObject.Create(true);
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
goto redo_char;
end
end else
if (StrLComp('false', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 5)) = 0) then
begin
if (tok.st_pos = 5) then
if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
TokRec^.state := tsIdentifier else
begin
TokRec^.current := TSuperObject.Create(false);
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
goto redo_char;
end
end else
begin
TokRec^.state := tsIdentifier;
tok.pb.FBuf[tok.st_pos] := #0;
dec(tok.pb.FBPos);
goto redo_char;
end;
inc(tok.st_pos);
end;
tsNumber:
begin
if (SOIChar(v) < 256) and (AnsiChar(v) in super_number_chars_set) then
begin
tok.pb.Append(@v, 1);
if (SOIChar(v) < 256) then
case v of
'.': begin
tok.is_double := 1;
tok.floatcount := 0;
end;
'e','E':
begin
tok.is_double := 1;
tok.floatcount := -1;
end;
'0'..'9':
begin
if (tok.is_double = 1) and (tok.floatcount >= 0) then
begin
inc(tok.floatcount);
if tok.floatcount > 4 then
tok.floatcount := -1;
end;
end;
end;
end else
begin
if (tok.is_double = 0) then
begin
val(tok.pb.FBuf, numi, code);
if ObjectIsType(this, stArray) then
begin
if (foPutValue in options) and (evalstack = 0) then
begin
this.AsArray.PutO(numi, put);
TokRec^.current := put;
end else
if (foDelete in options) and (evalstack = 0) then
TokRec^.current := this.AsArray.Delete(numi) else
TokRec^.current := this.AsArray.GetO(numi);
end else
TokRec^.current := TSuperObject.Create(numi);
end else
if (tok.is_double <> 0) then
begin
if tok.floatcount >= 0 then
begin
p := tok.pb.FBuf;
while p^ <> '.' do inc(p);
for code := 0 to tok.floatcount - 1 do
begin
p^ := p[1];
inc(p);
end;
p^ := #0;
val(tok.pb.FBuf, numi, code);
case tok.floatcount of
0: numi := numi * 10000;
1: numi := numi * 1000;
2: numi := numi * 100;
3: numi := numi * 10;
end;
TokRec^.current := TSuperObject.CreateCurrency(PCurrency(@numi)^);
end else
begin
val(tok.pb.FBuf, numd, code);
TokRec^.current := TSuperObject.Create(numd);
end;
end else
begin
tok.err := teParseNumber;
goto out;
end;
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
goto redo_char;
end
end;
tsArray:
begin
if (v = ']') then
begin
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
end else
begin
if(tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
begin
tok.err := teDepth;
goto out;
end;
TokRec^.state := tsArrayAdd;
inc(tok.depth);
tok.ResetLevel(tok.depth);
TokRec := @tok.stack[tok.depth];
goto redo_char;
end
end;
tsArrayAdd:
begin
TokRec^.current.AsArray.Add(obj);
TokRec^.saved_state := tsArraySep;
TokRec^.state := tsEatws;
goto redo_char;
end;
tsArraySep:
begin
if (v = ']') then
begin
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
end else
if (v = ',') then
begin
TokRec^.saved_state := tsArray;
TokRec^.state := tsEatws;
end else
begin
tok.err := teParseArray;
goto out;
end
end;
tsObjectFieldStart:
begin
if (v = '}') then
begin
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
end else
if (SOIChar(v) < 256) and (AnsiChar(v) in ['"', '''']) then
begin
tok.quote_char := v;
tok.pb.Reset;
TokRec^.state := tsObjectField;
end else
if not((SOIChar(v) < 256) and ((AnsiChar(v) in reserved) or strict)) then
begin
TokRec^.state := tsObjectUnquotedField;
tok.pb.Reset;
goto redo_char;
end else
begin
tok.err := teParseObjectKeyName;
goto out;
end
end;
tsObjectField:
begin
if (v = tok.quote_char) then
begin
TokRec^.field_name := tok.pb.FBuf;
TokRec^.saved_state := tsObjectFieldEnd;
TokRec^.state := tsEatws;
end else
if (v = '\') then
begin
TokRec^.saved_state := tsObjectField;
TokRec^.state := tsStringEscape;
end else
begin
tok.pb.Append(@v, 1);
end
end;
tsObjectUnquotedField:
begin
if (SOIChar(v) < 256) and (AnsiChar(v) in [':', #0]) then
begin
TokRec^.field_name := tok.pb.FBuf;
TokRec^.saved_state := tsObjectFieldEnd;
TokRec^.state := tsEatws;
goto redo_char;
end else
if (v = '\') then
begin
TokRec^.saved_state := tsObjectUnquotedField;
TokRec^.state := tsStringEscape;
end else
tok.pb.Append(@v, 1);
end;
tsObjectFieldEnd:
begin
if (v = ':') then
begin
TokRec^.saved_state := tsObjectValue;
TokRec^.state := tsEatws;
end else
begin
tok.err := teParseObjectKeySep;
goto out;
end
end;
tsObjectValue:
begin
if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
begin
tok.err := teDepth;
goto out;
end;
TokRec^.state := tsObjectValueAdd;
inc(tok.depth);
tok.ResetLevel(tok.depth);
TokRec := @tok.stack[tok.depth];
goto redo_char;
end;
tsObjectValueAdd:
begin
TokRec^.current.AsObject.PutO(TokRec^.field_name, obj);
TokRec^.field_name := '';
TokRec^.saved_state := tsObjectSep;
TokRec^.state := tsEatws;
goto redo_char;
end;
tsObjectSep:
begin
if (v = '}') then
begin
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
end else
if (v = ',') then
begin
TokRec^.saved_state := tsObjectFieldStart;
TokRec^.state := tsEatws;
end else
begin
tok.err := teParseObjectValueSep;
goto out;
end
end;
end;
inc(str);
inc(tok.char_offset);
until v = #0;
if(TokRec^.state <> tsFinish) and
(TokRec^.saved_state <> tsFinish) then
tok.err := teParseEof;
out:
if(tok.err in [teSuccess]) then
begin
{$IFDEF SUPER_METHOD}
if (foCallMethod in options) and ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then
begin
sm := TokRec^.current.AsMethod;
sm(TokRec^.parent, put, Result);
end else
{$ENDIF}
Result := TokRec^.current;
end else
Result := nil;
end;
procedure TSuperObject.PutO(const path: SOString; const Value: ISuperObject);
begin
ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], Value);
end;
procedure TSuperObject.PutB(const path: SOString; Value: Boolean);
begin
ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
end;
procedure TSuperObject.PutD(const path: SOString; Value: Double);
begin
ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
end;
procedure TSuperObject.PutC(const path: SOString; Value: Currency);
begin
ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.CreateCurrency(Value));
end;
procedure TSuperObject.PutI(const path: SOString; Value: SuperInt);
begin
ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
end;
procedure TSuperObject.PutS(const path: SOString; const Value: SOString);
begin
ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
end;
function TSuperObject.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
function TSuperObject.SaveTo(stream: TStream; indent, escape: boolean): integer;
var
pb: TSuperWriterStream;
begin
if escape then
pb := TSuperAnsiWriterStream.Create(stream) else
pb := TSuperUnicodeWriterStream.Create(stream);
if(Write(pb, indent, escape, 0) < 0) then
begin
pb.Reset;
pb.Free;
Result := 0;
Exit;
end;
Result := stream.Size;
pb.Free;
end;
function TSuperObject.CalcSize(indent, escape: boolean): integer;
var
pb: TSuperWriterFake;
begin
pb := TSuperWriterFake.Create;
if(Write(pb, indent, escape, 0) < 0) then
begin
pb.Free;
Result := 0;
Exit;
end;
Result := pb.FSize;
pb.Free;
end;
function TSuperObject.SaveTo(socket: Integer; indent, escape: boolean): integer;
var
pb: TSuperWriterSock;
begin
pb := TSuperWriterSock.Create(socket);
if(Write(pb, indent, escape, 0) < 0) then
begin
pb.Free;
Result := 0;
Exit;
end;
Result := pb.FSize;
pb.Free;
end;
constructor TSuperObject.Create(const s: SOString);
begin
Create(stString);
FOString := s;
end;
procedure TSuperObject.Clear(all: boolean);
begin
if FProcessing then exit;
FProcessing := true;
try
case FDataType of
stBoolean: FO.c_boolean := false;
stDouble: FO.c_double := 0.0;
stCurrency: FO.c_currency := 0.0;
stInt: FO.c_int := 0;
stObject: FO.c_object.Clear(all);
stArray: FO.c_array.Clear(all);
stString: FOString := '';
{$IFDEF SUPER_METHOD}
stMethod: FO.c_method := nil;
{$ENDIF}
end;
finally
FProcessing := false;
end;
end;
procedure TSuperObject.Pack(all: boolean = false);
begin
if FProcessing then exit;
FProcessing := true;
try
case FDataType of
stObject: FO.c_object.Pack(all);
stArray: FO.c_array.Pack(all);
end;
finally
FProcessing := false;
end;
end;
function TSuperObject.GetN(const path: SOString): ISuperObject;
begin
Result := ParseString(PSOChar(path), False, true, self);
if Result = nil then
Result := TSuperObject.Create(stNull);
end;
procedure TSuperObject.PutN(const path: SOString; const Value: ISuperObject);
begin
if Value = nil then
ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], TSuperObject.Create(stNull)) else
ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], Value);
end;
function TSuperObject.Delete(const path: SOString): ISuperObject;
begin
Result := ParseString(PSOChar(path), False, true, self, [foDelete]);
end;
function TSuperObject.Clone: ISuperObject;
var
ite: TSuperObjectIter;
arr: TSuperArray;
j: integer;
begin
case FDataType of
stBoolean: Result := TSuperObject.Create(FO.c_boolean);
stDouble: Result := TSuperObject.Create(FO.c_double);
stCurrency: Result := TSuperObject.CreateCurrency(FO.c_currency);
stInt: Result := TSuperObject.Create(FO.c_int);
stString: Result := TSuperObject.Create(FOString);
{$IFDEF SUPER_METHOD}
stMethod: Result := TSuperObject.Create(FO.c_method);
{$ENDIF}
stObject:
begin
Result := TSuperObject.Create(stObject);
if ObjectFindFirst(self, ite) then
with Result.AsObject do
repeat
PutO(ite.key, ite.val.Clone);
until not ObjectFindNext(ite);
ObjectFindClose(ite);
end;
stArray:
begin
Result := TSuperObject.Create(stArray);
arr := AsArray;
with Result.AsArray do
for j := 0 to arr.Length - 1 do
Add(arr.GetO(j).Clone);
end;
else
Result := nil;
end;
end;
procedure TSuperObject.Merge(const obj: ISuperObject; reference: boolean);
var
prop1, prop2: ISuperObject;
ite: TSuperObjectIter;
arr: TSuperArray;
j: integer;
begin
if ObjectIsType(obj, FDataType) then
case FDataType of
stBoolean: FO.c_boolean := obj.AsBoolean;
stDouble: FO.c_double := obj.AsDouble;
stCurrency: FO.c_currency := obj.AsCurrency;
stInt: FO.c_int := obj.AsInteger;
stString: FOString := obj.AsString;
{$IFDEF SUPER_METHOD}
stMethod: FO.c_method := obj.AsMethod;
{$ENDIF}
stObject:
begin
if ObjectFindFirst(obj, ite) then
with FO.c_object do
repeat
prop1 := FO.c_object.GetO(ite.key);
if (prop1 <> nil) and (ite.val <> nil) and (prop1.DataType = ite.val.DataType) then
prop1.Merge(ite.val) else
if reference then
PutO(ite.key, ite.val) else
PutO(ite.key, ite.val.Clone);
until not ObjectFindNext(ite);
ObjectFindClose(ite);
end;
stArray:
begin
arr := obj.AsArray;
with FO.c_array do
for j := 0 to arr.Length - 1 do
begin
prop1 := GetO(j);
prop2 := arr.GetO(j);
if (prop1 <> nil) and (prop2 <> nil) and (prop1.DataType = prop2.DataType) then
prop1.Merge(prop2) else
if reference then
PutO(j, prop2) else
PutO(j, prop2.Clone);
end;
end;
end;
end;
procedure TSuperObject.Merge(const str: SOString);
begin
Merge(TSuperObject.ParseString(PSOChar(str), False), true);
end;
class function TSuperObject.NewInstance: TObject;
begin
Result := inherited NewInstance;
TSuperObject(Result).FRefCount := 1;
end;
function TSuperObject.ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
begin
Result := ParseString(PSOChar(path), False, True, Self, [foCreatePath], nil, dataType);
end;
function TSuperObject.Format(const str: SOString; BeginSep: SOChar; EndSep: SOChar): SOString;
var
p1, p2: PSOChar;
begin
Result := '';
p2 := PSOChar(str);
p1 := p2;
while true do
if p2^ = BeginSep then
begin
if p2 > p1 then
Result := Result + Copy(p1, 0, p2-p1);
inc(p2);
p1 := p2;
while true do
if p2^ = EndSep then Break else
if p2^ = #0 then Exit else
inc(p2);
Result := Result + GetS(copy(p1, 0, p2-p1));
inc(p2);
p1 := p2;
end
else if p2^ = #0 then
begin
if p2 > p1 then
Result := Result + Copy(p1, 0, p2-p1);
Break;
end else
inc(p2);
end;
function TSuperObject.GetO(const path: SOString): ISuperObject;
begin
Result := ParseString(PSOChar(path), False, True, Self);
end;
function TSuperObject.GetA(const path: SOString): TSuperArray;
var
obj: ISuperObject;
begin
obj := ParseString(PSOChar(path), False, True, Self);
if obj <> nil then
Result := obj.AsArray else
Result := nil;
end;
function TSuperObject.GetB(const path: SOString): Boolean;
var
obj: ISuperObject;
begin
obj := GetO(path);
if obj <> nil then
Result := obj.AsBoolean else
Result := false;
end;
function TSuperObject.GetD(const path: SOString): Double;
var
obj: ISuperObject;
begin
obj := GetO(path);
if obj <> nil then
Result := obj.AsDouble else
Result := 0.0;
end;
function TSuperObject.GetC(const path: SOString): Currency;
var
obj: ISuperObject;
begin
obj := GetO(path);
if obj <> nil then
Result := obj.AsCurrency else
Result := 0.0;
end;
function TSuperObject.GetI(const path: SOString): SuperInt;
var
obj: ISuperObject;
begin
obj := GetO(path);
if obj <> nil then
Result := obj.AsInteger else
Result := 0;
end;
function TSuperObject.GetDataPtr: Pointer;
begin
Result := FDataPtr;
end;
function TSuperObject.GetDataType: TSuperType;
begin
Result := FDataType
end;
function TSuperObject.GetS(const path: SOString): SOString;
var
obj: ISuperObject;
begin
obj := GetO(path);
if obj <> nil then
Result := obj.AsString else
Result := '';
end;
function TSuperObject.SaveTo(const FileName: string; indent, escape: boolean): integer;
var
stream: TFileStream;
begin
stream := TFileStream.Create(FileName, fmCreate);
try
Result := SaveTo(stream, indent, escape);
finally
stream.Free;
end;
end;
function TSuperObject.Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean;
begin
Result := Validate(TSuperObject.ParseString(PSOChar(rules), False), TSuperObject.ParseString(PSOChar(defs), False), callback, sender);
end;
function TSuperObject.Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean;
type
TDataType = (dtUnknown, dtStr, dtInt, dtFloat, dtNumber, dtText, dtBool,
dtMap, dtSeq, dtScalar, dtAny);
var
datatypes: ISuperObject;
names: ISuperObject;
function FindInheritedProperty(const prop: PSOChar; p: ISuperObject): ISuperObject;
var
o: ISuperObject;
e: TSuperAvlEntry;
begin
o := p[prop];
if o <> nil then
result := o else
begin
o := p['inherit'];
if (o <> nil) and ObjectIsType(o, stString) then
begin
e := names.AsObject.Search(o.AsString);
if (e <> nil) then
Result := FindInheritedProperty(prop, e.Value) else
Result := nil;
end else
Result := nil;
end;
end;
function FindDataType(o: ISuperObject): TDataType;
var
e: TSuperAvlEntry;
obj: ISuperObject;
begin
obj := FindInheritedProperty('type', o);
if obj <> nil then
begin
e := datatypes.AsObject.Search(obj.AsString);
if e <> nil then
Result := TDataType(e.Value.AsInteger) else
Result := dtUnknown;
end else
Result := dtUnknown;
end;
procedure GetNames(o: ISuperObject);
var
obj: ISuperObject;
f: TSuperObjectIter;
begin
obj := o['name'];
if ObjectIsType(obj, stString) then
names[obj.AsString] := o;
case FindDataType(o) of
dtMap:
begin
obj := o['mapping'];
if ObjectIsType(obj, stObject) then
begin
if ObjectFindFirst(obj, f) then
repeat
if ObjectIsType(f.val, stObject) then
GetNames(f.val);
until not ObjectFindNext(f);
ObjectFindClose(f);
end;
end;
dtSeq:
begin
obj := o['sequence'];
if ObjectIsType(obj, stObject) then
GetNames(obj);
end;
end;
end;
function FindInheritedField(const prop: SOString; p: ISuperObject): ISuperObject;
var
o: ISuperObject;
e: TSuperAvlEntry;
begin
o := p['mapping'];
if ObjectIsType(o, stObject) then
begin
o := o.AsObject.GetO(prop);
if o <> nil then
begin
Result := o;
Exit;
end;
end;
o := p['inherit'];
if ObjectIsType(o, stString) then
begin
e := names.AsObject.Search(o.AsString);
if (e <> nil) then
Result := FindInheritedField(prop, e.Value) else
Result := nil;
end else
Result := nil;
end;
function InheritedFieldExist(const obj: ISuperObject; p: ISuperObject; const name: SOString = ''): boolean;
var
o: ISuperObject;
e: TSuperAvlEntry;
j: TSuperAvlIterator;
begin
Result := true;
o := p['mapping'];
if ObjectIsType(o, stObject) then
begin
j := TSuperAvlIterator.Create(o.AsObject);
try
j.First;
e := j.GetIter;
while e <> nil do
begin
if obj.AsObject.Search(e.Name) = nil then
begin
Result := False;
if assigned(callback) then
callback(sender, veFieldNotFound, name + '.' + e.Name);
end;
j.Next;
e := j.GetIter;
end;
finally
j.Free;
end;
end;
o := p['inherit'];
if ObjectIsType(o, stString) then
begin
e := names.AsObject.Search(o.AsString);
if (e <> nil) then
Result := InheritedFieldExist(obj, e.Value, name) and Result;
end;
end;
function getInheritedBool(f: PSOChar; p: ISuperObject; default: boolean = false): boolean;
var
o: ISuperObject;
begin
o := FindInheritedProperty(f, p);
case ObjectGetType(o) of
stBoolean: Result := o.AsBoolean;
stNull: Result := Default;
else
Result := default;
if assigned(callback) then
callback(sender, veRuleMalformated, f);
end;
end;
procedure GetInheritedFieldList(list: ISuperObject; p: ISuperObject);
var
o: ISuperObject;
e: TSuperAvlEntry;
i: TSuperAvlIterator;
begin
Result := true;
o := p['mapping'];
if ObjectIsType(o, stObject) then
begin
i := TSuperAvlIterator.Create(o.AsObject);
try
i.First;
e := i.GetIter;
while e <> nil do
begin
if list.AsObject.Search(e.Name) = nil then
list[e.Name] := e.Value;
i.Next;
e := i.GetIter;
end;
finally
i.Free;
end;
end;
o := p['inherit'];
if ObjectIsType(o, stString) then
begin
e := names.AsObject.Search(o.AsString);
if (e <> nil) then
GetInheritedFieldList(list, e.Value);
end;
end;
function CheckEnum(o: ISuperObject; p: ISuperObject; name: SOString = ''): boolean;
var
enum: ISuperObject;
i: integer;
begin
Result := false;
enum := FindInheritedProperty('enum', p);
case ObjectGetType(enum) of
stArray:
for i := 0 to enum.AsArray.Length - 1 do
if (o.AsString = enum.AsArray[i].AsString) then
begin
Result := true;
exit;
end;
stNull: Result := true;
else
Result := false;
if assigned(callback) then
callback(sender, veRuleMalformated, '');
Exit;
end;
if (not Result) and assigned(callback) then
callback(sender, veValueNotInEnum, name);
end;
function CheckLength(len: integer; p: ISuperObject; const objpath: SOString): boolean;
var
length, o: ISuperObject;
begin
result := true;
length := FindInheritedProperty('length', p);
case ObjectGetType(length) of
stObject:
begin
o := length.AsObject.GetO('min');
if (o <> nil) and (o.AsInteger > len) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidLength, objpath);
end;
o := length.AsObject.GetO('max');
if (o <> nil) and (o.AsInteger < len) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidLength, objpath);
end;
o := length.AsObject.GetO('minex');
if (o <> nil) and (o.AsInteger >= len) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidLength, objpath);
end;
o := length.AsObject.GetO('maxex');
if (o <> nil) and (o.AsInteger <= len) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidLength, objpath);
end;
end;
stNull: ;
else
Result := false;
if assigned(callback) then
callback(sender, veRuleMalformated, '');
end;
end;
function CheckRange(obj: ISuperObject; p: ISuperObject; const objpath: SOString): boolean;
var
length, o: ISuperObject;
begin
result := true;
length := FindInheritedProperty('range', p);
case ObjectGetType(length) of
stObject:
begin
o := length.AsObject.GetO('min');
if (o <> nil) and (o.Compare(obj) = cpGreat) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidRange, objpath);
end;
o := length.AsObject.GetO('max');
if (o <> nil) and (o.Compare(obj) = cpLess) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidRange, objpath);
end;
o := length.AsObject.GetO('minex');
if (o <> nil) and (o.Compare(obj) in [cpGreat, cpEqu]) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidRange, objpath);
end;
o := length.AsObject.GetO('maxex');
if (o <> nil) and (o.Compare(obj) in [cpLess, cpEqu]) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidRange, objpath);
end;
end;
stNull: ;
else
Result := false;
if assigned(callback) then
callback(sender, veRuleMalformated, '');
end;
end;
function process(o: ISuperObject; p: ISuperObject; objpath: SOString = ''): boolean;
var
ite: TSuperAvlIterator;
ent: TSuperAvlEntry;
p2, o2, sequence: ISuperObject;
s: SOString;
i: integer;
uniquelist, fieldlist: ISuperObject;
begin
Result := true;
if (o = nil) then
begin
if getInheritedBool('required', p) then
begin
if assigned(callback) then
callback(sender, veFieldIsRequired, objpath);
result := false;
end;
end else
case FindDataType(p) of
dtStr:
case ObjectGetType(o) of
stString:
begin
Result := Result and CheckLength(Length(o.AsString), p, objpath);
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtBool:
case ObjectGetType(o) of
stBoolean:
begin
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtInt:
case ObjectGetType(o) of
stInt:
begin
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtFloat:
case ObjectGetType(o) of
stDouble, stCurrency:
begin
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtMap:
case ObjectGetType(o) of
stObject:
begin
// all objects have and match a rule ?
ite := TSuperAvlIterator.Create(o.AsObject);
try
ite.First;
ent := ite.GetIter;
while ent <> nil do
begin
p2 := FindInheritedField(ent.Name, p);
if ObjectIsType(p2, stObject) then
result := process(ent.Value, p2, objpath + '.' + ent.Name) and result else
begin
if assigned(callback) then
callback(sender, veUnexpectedField, objpath + '.' + ent.Name);
result := false; // field have no rule
end;
ite.Next;
ent := ite.GetIter;
end;
finally
ite.Free;
end;
// all expected field exists ?
Result := InheritedFieldExist(o, p, objpath) and Result;
end;
stNull: {nop};
else
result := false;
if assigned(callback) then
callback(sender, veRuleMalformated, objpath);
end;
dtSeq:
case ObjectGetType(o) of
stArray:
begin
sequence := FindInheritedProperty('sequence', p);
if sequence <> nil then
case ObjectGetType(sequence) of
stObject:
begin
for i := 0 to o.AsArray.Length - 1 do
result := process(o.AsArray.GetO(i), sequence, objpath + '[' + IntToStr(i) + ']') and result;
if getInheritedBool('unique', sequence) then
begin
// type is unique ?
uniquelist := TSuperObject.Create(stObject);
try
for i := 0 to o.AsArray.Length - 1 do
begin
s := o.AsArray.GetO(i).AsString;
if (s <> '') then
begin
if uniquelist.AsObject.Search(s) = nil then
uniquelist[s] := nil else
begin
Result := False;
if Assigned(callback) then
callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + ']');
end;
end;
end;
finally
uniquelist := nil;
end;
end;
// field is unique ?
if (FindDataType(sequence) = dtMap) then
begin
fieldlist := TSuperObject.Create(stObject);
try
GetInheritedFieldList(fieldlist, sequence);
ite := TSuperAvlIterator.Create(fieldlist.AsObject);
try
ite.First;
ent := ite.GetIter;
while ent <> nil do
begin
if getInheritedBool('unique', ent.Value) then
begin
uniquelist := TSuperObject.Create(stObject);
try
for i := 0 to o.AsArray.Length - 1 do
begin
o2 := o.AsArray.GetO(i);
if o2 <> nil then
begin
s := o2.AsObject.GetO(ent.Name).AsString;
if (s <> '') then
if uniquelist.AsObject.Search(s) = nil then
uniquelist[s] := nil else
begin
Result := False;
if Assigned(callback) then
callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + '].' + ent.name);
end;
end;
end;
finally
uniquelist := nil;
end;
end;
ite.Next;
ent := ite.GetIter;
end;
finally
ite.Free;
end;
finally
fieldlist := nil;
end;
end;
end;
stNull: {nop};
else
result := false;
if assigned(callback) then
callback(sender, veRuleMalformated, objpath);
end;
Result := Result and CheckLength(o.AsArray.Length, p, objpath);
end;
else
result := false;
if assigned(callback) then
callback(sender, veRuleMalformated, objpath);
end;
dtNumber:
case ObjectGetType(o) of
stInt,
stDouble, stCurrency:
begin
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtText:
case ObjectGetType(o) of
stInt,
stDouble,
stCurrency,
stString:
begin
result := result and CheckLength(Length(o.AsString), p, objpath);
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtScalar:
case ObjectGetType(o) of
stBoolean,
stDouble,
stCurrency,
stInt,
stString:
begin
result := result and CheckLength(Length(o.AsString), p, objpath);
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtAny:;
else
if assigned(callback) then
callback(sender, veRuleMalformated, objpath);
result := false;
end;
Result := Result and CheckEnum(o, p, objpath)
end;
var
j: integer;
begin
Result := False;
datatypes := TSuperObject.Create(stObject);
names := TSuperObject.Create;
try
datatypes.I['str'] := ord(dtStr);
datatypes.I['int'] := ord(dtInt);
datatypes.I['float'] := ord(dtFloat);
datatypes.I['number'] := ord(dtNumber);
datatypes.I['text'] := ord(dtText);
datatypes.I['bool'] := ord(dtBool);
datatypes.I['map'] := ord(dtMap);
datatypes.I['seq'] := ord(dtSeq);
datatypes.I['scalar'] := ord(dtScalar);
datatypes.I['any'] := ord(dtAny);
if ObjectIsType(defs, stArray) then
for j := 0 to defs.AsArray.Length - 1 do
if ObjectIsType(defs.AsArray[j], stObject) then
GetNames(defs.AsArray[j]) else
begin
if assigned(callback) then
callback(sender, veRuleMalformated, '');
Exit;
end;
if ObjectIsType(rules, stObject) then
GetNames(rules) else
begin
if assigned(callback) then
callback(sender, veRuleMalformated, '');
Exit;
end;
Result := process(self, rules);
finally
datatypes := nil;
names := nil;
end;
end;
function TSuperObject._AddRef: Integer; stdcall;
begin
Result := InterlockedIncrement(FRefCount);
end;
function TSuperObject._Release: Integer; stdcall;
begin
Result := InterlockedDecrement(FRefCount);
if Result = 0 then
Destroy;
end;
function TSuperObject.Compare(const str: SOString): TSuperCompareResult;
begin
Result := Compare(TSuperObject.ParseString(PSOChar(str), False));
end;
function TSuperObject.Compare(const obj: ISuperObject): TSuperCompareResult;
function GetIntCompResult(const i: int64): TSuperCompareResult;
begin
if i < 0 then result := cpLess else
if i = 0 then result := cpEqu else
Result := cpGreat;
end;
function GetDblCompResult(const d: double): TSuperCompareResult;
begin
if d < 0 then result := cpLess else
if d = 0 then result := cpEqu else
Result := cpGreat;
end;
begin
case DataType of
stBoolean:
case ObjectGetType(obj) of
stBoolean: Result := GetIntCompResult(ord(FO.c_boolean) - ord(obj.AsBoolean));
stDouble: Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsDouble);
stCurrency:Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsCurrency);
stInt: Result := GetIntCompResult(ord(FO.c_boolean) - obj.AsInteger);
stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
else
Result := cpError;
end;
stDouble:
case ObjectGetType(obj) of
stBoolean: Result := GetDblCompResult(FO.c_double - ord(obj.AsBoolean));
stDouble: Result := GetDblCompResult(FO.c_double - obj.AsDouble);
stCurrency:Result := GetDblCompResult(FO.c_double - obj.AsCurrency);
stInt: Result := GetDblCompResult(FO.c_double - obj.AsInteger);
stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
else
Result := cpError;
end;
stCurrency:
case ObjectGetType(obj) of
stBoolean: Result := GetDblCompResult(FO.c_currency - ord(obj.AsBoolean));
stDouble: Result := GetDblCompResult(FO.c_currency - obj.AsDouble);
stCurrency:Result := GetDblCompResult(FO.c_currency - obj.AsCurrency);
stInt: Result := GetDblCompResult(FO.c_currency - obj.AsInteger);
stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
else
Result := cpError;
end;
stInt:
case ObjectGetType(obj) of
stBoolean: Result := GetIntCompResult(FO.c_int - ord(obj.AsBoolean));
stDouble: Result := GetDblCompResult(FO.c_int - obj.AsDouble);
stCurrency:Result := GetDblCompResult(FO.c_int - obj.AsCurrency);
stInt: Result := GetIntCompResult(FO.c_int - obj.AsInteger);
stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
else
Result := cpError;
end;
stString:
case ObjectGetType(obj) of
stBoolean,
stDouble,
stCurrency,
stInt,
stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
else
Result := cpError;
end;
else
Result := cpError;
end;
end;
{$IFDEF SUPER_METHOD}
function TSuperObject.AsMethod: TSuperMethod;
begin
if FDataType = stMethod then
Result := FO.c_method else
Result := nil;
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
constructor TSuperObject.Create(m: TSuperMethod);
begin
Create(stMethod);
FO.c_method := m;
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
function TSuperObject.GetM(const path: SOString): TSuperMethod;
var
v: ISuperObject;
begin
v := ParseString(PSOChar(path), False, True, Self);
if (v <> nil) and (ObjectGetType(v) = stMethod) then
Result := v.AsMethod else
Result := nil;
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
procedure TSuperObject.PutM(const path: SOString; Value: TSuperMethod);
begin
ParseString(PSOChar(path), False, True, Self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
function TSuperObject.call(const path: SOString; const param: ISuperObject): ISuperObject;
begin
Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], param);
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
function TSuperObject.call(const path, param: SOString): ISuperObject;
begin
Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], TSuperObject.ParseString(PSOChar(param), False));
end;
{$ENDIF}
function TSuperObject.GetProcessing: boolean;
begin
Result := FProcessing;
end;
procedure TSuperObject.SetDataPtr(const Value: Pointer);
begin
FDataPtr := Value;
end;
procedure TSuperObject.SetProcessing(value: boolean);
begin
FProcessing := value;
end;
{ TSuperArray }
function TSuperArray.Add(const Data: ISuperObject): Integer;
begin
Result := FLength;
PutO(Result, data);
end;
function TSuperArray.Delete(index: Integer): ISuperObject;
begin
if (Index >= 0) and (Index < FLength) then
begin
Result := FArray^[index];
FArray^[index] := nil;
Dec(FLength);
if Index < FLength then
begin
Move(FArray^[index + 1], FArray^[index],
(FLength - index) * SizeOf(Pointer));
Pointer(FArray^[FLength]) := nil;
end;
end;
end;
procedure TSuperArray.Insert(index: Integer; const value: ISuperObject);
begin
if (Index >= 0) then
if (index < FLength) then
begin
if FLength = FSize then
Expand(index);
if Index < FLength then
Move(FArray^[index], FArray^[index + 1],
(FLength - index) * SizeOf(Pointer));
Pointer(FArray^[index]) := nil;
FArray^[index] := value;
Inc(FLength);
end else
PutO(index, value);
end;
procedure TSuperArray.Clear(all: boolean);
var
j: Integer;
begin
for j := 0 to FLength - 1 do
if FArray^[j] <> nil then
begin
if all then
FArray^[j].Clear(all);
FArray^[j] := nil;
end;
FLength := 0;
end;
procedure TSuperArray.Pack(all: boolean);
var
PackedCount, StartIndex, EndIndex, j: Integer;
begin
if FLength > 0 then
begin
PackedCount := 0;
StartIndex := 0;
repeat
while (StartIndex < FLength) and (FArray^[StartIndex] = nil) do
Inc(StartIndex);
if StartIndex < FLength then
begin
EndIndex := StartIndex;
while (EndIndex < FLength) and (FArray^[EndIndex] <> nil) do
Inc(EndIndex);
Dec(EndIndex);
if StartIndex > PackedCount then
Move(FArray^[StartIndex], FArray^[PackedCount], (EndIndex - StartIndex + 1) * SizeOf(Pointer));
Inc(PackedCount, EndIndex - StartIndex + 1);
StartIndex := EndIndex + 1;
end;
until StartIndex >= FLength;
FillChar(FArray^[PackedCount], (FLength - PackedCount) * sizeof(Pointer), 0);
FLength := PackedCount;
if all then
for j := 0 to FLength - 1 do
FArray^[j].Pack(all);
end;
end;
constructor TSuperArray.Create;
begin
inherited Create;
FSize := SUPER_ARRAY_LIST_DEFAULT_SIZE;
FLength := 0;
GetMem(FArray, sizeof(Pointer) * FSize);
FillChar(FArray^, sizeof(Pointer) * FSize, 0);
end;
destructor TSuperArray.Destroy;
begin
Clear;
FreeMem(FArray);
inherited;
end;
procedure TSuperArray.Expand(max: Integer);
var
new_size: Integer;
begin
if (max < FSize) then
Exit;
if max < (FSize shl 1) then
new_size := (FSize shl 1) else
new_size := max + 1;
ReallocMem(FArray, new_size * sizeof(Pointer));
FillChar(FArray^[FSize], (new_size - FSize) * sizeof(Pointer), 0);
FSize := new_size;
end;
function TSuperArray.GetO(const index: Integer): ISuperObject;
begin
if(index >= FLength) then
Result := nil else
Result := FArray^[index];
end;
function TSuperArray.GetB(const index: integer): Boolean;
var
obj: ISuperObject;
begin
obj := GetO(index);
if obj <> nil then
Result := obj.AsBoolean else
Result := false;
end;
function TSuperArray.GetD(const index: integer): Double;
var
obj: ISuperObject;
begin
obj := GetO(index);
if obj <> nil then
Result := obj.AsDouble else
Result := 0.0;
end;
function TSuperArray.GetI(const index: integer): SuperInt;
var
obj: ISuperObject;
begin
obj := GetO(index);
if obj <> nil then
Result := obj.AsInteger else
Result := 0;
end;
function TSuperArray.GetS(const index: integer): SOString;
var
obj: ISuperObject;
begin
obj := GetO(index);
if obj <> nil then
Result := obj.AsString else
Result := '';
end;
procedure TSuperArray.PutO(const index: Integer; const Value: ISuperObject);
begin
Expand(index);
FArray^[index] := value;
if(FLength <= index) then FLength := index + 1;
end;
function TSuperArray.GetN(const index: integer): ISuperObject;
begin
Result := GetO(index);
if Result = nil then
Result := TSuperObject.Create(stNull);
end;
procedure TSuperArray.PutN(const index: integer; const Value: ISuperObject);
begin
if Value <> nil then
PutO(index, Value) else
PutO(index, TSuperObject.Create(stNull));
end;
procedure TSuperArray.PutB(const index: integer; Value: Boolean);
begin
PutO(index, TSuperObject.Create(Value));
end;
procedure TSuperArray.PutD(const index: integer; Value: Double);
begin
PutO(index, TSuperObject.Create(Value));
end;
function TSuperArray.GetC(const index: integer): Currency;
var
obj: ISuperObject;
begin
obj := GetO(index);
if obj <> nil then
Result := obj.AsCurrency else
Result := 0.0;
end;
procedure TSuperArray.PutC(const index: integer; Value: Currency);
begin
PutO(index, TSuperObject.CreateCurrency(Value));
end;
procedure TSuperArray.PutI(const index: integer; Value: SuperInt);
begin
PutO(index, TSuperObject.Create(Value));
end;
procedure TSuperArray.PutS(const index: integer; const Value: SOString);
begin
PutO(index, TSuperObject.Create(Value));
end;
{$IFDEF SUPER_METHOD}
function TSuperArray.GetM(const index: integer): TSuperMethod;
var
v: ISuperObject;
begin
v := GetO(index);
if (ObjectGetType(v) = stMethod) then
Result := v.AsMethod else
Result := nil;
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
procedure TSuperArray.PutM(const index: integer; Value: TSuperMethod);
begin
PutO(index, TSuperObject.Create(Value));
end;
{$ENDIF}
{ TSuperWriterString }
function TSuperWriterString.Append(buf: PSOChar; Size: Integer): Integer;
function max(a, b: Integer): integer; begin if a > b then Result := a else Result := b end;
begin
Result := size;
if Size > 0 then
begin
if (FSize - FBPos <= size) then
begin
FSize := max(FSize * 2, FBPos + size + 8);
ReallocMem(FBuf, FSize * SizeOf(SOChar));
end;
// fast move
case size of
1: FBuf[FBPos] := buf^;
2: PInteger(@FBuf[FBPos])^ := PInteger(buf)^;
4: PInt64(@FBuf[FBPos])^ := PInt64(buf)^;
else
move(buf^, FBuf[FBPos], size * SizeOf(SOChar));
end;
inc(FBPos, size);
FBuf[FBPos] := #0;
end;
end;
function TSuperWriterString.Append(buf: PSOChar): Integer;
begin
Result := Append(buf, strlen(buf));
end;
constructor TSuperWriterString.Create;
begin
inherited;
FSize := 32;
FBPos := 0;
GetMem(FBuf, FSize * SizeOf(SOChar));
end;
destructor TSuperWriterString.Destroy;
begin
inherited;
if FBuf <> nil then
FreeMem(FBuf)
end;
function TSuperWriterString.GetString: SOString;
begin
SetString(Result, FBuf, FBPos);
end;
procedure TSuperWriterString.Reset;
begin
FBuf[0] := #0;
FBPos := 0;
end;
procedure TSuperWriterString.TrimRight;
begin
while (FBPos > 0) and (FBuf[FBPos-1] < #256) and (AnsiChar(FBuf[FBPos-1]) in [#32, #13, #10]) do
begin
dec(FBPos);
FBuf[FBPos] := #0;
end;
end;
{ TSuperWriterStream }
function TSuperWriterStream.Append(buf: PSOChar): Integer;
begin
Result := Append(buf, StrLen(buf));
end;
constructor TSuperWriterStream.Create(AStream: TStream);
begin
inherited Create;
FStream := AStream;
end;
procedure TSuperWriterStream.Reset;
begin
FStream.Size := 0;
end;
{ TSuperWriterStream }
function TSuperAnsiWriterStream.Append(buf: PSOChar; Size: Integer): Integer;
var
Buffer: array[0..1023] of AnsiChar;
pBuffer: PAnsiChar;
i: Integer;
begin
if Size = 1 then
Result := FStream.Write(buf^, Size) else
begin
if Size > SizeOf(Buffer) then
GetMem(pBuffer, Size) else
pBuffer := @Buffer;
try
for i := 0 to Size - 1 do
pBuffer[i] := AnsiChar(buf[i]);
Result := FStream.Write(pBuffer^, Size);
finally
if pBuffer <> @Buffer then
FreeMem(pBuffer);
end;
end;
end;
{ TSuperUnicodeWriterStream }
function TSuperUnicodeWriterStream.Append(buf: PSOChar; Size: Integer): Integer;
begin
Result := FStream.Write(buf^, Size * 2);
end;
{ TSuperWriterFake }
function TSuperWriterFake.Append(buf: PSOChar; Size: Integer): Integer;
begin
inc(FSize, Size);
Result := FSize;
end;
function TSuperWriterFake.Append(buf: PSOChar): Integer;
begin
inc(FSize, Strlen(buf));
Result := FSize;
end;
constructor TSuperWriterFake.Create;
begin
inherited Create;
FSize := 0;
end;
procedure TSuperWriterFake.Reset;
begin
FSize := 0;
end;
{ TSuperWriterSock }
function TSuperWriterSock.Append(buf: PSOChar; Size: Integer): Integer;
var
Buffer: array[0..1023] of AnsiChar;
pBuffer: PAnsiChar;
i: Integer;
begin
if Size = 1 then
{$IFDEF FPC}
Result := fpsend(FSocket, buf, size, 0) else
{$ELSE}
Result := send(FSocket, buf^, size, 0) else
{$ENDIF}
begin
if Size > SizeOf(Buffer) then
GetMem(pBuffer, Size) else
pBuffer := @Buffer;
try
for i := 0 to Size - 1 do
pBuffer[i] := AnsiChar(buf[i]);
{$IFDEF FPC}
Result := fpsend(FSocket, pBuffer, size, 0);
{$ELSE}
Result := send(FSocket, pBuffer^, size, 0);
{$ENDIF}
finally
if pBuffer <> @Buffer then
FreeMem(pBuffer);
end;
end;
inc(FSize, Result);
end;
function TSuperWriterSock.Append(buf: PSOChar): Integer;
begin
Result := Append(buf, StrLen(buf));
end;
constructor TSuperWriterSock.Create(ASocket: Integer);
begin
inherited Create;
FSocket := ASocket;
FSize := 0;
end;
procedure TSuperWriterSock.Reset;
begin
FSize := 0;
end;
{ TSuperTokenizer }
constructor TSuperTokenizer.Create;
begin
pb := TSuperWriterString.Create;
line := 1;
col := 0;
Reset;
end;
destructor TSuperTokenizer.Destroy;
begin
Reset;
pb.Free;
inherited;
end;
procedure TSuperTokenizer.Reset;
var
i: integer;
begin
for i := depth downto 0 do
ResetLevel(i);
depth := 0;
err := teSuccess;
end;
procedure TSuperTokenizer.ResetLevel(adepth: integer);
begin
stack[adepth].state := tsEatws;
stack[adepth].saved_state := tsStart;
stack[adepth].current := nil;
stack[adepth].field_name := '';
stack[adepth].obj := nil;
stack[adepth].parent := nil;
stack[adepth].gparent := nil;
end;
{ TSuperAvlTree }
constructor TSuperAvlTree.Create;
begin
FRoot := nil;
FCount := 0;
end;
destructor TSuperAvlTree.Destroy;
begin
Clear;
inherited;
end;
function TSuperAvlTree.IsEmpty: boolean;
begin
result := FRoot = nil;
end;
function TSuperAvlTree.balance(bal: TSuperAvlEntry): TSuperAvlEntry;
var
deep, old: TSuperAvlEntry;
bf: integer;
begin
if (bal.FBf > 0) then
begin
deep := bal.FGt;
if (deep.FBf < 0) then
begin
old := bal;
bal := deep.FLt;
old.FGt := bal.FLt;
deep.FLt := bal.FGt;
bal.FLt := old;
bal.FGt := deep;
bf := bal.FBf;
if (bf <> 0) then
begin
if (bf > 0) then
begin
old.FBf := -1;
deep.FBf := 0;
end else
begin
deep.FBf := 1;
old.FBf := 0;
end;
bal.FBf := 0;
end else
begin
old.FBf := 0;
deep.FBf := 0;
end;
end else
begin
bal.FGt := deep.FLt;
deep.FLt := bal;
if (deep.FBf = 0) then
begin
deep.FBf := -1;
bal.FBf := 1;
end else
begin
deep.FBf := 0;
bal.FBf := 0;
end;
bal := deep;
end;
end else
begin
(* "Less than" subtree is deeper. *)
deep := bal.FLt;
if (deep.FBf > 0) then
begin
old := bal;
bal := deep.FGt;
old.FLt := bal.FGt;
deep.FGt := bal.FLt;
bal.FGt := old;
bal.FLt := deep;
bf := bal.FBf;
if (bf <> 0) then
begin
if (bf < 0) then
begin
old.FBf := 1;
deep.FBf := 0;
end else
begin
deep.FBf := -1;
old.FBf := 0;
end;
bal.FBf := 0;
end else
begin
old.FBf := 0;
deep.FBf := 0;
end;
end else
begin
bal.FLt := deep.FGt;
deep.FGt := bal;
if (deep.FBf = 0) then
begin
deep.FBf := 1;
bal.FBf := -1;
end else
begin
deep.FBf := 0;
bal.FBf := 0;
end;
bal := deep;
end;
end;
Result := bal;
end;
function TSuperAvlTree.Insert(h: TSuperAvlEntry): TSuperAvlEntry;
var
unbal, parentunbal, hh, parent: TSuperAvlEntry;
depth, unbaldepth: longint;
cmp: integer;
unbalbf: integer;
branch: TSuperAvlBitArray;
p: Pointer;
begin
inc(FCount);
h.FLt := nil;
h.FGt := nil;
h.FBf := 0;
branch := [];
if (FRoot = nil) then
FRoot := h
else
begin
unbal := nil;
parentunbal := nil;
depth := 0;
unbaldepth := 0;
hh := FRoot;
parent := nil;
repeat
if (hh.FBf <> 0) then
begin
unbal := hh;
parentunbal := parent;
unbaldepth := depth;
end;
if hh.FHash <> h.FHash then
begin
if hh.FHash < h.FHash then cmp := -1 else
if hh.FHash > h.FHash then cmp := 1 else
cmp := 0;
end else
cmp := CompareNodeNode(h, hh);
if (cmp = 0) then
begin
Result := hh;
//exchange data
p := hh.Ptr;
hh.FPtr := h.Ptr;
h.FPtr := p;
doDeleteEntry(h, false);
dec(FCount);
exit;
end;
parent := hh;
if (cmp > 0) then
begin
hh := hh.FGt;
include(branch, depth);
end else
begin
hh := hh.FLt;
exclude(branch, depth);
end;
inc(depth);
until (hh = nil);
if (cmp < 0) then
parent.FLt := h else
parent.FGt := h;
depth := unbaldepth;
if (unbal = nil) then
hh := FRoot
else
begin
if depth in branch then
cmp := 1 else
cmp := -1;
inc(depth);
unbalbf := unbal.FBf;
if (cmp < 0) then
dec(unbalbf) else
inc(unbalbf);
if cmp < 0 then
hh := unbal.FLt else
hh := unbal.FGt;
if ((unbalbf <> -2) and (unbalbf <> 2)) then
begin
unbal.FBf := unbalbf;
unbal := nil;
end;
end;
if (hh <> nil) then
while (h <> hh) do
begin
if depth in branch then
cmp := 1 else
cmp := -1;
inc(depth);
if (cmp < 0) then
begin
hh.FBf := -1;
hh := hh.FLt;
end else (* cmp > 0 *)
begin
hh.FBf := 1;
hh := hh.FGt;
end;
end;
if (unbal <> nil) then
begin
unbal := balance(unbal);
if (parentunbal = nil) then
FRoot := unbal
else
begin
depth := unbaldepth - 1;
if depth in branch then
cmp := 1 else
cmp := -1;
if (cmp < 0) then
parentunbal.FLt := unbal else
parentunbal.FGt := unbal;
end;
end;
end;
result := h;
end;
function TSuperAvlTree.Search(const k: SOString; st: TSuperAvlSearchTypes): TSuperAvlEntry;
var
cmp, target_cmp: integer;
match_h, h: TSuperAvlEntry;
ha: Cardinal;
begin
ha := TSuperAvlEntry.Hash(k);
match_h := nil;
h := FRoot;
if (stLess in st) then
target_cmp := 1 else
if (stGreater in st) then
target_cmp := -1 else
target_cmp := 0;
while (h <> nil) do
begin
if h.FHash < ha then cmp := -1 else
if h.FHash > ha then cmp := 1 else
cmp := 0;
if cmp = 0 then
cmp := CompareKeyNode(PSOChar(k), h);
if (cmp = 0) then
begin
if (stEqual in st) then
begin
match_h := h;
break;
end;
cmp := -target_cmp;
end
else
if (target_cmp <> 0) then
if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then
match_h := h;
if cmp < 0 then
h := h.FLt else
h := h.FGt;
end;
result := match_h;
end;
function TSuperAvlTree.Delete(const k: SOString): ISuperObject;
var
depth, rm_depth: longint;
branch: TSuperAvlBitArray;
h, parent, child, path, rm, parent_rm: TSuperAvlEntry;
cmp, cmp_shortened_sub_with_path, reduced_depth, bf: integer;
ha: Cardinal;
begin
ha := TSuperAvlEntry.Hash(k);
cmp_shortened_sub_with_path := 0;
branch := [];
depth := 0;
h := FRoot;
parent := nil;
while true do
begin
if (h = nil) then
exit;
if h.FHash < ha then cmp := -1 else
if h.FHash > ha then cmp := 1 else
cmp := 0;
if cmp = 0 then
cmp := CompareKeyNode(k, h);
if (cmp = 0) then
break;
parent := h;
if (cmp > 0) then
begin
h := h.FGt;
include(branch, depth)
end else
begin
h := h.FLt;
exclude(branch, depth)
end;
inc(depth);
cmp_shortened_sub_with_path := cmp;
end;
rm := h;
parent_rm := parent;
rm_depth := depth;
if (h.FBf < 0) then
begin
child := h.FLt;
exclude(branch, depth);
cmp := -1;
end else
begin
child := h.FGt;
include(branch, depth);
cmp := 1;
end;
inc(depth);
if (child <> nil) then
begin
cmp := -cmp;
repeat
parent := h;
h := child;
if (cmp < 0) then
begin
child := h.FLt;
exclude(branch, depth);
end else
begin
child := h.FGt;
include(branch, depth);
end;
inc(depth);
until (child = nil);
if (parent = rm) then
cmp_shortened_sub_with_path := -cmp else
cmp_shortened_sub_with_path := cmp;
if cmp > 0 then
child := h.FLt else
child := h.FGt;
end;
if (parent = nil) then
FRoot := child else
if (cmp_shortened_sub_with_path < 0) then
parent.FLt := child else
parent.FGt := child;
if parent = rm then
path := h else
path := parent;
if (h <> rm) then
begin
h.FLt := rm.FLt;
h.FGt := rm.FGt;
h.FBf := rm.FBf;
if (parent_rm = nil) then
FRoot := h
else
begin
depth := rm_depth - 1;
if (depth in branch) then
parent_rm.FGt := h else
parent_rm.FLt := h;
end;
end;
if (path <> nil) then
begin
h := FRoot;
parent := nil;
depth := 0;
while (h <> path) do
begin
if (depth in branch) then
begin
child := h.FGt;
h.FGt := parent;
end else
begin
child := h.FLt;
h.FLt := parent;
end;
inc(depth);
parent := h;
h := child;
end;
reduced_depth := 1;
cmp := cmp_shortened_sub_with_path;
while true do
begin
if (reduced_depth <> 0) then
begin
bf := h.FBf;
if (cmp < 0) then
inc(bf) else
dec(bf);
if ((bf = -2) or (bf = 2)) then
begin
h := balance(h);
bf := h.FBf;
end else
h.FBf := bf;
reduced_depth := integer(bf = 0);
end;
if (parent = nil) then
break;
child := h;
h := parent;
dec(depth);
if depth in branch then
cmp := 1 else
cmp := -1;
if (cmp < 0) then
begin
parent := h.FLt;
h.FLt := child;
end else
begin
parent := h.FGt;
h.FGt := child;
end;
end;
FRoot := h;
end;
if rm <> nil then
begin
Result := rm.GetValue;
doDeleteEntry(rm, false);
dec(FCount);
end;
end;
procedure TSuperAvlTree.Pack(all: boolean);
var
node1, node2: TSuperAvlEntry;
list: TList;
i: Integer;
begin
node1 := FRoot;
list := TList.Create;
while node1 <> nil do
begin
if (node1.FLt = nil) then
begin
node2 := node1.FGt;
if (node1.FPtr = nil) then
list.Add(node1) else
if all then
node1.Value.Pack(all);
end
else
begin
node2 := node1.FLt;
node1.FLt := node2.FGt;
node2.FGt := node1;
end;
node1 := node2;
end;
for i := 0 to list.Count - 1 do
Delete(TSuperAvlEntry(list[i]).FName);
list.Free;
end;
procedure TSuperAvlTree.Clear(all: boolean);
var
node1, node2: TSuperAvlEntry;
begin
node1 := FRoot;
while node1 <> nil do
begin
if (node1.FLt = nil) then
begin
node2 := node1.FGt;
doDeleteEntry(node1, all);
end
else
begin
node2 := node1.FLt;
node1.FLt := node2.FGt;
node2.FGt := node1;
end;
node1 := node2;
end;
FRoot := nil;
FCount := 0;
end;
function TSuperAvlTree.CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer;
begin
Result := StrComp(PSOChar(k), PSOChar(h.FName));
end;
function TSuperAvlTree.CompareNodeNode(node1, node2: TSuperAvlEntry): integer;
begin
Result := StrComp(PSOChar(node1.FName), PSOChar(node2.FName));
end;
{ TSuperAvlIterator }
(* Initialize depth to invalid value, to indicate iterator is
** invalid. (Depth is zero-base.) It's not necessary to initialize
** iterators prior to passing them to the "start" function.
*)
constructor TSuperAvlIterator.Create(tree: TSuperAvlTree);
begin
FDepth := not 0;
FTree := tree;
end;
procedure TSuperAvlIterator.Search(const k: SOString; st: TSuperAvlSearchTypes);
var
h: TSuperAvlEntry;
d: longint;
cmp, target_cmp: integer;
ha: Cardinal;
begin
ha := TSuperAvlEntry.Hash(k);
h := FTree.FRoot;
d := 0;
FDepth := not 0;
if (h = nil) then
exit;
if (stLess in st) then
target_cmp := 1 else
if (stGreater in st) then
target_cmp := -1 else
target_cmp := 0;
while true do
begin
if h.FHash < ha then cmp := -1 else
if h.FHash > ha then cmp := 1 else
cmp := 0;
if cmp = 0 then
cmp := FTree.CompareKeyNode(k, h);
if (cmp = 0) then
begin
if (stEqual in st) then
begin
FDepth := d;
break;
end;
cmp := -target_cmp;
end
else
if (target_cmp <> 0) then
if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then
FDepth := d;
if cmp < 0 then
h := h.FLt else
h := h.FGt;
if (h = nil) then
break;
if (cmp > 0) then
include(FBranch, d) else
exclude(FBranch, d);
FPath[d] := h;
inc(d);
end;
end;
procedure TSuperAvlIterator.First;
var
h: TSuperAvlEntry;
begin
h := FTree.FRoot;
FDepth := not 0;
FBranch := [];
while (h <> nil) do
begin
if (FDepth <> not 0) then
FPath[FDepth] := h;
inc(FDepth);
h := h.FLt;
end;
end;
procedure TSuperAvlIterator.Last;
var
h: TSuperAvlEntry;
begin
h := FTree.FRoot;
FDepth := not 0;
FBranch := [0..SUPER_AVL_MAX_DEPTH - 1];
while (h <> nil) do
begin
if (FDepth <> not 0) then
FPath[FDepth] := h;
inc(FDepth);
h := h.FGt;
end;
end;
function TSuperAvlIterator.MoveNext: boolean;
begin
if FDepth = not 0 then
First else
Next;
Result := GetIter <> nil;
end;
function TSuperAvlIterator.GetIter: TSuperAvlEntry;
begin
if (FDepth = not 0) then
begin
result := nil;
exit;
end;
if FDepth = 0 then
Result := FTree.FRoot else
Result := FPath[FDepth - 1];
end;
procedure TSuperAvlIterator.Next;
var
h: TSuperAvlEntry;
begin
if (FDepth <> not 0) then
begin
if FDepth = 0 then
h := FTree.FRoot.FGt else
h := FPath[FDepth - 1].FGt;
if (h = nil) then
repeat
if (FDepth = 0) then
begin
FDepth := not 0;
break;
end;
dec(FDepth);
until (not (FDepth in FBranch))
else
begin
include(FBranch, FDepth);
FPath[FDepth] := h;
inc(FDepth);
while true do
begin
h := h.FLt;
if (h = nil) then
break;
exclude(FBranch, FDepth);
FPath[FDepth] := h;
inc(FDepth);
end;
end;
end;
end;
procedure TSuperAvlIterator.Prior;
var
h: TSuperAvlEntry;
begin
if (FDepth <> not 0) then
begin
if FDepth = 0 then
h := FTree.FRoot.FLt else
h := FPath[FDepth - 1].FLt;
if (h = nil) then
repeat
if (FDepth = 0) then
begin
FDepth := not 0;
break;
end;
dec(FDepth);
until (FDepth in FBranch)
else
begin
exclude(FBranch, FDepth);
FPath[FDepth] := h;
inc(FDepth);
while true do
begin
h := h.FGt;
if (h = nil) then
break;
include(FBranch, FDepth);
FPath[FDepth] := h;
inc(FDepth);
end;
end;
end;
end;
procedure TSuperAvlTree.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);
begin
Entry.Free;
end;
function TSuperAvlTree.GetEnumerator: TSuperAvlIterator;
begin
Result := TSuperAvlIterator.Create(Self);
end;
{ TSuperAvlEntry }
constructor TSuperAvlEntry.Create(const AName: SOString; Obj: Pointer);
begin
FName := AName;
FPtr := Obj;
FHash := Hash(FName);
end;
function TSuperAvlEntry.GetValue: ISuperObject;
begin
Result := ISuperObject(FPtr)
end;
class function TSuperAvlEntry.Hash(const k: SOString): Cardinal;
var
h: cardinal;
i: Integer;
begin
h := 0;
{$Q-}
for i := 1 to Length(k) do
h := h*129 + ord(k[i]) + $9e370001;
{$Q+}
Result := h;
end;
procedure TSuperAvlEntry.SetValue(const val: ISuperObject);
begin
ISuperObject(FPtr) := val;
end;
{ TSuperTableString }
function TSuperTableString.GetValues: ISuperObject;
var
ite: TSuperAvlIterator;
obj: TSuperAvlEntry;
begin
Result := TSuperObject.Create(stArray);
ite := TSuperAvlIterator.Create(Self);
try
ite.First;
obj := ite.GetIter;
while obj <> nil do
begin
Result.AsArray.Add(obj.Value);
ite.Next;
obj := ite.GetIter;
end;
finally
ite.Free;
end;
end;
function TSuperTableString.GetNames: ISuperObject;
var
ite: TSuperAvlIterator;
obj: TSuperAvlEntry;
begin
Result := TSuperObject.Create(stArray);
ite := TSuperAvlIterator.Create(Self);
try
ite.First;
obj := ite.GetIter;
while obj <> nil do
begin
Result.AsArray.Add(TSuperObject.Create(obj.FName));
ite.Next;
obj := ite.GetIter;
end;
finally
ite.Free;
end;
end;
procedure TSuperTableString.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);
begin
if Entry.Ptr <> nil then
begin
if all then Entry.Value.Clear(true);
Entry.Value := nil;
end;
inherited;
end;
function TSuperTableString.GetO(const k: SOString): ISuperObject;
var
e: TSuperAvlEntry;
begin
e := Search(k);
if e <> nil then
Result := e.Value else
Result := nil
end;
procedure TSuperTableString.PutO(const k: SOString; const value: ISuperObject);
var
entry: TSuperAvlEntry;
begin
entry := Insert(TSuperAvlEntry.Create(k, Pointer(value)));
if entry.FPtr <> nil then
ISuperObject(entry.FPtr)._AddRef;
end;
procedure TSuperTableString.PutS(const k: SOString; const value: SOString);
begin
PutO(k, TSuperObject.Create(Value));
end;
function TSuperTableString.GetS(const k: SOString): SOString;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj.AsString else
Result := '';
end;
procedure TSuperTableString.PutI(const k: SOString; value: SuperInt);
begin
PutO(k, TSuperObject.Create(Value));
end;
function TSuperTableString.GetI(const k: SOString): SuperInt;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj.AsInteger else
Result := 0;
end;
procedure TSuperTableString.PutD(const k: SOString; value: Double);
begin
PutO(k, TSuperObject.Create(Value));
end;
procedure TSuperTableString.PutC(const k: SOString; value: Currency);
begin
PutO(k, TSuperObject.CreateCurrency(Value));
end;
function TSuperTableString.GetC(const k: SOString): Currency;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj.AsCurrency else
Result := 0.0;
end;
function TSuperTableString.GetD(const k: SOString): Double;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj.AsDouble else
Result := 0.0;
end;
procedure TSuperTableString.PutB(const k: SOString; value: Boolean);
begin
PutO(k, TSuperObject.Create(Value));
end;
function TSuperTableString.GetB(const k: SOString): Boolean;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj.AsBoolean else
Result := False;
end;
{$IFDEF SUPER_METHOD}
procedure TSuperTableString.PutM(const k: SOString; value: TSuperMethod);
begin
PutO(k, TSuperObject.Create(Value));
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
function TSuperTableString.GetM(const k: SOString): TSuperMethod;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj.AsMethod else
Result := nil;
end;
{$ENDIF}
procedure TSuperTableString.PutN(const k: SOString; const value: ISuperObject);
begin
if value <> nil then
PutO(k, TSuperObject.Create(stNull)) else
PutO(k, value);
end;
function TSuperTableString.GetN(const k: SOString): ISuperObject;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj else
Result := TSuperObject.Create(stNull);
end;
{$IFDEF VER210}
{ TSuperAttribute }
constructor TSuperAttribute.Create(const AName: string);
begin
FName := AName;
end;
{ TSuperRttiContext }
constructor TSuperRttiContext.Create;
begin
Context := TRttiContext.Create;
SerialFromJson := TDictionary.Create;
SerialToJson := TDictionary.Create;
SerialFromJson.Add(TypeInfo(Boolean), serialfromboolean);
SerialFromJson.Add(TypeInfo(TDateTime), serialfromdatetime);
SerialFromJson.Add(TypeInfo(TGUID), serialfromguid);
SerialToJson.Add(TypeInfo(Boolean), serialtoboolean);
SerialToJson.Add(TypeInfo(TDateTime), serialtodatetime);
SerialToJson.Add(TypeInfo(TGUID), serialtoguid);
end;
destructor TSuperRttiContext.Destroy;
begin
SerialFromJson.Free;
SerialToJson.Free;
Context.Free;
end;
class function TSuperRttiContext.GetFieldName(r: TRttiField): string;
var
o: TCustomAttribute;
begin
for o in r.GetAttributes do
if o is SOName then
Exit(SOName(o).Name);
Result := r.Name;
end;
class function TSuperRttiContext.GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;
var
o: TCustomAttribute;
begin
if not ObjectIsType(obj, stNull) then Exit(obj);
for o in r.GetAttributes do
if o is SODefault then
Exit(SO(SODefault(o).Name));
Result := obj;
end;
function TSuperRttiContext.AsType(const obj: ISuperObject): T;
var
ret: TValue;
begin
if FromJson(TypeInfo(T), obj, ret) then
Result := ret.AsType else
raise exception.Create('Marshalling error');
end;
function TSuperRttiContext.AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject;
var
v: TValue;
begin
TValue.MakeWithoutCopy(@obj, TypeInfo(T), v);
if index <> nil then
Result := ToJson(v, index) else
Result := ToJson(v, so);
end;
function TSuperRttiContext.FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject;
var Value: TValue): Boolean;
procedure FromChar;
begin
if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then
begin
Value := string(AnsiString(obj.AsString)[1]);
Result := True;
end else
Result := False;
end;
procedure FromWideChar;
begin
if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then
begin
Value := obj.AsString[1];
Result := True;
end else
Result := False;
end;
procedure FromInt64;
var
i: Int64;
begin
case ObjectGetType(obj) of
stInt:
begin
TValue.Make(nil, TypeInfo, Value);
TValueData(Value).FAsSInt64 := obj.AsInteger;
Result := True;
end;
stString:
begin
if TryStrToInt64(obj.AsString, i) then
begin
TValue.Make(nil, TypeInfo, Value);
TValueData(Value).FAsSInt64 := i;
Result := True;
end else
Result := False;
end;
else
Result := False;
end;
end;
procedure FromInt(const obj: ISuperObject);
var
TypeData: PTypeData;
i: Integer;
o: ISuperObject;
begin
case ObjectGetType(obj) of
stInt, stBoolean:
begin
i := obj.AsInteger;
TypeData := GetTypeData(TypeInfo);
Result := (i >= TypeData.MinValue) and (i <= TypeData.MaxValue);
if Result then
TValue.Make(@i, TypeInfo, Value);
end;
stString:
begin
o := SO(obj.AsString);
if not ObjectIsType(o, stString) then
FromInt(o) else
Result := False;
end;
else
Result := False;
end;
end;
procedure fromSet;
begin
if ObjectIsType(obj, stInt) then
begin
TValue.Make(nil, TypeInfo, Value);
TValueData(Value).FAsSLong := obj.AsInteger;
Result := True;
end else
Result := False;
end;
procedure FromFloat(const obj: ISuperObject);
var
o: ISuperObject;
begin
case ObjectGetType(obj) of
stInt, stDouble, stCurrency:
begin
TValue.Make(nil, TypeInfo, Value);
case GetTypeData(TypeInfo).FloatType of
ftSingle: TValueData(Value).FAsSingle := obj.AsDouble;
ftDouble: TValueData(Value).FAsDouble := obj.AsDouble;
ftExtended: TValueData(Value).FAsExtended := obj.AsDouble;
ftComp: TValueData(Value).FAsSInt64 := obj.AsInteger;
ftCurr: TValueData(Value).FAsCurr := obj.AsCurrency;
end;
Result := True;
end;
stString:
begin
o := SO(obj.AsString);
if not ObjectIsType(o, stString) then
FromFloat(o) else
Result := False;
end
else
Result := False;
end;
end;
procedure FromString;
begin
case ObjectGetType(obj) of
stObject, stArray:
Result := False;
stnull:
begin
Value := '';
Result := True;
end;
else
Value := obj.AsString;
Result := True;
end;
end;
procedure FromClass;
var
f: TRttiField;
v: TValue;
begin
case ObjectGetType(obj) of
stObject:
begin
Result := True;
if Value.Kind <> tkClass then
Value := GetTypeData(TypeInfo).ClassType.Create;
for f in Context.GetType(Value.AsObject.ClassType).GetFields do
if f.FieldType <> nil then
begin
Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);
if Result then
f.SetValue(Value.AsObject, v) else
Exit;
end;
end;
stNull:
begin
Value := nil;
Result := True;
end
else
// error
Value := nil;
Result := False;
end;
end;
procedure FromRecord;
var
f: TRttiField;
p: Pointer;
v: TValue;
begin
Result := True;
TValue.Make(nil, TypeInfo, Value);
for f in Context.GetType(TypeInfo).GetFields do
begin
if ObjectIsType(obj, stObject) and (f.FieldType <> nil) then
begin
p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData;
Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);
if Result then
f.SetValue(p, v) else
Exit;
end else
begin
Result := False;
Exit;
end;
end;
end;
procedure FromDynArray;
var
i: Integer;
p: Pointer;
pb: PByte;
val: TValue;
typ: PTypeData;
el: PTypeInfo;
begin
case ObjectGetType(obj) of
stArray:
begin
i := obj.AsArray.Length;
p := nil;
DynArraySetLength(p, TypeInfo, 1, @i);
pb := p;
typ := GetTypeData(TypeInfo);
if typ.elType <> nil then
el := typ.elType^ else
el := typ.elType2^;
Result := True;
for i := 0 to i - 1 do
begin
Result := FromJson(el, obj.AsArray[i], val);
if not Result then
Break;
val.ExtractRawData(pb);
val := TValue.Empty;
Inc(pb, typ.elSize);
end;
if Result then
TValue.MakeWithoutCopy(@p, TypeInfo, Value) else
DynArrayClear(p, TypeInfo);
end;
stNull:
begin
TValue.MakeWithoutCopy(nil, TypeInfo, Value);
Result := True;
end;
else
i := 1;
p := nil;
DynArraySetLength(p, TypeInfo, 1, @i);
pb := p;
typ := GetTypeData(TypeInfo);
if typ.elType <> nil then
el := typ.elType^ else
el := typ.elType2^;
Result := FromJson(el, obj, val);
val.ExtractRawData(pb);
val := TValue.Empty;
if Result then
TValue.MakeWithoutCopy(@p, TypeInfo, Value) else
DynArrayClear(p, TypeInfo);
end;
end;
procedure FromArray;
var
ArrayData: PArrayTypeData;
idx: Integer;
function ProcessDim(dim: Byte; const o: ISuperobject): Boolean;
var
i: Integer;
v: TValue;
a: PTypeData;
begin
if ObjectIsType(o, stArray) and (ArrayData.Dims[dim-1] <> nil) then
begin
a := @GetTypeData(ArrayData.Dims[dim-1]^).ArrayData;
if (a.MaxValue - a.MinValue + 1) <> o.AsArray.Length then
begin
Result := False;
Exit;
end;
Result := True;
if dim = ArrayData.DimCount then
for i := a.MinValue to a.MaxValue do
begin
Result := FromJson(ArrayData.ElType^, o.AsArray[i], v);
if not Result then
Exit;
Value.SetArrayElement(idx, v);
inc(idx);
end
else
for i := a.MinValue to a.MaxValue do
begin
Result := ProcessDim(dim + 1, o.AsArray[i]);
if not Result then
Exit;
end;
end else
Result := False;
end;
var
i: Integer;
v: TValue;
begin
TValue.Make(nil, TypeInfo, Value);
ArrayData := @GetTypeData(TypeInfo).ArrayData;
idx := 0;
if ArrayData.DimCount = 1 then
begin
if ObjectIsType(obj, stArray) and (obj.AsArray.Length = ArrayData.ElCount) then
begin
Result := True;
for i := 0 to ArrayData.ElCount - 1 do
begin
Result := FromJson(ArrayData.ElType^, obj.AsArray[i], v);
if not Result then
Exit;
Value.SetArrayElement(idx, v);
v := TValue.Empty;
inc(idx);
end;
end else
Result := False;
end else
Result := ProcessDim(1, obj);
end;
procedure FromClassRef;
var
r: TRttiType;
begin
if ObjectIsType(obj, stString) then
begin
r := Context.FindType(obj.AsString);
if r <> nil then
begin
Value := TRttiInstanceType(r).MetaclassType;
Result := True;
end else
Result := False;
end else
Result := False;
end;
procedure FromUnknown;
begin
case ObjectGetType(obj) of
stBoolean:
begin
Value := obj.AsBoolean;
Result := True;
end;
stDouble:
begin
Value := obj.AsDouble;
Result := True;
end;
stCurrency:
begin
Value := obj.AsCurrency;
Result := True;
end;
stInt:
begin
Value := obj.AsInteger;
Result := True;
end;
stString:
begin
Value := obj.AsString;
Result := True;
end
else
Value := nil;
Result := False;
end;
end;
procedure FromInterface;
const soguid: TGuid = '{4B86A9E3-E094-4E5A-954A-69048B7B6327}';
var
o: ISuperObject;
begin
if CompareMem(@GetTypeData(TypeInfo).Guid, @soguid, SizeOf(TGUID)) then
begin
if obj <> nil then
TValue.Make(@obj, TypeInfo, Value) else
begin
o := TSuperObject.Create(stNull);
TValue.Make(@o, TypeInfo, Value);
end;
Result := True;
end else
Result := False;
end;
var
Serial: TSerialFromJson;
begin
if TypeInfo <> nil then
begin
if not SerialFromJson.TryGetValue(TypeInfo, Serial) then
case TypeInfo.Kind of
tkChar: FromChar;
tkInt64: FromInt64;
tkEnumeration, tkInteger: FromInt(obj);
tkSet: fromSet;
tkFloat: FromFloat(obj);
tkString, tkLString, tkUString, tkWString: FromString;
tkClass: FromClass;
tkMethod: ;
tkWChar: FromWideChar;
tkRecord: FromRecord;
tkPointer: ;
tkInterface: FromInterface;
tkArray: FromArray;
tkDynArray: FromDynArray;
tkClassRef: FromClassRef;
else
FromUnknown
end else
begin
TValue.Make(nil, TypeInfo, Value);
Result := Serial(Self, obj, Value);
end;
end else
Result := False;
end;
function TSuperRttiContext.ToJson(var value: TValue; const index: ISuperObject): ISuperObject;
procedure ToInt64;
begin
Result := TSuperObject.Create(SuperInt(Value.AsInt64));
end;
procedure ToChar;
begin
Result := TSuperObject.Create(string(Value.AsType));
end;
procedure ToInteger;
begin
Result := TSuperObject.Create(TValueData(Value).FAsSLong);
end;
procedure ToFloat;
begin
case Value.TypeData.FloatType of
ftSingle: Result := TSuperObject.Create(TValueData(Value).FAsSingle);
ftDouble: Result := TSuperObject.Create(TValueData(Value).FAsDouble);
ftExtended: Result := TSuperObject.Create(TValueData(Value).FAsExtended);
ftComp: Result := TSuperObject.Create(TValueData(Value).FAsSInt64);
ftCurr: Result := TSuperObject.CreateCurrency(TValueData(Value).FAsCurr);
end;
end;
procedure ToString;
begin
Result := TSuperObject.Create(string(Value.AsType));
end;
procedure ToClass;
var
o: ISuperObject;
f: TRttiField;
v: TValue;
begin
if TValueData(Value).FAsObject <> nil then
begin
o := index[IntToStr(Integer(Value.AsObject))];
if o = nil then
begin
Result := TSuperObject.Create(stObject);
index[IntToStr(Integer(Value.AsObject))] := Result;
for f in Context.GetType(Value.AsObject.ClassType).GetFields do
if f.FieldType <> nil then
begin
v := f.GetValue(Value.AsObject);
Result.AsObject[GetFieldName(f)] := ToJson(v, index);
end
end else
Result := o;
end else
Result := nil;
end;
procedure ToWChar;
begin
Result := TSuperObject.Create(string(Value.AsType));
end;
procedure ToVariant;
begin
Result := SO(Value.AsVariant);
end;
procedure ToRecord;
var
f: TRttiField;
v: TValue;
begin
Result := TSuperObject.Create(stObject);
for f in Context.GetType(Value.TypeInfo).GetFields do
begin
v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData);
Result.AsObject[GetFieldName(f)] := ToJson(v, index);
end;
end;
procedure ToArray;
var
idx: Integer;
ArrayData: PArrayTypeData;
procedure ProcessDim(dim: Byte; const o: ISuperObject);
var
dt: PTypeData;
i: Integer;
o2: ISuperObject;
v: TValue;
begin
if ArrayData.Dims[dim-1] = nil then Exit;
dt := GetTypeData(ArrayData.Dims[dim-1]^);
if Dim = ArrayData.DimCount then
for i := dt.MinValue to dt.MaxValue do
begin
v := Value.GetArrayElement(idx);
o.AsArray.Add(toJSon(v, index));
inc(idx);
end
else
for i := dt.MinValue to dt.MaxValue do
begin
o2 := TSuperObject.Create(stArray);
o.AsArray.Add(o2);
ProcessDim(dim + 1, o2);
end;
end;
var
i: Integer;
v: TValue;
begin
Result := TSuperObject.Create(stArray);
ArrayData := @Value.TypeData.ArrayData;
idx := 0;
if ArrayData.DimCount = 1 then
for i := 0 to ArrayData.ElCount - 1 do
begin
v := Value.GetArrayElement(i);
Result.AsArray.Add(toJSon(v, index))
end
else
ProcessDim(1, Result);
end;
procedure ToDynArray;
var
i: Integer;
v: TValue;
begin
Result := TSuperObject.Create(stArray);
for i := 0 to Value.GetArrayLength - 1 do
begin
v := Value.GetArrayElement(i);
Result.AsArray.Add(toJSon(v, index));
end;
end;
procedure ToClassRef;
begin
if TValueData(Value).FAsClass <> nil then
Result := TSuperObject.Create(string(
TValueData(Value).FAsClass.UnitName + '.' +
TValueData(Value).FAsClass.ClassName)) else
Result := nil;
end;
procedure ToInterface;
begin
if TValueData(Value).FHeapData <> nil then
TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else
Result := nil;
end;
var
Serial: TSerialToJson;
begin
if not SerialToJson.TryGetValue(value.TypeInfo, Serial) then
case Value.Kind of
tkInt64: ToInt64;
tkChar: ToChar;
tkSet, tkInteger, tkEnumeration: ToInteger;
tkFloat: ToFloat;
tkString, tkLString, tkUString, tkWString: ToString;
tkClass: ToClass;
tkWChar: ToWChar;
tkVariant: ToVariant;
tkRecord: ToRecord;
tkArray: ToArray;
tkDynArray: ToDynArray;
tkClassRef: ToClassRef;
tkInterface: ToInterface;
else
result := nil;
end else
Result := Serial(Self, value, index);
end;
{ TSuperObjectHelper }
constructor TSuperObjectHelper.FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil);
var
v: TValue;
ctxowned: Boolean;
begin
if ctx = nil then
begin
ctx := TSuperRttiContext.Create;
ctxowned := True;
end else
ctxowned := False;
try
v := Self;
if not ctx.FromJson(v.TypeInfo, obj, v) then
raise Exception.Create('Invalid object');
finally
if ctxowned then
ctx.Free;
end;
end;
constructor TSuperObjectHelper.FromJson(const str: string; ctx: TSuperRttiContext = nil);
begin
FromJson(SO(str), ctx);
end;
function TSuperObjectHelper.ToJson(ctx: TSuperRttiContext = nil): ISuperObject;
var
v: TValue;
ctxowned: boolean;
begin
if ctx = nil then
begin
ctx := TSuperRttiContext.Create;
ctxowned := True;
end else
ctxowned := False;
try
v := Self;
Result := ctx.ToJson(v, SO);
finally
if ctxowned then
ctx.Free;
end;
end;
{$ENDIF}
{$IFDEF DEBUG}
initialization
finalization
Assert(debugcount = 0, 'Memory leak');
{$ENDIF}
end.
================================================
FILE: lib/xedit/lz4/lz4.pas
================================================
(*
LZ4Delphi
Copyright (C) 2015, Jose Pascoa (atelierwebgm@gmail.com)
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
*************************************************************************
LZ4 - Fast LZ compression algorithm
xxHash - Fast Hash algorithm
LZ4 source repository : http://code.google.com/p/lz4/
xxHash source repository : http://code.google.com/p/xxhash/
Copyright (c) 2011-2014, Yann Collet
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following disclaimer
in the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************
*)
unit lz4;
{$POINTERMATH ON}
interface
uses Windows, lz4Common;
const
LZ4_VERSION_MAJOR = 1;
LZ4_VERSION_MINOR = 5;
LZ4_VERSION_RELEASE = 0;
LZ4_MEMORY_USAGE = 14;
LZ4_STREAMSIZE_U64 = (1 shl (LZ4_MEMORY_USAGE - 3)) + 4;
LZ4_STREAMSIZE = LZ4_STREAMSIZE_U64 * sizeof(int64);
LZ4_MAX_INPUT_SIZE = $7E000000;
LZ4_UNALIGNED_ACCESS = 1;
LZ4_STREAMDECODESIZE_U64 = 4;
type
PLZ4_stream_t = ^LZ4_stream_t;
LZ4_stream_t = record
table: array [0 .. LZ4_STREAMSIZE_U64 - 1] of int64;
end;
PLZ4_streamDecode_t = ^LZ4_streamDecode_t;
LZ4_streamDecode_t = record
table: array [0 .. LZ4_STREAMDECODESIZE_U64 - 1] of int64;
end;
function LZ4_versionNumber: integer;
function LZ4_compressBound(iSize: cardinal): cardinal;
function LZ4_create(inputBuffer: pAnsiChar): pointer;
function LZ4_createStream: PLZ4_stream_t;
procedure LZ4_freeStream(LZ4_streamPtr: PLZ4_stream_t);
function LZ4_createStreamDecode: PLZ4_streamDecode_t;
procedure LZ4_freeStreamDecode(LZ4_stream: PLZ4_streamDecode_t);
function LZ4_compress(source: pAnsiChar; dest: pAnsiChar; sourceSize: integer): integer;
function LZ4_decompress_safe(source: pAnsiChar; dest: pAnsiChar; compressedSize: integer; maxDecompressedSize: integer): integer;
function LZ4_compress_continue(LZ4_stream: pointer; const ASource: pointer; ADestination: pointer; AInputSize: integer): integer;
function LZ4_saveDict(LZ4_streamPtr: PLZ4_stream_t; safeBuffer: pointer; dictSize: integer): integer;
function LZ4_decompress_safe_continue(LZ4_streamDecode: PLZ4_streamDecode_t; source: pointer; dest: pointer; compressedSize: integer;
maxDecompressedSize: integer): integer;
function LZ4_compress_limitedOutput(const source: pAnsiChar; dest: pAnsiChar; inputSize: integer; maxOutputSize: integer): integer;
function LZ4_compress_withState(state: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer): integer;
function LZ4_compress_limitedOutput_withState(state: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer;
maxOutputSize: integer): integer;
function LZ4_compress_limitedOutput_continue(LZ4_stream: PLZ4_stream_t; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer;
maxOutputSize: integer): integer;
procedure LZ4_resetStream(LZ4_stream: PLZ4_stream_t);
function LZ4_loadDict(LZ4_dict: PLZ4_stream_t; dictionary: pAnsiChar; dictSize: integer): integer;
// debug function
function LZ4_compress_forceExtDict(LZ4_dict: PLZ4_stream_t; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer): integer;
function LZ4_decompress_fast(source: pAnsiChar; dest: pAnsiChar; originalSize: integer): integer;
function LZ4_decompress_fast_withPrefix64k(source: pAnsiChar; dest: pAnsiChar; originalSize: integer): integer;
function LZ4_decompress_fast_usingDict(source: pAnsiChar; dest: pAnsiChar; originalSize: integer; const dictStart: pAnsiChar;
dictSize: integer): integer;
function LZ4_decompress_safe_withPrefix64k(source: pAnsiChar; dest: pAnsiChar; compressedSize: integer; maxOutputSize: integer): integer;
function LZ4_decompress_safe_usingDict(const source: pAnsiChar; dest: pAnsiChar; compressedSize: integer; maxOutputSize: integer;
const dictStart: pAnsiChar; dictSize: integer): integer;
function LZ4_decompress_safe_partial(const source: pAnsiChar; dest: pAnsiChar; compressedSize: integer; targetOutputSize: integer;
maxDecompressedSize: integer): integer;
function LZ4_decompress_safe_forceExtDict(source: pAnsiChar; dest: pAnsiChar; compressedSize: integer; maxOutputSize: integer;
const dictStart: pAnsiChar; dictSize: integer): integer;
// replaced with move(source^, dest^, count)
// procedure memmove(dest, source: pointer; count: integer); cdecl; external 'msvcrt.dll' name 'memmove';
implementation
const
LZ4_HASHLOG = LZ4_MEMORY_USAGE - 2;
HASHTABLESIZE = 1 shl LZ4_MEMORY_USAGE;
HASH_SIZE_U32 = 1 shl LZ4_HASHLOG;
type
limitedOutput_directive = (notLimited = 0, limitedOutput = 1);
tableType_t = (byPtr, byU32, byU16);
dict_directive = (noDict = 0, withPrefix64k, usingExtDict);
dictIssue_directive = (noDictIssue = 0, dictSmall);
endCondition_directive = (endOnOutputSize = 0, endOnInputSize = 1);
earlyEnd_directive = (full = 0, partial = 1);
PLZ4_stream_t_internal = ^LZ4_stream_t_internal;
LZ4_stream_t_internal = record
hashTable: array [0 .. HASH_SIZE_U32 - 1] of cardinal;
currentOffset: cardinal;
initCheck: cardinal;
dictionary: pByte;
bufferStart: pByte;
dictSize: cardinal;
end;
PLZ4_streamDecode_t_internal = ^LZ4_streamDecode_t_internal;
LZ4_streamDecode_t_internal = record
externalDict: pByte;
extDictSize: size_t;
prefixEnd: pByte;
prefixSize: size_t;
end;
var
LZ4_64Klimit: integer = 65536 + _MFLIMIT - 1;
LZ4_skipTrigger: cardinal = 6;
LZ4_minLength: integer = (_MFLIMIT + 1);
function LZ4_versionNumber: integer;
begin
result := LZ4_VERSION_MAJOR * 100 * 100 + LZ4_VERSION_MINOR * 100 + LZ4_VERSION_RELEASE;
end;
function LZ4_compressBound(iSize: cardinal): cardinal;
begin
if (iSize) > cardinal(LZ4_MAX_INPUT_SIZE) then
result := 0
else
result := iSize + (iSize div 255 + 16)
end;
procedure LZ4_copy8(const dstPtr: pointer; const srcPtr: pointer); inline;
begin
{$IFDEF WIN64}
pUint64(dstPtr)^ := pUint64(srcPtr)^;
{$ELSE}
pCardinal(dstPtr)[0] := pCardinal(srcPtr)[0];
pCardinal(dstPtr)[1] := pCardinal(srcPtr)[1];
{$ENDIF}
end;
function LZ4_hashSequence(sequence: cardinal; tableType: tableType_t): cardinal; inline;
const
SHL1 = (MINMATCH * 8) - (LZ4_HASHLOG + 1);
SHL2 = ((MINMATCH * 8) - LZ4_HASHLOG);
begin
if (tableType = byU16) then
result := (sequence * 2654435761) shr SHL1
else
result := (sequence * 2654435761) shr SHL2;
end;
function LZ4_hashPosition(const p: pByte; tableType: tableType_t): cardinal; inline;
begin
result := LZ4_hashSequence(pCardinal(p)^, tableType);
end;
procedure LZ4_putPositionOnHash(const p: pByte; h: cardinal; tableBase: pointer; tableType: tableType_t; const srcBase: pByte); inline;
begin
case tableType of
byPtr: ppByte(tableBase)[h] := p;
byU32: pCardinal(tableBase)[h] := cardinal(p - srcBase);
byU16: pWord(tableBase)[h] := word(p - srcBase);
end;
end;
function LZ4_getPositionOnHash(h: cardinal; tableBase: pointer; tableType: tableType_t; const srcBase: pByte): pByte; inline;
begin
if (tableType = byPtr) then
result := ppByte(tableBase)[h]
else if (tableType = byU32) then
result := pCardinal(tableBase)[h] + srcBase
else
result := pWord(tableBase)[h] + srcBase;
end;
function LZ4_getPosition(const p: pByte; tableBase: pointer; tableType: tableType_t; const srcBase: pByte): pByte; inline;
var
h: cardinal;
begin
h := LZ4_hashPosition(p, tableType);
result := LZ4_getPositionOnHash(h, tableBase, tableType, srcBase);
end;
procedure LZ4_putPosition(const p: pByte; tableBase: pointer; tableType: tableType_t; const srcBase: pByte); inline;
var
h: cardinal;
begin
h := LZ4_hashPosition(p, tableType);
LZ4_putPositionOnHash(p, h, tableBase, tableType, srcBase);
end;
function LZ4_compress_generic(ctx: pointer; const source: pointer; dest: pointer; inputSize: integer; maxOutputSize: integer;
outputLimited: limitedOutput_directive; tableType: tableType_t; dict: dict_directive; dictIssue: dictIssue_directive): integer; inline;
var
lowRefLimit: pByte;
match: pByte;
refDelta: size_t;
ip: pByte;
dictPtr: PLZ4_stream_t_internal;
base: pByte;
lowLimit: pByte;
dictionary: pByte;
dictEnd: pByte;
dictDelta: size_t;
anchor: pByte;
iend: pByte;
mflimit: pByte;
matchlimit: pByte;
op: pByte;
olimit: pByte;
forwardH: cardinal;
lastRun: integer;
token: pByte;
forwardIp: pByte;
step: cardinal;
searchMatchNb: cardinal;
h: cardinal;
litLength: cardinal;
len: integer;
matchLength: cardinal;
limit: pByte;
more: cardinal;
booleanValue: boolean;
label
_last_literals, _next_match;
begin
match := nil;
dictPtr := ctx;
ip := pByte(source);
lowRefLimit := ip - dictPtr.dictSize;
dictionary := dictPtr.dictionary;
dictEnd := dictionary + dictPtr.dictSize;
dictDelta := dictEnd - pByte(source);
anchor := pByte(source);
iend := ip + inputSize;
mflimit := iend - _MFLIMIT;
matchlimit := iend - LASTLITERALS;
op := pByte(dest);
olimit := op + maxOutputSize;
refDelta := 0;
if cardinal(inputSize) > cardinal(LZ4_MAX_INPUT_SIZE) then
exit(0);
case dict of
withPrefix64k:
begin
base := pByte(source) - dictPtr.currentOffset;
lowLimit := pByte(source) - dictPtr.dictSize;
end;
usingExtDict:
begin
base := pByte(source) - dictPtr.currentOffset;
lowLimit := pByte(source);
end;
else
begin
base := pByte(source);
lowLimit := pByte(source);
end;
end;
if ((tableType = byU16) and (inputSize >= LZ4_64Klimit)) then
exit(0);
if (inputSize < LZ4_minLength) then
goto _last_literals;
LZ4_putPosition(ip, ctx, tableType, base);
inc(ip);
forwardH := LZ4_hashPosition(ip, tableType);
while true do
begin
forwardIp := ip;
step := 1;
searchMatchNb := (1 shl LZ4_skipTrigger);
while true do
begin
h := forwardH;
ip := forwardIp;
inc(forwardIp, step);
step := searchMatchNb shr LZ4_skipTrigger;
inc(searchMatchNb);
if forwardIp > mflimit then
goto _last_literals;
match := LZ4_getPositionOnHash(h, ctx, tableType, base);
if (dict = usingExtDict) then
begin
if match < pByte(source) then
begin
refDelta := dictDelta;
lowLimit := dictionary;
end
else
begin
refDelta := 0;
lowLimit := pByte(source);
end;
end;
forwardH := LZ4_hashPosition(forwardIp, tableType);
LZ4_putPositionOnHash(ip, h, ctx, tableType, base);
if (dictIssue = dictSmall) and (match < lowRefLimit) then
continue;
if not(tableType = byU16) and (match + MAX_DISTANCE < ip) then
continue;
if (pCardinal(match + refDelta)^ <> pCardinal(ip)^) then
continue;
break;
end;
while (ip > anchor) and (match + refDelta > lowLimit) and (ip[-1] = match[refDelta - 1]) do
begin
dec(ip);
dec(match);
end;
litLength := cardinal(ip - anchor);
token := op;
inc(op);
if (outputLimited <> notLimited) and (op + litLength + (2 + 1 + LASTLITERALS) + (litLength div 255) > olimit) then
exit(0);
if (litLength >= RUN_MASK) then
begin
len := integer(litLength - RUN_MASK);
token^ := (RUN_MASK shl ML_BITS);
while len >= 255 do
begin
op^ := 255;
inc(op);
dec(len, 255);
end;
op^ := BYTE(len);
inc(op);
end
else
token^ := BYTE(litLength shl ML_BITS);
LZ4_wildCopy(op, anchor, op + litLength);
inc(op, litLength);
_next_match:
pWord(op)^ := word(ip - match);
inc(op, 2);
if (dict = usingExtDict) and (lowLimit = dictionary) then
begin
inc(match, refDelta);
limit := ip + (dictEnd - match);
if (limit > matchlimit) then
limit := matchlimit;
matchLength := LZ4_count(ip + MINMATCH, match + MINMATCH, limit);
inc(ip, MINMATCH + matchLength);
if (ip = limit) then
begin
more := LZ4_count(ip, pByte(source), matchlimit);
inc(matchLength, more);
inc(ip, more);
end;
end
else
begin
matchLength := LZ4_count(ip + MINMATCH, match + MINMATCH, matchlimit);
inc(ip, MINMATCH + matchLength);
end;
if (outputLimited <> notLimited) and (op + (1 + LASTLITERALS) + (matchLength shr 8) > olimit) then
exit(0);
if (matchLength >= ML_MASK) then
begin
inc(token^, ML_MASK);
dec(matchLength, ML_MASK);
while matchLength >= 510 do
begin
pWord(op)^ := $FFFF;
inc(op, 2);
// op^ := 255;
// inc(op);
// op^ := 255;
// inc(op);
dec(matchLength, 510);
end;
if (matchLength >= 255) then
begin
dec(matchLength, 255);
op^ := 255;
inc(op);
end;
op^ := BYTE(matchLength);
inc(op);
end
else
inc(token^, BYTE(matchLength));
anchor := ip;
if (ip > mflimit) then
break;
LZ4_putPosition(ip - 2, ctx, tableType, base);
match := LZ4_getPosition(ip, ctx, tableType, base);
if (dict = usingExtDict) then
begin
if match < pByte(source) then
begin
refDelta := dictDelta;
lowLimit := dictionary;
end
else
begin
refDelta := 0;
lowLimit := pByte(source);
end;
end;
LZ4_putPosition(ip, ctx, tableType, base);
if dictIssue = dictSmall then
booleanValue := match >= lowRefLimit
else
booleanValue := true;
if (booleanValue and (match + MAX_DISTANCE >= ip)
and (pCardinal(match + refDelta)^ = pCardinal(ip)^)) then
begin
token := op;
inc(op);
token^ := 0;
goto _next_match;
end;
inc(ip);
forwardH := LZ4_hashPosition(ip, tableType);
end;
_last_literals:
lastRun := integer(iend - anchor);
if (outputLimited <> notLimited) and ((op - pByte(dest)) + lastRun + 1 + ((lastRun + 255 - RUN_MASK) div 255) >
maxOutputSize)
then
exit(0);
if lastRun >= integer(RUN_MASK) then
begin
op^ := (RUN_MASK shl ML_BITS);
inc(op);
dec(lastRun, RUN_MASK);
while lastRun >= 255 do
begin
op^ := 255;
inc(op);
dec(lastRun, 255);
end;
op^ := BYTE(lastRun);
inc(op);
end
else
begin
op^ := BYTE(lastRun shl ML_BITS);
inc(op);
end;
move(anchor^, op^, iend - anchor);
inc(op, iend - anchor);
result := integer(op - pByte(dest));
end;
function LZ4_compress(source: pAnsiChar; dest: pAnsiChar; sourceSize: integer): integer;
var
ctx: array [0 .. LZ4_STREAMSIZE_U64 - 1] of uint64;
begin
fillchar(ctx, sizeof(ctx), 0);
if sourceSize < LZ4_64Klimit then
result := LZ4_compress_generic(@ctx, source, dest, sourceSize, 0, notLimited, byU16, noDict, noDictIssue)
else
begin
{$IFDEF WIN64}
result := LZ4_compress_generic(@ctx, source, dest, sourceSize, 0, notLimited, byU32, noDict,
noDictIssue)
{$ELSE}
result := LZ4_compress_generic(@ctx, source, dest, sourceSize, 0, notLimited, byPtr, noDict, noDictIssue);
{$ENDIF}
end;
end;
function LZ4_decompress_generic(const source: pointer; const dest: pointer; inputSize: integer; outputSize: integer;
endOnInput: integer; partialDecoding: integer; targetOutputSize: integer; dict: integer;
const lowPrefix: pByte; const dictStart: pByte; const dictSize: size_t): integer; inline;
var
ip: pByte;
iend: pByte;
op: pByte;
oend: pByte;
cpy: pByte;
oexit: pByte;
lowLimit: pByte;
dictEnd: pByte;
safeDecode: boolean;
checkOffset: boolean;
token: cardinal;
length: size_t;
match: pByte;
s: cardinal;
booleantest: boolean;
copySize: size_t;
endOfMatch: pByte;
copyFrom: pByte;
dec64: size_t;
const
dec32table: array [0 .. 7] of size_t = (4, 1, 2, 1, 4, 4, 4, 4);
dec64table: array [0 .. 7] of size_t = (0, 0, 0, size_t(-1), 0, 1, 2, 3);
label
_output_error;
begin
ip := pByte(source);
iend := ip + inputSize;
op := pByte(dest);
oend := op + outputSize;
oexit := op + targetOutputSize;
lowLimit := lowPrefix - dictSize;
dictEnd := pByte(dictStart) + dictSize;
safeDecode := (endOnInput = integer(endOnInputSize));
checkOffset := ((safeDecode) and (dictSize < 65536));
if (partialDecoding <> 0) and (oexit > oend - _MFLIMIT) then
oexit := oend - _MFLIMIT;
if (endOnInput <> 0) and (outputSize = 0) then
begin
if (inputSize = 1) and (ip^ = 0) then
exit(0)
else
exit(-1);
end;
if (endOnInput = 0) and (outputSize = 0) then
begin
if ip^ = 0 then
exit(1)
else
exit(-1);
end;
while true do
begin
token := ip^;
inc(ip);
length := token shr ML_BITS;
if length = RUN_MASK then
begin
while true do
begin
s := ip^;
inc(ip);
inc(length, s);
if endOnInput <> 0 then
begin
if not(ip < iend - RUN_MASK) then
break;
end;
if s <> 255 then
break;
end;
if safeDecode and (size_t(op + length) < size_t(op)) then
goto _output_error;
if safeDecode and (size_t(ip + length) < size_t(ip)) then
goto _output_error;
end;
cpy := op + length;
if partialDecoding <> 0 then
booleantest := cpy > oexit
else
booleantest := cpy > oend - _MFLIMIT;
if ((endOnInput <> 0) and ((booleantest) or (ip + length > iend - (2 + 1 + LASTLITERALS))))
or ((endOnInput = 0) and (cpy > oend - COPYLENGTH)) then
begin
if partialDecoding <> 0 then
begin
if (cpy > oend) then
goto _output_error;
if ((endOnInput <> 0) and (ip + length > iend)) then
goto _output_error;
end
else
begin
if ((endOnInput = 0) and (cpy <> oend)) then
goto _output_error;
if ((endOnInput <> 0) and ((ip + length <> iend) or (cpy > oend))) then
goto _output_error;
end;
move(ip^, op^, length);
inc(ip, length);
inc(op, length);
break;
end;
LZ4_wildCopy(op, ip, cpy);
inc(ip, length);
op := cpy;
match := cpy - LZ4_read16(ip); // LZ4_readLE16 = LZ4_read16 for unaligned
inc(ip, 2);
if checkOffset and (match < lowLimit) then
goto _output_error;
length := token and ML_MASK;
if length = ML_MASK then
begin
while true do
begin
if ((endOnInput <> 0) and (ip > iend - LASTLITERALS)) then
goto _output_error;
s := ip^;
inc(ip);
inc(length, s);
if s <> 255 then
break;
end;
if safeDecode and (size_t(op + length) < size_t(op)) then
goto _output_error;
end;
inc(length, MINMATCH);
if (dict = integer(usingExtDict)) and (match < lowPrefix) then
begin
if op + length > oend - LASTLITERALS then
goto _output_error;
if (length <= size_t(lowPrefix - match)) then
begin
match := dictEnd - (lowPrefix - match);
move(match^, op^, length);
inc(op, length);
end
else
begin
copySize := size_t(lowPrefix - match);
move((dictEnd - copySize)^, op^, copySize);
inc(op, copySize);
copySize := length - copySize;
if copySize > size_t(op - lowPrefix) then
begin
endOfMatch := op + copySize;
copyFrom := lowPrefix;
while (op < endOfMatch) do
begin
op^ := copyFrom^;
inc(op);
inc(copyFrom);
end;
end
else
begin
move(lowPrefix^, op^, copySize);
inc(op, copySize);
end;
end;
continue;
end;
cpy := op + length;
if (op - match) < 8 then
begin
dec64 := dec64table[op - match];
op[0] := match[0];
op[1] := match[1];
op[2] := match[2];
op[3] := match[3];
inc(match, dec32table[op - match]);
pCardinal(op + 4)^ := pCardinal(match)^;
inc(op, 8);
dec(match, dec64);
end
else
begin
{$IFDEF WIN64}
pUint64(op)^ := pUint64(match)^;
{$ELSE}
pCardinal(op)[0] := pCardinal(match)[0];
pCardinal(op)[1] := pCardinal(match)[1];
{$ENDIF}
inc(op, 8);
inc(match, 8);
end;
if cpy > oend - 12 then
begin
if (cpy > oend - LASTLITERALS) then
goto _output_error;
if (op < oend - 8) then
begin
LZ4_wildCopy(op, match, oend - 8);
inc(match, (oend - 8) - op);
op := oend - 8;
end;
while (op < cpy) do
begin
op^ := match^;
inc(op);
inc(match);
end;
end
else
LZ4_wildCopy(op, match, cpy);
op := cpy;
end;
if (endOnInput <> 0) then
result := integer(op - pByte(dest))
else
result := integer(ip - pByte(source));
exit;
_output_error:
result := -(ip - pByte(source)) - 1;
end;
function LZ4_decompress_safe(source: pAnsiChar; dest: pAnsiChar; compressedSize: integer; maxDecompressedSize: integer): integer;
begin
result := LZ4_decompress_generic(source, dest, compressedSize, maxDecompressedSize, integer(endOnInputSize), integer(full), 0,
integer(noDict), pByte(dest), nil, 0);
end;
function LZ4_createStream: PLZ4_stream_t;
begin
result := allocmem(8 * LZ4_STREAMSIZE_U64);
end;
procedure LZ4_freeStream(LZ4_streamPtr: PLZ4_stream_t);
begin
freemem(LZ4_streamPtr);
end;
function LZ4_createStreamDecode: PLZ4_streamDecode_t;
begin
result := allocmem(sizeof(uint64) * LZ4_STREAMDECODESIZE_U64);
end;
procedure LZ4_freeStreamDecode(LZ4_stream: PLZ4_streamDecode_t);
begin
freemem(LZ4_stream);
end;
procedure LZ4_renormDictT(LZ4_dict: PLZ4_stream_t_internal; src: pByte);
var
delta: cardinal;
dictEnd: pByte;
i: integer;
begin
if (LZ4_dict.currentOffset > $80000000) or
(size_t(LZ4_dict.currentOffset) > size_t(src)) then
begin
delta := LZ4_dict.currentOffset - 65536;
dictEnd := LZ4_dict.dictionary + LZ4_dict.dictSize;
for i := 0 to HASH_SIZE_U32 - 1 do
begin
if (LZ4_dict.hashTable[i] < delta) then
LZ4_dict.hashTable[i] := 0
else
dec(LZ4_dict.hashTable[i], delta);
end;
LZ4_dict.currentOffset := 65536;
if (LZ4_dict.dictSize > 65536) then
LZ4_dict.dictSize := 65536;
LZ4_dict.dictionary := dictEnd - LZ4_dict.dictSize;
end;
end;
function LZ4_compress_continue_generic(LZ4_stream: pointer; source: pointer; dest: pointer; inputSize: integer; maxOutputSize: integer;
limit: limitedOutput_directive): integer; inline;
var
streamPtr: PLZ4_stream_t_internal;
dictEnd: pByte;
smallest: pByte;
sourceEnd: pByte;
res: integer;
begin
streamPtr := PLZ4_stream_t_internal(LZ4_stream);
dictEnd := streamPtr.dictionary + streamPtr.dictSize;
smallest := pByte(source);
if (streamPtr.initCheck <> 0) then
exit(0);
if (streamPtr.dictSize > 0) and (smallest > dictEnd) then
smallest := dictEnd;
LZ4_renormDictT(streamPtr, smallest);
sourceEnd := pByte(source) + inputSize;
if (sourceEnd > streamPtr.dictionary) and (sourceEnd < dictEnd) then
begin
streamPtr.dictSize := cardinal(dictEnd - sourceEnd);
if (streamPtr.dictSize > 65536) then
streamPtr.dictSize := 65536;
if (streamPtr.dictSize < 4) then
streamPtr.dictSize := 0;
streamPtr.dictionary := dictEnd - streamPtr.dictSize;
end;
if dictEnd = pByte(source) then
begin
if (streamPtr.dictSize < 65536) and (streamPtr.dictSize < streamPtr.currentOffset) then
res := LZ4_compress_generic(LZ4_stream, source, dest, inputSize, maxOutputSize, limit, byU32, withPrefix64k, dictSmall)
else
res := LZ4_compress_generic(LZ4_stream, source, dest, inputSize, maxOutputSize, limit, byU32, withPrefix64k, noDictIssue);
inc(streamPtr.dictSize, cardinal(inputSize));
inc(streamPtr.currentOffset, cardinal(inputSize));
exit(res);
end;
if (streamPtr.dictSize < 65536) and (streamPtr.dictSize < streamPtr.currentOffset) then
res := LZ4_compress_generic(LZ4_stream, source, dest, inputSize, maxOutputSize, limit, byU32, usingExtDict, dictSmall)
else
res := LZ4_compress_generic(LZ4_stream, source, dest, inputSize, maxOutputSize, limit, byU32, usingExtDict, noDictIssue);
streamPtr.dictionary := pByte(source);
streamPtr.dictSize := cardinal(inputSize);
inc(streamPtr.currentOffset, cardinal(inputSize));
result := res;
end;
function LZ4_compress_continue(LZ4_stream: pointer; const ASource: pointer; ADestination: pointer; AInputSize: integer): integer;
begin
result := LZ4_compress_continue_generic(LZ4_stream, ASource, ADestination, AInputSize, 0, notLimited);
end;
function LZ4_saveDict(LZ4_streamPtr: PLZ4_stream_t; safeBuffer: pointer; dictSize: integer): integer;
var
dict: PLZ4_stream_t_internal;
previousDictEnd: pByte;
begin
dict := PLZ4_stream_t_internal(LZ4_streamPtr);
previousDictEnd := dict.dictionary + dict.dictSize;
if cardinal(dictSize) > 65536 then
dictSize := 65536;
if cardinal(dictSize) > dict.dictSize then
dictSize := dict.dictSize;
move((previousDictEnd - dictSize)^, safeBuffer^, dictSize);
// memmove(safeBuffer, (previousDictEnd - dictSize), dictSize);
dict.dictionary := pByte(safeBuffer);
dict.dictSize := cardinal(dictSize);
result := dictSize;
end;
function LZ4_decompress_safe_continue(LZ4_streamDecode: PLZ4_streamDecode_t; source: pointer; dest: pointer; compressedSize: integer;
maxDecompressedSize: integer): integer;
var
lz4sd: PLZ4_streamDecode_t_internal;
res: integer;
begin
lz4sd := PLZ4_streamDecode_t_internal(LZ4_streamDecode);
if lz4sd.prefixEnd = pByte(dest) then
begin
res := LZ4_decompress_generic(source, dest, compressedSize, maxDecompressedSize,
integer(endOnInputSize), integer(full), 0,
integer(usingExtDict), lz4sd.prefixEnd - lz4sd.prefixSize, lz4sd.externalDict, lz4sd.extDictSize);
if (res <= 0) then
exit(res);
inc(lz4sd.prefixSize, res);
inc(lz4sd.prefixEnd, res);
end
else
begin
lz4sd.extDictSize := lz4sd.prefixSize;
lz4sd.externalDict := lz4sd.prefixEnd - lz4sd.extDictSize;
res := LZ4_decompress_generic(source, dest, compressedSize, maxDecompressedSize,
integer(endOnInputSize), integer(full), 0,
integer(usingExtDict), pByte(dest), lz4sd.externalDict, lz4sd.extDictSize);
if (res <= 0) then
exit(res);
lz4sd.prefixSize := res;
lz4sd.prefixEnd := pByte(dest) + res;
end;
result := res;
end;
procedure LZ4_init(lz4ds: PLZ4_stream_t_internal; base: pByte);
begin
fillchar(lz4ds^, LZ4_STREAMSIZE, 0);
lz4ds.bufferStart := base;
end;
function LZ4_create(inputBuffer: pAnsiChar): pointer;
var
lz4ds: pointer;
begin
lz4ds := allocmem(8 * LZ4_STREAMSIZE_U64);
LZ4_init(PLZ4_stream_t_internal(lz4ds), pByte(inputBuffer));
result := lz4ds;
end;
function LZ4_compress_limitedOutput(const source: pAnsiChar; dest: pAnsiChar; inputSize: integer; maxOutputSize: integer): integer;
var
ctx: array [0 .. LZ4_STREAMSIZE_U64 - 1] of uint64;
begin
fillchar(ctx, sizeof(ctx), 0);
if inputSize < LZ4_64Klimit then
result := LZ4_compress_generic(@ctx, source, dest, inputSize, maxOutputSize, limitedOutput, byU16, noDict, noDictIssue)
else
begin
{$IFDEF WIN64}
result := LZ4_compress_generic(@ctx, source, dest, inputSize, maxOutputSize, limitedOutput, byU32, noDict, noDictIssue);
{$ELSE}
result := LZ4_compress_generic(@ctx, source, dest, inputSize, maxOutputSize, limitedOutput, byPtr, noDict, noDictIssue);
{$ENDIF}
end;
end;
function LZ4_compress_withState(state: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer): integer;
begin
if ((size_t(state) and 3) <> 0) then
exit(0); // Error : state is not aligned on 4-bytes boundary
fillchar(state^, LZ4_STREAMSIZE, 0);
if inputSize < LZ4_64Klimit then
result := LZ4_compress_generic(state, source, dest, inputSize, 0, notLimited, byU16, noDict, noDictIssue)
else
begin
{$IFDEF WIN64}
result := LZ4_compress_generic(state, source, dest, inputSize, 0, notLimited, byU32, noDict, noDictIssue);
{$ELSE}
result := LZ4_compress_generic(state, source, dest, inputSize, 0, notLimited, byPtr, noDict, noDictIssue);
{$ENDIF}
end;
end;
function LZ4_compress_limitedOutput_withState(state: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer;
maxOutputSize: integer): integer;
begin
if ((size_t(state) and 3) <> 0) then
exit(0); // Error : state is not aligned on 4-bytes boundary
fillchar(state^, LZ4_STREAMSIZE, 0);
if inputSize < LZ4_64Klimit then
result := LZ4_compress_generic(state, source, dest, inputSize, maxOutputSize, limitedOutput, byU16, noDict, noDictIssue)
else
begin
{$IFDEF WIN64}
result := LZ4_compress_generic(state, source, dest, inputSize, maxOutputSize, limitedOutput, byU32, noDict, noDictIssue);
{$ELSE}
result := LZ4_compress_generic(state, source, dest, inputSize, maxOutputSize, limitedOutput, byPtr, noDict, noDictIssue);
{$ENDIF}
end;
end;
function LZ4_compress_limitedOutput_continue(LZ4_stream: PLZ4_stream_t; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer;
maxOutputSize: integer): integer;
begin
result := LZ4_compress_continue_generic(LZ4_stream, source, dest, inputSize, maxOutputSize, limitedOutput);
end;
function LZ4_compress_forceExtDict(LZ4_dict: PLZ4_stream_t; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer): integer;
var
streamPtr: PLZ4_stream_t_internal;
dictEnd: pByte;
smallest: pByte;
begin
streamPtr := PLZ4_stream_t_internal(LZ4_dict);
dictEnd := streamPtr.dictionary + streamPtr.dictSize;
smallest := dictEnd;
if smallest > pByte(source) then
smallest := pByte(source);
LZ4_renormDictT(PLZ4_stream_t_internal(LZ4_dict), smallest);
result := LZ4_compress_generic(LZ4_dict, source, dest, inputSize, 0, notLimited, byU32, usingExtDict, noDictIssue);
streamPtr.dictionary := pByte(source);
streamPtr.dictSize := cardinal(inputSize);
inc(streamPtr.currentOffset, cardinal(inputSize));
end;
procedure LZ4_resetStream(LZ4_stream: PLZ4_stream_t);
begin
fillchar(LZ4_stream^, sizeof(LZ4_stream_t), 0);
end;
function LZ4_loadDict(LZ4_dict: PLZ4_stream_t; dictionary: pAnsiChar; dictSize: integer): integer;
var
dict: PLZ4_stream_t_internal;
p: pByte;
dictEnd: pByte;
base: pByte;
begin
dict := PLZ4_stream_t_internal(LZ4_dict);
p := pByte(dictionary);
dictEnd := p + dictSize;
if (dict.initCheck <> 0) then
LZ4_resetStream(LZ4_dict); // Uninitialized structure detected
if dictSize < MINMATCH then
begin
dict.dictionary := Nil;
dict.dictSize := 0;
exit(0);
end;
if (p <= dictEnd - 65536) then
p := dictEnd - 65536;
base := p - dict.currentOffset;
dict.dictionary := p;
dict.dictSize := cardinal(dictEnd - p);
inc(dict.currentOffset, dict.dictSize);
while (p <= dictEnd - MINMATCH) do
begin
LZ4_putPosition(p, dict, byU32, base);
inc(p, 3);
end;
result := dict.dictSize;
end;
function LZ4_decompress_fast(source: pAnsiChar; dest: pAnsiChar; originalSize: integer): integer;
begin
result := LZ4_decompress_generic(source, dest, 0, originalSize, integer(endOnOutputSize), integer(full), 0, integer(withPrefix64k),
pByte(dest - 65536), Nil, 65536);
end;
function LZ4_decompress_fast_withPrefix64k(source: pAnsiChar; dest: pAnsiChar; originalSize: integer): integer;
begin
result := LZ4_decompress_generic(source, dest, 0, originalSize, integer(endOnOutputSize), integer(full), 0, integer(withPrefix64k),
pByte(dest) - 65536, Nil, 65536);
end;
function LZ4_decompress_usingDict_generic(source: pAnsiChar; dest: pAnsiChar; compressedSize: integer; maxOutputSize: integer;
safe: integer; dictStart: pAnsiChar; dictSize: integer): integer; inline;
begin
if dictSize = 0 then
exit(LZ4_decompress_generic(source, dest, compressedSize, maxOutputSize, safe, integer(full), 0, integer(noDict),
pByte(dest), Nil, 0));
if (dictStart + dictSize = dest) then
begin
if dictSize >= integer(65536 - 1) then
exit(LZ4_decompress_generic(source, dest, compressedSize, maxOutputSize, safe, integer(full), 0, integer(withPrefix64k),
pByte(dest) - 65536, Nil, 0));
exit(LZ4_decompress_generic(source, dest, compressedSize, maxOutputSize, safe, integer(full), 0, integer(noDict),
pByte(dest) - dictSize, Nil, 0));
end;
result := LZ4_decompress_generic(source, dest, compressedSize, maxOutputSize, safe, integer(full), 0, integer(usingExtDict),
pByte(dest), pByte(dictStart), dictSize);
end;
function LZ4_decompress_fast_usingDict(source: pAnsiChar; dest: pAnsiChar; originalSize: integer; const dictStart: pAnsiChar;
dictSize: integer): integer;
begin
result := LZ4_decompress_usingDict_generic(source, dest, 0, originalSize, 0, dictStart, dictSize);
end;
function LZ4_decompress_safe_withPrefix64k(source: pAnsiChar; dest: pAnsiChar; compressedSize: integer; maxOutputSize: integer): integer;
begin
result := LZ4_decompress_generic(source, dest, compressedSize, maxOutputSize, integer(endOnInputSize), integer(full), 0,
integer(withPrefix64k), pByte(dest) - 65536, Nil, 65536);
end;
function LZ4_decompress_safe_usingDict(const source: pAnsiChar; dest: pAnsiChar; compressedSize: integer; maxOutputSize: integer;
const dictStart: pAnsiChar; dictSize: integer): integer;
begin
result := LZ4_decompress_usingDict_generic(source, dest, compressedSize, maxOutputSize, 1, dictStart, dictSize);
end;
function LZ4_decompress_safe_partial(const source: pAnsiChar; dest: pAnsiChar; compressedSize: integer; targetOutputSize: integer;
maxDecompressedSize: integer): integer;
begin
result := LZ4_decompress_generic(source, dest, compressedSize, maxDecompressedSize, integer(endOnInputSize), integer(partial),
targetOutputSize, integer(noDict), pByte(dest), Nil, 0);
end;
function LZ4_decompress_safe_forceExtDict(source: pAnsiChar; dest: pAnsiChar; compressedSize: integer; maxOutputSize: integer;
const dictStart: pAnsiChar; dictSize: integer): integer;
begin
result := LZ4_decompress_generic(source, dest, compressedSize, maxOutputSize, integer(endOnInputSize), integer(full), 0,
integer(usingExtDict), pByte(dest), pByte(dictStart), dictSize);
end;
end.
================================================
FILE: lib/xedit/lz4/lz4Common.pas
================================================
(*
LZ4Delphi
Copyright (C) 2015, Jose Pascoa (atelierwebgm@gmail.com)
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
*************************************************************************
LZ4 - Fast LZ compression algorithm
xxHash - Fast Hash algorithm
LZ4 source repository : http://code.google.com/p/lz4/
xxHash source repository : http://code.google.com/p/xxhash/
Copyright (c) 2011-2014, Yann Collet
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following disclaimer
in the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************
*)
unit lz4common;
{$POINTERMATH ON}
interface
uses Windows;
type
ppByte = ^pByte;
{$IFDEF WIN32}
size_t = Cardinal;
{$ENDIF WIN32}
{$IFDEF WIN64}
size_t = UInt64;
{$ENDIF WIN64}
psize_t = ^size_t;
const
MINMATCH = 4;
COPYLENGTH = 8;
LASTLITERALS = 5;
_MFLIMIT = COPYLENGTH + MINMATCH;
MAXD_LOG = 16;
MAX_DISTANCE = (1 shl MAXD_LOG) - 1;
STEPSIZE = sizeof(size_t);
ML_BITS = 4;
ML_MASK = (1 shl ML_BITS) - 1;
RUN_BITS = 8 - ML_BITS;
RUN_MASK = (1 shl RUN_BITS) - 1;
function LZ4_read32(const memPtr: pointer): cardinal;
function LZ4_read64(const memPtr: pointer): uint64; inline;
function LZ4_count(pIn: pByte; pMatch: pByte; const pInLimit: pByte): cardinal;
function LZ4_read_ARCH(const p: pointer): size_t; inline;
function LZ4_read16(const memPtr: pointer): word; inline;
procedure LZ4_writeLE16(memPtr: pointer; value: word); inline;
procedure LZ4_wildCopy(dstPtr: pointer; const srcPtr: pointer; dstEnd: pointer);
implementation
function LZ4_read32(const memPtr: pointer): cardinal;
begin
result := pCardinal(memPtr)^;
end;
{$IFDEF WIN64}
function LZ4_NbCommonBytesx64(value: size_t): cardinal;
asm
bsf rax, rcx // value comes in rcx register
shr eax, 3
end;
{$ENDIF}
function LZ4_count(pIn: pByte; pMatch: pByte; const pInLimit: pByte): cardinal;
var
pStart: pByte;
diff: size_t;
incValue: cardinal;
calcedPByte: pByte;
begin
pStart := pIn;
calcedPByte := pInLimit - (STEPSIZE - 1);
while pIn < calcedPByte do
begin
diff := LZ4_read_ARCH(pMatch) xor LZ4_read_ARCH(pIn);
if (diff = 0) then
begin
inc(pIn, STEPSIZE);
inc(pMatch, STEPSIZE);
continue;
end;
{$IFDEF WIN32}
asm
bsf eax, diff
shr eax, 3
mov incValue, eax
end;
{$ELSE}
incValue := LZ4_NbCommonBytesx64(diff); // x64 mode does not allow asm inline
{$ENDIF}
inc(pIn, incValue);
exit(cardinal(pIn - pStart));
end;
{$IFDEF WIN64}
if (pIn < (pInLimit - 3)) and (pCardinal(pMatch)^ = pCardinal(pIn)^) then
begin
inc(pIn, 4);
inc(pMatch, 4);
end;
{$ENDIF}
if ((pIn < (pInLimit - 1)) and (pWord(pMatch)^ = pWord(pIn)^)) then
begin
inc(pIn, 2);
inc(pMatch, 2);
end;
if ((pIn < pInLimit) and (pMatch^ = pIn^)) then
inc(pIn);
result := cardinal(pIn - pStart);
end;
function LZ4_read_ARCH(const p: pointer): size_t; inline;
begin
{$IFDEF WIN64}
result := size_t(pUint64(p)^)
{$ELSE}
result := size_t(pCardinal(p)^);
{$ENDIF}
end;
function LZ4_read16(const memPtr: pointer): word; inline;
begin
result := pWord(memPtr)^;
end;
function LZ4_read64(const memPtr: pointer): uint64; inline;
begin
result := pUint64(memPtr)^;
end;
{$IFDEF WILDCOPY_ASM}
{$IFDEF WIN32}
procedure LZ4_wildCopy; // (dstPtr: pointer; const srcPtr: pointer; dstEnd: pointer);
asm
push edi
push esi
mov edi, eax
mov esi, edx
// copyCount := (((e - d) - 1) div 8) * 8 + 8;
sub ecx, eax // (e - d)
dec ecx // e - d) - 1)
shr ecx, 3 // ((e - d) - 1) div 8)
shl ecx, 3 // ((e - d) - 1) div 8) * 8
add ecx, 8 // ((e - d) - 1) div 8) * 8 + 8
// if copyCount <= 0 then
// copyCount := 8;
mov eax, 8
cmp ecx, 0
cmovbe ecx, eax
shr ecx, 2
rep movsd
pop esi
pop edi
end;
{$ELSE}
procedure LZ4_wildCopy; // (dstPtr: pointer; const srcPtr: pointer; dstEnd: pointer);
asm
mov r10, rdi
mov r11, rsi
mov rdi, rcx
mov rsi, rdx
// copyCount := (((e - d) - 1) div 8) * 8 + 8;
sub r8, rcx // (dstEnd - dest)
mov rax, 8
dec r8 // e - d) - 1)
shr r8, 3 // ((e - d) - 1) div 8)
shl r8, 3 // ((e - d) - 1) div 8) * 8
add r8, rax // ((e - d) - 1) div 8) * 8 + 8
cmp r8, 0
cmovbe r8, rax
mov rcx, r8
shr rcx, 3
rep movsq
mov rdi, r10
mov rsi, r11
end;
{$ENDIF}
{$ELSE}
procedure LZ4_wildCopy(dstPtr: pointer; const srcPtr: pointer; dstEnd: pointer); inline;
var
d: pByte;
s: pByte;
e: pByte;
begin
d := dstPtr;
s := srcPtr;
e := dstEnd;
repeat
{$IFDEF WIN32}
pCardinal(d)[0] := pCardinal(s)[0];
pCardinal(d)[1] := pCardinal(s)[1];
{$ELSE}
pUint64(d)^ := pUint64(s)^;
{$ENDIF}
inc(d, 8);
inc(s, 8);
until not(d < e);
end;
{$ENDIF}
procedure LZ4_writeLE16(memPtr: pointer; value: word); inline;
begin
pWord(memPtr)^ := value;
end;
end.
================================================
FILE: lib/xedit/lz4/lz4HC.pas
================================================
(*
LZ4Delphi
Copyright (C) 2015, Jose Pascoa (atelierwebgm@gmail.com)
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
*************************************************************************
LZ4 - Fast LZ compression algorithm
xxHash - Fast Hash algorithm
LZ4 source repository : http://code.google.com/p/lz4/
xxHash source repository : http://code.google.com/p/xxhash/
Copyright (c) 2011-2014, Yann Collet
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following disclaimer
in the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************
*)
unit lz4HC;
{$POINTERMATH ON}
interface
uses Windows, lz4Common;
const
LZ4_STREAMHCSIZE_U64 = 32774;
type
PLZ4_streamHC_t = ^LZ4_streamHC_t;
LZ4_streamHC_t = record
table: array [0 .. LZ4_STREAMHCSIZE_U64 - 1] of uint64;
end;
function LZ4_createStreamHC: PLZ4_streamHC_t;
procedure LZ4_freeStreamHC(LZ4_streamHCPtr: PLZ4_streamHC_t);
function LZ4_compressHC2(const source: pAnsiChar; dest: pAnsiChar; inputSize: integer; compressionLevel: integer): integer;
function LZ4_compressHC(source: pAnsiChar; dest: pAnsiChar; inputSize: integer): integer;
function LZ4_compressHC_limitedOutput(const source: pAnsiChar; dest: pAnsiChar; inputSize: integer; maxOutputSize: integer): integer;
function LZ4_compressHC2_limitedOutput(const source: pAnsiChar; dest: pAnsiChar; inputSize: integer; maxOutputSize: integer;
compressionLevel: integer): integer;
function LZ4_compressHC_withStateHC(state: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer): integer;
function LZ4_compressHC2_withStateHC(state: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer;
compressionLevel: integer): integer;
function LZ4_compressHC_limitedOutput_withStateHC(state: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer;
maxOutputSize: integer): integer;
function LZ4_compressHC2_limitedOutput_withStateHC(state: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer;
maxOutputSize: integer; compressionLevel: integer): integer;
function LZ4_createHC(inputBuffer: pAnsiChar): pointer;
function LZ4_compressHC_continue(LZ4_streamHCPtr: PLZ4_streamHC_t; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer): integer;
function LZ4_loadDictHC(LZ4_streamHCPtr: PLZ4_streamHC_t; dictionary: pAnsiChar; dictSize: integer): integer;
function LZ4_compressHC_limitedOutput_continue(LZ4_streamHCPtr: PLZ4_streamHC_t; const source: pAnsiChar; dest: pAnsiChar;
inputSize: integer; maxOutputSize: integer): integer;
procedure LZ4_resetStreamHC(LZ4_streamHCPtr: PLZ4_streamHC_t; compressionLevel: integer);
function LZ4_saveDictHC(LZ4_streamHCPtr: PLZ4_streamHC_t; safeBuffer: pAnsiChar; dictSize: integer): integer;
implementation
const
DICTIONARY_LOGSIZE = 16;
MAXD = (1 shl DICTIONARY_LOGSIZE);
HASH_LOG = (DICTIONARY_LOGSIZE - 1);
HASHTABLESIZE = (1 shl HASH_LOG);
OPTIMAL_ML = integer((ML_MASK - 1) + MINMATCH);
g_maxCompressionLevel: integer = 16;
LZ4HC_compressionLevel_default: integer = 8;
type
PLZ4HC_Data_Structure = ^LZ4HC_Data_Structure;
LZ4HC_Data_Structure = record
hashTable: array [0 .. HASHTABLESIZE - 1] of cardinal;
chainTable: array [0 .. MAXD - 1] of word;
_end: pByte;
base: pByte;
dictBase: pByte;
inputBuffer: pByte;
dictLimit: cardinal;
lowLimit: cardinal;
nextToUpdate: cardinal;
compressionLevel: cardinal;
end;
limitedOutput_directive = (noLimit = 0, limitedOutput = 1);
function LZ4_createStreamHC: PLZ4_streamHC_t;
begin
result := allocmem(sizeof(LZ4_streamHC_t));
end;
procedure LZ4_freeStreamHC(LZ4_streamHCPtr: PLZ4_streamHC_t);
begin
freemem(LZ4_streamHCPtr);
end;
procedure LZ4HC_init(hc4: PLZ4HC_Data_Structure; const start: pByte);
begin
fillchar(hc4.hashTable, sizeof(hc4.hashTable), 0);
fillchar(hc4.chainTable, sizeof(hc4.chainTable), 255);
hc4.nextToUpdate := 65536;
hc4.base := start - 65536;
hc4.inputBuffer := start;
hc4._end := start;
hc4.dictBase := start - 65536;
hc4.dictLimit := 65536;
hc4.lowLimit := 65536;
end;
function HASH_FUNCTION(i: cardinal): cardinal; inline;
begin
result := (i * 2654435761) shr ((MINMATCH * 8) - HASH_LOG);
end;
function LZ4HC_hashPtr(const ptr: pointer): cardinal; inline;
begin
result := HASH_FUNCTION(pCardinal(ptr)^);
end;
procedure LZ4HC_Insert(hc4: PLZ4HC_Data_Structure; const ip: pByte); inline;
var
chainTable: pWord;
hashTable: pCardinal;
base: pByte;
target: cardinal;
idx: cardinal;
h: cardinal;
delta: size_t;
begin
chainTable := @hc4.chainTable;
hashTable := @hc4.hashTable;
base := hc4.base;
target := cardinal(ip - base);
idx := hc4.nextToUpdate;
while idx < target do
begin
h := LZ4HC_hashPtr(base + idx);
delta := idx - hashTable[h];
if (delta > MAX_DISTANCE) then
delta := MAX_DISTANCE;
chainTable[idx and $FFFF] := word(delta);
hashTable[h] := idx;
inc(idx);
end;
hc4.nextToUpdate := target;
end;
function LZ4HC_InsertAndFindBestMatch(hc4: PLZ4HC_Data_Structure; const ip: pByte; const iLimit: pByte;
const matchpos: ppByte; const maxNbAttempts: integer): integer; inline;
var
chainTable: pWord;
hashTable: pCardinal;
base: pByte;
dictBase: pByte;
dictLimit: cardinal;
lowLimit: cardinal;
matchIndex: cardinal;
match: pByte;
nbAttempts: integer;
ml: size_t;
mlt: size_t;
vLimit: pByte;
begin
chainTable := @hc4.chainTable;
hashTable := @hc4.hashTable;
base := hc4.base;
dictBase := hc4.dictBase;
dictLimit := hc4.dictLimit;
if hc4.lowLimit + 65536 > cardinal(ip - base) then
lowLimit := hc4.lowLimit
else
lowLimit := cardinal(ip - base) - 65535;
nbAttempts := maxNbAttempts;
ml := 0;
LZ4HC_Insert(hc4, ip);
matchIndex := hashTable[LZ4HC_hashPtr(ip)];
while (matchIndex >= lowLimit) and (nbAttempts > 0) do
begin
dec(nbAttempts);
if matchIndex >= dictLimit then
begin
match := base + matchIndex;
if ((match + ml)^ = (ip + ml)^) and (pCardinal(match)^ = pCardinal(ip)^) then
begin
mlt := LZ4_count(ip + MINMATCH, match + MINMATCH, iLimit) + MINMATCH;
if mlt > ml then
begin
ml := mlt;
matchpos^ := match;
end;
end;
end
else
begin
match := dictBase + matchIndex;
if pCardinal(match)^ = pCardinal(ip)^ then
begin
vLimit := ip + (dictLimit - matchIndex);
if (vLimit > iLimit) then
vLimit := iLimit;
mlt := LZ4_count(ip + MINMATCH, match + MINMATCH, vLimit) + MINMATCH;
if ((ip + mlt = vLimit) and (vLimit < iLimit)) then
inc(mlt, LZ4_count(ip + mlt, base + dictLimit, iLimit));
if (mlt > ml) then
begin
ml := mlt;
matchpos^ := base + matchIndex;
end; // virtual matchpos
end;
end;
dec(matchIndex, chainTable[matchIndex and $FFFF]);
end;
result := integer(ml);
end;
function LZ4HC_InsertAndGetWiderMatch(hc4: PLZ4HC_Data_Structure; const ip: pByte; const iLowLimit: pByte;
const iHighLimit: pByte; longest: integer; const matchpos: ppByte; const startpos: ppByte; const maxNbAttempts: integer): integer; inline;
var
chainTable: pWord;
hashTable: pCardinal;
base: pByte;
dictLimit: cardinal;
lowLimit: cardinal;
dictBase: pByte;
match: pByte;
matchIndex: cardinal;
nbAttempts: integer;
delta: integer;
startt: pByte;
tmpMatch: pByte;
matchEnd: pByte;
mlt: size_t;
back: integer;
vLimit: pByte;
begin
chainTable := @hc4.chainTable;
hashTable := @hc4.hashTable;
base := hc4.base;
dictLimit := hc4.dictLimit;
if (hc4.lowLimit + 65536 > cardinal(ip - base)) then
lowLimit := hc4.lowLimit
else
lowLimit := cardinal(ip - base) - 65535;
dictBase := hc4.dictBase;
nbAttempts := maxNbAttempts;
delta := integer(ip - iLowLimit);
LZ4HC_Insert(hc4, ip);
matchIndex := hashTable[LZ4HC_hashPtr(ip)];
while (matchIndex >= lowLimit) and (nbAttempts > 0) do
begin
dec(nbAttempts);
if matchIndex >= dictLimit then
begin
match := base + matchIndex;
if ((iLowLimit + longest)^ = (match - delta + longest)^) then
if pCardinal(match)^ = pCardinal(ip)^ then
begin
startt := ip;
tmpMatch := match;
matchEnd := ip + MINMATCH + LZ4_count(ip + MINMATCH, match + MINMATCH, iHighLimit);
while (startt > iLowLimit) and (tmpMatch > iLowLimit) and (startt[-1] = tmpMatch[-1]) do
begin
dec(startt);
dec(tmpMatch);
end;
if (matchEnd - startt) > longest then
begin
longest := integer(matchEnd - startt);
matchpos^ := tmpMatch;
startpos^ := startt;
end;
end;
end
else
begin
match := dictBase + matchIndex;
if pCardinal(match)^ = pCardinal(ip)^ then
begin
back := 0;
vLimit := ip + (dictLimit - matchIndex);
if vLimit > iHighLimit then
vLimit := iHighLimit;
mlt := LZ4_count(ip + MINMATCH, match + MINMATCH, vLimit) + MINMATCH;
if (ip + mlt = vLimit) and (vLimit < iHighLimit) then
inc(mlt, LZ4_count(ip + mlt, base + dictLimit, iHighLimit));
while ((ip + back > iLowLimit) and (matchIndex + cardinal(back) > lowLimit) and (ip[back - 1] = match[back - 1])) do
dec(back);
dec(mlt, back);
if integer(mlt) > longest then
begin
longest := integer(mlt);
matchpos^ := base + matchIndex + back;
startpos^ := ip + back;
end;
end;
end;
dec(matchIndex, chainTable[matchIndex and $FFFF]);
end;
result := longest;
end;
function LZ4HC_encodeSequence(const ip: ppByte; op: ppByte; const anchor: ppByte; matchLength: integer;
const match: pByte; limitedOutputBuffer: limitedOutput_directive; oend: pByte): integer; inline;
var
length: integer;
token: pByte;
len: integer;
begin
length := integer(ip^ - anchor^);
token := op^;
inc(op^);
if (limitedOutputBuffer <> noLimit) and ((op^ + (length shr 8) + length + (2 + 1 + LASTLITERALS)) > oend) then
exit(1);
if length >= integer(RUN_MASK) then
begin
token^ := (RUN_MASK shl ML_BITS);
len := length - RUN_MASK;
while len > 254 do
begin
op^^ := 255;
inc(op^);
dec(len, 255)
end;
op^^ := byte(len);
inc(op^);
end
else
token^ := byte(length shl ML_BITS);
LZ4_wildCopy(op^, anchor^, op^ + length);
inc(op^, length);
pWord(op^)^ := word(ip^ - match); // ?
inc(op^, 2);
length := integer(matchLength - MINMATCH);
if (limitedOutputBuffer <> noLimit) and (op^ + (length shr 8) + (1 + LASTLITERALS) > oend) then
exit(1);
if length >= integer(ML_MASK) then
begin
inc(token^, ML_MASK);
dec(length, ML_MASK);
while length > 509 do
begin
op^^ := 255;
inc(op^);
op^^ := 255;
inc(op^);
dec(length, 510);
end;
if (length > 254) then
begin
dec(length, 255);
op^^ := 255;
inc(op^);
end;
op^^ := byte(length);
inc(op^);
end
else
inc(token^, byte(length));
inc(ip^, matchLength);
anchor^ := ip^;
result := 0;
end;
function LZ4HC_compress_generic(ctxvoid: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer;
maxOutputSize: integer; compressionLevel: integer; limit: limitedOutput_directive): integer;
var
ctx: PLZ4HC_Data_Structure;
ip: pByte;
anchor: pByte;
iend: pByte;
mflimit: pByte;
matchlimit: pByte;
op: pByte;
oend: pByte;
maxNbAttempts: cardinal;
ml, ml2, ml3, ml0: integer;
ref: pByte;
start2: pByte;
ref2: pByte;
start3: pByte;
ref3: pByte;
start0: pByte;
ref0: pByte;
correction: integer;
new_ml: integer;
lastRun: integer;
label
_Search2, _Search3;
begin
ctx := ctxvoid;
ip := pByte(source);
anchor := ip;
iend := ip + inputSize;
mflimit := iend - _MFLIMIT;
matchlimit := (iend - LASTLITERALS);
op := pByte(dest);
oend := op + maxOutputSize;
ref := nil;
start2 := nil;
ref2 := nil;
start3 := nil;
ref3 := nil;
// init
if compressionLevel > g_maxCompressionLevel then
compressionLevel := g_maxCompressionLevel;
if (compressionLevel < 1) then
compressionLevel := LZ4HC_compressionLevel_default;
maxNbAttempts := 1 shl (compressionLevel - 1);
inc(ctx._end, inputSize);
inc(ip);
// Main Loop
while ip < mflimit do
begin
ml := LZ4HC_InsertAndFindBestMatch(ctx, ip, matchlimit, (@ref), maxNbAttempts);
if (ml = 0) then
begin
inc(ip);
continue;
end;
// saved, in case we would skip too much
start0 := ip;
ref0 := ref;
ml0 := ml;
_Search2:
if ip + ml < mflimit then
ml2 := LZ4HC_InsertAndGetWiderMatch(ctx, ip + ml - 2, ip + 1, matchlimit, ml, @ref2, @start2, maxNbAttempts)
else
ml2 := ml;
if (ml2 = ml) then // No better match
begin
if LZ4HC_encodeSequence(@ip, @op, @anchor, ml, ref, limit, oend) > 0 then
exit(0);
continue;
end;
if start0 < ip then
begin
if start2 < ip + ml0 then // empirical
begin
ip := start0;
ref := ref0;
ml := ml0;
end;
end;
// Here, start0==ip
if ((start2 - ip) < 3) then // First Match too small : removed
begin
ml := ml2;
ip := start2;
ref := ref2;
goto _Search2;
end;
_Search3:
if (start2 - ip) < OPTIMAL_ML then
begin
new_ml := ml;
if new_ml > OPTIMAL_ML then
new_ml := OPTIMAL_ML;
if ip + new_ml > start2 + ml2 - MINMATCH then
new_ml := integer(start2 - ip) + ml2 - MINMATCH;
correction := new_ml - integer(start2 - ip);
if (correction > 0) then
begin
inc(start2, correction);
inc(ref2, correction);
dec(ml2, correction);
end;
end;
// Now, we have start2 = ip+new_ml, with new_ml = min(ml, OPTIMAL_ML=18)
if start2 + ml2 < mflimit then
ml3 := LZ4HC_InsertAndGetWiderMatch(ctx, start2 + ml2 - 3, start2, matchlimit, ml2, @ref3, @start3, maxNbAttempts)
else
ml3 := ml2;
if (ml3 = ml2) then // No better match : 2 sequences to encode
begin
// ip & ref are known; Now for ml
if start2 < ip + ml then
ml := integer(start2 - ip);
// Now, encode 2 sequences
if LZ4HC_encodeSequence(@ip, @op, @anchor, ml, ref, limit, oend) <> 0 then
exit(0);
ip := start2;
if LZ4HC_encodeSequence(@ip, @op, @anchor, ml2, ref2, limit, oend) <> 0 then
exit(0);
continue;
end;
if start3 < ip + ml + 3 then // Not enough space for match 2 : remove it
begin
if start3 >= (ip + ml) then // can write Seq1 immediately ==> Seq2 is removed, so Seq3 becomes Seq1
begin
if start2 < ip + ml then
begin
correction := integer(ip + ml - start2);
inc(start2, correction);
inc(ref2, correction);
dec(ml2, correction);
if ml2 < MINMATCH then
begin
start2 := start3;
ref2 := ref3;
ml2 := ml3;
end;
end;
if LZ4HC_encodeSequence(@ip, @op, @anchor, ml, ref, limit, oend) <> 0 then
exit(0);
ip := start3;
ref := ref3;
ml := ml3;
start0 := start2;
ref0 := ref2;
ml0 := ml2;
goto _Search2;
end;
start2 := start3;
ref2 := ref3;
ml2 := ml3;
goto _Search3;
end;
(*
* OK, now we have 3 ascending matches; let's write at least the first one
* ip & ref are known; Now for ml
*)
if start2 < ip + ml then
begin
if (start2 - ip) < integer(ML_MASK) then
begin
if ml > OPTIMAL_ML then
ml := OPTIMAL_ML;
if ip + ml > start2 + ml2 - MINMATCH then
ml := integer(start2 - ip) + ml2 - MINMATCH;
correction := ml - integer(start2 - ip);
if correction > 0 then
begin
inc(start2, correction);
inc(ref2, correction);
dec(ml2, correction);
end;
end
else
ml := integer(start2 - ip);
end;
if LZ4HC_encodeSequence(@ip, @op, @anchor, ml, ref, limit, oend) <> 0 then
exit(0);
ip := start2;
ref := ref2;
ml := ml2;
start2 := start3;
ref2 := ref3;
ml2 := ml3;
goto _Search3;
end;
lastRun := integer(iend - anchor);
if (limit <> noLimit) and ((op - pByte(dest)) + lastRun + 1 + ((lastRun + 255 - RUN_MASK) div 255) > maxOutputSize) then
exit(0);
if lastRun >= integer(RUN_MASK) then
begin
op^ := RUN_MASK shl ML_BITS;
inc(op);
dec(lastRun, RUN_MASK);
while lastRun > 254 do
begin
op^ := 255;
inc(op);
dec(lastRun, 255);
end;
op^ := byte(lastRun);
inc(op);
end
else
begin
op^ := byte(lastRun shl ML_BITS);
inc(op);
end;
move(anchor^, op^, iend - anchor);
inc(op, iend - anchor);
result := integer(op - pByte(dest));
end;
function LZ4_compressHC2(const source: pAnsiChar; dest: pAnsiChar; inputSize: integer; compressionLevel: integer): integer;
var
ctx: LZ4HC_Data_Structure;
begin
fillchar(ctx, sizeof(LZ4HC_Data_Structure), 0);
LZ4HC_init(@ctx, pByte(source));
result := LZ4HC_compress_generic(@ctx, source, dest, inputSize, 0, compressionLevel, noLimit);
end;
function LZ4_compressHC(source: pAnsiChar; dest: pAnsiChar; inputSize: integer): integer;
begin
result := LZ4_compressHC2(source, dest, inputSize, 0);
end;
function LZ4_compressHC_limitedOutput(const source: pAnsiChar; dest: pAnsiChar; inputSize: integer; maxOutputSize: integer): integer;
begin
result := LZ4_compressHC2_limitedOutput(source, dest, inputSize, maxOutputSize, 0);
end;
function LZ4_compressHC2_limitedOutput(const source: pAnsiChar; dest: pAnsiChar; inputSize: integer; maxOutputSize: integer;
compressionLevel: integer): integer;
var
ctx: LZ4HC_Data_Structure;
begin
fillchar(ctx, sizeof(LZ4HC_Data_Structure), 0);
LZ4HC_init(@ctx, pByte(source));
result := LZ4HC_compress_generic(@ctx, source, dest, inputSize, maxOutputSize, compressionLevel, limitedOutput);
end;
function LZ4_compressHC_withStateHC(state: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer): integer;
begin
result := LZ4_compressHC2_withStateHC(state, source, dest, inputSize, 0);
end;
function LZ4_compressHC2_withStateHC(state: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer;
compressionLevel: integer): integer;
begin
if (size_t(state) and (sizeof(pointer) - 1)) <> 0 then
exit(0); // Error : : state is not aligned for pointers (32 or 64 bits) */
LZ4HC_init(PLZ4HC_Data_Structure(state), pByte(source));
result := LZ4HC_compress_generic(state, source, dest, inputSize, 0, compressionLevel, noLimit);
end;
function LZ4_compressHC_limitedOutput_withStateHC(state: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer;
maxOutputSize: integer): integer;
begin
result := LZ4_compressHC2_limitedOutput_withStateHC(state, source, dest, inputSize, maxOutputSize, 0);
end;
function LZ4_compressHC2_limitedOutput_withStateHC(state: pointer; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer;
maxOutputSize: integer; compressionLevel: integer): integer;
begin
if (size_t(state) and (sizeof(pointer) - 1)) <> 0 then
exit(0); // Error : : state is not aligned for pointers (32 or 64 bits) */
LZ4HC_init(PLZ4HC_Data_Structure(state), pByte(source));
result := LZ4HC_compress_generic(state, source, dest, inputSize, maxOutputSize, compressionLevel, limitedOutput);
end;
function LZ4_createHC(inputBuffer: pAnsiChar): pointer;
var
hc4: pointer;
begin
hc4 := allocmem(sizeof(LZ4HC_Data_Structure));
LZ4HC_init(PLZ4HC_Data_Structure(hc4), pByte(inputBuffer));
result := hc4;
end;
procedure LZ4HC_setExternalDict(ctxPtr: PLZ4HC_Data_Structure; const newBlock: pByte);
begin
if ctxPtr._end >= ctxPtr.base + 4 then
LZ4HC_Insert(ctxPtr, ctxPtr._end - 3); // Referencing remaining dictionary content
// Only one memory segment for extDict, so any previous extDict is lost at this stage
ctxPtr.lowLimit := ctxPtr.dictLimit;
ctxPtr.dictLimit := cardinal(ctxPtr._end - ctxPtr.base);
ctxPtr.dictBase := ctxPtr.base;
ctxPtr.base := newBlock - ctxPtr.dictLimit;
ctxPtr._end := newBlock;
ctxPtr.nextToUpdate := ctxPtr.dictLimit; // match referencing will resume from there
end;
function LZ4_compressHC_continue_generic(ctxPtr: PLZ4HC_Data_Structure;
const source: pAnsiChar; dest: pAnsiChar;
inputSize: integer; maxOutputSize: integer; limit: limitedOutput_directive): integer;
var
dictSize: size_t;
sourceEnd: pByte;
dictBegin: pByte;
dictEnd: pByte;
begin
// auto-init if forgotten
if (ctxPtr.base = Nil) then
LZ4HC_init(ctxPtr, pByte(source));
// Check overflow
if size_t(ctxPtr._end - ctxPtr.base) > 2147483648 then
begin
dictSize := size_t(ctxPtr._end - ctxPtr.base) - ctxPtr.dictLimit;
if (dictSize > 65536) then
dictSize := 65536;
LZ4_loadDictHC(PLZ4_streamHC_t(ctxPtr), pAnsiChar(ctxPtr._end) - dictSize, integer(dictSize));
end;
// Check if blocks follow each other
if (pByte(source) <> ctxPtr._end) then
LZ4HC_setExternalDict(ctxPtr, pByte(source));
// Check overlapping input/dictionary space
sourceEnd := pByte(source) + inputSize;
dictBegin := ctxPtr.dictBase + ctxPtr.lowLimit;
dictEnd := ctxPtr.dictBase + ctxPtr.dictLimit;
if (sourceEnd > dictBegin) and (pByte(source) < dictEnd) then
begin
if sourceEnd > dictEnd then
sourceEnd := dictEnd;
ctxPtr.lowLimit := cardinal(sourceEnd - ctxPtr.dictBase);
if ctxPtr.dictLimit - ctxPtr.lowLimit < 4 then
ctxPtr.lowLimit := ctxPtr.dictLimit;
end;
result := LZ4HC_compress_generic(ctxPtr, source, dest, inputSize, maxOutputSize, ctxPtr.compressionLevel, limit);
end;
function LZ4_compressHC_continue(LZ4_streamHCPtr: PLZ4_streamHC_t; const source: pAnsiChar; dest: pAnsiChar; inputSize: integer): integer;
begin
result := LZ4_compressHC_continue_generic(PLZ4HC_Data_Structure(LZ4_streamHCPtr), source, dest, inputSize, 0, noLimit);
end;
function LZ4_loadDictHC(LZ4_streamHCPtr: PLZ4_streamHC_t; dictionary: pAnsiChar; dictSize: integer): integer;
var
ctxPtr: PLZ4HC_Data_Structure;
begin
ctxPtr := PLZ4HC_Data_Structure(LZ4_streamHCPtr);
if dictSize > 65536 then
begin
inc(dictionary, dictSize - 65536);
dictSize := 65536;
end;
LZ4HC_init(ctxPtr, pByte(dictionary));
if (dictSize >= 4) then
LZ4HC_Insert(ctxPtr, pByte(dictionary) + (dictSize - 3));
ctxPtr._end := pByte(dictionary) + dictSize;
result := dictSize;
end;
function LZ4_compressHC_limitedOutput_continue(LZ4_streamHCPtr: PLZ4_streamHC_t; const source: pAnsiChar; dest: pAnsiChar;
inputSize: integer; maxOutputSize: integer): integer;
begin
result := LZ4_compressHC_continue_generic(PLZ4HC_Data_Structure(LZ4_streamHCPtr), source, dest, inputSize, maxOutputSize,
limitedOutput);
end;
procedure LZ4_resetStreamHC(LZ4_streamHCPtr: PLZ4_streamHC_t; compressionLevel: integer);
begin
PLZ4HC_Data_Structure(LZ4_streamHCPtr).base := Nil;
PLZ4HC_Data_Structure(LZ4_streamHCPtr).compressionLevel := cardinal(compressionLevel);
end;
function LZ4_saveDictHC(LZ4_streamHCPtr: PLZ4_streamHC_t; safeBuffer: pAnsiChar; dictSize: integer): integer;
var
streamPtr: PLZ4HC_Data_Structure;
prefixSize: integer;
endIndex: cardinal;
begin
streamPtr := PLZ4HC_Data_Structure(LZ4_streamHCPtr);
prefixSize := integer((streamPtr._end - (streamPtr.base + streamPtr.dictLimit)));
if dictSize > 65536 then
dictSize := 65536;
if dictSize < 4 then
dictSize := 0;
if (dictSize > prefixSize) then
dictSize := prefixSize;
move((streamPtr._end - dictSize)^, safeBuffer^, dictSize);
endIndex := cardinal(streamPtr._end - streamPtr.base);
streamPtr._end := pByte(safeBuffer) + dictSize;
streamPtr.base := streamPtr._end - endIndex;
streamPtr.dictLimit := endIndex - cardinal(dictSize);
streamPtr.lowLimit := endIndex - cardinal(dictSize);
if streamPtr.nextToUpdate < streamPtr.dictLimit then
streamPtr.nextToUpdate := streamPtr.dictLimit;
result:=dictSize;
end;
end.
================================================
FILE: lib/xedit/lz4/lz4frame.pas
================================================
(*
LZ4Delphi
Copyright (C) 2015, Jose Pascoa (atelierwebgm@gmail.com)
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
*************************************************************************
LZ4 - Fast LZ compression algorithm
xxHash - Fast Hash algorithm
LZ4 source repository : http://code.google.com/p/lz4/
xxHash source repository : http://code.google.com/p/xxhash/
Copyright (c) 2011-2014, Yann Collet
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following disclaimer
in the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************
*)
unit lz4frame;
{$POINTERMATH ON}
interface
uses Windows, xxHash, lz4frame_static, lz4, lz4HC, lz4common;
const
LZ4F_VERSION = 100;
LZ4F_MAGICNUMBER = $184D2204;
_1BIT = $01;
_2BITS = $03;
_3BITS = $07;
_4BITS = $0F;
_8BITS = $FF;
LZ4F_BLOCKUNCOMPRESSED_FLAG: cardinal = $80000000;
type
LZ4F_errorCode_t = size_t;
PLZ4F_decompressionContext_t = pointer;
PLZ4F_compressionContext_t = pointer;
blockSizeID_t = (LZ4F_default = 0, max64KB = 4, max256KB = 5, max1MB = 6, max4MB = 7);
blockMode_t = (blockLinked = 0, blockIndependent);
contentChecksum_t = (noContentChecksum = 0, contentChecksumEnabled);
LZ4F_lastBlockStatus = (notDone, fromTmpBuffer, fromSrcBuffer);
PLZ4F_frameInfo_t = ^LZ4F_frameInfo_t;
LZ4F_frameInfo_t = record
blockSizeID: blockSizeID_t;
blockMode: blockMode_t;
contentChecksumFlag: contentChecksum_t;
reserved: array [0 .. 4] of cardinal;
end;
PLZ4F_preferences_t = ^LZ4F_preferences_t;
LZ4F_preferences_t = record
frameInfo: LZ4F_frameInfo_t;
compressionLevel: cardinal;
autoFlush: cardinal;
reserved: array [0 .. 3] of cardinal;
end;
PLZ4F_compressOptions_t = ^LZ4F_compressOptions_t;
LZ4F_compressOptions_t = record
stableSrc: cardinal;
reserved: array [0 .. 2] of cardinal;
end;
PLZ4F_cctx_internal_t = ^LZ4F_cctx_internal_t;
LZ4F_cctx_internal_t = record
prefs: LZ4F_preferences_t;
version: cardinal;
cStage: cardinal;
maxBlockSize: size_t;
maxBufferSize: size_t;
tmpBuff: pByte;
tmpIn: pByte;
tmpInSize: size_t;
xxh: XXH32_state_t;
lz4CtxPtr: pointer;
lz4CtxLevel: cardinal;
end;
PLZ4F_dctx_internal_t = ^LZ4F_dctx_internal_t;
LZ4F_dctx_internal_t = record
frameInfo: LZ4F_frameInfo_t;
version: cardinal;
dStage: cardinal;
maxBlockSize: size_t;
maxBufferSize: size_t;
srcExpect: pByte;
tmpIn: pByte;
tmpInSize: size_t;
tmpInTarget: size_t;
tmpOutBuffer: pByte;
dict: pByte;
dictSize: size_t;
tmpOut: pByte;
tmpOutSize: size_t;
tmpOutStart: size_t;
xxh: XXH32_state_t;
header: array [0 .. 7] of byte;
end;
PLZ4F_decompressOptions_t = ^LZ4F_decompressOptions_t;
LZ4F_decompressOptions_t = record
stableDst: cardinal;
reserved: array [0 .. 2] of cardinal;
end;
const
LZ4F_BLOCKSIZEID_DEFAULT = max64KB;
LZ4F_MAXHEADERFRAME_SIZE = 7;
function LZ4F_createDecompressionContext(var LZ4F_decompressionContextPtr: PLZ4F_compressionContext_t; versionNumber: cardinal)
: LZ4F_errorCode_t;
function LZ4F_isError(code: LZ4F_errorCode_t): boolean;
function LZ4F_compressFrame(dstBuffer: pointer; dstMaxSize: size_t; const srcBuffer: pointer; srcSize: size_t;
const preferencesPtr: PLZ4F_preferences_t): size_t;
function LZ4F_compressBound(srcSize: size_t; const preferencesPtr: PLZ4F_preferences_t): size_t;
function LZ4F_compressFrameBound(srcSize: size_t; const preferencesPtr: PLZ4F_preferences_t): size_t;
function LZ4F_compressBegin(compressionContext: PLZ4F_compressionContext_t; dstBuffer: pointer; dstMaxSize: size_t;
preferencesPtr: PLZ4F_preferences_t): size_t;
function LZ4F_compressUpdate(compressionContext: PLZ4F_compressionContext_t; dstBuffer: pointer; dstMaxSize: size_t;
const srcBuffer: pointer; srcSize: size_t; compressOptionsPtr: PLZ4F_compressOptions_t): size_t;
function LZ4F_compressEnd(compressionContext: PLZ4F_compressionContext_t; dstBuffer: pointer; dstMaxSize: size_t;
const compressOptionsPtr: PLZ4F_compressOptions_t): size_t;
function LZ4F_flush(compressionContext: PLZ4F_compressionContext_t; dstBuffer: pointer; dstMaxSize: size_t;
compressOptionsPtr: PLZ4F_compressOptions_t): size_t;
function LZ4F_decompress(decompressionContext: PLZ4F_decompressionContext_t;
dstBuffer: pointer; dstSizePtr: psize_t; const srcBuffer: pointer; srcSizePtr: psize_t;
decompressOptionsPtr: PLZ4F_decompressOptions_t): size_t;
function LZ4F_createCompressionContext(var LZ4F_compressionContextPtr: PLZ4F_compressionContext_t; version: cardinal): LZ4F_errorCode_t;
function LZ4F_freeCompressionContext(LZ4F_compressionContext: PLZ4F_compressionContext_t): LZ4F_errorCode_t;
function LZ4F_getFrameInfo(decompressionContext: PLZ4F_decompressionContext_t; frameInfoPtr: PLZ4F_frameInfo_t; const srcBuffer: pointer;
srcSizePtr: psize_t): LZ4F_errorCode_t;
function LZ4F_freeDecompressionContext(LZ4F_decompressionContext: PLZ4F_decompressionContext_t): LZ4F_errorCode_t;
function LZ4F_getErrorName(code : LZ4F_errorCode_t ): pAnsiChar;
implementation
var
minHClevel: cardinal = 3;
type
dStage_t = (dstage_getHeader = 0, dstage_storeHeader, dstage_decodeHeader,
dstage_getCBlockSize, dstage_storeCBlockSize, dstage_decodeCBlockSize,
dstage_copyDirect,
dstage_getCBlock, dstage_storeCBlock, dstage_decodeCBlock,
dstage_decodeCBlock_intoDst, dstage_decodeCBlock_intoTmp, dstage_flushOut,
dstage_getSuffix, dstage_storeSuffix, dstage_checkSuffix);
function LZ4F_getBlockSize(blockSizeID: cardinal): size_t; forward;
function LZ4F_createDecompressionContext(var LZ4F_decompressionContextPtr: PLZ4F_compressionContext_t; versionNumber: cardinal)
: LZ4F_errorCode_t;
var
dctxPtr: PLZ4F_dctx_internal_t;
begin
dctxPtr := allocmem(sizeof(LZ4F_dctx_internal_t));
if dctxPtr = nil then
exit(LZ4F_errorCode_t(-integer(ERROR_GENERIC)));
dctxPtr.version := versionNumber;
LZ4F_decompressionContextPtr := dctxPtr;
result := LZ4F_errorCode_t(OK_NoError);
end;
function LZ4F_isError(code: LZ4F_errorCode_t): boolean;
begin
result := code > LZ4F_errorCode_t(-integer(ERROR_maxCode));
end;
function LZ4F_getErrorName(code : LZ4F_errorCode_t ): pAnsiChar;
begin
result:= 'Unspecified error code';
if LZ4F_isError(code) then exit (pAnsiChar(LZ4F_errorStrings[-integer(code)]));
end;
function LZ4F_compressFrameBound(srcSize: size_t; const preferencesPtr: PLZ4F_preferences_t): size_t;
var
prefs: LZ4F_preferences_t;
headerSize: size_t;
streamSize: size_t;
proposedBSID: blockSizeID_t;
maxBlockSize: size_t;
begin
fillchar(prefs, sizeof(LZ4F_preferences_t), 0);
if (preferencesPtr <> Nil) then
prefs := preferencesPtr^;
proposedBSID := max64KB;
maxBlockSize := 65536;
while (prefs.frameInfo.blockSizeID > proposedBSID) do
begin
if srcSize <= maxBlockSize then
begin
prefs.frameInfo.blockSizeID := proposedBSID;
break;
end;
inc(proposedBSID);
maxBlockSize := maxBlockSize shl 2;
end;
prefs.autoFlush := 1;
headerSize := 7; // basic header size (no option) including magic number
streamSize := LZ4F_compressBound(srcSize, @prefs);
result := headerSize + streamSize;
end;
function LZ4F_compressFrame(dstBuffer: pointer; dstMaxSize: size_t; const srcBuffer: pointer; srcSize: size_t;
const preferencesPtr: PLZ4F_preferences_t): size_t;
var
cctxI: LZ4F_cctx_internal_t;
prefs: LZ4F_preferences_t;
options: LZ4F_compressOptions_t;
errorCode: LZ4F_errorCode_t;
dstStart: pByte;
dstPtr: pByte;
dstEnd: pByte;
proposedBSID: blockSizeID_t;
maxBlockSize: size_t;
begin
fillchar(cctxI, sizeof(LZ4F_cctx_internal_t), 0);
fillchar(prefs, sizeof(LZ4F_preferences_t), 0);
fillchar(options, sizeof(LZ4F_compressOptions_t), 0);
dstStart := pByte(dstBuffer);
dstPtr := dstStart;
dstEnd := dstStart + dstMaxSize;
cctxI.version := LZ4F_VERSION;
cctxI.maxBufferSize := 5 * 1048576;
if (preferencesPtr <> Nil) then
prefs := preferencesPtr^;
proposedBSID := max64KB;
maxBlockSize := 65536;
while (prefs.frameInfo.blockSizeID > proposedBSID) do
begin
if (srcSize <= maxBlockSize) then
begin
prefs.frameInfo.blockSizeID := proposedBSID;
break;
end;
inc(proposedBSID);
maxBlockSize := maxBlockSize shl 2;
end;
prefs.autoFlush := 1;
if (srcSize <= LZ4F_getBlockSize(cardinal(prefs.frameInfo.blockSizeID))) then
prefs.frameInfo.blockMode := blockIndependent; // no need for linked blocks
options.stableSrc := 1;
if (dstMaxSize < LZ4F_compressFrameBound(srcSize, @prefs)) then
exit(size_t(-integer(ERROR_dstMaxSize_tooSmall)));
errorCode := LZ4F_compressBegin(@cctxI, dstBuffer, dstMaxSize, @prefs); // write header
if (LZ4F_isError(errorCode)) then
exit(errorCode);
inc(dstPtr, errorCode); // header size
dec(dstMaxSize, errorCode);
errorCode := LZ4F_compressUpdate(@cctxI, dstPtr, dstMaxSize, srcBuffer, srcSize, @options);
if (LZ4F_isError(errorCode)) then
exit(errorCode);
inc(dstPtr, errorCode);
errorCode := LZ4F_compressEnd(@cctxI, dstPtr, dstEnd - dstPtr, @options); // flush last block, and generate suffix
if LZ4F_isError(errorCode) then
exit(errorCode);
inc(dstPtr, errorCode);
freemem(cctxI.lz4CtxPtr);
result := dstPtr - dstStart;
end;
function LZ4F_getBlockSize(blockSizeID: cardinal): size_t;
const
blockSizes: array [0 .. 3] of size_t = (65536, 4 * 65536, 16 * 65536, 64 * 65536);
begin
if (blockSizeID = 0) then
blockSizeID := cardinal(LZ4F_BLOCKSIZEID_DEFAULT);
dec(blockSizeID, 4);
if (blockSizeID > 3) then
exit(size_t(-integer(ERROR_maxBlockSize_invalid)));
result := blockSizes[blockSizeID];
end;
function LZ4F_compressBound(srcSize: size_t; const preferencesPtr: PLZ4F_preferences_t): size_t;
var
prefsNull: LZ4F_preferences_t;
prefsPtr: PLZ4F_preferences_t;
bid: blockSizeID_t;
blockSize: size_t;
nbBlocks: cardinal;
lastBlockSize: size_t;
blockInfo: size_t;
frameEnd: size_t;
begin
fillchar(prefsNull, sizeof(LZ4F_preferences_t), 0);
if preferencesPtr = Nil then
prefsPtr := @prefsNull
else
prefsPtr := preferencesPtr;
bid := prefsPtr.frameInfo.blockSizeID;
blockSize := LZ4F_getBlockSize(cardinal(bid));
nbBlocks := cardinal(srcSize div blockSize) + 1;
if prefsPtr.autoFlush <> 0 then
lastBlockSize := srcSize mod blockSize
else
lastBlockSize := blockSize;
blockInfo := 4; // default, without block CRC option
frameEnd := 4 + (cardinal(prefsPtr.frameInfo.contentChecksumFlag) * 4);
result := (blockInfo * nbBlocks) + (blockSize * (nbBlocks - 1)) + lastBlockSize + frameEnd;
end;
procedure LZ4F_writeLE32(dstPtr: pByte; value32: cardinal);
begin
dstPtr[0] := byte(value32);
dstPtr[1] := byte(value32 shr 8);
dstPtr[2] := byte(value32 shr 16);
dstPtr[3] := byte(value32 shr 24);
end;
function LZ4F_headerChecksum(const header: pByte; length: size_t): byte;
var
xxh: cardinal;
begin
xxh := XXH32(header, cardinal(length), 0);
result := byte(xxh shr 8);
end;
function LZ4F_compressBegin(compressionContext: PLZ4F_compressionContext_t; dstBuffer: pointer; dstMaxSize: size_t;
preferencesPtr: PLZ4F_preferences_t): size_t;
var
prefNull: LZ4F_preferences_t;
cctxPtr: PLZ4F_cctx_internal_t;
dstStart: pByte;
dstPtr: pByte;
headerStart: pByte;
requiredBuffSize: size_t;
targetCtxLevel: cardinal;
begin
fillchar(prefNull, sizeof(LZ4F_preferences_t), 0);
cctxPtr := PLZ4F_cctx_internal_t(compressionContext);
dstStart := pByte(dstBuffer);
dstPtr := dstStart;
if (dstMaxSize < LZ4F_MAXHEADERFRAME_SIZE) then
exit(size_t(-integer(ERROR_dstMaxSize_tooSmall)));
if (cctxPtr.cStage <> 0) then
exit(size_t(-integer(ERROR_GENERIC)));
if (preferencesPtr = Nil) then
preferencesPtr := @prefNull;
cctxPtr.prefs := preferencesPtr^;
// ctx Management
if cctxPtr.prefs.compressionLevel < minHClevel then
targetCtxLevel := 1
else
targetCtxLevel := 2;
if cctxPtr.lz4CtxLevel < targetCtxLevel then
begin
freemem(cctxPtr.lz4CtxPtr);
if (cctxPtr.prefs.compressionLevel < minHClevel) then
cctxPtr.lz4CtxPtr := LZ4_createStream()
else
cctxPtr.lz4CtxPtr := LZ4_createStreamHC();
cctxPtr.lz4CtxLevel := targetCtxLevel;
end;
// Buffer Management
if cardinal(cctxPtr.prefs.frameInfo.blockSizeID) = 0 then
cctxPtr.prefs.frameInfo.blockSizeID := LZ4F_BLOCKSIZEID_DEFAULT;
cctxPtr.maxBlockSize := LZ4F_getBlockSize(cardinal(cctxPtr.prefs.frameInfo.blockSizeID));
requiredBuffSize := cctxPtr.maxBlockSize + (cardinal(cctxPtr.prefs.frameInfo.blockMode = blockLinked) * 131072);
if preferencesPtr.autoFlush <> 0 then
requiredBuffSize := cardinal(cctxPtr.prefs.frameInfo.blockMode = blockLinked) * 65536; // just needs dict
if (cctxPtr.maxBufferSize < requiredBuffSize) then
begin
cctxPtr.maxBufferSize := requiredBuffSize;
freemem(cctxPtr.tmpBuff);
cctxPtr.tmpBuff := allocmem(requiredBuffSize);
if (cctxPtr.tmpBuff = Nil) then
exit(size_t(-integer(ERROR_allocation_failed)));
end;
cctxPtr.tmpIn := cctxPtr.tmpBuff;
cctxPtr.tmpInSize := 0;
XXH32_reset(@cctxPtr.xxh, 0);
if cctxPtr.prefs.compressionLevel < minHClevel then
LZ4_resetStream(PLZ4_stream_t(cctxPtr.lz4CtxPtr))
else
LZ4_resetStreamHC(cctxPtr.lz4CtxPtr, cctxPtr.prefs.compressionLevel);
// Magic Number
LZ4F_writeLE32(dstPtr, LZ4F_MAGICNUMBER);
inc(dstPtr, 4);
headerStart := dstPtr;
// FLG Byte
dstPtr^ := ((1 and _2BITS) shl 6) // Version('01')
+ ((cardinal(cctxPtr.prefs.frameInfo.blockMode) and _1BIT) shl 5) // Block mode
+ byte((cardinal(cctxPtr.prefs.frameInfo.contentChecksumFlag) and _1BIT) shl 2); // Stream checksum
inc(dstPtr);
// BD Byte
dstPtr^ := byte((cardinal(cctxPtr.prefs.frameInfo.blockSizeID) and _3BITS) shl 4);
inc(dstPtr);
// *CRC Byte
dstPtr^ := LZ4F_headerChecksum(headerStart, 2);
inc(dstPtr);
cctxPtr.cStage := 1; // header written, wait for data block
result := dstPtr - dstStart;
end;
type
compressFunc_t = function(ctx: pointer; const src: pAnsiChar; dst: pAnsiChar; srcSize: integer; dstSize: integer;
level: integer): integer;
function LZ4F_localLZ4_compress_limitedOutput_withState(ctx: pointer; const src: pAnsiChar; dst: pAnsiChar; srcSize: integer;
dstSize: integer; level: integer): integer;
begin
result := LZ4_compress_limitedOutput_withState(ctx, src, dst, srcSize, dstSize);
end;
function LZ4F_localLZ4_compress_limitedOutput_continue(ctx: pointer; const src: pAnsiChar; dst: pAnsiChar; srcSize: integer;
dstSize: integer; level: integer): integer;
begin
result := LZ4_compress_limitedOutput_continue(PLZ4_stream_t(ctx), src, dst, srcSize, dstSize);
end;
function LZ4F_localLZ4_compressHC_limitedOutput_continue(ctx: pointer; const src: pAnsiChar; dst: pAnsiChar; srcSize: integer;
dstSize: integer; level: integer): integer;
begin
result := LZ4_compressHC_limitedOutput_continue(PLZ4_streamHC_t(ctx), src, dst, srcSize, dstSize);
end;
function LZ4F_localSaveDict(cctxPtr: PLZ4F_cctx_internal_t): integer;
begin
if cctxPtr.prefs.compressionLevel < minHClevel then
result := LZ4_saveDict(PLZ4_stream_t(cctxPtr.lz4CtxPtr), pAnsiChar(cctxPtr.tmpBuff), 65536)
else
result := LZ4_saveDictHC(PLZ4_streamHC_t(cctxPtr.lz4CtxPtr), pAnsiChar(cctxPtr.tmpBuff), 65536);
end;
function LZ4F_selectCompression(blockMode: blockMode_t; level: cardinal): compressFunc_t;
begin
if level < minHClevel then
begin
if (blockMode = blockIndependent) then
exit(@LZ4F_localLZ4_compress_limitedOutput_withState);
exit(@LZ4F_localLZ4_compress_limitedOutput_continue);
end;
if (blockMode = blockIndependent) then
exit(@LZ4_compressHC2_limitedOutput_withStateHC);
exit(@LZ4F_localLZ4_compressHC_limitedOutput_continue);
end;
function LZ4F_compressBlock(dst: pointer; const src: pointer; srcSize: size_t; compress: compressFunc_t; lz4ctx: pointer;
level: integer): integer;
var
cSizePtr: pByte;
cSize: cardinal;
begin
cSizePtr := dst;
cSize := cardinal(compress(lz4ctx, src, pAnsiChar(cSizePtr + 4), integer(srcSize), integer(srcSize - 1), level));
LZ4F_writeLE32(cSizePtr, cSize);
if (cSize = 0) then // compression failed
begin
cSize := srcSize;
LZ4F_writeLE32(cSizePtr, cSize + LZ4F_BLOCKUNCOMPRESSED_FLAG);
move(src^, (cSizePtr + 4)^, srcSize);
end;
result := cSize + 4;
end;
function LZ4F_compressUpdate(compressionContext: PLZ4F_compressionContext_t; dstBuffer: pointer; dstMaxSize: size_t;
const srcBuffer: pointer; srcSize: size_t; compressOptionsPtr: PLZ4F_compressOptions_t): size_t;
var
cOptionsNull: LZ4F_compressOptions_t;
cctxPtr: PLZ4F_cctx_internal_t;
blockSize: size_t;
srcPtr: pByte;
srcEnd: pByte;
dstStart: pByte;
dstPtr: pByte;
lastBlockCompressed: LZ4F_lastBlockStatus;
compress: compressFunc_t;
sizeToCopy: size_t;
realDictSize: integer;
begin
fillchar(cOptionsNull, sizeof(LZ4F_compressOptions_t), 0);
cctxPtr := PLZ4F_cctx_internal_t(compressionContext);
blockSize := cctxPtr.maxBlockSize;
srcPtr := srcBuffer;
srcEnd := srcPtr + srcSize;
dstStart := dstBuffer;
dstPtr := dstStart;
lastBlockCompressed := notDone;
if cctxPtr.cStage <> 1 then
exit(size_t(-integer(ERROR_GENERIC)));
if dstMaxSize < LZ4F_compressBound(srcSize, @(cctxPtr.prefs)) then
exit(size_t(-integer(ERROR_dstMaxSize_tooSmall)));
if compressOptionsPtr = Nil then
compressOptionsPtr := @cOptionsNull;
// select compression function
compress := LZ4F_selectCompression(cctxPtr.prefs.frameInfo.blockMode, cctxPtr.prefs.compressionLevel);
// complete tmp buffer
if cctxPtr.tmpInSize > 0 then // some data already within tmp buffer
begin
sizeToCopy := blockSize - cctxPtr.tmpInSize;
if sizeToCopy > srcSize then
begin
// add src to tmpIn buffer
move(srcBuffer^, (cctxPtr.tmpIn + cctxPtr.tmpInSize)^, srcSize);
srcPtr := srcEnd;
inc(cctxPtr.tmpInSize, srcSize);
// still needs some CRC
end
else
begin
// complete tmpIn block and then compress it
lastBlockCompressed := fromTmpBuffer;
move(srcBuffer^, (cctxPtr.tmpIn + cctxPtr.tmpInSize)^, sizeToCopy);
inc(srcPtr, sizeToCopy);
inc(dstPtr, LZ4F_compressBlock(dstPtr, cctxPtr.tmpIn, blockSize, compress, cctxPtr.lz4CtxPtr, cctxPtr.prefs.compressionLevel));
if (cctxPtr.prefs.frameInfo.blockMode = blockLinked) then
inc(cctxPtr.tmpIn, blockSize);
cctxPtr.tmpInSize := 0;
end;
end;
while size_t(srcEnd - srcPtr) >= blockSize do
begin
// compress full block
lastBlockCompressed := fromSrcBuffer;
inc(dstPtr, LZ4F_compressBlock(dstPtr, srcPtr, blockSize, compress, cctxPtr.lz4CtxPtr, cctxPtr.prefs.compressionLevel));
inc(srcPtr, blockSize);
end;
if ((cctxPtr.prefs.autoFlush <> 0) and (srcPtr < srcEnd)) then
begin
// compress remaining input < blockSize
lastBlockCompressed := fromSrcBuffer;
inc(dstPtr, LZ4F_compressBlock(dstPtr, srcPtr, srcEnd - srcPtr, compress, cctxPtr.lz4CtxPtr, cctxPtr.prefs.compressionLevel));
srcPtr := srcEnd;
end;
// preserve dictionary if necessary
if ((cctxPtr.prefs.frameInfo.blockMode = blockLinked) and (lastBlockCompressed = fromSrcBuffer)) then
begin
if compressOptionsPtr.stableSrc <> 0 then
cctxPtr.tmpIn := cctxPtr.tmpBuff
else
begin
realDictSize := LZ4F_localSaveDict(cctxPtr);
if (realDictSize = 0) then
exit(size_t(-integer(ERROR_GENERIC)));
cctxPtr.tmpIn := cctxPtr.tmpBuff + realDictSize;
end;
end;
// keep tmpIn within limits
if ((cctxPtr.tmpIn + blockSize) > (cctxPtr.tmpBuff + cctxPtr.maxBufferSize))
// necessarily blockLinked && lastBlockCompressed==fromTmpBuffer
and (cctxPtr.prefs.autoFlush = 0) then
begin
LZ4F_localSaveDict(cctxPtr);
cctxPtr.tmpIn := cctxPtr.tmpBuff + 65536;
end;
// some input data left, necessarily < blockSize
if srcPtr < srcEnd then
begin
// fill tmp buffer
sizeToCopy := srcEnd - srcPtr;
move(srcPtr^, (cctxPtr.tmpIn)^, sizeToCopy);
cctxPtr.tmpInSize := sizeToCopy;
end;
if (cctxPtr.prefs.frameInfo.contentChecksumFlag = contentChecksumEnabled) then
XXH32_update(@(cctxPtr.xxh), srcBuffer, cardinal(srcSize));
result := dstPtr - dstStart;
end;
function LZ4F_flush(compressionContext: PLZ4F_compressionContext_t; dstBuffer: pointer; dstMaxSize: size_t;
compressOptionsPtr: PLZ4F_compressOptions_t): size_t;
var
cOptionsNull: LZ4F_compressOptions_t;
cctxPtr: PLZ4F_cctx_internal_t;
dstStart: pByte;
dstPtr: pByte;
compress: compressFunc_t;
begin
fillchar(cOptionsNull, sizeof(LZ4F_compressOptions_t), 0);
cctxPtr := PLZ4F_cctx_internal_t(compressionContext);
dstStart := pByte(dstBuffer);
dstPtr := dstStart;
if cctxPtr.tmpInSize = 0 then
exit(0); // nothing to flush
if cctxPtr.cStage <> 1 then
exit(size_t(-integer(ERROR_GENERIC)));
if (dstMaxSize < (cctxPtr.tmpInSize + 16)) then
exit(size_t(-integer(ERROR_dstMaxSize_tooSmall)));
(* Not used
if (compressOptionsPtr = Nil) then
compressOptionsPtr := @cOptionsNull;
*)
// select compression function
compress := LZ4F_selectCompression(cctxPtr.prefs.frameInfo.blockMode, cctxPtr.prefs.compressionLevel);
// compress tmp buffer
inc(dstPtr, LZ4F_compressBlock(dstPtr, cctxPtr.tmpIn, cctxPtr.tmpInSize, compress, cctxPtr.lz4CtxPtr, cctxPtr.prefs.compressionLevel));
if (cctxPtr.prefs.frameInfo.blockMode = blockLinked) then
inc(cctxPtr.tmpIn, cctxPtr.tmpInSize);
cctxPtr.tmpInSize := 0;
// keep tmpIn within limits
if ((cctxPtr.tmpIn + cctxPtr.maxBlockSize) > (cctxPtr.tmpBuff + cctxPtr.maxBufferSize)) then // necessarily blockLinked
begin
LZ4F_localSaveDict(cctxPtr);
cctxPtr.tmpIn := cctxPtr.tmpBuff + 65536;
end;
result := dstPtr - dstStart;
end;
function LZ4F_compressEnd(compressionContext: PLZ4F_compressionContext_t; dstBuffer: pointer; dstMaxSize: size_t;
const compressOptionsPtr: PLZ4F_compressOptions_t): size_t;
var
cctxPtr: PLZ4F_cctx_internal_t;
dstStart: pByte;
dstPtr: pByte;
errorCode: size_t;
xxh: cardinal;
begin
cctxPtr := PLZ4F_cctx_internal_t(compressionContext);
dstStart := pByte(dstBuffer);
dstPtr := dstStart;
errorCode := LZ4F_flush(compressionContext, dstBuffer, dstMaxSize, compressOptionsPtr);
if LZ4F_isError(errorCode) then
exit(errorCode);
inc(dstPtr, errorCode);
LZ4F_writeLE32(dstPtr, 0);
inc(dstPtr, 4); // endMark
if cctxPtr.prefs.frameInfo.contentChecksumFlag = contentChecksumEnabled then
begin
xxh := XXH32_digest(@(cctxPtr.xxh));
LZ4F_writeLE32(dstPtr, xxh);
inc(dstPtr, 4); // content Checksum
end;
cctxPtr.cStage := 0; // state is now re-usable (with identical preferences)
result := dstPtr - dstStart;
end;
function LZ4F_readLE32(const srcPtr: pByte): cardinal;
var
value32: cardinal;
begin
value32 := srcPtr[0];
inc(value32, (srcPtr[1] shl 8));
inc(value32, (srcPtr[2] shl 16));
inc(value32, (srcPtr[3] shl 24));
result := value32;
end;
function LZ4F_decodeHeader(dctxPtr: PLZ4F_dctx_internal_t; srcPtr: pByte; srcSize: size_t): size_t;
var
FLG, BD, HC: byte;
version, blockMode, blockChecksumFlag, contentSizeFlag, contentChecksumFlag, dictFlag, blockSizeID: cardinal;
bufferNeeded: size_t;
begin
// need to decode header to get frameInfo
if srcSize < 7 then
exit(size_t(-integer(ERROR_GENERIC))); // minimal header size
// control magic number
if (LZ4F_readLE32(srcPtr) <> LZ4F_MAGICNUMBER) then
exit(size_t(-integer(ERROR_GENERIC)));
inc(srcPtr, 4);
// Flags
FLG := srcPtr[0];
version := (FLG shr 6) and _2BITS;
blockMode := (FLG shr 5) and _1BIT;
blockChecksumFlag := (FLG shr 4) and _1BIT;
contentSizeFlag := (FLG shr 3) and _1BIT;
contentChecksumFlag := (FLG shr 2) and _1BIT;
dictFlag := (FLG shr 0) and _1BIT;
BD := srcPtr[1];
blockSizeID := (BD shr 4) and _3BITS;
// check
HC := LZ4F_headerChecksum(srcPtr, 2);
if (HC <> srcPtr[2]) then
exit(size_t(-integer(ERROR_GENERIC))); // Bad header checksum error
// validate
if version <> 1 then
exit(size_t(-integer(ERROR_GENERIC))); // Version Number, only supported value
if blockChecksumFlag <> 0 then
exit(size_t(-integer(ERROR_GENERIC))); // Only supported value for the time being
if contentSizeFlag <> 0 then
exit(size_t(-integer(ERROR_GENERIC))); // Only supported value for the time being
if ((FLG shr 1) and _1BIT) <> 0 then
exit(size_t(-integer(ERROR_GENERIC)));
/// Reserved bit
if dictFlag <> 0 then
exit(size_t(-integer(ERROR_GENERIC))); // Only supported value for the time being
if (BD shr 7) and _1BIT <> 0 then
exit(size_t(-integer(ERROR_GENERIC)));
/// Reserved bit
if blockSizeID < 4 then
exit(size_t(-integer(ERROR_GENERIC))); // Only supported values for the time being
if (((BD shr 0) and _4BITS) <> 0) then
exit(size_t(-integer(ERROR_GENERIC))); // Reserved bits
// save
dctxPtr.frameInfo.blockMode := blockMode_t(blockMode);
dctxPtr.frameInfo.contentChecksumFlag := contentChecksum_t(contentChecksumFlag);
dctxPtr.frameInfo.blockSizeID := blockSizeID_t(blockSizeID);
dctxPtr.maxBlockSize := LZ4F_getBlockSize(blockSizeID);
// init
if (contentChecksumFlag <> 0) then
XXH32_reset(@(dctxPtr.xxh), 0);
// alloc
bufferNeeded := dctxPtr.maxBlockSize + size_t (integer(dctxPtr.frameInfo.blockMode = blockLinked) * 131072);
if bufferNeeded > dctxPtr.maxBufferSize then // tmp buffers too small
begin
freemem(dctxPtr.tmpIn);
freemem(dctxPtr.tmpOutBuffer);
dctxPtr.maxBufferSize := bufferNeeded;
dctxPtr.tmpIn := allocmem(dctxPtr.maxBlockSize);
if dctxPtr.tmpIn = Nil then
exit(size_t(-integer(ERROR_GENERIC)));
dctxPtr.tmpOutBuffer := allocmem(dctxPtr.maxBufferSize);
if dctxPtr.tmpOutBuffer = Nil then
exit(size_t(-integer(ERROR_GENERIC)));
end;
dctxPtr.tmpInSize := 0;
dctxPtr.tmpInTarget := 0;
dctxPtr.dict := dctxPtr.tmpOutBuffer;
dctxPtr.dictSize := 0;
dctxPtr.tmpOut := dctxPtr.tmpOutBuffer;
dctxPtr.tmpOutStart := 0;
dctxPtr.tmpOutSize := 0;
result := 7;
end;
procedure LZ4F_updateDict(dctxPtr: PLZ4F_dctx_internal_t; const dstPtr: pByte; dstSize: size_t; const dstPtr0: pByte; withinTmp: cardinal);
var
preserveSize: size_t;
copySize: size_t;
oldDictEnd: pByte;
begin
if dctxPtr.dictSize = 0 then
dctxPtr.dict := pByte(dstPtr); // priority to dictionary continuity
if dctxPtr.dict + dctxPtr.dictSize = dstPtr then // dictionary continuity
begin
inc(dctxPtr.dictSize, dstSize);
exit;
end;
if size_t(dstPtr - dstPtr0) + dstSize >= 65536 then // dstBuffer large enough to become dictionary
begin
dctxPtr.dict := pByte(dstPtr0);
dctxPtr.dictSize := size_t(dstPtr - dstPtr0) + dstSize;
exit;
end;
if ((withinTmp <> 0) and (dctxPtr.dict = dctxPtr.tmpOutBuffer)) then
begin
// assumption : dctxPtr->dict + dctxPtr->dictSize == dctxPtr->tmpOut + dctxPtr->tmpOutStart
inc(dctxPtr.dictSize, dstSize);
exit;
end;
if withinTmp <> 0 then // copy relevant dict portion in front of tmpOut within tmpOutBuffer
begin
preserveSize := dctxPtr.tmpOut - dctxPtr.tmpOutBuffer;
copySize := 65536 - dctxPtr.tmpOutSize;
oldDictEnd := dctxPtr.dict + dctxPtr.dictSize - dctxPtr.tmpOutStart;
if dctxPtr.tmpOutSize > 65536 then
copySize := 0;
if copySize > preserveSize then
copySize := preserveSize;
move((oldDictEnd - copySize)^, (dctxPtr.tmpOutBuffer + preserveSize - copySize)^, copySize);
dctxPtr.dict := dctxPtr.tmpOutBuffer;
dctxPtr.dictSize := preserveSize + dctxPtr.tmpOutStart + dstSize;
exit;
end;
if dctxPtr.dict = dctxPtr.tmpOutBuffer then // copy dst into tmp to complete dict
begin
if dctxPtr.dictSize + dstSize > dctxPtr.maxBufferSize then // tmp buffer not large enough
begin
preserveSize := 65536 - dstSize; // note : dstSize < 64 KB
move((dctxPtr.dict + dctxPtr.dictSize - preserveSize)^, (dctxPtr.dict)^, preserveSize);
dctxPtr.dictSize := preserveSize;
end;
move(dstPtr^, (dctxPtr.dict + dctxPtr.dictSize)^, dstSize);
inc(dctxPtr.dictSize, dstSize);
exit;
end;
// join dict & dest into tmp
preserveSize := 65536 - dstSize; // note : dstSize < 64 KB
if preserveSize > dctxPtr.dictSize then
preserveSize := dctxPtr.dictSize;
move((dctxPtr.dict + dctxPtr.dictSize - preserveSize)^, dctxPtr.tmpOutBuffer^, preserveSize);
move(dstPtr^, (dctxPtr.tmpOutBuffer + preserveSize)^, dstSize);
dctxPtr.dict := dctxPtr.tmpOutBuffer;
dctxPtr.dictSize := preserveSize + dstSize;
end;
function LZ4F_decompress_safe(const source: pAnsiChar; dest: pAnsiChar; compressedSize: integer; maxDecompressedSize: integer;
const dictStart: pAnsiChar; dictSize: integer): integer;
begin
result := LZ4_decompress_safe(source, dest, compressedSize, maxDecompressedSize);
end;
function LZ4F_decompress(decompressionContext: PLZ4F_decompressionContext_t;
dstBuffer: pointer; dstSizePtr: psize_t;
const srcBuffer: pointer; srcSizePtr: psize_t;
decompressOptionsPtr: PLZ4F_decompressOptions_t): size_t;
type
Tdecoder = function(const c1: pAnsiChar; c2: pAnsiChar; c3: integer; c4: integer; const c5: pAnsiChar; c6: integer): integer;
var
dctxPtr: PLZ4F_dctx_internal_t;
optionsNull: LZ4F_decompressOptions_t;
srcStart: pByte;
srcEnd: pByte;
srcPtr: pByte;
dstStart: pByte;
dstEnd: pByte;
dstPtr: pByte;
selectedIn: pByte;
doAnotherStage: cardinal;
nextSrcSizeHint: size_t;
sizeToCopy: size_t;
errorCode: LZ4F_errorCode_t;
nextCBlockSize: size_t;
decodedSize: integer;
decoder: Tdecoder;
reservedDictSpace: size_t;
suffixSize: size_t;
readCRC: cardinal;
resultCRC: cardinal;
preserveSize: size_t;
copySize: size_t;
oldDictEnd: pByte;
newDictSize: size_t;
begin
dctxPtr := PLZ4F_dctx_internal_t(decompressionContext);
fillchar(optionsNull, sizeof(LZ4F_decompressOptions_t), 0);
srcStart := pByte(srcBuffer);
srcEnd := srcStart + srcSizePtr^;
srcPtr := srcStart;
dstStart := pByte(dstBuffer);
dstEnd := dstStart + dstSizePtr^;
dstPtr := dstStart;
selectedIn := Nil;
doAnotherStage := 1;
nextSrcSizeHint := 1;
if decompressOptionsPtr = Nil then
decompressOptionsPtr := @optionsNull;
srcSizePtr^ := 0;
dstSizePtr^ := 0;
// expect to continue decoding src buffer where it left previously
if dctxPtr.srcExpect <> Nil then
begin
if (srcStart <> dctxPtr.srcExpect) then
exit(size_t(-integer(ERROR_GENERIC)));
end;
// programmed as a state machine
while (doAnotherStage <> 0) do
begin
case dctxPtr.dStage of
cardinal(dstage_getHeader):
begin
if srcEnd - srcPtr >= 7 then
begin
selectedIn := srcPtr;
inc(srcPtr, 7);
dctxPtr.dStage := cardinal(dstage_decodeHeader);
end
else
begin
dctxPtr.tmpInSize := 0;
dctxPtr.dStage := cardinal(dstage_storeHeader);
end;
end;
cardinal(dstage_storeHeader):
begin
sizeToCopy := 7 - dctxPtr.tmpInSize;
if sizeToCopy > size_t(srcEnd - srcPtr) then
sizeToCopy := srcEnd - srcPtr;
move(srcPtr^, (pByte(@dctxPtr.header) + dctxPtr.tmpInSize)^, sizeToCopy);
inc(dctxPtr.tmpInSize, sizeToCopy);
inc(srcPtr, sizeToCopy);
if (dctxPtr.tmpInSize < 7) then
begin
nextSrcSizeHint := (7 - dctxPtr.tmpInSize) + 4;
doAnotherStage := 0; // no enough src, wait to get some more
end
else
begin
selectedIn := @dctxPtr.header;
dctxPtr.dStage := cardinal(dstage_decodeHeader);
end;
end;
cardinal(dstage_decodeHeader):
begin
errorCode := LZ4F_decodeHeader(dctxPtr, selectedIn, 7);
if LZ4F_isError(errorCode) then
exit(errorCode);
dctxPtr.dStage := cardinal(dstage_getCBlockSize);
end;
cardinal(dstage_getCBlockSize):
begin
if (srcEnd - srcPtr) >= 4 then
begin
selectedIn := srcPtr;
inc(srcPtr, 4);
dctxPtr.dStage := cardinal(dstage_decodeCBlockSize);
end
else
begin
// not enough input to read cBlockSize field
dctxPtr.tmpInSize := 0;
dctxPtr.dStage := cardinal(dstage_storeCBlockSize);
end;
end;
cardinal(dstage_storeCBlockSize):
begin
sizeToCopy := 4 - dctxPtr.tmpInSize;
if sizeToCopy > size_t(srcEnd - srcPtr) then
sizeToCopy := srcEnd - srcPtr;
move(srcPtr^, (dctxPtr.tmpIn + dctxPtr.tmpInSize)^, sizeToCopy);
inc(srcPtr, sizeToCopy);
inc(dctxPtr.tmpInSize, sizeToCopy);
if dctxPtr.tmpInSize < 4 then // not enough input to get full cBlockSize; wait for more
begin
nextSrcSizeHint := 4 - dctxPtr.tmpInSize;
doAnotherStage := 0;
end
else
begin
selectedIn := dctxPtr.tmpIn;
dctxPtr.dStage := cardinal(dstage_decodeCBlockSize);
end;
end;
cardinal(dstage_decodeCBlockSize):
begin
nextCBlockSize := LZ4F_readLE32(selectedIn) and $7FFFFFFF;
if (nextCBlockSize = 0) then
dctxPtr.dStage := cardinal(dstage_getSuffix)
else
begin
if (nextCBlockSize > dctxPtr.maxBlockSize) then
exit(size_t(-integer(ERROR_GENERIC))); // invalid cBlockSize
dctxPtr.tmpInTarget := nextCBlockSize;
if (LZ4F_readLE32(selectedIn) and LZ4F_BLOCKUNCOMPRESSED_FLAG) <> 0 then
dctxPtr.dStage := cardinal(dstage_copyDirect)
else
begin
dctxPtr.dStage := cardinal(dstage_getCBlock);
if dstPtr = dstEnd then
begin
nextSrcSizeHint := nextCBlockSize + 4;
doAnotherStage := 0;
end;
end;
end;
end;
cardinal(dstage_copyDirect): // uncompressed block
begin
sizeToCopy := dctxPtr.tmpInTarget;
if size_t(srcEnd - srcPtr) < sizeToCopy then
sizeToCopy := srcEnd - srcPtr; // not enough input to read full block
if size_t(dstEnd - dstPtr) < sizeToCopy then
sizeToCopy := dstEnd - dstPtr;
move(srcPtr^, dstPtr^, sizeToCopy);
if (dctxPtr.frameInfo.contentChecksumFlag <> noContentChecksum) then
XXH32_update(@(dctxPtr.xxh), srcPtr, cardinal(sizeToCopy));
// dictionary management
if (dctxPtr.frameInfo.blockMode = blockLinked) then
LZ4F_updateDict(dctxPtr, dstPtr, sizeToCopy, dstStart, 0);
inc(srcPtr, sizeToCopy);
inc(dstPtr, sizeToCopy);
if sizeToCopy = dctxPtr.tmpInTarget then // all copied
dctxPtr.dStage := cardinal(dstage_getCBlockSize)
else
begin
dec(dctxPtr.tmpInTarget, sizeToCopy); // still need to copy more
nextSrcSizeHint := dctxPtr.tmpInTarget + 4;
doAnotherStage := 0;
end;
end;
cardinal(dstage_getCBlock):
begin
if size_t(srcEnd - srcPtr) < dctxPtr.tmpInTarget then
begin
dctxPtr.tmpInSize := 0;
dctxPtr.dStage := cardinal(dstage_storeCBlock);
end
else
begin
selectedIn := srcPtr;
inc(srcPtr, dctxPtr.tmpInTarget);
dctxPtr.dStage := cardinal(dstage_decodeCBlock);
end;
end;
cardinal(dstage_storeCBlock):
begin
sizeToCopy := dctxPtr.tmpInTarget - dctxPtr.tmpInSize;
if sizeToCopy > size_t(srcEnd - srcPtr) then
sizeToCopy := srcEnd - srcPtr;
move(srcPtr^, (dctxPtr.tmpIn + dctxPtr.tmpInSize)^, sizeToCopy);
inc(dctxPtr.tmpInSize, sizeToCopy);
inc(srcPtr, sizeToCopy);
if (dctxPtr.tmpInSize < dctxPtr.tmpInTarget) then // need more input
begin
nextSrcSizeHint := (dctxPtr.tmpInTarget - dctxPtr.tmpInSize) + 4;
doAnotherStage := 0;
end
else
begin
selectedIn := dctxPtr.tmpIn;
dctxPtr.dStage := cardinal(dstage_decodeCBlock);
end;
end;
cardinal(dstage_decodeCBlock):
begin
if (size_t(dstEnd - dstPtr) < dctxPtr.maxBlockSize) then // not enough place into dst : decode into tmpOut
dctxPtr.dStage := cardinal(dstage_decodeCBlock_intoTmp)
else
dctxPtr.dStage := cardinal(dstage_decodeCBlock_intoDst);
end;
cardinal(dstage_decodeCBlock_intoDst):
begin
if (dctxPtr.frameInfo.blockMode = blockLinked) then
decoder := LZ4_decompress_safe_usingDict
else
decoder := LZ4F_decompress_safe;
decodedSize := decoder(pAnsiChar(selectedIn), pAnsiChar(dstPtr), integer(dctxPtr.tmpInTarget),
integer(dctxPtr.maxBlockSize), pAnsiChar(dctxPtr.dict), integer(dctxPtr.dictSize));
if (decodedSize < 0) then
exit(size_t(-integer(ERROR_GENERIC))); // decompression failed
if (dctxPtr.frameInfo.contentChecksumFlag <> noContentChecksum) then
XXH32_update(@(dctxPtr.xxh), dstPtr, decodedSize);
// dictionary management
if (dctxPtr.frameInfo.blockMode = blockLinked) then
LZ4F_updateDict(dctxPtr, dstPtr, decodedSize, dstStart, 0);
inc(dstPtr, decodedSize);
dctxPtr.dStage := cardinal(dstage_getCBlockSize);
end;
cardinal(dstage_decodeCBlock_intoTmp):
begin
if (dctxPtr.frameInfo.blockMode = blockLinked) then
decoder := LZ4_decompress_safe_usingDict
else
decoder := LZ4F_decompress_safe;
// ensure enough place for tmpOut
if dctxPtr.frameInfo.blockMode = blockLinked then
begin
if (dctxPtr.dict = dctxPtr.tmpOutBuffer) then
begin
if (dctxPtr.dictSize > 131072) then
begin
move((dctxPtr.dict + dctxPtr.dictSize - 65536)^, dctxPtr.dict^, 65536);
dctxPtr.dictSize := 65536;
end;
dctxPtr.tmpOut := dctxPtr.dict + dctxPtr.dictSize;
end
else // dict not within tmp
begin
reservedDictSpace := dctxPtr.dictSize;
if (reservedDictSpace > 65536) then
reservedDictSpace := 65536;
dctxPtr.tmpOut := dctxPtr.tmpOutBuffer + reservedDictSpace;
end;
end;
// Decode
decodedSize := decoder(pAnsiChar(selectedIn), pAnsiChar(dctxPtr.tmpOut), integer(dctxPtr.tmpInTarget),
integer(dctxPtr.maxBlockSize), pAnsiChar(dctxPtr.dict), integer(dctxPtr.dictSize));
if decodedSize < 0 then
exit(size_t(-integer(ERROR_decompressionFailed))); // decompression failed
if (dctxPtr.frameInfo.contentChecksumFlag <> noContentChecksum) then
XXH32_update(@(dctxPtr.xxh), dctxPtr.tmpOut, decodedSize);
dctxPtr.tmpOutSize := decodedSize;
dctxPtr.tmpOutStart := 0;
dctxPtr.dStage := cardinal(dstage_flushOut);
end;
cardinal(dstage_flushOut): // flush decoded data from tmpOut to dstBuffer
begin
sizeToCopy := dctxPtr.tmpOutSize - dctxPtr.tmpOutStart;
if (sizeToCopy > size_t(dstEnd - dstPtr)) then
sizeToCopy := dstEnd - dstPtr;
move((dctxPtr.tmpOut + dctxPtr.tmpOutStart)^, dstPtr^, sizeToCopy);
// dictionary management
if (dctxPtr.frameInfo.blockMode = blockLinked) then
LZ4F_updateDict(dctxPtr, dstPtr, sizeToCopy, dstStart, 1);
inc(dctxPtr.tmpOutStart, sizeToCopy);
inc(dstPtr, sizeToCopy);
// end of flush ?
if (dctxPtr.tmpOutStart = dctxPtr.tmpOutSize) then
dctxPtr.dStage := cardinal(dstage_getCBlockSize)
else
begin
nextSrcSizeHint := 4;
doAnotherStage := 0; // still some data to flush
end;
end;
cardinal(dstage_getSuffix):
begin
suffixSize := cardinal(dctxPtr.frameInfo.contentChecksumFlag) * 4;
if (suffixSize = 0) then // frame completed
begin
nextSrcSizeHint := 0;
dctxPtr.dStage := cardinal(dstage_getHeader);
doAnotherStage := 0;
end
else
begin
if ((srcEnd - srcPtr) >= 4) then // CRC present
begin
selectedIn := srcPtr;
inc(srcPtr, 4);
dctxPtr.dStage := cardinal(dstage_checkSuffix);
end
else
begin
dctxPtr.tmpInSize := 0;
dctxPtr.dStage := cardinal(dstage_storeSuffix);
end;
end;
end;
cardinal(dstage_storeSuffix):
begin
sizeToCopy := 4 - dctxPtr.tmpInSize;
if (sizeToCopy > size_t(srcEnd - srcPtr)) then
sizeToCopy := srcEnd - srcPtr;
move(srcPtr^, (dctxPtr.tmpIn + dctxPtr.tmpInSize)^, sizeToCopy);
inc(srcPtr, sizeToCopy);
inc(dctxPtr.tmpInSize, sizeToCopy);
if (dctxPtr.tmpInSize < 4) then // not enough input to read complete suffix
begin
nextSrcSizeHint := 4 - dctxPtr.tmpInSize;
doAnotherStage := 0;
end
else
begin
selectedIn := dctxPtr.tmpIn;
dctxPtr.dStage := cardinal(dstage_checkSuffix);
end;
end;
cardinal(dstage_checkSuffix):
begin
readCRC := LZ4F_readLE32(selectedIn);
resultCRC := XXH32_digest(@(dctxPtr.xxh));
if (readCRC <> resultCRC) then
exit(size_t(-integer(ERROR_checksum_invalid)));
nextSrcSizeHint := 0;
dctxPtr.dStage := cardinal(dstage_getHeader);
doAnotherStage := 0;
end;
end;
end;
// preserve dictionary within tmp if necessary
if (dctxPtr.frameInfo.blockMode = blockLinked)
and (dctxPtr.dict <> dctxPtr.tmpOutBuffer)
and (decompressOptionsPtr.stableDst = 0)
and (cardinal(dctxPtr.dStage - 1) < cardinal(cardinal(dstage_getSuffix) - 1)) then
begin
if dctxPtr.dStage = cardinal(dstage_flushOut) then
begin
preserveSize := dctxPtr.tmpOut - dctxPtr.tmpOutBuffer;
copySize := 65536 - dctxPtr.tmpOutSize;
oldDictEnd := dctxPtr.dict + dctxPtr.dictSize - dctxPtr.tmpOutStart;
if dctxPtr.tmpOutSize > 65536 then
copySize := 0;
if copySize > preserveSize then
copySize := preserveSize;
move((oldDictEnd - copySize)^, (dctxPtr.tmpOutBuffer + preserveSize - copySize)^, copySize);
dctxPtr.dict := dctxPtr.tmpOutBuffer;
dctxPtr.dictSize := preserveSize + dctxPtr.tmpOutStart;
end
else
begin
newDictSize := dctxPtr.dictSize;
oldDictEnd := dctxPtr.dict + dctxPtr.dictSize;
if newDictSize > 65536 then
newDictSize := 65536;
move((oldDictEnd - newDictSize)^, (dctxPtr.tmpOutBuffer)^, newDictSize);
dctxPtr.dict := dctxPtr.tmpOutBuffer;
dctxPtr.dictSize := newDictSize;
dctxPtr.tmpOut := dctxPtr.tmpOutBuffer + newDictSize;
end;
end;
if (srcPtr < srcEnd) then // function must be called again with following source data
dctxPtr.srcExpect := srcPtr
else
dctxPtr.srcExpect := Nil;
srcSizePtr^ := (srcPtr - srcStart);
dstSizePtr^ := (dstPtr - dstStart);
result := nextSrcSizeHint;
end;
function LZ4F_createCompressionContext(var LZ4F_compressionContextPtr: PLZ4F_compressionContext_t; version: cardinal): LZ4F_errorCode_t;
var
cctxPtr: PLZ4F_cctx_internal_t;
begin
cctxPtr := allocmem(sizeof(LZ4F_cctx_internal_t));
if cctxPtr = Nil then
exit(LZ4F_errorCode_t(-integer(ERROR_allocation_failed)));
cctxPtr.version := version;
cctxPtr.cStage := 0; // Next stage : write header
LZ4F_compressionContextPtr := PLZ4F_compressionContext_t(cctxPtr);
result := cardinal(OK_NoError);
end;
function LZ4F_freeCompressionContext(LZ4F_compressionContext: PLZ4F_compressionContext_t): LZ4F_errorCode_t;
var
cctxPtr: PLZ4F_cctx_internal_t;
begin
cctxPtr := PLZ4F_cctx_internal_t(LZ4F_compressionContext);
freemem(cctxPtr.lz4CtxPtr);
freemem(cctxPtr.tmpBuff);
freemem(LZ4F_compressionContext);
result := cardinal(OK_NoError);
end;
function LZ4F_getFrameInfo(decompressionContext: PLZ4F_decompressionContext_t; frameInfoPtr: PLZ4F_frameInfo_t; const srcBuffer: pointer;
srcSizePtr: psize_t): LZ4F_errorCode_t;
var
dctxPtr: PLZ4F_dctx_internal_t;
errorCode: LZ4F_errorCode_t;
begin
dctxPtr := PLZ4F_dctx_internal_t(decompressionContext);
if dctxPtr.dStage = cardinal(dstage_getHeader) then
begin
errorCode := LZ4F_decodeHeader(dctxPtr, srcBuffer, srcSizePtr^);
if LZ4F_isError(errorCode) then
exit(errorCode);
srcSizePtr^ := errorCode;
frameInfoPtr^ := dctxPtr.frameInfo;
dctxPtr.srcExpect := Nil;
dctxPtr.dStage := cardinal(dstage_getCBlockSize);
exit(4);
end;
srcSizePtr^ := 0;
frameInfoPtr^ := dctxPtr.frameInfo;
result := 0;
end;
function LZ4F_freeDecompressionContext(LZ4F_decompressionContext: PLZ4F_decompressionContext_t): LZ4F_errorCode_t;
var
dctxPtr: PLZ4F_dctx_internal_t;
begin
dctxPtr := PLZ4F_dctx_internal_t(LZ4F_decompressionContext);
freemem(dctxPtr.tmpIn);
freemem(dctxPtr.tmpOutBuffer);
freemem(dctxPtr);
result := cardinal(OK_NoError);
end;
end.
================================================
FILE: lib/xedit/lz4/lz4frame_static.pas
================================================
(*
LZ4Delphi
Copyright (C) 2015, Jose Pascoa (atelierwebgm@gmail.com)
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
*************************************************************************
LZ4 - Fast LZ compression algorithm
xxHash - Fast Hash algorithm
LZ4 source repository : http://code.google.com/p/lz4/
xxHash source repository : http://code.google.com/p/xxhash/
Copyright (c) 2011-2014, Yann Collet
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following disclaimer
in the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************
*)
unit lz4frame_static;
{$POINTERMATH ON}
interface
uses Windows;
type
LZ4F_LIST_ERRORS = (
OK_NoError = 0,
ERROR_GENERIC,
ERROR_maxBlockSize_invalid,
ERROR_blockMode_invalid,
ERROR_contentChecksumFlag_invalid,
ERROR_compressionLevel_invalid,
ERROR_allocation_failed,
ERROR_srcSize_tooLarge,
ERROR_dstMaxSize_tooSmall,
ERROR_decompressionFailed,
ERROR_checksum_invalid,
ERROR_maxCode);
const
LZ4F_errorStrings : array[0..11] of AnsiString =
(
'OK_NoError',
'ERROR_GENERIC',
'ERROR_maxBlockSize_invalid',
'ERROR_blockMode_invalid',
'ERROR_contentChecksumFlag_invalid',
'ERROR_compressionLevel_invalid',
'ERROR_allocation_failed',
'ERROR_srcSize_tooLarge',
'ERROR_dstMaxSize_tooSmall',
'ERROR_decompressionFailed',
'ERROR_checksum_invalid',
'ERROR_maxCode'
);
implementation
end.
================================================
FILE: lib/xedit/lz4/lz4io.pas
================================================
(*
LZ4Delphi
Copyright (C) 2015, Jose Pascoa (atelierwebgm@gmail.com)
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
*************************************************************************
LZ4 - Fast LZ compression algorithm
xxHash - Fast Hash algorithm
LZ4 source repository : http://code.google.com/p/lz4/
xxHash source repository : http://code.google.com/p/xxhash/
Copyright (c) 2011-2014, Yann Collet
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following disclaimer
in the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************
*)
unit lz4io;
{$POINTERMATH ON}
interface
uses Windows, Classes, SysUtils, Math, lz4frame_static, xxHash, lz4, lz4common, lz4frame, lz4HC;
const
LZ4_BLOCKSIZEID_DEFAULT = 7;
ENDOFSTREAM = uint64(-1);
LZ4S_MAGICNUMBER = $184D2204;
LZ4S_SKIPPABLE0 = $184D2A50;
LZ4S_SKIPPABLEMASK = $FFFFFFF0;
LEGACY_MAGICNUMBER = $184C2102;
MAGICNUMBER_SIZE = 4;
LEGACY_BLOCKSIZE = 8388608;
MIN_STREAM_BUFSIZE = 196608;
var
lz4_overwrite_file: boolean = true;
globalblockSizeID: integer = LZ4_BLOCKSIZEID_DEFAULT;
blockIndependence: integer = 1;
streamChecksum: integer = 1;
function LZ4IO_compressFilename_Legacy(input_filename: string; output_filename: string; compressionLevel: integer): integer;
function LZ4IO_compressFilename(input_filename: string; output_filename: string; compressionLevel: integer): integer;
function LZ4IO_decompressFilename(input_filename: string; output_filename: string): integer;
procedure lz4DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer;
const OutBuf: Pointer; BufSize: Integer);
implementation
const
minBlockSizeID: integer = 4;
maxBlockSizeID: integer = 7;
function reportError(err: string): integer;
begin
//LZ4Client.Memo.Lines.Add(err);
result := 0;
end;
procedure LZ4IO_writeLE32(p: pointer; value32: cardinal);
var
dstPtr: pByte;
begin
dstPtr := p;
dstPtr[0] := byte(value32);
dstPtr[1] := byte(value32 shr 8);
dstPtr[2] := byte(value32 shr 16);
dstPtr[3] := byte(value32 shr 24);
end;
function LZ4IO_compressFilename_Legacy(input_filename: string; output_filename: string; compressionLevel: integer): integer;
type
TCompressionFunction =
function(c1: pAnsiChar; c2: pAnsiChar; c3: integer): integer;
var
compressionFunction: TCompressionFunction;
filesize: uint64;
compressedfilesize: uint64;
in_buff: pAnsiChar;
out_buff: pAnsiChar;
fileIn: TFileSTream;
fileOut: TFileSTream;
sizeCheck: size_t;
outSize, inSize: cardinal;
begin
filesize := 0;
compressedfilesize := MAGICNUMBER_SIZE;
if (compressionLevel < 3) then
compressionFunction := LZ4_compress
else
compressionFunction := LZ4_compressHC;
fileIn := TFileSTream.Create(input_filename, fmOpenRead);
fileOut := TFileSTream.Create(output_filename, fmCreate);
in_buff := allocmem(LEGACY_BLOCKSIZE);
out_buff := allocmem(LZ4_compressBound(LEGACY_BLOCKSIZE));
try
if (in_buff = nil) or (out_buff = nil) then
exit(reportError('Allocation error : not enough memory'));
LZ4IO_writeLE32(out_buff, LEGACY_MAGICNUMBER);
sizeCheck := fileOut.Write(out_buff^, MAGICNUMBER_SIZE);
if sizeCheck <> MAGICNUMBER_SIZE then
exit(reportError('Write error : cannot write header'));
while true do
begin
inSize := fileIn.Read(in_buff^, LEGACY_BLOCKSIZE);
if inSize <= 0 then
break;
inc(filesize, inSize);
outSize := compressionFunction(in_buff, out_buff + 4, inSize);
inc(compressedfilesize, outSize + 4);
LZ4IO_writeLE32(out_buff, outSize);
sizeCheck := fileOut.Write(out_buff^, outSize + 4);
if sizeCheck <> size_t(outSize + 4) then
exit(reportError('Write error : cannot write compressed block'));
end;
finally
if in_buff <> nil then
freemem(in_buff);
if out_buff <> nil then
freemem(out_buff);
fileIn.Free;
fileOut.Free;
result := 0;
end;
end;
function LZ4IO_setBlockSizeID(bsid: integer): integer;
const
blockSizeTable: array [0 .. 3] of integer = (65536, 262144, 1048576, 4194304);
begin
if (bsid < minBlockSizeID) or (bsid > maxBlockSizeID) then
exit(-1);
globalblockSizeID := bsid;
result := blockSizeTable[globalblockSizeID - minBlockSizeID];
end;
function LZ4IO_compressFilename(input_filename: string; output_filename: string; compressionLevel: integer): integer;
var
filesize: uint64;
errorCode: LZ4F_errorCode_t;
ctx: PLZ4F_compressionContext_t;
blockSize: integer;
fileIn: TFileSTream;
fileOut: TFileSTream;
prefs: LZ4F_preferences_t;
in_buff: pAnsiChar;
out_buff: pAnsiChar;
outBuffSize: size_t;
headerSize: size_t;
sizeCheck: size_t;
readSize: size_t;
outSize: size_t;
begin
result := 0;
filesize := 0;
errorCode := LZ4F_createCompressionContext(ctx, LZ4F_VERSION);
if (LZ4F_isError(errorCode)) then
exit(reportError(format('Allocation error : can''t create LZ4F context: %s', [LZ4F_getErrorName(errorCode)])));
fileIn := TFileSTream.Create(input_filename, fmOpenRead);
fileOut := TFileSTream.Create(output_filename, fmCreate);
blockSize := 1 shl (8 + 2 * globalblockSizeID);
fillchar(prefs, sizeof(LZ4F_preferences_t), 0);
prefs.autoFlush := 1;
prefs.compressionLevel := compressionLevel;
prefs.frameInfo.blockMode := blockMode_t(blockIndependence);
prefs.frameInfo.blockSizeID := blockSizeID_t(globalblockSizeID);
prefs.frameInfo.contentChecksumFlag := contentChecksum_t(streamChecksum);
// Allocate Memory
in_buff := allocmem(blockSize);
outBuffSize := LZ4F_compressBound(blockSize, @prefs);
out_buff := allocmem(outBuffSize);
try
if (in_buff = nil) or (out_buff = nil) then
exit(reportError('Allocation error : not enough memory'));
// Write Archive Header
headerSize := LZ4F_compressBegin(ctx, out_buff, outBuffSize, @prefs);
if (LZ4F_isError(headerSize)) then
exit(reportError(format('File header generation failed: %s', [LZ4F_getErrorName(errorCode)])));
sizeCheck := fileOut.Write(out_buff^, headerSize);
if sizeCheck <> headerSize then
exit(reportError('Write error : cannot write header'));
readSize := fileIn.Read(in_buff^, blockSize);
inc(filesize, readSize);
while readSize > 0 do
begin
outSize := LZ4F_compressUpdate(ctx, out_buff, outBuffSize, in_buff, readSize, Nil);
if (LZ4F_isError(outSize)) then
exit(reportError(format('Compression failed: %s', [LZ4F_getErrorName(errorCode)])));
sizeCheck := fileOut.Write(out_buff^, outSize);
if sizeCheck <> outSize then
exit(reportError('Write error : cannot write compressed block'));
readSize := fileIn.Read(in_buff^, blockSize);
inc(filesize, readSize);
end;
// End of Stream mark
headerSize := LZ4F_compressEnd(ctx, out_buff, outBuffSize, Nil);
if LZ4F_isError(headerSize) then
exit(reportError(format('End of file generation failed: %s', [LZ4F_getErrorName(errorCode)])));
sizeCheck := fileOut.Write(out_buff^, headerSize);
if sizeCheck <> headerSize then
exit(reportError('Write error : cannot write end of stream'));
errorCode := LZ4F_freeCompressionContext(ctx);
if LZ4F_isError(errorCode) then
exit(reportError(format('Error : can''t free LZ4F context resource: %s', [LZ4F_getErrorName(errorCode)])));
finally
if in_buff <> nil then
freemem(in_buff);
if out_buff <> nil then
freemem(out_buff);
fileIn.Free;;
fileOut.Free;
end;
end;
function LZ4IO_readLE32(s: pointer): cardinal;
var
srcPtr: pByte;
value32: cardinal;
begin
srcPtr := s;
value32 := srcPtr[0];
inc(value32, (srcPtr[1] shl 8));
inc(value32, (srcPtr[2] shl 16));
inc(value32, (srcPtr[3] shl 24));
result := value32;
end;
function LZ4S_isSkippableMagicNumber(magic: cardinal): boolean;
begin
result := (magic and LZ4S_SKIPPABLEMASK) = LZ4S_SKIPPABLE0;
end;
function decodeLZ4S(finput, foutput: TSTream): uint64;
const
HEADERMAX = 20;
var
filesize: uint64;
inBuff: pAnsiChar;
outBuff: pAnsiChar;
headerBuff: array [0 .. HEADERMAX - 1] of ansiChar;
sizeCheck, nextToRead, outBuffSize, inBuffSize: size_t;
ctx: PLZ4F_decompressionContext_t;
errorCode: LZ4F_errorCode_t;
frameInfo: LZ4F_frameInfo_t;
decodedBytes: size_t;
begin
filesize := 0;
errorCode := LZ4F_createDecompressionContext(ctx, LZ4F_VERSION);
if LZ4F_isError(errorCode) then
exit(reportError(format('Allocation error : can''t create context: %s', [LZ4F_getErrorName(errorCode)])));
LZ4IO_writeLE32(@headerBuff, LZ4S_MAGICNUMBER);
outBuffSize := 0;
inBuffSize := 0;
sizeCheck := MAGICNUMBER_SIZE;
nextToRead := LZ4F_decompress(ctx, Nil, @outBuffSize, @headerBuff, @sizeCheck, Nil);
if LZ4F_isError(nextToRead) then
exit(reportError(format('Decompression error: %s', [LZ4F_getErrorName(errorCode)])));
if nextToRead > HEADERMAX then
exit(reportError(format('Header too large (%d>%d)', [integer(nextToRead), HEADERMAX])));
sizeCheck := finput.Read(headerBuff, nextToRead);
if sizeCheck <> nextToRead then
exit(reportError('Read error'));
nextToRead := LZ4F_decompress(ctx, Nil, @outBuffSize, @headerBuff, @sizeCheck, Nil);
errorCode := LZ4F_getFrameInfo(ctx, @frameInfo, Nil, @inBuffSize);
if LZ4F_isError(errorCode) then
exit(reportError(format('can''t decode frame header: %s', [LZ4F_getErrorName(errorCode)])));
outBuffSize := LZ4IO_setBlockSizeID(integer(frameInfo.blockSizeID));
inBuffSize := outBuffSize + 4;
inBuff := allocmem(inBuffSize);
outBuff := allocmem(outBuffSize);
try
if (inBuff = nil) or (outBuff = nil) then
exit(reportError('Allocation error : not enough memory'));
while (nextToRead <> 0) do
begin
decodedBytes := outBuffSize;
sizeCheck := finput.Read(inBuff^, nextToRead);
if sizeCheck <> nextToRead then
exit(reportError('Read error'));
errorCode := LZ4F_decompress(ctx, outBuff, @decodedBytes, inBuff, @sizeCheck, Nil);
if LZ4F_isError(errorCode) then
exit(reportError(format('Decompression error: %s', [LZ4F_getErrorName(errorCode)])));
if sizeCheck <> nextToRead then
exit(reportError('Synchronization error'));
nextToRead := errorCode;
inc(filesize, decodedBytes);
sizeCheck := foutput.Write(outBuff^, decodedBytes);
if sizeCheck <> decodedBytes then
exit(reportError('Write error : cannot write decoded block'));
end;
errorCode := LZ4F_freeDecompressionContext(ctx);
if LZ4F_isError(errorCode) then
exit(reportError(format('Error : can''t free LZ4F context resource: %s', [LZ4F_getErrorName(errorCode)])));
finally
if inBuff <> nil then
freemem(inBuff);
if outBuff <> nil then
freemem(outBuff);
result := filesize;
end;
end;
function decodeLegacyStream(finput, foutput: TSTream): uint64;
var
filesize: uint64;
in_buff: pAnsiChar;
out_buff: pAnsiChar;
decodeSize: integer;
sizeCheck: size_t;
blockSize: cardinal;
begin
filesize := 0;
in_buff := allocmem(LZ4_compressBound(LEGACY_BLOCKSIZE));
out_buff := allocmem(LEGACY_BLOCKSIZE);
try
if (in_buff = nil) or (out_buff = nil) then
exit(reportError('Allocation error : not enough memory'));
while true do
begin
sizeCheck := finput.Read(in_buff^, 4);
if sizeCheck = 0 then
break;
blockSize := LZ4IO_readLE32(in_buff);
if blockSize > LZ4_compressBound(LEGACY_BLOCKSIZE) then
begin
finput.Seek(-4, soFromCurrent);
break;
end;
sizeCheck := finput.Read(in_buff^, blockSize);
if sizeCheck <> blockSize then
exit(reportError('Error reading input file'));
decodeSize := LZ4_decompress_safe(in_buff, out_buff, blockSize, LEGACY_BLOCKSIZE);
if (decodeSize < 0) then
exit(reportError('Decoding Failed ! Corrupted input detected'));
inc(filesize, decodeSize);
sizeCheck := foutput.Write(out_buff^, decodeSize);
if sizeCheck <> size_t(decodeSize) then
exit(reportError('Write error : cannot write decoded block into output'));
end;
finally
if in_buff <> nil then
freemem(in_buff);
if out_buff <> nil then
freemem(out_buff);
result := filesize;
end;
end;
function selectDecoder(finput, foutput: TSTream): uint64;
var
nbReadBytes: size_t;
U32Store: array [0 .. MAGICNUMBER_SIZE - 1] of byte;
magicNumber, Size: cardinal;
newPos: uint64;
begin
nbReadBytes := finput.Read(U32Store, MAGICNUMBER_SIZE);
if nbReadBytes = 0 then
exit(ENDOFSTREAM);
if nbReadBytes <> MAGICNUMBER_SIZE then
exit(reportError('Unrecognized header : Magic Number unreadable'));
magicNumber := LZ4IO_readLE32(@U32Store);
if LZ4S_isSkippableMagicNumber(magicNumber) then
magicNumber := LZ4S_SKIPPABLE0;
case magicNumber of
LZ4S_MAGICNUMBER: result := decodeLZ4S(finput, foutput);
LEGACY_MAGICNUMBER:
begin
result := decodeLegacyStream(finput, foutput);
end;
LZ4S_SKIPPABLE0:
begin
nbReadBytes := finput.Read(U32Store, 4);
if (nbReadBytes <> 4) then
exit(reportError('Stream error : skippable size unreadable'));
Size := LZ4IO_readLE32(@U32Store);
newPos := finput.Seek(Size, soFromCurrent);
if newPos <> finput.Position then
exit(reportError('Stream error : cannot skip skippable area'));
result := selectDecoder(finput, foutput);
end;
else
begin
if finput.Position = MAGICNUMBER_SIZE then
exit(reportError('Unrecognized header : file cannot be decoded'));
reportError('Stream followed by unrecognized data');
result := ENDOFSTREAM;
end;
end;
end;
function LZ4IO_decompressFilename(input_filename: string; output_filename: string): integer;
var
fileIn: TFileSTream;
fileOut: TFileSTream;
decodedSize: int64;
filesize: int64;
begin
result := 0;
filesize := 0;
fileIn := TFileSTream.Create(input_filename, fmOpenRead);
fileOut := TFileSTream.Create(output_filename, fmCreate);
repeat
decodedSize := selectDecoder(fileIn, fileOut);
if decodedSize <> ENDOFSTREAM then
inc(filesize, decodedSize);
until decodedSize = ENDOFSTREAM;
fileIn.Free;;
fileOut.Free;
end;
type
TPreallocatedMemoryStream = class(TCustomMemoryStream)
public
constructor Create(Ptr: Pointer; Size: Int64);
function Write(const Buffer; Count: Longint): Longint; override;
end;
constructor TPreallocatedMemoryStream.Create(Ptr: Pointer; Size: Int64);
begin
inherited Create;
SetPointer(Ptr, Size);
end;
function TPreallocatedMemoryStream.Write(const Buffer; Count: Integer): Longint;
begin
Result := Min(Count, Size-Position);
System.Move(Buffer, Pointer(PByte(Memory) + Position)^, Result);
Seek(Result, soCurrent);
end;
procedure lz4DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer;
const OutBuf: Pointer; BufSize: Integer);
var
stin, stout: TPreallocatedMemoryStream;
decodedSize: int64;
decompressedSize: int64;
begin
stin := TPreallocatedMemoryStream.Create(InBuf, InBytes);
stout := TPreallocatedMemoryStream.Create(OutBuf, BufSize);
try
decompressedSize := 0;
repeat
decodedSize := selectDecoder(stin, stout);
if decodedSize <> ENDOFSTREAM then
Inc(decompressedSize, decodedSize);
until decodedSize = ENDOFSTREAM;
if decompressedSize <> BufSize then
Exception.Create('lz4 decompression size mismatch');
//Move(stout.Memory^, OutBuf^, BufSize);
finally
stin.Free;
stout.Free;
end;
end;
end.
================================================
FILE: lib/xedit/lz4/xxHash.pas
================================================
(*
LZ4Delphi
Copyright (C) 2015, Jose Pascoa (atelierwebgm@gmail.com)
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
*************************************************************************
LZ4 - Fast LZ compression algorithm
xxHash - Fast Hash algorithm
LZ4 source repository : http://code.google.com/p/lz4/
xxHash source repository : http://code.google.com/p/xxhash/
Copyright (c) 2011-2014, Yann Collet
BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following disclaimer
in the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************
*)
unit xxHash;
{$POINTERMATH ON}
interface
uses Windows, lz4common;
const
PRIME32_1: cardinal = 2654435761;
PRIME32_2: cardinal = 2246822519;
PRIME32_3: cardinal = 3266489917;
PRIME32_4: cardinal = 668265263;
PRIME32_5: cardinal = 374761393;
PRIME64_1: uint64 = 11400714785074694791;
PRIME64_2: uint64 = 14029467366897019727;
PRIME64_3: uint64 = 1609587929392839161;
PRIME64_4: uint64 = 9650029242287828579;
PRIME64_5: uint64 = 2870177450012600261;
type
XXH_errorcode = (XXH_OK = 0, XXH_ERROR);
XXH_endianess = (XXH_bigEndian = 0, XXH_littleEndian = 1);
XXH_alignment = (XXH_aligned, XXH_unaligned);
PXXH32_state_t = ^XXH32_state_t;
XXH32_state_t = record
ll: array [0 .. 5] of int64;
end;
PXXH_istate32_t = ^XXH_istate32_t;
XXH_istate32_t = record
total_len: uint64;
seed: cardinal;
v1: cardinal;
v2: cardinal;
v3: cardinal;
v4: cardinal;
mem32: array [0 .. 3] of cardinal;
memsize: cardinal;
end;
PXXH64_state_t = ^XXH64_state_t;
XXH64_state_t = record
ll: array [0 .. 10] of int64;
end;
PXXH_istate64_t = ^XXH_istate64_t;
XXH_istate64_t = record
total_len: uint64;
seed: uint64;
v1: uint64;
v2: uint64;
v3: uint64;
v4: uint64;
mem64: array [0 .. 3] of uint64;
memsize: cardinal;
end;
function XXH32(input: pointer; len: size_t; seed: cardinal): cardinal;
function XXH32_reset(statePtr: PXXH32_state_t; seed: cardinal): XXH_errorcode;
function XXH32_update(statePtr: PXXH32_state_t; Ainput: pointer; ALength: size_t): XXH_errorcode;
function XXH32_digest(statePtr: PXXH32_state_t): cardinal;
function XXH32_createState: PXXH32_state_t;
procedure XXH32_freeState(statePtr: PXXH32_state_t);
// Obsolet in recent release
function XXH32_init(seed: cardinal): PXXH32_state_t;
function XXH64_reset(statePtr: PXXH64_state_t; seed: uint64): XXH_errorcode;
function XXH64_update(statePtr: PXXH64_state_t; Ainput: pointer; ALength: size_t): XXH_errorcode;
function XXH64_digest(statePtr: PXXH64_state_t): uint64;
function XXH64_createState: PXXH64_state_t;
procedure XXH64_freeState(statePtr: PXXH64_state_t);
// Obsolet in recent release
function XXH64_init(seed: uint64): PXXH64_state_t;
implementation
type
PU32_S = ^U32_S;
U32_S = packed record
v: cardinal;
end;
PU64_S = ^U64_S;
U64_S = packed record
v: uint64;
end;
function XXH_rotl32(x, r: cardinal): cardinal;
asm
mov eax, x
mov ecx, r
rol eax, cl
end;
(* Alternative
function XXH_rotl32(x, r: cardinal): cardinal; inline;
var
temp: cardinal;
begin
temp := x;
result := (x shl r) or (temp shr (32 - r));
end;
*)
{$IFDEF CPUX64}
function XXH_rotl64(x: uint64; r: cardinal): uint64;
asm
mov rax, x
mov ecx, r
rol rax, cl
end;
{$ELSE}
function XXH_rotl64(x: uint64; r: cardinal): uint64; inline
var
temp: uint64;
begin
temp := x;
result := (x shl r) or (temp shr (64 - r));
end;
{$ENDIF}
function A32(x: pointer): cardinal; inline;
begin
result := PU32_S(x).v;
end;
function A64(x: pointer): uint64; inline;
begin
result := PU64_S(x).v;
end;
function XXH_readLE32_align(ptr: pointer; endian: XXH_endianess; align: XXH_alignment): cardinal; inline;
begin
if align = XXH_unaligned then
result := A32(ptr)
else
result := pcardinal(ptr)^;
end;
function XXH_readLE32(ptr: pointer): cardinal; inline;
begin
result := XXH_readLE32_align(ptr, XXH_littleEndian, XXH_unaligned);
end;
function XXH_readLE64_align(ptr: pointer; endian: XXH_endianess; align: XXH_alignment): uint64; inline;
begin
if align = XXH_unaligned then
result := A64(ptr)
else
result := puint64(ptr)^;
end;
function XXH_readLE64(ptr: pointer): uint64; inline;
begin
result := XXH_readLE64_align(ptr, XXH_littleEndian, XXH_unaligned);
end;
function XXH32_reset(statePtr: PXXH32_state_t; seed: cardinal): XXH_errorcode;
var
state: PXXH_istate32_t;
begin
state := PXXH_istate32_t(statePtr);
state.seed := seed;
state.v1 := seed + PRIME32_1 + PRIME32_2;
state.v2 := seed + PRIME32_2;
state.v3 := seed + 0;
state.v4 := seed - PRIME32_1;
state.total_len := 0;
state.memsize := 0;
result := XXH_OK;
end;
function XXH64_reset(statePtr: PXXH64_state_t; seed: uint64): XXH_errorcode;
var
state: PXXH_istate64_t;
begin
state := PXXH_istate64_t(statePtr);
state.seed := seed;
state.v1 := seed + PRIME64_1 + PRIME64_2;
state.v2 := seed + PRIME64_2;
state.v3 := seed + 0;
state.v4 := seed - PRIME64_1;
state.total_len := 0;
state.memsize := 0;
result := XXH_OK;
end;
function XXH32_update(statePtr: PXXH32_state_t; Ainput: pointer; ALength: size_t): XXH_errorcode;
var
state: PXXH_istate32_t;
p: pByte;
bEnd: pByte;
p32: pcardinal;
limit: pByte;
v1, v2, v3, v4: cardinal;
begin
state := PXXH_istate32_t(statePtr);
p := Ainput;
bEnd := p + ALength;
inc(state.total_len, ALength);
if (state.memsize + ALength < 16) then
begin
move(Ainput^, (pByte(@state.mem32) + state.memsize)^, ALength);
inc(state.memsize, cardinal(ALength));
exit(XXH_OK);
end;
if state.memsize > 0 then
begin
move(Ainput^, (pByte(@state.mem32) + state.memsize)^, 16 - state.memsize);
p32 := @state.mem32;
inc(state.v1, XXH_readLE32(p32) * PRIME32_2);
state.v1 := XXH_rotl32(state.v1, 13);
state.v1 := state.v1 * PRIME32_1;
inc(p32);
inc(state.v2, XXH_readLE32(p32) * PRIME32_2);
state.v2 := XXH_rotl32(state.v2, 13);
state.v2 := state.v2 * PRIME32_1;
inc(p32);
inc(state.v3, XXH_readLE32(p32) * PRIME32_2);
state.v3 := XXH_rotl32(state.v3, 13);
state.v3 := state.v3 * PRIME32_1;
inc(p32);
inc(state.v4, XXH_readLE32(p32) * PRIME32_2);
state.v4 := XXH_rotl32(state.v4, 13);
state.v4 := state.v4 * PRIME32_1;
// inc(p32);
inc(p, 16 - state.memsize);
state.memsize := 0;
end;
if p <= (bEnd - 16) then
begin
limit := bEnd - 16;
v1 := state.v1;
v2 := state.v2;
v3 := state.v3;
v4 := state.v4;
repeat
inc(v1, XXH_readLE32(p) * PRIME32_2);
v1 := XXH_rotl32(v1, 13);
v1 := v1 * PRIME32_1;
inc(p, 4);
inc(v2, XXH_readLE32(p) * PRIME32_2);
v2 := XXH_rotl32(v2, 13);
v2 := v2 * PRIME32_1;
inc(p, 4);
inc(v3, XXH_readLE32(p) * PRIME32_2);
v3 := XXH_rotl32(v3, 13);
v3 := v3 * PRIME32_1;
inc(p, 4);
inc(v4, XXH_readLE32(p) * PRIME32_2);
v4 := XXH_rotl32(v4, 13);
v4 := v4 * PRIME32_1;
inc(p, 4);
until p > limit;
state.v1 := v1;
state.v2 := v2;
state.v3 := v3;
state.v4 := v4;
end;
if p < bEnd then
begin
move(p^, state.mem32, bEnd - p);
state.memsize := integer(bEnd - p);
end;
result := XXH_OK;
end;
function XXH64_update(statePtr: PXXH64_state_t; Ainput: pointer; ALength: size_t): XXH_errorcode;
var
state: PXXH_istate64_t;
p: pByte;
bEnd: pByte;
p64: puint64;
limit: pByte;
v1, v2, v3, v4: uint64;
begin
state := PXXH_istate64_t(statePtr);
p := Ainput;
bEnd := p + ALength;
inc(state.total_len, ALength);
if (state.memsize + ALength < 32) then
begin
move(Ainput^, (pByte(@state.mem64) + state.memsize)^, ALength);
inc(state.memsize, cardinal(ALength));
exit(XXH_OK);
end;
if state.memsize > 0 then
begin
move(Ainput^, (pByte(@state.mem64) + state.memsize)^, 32 - state.memsize);
p64 := @state.mem64;
inc(state.v1, XXH_readLE64(p64) * PRIME64_2);
state.v1 := XXH_rotl64(state.v1, 31);
state.v1 := state.v1 * PRIME64_1;
inc(p64);
inc(state.v2, XXH_readLE64(p64) * PRIME64_2);
state.v2 := XXH_rotl64(state.v2, 31);
state.v2 := state.v2 * PRIME64_1;
inc(p64);
inc(state.v3, XXH_readLE64(p64) * PRIME64_2);
state.v3 := XXH_rotl64(state.v3, 31);
state.v3 := state.v3 * PRIME64_1;
inc(p64);
inc(state.v4, XXH_readLE64(p64) * PRIME64_2);
state.v4 := XXH_rotl64(state.v4, 31);
state.v4 := state.v4 * PRIME64_1;
inc(p, 32 - state.memsize);
state.memsize := 0;
end;
if (p + 32) <= bEnd then
begin
limit := bEnd - 32;
v1 := state.v1;
v2 := state.v2;
v3 := state.v3;
v4 := state.v4;
repeat
inc(v1, XXH_readLE64(p) * PRIME64_2);
v1 := XXH_rotl64(v1, 31);
v1 := v1 * PRIME64_1;
inc(p, 8);
inc(v2, XXH_readLE64(p) * PRIME64_2);
v2 := XXH_rotl64(v2, 31);
v2 := v2 * PRIME64_1;
inc(p, 8);
inc(v3, XXH_readLE64(p) * PRIME64_2);
v3 := XXH_rotl64(v3, 31);
v3 := v3 * PRIME64_1;
inc(p, 8);
inc(v4, XXH_readLE64(p) * PRIME64_2);
v4 := XXH_rotl64(v4, 31);
v4 := v4 * PRIME64_1;
inc(p, 8);
until p > limit;
state.v1 := v1;
state.v2 := v2;
state.v3 := v3;
state.v4 := v4;
end;
if p < bEnd then
begin
move(p^, state.mem64, bEnd - p);
state.memsize := integer(bEnd - p);
end;
result := XXH_OK;
end;
function XXH32_digest(statePtr: PXXH32_state_t): cardinal;
var
state: PXXH_istate32_t;
p: pByte;
bEnd: pByte;
h32: cardinal;
begin
state := PXXH_istate32_t(statePtr);
p := @state.mem32;
bEnd := pByte(@state.mem32) + state.memsize;
if (state.total_len >= 16) then
h32 := XXH_rotl32(state.v1, 1) + XXH_rotl32(state.v2, 7) + XXH_rotl32(state.v3, 12) + XXH_rotl32(state.v4, 18)
else
h32 := state.seed + PRIME32_5;
inc(h32, state.total_len);
while (p + 4) <= bEnd do
begin
inc(h32, XXH_readLE32(p) * PRIME32_3);
h32 := XXH_rotl32(h32, 17) * PRIME32_4;
inc(p, 4);
end;
while p < bEnd do
begin
inc(h32, p^ * PRIME32_5);
h32 := XXH_rotl32(h32, 11) * PRIME32_1;
inc(p);
end;
h32 := h32 xor (h32 shr 15);
h32 := h32 * PRIME32_2;
h32 := h32 xor (h32 shr 13);
h32 := h32 * PRIME32_3;
h32 := h32 xor (h32 shr 16);
result := h32;
end;
function XXH64_digest(statePtr: PXXH64_state_t): uint64;
var
state: PXXH_istate64_t;
p: pByte;
bEnd: pByte;
h64: uint64;
v1, v2, v3, v4: uint64;
k1: uint64;
begin
state := PXXH_istate64_t(statePtr);
p := @state.mem64;
bEnd := pByte(@state.mem64) + state.memsize;
if state.total_len >= 32 then
begin
v1 := state.v1;
v2 := state.v2;
v3 := state.v3;
v4 := state.v4;
h64 := XXH_rotl64(v1, 1) + XXH_rotl64(v2, 7) + XXH_rotl64(v3, 12) + XXH_rotl64(v4, 18);
v1 := v1 * PRIME64_2;
v1 := XXH_rotl64(v1, 31);
v1 := v1 * PRIME64_1;
h64 := h64 xor v1;
h64 := h64 * PRIME64_1 + PRIME64_4;
v2 := v2 * PRIME64_2;
v2 := XXH_rotl64(v2, 31);
v2 := v2 * PRIME64_1;
h64 := h64 xor v2;
h64 := h64 * PRIME64_1 + PRIME64_4;
v3 := v3 * PRIME64_2;
v3 := XXH_rotl64(v3, 31);
v3 := v3 * PRIME64_1;
h64 := h64 xor v3;
h64 := h64 * PRIME64_1 + PRIME64_4;
v4 := v4 * PRIME64_2;
v4 := XXH_rotl64(v4, 31);
v4 := v4 * PRIME64_1;
h64 := h64 xor v4;
h64 := h64 * PRIME64_1 + PRIME64_4;
end
else
h64 := state.seed + PRIME64_5;
inc(h64, state.total_len);
while (p + 8) <= bEnd do
begin
k1 := XXH_readLE64(p);
k1 := k1 * PRIME64_2;
k1 := XXH_rotl64(k1, 31);
k1 := k1 * PRIME64_1;
h64 := h64 xor k1;
h64 := XXH_rotl64(h64, 27) * PRIME64_1 + PRIME64_4;
inc(p, 8);
end;
if (p + 4) <= bEnd then
begin
h64 := h64 xor (uint64(XXH_readLE32(p)) * PRIME64_1);
h64 := XXH_rotl64(h64, 23) * PRIME64_2 + PRIME64_3;
inc(p, 4);
end;
while (p < bEnd) do
begin
h64 := h64 xor (p^ * PRIME64_5);
h64 := XXH_rotl64(h64, 11) * PRIME64_1;
inc(p);
end;
h64 := h64 xor (h64 shr 33);
h64 := h64 * PRIME64_2;
h64 := h64 xor (h64 shr 29);
h64 := h64 * PRIME64_3;
h64 := h64 xor (h64 shr 32);
result := h64;
end;
function XXH32_createState: PXXH32_state_t;
begin
result := allocmem(sizeof(XXH32_state_t));
end;
function XXH64_createState: PXXH64_state_t;
begin
result := allocmem(sizeof(XXH64_state_t));
end;
procedure XXH32_freeState(statePtr: PXXH32_state_t);
begin
freemem(statePtr);
end;
procedure XXH64_freeState(statePtr: PXXH64_state_t);
begin
freemem(statePtr);
end;
function XXH32_init(seed: cardinal): PXXH32_state_t;
begin
result := XXH32_createState;
XXH32_reset(result, seed);
end;
function XXH64_init(seed: uint64): PXXH64_state_t;
begin
result := XXH64_createState;
XXH64_reset(result, seed);
end;
function XXH32_endian_align(input: pointer; len: size_t; seed: cardinal; endian: XXH_endianess; align: XXH_alignment): cardinal;
function XXH_get32bits(p: pByte): cardinal;
begin
result := XXH_readLE32_align(p, endian, align);
end;
var
p: pByte;
bEnd: pByte;
h32: cardinal;
limit: pByte;
v1, v2, v3, v4: cardinal;
begin
p := input;
bEnd := p + len;
if (len >= 16) then
begin
limit := bEnd - 16;
v1 := seed + PRIME32_1 + PRIME32_2;
v2 := seed + PRIME32_2;
v3 := seed + 0;
v4 := seed - PRIME32_1;
while true do
begin
inc(v1, XXH_get32bits(p) * PRIME32_2);
v1 := XXH_rotl32(v1, 13);
v1 := v1 * PRIME32_1;
inc(p, 4);
inc(v2, XXH_get32bits(p) * PRIME32_2);
v2 := XXH_rotl32(v2, 13);
v2 := v2 * PRIME32_1;
inc(p, 4);
inc(v3, XXH_get32bits(p) * PRIME32_2);
v3 := XXH_rotl32(v3, 13);
v3 := v3 * PRIME32_1;
inc(p, 4);
inc(v4, XXH_get32bits(p) * PRIME32_2);
v4 := XXH_rotl32(v4, 13);
v4 := v4 * PRIME32_1;
inc(p, 4);
if p > limit then
break;
end;
h32 := XXH_rotl32(v1, 1) + XXH_rotl32(v2, 7) + XXH_rotl32(v3, 12) + XXH_rotl32(v4, 18);
end
else
h32 := seed + PRIME32_5;
inc(h32, cardinal(len));
while (p + 4 <= bEnd) do
begin
inc(h32, XXH_get32bits(p) * PRIME32_3);
h32 := XXH_rotl32(h32, 17) * PRIME32_4;
inc(p, 4);
end;
while (p < bEnd) do
begin
inc(h32, p^ * PRIME32_5);
h32 := XXH_rotl32(h32, 11) * PRIME32_1;
inc(p);
end;
h32 := h32 xor (h32 shr 15);
h32 := h32 * PRIME32_2;
h32 := h32 xor (h32 shr 13);
h32 := h32 * PRIME32_3;
h32 := h32 xor (h32 shr 16);
result := h32;
end;
function XXH32(input: pointer; len: size_t; seed: cardinal): cardinal;
begin
result := XXH32_endian_align(input, len, seed, XXH_littleEndian, XXH_unaligned);
end;
end.
================================================
FILE: lib/xedit/wbBSA.pas
================================================
{*******************************************************************************
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in
compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/
Software distributed under the License is distributed on an "AS IS"
basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
License for the specific language governing rights and limitations
under the License.
*******************************************************************************}
unit wbBSA;
{$I wbDefines.inc}
interface
uses
Classes, SysUtils, IOUtils,
wbInterface,
ImagingDds;
function wbCreateContainerHandler: IwbContainerHandler;
implementation
uses
wbStreams,
zlibEx,
lz4io;
const
{ https://github.com/Ethatron/bsaopt/blob/master/io/bsa.C }
BSAHEADER_VERSION_OB = $67; // Oblivion
BSAHEADER_VERSION_SK = $68; // Fallout3, Skyrim
BSAHEADER_VERSION_SSE = $69; // Skyrim Special Edition
BSAARCHIVE_COMPRESSFILES = $0004; // Whether the files are compressed in archive (invert file's compression flag)
BSAARCHIVE_PREFIXFULLFILENAMES = $0100; // Whether the name is prefixed to the data?
BSAFILE_COMPRESS = $40000000; // Whether the file is compressed
{ https://github.com/jonwd7/bae/blob/master/src/bsa.h }
BA2HEADER_VERSION_FO4 = $01; // Fallout 4
type
TwbContainerHandler = class(TInterfacedObject, IwbContainerHandler)
private
chContainers: array of IwbResourceContainer;
protected
procedure AddContainer(const aContainer: IwbResourceContainer);
{---IwbContainerHandler---}
procedure AddFolder(const aPath: string);
procedure AddBSA(const aFileName: string);
procedure AddBA2(const aFileName: string);
function OpenResource(const aFileName: string): TDynResources;
function OpenResourceData(const aContainerName, aFileName: string): TBytes;
function ContainerExists(aContainerName: string): Boolean;
procedure ContainerList(const aList: TStrings);
procedure ContainerResourceList(const aContainerName: string; const aList: TStrings;
const aFolder: string = '');
function ResourceExists(const aFileName: string): Boolean;
function ResolveHash(const aHash: Int64): TDynStrings;
function ResourceCount(const aFileName: string; aContainers: TStrings = nil): Integer;
procedure ResourceCopy(const aContainerName, aFileName, aPathOut: string);
end;
TwbBSAFileRec = record
Name : string;
Hash : Int64;
Size : Cardinal;
Offset : Cardinal;
end;
TwbBSAFolderRec = record
Name : string;
Hash : Int64;
Files : array of TwbBSAFileRec;
Map : TStringList;
end;
IwbBSAFileInternal = interface(IwbBSAFile)
['{A360B348-8F6B-4FC1-A869-9D5B833DCA5F}']
function GetData(aOffset, aSize: Cardinal): TBytes;
end;
TwbBSAFile = class(TInterfacedObject, IwbResourceContainer, IwbBSAFile, IwbBSAFileInternal)
private
bfStream : TwbReadOnlyCachedFileStream;
bfFileName : string;
bfVersion : Cardinal;
bfOffset : Cardinal;
bfFlags : Cardinal;
bfFileFlags : Cardinal;
bfFolders : array of TwbBSAFolderRec;
bfFolderMap : TStringList;
procedure ReadDirectory;
protected
{---IwbResourceContainer---}
function GetName: string;
function OpenResource(const aFileName: string): IwbResource;
function ResourceExists(const aFileName: string): Boolean;
procedure ResourceList(const aList: TStrings; const aFolder: string = '');
procedure ResolveHash(const aHash: Int64; var Results: TDynStrings);
{---IwbBSAFile---}
function GetFileName: string;
{---IwbBSAFileInternal---}
function GetData(aOffset, aSize: Cardinal):TBytes;
public
constructor Create(const aFileName: string);
destructor Destroy; override;
end;
TwbBSAResource = class(TInterfacedObject, IwbResource)
brFile : IwbBSAFileInternal;
brOffset : Cardinal;
brSize : Cardinal;
protected
{---IwbResource---}
function GetContainer: IwbResourceContainer;
function GetData: TBytes;
public
constructor Create(aFile: TwbBSAFile; aSize, aOffset: Cardinal);
end;
TwbBA2TexChunkRec = record
Size : Cardinal;
PackedSize : Cardinal;
Offset : Int64;
StartMip : Word;
EndMip : Word;
end;
TwbBA2FileRec = record
Name : string;
NameHash : Cardinal;
DirHash : Cardinal;
Size : Cardinal;
PackedSize : Cardinal;
Offset : Int64;
Height : Word;
Width : Word;
NumMips : Byte;
DXGIFormat : Byte;
CubeMaps : Word;
TexChunks : array of TwbBA2TexChunkRec;
end;
IwbBA2FileInternal = interface(IwbBA2File)
['{87D66150-746E-4B37-B295-45C4221CDCBE}']
procedure ReadData(var Buffer; Offset: Int64; Count: Longint);
end;
TwbBA2File = class(TInterfacedObject, IwbResourceContainer, IwbBA2File, IwbBA2FileInternal)
private
bfStream : TwbReadOnlyCachedFileStream;
bfFileName : string;
bfVersion : Cardinal;
bfType : TwbSignature;
bfFiles : array of TwbBA2FileRec;
bfFolderMap : TStringList;
procedure ReadDirectory;
protected
{---IwbResourceContainer---}
function GetName: string;
function OpenResource(const aFileName: string): IwbResource;
function ResourceExists(const aFileName: string): Boolean;
procedure ResourceList(const aList: TStrings; const aFolder: string = '');
procedure ResolveHash(const aHash: Int64; var Results: TDynStrings);
{---IwbBA2File---}
function GetFileName: string;
{---IwbBA2FileInternal---}
procedure ReadData(var Buffer; Offset: Int64; Count: Longint);
public
constructor Create(const aFileName: string);
destructor Destroy; override;
end;
TwbBA2Resource = class(TInterfacedObject, IwbResource)
brFile : IwbBA2FileInternal;
brFileRec : TwbBA2FileRec;
protected
{---IwbResource---}
function GetContainer: IwbResourceContainer;
function GetData: TBytes;
public
constructor Create(aFile: TwbBA2File; var aFileRec: TwbBA2FileRec);
end;
IwbFolderInternal = interface(IwbFolder)
['{6DF2B964-5AF7-4732-BD28-CD7600407A83}']
end;
TwbFolder = class(TInterfacedObject, IwbResourceContainer, IwbFolder, IwbFolderInternal)
private
fPath : string;
protected
{---IwbResourceContainer---}
function GetName: string;
function OpenResource(const aFileName: string): IwbResource;
function ResourceExists(const aFileName: string): Boolean;
procedure ResourceList(const aList: TStrings; const aFolder: string = '');
procedure ResolveHash(const aHash: Int64; var Results: TDynStrings);
{---IwbFolder---}
function GetPathName: string;
public
constructor Create(const aPath: string);
destructor Destroy; override;
end;
TwbFolderResource = class(TInterfacedObject, IwbResource)
frFolder : IwbFolderInternal;
frFileName : string;
protected
{---IwbResource---}
function GetContainer: IwbResourceContainer;
function GetData: TBytes;
public
constructor Create(aFolder: IwbFolderInternal; const aFileName: string);
destructor Destroy; override;
end;
function wbCreateContainerHandler: IwbContainerHandler;
begin
Result := TwbContainerHandler.Create;
end;
{ TwbContainerHandler }
procedure TwbContainerHandler.AddContainer(const aContainer: IwbResourceContainer);
begin
SetLength(chContainers, Succ(Length(chContainers)));
chContainers[High(chContainers)] := aContainer;
end;
function TwbContainerHandler.ContainerExists(aContainerName: string): Boolean;
var
i: Integer;
begin
Result := True;
for i := Low(chContainers) to High(chContainers) do
if SameText(chContainers[i].Name, aContainerName) then
Exit;
Result := False;
end;
procedure TwbContainerHandler.AddBSA(const aFileName: string);
begin
if not ContainerExists(aFileName) then
AddContainer(TwbBSAFile.Create(aFileName));
end;
procedure TwbContainerHandler.AddBA2(const aFileName: string);
begin
if not ContainerExists(aFileName) then
AddContainer(TwbBA2File.Create(aFileName));
end;
procedure TwbContainerHandler.AddFolder(const aPath: string);
begin
if not ContainerExists(aPath) then
AddContainer(TwbFolder.Create(aPath));
end;
function TwbContainerHandler.OpenResource(const aFileName: string): TDynResources;
var
i, j: Integer;
begin
SetLength(Result, Length(chContainers));
j := 0;
for i := Low(chContainers) to High(chContainers) do begin
Result[j] := chContainers[i].OpenResource(aFileName);
if Assigned(Result[j]) then
Inc(j);
end;
SetLength(Result, j);
end;
function TwbContainerHandler.OpenResourceData(const aContainerName, aFileName: string): TBytes;
var
Res : TDynResources;
i : Integer;
begin
Res := OpenResource(aFileName);
if Length(Res) = 0 then
Exit;
for i := High(Res) downto Low(Res) do
if (aContainerName = '') or SameText(Res[i].Container.Name, aContainerName) then begin
Result := Res[i].GetData;
Break;
end;
end;
procedure TwbContainerHandler.ContainerList(const aList: TStrings);
var
i: Integer;
begin
if not Assigned(aList) then
Exit;
for i := Low(chContainers) to High(chContainers) do
aList.Add(chContainers[i].Name);
end;
procedure TwbContainerHandler.ContainerResourceList(const aContainerName: string; const aList: TStrings;
const aFolder: string = '');
var
i: Integer;
begin
for i := Low(chContainers) to High(chContainers) do
if SameText(chContainers[i].Name, aContainerName) then begin
chContainers[i].ResourceList(aList, aFolder);
Break;
end;
end;
function TwbContainerHandler.ResourceExists(const aFileName: string): Boolean;
var
i: Integer;
begin
Result := False;
for i := Low(chContainers) to High(chContainers) do
if chContainers[i].ResourceExists(aFileName) then begin
Result := True;
Exit;
end;
end;
function TwbContainerHandler.ResolveHash(const aHash: Int64): TDynStrings;
var
i: Integer;
begin
Result := nil;
for i := Low(chContainers) to High(chContainers) do
chContainers[i].ResolveHash(aHash, Result);
end;
function TwbContainerHandler.ResourceCount(const aFileName: string; aContainers: TStrings = nil): Integer;
var
i: Integer;
begin
Result := 0;
for i := Low(chContainers) to High(chContainers) do
if chContainers[i].ResourceExists(aFileName) then begin
Inc(Result);
if Assigned(aContainers) then
aContainers.Add(chContainers[i].Name);
end;
end;
procedure TwbContainerHandler.ResourceCopy(const aContainerName, aFileName, aPathOut: string);
var
fn, dir : string;
aData : TBytes;
res : TDynResources;
i, residx : integer;
begin
if aPathOut = '' then
raise Exception.Create('Destination path is not specified');
res := OpenResource(aFileName);
if Length(res) = 0 then
raise Exception.Create('Resource doesn''t exist');
residx := High(res);
for i := High(res) to Low(res) do
if (aContainerName = '') or SameText(res[i].Container.Name, aContainerName) then begin
residx := i;
Break;
end;
// file name is provided instead of path
if TPath.HasExtension(aPathOut) then
fn := aPathOut
// destination path is provided
else
fn := IncludeTrailingPathDelimiter(aPathOut) + aFileName;
// create distination directory
dir := ExtractFilePath(fn);
if not DirectoryExists(dir) then
if not ForceDirectories(dir) then
raise Exception.Create('Unable to create destination directory ' + dir);
// direct copy if file is loose, with overwriting
if ExtractFileExt(res[residx].Container.Name) = '' then begin
TFile.Copy(res[residx].Container.Name + aFileName, fn, True);
end
// otherwise extract from BSA
else begin
aData := res[residx].GetData;
// exception handled outside
with TFileStream.Create(fn, fmCreate) do try
WriteBuffer(aData[0], Length(aData));
finally
Free;
end;
end;
end;
{ TwbBSAFile }
constructor TwbBSAFile.Create(const aFileName: string);
begin
bfFileName := aFileName;
bfStream := TwbReadOnlyCachedFileStream.Create(aFileName);
ReadDirectory;
end;
destructor TwbBSAFile.Destroy;
var
i: Integer;
begin
FreeAndNil(bfStream);
for i := Low(bfFolders) to High(bfFolders) do with bfFolders[i] do
FreeAndNil(Map);
FreeAndNil(bfFolderMap);
inherited;
end;
function TwbBSAFile.GetData(aOffset, aSize: Cardinal): TBytes;
var
IsCompressed : Boolean;
Buffer : TBytes;
begin
IsCompressed := (aSize and BSAFILE_COMPRESS) <> 0;
if IsCompressed then
aSize := aSize and not BSAFILE_COMPRESS;
if (bfFlags and BSAARCHIVE_COMPRESSFILES) <> 0 then
IsCompressed := not IsCompressed;
bfStream.Position := aOffset;
if (bfVersion >= BSAHEADER_VERSION_SK) and ((bfFlags and BSAARCHIVE_PREFIXFULLFILENAMES) <> 0) then
// size - file name length (no terminator) - string length prefix
aSize := aSize - Length(bfStream.ReadStringLen(False)) - 1;
if IsCompressed then begin
SetLength(Result, bfStream.ReadCardinal);
aSize := aSize - 4;
if (Length(Result) > 0) and (aSize > 0) then begin
SetLength(Buffer, aSize);
bfStream.ReadBuffer(Buffer[0], Length(Buffer));
if bfVersion = BSAHEADER_VERSION_SSE then
lz4DecompressToUserBuf(@Buffer[0], Length(Buffer), @Result[0], Length(Result))
else
DecompressToUserBuf(@Buffer[0], Length(Buffer), @Result[0], Length(Result));
end;
end else begin
SetLength(Result, aSize);
if aSize > 0 then
bfStream.ReadBuffer(Result[0], aSize);
end;
end;
function TwbBSAFile.GetFileName: string;
begin
Result := bfFileName;
end;
function TwbBSAFile.GetName: string;
begin
Result := GetFileName;
end;
function TwbBSAFile.OpenResource(const aFileName: string): IwbResource;
var
lPath, lName: string;
i, j: Integer;
begin
Result := nil;
lPath := ExtractFilePath(aFileName);
SetLength(lPath, Pred(Length(lPath)));
lName := ExtractFileName(aFileName);
if bfFolderMap.Find(lPath, i) then
with bfFolders[Integer(bfFolderMap.Objects[i])] do
if Map.Find(lName, j) then
with Files[Integer(Map.Objects[j])] do
Result := TwbBSAResource.Create(Self, Size, Offset);
end;
function TwbBSAFile.ResourceExists(const aFileName: string): Boolean;
var
lPath, lName: string;
i: Integer;
begin
Result := False;
lPath := ExtractFilePath(aFileName);
SetLength(lPath, Pred(Length(lPath)));
lName := ExtractFileName(aFileName);
if bfFolderMap.Find(lPath, i) then
Result := bfFolders[Integer(bfFolderMap.Objects[i])].Map.IndexOf(lName) <> -1;
end;
procedure TwbBSAFile.ResourceList(const aList: TStrings; const aFolder: string = '');
var
i, j: Integer;
Folder: string;
begin
if not Assigned(aList) then
Exit;
Folder := ExcludeTrailingPathDelimiter(aFolder);
for i := Low(bfFolders) to High(bfFolders) do with bfFolders[i] do
if (aFolder = '') or SameText(Folder, Name) then
for j := Low(Files) to High(Files) do
aList.Add(Name + '\' + Files[j].Name);
end;
procedure TwbBSAFile.ReadDirectory;
var
i, j : Integer;
OldPos : Int64;
NewPos : Int64;
// FileCount : Cardinal;
// totalFolderNameLength : Cardinal;
totalFileNameLength : Cardinal;
begin
if bfStream.ReadSignature <> 'BSA' then
raise Exception.Create(bfFileName + ' is not a valid BSA file');
bfVersion := bfStream.ReadCardinal;
if not (bfVersion in [BSAHEADER_VERSION_OB, BSAHEADER_VERSION_SK, BSAHEADER_VERSION_SSE]) then
raise Exception.Create(bfFileName + ' has unknown version: ' + IntToStr(bfVersion) );
bfOffset := bfStream.ReadCardinal;
if bfOffset <> $24 then
raise Exception.Create(bfFileName + ' has unexpected Offset: ' + IntToStr(bfOffset) );
bfFlags := bfStream.ReadCardinal;
SetLength(bfFolders, bfStream.ReadCardinal);
{FileCount := } bfStream.ReadCardinal; //skip file count
{totalFolderNameLength := } bfStream.ReadCardinal; //skip totalFolderNameLength
totalFileNameLength := bfStream.ReadCardinal; //skip totalFileNameLength
bfFileFlags := bfStream.ReadCardinal;
OldPos := bfStream.Position;
for i := Low(bfFolders) to High(bfFolders) do with bfFolders[i] do begin
bfStream.Position := OldPos;
Hash := bfStream.ReadInt64; // skip hash
SetLength(Files, bfStream.ReadCardinal);
if bfVersion = BSAHEADER_VERSION_SSE then begin
bfStream.ReadCardinal; // skip unk32
NewPos := bfStream.ReadInt64;
end else
NewPos := bfStream.ReadCardinal;
OldPos := bfStream.Position;
bfStream.Position := NewPos - totalFileNameLength;
Name := bfStream.ReadStringLen;
for j := Low(Files) to High(Files) do with Files[j] do begin
Hash := bfStream.ReadInt64; // skip hash
Size := bfStream.ReadCardinal;
Offset := bfStream.ReadCardinal;
end;
end;
bfFolderMap := TwbFastStringList.Create;
for i := Low(bfFolders) to High(bfFolders) do with bfFolders[i] do begin
bfFolderMap.AddObject(Name, TObject(i));
Map := TwbFastStringList.Create;
for j := Low(Files) to High(Files) do with Files[j] do begin
Name := bfStream.ReadStringTerm;
Map.AddObject(Name, TObject(j));
end;
Map.Sorted := True;
end;
bfFolderMap.Sorted := True;
end;
procedure TwbBSAFile.ResolveHash(const aHash: Int64; var Results: TDynStrings);
var
i, j: Integer;
begin
for i := Low(bfFolders) to High(bfFolders) do with bfFolders[i] do begin
if Hash = aHash then begin
SetLength(Results, Succ(Length(Results)));
Results[High(Results)] := Name;
end;
for j := Low(Files) to High(Files) do with Files[j] do begin
if Hash = aHash then begin
SetLength(Results, Succ(Length(Results)));
Results[High(Results)] := Name;
end;
end;
end;
end;
{ TwbBSAResource }
constructor TwbBSAResource.Create(aFile: TwbBSAFile; aSize, aOffset: Cardinal);
begin
brFile := aFile;
brOffset := aOffset;
brSize := aSize;
end;
function TwbBSAResource.GetContainer: IwbResourceContainer;
begin
Result := brFile;
end;
function TwbBSAResource.GetData: TBytes;
begin
Result := brFile.GetData(brOffset, brSize);
end;
{ TwbBA2File }
constructor TwbBA2File.Create(const aFileName: string);
begin
bfFileName := aFileName;
bfStream := TwbReadOnlyCachedFileStream.Create(aFileName);
ReadDirectory;
end;
destructor TwbBA2File.Destroy;
var
i: integer;
begin
FreeAndNil(bfStream);
for i := 0 to Pred(bfFolderMap.Count) do
TStringList(bfFolderMap.Objects[i]).Free;
FreeAndNil(bfFolderMap);
inherited;
end;
procedure TwbBA2File.ReadDirectory;
var
i, j : Integer;
OldPos : Int64;
FileCount : Cardinal;
FileTablePosition: Int64;
NumChunks: Byte;
folder: string;
begin
if bfStream.ReadSignature <> 'BTDX' then
raise Exception.Create(bfFileName + ' is not a valid BA2 file');
bfVersion := bfStream.ReadCardinal;
if bfVersion <> BA2HEADER_VERSION_FO4 then
raise Exception.Create(bfFileName + ' has unknown version: ' + IntToStr(bfVersion) );
bfType := bfStream.ReadSignature;
if (bfType <> 'GNRL') and (bfType <> 'DX10') then
raise Exception.Create(bfFileName + ' has unknown type: ' + String(bfType));
FileCount := bfStream.ReadCardinal;
FileTablePosition := bfStream.ReadInt64;
OldPos := bfStream.Position;
bfStream.Position := FileTablePosition;
SetLength(bfFiles, FileCount);
for i := Low(bfFiles) to High(bfFiles) do begin
bfFiles[i].Name := bfStream.ReadStringLen16;
end;
bfStream.Position := OldPos;
if bfType = 'GNRL' then begin
for i := Low(bfFiles) to High(bfFiles) do begin
bfFiles[i].NameHash := bfStream.ReadCardinal;
bfStream.ReadCardinal; // skip ext
bfFiles[i].DirHash := bfStream.ReadCardinal;
bfStream.ReadCardinal; // skip unk0C
bfFiles[i].Offset := bfStream.ReadInt64;
bfFiles[i].PackedSize := bfStream.ReadCardinal;
bfFiles[i].Size := bfStream.ReadCardinal;
bfStream.ReadCardinal; // skip BAADF00D
end;
end
else if bfType = 'DX10' then begin
for i := Low(bfFiles) to High(bfFiles) do begin
bfFiles[i].NameHash := bfStream.ReadCardinal;
bfStream.ReadCardinal; // skip ext
bfFiles[i].DirHash := bfStream.ReadCardinal;
bfStream.ReadByte; // skip unk0C
NumChunks := bfStream.ReadByte;
bfStream.ReadWord; // skip chunkHeaderSize
bfFiles[i].Height := bfStream.ReadWord;
bfFiles[i].Width := bfStream.ReadWord;
bfFiles[i].NumMips := bfStream.ReadByte;
bfFiles[i].DXGIFormat := bfStream.ReadByte;
bfFiles[i].CubeMaps := bfStream.ReadWord;
SetLength(bfFiles[i].TexChunks, NumChunks);
for j := Low(bfFiles[i].TexChunks) to High(bfFiles[i].TexChunks) do
with bfFiles[i].TexChunks[j] do begin
Offset := bfStream.ReadInt64;
PackedSize := bfStream.ReadCardinal;
Size := bfStream.ReadCardinal;
StartMip := bfStream.ReadWord;
EndMip := bfStream.ReadWord;
bfStream.ReadCardinal; // skip BAADF00D
end;
end;
end;
bfFolderMap := TwbFastStringList.Create;
bfFolderMap.Sorted := True;
for i := Low(bfFiles) to High(bfFiles) do begin
folder := LowerCase(ExtractFilePath(bfFiles[i].Name));
SetLength(folder, Pred(Length(folder)));
j := bfFolderMap.IndexOf(folder);
if not bfFolderMap.Find(folder, j) then begin
bfFolderMap.AddObject(folder, TwbFastStringList.Create);
if not bfFolderMap.Find(folder, j) then
raise Exception.Create('Indexing error');
end;
TStringList(bfFolderMap.Objects[j]).AddObject(LowerCase(ExtractFileName(bfFiles[i].Name)), TObject(i));
end;
for i := 0 to Pred(bfFolderMap.Count) do
TStringList(bfFolderMap.Objects[i]).Sorted := True;
end;
function TwbBA2File.GetFileName: string;
begin
Result := bfFileName;
end;
function TwbBA2File.GetName: string;
begin
Result := GetFileName;
end;
procedure TwbBA2File.ReadData(var Buffer; Offset: Int64; Count: Longint);
begin
bfStream.Position := Offset;
bfStream.ReadBuffer(Buffer, Count);
end;
function TwbBA2File.OpenResource(const aFileName: string): IwbResource;
var
lPath, lName: string;
i, j: Integer;
begin
lPath := LowerCase(ExtractFilePath(aFileName));
SetLength(lPath, Pred(Length(lPath)));
lName := LowerCase(ExtractFileName(aFileName));
if bfFolderMap.Find(lPath, i) then with TStringList(bfFolderMap.Objects[i]) do
if Find(lName, j) then
Result := TwbBA2Resource.Create(Self, bfFiles[Integer(Objects[j])]);
end;
procedure TwbBA2File.ResolveHash(const aHash: Int64; var Results: TDynStrings);
begin
// ...
end;
function TwbBA2File.ResourceExists(const aFileName: string): Boolean;
var
lPath, lName: string;
i: Integer;
begin
Result := False;
lPath := LowerCase(ExtractFilePath(aFileName));
SetLength(lPath, Pred(Length(lPath)));
lName := LowerCase(ExtractFileName(aFileName));
if bfFolderMap.Find(lPath, i) then
Result := TStringList(bfFolderMap.Objects[i]).IndexOf(lName) <> -1;
end;
procedure TwbBA2File.ResourceList(const aList: TStrings; const aFolder: string = '');
var
i: Integer;
begin
if not Assigned(aList) then
Exit;
for i := Low(bfFiles) to High(bfFiles) do
aList.Add(LowerCase(bfFiles[i].Name));
end;
{ TwbBA2Resource }
constructor TwbBA2Resource.Create(aFile: TwbBA2File; var aFileRec: TwbBA2FileRec);
begin
brFile := aFile;
brFileRec := aFileRec;
end;
function TwbBA2Resource.GetContainer: IwbResourceContainer;
begin
Result := brFile;
end;
function TwbBA2Resource.GetData: TBytes;
const
FOURCC_BC7 = LongWord(Byte('B') or (Byte('C') shl 8) or (Byte('7') shl 16) or
(Byte(0) shl 24));
var
Buffer : TBytes;
Hdr: ^TDDSFileHeader;
TexSize, i: integer;
begin
// GNRL resource
if (brFileRec.Size <> 0) and (Length(brFileRec.TexChunks) = 0) then begin
if brFileRec.PackedSize <> 0 then begin
SetLength(Buffer, brFileRec.PackedSize);
brFile.ReadData(Buffer[0], brFileRec.Offset, Length(Buffer));
SetLength(Result, brFileRec.Size);
DecompressToUserBuf(@Buffer[0], Length(Buffer), @Result[0], Length(Result));
end
else begin
SetLength(Result, brFileRec.Size);
brFile.ReadData(Result[0], brFileRec.Offset, Length(Result));
end;
end
// DX10 texture
else if Length(brFileRec.TexChunks) <> 0 then begin
// calculate texture size including header
TexSize := SizeOf(TDDSFileHeader);
for i := Low(brFileRec.TexChunks) to High(brFileRec.TexChunks) do
Inc(TexSize, brFileRec.TexChunks[i].Size);
SetLength(Result, TexSize);
// fill DDS header
Hdr := @Result[0];
hdr.Magic := DDSMagic;
hdr.Desc.Size := SizeOf(hdr.Desc);
hdr.Desc.Width := brFileRec.Width;
hdr.Desc.Height := brFileRec.Height;
hdr.Desc.Flags := DDS_SAVE_FLAGS or DDSD_MIPMAPCOUNT;
hdr.Desc.Caps.Caps1 := DDSCAPS_TEXTURE or DDSCAPS_MIPMAP;
hdr.Desc.MipMaps := brFileRec.NumMips;
if brFileRec.CubeMaps = 2049 then
hdr.Desc.Caps.Caps2 := DDSCAPS2_POSITIVEX or DDSCAPS2_NEGATIVEX
or DDSCAPS2_POSITIVEY or DDSCAPS2_NEGATIVEY
or DDSCAPS2_POSITIVEZ or DDSCAPS2_NEGATIVEZ
or DDSCAPS2_CUBEMAP;
hdr.Desc.PixelFormat.Size := SizeOf(hdr.Desc.PixelFormat);
case TDXGIFormat(brFileRec.DXGIFormat) of
DXGI_FORMAT_BC1_UNORM: begin
hdr.Desc.PixelFormat.Flags := DDPF_FOURCC;
hdr.Desc.PixelFormat.FourCC := FOURCC_DXT1;
hdr.Desc.PitchOrLinearSize := brFileRec.Width * brFileRec.Height div 4;
end;
DXGI_FORMAT_BC2_UNORM: begin
hdr.Desc.PixelFormat.Flags := DDPF_FOURCC;
hdr.Desc.PixelFormat.FourCC := FOURCC_DXT3;
hdr.Desc.PitchOrLinearSize := brFileRec.Width * brFileRec.Height;
end;
DXGI_FORMAT_BC3_UNORM: begin
hdr.Desc.PixelFormat.Flags := DDPF_FOURCC;
hdr.Desc.PixelFormat.FourCC := FOURCC_DXT5;
hdr.Desc.PitchOrLinearSize := brFileRec.Width * brFileRec.Height;
end;
DXGI_FORMAT_BC5_UNORM: begin
hdr.Desc.PixelFormat.Flags := DDPF_FOURCC;
hdr.Desc.PixelFormat.FourCC := FOURCC_ATI2;
hdr.Desc.PitchOrLinearSize := brFileRec.Width * brFileRec.Height;
end;
DXGI_FORMAT_BC7_UNORM: begin
hdr.Desc.PixelFormat.Flags := DDPF_FOURCC;
hdr.Desc.PixelFormat.FourCC := FOURCC_BC7;
hdr.Desc.PitchOrLinearSize := brFileRec.Width * brFileRec.Height;
end;
DXGI_FORMAT_B8G8R8A8_UNORM: begin
hdr.Desc.PixelFormat.Flags := DDPF_RGB;
hdr.Desc.PixelFormat.BitCount := 32;
hdr.Desc.PixelFormat.RedMask := $00FF0000;
hdr.Desc.PixelFormat.GreenMask := $0000FF00;
hdr.Desc.PixelFormat.BlueMask := $000000FF;
hdr.Desc.PitchOrLinearSize := brFileRec.Width * brFileRec.Height * 4;
end;
DXGI_FORMAT_R8_UNORM: begin
hdr.Desc.PixelFormat.Flags := DDPF_RGB;
hdr.Desc.PixelFormat.BitCount := 8;
hdr.Desc.PixelFormat.RedMask := $FF;
hdr.Desc.PitchOrLinearSize := brFileRec.Width * brFileRec.Height;
end;
end;
// append chunks
TexSize := SizeOf(TDDSFileHeader);
for i := Low(brFileRec.TexChunks) to High(brFileRec.TexChunks) do with brFileRec.TexChunks[i] do begin
// compressed chunk
if PackedSize <> 0 then begin
SetLength(Buffer, PackedSize);
brFile.ReadData(Buffer[0], Offset, Length(Buffer));
DecompressToUserBuf(@Buffer[0], Length(Buffer), @Result[TexSize], Size);
end
// uncompressed chunk
else
brFile.ReadData(Result[TexSize], Offset, Size);
Inc(TexSize, Size);
end;
end;
end;
{ TwbFolder }
constructor TwbFolder.Create(const aPath: string);
begin
fPath := IncludeTrailingPathDelimiter(aPath);
end;
destructor TwbFolder.Destroy;
begin
inherited;
end;
function TwbFolder.GetPathName: string;
begin
Result := fPath;
end;
function TwbFolder.GetName: string;
begin
Result := GetPathName;
end;
function TwbFolder.OpenResource(const aFileName: string): IwbResource;
var
s: string;
begin
s := fPath + aFileName;
if FileExists(s) then
Result := TwbFolderResource.Create(Self, s);
end;
function TwbFolder.ResourceExists(const aFileName: string): Boolean;
begin
Result := FileExists(fPath + aFileName);
end;
procedure TwbFolder.ResourceList(const aList: TStrings; const aFolder: string = '');
var
FileName: string;
begin
if not Assigned(aList) then
Exit;
if TDirectory.Exists(fPath + aFolder) then
for FileName in TDirectory.GetFiles(fPath + aFolder, '*.*', TSearchOption.soAllDirectories) do
aList.Add(LowerCase(Copy(FileName, Length(fPath) + 1, Length(FileName))));
end;
procedure TwbFolder.ResolveHash(const aHash: Int64; var Results: TDynStrings);
begin
//...
end;
{ TwbFolderResource }
constructor TwbFolderResource.Create(aFolder: IwbFolderInternal; const aFileName: string);
begin
frFolder := aFolder;
frFileName := aFileName;
end;
destructor TwbFolderResource.Destroy;
begin
inherited;
end;
function TwbFolderResource.GetContainer: IwbResourceContainer;
begin
Result := frFolder;
end;
function TwbFolderResource.GetData: TBytes;
begin
with TFileStream.Create(frFileName, fmOpenRead or fmShareDenyWrite) do try
SetLength(Result, Size);
if Length(Result) > 0 then
ReadBuffer(Result[0], Length(Result));
finally
Free;
end;
end;
end.
================================================
FILE: lib/xedit/wbDefines.inc
================================================
{*******************************************************************************
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in
compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/
Software distributed under the License is distributed on an "AS IS"
basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
License for the specific language governing rights and limitations
under the License.
*******************************************************************************}
{.$DEFINE USE_CODESITE}
================================================
FILE: lib/xedit/wbDefinitionsFNV.pas
================================================
{*******************************************************************************
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in
compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/
Software distributed under the License is distributed on an "AS IS"
basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
License for the specific language governing rights and limitations
under the License.
*******************************************************************************}
unit wbDefinitionsFNV;
{$I wbDefines.inc}
interface
uses
wbInterface;
var
wbAggroRadiusFlags: IwbFlagsDef;
wbPKDTFlags: IwbFlagsDef;
wbRecordFlagsFlags: IwbFlagsDef;
wbServiceFlags: IwbFlagsDef;
wbTemplateFlags: IwbFlagsDef;
wbAgressionEnum: IwbEnumDef;
wbAlignmentEnum: IwbEnumDef;
wbArchtypeEnum: IwbEnumDef;
wbAssistanceEnum: IwbEnumDef;
wbAttackAnimationEnum: IwbEnumDef;
wbAxisEnum: IwbEnumDef;
wbBlendModeEnum: IwbEnumDef;
wbBlendOpEnum: IwbEnumDef;
wbBodyLocationEnum: IwbEnumDef;
wbBodyPartIndexEnum: IwbEnumDef;
wbConfidenceEnum: IwbEnumDef;
wbCreatureTypeEnum: IwbEnumDef;
wbCrimeTypeEnum: IwbEnumDef;
wbCriticalStageEnum: IwbEnumDef;
wbEquipTypeEnum: IwbEnumDef;
wbFormTypeEnum: IwbEnumDef;
wbFunctionsEnum: IwbEnumDef;
wbHeadPartIndexEnum: IwbEnumDef;
wbImpactMaterialTypeEnum: IwbEnumDef;
wbMenuModeEnum: IwbEnumDef;
wbMiscStatEnum: IwbEnumDef;
wbModEffectEnum: IwbEnumDef;
wbMoodEnum: IwbEnumDef;
wbMusicEnum: IwbEnumDef;
wbObjectTypeEnum: IwbEnumDef;
wbPKDTType: IwbEnumDef;
wbPlayerActionEnum: IwbEnumDef;
wbQuadrantEnum: IwbEnumDef;
wbReloadAnimEnum: IwbEnumDef;
wbSexEnum: IwbEnumDef;
wbSkillEnum: IwbEnumDef;
wbSoundLevelEnum: IwbEnumDef;
wbSpecializationEnum: IwbEnumDef;
wbVatsValueFunctionEnum: IwbEnumDef;
wbWeaponAnimTypeEnum: IwbEnumDef;
wbZTestFuncEnum: IwbEnumDef;
function wbCreaLevelDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
procedure DefineFNV;
implementation
uses
Types,
Classes,
SysUtils,
Math,
Variants,
wbHelpers;
const
_00_IAD: TwbSignature = #$00'IAD';
_40_IAD: TwbSignature = #$40'IAD';
_01_IAD: TwbSignature = #$01'IAD';
_41_IAD: TwbSignature = #$41'IAD';
_02_IAD: TwbSignature = #$02'IAD';
_42_IAD: TwbSignature = #$42'IAD';
_03_IAD: TwbSignature = #$03'IAD';
_43_IAD: TwbSignature = #$43'IAD';
_04_IAD: TwbSignature = #$04'IAD';
_44_IAD: TwbSignature = #$44'IAD';
_05_IAD: TwbSignature = #$05'IAD';
_45_IAD: TwbSignature = #$45'IAD';
_06_IAD: TwbSignature = #$06'IAD';
_46_IAD: TwbSignature = #$46'IAD';
_07_IAD: TwbSignature = #$07'IAD';
_47_IAD: TwbSignature = #$47'IAD';
_08_IAD: TwbSignature = #$08'IAD';
_48_IAD: TwbSignature = #$48'IAD';
_09_IAD: TwbSignature = #$09'IAD';
_49_IAD: TwbSignature = #$49'IAD';
_0A_IAD: TwbSignature = #$0A'IAD';
_4A_IAD: TwbSignature = #$4A'IAD';
_0B_IAD: TwbSignature = #$0B'IAD';
_4B_IAD: TwbSignature = #$4B'IAD';
_0C_IAD: TwbSignature = #$0C'IAD';
_4C_IAD: TwbSignature = #$4C'IAD';
_0D_IAD: TwbSignature = #$0D'IAD';
_4D_IAD: TwbSignature = #$4D'IAD';
_0E_IAD: TwbSignature = #$0E'IAD';
_4E_IAD: TwbSignature = #$4E'IAD';
_0F_IAD: TwbSignature = #$0F'IAD';
_4F_IAD: TwbSignature = #$4F'IAD';
_10_IAD: TwbSignature = #$10'IAD';
_50_IAD: TwbSignature = #$50'IAD';
_11_IAD: TwbSignature = #$11'IAD';
_51_IAD: TwbSignature = #$51'IAD';
_12_IAD: TwbSignature = #$12'IAD';
_52_IAD: TwbSignature = #$52'IAD';
_13_IAD: TwbSignature = #$13'IAD';
_53_IAD: TwbSignature = #$53'IAD';
_14_IAD: TwbSignature = #$14'IAD';
_54_IAD: TwbSignature = #$54'IAD';
_0_IAD : TwbSignature = #0'IAD';
_1_IAD : TwbSignature = #1'IAD';
_2_IAD : TwbSignature = #2'IAD';
_3_IAD : TwbSignature = #3'IAD';
_4_IAD : TwbSignature = #4'IAD';
_5_IAD : TwbSignature = #5'IAD';
ACBS : TwbSignature = 'ACBS';
ACHR : TwbSignature = 'ACHR';
ACRE : TwbSignature = 'ACRE';
ACTI : TwbSignature = 'ACTI';
ADDN : TwbSignature = 'ADDN';
AIDT : TwbSignature = 'AIDT';
ALCH : TwbSignature = 'ALCH';
AMMO : TwbSignature = 'AMMO';
ANAM : TwbSignature = 'ANAM';
ANIO : TwbSignature = 'ANIO';
ARMA : TwbSignature = 'ARMA';
ARMO : TwbSignature = 'ARMO';
ASPC : TwbSignature = 'ASPC';
ATTR : TwbSignature = 'ATTR';
ATXT : TwbSignature = 'ATXT';
AVIF : TwbSignature = 'AVIF';
BIPL : TwbSignature = 'BIPL';
BMCT : TwbSignature = 'BMCT';
BMDT : TwbSignature = 'BMDT';
BNAM : TwbSignature = 'BNAM';
BOOK : TwbSignature = 'BOOK';
BPND : TwbSignature = 'BPND';
BPNI : TwbSignature = 'BPNI';
BPNN : TwbSignature = 'BPNN';
BPNT : TwbSignature = 'BPNT';
BPTD : TwbSignature = 'BPTD';
BPTN : TwbSignature = 'BPTN';
BTXT : TwbSignature = 'BTXT';
CAMS : TwbSignature = 'CAMS';
CELL : TwbSignature = 'CELL';
CLAS : TwbSignature = 'CLAS';
CLMT : TwbSignature = 'CLMT';
CNAM : TwbSignature = 'CNAM';
MMRK : TwbSignature = 'MMRK';
CNTO : TwbSignature = 'CNTO';
COBJ : TwbSignature = 'COBJ';
COED : TwbSignature = 'COED';
CONT : TwbSignature = 'CONT';
CPTH : TwbSignature = 'CPTH';
CRDT : TwbSignature = 'CRDT';
CREA : TwbSignature = 'CREA';
CSAD : TwbSignature = 'CSAD';
CSCR : TwbSignature = 'CSCR';
CSDC : TwbSignature = 'CSDC';
CSDI : TwbSignature = 'CSDI';
CSDT : TwbSignature = 'CSDT';
CSSD : TwbSignature = 'CSSD';
CSTD : TwbSignature = 'CSTD';
CSTY : TwbSignature = 'CSTY';
CTDA : TwbSignature = 'CTDA';
DATA : TwbSignature = 'DATA';
DAT2 : TwbSignature = 'DAT2';
DEBR : TwbSignature = 'DEBR';
DELE : TwbSignature = 'DELE';
DESC : TwbSignature = 'DESC';
DEST : TwbSignature = 'DEST';
DIAL : TwbSignature = 'DIAL';
DMDL : TwbSignature = 'DMDL';
DMDT : TwbSignature = 'DMDT';
DNAM : TwbSignature = 'DNAM';
DOBJ : TwbSignature = 'DOBJ';
DODT : TwbSignature = 'DODT';
DOOR : TwbSignature = 'DOOR';
DSTD : TwbSignature = 'DSTD';
DSTF : TwbSignature = 'DSTF';
EAMT : TwbSignature = 'EAMT';
ECZN : TwbSignature = 'ECZN';
EDID : TwbSignature = 'EDID';
EFID : TwbSignature = 'EFID';
EFIT : TwbSignature = 'EFIT';
EFSD : TwbSignature = 'EFSD';
EFSH : TwbSignature = 'EFSH';
EITM : TwbSignature = 'EITM';
ENAM : TwbSignature = 'ENAM';
ENCH : TwbSignature = 'ENCH';
ENIT : TwbSignature = 'ENIT';
EPF2 : TwbSignature = 'EPF2';
EPF3 : TwbSignature = 'EPF3';
EPFD : TwbSignature = 'EPFD';
EPFT : TwbSignature = 'EPFT';
ESCE : TwbSignature = 'ESCE';
ETYP : TwbSignature = 'ETYP';
EXPL : TwbSignature = 'EXPL';
EYES : TwbSignature = 'EYES';
FACT : TwbSignature = 'FACT';
FGGA : TwbSignature = 'FGGA';
FGGS : TwbSignature = 'FGGS';
FGTS : TwbSignature = 'FGTS';
FLST : TwbSignature = 'FLST';
FLTV : TwbSignature = 'FLTV';
FNAM : TwbSignature = 'FNAM';
FULL : TwbSignature = 'FULL';
FURN : TwbSignature = 'FURN';
GLOB : TwbSignature = 'GLOB';
RDID : TwbSignature = 'RDID';
RDSI : TwbSignature = 'RDSI';
RDSB : TwbSignature = 'RDSB';
GMST : TwbSignature = 'GMST';
GNAM : TwbSignature = 'GNAM';
GRAS : TwbSignature = 'GRAS';
HAIR : TwbSignature = 'HAIR';
HCLR : TwbSignature = 'HCLR';
HDPT : TwbSignature = 'HDPT';
HEDR : TwbSignature = 'HEDR';
HNAM : TwbSignature = 'HNAM';
ICO2 : TwbSignature = 'ICO2';
ICON : TwbSignature = 'ICON';
IDLA : TwbSignature = 'IDLA';
IDLB : TwbSignature = 'IDLB';
IDLC : TwbSignature = 'IDLC';
IDLE : TwbSignature = 'IDLE';
IDLF : TwbSignature = 'IDLF';
IDLM : TwbSignature = 'IDLM';
IDLT : TwbSignature = 'IDLT';
IMAD : TwbSignature = 'IMAD';
IMGS : TwbSignature = 'IMGS';
INAM : TwbSignature = 'INAM';
INDX : TwbSignature = 'INDX';
INFO : TwbSignature = 'INFO';
INGR : TwbSignature = 'INGR';
IPCT : TwbSignature = 'IPCT';
IPDS : TwbSignature = 'IPDS';
ITXT : TwbSignature = 'ITXT';
JNAM : TwbSignature = 'JNAM';
KEYM : TwbSignature = 'KEYM';
KFFZ : TwbSignature = 'KFFZ';
KNAM : TwbSignature = 'KNAM';
LAND : TwbSignature = 'LAND';
LGTM : TwbSignature = 'LGTM';
LIGH : TwbSignature = 'LIGH';
LNAM : TwbSignature = 'LNAM';
LSCR : TwbSignature = 'LSCR';
LTEX : TwbSignature = 'LTEX';
LTMP : TwbSignature = 'LTMP';
LVLC : TwbSignature = 'LVLC';
LVLD : TwbSignature = 'LVLD';
LVLF : TwbSignature = 'LVLF';
LVLG : TwbSignature = 'LVLG';
LVLI : TwbSignature = 'LVLI';
LVLN : TwbSignature = 'LVLN';
LVLO : TwbSignature = 'LVLO';
MAST : TwbSignature = 'MAST';
MESG : TwbSignature = 'MESG';
MGEF : TwbSignature = 'MGEF';
MICN : TwbSignature = 'MICN';
MICO : TwbSignature = 'MICO';
MIC2 : TwbSignature = 'MIC2';
MISC : TwbSignature = 'MISC';
MNAM : TwbSignature = 'MNAM';
MO2B : TwbSignature = 'MO2B';
MO2S : TwbSignature = 'MO2S';
MO2T : TwbSignature = 'MO2T';
MO3B : TwbSignature = 'MO3B';
MO3S : TwbSignature = 'MO3S';
MO3T : TwbSignature = 'MO3T';
MO4B : TwbSignature = 'MO4B';
MO4S : TwbSignature = 'MO4S';
MO4T : TwbSignature = 'MO4T';
MOD2 : TwbSignature = 'MOD2';
VANM : TwbSignature = 'VANM';
MOD3 : TwbSignature = 'MOD3';
MOD4 : TwbSignature = 'MOD4';
MODB : TwbSignature = 'MODB';
MODD : TwbSignature = 'MODD';
MODL : TwbSignature = 'MODL';
MODS : TwbSignature = 'MODS';
MODT : TwbSignature = 'MODT';
MOSD : TwbSignature = 'MOSD';
MSTT : TwbSignature = 'MSTT';
MUSC : TwbSignature = 'MUSC';
IMPS : TwbSignature = 'IMPS';
IMPF : TwbSignature = 'IMPF';
NAM0 : TwbSignature = 'NAM0';
NAM1 : TwbSignature = 'NAM1';
NAM2 : TwbSignature = 'NAM2';
NAM3 : TwbSignature = 'NAM3';
NAM4 : TwbSignature = 'NAM4';
NAM5 : TwbSignature = 'NAM5';
NAM6 : TwbSignature = 'NAM6';
NAM7 : TwbSignature = 'NAM7';
NAM8 : TwbSignature = 'NAM8';
NAM9 : TwbSignature = 'NAM9';
NAME : TwbSignature = 'NAME';
NAVI : TwbSignature = 'NAVI';
NAVM : TwbSignature = 'NAVM';
NEXT : TwbSignature = 'NEXT';
NIFT : TwbSignature = 'NIFT';
NIFZ : TwbSignature = 'NIFZ';
NNAM : TwbSignature = 'NNAM';
XSRF : TwbSignature = 'XSRF';
XSRD : TwbSignature = 'XSRD';
MWD1 : TwbSignature = 'MWD1';
MWD2 : TwbSignature = 'MWD2';
MWD3 : TwbSignature = 'MWD3';
MWD4 : TwbSignature = 'MWD4';
MWD5 : TwbSignature = 'MWD5';
MWD6 : TwbSignature = 'MWD6';
MWD7 : TwbSignature = 'MWD7';
WNM1 : TwbSignature = 'WNM1';
WNM2 : TwbSignature = 'WNM2';
WNM3 : TwbSignature = 'WNM3';
WNM4 : TwbSignature = 'WNM4';
WNM5 : TwbSignature = 'WNM5';
WNM6 : TwbSignature = 'WNM6';
WNM7 : TwbSignature = 'WNM7';
WMI1 : TwbSignature = 'WMI1';
WMI2 : TwbSignature = 'WMI2';
WMI3 : TwbSignature = 'WMI3';
WMS1 : TwbSignature = 'WMS1';
WMS2 : TwbSignature = 'WMS2';
NOTE : TwbSignature = 'NOTE';
NPC_ : TwbSignature = 'NPC_';
NULL : TwbSignature = 'NULL';
NVCA : TwbSignature = 'NVCA';
NVCI : TwbSignature = 'NVCI';
NVDP : TwbSignature = 'NVDP';
NVER : TwbSignature = 'NVER';
NVEX : TwbSignature = 'NVEX';
NVGD : TwbSignature = 'NVGD';
NVMI : TwbSignature = 'NVMI';
NVTR : TwbSignature = 'NVTR';
NVVX : TwbSignature = 'NVVX';
OBND : TwbSignature = 'OBND';
OFST : TwbSignature = 'OFST';
ONAM : TwbSignature = 'ONAM';
PACK : TwbSignature = 'PACK';
PBEA : TwbSignature = 'PBEA';
PERK : TwbSignature = 'PERK';
PFIG : TwbSignature = 'PFIG';
PFPC : TwbSignature = 'PFPC';
PGAG : TwbSignature = 'PGAG';
PGRE : TwbSignature = 'PGRE';
PMIS : TwbSignature = 'PMIS';
TRGT : TwbSignature = 'TRGT';
PGRI : TwbSignature = 'PGRI';
PGRL : TwbSignature = 'PGRL';
PGRP : TwbSignature = 'PGRP';
PGRR : TwbSignature = 'PGRR';
PKAM : TwbSignature = 'PKAM';
PKDD : TwbSignature = 'PKDD';
PKDT : TwbSignature = 'PKDT';
PKE2 : TwbSignature = 'PKE2';
PKED : TwbSignature = 'PKED';
PKFD : TwbSignature = 'PKFD';
PKID : TwbSignature = 'PKID';
PKPT : TwbSignature = 'PKPT';
PKW3 : TwbSignature = 'PKW3';
PLD2 : TwbSignature = 'PLD2';
PLDT : TwbSignature = 'PLDT';
PLYR : TwbSignature = 'PLYR';
PNAM : TwbSignature = 'PNAM';
TDUM : TwbSignature = 'TDUM';
POBA : TwbSignature = 'POBA';
POCA : TwbSignature = 'POCA';
POEA : TwbSignature = 'POEA';
PRKC : TwbSignature = 'PRKC';
PRKE : TwbSignature = 'PRKE';
PRKF : TwbSignature = 'PRKF';
PROJ : TwbSignature = 'PROJ';
PSDT : TwbSignature = 'PSDT';
PTD2 : TwbSignature = 'PTD2';
PTDT : TwbSignature = 'PTDT';
PUID : TwbSignature = 'PUID';
PWAT : TwbSignature = 'PWAT';
QNAM : TwbSignature = 'QNAM';
RCIL : TwbSignature = 'RCIL';
RCQY : TwbSignature = 'RCQY';
RCOD : TwbSignature = 'RCOD';
QOBJ : TwbSignature = 'QOBJ';
QSDT : TwbSignature = 'QSDT';
QSTA : TwbSignature = 'QSTA';
QSTI : TwbSignature = 'QSTI';
TPIC : TwbSignature = 'TPIC';
QSTR : TwbSignature = 'QSTR';
INFC : TwbSignature = 'INFC';
INFX : TwbSignature = 'INFX';
QUST : TwbSignature = 'QUST';
RACE : TwbSignature = 'RACE';
RADS : TwbSignature = 'RADS';
RAFB : TwbSignature = 'RAFB';
RAFD : TwbSignature = 'RAFD';
RAGA : TwbSignature = 'RAGA';
RAPS : TwbSignature = 'RAPS';
RCLR : TwbSignature = 'RCLR';
RDAT : TwbSignature = 'RDAT';
RDMD : TwbSignature = 'RDMD';
RDMO : TwbSignature = 'RDMO';
RDMP : TwbSignature = 'RDMP';
RDGS : TwbSignature = 'RDGS';
RDOT : TwbSignature = 'RDOT';
RDSD : TwbSignature = 'RDSD';
RDWT : TwbSignature = 'RDWT';
REFR : TwbSignature = 'REFR';
REGN : TwbSignature = 'REGN';
REPL : TwbSignature = 'REPL';
RGDL : TwbSignature = 'RGDL';
RNAM : TwbSignature = 'RNAM';
RPLD : TwbSignature = 'RPLD';
RPLI : TwbSignature = 'RPLI';
SCDA : TwbSignature = 'SCDA';
SCHR : TwbSignature = 'SCHR';
SCOL : TwbSignature = 'SCOL';
SCPT : TwbSignature = 'SCPT';
SCRI : TwbSignature = 'SCRI';
SCRN : TwbSignature = 'SCRN';
SCRO : TwbSignature = 'SCRO';
SCRV : TwbSignature = 'SCRV';
SCTX : TwbSignature = 'SCTX';
SCVR : TwbSignature = 'SCVR';
SLCP : TwbSignature = 'SLCP';
SLSD : TwbSignature = 'SLSD';
SNAM : TwbSignature = 'SNAM';
SNDD : TwbSignature = 'SNDD';
SNDX : TwbSignature = 'SNDX';
SOUL : TwbSignature = 'SOUL';
SOUN : TwbSignature = 'SOUN';
SPEL : TwbSignature = 'SPEL';
SPIT : TwbSignature = 'SPIT';
SPLO : TwbSignature = 'SPLO';
STAT : TwbSignature = 'STAT';
BRUS : TwbSignature = 'BRUS';
TACT : TwbSignature = 'TACT';
TCLF : TwbSignature = 'TCLF';
TCFU : TwbSignature = 'TCFU';
TCLT : TwbSignature = 'TCLT';
TERM : TwbSignature = 'TERM';
TES4 : TwbSignature = 'TES4';
TNAM : TwbSignature = 'TNAM';
TPLT : TwbSignature = 'TPLT';
TRDT : TwbSignature = 'TRDT';
TREE : TwbSignature = 'TREE';
TX00 : TwbSignature = 'TX00';
TX01 : TwbSignature = 'TX01';
INTV : TwbSignature = 'INTV';
TX02 : TwbSignature = 'TX02';
TX03 : TwbSignature = 'TX03';
TX04 : TwbSignature = 'TX04';
TX05 : TwbSignature = 'TX05';
TXST : TwbSignature = 'TXST';
UNAM : TwbSignature = 'UNAM';
VATS : TwbSignature = 'VATS';
VCLR : TwbSignature = 'VCLR';
VHGT : TwbSignature = 'VHGT';
VNAM : TwbSignature = 'VNAM';
VNML : TwbSignature = 'VNML';
VTCK : TwbSignature = 'VTCK';
VTEX : TwbSignature = 'VTEX';
VTXT : TwbSignature = 'VTXT';
VTYP : TwbSignature = 'VTYP';
WATR : TwbSignature = 'WATR';
WEAP : TwbSignature = 'WEAP';
WLST : TwbSignature = 'WLST';
WNAM : TwbSignature = 'WNAM';
XATO : TwbSignature = 'XATO';
WRLD : TwbSignature = 'WRLD';
WTHR : TwbSignature = 'WTHR';
XACT : TwbSignature = 'XACT';
XAMC : TwbSignature = 'XAMC';
XAMT : TwbSignature = 'XAMT';
XAPD : TwbSignature = 'XAPD';
XAPR : TwbSignature = 'XAPR';
XCAS : TwbSignature = 'XCAS';
XCCM : TwbSignature = 'XCCM';
XCET : TwbSignature = 'XCET';
XCHG : TwbSignature = 'XCHG';
XCIM : TwbSignature = 'XCIM';
XCLC : TwbSignature = 'XCLC';
XCLL : TwbSignature = 'XCLL';
XCLP : TwbSignature = 'XCLP';
XCLR : TwbSignature = 'XCLR';
XCLW : TwbSignature = 'XCLW';
XCMO : TwbSignature = 'XCMO';
XCMT : TwbSignature = 'XCMT';
XCNT : TwbSignature = 'XCNT';
XCWT : TwbSignature = 'XCWT';
XEMI : TwbSignature = 'XEMI';
XESP : TwbSignature = 'XESP';
XEZN : TwbSignature = 'XEZN';
XGLB : TwbSignature = 'XGLB';
XHLP : TwbSignature = 'XHLP';
XDCR : TwbSignature = 'XDCR';
XHLT : TwbSignature = 'XHLT';
XIBS : TwbSignature = 'XIBS';
XLCM : TwbSignature = 'XLCM';
XLKR : TwbSignature = 'XLKR';
XLOC : TwbSignature = 'XLOC';
XLOD : TwbSignature = 'XLOD';
XLRM : TwbSignature = 'XLRM';
XLTW : TwbSignature = 'XLTW';
XMBO : TwbSignature = 'XMBO';
XMBP : TwbSignature = 'XMBP';
XMBR : TwbSignature = 'XMBR';
XMRC : TwbSignature = 'XMRC';
XMRK : TwbSignature = 'XMRK';
XNAM : TwbSignature = 'XNAM';
XNDP : TwbSignature = 'XNDP';
XOCP : TwbSignature = 'XOCP';
XORD : TwbSignature = 'XORD';
XOWN : TwbSignature = 'XOWN';
XPOD : TwbSignature = 'XPOD';
XPTL : TwbSignature = 'XPTL';
XPPA : TwbSignature = 'XPPA';
XPRD : TwbSignature = 'XPRD';
XPRM : TwbSignature = 'XPRM';
XPWR : TwbSignature = 'XPWR';
XRAD : TwbSignature = 'XRAD';
XRDO : TwbSignature = 'XRDO';
XRDS : TwbSignature = 'XRDS';
XRGB : TwbSignature = 'XRGB';
XRGD : TwbSignature = 'XRGD';
XRMR : TwbSignature = 'XRMR';
XRNK : TwbSignature = 'XRNK';
XRTM : TwbSignature = 'XRTM';
XSCL : TwbSignature = 'XSCL';
XSED : TwbSignature = 'XSED';
XTEL : TwbSignature = 'XTEL';
XTRG : TwbSignature = 'XTRG';
XTRI : TwbSignature = 'XTRI';
XXXX : TwbSignature = 'XXXX';
YNAM : TwbSignature = 'YNAM';
ZNAM : TwbSignature = 'ZNAM';
IMOD : TwbSignature = 'IMOD';
REPU : TwbSignature = 'REPU';
RCPE : TwbSignature = 'RCPE';
RCCT : TwbSignature = 'RCCT';
CHIP : TwbSignature = 'CHIP';
CSNO : TwbSignature = 'CSNO';
LSCT : TwbSignature = 'LSCT';
MSET : TwbSignature = 'MSET';
ALOC : TwbSignature = 'ALOC';
CHAL : TwbSignature = 'CHAL';
AMEF : TwbSignature = 'AMEF';
CCRD : TwbSignature = 'CCRD';
CARD : TwbSignature = 'CARD';
CMNY : TwbSignature = 'CMNY';
CDCK : TwbSignature = 'CDCK';
DEHY : TwbSignature = 'DEHY';
HUNG : TwbSignature = 'HUNG';
SLPD : TwbSignature = 'SLPD';
var
wbPKDTSpecificFlagsUnused : Boolean;
wbEDID: IwbSubRecordDef;
wbEDIDReq: IwbSubRecordDef;
wbBMDT: IwbSubRecordDef;
wbYNAM: IwbSubRecordDef;
wbZNAM: IwbSubRecordDef;
wbCOED: IwbSubRecordDef;
wbXLCM: IwbSubRecordDef;
wbEITM: IwbSubRecordDef;
wbREPL: IwbSubRecordDef;
wbBIPL: IwbSubRecordDef;
wbOBND: IwbSubRecordDef;
wbOBNDReq: IwbSubRecordDef;
wbDEST: IwbSubRecordStructDef;
wbDESTActor: IwbSubRecordStructDef;
wbDODT: IwbSubRecordDef;
wbXOWN: IwbSubRecordDef;
wbXGLB: IwbSubRecordDef;
wbXRGD: IwbSubRecordDef;
wbXRGB: IwbSubRecordDef;
wbSLSD: IwbSubRecordDef;
wbSPLO: IwbSubRecordDef;
wbSPLOs: IwbSubRecordArrayDef;
wbCNTO: IwbSubRecordStructDef;
wbCNTOs: IwbSubRecordArrayDef;
wbAIDT: IwbSubRecordDef;
wbCSDT: IwbSubRecordStructDef;
wbCSDTs: IwbSubRecordArrayDef;
wbFULL: IwbSubRecordDef;
wbFULLActor: IwbSubRecordDef;
wbFULLReq: IwbSubRecordDef;
wbXNAM: IwbSubRecordDef;
wbXNAMs: IwbSubRecordArrayDef;
wbDESC: IwbSubRecordDef;
wbDESCReq: IwbSubRecordDef;
wbXSCL: IwbSubRecordDef;
wbDATAPosRot : IwbSubRecordDef;
wbPosRot : IwbStructDef;
wbMODD: IwbSubRecordDef;
wbMOSD: IwbSubRecordDef;
wbMODL: IwbSubRecordStructDef;
wbMODS: IwbSubRecordDef;
wbMO2S: IwbSubRecordDef;
wbMO3S: IwbSubRecordDef;
wbMO4S: IwbSubRecordDef;
wbMODLActor: IwbSubRecordStructDef;
wbMODLReq: IwbSubRecordStructDef;
wbCTDA: IwbSubRecordDef;
wbSCHRReq: IwbSubRecordDef;
wbCTDAs: IwbSubRecordArrayDef;
wbCTDAsReq: IwbSubRecordArrayDef;
wbSCROs: IwbSubRecordArrayDef;
wbPGRP: IwbSubRecordDef;
wbEmbeddedScript: IwbSubRecordStructDef;
wbEmbeddedScriptPerk: IwbSubRecordStructDef;
wbEmbeddedScriptReq: IwbSubRecordStructDef;
wbSCRI: IwbSubRecordDef;
wbSCRIActor: IwbSubRecordDef;
wbFaceGen: IwbSubRecordStructDef;
wbFaceGenNPC: IwbSubRecordStructDef;
wbENAM: IwbSubRecordDef;
wbFGGS: IwbSubRecordDef;
wbXLOD: IwbSubRecordDef;
wbXESP: IwbSubRecordDef;
wbICON: IwbSubRecordStructDef;
wbICONReq: IwbSubRecordStructDef;
wbActorValue: IwbIntegerDef;
wbETYP: IwbSubRecordDef;
wbETYPReq: IwbSubRecordDef;
wbEFID: IwbSubRecordDef;
wbEFIT: IwbSubRecordDef;
wbEffects: IwbSubRecordArrayDef;
wbEffectsReq: IwbSubRecordArrayDef;
wbBPNDStruct: IwbSubRecordDef;
wbTimeInterpolator: IwbStructDef;
wbColorInterpolator: IwbStructDef;
function wbNVTREdgeToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Index : Integer;
Flags : Cardinal;
IsExternal : Boolean;
Container : IwbContainerElementRef;
begin
Result := '';
IsExternal := False;
if Supports(aElement, IwbContainerElementRef, Container) then begin
Index := StrToIntDef(Copy(Container.Name, 11, 1), -1);
if (Index >= 0) and (Index <= 2) then begin
Flags := Container.ElementNativeValues['..\..\Flags'];
IsExternal := Flags and (Cardinal(1) shl Index) <> 0;
end;
end;
if IsExternal then begin
case aType of
ctToStr: begin
Result := IntToStr(aInt);
if Container.ElementExists['..\..\..\..\NVEX\Connection #' + IntToStr(aInt)] then
Result := Result + ' (Triangle #' +
Container.ElementValues['..\..\..\..\NVEX\Connection #' + IntToStr(aInt) + '\Triangle'] + ' in ' +
Container.ElementValues['..\..\..\..\NVEX\Connection #' + IntToStr(aInt) + '\Navigation Mesh'] + ')'
else
Result := Result + ' ';
end;
ctToSortKey:
if Container.ElementExists['..\..\..\..\NVEX\Connection #' + IntToStr(aInt)] then
Result :=
Container.ElementSortKeys['..\..\..\..\NVEX\Connection #' + IntToStr(aInt) + '\Navigation Mesh', True] + '|' +
Container.ElementSortKeys['..\..\..\..\NVEX\Connection #' + IntToStr(aInt) + '\Triangle', True];
ctCheck:
if Container.ElementExists['..\..\..\..\NVEX\Connection #' + IntToStr(aInt)] then
Result := ''
else
Result := 'NVEX\Connection #' + IntToStr(aInt) + ' is missing';
end
end else
case aType of
ctToStr: Result := IntToStr(aInt);
end;
end;
function wbNVTREdgeToInt(const aString: string; const aElement: IwbElement): Int64;
begin
Result := StrToInt64(aString);
end;
function wbEPFDActorValueToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
AsCardinal : Cardinal;
AsFloat : Single;
begin
AsCardinal := aInt;
AsFloat := PSingle(@AsCardinal)^;
aInt := Round(AsFloat);
case aType of
ctToStr: Result := wbActorValueEnum.ToString(aInt, aElement);
ctToSortKey: Result := wbActorValueEnum.ToSortKey(aInt, aElement);
ctCheck: Result := wbActorValueEnum.Check(aInt, aElement);
ctToEditValue: Result := wbActorValueEnum.ToEditValue(aInt, aElement);
ctEditType: Result := 'ComboBox';
ctEditInfo: Result := wbActorValueEnum.EditInfo[aInt, aElement];
end;
end;
function wbEPFDActorValueToInt(const aString: string; const aElement: IwbElement): Int64;
var
AsCardinal : Cardinal;
AsFloat : Single;
begin
AsFloat := wbActorValueEnum.FromEditValue(aString, aElement);
PSingle(@AsCardinal)^ := AsFloat;
Result := AsCardinal;
end;
function wbCTDAParam2VariableNameToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
//Container2 : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
BaseRecord : IwbMainRecord;
ScriptRef : IwbElement;
Script : IwbMainRecord;
Variables : TStringList;
LocalVars : IwbContainerElementRef;
LocalVar : IwbContainerElementRef;
i, j : Integer;
s : string;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Param1 := Container.ElementByName['Parameter #1'];
if not Assigned(Param1) then
Exit;
MainRecord := nil;
if not Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
Exit;
{ if Param1.NativeValue = 0 then
if Supports(Container.Container, IwbContainerElementRef, Container) then
for i := 0 to Pred(Container.ElementCount) do
if Supports(Container.Elements[i], IwbContainerElementRef, Container2) then
if SameText(Container2.ElementValues['Function'], 'GetIsID') then begin
Param1 := Container2.ElementByName['Parameter #1'];
if Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
Break;
end;}
if not Assigned(MainRecord) then
Exit;
BaseRecord := MainRecord.BaseRecord;
if Assigned(BaseRecord) then
MainRecord := BaseRecord;
ScriptRef := MainRecord.RecordBySignature['SCRI'];
if not Assigned(ScriptRef) then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
if not Supports(ScriptRef.LinksTo, IwbMainRecord, Script) then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
Script := Script.HighestOverrideOrSelf[aElement._File.LoadOrder];
case aType of
ctEditType: begin
Result := 'ComboBox';
Exit;
end;
ctEditInfo:
Variables := TStringList.Create;
else
Variables := nil;
end;
try
if Supports(Script.ElementByName['Local Variables'], IwbContainerElementRef, LocalVars) then begin
for i := 0 to Pred(LocalVars.ElementCount) do
if Supports(LocalVars.Elements[i], IwbContainerElementRef, LocalVar) then begin
j := LocalVar.ElementNativeValues['SLSD\Index'];
s := LocalVar.ElementNativeValues['SCVR'];
if Assigned(Variables) then
Variables.AddObject(s, TObject(j))
else if j = aInt then begin
case aType of
ctToStr, ctToEditValue: Result := s;
ctCheck: Result := '';
end;
Exit;
end;
end;
end;
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
ctEditInfo: begin
Variables.Sort;
Result := Variables.CommaText;
end;
end;
finally
FreeAndNil(Variables);
end;
end;
function wbCTDAParam2VariableNameToInt(const aString: string; const aElement: IwbElement): Int64;
var
Container : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
BaseRecord : IwbMainRecord;
ScriptRef : IwbElement;
Script : IwbMainRecord;
LocalVars : IwbContainerElementRef;
LocalVar : IwbContainerElementRef;
i, j : Integer;
s : string;
begin
Result := StrToInt64Def(aString, Low(Cardinal));
if Result <> Low(Cardinal) then
Exit;
if not Assigned(aElement) then
raise Exception.Create('aElement not specified');
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then
raise Exception.Create('Container not assigned');
Param1 := Container.ElementByName['Parameter #1'];
if not Assigned(Param1) then
raise Exception.Create('Could not find "Parameter #1"');
if not Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
raise Exception.Create('"Parameter #1" does not reference a valid main record');
BaseRecord := MainRecord.BaseRecord;
if Assigned(BaseRecord) then
MainRecord := BaseRecord;
ScriptRef := MainRecord.RecordBySignature['SCRI'];
if not Assigned(ScriptRef) then
raise Exception.Create('"'+MainRecord.ShortName+'" does not contain a SCRI subrecord');
if not Supports(ScriptRef.LinksTo, IwbMainRecord, Script) then
raise Exception.Create('"'+MainRecord.ShortName+'" does not have a valid script');
Script := Script.HighestOverrideOrSelf[aElement._File.LoadOrder];
if Supports(Script.ElementByName['Local Variables'], IwbContainerElementRef, LocalVars) then begin
for i := 0 to Pred(LocalVars.ElementCount) do
if Supports(LocalVars.Elements[i], IwbContainerElementRef, LocalVar) then begin
j := LocalVar.ElementNativeValues['SLSD\Index'];
s := LocalVar.ElementNativeValues['SCVR'];
if SameText(s, Trim(aString)) then begin
Result := j;
Exit;
end;
end;
end;
raise Exception.Create('Variable "'+aString+'" was not found in "'+MainRecord.ShortName+'"');
end;
function wbCTDAParam2QuestStageToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
EditInfos : TStringList;
Stages : IwbContainerElementRef;
Stage : IwbContainerElementRef;
i, j : Integer;
s, t : string;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Param1 := Container.ElementByName['Parameter #1'];
if not Assigned(Param1) then
Exit;
if not Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
Exit;
MainRecord := MainRecord.WinningOverride;
if MainRecord.Signature <> QUST then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
case aType of
ctEditType: begin
Result := 'ComboBox';
Exit;
end;
ctEditInfo:
EditInfos := TStringList.Create;
else
EditInfos := nil;
end;
try
if Supports(MainRecord.ElementByName['Stages'], IwbContainerElementRef, Stages) then begin
for i := 0 to Pred(Stages.ElementCount) do
if Supports(Stages.Elements[i], IwbContainerElementRef, Stage) then begin
j := Stage.ElementNativeValues['INDX'];
s := Trim(Stage.ElementValues['Log Entries\Log Entry\CNAM']);
t := IntToStr(j);
while Length(t) < 3 do
t := '0' + t;
if s <> '' then
t := t + ' ' + s;
if Assigned(EditInfos) then
EditInfos.AddObject(t, TObject(j))
else if j = aInt then begin
case aType of
ctToStr, ctToEditValue: Result := t;
ctCheck: Result := '';
end;
Exit;
end;
end;
end;
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
ctEditInfo: begin
EditInfos.Sort;
Result := EditInfos.CommaText;
end;
end;
finally
FreeAndNil(EditInfos);
end;
end;
function wbPerkDATAQuestStageToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
EditInfos : TStringList;
Stages : IwbContainerElementRef;
Stage : IwbContainerElementRef;
i, j : Integer;
s, t : string;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Param1 := Container.ElementByName['Quest'];
if not Assigned(Param1) then
Exit;
if not Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
Exit;
MainRecord := MainRecord.WinningOverride;
if MainRecord.Signature <> QUST then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
case aType of
ctEditType: begin
Result := 'ComboBox';
Exit;
end;
ctEditInfo:
EditInfos := TStringList.Create;
else
EditInfos := nil;
end;
try
if Supports(MainRecord.ElementByName['Stages'], IwbContainerElementRef, Stages) then begin
for i := 0 to Pred(Stages.ElementCount) do
if Supports(Stages.Elements[i], IwbContainerElementRef, Stage) then begin
j := Stage.ElementNativeValues['INDX'];
s := Trim(Stage.ElementValues['Log Entries\Log Entry\CNAM']);
t := IntToStr(j);
while Length(t) < 3 do
t := '0' + t;
if s <> '' then
t := t + ' ' + s;
if Assigned(EditInfos) then
EditInfos.AddObject(t, TObject(j))
else if j = aInt then begin
case aType of
ctToStr, ctToEditValue: Result := t;
ctCheck: Result := '';
end;
Exit;
end;
end;
end;
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
ctEditInfo: begin
EditInfos.Sort;
Result := EditInfos.CommaText;
end;
end;
finally
FreeAndNil(EditInfos);
end;
end;
function wbCTDAParam2QuestObjectiveToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
EditInfos : TStringList;
Objectives : IwbContainerElementRef;
Objective : IwbContainerElementRef;
i, j : Integer;
s, t : string;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Param1 := Container.ElementByName['Parameter #1'];
if not Assigned(Param1) then
Exit;
if not Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
Exit;
MainRecord := MainRecord.WinningOverride;
if MainRecord.Signature <> QUST then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
case aType of
ctEditType: begin
Result := 'ComboBox';
Exit;
end;
ctEditInfo:
EditInfos := TStringList.Create;
else
EditInfos := nil;
end;
try
if Supports(MainRecord.ElementByName['Objectives'], IwbContainerElementRef, Objectives) then begin
for i := 0 to Pred(Objectives.ElementCount) do
if Supports(Objectives.Elements[i], IwbContainerElementRef, Objective) then begin
j := Objective.ElementNativeValues['QOBJ'];
s := Trim(Objective.ElementValues['NNAM']);
t := IntToStr(j);
while Length(t) < 3 do
t := '0' + t;
if s <> '' then
t := t + ' ' + s;
if Assigned(EditInfos) then
EditInfos.AddObject(t, TObject(j))
else if j = aInt then begin
case aType of
ctToStr, ctToEditValue: Result := t;
ctCheck: Result := '';
end;
Exit;
end;
end;
end;
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
ctEditInfo: begin
EditInfos.Sort;
Result := EditInfos.CommaText;
end;
end;
finally
FreeAndNil(EditInfos);
end;
end;
function wbCTDAParam2QuestStageToInt(const aString: string; const aElement: IwbElement): Int64;
var
i : Integer;
s : string;
begin
i := 1;
s := Trim(aString);
while (i <= Length(s)) and (s[i] in ['0'..'9']) do
Inc(i);
s := Copy(s, 1, Pred(i));
Result := StrToInt(s);
end;
function wbCTDAParam2QuestObjectiveToInt(const aString: string; const aElement: IwbElement): Int64;
var
i : Integer;
s : string;
begin
i := 1;
s := Trim(aString);
while (i <= Length(s)) and (s[i] in ['0'..'9']) do
Inc(i);
s := Copy(s, 1, Pred(i));
Result := StrToInt(s);
end;
function wbClmtMoonsPhaseLength(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
PhaseLength : Byte;
Masser : Boolean;
Secunda : Boolean;
begin
Result := '';
if aType = ctToSortKey then begin
Result := IntToHex64(aInt, 2);
end else if aType = ctToStr then begin
PhaseLength := aInt mod 64;
Masser := (aInt and 64) <> 0;
Secunda := (aInt and 128) <> 0;
if Masser then
if Secunda then
Result := 'Masser, Secunda / '
else
Result := 'Masser / '
else
if Secunda then
Result := 'Secunda / '
else
Result := 'No Moon / ';
Result := Result + IntToStr(PhaseLength);
end;
end;
function wbClmtTime(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
if aType = ctToSortKey then
Result := IntToHex64(aInt, 4)
else if aType = ctToStr then
Result := TimeToStr( EncodeTime(aInt div 6, (aInt mod 6) * 10, 0, 0) )
else
Result := '';
end;
function wbAlocTime(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
if aType = ctToSortKey then
Result := IntToHex64(aInt, 4)
else if aType = ctToStr then
Result := TimeToStr( aInt / 256 )
else
Result := '';
end;
function wbREFRNavmeshTriangleToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
Navmesh : IwbElement;
MainRecord : IwbMainRecord;
Triangles : IwbContainerElementRef;
begin
case aType of
ctToStr: Result := IntToStr(aInt);
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Navmesh := Container.Elements[0];
if not Assigned(Navmesh) then
Exit;
if not Supports(Navmesh.LinksTo, IwbMainRecord, MainRecord) then
Exit;
MainRecord := MainRecord.WinningOverride;
if MainRecord.Signature <> NAVM then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
if not wbSimpleRecords and (aType = ctCheck) and Supports(MainRecord.ElementByPath['NVTR'], IwbContainerElementRef, Triangles) then
if aInt >= Triangles.ElementCount then
Result := '';
end;
function wbStringToInt(const aString: string; const aElement: IwbElement): Int64;
begin
Result := StrToIntDef(aString, 0);
end;
var
wbCtdaTypeFlags : IwbFlagsDef;
function wbCtdaTypeToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
s: string;
begin
Result := '';
case aType of
ctEditType:
Result := 'CheckComboBox';
ctEditInfo:
Result := 'Equal,Greater,Lesser,Or,"Use Global","Run on Target"';
ctToEditValue: begin
Result := '000000';
case aInt and $F0 of
$00 : Result[1] := '1';
$40 : Result[2] := '1';
$60 : begin
Result[1] := '1';
Result[2] := '1';
end;
$80 : Result[3] := '1';
$A0 : begin
Result[1] := '1';
Result[3] := '1';
end;
end;
if (aInt and $01) <> 0 then
Result[4] := '1';
if (aInt and $02) <> 0 then
Result[6] := '1';
if (aInt and $04) <> 0 then
Result[5] := '1';
end;
ctToStr: begin
case aInt and $F0 of
$00 : Result := 'Equal to';
$20 : Result := 'Not equal to';
$40 : Result := 'Greater than';
$60 : Result := 'Greater than or equal to';
$80 : Result := 'Less than';
$A0 : Result := 'Less than or equal to';
else
Result := ''
end;
if not Assigned(wbCtdaTypeFlags) then
wbCtdaTypeFlags := wbFlags([
{0x01} 'Or',
{0x02} 'Run on target',
{0x04} 'Use global'
]);
s := wbCtdaTypeFlags.ToString(aInt and $0F, aElement);
if s <> '' then
Result := Result + ' / ' + s;
end;
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
Exit;
end;
ctCheck: begin
case aInt and $F0 of
$00, $20, $40, $60, $80, $A0 : Result := '';
else
Result := ''
end;
if not Assigned(wbCtdaTypeFlags) then
wbCtdaTypeFlags := wbFlags([
{0x01} 'Or',
{0x02} 'Run on target',
{0x04} 'Use global'
]);
s := wbCtdaTypeFlags.Check(aInt and $0F, aElement);
if s <> '' then
Result := Result + ' / ' + s;
end;
end;
end;
function wbCtdaTypeToInt(const aString: string; const aElement: IwbElement): Int64;
var
s: string;
begin
s := aString + '000000';
// Result := 0;
if s[1] = '1' then begin
if s[2] = '1' then begin
if s[3] = '1' then begin
Result := $00;
end else begin
Result := $60;
end;
end else begin
if s[3] = '1' then begin
Result := $A0;
end else begin
Result := $00;
end;
end;
end else begin
if s[2] = '1' then begin
if s[3] = '1' then begin
Result := $20;
end else begin
Result := $40;
end;
end else begin
if s[3] = '1' then begin
Result := $80;
end else begin
Result := $20;
end;
end;
end;
if s[4] = '1' then
Result := Result or $01;
if s[6] = '1' then
Result := Result or $02;
if s[5] = '1' then
Result := Result or $04;
end;
procedure wbHeadPartsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container : IwbContainerElementRef;
begin
if wbBeginInternalEdit then try
if Supports(aElement, IwbContainerElementRef, Container) then
if (Container.Elements[0].NativeValue = 1) and (Container.ElementCount > 2) then
Container.RemoveElement(1);
finally
wbEndInternalEdit;
end;
end;
procedure wbMESGDNAMAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldValue, NewValue : Integer;
Container : IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if Supports(aElement.Container, IwbContainerElementRef, Container) then begin
OldValue := Integer(aOldValue) and 1;
NewValue := Integer(aNewValue) and 1;
if NewValue = OldValue then
Exit;
if NewValue = 1 then
Container.RemoveElement('TNAM')
else
Container.Add('TNAM', True);
end;
end;
procedure wbGMSTEDIDAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldValue, NewValue : string;
Container : IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if Supports(aElement.Container, IwbContainerElementRef, Container) then begin
OldValue := aOldValue;
NewValue := aNewValue;
if (Length(OldValue) < 1) or (Length(OldValue) < 1) or (OldValue[1] <> NewValue[1]) then begin
Container.RemoveElement('DATA');
Container.Add('DATA', True);
end;
end;
end;
procedure wbFLSTEDIDAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldValue, NewValue : string;
OldOrdered, NewOrdered : Boolean;
Container : IwbContainerElementRef;
const
OrderedList = 'OrderedList';
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if Supports(aElement.Container, IwbContainerElementRef, Container) then begin
OldValue := aOldValue;
NewValue := aNewValue;
if Length(OldValue) > Length(OrderedList) then
Delete(OldValue, 1, Length(OldValue)-Length(OrderedList));
if Length(NewValue) > Length(OrderedList) then
Delete(NewValue, 1, Length(NewValue)-Length(OrderedList));
OldOrdered := SameText(OldValue, OrderedList);
NewOrdered := SameText(NewValue, OrderedList);
if OldOrdered <> NewOrdered then
Container.RemoveElement('FormIDs');
end;
end;
procedure wbCtdaTypeAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldValue, NewValue: Integer;
Container: IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
OldValue := aOldValue and $04;
NewValue := aNewValue and $04;
if OldValue <> NewValue then
Container.ElementNativeValues['..\Comparison Value'] := 0;
if aNewValue and $02 then begin
Container.ElementNativeValues['..\Run On'] := 1;
if Integer(Container.ElementNativeValues['..\Run On']) = 1 then
aElement.NativeValue := Byte(aNewValue) and not $02;
end;
end;
function wbMODTCallback(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Strings: TDynStrings;
i: Integer;
begin
Result := '';
if wbLoaderDone and (aType in [ctToStr, ctToSortKey] ) then begin
Strings := wbContainerHandler.ResolveHash(aInt);
for i := Low(Strings) to High(Strings) do
Result := Result + Strings[i] + ', ';
SetLength(Result, Length(Result) -2 );
end;
end;
function wbIdleAnam(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
case aType of
ctToStr: begin
case aInt and not $C0 of
0: Result := 'Idle';
1: Result := 'Movement';
2: Result := 'Left Arm';
3: Result := 'Left Hand';
4: Result := 'Weapon';
5: Result := 'Weapon Up';
6: Result := 'Weapon Down';
7: Result := 'Special Idle';
20: Result := 'Whole Body';
21: Result := 'Upper Body';
else
Result := '';
end;
if (aInt and $80) = 0 then
Result := Result + ', Must return a file';
if (aInt and $40) = 1 then
Result := Result + ', Unknown Flag';
end;
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
end;
ctCheck: begin
case aInt and not $C0 of
0..7, 20, 21: Result := '';
else
Result := '';
end;
end;
end;
end;
function wbScaledInt4ToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
const
PlusMinus : array[Boolean] of string = ('+', '-');
begin
Result := '';
case aType of
ctToStr, ctToEditValue: Result := FloatToStrF(aInt / 10000, ffFixed, 99, 4);
ctToSortKey: begin
Result := FloatToStrF(aInt / 10000, ffFixed, 99, 4);
if Length(Result) < 22 then
Result := StringOfChar('0', 22 - Length(Result)) + Result;
Result := PlusMinus[aInt < 0] + Result;
end;
ctCheck: Result := '';
end;
end;
function wbScaledInt4ToInt(const aString: string; const aElement: IwbElement): Int64;
var
f: Extended;
begin
f := StrToFloat(aString);
f := f * 10000;
Result := Round(f);
end;
function wbHideFFFF(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
if aType = ctToSortKey then
Result := IntToHex64(aInt, 4)
else if aType = ctToStr then
if aInt = $FFFF then
Result := 'None'
else
Result := IntToStr(aInt);
end;
function wbAtxtPosition(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
if aType = ctToSortKey then
Result := IntToHex64(aInt div 17, 2) + IntToHex64(aInt mod 17, 2)
else if aType = ctCheck then begin
if (aInt < 0) or (aInt > 288) then
Result := ''
else
Result := '';
end else if aType = ctToStr then
Result := IntToStr(aInt) + ' -> ' + IntToStr(aInt div 17) + ':' + IntToStr(aInt mod 17);
end;
function wbGLOBFNAM(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
case aType of
ctToStr: begin
case aInt of
Ord('s'): Result := 'Short';
Ord('l'): Result := 'Long';
Ord('f'): Result := 'Float';
else
Result := '';
end;
end;
ctToSortKey: Result := Chr(aInt);
ctCheck: begin
case aInt of
Ord('s'), Ord('l'), Ord('f'): Result := '';
else
Result := '';
end;
end;
end;
end;
function wbPlacedAddInfo(const aMainRecord: IwbMainRecord): string;
var
Rec: IwbRecord;
Container: IwbContainer;
s: string;
Cell: IwbMainRecord;
Position: TwbVector;
Grid: TwbGridCell;
begin
Result := '';
Rec := aMainRecord.RecordBySignature['NAME'];
if Assigned(Rec) then begin
s := Trim(Rec.Value);
if s <> '' then
Result := 'places ' + s;
end;
Container := aMainRecord.Container;
while Assigned(Container) and (Container.ElementType <> etGroupRecord) do
Container := Container.Container;
if Assigned(Container) then begin
s := Trim(Container.Name);
if s <> '' then begin
if Result <> '' then
Result := Result + ' ';
Result := Result + 'in ' + s;
// grid position of persistent reference in exterior persistent cell (interior cells are not persistent)
if Supports(aMainRecord.Container, IwbGroupRecord, Container) then
Cell := IwbGroupRecord(Container).ChildrenOf;
if Assigned(Cell) and Cell.IsPersistent and (Cell.Signature = 'CELL') then
if aMainRecord.GetPosition(Position) then begin
Grid := wbPositionToGridCell(Position);
Result := Result + ' at ' + IntToStr(Grid.x) + ',' + IntToStr(Grid.y);
end;
end;
end;
end;
function wbINFOAddInfo(const aMainRecord: IwbMainRecord): string;
var
Container: IwbContainer;
s: string;
begin
Result := Trim(aMainRecord.ElementValues['Responses\Response\NAM1']);
if Result <> '' then
Result := '''' + Result + '''';
Container := aMainRecord.Container;
while Assigned(Container) and (Container.ElementType <> etGroupRecord) do
Container := Container.Container;
if Assigned(Container) then begin
s := Trim(Container.Name);
if s <> '' then begin
if Result <> '' then
Result := Result + ' ';
Result := Result + 'in ' + s;
end;
end;
s := Trim(aMainRecord.ElementValues['QSTI']);
if s <> '' then begin
if Result <> '' then
Result := Result + ' ';
Result := Result + 'for ' + s;
end;
end;
function wbNAVMAddInfo(const aMainRecord: IwbMainRecord): string;
var
Rec : IwbRecord;
Element : IwbElement;
s : string;
begin
Result := '';
Rec := aMainRecord.RecordBySignature['DATA'];
if Assigned(Rec) then begin
Element := Rec.ElementByName['Cell'];
if Assigned(Element) then
Element := Element.LinksTo;
if Assigned(Element) then
s := Trim(Element.Name);
if s <> '' then
Result := 'for ' + s;
end;
end;
function wbCellAddInfo(const aMainRecord: IwbMainRecord): string;
var
Rec: IwbRecord;
Container: IwbContainer;
GroupRecord : IwbGroupRecord;
s: string;
begin
Result := '';
if not aMainRecord.IsPersistent then begin
Rec := aMainRecord.RecordBySignature['XCLC'];
if Assigned(Rec) then
Result := 'at ' + Rec.Elements[0].Value + ',' + Rec.Elements[1].Value;
end;
Container := aMainRecord.Container;
while Assigned(Container) and not
(Supports(Container, IwbGroupRecord, GroupRecord) and (GroupRecord.GroupType = 1)) do
Container := Container.Container;
if Assigned(Container) then begin
s := wbFormID.ToString(GroupRecord.GroupLabel, aMainRecord);
if s <> '' then begin
if Result <> '' then
s := s + ' ';
Result := 'in ' + s + Result;
end;
end;
end;
function wbWthrDataClassification(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
case aType of
ctToStr: begin
case aInt and not 192 of
0: Result := 'None';
1: Result := 'Pleasant';
2: Result := 'Cloudy';
4: Result := 'Rainy';
8: Result := 'Snow';
else
Result := '';
end;
end;
ctToSortKey: begin
Result := IntToHex64(aInt, 2)
end;
ctCheck: begin
case aInt and not 192 of
0, 1, 2, 4, 8: Result := '';
else
Result := '';
end;
end;
end;
end;
function wbNOTETNAMDecide(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
rDATA: IwbRecord;
begin
Result := 0;
rDATA := aElement.Container.RecordBySignature[DATA];
if Assigned(rDATA) then
if rDATA.NativeValue = 3 then //Voice
Result := 1;
end;
function wbNOTESNAMDecide(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
rDATA: IwbRecord;
begin
Result := 0;
rDATA := aElement.Container.RecordBySignature[DATA];
if Assigned(rDATA) then
if rDATA.NativeValue = 3 then //Voice
Result := 1;
end;
function wbIPDSDATACount(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
begin
if Assigned(aBasePtr) and Assigned(aEndPtr) then
Result := (Cardinal(aBasePtr) - Cardinal(aBasePtr)) div 4
else
Result := 12;
end;
function wbNAVINAVMGetCount1(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
DataContainer : IwbDataContainer;
begin
Result := 0;
if Supports(aElement, IwbDataContainer, DataContainer) then begin
if DataContainer.ElementType = etArray then
if not Supports(DataContainer.Container, IwbDataContainer, DataContainer) then
Exit;
Assert(DataContainer.Name = 'Data');
Result := PWord(Cardinal(DataContainer.DataBasePtr) + 3*3*4)^;
end;
end;
function wbNAVINAVMGetCount2(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
DataContainer : IwbDataContainer;
begin
Result := 0;
if Supports(aElement, IwbDataContainer, DataContainer) then begin
if DataContainer.ElementType = etArray then
if not Supports(DataContainer.Container, IwbDataContainer, DataContainer) then
Exit;
Assert(DataContainer.Name = 'Data');
Result := PWord(Cardinal(DataContainer.DataBasePtr) + 3*3*4 + 2)^;
end;
end;
procedure wbCTDARunOnAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
if aOldValue <> aNewValue then
if aNewValue <> 2 then
aElement.Container.ElementNativeValues['Reference'] := 0;
end;
procedure wbPERKPRKETypeAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container : IwbContainerElementRef;
// rDATA : IwbRecord;
begin
if aOldValue <> aNewValue then
if Supports(aElement.Container, IwbContainerElementRef, Container) then begin
if Supports(Container.Container, IwbContainerElementRef, Container) then begin
Container.RemoveElement('DATA');
Container.Add('DATA', True);
Container.RemoveElement('Perk Conditions');
Container.RemoveElement('Entry Point Function Parameters');
if aNewValue = 2 then begin
Container.Add('EPFT', True);
Container.ElementNativeValues['DATA\Entry Point\Function'] := 2;
end;
end;
end;
end;
function wbMGEFFAssocItemDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
Archtype : Variant;
DataContainer : IwbDataContainer;
Element : IwbElement;
const
OffsetArchtype = 56;
begin
Result := 1;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
VarClear(ArchType);
Element := Container.ElementByName['Archtype'];
if Assigned(Element) then
ArchType := Element.NativeValue
else if Supports(Container, IwbDataContainer, DataContainer) and
DataContainer.IsValidOffset(aBasePtr, aEndPtr, OffsetArchtype) then
begin // we are part of a proper structure
aBasePtr := Pointer(Cardinal(aBasePtr) + OffsetArchtype);
ArchType := PCardinal(aBasePtr)^;
end;
if not VarIsEmpty(ArchType) then
case Integer(ArchType) of
01: Result := 2;//Script
18: Result := 3;//Bound Item
19: Result := 4;//Summon Creature
else
Result := 0;
end;
end;
procedure wbMGEFFAssocItemAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container : IwbContainer;
Element : IwbElement;
begin
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if (aNewValue <> 0) then begin
Element := Container.ElementByName['Archtype'];
if Assigned(Element) and Element.NativeValue = 0 then
Element.NativeValue := $FF; // Signals ArchType that it should not mess with us on the next change!
end;
end;
procedure wbMGEFArchtypeAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container: IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if (aNewValue < $FF) and (aOldValue < $FF) then begin
Container.ElementNativeValues['..\Assoc. Item'] := 0;
case Integer(aNewValue) of
11: Container.ElementNativeValues['..\Actor Value'] := 48;//Invisibility
12: Container.ElementNativeValues['..\Actor Value'] := 49;//Chameleon
24: Container.ElementNativeValues['..\Actor Value'] := 47;//Paralysis
36: Container.ElementNativeValues['..\Actor Value'] := 51;//Turbo
else
Container.ElementNativeValues['..\Actor Value'] := -1;
end;
end;
end;
procedure wbCounterEffectsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterByPathAfterSet('DATA - Data\Counter effect count', aElement);
end;
procedure wbMGEFAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterContainerByPathAfterSet('DATA - Data\Counter effect count', 'Counter Effects', aElement);
end;
function wbCTDAReferenceDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Integer(Container.ElementNativeValues['Run On']) = 2 then
Result := 1;
end;
function wbNAVINVMIDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
case Integer(Container.ElementNativeValues['Type']) of
$00: Result :=1;
$20: Result :=2;
$30: Result :=3;
end;
end;
function wbIMGSSkinDimmerDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
SubRecord : IwbSubRecord;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Supports(Container, IwbSubRecord, SubRecord) then
if SubRecord.SubRecordHeaderSize in [132, 148] then
Result := 1;
end;
function wbCOEDOwnerDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
LinksTo : IwbElement;
MainRecord : IwbMainRecord;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
LinksTo := Container.ElementByName['Owner'].LinksTo;
if Supports(LinksTo, IwbMainRecord, MainRecord) then
if MainRecord.Signature = 'NPC_' then
Result := 1
else if MainRecord.Signature = 'FACT' then
Result := 2;
end;
function wbCreaLevelDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
i: Int64;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
i := Container.ElementByName['Flags'].NativeValue;
if i and $00000080 <> 0 then
Result := 1;
end;
function wbGMSTUnionDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
rEDID: IwbRecord;
s: string;
begin
Result := 1;
rEDID := aElement.Container.RecordBySignature[EDID];
if Assigned(rEDID) then begin
s := rEDID.Value;
if Length(s) > 0 then
case s[1] of
's': Result := 0;
'f': Result := 2;
end;
end;
end;
function wbFLSTLNAMIsSorted(const aContainer: IwbContainer): Boolean;
var
rEDID : IwbRecord;
s : string;
_File : IwbFile;
MainRecord : IwbMainRecord;
const
OrderedList = 'OrderedList';
begin
Result := wbSortFLST; {>>> Should not be sorted according to Arthmoor and JustinOther, left as sorted for compatibility <<<}
rEDID := aContainer.RecordBySignature[EDID];
if Assigned(rEDID) then begin
s := rEDID.Value;
if Length(s) > Length(OrderedList) then
Delete(s, 1, Length(s)-Length(OrderedList));
if SameText(s, OrderedList) then
Result := False;
end;
if Result then begin
MainRecord := aContainer.ContainingMainRecord;
if not Assigned(MainRecord) then
Exit;
MainRecord := MainRecord.MasterOrSelf;
if not Assigned(MainRecord) then
Exit;
_File := MainRecord._File;
if not Assigned(_File) then
Exit;
if not SameText(_File.FileName, 'WeaponModKits.esp') then
Exit;
case (MainRecord.FormID and $FFFFFF) of
$0130EB, $0130ED, $01522D, $01522E, $0158D5, $0158D6, $0158D7, $0158D8, $0158D9, $0158DA, $0158DC, $0158DD, $018E20:
Result := False;
end;
end;
end;
function wbPerkDATADecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
rPRKE: IwbRecord;
eType: IwbElement;
begin
Result := 0;
rPRKE := aElement.Container.RecordBySignature[PRKE];
if Assigned(rPRKE) then begin
eType := rPRKE.ElementByName['Type'];
if Assigned(eType) then begin
Result := eType.NativeValue;
end;
end;
end;
function wbEPFDDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainerElementRef;
begin
Result := 0;
if not Assigned(aElement) then
Exit;
if not Supports(aElement.Container, IwbContainerElementRef, Container) then
Exit;
Result := Container.ElementNativeValues['EPFT'];
if Result = 2 then
if Integer(Container.ElementNativeValues['..\DATA\Entry Point\Function']) = 5 then
Result := 5;
end;
type
TCTDAFunctionParamType = (
ptNone,
ptInteger,
ptVariableName, //Integer
ptSex, //Enum: Male, Female
ptActorValue, //Enum: wbActorValue
ptCrimeType, //?? Enum
ptAxis, //?? Char
ptQuestStage, //?? Integer
ptMiscStat, //?? Enum
ptAlignment, //?? Enum
ptEquipType, //?? Enum
ptFormType, //?? Enum
ptCriticalStage, //?? Enum
ptObjectReference, //REFR, ACHR, ACRE, PGRE
ptInventoryObject, //ARMO, BOOK, MISC, WEAP, AMMO, KEYM, ALCH, NOTE, ARMA
ptActor, //ACHR, ACRE
ptVoiceType, //VTYP
ptIdleForm, //IDLE
ptFormList, //FLST
ptNote, //NOTE
ptQuest, //QUST
ptFaction, //FACT
ptWeapon, //WEAP
ptCell, //CELL
ptClass, //CLAS
ptRace, //RACE
ptActorBase, //NPC_, CREA
ptGlobal, //GLOB
ptWeather, //WTHR
ptPackage, //PACK
ptEncounterZone, //ECZN
ptPerk, //PERK
ptOwner, //FACT, NPC_
ptFurniture, //FURN
ptMagicItem, //SPEL
ptMagicEffect, //MGEF
ptWorldspace, //WRLD
ptVATSValueFunction,
ptVATSValueParam,
ptCreatureType,
ptMenuMode,
ptPlayerAction,
ptBodyLocation,
ptReferencableObject, //TREE, SOUN, ACTI, DOOR, STAT, FURN, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS, ASPC, IDLM, ARMA, MSTT, NOTE, PWAT, SCOL, TACT, TERM
ptQuestObjective, //?? Integer
ptReputation, //REPU
ptRegion, //REGN
ptChallenge, //CHAL
ptCasino, //CSNO
ptAnyForm // Any form
);
PCTDAFunction = ^TCTDAFunction;
TCTDAFunction = record
Index: Integer;
Name: string;
ParamType1: TCTDAFunctionParamType;
ParamType2: TCTDAFunctionParamType;
end;
const
wbCTDAFunctions : array[0..288] of TCTDAFunction = (
(Index: 1; Name: 'GetDistance'; ParamType1: ptObjectReference),
(Index: 5; Name: 'GetLocked'),
(Index: 6; Name: 'GetPos'; ParamType1: ptAxis),
(Index: 8; Name: 'GetAngle'; ParamType1: ptAxis),
(Index: 10; Name: 'GetStartingPos'; ParamType1: ptAxis),
(Index: 11; Name: 'GetStartingAngle'; ParamType1: ptAxis),
(Index: 12; Name: 'GetSecondsPassed'),
(Index: 14; Name: 'GetActorValue'; ParamType1: ptActorValue),
(Index: 18; Name: 'GetCurrentTime'),
(Index: 24; Name: 'GetScale'),
(Index: 25; Name: 'IsMoving'),
(Index: 26; Name: 'IsTurning'),
(Index: 27; Name: 'GetLineOfSight'; ParamType1: ptObjectReference),
(Index: 32; Name: 'GetInSameCell'; ParamType1: ptObjectReference),
(Index: 35; Name: 'GetDisabled'),
(Index: 36; Name: 'MenuMode'; ParamType1: ptMenuMode),
(Index: 39; Name: 'GetDisease'),
(Index: 40; Name: 'GetVampire'),
(Index: 41; Name: 'GetClothingValue'),
(Index: 42; Name: 'SameFaction'; ParamType1: ptActor),
(Index: 43; Name: 'SameRace'; ParamType1: ptActor),
(Index: 44; Name: 'SameSex'; ParamType1: ptActor),
(Index: 45; Name: 'GetDetected'; ParamType1: ptActor),
(Index: 46; Name: 'GetDead'),
(Index: 47; Name: 'GetItemCount'; ParamType1: ptInventoryObject),
(Index: 48; Name: 'GetGold'),
(Index: 49; Name: 'GetSleeping'),
(Index: 50; Name: 'GetTalkedToPC'),
(Index: 53; Name: 'GetScriptVariable'; ParamType1: ptObjectReference; ParamType2: ptVariableName),
(Index: 56; Name: 'GetQuestRunning'; ParamType1: ptQuest),
(Index: 58; Name: 'GetStage'; ParamType1: ptQuest),
(Index: 59; Name: 'GetStageDone'; ParamType1: ptQuest; ParamType2: ptQuestStage),
(Index: 60; Name: 'GetFactionRankDifference'; ParamType1: ptFaction; ParamType2: ptActor),
(Index: 61; Name: 'GetAlarmed'),
(Index: 62; Name: 'IsRaining'),
(Index: 63; Name: 'GetAttacked'),
(Index: 64; Name: 'GetIsCreature'),
(Index: 65; Name: 'GetLockLevel'),
(Index: 66; Name: 'GetShouldAttack'; ParamType1: ptActor),
(Index: 67; Name: 'GetInCell'; ParamType1: ptCell),
(Index: 68; Name: 'GetIsClass'; ParamType1: ptClass),
(Index: 69; Name: 'GetIsRace'; ParamType1: ptRace),
(Index: 70; Name: 'GetIsSex'; ParamType1: ptSex),
(Index: 71; Name: 'GetInFaction'; ParamType1: ptFaction),
(Index: 72; Name: 'GetIsID'; ParamType1: ptReferencableObject),
(Index: 73; Name: 'GetFactionRank'; ParamType1: ptFaction),
(Index: 74; Name: 'GetGlobalValue'; ParamType1: ptGlobal),
(Index: 75; Name: 'IsSnowing'),
(Index: 76; Name: 'GetDisposition'; ParamType1: ptActor),
(Index: 77; Name: 'GetRandomPercent'),
(Index: 79; Name: 'GetQuestVariable'; ParamType1: ptQuest; ParamType2: ptVariableName),
(Index: 80; Name: 'GetLevel'),
(Index: 81; Name: 'GetArmorRating'),
(Index: 84; Name: 'GetDeadCount'; ParamType1: ptActorBase),
(Index: 91; Name: 'GetIsAlerted'),
(Index: 98; Name: 'GetPlayerControlsDisabled'; ParamType1: ptInteger; ParamType2: ptInteger{; ParamType3: ptInteger; ParamType4: ptInteger; ParamType5: ptInteger; ParamType6: ptInteger; ParamType7: ptInteger}),
(Index: 99; Name: 'GetHeadingAngle'; ParamType1: ptObjectReference),
(Index: 101; Name: 'IsWeaponOut'),
(Index: 102; Name: 'IsTorchOut'),
(Index: 103; Name: 'IsShieldOut'),
(Index: 106; Name: 'IsFacingUp'),
(Index: 107; Name: 'GetKnockedState'),
(Index: 108; Name: 'GetWeaponAnimType'),
(Index: 109; Name: 'IsWeaponSkillType'; ParamType1: ptActorValue),
(Index: 110; Name: 'GetCurrentAIPackage'),
(Index: 111; Name: 'IsWaiting'),
(Index: 112; Name: 'IsIdlePlaying'),
(Index: 116; Name: 'GetMinorCrimeCount'),
(Index: 117; Name: 'GetMajorCrimeCount'),
(Index: 118; Name: 'GetActorAggroRadiusViolated'),
(Index: 122; Name: 'GetCrime'; ParamType1: ptActor; ParamType2: ptCrimeType),
(Index: 123; Name: 'IsGreetingPlayer'),
(Index: 125; Name: 'IsGuard'),
(Index: 127; Name: 'HasBeenEaten'),
(Index: 128; Name: 'GetFatiguePercentage'),
(Index: 129; Name: 'GetPCIsClass'; ParamType1: ptClass),
(Index: 130; Name: 'GetPCIsRace'; ParamType1: ptRace),
(Index: 131; Name: 'GetPCIsSex'; ParamType1: ptSex),
(Index: 132; Name: 'GetPCInFaction'; ParamType1: ptFaction),
(Index: 133; Name: 'SameFactionAsPC'),
(Index: 134; Name: 'SameRaceAsPC'),
(Index: 135; Name: 'SameSexAsPC'),
(Index: 136; Name: 'GetIsReference'; ParamType1: ptObjectReference),
(Index: 141; Name: 'IsTalking'),
(Index: 142; Name: 'GetWalkSpeed'),
(Index: 143; Name: 'GetCurrentAIProcedure'),
(Index: 144; Name: 'GetTrespassWarningLevel'),
(Index: 145; Name: 'IsTrespassing'),
(Index: 146; Name: 'IsInMyOwnedCell'),
(Index: 147; Name: 'GetWindSpeed'),
(Index: 148; Name: 'GetCurrentWeatherPercent'),
(Index: 149; Name: 'GetIsCurrentWeather'; ParamType1: ptWeather),
(Index: 150; Name: 'IsContinuingPackagePCNear'),
(Index: 153; Name: 'CanHaveFlames'),
(Index: 154; Name: 'HasFlames'),
(Index: 157; Name: 'GetOpenState'),
(Index: 159; Name: 'GetSitting'),
(Index: 160; Name: 'GetFurnitureMarkerID'),
(Index: 161; Name: 'GetIsCurrentPackage'; ParamType1: ptPackage),
(Index: 162; Name: 'IsCurrentFurnitureRef'; ParamType1: ptObjectReference),
(Index: 163; Name: 'IsCurrentFurnitureObj'; ParamType1: ptFurniture),
(Index: 170; Name: 'GetDayOfWeek'),
(Index: 172; Name: 'GetTalkedToPCParam'; ParamType1: ptActor),
(Index: 175; Name: 'IsPCSleeping'),
(Index: 176; Name: 'IsPCAMurderer'),
(Index: 180; Name: 'GetDetectionLevel'; ParamType1: ptActor),
(Index: 182; Name: 'GetEquipped'; ParamType1: ptInventoryObject),
(Index: 185; Name: 'IsSwimming'),
(Index: 190; Name: 'GetAmountSoldStolen'),
(Index: 192; Name: 'GetIgnoreCrime'),
(Index: 193; Name: 'GetPCExpelled'; ParamType1: ptFaction),
(Index: 195; Name: 'GetPCFactionMurder'; ParamType1: ptFaction),
(Index: 197; Name: 'GetPCEnemyofFaction'; ParamType1: ptFaction),
(Index: 199; Name: 'GetPCFactionAttack'; ParamType1: ptFaction),
(Index: 203; Name: 'GetDestroyed'),
(Index: 214; Name: 'HasMagicEffect'; ParamType1: ptMagicEffect),
(Index: 215; Name: 'GetDefaultOpen'),
(Index: 219; Name: 'GetAnimAction'),
(Index: 223; Name: 'IsSpellTarget'; ParamType1: ptMagicItem),
(Index: 224; Name: 'GetVATSMode'),
(Index: 225; Name: 'GetPersuasionNumber'),
(Index: 226; Name: 'GetSandman'),
(Index: 227; Name: 'GetCannibal'),
(Index: 228; Name: 'GetIsClassDefault'; ParamType1: ptClass),
(Index: 229; Name: 'GetClassDefaultMatch'),
(Index: 230; Name: 'GetInCellParam'; ParamType1: ptCell; ParamType2: ptObjectReference),
(Index: 235; Name: 'GetVatsTargetHeight'),
(Index: 237; Name: 'GetIsGhost'),
(Index: 242; Name: 'GetUnconscious'),
(Index: 244; Name: 'GetRestrained'),
(Index: 246; Name: 'GetIsUsedItem'; ParamType1: ptReferencableObject),
(Index: 247; Name: 'GetIsUsedItemType'; ParamType1: ptFormType),
(Index: 254; Name: 'GetIsPlayableRace'),
(Index: 255; Name: 'GetOffersServicesNow'),
(Index: 258; Name: 'GetUsedItemLevel'),
(Index: 259; Name: 'GetUsedItemActivate'),
(Index: 264; Name: 'GetBarterGold'),
(Index: 265; Name: 'IsTimePassing'),
(Index: 266; Name: 'IsPleasant'),
(Index: 267; Name: 'IsCloudy'),
(Index: 274; Name: 'GetArmorRatingUpperBody'),
(Index: 277; Name: 'GetBaseActorValue'; ParamType1: ptActorValue),
(Index: 278; Name: 'IsOwner'; ParamType1: ptOwner),
(Index: 280; Name: 'IsCellOwner'; ParamType1: ptCell; ParamType2: ptOwner),
(Index: 282; Name: 'IsHorseStolen'),
(Index: 285; Name: 'IsLeftUp'),
(Index: 286; Name: 'IsSneaking'),
(Index: 287; Name: 'IsRunning'),
(Index: 288; Name: 'GetFriendHit'),
(Index: 289; Name: 'IsInCombat'),
(Index: 300; Name: 'IsInInterior'),
(Index: 304; Name: 'IsWaterObject'),
(Index: 306; Name: 'IsActorUsingATorch'),
(Index: 309; Name: 'IsXBox'),
(Index: 310; Name: 'GetInWorldspace'; ParamType1: ptWorldSpace),
(Index: 312; Name: 'GetPCMiscStat'; ParamType1: ptMiscStat),
(Index: 313; Name: 'IsActorEvil'),
(Index: 314; Name: 'IsActorAVictim'),
(Index: 315; Name: 'GetTotalPersuasionNumber'),
(Index: 318; Name: 'GetIdleDoneOnce'),
(Index: 320; Name: 'GetNoRumors'),
(Index: 323; Name: 'WhichServiceMenu'),
(Index: 327; Name: 'IsRidingHorse'),
(Index: 332; Name: 'IsInDangerousWater'),
(Index: 338; Name: 'GetIgnoreFriendlyHits'),
(Index: 339; Name: 'IsPlayersLastRiddenHorse'),
(Index: 353; Name: 'IsActor'),
(Index: 354; Name: 'IsEssential'),
(Index: 358; Name: 'IsPlayerMovingIntoNewSpace'),
(Index: 361; Name: 'GetTimeDead'),
(Index: 362; Name: 'GetPlayerHasLastRiddenHorse'),
(Index: 365; Name: 'IsChild'),
(Index: 367; Name: 'GetLastPlayerAction'),
(Index: 368; Name: 'IsPlayerActionActive'; ParamType1: ptPlayerAction),
(Index: 370; Name: 'IsTalkingActivatorActor'; ParamType1: ptActor),
(Index: 372; Name: 'IsInList'; ParamType1: ptFormList),
(Index: 382; Name: 'GetHasNote'; ParamType1: ptNote),
(Index: 391; Name: 'GetHitLocation'),
(Index: 392; Name: 'IsPC1stPerson'),
(Index: 397; Name: 'GetCauseofDeath'),
(Index: 398; Name: 'IsLimbGone'; ParamType1: ptBodyLocation),
(Index: 399; Name: 'IsWeaponInList'; ParamType1: ptFormList),
(Index: 403; Name: 'HasFriendDisposition'),
(Index: 408; Name: 'GetVATSValue'; ParamType1: ptVATSValueFunction; ParamType2: ptVATSValueParam),
(Index: 409; Name: 'IsKiller'; ParamType1: ptActor),
(Index: 410; Name: 'IsKillerObject'; ParamType1: ptFormList),
(Index: 411; Name: 'GetFactionCombatReaction'; ParamType1: ptFaction; ParamType2: ptFaction),
(Index: 415; Name: 'Exists'; ParamType1: ptObjectReference),
(Index: 416; Name: 'GetGroupMemberCount'),
(Index: 417; Name: 'GetGroupTargetCount'),
(Index: 420; Name: 'GetObjectiveCompleted'; ParamType1: ptQuest; ParamType2: ptQuestObjective),
(Index: 421; Name: 'GetObjectiveDisplayed'; ParamType1: ptQuest; ParamType2: ptQuestObjective),
(Index: 427; Name: 'GetIsVoiceType'; ParamType1: ptVoiceType),
(Index: 428; Name: 'GetPlantedExplosive'),
(Index: 430; Name: 'IsActorTalkingThroughActivator'),
(Index: 431; Name: 'GetHealthPercentage'),
(Index: 433; Name: 'GetIsObjectType'; ParamType1: ptFormType),
(Index: 435; Name: 'GetDialogueEmotion'),
(Index: 436; Name: 'GetDialogueEmotionValue'),
(Index: 438; Name: 'GetIsCreatureType'; ParamType1: ptCreatureType),
(Index: 446; Name: 'GetInZone'; ParamType1: ptEncounterZone),
(Index: 449; Name: 'HasPerk'; ParamType1: ptPerk; ParamType2: ptInteger {boolean Alt}), // PlayerCharacter has 2 lists of perks
(Index: 450; Name: 'GetFactionRelation'; ParamType1: ptActor),
(Index: 451; Name: 'IsLastIdlePlayed'; ParamType1: ptIdleForm),
(Index: 454; Name: 'GetPlayerTeammate'),
(Index: 455; Name: 'GetPlayerTeammateCount'),
(Index: 459; Name: 'GetActorCrimePlayerEnemy'),
(Index: 460; Name: 'GetActorFactionPlayerEnemy'),
(Index: 462; Name: 'IsPlayerTagSkill'; ParamType1: ptActorValue),
(Index: 464; Name: 'IsPlayerGrabbedRef'; ParamType1: ptObjectReference),
(Index: 471; Name: 'GetDestructionStage'),
(Index: 474; Name: 'GetIsAlignment'; ParamType1: ptAlignment),
(Index: 478; Name: 'GetThreatRatio'; ParamType1: ptActor),
(Index: 480; Name: 'GetIsUsedItemEquipType'; ParamType1: ptEquipType),
(Index: 489; Name: 'GetConcussed'),
(Index: 492; Name: 'GetMapMarkerVisible'),
(Index: 495; Name: 'GetPermanentActorValue'; ParamType1: ptActorValue),
(Index: 496; Name: 'GetKillingBlowLimb'),
(Index: 500; Name: 'GetWeaponHealthPerc'),
(Index: 503; Name: 'GetRadiationLevel'),
(Index: 510; Name: 'GetLastHitCritical'),
(Index: 515; Name: 'IsCombatTarget'; ParamType1: ptActor),
(Index: 518; Name: 'GetVATSRightAreaFree'; ParamType1: ptObjectReference),
(Index: 519; Name: 'GetVATSLeftAreaFree'; ParamType1: ptObjectReference),
(Index: 520; Name: 'GetVATSBackAreaFree'; ParamType1: ptObjectReference),
(Index: 521; Name: 'GetVATSFrontAreaFree'; ParamType1: ptObjectReference),
(Index: 522; Name: 'GetIsLockBroken'),
(Index: 523; Name: 'IsPS3'),
(Index: 524; Name: 'IsWin32'),
(Index: 525; Name: 'GetVATSRightTargetVisible'; ParamType1: ptObjectReference),
(Index: 526; Name: 'GetVATSLeftTargetVisible'; ParamType1: ptObjectReference),
(Index: 527; Name: 'GetVATSBackTargetVisible'; ParamType1: ptObjectReference),
(Index: 528; Name: 'GetVATSFrontTargetVisible'; ParamType1: ptObjectReference),
(Index: 531; Name: 'IsInCriticalStage'; ParamType1: ptCriticalStage),
(Index: 533; Name: 'GetXPForNextLevel'),
(Index: 546; Name: 'GetQuestCompleted'; ParamType1: ptQuest),
(Index: 550; Name: 'IsGoreDisabled'),
(Index: 555; Name: 'GetSpellUsageNum'; ParamType1: ptMagicItem),
(Index: 557; Name: 'GetActorsInHigh'),
(Index: 558; Name: 'HasLoaded3D'),
(Index: 573; Name: 'GetReputation'; ParamType1: ptReputation; ParamType2: ptInteger),
(Index: 574; Name: 'GetReputationPct'; ParamType1: ptReputation; ParamType2: ptInteger),
(Index: 575; Name: 'GetReputationThreshold'; ParamType1: ptReputation; ParamType2: ptInteger),
(Index: 586; Name: 'IsHardcore'),
(Index: 601; Name: 'GetForceHitReaction'),
(Index: 607; Name: 'ChallengeLocked'; ParamType1: ptChallenge),
(Index: 610; Name: 'GetCasinoWinningStage'; ParamType1: ptCasino),
(Index: 612; Name: 'PlayerInRegion'; ParamType1: ptRegion),
(Index: 614; Name: 'GetChallengeCompleted'; ParamType1: ptChallenge),
(Index: 619; Name: 'IsAlwaysHardcore'),
// Added by NVSE
(Index: 1024; Name: 'GetNVSEVersion'; ),
(Index: 1025; Name: 'GetNVSERevision'; ),
(Index: 1026; Name: 'GetNVSEBeta'; ),
(Index: 1028; Name: 'GetWeight'; ParamType1: ptInventoryObject; ),
(Index: 1076; Name: 'GetWeaponHasScope'; ParamType1: ptInventoryObject; ),
(Index: 1089; Name: 'ListGetFormIndex'; ParamType1: ptFormList; ParamType2: ptFormType;),
(Index: 1107; Name: 'IsKeyPressed'; ParamType1: ptInteger; ParamType2: ptInteger;),
(Index: 1131; Name: 'IsControlPressed'; ParamType1: ptInteger; ),
(Index: 1271; Name: 'HasOwnership'; ParamType1: ptObjectReference; ),
(Index: 1272; Name: 'IsOwned'; ParamType1: ptActor ),
(Index: 1274; Name: 'GetDialogueTarget'; ParamType1: ptActor; ),
(Index: 1275; Name: 'GetDialogueSubject'; ParamType1: ptActor; ),
(Index: 1276; Name: 'GetDialogueSpeaker'; ParamType1: ptActor; ),
(Index: 1278; Name: 'GetAgeClass'; ParamType1: ptActorBase; ),
(Index: 1286; Name: 'GetTokenValue'; ParamType1: ptFormType; ),
(Index: 1288; Name: 'GetTokenRef'; ParamType1: ptFormType; ),
(Index: 1291; Name: 'GetPaired'; ParamType1: ptInventoryObject; ParamType2: ptActorBase;),
(Index: 1292; Name: 'GetRespawn'; ParamType1: ptACtorBase; ),
(Index: 1294; Name: 'GetPermanent'; ParamType1: ptObjectReference; ),
(Index: 1297; Name: 'IsRefInList'; ParamType1: ptFormList; ParamType2: ptFormType;),
(Index: 1301; Name: 'GetPackageCount'; ParamType1: ptObjectReference; ),
(Index: 1440; Name: 'IsPlayerSwimming'; ),
(Index: 1441; Name: 'GetTFC'; ),
(Index: 1475; Name: 'GetPerkRank'; ParamType1: ptPerk; ParamType2: ptActor;),
(Index: 1476; Name: 'GetAltPerkRank'; ParamType1: ptPerk; ParamType2: ptActor;),
(Index: 1541; Name: 'GetActorFIKstatus'; ),
// Added by nvse_plugin_ExtendedActorVariable
(Index: 4352; Name: 'GetExtendedActorVariable'; ParamType1: ptInventoryObject; ),
(Index: 4353; Name: 'GetBaseExtendedActorVariable'; ParamType1: ptInventoryObject; ),
(Index: 4355; Name: 'GetModExtendedActorVariable'; ParamType1: ptInventoryObject; ),
// Added by nvse_extender
(Index: 4420; Name: 'NX_GetEVFl'; ParamType1: ptNone; ), // Actually ptString, but it cannot be used in GECK
(Index: 4426; Name: 'NX_GetQVEVFl'; ParamType1: ptQuest; ParamType2: ptInteger;),
// Added by lutana_nvse
(Index: 4708; Name: 'GetArmorClass'; ParamType1: ptAnyForm; ),
(Index: 4709; Name: 'IsRaceInList'; ParamType1: ptFormList; ),
(Index: 4822; Name: 'GetReferenceFlag'; ParamType1: ptInteger; ),
// Added by JIP NVSE Plugin
(Index: 5637; Name: 'GetIsPoisoned'; ),
(Index: 5708; Name: 'IsEquippedWeaponSilenced'; ),
(Index: 5709; Name: 'IsEquippedWeaponScoped'; ),
(Index: 5953; Name: 'GetPCInRegion'; ParamType1: ptRegion; ),
(Index: 5962; Name: 'GetPCDetectionState'; )
);
var
wbCTDAFunctionEditInfo: string;
function wbCTDAParamDescFromIndex(aIndex: Integer): PCTDAFunction;
var
L, H, I, C: Integer;
begin
Result := nil;
L := Low(wbCTDAFunctions);
H := High(wbCTDAFunctions);
while L <= H do begin
I := (L + H) shr 1;
C := CmpW32(wbCTDAFunctions[I].Index, aIndex);
if C < 0 then
L := I + 1
else begin
H := I - 1;
if C = 0 then begin
L := I;
Result := @wbCTDAFunctions[L];
end;
end;
end;
end;
function wbCTDACompValueDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Integer(Container.ElementByName['Type'].NativeValue) and $04 <> 0 then
Result := 1;
end;
function wbCTDAParam1Decider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Desc: PCTDAFunction;
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Desc := wbCTDAParamDescFromIndex(Container.ElementByName['Function'].NativeValue);
if Assigned(Desc) then
Result := Succ(Integer(Desc.ParamType1));
end;
function wbCTDAParam2VATSValueParam(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Result := Container.ElementByName['Parameter #1'].NativeValue;
end;
function wbCTDAParam2Decider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Desc: PCTDAFunction;
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Desc := wbCTDAParamDescFromIndex(Container.ElementByName['Function'].NativeValue);
if Assigned(Desc) then
Result := Succ(Integer(Desc.ParamType2));
end;
function wbCTDAFunctionToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Desc : PCTDAFunction;
i : Integer;
begin
Result := '';
case aType of
ctToStr, ctToEditValue: begin
Desc := wbCTDAParamDescFromIndex(aInt);
if Assigned(Desc) then
Result := Desc.Name
else if aType = ctToEditValue then
Result := IntToStr(aInt)
else
Result := '';
end;
ctToSortKey: Result := IntToHex(aInt, 8);
ctCheck: begin
Desc := wbCTDAParamDescFromIndex(aInt);
if Assigned(Desc) then
Result := ''
else
Result := '';
end;
ctEditType:
Result := 'ComboBox';
ctEditInfo: begin
Result := wbCTDAFunctionEditInfo;
if Result = '' then begin
with TStringList.Create do try
for i := Low(wbCTDAFunctions) to High(wbCTDAFunctions) do
Add(wbCTDAFunctions[i].Name);
Sort;
Result := CommaText;
finally
Free;
end;
wbCTDAFunctionEditInfo := Result;
end;
end;
end;
end;
function wbCTDAFunctionToInt(const aString: string; const aElement: IwbElement): Int64;
var
i: Integer;
begin
for i := Low(wbCTDAFunctions) to High(wbCTDAFunctions) do
with wbCTDAFunctions[i] do
if SameText(Name, aString) then begin
Result := Index;
Exit;
end;
Result := StrToInt64(aString);
end;
type
TPERKEntryPointConditionType = (
epcDefault,
epcItem,
epcWeapon,
epcWeaponTarget,
epcTarget,
epcAttacker,
epcAttackerAttackee,
epcAttackerAttackerWeapon
);
TPERKEntryPointFunctionType = (
epfFloat,
epfLeveledItem,
epfScript,
epfUnknown
);
TPERKEntryPointFunctionParamType = (
epfpNone,
epfpFloat,
epfpFloatFloat,
epfpLeveledItem,
epfpScript
);
PPERKEntryPoint = ^TPERKEntryPoint;
TPERKEntryPoint = record
Name : string;
Condition : TPERKEntryPointConditionType;
FunctionType : TPERKEntryPointFunctionType;
end;
PPERKCondition = ^TPERKCondition;
TPERKCondition = record
Count : Integer;
Caption1 : string;
Caption2 : string;
Caption3 : string;
end;
PPERKFunction = ^TPERKFunction;
TPERKFunction = record
Name : string;
FunctionType : TPERKEntryPointFunctionType;
ParamType : TPERKEntryPointFunctionParamType;
end;
const
wbPERKCondition : array[TPERKEntryPointConditionType] of TPERKCondition = (
(Count: 1; Caption1: 'Perk Owner'),
(Count: 2; Caption1: 'Perk Owner'; Caption2: 'Item'),
(Count: 2; Caption1: 'Perk Owner'; Caption2: 'Weapon'),
(Count: 3; Caption1: 'Perk Owner'; Caption2: 'Weapon'; Caption3: 'Target'),
(Count: 2; Caption1: 'Perk Owner'; Caption2: 'Target'),
(Count: 2; Caption1: 'Perk Owner'; Caption2: 'Attacker'),
(Count: 3; Caption1: 'Perk Owner'; Caption2: 'Attacker'; Caption3: 'Attackee'),
(Count: 3; Caption1: 'Perk Owner'; Caption2: 'Attacker'; Caption3: 'Attacker Weapon')
);
wbPERKFunctions : array[0..9] of TPERKFunction = (
(Name: ''; FunctionType: epfUnknown; ParamType: epfpNone),
(Name: 'Set Value'; FunctionType: epfFloat; ParamType: epfpFloat),
(Name: 'Add Value'; FunctionType: epfFloat; ParamType: epfpFloat),
(Name: 'Multiply Value'; FunctionType: epfFloat; ParamType: epfpFloat),
(Name: 'Add Range To Value'; FunctionType: epfFloat; ParamType: epfpFloatFloat),
(Name: 'Add Actor Value Mult'; FunctionType: epfFloat; ParamType: epfpFloatFloat),
(Name: 'Absolute Value'; FunctionType: epfFloat; ParamType: epfpNone),
(Name: 'Negative Absolute Value'; FunctionType: epfFloat; ParamType: epfpNone),
(Name: 'Add Leveled List'; FunctionType: epfLeveledItem; ParamType: epfpLeveledItem),
(Name: 'Add Activate Choice'; FunctionType: epfScript; ParamType: epfpScript)
);
wbPERKEntryPoints : array[0..73] of TPERKEntryPoint = (
(Name: 'Calculate Weapon Damage'; Condition: epcWeaponTarget),
(Name: 'Calculate My Critical Hit Chance'; Condition: epcWeaponTarget),
(Name: 'Calculate My Critical Hit Damage'; Condition: epcWeaponTarget),
(Name: 'Calculate Weapon Attack AP Cost'; Condition: epcWeapon),
(Name: 'Calculate Mine Explode Chance'; Condition: epcItem),
(Name: 'Adjust Range Penalty'; Condition: epcWeapon),
(Name: 'Adjust Limb Damage'; Condition: epcAttackerAttackerWeapon),
(Name: 'Calculate Weapon Range'; Condition: epcWeapon),
(Name: 'Calculate To Hit Chance'; Condition: epcWeaponTarget),
(Name: 'Adjust Experience Points'),
(Name: 'Adjust Gained Skill Points'),
(Name: 'Adjust Book Skill Points'),
(Name: 'Modify Recovered Health'),
(Name: 'Calculate Inventory AP Cost'),
(Name: 'Get Disposition'; Condition: epcTarget),
(Name: 'Get Should Attack'; Condition: epcAttacker),
(Name: 'Get Should Assist'; Condition: epcAttackerAttackee),
(Name: 'Calculate Buy Price'; Condition: epcItem),
(Name: 'Get Bad Karma'),
(Name: 'Get Good Karma'),
(Name: 'Ignore Locked Terminal'),
(Name: 'Add Leveled List On Death'; Condition: epcTarget; FunctionType: epfLeveledItem),
(Name: 'Get Max Carry Weight'),
(Name: 'Modify Addiction Chance'),
(Name: 'Modify Addiction Duration'),
(Name: 'Modify Positive Chem Duration'),
(Name: 'Adjust Drinking Radiation'),
(Name: 'Activate'; Condition: epcTarget; FunctionType: epfScript),
(Name: 'Mysterious Stranger'),
(Name: 'Has Paralyzing Palm'),
(Name: 'Hacking Science Bonus'),
(Name: 'Ignore Running During Detection'),
(Name: 'Ignore Broken Lock'),
(Name: 'Has Concentrated Fire'),
(Name: 'Calculate Gun Spread'; Condition: epcWeapon),
(Name: 'Player Kill AP Reward'; Condition: epcWeaponTarget),
{36}(Name: 'Modify Enemy Critical Hit Chance'; Condition: epcWeaponTarget),
{37}(Name: 'Reload Speed'; Condition: epcWeapon),
{38}(Name: 'Equip Speed'; Condition: epcWeapon),
{39}(Name: 'Action Point Regen'; Condition: epcWeapon),
{40}(Name: 'Action Point Cost'; Condition: epcWeapon),
{41}(Name: 'Miss Fortune'; Condition: epcDefault),
{42}(Name: 'Modify Run Speed'; Condition: epcDefault),
{43}(Name: 'Modify Attack Speed'; Condition: epcWeapon),
{44}(Name: 'Modify Radiation Consumed'; Condition: epcDefault),
{45}(Name: 'Has Pip Hacker'; Condition: epcDefault),
{46}(Name: 'Has Meltdown'; Condition: epcDefault),
{47}(Name: 'See Enemy Health'; Condition: epcDefault),
{48}(Name: 'Has Jury Rigging'; Condition: epcDefault),
{49}(Name: 'Modify Threat Range'; Condition: epcWeapon),
{50}(Name: 'Modify Thread'; Condition: epcWeapon),
{51}(Name: 'Has Fast Travel Always'; Condition: epcDefault),
{52}(Name: 'Knockdown Chance'; Condition: epcWeapon),
{53}(Name: 'Modify Weapon Strength Req'; Condition: epcWeapon),
{54}(Name: 'Modify Aiming Move Speed'; Condition: epcWeapon),
{55}(Name: 'Modify Light Items'; Condition: epcDefault),
{56}(Name: 'Modify Damage Threshold (defender)'; Condition: epcWeaponTarget),
{57}(Name: 'Modify Chance for Ammo Item'; Condition: epcWeapon),
{58}(Name: 'Modify Damage Threshold (attacker)'; Condition: epcWeaponTarget),
{59}(Name: 'Modify Throwing Velocity'; Condition: epcWeapon),
{60}(Name: 'Chance for Item on Fire'; Condition: epcWeapon),
{61}(Name: 'Has Unarmed Forward Power Attack'; Condition: epcDefault),
{62}(Name: 'Has Unarmed Back Power Attack'; Condition: epcWeaponTarget),
{63}(Name: 'Has Unarmed Crouched Power Attack'; Condition: epcDefault),
{64}(Name: 'Has Unarmed Counter Attack'; Condition: epcWeaponTarget),
{65}(Name: 'Has Unarmed Left Power Attack'; Condition: epcDefault),
{66}(Name: 'Has Unarmed Right Power Attack'; Condition: epcDefault),
{67}(Name: 'VATS HelperChance'; Condition: epcDefault),
{68}(Name: 'Modify Item Damage'; Condition: epcDefault),
{69}(Name: 'Has Improved Detection'; Condition: epcDefault),
{70}(Name: 'Has Improved Spotting'; Condition: epcDefault),
{71}(Name: 'Has Improved Item Detection'; Condition: epcDefault),
{72}(Name: 'Adjust Explosion Radius'; Condition: epcWeapon),
{73}(Name: 'Reserved'; Condition: epcWeapon)
);
wbPERKFunctionParams: array[TPERKEntryPointFunctionParamType] of string = (
'None',
'Float',
'Float, Float',
'Leveled Item',
'Script'
);
procedure wbPERKEntryPointAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldEntryPoint : PPERKEntryPoint;
NewEntryPoint : PPERKEntryPoint;
OldCondition : PPERKCondition;
NewCondition : PPERKCondition;
OldFunction : PPERKFunction;
EntryPoint : IwbContainerElementRef;
Effect : IwbContainerElementRef;
PerkConditions : IwbContainerElementRef;
PerkCondition : IwbContainerElementRef;
Container : IwbContainerElementRef;
i : Integer;
begin
if aOldValue <> aNewValue then begin
OldEntryPoint := @wbPERKEntryPoints[Integer(aOldValue)];
NewEntryPoint := @wbPERKEntryPoints[Integer(aNewValue)];
OldCondition := @wbPERKCondition[OldEntryPoint.Condition];
NewCondition := @wbPERKCondition[NewEntryPoint.Condition];
if not Assigned(aElement) then
Exit;
if not Supports(aElement.Container, IwbContainerElementRef, EntryPoint) then
Exit;
i := EntryPoint.ElementNativeValues['Function'];
if (i >= Low(wbPERKFunctions)) and (i <= High(wbPERKFunctions)) then
OldFunction := @wbPERKFunctions[i]
else
OldFunction := nil;
if not Assigned(OldFunction) or (OldFunction.FunctionType <> NewEntryPoint.FunctionType) then
for i := Low(wbPERKFunctions) to High(wbPERKFunctions) do
with wbPERKFunctions[i] do
if FunctionType = NewEntryPoint.FunctionType then begin
EntryPoint.ElementNativeValues['Function'] := i;
Break;
end;
EntryPoint.ElementNativeValues['Perk Condition Tab Count'] := NewCondition.Count;
if not Supports(EntryPoint.Container, IwbContainerElementRef, Container) then
Exit;
if not Supports(Container.Container, IwbContainerElementRef, Effect) then
Exit;
if not Supports(Effect.ElementByName['Perk Conditions'], IwbContainerElementRef, PerkConditions) then
Exit;
for i := Pred(PerkConditions.ElementCount) downto 0 do
if Supports(PerkConditions.Elements[i], IwbContainerElementRef, PerkCondition) then
if Integer(PerkCondition.ElementNativeValues['PRKC']) >= NewCondition.Count then
PerkCondition.Remove
else
case Integer(PerkCondition.ElementNativeValues['PRKC']) of
2: if OldCondition.Caption2 <> NewCondition.Caption2 then
PerkCondition.Remove;
3: if OldCondition.Caption3 <> NewCondition.Caption3 then
PerkCondition.Remove;
end;
end;
end;
function wbPRKCToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
EntryPointVar : Variant;
EntryPoint : Integer;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
EntryPointVar := Container.ElementNativeValues['..\..\..\DATA\Entry Point\Entry Point'];
if VarIsNull(EntryPointVar) or VarIsClear(EntryPointVar) then
Exit;
EntryPoint := EntryPointVar;
if (EntryPoint < Low(wbPERKEntryPoints)) or (EntryPoint > High(wbPERKEntryPoints)) then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
with wbPERKEntryPoints[EntryPoint] do begin
with wbPERKCondition[Condition] do begin
case aType of
ctEditType: Result := 'ComboBox';
ctEditInfo: with TStringList.Create do try
if Caption1 <> '' then
Add(Caption1);
if Caption2 <> '' then
Add(Caption2);
if Caption3 <> '' then
Add(Caption3);
Sort;
Result := CommaText;
finally
Free;
end;
else
if (aInt < 0) or (aInt >= Count) then
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end
else
case aType of
ctToStr, ctToEditValue: case Integer(aInt) of
0: Result := Caption1;
1: Result := Caption2;
2: Result := Caption3;
end;
ctCheck: Result := '';
end;
end;
end;
end;
end;
function wbPRKCToInt(const aString: string; const aElement: IwbElement): Int64;
var
Container : IwbContainerElementRef;
EntryPointVar : Variant;
EntryPoint : Integer;
s : string;
begin
s := Trim(aString);
Result := StrToInt64Def(s, Low(Integer));
if Result <> Low(Integer) then
Exit;
if s = '' then begin
Result := 0;
Exit;
end;
if not Supports(aElement, IwbContainerElementRef, Container) then
raise Exception.Create('Could not resolve Entry Point');
EntryPointVar := Container.ElementNativeValues['..\..\..\DATA\Entry Point\Entry Point'];
if VarIsNull(EntryPointVar) or VarIsClear(EntryPointVar) then
raise Exception.Create('Could not resolve Entry Point');
EntryPoint := EntryPointVar;
if (EntryPoint < Low(wbPERKEntryPoints)) or (EntryPoint > High(wbPERKEntryPoints)) then
raise Exception.Create('Unknown Entry Point #'+IntToStr(EntryPoint));
with wbPERKEntryPoints[EntryPoint] do
with wbPERKCondition[Condition] do
if SameText(aString, Caption1) then
Result := 0
else if SameText(aString, Caption2) then
Result := 1
else if SameText(aString, Caption3) then
Result := 2
else
raise Exception.Create('"'+s+'" is not valid for this Entry Point');
end;
function wbNeverShow(const aElement: IwbElement): Boolean;
begin
Result := wbHideNeverShow;
end;
function GetREGNType(aElement: IwbElement): Integer;
var
Container: IwbContainerElementRef;
begin
Result := -1;
if not Assigned(aElement) then
Exit;
while aElement.Name <> 'Region Data Entry' do begin
aElement := aElement.Container;
if not Assigned(aElement) then
Exit;
end;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
Result := Container.ElementNativeValues['RDAT\Type'];
end;
function wbREGNObjectsDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 2;
end;
function wbREGNWeatherDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 3;
end;
function wbREGNMapDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 4;
end;
function wbREGNLandDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 5;
end;
function wbREGNGrassDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 6;
end;
function wbREGNSoundDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 7;
end;
function wbREGNImposterDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 8;
end;
function wbMESGTNAMDontShow(const aElement: IwbElement): Boolean;
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
Result := False;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Integer(Container.ElementNativeValues['DNAM']) and 1 <> 0 then
Result := True;
end;
function wbEPFDDontShow(const aElement: IwbElement): Boolean;
var
Container: IwbContainerElementRef;
begin
Result := False;
if aElement.Name <> 'Entry Point Function Parameters' then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if not (Integer(Container.ElementNativeValues['EPFT']) in [1..3]) then
Result := True;
end;
function wbTES4ONAMDontShow(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
Result := False;
if not Assigned(aElement) then
Exit;
MainRecord := aElement.ContainingMainRecord;
if not Assigned(MainRecord) then
Exit;
if not MainRecord.IsESM then
Result := True;
end;
function wbEPF2DontShow(const aElement: IwbElement): Boolean;
var
Container: IwbContainerElementRef;
begin
Result := False;
if aElement.Name <> 'Entry Point Function Parameters' then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if not (Integer(Container.ElementNativeValues['EPFT']) in [4]) then
Result := True;
end;
function wbPERKPRKCDontShow(const aElement: IwbElement): Boolean;
var
Container: IwbContainerElementRef;
begin
Result := False;
if aElement.Name <> 'Effect' then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Integer(Container.ElementNativeValues['PRKE\Type']) <> 2 then
Result := True;
end;
function wbPerkDATAFunctionToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
EntryPointVar : Variant;
EntryPoint : Integer;
i : Integer;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
EntryPointVar := Container.ElementNativeValues['..\Entry Point'];
if VarIsNull(EntryPointVar) or VarIsClear(EntryPointVar) then
Exit;
EntryPoint := EntryPointVar;
if (EntryPoint < Low(wbPERKEntryPoints)) or (EntryPoint > High(wbPERKEntryPoints)) then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
with wbPERKEntryPoints[EntryPoint] do begin
case aType of
ctEditType: Result := 'ComboBox';
ctEditInfo: with TStringList.Create do try
for i := Low(wbPERKFunctions) to High(wbPERKFunctions) do
if wbPERKFunctions[i].FunctionType = FunctionType then
if (wbPERKFunctions[i].Name <> '') then
Add(wbPERKFunctions[i].Name);
Sort;
Result := CommaText;
finally
Free;
end;
else
if (aInt < Low(wbPERKFunctions)) or (aInt > High(wbPERKFunctions)) then
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end
else
case aType of
ctToStr, ctToEditValue: begin
Result := wbPERKFunctions[Integer(aInt)].Name;
if (aType = ctToStr) and (wbPERKFunctions[Integer(aInt)].FunctionType <> FunctionType) then
Result := Result + ' ';
end;
ctCheck:
if wbPERKFunctions[Integer(aInt)].FunctionType <> FunctionType then
Result := ''
else
Result := '';
end;
end;
end;
end;
function wbPerkDATAFunctionToInt(const aString: string; const aElement: IwbElement): Int64;
var
Container : IwbContainerElementRef;
EntryPointVar : Variant;
EntryPoint : Integer;
s : string;
i : Integer;
begin
s := Trim(aString);
Result := StrToInt64Def(s, Low(Integer));
if Result <> Low(Integer) then
Exit;
if s = '' then
raise Exception.Create('"" is not a valid value for this field');
if not Supports(aElement, IwbContainerElementRef, Container) then
raise Exception.Create('Could not resolve Entry Point');
EntryPointVar := Container.ElementNativeValues['..\Entry Point'];
if VarIsNull(EntryPointVar) or VarIsClear(EntryPointVar) then
raise Exception.Create('Could not resolve Entry Point');
EntryPoint := EntryPointVar;
if (EntryPoint < Low(wbPERKEntryPoints)) or (EntryPoint > High(wbPERKEntryPoints)) then
raise Exception.Create('Unknown Entry Point #'+IntToStr(EntryPoint));
with wbPERKEntryPoints[EntryPoint] do
for i := Low(wbPERKFunctions) to High(wbPERKFunctions) do
if wbPERKFunctions[i].FunctionType = FunctionType then
if SameText(s, wbPERKFunctions[i].Name) then begin
Result := i;
Exit;
end;
raise Exception.Create('"'+s+'" is not valid for this Entry Point');
end;
procedure wbPerkDATAFunctionAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
NewFunction : Integer;
Container : IwbContainerElementRef;
OldParamType: Integer;
NewParamType: Integer;
begin
NewFunction := aNewValue;
if (NewFunction < Low(wbPERKFunctions)) or (NewFunction > High(wbPERKFunctions)) then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
OldParamType := Container.ElementNativeValues['..\..\..\Entry Point Function Parameters\EPFT'];
NewParamType := Ord(wbPERKFunctions[NewFunction].ParamType);
if (OldParamType = NewParamType) and not VarSameValue(aOldValue, aNewValue) and (NewFunction in [4,5]) then
Container.ElementNativeValues['..\..\..\Entry Point Function Parameters\EPFT'] := 0;
Container.ElementNativeValues['..\..\..\Entry Point Function Parameters\EPFT'] := NewParamType;
end;
function wbPerkEPFTToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
FunctionTypeVar : Variant;
FunctionType : Integer;
// i : Integer;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
FunctionTypeVar := Container.ElementNativeValues['..\..\DATA\Entry Point\Function'];
if VarIsNull(FunctionTypeVar) or VarIsClear(FunctionTypeVar) then
Exit;
FunctionType := FunctionTypeVar;
if (FunctionType < Low(wbPERKFunctions)) or (FunctionType > High(wbPERKFunctions)) then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
with wbPERKFunctions[FunctionType] do begin
case aType of
ctEditType: Result := 'ComboBox';
ctEditInfo: Result := '"' + wbPERKFunctionParams[ParamType] + '"';
else
if (aInt < Ord(Low(wbPERKFunctionParams))) or (aInt > Ord(High(wbPERKFunctionParams))) then
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end
else
case aType of
ctToStr, ctToEditValue: begin
Result := wbPERKFunctionParams[TPERKEntryPointFunctionParamType(aInt)];
if (aType = ctToStr) and (TPERKEntryPointFunctionParamType(aInt) <> ParamType) then
Result := Result + ' ';
end;
ctCheck:
if TPERKEntryPointFunctionParamType(aInt) <> ParamType then
Result := Result + ' '
else
Result := '';
end;
end;
end;
end;
function wbPerkEPFTToInt(const aString: string; const aElement: IwbElement): Int64;
var
Container : IwbContainerElementRef;
FunctionTypeVar : Variant;
FunctionType : Integer;
s : string;
// i : Integer;
j : TPERKEntryPointFunctionParamType;
begin
s := Trim(aString);
Result := StrToInt64Def(s, Low(Integer));
if Result <> Low(Integer) then
Exit;
if s = '' then
raise Exception.Create('"" is not a valid value for this field');
if not Supports(aElement, IwbContainerElementRef, Container) then
raise Exception.Create('Could not resolve Function');
FunctionTypeVar := Container.ElementNativeValues['..\..\DATA\Entry Point\Function'];
if VarIsNull(FunctionTypeVar) or VarIsClear(FunctionTypeVar) then
raise Exception.Create('Could not resolve Function');
FunctionType := FunctionTypeVar;
if (FunctionType < Low(wbPERKFunctions)) or (FunctionType > High(wbPERKFunctions)) then
raise Exception.Create('Unknown Function #'+IntToStr(FunctionType));
with wbPERKFunctions[FunctionType] do begin
for j := Low(wbPERKFunctionParams) to High(wbPERKFunctionParams) do
if SameText(s, wbPERKFunctionParams[j]) then begin
if j <> ParamType then
raise Exception.Create('"'+s+'" is not a valid Parameter Type for Function "'+Name+'"');
Result := Ord(j);
Exit;
end;
end;
raise Exception.Create('"'+s+'" is not a valid Parameter Type');
end;
procedure wbPerkEPFTAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
i: Integer;
Container: IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
i := aNewValue;
if (i < Ord(Low(wbPERKFunctionParams))) or (i> Ord(High(wbPERKFunctionParams))) then
Exit;
if not Supports(aElement.Container, IwbContainerElementRef, Container) then
Exit;
Container.RemoveElement('EPFD');
Container.RemoveElement('EPF2');
Container.RemoveElement('EPF3');
Container.RemoveElement('Embedded Script');
case TPERKEntryPointFunctionParamType(i) of
epfpFloat, epfpFloatFloat, epfpLeveledItem:
Container.Add('EPFD', True);
epfpScript: begin
Container.Add('EPF2', True);
Container.Add('EPF3', True);
Container.Add('SCHR', True);
end;
end;
end;
procedure wbRemoveOFST(const aElement: IwbElement);
var
Container: IwbContainer;
rOFST: IwbRecord;
begin
if not wbRemoveOffsetData then
Exit;
if Supports(aElement, IwbContainer, Container) then begin
if wbBeginInternalEdit then try
Container.RemoveElement(OFST);
finally
wbEndInternalEdit;
end else begin
rOFST := Container.RecordBySignature[OFST];
if Assigned(rOFST) then
Container.RemoveElement(rOFST);
end;
end;
end;
function wbActorTemplateUseTraits(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000001) <> 0;
end;
end;
function wbActorTemplateUseStats(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000002) <> 0;
end;
end;
function wbActorAutoCalcDontShow(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Flags'];
Result := (i and $00000010) <> 0;
end;
end;
function wbActorTemplateUseStatsAutoCalc(const aElement: IwbElement): Boolean;
begin
if not wbActorTemplateHide then
Result := False
else
Result := wbActorTemplateUseStats(aElement) or wbActorAutoCalcDontShow(aElement);
end;
function wbActorTemplateUseFactions(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000004) <> 0;
end;
end;
function wbActorTemplateUseActorEffectList(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000008) <> 0;
end;
end;
function wbActorTemplateUseAIData(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000010) <> 0;
end;
end;
function wbActorTemplateUseAIPackages(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000020) <> 0;
end;
end;
function wbActorTemplateUseModelAnimation(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000040) <> 0;
end;
end;
function wbActorTemplateUseBaseData(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000080) <> 0;
end;
end;
function wbActorTemplateUseInventory(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000100) <> 0;
end;
end;
function wbActorTemplateUseScript(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000200) <> 0;
end;
end;
procedure wbCTDAAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
//Size : Cardinal;
TypeFlags : Cardinal;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
TypeFlags := Container.ElementNativeValues['Type'];
if (TypeFlags and $02) <> 0 then begin
if Container.DataSize = 20 then
Container.DataSize := 28;
Container.ElementNativeValues['Type'] := TypeFlags and not $02;
Container.ElementEditValues['Run On'] := 'Target';
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbMGEFAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
OldActorValue : Integer;
NewActorValue : Integer;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
OldActorValue := Container.ElementNativeValues['DATA - Data\Actor Value'];
NewActorValue := OldActorValue;
case Integer(Container.ElementNativeValues['DATA - Data\Archtype']) of
01, //Script
02, //Dispel
03, //Cure Disease
13, //Light
16, //Lock
17, //Open
18, //Bound Item
19, //Summon Creature
30, //Cure Paralysis
31, //Cure Addiction
32, //Cure Poison
33, //Concussion
35: //Limb Condition
NewActorValue := -1;
11: //Invisibility
NewActorValue := 48; //Invisibility
12: //Chameleon
NewActorValue := 49; //Chameleon
24: //Paralysis
NewActorValue := 47; //Paralysis
36: //Turbo
NewActorValue := 51; //Turbo
end;
if OldActorValue <> NewActorValue then
Container.ElementNativeValues['DATA - Data\Actor Value'] := NewActorValue;
finally
wbEndInternalEdit;
end;
end;
procedure wbPACKAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
// OldContainer : IwbContainerElementRef;
NewContainer : IwbContainerElementRef;
// NewContainer2 : IwbContainerElementRef;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
case Integer(Container.ElementNativeValues['PKDT - General\Type']) of
0: begin {Find}
Container.Add('PTDT');
end;
1: begin {Follow}
Container.Add('PKFD');
end;
2: begin {Escort}
end;
3: begin {Eat}
Container.Add('PTDT');
Container.Add('PKED');
end;
4: begin {Sleep}
if not Container.ElementExists['Locations'] then
if Supports(Container.Add('Locations'), IwbContainerElementRef, NewContainer) then
NewContainer.ElementEditValues['PLDT - Location 1\Type'] := 'Near editor location';
end;
5: begin {Wander}
end;
6: begin {Travel}
end;
7: begin {Accompany}
end;
8: begin {Use Item At}
end;
9: begin {Ambush}
end;
10: begin {Flee Not Combat}
end;
12: begin {Sandbox}
end;
13: begin {Patrol}
if not Container.ElementExists['Locations'] then
if Supports(Container.Add('Locations'), IwbContainerElementRef, NewContainer) then
NewContainer.ElementEditValues['PLDT - Location 1\Type'] := 'Near linked reference';
Container.Add('PKPT');
end;
14: begin {Guard}
end;
15: begin {Dialogue}
end;
16: begin {Use Weapon}
end;
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbNPCAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
// BaseRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if Container.ElementNativeValues['NAM5'] > 255 then
Container.ElementNativeValues['NAM5'] := 255;
finally
wbEndInternalEdit;
end;
end;
procedure wbREFRAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
BaseRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
Container.RemoveElement('RCLR');
if Container.ElementExists['Ammo'] then begin
BaseRecord := MainRecord.BaseRecord;
if Assigned(BaseRecord) and (BaseRecord.Signature <> 'WEAP') then
Container.RemoveElement('Ammo');
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbINFOAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if (Integer(Container.ElementNativeValues['DATA\Flags 1']) and $80) = 0 then
Container.RemoveElement('DNAM');
Container.RemoveElement('SNDD');
if Container.ElementNativeValues['DATA\Type'] = 3 {Persuasion} then
Container.ElementNativeValues['DATA\Type'] := 0 {Topic};
finally
wbEndInternalEdit;
end;
end;
procedure wbCELLAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
// Container2 : IwbContainerElementRef;
MainRecord : IwbMainRecord;
// i : Integer;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if (not Container.ElementExists['XCLW']) and ((Integer(Container.ElementNativeValues['DATA']) and $02) <> 0) then begin
Container.Add('XCLW', True);
Container.ElementEditValues['XCLW'] := 'Default';
end;
if (not Container.ElementExists['XNAM']) and ((Integer(Container.ElementNativeValues['DATA']) and $02) <> 0) then
Container.Add('XNAM', True);
// if Supports(Container.ElementBySignature[XCLR], IwbContainerElementRef, Container2) then begin
// for i:= Pred(Container2.ElementCount) downto 0 do
// if not Supports(Container2.Elements[i].LinksTo, IwbMainRecord, MainRecord) or (MainRecord.Signature <> 'REGN') then
// Container2.RemoveElement(i);
// if Container2.ElementCount < 1 then
// Container2.Remove;
// end;
finally
wbEndInternalEdit;
end;
end;
procedure wbEmbeddedScriptAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if Container.ElementEditValues['SCHR\Type'] = 'Quest' then
Container.ElementEditValues['SCHR\Type'] := 'Object';
finally
wbEndInternalEdit;
end;
end;
procedure wbSOUNAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
OldCntr: IwbContainerElementRef;
NewCntr: IwbContainerElementRef;
NewCntr2: IwbContainerElementRef;
i: Integer;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if Container.ElementExists['SNDD'] then
Exit;
if not Supports(Container.RemoveElement('SNDX - Sound Data'), IwbContainerElementRef, OldCntr) then
Exit;
if not Supports(Container.Add('SNDD', True), IwbContainerElementRef, NewCntr) then
Exit;
for i := 0 to Pred(Min(OldCntr.ElementCount, NewCntr.ElementCount)) do
NewCntr.Elements[i].Assign(Low(Integer), OldCntr.Elements[i], False);
if not Supports(NewCntr.ElementByName['Attenuation Curve'], IwbContainerElementRef, NewCntr2) then
Assert(False);
Assert(NewCntr2.ElementCount = 5);
if Supports(Container.RemoveElement('ANAM'), IwbContainerElementRef, OldCntr) then begin
Assert(OldCntr.ElementCount = 5);
for i := 0 to Pred(Min(OldCntr.ElementCount, NewCntr2.ElementCount)) do
NewCntr2.Elements[i].Assign(Low(Integer), OldCntr.Elements[i], False);
end else begin
NewCntr2.Elements[0].NativeValue := 100;
NewCntr2.Elements[1].NativeValue := 50;
NewCntr2.Elements[2].NativeValue := 20;
NewCntr2.Elements[3].NativeValue := 5;
NewCntr2.Elements[4].NativeValue := 0;
end;
if not Supports(NewCntr.ElementByName['Reverb Attenuation Control'], IwbContainerElementRef, NewCntr2) then
Assert(False);
if Supports(Container.RemoveElement('GNAM'), IwbContainerElementRef, OldCntr) then
NewCntr2.Assign(Low(Integer), OldCntr, False)
else
NewCntr2.NativeValue := 80;
if not Supports(NewCntr.ElementByName['Priority'], IwbContainerElementRef, NewCntr2) then
Assert(False);
if Supports(Container.RemoveElement('HNAM'), IwbContainerElementRef, OldCntr) then
NewCntr2.Assign(Low(Integer), OldCntr, False)
else
NewCntr2.NativeValue := 128;
finally
wbEndInternalEdit;
end;
end;
procedure wbWATRAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
// AnimationMultiplier : Extended;
// AnimationAttackMultiplier : Extended;
OldCntr: IwbContainerElementRef;
NewCntr: IwbContainerElementRef;
i: Integer;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if Container.ElementExists['DNAM'] then
Exit;
if not Supports(Container.RemoveElement('DATA - Visual Data'), IwbContainerElementRef, OldCntr) then
Exit;
if not Supports(Container.Add('DNAM', True), IwbContainerElementRef, NewCntr) then
Exit;
for i := 0 to Pred(Min(OldCntr.ElementCount, NewCntr.ElementCount)) do
if OldCntr.Elements[i].Name = 'Damage (Old Format)' then
Container.ElementNativeValues['DATA - Damage'] := OldCntr.Elements[i].NativeValue
else
NewCntr.Elements[i].Assign(Low(Integer), OldCntr.Elements[i], False);
NewCntr.ElementNativeValues['Noise Properties - Noise Layer One - Amplitude Scale'] := 1.0;
NewCntr.ElementNativeValues['Noise Properties - Noise Layer Two - Amplitude Scale'] := 0.5;
NewCntr.ElementNativeValues['Noise Properties - Noise Layer Three - Amplitude Scale'] := 0.25;
finally
wbEndInternalEdit;
end;
end;
procedure wbWEAPAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if not Container.ElementExists['DNAM'] then
Exit;
if Container.ElementNativeValues['DNAM\Animation Multiplier'] = 0.0 then
Container.ElementNativeValues['DNAM\Animation Multiplier'] := 1.0;
if Container.ElementNativeValues['DNAM\Animation Attack Multiplier'] = 0.0 then
Container.ElementNativeValues['DNAM\Animation Attack Multiplier'] := 1.0;
finally
wbEndInternalEdit;
end;
end;
procedure wbMESGAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
IsMessageBox : Boolean;
HasTimeDelay : Boolean;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
IsMessageBox := (Integer(Container.ElementNativeValues['DNAM']) and 1) = 1;
HasTimeDelay := Container.ElementExists['TNAM'];
if IsMessageBox = HasTimeDelay then
if IsMessageBox then
Container.RemoveElement('TNAM')
else begin
if not Container.ElementExists['DNAM'] then
Container.Add('DNAM', True);
Container.ElementNativeValues['DNAM'] := Integer(Container.ElementNativeValues['DNAM']) or 1;
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbEFSHAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
FullParticleBirthRatio : Extended;
PersistantParticleBirthRatio : Extended;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if not Container.ElementExists['DATA'] then
Exit;
FullParticleBirthRatio := Container.ElementNativeValues['DATA\Particle Shader - Full Particle Birth Ratio'];
PersistantParticleBirthRatio := Container.ElementNativeValues['DATA\Particle Shader - Persistant Particle Birth Ratio'];
if ((FullParticleBirthRatio <> 0) and (FullParticleBirthRatio <= 1)) then begin
FullParticleBirthRatio := FullParticleBirthRatio * 78.0;
Container.ElementNativeValues['DATA\Particle Shader - Full Particle Birth Ratio'] := FullParticleBirthRatio;
end;
if ((PersistantParticleBirthRatio <> 0) and (PersistantParticleBirthRatio <= 1)) then begin
PersistantParticleBirthRatio := PersistantParticleBirthRatio * 78.0;
Container.ElementNativeValues['DATA\Particle Shader - Persistant Particle Birth Ratio'] := PersistantParticleBirthRatio;
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbFACTAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Container.ElementExists['CNAM'] then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
Container.RemoveElement('CNAM');
finally
wbEndInternalEdit;
end;
end;
procedure wbLIGHAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if not Container.ElementExists['FNAM'] then begin
Container.Add('FNAM', True);
Container.ElementNativeValues['FNAM'] := 1.0;
end;
if Container.ElementExists['DATA'] then begin
if SameValue(Container.ElementNativeValues['DATA\Falloff Exponent'], 0.0) then
Container.ElementNativeValues['DATA\Falloff Exponent'] := 1.0;
if SameValue(Container.ElementNativeValues['DATA\FOV'], 0.0) then
Container.ElementNativeValues['DATA\FOV'] := 90.0;
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbEFITAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
Element : IwbElement;
ActorValue: Variant;
MainRecord: IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
MainRecord := Container.ContainingMainRecord;
if not Assigned(MainRecord) or MainRecord.IsDeleted then
Exit;
Element := Container.ElementByPath['..\EFID'];
if not Assigned(Element) then
Exit;
if not Supports(Element.LinksTo, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.Signature <> 'MGEF' then
Exit;
ActorValue := MainRecord.ElementNativeValues['DATA - Data\Actor Value'];
if VarIsNull(ActorValue) or VarIsClear(ActorValue) then
Exit;
if VarCompareValue(ActorValue, Container.ElementNativeValues['Actor Value']) <> vrEqual then
Container.ElementNativeValues['Actor Value'] := ActorValue;
finally
wbEndInternalEdit;
end;
end;
procedure wbRPLDAfterLoad(const aElement: IwbElement);
var
Container: IwbContainer;
a, b: Single;
NeedsFlip: Boolean;
begin
if wbBeginInternalEdit then try
if Supports(aElement, IwbContainer, Container) then begin
NeedsFlip := False;
if Container.ElementCount > 1 then begin
a := StrToFloat((Container.Elements[0] as IwbContainer).Elements[0].Value);
b := StrToFloat((Container.Elements[Pred(Container.ElementCount)] as IwbContainer).Elements[0].Value);
case CompareValue(a, b) of
EqualsValue: begin
a := StrToFloat((Container.Elements[0] as IwbContainer).Elements[1].Value);
b := StrToFloat((Container.Elements[Pred(Container.ElementCount)] as IwbContainer).Elements[1].Value);
NeedsFlip := CompareValue(a, b) = GreaterThanValue;
end;
GreaterThanValue:
NeedsFlip := True;
end;
end;
if NeedsFlip then
Container.ReverseElements;
end;
finally
wbEndInternalEdit;
end;
end;
function wbPxDTLocationDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Result := Container.ElementByName['Type'].NativeValue;
end;
function wbPKDTFalloutBehaviorFlagsDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
SubRecord : IwbSubRecord;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Supports(Container, IwbSubRecord, SubRecord) then
if SubRecord.SubRecordHeaderSize = 8 then
Result := 1;
end;
function wbPKDTSpecificFlagsDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
SubRecord : IwbSubRecord;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Supports(Container, IwbSubRecord, SubRecord) then
if SubRecord.SubRecordHeaderSize = 8 then
Exit;
Result := Container.ElementByName['Type'].NativeValue + 1;
end;
procedure wbIDLAsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Element : IwbElement;
Container : IwbContainer;
SelfAsContainer : IwbContainer;
begin
if wbBeginInternalEdit then try
// if not wbCounterAfterSet('IDLC - Animation Count', aElement) then
if Supports(aElement.Container, IwbContainer, Container) then begin
Element := Container.ElementByPath['IDLC\Animation Count'];
if Assigned(Element) and Supports(aElement, IwbContainer, SelfAsContainer) and
(Element.GetNativeValue<>SelfAsContainer.GetElementCount) then
Element.SetNativeValue(SelfAsContainer.GetElementCount);
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbAnimationsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Element : IwbElement;
Elems : IwbElement;
Container : IwbContainer;
begin
if wbBeginInternalEdit then try
// if not wbCounterContainerAfterSet('IDLC - Animation Count', 'IDLA - Animations', aElement) then
if Supports(aElement, IwbContainer, Container) then begin
Element := Container.ElementByPath['IDLC\Animation Count'];
Elems := Container.ElementByName['IDLA - Animations'];
if Assigned(Element) and not Assigned(Elems) then
if Element.GetNativeValue<>0 then
Element.SetNativeValue(0);
end;
finally
wbEndInternalEdit;
end;
end;
function wbOffsetDataColsCounter(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Cardinal;
var
Container : IwbDataContainer;
Element : IwbElement;
fResult : Extended;
begin
Result := 0;
if Supports(aElement.Container, IwbDataContainer, Container) and (Container.Name = 'OFST - Offset Data') and
Supports(Container.Container, IwbDataContainer, Container) then begin
Element := Container.ElementByPath['Object Bounds\NAM0 - Min\X'];
if Assigned(Element) then begin
fResult := Element.NativeValue;
if fResult >= MaxInt then
Result := 0
else
Result := Trunc(fResult);
Element := Container.ElementByPath['Object Bounds\NAM9 - Max\X'];
if Assigned(Element) then begin
fResult := Element.NativeValue;
if fResult >= MaxInt then
Result := 1
else
Result := Trunc(fResult) - Result + 1;
end;
end;
end;
end;
procedure DefineFNVa;
begin
wbRecordFlags := wbInteger('Record Flags', itU32, wbFlags([
{0x00000001}'ESM',
{0x00000002}'',
{0x00000004}'', // Plugin selected (Editor)
{0x00000008}'Form initialized (Runtime only)', // Form cannot be saved (Runtime)/Plugin active (Editor)
{0x00000010}'', // Plugin cannot be active or selected (Editor)
{0x00000020}'Deleted',
{0x00000040}'Border Region / Has Tree LOD / Constant / Hidden From Local Map / Plugin Endian',
{0x00000080}'Turn Off Fire',
{0x00000100}'Inaccessible',
{0x00000200}'Casts shadows / On Local Map / Motion Blur',
{0x00000400}'Quest item / Persistent reference',
{0x00000800}'Initially disabled',
{0x00001000}'Ignored',
{0x00002000}'No Voice Filter',
{0x00004000}'Cannot Save (Runtime only)',
{0x00008000}'Visible when distant',
{0x00010000}'Random Anim Start / High Priority LOD',
{0x00020000}'Dangerous / Off limits (Interior cell) / Radio Station (Talking Activator)',
{0x00040000}'Compressed',
{0x00080000}'Can''t wait / Platform Specific Texture / Dead',
{0x00100000}'Unknown 21',
{0x00200000}'Load Started (Runtime Only)', // set when beginning to load the form from save
{0x00400000}'Unknown 23',
{0x00800000}'Unknown 24', // Runtime might use it for "Not dead" on non actors.
{0x01000000}'Destructible (Runtime only)',
{0x02000000}'Obstacle / No AI Acquire',
{0x03000000}'NavMesh Generation - Filter',
{0x08000000}'NavMesh Generation - Bounding Box',
{0x10000000}'Non-Pipboy / Reflected by Auto Water',
{0x20000000}'Child Can Use / Refracted by Auto Water',
{0x40000000}'NavMesh Generation - Ground',
{0x80000000}'Multibound'
]));
(* wbInteger('Record Flags 2', itU32, wbFlags([
{0x00000001}'Unknown 1',
{0x00000002}'Unknown 2',
{0x00000004}'Unknown 3',
{0x00000008}'Unknown 4',
{0x00000010}'Unknown 5',
{0x00000020}'Unknown 6',
{0x00000040}'Unknown 7',
{0x00000080}'Unknown 8',
{0x00000100}'Unknown 9',
{0x00000200}'Unknown 10',
{0x00000400}'Unknown 11',
{0x00000800}'Unknown 12',
{0x00001000}'Unknown 13',
{0x00002000}'Unknown 14',
{0x00004000}'Unknown 15',
{0x00008000}'Unknown 16',
{0x00010000}'Unknown 17',
{0x00020000}'Unknown 18',
{0x00040000}'Unknown 19',
{0x00080000}'Unknown 20',
{0x00100000}'Unknown 21',
{0x00200000}'Unknown 22',
{0x00400000}'Unknown 23',
{0x00800000}'Unknown 24',
{0x01000000}'Unknown 25',
{0x02000000}'Unknown 26',
{0x03000000}'Unknown 27',
{0x08000000}'Unknown 28',
{0x10000000}'Unknown 29',
{0x20000000}'Unknown 30',
{0x40000000}'Unknown 31',
{0x80000000}'Unknown 32'
])); (**)
wbMainRecordHeader := wbStruct('Record Header', [
wbString('Signature', 4, cpCritical),
wbInteger('Data Size', itU32, nil, cpIgnore),
wbRecordFlags,
wbFormID('FormID', cpFormID),
wbInteger('Version Control Master FormID', itU32, nil, cpIgnore),
wbInteger('Form Version', itU16, nil, cpIgnore),
wbInteger('Version Control Info 2', itU16, nil, cpIgnore) // limited to values from 0 to 0xF
]);
wbSizeOfMainRecordStruct := 24;
wbIgnoreRecords.Add(XXXX);
wbXRGD := wbByteArray(XRGD, 'Ragdoll Data');
wbXRGB := wbByteArray(XRGB, 'Ragdoll Biped Data');
wbMusicEnum := wbEnum(['Default', 'Public', 'Dungeon']);
wbSoundLevelEnum := wbEnum([
'Loud',
'Normal',
'Silent'
]);
wbWeaponAnimTypeEnum := wbEnum([
{00} 'Hand to Hand',
{01} 'Melee (1 Hand)',
{02} 'Melee (2 Hand)',
{03} 'Pistol - Balistic (1 Hand)',
{04} 'Pistol - Energy (1 Hand)',
{05} 'Rifle - Balistic (2 Hand)',
{06} 'Rifle - Automatic (2 Hand)',
{07} 'Rifle - Energy (2 Hand)',
{08} 'Handle (2 Hand)',
{09} 'Launcher (2 Hand)',
{10} 'Grenade Throw (1 Hand)',
{11} 'Land Mine (1 Hand)',
{12} 'Mine Drop (1 Hand)',
{13} 'Thrown (1 Hand)'
]);
wbReloadAnimEnum := wbEnum([
'ReloadA',
'ReloadB',
'ReloadC',
'ReloadD',
'ReloadE',
'ReloadF',
'ReloadG',
'ReloadH',
'ReloadI',
'ReloadJ',
'ReloadK',
'ReloadL',
'ReloadM',
'ReloadN',
'ReloadO',
'ReloadP',
'ReloadQ',
'ReloadR',
'ReloadS',
// 'ReloadT',
// 'ReloadU',
// 'ReloadV',
'ReloadW',
'ReloadX',
'ReloadY',
'ReloadZ'
],[255, 'None']); // 255 seen in DLC, though Geck converts to 0
wbEDID := wbString(EDID, 'Editor ID', 0, cpNormal); // not cpBenign according to Arthmoor
wbEDIDReq := wbString(EDID, 'Editor ID', 0, cpNormal, True); // not cpBenign according to Arthmoor
wbFULL := wbString(FULL, 'Name', 0, cpTranslate);
wbFULLActor := wbString(FULL, 'Name', 0, cpTranslate, False, wbActorTemplateUseBaseData);
wbFULLReq := wbString(FULL, 'Name', 0, cpNormal, True);
wbDESC := wbString(DESC, 'Description', 0, cpTranslate);
wbDESCReq := wbString(DESC, 'Description', 0, cpTranslate, True);
wbXSCL := wbFloat(XSCL, 'Scale');
wbOBND := wbStruct(OBND, 'Object Bounds', [
wbInteger('X1', itS16),
wbInteger('Y1', itS16),
wbInteger('Z1', itS16),
wbInteger('X2', itS16),
wbInteger('Y2', itS16),
wbInteger('Z2', itS16)
]);
wbOBNDReq := wbStruct(OBND, 'Object Bounds', [
wbInteger('X1', itS16),
wbInteger('Y1', itS16),
wbInteger('Z1', itS16),
wbInteger('X2', itS16),
wbInteger('Y2', itS16),
wbInteger('Z2', itS16)
], cpNormal, True);
wbREPL := wbFormIDCkNoReach(REPL, 'Repair List', [FLST]);
wbEITM := wbFormIDCk(EITM, 'Object Effect', [ENCH, SPEL]);
wbBIPL := wbFormIDCk(BIPL, 'Biped Model List', [FLST]);
wbCOED := wbStructExSK(COED, [2], [0, 1], 'Extra Data', [
{00} wbFormIDCkNoReach('Owner', [NPC_, FACT, NULL]),
{04} wbUnion('Global Variable / Required Rank', wbCOEDOwnerDecider, [
wbByteArray('Unused', 4, cpIgnore),
wbFormIDCk('Global Variable', [GLOB, NULL]),
wbInteger('Required Rank', itS32)
]),
{08} wbFloat('Item Condition')
]);
wbYNAM := wbFormIDCk(YNAM, 'Sound - Pick Up', [SOUN]);
wbZNAM := wbFormIDCk(ZNAM, 'Sound - Drop', [SOUN]);
wbPosRot :=
wbStruct('Position/Rotation', [
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation', [
wbFloat('X', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Y', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Z', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize)
])
]);
wbDATAPosRot :=
wbStruct(DATA, 'Position/Rotation', [
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation', [
wbFloat('X', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Y', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Z', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize)
])
], cpNormal, True);
wbMODS :=
wbArrayS(MODS, 'Alternate Textures',
wbStructSK([0, 2], 'Alternate Texture', [
wbLenString('3D Name'),
wbFormIDCk('New Texture', [TXST]),
wbInteger('3D Index', itS32)
]),
-1);
wbMO2S :=
wbArrayS(MO2S, 'Alternate Textures',
wbStructSK([0, 2], 'Alternate Texture', [
wbLenString('3D Name'),
wbFormIDCk('New Texture', [TXST]),
wbInteger('3D Index', itS32)
]),
-1);
wbMO3S :=
wbArrayS(MO3S, 'Alternate Textures',
wbStructSK([0, 2], 'Alternate Texture', [
wbLenString('3D Name'),
wbFormIDCk('New Texture', [TXST]),
wbInteger('3D Index', itS32)
]),
-1);
wbMO4S :=
wbArrayS(MO4S, 'Alternate Textures',
wbStructSK([0, 2], 'Alternate Texture', [
wbLenString('3D Name'),
wbFormIDCk('New Texture', [TXST]),
wbInteger('3D Index', itS32)
]),
-1);
wbMODD :=
wbInteger(MODD, 'FaceGen Model Flags', itU8, wbFlags([
'Head',
'Torso',
'Right Hand',
'Left Hand'
]));
wbMOSD :=
wbInteger(MOSD, 'FaceGen Model Flags', itU8, wbFlags([
'Head',
'Torso',
'Right Hand',
'Left Hand'
]));
wbMODL :=
wbRStructSK([0], 'Model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbByteArray(MODB, 'Unknown', 4, cpIgnore),
wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore),
// wbArray(MODT, 'Texture Files Hashes',
// wbByteArray('Unknown', 24, cpBenign),
// wbArray('Hashes', wbInteger('Hash', itU64, wbMODTCallback), 3),
// 0, nil, nil, cpBenign),
wbMODS,
wbMODD
], [], cpNormal, False, nil, True);
wbMODLActor :=
wbRStructSK([0], 'Model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbByteArray(MODB, 'Unknown', 4, cpIgnore),
wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore),
// wbArray(MODT, 'Texture Files Hashes',
// wbByteArray('Unknown', 24, cpBenign),
// wbArray('Hashes', wbInteger('Hash', itU64, wbMODTCallback), 3),
// 0, nil, nil, cpBenign),
wbMODS,
wbMODD
], [], cpNormal, False, wbActorTemplateUseModelAnimation, True);
wbMODLReq :=
wbRStructSK([0], 'Model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbByteArray(MODB, 'Unknown', 4, cpIgnore),
wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore),
// wbArray(MODT, 'Texture Files',
// wbByteArray('Unknown', 24, cpBenign),
// wbArray('Hashes', wbInteger('Hash', itU64, wbMODTCallback), 3),
// 0, nil, nil, cpBenign),
wbMODS,
wbMODD
], [], cpNormal, True, nil, True);
wbDEST := wbRStruct('Destructable', [
wbStruct(DEST, 'Header', [
wbInteger('Health', itS32),
wbInteger('Count', itU8),
wbInteger('Flags', itU8, wbFlags([
'VATS Targetable'
], True)),
wbByteArray('Unused', 2)
]),
wbRArray('Stages',
wbRStruct('Stage', [
wbStruct(DSTD, 'Destruction Stage Data', [
wbInteger('Health %', itU8),
wbInteger('Index', itU8),
wbInteger('Damage Stage', itU8),
wbInteger('Flags', itU8, wbFlags([
'Cap Damage',
'Disable',
'Destroy'
])),
wbInteger('Self Damage per Second', itS32),
wbFormIDCk('Explosion', [EXPL, NULL]),
wbFormIDCk('Debris', [DEBR, NULL]),
wbInteger('Debris Count', itS32)
], cpNormal, True),
wbRStructSK([0], 'Model', [
wbString(DMDL, 'Model Filename'),
wbByteArray(DMDT, 'Texture Files Hashes', 0, cpIgnore)
// wbArray(DMDT, 'Unknown',
// wbByteArray('Unknown', 24, cpBenign),
// 0, nil, nil, cpBenign)
], []),
wbEmpty(DSTF, 'End Marker', cpNormal, True)
], [])
)
], []);
wbDESTActor := wbRStruct('Destructable', [
wbStruct(DEST, 'Header', [
wbInteger('Health', itS32),
wbInteger('Count', itU8),
wbInteger('Flags', itU8, wbFlags([
'VATS Targetable'
])),
wbByteArray('Unused', 2)
]),
wbRArray('Stages',
wbRStruct('Stage', [
wbStruct(DSTD, 'Destruction Stage Data', [
wbInteger('Health %', itU8),
wbInteger('Index', itU8),
wbInteger('Damage Stage', itU8),
wbInteger('Flags', itU8, wbFlags([
'Cap Damage',
'Disable',
'Destroy'
])),
wbInteger('Self Damage per Second', itS32),
wbFormIDCk('Explosion', [EXPL, NULL]),
wbFormIDCk('Debris', [DEBR, NULL]),
wbInteger('Debris Count', itS32)
], cpNormal, True),
wbRStructSK([0], 'Model', [
wbString(DMDL, 'Model Filename'),
wbByteArray(DMDT, 'Texture Files Hashes', 0, cpIgnore)
// wbArray(DMDT, 'Unknown',
// wbByteArray('Unknown', 24, cpBenign),
// 0, nil, nil, cpBenign)
], []),
wbEmpty(DSTF, 'End Marker', cpNormal, True)
], [])
)
], [], cpNormal, False, wbActorTemplateUseModelAnimation);
wbSCRI := wbFormIDCk(SCRI, 'Script', [SCPT]);
wbSCRIActor := wbFormIDCk(SCRI, 'Script', [SCPT], False, cpNormal, False, wbActorTemplateUseScript);
wbENAM := wbFormIDCk(ENAM, 'Object Effect', [ENCH]);
wbXLOD := wbArray(XLOD, 'Distant LOD Data', wbFloat('Unknown'), 3);
wbXESP := wbStruct(XESP, 'Enable Parent', [
wbFormIDCk('Reference', [PLYR, REFR, ACRE, ACHR, PGRE, PMIS, PBEA]),
wbInteger('Flags', itU8, wbFlags([
'Set Enable State to Opposite of Parent',
'Pop In'
])),
wbByteArray('Unused', 3)
]);
wbSCHRReq := wbStruct(SCHR, 'Basic Script Data', [
wbByteArray('Unused', 4),
wbInteger('RefCount', itU32),
wbInteger('CompiledSize', itU32),
wbInteger('VariableCount', itU32),
wbInteger('Type', itU16, wbEnum([
'Object',
'Quest'
], [
$100, 'Effect'
])),
wbInteger('Flags', itU16, wbFlags([
'Enabled'
]), cpNormal, False, nil, nil, 1)
], cpNormal, True);
wbSCROs :=
wbRArray('References',
wbRUnion('', [
wbFormID(SCRO, 'Global Reference'),
// wbFormIDCk(SCRO, 'Global Reference',
// [ACTI, DOOR, STAT, FURN, CREA, SPEL, NPC_, CONT, ARMO, AMMO, MISC, WEAP, IMAD,
// BOOK, KEYM, ALCH, LIGH, QUST, PLYR, PACK, LVLI, ECZN, EXPL, FLST, IDLM, PMIS,
// FACT, ACHR, REFR, ACRE, GLOB, DIAL, CELL, SOUN, MGEF, WTHR, CLAS, EFSH, RACE,
// LVLC, CSTY, WRLD, SCPT, IMGS, MESG, MSTT, MUSC, NOTE, PERK, PGRE, PROJ, LVLN,
// WATR, ENCH, TREE, REPU, REGN, CSNO, CHAL, IMOD, RCCT, CMNY, CDCK, CHIP, CCRD,
// TERM, HAIR, EYES, ADDN, RCPE, NULL]),
wbInteger(SCRV, 'Local Variable', itU32)
], [])
);
wbSLSD := wbStructSK(SLSD, [0], 'Local Variable Data', [
wbInteger('Index', itU32),
wbByteArray('Unused', 12),
wbInteger('Flags', itU8, wbFlags(['IsLongOrShort']), cpCritical),
wbByteArray('Unused', 7)
]);
wbEmbeddedScript := wbRStruct('Embedded Script', [
wbSCHRReq,
wbByteArray(SCDA, 'Compiled Embedded Script', 0, cpNormal{, True}),
wbStringScript(SCTX, 'Embedded Script Source', 0, cpNormal{, True}),
wbRArrayS('Local Variables', wbRStructSK([0], 'Local Variable', [
wbSLSD,
wbString(SCVR, 'Name', 0, cpCritical, True)
], [])),
wbSCROs
], [], cpNormal, False, nil, False, wbEmbeddedScriptAfterLoad);
wbEmbeddedScriptPerk := wbRStruct('Embedded Script', [
wbSCHRReq,
wbByteArray(SCDA, 'Compiled Embedded Script', 0, cpNormal, True),
wbStringScript(SCTX, 'Embedded Script Source', 0, cpNormal, True),
wbRArrayS('Local Variables', wbRStructSK([0], 'Local Variable', [
wbSLSD,
wbString(SCVR, 'Name', 0, cpCritical, True)
], [])),
wbSCROs
], [], cpNormal, False, wbEPF2DontShow, False, wbEmbeddedScriptAfterLoad);
wbEmbeddedScriptReq := wbRStruct('Embedded Script', [
wbSCHRReq,
wbByteArray(SCDA, 'Compiled Embedded Script', 0, cpNormal{, True}),
wbStringScript(SCTX, 'Embedded Script Source', 0, cpNormal{, True}),
wbRArrayS('Local Variables', wbRStructSK([0], 'Local Variable', [
wbSLSD,
wbString(SCVR, 'Name', 0, cpCritical, True)
], [])),
wbSCROs
], [], cpNormal, True, nil, False, wbEmbeddedScriptAfterLoad);
wbXLCM := wbInteger(XLCM, 'Level Modifier', itS32);
wbRecord(ACHR, 'Placed NPC', [
wbEDID,
wbFormIDCk(NAME, 'Base', [NPC_], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
{--- Ragdoll ---}
wbXRGD,
wbXRGB,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], []),
{--- Leveled Actor ----}
wbXLCM,
{--- Merchant Container ----}
wbFormIDCk(XMRC, 'Merchant Container', [REFR], True),
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbFloat(XHLP, 'Health'),
{--- Decals ---}
wbRArrayS('Linked Decals',
wbStructSK(XDCR, [0], 'Decal', [
wbFormIDCk('Reference', [REFR]),
wbUnknown
])
),
{--- Linked Ref ---}
wbFormIDCk(XLKR, 'Linked Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbStruct(XCLP, 'Linked Reference Color', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbFloat('Delay')
])
)
], []),
wbString(XATO, 'Activation Prompt'),
{--- Enable Parent ---}
wbXESP,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Flags ---}
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot
], True, wbPlacedAddInfo);
wbXOWN := wbFormIDCkNoReach(XOWN, 'Owner', [FACT, ACHR, CREA, NPC_]); // Ghouls can own too aparently !
wbXGLB := wbFormIDCk(XGLB, 'Global variable', [GLOB]);
wbRecord(ACRE, 'Placed Creature', [
wbEDID,
wbFormIDCk(NAME, 'Base', [CREA], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbXRGD,
wbXRGB,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], []),
{--- Leveled Actor ----}
wbXLCM,
{--- Ownership ---}
wbRStruct('Ownership', [
wbXOWN,
wbInteger(XRNK, 'Faction rank', itS32)
], [XCMT, XCMO]),
{--- Merchant Container ----}
wbFormIDCk(XMRC, 'Merchant Container', [REFR], True),
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbFloat(XHLP, 'Health'),
{--- Decals ---}
wbRArrayS('Linked Decals',
wbStructSK(XDCR, [0], 'Decal', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA]),
wbUnknown
])
),
{--- Linked Ref ---}
wbFormIDCk(XLKR, 'Linked Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbStruct(XCLP, 'Linked Reference Color', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbFloat('Delay')
])
)
], []),
wbString(XATO, 'Activation Prompt'),
{--- Enable Parent ---}
wbXESP,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Flags ---}
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot
], True, wbPlacedAddInfo);
wbRecord(ACTI, 'Activator', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbSCRI,
wbDEST,
wbFormIDCk(SNAM, 'Sound - Looping', [SOUN]),
wbFormIDCk(VNAM, 'Sound - Activation', [SOUN]),
wbFormIDCk(INAM, 'Radio Template', [SOUN]),
wbFormIDCk(RNAM, 'Radio Station', [TACT]),
wbFormIDCk(WNAM, 'Water Type', [WATR]),
wbString(XATO, 'Activation Prompt')
]);
wbICON := wbRStruct('Icon', [
wbString(ICON, 'Large Icon filename', 0, cpNormal, True),
wbString(MICO, 'Small Icon filename')
], [], cpNormal, False, nil, True);
wbICONReq := wbRStruct('Icon', [
wbString(ICON, 'Large Icon filename', 0, cpNormal, True),
wbString(MICO, 'Small Icon filename')
], [], cpNormal, True, nil, True);
wbVatsValueFunctionEnum :=
wbEnum([
'Weapon Is',
'Weapon In List',
'Target Is',
'Target In List',
'Target Distance',
'Target Part',
'VATS Action',
'Is Success',
'Is Critical',
'Critical Effect Is',
'Critical Effect In List',
'Is Fatal',
'Explode Part',
'Dismember Part',
'Cripple Part',
'Weapon Type Is',
'Is Stranger',
'Is Paralyzing Palm'
]);
wbActorValueEnum :=
wbEnum([
{00} 'Aggresion',
{01} 'Confidence',
{02} 'Energy',
{03} 'Responsibility',
{04} 'Mood',
{05} 'Strength',
{06} 'Perception',
{07} 'Endurance',
{08} 'Charisma',
{09} 'Intelligence',
{10} 'Agility',
{11} 'Luck',
{12} 'Action Points',
{13} 'Carry Weight',
{14} 'Critical Chance',
{15} 'Heal Rate',
{16} 'Health',
{17} 'Melee Damage',
{18} 'Damage Resistance',
{19} 'Poison Resistance',
{20} 'Rad Resistance',
{21} 'Speed Multiplier',
{22} 'Fatigue',
{23} 'Karma',
{24} 'XP',
{25} 'Perception Condition',
{26} 'Endurance Condition',
{27} 'Left Attack Condition',
{28} 'Right Attack Condition',
{29} 'Left Mobility Condition',
{30} 'Right Mobility Condition',
{31} 'Brain Condition',
{32} 'Barter',
{33} 'Big Guns (obsolete)',
{34} 'Energy Weapons',
{35} 'Explosives',
{36} 'Lockpick',
{37} 'Medicine',
{38} 'Melee Weapons',
{39} 'Repair',
{40} 'Science',
{41} 'Guns',
{42} 'Sneak',
{43} 'Speech',
{44} 'Survival',
{45} 'Unarmed',
{46} 'Inventory Weight',
{47} 'Paralysis',
{48} 'Invisibility',
{49} 'Chameleon',
{50} 'Night Eye',
{51} 'Turbo',
{52} 'Fire Resistance',
{53} 'Water Breathing',
{54} 'Rad Level',
{55} 'Bloody Mess',
{56} 'Unarmed Damage',
{57} 'Assistance',
{58} 'Electric Resistance',
{59} 'Frost Resistance',
{60} 'Energy Resistance',
{61} 'EMP Resistance',
{62} 'Variable01',
{63} 'Variable02',
{64} 'Variable03',
{65} 'Variable04',
{66} 'Variable05',
{67} 'Variable06',
{68} 'Variable07',
{79} 'Variable08',
{70} 'Variable09',
{71} 'Variable10',
{72} 'Ignore Crippled Limbs',
{73} 'Dehydration',
{74} 'Hunger',
{75} 'Sleep Deprivation',
{76} 'Damage Threshold'
], [
-1, 'None'
]);
wbModEffectEnum :=
wbEnum([
{00} 'None',
{01} 'Increase Weapon Damage',
{02} 'Increase Clip Capacity',
{03} 'Decrease Spread',
{04} 'Decrease Weight',
{05} 'Regenerate Ammo (shots)',
{06} 'Regenerate Ammo (seconds)',
{07} 'Decrease Equip Time',
{08} 'Increase Rate of Fire',
{09} 'Increase Projectile Speed',
{10} 'Increase Max. Condition',
{11} 'Silence',
{12} 'Split Beam',
{13} 'VATS Bonus',
{14} 'Increase Zoom',
{15} 'Decrease Equip Time',
{16} 'Suppressor'
]);
wbSkillEnum :=
wbEnum([
'Barter',
'Big Guns (obsolete)',
'Energy Weapons',
'Explosives',
'Lockpick',
'Medicine',
'Melee Weapons',
'Repair',
'Science',
'Guns',
'Sneak',
'Speech',
'Survival',
'Unarmed'
], [
-1, 'None'
]);
wbCrimeTypeEnum :=
wbEnum([
'Steal',
'Pickpocket',
'Trespass',
'Attack',
'Murder'
], [
-1, 'None'
]);
wbActorValue := wbInteger('Actor Value', itS32, wbActorValueEnum);
wbEquipTypeEnum :=
wbEnum([
{00} 'Big Guns',
{01} 'Energy Weapons',
{02} 'Small Guns',
{03} 'Melee Weapons',
{04} 'Unarmed Weapon',
{05} 'Thrown Weapons',
{06} 'Mine',
{07} 'Body Wear',
{08} 'Head Wear',
{09} 'Hand Wear',
{10} 'Chems',
{11} 'Stimpack',
{12} 'Food',
{13} 'Alcohol'
], [
-1, 'None'
]);
wbETYP := wbInteger(ETYP, 'Equiptment Type', itS32, wbEquipTypeEnum);
wbETYPReq := wbInteger(ETYP, 'Equiptment Type', itS32, wbEquipTypeEnum, cpNormal, True);
wbFormTypeEnum :=
wbEnum([], [
$04, 'Texture Set',
$05, 'Menu Icon',
$06, 'Global',
$07, 'Class',
$08, 'Faction',
$09, 'Head Part',
$0A, 'Hair',
$0B, 'Eyes',
$0C, 'Race',
$0D, 'Sound',
$0E, 'Acoustic Space',
$0F, 'Skill',
$10, 'Base Effect',
$11, 'Script',
$12, 'Landscape Texture',
$13, 'Object Effect',
$14, 'Actor Effect',
$15, 'Activator',
$16, 'Talking Activator',
$17, 'Terminal',
$18, 'Armor',
$19, 'Book',
$1A, 'Clothing',
$1B, 'Container',
$1C, 'Door',
$1D, 'Ingredient',
$1E, 'Light',
$1F, 'Misc',
$20, 'Static',
$21, 'Static Collection',
$22, 'Movable Static',
$23, 'Placeable Water',
$24, 'Grass',
$25, 'Tree',
$26, 'Flora',
$27, 'Furniture',
$28, 'Weapon',
$29, 'Ammo',
$2A, 'NPC',
$2B, 'Creature',
$2C, 'Leveled Creature',
$2D, 'Leveled NPC',
$2E, 'Key',
$2F, 'Ingestible',
$30, 'Idle Marker',
$31, 'Note',
$32, 'Constructible Object',
$33, 'Projectile',
$34, 'Leveled Item',
$35, 'Weather',
$36, 'Climate',
$37, 'Region',
$39, 'Cell',
$3A, 'Placed Object',
$3B, 'Placed Character',
$3C, 'Placed Creature',
$3E, 'Placed Grenade',
$41, 'Worldspace',
$42, 'Landscape',
$43, 'Navigation Mesh',
$45, 'Dialog Topic',
$46, 'Dialog Response',
$47, 'Quest',
$48, 'Idle Animation',
$49, 'Package',
$4A, 'Combat Style',
$4B, 'Load Screen',
$4C, 'Leveled Spell',
$4D, 'Animated Object',
$4E, 'Water',
$4F, 'Effect Shader',
$51, 'Explosion',
$52, 'Debris',
$53, 'Image Space',
$54, 'Image Space Modifier',
$55, 'FormID List',
$56, 'Perk',
$57, 'Body Part Data',
$58, 'Addon Node',
$59, 'Actor Value Info',
$5A, 'Radiation Stage',
$5B, 'Camera Shot',
$5C, 'Camera Path',
$5D, 'Voice Type',
$5E, 'Impact Data',
$5F, 'Impact DataSet',
$60, 'Armor Addon',
$61, 'Encounter Zone',
$62, 'Message',
$63, 'Ragdoll',
$64, 'Default Object Manager',
$65, 'Lighting Template',
$66, 'Music Type',
$67, 'Item Mod',
$68, 'Reputation',
$69, '?PCBE', //no such records in FalloutNV.esm
$6A, 'Recipe',
$6B, 'Recipe Category',
$6C, 'Casino Chip',
$6D, 'Casino',
$6E, 'Load Screen Type',
$6F, 'Media Set',
$70, 'Media Location Controller',
$71, 'Challenge',
$72, 'Ammo Effect',
$73, 'Caravan Card',
$74, 'Caravan Money',
$75, 'Caravan Deck',
$76, 'Dehydration Stages',
$77, 'Hunger Stages',
$78, 'Sleep Deprivation Stages'
]);
wbMenuModeEnum :=
wbEnum([],[
1, 'Type: Character Interface',
2, 'Type: Other',
3, 'Type: Console',
1001, 'Specific: Message',
1002, 'Specific: Inventory',
1003, 'Specific: Stats',
1004, 'Specific: HUDMainMenu',
1007, 'Specific: Loading',
1008, 'Specific: Container',
1009, 'Specific: Dialog',
1012, 'Specific: Sleep/Wait',
1013, 'Specific: Pause',
1014, 'Specific: LockPick',
1016, 'Specific: Quantity',
1027, 'Specific: Level Up',
1035, 'Specific: Pipboy Repair',
1036, 'Specific: Race / Sex',
1047, 'Specific: Credits',
1048, 'Specific: CharGen',
1051, 'Specific: TextEdit',
1053, 'Specific: Barter',
1054, 'Specific: Surgery',
1055, 'Specific: Hacking',
1056, 'Specific: VATS',
1057, 'Specific: Computers',
1058, 'Specific: Vendor Repair',
1059, 'Specific: Tutorial',
1060, 'Specific: You''re SPECIAL book'
]);
end;
procedure DefineFNVb;
begin
wbMiscStatEnum :=
wbEnum([
'Quests Completed',
'Locations Discovered',
'People Killed',
'Creatures Killed',
'Locks Picked',
'Computers Hacked',
'Stimpaks Taken',
'Rad-X Taken',
'RadAway Taken',
'Chems Taken',
'Times Addicted',
'Mines Disarmed',
'Speech Successes',
'Pockets Picked',
'Pants Exploded',
'Books Read',
'Bobbleheads Found',
'Weapons Created',
'People Mezzed',
'Captives Rescued',
'Sandman Kills',
'Paralyzing Punches',
'Robots Disabled',
'Contracts Completed',
'Corpses Eaten',
'Mysterious Stranger Visits',
'Doctor Bags Used',
'Challenges Completed',
'Miss Fortunate Occurrences',
'Disintegrations',
'Have Limbs Crippled',
'Speech Failures',
'Items Crafted',
'Weapon Modifications',
'Items Repaired',
'Total Things Killed',
'Dismembered Limbs',
'Caravan Games Won',
'Caravan Games Lost',
'Barter Amount Traded',
'Roulette Games Played',
'Blackjack Games Played',
'Slots Games Played'
]);
wbAlignmentEnum :=
wbEnum([
'Good',
'Neutral',
'Evil',
'Very Good',
'Very Evil'
]);
wbAxisEnum :=
wbEnum([], [
88, 'X',
89, 'Y',
90, 'Z'
]);
wbCriticalStageEnum :=
wbEnum([
'None',
'Goo Start',
'Goo End',
'Disintegrate Start',
'Disintegrate End'
]);
wbSexEnum :=
wbEnum(['Male','Female']);
wbCreatureTypeEnum :=
wbEnum([
'Animal',
'Mutated Animal',
'Mutated Insect',
'Abomination',
'Super Mutant',
'Feral Ghoul',
'Robot',
'Giant'
]);
wbPlayerActionEnum :=
wbEnum([
'',
'Swinging Melee Weapon',
'Throwing Grenade',
'Fire Weapon',
'Lay Mine',
'Z Key Object',
'Jumping',
'Knocking over Objects',
'Stand on Table/Chair',
'Iron Sites',
'Destroying Object'
]);
wbBodyLocationEnum :=
wbEnum([
'Torso',
'Head 1',
'Head 2',
'Left Arm 1',
'Left Arm 2',
'Right Arm 1',
'Right Arm 2',
'Left Leg 1',
'Left Leg 2',
'Left Leg 3',
'Right Leg 1',
'Right Leg 2',
'Right Leg 3',
'Brain'
], [
-1, 'None'
]);
wbEFID := wbFormIDCk(EFID, 'Base Effect', [MGEF]);
wbEFIT :=
wbStructSK(EFIT, [3, 4], '', [
wbInteger('Magnitude', itU32),
wbInteger('Area', itU32),
wbInteger('Duration', itU32),
wbInteger('Type', itU32, wbEnum(['Self', 'Touch', 'Target'])),
wbActorValue
], cpNormal, True, nil, -1, wbEFITAfterLoad);
wbCTDA :=
wbStruct(CTDA, 'Condition', [
wbInteger('Type', itU8, wbCtdaTypeToStr, wbCtdaTypeToInt, cpNormal, False, nil, wbCtdaTypeAfterSet),
wbByteArray('Unused', 3),
wbUnion('Comparison Value', wbCTDACompValueDecider, [
wbFloat('Comparison Value - Float'),
wbFormIDCk('Comparison Value - Global', [GLOB])
]),
wbInteger('Function', itU32, wbCTDAFunctionToStr, wbCTDAFunctionToInt), // Limited to itu16
wbUnion('Parameter #1', wbCTDAParam1Decider, [
{00} wbByteArray('Unknown', 4),
{01} wbByteArray('None', 4, cpIgnore),
{02} wbInteger('Integer', itS32),
{03} wbInteger('Variable Name (INVALID)', itS32),
{04} wbInteger('Sex', itU32, wbSexEnum),
{05} wbInteger('Actor Value', itS32, wbActorValueEnum),
{06} wbInteger('Crime Type', itU32, wbCrimeTypeEnum),
{07} wbInteger('Axis', itU32, wbAxisEnum),
{08} wbInteger('Quest Stage (INVALID)', itS32),
{09} wbInteger('Misc Stat', itU32, wbMiscStatEnum),
{10} wbInteger('Alignment', itU32, wbAlignmentEnum),
{11} wbInteger('Equip Type', itU32, wbEquipTypeEnum),
{12} wbInteger('Form Type', itU32, wbFormTypeEnum),
{13} wbInteger('Critical Stage', itU32, wbCriticalStageEnum),
{14} wbFormIDCkNoReach('Object Reference', [PLYR, REFR, ACHR, ACRE, PGRE, PMIS, PBEA, TRGT], True),
{16} wbFormIDCkNoReach('Inventory Object', [ARMO, BOOK, MISC, WEAP, AMMO, KEYM, ALCH, NOTE, FLST, CHIP, CMNY, IMOD]),
{17} wbFormIDCkNoReach('Actor', [PLYR, ACHR, ACRE, TRGT], True),
{18} wbFormIDCkNoReach('Voice Type', [VTYP]),
{19} wbFormIDCkNoReach('Idle', [IDLE]),
{20} wbFormIDCkNoReach('Form List', [FLST]),
{21} wbFormIDCkNoReach('Note', [NOTE]),
{22} wbFormIDCkNoReach('Quest', [QUST]),
{23} wbFormIDCkNoReach('Faction', [FACT]),
{24} wbFormIDCkNoReach('Weapon', [WEAP]),
{25} wbFormIDCkNoReach('Cell', [CELL]),
{26} wbFormIDCkNoReach('Class', [CLAS]),
{27} wbFormIDCkNoReach('Race', [RACE]),
{28} wbFormIDCkNoReach('Actor Base', [NPC_, CREA, ACTI, TACT, NULL]),
{29} wbFormIDCkNoReach('Global', [GLOB]),
{30} wbFormIDCkNoReach('Weather', [WTHR]),
{31} wbFormIDCkNoReach('Package', [PACK]),
{32} wbFormIDCkNoReach('Encounter Zone', [ECZN]),
{33} wbFormIDCkNoReach('Perk', [PERK]),
{34} wbFormIDCkNoReach('Owner', [FACT, NPC_]),
{35} wbFormIDCkNoReach('Furniture', [FURN, FLST]),
{36} wbFormIDCkNoReach('Effect Item', [SPEL, ENCH, ALCH, INGR]),
{37} wbFormIDCkNoReach('Base Effect', [MGEF]),
{38} wbFormIDCkNoReach('Worldspace', [WRLD]),
{39} wbInteger('VATS Value Function', itU32, wbVATSValueFunctionEnum),
{40} wbInteger('VATS Value Param (INVALID)', itU32),
{41} wbInteger('Creature Type', itU32, wbCreatureTypeEnum),
{42} wbInteger('Menu Mode', itU32, wbMenuModeEnum),
{43} wbInteger('Player Action', itU32, wbPlayerActionEnum),
{44} wbInteger('Body Location', itS32, wbBodyLocationEnum),
{45} wbFormIDCkNoReach('Referenceable Object', [CREA, NPC_, PROJ, TREE, SOUN, ACTI, DOOR, STAT, FURN, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS, ASPC, IDLM, ARMA, MSTT, NOTE, PWAT, SCOL, TACT, TERM, FLST, CHIP, CMNY, CCRD, IMOD, LVLC, LVLN],
[CREA, NPC_, PROJ, TREE, SOUN, ACTI, DOOR, STAT, FURN, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS, ASPC, IDLM, ARMA, MSTT, NOTE, PWAT, SCOL, TACT, TERM, CHIP, CMNY, CCRD, IMOD, LVLC, LVLN]),
{46} wbInteger('Quest Objective (INVALID)', itS32),
{47} wbFormIDCkNoReach('Reputation', [REPU]),
{48} wbFormIDCkNoReach('Region', [REGN]),
{49} wbFormIDCkNoReach('Challenge', [CHAL]),
{50} wbFormIDCkNoReach('Casino', [CSNO]),
{51} wbFormID('Form')
]),
wbUnion('Parameter #2', wbCTDAParam2Decider, [
{00} wbByteArray('Unknown', 4),
{01} wbByteArray('None', 4, cpIgnore),
{02} wbInteger('Integer', itS32),
{03} wbInteger('Variable Name', itS32, wbCTDAParam2VariableNameToStr, wbCTDAParam2VariableNameToInt),
{04} wbInteger('Sex', itU32, wbSexEnum),
{05} wbInteger('Actor Value', itS32, wbActorValueEnum),
{06} wbInteger('Crime Type', itU32, wbCrimeTypeEnum),
{07} wbInteger('Axis', itU32, wbAxisEnum),
{08} wbInteger('Quest Stage', itS32, wbCTDAParam2QuestStageToStr, wbCTDAParam2QuestStageToInt),
{09} wbInteger('Misc Stat', itU32, wbMiscStatEnum),
{10} wbInteger('Alignment', itU32, wbAlignmentEnum),
{11} wbInteger('Equip Type', itU32, wbEquipTypeEnum),
{12} wbInteger('Form Type', itU32, wbFormTypeEnum),
{13} wbInteger('Critical Stage', itU32, wbCriticalStageEnum),
{14} wbFormIDCkNoReach('Object Reference', [PLYR, REFR, PMIS, PBEA, ACHR, ACRE, PGRE, TRGT], True),
{16} wbFormIDCkNoReach('Inventory Object', [ARMO, BOOK, MISC, WEAP, AMMO, KEYM, ALCH, NOTE, FLST, CHIP, CMNY, CCRD, IMOD]),
{17} wbFormIDCkNoReach('Actor', [PLYR, ACHR, ACRE, TRGT], True),
{18} wbFormIDCkNoReach('Voice Type', [VTYP]),
{19} wbFormIDCkNoReach('Idle', [IDLE]),
{20} wbFormIDCkNoReach('Form List', [FLST]),
{21} wbFormIDCkNoReach('Note', [NOTE]),
{22} wbFormIDCkNoReach('Quest', [QUST]),
{23} wbFormIDCkNoReach('Faction', [FACT]),
{24} wbFormIDCkNoReach('Weapon', [WEAP]),
{25} wbFormIDCkNoReach('Cell', [CELL]),
{26} wbFormIDCkNoReach('Class', [CLAS]),
{27} wbFormIDCkNoReach('Race', [RACE]),
{28} wbFormIDCkNoReach('Actor Base', [NPC_, CREA, ACTI, TACT]),
{29} wbFormIDCkNoReach('Global', [GLOB]),
{30} wbFormIDCkNoReach('Weather', [WTHR]),
{31} wbFormIDCkNoReach('Package', [PACK]),
{32} wbFormIDCkNoReach('Encounter Zone', [ECZN]),
{33} wbFormIDCkNoReach('Perk', [PERK]),
{34} wbFormIDCkNoReach('Owner', [FACT, NPC_]),
{35} wbFormIDCkNoReach('Furniture', [FURN, FLST]),
{36} wbFormIDCkNoReach('Effect Item', [SPEL, ENCH, ALCH, INGR]),
{37} wbFormIDCkNoReach('Base Effect', [MGEF]),
{38} wbFormIDCkNoReach('Worldspace', [WRLD]),
{39} wbInteger('VATS Value Function (INVALID)', itU32),
{40} wbUnion('VATS Value Param', wbCTDAParam2VATSValueParam, [
wbFormIDCkNoReach('Weapon', [WEAP]),
wbFormIDCkNoReach('Weapon List', [FLST], [WEAP]),
wbFormIDCkNoReach('Target', [NPC_, CREA]),
wbFormIDCkNoReach('Target List', [FLST], [NPC_, CREA]),
wbByteArray('Unused', 4, cpIgnore),
wbInteger('Target Part', itS32, wbActorValueEnum),
wbInteger('VATS Action', itU32, wbEnum([
'Unarmed Attack',
'One Hand Melee Attack',
'Two Hand Melee Attack',
'Fire Pistol',
'Fire Rifle',
'Fire Handle Weapon',
'Fire Launcher',
'Throw Grenade',
'Place Mine',
'Reload',
'Crouch',
'Stand',
'Switch Weapon',
'Toggle Weapon Drawn',
'Heal',
'Player Death',
'Special Weapon Attack',
'Special Unarmed Attack',
'Kill Camera Shot',
'Throw Weapon'
])),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbFormIDCkNoReach('Critical Effect', [SPEL]),
wbFormIDCkNoReach('Critical Effect List', [FLST], [SPEL]),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbInteger('Weapon Type', itU32, wbWeaponAnimTypeEnum),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore)
]),
{41} wbInteger('Creature Type', itU32, wbCreatureTypeEnum),
{42} wbInteger('Menu Mode', itU32, wbMenuModeEnum),
{43} wbInteger('Player Action', itU32, wbPlayerActionEnum),
{44} wbInteger('Body Location', itS32, wbBodyLocationEnum),
{45} wbFormIDCkNoReach('Referenceable Object', [CREA, NPC_, PROJ, TREE, SOUN, ACTI, DOOR, STAT, FURN, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS, ASPC, IDLM, ARMA, MSTT, NOTE, PWAT, SCOL, TACT, TERM, FLST, CHIP, CMNY, CCRD, IMOD, LVLC, LVLN],
[CREA, NPC_, PROJ, TREE, SOUN, ACTI, DOOR, STAT, FURN, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS, ASPC, IDLM, ARMA, MSTT, NOTE, PWAT, SCOL, TACT, TERM, CHIP, CMNY, CCRD, IMOD, LVLC, LVLN]),
{46} wbInteger('Quest Objective', itS32, wbCTDAParam2QuestObjectiveToStr, wbCTDAParam2QuestObjectiveToInt),
{47} wbFormIDCkNoReach('Reputation', [REPU]),
{48} wbFormIDCkNoReach('Region', [REGN]),
{49} wbFormIDCkNoReach('Challenge', [CHAL]),
{50} wbFormIDCkNoReach('Casino', [CSNO]),
{51} wbFormID('Form')
]),
wbInteger('Run On', itU32, wbEnum([
'Subject',
'Target',
'Reference',
'Combat Target',
'Linked Reference'
]), cpNormal, False, nil, wbCTDARunOnAfterSet),
wbUnion('Reference', wbCTDAReferenceDecider, [
wbInteger('Unused', itU32, nil, cpIgnore),
wbFormIDCkNoReach('Reference', [PLYR, ACHR, ACRE, REFR, PMIS, PBEA, PGRE, NULL], True) // Can end up NULL if the original function requiring a reference is replaced by another who has no Run on prerequisite
])
], cpNormal, False, nil, 6, wbCTDAAfterLoad);
wbCTDAs := wbRArray('Conditions', wbCTDA);
wbCTDAsReq := wbRArray('Conditions', wbCTDA, cpNormal, True);
wbEffects :=
wbRStructs('Effects','Effect', [
wbEFID,
wbEFIT,
wbCTDAs
], []);
wbEffectsReq :=
wbRStructs('Effects','Effect', [
wbEFID,
wbEFIT,
wbCTDAs
], [], cpNormal, True);
wbRecord(ALCH, 'Ingestible', [
wbEDIDReq,
wbOBNDReq,
wbFULLReq,
wbMODL,
wbICON,
wbSCRI,
wbDEST,
wbYNAM,
wbZNAM,
wbETYPReq,
wbFloat(DATA, 'Weight', cpNormal, True),
wbStruct(ENIT, 'Effect Data', [
wbInteger('Value', itS32),
wbInteger('Flags?', itU8, wbFlags([
'No Auto-Calc (Unused)',
'Food Item',
'Medicine'
])),
wbByteArray('Unused', 3),
wbFormIDCk('Withdrawal Effect', [SPEL, NULL]),
wbFloat('Addiction Chance'),
wbFormIDCk('Sound - Consume', [SOUN, NULL])
], cpNormal, True),
wbEffectsReq
]);
wbRecord(AMMO, 'Ammunition', [
wbEDIDReq,
wbOBNDReq,
wbFULLReq,
wbMODL,
wbICON,
wbSCRI,
wbDEST,
wbYNAM,
wbZNAM,
wbStruct(DATA, 'Data', [
wbFloat('Speed'),
wbInteger('Flags', itU8, wbFlags([
'Ignores Normal Weapon Resistance',
'Non-Playable'
])),
wbByteArray('Unused', 3),
wbInteger('Value', itS32),
wbInteger('Clip Rounds', itU8)
], cpNormal, True),
wbStruct(DAT2, 'Data 2', [
wbInteger('Proj. per Shot', itU32),
wbFormIDCk('Projectile', [PROJ, NULL]),
wbFloat('Weight'),
wbFormIDCk('Consumed Ammo', [AMMO, MISC, NULL]),
wbFloat('Consumed Percentage')
], cpNormal, False, nil, 3),
wbString(ONAM, 'Short Name'),
wbString(QNAM, 'Abbrev.'),
wbRArray('Ammo Effects',
wbFormIDCk(RCIL, 'Effect', [AMEF])
)
]);
wbRecord(ANIO, 'Animated Object', [
wbEDIDReq,
wbMODLReq,
wbFormIDCk(DATA, 'Animation', [IDLE], False, cpNormal, True)
]);
wbBMDT := wbStruct(BMDT, 'Biped Data', [
wbInteger('Biped Flags', itU32, wbFlags([
{0x00000001} 'Head',
{0x00000002} 'Hair',
{0x00000004} 'Upper Body',
{0x00000008} 'Left Hand',
{0x00000010} 'Right Hand',
{0x00000020} 'Weapon',
{0x00000040} 'PipBoy',
{0x00000080} 'Backpack',
{0x00000100} 'Necklace',
{0x00000200} 'Headband',
{0x00000400} 'Hat',
{0x00000800} 'Eye Glasses',
{0x00001000} 'Nose Ring',
{0x00002000} 'Earrings',
{0x00004000} 'Mask',
{0x00008000} 'Choker',
{0x00010000} 'Mouth Object',
{0x00020000} 'Body AddOn 1',
{0x00040000} 'Body AddOn 2',
{0x00080000} 'Body AddOn 3'
])),
wbInteger('General Flags', itU8, wbFlags([
{0x0001} '1',
{0x0002} '2',
{0x0004} 'Has Backpack',
{0x0008} 'Medium',
{0x0010} '5',
{0x0020} 'Power Armor',
{0x0040} 'Non-Playable',
{0x0080} 'Heavy'
], True)),
wbByteArray('Unused')
], cpNormal, True);
wbRecord(ARMO, 'Armor', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbSCRI,
wbEITM,
wbBMDT,
wbRStruct('Male biped model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore),
wbMODS,
wbMODD
], [], cpNormal, False, nil, True),
wbRStruct('Male world model', [
wbString(MOD2, 'Model Filename'),
wbByteArray(MO2T, 'Texture Files Hashes', 0, cpIgnore),
wbMO2S
], []),
wbString(ICON, 'Male icon filename'),
wbString(MICO, 'Male mico filename'),
wbRStruct('Female biped model', [
wbString(MOD3, 'Model Filename', 0, cpNormal, True),
wbByteArray(MO3T, 'Texture Files Hashes', 0, cpIgnore),
wbMO3S,
wbMOSD
], [], cpNormal, False, nil, True),
wbRStruct('Female world model', [
wbString(MOD4, 'Model Filename'),
wbByteArray(MO4T, 'Texture Files Hashes', 0, cpIgnore),
wbMO4S
], []),
wbString(ICO2, 'Female icon filename'),
wbString(MIC2, 'Female mico filename'),
wbString(BMCT, 'Ragdoll Constraint Template'),
wbREPL,
wbBIPL,
wbETYPReq,
wbYNAM,
wbZNAM,
wbStruct(DATA, 'Data', [
wbInteger('Value', itS32),
wbInteger('Health', itS32),
wbFloat('Weight')
], cpNormal, True),
wbStruct(DNAM, '', [
wbInteger('AR', itS16, wbDiv(100)),
wbInteger('Flags', itU16, wbFlags([
'Modulates Voice'
])),
wbFloat('DT'),
wbByteArray('?', 4)
], cpNormal, True, nil, 2),
wbInteger(BNAM, 'Overrides Animation Sounds', itU32, wbEnum(['No', 'Yes'])),
wbRArray('Animation Sounds',
wbStruct(SNAM, 'Animation Sound', [
wbFormIDCk('Sound', [SOUN]),
wbInteger('Chance', itU8),
wbByteArray('Unused', 3),
wbInteger('Type', itU32, wbEnum([], [
19, 'Run',
21, 'Run (Armor)',
18, 'Sneak',
20, 'Sneak (Armor)',
17, 'Walk',
22, 'Walk (Armor)'
]))
])
),
wbFormIDCk(TNAM, 'Animation Sounds Template', [ARMO])
]);
wbRecord(ARMA, 'Armor Addon', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbBMDT,
wbRStruct('Male biped model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore),
wbMODS,
wbMODD
], [], cpNormal, False, nil, True),
wbRStruct('Male world model', [
wbString(MOD2, 'Model Filename'),
wbByteArray(MO2T, 'Texture Files Hashes', 0, cpIgnore),
wbMO2S
], []),
wbString(ICON, 'Male icon filename'),
wbString(MICO, 'Male mico filename'),
wbRStruct('Female biped model', [
wbString(MOD3, 'Model Filename', 0, cpNormal, True),
wbByteArray(MO3T, 'Texture Files Hashes', 0, cpIgnore),
wbMO3S,
wbMOSD
], [], cpNormal, False, nil, True),
wbRStruct('Female world model', [
wbString(MOD4, 'Model Filename'),
wbByteArray(MO4T, 'Texture Files Hashes', 0, cpIgnore),
wbMO4S
], []),
wbString(ICO2, 'Female icon filename'),
wbString(MIC2, 'Female mico filename'),
wbETYPReq,
wbStruct(DATA, 'Data', [
wbInteger('Value', itS32),
wbInteger('Max Condition', itS32),
wbFloat('Weight')
], cpNormal, True),
wbStruct(DNAM, '', [
wbInteger('AR', itS16, wbDiv(100)),
wbInteger('Flags', itU16, wbFlags([ // Only a byte or 2 distincts byte
'Modulates Voice'
])),
wbFloat('DT'),
wbByteArray('Unused', 4)
], cpNormal, True, nil, 2)
]);
wbRecord(BOOK, 'Book', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbSCRI,
wbDESCReq,
wbDEST,
wbYNAM,
wbZNAM,
wbStruct(DATA, 'Data', [
wbInteger('Flags', itU8, wbFlags([
'',
'Can''t be Taken'
])),
wbInteger('Skill', itS8, wbSkillEnum),
wbInteger('Value', itS32),
wbFloat('Weight')
], cpNormal, True)
]);
wbSPLO := wbFormIDCk(SPLO, 'Actor Effect', [SPEL]);
wbSPLOs := wbRArrayS('Actor Effects', wbSPLO, cpNormal, False, nil, nil, wbActorTemplateUseActorEffectList);
wbRecord(CELL, 'Cell', [
wbEDID,
wbFULL,
wbInteger(DATA, 'Flags', itU8, wbFlags([
{0x01} 'Is Interior Cell',
{0x02} 'Has water',
{0x04} 'Invert Fast Travel behavior',
{0x08} 'No LOD Water',
{0x10} '',
{0x20} 'Public place',
{0x40} 'Hand changed',
{0x80} 'Behave like exterior'
]), cpNormal, True),
wbStruct(XCLC, 'Grid', [
wbInteger('X', itS32),
wbInteger('Y', itS32),
wbInteger('Force Hide Land', itU32, wbFlags([
'Quad 1',
'Quad 2',
'Quad 3',
'Quad 4'
], True))
], cpNormal, False, nil, 2),
wbStruct(XCLL, 'Lighting', [
wbStruct('Ambient Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Directional Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Fog Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbFloat('Fog Near'),
wbFloat('Fog Far'),
wbInteger('Directional Rotation XY', itS32),
wbInteger('Directional Rotation Z', itS32),
wbFloat('Directional Fade'),
wbFloat('Fog Clip Dist'),
wbFloat('Fog Power')
], cpNormal, False, nil, 7),
wbArray(IMPF, 'Footstep Materials', wbString('Unknown', 30), [
'ConcSolid',
'ConcBroken',
'MetalSolid',
'MetalHollow',
'MetalSheet',
'Wood',
'Sand',
'Dirt',
'Grass',
'Water'
]),
wbRStruct('Light Template', [
wbFormIDCk(LTMP, 'Template', [LGTM, NULL]),
wbInteger(LNAM, 'Inherit', itU32, wbFlags([
{0x00000001}'Ambient Color',
{0x00000002}'Directional Color',
{0x00000004}'Fog Color',
{0x00000008}'Fog Near',
{0x00000010}'Fog Far',
{0x00000020}'Directional Rotation',
{0x00000040}'Directional Fade',
{0x00000080}'Clip Distance',
{0x00000100}'Fog Power'
]), cpNormal, True)
], [], cpNormal, True ),
wbFloat(XCLW, 'Water Height'),
wbString(XNAM, 'Water Noise Texture'),
wbArrayS(XCLR, 'Regions', wbFormIDCk('Region', [REGN])),
wbFormIDCk(XCIM, 'Image Space', [IMGS]),
wbByteArray(XCET, 'Unknown', 1, cpIgnore),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbFormIDCk(XCCM, 'Climate', [CLMT]),
wbFormIDCk(XCWT, 'Water', [WATR]),
wbRStruct('Ownership', [
wbXOWN,
wbInteger(XRNK, 'Faction rank', itS32)
], [XCMT, XCMO]),
wbFormIDCk(XCAS, 'Acoustic Space', [ASPC]),
wbByteArray(XCMT, 'Unused', 1, cpIgnore),
wbFormIDCk(XCMO, 'Music Type', [MUSC])
], True, wbCellAddInfo, cpNormal, False, wbCELLAfterLoad);
wbServiceFlags :=
wbFlags([
{0x00000001} 'Weapons',
{0x00000002} 'Armor',
{0x00000004} 'Alcohol',
{0x00000008} 'Books',
{0x00000010} 'Food',
{0x00000020} 'Chems',
{0x00000040} 'Stimpacks',
{0x00000080} 'Lights?',
{0x00000100} '',
{0x00000200} '',
{0x00000400} 'Miscellaneous',
{0x00000800} '',
{0x00001000} '',
{0x00002000} 'Potions?',
{0x00004000} 'Training',
{0x00008000} '',
{0x00010000} 'Recharge',
{0x00020000} 'Repair'
]);
wbSpecializationEnum := wbEnum(['Combat', 'Magic', 'Stealth']);
wbRecord(CLAS, 'Class', [
wbEDIDReq,
wbFULLReq,
wbDESCReq,
wbICON,
wbStruct(DATA, '', [
wbArray('Tag Skills', wbInteger('Tag Skill', itS32, wbActorValueEnum), 4),
wbInteger('Flags', itU32, wbFlags(['Playable', 'Guard'], True)),
wbInteger('Buys/Sells and Services', itU32, wbServiceFlags),
wbInteger('Teaches', itS8, wbSkillEnum),
wbInteger('Maximum training level', itU8),
wbByteArray('Unused', 2)
], cpNormal, True),
wbArray(ATTR, 'Attributes', wbInteger('Attribute', itU8), [
'Strength',
'Perception',
'Endurance',
'Charisma',
'Intelligence',
'Agility',
'Luck'
], cpNormal, True)
]);
end;
procedure DefineFNVc;
begin
wbRecord(CLMT, 'Climate', [
wbEDIDReq,
wbArrayS(WLST, 'Weather Types', wbStructSK([0], 'Weather Type', [
wbFormIDCk('Weather', [WTHR, NULL]),
wbInteger('Chance', itS32),
wbFormIDCk('Global', [GLOB, NULL])
])),
wbString(FNAM, 'Sun Texture'),
wbString(GNAM, 'Sun Glare Texture'),
wbMODL,
wbStruct(TNAM, 'Timing', [
wbStruct('Sunrise', [
wbInteger('Begin', itU8, wbClmtTime),
wbInteger('End', itU8, wbClmtTime)
]),
wbStruct('Sunset', [
wbInteger('Begin', itU8, wbClmtTime),
wbInteger('End', itU8, wbClmtTime)
]),
wbInteger('Volatility', itU8),
wbInteger('Moons / Phase Length', itU8, wbClmtMoonsPhaseLength)
], cpNormal, True)
]);
wbCNTO :=
wbRStructExSK([0], [1], 'Item', [
wbStructExSK(CNTO, [0], [1], 'Item', [
wbFormIDCk('Item', [ARMO, AMMO, MISC, WEAP, BOOK, LVLI, KEYM, ALCH, NOTE, IMOD, CMNY, CCRD, LIGH, CHIP{, MSTT{?}{, STAT{?}]),
wbInteger('Count', itS32)
]),
wbCOED
], []);
wbCNTOs := wbRArrayS('Items', wbCNTO);
wbRecord(CONT, 'Container', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbSCRI,
wbCNTOs,
wbDEST,
wbStruct(DATA, '', [
wbInteger('Flags', itU8, wbFlags(['', 'Respawns'])),
wbFloat('Weight')
], cpNormal, True),
wbFormIDCk(SNAM, 'Sound - Open', [SOUN]),
wbFormIDCk(QNAM, 'Sound - Close', [SOUN]),
wbFormIDCk(RNAM, 'Sound - Random/Looping', [SOUN])
], True);
wbCSDT := wbRStructSK([0], 'Sound Type', [
wbInteger(CSDT, 'Type', itU32,wbEnum([
{00} 'Left Foot',
{01} 'Right Foot',
{02} 'Left Back Foot',
{03} 'Right Back Foot',
{04} 'Idle',
{05} 'Aware',
{06} 'Attack',
{07} 'Hit',
{08} 'Death',
{09} 'Weapon',
{10} 'Movement Loop',
{11} 'Conscious Loop',
{12} 'Auxiliary 1',
{13} 'Auxiliary 2',
{14} 'Auxiliary 3',
{15} 'Auxiliary 4',
{16} 'Auxiliary 5',
{17} 'Auxiliary 6',
{18} 'Auxiliary 7',
{19} 'Auxiliary 8',
{19} 'Auxiliary 8',
{20} 'Jump',
{21} 'PlayRandom/Loop'
])),
wbRArrayS('Sounds', wbRStructSK([0], 'Sound', [
wbFormIDCk(CSDI, 'Sound', [SOUN, NULL], False, cpNormal, True),
wbInteger(CSDC, 'Sound Chance', itU8, nil, cpNormal, True)
], []), cpNormal, True)
], []);
wbCSDTs := wbRArrayS('Sound Types', wbCSDT, cpNormal, False, nil, nil, wbActorTemplateUseModelAnimation);
wbAgressionEnum := wbEnum([
'Unaggressive',
'Aggressive',
'Very Aggressive',
'Frenzied'
]);
wbConfidenceEnum := wbEnum([
'Cowardly',
'Cautious',
'Average',
'Brave',
'Foolhardy'
]);
wbMoodEnum := wbEnum([
'Neutral',
'Afraid',
'Annoyed',
'Cocky',
'Drugged',
'Pleasant',
'Angry',
'Sad'
]);
wbAssistanceEnum := wbEnum([
'Helps Nobody',
'Helps Allies',
'Helps Friends and Allies'
]);
wbAggroRadiusFlags := wbFlags([
'Aggro Radius Behavior'
]);
wbAIDT :=
wbStruct(AIDT, 'AI Data', [
{00} wbInteger('Aggression', itU8, wbAgressionEnum),
{01} wbInteger('Confidence', itU8, wbConfidenceEnum),
{02} wbInteger('Energy Level', itU8),
{03} wbInteger('Responsibility', itU8),
{04} wbInteger('Mood', itU8, wbMoodEnum),
{05} wbByteArray('Unused', 3), // Mood is stored as a DWord as shown by endianSwapping but is truncated to byte during load :)
{08} wbInteger('Buys/Sells and Services', itU32, wbServiceFlags),
{0C} wbInteger('Teaches', itS8, wbSkillEnum),
{0D} wbInteger('Maximum training level', itU8),
{0E} wbInteger('Assistance', itS8, wbAssistanceEnum),
{0F} wbInteger('Aggro Radius Behavior', itU8, wbAggroRadiusFlags),
{10} wbInteger('Aggro Radius', itS32)
], cpNormal, True, wbActorTemplateUseAIData);
wbAttackAnimationEnum :=
wbEnum([
], [
26, 'AttackLeft',
27, 'AttackLeftUp',
28, 'AttackLeftDown',
29, 'AttackLeftIS',
30, 'AttackLeftISUp',
31, 'AttackLeftISDown',
32, 'AttackRight',
33, 'AttackRightUp',
34, 'AttackRightDown',
35, 'AttackRightIS',
36, 'AttackRightISUp',
37, 'AttackRightISDown',
38, 'Attack3',
39, 'Attack3Up',
40, 'Attack3Down',
41, 'Attack3IS',
42, 'Attack3ISUp',
43, 'Attack3ISDown',
44, 'Attack4',
45, 'Attack4Up',
46, 'Attack4Down',
47, 'Attack4IS',
48, 'Attack4ISUp',
49, 'Attack4ISDown',
50, 'Attack5',
51, 'Attack5Up',
52, 'Attack5Down',
53, 'Attack5IS',
54, 'Attack5ISUp',
55, 'Attack5ISDown',
56, 'Attack6',
57, 'Attack6Up',
58, 'Attack6Down',
59, 'Attack6IS',
60, 'Attack6ISUp',
61, 'Attack6ISDown',
62, 'Attack7',
63, 'Attack7Up',
64, 'Attack7Down',
65, 'Attack7IS',
66, 'Attack7ISUp',
67, 'Attack7ISDown',
68, 'Attack8',
69, 'Attack8Up',
70, 'Attack8Down',
71, 'Attack8IS',
72, 'Attack8ISUp',
73, 'Attack8ISDown',
74, 'AttackLoop',
75, 'AttackLoopUp',
76, 'AttackLoopDown',
77, 'AttackLoopIS',
78, 'AttackLoopISUp',
79, 'AttackLoopISDown',
80, 'AttackSpin',
81, 'AttackSpinUp',
82, 'AttackSpinDown',
83, 'AttackSpinIS',
84, 'AttackSpinISUp',
85, 'AttackSpinISDown',
86, 'AttackSpin2',
87, 'AttackSpin2Up',
88, 'AttackSpin2Down',
89, 'AttackSpin2IS',
90, 'AttackSpin2ISUp',
91, 'AttackSpin2ISDown',
92, 'AttackPower',
93, 'AttackForwardPower',
94, 'AttackBackPower',
95, 'AttackLeftPower',
96, 'AttackRightPower',
97, 'PlaceMine',
98, 'PlaceMineUp',
99, 'PlaceMineDown',
100, 'PlaceMineIS',
101, 'PlaceMineISUp',
102, 'PlaceMineISDown',
103, 'PlaceMine2',
104, 'PlaceMine2Up',
105, 'PlaceMine2Down',
106, 'PlaceMine2IS',
107, 'PlaceMine2ISUp',
108, 'PlaceMine2ISDown',
109, 'AttackThrow',
110, 'AttackThrowUp',
111, 'AttackThrowDown',
112, 'AttackThrowIS',
113, 'AttackThrowISUp',
114, 'AttackThrowISDown',
115, 'AttackThrow2',
116, 'AttackThrow2Up',
117, 'AttackThrow2Down',
118, 'AttackThrow2IS',
119, 'AttackThrow2ISUp',
120, 'AttackThrow2ISDown',
121, 'AttackThrow3',
122, 'AttackThrow3Up',
123, 'AttackThrow3Down',
124, 'AttackThrow3IS',
125, 'AttackThrow3ISUp',
126, 'AttackThrow3ISDown',
127, 'AttackThrow4',
128, 'AttackThrow4Up',
129, 'AttackThrow4Down',
130, 'AttackThrow4IS',
131, 'AttackThrow4ISUp',
132, 'AttackThrow4ISDown',
133, 'AttackThrow5',
134, 'AttackThrow5Up',
135, 'AttackThrow5Down',
136, 'AttackThrow5IS',
137, 'AttackThrow5ISUp',
138, 'AttackThrow5ISDown',
167, 'PipBoy',
178, 'PipBoyChild',
255, ' ANY'
]);
wbImpactMaterialTypeEnum :=
wbEnum([
'Stone',
'Dirt',
'Grass',
'Glass',
'Metal',
'Wood',
'Organic',
'Cloth',
'Water',
'Hollow Metal',
'Organic Bug',
'Organic Glow'
]);
wbTemplateFlags := wbFlags([
'Use Traits',
'Use Stats',
'Use Factions',
'Use Actor Effect List',
'Use AI Data',
'Use AI Packages',
'Use Model/Animation',
'Use Base Data',
'Use Inventory',
'Use Script'
]);
wbRecord(CREA, 'Creature', [
wbEDIDReq,
wbOBNDReq,
wbFULLActor,
wbMODLActor,
wbSPLOs,
wbFormIDCk(EITM, 'Unarmed Attack Effect', [ENCH, SPEL], False, cpNormal, False, wbActorTemplateUseActorEffectList),
wbInteger(EAMT, 'Unarmed Attack Animation', itU16, wbAttackAnimationEnum, cpNormal, True, False, wbActorTemplateUseActorEffectList),
wbArrayS(NIFZ, 'Model List', wbStringLC('Model'), 0, cpNormal, False, nil, nil, wbActorTemplateUseModelAnimation),
wbByteArray(NIFT, 'Texture Files Hashes', 0, cpIgnore, False, False, wbActorTemplateUseModelAnimation),
wbStruct(ACBS, 'Configuration', [
{00} wbInteger('Flags', itU32, wbFlags([
{0x000001} 'Biped',
{0x000002} 'Essential',
{0x000004} 'Weapon & Shield?',
{0x000008} 'Respawn',
{0x000010} 'Swims',
{0x000020} 'Flies',
{0x000040} 'Walks',
{0x000080} 'PC Level Mult',
{0x000100} 'Unknown 8',
{0x000200} 'No Low Level Processing',
{0x000400} '',
{0x000800} 'No Blood Spray',
{0x001000} 'No Blood Decal',
{0x002000} '',
{0x004000} '',
{0x008000} 'No Head',
{0x010000} 'No Right Arm',
{0x020000} 'No Left Arm',
{0x040000} 'No Combat in Water',
{0x080000} 'No Shadow',
{0x100000} 'No VATS Melee',
{0x00200000} 'Allow PC Dialogue',
{0x00400000} 'Can''t Open Doors',
{0x00800000} 'Immobile',
{0x01000000} 'Tilt Front/Back',
{0x02000000} 'Tilt Left/Right',
{0x03000000} 'No Knockdowns',
{0x08000000} 'Not Pushable',
{0x10000000} 'Allow Pickpocket',
{0x20000000} 'Is Ghost',
{0x40000000} 'No Rotating To Head-track',
{0x80000000} 'Invulnerable'
], [
{0x000001 Biped} wbActorTemplateUseModelAnimation,
{0x000002 Essential} wbActorTemplateUseBaseData,
{0x000004 Weapon & Shield} nil,
{0x000008 Respawn} wbActorTemplateUseBaseData,
{0x000010 Swims} wbActorTemplateUseModelAnimation,
{0x000020 Flies} wbActorTemplateUseModelAnimation,
{0x000040 Walks} wbActorTemplateUseModelAnimation,
{0x000080 PC Level Mult} wbActorTemplateUseStats,
{0x000100 Unknown 8} nil,
{0x000200 No Low Level Processing} wbActorTemplateUseBaseData,
{0x000400 } nil,
{0x000800 No Blood Spray} wbActorTemplateUseModelAnimation,
{0x001000 No Blood Decal} wbActorTemplateUseModelAnimation,
{0x002000 } nil,
{0x004000 } nil,
{0x008000 No Head} wbActorTemplateUseModelAnimation,
{0x010000 No Right Arm} wbActorTemplateUseModelAnimation,
{0x020000 No Left Arm} wbActorTemplateUseModelAnimation,
{0x040000 No Combat in Water} wbActorTemplateUseModelAnimation,
{0x080000 No Shadow} wbActorTemplateUseModelAnimation,
{0x100000 No VATS Melee} nil,
{0x00200000 Allow PC Dialogue} wbActorTemplateUseBaseData,
{0x00400000 Can''t Open Doors} wbActorTemplateUseBaseData,
{0x00800000 Immobile} wbActorTemplateUseModelAnimation,
{0x01000000 Tilt Front/Back} wbActorTemplateUseModelAnimation,
{0x02000000 Tilt Left/Right} wbActorTemplateUseModelAnimation,
{0x03000000 No Knockdowns} nil,
{0x08000000 Not Pushable} wbActorTemplateUseModelAnimation,
{0x10000000 Allow Pickpocket} wbActorTemplateUseBaseData,
{0x20000000 Is Ghost} nil,
{0x40000000 No Rotating To Head-track} wbActorTemplateUseModelAnimation,
{0x80000000 Invulnerable} nil
])),
{04} wbInteger('Fatigue', itU16, nil, cpNormal, False, wbActorTemplateUseStats),
{06} wbInteger('Barter gold', itU16, nil, cpNormal, False, wbActorTemplateUseAIData),
{08} wbUnion('Level', wbCreaLevelDecider, [
wbInteger('Level', itS16, nil, cpNormal, False, wbActorTemplateUseStats),
wbInteger('Level Mult', itS16, wbDiv(1000), cpNormal, False, wbActorTemplateUseStats)
], cpNormal, False, wbActorTemplateUseStats),
{10} wbInteger('Calc min', itU16, nil, cpNormal, False, wbActorTemplateUseStats),
{12} wbInteger('Calc max', itU16, nil, cpNormal, False, wbActorTemplateUseStats),
{14} wbInteger('Speed Multiplier', itU16, nil, cpNormal, False, wbActorTemplateUseStats),
{16} wbFloat('Karma (Alignment)', cpNormal, False, 1, -1, wbActorTemplateUseTraits),
{20} wbInteger('Disposition Base', itS16, nil, cpNormal, False, wbActorTemplateUseTraits),
{22} wbInteger('Template Flags', itU16, wbTemplateFlags)
], cpNormal, True),
wbRArrayS('Factions',
wbStructSK(SNAM, [0], 'Faction', [
wbFormIDCk('Faction', [FACT]),
wbInteger('Rank', itU8),
wbByteArray('Unused', 3)
]),
cpNormal, False, nil, nil, wbActorTemplateUseFactions),
wbFormIDCk(INAM, 'Death item', [LVLI], False, cpNormal, False, wbActorTemplateUseTraits),
wbFormIDCk(VTCK, 'Voice', [VTYP], False, cpNormal, False, wbActorTemplateUseTraits),
wbFormIDCk(TPLT, 'Template', [CREA, LVLC]),
wbDESTActor,
wbSCRIActor,
wbRArrayS('Items', wbCNTO, cpNormal, False, nil, nil, wbActorTemplateUseInventory),
wbAIDT,
wbRArray('Packages', wbFormIDCk(PKID, 'Package', [PACK]), cpNormal, False, nil, nil, wbActorTemplateUseAIPackages),
wbArrayS(KFFZ, 'Animations', wbStringLC('Animation'), 0, cpNormal, False, nil, nil, wbActorTemplateUseModelAnimation),
wbStruct(DATA, '', [
{00} wbInteger('Type', itU8, wbCreatureTypeEnum, cpNormal, False, wbActorTemplateUseTraits),
{01} wbInteger('Combat Skill', itU8, nil, cpNormal, False, wbActorTemplateUseStats),
{02} wbInteger('Magic Skill', itU8, nil, cpNormal, False, wbActorTemplateUseStats),
{03} wbInteger('Stealth Skill', itU8, nil, cpNormal, False, wbActorTemplateUseStats),
{04} wbInteger('Health', itS16, nil, cpNormal, False, wbActorTemplateUseStats),
{06} wbByteArray('Unused', 2),
{08} wbInteger('Damage', itS16, nil, cpNormal, False, wbActorTemplateUseStats),
{10} wbArray('Attributes', wbInteger('Attribute', itU8), [
'Strength',
'Perception',
'Endurance',
'Charisma',
'Intelligence',
'Agility',
'Luck'
], cpNormal, False, wbActorTemplateUseStats)
], cpNormal, True),
wbInteger(RNAM, 'Attack reach', itU8, nil, cpNormal, True, False, wbActorTemplateUseTraits),
wbFormIDCk(ZNAM, 'Combat Style', [CSTY], False, cpNormal, False, wbActorTemplateUseTraits),
wbFormIDCk(PNAM, 'Body Part Data', [BPTD], False, cpNormal, True, wbActorTemplateUseModelAnimation),
wbFloat(TNAM, 'Turning Speed', cpNormal, True, 1, -1, wbActorTemplateUseStats),
wbFloat(BNAM, 'Base Scale', cpNormal, True, 1, -1, wbActorTemplateUseStats),
wbFloat(WNAM, 'Foot Weight', cpNormal, True, 1, -1, wbActorTemplateUseStats),
wbInteger(NAM4, 'Impact Material Type', itU32, wbImpactMaterialTypeEnum, cpNormal, True, False, wbActorTemplateUseModelAnimation),
wbInteger(NAM5, 'Sound Level', itU32, wbSoundLevelEnum, cpNormal, True, False, wbActorTemplateUseModelAnimation),
wbFormIDCk(CSCR, 'Inherits Sounds from', [CREA], False, cpNormal, False, wbActorTemplateUseModelAnimation),
wbCSDTs,
wbFormIDCk(CNAM, 'Impact Dataset', [IPDS], False, cpNormal, False, wbActorTemplateUseModelAnimation),
wbFormIDCk(LNAM, 'Melee Weapon List', [FLST], False, cpNormal, False, wbActorTemplateUseTraits)
], True);
end;
procedure DefineFNVd;
begin
wbRecord(CSTY, 'Combat Style', [
wbEDIDReq,
wbStruct(CSTD, 'Advanced - Standard', [
{000}wbInteger('Maneuver Decision - Dodge % Chance', itU8),
{001}wbInteger('Maneuver Decision - Left/Right % Chance', itU8),
{002}wbByteArray('Unused', 2),
{004}wbFloat('Maneuver Decision - Dodge L/R Timer (min)'),
{008}wbFloat('Maneuver Decision - Dodge L/R Timer (max)'),
{012}wbFloat('Maneuver Decision - Dodge Forward Timer (min)'),
{016}wbFloat('Maneuver Decision - Dodge Forward Timer (max)'),
{020}wbFloat('Maneuver Decision - Dodge Back Timer Min'),
{024}wbFloat('Maneuver Decision - Dodge Back Timer Max'),
{028}wbFloat('Maneuver Decision - Idle Timer min'),
{032}wbFloat('Maneuver Decision - Idle Timer max'),
{036}wbInteger('Melee Decision - Block % Chance', itU8),
{037}wbInteger('Melee Decision - Attack % Chance', itU8),
{038}wbByteArray('Unused', 2),
{040}wbFloat('Melee Decision - Recoil/Stagger Bonus to Attack'),
{044}wbFloat('Melee Decision - Unconscious Bonus to Attack'),
{048}wbFloat('Melee Decision - Hand-To-Hand Bonus to Attack'),
{052}wbInteger('Melee Decision - Power Attacks - Power Attack % Chance', itU8),
{053}wbByteArray('Unused', 3),
{056}wbFloat('Melee Decision - Power Attacks - Recoil/Stagger Bonus to Power'),
{060}wbFloat('Melee Decision - Power Attacks - Unconscious Bonus to Power Attack'),
{064}wbInteger('Melee Decision - Power Attacks - Normal', itU8),
{065}wbInteger('Melee Decision - Power Attacks - Forward', itU8),
{066}wbInteger('Melee Decision - Power Attacks - Back', itU8),
{067}wbInteger('Melee Decision - Power Attacks - Left', itU8),
{068}wbInteger('Melee Decision - Power Attacks - Right', itU8),
{069}wbByteArray('Unused', 3),
{072}wbFloat('Melee Decision - Hold Timer (min)'),
{076}wbFloat('Melee Decision - Hold Timer (max)'),
{080}wbInteger('Flags', itU16, wbFlags([
'Choose Attack using % Chance',
'Melee Alert OK',
'Flee Based on Personal Survival',
'',
'Ignore Threats',
'Ignore Damaging Self',
'Ignore Damaging Group',
'Ignore Damaging Spectators',
'Cannot Use Stealthboy'
])),
{082}wbByteArray('Unused', 2),
{085}wbInteger('Maneuver Decision - Acrobatic Dodge % Chance', itU8),
{085}wbInteger('Melee Decision - Power Attacks - Rushing Attack % Chance', itU8),
{086}wbByteArray('Unused', 2),
{088}wbFloat('Melee Decision - Power Attacks - Rushing Attack Distance Mult')
], cpNormal, True),
wbStruct(CSAD, 'Advanced - Advanced', [
wbFloat('Dodge Fatigue Mod Mult'),
wbFloat('Dodge Fatigue Mod Base'),
wbFloat('Encumb. Speed Mod Base'),
wbFloat('Encumb. Speed Mod Mult'),
wbFloat('Dodge While Under Attack Mult'),
wbFloat('Dodge Not Under Attack Mult'),
wbFloat('Dodge Back While Under Attack Mult'),
wbFloat('Dodge Back Not Under Attack Mult'),
wbFloat('Dodge Forward While Attacking Mult'),
wbFloat('Dodge Forward Not Attacking Mult'),
wbFloat('Block Skill Modifier Mult'),
wbFloat('Block Skill Modifier Base'),
wbFloat('Block While Under Attack Mult'),
wbFloat('Block Not Under Attack Mult'),
wbFloat('Attack Skill Modifier Mult'),
wbFloat('Attack Skill Modifier Base'),
wbFloat('Attack While Under Attack Mult'),
wbFloat('Attack Not Under Attack Mult'),
wbFloat('Attack During Block Mult'),
wbFloat('Power Att. Fatigue Mod Base'),
wbFloat('Power Att. Fatigue Mod Mult')
], cpNormal, True),
wbStruct(CSSD, 'Simple', [
{00} wbFloat('Cover Search Radius'),
{04} wbFloat('Take Cover Chance'),
{08} wbFloat('Wait Timer (min)'),
{12} wbFloat('Wait Timer (max)'),
{16} wbFloat('Wait to Fire Timer (min)'),
{20} wbFloat('Wait to Fire Timer (max)'),
{24} wbFloat('Fire Timer (min)'),
{28} wbFloat('Fire Timer (max)'),
{32} wbFloat('Ranged Weapon Range Mult (min)'),
{36} wbByteArray('Unused', 4),
{40} wbInteger('Weapon Restrictions', itU32, wbEnum([
'None',
'Melee Only',
'Ranged Only'
])),
{44} wbFloat('Ranged Weapon Range Mult (max)'),
{48} wbFloat('Max Targeting FOV'),
{52} wbFloat('Combat Radius'),
{56} wbFloat('Semi-Auto Firing Delay Mult (min)'),
{60} wbFloat('Semi-Auto Firing Delay Mult (max)')
], cpNormal, True)
]);
wbRecord(DIAL, 'Dialog Topic', [
wbEDIDReq,
wbRArrayS('Added Quests', wbRStructSK([0], 'Added Quest', [
wbFormIDCkNoReach(QSTI, 'Quest', [QUST], False, cpBenign),
wbRArray('Shared Infos', wbRStruct('Shared Info', [
wbFormIDCk(INFC, 'Info Connection', [INFO], False, cpBenign),
wbInteger(INFX, 'Info Index', itS32, nil, cpBenign)
], []))
], [])),
// no QSTR in FNV, but keep it just in case
wbRArrayS('Removed Quests', wbRStructSK([0], 'Removed Quest', [
wbFormIDCkNoReach(QSTR, 'Quest', [QUST], False, cpBenign)
], [])),
// some records have INFC INFX (with absent formids) but no QSTI, probably error in GECK
// i.e. [DIAL:001287C6] and [DIAL:000E9084]
wbRArray('Unused', wbRStruct('Unused', [
wbUnknown(INFC, cpIgnore),
wbUnknown(INFX, cpIgnore)
], []), cpIgnore, False, nil, nil, wbNeverShow),
wbFULL,
wbFloat(PNAM, 'Priority', cpNormal, True, 1, -1, nil, nil, 50.0),
wbString(TDUM, 'Dumb Response'),
wbStruct(DATA, '', [
wbInteger('Type', itU8, wbEnum([
{0} 'Topic',
{1} 'Conversation',
{2} 'Combat',
{3} 'Persuasion',
{4} 'Detection',
{5} 'Service',
{6} 'Miscellaneous',
{7} 'Radio'
])),
wbInteger('Flags', itU8, wbFlags([
'Rumors',
'Top-level'
]))
], cpNormal, True, nil, 1)
], True);
wbRecord(DOOR, 'Door', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODLReq,
wbSCRI,
wbDEST,
wbFormIDCk(SNAM, 'Sound - Open', [SOUN]),
wbFormIDCk(ANAM, 'Sound - Close', [SOUN]),
wbFormIDCk(BNAM, 'Sound - Looping', [SOUN]),
wbInteger(FNAM, 'Flags', itU8, wbFlags([
'',
'Automatic Door',
'Hidden',
'Minimal Use',
'Sliding Door'
]), cpNormal, True)
]);
wbBlendModeEnum := wbEnum([
'',
'Zero',
'One',
'Source Color',
'Source Inverse Color',
'Source Alpha',
'Source Inverted Alpha',
'Dest Alpha',
'Dest Inverted Alpha',
'Dest Color',
'Dest Inverse Color',
'Source Alpha SAT'
]);
wbBlendOpEnum := wbEnum([
'',
'Add',
'Subtract',
'Reverse Subtract',
'Minimum',
'Maximum'
]);
wbZTestFuncEnum := wbEnum([
'',
'',
'',
'Equal To',
'Normal',
'Greater Than',
'',
'Greater Than or Equal Than',
'Always Show'
]);
wbRecord(EFSH, 'Effect Shader', [
wbEDID,
wbString(ICON, 'Fill Texture'),
wbString(ICO2, 'Particle Shader Texture'),
wbString(NAM7, 'Holes Texture'),
wbStruct(DATA, '', [
wbInteger('Flags', itU8, wbFlags([
{0} 'No Membrane Shader',
{1} '',
{2} '',
{3} 'No Particle Shader',
{4} 'Edge Effect - Inverse',
{5} 'Membrane Shader - Affect Skin Only'
])),
wbByteArray('Unused', 3),
wbInteger('Membrane Shader - Source Blend Mode', itU32, wbBlendModeEnum),
wbInteger('Membrane Shader - Blend Operation', itU32, wbBlendOpEnum),
wbInteger('Membrane Shader - Z Test Function', itU32, wbZTestFuncEnum),
wbStruct('Fill/Texture Effect - Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbFloat('Fill/Texture Effect - Alpha Fade In Time'),
wbFloat('Fill/Texture Effect - Full Alpha Time'),
wbFloat('Fill/Texture Effect - Alpha Fade Out Time'),
wbFloat('Fill/Texture Effect - Presistent Alpha Ratio'),
wbFloat('Fill/Texture Effect - Alpha Pulse Amplitude'),
wbFloat('Fill/Texture Effect - Alpha Pulse Frequency'),
wbFloat('Fill/Texture Effect - Texture Animation Speed (U)'),
wbFloat('Fill/Texture Effect - Texture Animation Speed (V)'),
wbFloat('Edge Effect - Fall Off'),
wbStruct('Edge Effect - Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbFloat('Edge Effect - Alpha Fade In Time'),
wbFloat('Edge Effect - Full Alpha Time'),
wbFloat('Edge Effect - Alpha Fade Out Time'),
wbFloat('Edge Effect - Persistent Alpha Ratio'),
wbFloat('Edge Effect - Alpha Pulse Amplitude'),
wbFloat('Edge Effect - Alpha Pusle Frequence'),
wbFloat('Fill/Texture Effect - Full Alpha Ratio'),
wbFloat('Edge Effect - Full Alpha Ratio'),
wbInteger('Membrane Shader - Dest Blend Mode', itU32, wbBlendModeEnum),
wbInteger('Particle Shader - Source Blend Mode', itU32, wbBlendModeEnum),
wbInteger('Particle Shader - Blend Operation', itU32, wbBlendOpEnum),
wbInteger('Particle Shader - Z Test Function', itU32, wbZTestFuncEnum),
wbInteger('Particle Shader - Dest Blend Mode', itU32, wbBlendModeEnum),
wbFloat('Particle Shader - Particle Birth Ramp Up Time'),
wbFloat('Particle Shader - Full Particle Birth Time'),
wbFloat('Particle Shader - Particle Birth Ramp Down Time'),
wbFloat('Particle Shader - Full Particle Birth Ratio'),
wbFloat('Particle Shader - Persistant Particle Birth Ratio'),
wbFloat('Particle Shader - Particle Lifetime'),
wbFloat('Particle Shader - Particle Lifetime +/-'),
wbFloat('Particle Shader - Initial Speed Along Normal'),
wbFloat('Particle Shader - Acceleration Along Normal'),
wbFloat('Particle Shader - Initial Velocity #1'),
wbFloat('Particle Shader - Initial Velocity #2'),
wbFloat('Particle Shader - Initial Velocity #3'),
wbFloat('Particle Shader - Acceleration #1'),
wbFloat('Particle Shader - Acceleration #2'),
wbFloat('Particle Shader - Acceleration #3'),
wbFloat('Particle Shader - Scale Key 1'),
wbFloat('Particle Shader - Scale Key 2'),
wbFloat('Particle Shader - Scale Key 1 Time'),
wbFloat('Particle Shader - Scale Key 2 Time'),
wbStruct('Color Key 1 - Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Color Key 2 - Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Color Key 3 - Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbFloat('Color Key 1 - Color Alpha'),
wbFloat('Color Key 2 - Color Alpha'),
wbFloat('Color Key 3 - Color Alpha'),
wbFloat('Color Key 1 - Color Key Time'),
wbFloat('Color Key 2 - Color Key Time'),
wbFloat('Color Key 3 - Color Key Time'),
wbFloat('Particle Shader - Initial Speed Along Normal +/-'),
wbFloat('Particle Shader - Initial Rotation (deg)'),
wbFloat('Particle Shader - Initial Rotation (deg) +/-'),
wbFloat('Particle Shader - Rotation Speed (deg/sec)'),
wbFloat('Particle Shader - Rotation Speed (deg/sec) +/-'),
wbFormIDCk('Addon Models', [DEBR, NULL]),
wbFloat('Holes - Start Time'),
wbFloat('Holes - End Time'),
wbFloat('Holes - Start Val'),
wbFloat('Holes - End Val'),
wbFloat('Edge Width (alpha units)'),
wbStruct('Edge Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbFloat('Explosion Wind Speed'),
wbInteger('Texture Count U', itU32),
wbInteger('Texture Count V', itU32),
wbFloat('Addon Models - Fade In Time'),
wbFloat('Addon Models - Fade Out Time'),
wbFloat('Addon Models - Scale Start'),
wbFloat('Addon Models - Scale End'),
wbFloat('Addon Models - Scale In Time'),
wbFloat('Addon Models - Scale Out Time')
], cpNormal, True, nil, 57)
], False, nil, cpNormal, False, wbEFSHAfterLoad);
wbRecord(ENCH, 'Object Effect', [
wbEDIDReq,
wbFULL,
wbStruct(ENIT, 'Effect Data', [
wbInteger('Type', itU32, wbEnum([
{0} '',
{1} '',
{2} 'Weapon',
{3} 'Apparel'
])),
wbByteArray('Unused', 4),
wbByteArray('Unused', 4),
wbInteger('Flags', itU8, wbFlags([
'No Auto-Calc',
'Auto Calculate',
'Hide Effect'
])),
wbByteArray('Unused', 3)
], cpNormal, True),
wbEffectsReq
]);
wbRecord(EYES, 'Eyes', [
wbEDIDReq,
wbFULLReq,
wbString(ICON, 'Texture', 0{, cpNormal, True??}),
wbInteger(DATA, 'Flags', itU8, wbFlags([
'Playable',
'Not Male',
'Not Female'
]), cpNormal, True)
]);
wbXNAM :=
wbStructSK(XNAM, [0], 'Relation', [
wbFormIDCkNoReach('Faction', [FACT, RACE]),
wbInteger('Modifier', itS32),
wbInteger('Group Combat Reaction', itU32, wbEnum([
'Neutral',
'Enemy',
'Ally',
'Friend'
]))
]);
wbXNAMs := wbRArrayS('Relations', wbXNAM);
wbRecord(FACT, 'Faction', [
wbEDIDReq,
wbFULL,
wbXNAMs,
wbStruct(DATA, '', [
wbInteger('Flags 1', itU8, wbFlags([
'Hidden from PC',
'Evil',
'Special Combat'
])),
wbInteger('Flags 2', itU8, wbFlags([
'Track Crime',
'Allow Sell'
])),
wbByteArray('Unused', 2)
], cpNormal, True, nil, 1),
wbFloat(CNAM, 'Unused'),
wbRStructsSK('Ranks', 'Rank', [0], [
wbInteger(RNAM, 'Rank#', itS32),
wbString(MNAM, 'Male', 0, cpTranslate),
wbString(FNAM, 'Female', 0, cpTranslate),
wbString(INAM, 'Insignia (Unused)')
], []),
wbFormIDCk(WMI1, 'Reputation', [REPU])
], False, nil, cpNormal, False, wbFACTAfterLoad);
wbRecord(FURN, 'Furniture', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODLReq,
wbSCRI,
wbDEST,
wbByteArray(MNAM, 'Marker Flags', 0, cpNormal, True)
]);
wbRecord(GLOB, 'Global', [
wbEDIDReq,
wbInteger(FNAM, 'Type', itU8, wbGLOBFNAM, nil, cpNormal, True),
wbFloat(FLTV, 'Value', cpNormal, True)
]);
wbRecord(GMST, 'Game Setting', [
wbString(EDID, 'Editor ID', 0, cpCritical, True, nil, wbGMSTEDIDAfterSet),
wbUnion(DATA, 'Value', wbGMSTUnionDecider, [
wbString('', 0, cpTranslate),
wbInteger('', itS32),
wbFloat('')
], cpNormal, True)
]);
wbDODT := wbStruct(DODT, 'Decal Data', [
wbFloat('Min Width'),
wbFloat('Max Width'),
wbFloat('Min Height'),
wbFloat('Max Height'),
wbFloat('Depth'),
wbFloat('Shininess'),
wbStruct('Parallax', [
wbFloat('Scale'),
wbInteger('Passes', itU8)
]),
wbInteger('Flags', itU8, wbFlags([
'Parallax',
'Alpha - Blending',
'Alpha - Testing'
], True)),
wbByteArray('Unused', 2),
wbStruct('Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]);
wbRecord(TXST, 'Texture Set', [
wbEDIDReq,
wbOBNDReq,
wbRStruct('Textures (RGB/A)', [
wbString(TX00,'Base Image / Transparency'),
wbString(TX01,'Normal Map / Specular'),
wbString(TX02,'Environment Map Mask / ?'),
wbString(TX03,'Glow Map / Unused'),
wbString(TX04,'Parallax Map / Unused'),
wbString(TX05,'Environment Map / Unused')
], []),
wbDODT,
wbInteger(DNAM, 'Flags', itU16, wbFlags([
'No Specular Map'
]), cpNormal, True)
]);
wbRecord(MICN, 'Menu Icon', [
wbEDIDReq,
wbICONReq
]);
wbRecord(HDPT, 'Head Part', [
wbEDIDReq,
wbFULLReq,
wbMODL,
wbInteger(DATA, 'Flags', itU8, wbFlags([
'Playable'
]), cpNormal, True),
wbRArrayS('Extra Parts',
wbFormIDCk(HNAM, 'Part', [HDPT])
)
]);
wbRecord(ASPC, 'Acoustic Space', [
wbEDIDReq,
wbOBNDReq,
wbFormIDCk(SNAM, 'Dawn / Default Loop', [NULL, SOUN], False, cpNormal, True),
wbFormIDCk(SNAM, 'Afternoon', [NULL, SOUN], False, cpNormal, True),
wbFormIDCk(SNAM, 'Dusk', [NULL, SOUN], False, cpNormal, True),
wbFormIDCk(SNAM, 'Night', [NULL, SOUN], False, cpNormal, True),
wbFormIDCk(SNAM, 'Walla', [NULL, SOUN], False, cpNormal, True),
wbInteger(WNAM, 'Walla Trigger Count', itU32, nil, cpNormal, True),
wbFormIDCk(RDAT, 'Use Sound from Region (Interiors Only)', [REGN]),
wbInteger(ANAM, 'Environment Type', itU32, wbEnum([
'None',
'Default',
'Generic',
'Padded Cell',
'Room',
'Bathroom',
'Livingroom',
'Stone Room',
'Auditorium',
'Concerthall',
'Cave',
'Arena',
'Hangar',
'Carpeted Hallway',
'Hallway',
'Stone Corridor',
'Alley',
'Forest',
'City',
'Mountains',
'Quarry',
'Plain',
'Parkinglot',
'Sewerpipe',
'Underwater',
'Small Room',
'Medium Room',
'Large Room',
'Medium Hall',
'Large Hall',
'Plate'
]), cpNormal, True),
wbInteger(INAM, 'Is Interior', itU32, wbEnum(['No', 'Yes']), cpNormal, True)
]);
wbRecord(TACT, 'Talking Activator', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODLReq,
wbSCRI,
wbDEST,
wbFormIDCk(SNAM, 'Looping Sound', [SOUN]),
wbFormIDCk(VNAM, 'Voice Type', [VTYP]),
wbFormIDCk(INAM, 'Radio Template', [SOUN])
]);
wbRecord(SCPT, 'Script', [
wbEDIDReq,
wbSCHRReq,
wbByteArray(SCDA, 'Compiled Script'),
wbStringScript(SCTX, 'Script Source', 0, cpNormal{, True}),
wbRArrayS('Local Variables', wbRStructSK([0], 'Local Variable', [
wbSLSD,
wbString(SCVR, 'Name', 0, cpCritical, True)
], [])),
wbSCROs
]);
wbRecord(TERM, 'Terminal', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbSCRI,
wbDEST,
wbDESCReq,
wbFormIDCk(SNAM, 'Sound - Looping', [SOUN]),
wbFormIDCk(PNAM, 'Password Note', [NOTE]),
wbStruct(DNAM, '', [
wbInteger('Base Hacking Difficulty', itU8, wbEnum([
'Very Easy',
'Easy',
'Average',
'Hard',
'Very Hard',
'Requires Key'
])),
wbInteger('Flags', itU8, wbFlags([
'Leveled',
'Unlocked',
'Alternate Colors',
'Hide Welcome Text when displaying Image'
])),
wbInteger('ServerType', itU8, wbEnum([
'-Server 1-',
'-Server 2-',
'-Server 3-',
'-Server 4-',
'-Server 5-',
'-Server 6-',
'-Server 7-',
'-Server 8-',
'-Server 9-',
'-Server 10-'
])),
wbByteArray('Unused', 1)
], cpNormal, True),
wbRArray('Menu Items',
wbRStruct('Menu Item', [
wbString(ITXT, 'Item Text'),
wbString(RNAM, 'Result Text', 0, cpNormal, True),
wbInteger(ANAM, 'Flags', itU8, wbFlags([
'Add Note',
'Force Redraw'
]), cpNormal, True),
wbFormIDCk(INAM, 'Display Note', [NOTE]),
wbFormIDCk(TNAM, 'Sub Menu', [TERM]),
wbEmbeddedScriptReq,
wbCTDAs
], [])
)
]);
wbRecord(SCOL, 'Static Collection', [
wbEDIDReq,
wbOBNDReq,
wbMODLReq,
wbRStructsSK('Parts', 'Part', [0], [
wbFormIDCk(ONAM, 'Static', [STAT]),
wbArrayS(DATA, 'Placements', wbStruct('Placement', [
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation', [
wbFloat('X', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Y', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Z', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize)
]),
wbFloat('Scale')
]), 0, cpNormal, True)
], [], cpNormal, True)
]);
wbRecord(MSTT, 'Moveable Static', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODLReq,
wbDEST,
wbByteArray(DATA, 'Unknown', 1, cpNormal, True),
wbFormIDCk(SNAM, 'Sound', [SOUN])
]);
wbRecord(PWAT, 'Placeable Water', [
wbEDIDReq,
wbOBNDReq,
wbMODLReq,
wbStruct(DNAM, '', [
wbInteger('Flags', itU32, wbFlags([
{0x00000001}'Reflects',
{0x00000002}'Reflects - Actors',
{0x00000004}'Reflects - Land',
{0x00000008}'Reflects - LOD Land',
{0x00000010}'Reflects - LOD Buildings',
{0x00000020}'Reflects - Trees',
{0x00000040}'Reflects - Sky',
{0x00000080}'Reflects - Dynamic Objects',
{0x00000100}'Reflects - Dead Bodies',
{0x00000200}'Refracts',
{0x00000400}'Refracts - Actors',
{0x00000800}'Refracts - Land',
{0x00001000}'',
{0x00002000}'',
{0x00004000}'',
{0x00008000}'',
{0x00010000}'Refracts - Dynamic Objects',
{0x00020000}'Refracts - Dead Bodies',
{0x00040000}'Silhouette Reflections',
{0x00080000}'',
{0x00100000}'',
{0x00200000}'',
{0x00400000}'',
{0x00800000}'',
{0x01000000}'',
{0x02000000}'',
{0x03000000}'',
{0x08000000}'',
{0x10000000}'Depth',
{0x20000000}'Object Texture Coordinates',
{0x40000000}'',
{0x80000000}'No Underwater Fog'
])),
wbFormIDCk('Water', [WATR])
], cpNormal, True)
]);
wbRecord(IDLM, 'Idle Marker', [
wbEDIDReq,
wbOBNDReq,
wbInteger(IDLF, 'Flags', itU8, wbFlags([
'Run in Sequence',
'',
'Do Once'
]), cpNormal, True),
wbStruct(IDLC, '', [
wbInteger('Animation Count', itU8),
wbByteArray('Unused', 3)
], cpNormal, True, nil, 1),
wbFloat(IDLT, 'Idle Timer Setting', cpNormal, True),
wbArray(IDLA, 'Animations', wbFormIDCk('Animation', [IDLE, NULL]), 0, nil, wbIDLAsAfterSet, cpNormal, True) // NULL looks valid if IDLS\Animation Count is 0
], False, nil, cpNormal, False, nil, wbAnimationsAfterSet);
wbRecord(NOTE, 'Note', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbYNAM,
wbZNAM,
wbInteger(DATA, 'Type', itU8, wbEnum([
'Sound',
'Text',
'Image',
'Voice'
]), cpNormal, True),
wbRArrayS('Quests',
wbFormIDCkNoReach(ONAM, 'Quest', [QUST])
),
wbString(XNAM, 'Texture'),
wbUnion(TNAM, 'Text / Topic', wbNOTETNAMDecide, [
wbString('Text'),
wbFormIDCk('Topic', [DIAL])
]),
wbUnion(SNAM, 'Sound / NPC', wbNOTESNAMDecide, [
wbFormIDCk('Sound', [SOUN]),
wbFormIDCk('Actor', [NPC_, CREA])
])
]);
end;
procedure DefineFNVe;
begin
wbRecord(PROJ, 'Projectile', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODLReq,
wbDEST,
wbStruct(DATA, 'Data', [
{00} wbInteger('Flags', itU16, wbFlags([
'Hitscan',
'Explosion',
'Alt. Trigger',
'Muzzle Flash',
'',
'Can Be Disabled',
'Can Be Picked Up',
'Supersonic',
'Pins Limbs',
'Pass Through Small Transparent',
'Detonates',
'Rotation'
])),
{02} wbInteger('Type', itU16, wbEnum([
{00} '',
{01} 'Missile',
{02} 'Lobber',
{03} '',
{04} 'Beam',
{05} '',
{06} '',
{07} '',
{08} 'Flame',
{09} '',
{10} '',
{11} '',
{12} '',
{13} '',
{14} '',
{15} '',
{16} 'Continuous Beam'
])),
{04} wbFloat('Gravity'),
{08} wbFloat('Speed'),
{12} wbFloat('Range'),
{16} wbFormIDCk('Light', [LIGH, NULL]),
{20} wbFormIDCk('Muzzle Flash - Light', [LIGH, NULL]),
{24} wbFloat('Tracer Chance'),
{28} wbFloat('Explosion - Alt. Trigger - Proximity'),
{32} wbFloat('Explosion - Alt. Trigger - Timer'),
{36} wbFormIDCk('Explosion', [EXPL, NULL]),
{40} wbFormIDCk('Sound', [SOUN, NULL]),
{44} wbFloat('Muzzle Flash - Duration'),
{48} wbFloat('Fade Duration'),
{52} wbFloat('Impact Force'),
{56} wbFormIDCk('Sound - Countdown', [SOUN, NULL]),
{60} wbFormIDCk('Sound - Disable', [SOUN, NULL]),
{64} wbFormIDCk('Default Weapon Source', [WEAP, NULL]),
{68} wbStruct('Rotation', [
{68} wbFloat('X'),
{72} wbFloat('Y'),
{76} wbFloat('Z')
]),
{80} wbFloat('Bouncy Mult')
], cpNormal, True),
wbRStructSK([0], 'Muzzle Flash Model', [
wbString(NAM1, 'Model Filename'),
wbByteArray(NAM2, 'Texture Files Hashes', 0, cpIgnore)
], [], cpNormal, True),
wbInteger(VNAM, 'Sound Level', itU32, wbSoundLevelEnum, cpNormal, True)
]);
wbRecord(NAVI, 'Navigation Mesh Info Map', [
wbEDID,
wbInteger(NVER, 'Version', itU32),
wbRArray('Navigation Map Infos',
wbStruct(NVMI, 'Navigation Map Info', [
wbByteArray('Unknown', 4),
wbFormIDCk('Navigation Mesh', [NAVM]),
wbFormIDCk('Location', [CELL, WRLD]),
wbStruct('Grid', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
]),
wbUnknown
{ wbUnion('Data', wbNAVINVMIDecider, [
wbStruct('Data', [
wbUnknown
]),
wbStruct('Data', [
wbArray('Unknown', wbFloat('Unknown'), 3),
wbByteArray('Unknown', 4)
]),
wbStruct('Data', [
wbArray('Unknown', wbArray('Unknown', wbFloat('Unknown'), 3), 3),
wbInteger('Count 1', itU16),
wbInteger('Count 2', itU16),
wbArray('Unknown', wbArray('Unknown', wbFloat('Unknown'), 3), [], wbNAVINAVMGetCount1),
wbUnknown
]),
wbStruct('Data', [
wbUnknown
])
])}
])
),
wbRArray('Unknown',
wbStruct(NVCI, 'Unknown', [
wbFormIDCk('Unknown', [NAVM]),
wbArray('Unknown', wbFormIDCk('Unknown', [NAVM]), -1),
wbArray('Unknown', wbFormIDCk('Unknown', [NAVM]), -1),
wbArray('Doors', wbFormIDCk('Door', [REFR]), -1)
])
)
]);
if wbSimpleRecords then begin
wbRecord(NAVM, 'Navigation Mesh', [
wbEDID,
wbInteger(NVER, 'Version', itU32),
wbStruct(DATA, '', [
wbFormIDCk('Cell', [CELL]),
wbInteger('Vertex Count', itU32),
wbInteger('Triangle Count', itU32),
wbInteger('External Connections Count', itU32),
wbInteger('NVCA Count', itU32),
wbInteger('Doors Count', itU32)
]),
wbByteArray(NVVX, 'Vertices'),
wbByteArray(NVTR, 'Triangles'),
wbByteArray(NVCA, 'Unknown'),
wbArray(NVDP, 'Doors', wbStruct('Door', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Triangle', itU16),
wbByteArray('Unused', 2)
])),
wbByteArray(NVGD, 'Unknown'),
wbArray(NVEX, 'External Connections', wbStruct('Connection', [
wbByteArray('Unknown', 4),
wbFormIDCk('Navigation Mesh', [NAVM], False, cpNormal),
wbInteger('Triangle', itU16, nil, cpNormal)
]))
], False, wbNAVMAddInfo);
end else begin
wbRecord(NAVM, 'Navigation Mesh', [
wbEDID,
wbInteger(NVER, 'Version', itU32),
wbStruct(DATA, '', [
wbFormIDCk('Cell', [CELL]),
wbInteger('Vertex Count', itU32),
wbInteger('Triangle Count', itU32),
wbInteger('External Connections Count', itU32),
wbInteger('NVCA Count', itU32),
wbInteger('Doors Count', itU32) // as of version = 5 (earliest NavMesh version I saw (Fallout3 1.7) is already 11)
]),
wbArray(NVVX, 'Vertices', wbStruct('Vertex', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
])),
wbArray(NVTR, 'Triangles', wbStruct('Triangle', [
wbArray('Vertices', wbInteger('Vertex', itS16), 3),
wbArray('Edges', wbInteger('Triangle', itS16, wbNVTREdgeToStr, wbNVTREdgeToInt), [
'0 <-> 1',
'1 <-> 2',
'2 <-> 0'
]),
wbInteger('Flags', itU32, wbFlags([
'Triangle #0 Is External',
'Triangle #1 Is External',
'Triangle #2 Is External',
'Unknown 4',
'Unknown 5',
'Unknown 6',
'Preferred pathing',
'Unknown 8',
'Unknown 9',
'Water',
'Contains door',
'Unknown 12',
'Unknown 13', // Cleared on LoadForm
'Unknown 14', // Cleared on LoadForm
'Unknown 15', // Cleared on LoadForm
'Unknown 16',
'Unknown 17',
'Unknown 18',
'Unknown 19',
'Unknown 20',
'Unknown 21',
'Unknown 22',
'Unknown 23',
'Unknown 24',
'Unknown 25',
'Unknown 26',
'Unknown 27',
'Unknown 28',
'Unknown 29',
'Unknown 30',
'Unknown 31',
'Unknown 32'
]))
])),
wbArray(NVCA, 'Unknown', wbInteger('Triangle', itS16)), // Assumed triangle as the value fits the triangle id's
wbArray(NVDP, 'Doors', wbStruct('Door', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Triangle', itU16),
wbByteArray('Unused', 2)
])),
wbStruct(NVGD, 'NavMesh Grid', [
wbInteger('NavMeshGrid Divisor', itU32),
wbFloat('Max X Distance'), // Floats named after TES5 definition
wbFloat('Max Y Distance'),
wbFloat('Min X'),
wbFloat('Min Y'),
wbFloat('Min Z'),
wbFloat('Max X'),
wbFloat('Max Y'),
wbFloat('Max Z'),
wbArray('Cells', wbArray('Cell', wbInteger('Triangle', itS16), -2)) // Divisor is row count , assumed triangle as the values fit the triangle id's
]),
wbArray(NVEX, 'External Connections', wbStruct('Connection', [
wbByteArray('Unknown', 4), // absent in ver<9, not endian swap in ver>=9, so char or byte array
wbFormIDCk('Navigation Mesh', [NAVM, NULL], False, cpNormal), // NULL values are ignored silently.
wbInteger('Triangle', itU16, nil, cpNormal)
])) // Different if ver<5: Length = $2E/$30 and contains other data between NavMesh and Triangle
], False, wbNAVMAddInfo);
end;
wbRecord(PGRE, 'Placed Grenade', [
wbEDID,
wbFormIDCk(NAME, 'Base', [PROJ], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbXRGD,
wbXRGB,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], []),
{--- Ownership ---}
wbRStruct('Ownership', [
wbXOWN,
wbInteger(XRNK, 'Faction rank', itS32)
], [XCMT, XCMO]),
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbFloat(XHLP, 'Health'),
{--- Reflected By / Refracted By ---}
wbRArrayS('Reflected/Refracted By',
wbStructSK(XPWR, [0], 'Water', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Type', itU32, wbFlags([
'Reflection',
'Refraction'
]))
])
),
{--- Decals ---}
wbRArrayS('Linked Decals',
wbStructSK(XDCR, [0], 'Decal', [
wbFormIDCk('Reference', [REFR]),
wbUnknown
])
),
{--- Linked Ref ---}
wbFormIDCk(XLKR, 'Linked Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbStruct(XCLP, 'Linked Reference Color', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbFloat('Delay')
])
)
], []),
wbString(XATO, 'Activation Prompt'),
{--- Enable Parent ---}
wbXESP,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Flags ---}
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot
], True, wbPlacedAddInfo);
wbRecord(PMIS, 'Placed Missile', [
wbEDID,
wbFormIDCk(NAME, 'Base', [PROJ], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbXRGD,
wbXRGB,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], []),
{--- Ownership ---}
wbRStruct('Ownership', [
wbXOWN,
wbInteger(XRNK, 'Faction rank', itS32)
], [XCMT, XCMO]),
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbFloat(XHLP, 'Health'),
{--- Reflected By / Refracted By ---}
wbRArrayS('Reflected/Refracted By',
wbStructSK(XPWR, [0], 'Water', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Type', itU32, wbFlags([
'Reflection',
'Refraction'
]))
])
),
{--- Decals ---}
wbRArrayS('Linked Decals',
wbStructSK(XDCR, [0], 'Decal', [
wbFormIDCk('Reference', [REFR]),
wbUnknown
])
),
{--- Linked Ref ---}
wbFormIDCk(XLKR, 'Linked Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbStruct(XCLP, 'Linked Reference Color', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbFloat('Delay')
])
)
], []),
wbString(XATO, 'Activation Prompt'),
{--- Enable Parent ---}
wbXESP,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Flags ---}
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot
], True, wbPlacedAddInfo);
wbRecord(PBEA, 'Placed Beam', [
wbEDID,
wbFormIDCk(NAME, 'Base', [PROJ], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbXRGD,
wbXRGB,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], []),
{--- Ownership ---}
wbRStruct('Ownership', [
wbXOWN,
wbInteger(XRNK, 'Faction rank', itS32)
], [XCMT, XCMO]),
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbFloat(XHLP, 'Health'),
{--- Reflected By / Refracted By ---}
wbRArrayS('Reflected/Refracted By',
wbStructSK(XPWR, [0], 'Water', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Type', itU32, wbFlags([
'Reflection',
'Refraction'
]))
])
),
{--- Decals ---}
wbRArrayS('Linked Decals',
wbStructSK(XDCR, [0], 'Decal', [
wbFormIDCk('Reference', [REFR]),
wbUnknown
])
),
{--- Linked Ref ---}
wbFormIDCk(XLKR, 'Linked Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbStruct(XCLP, 'Linked Reference Color', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbFloat('Delay')
])
)
], []),
wbString(XATO, 'Activation Prompt'),
{--- Enable Parent ---}
wbXESP,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Flags ---}
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot
], True, wbPlacedAddInfo);
wbRecord(EXPL, 'Explosion', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbEITM,
wbFormIDCk(MNAM, 'Image Space Modifier', [IMAD]),
wbStruct(DATA, 'Data', [
{00} wbFloat('Force'),
{04} wbFloat('Damage'),
{08} wbFloat('Radius'),
{12} wbFormIDCk('Light', [LIGH, NULL]),
{16} wbFormIDCk('Sound 1', [SOUN, NULL]),
{20} wbInteger('Flags', itU32, wbFlags([
{0x00000001}'Unknown 1',
{0x00000002}'Always Uses World Orientation',
{0x00000004}'Knock Down - Always',
{0x00000008}'Knock Down - By Formula',
{0x00000010}'Ignore LOS Check',
{0x00000020}'Push Explosion Source Ref Only',
{0x00000040}'Ignore Image Space Swap'
])),
{24} wbFloat('IS Radius'),
{28} wbFormIDCk('Impact DataSet', [IPDS, NULL]),
{32} wbFormIDCk('Sound 2', [SOUN, NULL]),
wbStruct('Radiation', [
{36} wbFloat('Level'),
{40} wbFloat('Dissipation Time'),
{44} wbFloat('Radius')
]),
{48} wbInteger('Sound Level', itU32, wbSoundLevelEnum, cpNormal, True)
], cpNormal, True),
wbFormIDCk(INAM, 'Placed Impact Object', [TREE, SOUN, ACTI, DOOR, STAT, FURN,
CONT, ARMO, AMMO, LVLN, LVLC, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS,
ASPC, IDLM, ARMA, MSTT, NOTE, PWAT, SCOL, TACT, TERM, TXST, CHIP, CMNY,
CCRD, IMOD])
]);
wbRecord(DEBR, 'Debris', [
wbEDIDReq,
wbRStructs('Models', 'Model', [
wbStruct(DATA, 'Data', [
wbInteger('Percentage', itU8),
wbString('Model Filename'),
wbInteger('Flags', itU8, wbFlags([
'Has Collission Data'
]))
], cpNormal, True),
wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore)
], [], cpNormal, True)
]);
wbRecord(IMGS, 'Image Space', [
wbEDIDReq,
wbStruct(DNAM, '', [
wbStruct('HDR', [
{00} wbFloat('Eye Adapt Speed'),
{04} wbFloat('Blur Radius'),
{08} wbFloat('Blur Passes'),
{12} wbFloat('Emissive Mult'),
{16} wbFloat('Target LUM'),
{20} wbFloat('Upper LUM Clamp'),
{24} wbFloat('Bright Scale'),
{28} wbFloat('Bright Clamp'),
{32} wbFloat('LUM Ramp No Tex'),
{36} wbFloat('LUM Ramp Min'),
{40} wbFloat('LUM Ramp Max'),
{44} wbFloat('Sunlight Dimmer'),
{48} wbFloat('Grass Dimmer'),
{52} wbFloat('Tree Dimmer'),
{56} wbUnion('Skin Dimmer', wbIMGSSkinDimmerDecider, [
wbFloat('Skin Dimmer'),
wbEmpty('Skin Dimmer', cpIgnore)
])
], cpNormal, False, nil, 14),
wbStruct('Bloom', [
{60} wbFloat('Blur Radius'),
{64} wbFloat('Alpha Mult Interior'),
{68} wbFloat('Alpha Mult Exterior')
]),
wbStruct('Get Hit', [
{72} wbFloat('Blur Radius'),
{76} wbFloat('Blur Damping Constant'),
{80} wbFloat('Damping Constant')
]),
wbStruct('Night Eye', [
wbStruct('Tint Color', [
{84} wbFloat('Red', cpNormal, False, 255, 0),
{88} wbFloat('Green', cpNormal, False, 255, 0),
{92} wbFloat('Blue', cpNormal, False, 255, 0)
]),
{96} wbFloat('Brightness')
]),
wbStruct('Cinematic', [
{100} wbFloat('Saturation'),
wbStruct('Contrast', [
{104} wbFloat('Avg Lum Value'),
{108} wbFloat('Value')
]),
{112} wbFloat('Cinematic - Brightness - Value'),
wbStruct('Tint', [
wbStruct('Color', [
{116} wbFloat('Red', cpNormal, False, 255, 0),
{120} wbFloat('Green', cpNormal, False, 255, 0),
{124} wbFloat('Blue', cpNormal, False, 255, 0)
]),
{128} wbFloat('Value')
])
]),
wbByteArray('Unused', 4),
wbByteArray('Unused', 4),
wbByteArray('Unused', 4),
wbByteArray('Unused', 4),
wbInteger('Flags', itU8, wbFlags([
'Saturation',
'Contrast',
'Tint',
'Brightness'
], True)),
wbByteArray('Unused', 3)
], cpNormal, True, nil, 5)
]);
wbTimeInterpolator := wbStruct('Data', [
wbFloat('Time'),
wbFloat('Value')
]);
wbColorInterpolator := wbStruct('Data', [
wbFloat('Time'),
wbFloat('Red', cpNormal, False, 255, 0),
wbFloat('Green', cpNormal, False, 255, 0),
wbFloat('Blue', cpNormal, False, 255, 0),
wbFloat('Alpha', cpNormal, False, 255, 0)
]);
wbRecord(IMAD, 'Image Space Adapter', [
wbEDID,
wbStruct(DNAM, 'Data Count', [
wbInteger('Flags', itU32, wbFlags(['Animatable'])),
wbFloat('Duration'),
wbStruct('HDR', [
wbInteger('Eye Adapt Speed Mult', itU32),
wbInteger('Eye Adapt Speed Add', itU32),
wbInteger('Bloom Blur Radius Mult', itU32),
wbInteger('Bloom Blur Radius Add', itU32),
wbInteger('Bloom Threshold Mult', itU32),
wbInteger('Bloom Threshold Add', itU32),
wbInteger('Bloom Scale Mult', itU32),
wbInteger('Bloom Scale Add', itU32),
wbInteger('Target Lum Min Mult', itU32),
wbInteger('Target Lum Min Add', itU32),
wbInteger('Target Lum Max Mult', itU32),
wbInteger('Target Lum Max Add', itU32),
wbInteger('Sunlight Scale Mult', itU32),
wbInteger('Sunlight Scale Add', itU32),
wbInteger('Sky Scale Mult', itU32),
wbInteger('Sky Scale Add', itU32)
]),
wbInteger('Unknown08 Mult', itU32),
wbInteger('Unknown48 Add', itU32),
wbInteger('Unknown09 Mult', itU32),
wbInteger('Unknown49 Add', itU32),
wbInteger('Unknown0A Mult', itU32),
wbInteger('Unknown4A Add', itU32),
wbInteger('Unknown0B Mult', itU32),
wbInteger('Unknown4B Add', itU32),
wbInteger('Unknown0C Mult', itU32),
wbInteger('Unknown4C Add', itU32),
wbInteger('Unknown0D Mult', itU32),
wbInteger('Unknown4D Add', itU32),
wbInteger('Unknown0E Mult', itU32),
wbInteger('Unknown4E Add', itU32),
wbInteger('Unknown0F Mult', itU32),
wbInteger('Unknown4F Add', itU32),
wbInteger('Unknown10 Mult', itU32),
wbInteger('Unknown50 Add', itU32),
wbStruct('Cinematic', [
wbInteger('Saturation Mult', itU32),
wbInteger('Saturation Add', itU32),
wbInteger('Brightness Mult', itU32),
wbInteger('Brightness Add', itU32),
wbInteger('Contrast Mult', itU32),
wbInteger('Contrast Add', itU32)
]),
wbInteger('Unknown14 Mult', itU32),
wbInteger('Unknown54 Add', itU32),
wbInteger('Tint Color', itU32),
wbInteger('Blur Radius', itU32),
wbInteger('Double Vision Strength', itU32),
wbInteger('Radial Blur Strength', itU32),
wbInteger('Radial Blur Ramp Up', itU32),
wbInteger('Radial Blur Start', itU32),
wbInteger('Radial Blur Flags', itU32, wbFlags(['Use Target'])),
wbFloat('Radial Blur Center X'),
wbFloat('Radial Blur Center Y'),
wbInteger('DoF Strength', itU32),
wbInteger('DoF Distance', itU32),
wbInteger('DoF Range', itU32),
wbInteger('DoF Flags', itU32, wbFlags(['Use Target'])),
wbInteger('Radial Blur Ramp Down', itU32),
wbInteger('Radial Blur Down Start', itU32),
wbInteger('Fade Color', itU32),
wbInteger('Motion Blur Strength', itU32)
], cpNormal, True, nil, 26),
wbArray(BNAM, 'Blur Radius', wbTimeInterpolator),
wbArray(VNAM, 'Double Vision Strength', wbTimeInterpolator),
wbArray(TNAM, 'Tint Color', wbColorInterpolator),
wbArray(NAM3, 'Fade Color', wbColorInterpolator),
wbArray(RNAM, 'Radial Blur Strength', wbTimeInterpolator),
wbArray(SNAM, 'Radial Blur Ramp Up', wbTimeInterpolator),
wbArray(UNAM, 'Radial Blur Start', wbTimeInterpolator),
wbArray(NAM1, 'Radial Blur Ramp Down', wbTimeInterpolator),
wbArray(NAM2, 'Radial Blur Down Start', wbTimeInterpolator),
wbArray(WNAM, 'DoF Strength', wbTimeInterpolator),
wbArray(XNAM, 'DoF Distance', wbTimeInterpolator),
wbArray(YNAM, 'DoF Range', wbTimeInterpolator),
wbArray(NAM4, 'Motion Blur Strength', wbTimeInterpolator),
wbRStruct('HDR', [
wbArray(_00_IAD, 'Eye Adapt Speed Mult', wbTimeInterpolator),
wbArray(_40_IAD, 'Eye Adapt Speed Add', wbTimeInterpolator),
wbArray(_01_IAD, 'Bloom Blur Radius Mult', wbTimeInterpolator),
wbArray(_41_IAD, 'Bloom Blur Radius Add', wbTimeInterpolator),
wbArray(_02_IAD, 'Bloom Threshold Mult', wbTimeInterpolator),
wbArray(_42_IAD, 'Bloom Threshold Add', wbTimeInterpolator),
wbArray(_03_IAD, 'Bloom Scale Mult', wbTimeInterpolator),
wbArray(_43_IAD, 'Bloom Scale Add', wbTimeInterpolator),
wbArray(_04_IAD, 'Target Lum Min Mult', wbTimeInterpolator),
wbArray(_44_IAD, 'Target Lum Min Add', wbTimeInterpolator),
wbArray(_05_IAD, 'Target Lum Max Mult', wbTimeInterpolator),
wbArray(_45_IAD, 'Target Lum Max Add', wbTimeInterpolator),
wbArray(_06_IAD, 'Sunlight Scale Mult', wbTimeInterpolator),
wbArray(_46_IAD, 'Sunlight Scale Add', wbTimeInterpolator),
wbArray(_07_IAD, 'Sky Scale Mult', wbTimeInterpolator),
wbArray(_47_IAD, 'Sky Scale Add', wbTimeInterpolator)
], []),
wbUnknown(_08_IAD),
wbUnknown(_48_IAD),
wbUnknown(_09_IAD),
wbUnknown(_49_IAD),
wbUnknown(_0A_IAD),
wbUnknown(_4A_IAD),
wbUnknown(_0B_IAD),
wbUnknown(_4B_IAD),
wbUnknown(_0C_IAD),
wbUnknown(_4C_IAD),
wbUnknown(_0D_IAD),
wbUnknown(_4D_IAD),
wbUnknown(_0E_IAD),
wbUnknown(_4E_IAD),
wbUnknown(_0F_IAD),
wbUnknown(_4F_IAD),
wbUnknown(_10_IAD),
wbUnknown(_50_IAD),
wbRStruct('Cinematic', [
wbArray(_11_IAD, 'Saturation Mult', wbTimeInterpolator),
wbArray(_51_IAD, 'Saturation Add', wbTimeInterpolator),
wbArray(_12_IAD, 'Brightness Mult', wbTimeInterpolator),
wbArray(_52_IAD, 'Brightness Add', wbTimeInterpolator),
wbArray(_13_IAD, 'Contrast Mult', wbTimeInterpolator),
wbArray(_53_IAD, 'Contrast Add', wbTimeInterpolator)
], []),
wbUnknown(_14_IAD),
wbUnknown(_54_IAD),
wbFormIDCk(RDSD, 'Sound - Intro', [SOUN]),
wbFormIDCk(RDSI, 'Sound - Outro', [SOUN])
]);
wbRecord(FLST, 'FormID List', [
wbString(EDID, 'Editor ID', 0, cpBenign, True, nil, wbFLSTEDIDAfterSet),
wbRArrayS('FormIDs', wbFormID(LNAM, 'FormID'), cpNormal, False, nil, nil, nil, wbFLSTLNAMIsSorted)
]);
wbRecord(PERK, 'Perk', [
wbEDIDReq,
wbFULL,
wbDESCReq,
wbICON,
wbCTDAs,
wbStruct(DATA, 'Data', [
wbInteger('Trait', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Min Level', itU8),
wbInteger('Ranks', itU8),
wbInteger('Playable', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Hidden', itU8, wbEnum(['No', 'Yes']))
], cpNormal, True, nil, 4),
wbRStructsSK('Effects', 'Effect', [0, 1], [
wbStructSK(PRKE, [1, 2, 0], 'Header', [
wbInteger('Type', itU8, wbEnum([
'Quest + Stage',
'Ability',
'Entry Point'
]), cpNormal, False, nil, wbPERKPRKETypeAfterSet),
wbInteger('Rank', itU8),
wbInteger('Priority', itU8)
]),
wbUnion(DATA, 'Effect Data', wbPerkDATADecider, [
wbStructSK([0, 1], 'Quest + Stage', [
wbFormIDCk('Quest', [QUST]),
wbInteger('Quest Stage', itU8, wbPerkDATAQuestStageToStr, wbCTDAParam2QuestStageToInt),
wbByteArray('Unused', 3)
]),
wbFormIDCk('Ability', [SPEL]),
wbStructSK([0, 1], 'Entry Point', [
wbInteger('Entry Point', itU8, wbEnum([
{00} 'Calculate Weapon Damage',
{01} 'Calculate My Critical Hit Chance',
{02} 'Calculate My Critical Hit Damage',
{03} 'Calculate Weapon Attack AP Cost',
{04} 'Calculate Mine Explode Chance',
{05} 'Adjust Range Penalty',
{06} 'Adjust Limb Damage',
{07} 'Calculate Weapon Range',
{08} 'Calculate To Hit Chance',
{09} 'Adjust Experience Points',
{10} 'Adjust Gained Skill Points',
{11} 'Adjust Book Skill Points',
{12} 'Modify Recovered Health',
{13} 'Calculate Inventory AP Cost',
{14} 'Get Disposition',
{15} 'Get Should Attack',
{16} 'Get Should Assist',
{17} 'Calculate Buy Price',
{18} 'Get Bad Karma',
{19} 'Get Good Karma',
{20} 'Ignore Locked Terminal',
{21} 'Add Leveled List On Death',
{22} 'Get Max Carry Weight',
{23} 'Modify Addiction Chance',
{24} 'Modify Addiction Duration',
{25} 'Modify Positive Chem Duration',
{26} 'Adjust Drinking Radiation',
{27} 'Activate',
{28} 'Mysterious Stranger',
{29} 'Has Paralyzing Palm',
{30} 'Hacking Science Bonus',
{31} 'Ignore Running During Detection',
{32} 'Ignore Broken Lock',
{33} 'Has Concentrated Fire',
{34} 'Calculate Gun Spread',
{35} 'Player Kill AP Reward',
{36} 'Modify Enemy Critical Hit Chance',
{37} 'Reload Speed',
{38} 'Equip Speed',
{39} 'Action Point Regen',
{40} 'Action Point Cost',
{41} 'Miss Fortune',
{42} 'Modify Run Speed',
{43} 'Modify Attack Speed',
{44} 'Modify Radiation Consumed',
{45} 'Has Pip Hacker',
{46} 'Has Meltdown',
{47} 'See Enemy Health',
{48} 'Has Jury Rigging',
{49} 'Modify Threat Range',
{50} 'Modify Thread',
{51} 'Has Fast Travel Always',
{52} 'Knockdown Chance',
{53} 'Modify Weapon Strength Req',
{54} 'Modify Aiming Move Speed',
{55} 'Modify Light Items',
{56} 'Modify Damage Threshold (defender)',
{57} 'Modify Chance for Ammo Item',
{58} 'Modify Damage Threshold (attacker)',
{59} 'Modify Throwing Velocity',
{60} 'Chance for Item on Fire',
{61} 'Has Unarmed Forward Power Attack',
{62} 'Has Unarmed Back Power Attack',
{63} 'Has Unarmed Crouched Power Attack',
{64} 'Has Unarmed Counter Attack',
{65} 'Has Unarmed Left Power Attack',
{66} 'Has Unarmed Right Power Attack',
{67} 'VATS HelperChance',
{68} 'Modify Item Damage',
{69} 'Has Improved Detection',
{70} 'Has Improved Spotting',
{71} 'Has Improved Item Detection',
{72} 'Adjust Explosion Radius',
{73} 'Reserved'
]), cpNormal, True, nil, wbPERKEntryPointAfterSet),
wbInteger('Function', itU8, wbPerkDATAFunctionToStr, wbPerkDATAFunctionToInt, cpNormal, False, nil, wbPerkDATAFunctionAfterSet),
wbInteger('Perk Condition Tab Count', itU8, nil, cpIgnore)
])
], cpNormal, True),
wbRStructsSK('Perk Conditions', 'Perk Condition', [0], [
wbInteger(PRKC, 'Run On', itS8, wbPRKCToStr, wbPRKCToInt),
wbCTDAsReq
], [], cpNormal, False, nil, nil, wbPERKPRKCDontShow),
wbRStruct('Entry Point Function Parameters', [
wbInteger(EPFT, 'Type', itU8, wbPerkEPFTToStr, wbPerkEPFTToInt, cpIgnore, False, nil, wbPerkEPFTAfterSet),
wbUnion(EPFD, 'Data', wbEPFDDecider, [
wbByteArray('Unknown'),
wbFloat('Float'),
wbStruct('Float, Float', [
wbFloat('Float 1'),
wbFloat('Float 2')
]),
wbFormIDCk('Leveled Item', [LVLI]),
wbEmpty('None (Script)'),
wbStruct('Actor Value, Float', [
wbInteger('Actor Value', itU32, wbEPFDActorValueToStr, wbEPFDActorValueToInt),
wbFloat('Float')
])
], cpNormal, False, wbEPFDDontShow),
wbString(EPF2, 'Button Label', 0, cpNormal, False, wbEPF2DontShow),
wbInteger(EPF3, 'Script Flags', itU16, wbFlags([
'Run Immediately'
]), cpNormal, False, False, wbEPF2DontShow),
wbEmbeddedScriptPerk
], [], cpNormal, False, wbPERKPRKCDontShow),
wbEmpty(PRKF, 'End Marker', cpIgnore, True)
], [])
]);
wbBPNDStruct := wbStruct(BPND, '', [
{00} wbFloat('Damage Mult'),
{04} wbInteger('Flags', itU8, wbFlags([
'Severable',
'IK Data',
'IK Data - Biped Data',
'Explodable',
'IK Data - Is Head',
'IK Data - Headtracking',
'To Hit Chance - Absolute'
])),
{05} wbInteger('Part Type', itU8, wbEnum([
'Torso',
'Head 1',
'Head 2',
'Left Arm 1',
'Left Arm 2',
'Right Arm 1',
'Right Arm 2',
'Left Leg 1',
'Left Leg 2',
'Left Leg 3',
'Right Leg 1',
'Right Leg 2',
'Right Leg 3',
'Brain',
'Weapon'
])),
{06} wbInteger('Health Percent', itU8),
{07} wbInteger('Actor Value', itS8, wbActorValueEnum),
{08} wbInteger('To Hit Chance', itU8),
{09} wbInteger('Explodable - Explosion Chance %', itU8),
{10} wbInteger('Explodable - Debris Count', itU16),
{12} wbFormIDCk('Explodable - Debris', [DEBR, NULL]),
{16} wbFormIDCk('Explodable - Explosion', [EXPL, NULL]),
{20} wbFloat('Tracking Max Angle'),
{24} wbFloat('Explodable - Debris Scale'),
{28} wbInteger('Severable - Debris Count', itS32),
{32} wbFormIDCk('Severable - Debris', [DEBR, NULL]),
{36} wbFormIDCk('Severable - Explosion', [EXPL, NULL]),
{40} wbFloat('Severable - Debris Scale'),
wbStruct('Gore Effects Positioning', [
wbStruct('Translate', [
{44} wbFloat('X'),
{48} wbFloat('Y'),
{52} wbFloat('Z')
]),
wbStruct('Rotation', [
{56} wbFloat('X', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
{60} wbFloat('Y', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
{64} wbFloat('Z', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize)
])
]),
{68} wbFormIDCk('Severable - Impact DataSet', [IPDS, NULL]),
{72} wbFormIDCk('Explodable - Impact DataSet', [IPDS, NULL]),
{28} wbInteger('Severable - Decal Count', itU8),
{28} wbInteger('Explodable - Decal Count', itU8),
{76} wbByteArray('Unused', 2),
{80} wbFloat('Limb Replacement Scale')
], cpNormal, True);
wbRecord(BPTD, 'Body Part Data', [
wbEDIDReq,
wbMODLReq,
wbRStructS('Body Parts', 'Body Part', [ // When the Part Name is provided
wbString(BPTN, 'Part Name', 0, cpNormal, True),
wbString(BPNN, 'Part Node', 0, cpNormal, True),
wbString(BPNT, 'VATS Target', 0, cpNormal, True),
wbString(BPNI, 'IK Data - Start Node', 0, cpNormal, True),
wbBPNDStruct,
wbString(NAM1, 'Limb Replacement Model', 0, cpNormal, True),
wbString(NAM4, 'Gore Effects - Target Bone', 0, cpNormal, True),
wbByteArray(NAM5, 'Texture Files Hashes', 0, cpIgnore)
], [], cpNormal, False),
wbRStructS('Unnamed Body Parts', 'Body Part', [ // When the Part Name is not provided
wbString(BPNN, 'Part Node', 0, cpNormal, True),
wbString(BPNT, 'VATS Target', 0, cpNormal, True),
wbString(BPNI, 'IK Data - Start Node', 0, cpNormal, True),
wbBPNDStruct,
wbString(NAM1, 'Limb Replacement Model', 0, cpNormal, True),
wbString(NAM4, 'Gore Effects - Target Bone', 0, cpNormal, True),
wbByteArray(NAM5, 'Texture Files Hashes', 0, cpIgnore)
], [], cpNormal, False),
wbFormIDCk(RAGA, 'Ragdoll', [RGDL])
]);
wbRecord(ADDN, 'Addon Node', [
wbEDIDReq,
wbOBNDReq,
wbMODLReq,
wbInteger(DATA, 'Node Index', itS32, nil, cpNormal, True),
wbFormIDCk(SNAM, 'Sound', [SOUN]),
wbStruct(DNAM, 'Data', [
wbInteger('Master Particle System Cap', itU16),
wbByteArray('Unknown', 2)
], cpNormal, True)
]);
wbRecord(AVIF, 'ActorValue Information', [
wbEDIDReq,
wbFULL,
wbDESCReq,
wbICON,
wbString(ANAM, 'Short Name')
]);
wbRecord(RADS, 'Radiation Stage', [
wbEDIDReq,
wbStruct(DATA, '', [
wbInteger('Trigger Threshold', itU32),
wbFormIDCk('Actor Effect', [SPEL])
], cpNormal, True)
]);
wbRecord(CAMS, 'Camera Shot', [
wbEDIDReq,
wbMODL,
wbStruct(DATA, 'Data', [
{00} wbInteger('Action', itU32, wbEnum([
'Shoot',
'Fly',
'Hit',
'Zoom'
])),
{04} wbInteger('Location', itU32, wbEnum([
'Attacker',
'Projectile',
'Target'
])),
{08} wbInteger('Target', itU32, wbEnum([
'Attacker',
'Projectile',
'Target'
])),
{12} wbInteger('Flags', itU32, wbFlags([
'Position Follows Location',
'Rotation Follows Target',
'Don''t Follow Bone',
'First Person Camera',
'No Tracer',
'Start At Time Zero'
])),
wbStruct('Time Multipliers', [
{16} wbFloat('Player'),
{20} wbFloat('Target'),
{24} wbFloat('Global')
]),
{28} wbFloat('Max Time'),
{32} wbFloat('Min Time'),
{36} wbFloat('Target % Between Actors')
], cpNormal, True, nil, 7),
wbFormIDCk(MNAM, 'Image Space Modifier', [IMAD])
]);
wbRecord(CPTH, 'Camera Path', [
wbEDIDReq,
wbCTDAs,
wbArray(ANAM, 'Related Camera Paths', wbFormIDCk('Related Camera Path', [CPTH, NULL]), ['Parent', 'Previous Sibling'], cpNormal, True),
wbInteger(DATA, 'Camera Zoom', itU8, wbEnum([
'Default',
'Disable',
'Shot List'
]), cpNormal, True),
wbRArray('Camera Shots', wbFormIDCk(SNAM, 'Camera Shot', [CAMS]))
]);
wbRecord(VTYP, 'Voice Type', [
wbEDIDReq,
wbInteger(DNAM, 'Flags', itU8, wbFlags([
'Allow Default Dialog',
'Female'
]), cpNormal, False)
]);
wbRecord(IPCT, 'Impact', [
wbEDIDReq,
wbMODL,
wbStruct(DATA, '', [
wbFloat('Effect - Duration'),
wbInteger('Effect - Orientation', itU32, wbEnum([
'Surface Normal',
'Projectile Vector',
'Projectile Reflection'
])),
wbFloat('Angle Threshold'),
wbFloat('Placement Radius'),
wbInteger('Sound Level', itU32, wbSoundLevelEnum),
wbInteger('Flags', itU32, wbFlags([
'No Decal Data'
]))
], cpNormal, True),
wbDODT,
wbFormIDCk(DNAM, 'Texture Set', [TXST]),
wbFormIDCk(SNAM, 'Sound 1', [SOUN]),
wbFormIDCk(NAM1, 'Sound 2', [SOUN])
]);
wbRecord(IPDS, 'Impact DataSet', [
wbEDIDReq,
wbStruct(DATA, 'Impacts', [
wbFormIDCk('Stone', [IPCT, NULL]),
wbFormIDCk('Dirt', [IPCT, NULL]),
wbFormIDCk('Grass', [IPCT, NULL]),
wbFormIDCk('Glass', [IPCT, NULL]),
wbFormIDCk('Metal', [IPCT, NULL]),
wbFormIDCk('Wood', [IPCT, NULL]),
wbFormIDCk('Organic', [IPCT, NULL]),
wbFormIDCk('Cloth', [IPCT, NULL]),
wbFormIDCk('Water', [IPCT, NULL]),
wbFormIDCk('Hollow Metal', [IPCT, NULL]),
wbFormIDCk('Organic Bug', [IPCT, NULL]),
wbFormIDCk('Organic Glow', [IPCT, NULL])
], cpNormal, True, nil, 9)
]);
wbRecord(ECZN, 'Encounter Zone', [
wbEDIDReq,
wbStruct(DATA, '', [
wbFormIDCkNoReach('Owner', [NPC_, FACT, NULL]),
wbInteger('Rank', itS8),
wbInteger('Minimum Level', itS8),
wbInteger('Flags', itU8, wbFlags([
'Never Resets',
'Match PC Below Minimum Level'
])),
wbByteArray('Unused', 1)
], cpNormal, True)
]);
wbRecord(MESG, 'Message', [
wbEDIDReq,
wbDESCReq,
wbFULL,
wbFormIDCk(INAM, 'Icon', [MICN, NULL], False, cpNormal, True),
wbByteArray(NAM0, 'Unused', 0, cpIgnore),
wbByteArray(NAM1, 'Unused', 0, cpIgnore),
wbByteArray(NAM2, 'Unused', 0, cpIgnore),
wbByteArray(NAM3, 'Unused', 0, cpIgnore),
wbByteArray(NAM4, 'Unused', 0, cpIgnore),
wbByteArray(NAM5, 'Unused', 0, cpIgnore),
wbByteArray(NAM6, 'Unused', 0, cpIgnore),
wbByteArray(NAM7, 'Unused', 0, cpIgnore),
wbByteArray(NAM8, 'Unused', 0, cpIgnore),
wbByteArray(NAM9, 'Unused', 0, cpIgnore),
wbInteger(DNAM, 'Flags', itU32, wbFlags([
'Message Box',
'Auto Display'
]), cpNormal, True, False, nil, wbMESGDNAMAfterSet),
wbInteger(TNAM, 'Display Time', itU32, nil, cpNormal, False, False, wbMESGTNAMDontShow),
wbRStructs('Menu Buttons', 'Menu Button', [
wbString(ITXT, 'Button Text'),
wbCTDAs
], [])
], False, nil, cpNormal, False, wbMESGAfterLoad);
wbRecord(RGDL, 'Ragdoll', [
wbEDIDReq,
wbInteger(NVER, 'Version', itU32, nil, cpNormal, True),
wbStruct(DATA, 'General Data', [
wbInteger('Dynamic Bone Count', itU32),
wbByteArray('Unused', 4),
wbStruct('Enabled', [
wbInteger('Feedback', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Foot IK (broken, don''t use)', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Look IK (broken, don''t use)', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Grab IK (broken, don''t use)', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Pose Matching', itU8, wbEnum(['No', 'Yes']))
]),
wbByteArray('Unused', 1)
], cpNormal, True),
wbFormIDCk(XNAM, 'Actor Base', [CREA, NPC_], False, cpNormal, True),
wbFormIDCk(TNAM, 'Body Part Data', [BPTD], False, cpNormal, True),
wbStruct(RAFD, 'Feedback Data', [
{00} wbFloat('Dynamic/Keyframe Blend Amount'),
{04} wbFloat('Hierarchy Gain'),
{08} wbFloat('Position Gain'),
{12} wbFloat('Velocity Gain'),
{16} wbFloat('Acceleration Gain'),
{20} wbFloat('Snap Gain'),
{24} wbFloat('Velocity Damping'),
wbStruct('Snap Max Settings', [
{28} wbFloat('Linear Velocity'),
{32} wbFloat('Angular Velocity'),
{36} wbFloat('Linear Distance'),
{40} wbFloat('Angular Distance')
]),
wbStruct('Position Max Velocity', [
{44} wbFloat('Linear'),
{48} wbFloat('Angular')
]),
wbStruct('Position Max Velocity', [
{52} wbInteger('Projectile', itS32, wbDiv(1000)),
{56} wbInteger('Melee', itS32, wbDiv(1000))
])
], cpNormal, False),
wbArray(RAFB, 'Feedback Dynamic Bones', wbInteger('Bone', itU16), 0, nil, nil, cpNormal, False),
wbStruct(RAPS, 'Pose Matching Data', [
{00} wbArray('Match Bones', wbInteger('Bone', itU16, wbHideFFFF), 3),
{06} wbInteger('Flags', itU8, wbFlags([
'Disable On Move'
])),
{07} wbByteArray('Unused', 1),
{08} wbFloat('Motors Strength'),
{12} wbFloat('Pose Activation Delay Time'),
{16} wbFloat('Match Error Allowance'),
{20} wbFloat('Displacement To Disable')
], cpNormal, True),
wbString(ANAM, 'Death Pose')
]);
wbRecord(DOBJ, 'Default Object Manager', [
wbEDIDReq,
wbArray(DATA, 'Default Objects', wbFormID('Default Object'), [
'Stimpack',
'SuperStimpack',
'RadX',
'RadAway',
'Morphine',
'Perk Paralysis',
'Player Faction',
'Mysterious Stranger NPC',
'Mysterious Stranger Faction',
'Default Music',
'Battle Music',
'Death Music',
'Success Music',
'Level Up Music',
'Player Voice (Male)',
'Player Voice (Male Child)',
'Player Voice (Female)',
'Player Voice (Female Child)',
'Eat Package Default Food',
'Every Actor Ability',
'Drug Wears Off Image Space',
'Doctor''s Bag',
'Miss Fortune NPC',
'Miss Fortune Faction',
'Meltdown Explosion',
'Unarmed Forward PA',
'Unarmed Backward PA',
'Unarmed Left PA',
'Unarmed Right PA',
'Unarmed Crouch PA',
'Unarmed Counter PA',
'Spotter Effect',
'Item Detected Effect',
'Cateye Mobile Effect (NYI)'
], cpNormal, True)
]);
wbRecord(LGTM, 'Lighting Template', [
wbEDIDReq,
wbStruct(DATA, 'Lighting', [
wbStruct('Ambient Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Directional Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Fog Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbFloat('Fog Near'),
wbFloat('Fog Far'),
wbInteger('Directional Rotation XY', itS32),
wbInteger('Directional Rotation Z', itS32),
wbFloat('Directional Fade'),
wbFloat('Fog Clip Dist'),
wbFloat('Fog Power')
], cpNormal, True)
]);
wbRecord(MUSC, 'Music Type', [
wbEDIDReq,
wbString(FNAM, 'Filename'),
wbFloat(ANAM, 'dB (positive = Loop)')
]);
wbRecord(GRAS, 'Grass', [
wbEDIDReq,
wbOBNDReq,
wbMODLReq,
wbStruct(DATA, '', [
wbInteger('Density', itU8),
wbInteger('Min Slope', itU8),
wbInteger('Max Slope', itU8),
wbByteArray('Unused', 1),
wbInteger('Unit from water amount', itU16),
wbByteArray('Unused', 2),
wbInteger('Unit from water type', itU32, wbEnum([
'Above - At Least',
'Above - At Most',
'Below - At Least',
'Below - At Most',
'Either - At Least',
'Either - At Most',
'Either - At Most Above',
'Either - At Most Below'
])),
wbFloat('Position Range'),
wbFloat('Height Range'),
wbFloat('Color Range'),
wbFloat('Wave Period'),
wbInteger('Flags', itU8, wbFlags([
'Vertex Lighting',
'Uniform Scaling',
'Fit to Slope'
])),
wbByteArray('Unused', 3)
], cpNormal, True)
]);
wbRecord(HAIR, 'Hair', [
wbEDIDReq,
wbFULLReq,
wbMODLReq,
wbString(ICON, 'Texture', 0, cpNormal, True),
wbInteger(DATA, 'Flags', itU8, wbFlags([
'Playable',
'Not Male',
'Not Female',
'Fixed'
]), cpNormal, True)
]);
wbRecord(IDLE, 'Idle Animation', [
wbEDID,
wbMODLReq,
wbCTDAs,
wbArray(ANAM, 'Related Idle Animations', wbFormIDCk('Related Idle Animation', [IDLE, NULL]), ['Parent', 'Previous Sibling'], cpNormal, True),
wbStruct(DATA, '', [
wbInteger('Animation Group Section', itU8, wbIdleAnam),
wbStruct('Looping', [
wbInteger('Min', itU8),
wbInteger('Max', itU8)
]),
wbByteArray('Unused', 1),
wbInteger('Replay Delay', itS16),
wbInteger('Flags', itU8, wbFlags([
'No attacking'
])),
wbByteArray('Unused', 1)
], cpNormal, True, nil, 4)
]);
wbRecord(INFO, 'Dialog response', [
wbStruct(DATA, '', [
wbInteger('Type', itU8, wbEnum([
{0} 'Topic',
{1} 'Conversation',
{2} 'Combat',
{3} 'Persuasion',
{4} 'Detection',
{5} 'Service',
{6} 'Miscellaneous',
{7} 'Radio'
])),
wbInteger('Next Speaker', itU8, wbEnum([
{0} 'Target',
{1} 'Self',
{2} 'Either'
])),
wbInteger('Flags 1', itU8, wbFlags([
{0x01} 'Goodbye',
{0x02} 'Random',
{0x04} 'Say Once',
{0x08} 'Run Immediately',
{0x10} 'Info Refusal',
{0x20} 'Random End',
{0x40} 'Run for Rumors',
{0x80} 'Speech Challenge'
])),
wbInteger('Flags 2', itU8, wbFlags([
{0x01} 'Say Once a Day',
{0x02} 'Always Darken',
{0x04} 'Unknown 2',
{0x08} 'Unknown 3',
{0x10} 'Low Intelligence',
{0x20} 'High Intelligence'
]))
], cpNormal, True, nil, 3),
wbFormIDCkNoReach(QSTI, 'Quest', [QUST], False, cpNormal, True),
wbFormIDCk(TPIC, 'Topic', [DIAL]), // The GECK ignores it for ESM
wbFormIDCkNoReach(PNAM, 'Previous INFO', [INFO, NULL]),
wbRArray('Add Topics', wbFormIDCk(NAME, 'Topic', [DIAL])),
wbRArray('Responses',
wbRStruct('Response', [
wbStruct(TRDT, 'Response Data', [
wbInteger('Emotion Type', itU32, wbEnum([
{0} 'Neutral',
{1} 'Anger',
{2} 'Disgust',
{3} 'Fear',
{4} 'Sad',
{5} 'Happy',
{6} 'Surprise',
{7} 'Pained'
])),
wbInteger('Emotion Value', itS32),
wbByteArray('Unused', 4),
wbInteger('Response number', itU8),
wbByteArray('Unused', 3),
wbFormIDCk('Sound', [SOUN, NULL]),
wbInteger('Flags', itU8, wbFlags([
'Use Emotion Animation'
])),
wbByteArray('Unused', 3)
], cpNormal, False, nil, 5),
wbStringKC(NAM1, 'Response Text', 0, cpTranslate, True),
wbString(NAM2, 'Script Notes', 0, cpTranslate, True),
wbString(NAM3, 'Edits'),
wbFormIDCk(SNAM, 'Speaker Animation', [IDLE]),
wbFormIDCk(LNAM, 'Listener Animation', [IDLE])
], [])
),
wbCTDAs,
wbRArray('Choices', wbFormIDCk(TCLT, 'Choice', [DIAL])),
wbRArray('Link From', wbFormIDCk(TCLF, 'Topic', [DIAL])),
wbRArray('Unknown', wbFormIDCk(TCFU, 'Info', [INFO] )),
wbRStruct('Script (Begin)', [
wbEmbeddedScriptReq
], [], cpNormal, True),
wbRStruct('Script (End)', [
wbEmpty(NEXT, 'Marker'),
wbEmbeddedScriptReq
], [], cpNormal, True),
wbFormIDCk(SNDD, 'Unused', [SOUN]),
wbString(RNAM, 'Prompt'),
wbFormIDCk(ANAM, 'Speaker', [CREA, NPC_]),
wbFormIDCk(KNAM, 'ActorValue/Perk', [AVIF, PERK]),
wbInteger(DNAM, 'Speech Challenge', itU32, wbEnum([
'---',
'Very Easy',
'Easy',
'Average',
'Hard',
'Very Hard'
]))
], False, wbINFOAddInfo, cpNormal, False, wbINFOAfterLoad);
wbRecord(INGR, 'Ingredient', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbSCRI,
wbETYPReq,
wbFloat(DATA, 'Weight', cpNormal, True),
wbStruct(ENIT, 'Effect Data', [
wbInteger('Value', itS32),
wbInteger('Flags', itU8, wbFlags(['No auto-calculation', 'Food item'])),
wbByteArray('Unused', 3)
], cpNormal, True),
wbEffectsReq
]);
wbRecord(KEYM, 'Key', [
wbEDIDReq,
wbOBNDReq,
wbFULLReq,
wbMODL,
wbICONReq,
wbSCRI,
wbDEST,
wbYNAM,
wbZNAM,
wbStruct(DATA, '', [
wbInteger('Value', itS32),
wbFloat('Weight')
], cpNormal, True),
wbFormIDCk(RNAM, 'Sound - Random/Looping', [SOUN])
]);
wbQuadrantEnum := wbEnum([
{0} 'Bottom Left',
{1} 'Bottom Right',
{2} 'Top Left',
{3} 'Top Right'
]);
if wbSimpleRecords then begin
wbRecord(LAND, 'Landscape', [
wbByteArray(DATA, 'Unknown'),
wbByteArray(VNML, 'Vertex Normals'),
wbByteArray(VHGT, 'Vertext Height Map'),
wbByteArray(VCLR, 'Vertex Colours'),
wbRArrayS('Layers', wbRUnion('Layer', [
wbRStructSK([0],'Base Layer', [
wbStructSK(BTXT, [1, 3], 'Base Layer Header', [
wbFormIDCk('Texture', [LTEX, NULL]),
wbInteger('Quadrant', itU8, wbQuadrantEnum),
wbByteArray('Unused', 1),
wbInteger('Layer', itS16)
])
], []),
wbRStructSK([0],'Alpha Layer', [
wbStructSK(ATXT, [1, 3], 'Alpha Layer Header', [
wbFormIDCk('Texture', [LTEX, NULL]),
wbInteger('Quadrant', itU8, wbQuadrantEnum),
wbByteArray('Unused', 1),
wbInteger('Layer', itS16)
]),
wbByteArray(VTXT, 'Alpha Layer Data')
], [])
], [])),
wbArray(VTEX, 'Textures', wbFormIDCk('Texture', [LTEX, NULL]))
]);
end else begin
wbRecord(LAND, 'Landscape', [
wbByteArray(DATA, 'Unknown'),
wbArray(VNML, 'Vertex Normals', wbStruct('Row', [
wbArray('Columns', wbStruct('Column', [
wbInteger('X', itU8),
wbInteger('Y', itU8),
wbInteger('Z', itU8)
]), 33)
]), 33),
wbStruct(VHGT, 'Vertext Height Map', [
wbFloat('Offset'),
wbArray('Rows', wbStruct('Row', [
wbArray('Columns', wbInteger('Column', itU8), 33)
]), 33),
wbByteArray('Unused', 3)
]),
wbArray(VCLR, 'Vertex Colours', wbStruct('Row', [
wbArray('Columns', wbStruct('Column', [
wbInteger('X', itU8),
wbInteger('Y', itU8),
wbInteger('Z', itU8)
]), 33)
]), 33),
wbRArrayS('Layers', wbRUnion('Layer', [
wbRStructSK([0],'Base Layer', [
wbStructSK(BTXT, [1, 3], 'Base Layer Header', [
wbFormIDCk('Texture', [LTEX, NULL]),
wbInteger('Quadrant', itU8, wbQuadrantEnum),
wbByteArray('Unused', 1),
wbInteger('Layer', itS16)
])
], []),
wbRStructSK([0],'Alpha Layer', [
wbStructSK(ATXT, [1, 3], 'Alpha Layer Header', [
wbFormIDCk('Texture', [LTEX, NULL]),
wbInteger('Quadrant', itU8, wbQuadrantEnum),
wbByteArray('Unused', 1),
wbInteger('Layer', itS16)
]),
wbArrayS(VTXT, 'Alpha Layer Data', wbStructSK([0], 'Cell', [
wbInteger('Position', itU16, wbAtxtPosition),
wbByteArray('Unused', 2),
wbFloat('Opacity')
]))
], [])
], [])),
wbArray(VTEX, 'Textures', wbFormIDCk('Texture', [LTEX, NULL]))
]);
end;
wbRecord(LIGH, 'Light', [
wbEDIDReq,
wbOBNDReq,
wbMODL,
wbSCRI,
wbDEST,
wbFULL,
wbICON,
wbStruct(DATA, '', [
wbInteger('Time', itS32),
wbInteger('Radius', itU32),
wbStruct('Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbInteger('Unused', itU8)
]),
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Dynamic',
{0x00000002} 'Can be Carried',
{0x00000004} 'Negative',
{0x00000008} 'Flicker',
{0x00000010} 'Unused',
{0x00000020} 'Off By Default',
{0x00000040} 'Flicker Slow',
{0x00000080} 'Pulse',
{0x00000100} 'Pulse Slow',
{0x00000200} 'Spot Light',
{0x00000400} 'Spot Shadow'
])),
wbFloat('Falloff Exponent'),
wbFloat('FOV'),
wbInteger('Value', itU32),
wbFloat('Weight')
], cpNormal, True),
wbFloat(FNAM, 'Fade value', cpNormal, True),
wbFormIDCk(SNAM, 'Sound', [SOUN])
], False, nil, cpNormal, False, wbLIGHAfterLoad);
wbRecord(LSCR, 'Load Screen', [
wbEDIDReq,
wbICONReq,
wbDESCReq,
wbRArrayS('Locations', wbStructSK(LNAM, [0, 1], 'Location', [
wbFormIDCk('Direct', [CELL, WRLD, NULL]),
wbStructSK([0, 1], 'Indirect', [
wbFormIDCk('World', [NULL, WRLD]),
wbStructSK([0,1], 'Grid', [
wbInteger('Y', itS16),
wbInteger('X', itS16)
])
])
])),
wbFormIDCk(WMI1, 'Load Screen Type', [LSCT])
]);
wbRecord(LTEX, 'Landscape Texture', [
wbEDIDReq,
wbICON,
wbFormIDCk(TNAM, 'Texture', [TXST], False, cpNormal, True),
wbStruct(HNAM, 'Havok Data', [
wbInteger('Material Type', itU8, wbEnum([
{00} 'STONE',
{01} 'CLOTH',
{02} 'DIRT',
{03} 'GLASS',
{04} 'GRASS',
{05} 'METAL',
{06} 'ORGANIC',
{07} 'SKIN',
{08} 'WATER',
{09} 'WOOD',
{10} 'HEAVY STONE',
{11} 'HEAVY METAL',
{12} 'HEAVY WOOD',
{13} 'CHAIN',
{14} 'SNOW',
{15} 'ELEVATOR',
{16} 'HOLLOW METAL',
{17} 'SHEET METAL',
{18} 'SAND',
{19} 'BRIKEN CONCRETE',
{20} 'VEHILCE BODY',
{21} 'VEHILCE PART SOLID',
{22} 'VEHILCE PART HOLLOW',
{23} 'BARREL',
{24} 'BOTTLE',
{25} 'SODA CAN',
{26} 'PISTOL',
{27} 'RIFLE',
{28} 'SHOPPING CART',
{29} 'LUNCHBOX',
{30} 'BABY RATTLE',
{31} 'RUBER BALL'
])),
wbInteger('Friction', itU8),
wbInteger('Restitution', itU8)
], cpNormal, True),
wbInteger(SNAM, 'Texture Specular Exponent', itU8, nil, cpNormal, True),
wbRArrayS('Grasses', wbFormIDCk(GNAM, 'Grass', [GRAS]))
]);
wbRecord(LVLC, 'Leveled Creature', [
wbEDIDReq,
wbOBNDReq,
wbInteger(LVLD, 'Chance none', itU8, nil, cpNormal, True),
wbInteger(LVLF, 'Flags', itU8, wbFlags([
{0x01} 'Calculate from all levels <= player''s level',
{0x02} 'Calculate for each item in count'
]), cpNormal, True),
wbRArrayS('Leveled List Entries',
wbRStructExSK([0], [1], 'Leveled List Entry', [
wbStructExSK(LVLO , [0, 2], [3], 'Base Data', [
wbInteger('Level', itS16),
wbByteArray('Unused', 2),
wbFormIDCk('Reference', [CREA, LVLC]),
wbInteger('Count', itS16),
wbByteArray('Unused', 2)
]),
wbCOED
], []),
cpNormal, True),
wbMODL
]);
wbRecord(LVLN, 'Leveled NPC', [
wbEDIDReq,
wbOBNDReq,
wbInteger(LVLD, 'Chance none', itU8, nil, cpNormal, True),
wbInteger(LVLF, 'Flags', itU8, wbFlags([
{0x01} 'Calculate from all levels <= player''s level',
{0x02} 'Calculate for each item in count'
]), cpNormal, True),
wbRArrayS('Leveled List Entries',
wbRStructExSK([0], [1], 'Leveled List Entry', [
wbStructExSK(LVLO , [0, 2], [3], 'Base Data', [
wbInteger('Level', itS16),
wbByteArray('Unused', 2),
wbFormIDCk('Reference', [NPC_, LVLN]),
wbInteger('Count', itS16),
wbByteArray('Unused', 2)
]),
wbCOED
], []),
cpNormal, True),
wbMODL
]);
wbRecord(LVLI, 'Leveled Item', [
wbEDIDReq,
wbOBNDReq,
wbInteger(LVLD, 'Chance none', itU8, nil, cpNormal, True),
wbInteger(LVLF, 'Flags', itU8, wbFlags([
{0x01} 'Calculate from all levels <= player''s level',
{0x02} 'Calculate for each item in count',
{0x04} 'Use All'
]), cpNormal, True),
wbFormIDCk(LVLG, 'Global', [GLOB]),
wbRArrayS('Leveled List Entries',
wbRStructExSK([0], [1], 'Leveled List Entry', [
wbStructExSK(LVLO , [0, 2], [3], 'Base Data', [
wbInteger('Level', itS16),
wbByteArray('Unused', 2),
wbFormIDCk('Reference', [ARMO, AMMO, MISC, WEAP, BOOK, LVLI, KEYM, ALCH, NOTE, IMOD, CMNY, CCRD, CHIP]),
wbInteger('Count', itS16),
wbByteArray('Unused', 2)
]),
wbCOED
], [])
)
]);
wbArchtypeEnum := wbEnum([
{00} 'Value Modifier',
{01} 'Script',
{02} 'Dispel',
{03} 'Cure Disease',
{04} '',
{05} '',
{06} '',
{07} '',
{08} '',
{09} '',
{10} '',
{11} 'Invisibility',
{12} 'Chameleon',
{13} 'Light',
{14} '',
{15} '',
{16} 'Lock',
{17} 'Open',
{18} 'Bound Item',
{19} 'Summon Creature',
{20} '',
{21} '',
{22} '',
{23} '',
{24} 'Paralysis',
{25} '',
{26} '',
{27} '',
{28} '',
{29} '',
{30} 'Cure Paralysis',
{31} 'Cure Addiction',
{32} 'Cure Poison',
{33} 'Concussion',
{34} 'Value And Parts',
{35} 'Limb Condition',
{36} 'Turbo'
]);
wbRecord(MGEF, 'Base Effect', [
wbEDIDReq,
wbFULL,
wbDESCReq,
wbICON,
wbMODL,
wbStruct(DATA, 'Data', [
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Hostile',
{0x00000002} 'Recover',
{0x00000004} 'Detrimental',
{0x00000008} '',
{0x00000010} 'Self',
{0x00000020} 'Touch',
{0x00000040} 'Target',
{0x00000080} 'No Duration',
{0x00000100} 'No Magnitude',
{0x00000200} 'No Area',
{0x00000400} 'FX Persist',
{0x00000800} '',
{0x00001000} 'Gory Visuals',
{0x00002000} 'Display Name Only',
{0x00004000} '',
{0x00008000} 'Radio Broadcast ??',
{0x00010000} '',
{0x00020000} '',
{0x00040000} '',
{0x00080000} 'Use skill',
{0x00100000} 'Use attribute',
{0x00200000} '',
{0x00400000} '',
{0x00800000} '',
{0x01000000} 'Painless',
{0x02000000} 'Spray projectile type (or Fog if Bolt is specified as well)',
{0x04000000} 'Bolt projectile type (or Fog if Spray is specified as well)',
{0x08000000} 'No Hit Effect',
{0x10000000} 'No Death Dispel',
{0x20000000} '????'
])),
{04} wbFloat('Base cost (Unused)'),
{08} wbUnion('Assoc. Item', wbMGEFFAssocItemDecider, [
wbFormID('Unused', cpIgnore),
wbFormID('Assoc. Item'),
wbFormIDCk('Assoc. Script', [SCPT, NULL]), //Script
wbFormIDCk('Assoc. Item', [WEAP, ARMO, NULL]), //Bound Item
wbFormIDCk('Assoc. Creature', [CREA]) //Summon Creature
], cpNormal, false, nil, wbMGEFFAssocItemAfterSet),
{12} wbInteger('Magic School (Unused)', itS32, wbEnum([
], [
-1, 'None'
])),
{16} wbInteger('Resistance Type', itS32, wbActorValueEnum),
{20} wbInteger('Counter effect count', itU16),
{22} wbByteArray('Unused', 2),
{24} wbFormIDCk('Light', [LIGH, NULL]),
{28} wbFloat('Projectile speed'),
{32} wbFormIDCk('Effect Shader', [EFSH, NULL]),
{36} wbFormIDCk('Object Display Shader', [EFSH, NULL]),
{40} wbFormIDCk('Effect sound', [NULL, SOUN]),
{44} wbFormIDCk('Bolt sound', [NULL, SOUN]),
{48} wbFormIDCk('Hit sound', [NULL, SOUN]),
{52} wbFormIDCk('Area sound', [NULL, SOUN]),
{56} wbFloat('Constant Effect enchantment factor (Unused)'),
{60} wbFloat('Constant Effect barter factor (Unused)'),
{64} wbInteger('Archtype', itU32, wbArchtypeEnum, cpNormal, False, nil, wbMGEFArchtypeAfterSet),
{68} wbActorValue
], cpNormal, True),
wbRArrayS('Counter Effects', wbFormIDCk(ESCE, 'Effect', [MGEF]), cpNormal, False, nil, wbCounterEffectsAfterSet)
], False, nil, cpNormal, False, wbMGEFAfterLoad, wbMGEFAfterSet);
wbRecord(MISC, 'Misc. Item', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbSCRI,
wbDEST,
wbYNAM,
wbZNAM,
wbStruct(DATA, '', [
wbInteger('Value', itS32),
wbFloat('Weight')
], cpNormal, True),
wbFormIDCk(RNAM, 'Sound - Random/Looping', [SOUN])
]);
wbRecord(COBJ, 'Constructible Object', [
wbEDID,
wbOBND,
wbFULL,
wbMODL,
wbICON,
wbSCRI,
wbYNAM,
wbZNAM,
wbStruct(DATA, '', [
wbInteger('Value', itS32),
wbFloat('Weight')
], cpNormal, True)
]);
// floats are reported to change faces after copying
if True {wbSimpleRecords} then begin
wbFaceGen := wbRStruct('FaceGen Data', [
wbByteArray(FGGS, 'FaceGen Geometry-Symmetric', 0, cpNormal, True),
wbByteArray(FGGA, 'FaceGen Geometry-Asymmetric', 0, cpNormal, True),
wbByteArray(FGTS, 'FaceGen Texture-Symmetric', 0, cpNormal, True)
], [], cpNormal, True);
wbFaceGenNPC := wbRStruct('FaceGen Data', [ // Arrays of 4bytes elements
wbByteArray(FGGS, 'FaceGen Geometry-Symmetric', 0, cpNormal, True),
wbByteArray(FGGA, 'FaceGen Geometry-Asymmetric', 0, cpNormal, True),
wbByteArray(FGTS, 'FaceGen Texture-Symmetric', 0, cpNormal, True)
], [], cpNormal, True, wbActorTemplateUseModelAnimation);
end else begin
wbFaceGen := wbRStruct('FaceGen Data', [
wbArray(FGGS, 'FaceGen Geometry-Symmetric', wbFloat('Value'), [], cpNormal, True),
wbArray(FGGA, 'FaceGen Geometry-Asymmetric', wbFloat('Value'), [], cpNormal, True),
wbArray(FGTS, 'FaceGen Texture-Symmetric', wbFloat('Value'), [], cpNormal, True)
], [], cpNormal, True);
wbFaceGenNPC := wbRStruct('FaceGen Data', [
wbArray(FGGS, 'FaceGen Geometry-Symmetric', wbFloat('Value'), [], cpNormal, True),
wbArray(FGGA, 'FaceGen Geometry-Asymmetric', wbFloat('Value'), [], cpNormal, True),
wbArray(FGTS, 'FaceGen Texture-Symmetric', wbFloat('Value'), [], cpNormal, True)
], [], cpNormal, True, wbActorTemplateUseModelAnimation);
end;
wbRecord(NPC_, 'Non-Player Character', [
wbEDIDReq,
wbOBNDReq,
wbFULLActor,
wbMODLActor,
wbStruct(ACBS, 'Configuration', [
{00} wbInteger('Flags', itU32, wbFlags([
{0x000001} 'Female',
{0x000002} 'Essential',
{0x000004} 'Is CharGen Face Preset',
{0x000008} 'Respawn',
{0x000010} 'Auto-calc stats',
{0x000020} '',
{0x000040} '',
{0x000080} 'PC Level Mult',
{0x000100} 'Use Template',
{0x000200} 'No Low Level Processing',
{0x000400} '',
{0x000800} 'No Blood Spray',
{0x001000} 'No Blood Decal',
{0x002000} '',
{0x004000} '',
{0x008000} '',
{0x010000} '',
{0x020000} '',
{0x040000} '',
{0x080000} '',
{0x100000} 'No VATS Melee',
{0x00200000} '',
{0x00400000} 'Can be all races',
{0x00800000} 'Autocalc Service',
{0x01000000} '',
{0x02000000} '',
{0x04000000} 'No Knockdowns',
{0x08000000} 'Not Pushable',
{0x10000000} 'Unknown 28',
{0x20000000} '',
{0x40000000} 'No Rotating To Head-track',
{0x80000000} ''
], [
{0x000001 Female} wbActorTemplateUseTraits,
{0x000002 Essential} wbActorTemplateUseBaseData,
{0x000004 Is CharGen Face Preset} nil,
{0x000008 Respawn} wbActorTemplateUseBaseData,
{0x000010 Auto-calc stats} wbActorTemplateUseStats,
{0x000020 } nil,
{0x000040 } nil,
{0x000080 PC Level Mult} wbActorTemplateUseStats,
{0x000100 Use Template} nil,
{0x000200 No Low Level Processing} wbActorTemplateUseBaseData,
{0x000400 } nil,
{0x000800 No Blood Spray} wbActorTemplateUseModelAnimation,
{0x001000 No Blood Decal} wbActorTemplateUseModelAnimation,
{0x002000 } nil,
{0x004000 } nil,
{0x008000 } nil,
{0x010000 } nil,
{0x020000 } nil,
{0x040000 } nil,
{0x080000 } nil,
{0x100000 No VATS Melee} nil,
{0x00200000 } nil,
{0x00400000 Can be all races} nil,
{0x00800000 } nil,
{0x01000000 } nil,
{0x02000000 } nil,
{0x04000000 No Knockdowns} nil,
{0x08000000 Not Pushable} wbActorTemplateUseModelAnimation,
{0x10000000 } nil,
{0x20000000 } nil,
{0x40000000 No Rotating To Head-track} wbActorTemplateUseModelAnimation,
{0x80000000 } nil
])),
{04} wbInteger('Fatigue', itU16, nil, cpNormal, True, wbActorTemplateUseStats),
{06} wbInteger('Barter gold', itU16, nil, cpNormal, False, wbActorTemplateUseAIData),
{08} wbUnion('Level', wbCreaLevelDecider, [
wbInteger('Level', itS16, nil, cpNormal, True, wbActorTemplateUseStats),
wbInteger('Level Mult', itS16, wbDiv(1000), cpNormal, True, wbActorTemplateUseStats)
], cpNormal, True, wbActorTemplateUseStats),
{10} wbInteger('Calc min', itU16, nil, cpNormal, True, wbActorTemplateUseStats),
{12} wbInteger('Calc max', itU16, nil, cpNormal, True, wbActorTemplateUseStats),
{14} wbInteger('Speed Multiplier', itU16, nil, cpNormal, True, wbActorTemplateUseStats),
{16} wbFloat('Karma (Alignment)', cpNormal, False, 1, -1, wbActorTemplateUseTraits),
{20} wbInteger('Disposition Base', itS16, nil, cpNormal, False, wbActorTemplateUseTraits),
{22} wbInteger('Template Flags', itU16, wbTemplateFlags)
], cpNormal, True),
wbRArrayS('Factions',
wbStructSK(SNAM, [0], 'Faction', [
wbFormIDCk('Faction', [FACT]),
wbInteger('Rank', itU8),
wbByteArray('Unused', 3)
]),
cpNormal, False, nil, nil, wbActorTemplateUseFactions),
wbFormIDCk(INAM, 'Death item', [LVLI], False, cpNormal, False, wbActorTemplateUseTraits),
wbFormIDCk(VTCK, 'Voice', [VTYP], False, cpNormal, True, wbActorTemplateUseTraits),
wbFormIDCk(TPLT, 'Template', [LVLN, NPC_]),
wbFormIDCk(RNAM, 'Race', [RACE], False, cpNormal, True, wbActorTemplateUseTraits),
wbSPLOs,
wbFormIDCk(EITM, 'Unarmed Attack Effect', [ENCH, SPEL], False, cpNormal, False, wbActorTemplateUseActorEffectList),
wbInteger(EAMT, 'Unarmed Attack Animation', itU16, wbAttackAnimationEnum, cpNormal, True, False, wbActorTemplateUseActorEffectList),
wbDESTActor,
wbSCRIActor,
wbRArrayS('Items', wbCNTO, cpNormal, False, nil, nil, wbActorTemplateUseInventory),
wbAIDT,
wbRArray('Packages', wbFormIDCk(PKID, 'Package', [PACK]), cpNormal, False, nil, nil, wbActorTemplateUseAIPackages),
wbArrayS(KFFZ, 'Animations', wbStringLC('Animation'), 0, cpNormal, False, nil, nil, wbActorTemplateUseModelAnimation),
wbFormIDCk(CNAM, 'Class', [CLAS], False, cpNormal, True, wbActorTemplateUseTraits),
wbStruct(DATA, '', [
{00} wbInteger('Base Health', itS32),
{04} wbArray('Attributes', wbInteger('Attribute', itU8), [
'Strength',
'Perception',
'Endurance',
'Charisma',
'Intelligence',
'Agility',
'Luck'
], cpNormal, False, wbActorAutoCalcDontShow),
wbByteArray('Unused'{, 14 - only present in old record versions})
], cpNormal, True, wbActorTemplateUseStats),
wbStruct(DNAM, '', [
{00} wbArray('Skill Values', wbInteger('Skill', itU8), [
'Barter',
'Big Guns (obsolete)',
'Energy Weapons',
'Explosives',
'Lockpick',
'Medicine',
'Melee Weapons',
'Repair',
'Science',
'Guns',
'Sneak',
'Speech',
'Survival',
'Unarmed'
]),
{14} wbArray('Skill Offsets', wbInteger('Skill', itU8), [
'Barter',
'Big Guns (obsolete)',
'Energy Weapons',
'Explosives',
'Lockpick',
'Medicine',
'Melee Weapons',
'Repair',
'Science',
'Guns',
'Sneak',
'Speech',
'Survival',
'Unarmed'
])
], cpNormal, False, wbActorTemplateUseStatsAutoCalc),
wbRArrayS('Head Parts',
wbFormIDCk(PNAM, 'Head Part', [HDPT]),
cpNormal, False, nil, nil, wbActorTemplateUseModelAnimation),
wbFormIDCk(HNAM, 'Hair', [HAIR], False, cpNormal, False, wbActorTemplateUseModelAnimation),
wbFloat(LNAM, 'Hair length', cpNormal, False, 1, -1, wbActorTemplateUseModelAnimation),
wbFormIDCk(ENAM, 'Eyes', [EYES], False, cpNormal, False, wbActorTemplateUseModelAnimation),
wbStruct(HCLR, 'Hair color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
], cpNormal, True, wbActorTemplateUseModelAnimation),
wbFormIDCk(ZNAM, 'Combat Style', [CSTY], False, cpNormal, False, wbActorTemplateUseTraits),
wbInteger(NAM4, 'Impact Material Type', itU32, wbImpactMaterialTypeEnum, cpNormal, True, False, wbActorTemplateUseModelAnimation),
wbFaceGenNPC,
wbInteger(NAM5, 'Unknown', itU16, nil, cpNormal, True, False, nil, nil, 255),
wbFloat(NAM6, 'Height', cpNormal, True, 1, -1, wbActorTemplateUseTraits),
wbFloat(NAM7, 'Weight', cpNormal, True, 1, -1, wbActorTemplateUseTraits)
], True, nil, cpNormal, False, wbNPCAfterLoad);
wbPKDTFlags := wbFlags([
{0x00000001} 'Offers Services',
{0x00000002} 'Must reach location',
{0x00000004} 'Must complete',
{0x00000008} 'Lock doors at package start',
{0x00000010} 'Lock doors at package end',
{0x00000020} 'Lock doors at location',
{0x00000040} 'Unlock doors at package start',
{0x00000080} 'Unlock doors at package end',
{0x00000100} 'Unlock doors at location',
{0x00000200} 'Continue if PC near',
{0x00000400} 'Once per day',
{0x00000800} '',
{0x00001000} 'Skip fallout behavior',
{0x00002000} 'Always run',
{0x00004000} '',
{0x00008000} '',
{0x00010000} '',
{0x00020000} 'Always sneak',
{0x00040000} 'Allow swimming',
{0x00080000} 'Allow falls',
{0x00100000} 'Head-Tracking off',
{0x00200000} 'Weapons unequipped',
{0x00400000} 'Defensive combat',
{0x00800000} 'Weapon Drawn',
{0x01000000} 'No idle anims',
{0x02000000} 'Pretend In Combat',
{0x04000000} 'Continue During Combat',
{0x08000000} 'No Combat Alert',
{0x10000000} 'No Warn/Attack Behaviour',
{0x20000000} '',
{0x40000000} '',
{0x80000000} ''
]);
wbPKDTType := wbEnum([
{0} 'Find',
{1} 'Follow',
{2} 'Escort',
{3} 'Eat',
{4} 'Sleep',
{5} 'Wander',
{6} 'Travel',
{7} 'Accompany',
{8} 'Use Item At',
{9} 'Ambush',
{10} 'Flee Not Combat',
{11} 'Package Type 11',
{12} 'Sandbox',
{13} 'Patrol',
{14} 'Guard',
{15} 'Dialogue',
{16} 'Use Weapon',
{17} 'Package Type 17',
{18} 'Combat Controller',
{19} 'Package Type 19',
{20} 'Package Type 20',
{21} 'Alarm',
{22} 'Flee',
{23} 'TressPass',
{24} 'Spectator',
{25} 'Package Type 25',
{26} 'Package Type 26',
{27} 'Package Type 27',
{28} 'Dialogue 2',
{29} 'Package Type 29',
{30} 'Package Type 30',
{31} 'Package Type 31',
{32} 'Package Type 32',
{33} 'Package Type 33',
{34} 'Package Type 34',
{35} 'Package Type 35',
{36} 'Package Type 36',
{37} 'Package Type 37',
{38} 'Package Type 38',
{39} 'Package Type 39',
{40} 'Package Type 40'
]);
wbObjectTypeEnum := wbEnum([
' NONE',
'Activators',
'Armor',
'Books',
'Clothing',
'Containers',
'Doors',
'Ingredients',
'Lights',
'Misc',
'Flora',
'Furniture',
'Weapons: Any',
'Ammo',
'NPCs',
'Creatures',
'Keys',
'Alchemy',
'Food',
' All: Combat Wearable',
' All: Wearable',
'Weapons: Ranged',
'Weapons: Melee',
'Weapons: NONE',
'Actor Effects: Any',
'Actor Effects: Range Target',
'Actor Effects: Range Touch',
'Actor Effects: Range Self',
// '',
'Actors: Any'
]);
wbPKDTSpecificFlagsUnused := True;
wbRecord(PACK, 'Package', [
wbEDIDReq,
wbStruct(PKDT, 'General', [
wbInteger('General Flags', itU32, wbPKDTFlags),
wbInteger('Type', itU8, wbPKDTType),
wbByteArray('Unused', 1),
wbInteger('Fallout Behavior Flags', itU16, wbFlags([
{0x00000001}'Hellos To Player',
{0x00000002}'Random Conversations',
{0x00000004}'Observe Combat Behavior',
{0x00000008}'Unknown 4',
{0x00000010}'Reaction To Player Actions',
{0x00000020}'Friendly Fire Comments',
{0x00000040}'Aggro Radius Behavior',
{0x00000080}'Allow Idle Chatter',
{0x00000100}'Avoid Radiation'
], True)),
wbUnion('Type Specific Flags', wbPKDTSpecificFlagsDecider, [
wbEmpty('Type Specific Flags (missing)', cpIgnore, False, nil, True),
wbInteger('Type Specific Flags - Find', itU16, wbFlags([
{0x00000001}'',
{0x00000002}'',
{0x00000004}'',
{0x00000008}'',
{0x00000010}'',
{0x00000020}'',
{0x00000040}'',
{0x00000080}'',
{0x00000100}'Find - Allow Buying',
{0x00000200}'Find - Allow Killing',
{0x00000400}'Find - Allow Stealing'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Follow', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Escort', itU16, wbFlags([
{0x00000001}'',
{0x00000002}'',
{0x00000004}'',
{0x00000008}'',
{0x00000010}'',
{0x00000020}'',
{0x00000040}'',
{0x00000080}'',
{0x00000100}'Escort - Allow Buying',
{0x00000200}'Escort - Allow Killing',
{0x00000400}'Escort - Allow Stealing'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Eat', itU16, wbFlags([
{0x00000001}'',
{0x00000002}'',
{0x00000004}'',
{0x00000008}'',
{0x00000010}'',
{0x00000020}'',
{0x00000040}'',
{0x00000080}'',
{0x00000100}'Eat - Allow Buying',
{0x00000200}'Eat - Allow Killing',
{0x00000400}'Eat - Allow Stealing'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Sleep', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Wander', itU16, wbFlags([
{0x00000001}'Wander - No Eating',
{0x00000002}'Wander - No Sleeping',
{0x00000004}'Wander - No Conversation',
{0x00000008}'Wander - No Idle Markers',
{0x00000010}'Wander - No Furniture',
{0x00000020}'Wander - No Wandering'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Travel', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Accompany', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Use Item At', itU16, wbFlags([
{0x00000001}'',
{0x00000002}'Use Item At - Sit Down',
{0x00000004}'',
{0x00000008}'',
{0x00000010}'',
{0x00000020}'',
{0x00000040}'',
{0x00000080}'',
{0x00000100}'Use Item At - Allow Buying',
{0x00000200}'Use Item At - Allow Killing',
{0x00000400}'Use Item At - Allow Stealing'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Ambush', itU16, wbFlags([
{0x00000001}'Ambush - Hide While Ambushing'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Flee Not Combat', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - ?', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Sandbox', itU16, wbFlags([
{0x00000001}'Sandbox - No Eating',
{0x00000002}'Sandbox - No Sleeping',
{0x00000004}'Sandbox - No Conversation',
{0x00000008}'Sandbox - No Idle Markers',
{0x00000010}'Sandbox - No Furniture',
{0x00000020}'Sandbox - No Wandering'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Patrol', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Guard', itU16, wbFlags([
{0x00000001}'',
{0x00000002}'',
{0x00000004}'Guard - Remain Near Reference to Guard'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Dialogue', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Use Weapon', itU16, wbFlags([], wbPKDTSpecificFlagsUnused))
]),
wbByteArray('Unused', 2)
], cpNormal, True, nil, 2),
wbRStruct('Locations', [
wbStruct(PLDT, 'Location 1', [
wbInteger('Type', itS32, wbEnum([ // Byte + filler
{0} 'Near reference',
{1} 'In cell',
{2} 'Near current location',
{3} 'Near editor location',
{4} 'Object ID',
{5} 'Object Type',
{6} 'Near linked reference',
{7} 'At package location'
])),
wbUnion('Location', wbPxDTLocationDecider, [
wbFormIDCkNoReach('Reference', [REFR, PGRE, PMIS, PBEA, ACHR, ACRE, PLYR], True),
wbFormIDCkNoReach('Cell', [CELL]),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbFormIDCkNoReach('Object ID', [ACTI, DOOR, STAT, FURN, CREA, SPEL, NPC_, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, CHIP, CMNY, CCRD, IMOD]),
wbInteger('Object Type', itU32, wbObjectTypeEnum),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore)
]),
wbInteger('Radius', itS32)
], cpNormal, True),
wbStruct(PLD2, 'Location 2', [
wbInteger('Type', itS32, wbEnum([
{0} 'Near reference',
{1} 'In cell',
{2} 'Near current location',
{3} 'Near editor location',
{4} 'Object ID',
{5} 'Object Type',
{6} 'Near linked reference',
{7} 'At package location'
])),
wbUnion('Location', wbPxDTLocationDecider, [
wbFormIDCkNoReach('Reference', [REFR, PGRE, PMIS, PBEA, ACHR, ACRE, PLYR], True),
wbFormIDCkNoReach('Cell', [CELL]),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbFormIDCkNoReach('Object ID', [ACTI, DOOR, STAT, FURN, CREA, SPEL, NPC_, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, CHIP, CMNY, CCRD, IMOD]),
wbInteger('Object Type', itU32, wbObjectTypeEnum),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore)
]),
wbInteger('Radius', itS32)
])
], [], cpNormal, False, nil, True),
wbStruct(PSDT, 'Schedule', [
wbInteger('Month', itS8),
wbInteger('Day of week', itS8, wbEnum([
'Sunday',
'Monday',
'Tuesday',
'Wednesday',
'Thursday',
'Friday',
'Saturday',
'Weekdays',
'Weekends',
'Monday, Wednesday, Friday',
'Tuesday, Thursday'
], [
-1, 'Any'
])),
wbInteger('Date', itU8),
wbInteger('Time', itS8),
wbInteger('Duration', itS32)
], cpNormal, True),
wbStruct(PTDT, 'Target 1', [
wbInteger('Type', itS32, wbEnum([
{0} 'Specific Reference',
{1} 'Object ID',
{2} 'Object Type',
{3} 'Linked Reference'
]), cpNormal, False, nil, nil, 2),
wbUnion('Target', wbPxDTLocationDecider, [
wbFormIDCkNoReach('Reference', [ACHR, ACRE, REFR, PGRE, PMIS, PBEA, PLYR], True),
wbFormIDCkNoReach('Object ID', [ACTI, DOOR, STAT, FURN, CREA, SPEL, NPC_, LVLN, LVLC, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, FACT, FLST, IDLM, CHIP, CMNY, CCRD, IMOD]),
wbInteger('Object Type', itU32, wbObjectTypeEnum),
wbByteArray('Unused', 4, cpIgnore)
]),
wbInteger('Count / Distance', itS32),
wbFloat('Unknown')
], cpNormal, False, nil, 3),
wbCTDAs,
wbRStruct('Idle Animations', [
wbInteger(IDLF, 'Flags', itU8, wbFlags([
'Run in Sequence',
'',
'Do Once'
]), cpNormal, True),
wbStruct(IDLC, '', [
wbInteger( 'Animation Count', itU8),
wbByteArray('Unused', 3)
], cpNormal, True, nil, 1),
wbFloat(IDLT, 'Idle Timer Setting', cpNormal, True),
wbArray(IDLA, 'Animations', wbFormIDCk('Animation', [IDLE]), 0, nil, wbIDLAsAfterSet, cpNormal, True),
wbByteArray(IDLB, 'Unused', 4, cpIgnore)
], [], cpNormal, False, nil, False, nil {cannot be totally removed , wbAnimationsAfterSet}),
wbFormIDCk(CNAM, 'Combat Style', [CSTY]),
wbEmpty(PKED, 'Eat Marker'),
wbInteger(PKE2, 'Escort Distance', itU32),
wbFloat(PKFD, 'Follow - Start Location - Trigger Radius'),
wbStruct(PKPT, 'Patrol Flags', [
wbInteger('Repeatable', itU8, wbEnum(['No', 'Yes']), cpNormal, False, nil, nil, 1),
wbByteArray('Unused', 1)
], cpNormal, False, nil, 1),
wbStruct(PKW3, 'Use Weapon Data', [
wbInteger('Flags', itU32, wbFlags([
'Always Hit',
'',
'',
'',
'',
'',
'',
'',
'Do No Damage',
'',
'',
'',
'',
'',
'',
'',
'Crouch To Reload',
'',
'',
'',
'',
'',
'',
'',
'Hold Fire When Blocked'
])),
wbInteger('Fire Rate', itU8, wbEnum([
'Auto Fire',
'Volley Fire'
])),
wbInteger('Fire Count', itU8, wbEnum([
'Number of Bursts',
'Repeat Fire'
])),
wbInteger('Number of Bursts', itU16),
wbStruct('Shoots Per Volleys', [
wbInteger('Min', itU16),
wbInteger('Max', itU16)
]),
wbStruct('Pause Between Volleys', [
wbFloat('Min'),
wbFloat('Max')
]),
wbByteArray('Unused', 4)
]),
wbStruct(PTD2, 'Target 2', [
wbInteger('Type', itS32, wbEnum([
{0} 'Specific reference',
{1} 'Object ID',
{2} 'Object Type',
{3} 'Linked Reference'
])),
wbUnion('Target', wbPxDTLocationDecider, [
wbFormIDCkNoReach('Reference', [ACHR, ACRE, REFR, PGRE, PMIS, PBEA, PLYR], True),
wbFormIDCkNoReach('Object ID', [ACTI, DOOR, STAT, FURN, CREA, SPEL, NPC_, LVLN, LVLC, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, FACT, FLST, CHIP, CMNY, CCRD, IMOD]),
wbInteger('Object Type', itU32, wbObjectTypeEnum),
wbByteArray('Unused', 4, cpIgnore)
]),
wbInteger('Count / Distance', itS32),
wbFloat('Unknown')
], cpNormal, False, nil, 3),
wbEmpty(PUID, 'Use Item Marker'),
wbEmpty(PKAM, 'Ambush Marker'),
wbStruct(PKDD, 'Dialogue Data', [
wbFloat('FOV'),
wbFormIDCk('Topic', [DIAL, NULL]),
wbInteger('Flags', itU32, wbFlags([
'No Headtracking',
'',
'',
'',
'',
'',
'',
'',
'Don''t Control Target Movement'
])),
wbByteArray('Unused', 4),
wbInteger('Dialogue Type', itU32, wbEnum([
'Conversation',
'Say To'
])),
wbByteArray('Unknown', 4)
], cpNormal, False, nil, 3),
wbStruct(PLD2, 'Location 2 (again??)', [
wbInteger('Type', itS32, wbEnum([
{0} 'Near reference',
{1} 'In cell',
{2} 'Near current location',
{3} 'Near editor location',
{4} 'Object ID',
{5} 'Object Type',
{6} 'Near linked reference',
{7} 'At package location'
])),
wbUnion('Location', wbPxDTLocationDecider, [
wbFormIDCkNoReach('Reference', [REFR, PGRE, PMIS, PBEA, ACHR, ACRE, PLYR], True),
wbFormIDCkNoReach('Cell', [CELL]),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbFormIDCkNoReach('Object ID', [ACTI, DOOR, STAT, FURN, CREA, SPEL, NPC_, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, CHIP, CMNY, CCRD, IMOD]),
wbInteger('Object Type', itU32, wbObjectTypeEnum),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore)
]),
wbInteger('Radius', itS32)
]),
wbRStruct('OnBegin', [
wbEmpty(POBA, 'OnBegin Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], [], cpNormal, True),
wbRStruct('OnEnd', [
wbEmpty(POEA, 'OnEnd Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], [], cpNormal, True),
wbRStruct('OnChange', [
wbEmpty(POCA, 'OnChange Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], [], cpNormal, True)
], False, nil, cpNormal, False, wbPACKAfterLoad);
wbRecord(QUST, 'Quest', [
wbEDIDReq,
wbSCRI,
wbFULL,
wbICON,
wbStruct(DATA, 'General', [
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Start game enabled',
{0x02} '',
{0x04} 'Allow repeated conversation topics',
{0x08} 'Allow repeated stages',
{0x10} 'Unknown 4'
])),
wbInteger('Priority', itU8),
wbByteArray('Unused', 2),
wbFloat('Quest Delay')
], cpNormal, True, nil, 3),
wbCTDAs,
wbRArrayS('Stages', wbRStructSK([0], 'Stage', [
wbInteger(INDX, 'Stage Index', itS16),
wbRArray('Log Entries', wbRStruct('Log Entry', [
wbInteger(QSDT, 'Stage Flags', itU8, wbFlags([
{0x01} 'Complete Quest',
{0x02} 'Fail Quest'
])),
wbCTDAs,
wbString(CNAM, 'Log Entry', 0, cpTranslate),
wbEmbeddedScriptReq,
wbFormIDCk(NAM0, 'Next Quest', [QUST])
], []))
], [])),
wbRArray('Objectives', wbRStruct('Objective', [
wbInteger(QOBJ, 'Objective Index', itS32),
wbString(NNAM, 'Description', 0, cpNormal, True),
wbRArray('Targets', wbRStruct('Target', [
wbStruct(QSTA, 'Target', [
wbFormIDCkNoReach('Target', [REFR, PGRE, PMIS, PBEA, ACRE, ACHR], True),
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Compass Marker Ignores Locks'
])),
wbByteArray('Unused', 3)
]),
wbCTDAs
], []))
], []))
]);
wbHeadPartIndexEnum := wbEnum([
'Head',
'Ears',
'Mouth',
'Teeth Lower',
'Teeth Upper',
'Tongue',
'Left Eye',
'Right Eye'
]);
wbBodyPartIndexEnum := wbEnum([
'Upper Body',
'Left Hand',
'Right Hand',
'Upper Body Texture'
]);
wbRecord(RACE, 'Race', [
wbEDIDReq,
wbFULLReq,
wbDESCReq,
wbXNAMs,
wbStruct(DATA, '', [
wbArrayS('Skill Boosts', wbStructSK([0], 'Skill Boost', [
wbInteger('Skill', itS8, wbActorValueEnum),
wbInteger('Boost', itS8)
]), 7),
wbByteArray('Unused', 2),
wbFloat('Male Height'),
wbFloat('Female Height'),
wbFloat('Male Weight'),
wbFloat('Female Weight'),
wbInteger('Flags', itU32, wbFlags([
'Playable',
'',
'Child'
]))
], cpNormal, True),
wbFormIDCk(ONAM, 'Older', [RACE]),
wbFormIDCk(YNAM, 'Younger', [RACE]),
wbEmpty(NAM2, 'Unknown Marker', cpNormal, True),
wbArray(VTCK, 'Voices', wbFormIDCk('Voice', [VTYP]), ['Male', 'Female'], cpNormal, True),
wbArray(DNAM, 'Default Hair Styles', wbFormIDCk('Default Hair Style', [HAIR, NULL]), ['Male', 'Female'], cpNormal, True),
wbArray(CNAM, 'Default Hair Colors', wbInteger('Default Hair Color', itU8, wbEnum([
'Bleached',
'Brown',
'Chocolate',
'Platinum',
'Cornsilk',
'Suede',
'Pecan',
'Auburn',
'Ginger',
'Honey',
'Gold',
'Rosewood',
'Black',
'Chestnut',
'Steel',
'Champagne'
])), ['Male', 'Female'], cpNormal, True),
wbFloat(PNAM, 'FaceGen - Main clamp', cpNormal, True),
wbFloat(UNAM, 'FaceGen - Face clamp', cpNormal, True),
wbByteArray(ATTR, 'Unused', 0, cpNormal, True),
wbRStruct('Head Data', [
wbEmpty(NAM0, 'Head Data Marker', cpNormal, True),
wbRStruct('Male Head Data', [
wbEmpty(MNAM, 'Male Data Marker', cpNormal, True),
wbRArrayS('Parts', wbRStructSK([0], 'Part', [
wbInteger(INDX, 'Index', itU32, wbHeadPartIndexEnum),
wbMODLReq,
wbICON
], [], cpNormal, False, nil, False, nil, wbHeadPartsAfterSet), cpNormal, True)
], [], cpNormal, True),
wbRStruct('Female Head Data', [
wbEmpty(FNAM, 'Female Data Marker', cpNormal, True),
wbRArrayS('Parts', wbRStructSK([0], 'Part', [
wbInteger(INDX, 'Index', itU32, wbHeadPartIndexEnum),
wbMODLReq,
wbICON
], [], cpNormal, False, nil, False, nil, wbHeadPartsAfterSet), cpNormal, True)
], [], cpNormal, True)
], [], cpNormal, True),
wbRStruct('Body Data', [
wbEmpty(NAM1, 'Body Data Marker', cpNormal, True),
wbRStruct('Male Body Data', [
wbEmpty(MNAM, 'Male Data Marker'),
wbRArrayS('Parts', wbRStructSK([0], 'Part', [
wbInteger(INDX, 'Index', itU32, wbBodyPartIndexEnum),
wbICON,
wbMODLReq
], []), cpNormal, True)
], [], cpNormal, True),
wbRStruct('Female Body Data', [
wbEmpty(FNAM, 'Female Data Marker', cpNormal, True),
wbRArrayS('Parts', wbRStructSK([0], 'Part', [
wbInteger(INDX, 'Index', itU32, wbBodyPartIndexEnum),
wbICON,
wbMODLReq
], []), cpNormal, True)
], [], cpNormal, True)
], [], cpNormal, True),
wbArrayS(HNAM, 'Hairs', wbFormIDCk('Hair', [HAIR]), 0, cpNormal, True),
wbArrayS(ENAM, 'Eyes', wbFormIDCk('Eye', [EYES]), 0, cpNormal, True),
wbRStruct('FaceGen Data', [
wbRStruct('Male FaceGen Data', [
wbEmpty(MNAM, 'Male Data Marker', cpNormal, True),
wbFaceGen,
wbInteger(SNAM, 'Unknown', itU16, nil, cpNormal, True)
], [], cpNormal, True),
wbRStruct('Female FaceGen Data', [
wbEmpty(FNAM, 'Female Data Marker', cpNormal, True),
wbFaceGen,
wbInteger(SNAM, 'Unknown', itU16, nil, cpNormal, True) // will effectivly overwrite the SNAM from the male :)
], [], cpNormal, True)
], [], cpNormal, True)
]);
wbRecord(REFR, 'Placed Object', [
wbEDID,
{
wbStruct(RCLR, 'Linked Reference Color (Old Format?)', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
], cpIgnore),}
wbByteArray(RCLR, 'Unused', 0, cpIgnore),
wbFormIDCk(NAME, 'Base', [TREE, SOUN, ACTI, DOOR, STAT, FURN, CONT, ARMO, AMMO, LVLN, LVLC,
MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS, ASPC, IDLM, ARMA, CHIP,
MSTT, NOTE, PWAT, SCOL, TACT, TERM, TXST, CCRD, IMOD, CMNY], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
{--- ?? ---}
wbXRGD,
wbXRGB,
{--- Primitive ---}
wbStruct(XPRM, 'Primitive', [
wbStruct('Bounds', [
wbFloat('X', cpNormal, True, 2, 4),
wbFloat('Y', cpNormal, True, 2, 4),
wbFloat('Z', cpNormal, True, 2, 4)
]),
wbStruct('Color', [
{84} wbFloat('Red', cpNormal, False, 255, 0),
{88} wbFloat('Green', cpNormal, False, 255, 0),
{92} wbFloat('Blue', cpNormal, False, 255, 0)
]),
wbFloat('Unknown'),
wbInteger('Type', itU32, wbEnum([
'None',
'Box',
'Sphere',
'Portal Box'
]))
]),
wbInteger(XTRI, 'Collision Layer', itU32, wbEnum([
'Unidentified',
'Static',
'AnimStatic',
'Transparent',
'Clutter',
'Weapon',
'Projectile',
'Spell',
'Biped',
'Trees',
'Props',
'Water',
'Trigger',
'Terrain',
'Trap',
'Non Collidable',
'Cloud Trap',
'Ground',
'Portal',
'Debris Small',
'Debris Large',
'Acustic Space',
'Actor Zone',
'Projectile Zone',
'Gas Trap',
'Shell Casing',
'Transparent Small',
'Invisible Wall',
'Transparent Small Anim',
'Dead Bip',
'Char Controller',
'Avoid Box',
'Collision Box',
'Camera Sphere',
'Door Detection',
'Camera Pick',
'Item Pick',
'Line Of Sight',
'Path Pick',
'Custom Pick 1',
'Custom Pick 2',
'Spell Explosion',
'Dropping Pick'
])),
wbEmpty(XMBP, 'MultiBound Primitive Marker'),
{--- Bound Contents ---}
{--- Bound Data ---}
wbStruct(XMBO, 'Bound Half Extents', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
{--- Teleport ---}
wbStruct(XTEL, 'Teleport Destination', [
wbFormIDCk('Door', [REFR], True),
wbPosRot,
wbInteger('Flags', itU32, wbFlags([
'No Alarm'
]))
]),
{--- Map Data ---}
wbRStruct('Map Marker', [
wbEmpty(XMRK, 'Map Marker Data'),
wbInteger(FNAM, 'Flags', itU8, wbFlags([
{0x01} 'Visible',
{0x02} 'Can Travel To',
{0x04} '"Show All" Hidden'
]), cpNormal, True),
wbFULLReq,
wbStruct(TNAM, '', [
wbInteger('Type', itU8, wbEnum([
'None',
'City',
'Settlement',
'Encampment',
'Natural Landmark',
'Cave',
'Factory',
'Monument',
'Military',
'Office',
'Town Ruins',
'Urban Ruins',
'Sewer Ruins',
'Metro',
'Vault'
])),
wbByteArray('Unused', 1)
], cpNormal, True),
wbFormIDCk(WMI1, 'Reputation', [REPU])
], []),
{--- Audio Data ---}
wbRStruct('Audio Data', [
wbEmpty(MMRK, 'Audio Marker'),
wbUnknown(FULL),
wbFormIDCk(CNAM, 'Audio Location', [ALOC]),
wbInteger(BNAM, 'Flags', itU32, wbFlags(['Use Controller Values'])),
wbFloat(MNAM, 'Layer 2 Trigger %', cpNormal, True, 100),
wbFloat(NNAM, 'Layer 3 Trigger %', cpNormal, True, 100)
], []),
wbInteger(XSRF, 'Special Rendering Flags', itU32, wbFlags([
'Unknown 0',
'Imposter',
'Use Full Shader in LOD'
])),
wbByteArray(XSRD, 'Special Rendering Data', 4),
{--- X Target Data ---}
wbFormIDCk(XTRG, 'Target', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA], True),
{--- Leveled Actor ----}
wbXLCM,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], []),
{--- Radio ---}
wbStruct(XRDO, 'Radio Data', [
wbFloat('Range Radius'),
wbInteger('Broadcast Range Type', itU32, wbEnum([
'Radius',
'Everywhere',
'Worldspace and Linked Interiors',
'Linked Interiors',
'Current Cell Only'
])),
wbFloat('Static Percentage'),
wbFormIDCkNoReach('Position Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, NULL])
]),
{--- Ownership ---}
wbRStruct('Ownership', [
wbXOWN,
wbInteger(XRNK, 'Faction rank', itS32)
], [XCMT, XCMO]),
{--- Lock ---}
wbStruct(XLOC, 'Lock Data', [
wbInteger('Level', itU8),
wbByteArray('Unused', 3),
wbFormIDCkNoReach('Key', [KEYM, NULL]),
wbInteger('Flags', itU8, wbFlags(['', '', 'Leveled Lock'])),
wbByteArray('Unused', 3),
wbByteArray('Unknown', 8)
], cpNormal, False, nil, 5),
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbFloat(XHLP, 'Health'),
wbFloat(XRAD, 'Radiation'),
wbFloat(XCHG, 'Charge'),
wbRStruct('Ammo', [
wbFormIDCk(XAMT, 'Type', [AMMO], False, cpNormal, True),
wbInteger(XAMC, 'Count', itS32, nil, cpNormal, True)
], []),
{--- Reflected By / Refracted By ---}
wbRArrayS('Reflected/Refracted By',
wbStructSK(XPWR, [0], 'Water', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Type', itU32, wbFlags([
'Reflection',
'Refraction'
]))
])
),
{--- Lit Water ---}
wbRArrayS('Lit Water',
wbFormIDCk(XLTW, 'Water', [REFR])
),
{--- Decals ---}
wbRArrayS('Linked Decals',
wbStructSK(XDCR, [0], 'Decal', [
wbFormIDCk('Reference', [REFR]),
wbUnknown
])
),
{--- Linked Ref ---}
wbFormIDCk(XLKR, 'Linked Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbStruct(XCLP, 'Linked Reference Color', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbFloat('Delay')
])
)
], []),
wbString(XATO, 'Activation Prompt'),
{--- Enable Parent ---}
wbXESP,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Flags ---}
wbInteger(XACT, 'Action Flag', itU32, wbFlags([
'Use Default',
'Activate',
'Open',
'Open by Default'
])),
wbEmpty(ONAM, 'Open by Default'),
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- Generated Data ---}
wbStruct(XNDP, 'Navigation Door Link', [
wbFormIDCk('Navigation Mesh', [NAVM]),
wbInteger('Teleport Marker Triangle', itS16, wbREFRNavmeshTriangleToStr, wbStringToInt),
wbByteArray('Unused', 2)
]),
wbArray(XPOD, 'Portal Data', wbFormIDCk('Room', [REFR, NULL]), 2),
wbStruct(XPTL, 'Portal Data', [
wbStruct('Size', [
wbFloat('Width', cpNormal, False, 2),
wbFloat('Height', cpNormal, False, 2)
]),
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation (Quaternion?)', [
wbFloat('q1'),
wbFloat('q2'),
wbFloat('q3'),
wbFloat('q4')
])
]),
wbInteger(XSED, 'SpeedTree Seed', itU8),
wbRStruct('Room Data', [
wbStruct(XRMR, 'Header', [
wbInteger('Linked Rooms Count', itU16),
wbByteArray('Unknown', 2)
]),
wbRArrayS('Linked Rooms',
wbFormIDCk(XLRM, 'Linked Room', [REFR])
)
], []),
wbStruct(XOCP, 'Occlusion Plane Data', [
wbStruct('Size', [
wbFloat('Width', cpNormal, False, 2),
wbFloat('Height', cpNormal, False, 2)
]),
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation (Quaternion?)', [
wbFloat('q1'),
wbFloat('q2'),
wbFloat('q3'),
wbFloat('q4')
])
]),
wbArray(XORD, 'Linked Occlusion Planes', wbFormIDCk('Plane', [REFR, NULL]), [
'Right',
'Left',
'Bottom',
'Top'
]),
wbXLOD,
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot
], True, wbPlacedAddInfo, cpNormal, False, wbREFRAfterLoad);
wbRecord(REGN, 'Region', [
wbEDID,
wbICON,
wbStruct(RCLR, 'Map Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
], cpNormal, True),
wbFormIDCkNoReach(WNAM, 'Worldspace', [WRLD]),
wbRArray('Region Areas', wbRStruct('Region Area', [
wbInteger(RPLI, 'Edge Fall-off', itU32),
wbArray(RPLD, 'Region Point List Data', wbStruct('Point', [
wbFloat('X'),
wbFloat('Y')
]), 0, wbRPLDAfterLoad)
], [])),
wbRArrayS('Region Data Entries', wbRStructSK([0], 'Region Data Entry', [
{always starts with an RDAT}
wbStructSK(RDAT, [0], 'Data Header', [
wbInteger('Type', itU32, wbEnum([
{0}'',
{1}'',
{2}'Objects',
{3}'Weather',
{4}'Map',
{5}'Land',
{6}'Grass',
{7}'Sound',
{8}'Imposter',
{9}''
])),
wbInteger('Flags', itU8, wbFlags([
'Override'
])),
wbInteger('Priority', itU8),
wbByteArray('Unused')
], cpNormal, True),
{followed by one of these: }
{--- Objects ---}
wbArray(RDOT, 'Objects', wbStruct('Object', [
wbFormIDCk('Object', [TREE, STAT, LTEX]),
wbInteger('Parent Index', itU16, wbHideFFFF),
wbByteArray('Unused', 2),
wbFloat('Density'),
wbInteger('Clustering', itU8),
wbInteger('Min Slope', itU8),
wbInteger('Max Slope', itU8),
wbInteger('Flags', itU8, wbFlags([
{0}'Conform to slope',
{1}'Paint Vertices',
{2}'Size Variance +/-',
{3}'X +/-',
{4}'Y +/-',
{5}'Z +/-',
{6}'Tree',
{7}'Huge Rock'
])),
wbInteger('Radius wrt Parent', itU16),
wbInteger('Radius', itU16),
wbFloat('Min Height'),
wbFloat('Max Height'),
wbFloat('Sink'),
wbFloat('Sink Variance'),
wbFloat('Size Variance'),
wbStruct('Angle Variance', [
wbInteger('X', itU16),
wbInteger('Y', itU16),
wbInteger('Z', itU16)
]),
wbByteArray('Unused', 2),
wbByteArray('Unknown', 4)
]), 0, nil, nil, cpNormal, False, wbREGNObjectsDontShow),
{--- Map ---}
wbString(RDMP, 'Map Name', 0, cpTranslate, False, wbREGNMapDontShow),
{--- Grass ---}
wbArrayS(RDGS, 'Grasses', wbStructSK([0], 'Grass', [
wbFormIDCk('Grass', [GRAS]),
wbByteArray('Unknown',4)
]), 0, cpNormal, False, nil, nil, wbREGNGrassDontShow),
{--- Sound ---}
wbInteger(RDMD, 'Music Type', itU32, wbMusicEnum, cpIgnore, False, False, wbNeverShow),
wbFormIDCk(RDMO, 'Music', [MUSC], False, cpNormal, False, wbREGNSoundDontShow),
wbFormIDCk(RDSI, 'Incidental MediaSet', [MSET], False, cpNormal, False, wbREGNSoundDontShow),
wbRArray('Battle MediaSets', wbFormIDCk(RDSB, 'Battle MediaSet', [MSET]), cpNormal, False, nil, nil, wbREGNSoundDontShow),
wbArrayS(RDSD, 'Sounds', wbStructSK([0], 'Sound', [
wbFormIDCk('Sound', [SOUN]),
wbInteger('Flags', itU32, wbFlags([
'Pleasant',
'Cloudy',
'Rainy',
'Snowy'
])),
wbInteger('Chance', itU32, wbScaledInt4ToStr, wbScaledInt4ToInt)
]), 0, cpNormal, False, nil, nil, wbREGNSoundDontShow),
{--- Weather ---}
wbArrayS(RDWT, 'Weather Types', wbStructSK([0], 'Weather Type', [
wbFormIDCk('Weather', [WTHR]),
wbInteger('Chance', itU32),
wbFormIDCk('Global', [GLOB, NULL])
]), 0, cpNormal, False, nil, nil, wbREGNWeatherDontShow),
{--- Imposter ---}
wbArrayS(RDID, 'Imposters', wbFormIDCk('Imposter', [REFR]), 0, cpNormal, False, nil, nil, wbREGNImposterDontShow)
], []))
], True);
wbRecord(SOUN, 'Sound', [
wbEDIDReq,
wbOBNDReq,
wbString(FNAM, 'Sound Filename'),
wbInteger(RNAM, 'Random Chance %', itU8),
wbRUnion('Sound Data', [
wbStruct(SNDD, 'Sound Data', [
wbInteger('Minimum Attentuation Distance', itU8, wbMul(5)),
wbInteger('Maximum Attentuation Distance', itU8, wbMul(100)),
wbInteger('Frequency Adjustment %', itS8),
wbByteArray('Unused', 1),
wbInteger('Flags', itU32, wbFlags([
{0x0001} 'Random Frequency Shift',
{0x0002} 'Play At Random',
{0x0004} 'Environment Ignored',
{0x0008} 'Random Location',
{0x0010} 'Loop',
{0x0020} 'Menu Sound',
{0x0040} '2D',
{0x0080} '360 LFE',
{0x0100} 'Dialogue Sound',
{0x0200} 'Envelope Fast',
{0x0400} 'Envelope Slow',
{0x0800} '2D Radius',
{0x1000} 'Mute When Submerged',
{0x2000} 'Start at Random Position'
])),
wbInteger('Static attentuation cdB', itS16),
wbInteger('Stop time ', itU8),
wbInteger('Start time ', itU8),
wbArray('Attenuation Curve', wbInteger('Point', itS16), 5),
wbInteger('Reverb Attenuation Control', itS16),
wbInteger('Priority', itS32),
// wbByteArray('Unknown', 8)
wbInteger('x', itS32),
wbInteger('y', itS32)
], cpNormal, True),
wbStruct(SNDX, 'Sound Data', [
wbInteger('Minimum attentuation distance', itU8, wbMul(5)),
wbInteger('Maximum attentuation distance', itU8, wbMul(100)),
wbInteger('Frequency adjustment %', itS8),
wbByteArray('Unused', 1),
wbInteger('Flags', itU32, wbFlags([
{0x0001} 'Random Frequency Shift',
{0x0002} 'Play At Random',
{0x0004} 'Environment Ignored',
{0x0008} 'Random Location',
{0x0010} 'Loop',
{0x0020} 'Menu Sound',
{0x0040} '2D',
{0x0080} '360 LFE',
{0x0100} 'Dialogue Sound',
{0x0200} 'Envelope Fast',
{0x0400} 'Envelope Slow',
{0x0800} '2D Radius',
{0x1000} 'Mute When Submerged'
])),
wbInteger('Static attentuation cdB', itS16),
wbInteger('Stop time ', itU8),
wbInteger('Start time ', itU8)
], cpNormal, True)
], [], cpNormal, True),
wbArray(ANAM, 'Attenuation Curve', wbInteger('Point', itS16), 5, nil, nil, cpNormal, False, wbNeverShow),
wbInteger(GNAM, 'Reverb Attenuation Control', itS16, nil, cpNormal, False, False, wbNeverShow),
wbInteger(HNAM, 'Priority', itS32, nil, cpNormal, False, False, wbNeverShow)
], False, nil, cpNormal, False, wbSOUNAfterLoad);
wbRecord(SPEL, 'Actor Effect', [
wbEDIDReq,
wbFULL,
wbStruct(SPIT, '', [
wbInteger('Type', itU32, wbEnum([
{0} 'Actor Effect',
{1} 'Disease',
{2} 'Power',
{3} 'Lesser Power',
{4} 'Ability',
{5} 'Poison',
{6} '',
{7} '',
{8} '',
{9} '',
{10} 'Addiction'
])),
wbInteger('Cost (Unused)', itU32),
wbInteger('Level (Unused)', itU32, wbEnum([
{0} 'Unused'
])),
wbInteger('Flags', itU8, wbFlags([
{0x00000001} 'No Auto-Calc',
{0x00000002} 'Immune to Silence 1?',
{0x00000004} 'PC Start Effect',
{0x00000008} 'Immune to Silence 2?',
{0x00000010} 'Area Effect Ignores LOS',
{0x00000020} 'Script Effect Always Applies',
{0x00000040} 'Disable Absorb/Reflect',
{0x00000080} 'Force Touch Explode'
])),
wbByteArray('Unused', 3)
], cpNormal, True),
wbEffectsReq
]);
wbRecord(STAT, 'Static', [
wbEDIDReq,
wbOBNDReq,
wbMODL,
wbInteger(BRUS, 'Passthrough Sound', itS8, wbEnum([
'BushA',
'BushB',
'BushC',
'BushD',
'BushE',
'BushF',
'BushG',
'BushH',
'BushI',
'BushJ'
], [
-1, 'NONE'
])),
wbFormIDCk(RNAM, 'Sound - Looping/Random', [SOUN])
]);
wbRecord(TES4, 'Main File Header', [
wbStruct(HEDR, 'Header', [
wbFloat('Version'),
wbInteger('Number of Records', itU32),
wbInteger('Next Object ID', itU32)
], cpNormal, True),
wbByteArray(OFST, 'Unknown', 0, cpIgnore),
wbByteArray(DELE, 'Unknown', 0, cpIgnore),
wbString(CNAM, 'Author', 0, cpTranslate, True),
wbString(SNAM, 'Description', 0, cpTranslate),
wbRArray('Master Files', wbRStruct('Master File', [
wbString(MAST, 'Filename', 0, cpNormal, True),
wbByteArray(DATA, 'Unused', 8, cpIgnore, True)
], [ONAM])),
wbArray(ONAM, 'Overriden Forms', wbFormIDCk('Form', [REFR, ACHR, ACRE, PMIS, PBEA, PGRE, LAND, NAVM]), 0, nil, nil, cpNormal, False, wbTES4ONAMDontShow),
wbByteArray(SCRN, 'Screenshot')
], True, nil, cpNormal, True, wbRemoveOFST);
wbRecord(TREE, 'Tree', [
wbEDIDReq,
wbOBNDReq,
wbMODLReq,
wbICONReq,
wbArrayS(SNAM, 'SpeedTree Seeds', wbInteger('SpeedTree Seed', itU32), 0, cpNormal, True),
wbStruct(CNAM, 'Tree Data', [
wbFloat('Leaf Curvature'),
wbFloat('Minimum Leaf Angle'),
wbFloat('Maximum Leaf Angle'),
wbFloat('Branch Dimming Value'),
wbFloat('Leaf Dimming Value'),
wbInteger('Shadow Radius', itS32),
wbFloat('Rock Speed'),
wbFloat('Rustle Speed')
], cpNormal, True),
wbStruct(BNAM, 'Billboard Dimensions', [
wbFloat('Width'),
wbFloat('Height')
], cpNormal, True)
]);
end;
procedure DefineFNVf;
begin
wbRecord(WATR, 'Water', [
wbEDIDReq,
wbFULL,
wbString(NNAM, 'Noise Map', 0, cpNormal, True),
wbInteger(ANAM, 'Opacity', itU8, nil, cpNormal, True),
wbInteger(FNAM, 'Flags', itU8, wbFlags([
{0}'Causes Damage',
{1}'Reflective'
]), cpNormal, True),
wbString(MNAM, 'Material ID', 0, cpNormal, True),
wbFormIDCk(SNAM, 'Sound', [SOUN]),
wbFormIDCk(XNAM, 'Actor Effect', [SPEL]),
wbInteger(DATA, 'Damage', itU16, nil, cpNormal, True, True),
wbRUnion('Visual Data', [
wbStruct(DNAM, 'Visual Data', [
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Water Properties - Sun Power'),
wbFloat('Water Properties - Reflectivity Amount'),
wbFloat('Water Properties - Fresnel Amount'),
wbByteArray('Unused', 4),
wbFloat('Fog Properties - Above Water - Fog Distance - Near Plane'),
wbFloat('Fog Properties - Above Water - Fog Distance - Far Plane'),
wbStruct('Shallow Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Deep Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Reflection Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbByteArray('Unused', 4),
wbFloat('Rain Simulator - Force'),
wbFloat('Rain Simulator - Velocity'),
wbFloat('Rain Simulator - Falloff'),
wbFloat('Rain Simulator - Dampner'),
wbFloat('Displacement Simulator - Starting Size'),
wbFloat('Displacement Simulator - Force'),
wbFloat('Displacement Simulator - Velocity'),
wbFloat('Displacement Simulator - Falloff'),
wbFloat('Displacement Simulator - Dampner'),
wbFloat('Rain Simulator - Starting Size'),
wbFloat('Noise Properties - Normals - Noise Scale'),
wbFloat('Noise Properties - Noise Layer One - Wind Direction'),
wbFloat('Noise Properties - Noise Layer Two - Wind Direction'),
wbFloat('Noise Properties - Noise Layer Three - Wind Direction'),
wbFloat('Noise Properties - Noise Layer One - Wind Speed'),
wbFloat('Noise Properties - Noise Layer Two - Wind Speed'),
wbFloat('Noise Properties - Noise Layer Three - Wind Speed'),
wbFloat('Noise Properties - Normals - Depth Falloff Start'),
wbFloat('Noise Properties - Normals - Depth Falloff End'),
wbFloat('Fog Properties - Above Water - Fog Amount'),
wbFloat('Noise Properties - Normals - UV Scale'),
wbFloat('Fog Properties - Under Water - Fog Amount'),
wbFloat('Fog Properties - Under Water - Fog Distance - Near Plane'),
wbFloat('Fog Properties - Under Water - Fog Distance - Far Plane'),
wbFloat('Water Properties - Distortion Amount'),
wbFloat('Water Properties - Shininess'),
wbFloat('Water Properties - Reflection HDR Multiplier'),
wbFloat('Water Properties - Light Radius'),
wbFloat('Water Properties - Light Brightness'),
wbFloat('Noise Properties - Noise Layer One - UV Scale'),
wbFloat('Noise Properties - Noise Layer Two - UV Scale'),
wbFloat('Noise Properties - Noise Layer Three - UV Scale'),
wbFloat('Noise Properties - Noise Layer One - Amplitude Scale'),
wbFloat('Noise Properties - Noise Layer Two - Amplitude Scale'),
wbFloat('Noise Properties - Noise Layer Three - Amplitude Scale')
], cpNormal, True, nil, 46),
wbStruct(DATA, 'Visual Data', [
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Water Properties - Sun Power'),
wbFloat('Water Properties - Reflectivity Amount'),
wbFloat('Water Properties - Fresnel Amount'),
wbByteArray('Unused', 4),
wbFloat('Fog Properties - Above Water - Fog Distance - Near Plane'),
wbFloat('Fog Properties - Above Water - Fog Distance - Far Plane'),
wbStruct('Shallow Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Deep Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Reflection Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbByteArray('Unused', 4),
wbFloat('Rain Simulator - Force'),
wbFloat('Rain Simulator - Velocity'),
wbFloat('Rain Simulator - Falloff'),
wbFloat('Rain Simulator - Dampner'),
wbFloat('Displacement Simulator - Starting Size'),
wbFloat('Displacement Simulator - Force'),
wbFloat('Displacement Simulator - Velocity'),
wbFloat('Displacement Simulator - Falloff'),
wbFloat('Displacement Simulator - Dampner'),
wbFloat('Rain Simulator - Starting Size'),
wbFloat('Noise Properties - Normals - Noise Scale'),
wbFloat('Noise Properties - Noise Layer One - Wind Direction'),
wbFloat('Noise Properties - Noise Layer Two - Wind Direction'),
wbFloat('Noise Properties - Noise Layer Three - Wind Direction'),
wbFloat('Noise Properties - Noise Layer One - Wind Speed'),
wbFloat('Noise Properties - Noise Layer Two - Wind Speed'),
wbFloat('Noise Properties - Noise Layer Three - Wind Speed'),
wbFloat('Noise Properties - Normals - Depth Falloff Start'),
wbFloat('Noise Properties - Normals - Depth Falloff End'),
wbFloat('Fog Properties - Above Water - Fog Amount'),
wbFloat('Noise Properties - Normals - UV Scale'),
wbFloat('Fog Properties - Under Water - Fog Amount'),
wbFloat('Fog Properties - Under Water - Fog Distance - Near Plane'),
wbFloat('Fog Properties - Under Water - Fog Distance - Far Plane'),
wbFloat('Water Properties - Distortion Amount'),
wbFloat('Water Properties - Shininess'),
wbFloat('Water Properties - Reflection HDR Multiplier'),
wbFloat('Water Properties - Light Radius'),
wbFloat('Water Properties - Light Brightness'),
wbFloat('Noise Properties - Noise Layer One - UV Scale'),
wbFloat('Noise Properties - Noise Layer Two - UV Scale'),
wbFloat('Noise Properties - Noise Layer Three - UV Scale'),
wbEmpty('Noise Properties - Noise Layer One - Amplitude Scale'),
wbEmpty('Noise Properties - Noise Layer Two - Amplitude Scale'),
wbEmpty('Noise Properties - Noise Layer Three - Amplitude Scale'),
wbInteger('Damage (Old Format)', itU16)
], cpNormal, True)
], [], cpNormal, True),
wbStruct(GNAM, 'Related Waters (Unused)', [
wbFormIDCk('Daytime', [WATR, NULL]),
wbFormIDCk('Nighttime', [WATR, NULL]),
wbFormIDCk('Underwater', [WATR, NULL])
], cpNormal, True)
], False, nil, cpNormal, False, wbWATRAfterLoad);
wbRecord(WEAP, 'Weapon', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbSCRI,
wbEITM,
wbInteger(EAMT, 'Enchantment Charge Amount', itS16),
wbFormIDCkNoReach(NAM0, 'Ammo', [AMMO, FLST]),
wbDEST,
wbREPL,
wbETYPReq,
wbBIPL,
wbYNAM,
wbZNAM,
wbRStruct('Shell Casing Model', [
wbString(MOD2, 'Model Filename'),
wbByteArray(MO2T, 'Texture Files Hashes', 0, cpIgnore),
wbMO2S
], []),
wbRStruct('Scope Model', [
wbString(MOD3, 'Model Filename'),
wbByteArray(MO3T, 'Texture Files Hashes', 0, cpIgnore),
wbMO3S
], []),
wbFormIDCK(EFSD, 'Scope Effect', [EFSH]),
wbRStruct('World Model', [
wbString(MOD4, 'Model Filename'),
wbByteArray(MO4T, 'Texture Files Hashes', 0, cpIgnore),
wbMO4S
], []),
wbString(MWD1, 'Model - Mod 1'),
wbString(MWD2, 'Model - Mod 2'),
wbString(MWD3, 'Model - Mod 1 and 2'),
wbString(MWD4, 'Model - Mod 3'),
wbString(MWD5, 'Model - Mod 1 and 3'),
wbString(MWD6, 'Model - Mod 2 and 3'),
wbString(MWD7, 'Model - Mod 1, 2 and 3'),
{wbRStruct( 'Model with Mods', [
wbString(MWD1, 'Mod 1'),
wbString(MWD2, 'Mod 2'),
wbString(MWD3, 'Mod 1 and 2'),
wbString(MWD4, 'Mod 3'),
wbString(MWD5, 'Mod 1 and 3'),
wbString(MWD6, 'Mod 2 and 3'),
wbString(MWD7, 'Mod 1, 2 and 3')
], [], cpNormal, False, nil, True),}
wbString(VANM, 'VATS Attack Name'),
wbString(NNAM, 'Embedded Weapon Node'),
wbFormIDCk(INAM, 'Impact DataSet', [IPDS]),
wbFormIDCk(WNAM, '1st Person Model', [STAT]),
wbFormIDCk(WNM1, '1st Person Model - Mod 1', [STAT]),
wbFormIDCk(WNM2, '1st Person Model - Mod 2', [STAT]),
wbFormIDCk(WNM3, '1st Person Model - Mod 1 and 2', [STAT]),
wbFormIDCk(WNM4, '1st Person Model - Mod 3', [STAT]),
wbFormIDCk(WNM5, '1st Person Model - Mod 1 and 3', [STAT]),
wbFormIDCk(WNM6, '1st Person Model - Mod 2 and 3', [STAT]),
wbFormIDCk(WNM7, '1st Person Model - Mod 1, 2 and 3', [STAT]),
{wbRStruct('1st Person Models with Mods', [
wbFormIDCk(WNM1, 'Mod 1', [STAT]),
wbFormIDCk(WNM2, 'Mod 2', [STAT]),
wbFormIDCk(WNM3, 'Mod 1 and 2', [STAT]),
wbFormIDCk(WNM4, 'Mod 3', [STAT]),
wbFormIDCk(WNM5, 'Mod 1 and 3', [STAT]),
wbFormIDCk(WNM6, 'Mod 2 and 3', [STAT]),
wbFormIDCk(WNM7, 'Mod 1, 2 and 3', [STAT])
], [], cpNormal, False, nil, True),}
wbFormIDCk(WMI1, 'Weapon Mod 1', [IMOD]),
wbFormIDCk(WMI2, 'Weapon Mod 2', [IMOD]),
wbFormIDCk(WMI3, 'Weapon Mod 3', [IMOD]),
{wbRStruct('Weapon Mods', [
wbFormIDCk(WMI1, 'Mod 1', [IMOD]),
wbFormIDCk(WMI2, 'Mod 2', [IMOD]),
wbFormIDCk(WMI3, 'Mod 3', [IMOD])
], [], cpNormal, False, nil, True),}
wbRStruct('Sound - Gun', [
wbFormIDCk(SNAM, 'Shoot 3D', [SOUN]),
wbFormIDCk(SNAM, 'Shoot Dist', [SOUN])
], []),
//wbFormIDCk(SNAM, 'Sound - Gun - Shoot 3D', [SOUN]),
//wbFormIDCk(SNAM, 'Sound - Gun - Shoot Dist', [SOUN]),
wbFormIDCk(XNAM, 'Sound - Gun - Shoot 2D', [SOUN]),
wbFormIDCk(NAM7, 'Sound - Gun - Shoot 3D Looping', [SOUN]),
wbFormIDCk(TNAM, 'Sound - Melee - Swing / Gun - No Ammo', [SOUN]),
wbFormIDCk(NAM6, 'Sound - Block', [SOUN]),
wbFormIDCk(UNAM, 'Sound - Idle', [SOUN]),
wbFormIDCk(NAM9, 'Sound - Equip', [SOUN]),
wbFormIDCk(NAM8, 'Sound - Unequip', [SOUN]),
wbRStruct('Sound - Mod 1', [
wbFormIDCk(WMS1, 'Shoot 3D', [SOUN]),
wbFormIDCk(WMS1, 'Shoot Dist', [SOUN])
], []),
//wbFormIDCk(WMS1, 'Sound - Mod 1 - Shoot 3D', [SOUN]),
//wbFormIDCk(WMS1, 'Sound - Mod 1 - Shoot Dist', [SOUN]),
wbFormIDCk(WMS2, 'Sound - Mod 1 - Shoot 2D', [SOUN]),
wbStruct(DATA, '', [
wbInteger('Value', itS32),
wbInteger('Health', itS32),
wbFloat('Weight'),
wbInteger('Base Damage', itS16),
wbInteger('Clip Size', itU8)
], cpNormal, True),
wbStruct(DNAM, '', [
{00} wbInteger('Animation Type', itU32, wbWeaponAnimTypeEnum),
{04} wbFloat('Animation Multiplier'),
{08} wbFloat('Reach'),
{12} wbInteger('Flags 1', itU8, wbFlags([
'Ignores Normal Weapon Resistance',
'Is Automatic',
'Has Scope',
'Can''t Drop',
'Hide Backpack',
'Embedded Weapon',
'Don''t Use 1st Person IS Animations',
'Non-Playable'
])),
{13} wbInteger('Grip Animation', itU8, wbEnum([
], [
230, 'HandGrip1',
231, 'HandGrip2',
232, 'HandGrip3',
233, 'HandGrip4',
234, 'HandGrip5',
235, 'HandGrip6',
255, 'DEFAULT'
])),
{14} wbInteger('Ammo Use', itU8),
{15} wbInteger('Reload Animation', itU8, wbReloadAnimEnum),
{16} wbFloat('Min Spread'),
{20} wbFloat('Spread'),
{24} wbFloat('Unknown'),
{28} wbFloat('Sight FOV'),
{32} wbFloat,
{36} wbFormIDCk('Projectile', [PROJ, NULL]),
{40} wbInteger('Base VATS To-Hit Chance', itU8),
{41} wbInteger('Attack Animation', itU8, wbEnum([
], [
26, 'AttackLeft',
32, 'AttackRight',
38, 'Attack3',
44, 'Attack4',
50, 'Attack5',
56, 'Attack6',
62, 'Attack7',
68, 'Attack8',
144, 'Attack9',
74, 'AttackLoop',
80, 'AttackSpin',
86, 'AttackSpin2',
114, 'AttackThrow',
120, 'AttackThrow2',
126, 'AttackThrow3',
132, 'AttackThrow4',
138, 'AttackThrow5',
150, 'AttackThrow6',
156, 'AttackThrow7',
162, 'AttackThrow8',
102, 'PlaceMine',
108, 'PlaceMine2',
255, 'DEFAULT'
])),
{42} wbInteger('Projectile Count', itU8),
{43} wbInteger('Embedded Weapon - Actor Value', itU8, wbEnum([
{00} 'Perception',
{01} 'Endurance',
{02} 'Left Attack',
{03} 'Right Attack',
{04} 'Left Mobility',
{05} 'Right Mobilty',
{06} 'Brain'
])),
{44} wbFloat('Min Range'),
{48} wbFloat('Max Range'),
{52} wbInteger('On Hit', itU32, wbEnum([
'Normal formula behavior',
'Dismember Only',
'Explode Only',
'No Dismember/Explode'
])),
{56} wbInteger('Flags 2', itU32, wbFlags([
{0x00000001}'Player Only',
{0x00000002}'NPCs Use Ammo',
{0x00000004}'No Jam After Reload',
{0x00000008}'Override - Action Points',
{0x00000010}'Minor Crime',
{0x00000020}'Range - Fixed',
{0x00000040}'Not Used In Normal Combat',
{0x00000080}'Override - Damage to Weapon Mult',
{0x00000100}'Don''t Use 3rd Person IS Animations',
{0x00000200}'Short Burst',
{0x00000400}'Rumble Alternate',
{0x00000800}'Long Burst',
{0x00001000}'Scope has NightVision',
{0x00002000}'Scope from Mod'
])),
{60} wbFloat('Animation Attack Multiplier'),
{64} wbFloat('Fire Rate'),
{68} wbFloat('Override - Action Points'),
{72} wbFloat('Rumble - Left Motor Strength'),
{76} wbFloat('Rumble - Right Motor Strength'),
{80} wbFloat('Rumble - Duration'),
{84} wbFloat('Override - Damage to Weapon Mult'),
{88} wbFloat('Attack Shots/Sec'),
{92} wbFloat('Reload Time'),
{96} wbFloat('Jam Time'),
{100} wbFloat('Aim Arc'),
{104} wbInteger('Skill', itS32, wbActorValueEnum),
{108} wbInteger('Rumble - Pattern', itU32, wbEnum([
'Constant',
'Square',
'Triangle',
'Sawtooth'
])),
{112} wbFloat('Rumble - Wavelength'),
{116} wbFloat('Limb Dmg Mult'),
{120} wbInteger('Resist Type', itS32, wbActorValueEnum),
{124} wbFloat('Sight Usage'),
{128} wbFloat('Semi-Automatic Fire Delay Min'),
{132} wbFloat('Semi-Automatic Fire Delay Max'),
wbFloat,
wbInteger('Effect - Mod 1', itU32, wbModEffectEnum),
wbInteger('Effect - Mod 2', itU32, wbModEffectEnum),
wbInteger('Effect - Mod 3', itU32, wbModEffectEnum),
wbFloat('Value A - Mod 1'),
wbFloat('Value A - Mod 2'),
wbFloat('Value A - Mod 3'),
wbInteger('Power Attack Animation Override', itU32, wbEnum([
], [
0, '0?',
97, 'AttackCustom1Power',
98, 'AttackCustom2Power',
99, 'AttackCustom3Power',
100, 'AttackCustom4Power',
101, 'AttackCustom5Power',
255, 'DEFAULT'
])),
wbInteger('Strength Req', itU32),
wbByteArray('Unknown', 1),
wbInteger('Reload Animation - Mod', itU8, wbReloadAnimEnum),
wbByteArray('Unknown', 2),
wbFloat('Regen Rate'),
wbFloat('Kill Impulse'),
wbFloat('Value B - Mod 1'),
wbFloat('Value B - Mod 2'),
wbFloat('Value B - Mod 3'),
wbFloat('Impulse Dist'),
wbInteger('Skill Req', itU32)
], cpNormal, True, nil, 36),
wbStruct(CRDT, 'Critical Data', [
{00} wbInteger('Critical Damage', itU16),
{09} wbByteArray('Unused', 2),
{04} wbFloat('Crit % Mult'),
{08} wbInteger('Flags', itU8, wbFlags([
'On Death'
])),
{09} wbByteArray('Unused', 3),
{12} wbFormIDCk('Effect', [SPEL, NULL])
], cpNormal, True),
wbStruct(VATS, 'VATS', [
wbFormIDCk('Effect',[SPEL, NULL]),
wbFloat('Skill'),
wbFloat('Dam. Mult'),
wbFloat('AP'),
wbInteger('Silent', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Mod Required', itU8, wbEnum(['No', 'Yes'])),
wbByteArray('Unused', 2)
]),
wbInteger(VNAM, 'Sound Level', itU32, wbSoundLevelEnum, cpNormal, True)
], True, nil, cpNormal, False, wbWEAPAfterLoad);
if wbSimpleRecords then
wbRecord(WRLD, 'Worldspace', [
wbEDIDReq,
wbFULL,
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbRStruct('Parent', [
wbFormIDCk(WNAM, 'Worldspace', [WRLD]),
wbInteger(PNAM, 'Flags', itU16, wbFlags([
{0x00000001}'Use Land Data',
{0x00000002}'Use LOD Data',
{0x00000004}'Use Map Data',
{0x00000008}'Use Water Data',
{0x00000010}'Use Climate Data',
{0x00000020}'Use Image Space Data'
], True), cpNormal, True)
], []),
wbFormIDCk(CNAM, 'Climate', [CLMT]),
wbFormIDCk(NAM2, 'Water', [WATR]),
wbFormIDCk(NAM3, 'LOD Water Type', [WATR]),
wbFloat(NAM4, 'LOD Water Height'),
wbStruct(DNAM, 'Land Data', [
wbFloat('Default Land Height'),
wbFloat('Default Water Height')
]),
wbICON,
wbStruct(MNAM, 'Map Data', [
wbStruct('Usable Dimensions', [
wbInteger('X', itS32),
wbInteger('Y', itS32)
]),
wbStruct('Cell Coordinates', [
wbStruct('NW Cell', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
]),
wbStruct('SE Cell', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
])
])
]),
wbStruct(ONAM, 'World Map Offset Data', [
wbFloat('World Map Scale'),
wbFloat('Cell X Offset'),
wbFloat('Cell Y Offset')
], cpNormal, True),
wbFormIDCk(INAM, 'Image Space', [IMGS]),
wbInteger(DATA, 'Flags', itU8, wbFlags([ // LoadForm supports a DWord here, but only first byte would be used.
{0x01} 'Small World',
{0x02} 'Can''t Fast Travel',
{0x04} '',
{0x08} '',
{0x10} 'No LOD Water',
{0x20} 'No LOD Noise',
{0x40} 'Don''t Allow NPC Fall Damage',
{0x80} 'Needs Water Adjustment'
]), cpNormal, True),
wbRStruct('Object Bounds', [
wbStruct(NAM0, 'Min', [
wbFloat('X', cpNormal, False, 1/4096),
wbFloat('Y', cpNormal, False, 1/4096)
], cpIgnore, True),
wbStruct(NAM9, 'Max', [
wbFloat('X', cpNormal, False, 1/4096),
wbFloat('Y', cpNormal, False, 1/4096)
], cpIgnore, True)
], []),
wbFormIDCk(ZNAM, 'Music', [MUSC]),
wbString(NNAM, 'Canopy Shadow', 0, cpNormal, True),
wbString(XNAM, 'Water Noise Texture', 0, cpNormal, True),
wbRArrayS('Swapped Impacts', wbStructExSK(IMPS, [0, 1], [2], 'Swapped Impact', [
wbInteger('Material Type', itU32, wbImpactMaterialTypeEnum),
wbFormIDCkNoReach('Old', [IPCT]),
wbFormIDCk('New', [IPCT, NULL])
])),
wbArray(IMPF, 'Footstep Materials', wbString('Unknown', 30), [
'ConcSolid',
'ConcBroken',
'MetalSolid',
'MetalHollow',
'MetalSheet',
'Wood',
'Sand',
'Dirt',
'Grass',
'Water'
]),
wbByteArray(OFST, 'Offset Data')
], False, nil, cpNormal, False, wbRemoveOFST)
else
wbRecord(WRLD, 'Worldspace', [
wbEDIDReq,
wbFULL,
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbRStruct('Parent', [
wbFormIDCk(WNAM, 'Worldspace', [WRLD]),
wbInteger(PNAM, 'Flags', itU16, wbFlags([
{0x00000001}'Use Land Data',
{0x00000002}'Use LOD Data',
{0x00000004}'Use Map Data',
{0x00000008}'Use Water Data',
{0x00000010}'Use Climate Data',
{0x00000020}'Use Image Space Data' // in order to use this "Image Space" needs to be NULL.
// Other parent flags are checked before the form value.
], True), cpNormal, True)
], []),
wbFormIDCk(CNAM, 'Climate', [CLMT]),
wbFormIDCk(NAM2, 'Water', [WATR]),
wbFormIDCk(NAM3, 'LOD Water Type', [WATR]),
wbFloat(NAM4, 'LOD Water Height'),
wbStruct(DNAM, 'Land Data', [
wbFloat('Default Land Height'),
wbFloat('Default Water Height')
]),
wbICON,
wbStruct(MNAM, 'Map Data', [
wbStruct('Usable Dimensions', [
wbInteger('X', itS32),
wbInteger('Y', itS32)
]),
wbStruct('Cell Coordinates', [
wbStruct('NW Cell', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
]),
wbStruct('SE Cell', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
])
])
]),
wbStruct(ONAM, 'World Map Offset Data', [
wbFloat('World Map Scale'),
wbFloat('Cell X Offset'),
wbFloat('Cell Y Offset')
], cpNormal, True),
wbFormIDCk(INAM, 'Image Space', [IMGS]),
wbInteger(DATA, 'Flags', itU8, wbFlags([ // LoadForm supports a DWord here, but only first byte would be used.
{0x01} 'Small World',
{0x02} 'Can''t Fast Travel',
{0x04} '',
{0x08} '',
{0x10} 'No LOD Water',
{0x20} 'No LOD Noise',
{0x40} 'Don''t Allow NPC Fall Damage',
{0x80} 'Needs Water Adjustment'
]), cpNormal, True),
wbRStruct('Object Bounds', [
wbStruct(NAM0, 'Min', [
wbFloat('X', cpNormal, False, 1/4096),
wbFloat('Y', cpNormal, False, 1/4096)
], cpIgnore, True),
wbStruct(NAM9, 'Max', [
wbFloat('X', cpNormal, False, 1/4096),
wbFloat('Y', cpNormal, False, 1/4096)
], cpIgnore, True)
], []),
wbFormIDCk(ZNAM, 'Music', [MUSC]),
wbString(NNAM, 'Canopy Shadow', 0, cpNormal, True),
wbString(XNAM, 'Water Noise Texture', 0, cpNormal, True),
wbRArrayS('Swapped Impacts', wbStructExSK(IMPS, [0, 1], [2], 'Swapped Impact', [
wbInteger('Material Type', itU32, wbImpactMaterialTypeEnum),
wbFormIDCkNoReach('Old', [IPCT]),
wbFormIDCk('New', [IPCT, NULL])
])),
wbArray(IMPF, 'Footstep Materials', wbString('Unknown', 30), [
'ConcSolid',
'ConcBroken',
'MetalSolid',
'MetalHollow',
'MetalSheet',
'Wood',
'Sand',
'Dirt',
'Grass',
'Water'
]),
wbArray(OFST, 'Offset Data', wbArray('Rows', wbInteger('Offset', itU32), wbOffsetDataColsCounter), 0) // cannot be saved by GECK
], False, nil, cpNormal, False, wbRemoveOFST);
wbRecord(WTHR, 'Weather', [
wbEDIDReq,
wbFormIDCk(_0_IAD, 'Sunrise Image Space Modifier', [IMAD]),
wbFormIDCk(_1_IAD, 'Day Image Space Modifier', [IMAD]),
wbFormIDCk(_2_IAD, 'Sunset Image Space Modifier', [IMAD]),
wbFormIDCk(_3_IAD, 'Night Image Space Modifier', [IMAD]),
wbFormIDCk(_4_IAD, 'Unknown', [IMAD]),
wbFormIDCk(_5_IAD, 'Unknown', [IMAD]),
wbString(DNAM, 'Cloud Textures - Layer 0', 0, cpNormal, True),
wbString(CNAM, 'Cloud Textures - Layer 1', 0, cpNormal, True),
wbString(ANAM, 'Cloud Textures - Layer 2', 0, cpNormal, True),
wbString(BNAM, 'Cloud Textures - Layer 3', 0, cpNormal, True),
wbMODL,
wbByteArray(LNAM, 'Unknown', 4, cpNormal, True),
wbArray(ONAM, 'Cloud Speed', wbInteger('Layer', itU8{, wbDiv(2550)}), 4, nil, nil, cpNormal, True),
wbArray(PNAM, 'Cloud Layer Colors',
wbArray('Layer',
wbStruct('Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
['Sunrise', 'Day', 'Sunset', 'Night', 'High Noon', 'Midnight']
),
4),
wbArray(NAM0, 'Colors by Types/Times',
wbArray('Type',
wbStruct('Time', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
['Sunrise', 'Day', 'Sunset', 'Night', 'High Noon', 'Midnight']
),
['Sky-Upper','Fog','Unused','Ambient','Sunlight','Sun','Stars','Sky-Lower','Horizon','Unused']
, cpNormal, True),
wbStruct(FNAM, 'Fog Distance', [
wbFloat('Day - Near'),
wbFloat('Day - Far'),
wbFloat('Night - Near'),
wbFloat('Night - Far'),
wbFloat('Day - Power'),
wbFloat('Night - Fower')
], cpNormal, True),
wbByteArray(INAM, 'Unused', 304, cpIgnore, True),
wbStruct(DATA, '', [
wbInteger('Wind Speed', itU8),
wbInteger('Cloud Speed (Lower)', itU8),
wbInteger('Cloud Speed (Upper)', itU8),
wbInteger('Trans Delta', itU8),
wbInteger('Sun Glare', itU8),
wbInteger('Sun Damage', itU8),
wbInteger('Precipitation - Begin Fade In', itU8),
wbInteger('Precipitation - End Fade Out', itU8),
wbInteger('Thunder/Lightning - Begin Fade In', itU8),
wbInteger('Thunder/Lightning - End Fade Out', itU8),
wbInteger('Thunder/Lightning - Frequency', itU8),
wbInteger('Weather Classification', itU8, wbWthrDataClassification),
wbStruct('Lightning Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8)
])
], cpNormal, True),
wbRArray('Sounds', wbStruct(SNAM, 'Sound', [
wbFormIDCk('Sound', [SOUN]),
wbInteger('Type', itU32, wbEnum([
{0}'Default',
{1}'Precip',
{2}'Wind',
{3}'Thunder'
]))
]))
]);
wbRecord(IMOD, 'Item Mod', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbSCRI,
wbDESC,
wbDEST,
wbYNAM,
wbZNAM,
wbStruct(DATA, 'Data', [
wbInteger('Value', itU32),
wbFloat('Weight')
])
]);
wbRecord(ALOC, 'Media Location Controller', [
wbEDIDReq,
wbFULL,
wbByteArray(NAM1, 'Flags and Enums, messily combined'),
wbUnknown(NAM2),
wbUnknown(NAM3),
wbFloat(NAM4, 'Location Delay'),
wbInteger(NAM5, 'Day Start', itU32, wbAlocTime),
wbInteger(NAM6, 'Night Start', itU32, wbAlocTime),
wbFloat(NAM7, 'Retrigger Delay'),
wbRArrayS('Neutral Sets',
wbFormIDCk(HNAM, 'Media Set', [MSET])
),
wbRArrayS('Ally Sets',
wbFormIDCk(ZNAM, 'Media Set', [MSET])
),
wbRArrayS('Friend Sets',
wbFormIDCk(XNAM, 'Media Set', [MSET])
),
wbRArrayS('Enemy Sets',
wbFormIDCk(YNAM, 'Media Set', [MSET])
),
wbRArrayS('Location Sets',
wbFormIDCk(LNAM, 'Media Set', [MSET])
),
wbRArrayS('Battle Sets',
wbFormIDCk(GNAM, 'Media Set', [MSET])
),
wbFormIDCk(RNAM, 'Conditional Faction', [FACT]),
wbUnknown(FNAM)
]);
wbRecord(MSET, 'Media Set', [
wbEDIDReq,
wbFULL,
wbInteger(NAM1, 'Type', itU32, wbEnum([
'Battle Set',
'Location Set',
'Dungeon Set',
'Incidental Set'
], [
-1, 'No Set'
])),
wbString(NAM2, 'Loop (B) / Battle (D) / Day Outer (L)'),
wbString(NAM3, 'Explore (D) / Day Middle (L)'),
wbString(NAM4, 'Suspense (D) / Day Inner (L)'),
wbString(NAM5, 'Night Outer (L)'),
wbString(NAM6, 'Night Middle (L)'),
wbString(NAM7, 'Night Inner (L)'),
wbFloat(NAM8, 'Loop dB (B) / Battle dB (D) / Day Outer dB (L)'),
wbFloat(NAM9, 'Explore dB (D) / Day Middle dB (L)'),
wbFloat(NAM0, 'Suspense dB (D) / Day Inner dB (L)'),
wbFloat(ANAM, 'Night Outer dB (L)'),
wbFloat(BNAM, 'Night Middle dB (L)'),
wbFloat(CNAM, 'Night Inner dB (L)'),
wbFloat(JNAM, 'Day Outer Boundary % (L)'),
wbFloat(KNAM, 'Day Middle Boundary % (L)'),
wbFloat(LNAM, 'Day Inner Boundary % (L)'),
wbFloat(MNAM, 'Night Outer Boundary % (L)'),
wbFloat(NNAM, 'Night Middle Boundary % (L)'),
wbFloat(ONAM, 'Night Inner Boundary % (L)'),
wbInteger(PNAM, 'Enable Flags', itU8, wbFlags([
{0x01} 'Day Outer',
{0x02} 'Day Middle',
{0x04} 'Day Inner',
{0x08} 'Night Outer',
{0x10} 'Night Middle',
{0x20} 'Night Inner'
])),
wbFloat(DNAM, 'Wait Time (B) / Minimum Time On (D,L) / Daytime Min (I)'),
wbFloat(ENAM, 'Loop Fade Out (B) / Looping/Random Crossfade Overlap (D,L) / Nighttime Min (I)'),
wbFloat(FNAM, 'Recovery Time (B) / Layer Crossfade Time (D,L) / Daytime Max (I)'),
wbFloat(GNAM, 'Nighttime Max (I)'),
wbFormIDCk(HNAM, 'Intro (B,D) / Daytime (I)', [SOUN]),
wbFormIDCk(INAM, 'Outro (B,D) / Nighttime (I)', [SOUN]),
wbUnknown(DATA)
]);
wbRecord(AMEF, 'Ammo Effect', [
wbEDIDReq,
wbFULL,
wbStruct(DATA, 'Data', [
wbInteger('Type', itU32, wbEnum([
'Damage Mod',
'DR Mod',
'DT Mod',
'Spread Mod',
'Weapon Condition Mod',
'Fatigue Mod'
])),
wbInteger('Operation', itU32, wbEnum([
'Add',
'Multiply',
'Subtract'
])),
wbFloat('Value')
])
]);
wbRecord(CCRD, 'Caravan Card', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbSCRI,
wbYNAM,
wbZNAM,
wbRStruct('High Res Image', [
wbString(TX00, 'Face'),
wbString(TX01, 'Back')
], []),
wbRStruct('Card', [
wbInteger(INTV, 'Suit', itU32, wbEnum([
'',
'Hearts',
'Spades',
'Diamonds',
'Clubs',
'Joker'
])),
wbInteger(INTV, 'Value', itU32, wbEnum([
'',
'Ace',
'2',
'3',
'4',
'5',
'6',
'7',
'8',
'9',
'10',
'',
'Jack',
'Queen',
'King',
'Joker'
]))
], []),
wbInteger(DATA, 'Value', itU32)
]);
wbRecord(CDCK, 'Caravan Deck', [
wbEDIDReq,
wbFULL,
wbRArrayS('Cards',
wbFormIDCk(CARD, 'Card', [CCRD])
),
wbInteger(DATA, 'Count (broken)', itU32)
]);
wbRecord(CHAL, 'Challenge', [
wbEDIDReq,
wbFULL,
wbICON,
wbSCRI,
wbDESC,
wbStruct(DATA, 'Data', [
wbInteger('Type', itU32, wbEnum([
{00} 'Kill from a Form List',
{01} 'Kill a specific FormID',
{02} 'Kill any in a category',
{03} 'Hit an Enemy',
{04} 'Discover a Map Marker',
{05} 'Use an Item',
{06} 'Acquire an Item',
{07} 'Use a Skill',
{08} 'Do Damage',
{09} 'Use an Item from a List',
{10} 'Acquire an Item from a List',
{11} 'Miscellaneous Stat',
{12} 'Craft Using an Item',
{13} 'Scripted Challenge'
])),
wbInteger('Threshold', itU32),
wbInteger('Flags', itU32, wbFlags([
'Start Disabled',
'Recurring',
'Show Zero Progress'
])),
wbInteger('Interval', itU32),
wbByteArray('(depends on type)', 2),
wbByteArray('(depends on type)', 2),
wbByteArray('(depends on type)', 4)
]),
wbFormID(SNAM, '(depends on type)'),
wbFormID(XNAM, '(depends on type)')
]);
wbRecord(CHIP, 'Casino Chip', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbDEST,
wbYNAM,
wbZNAM
]);
wbRecord(CMNY, 'Caravan Money', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbYNAM,
wbZNAM,
wbInteger(DATA, 'Absolute Value', itU32)
]);
wbRecord(CSNO, 'Casino', [
wbEDIDReq,
wbFULL,
wbStruct(DATA, 'Data', [
wbFloat('Decks % Before Shuffle'),
wbFloat('BlackJack Payout Ratio'),
wbArray('Slot Reel Stops', wbInteger('Reel', itU32),[
'Symbol 1',
'Symbol 2',
'Symbol 3',
'Symbol 4',
'Symbol 5',
'Symbol 6',
'Symbol W'
]),
wbInteger('Number of Decks', itU32),
wbInteger('Max Winnings', itU32),
wbFormIDCk('Currency', [CHIP]),
wbFormIDCk('Casino Winnings Quest', [QUST]),
wbInteger('Flags', itU32, wbFlags([
'Dealer Stay on Soft 17'
]))
]),
wbRStruct('Casino Chip Models', [
wbString(MODL, '$1 Chip'),
wbString(MODL, '$5 Chip'),
wbString(MODL, '$10 Chip'),
wbString(MODL, '$25 Chip'),
wbString(MODL, '$100 Chip'),
wbString(MODL, '$500 Chip'),
wbString(MODL, 'Roulette Chip')
], []),
wbString(MODL, 'Slot Machine Model'),
wbString(MOD2, 'Slot Machine Model (again?)'),
wbString(MOD3, 'BlackJack Table Model'),
wbString(MODT, 'BlackJack Table Model related'),
wbString(MOD4, 'Roulette Table Model'),
wbRStruct('Slot Reel Textures', [
wbString(ICON, 'Symbol 1'),
wbString(ICON, 'Symbol 2'),
wbString(ICON, 'Symbol 3'),
wbString(ICON, 'Symbol 4'),
wbString(ICON, 'Symbol 5'),
wbString(ICON, 'Symbol 6'),
wbString(ICON, 'Symbol W')
], []),
wbRStruct('BlackJack Decks', [
wbString(ICO2, 'Deck 1'),
wbString(ICO2, 'Deck 2'),
wbString(ICO2, 'Deck 3'),
wbString(ICO2, 'Deck 4')
], [])
]);
wbRecord(DEHY, 'Dehydration Stage', [
wbEDIDReq,
wbStruct(DATA, '', [
wbInteger('Trigger Threshold', itU32),
wbFormIDCk('Actor Effect', [SPEL])
], cpNormal, True)
]);
wbRecord(HUNG, 'Hunger Stage', [
wbEDIDReq,
wbStruct(DATA, '', [
wbInteger('Trigger Threshold', itU32),
wbFormIDCk('Actor Effect', [SPEL])
], cpNormal, True)
]);
wbRecord(LSCT, 'Load Screen Type', [
wbEDIDReq,
wbStruct(DATA, 'Data', [
wbInteger('Type', itU32, wbEnum([
'None',
'XP Progress',
'Objective',
'Tip',
'Stats'
])),
wbStruct('Data 1', [
wbInteger('X', itU32),
wbInteger('Y', itU32),
wbInteger('Width', itU32),
wbInteger('Height', itU32),
wbFloat('Orientation', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbInteger('Font', itU32, wbEnum([
'',
'2',
'3',
'4',
'5',
'6',
'7',
'8'
])),
wbStruct('Font Color', [
wbFloat('R'),
wbFloat('G'),
wbFloat('B')
]),
wbInteger('Font', itU32, wbEnum([
'',
'Left',
'Center',
'',
'Right'
]))
]),
wbByteArray('Unknown', 20),
wbStruct('Data 2', [
wbInteger('Font', itU32, wbEnum([
'',
'2',
'3',
'4',
'5',
'6',
'7',
'8'
])),
wbStruct('Font Color', [
wbFloat('R'),
wbFloat('G'),
wbFloat('B')
]),
wbByteArray('', 4),
wbInteger('Stats', itU32, wbEnum([
'',
'2',
'3',
'4',
'5',
'6',
'7',
'8'
]))
])
])
]);
wbRecord(RCCT, 'Recipe Category', [
wbEDIDReq,
wbFULL,
wbInteger(DATA, 'Flags', itU8, wbFlags([
'Subcategory?',
'',
'',
'',
'',
'',
'',
''
]))
]);
wbRecord(RCPE, 'Recipe', [
wbEDIDReq,
wbFULL,
wbCTDAs,
wbStruct(DATA, 'Data', [
wbInteger('Skill', itS32, wbActorValueEnum),
wbInteger('Level', itU32),
wbFormIDCk('Category', [RCCT, NULL]), // Some of DeadMoney are NULL
wbFormIDCk('Sub-Category', [RCCT])
]),
wbRStructs('Ingredients', 'Ingredient', [
wbFormIDCk(RCIL, 'Item', [ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, NOTE, IMOD, CMNY, CCRD, CHIP, LIGH], False, cpNormal, True),
wbInteger(RCQY, 'Quantity', itU32, nil, cpNormal, True)
], []),
wbRStructs('Outputs', 'Output', [
wbFormIDCk(RCOD, 'Item', [ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, NOTE, IMOD, CMNY, CCRD, CHIP, LIGH], False, cpNormal, True),
wbInteger(RCQY, 'Quantity', itU32, nil, cpNormal, True)
], [])
]);
wbRecord(REPU, 'Reputation', [
wbEDIDReq,
wbFULL,
wbICON,
wbFloat(DATA, 'Value')
]);
wbRecord(SLPD, 'Sleep Deprivation Stage', [
wbEDIDReq,
wbStruct(DATA, '', [
wbInteger('Trigger Threshold', itU32),
wbFormIDCk('Actor Effect', [SPEL])
], cpNormal, True)
]);
wbAddGroupOrder(GMST);
wbAddGroupOrder(TXST);
wbAddGroupOrder(MICN);
wbAddGroupOrder(GLOB);
wbAddGroupOrder(CLAS);
wbAddGroupOrder(FACT);
wbAddGroupOrder(HDPT);
wbAddGroupOrder(HAIR);
wbAddGroupOrder(EYES);
wbAddGroupOrder(RACE);
wbAddGroupOrder(SOUN);
wbAddGroupOrder(ASPC);
wbAddGroupOrder(MGEF);
wbAddGroupOrder(SCPT);
wbAddGroupOrder(LTEX);
wbAddGroupOrder(ENCH);
wbAddGroupOrder(SPEL);
wbAddGroupOrder(ACTI);
wbAddGroupOrder(TACT);
wbAddGroupOrder(TERM);
wbAddGroupOrder(ARMO);
wbAddGroupOrder(BOOK);
wbAddGroupOrder(CONT);
wbAddGroupOrder(DOOR);
wbAddGroupOrder(INGR);
wbAddGroupOrder(LIGH);
wbAddGroupOrder(MISC);
wbAddGroupOrder(STAT);
wbAddGroupOrder(SCOL);
wbAddGroupOrder(MSTT);
wbAddGroupOrder(PWAT);
wbAddGroupOrder(GRAS);
wbAddGroupOrder(TREE);
wbAddGroupOrder(FURN);
wbAddGroupOrder(WEAP);
wbAddGroupOrder(AMMO);
wbAddGroupOrder(NPC_);
wbAddGroupOrder(CREA);
wbAddGroupOrder(LVLC);
wbAddGroupOrder(LVLN);
wbAddGroupOrder(KEYM);
wbAddGroupOrder(ALCH);
wbAddGroupOrder(IDLM);
wbAddGroupOrder(NOTE);
wbAddGroupOrder(COBJ);
wbAddGroupOrder(PROJ);
wbAddGroupOrder(LVLI);
wbAddGroupOrder(WTHR);
wbAddGroupOrder(CLMT);
wbAddGroupOrder(REGN);
wbAddGroupOrder(NAVI);
wbAddGroupOrder(DIAL);
wbAddGroupOrder(QUST);
wbAddGroupOrder(IDLE);
wbAddGroupOrder(PACK);
wbAddGroupOrder(CSTY);
wbAddGroupOrder(LSCR);
wbAddGroupOrder(ANIO);
wbAddGroupOrder(WATR);
wbAddGroupOrder(EFSH);
wbAddGroupOrder(EXPL);
wbAddGroupOrder(DEBR);
wbAddGroupOrder(IMGS);
wbAddGroupOrder(IMAD);
wbAddGroupOrder(FLST);
wbAddGroupOrder(PERK);
wbAddGroupOrder(BPTD);
wbAddGroupOrder(ADDN);
wbAddGroupOrder(AVIF);
wbAddGroupOrder(RADS);
wbAddGroupOrder(CAMS);
wbAddGroupOrder(CPTH);
wbAddGroupOrder(VTYP);
wbAddGroupOrder(IPCT);
wbAddGroupOrder(IPDS);
wbAddGroupOrder(ARMA);
wbAddGroupOrder(ECZN);
wbAddGroupOrder(MESG);
wbAddGroupOrder(RGDL);
wbAddGroupOrder(DOBJ);
wbAddGroupOrder(LGTM);
wbAddGroupOrder(MUSC);
wbAddGroupOrder(IMOD);
wbAddGroupOrder(REPU);
wbAddGroupOrder(RCPE);
wbAddGroupOrder(RCCT);
wbAddGroupOrder(CHIP);
wbAddGroupOrder(CSNO);
wbAddGroupOrder(LSCT);
wbAddGroupOrder(MSET);
wbAddGroupOrder(ALOC);
wbAddGroupOrder(CHAL);
wbAddGroupOrder(AMEF);
wbAddGroupOrder(CCRD);
wbAddGroupOrder(CMNY);
wbAddGroupOrder(CDCK);
wbAddGroupOrder(DEHY);
wbAddGroupOrder(HUNG);
wbAddGroupOrder(SLPD);
// Forced at the end.
wbAddGroupOrder(CELL);
wbAddGroupOrder(WRLD);
end;
procedure DefineFNV;
begin
DefineFNVa;
DefineFNVb;
DefineFNVc;
DefineFNVd;
DefineFNVe;
DefineFNVf;
end;
end.
================================================
FILE: lib/xedit/wbDefinitionsFO3.pas
================================================
{*******************************************************************************
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in
compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/
Software distributed under the License is distributed on an "AS IS"
basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
License for the specific language governing rights and limitations
under the License.
*******************************************************************************}
unit wbDefinitionsFO3;
{$I wbDefines.inc}
interface
uses
wbInterface;
var
wbAggroRadiusFlags: IwbFlagsDef;
wbPKDTFlags: IwbFlagsDef;
wbRecordFlagsFlags: IwbFlagsDef;
wbServiceFlags: IwbFlagsDef;
wbTemplateFlags: IwbFlagsDef;
wbAgressionEnum: IwbEnumDef;
wbAlignmentEnum: IwbEnumDef;
wbArchtypeEnum: IwbEnumDef;
wbAssistanceEnum: IwbEnumDef;
wbAttackAnimationEnum: IwbEnumDef;
wbAxisEnum: IwbEnumDef;
wbBlendModeEnum: IwbEnumDef;
wbBlendOpEnum: IwbEnumDef;
wbBodyLocationEnum: IwbEnumDef;
wbBodyPartIndexEnum: IwbEnumDef;
wbConfidenceEnum: IwbEnumDef;
wbCreatureTypeEnum: IwbEnumDef;
wbCrimeTypeEnum: IwbEnumDef;
wbCriticalStageEnum: IwbEnumDef;
wbEquipTypeEnum: IwbEnumDef;
wbFormTypeEnum: IwbEnumDef;
wbFunctionsEnum: IwbEnumDef;
wbHeadPartIndexEnum: IwbEnumDef;
wbImpactMaterialTypeEnum: IwbEnumDef;
wbMenuModeEnum: IwbEnumDef;
wbMiscStatEnum: IwbEnumDef;
wbModEffectEnum: IwbEnumDef;
wbMoodEnum: IwbEnumDef;
wbMusicEnum: IwbEnumDef;
wbObjectTypeEnum: IwbEnumDef;
wbPKDTType: IwbEnumDef;
wbPlayerActionEnum: IwbEnumDef;
wbQuadrantEnum: IwbEnumDef;
wbReloadAnimEnum: IwbEnumDef;
wbSexEnum: IwbEnumDef;
wbSkillEnum: IwbEnumDef;
wbSoundLevelEnum: IwbEnumDef;
wbSpecializationEnum: IwbEnumDef;
wbVatsValueFunctionEnum: IwbEnumDef;
wbWeaponAnimTypeEnum: IwbEnumDef;
wbZTestFuncEnum: IwbEnumDef;
procedure DefineFO3;
implementation
uses
Types,
Classes,
SysUtils,
Math,
Variants,
wbHelpers;
const
_00_IAD: TwbSignature = #$00'IAD';
_40_IAD: TwbSignature = #$40'IAD';
_01_IAD: TwbSignature = #$01'IAD';
_41_IAD: TwbSignature = #$41'IAD';
_02_IAD: TwbSignature = #$02'IAD';
_42_IAD: TwbSignature = #$42'IAD';
_03_IAD: TwbSignature = #$03'IAD';
_43_IAD: TwbSignature = #$43'IAD';
_04_IAD: TwbSignature = #$04'IAD';
_44_IAD: TwbSignature = #$44'IAD';
_05_IAD: TwbSignature = #$05'IAD';
_45_IAD: TwbSignature = #$45'IAD';
_06_IAD: TwbSignature = #$06'IAD';
_46_IAD: TwbSignature = #$46'IAD';
_07_IAD: TwbSignature = #$07'IAD';
_47_IAD: TwbSignature = #$47'IAD';
_08_IAD: TwbSignature = #$08'IAD';
_48_IAD: TwbSignature = #$48'IAD';
_09_IAD: TwbSignature = #$09'IAD';
_49_IAD: TwbSignature = #$49'IAD';
_0A_IAD: TwbSignature = #$0A'IAD';
_4A_IAD: TwbSignature = #$4A'IAD';
_0B_IAD: TwbSignature = #$0B'IAD';
_4B_IAD: TwbSignature = #$4B'IAD';
_0C_IAD: TwbSignature = #$0C'IAD';
_4C_IAD: TwbSignature = #$4C'IAD';
_0D_IAD: TwbSignature = #$0D'IAD';
_4D_IAD: TwbSignature = #$4D'IAD';
_0E_IAD: TwbSignature = #$0E'IAD';
_4E_IAD: TwbSignature = #$4E'IAD';
_0F_IAD: TwbSignature = #$0F'IAD';
_4F_IAD: TwbSignature = #$4F'IAD';
_10_IAD: TwbSignature = #$10'IAD';
_50_IAD: TwbSignature = #$50'IAD';
_11_IAD: TwbSignature = #$11'IAD';
_51_IAD: TwbSignature = #$51'IAD';
_12_IAD: TwbSignature = #$12'IAD';
_52_IAD: TwbSignature = #$52'IAD';
_13_IAD: TwbSignature = #$13'IAD';
_53_IAD: TwbSignature = #$53'IAD';
_14_IAD: TwbSignature = #$14'IAD';
_54_IAD: TwbSignature = #$54'IAD';
_0_IAD : TwbSignature = #0'IAD';
_1_IAD : TwbSignature = #1'IAD';
_2_IAD : TwbSignature = #2'IAD';
_3_IAD : TwbSignature = #3'IAD';
ACBS : TwbSignature = 'ACBS';
ACHR : TwbSignature = 'ACHR';
ACRE : TwbSignature = 'ACRE';
ACTI : TwbSignature = 'ACTI';
ADDN : TwbSignature = 'ADDN';
AIDT : TwbSignature = 'AIDT';
ALCH : TwbSignature = 'ALCH';
AMMO : TwbSignature = 'AMMO';
ANAM : TwbSignature = 'ANAM';
ANIO : TwbSignature = 'ANIO';
ARMA : TwbSignature = 'ARMA';
ARMO : TwbSignature = 'ARMO';
ASPC : TwbSignature = 'ASPC';
ATTR : TwbSignature = 'ATTR';
ATXT : TwbSignature = 'ATXT';
AVIF : TwbSignature = 'AVIF';
BIPL : TwbSignature = 'BIPL';
BMCT : TwbSignature = 'BMCT';
BMDT : TwbSignature = 'BMDT';
BNAM : TwbSignature = 'BNAM';
BOOK : TwbSignature = 'BOOK';
BPND : TwbSignature = 'BPND';
BPNI : TwbSignature = 'BPNI';
BPNN : TwbSignature = 'BPNN';
BPNT : TwbSignature = 'BPNT';
BPTD : TwbSignature = 'BPTD';
BPTN : TwbSignature = 'BPTN';
BTXT : TwbSignature = 'BTXT';
CAMS : TwbSignature = 'CAMS';
CELL : TwbSignature = 'CELL';
CLAS : TwbSignature = 'CLAS';
CLMT : TwbSignature = 'CLMT';
CNAM : TwbSignature = 'CNAM';
CNTO : TwbSignature = 'CNTO';
COBJ : TwbSignature = 'COBJ';
COED : TwbSignature = 'COED';
CONT : TwbSignature = 'CONT';
CPTH : TwbSignature = 'CPTH';
CRDT : TwbSignature = 'CRDT';
CREA : TwbSignature = 'CREA';
CSAD : TwbSignature = 'CSAD';
CSCR : TwbSignature = 'CSCR';
CSDC : TwbSignature = 'CSDC';
CSDI : TwbSignature = 'CSDI';
CSDT : TwbSignature = 'CSDT';
CSSD : TwbSignature = 'CSSD';
CSTD : TwbSignature = 'CSTD';
CSTY : TwbSignature = 'CSTY';
CTDA : TwbSignature = 'CTDA';
DATA : TwbSignature = 'DATA';
DEBR : TwbSignature = 'DEBR';
DELE : TwbSignature = 'DELE';
DESC : TwbSignature = 'DESC';
DEST : TwbSignature = 'DEST';
DIAL : TwbSignature = 'DIAL';
DMDL : TwbSignature = 'DMDL';
DMDT : TwbSignature = 'DMDT';
DNAM : TwbSignature = 'DNAM';
DOBJ : TwbSignature = 'DOBJ';
DODT : TwbSignature = 'DODT';
DOOR : TwbSignature = 'DOOR';
DSTD : TwbSignature = 'DSTD';
DSTF : TwbSignature = 'DSTF';
EAMT : TwbSignature = 'EAMT';
ECZN : TwbSignature = 'ECZN';
EDID : TwbSignature = 'EDID';
EFID : TwbSignature = 'EFID';
EFIT : TwbSignature = 'EFIT';
EFSD : TwbSignature = 'EFSD';
EFSH : TwbSignature = 'EFSH';
EITM : TwbSignature = 'EITM';
ENAM : TwbSignature = 'ENAM';
ENCH : TwbSignature = 'ENCH';
ENIT : TwbSignature = 'ENIT';
EPF2 : TwbSignature = 'EPF2';
EPF3 : TwbSignature = 'EPF3';
EPFD : TwbSignature = 'EPFD';
EPFT : TwbSignature = 'EPFT';
ESCE : TwbSignature = 'ESCE';
ETYP : TwbSignature = 'ETYP';
EXPL : TwbSignature = 'EXPL';
EYES : TwbSignature = 'EYES';
FACT : TwbSignature = 'FACT';
FGGA : TwbSignature = 'FGGA';
FGGS : TwbSignature = 'FGGS';
FGTS : TwbSignature = 'FGTS';
FLST : TwbSignature = 'FLST';
FLTV : TwbSignature = 'FLTV';
FNAM : TwbSignature = 'FNAM';
FULL : TwbSignature = 'FULL';
FURN : TwbSignature = 'FURN';
GLOB : TwbSignature = 'GLOB';
GMST : TwbSignature = 'GMST';
GNAM : TwbSignature = 'GNAM';
GRAS : TwbSignature = 'GRAS';
HAIR : TwbSignature = 'HAIR';
HCLR : TwbSignature = 'HCLR';
HDPT : TwbSignature = 'HDPT';
HEDR : TwbSignature = 'HEDR';
HNAM : TwbSignature = 'HNAM';
ICO2 : TwbSignature = 'ICO2';
ICON : TwbSignature = 'ICON';
IDLA : TwbSignature = 'IDLA';
IDLB : TwbSignature = 'IDLB';
IDLC : TwbSignature = 'IDLC';
IDLE : TwbSignature = 'IDLE';
IDLF : TwbSignature = 'IDLF';
IDLM : TwbSignature = 'IDLM';
IDLT : TwbSignature = 'IDLT';
IMAD : TwbSignature = 'IMAD';
IMGS : TwbSignature = 'IMGS';
INAM : TwbSignature = 'INAM';
INDX : TwbSignature = 'INDX';
INFO : TwbSignature = 'INFO';
INGR : TwbSignature = 'INGR';
IPCT : TwbSignature = 'IPCT';
IPDS : TwbSignature = 'IPDS';
ITXT : TwbSignature = 'ITXT';
JNAM : TwbSignature = 'JNAM';
KEYM : TwbSignature = 'KEYM';
KFFZ : TwbSignature = 'KFFZ';
KNAM : TwbSignature = 'KNAM';
LAND : TwbSignature = 'LAND';
LGTM : TwbSignature = 'LGTM';
LIGH : TwbSignature = 'LIGH';
LNAM : TwbSignature = 'LNAM';
LSCR : TwbSignature = 'LSCR';
LTEX : TwbSignature = 'LTEX';
LTMP : TwbSignature = 'LTMP';
LVLC : TwbSignature = 'LVLC';
LVLD : TwbSignature = 'LVLD';
LVLF : TwbSignature = 'LVLF';
LVLG : TwbSignature = 'LVLG';
LVLI : TwbSignature = 'LVLI';
LVLN : TwbSignature = 'LVLN';
LVLO : TwbSignature = 'LVLO';
MAST : TwbSignature = 'MAST';
MESG : TwbSignature = 'MESG';
MGEF : TwbSignature = 'MGEF';
MICN : TwbSignature = 'MICN';
MICO : TwbSignature = 'MICO';
MIC2 : TwbSignature = 'MIC2';
MISC : TwbSignature = 'MISC';
MNAM : TwbSignature = 'MNAM';
MO2B : TwbSignature = 'MO2B';
MO2S : TwbSignature = 'MO2S';
MO2T : TwbSignature = 'MO2T';
MO3B : TwbSignature = 'MO3B';
MO3S : TwbSignature = 'MO3S';
MO3T : TwbSignature = 'MO3T';
MO4B : TwbSignature = 'MO4B';
MO4S : TwbSignature = 'MO4S';
MO4T : TwbSignature = 'MO4T';
MOD2 : TwbSignature = 'MOD2';
MOD3 : TwbSignature = 'MOD3';
MOD4 : TwbSignature = 'MOD4';
MODB : TwbSignature = 'MODB';
MODD : TwbSignature = 'MODD';
MODL : TwbSignature = 'MODL';
MODS : TwbSignature = 'MODS';
MODT : TwbSignature = 'MODT';
MOSD : TwbSignature = 'MOSD';
MSTT : TwbSignature = 'MSTT';
MUSC : TwbSignature = 'MUSC';
IMPS : TwbSignature = 'IMPS';
IMPF : TwbSignature = 'IMPF';
NAM0 : TwbSignature = 'NAM0';
NAM1 : TwbSignature = 'NAM1';
NAM2 : TwbSignature = 'NAM2';
NAM3 : TwbSignature = 'NAM3';
NAM4 : TwbSignature = 'NAM4';
NAM5 : TwbSignature = 'NAM5';
NAM6 : TwbSignature = 'NAM6';
NAM7 : TwbSignature = 'NAM7';
NAM8 : TwbSignature = 'NAM8';
NAM9 : TwbSignature = 'NAM9';
NAME : TwbSignature = 'NAME';
NAVI : TwbSignature = 'NAVI';
NAVM : TwbSignature = 'NAVM';
NEXT : TwbSignature = 'NEXT';
NIFT : TwbSignature = 'NIFT';
NIFZ : TwbSignature = 'NIFZ';
NNAM : TwbSignature = 'NNAM';
NOTE : TwbSignature = 'NOTE';
NPC_ : TwbSignature = 'NPC_';
NULL : TwbSignature = 'NULL';
NVCA : TwbSignature = 'NVCA';
NVCI : TwbSignature = 'NVCI';
NVDP : TwbSignature = 'NVDP';
NVER : TwbSignature = 'NVER';
NVEX : TwbSignature = 'NVEX';
NVGD : TwbSignature = 'NVGD';
NVMI : TwbSignature = 'NVMI';
NVTR : TwbSignature = 'NVTR';
NVVX : TwbSignature = 'NVVX';
OBND : TwbSignature = 'OBND';
OFST : TwbSignature = 'OFST';
ONAM : TwbSignature = 'ONAM';
PACK : TwbSignature = 'PACK';
PBEA : TwbSignature = 'PBEA';
PERK : TwbSignature = 'PERK';
PFIG : TwbSignature = 'PFIG';
PFPC : TwbSignature = 'PFPC';
PGAG : TwbSignature = 'PGAG';
PGRE : TwbSignature = 'PGRE';
PMIS : TwbSignature = 'PMIS';
TRGT : TwbSignature = 'TRGT';
PGRI : TwbSignature = 'PGRI';
PGRL : TwbSignature = 'PGRL';
PGRP : TwbSignature = 'PGRP';
PGRR : TwbSignature = 'PGRR';
PKAM : TwbSignature = 'PKAM';
PKDD : TwbSignature = 'PKDD';
PKDT : TwbSignature = 'PKDT';
PKE2 : TwbSignature = 'PKE2';
PKED : TwbSignature = 'PKED';
PKFD : TwbSignature = 'PKFD';
PKID : TwbSignature = 'PKID';
PKPT : TwbSignature = 'PKPT';
PKW3 : TwbSignature = 'PKW3';
PLD2 : TwbSignature = 'PLD2';
PLDT : TwbSignature = 'PLDT';
PLYR : TwbSignature = 'PLYR';
PNAM : TwbSignature = 'PNAM';
POBA : TwbSignature = 'POBA';
POCA : TwbSignature = 'POCA';
POEA : TwbSignature = 'POEA';
PRKC : TwbSignature = 'PRKC';
PRKE : TwbSignature = 'PRKE';
PRKF : TwbSignature = 'PRKF';
PROJ : TwbSignature = 'PROJ';
PSDT : TwbSignature = 'PSDT';
PTD2 : TwbSignature = 'PTD2';
PTDT : TwbSignature = 'PTDT';
PUID : TwbSignature = 'PUID';
PWAT : TwbSignature = 'PWAT';
QNAM : TwbSignature = 'QNAM';
QOBJ : TwbSignature = 'QOBJ';
QSDT : TwbSignature = 'QSDT';
QSTA : TwbSignature = 'QSTA';
QSTI : TwbSignature = 'QSTI';
TPIC : TwbSignature = 'TPIC';
QSTR : TwbSignature = 'QSTR';
QUST : TwbSignature = 'QUST';
RACE : TwbSignature = 'RACE';
RADS : TwbSignature = 'RADS';
RAFB : TwbSignature = 'RAFB';
RAFD : TwbSignature = 'RAFD';
RAGA : TwbSignature = 'RAGA';
RAPS : TwbSignature = 'RAPS';
RCLR : TwbSignature = 'RCLR';
RDAT : TwbSignature = 'RDAT';
RDMD : TwbSignature = 'RDMD';
RDMO : TwbSignature = 'RDMO';
RDMP : TwbSignature = 'RDMP';
RDGS : TwbSignature = 'RDGS';
RDOT : TwbSignature = 'RDOT';
RDSD : TwbSignature = 'RDSD';
RDWT : TwbSignature = 'RDWT';
REFR : TwbSignature = 'REFR';
REGN : TwbSignature = 'REGN';
REPL : TwbSignature = 'REPL';
RGDL : TwbSignature = 'RGDL';
RNAM : TwbSignature = 'RNAM';
RPLD : TwbSignature = 'RPLD';
RPLI : TwbSignature = 'RPLI';
SCDA : TwbSignature = 'SCDA';
SCHR : TwbSignature = 'SCHR';
SCOL : TwbSignature = 'SCOL';
SCPT : TwbSignature = 'SCPT';
SCRI : TwbSignature = 'SCRI';
SCRN : TwbSignature = 'SCRN';
SCRO : TwbSignature = 'SCRO';
SCRV : TwbSignature = 'SCRV';
SCTX : TwbSignature = 'SCTX';
SCVR : TwbSignature = 'SCVR';
SLCP : TwbSignature = 'SLCP';
SLSD : TwbSignature = 'SLSD';
SNAM : TwbSignature = 'SNAM';
SNDD : TwbSignature = 'SNDD';
SNDX : TwbSignature = 'SNDX';
SOUL : TwbSignature = 'SOUL';
SOUN : TwbSignature = 'SOUN';
SPEL : TwbSignature = 'SPEL';
SPIT : TwbSignature = 'SPIT';
SPLO : TwbSignature = 'SPLO';
STAT : TwbSignature = 'STAT';
TACT : TwbSignature = 'TACT';
TCLF : TwbSignature = 'TCLF';
TCLT : TwbSignature = 'TCLT';
TERM : TwbSignature = 'TERM';
TES4 : TwbSignature = 'TES4';
TNAM : TwbSignature = 'TNAM';
TPLT : TwbSignature = 'TPLT';
TRDT : TwbSignature = 'TRDT';
TREE : TwbSignature = 'TREE';
TX00 : TwbSignature = 'TX00';
TX01 : TwbSignature = 'TX01';
TX02 : TwbSignature = 'TX02';
TX03 : TwbSignature = 'TX03';
TX04 : TwbSignature = 'TX04';
TX05 : TwbSignature = 'TX05';
TXST : TwbSignature = 'TXST';
UNAM : TwbSignature = 'UNAM';
VCLR : TwbSignature = 'VCLR';
VHGT : TwbSignature = 'VHGT';
VNAM : TwbSignature = 'VNAM';
VNML : TwbSignature = 'VNML';
VTCK : TwbSignature = 'VTCK';
VTEX : TwbSignature = 'VTEX';
VTXT : TwbSignature = 'VTXT';
VTYP : TwbSignature = 'VTYP';
WATR : TwbSignature = 'WATR';
WEAP : TwbSignature = 'WEAP';
WLST : TwbSignature = 'WLST';
WNAM : TwbSignature = 'WNAM';
WRLD : TwbSignature = 'WRLD';
WTHR : TwbSignature = 'WTHR';
XACT : TwbSignature = 'XACT';
XAMC : TwbSignature = 'XAMC';
XAMT : TwbSignature = 'XAMT';
XAPD : TwbSignature = 'XAPD';
XAPR : TwbSignature = 'XAPR';
XCAS : TwbSignature = 'XCAS';
XCCM : TwbSignature = 'XCCM';
XCET : TwbSignature = 'XCET';
XCHG : TwbSignature = 'XCHG';
XCIM : TwbSignature = 'XCIM';
XCLC : TwbSignature = 'XCLC';
XCLL : TwbSignature = 'XCLL';
XCLP : TwbSignature = 'XCLP';
XCLR : TwbSignature = 'XCLR';
XCLW : TwbSignature = 'XCLW';
XCMO : TwbSignature = 'XCMO';
XCMT : TwbSignature = 'XCMT';
XCNT : TwbSignature = 'XCNT';
XCWT : TwbSignature = 'XCWT';
XEMI : TwbSignature = 'XEMI';
XESP : TwbSignature = 'XESP';
XEZN : TwbSignature = 'XEZN';
XGLB : TwbSignature = 'XGLB';
XHLP : TwbSignature = 'XHLP';
XDCR : TwbSignature = 'XDCR';
XHLT : TwbSignature = 'XHLT';
XIBS : TwbSignature = 'XIBS';
XLCM : TwbSignature = 'XLCM';
XLKR : TwbSignature = 'XLKR';
XLOC : TwbSignature = 'XLOC';
XLOD : TwbSignature = 'XLOD';
XLRM : TwbSignature = 'XLRM';
XLTW : TwbSignature = 'XLTW';
XMBO : TwbSignature = 'XMBO';
XMBP : TwbSignature = 'XMBP';
XMBR : TwbSignature = 'XMBR';
XMRC : TwbSignature = 'XMRC';
XMRK : TwbSignature = 'XMRK';
XNAM : TwbSignature = 'XNAM';
XNDP : TwbSignature = 'XNDP';
XOCP : TwbSignature = 'XOCP';
XORD : TwbSignature = 'XORD';
XOWN : TwbSignature = 'XOWN';
XPOD : TwbSignature = 'XPOD';
XPTL : TwbSignature = 'XPTL';
XPPA : TwbSignature = 'XPPA';
XPRD : TwbSignature = 'XPRD';
XPRM : TwbSignature = 'XPRM';
XPWR : TwbSignature = 'XPWR';
XRAD : TwbSignature = 'XRAD';
XRDO : TwbSignature = 'XRDO';
XRDS : TwbSignature = 'XRDS';
XRGB : TwbSignature = 'XRGB';
XRGD : TwbSignature = 'XRGD';
XRMR : TwbSignature = 'XRMR';
XRNK : TwbSignature = 'XRNK';
XRTM : TwbSignature = 'XRTM';
XSCL : TwbSignature = 'XSCL';
XSED : TwbSignature = 'XSED';
XSRF : TwbSignature = 'XSRF';
XSRD : TwbSignature = 'XSRD';
XTEL : TwbSignature = 'XTEL';
XTRG : TwbSignature = 'XTRG';
XTRI : TwbSignature = 'XTRI';
XXXX : TwbSignature = 'XXXX';
YNAM : TwbSignature = 'YNAM';
ZNAM : TwbSignature = 'ZNAM';
var
wbPKDTSpecificFlagsUnused : Boolean;
wbEDID: IwbSubRecordDef;
wbEDIDReq: IwbSubRecordDef;
wbBMDT: IwbSubRecordDef;
wbYNAM: IwbSubRecordDef;
wbZNAM: IwbSubRecordDef;
wbCOED: IwbSubRecordDef;
wbXLCM: IwbSubRecordDef;
wbEITM: IwbSubRecordDef;
wbREPL: IwbSubRecordDef;
wbBIPL: IwbSubRecordDef;
wbOBND: IwbSubRecordDef;
wbOBNDReq: IwbSubRecordDef;
wbDEST: IwbSubRecordStructDef;
wbDESTActor: IwbSubRecordStructDef;
wbDODT: IwbSubRecordDef;
wbXOWN: IwbSubRecordDef;
wbXGLB: IwbSubRecordDef;
wbXRGD: IwbSubRecordDef;
wbXRGB: IwbSubRecordDef;
wbSLSD: IwbSubRecordDef;
wbSPLO: IwbSubRecordDef;
wbSPLOs: IwbSubRecordArrayDef;
wbCNTO: IwbSubRecordStructDef;
wbCNTOs: IwbSubRecordArrayDef;
wbAIDT: IwbSubRecordDef;
wbCSDT: IwbSubRecordStructDef;
wbCSDTs: IwbSubRecordArrayDef;
wbFULL: IwbSubRecordDef;
wbFULLActor: IwbSubRecordDef;
wbFULLReq: IwbSubRecordDef;
wbXNAM: IwbSubRecordDef;
wbXNAMs: IwbSubRecordArrayDef;
wbDESC: IwbSubRecordDef;
wbDESCReq: IwbSubRecordDef;
wbXSCL: IwbSubRecordDef;
wbDATAPosRot : IwbSubRecordDef;
wbPosRot : IwbStructDef;
wbMODD: IwbSubRecordDef;
wbMOSD: IwbSubRecordDef;
wbMODL: IwbSubRecordStructDef;
wbMODS: IwbSubRecordDef;
wbMO2S: IwbSubRecordDef;
wbMO3S: IwbSubRecordDef;
wbMO4S: IwbSubRecordDef;
wbMODLActor: IwbSubRecordStructDef;
wbMODLReq: IwbSubRecordStructDef;
wbCTDA: IwbSubRecordDef;
wbSCHRReq: IwbSubRecordDef;
wbCTDAs: IwbSubRecordArrayDef;
wbCTDAsReq: IwbSubRecordArrayDef;
wbSCROs: IwbSubRecordArrayDef;
wbPGRP: IwbSubRecordDef;
wbEmbeddedScript: IwbSubRecordStructDef;
wbEmbeddedScriptPerk: IwbSubRecordStructDef;
wbEmbeddedScriptReq: IwbSubRecordStructDef;
wbSCRI: IwbSubRecordDef;
wbSCRIActor: IwbSubRecordDef;
wbFaceGen: IwbSubRecordStructDef;
wbFaceGenNPC: IwbSubRecordStructDef;
wbENAM: IwbSubRecordDef;
wbFGGS: IwbSubRecordDef;
wbXLOD: IwbSubRecordDef;
wbXESP: IwbSubRecordDef;
wbICON: IwbSubRecordStructDef;
wbICONReq: IwbSubRecordStructDef;
wbActorValue: IwbIntegerDef;
wbETYP: IwbSubRecordDef;
wbETYPReq: IwbSubRecordDef;
wbEFID: IwbSubRecordDef;
wbEFIT: IwbSubRecordDef;
wbEffects: IwbSubRecordArrayDef;
wbEffectsReq: IwbSubRecordArrayDef;
wbBPNDStruct: IwbSubRecordDef;
wbTimeInterpolator: IwbStructDef;
wbColorInterpolator: IwbStructDef;
function wbNVTREdgeToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Index : Integer;
Flags : Cardinal;
IsExternal : Boolean;
Container : IwbContainerElementRef;
begin
Result := '';
IsExternal := False;
if Supports(aElement, IwbContainerElementRef, Container) then begin
Index := StrToIntDef(Copy(Container.Name, 11, 1), -1);
if (Index >= 0) and (Index <= 2) then begin
Flags := Container.ElementNativeValues['..\..\Flags'];
IsExternal := Flags and (Cardinal(1) shl Index) <> 0;
end;
end;
if IsExternal then begin
case aType of
ctToStr: begin
Result := IntToStr(aInt);
if Container.ElementExists['..\..\..\..\NVEX\Connection #' + IntToStr(aInt)] then
Result := Result + ' (Triangle #' +
Container.ElementValues['..\..\..\..\NVEX\Connection #' + IntToStr(aInt) + '\Triangle'] + ' in ' +
Container.ElementValues['..\..\..\..\NVEX\Connection #' + IntToStr(aInt) + '\Navigation Mesh'] + ')'
else
Result := Result + ' ';
end;
ctToSortKey:
if Container.ElementExists['..\..\..\..\NVEX\Connection #' + IntToStr(aInt)] then
Result :=
Container.ElementSortKeys['..\..\..\..\NVEX\Connection #' + IntToStr(aInt) + '\Navigation Mesh', True] + '|' +
Container.ElementSortKeys['..\..\..\..\NVEX\Connection #' + IntToStr(aInt) + '\Triangle', True];
ctCheck:
if Container.ElementExists['..\..\..\..\NVEX\Connection #' + IntToStr(aInt)] then
Result := ''
else
Result := 'NVEX\Connection #' + IntToStr(aInt) + ' is missing';
end
end else
case aType of
ctToStr: Result := IntToStr(aInt);
end;
end;
function wbNVTREdgeToInt(const aString: string; const aElement: IwbElement): Int64;
begin
Result := StrToInt64(aString);
end;
function wbEPFDActorValueToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
AsCardinal : Cardinal;
AsFloat : Single;
begin
AsCardinal := aInt;
AsFloat := PSingle(@AsCardinal)^;
aInt := Round(AsFloat);
case aType of
ctToStr: Result := wbActorValueEnum.ToString(aInt, aElement);
ctToSortKey: Result := wbActorValueEnum.ToSortKey(aInt, aElement);
ctCheck: Result := wbActorValueEnum.Check(aInt, aElement);
ctToEditValue: Result := wbActorValueEnum.ToEditValue(aInt, aElement);
ctEditType: Result := 'ComboBox';
ctEditInfo: Result := wbActorValueEnum.EditInfo[aInt, aElement];
end;
end;
function wbEPFDActorValueToInt(const aString: string; const aElement: IwbElement): Int64;
var
AsCardinal : Cardinal;
AsFloat : Single;
begin
AsFloat := wbActorValueEnum.FromEditValue(aString, aElement);
PSingle(@AsCardinal)^ := AsFloat;
Result := AsCardinal;
end;
function wbCTDAParam2VariableNameToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
//Container2 : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
BaseRecord : IwbMainRecord;
ScriptRef : IwbElement;
Script : IwbMainRecord;
Variables : TStringList;
LocalVars : IwbContainerElementRef;
LocalVar : IwbContainerElementRef;
i, j : Integer;
s : string;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Param1 := Container.ElementByName['Parameter #1'];
if not Assigned(Param1) then
Exit;
MainRecord := nil;
if not Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
Exit;
{ if Param1.NativeValue = 0 then
if Supports(Container.Container, IwbContainerElementRef, Container) then
for i := 0 to Pred(Container.ElementCount) do
if Supports(Container.Elements[i], IwbContainerElementRef, Container2) then
if SameText(Container2.ElementValues['Function'], 'GetIsID') then begin
Param1 := Container2.ElementByName['Parameter #1'];
if Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
Break;
end;}
if not Assigned(MainRecord) then
Exit;
BaseRecord := MainRecord.BaseRecord;
if Assigned(BaseRecord) then
MainRecord := BaseRecord;
ScriptRef := MainRecord.RecordBySignature['SCRI'];
if not Assigned(ScriptRef) then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
if not Supports(ScriptRef.LinksTo, IwbMainRecord, Script) then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
Script := Script.HighestOverrideOrSelf[aElement._File.LoadOrder];
case aType of
ctEditType: begin
Result := 'ComboBox';
Exit;
end;
ctEditInfo:
Variables := TStringList.Create;
else
Variables := nil;
end;
try
if Supports(Script.ElementByName['Local Variables'], IwbContainerElementRef, LocalVars) then begin
for i := 0 to Pred(LocalVars.ElementCount) do
if Supports(LocalVars.Elements[i], IwbContainerElementRef, LocalVar) then begin
j := LocalVar.ElementNativeValues['SLSD\Index'];
s := LocalVar.ElementNativeValues['SCVR'];
if Assigned(Variables) then
Variables.AddObject(s, TObject(j))
else if j = aInt then begin
case aType of
ctToStr, ctToEditValue: Result := s;
ctCheck: Result := '';
end;
Exit;
end;
end;
end;
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
ctEditInfo: begin
Variables.Sort;
Result := Variables.CommaText;
end;
end;
finally
FreeAndNil(Variables);
end;
end;
function wbCTDAParam2VariableNameToInt(const aString: string; const aElement: IwbElement): Int64;
var
Container : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
BaseRecord : IwbMainRecord;
ScriptRef : IwbElement;
Script : IwbMainRecord;
LocalVars : IwbContainerElementRef;
LocalVar : IwbContainerElementRef;
i, j : Integer;
s : string;
begin
Result := StrToInt64Def(aString, Low(Cardinal));
if Result <> Low(Cardinal) then
Exit;
if not Assigned(aElement) then
raise Exception.Create('aElement not specified');
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then
raise Exception.Create('Container not assigned');
Param1 := Container.ElementByName['Parameter #1'];
if not Assigned(Param1) then
raise Exception.Create('Could not find "Parameter #1"');
if not Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
raise Exception.Create('"Parameter #1" does not reference a valid main record');
BaseRecord := MainRecord.BaseRecord;
if Assigned(BaseRecord) then
MainRecord := BaseRecord;
ScriptRef := MainRecord.RecordBySignature['SCRI'];
if not Assigned(ScriptRef) then
raise Exception.Create('"'+MainRecord.ShortName+'" does not contain a SCRI subrecord');
if not Supports(ScriptRef.LinksTo, IwbMainRecord, Script) then
raise Exception.Create('"'+MainRecord.ShortName+'" does not have a valid script');
Script := Script.HighestOverrideOrSelf[aElement._File.LoadOrder];
if Supports(Script.ElementByName['Local Variables'], IwbContainerElementRef, LocalVars) then begin
for i := 0 to Pred(LocalVars.ElementCount) do
if Supports(LocalVars.Elements[i], IwbContainerElementRef, LocalVar) then begin
j := LocalVar.ElementNativeValues['SLSD\Index'];
s := LocalVar.ElementNativeValues['SCVR'];
if SameText(s, Trim(aString)) then begin
Result := j;
Exit;
end;
end;
end;
raise Exception.Create('Variable "'+aString+'" was not found in "'+MainRecord.ShortName+'"');
end;
function wbCTDAParam2QuestStageToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
EditInfos : TStringList;
Stages : IwbContainerElementRef;
Stage : IwbContainerElementRef;
i, j : Integer;
s, t : string;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Param1 := Container.ElementByName['Parameter #1'];
if not Assigned(Param1) then
Exit;
if not Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
Exit;
MainRecord := MainRecord.WinningOverride;
if MainRecord.Signature <> QUST then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
case aType of
ctEditType: begin
Result := 'ComboBox';
Exit;
end;
ctEditInfo:
EditInfos := TStringList.Create;
else
EditInfos := nil;
end;
try
if Supports(MainRecord.ElementByName['Stages'], IwbContainerElementRef, Stages) then begin
for i := 0 to Pred(Stages.ElementCount) do
if Supports(Stages.Elements[i], IwbContainerElementRef, Stage) then begin
j := Stage.ElementNativeValues['INDX'];
s := Trim(Stage.ElementValues['Log Entries\Log Entry\CNAM']);
t := IntToStr(j);
while Length(t) < 3 do
t := '0' + t;
if s <> '' then
t := t + ' ' + s;
if Assigned(EditInfos) then
EditInfos.AddObject(t, TObject(j))
else if j = aInt then begin
case aType of
ctToStr, ctToEditValue: Result := t;
ctCheck: Result := '';
end;
Exit;
end;
end;
end;
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
ctEditInfo: begin
EditInfos.Sort;
Result := EditInfos.CommaText;
end;
end;
finally
FreeAndNil(EditInfos);
end;
end;
function wbPerkDATAQuestStageToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
EditInfos : TStringList;
Stages : IwbContainerElementRef;
Stage : IwbContainerElementRef;
i, j : Integer;
s, t : string;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Param1 := Container.ElementByName['Quest'];
if not Assigned(Param1) then
Exit;
if not Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
Exit;
MainRecord := MainRecord.WinningOverride;
if MainRecord.Signature <> QUST then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
case aType of
ctEditType: begin
Result := 'ComboBox';
Exit;
end;
ctEditInfo:
EditInfos := TStringList.Create;
else
EditInfos := nil;
end;
try
if Supports(MainRecord.ElementByName['Stages'], IwbContainerElementRef, Stages) then begin
for i := 0 to Pred(Stages.ElementCount) do
if Supports(Stages.Elements[i], IwbContainerElementRef, Stage) then begin
j := Stage.ElementNativeValues['INDX'];
s := Trim(Stage.ElementValues['Log Entries\Log Entry\CNAM']);
t := IntToStr(j);
while Length(t) < 3 do
t := '0' + t;
if s <> '' then
t := t + ' ' + s;
if Assigned(EditInfos) then
EditInfos.AddObject(t, TObject(j))
else if j = aInt then begin
case aType of
ctToStr, ctToEditValue: Result := t;
ctCheck: Result := '';
end;
Exit;
end;
end;
end;
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
ctEditInfo: begin
EditInfos.Sort;
Result := EditInfos.CommaText;
end;
end;
finally
FreeAndNil(EditInfos);
end;
end;
function wbCTDAParam2QuestObjectiveToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
EditInfos : TStringList;
Objectives : IwbContainerElementRef;
Objective : IwbContainerElementRef;
i, j : Integer;
s, t : string;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Param1 := Container.ElementByName['Parameter #1'];
if not Assigned(Param1) then
Exit;
if not Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
Exit;
MainRecord := MainRecord.WinningOverride;
if MainRecord.Signature <> QUST then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
case aType of
ctEditType: begin
Result := 'ComboBox';
Exit;
end;
ctEditInfo:
EditInfos := TStringList.Create;
else
EditInfos := nil;
end;
try
if Supports(MainRecord.ElementByName['Objectives'], IwbContainerElementRef, Objectives) then begin
for i := 0 to Pred(Objectives.ElementCount) do
if Supports(Objectives.Elements[i], IwbContainerElementRef, Objective) then begin
j := Objective.ElementNativeValues['QOBJ'];
s := Trim(Objective.ElementValues['NNAM']);
t := IntToStr(j);
while Length(t) < 3 do
t := '0' + t;
if s <> '' then
t := t + ' ' + s;
if Assigned(EditInfos) then
EditInfos.AddObject(t, TObject(j))
else if j = aInt then begin
case aType of
ctToStr, ctToEditValue: Result := t;
ctCheck: Result := '';
end;
Exit;
end;
end;
end;
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
ctEditInfo: begin
EditInfos.Sort;
Result := EditInfos.CommaText;
end;
end;
finally
FreeAndNil(EditInfos);
end;
end;
function wbCTDAParam2QuestStageToInt(const aString: string; const aElement: IwbElement): Int64;
var
i : Integer;
s : string;
begin
i := 1;
s := Trim(aString);
while (i <= Length(s)) and (s[i] in ['0'..'9']) do
Inc(i);
s := Copy(s, 1, Pred(i));
Result := StrToInt(s);
end;
function wbCTDAParam2QuestObjectiveToInt(const aString: string; const aElement: IwbElement): Int64;
var
i : Integer;
s : string;
begin
i := 1;
s := Trim(aString);
while (i <= Length(s)) and (s[i] in ['0'..'9']) do
Inc(i);
s := Copy(s, 1, Pred(i));
Result := StrToInt(s);
end;
function wbClmtMoonsPhaseLength(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
PhaseLength : Byte;
Masser : Boolean;
Secunda : Boolean;
begin
Result := '';
if aType = ctToSortKey then begin
Result := IntToHex64(aInt, 2);
end else if aType = ctToStr then begin
PhaseLength := aInt mod 64;
Masser := (aInt and 64) <> 0;
Secunda := (aInt and 128) <> 0;
if Masser then
if Secunda then
Result := 'Masser, Secunda / '
else
Result := 'Masser / '
else
if Secunda then
Result := 'Secunda / '
else
Result := 'No Moon / ';
Result := Result + IntToStr(PhaseLength);
end;
end;
function wbClmtTime(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
if aType = ctToSortKey then
Result := IntToHex64(aInt, 4)
else if aType = ctToStr then
Result := TimeToStr( EncodeTime(aInt div 6, (aInt mod 6) * 10, 0, 0) )
else
Result := '';
end;
function wbREFRNavmeshTriangleToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
Navmesh : IwbElement;
MainRecord : IwbMainRecord;
Triangles : IwbContainerElementRef;
begin
case aType of
ctToStr: Result := IntToStr(aInt);
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Navmesh := Container.Elements[0];
if not Assigned(Navmesh) then
Exit;
if not Supports(Navmesh.LinksTo, IwbMainRecord, MainRecord) then
Exit;
MainRecord := MainRecord.WinningOverride;
if MainRecord.Signature <> NAVM then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
if not wbSimpleRecords and (aType = ctCheck) and Supports(MainRecord.ElementByPath['NVTR'], IwbContainerElementRef, Triangles) then
if aInt >= Triangles.ElementCount then
Result := '';
end;
function wbStringToInt(const aString: string; const aElement: IwbElement): Int64;
begin
Result := StrToIntDef(aString, 0);
end;
var
wbCtdaTypeFlags : IwbFlagsDef;
function wbCtdaTypeToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
s: string;
begin
Result := '';
case aType of
ctEditType:
Result := 'CheckComboBox';
ctEditInfo:
Result := 'Equal,Greater,Lesser,Or,"Use Global","Run on Target"';
ctToEditValue: begin
Result := '000000';
case aInt and $F0 of
$00 : Result[1] := '1';
$40 : Result[2] := '1';
$60 : begin
Result[1] := '1';
Result[2] := '1';
end;
$80 : Result[3] := '1';
$A0 : begin
Result[1] := '1';
Result[3] := '1';
end;
end;
if (aInt and $01) <> 0 then
Result[4] := '1';
if (aInt and $02) <> 0 then
Result[6] := '1';
if (aInt and $04) <> 0 then
Result[5] := '1';
end;
ctToStr: begin
case aInt and $F0 of
$00 : Result := 'Equal to';
$20 : Result := 'Not equal to';
$40 : Result := 'Greater than';
$60 : Result := 'Greater than or equal to';
$80 : Result := 'Less than';
$A0 : Result := 'Less than or equal to';
else
Result := ''
end;
if not Assigned(wbCtdaTypeFlags) then
wbCtdaTypeFlags := wbFlags([
{0x01} 'Or',
{0x02} 'Run on target',
{0x04} 'Use global'
]);
s := wbCtdaTypeFlags.ToString(aInt and $0F, aElement);
if s <> '' then
Result := Result + ' / ' + s;
end;
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
Exit;
end;
ctCheck: begin
case aInt and $F0 of
$00, $20, $40, $60, $80, $A0 : Result := '';
else
Result := ''
end;
if not Assigned(wbCtdaTypeFlags) then
wbCtdaTypeFlags := wbFlags([
{0x01} 'Or',
{0x02} 'Run on target',
{0x04} 'Use global'
]);
s := wbCtdaTypeFlags.Check(aInt and $0F, aElement);
if s <> '' then
Result := Result + ' / ' + s;
end;
end;
end;
function wbCtdaTypeToInt(const aString: string; const aElement: IwbElement): Int64;
var
s: string;
begin
s := aString + '000000';
// Result := 0;
if s[1] = '1' then begin
if s[2] = '1' then begin
if s[3] = '1' then begin
Result := $00;
end else begin
Result := $60;
end;
end else begin
if s[3] = '1' then begin
Result := $A0;
end else begin
Result := $00;
end;
end;
end else begin
if s[2] = '1' then begin
if s[3] = '1' then begin
Result := $20;
end else begin
Result := $40;
end;
end else begin
if s[3] = '1' then begin
Result := $80;
end else begin
Result := $20;
end;
end;
end;
if s[4] = '1' then
Result := Result or $01;
if s[6] = '1' then
Result := Result or $02;
if s[5] = '1' then
Result := Result or $04;
end;
procedure wbHeadPartsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container : IwbContainerElementRef;
begin
if wbBeginInternalEdit then try
if Supports(aElement, IwbContainerElementRef, Container) then
if (Container.Elements[0].NativeValue = 1) and (Container.ElementCount > 2) then
Container.RemoveElement(1);
finally
wbEndInternalEdit;
end;
end;
procedure wbMESGDNAMAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldValue, NewValue : Integer;
Container : IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if Supports(aElement.Container, IwbContainerElementRef, Container) then begin
OldValue := Integer(aOldValue) and 1;
NewValue := Integer(aNewValue) and 1;
if NewValue = OldValue then
Exit;
if NewValue = 1 then
Container.RemoveElement('TNAM')
else
Container.Add('TNAM', True);
end;
end;
procedure wbGMSTEDIDAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldValue, NewValue : string;
Container : IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if Supports(aElement.Container, IwbContainerElementRef, Container) then begin
OldValue := aOldValue;
NewValue := aNewValue;
if (Length(OldValue) < 1) or (Length(OldValue) < 1) or (OldValue[1] <> NewValue[1]) then begin
Container.RemoveElement('DATA');
Container.Add('DATA', True);
end;
end;
end;
procedure wbFLSTEDIDAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldValue, NewValue : string;
OldOrdered, NewOrdered : Boolean;
Container : IwbContainerElementRef;
const
OrderedList = 'OrderedList';
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if Supports(aElement.Container, IwbContainerElementRef, Container) then begin
OldValue := aOldValue;
NewValue := aNewValue;
if Length(OldValue) > Length(OrderedList) then
Delete(OldValue, 1, Length(OldValue)-Length(OrderedList));
if Length(NewValue) > Length(OrderedList) then
Delete(NewValue, 1, Length(NewValue)-Length(OrderedList));
OldOrdered := SameText(OldValue, OrderedList);
NewOrdered := SameText(NewValue, OrderedList);
if OldOrdered <> NewOrdered then
Container.RemoveElement('FormIDs');
end;
end;
procedure wbCtdaTypeAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldValue, NewValue: Integer;
Container: IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
OldValue := aOldValue and $04;
NewValue := aNewValue and $04;
if OldValue <> NewValue then
Container.ElementNativeValues['..\Comparison Value'] := 0;
if aNewValue and $02 then begin
Container.ElementNativeValues['..\Run On'] := 1;
if Integer(Container.ElementNativeValues['..\Run On']) = 1 then
aElement.NativeValue := Byte(aNewValue) and not $02;
end;
end;
function wbMODTCallback(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Strings: TDynStrings;
i: Integer;
begin
Result := '';
if wbLoaderDone and (aType in [ctToStr, ctToSortKey] ) then begin
Strings := wbContainerHandler.ResolveHash(aInt);
for i := Low(Strings) to High(Strings) do
Result := Result + Strings[i] + ', ';
SetLength(Result, Length(Result) -2 );
end;
end;
function wbIdleAnam(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
case aType of
ctToStr: begin
case aInt and not $C0 of
0: Result := 'Idle';
1: Result := 'Movement';
2: Result := 'Left Arm';
3: Result := 'Left Hand';
4: Result := 'Weapon';
5: Result := 'Weapon Up';
6: Result := 'Weapon Down';
7: Result := 'Special Idle';
20: Result := 'Whole Body';
21: Result := 'Upper Body';
else
Result := '';
end;
if (aInt and $80) = 0 then
Result := Result + ', Must return a file';
if (aInt and $40) = 1 then
Result := Result + ', Unknown Flag';
end;
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
end;
ctCheck: begin
case aInt and not $C0 of
0..7, 20, 21: Result := '';
else
Result := '';
end;
end;
end;
end;
function wbScaledInt4ToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
const
PlusMinus : array[Boolean] of string = ('+', '-');
begin
Result := '';
case aType of
ctToStr, ctToEditValue: Result := FloatToStrF(aInt / 10000, ffFixed, 99, 4);
ctToSortKey: begin
Result := FloatToStrF(aInt / 10000, ffFixed, 99, 4);
if Length(Result) < 22 then
Result := StringOfChar('0', 22 - Length(Result)) + Result;
Result := PlusMinus[aInt < 0] + Result;
end;
ctCheck: Result := '';
end;
end;
function wbScaledInt4ToInt(const aString: string; const aElement: IwbElement): Int64;
var
f: Extended;
begin
f := StrToFloat(aString);
f := f * 10000;
Result := Round(f);
end;
function wbHideFFFF(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
if aType = ctToSortKey then
Result := IntToHex64(aInt, 4)
else if aType = ctToStr then
if aInt = $FFFF then
Result := 'None'
else
Result := IntToStr(aInt);
end;
function wbAtxtPosition(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
if aType = ctToSortKey then
Result := IntToHex64(aInt div 17, 2) + IntToHex64(aInt mod 17, 2)
else if aType = ctCheck then begin
if (aInt < 0) or (aInt > 288) then
Result := ''
else
Result := '';
end else if aType = ctToStr then
Result := IntToStr(aInt) + ' -> ' + IntToStr(aInt div 17) + ':' + IntToStr(aInt mod 17);
end;
function wbGLOBFNAM(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
case aType of
ctToStr: begin
case aInt of
Ord('s'): Result := 'Short';
Ord('l'): Result := 'Long';
Ord('f'): Result := 'Float';
else
Result := '';
end;
end;
ctToSortKey: Result := Chr(aInt);
ctCheck: begin
case aInt of
Ord('s'), Ord('l'), Ord('f'): Result := '';
else
Result := '';
end;
end;
end;
end;
function wbPlacedAddInfo(const aMainRecord: IwbMainRecord): string;
var
Rec: IwbRecord;
Container: IwbContainer;
s: string;
Cell: IwbMainRecord;
Position: TwbVector;
Grid: TwbGridCell;
begin
Result := '';
Rec := aMainRecord.RecordBySignature['NAME'];
if Assigned(Rec) then begin
s := Trim(Rec.Value);
if s <> '' then
Result := 'places ' + s;
end;
Container := aMainRecord.Container;
while Assigned(Container) and (Container.ElementType <> etGroupRecord) do
Container := Container.Container;
if Assigned(Container) then begin
s := Trim(Container.Name);
if s <> '' then begin
if Result <> '' then
Result := Result + ' ';
Result := Result + 'in ' + s;
// grid position of persistent reference in exterior persistent cell (interior cells are not persistent)
if Supports(aMainRecord.Container, IwbGroupRecord, Container) then
Cell := IwbGroupRecord(Container).ChildrenOf;
if Assigned(Cell) and Cell.IsPersistent and (Cell.Signature = 'CELL') then
if aMainRecord.GetPosition(Position) then begin
Grid := wbPositionToGridCell(Position);
Result := Result + ' at ' + IntToStr(Grid.x) + ',' + IntToStr(Grid.y);
end;
end;
end;
end;
function wbINFOAddInfo(const aMainRecord: IwbMainRecord): string;
var
Container: IwbContainer;
s: string;
begin
Result := Trim(aMainRecord.ElementValues['Responses\Response\NAM1']);
if Result <> '' then
Result := '''' + Result + '''';
Container := aMainRecord.Container;
while Assigned(Container) and (Container.ElementType <> etGroupRecord) do
Container := Container.Container;
if Assigned(Container) then begin
s := Trim(Container.Name);
if s <> '' then begin
if Result <> '' then
Result := Result + ' ';
Result := Result + 'in ' + s;
end;
end;
s := Trim(aMainRecord.ElementValues['QSTI']);
if s <> '' then begin
if Result <> '' then
Result := Result + ' ';
Result := Result + 'for ' + s;
end;
end;
function wbNAVMAddInfo(const aMainRecord: IwbMainRecord): string;
var
Rec : IwbRecord;
Element : IwbElement;
s : string;
begin
Result := '';
Rec := aMainRecord.RecordBySignature['DATA'];
if Assigned(Rec) then begin
Element := Rec.ElementByName['Cell'];
if Assigned(Element) then
Element := Element.LinksTo;
if Assigned(Element) then
s := Trim(Element.Name);
if s <> '' then
Result := 'for ' + s;
end;
end;
function wbCellAddInfo(const aMainRecord: IwbMainRecord): string;
var
Rec: IwbRecord;
Container: IwbContainer;
GroupRecord : IwbGroupRecord;
s: string;
begin
Result := '';
if not aMainRecord.IsPersistent then begin
Rec := aMainRecord.RecordBySignature['XCLC'];
if Assigned(Rec) then
Result := 'at ' + Rec.Elements[0].Value + ',' + Rec.Elements[1].Value;
end;
Container := aMainRecord.Container;
while Assigned(Container) and not
(Supports(Container, IwbGroupRecord, GroupRecord) and (GroupRecord.GroupType = 1)) do
Container := Container.Container;
if Assigned(Container) then begin
s := wbFormID.ToString(GroupRecord.GroupLabel, aMainRecord);
if s <> '' then begin
if Result <> '' then
s := s + ' ';
Result := 'in ' + s + Result;
end;
end;
end;
function wbWthrDataClassification(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
case aType of
ctToStr: begin
case aInt and not 192 of
0: Result := 'None';
1: Result := 'Pleasant';
2: Result := 'Cloudy';
4: Result := 'Rainy';
8: Result := 'Snow';
else
Result := '';
end;
end;
ctToSortKey: begin
Result := IntToHex64(aInt, 2)
end;
ctCheck: begin
case aInt and not 192 of
0, 1, 2, 4, 8: Result := '';
else
Result := '';
end;
end;
end;
end;
function wbNOTETNAMDecide(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
rDATA: IwbRecord;
begin
Result := 0;
rDATA := aElement.Container.RecordBySignature[DATA];
if Assigned(rDATA) then
if rDATA.NativeValue = 3 then //Voice
Result := 1;
end;
function wbNOTESNAMDecide(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
rDATA: IwbRecord;
begin
Result := 0;
rDATA := aElement.Container.RecordBySignature[DATA];
if Assigned(rDATA) then
if rDATA.NativeValue = 3 then //Voice
Result := 1;
end;
function wbIPDSDATACount(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
begin
if Assigned(aBasePtr) and Assigned(aEndPtr) then
Result := (Cardinal(aBasePtr) - Cardinal(aBasePtr)) div 4
else
Result := 12;
end;
function wbNAVINAVMGetCount1(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
DataContainer : IwbDataContainer;
begin
Result := 0;
if Supports(aElement, IwbDataContainer, DataContainer) then begin
if DataContainer.ElementType = etArray then
if not Supports(DataContainer.Container, IwbDataContainer, DataContainer) then
Exit;
Assert(DataContainer.Name = 'Data');
Result := PWord(Cardinal(DataContainer.DataBasePtr) + 3*3*4)^;
end;
end;
function wbNAVINAVMGetCount2(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
DataContainer : IwbDataContainer;
begin
Result := 0;
if Supports(aElement, IwbDataContainer, DataContainer) then begin
if DataContainer.ElementType = etArray then
if not Supports(DataContainer.Container, IwbDataContainer, DataContainer) then
Exit;
Assert(DataContainer.Name = 'Data');
Result := PWord(Cardinal(DataContainer.DataBasePtr) + 3*3*4 + 2)^;
end;
end;
procedure wbCTDARunOnAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
if aOldValue <> aNewValue then
if aNewValue <> 2 then
aElement.Container.ElementNativeValues['Reference'] := 0;
end;
procedure wbPERKPRKETypeAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container : IwbContainerElementRef;
// rDATA : IwbRecord;
begin
if aOldValue <> aNewValue then
if Supports(aElement.Container, IwbContainerElementRef, Container) then begin
if Supports(Container.Container, IwbContainerElementRef, Container) then begin
Container.RemoveElement('DATA');
Container.Add('DATA', True);
Container.RemoveElement('Perk Conditions');
Container.RemoveElement('Entry Point Function Parameters');
if aNewValue = 2 then begin
Container.Add('EPFT', True);
Container.ElementNativeValues['DATA\Entry Point\Function'] := 2;
end;
end;
end;
end;
function wbMGEFFAssocItemDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
Archtype : Variant;
DataContainer : IwbDataContainer;
Element : IwbElement;
const
OffsetArchtype = 56;
begin
Result := 1;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
VarClear(ArchType);
Element := Container.ElementByName['Archtype'];
if Assigned(Element) then
ArchType := Element.NativeValue
else if Supports(Container, IwbDataContainer, DataContainer) and
DataContainer.IsValidOffset(aBasePtr, aEndPtr, OffsetArchtype) then
begin // we are part of a proper structure
aBasePtr := Pointer(Cardinal(aBasePtr) + OffsetArchtype);
ArchType := PCardinal(aBasePtr)^;
end;
if not VarIsEmpty(ArchType) then
case Integer(ArchType) of
01: Result := 2;//Script
18: Result := 3;//Bound Item
19: Result := 4;//Summon Creature
else
Result := 0;
end;
end;
procedure wbMGEFFAssocItemAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container : IwbContainer;
Element : IwbElement;
begin
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if (aNewValue <> 0) then begin
Element := Container.ElementByName['Archtype'];
if Assigned(Element) and Element.NativeValue = 0 then
Element.NativeValue := $FF; // Signals ArchType that it should not mess with us on the next change!
end;
end;
procedure wbMGEFArchtypeAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container: IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if (aNewValue < $FF) and (aOldValue < $FF) then begin
Container.ElementNativeValues['..\Assoc. Item'] := 0;
case Integer(aNewValue) of
11: Container.ElementNativeValues['..\Actor Value'] := 48;//Invisibility
12: Container.ElementNativeValues['..\Actor Value'] := 49;//Chameleon
24: Container.ElementNativeValues['..\Actor Value'] := 47;//Paralysis
else
Container.ElementNativeValues['..\Actor Value'] := -1;
end;
end;
end;
procedure wbCounterEffectsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterByPathAfterSet('DATA - Data\Counter effect count', aElement);
end;
procedure wbMGEFAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterContainerByPathAfterSet('DATA - Data\Counter effect count', 'Counter Effects', aElement);
end;
function wbCTDAReferenceDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Integer(Container.ElementNativeValues['Run On']) = 2 then
Result := 1;
end;
function wbNAVINVMIDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
case Integer(Container.ElementNativeValues['Type']) of
$00: Result :=1;
$20: Result :=2;
$30: Result :=3;
end;
end;
function wbIMGSSkinDimmerDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
SubRecord : IwbSubRecord;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Supports(Container, IwbSubRecord, SubRecord) then
if SubRecord.SubRecordHeaderSize in [132, 148] then
Result := 1;
end;
function wbCOEDOwnerDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
LinksTo : IwbElement;
MainRecord : IwbMainRecord;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
LinksTo := Container.ElementByName['Owner'].LinksTo;
if Supports(LinksTo, IwbMainRecord, MainRecord) then
if MainRecord.Signature = 'NPC_' then
Result := 1
else if MainRecord.Signature = 'FACT' then
Result := 2;
end;
function wbCreaLevelDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
i: Int64;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
i := Container.ElementByName['Flags'].NativeValue;
if i and $00000080 <> 0 then
Result := 1;
end;
function wbGMSTUnionDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
rEDID: IwbRecord;
s: string;
begin
Result := 1;
rEDID := aElement.Container.RecordBySignature[EDID];
if Assigned(rEDID) then begin
s := rEDID.Value;
if Length(s) > 0 then
case s[1] of
's': Result := 0;
'f': Result := 2;
end;
end;
end;
function wbFLSTLNAMIsSorted(const aContainer: IwbContainer): Boolean;
var
rEDID : IwbRecord;
s : string;
_File : IwbFile;
MainRecord : IwbMainRecord;
const
OrderedList = 'OrderedList';
begin
Result := wbSortFLST; {>>> Should not be sorted according to Arthmoor and JustinOther, left as sorted for compatibility <<<}
rEDID := aContainer.RecordBySignature[EDID];
if Assigned(rEDID) then begin
s := rEDID.Value;
if Length(s) > Length(OrderedList) then
Delete(s, 1, Length(s)-Length(OrderedList));
if SameText(s, OrderedList) then
Result := False;
end;
if Result then begin
MainRecord := aContainer.ContainingMainRecord;
if not Assigned(MainRecord) then
Exit;
MainRecord := MainRecord.MasterOrSelf;
if not Assigned(MainRecord) then
Exit;
_File := MainRecord._File;
if not Assigned(_File) then
Exit;
if not SameText(_File.FileName, 'WeaponModKits.esp') then
Exit;
case (MainRecord.FormID and $FFFFFF) of
$0130EB, $0130ED, $01522D, $01522E, $0158D5, $0158D6, $0158D7, $0158D8, $0158D9, $0158DA, $0158DC, $0158DD, $018E20:
Result := False;
end;
end;
end;
function wbPerkDATADecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
rPRKE: IwbRecord;
eType: IwbElement;
begin
Result := 0;
rPRKE := aElement.Container.RecordBySignature[PRKE];
if Assigned(rPRKE) then begin
eType := rPRKE.ElementByName['Type'];
if Assigned(eType) then begin
Result := eType.NativeValue;
end;
end;
end;
function wbEPFDDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainerElementRef;
begin
Result := 0;
if not Assigned(aElement) then
Exit;
if not Supports(aElement.Container, IwbContainerElementRef, Container) then
Exit;
Result := Container.ElementNativeValues['EPFT'];
if Result = 2 then
if Integer(Container.ElementNativeValues['..\DATA\Entry Point\Function']) = 5 then
Result := 5;
end;
type
TCTDAFunctionParamType = (
ptNone,
ptInteger,
ptVariableName, //Integer
ptSex, //Enum: Male, Female
ptActorValue, //Enum: wbActorValue
ptCrimeType, //?? Enum
ptAxis, //?? Char
ptQuestStage, //?? Integer
ptMiscStat, //?? Enum
ptAlignment, //?? Enum
ptEquipType, //?? Enum
ptFormType, //?? Enum
ptCriticalStage, //?? Enum
ptObjectReference, //REFR, ACHR, ACRE, PGRE
ptInventoryObject, //ARMO, BOOK, MISC, WEAP, AMMO, KEYM, ALCH, NOTE, ARMA
ptActor, //ACHR, ACRE
ptVoiceType, //VTYP
ptIdleForm, //IDLE
ptFormList, //FLST
ptNote, //NOTE
ptQuest, //QUST
ptFaction, //FACT
ptWeapon, //WEAP
ptCell, //CELL
ptClass, //CLAS
ptRace, //RACE
ptActorBase, //NPC_, CREA
ptGlobal, //GLOB
ptWeather, //WTHR
ptPackage, //PACK
ptEncounterZone, //ECZN
ptPerk, //PERK
ptOwner, //FACT, NPC_
ptFurniture, //FURN
ptMagicItem, //SPEL
ptMagicEffect, //MGEF
ptWorldspace, //WRLD
ptVATSValueFunction,
ptVATSValueParam,
ptCreatureType,
ptMenuMode,
ptPlayerAction,
ptBodyLocation,
ptReferencableObject //TREE, SOUN, ACTI, DOOR, STAT, FURN, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS, ASPC, IDLM, ARMA, MSTT, NOTE, PWAT, SCOL, TACT, TERM
);
PCTDAFunction = ^TCTDAFunction;
TCTDAFunction = record
Index: Integer;
Name: string;
ParamType1: TCTDAFunctionParamType;
ParamType2: TCTDAFunctionParamType;
end;
const
wbCTDAFunctions : array[0..243] of TCTDAFunction = (
(Index: 1; Name: 'GetDistance'; ParamType1: ptObjectReference),
(Index: 5; Name: 'GetLocked'),
(Index: 6; Name: 'GetPos'; ParamType1: ptAxis),
(Index: 8; Name: 'GetAngle'; ParamType1: ptAxis),
(Index: 10; Name: 'GetStartingPos'; ParamType1: ptAxis),
(Index: 11; Name: 'GetStartingAngle'; ParamType1: ptAxis),
(Index: 12; Name: 'GetSecondsPassed'),
(Index: 14; Name: 'GetActorValue'; ParamType1: ptActorValue),
(Index: 18; Name: 'GetCurrentTime'),
(Index: 24; Name: 'GetScale'),
(Index: 25; Name: 'IsMoving'),
(Index: 26; Name: 'IsTurning'),
(Index: 27; Name: 'GetLineOfSight'; ParamType1: ptObjectReference),
(Index: 32; Name: 'GetInSameCell'; ParamType1: ptObjectReference),
(Index: 35; Name: 'GetDisabled'),
(Index: 36; Name: 'MenuMode'; ParamType1: ptMenuMode),
(Index: 39; Name: 'GetDisease'),
(Index: 40; Name: 'GetVampire'),
(Index: 41; Name: 'GetClothingValue'),
(Index: 42; Name: 'SameFaction'; ParamType1: ptActor),
(Index: 43; Name: 'SameRace'; ParamType1: ptActor),
(Index: 44; Name: 'SameSex'; ParamType1: ptActor),
(Index: 45; Name: 'GetDetected'; ParamType1: ptActor),
(Index: 46; Name: 'GetDead'),
(Index: 47; Name: 'GetItemCount'; ParamType1: ptInventoryObject),
(Index: 48; Name: 'GetGold'),
(Index: 49; Name: 'GetSleeping'),
(Index: 50; Name: 'GetTalkedToPC'),
(Index: 53; Name: 'GetScriptVariable'; ParamType1: ptObjectReference; ParamType2: ptVariableName),
(Index: 56; Name: 'GetQuestRunning'; ParamType1: ptQuest),
(Index: 58; Name: 'GetStage'; ParamType1: ptQuest),
(Index: 59; Name: 'GetStageDone'; ParamType1: ptQuest; ParamType2: ptQuestStage),
(Index: 60; Name: 'GetFactionRankDifference'; ParamType1: ptFaction; ParamType2: ptActor),
(Index: 61; Name: 'GetAlarmed'),
(Index: 62; Name: 'IsRaining'),
(Index: 63; Name: 'GetAttacked'),
(Index: 64; Name: 'GetIsCreature'),
(Index: 65; Name: 'GetLockLevel'),
(Index: 66; Name: 'GetShouldAttack'; ParamType1: ptActor),
(Index: 67; Name: 'GetInCell'; ParamType1: ptCell),
(Index: 68; Name: 'GetIsClass'; ParamType1: ptClass),
(Index: 69; Name: 'GetIsRace'; ParamType1: ptRace),
(Index: 70; Name: 'GetIsSex'; ParamType1: ptSex),
(Index: 71; Name: 'GetInFaction'; ParamType1: ptFaction),
(Index: 72; Name: 'GetIsID'; ParamType1: ptReferencableObject),
(Index: 73; Name: 'GetFactionRank'; ParamType1: ptFaction),
(Index: 74; Name: 'GetGlobalValue'; ParamType1: ptGlobal),
(Index: 75; Name: 'IsSnowing'),
(Index: 76; Name: 'GetDisposition'; ParamType1: ptActor),
(Index: 77; Name: 'GetRandomPercent'),
(Index: 79; Name: 'GetQuestVariable'; ParamType1: ptQuest; ParamType2: ptVariableName),
(Index: 80; Name: 'GetLevel'),
(Index: 81; Name: 'GetArmorRating'),
(Index: 84; Name: 'GetDeadCount'; ParamType1: ptActorBase),
(Index: 91; Name: 'GetIsAlerted'),
(Index: 98; Name: 'GetPlayerControlsDisabled'; ParamType1: ptInteger; ParamType2: ptInteger{; ParamType3: ptInteger; ParamType4: ptInteger; ParamType5: ptInteger; ParamType6: ptInteger; ParamType7: ptInteger}),
(Index: 99; Name: 'GetHeadingAngle'; ParamType1: ptObjectReference),
(Index: 101; Name: 'IsWeaponOut'),
(Index: 102; Name: 'IsTorchOut'),
(Index: 103; Name: 'IsShieldOut'),
(Index: 106; Name: 'IsFacingUp'),
(Index: 107; Name: 'GetKnockedState'),
(Index: 108; Name: 'GetWeaponAnimType'),
(Index: 109; Name: 'IsWeaponSkillType'; ParamType1: ptActorValue),
(Index: 110; Name: 'GetCurrentAIPackage'),
(Index: 111; Name: 'IsWaiting'),
(Index: 112; Name: 'IsIdlePlaying'),
(Index: 116; Name: 'GetMinorCrimeCount'),
(Index: 117; Name: 'GetMajorCrimeCount'),
(Index: 118; Name: 'GetActorAggroRadiusViolated'),
(Index: 122; Name: 'GetCrime'; ParamType1: ptActor; ParamType2: ptCrimeType),
(Index: 123; Name: 'IsGreetingPlayer'),
(Index: 125; Name: 'IsGuard'),
(Index: 127; Name: 'HasBeenEaten'),
(Index: 128; Name: 'GetFatiguePercentage'),
(Index: 129; Name: 'GetPCIsClass'; ParamType1: ptClass),
(Index: 130; Name: 'GetPCIsRace'; ParamType1: ptRace),
(Index: 131; Name: 'GetPCIsSex'; ParamType1: ptSex),
(Index: 132; Name: 'GetPCInFaction'; ParamType1: ptFaction),
(Index: 133; Name: 'SameFactionAsPC'),
(Index: 134; Name: 'SameRaceAsPC'),
(Index: 135; Name: 'SameSexAsPC'),
(Index: 136; Name: 'GetIsReference'; ParamType1: ptObjectReference),
(Index: 141; Name: 'IsTalking'),
(Index: 142; Name: 'GetWalkSpeed'),
(Index: 143; Name: 'GetCurrentAIProcedure'),
(Index: 144; Name: 'GetTrespassWarningLevel'),
(Index: 145; Name: 'IsTrespassing'),
(Index: 146; Name: 'IsInMyOwnedCell'),
(Index: 147; Name: 'GetWindSpeed'),
(Index: 148; Name: 'GetCurrentWeatherPercent'),
(Index: 149; Name: 'GetIsCurrentWeather'; ParamType1: ptWeather),
(Index: 150; Name: 'IsContinuingPackagePCNear'),
(Index: 153; Name: 'CanHaveFlames'),
(Index: 154; Name: 'HasFlames'),
(Index: 157; Name: 'GetOpenState'),
(Index: 159; Name: 'GetSitting'),
(Index: 160; Name: 'GetFurnitureMarkerID'),
(Index: 161; Name: 'GetIsCurrentPackage'; ParamType1: ptPackage),
(Index: 162; Name: 'IsCurrentFurnitureRef'; ParamType1: ptObjectReference),
(Index: 163; Name: 'IsCurrentFurnitureObj'; ParamType1: ptFurniture),
(Index: 170; Name: 'GetDayOfWeek'),
(Index: 172; Name: 'GetTalkedToPCParam'; ParamType1: ptActor),
(Index: 175; Name: 'IsPCSleeping'),
(Index: 176; Name: 'IsPCAMurderer'),
(Index: 180; Name: 'GetDetectionLevel'; ParamType1: ptActor),
(Index: 182; Name: 'GetEquipped'; ParamType1: ptInventoryObject),
(Index: 185; Name: 'IsSwimming'),
(Index: 190; Name: 'GetAmountSoldStolen'),
(Index: 192; Name: 'GetIgnoreCrime'),
(Index: 193; Name: 'GetPCExpelled'; ParamType1: ptFaction),
(Index: 195; Name: 'GetPCFactionMurder'; ParamType1: ptFaction),
(Index: 197; Name: 'GetPCEnemyofFaction'; ParamType1: ptFaction),
(Index: 199; Name: 'GetPCFactionAttack'; ParamType1: ptFaction),
(Index: 203; Name: 'GetDestroyed'),
(Index: 214; Name: 'HasMagicEffect'; ParamType1: ptMagicEffect),
(Index: 215; Name: 'GetDefaultOpen'),
(Index: 219; Name: 'GetAnimAction'),
(Index: 223; Name: 'IsSpellTarget'; ParamType1: ptMagicItem),
(Index: 224; Name: 'GetVATSMode'),
(Index: 225; Name: 'GetPersuasionNumber'),
(Index: 226; Name: 'GetSandman'),
(Index: 227; Name: 'GetCannibal'),
(Index: 228; Name: 'GetIsClassDefault'; ParamType1: ptClass),
(Index: 229; Name: 'GetClassDefaultMatch'),
(Index: 230; Name: 'GetInCellParam'; ParamType1: ptCell; ParamType2: ptObjectReference),
(Index: 235; Name: 'GetVatsTargetHeight'),
(Index: 237; Name: 'GetIsGhost'),
(Index: 242; Name: 'GetUnconscious'),
(Index: 244; Name: 'GetRestrained'),
(Index: 246; Name: 'GetIsUsedItem'; ParamType1: ptReferencableObject),
(Index: 247; Name: 'GetIsUsedItemType'; ParamType1: ptFormType),
(Index: 254; Name: 'GetIsPlayableRace'),
(Index: 255; Name: 'GetOffersServicesNow'),
(Index: 258; Name: 'GetUsedItemLevel'),
(Index: 259; Name: 'GetUsedItemActivate'),
(Index: 264; Name: 'GetBarterGold'),
(Index: 265; Name: 'IsTimePassing'),
(Index: 266; Name: 'IsPleasant'),
(Index: 267; Name: 'IsCloudy'),
(Index: 274; Name: 'GetArmorRatingUpperBody'),
(Index: 277; Name: 'GetBaseActorValue'; ParamType1: ptActorValue),
(Index: 278; Name: 'IsOwner'; ParamType1: ptOwner),
(Index: 280; Name: 'IsCellOwner'; ParamType1: ptCell; ParamType2: ptOwner),
(Index: 282; Name: 'IsHorseStolen'),
(Index: 285; Name: 'IsLeftUp'),
(Index: 286; Name: 'IsSneaking'),
(Index: 287; Name: 'IsRunning'),
(Index: 288; Name: 'GetFriendHit'),
(Index: 289; Name: 'IsInCombat'),
(Index: 300; Name: 'IsInInterior'),
(Index: 304; Name: 'IsWaterObject'),
(Index: 306; Name: 'IsActorUsingATorch'),
(Index: 309; Name: 'IsXBox'),
(Index: 310; Name: 'GetInWorldspace'; ParamType1: ptWorldSpace),
(Index: 312; Name: 'GetPCMiscStat'; ParamType1: ptMiscStat),
(Index: 313; Name: 'IsActorEvil'),
(Index: 314; Name: 'IsActorAVictim'),
(Index: 315; Name: 'GetTotalPersuasionNumber'),
(Index: 318; Name: 'GetIdleDoneOnce'),
(Index: 320; Name: 'GetNoRumors'),
(Index: 323; Name: 'WhichServiceMenu'),
(Index: 327; Name: 'IsRidingHorse'),
(Index: 332; Name: 'IsInDangerousWater'),
(Index: 338; Name: 'GetIgnoreFriendlyHits'),
(Index: 339; Name: 'IsPlayersLastRiddenHorse'),
(Index: 353; Name: 'IsActor'),
(Index: 354; Name: 'IsEssential'),
(Index: 358; Name: 'IsPlayerMovingIntoNewSpace'),
(Index: 361; Name: 'GetTimeDead'),
(Index: 362; Name: 'GetPlayerHasLastRiddenHorse'),
(Index: 365; Name: 'IsChild'),
(Index: 367; Name: 'GetLastPlayerAction'),
(Index: 368; Name: 'IsPlayerActionActive'; ParamType1: ptPlayerAction),
(Index: 370; Name: 'IsTalkingActivatorActor'; ParamType1: ptActor),
(Index: 372; Name: 'IsInList'; ParamType1: ptFormList),
(Index: 382; Name: 'GetHasNote'; ParamType1: ptNote),
(Index: 391; Name: 'GetHitLocation'),
(Index: 392; Name: 'IsPC1stPerson'),
(Index: 397; Name: 'GetCauseofDeath'),
(Index: 398; Name: 'IsLimbGone'; ParamType1: ptBodyLocation),
(Index: 399; Name: 'IsWeaponInList'; ParamType1: ptFormList),
(Index: 403; Name: 'HasFriendDisposition'),
(Index: 408; Name: 'GetVATSValue'; ParamType1: ptVATSValueFunction; ParamType2: ptVATSValueParam),
(Index: 409; Name: 'IsKiller'; ParamType1: ptActor),
(Index: 410; Name: 'IsKillerObject'; ParamType1: ptFormList),
(Index: 411; Name: 'GetFactionCombatReaction'; ParamType1: ptFaction; ParamType2: ptFaction),
(Index: 415; Name: 'Exists'; ParamType1: ptObjectReference),
(Index: 416; Name: 'GetGroupMemberCount'),
(Index: 417; Name: 'GetGroupTargetCount'),
(Index: 427; Name: 'GetIsVoiceType'; ParamType1: ptVoiceType),
(Index: 428; Name: 'GetPlantedExplosive'),
(Index: 430; Name: 'IsActorTalkingThroughActivator'),
(Index: 431; Name: 'GetHealthPercentage'),
(Index: 433; Name: 'GetIsObjectType'; ParamType1: ptFormType),
(Index: 435; Name: 'GetDialogueEmotion'),
(Index: 436; Name: 'GetDialogueEmotionValue'),
(Index: 438; Name: 'GetIsCreatureType'; ParamType1: ptCreatureType),
(Index: 446; Name: 'GetInZone'; ParamType1: ptEncounterZone),
(Index: 449; Name: 'HasPerk'; ParamType1: ptPerk),
(Index: 450; Name: 'GetFactionRelation'; ParamType1: ptActor),
(Index: 451; Name: 'IsLastIdlePlayed'; ParamType1: ptIdleForm),
(Index: 454; Name: 'GetPlayerTeammate'),
(Index: 455; Name: 'GetPlayerTeammateCount'),
(Index: 459; Name: 'GetActorCrimePlayerEnemy'),
(Index: 460; Name: 'GetActorFactionPlayerEnemy'),
(Index: 464; Name: 'IsPlayerGrabbedRef'; ParamType1: ptObjectReference),
(Index: 471; Name: 'GetDestructionStage'),
(Index: 474; Name: 'GetIsAlignment'; ParamType1: ptAlignment),
(Index: 478; Name: 'GetThreatRatio'; ParamType1: ptActor),
(Index: 480; Name: 'GetIsUsedItemEquipType'; ParamType1: ptEquipType),
(Index: 489; Name: 'GetConcussed'),
(Index: 492; Name: 'GetMapMarkerVisible'),
(Index: 495; Name: 'GetPermanentActorValue'; ParamType1: ptActorValue),
(Index: 496; Name: 'GetKillingBlowLimb'),
(Index: 500; Name: 'GetWeaponHealthPerc'),
(Index: 503; Name: 'GetRadiationLevel'),
(Index: 510; Name: 'GetLastHitCritical'),
(Index: 515; Name: 'IsCombatTarget'; ParamType1: ptActor),
(Index: 518; Name: 'GetVATSRightAreaFree'; ParamType1: ptObjectReference),
(Index: 519; Name: 'GetVATSLeftAreaFree'; ParamType1: ptObjectReference),
(Index: 520; Name: 'GetVATSBackAreaFree'; ParamType1: ptObjectReference),
(Index: 521; Name: 'GetVATSFrontAreaFree'; ParamType1: ptObjectReference),
(Index: 522; Name: 'GetIsLockBroken'),
(Index: 523; Name: 'IsPS3'),
(Index: 524; Name: 'IsWin32'),
(Index: 525; Name: 'GetVATSRightTargetVisible'; ParamType1: ptObjectReference),
(Index: 526; Name: 'GetVATSLeftTargetVisible'; ParamType1: ptObjectReference),
(Index: 527; Name: 'GetVATSBackTargetVisible'; ParamType1: ptObjectReference),
(Index: 528; Name: 'GetVATSFrontTargetVisible'; ParamType1: ptObjectReference),
(Index: 531; Name: 'IsInCriticalStage'; ParamType1: ptCriticalStage),
(Index: 533; Name: 'GetXPForNextLevel'),
(Index: 546; Name: 'GetQuestCompleted'; ParamType1: ptQuest),
(Index: 550; Name: 'IsGoreDisabled'),
(Index: 555; Name: 'GetSpellUsageNum'; ParamType1: ptMagicItem),
(Index: 557; Name: 'GetActorsInHigh'),
(Index: 558; Name: 'HasLoaded3D'),
// Added by FOSE:
(Index: 1024; Name: 'GetFOSEVersion'; ),
(Index: 1025; Name: 'GetFOSERevision'; ),
(Index: 1028; Name: 'GetWeight'; ParamType1: ptInventoryObject; ),
(Index: 1082; Name: 'IsKeyPressed'; ParamType1: ptInteger;),
(Index: 1165; Name: 'GetWeaponHasScope'; ParamType1: ptInventoryObject; ),
(Index: 1166; Name: 'IsControlPressed'; ParamType1: ptInteger; ),
(Index: 1213; Name: 'GetFOSEBeta'; )
);
var
wbCTDAFunctionEditInfo: string;
function wbCTDAParamDescFromIndex(aIndex: Integer): PCTDAFunction;
var
L, H, I, C: Integer;
begin
Result := nil;
L := Low(wbCTDAFunctions);
H := High(wbCTDAFunctions);
while L <= H do begin
I := (L + H) shr 1;
C := CmpW32(wbCTDAFunctions[I].Index, aIndex);
if C < 0 then
L := I + 1
else begin
H := I - 1;
if C = 0 then begin
L := I;
Result := @wbCTDAFunctions[L];
end;
end;
end;
end;
function wbCTDACompValueDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Integer(Container.ElementByName['Type'].NativeValue) and $04 <> 0 then
Result := 1;
end;
function wbCTDAParam1Decider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Desc: PCTDAFunction;
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Desc := wbCTDAParamDescFromIndex(Container.ElementByName['Function'].NativeValue);
if Assigned(Desc) then
Result := Succ(Integer(Desc.ParamType1));
end;
function wbCTDAParam2VATSValueParam(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Result := Container.ElementByName['Parameter #1'].NativeValue;
end;
function wbCTDAParam2Decider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Desc: PCTDAFunction;
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Desc := wbCTDAParamDescFromIndex(Container.ElementByName['Function'].NativeValue);
if Assigned(Desc) then
Result := Succ(Integer(Desc.ParamType2));
end;
function wbCTDAFunctionToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Desc : PCTDAFunction;
i : Integer;
begin
Result := '';
case aType of
ctToStr, ctToEditValue: begin
Desc := wbCTDAParamDescFromIndex(aInt);
if Assigned(Desc) then
Result := Desc.Name
else if aType = ctToEditValue then
Result := IntToStr(aInt)
else
Result := '';
end;
ctToSortKey: Result := IntToHex(aInt, 8);
ctCheck: begin
Desc := wbCTDAParamDescFromIndex(aInt);
if Assigned(Desc) then
Result := ''
else
Result := '';
end;
ctEditType:
Result := 'ComboBox';
ctEditInfo: begin
Result := wbCTDAFunctionEditInfo;
if Result = '' then begin
with TStringList.Create do try
for i := Low(wbCTDAFunctions) to High(wbCTDAFunctions) do
Add(wbCTDAFunctions[i].Name);
Sort;
Result := CommaText;
finally
Free;
end;
wbCTDAFunctionEditInfo := Result;
end;
end;
end;
end;
function wbCTDAFunctionToInt(const aString: string; const aElement: IwbElement): Int64;
var
i: Integer;
begin
for i := Low(wbCTDAFunctions) to High(wbCTDAFunctions) do
with wbCTDAFunctions[i] do
if SameText(Name, aString) then begin
Result := Index;
Exit;
end;
Result := StrToInt64(aString);
end;
type
TPERKEntryPointConditionType = (
epcDefault,
epcItem,
epcWeapon,
epcWeaponTarget,
epcTarget,
epcAttacker,
epcAttackerAttackee,
epcAttackerAttackerWeapon
);
TPERKEntryPointFunctionType = (
epfFloat,
epfLeveledItem,
epfScript,
epfUnknown
);
TPERKEntryPointFunctionParamType = (
epfpNone,
epfpFloat,
epfpFloatFloat,
epfpLeveledItem,
epfpScript
);
PPERKEntryPoint = ^TPERKEntryPoint;
TPERKEntryPoint = record
Name : string;
Condition : TPERKEntryPointConditionType;
FunctionType : TPERKEntryPointFunctionType;
end;
PPERKCondition = ^TPERKCondition;
TPERKCondition = record
Count : Integer;
Caption1 : string;
Caption2 : string;
Caption3 : string;
end;
PPERKFunction = ^TPERKFunction;
TPERKFunction = record
Name : string;
FunctionType : TPERKEntryPointFunctionType;
ParamType : TPERKEntryPointFunctionParamType;
end;
const
wbPERKCondition : array[TPERKEntryPointConditionType] of TPERKCondition = (
(Count: 1; Caption1: 'Perk Owner'),
(Count: 2; Caption1: 'Perk Owner'; Caption2: 'Item'),
(Count: 2; Caption1: 'Perk Owner'; Caption2: 'Weapon'),
(Count: 3; Caption1: 'Perk Owner'; Caption2: 'Weapon'; Caption3: 'Target'),
(Count: 2; Caption1: 'Perk Owner'; Caption2: 'Target'),
(Count: 2; Caption1: 'Perk Owner'; Caption2: 'Attacker'),
(Count: 3; Caption1: 'Perk Owner'; Caption2: 'Attacker'; Caption3: 'Attackee'),
(Count: 3; Caption1: 'Perk Owner'; Caption2: 'Attacker'; Caption3: 'Attacker Weapon')
);
wbPERKFunctions : array[0..9] of TPERKFunction = (
(Name: ''; FunctionType: epfUnknown; ParamType: epfpNone),
(Name: 'Set Value'; FunctionType: epfFloat; ParamType: epfpFloat),
(Name: 'Add Value'; FunctionType: epfFloat; ParamType: epfpFloat),
(Name: 'Multiply Value'; FunctionType: epfFloat; ParamType: epfpFloat),
(Name: 'Add Range To Value'; FunctionType: epfFloat; ParamType: epfpFloatFloat),
(Name: 'Add Actor Value Mult'; FunctionType: epfFloat; ParamType: epfpFloatFloat),
(Name: ''; FunctionType: epfUnknown; ParamType: epfpNone),
(Name: ''; FunctionType: epfUnknown; ParamType: epfpNone),
(Name: 'Add Leveled List'; FunctionType: epfLeveledItem; ParamType: epfpLeveledItem),
(Name: 'Add Activate Choice'; FunctionType: epfScript; ParamType: epfpScript)
);
wbPERKEntryPoints : array[0..36] of TPERKEntryPoint = (
(Name: 'Calculate Weapon Damage'; Condition: epcWeaponTarget),
(Name: 'Calculate My Critical Hit Chance'; Condition: epcWeaponTarget),
(Name: 'Calculate My Critical Hit Damage'; Condition: epcWeaponTarget),
(Name: 'Calculate Weapon Attack AP Cost'; Condition: epcWeapon),
(Name: 'Calculate Mine Explode Chance'; Condition: epcItem),
(Name: 'Adjust Range Penalty'; Condition: epcWeapon),
(Name: 'Adjust Limb Damage'; Condition: epcAttackerAttackerWeapon),
(Name: 'Calculate Weapon Range'; Condition: epcWeapon),
(Name: 'Calculate To Hit Chance'; Condition: epcWeaponTarget),
(Name: 'Adjust Experience Points'),
(Name: 'Adjust Gained Skill Points'),
(Name: 'Adjust Book Skill Points'),
(Name: 'Modify Recovered Health'),
(Name: 'Calculate Inventory AP Cost'),
(Name: 'Get Disposition'; Condition: epcTarget),
(Name: 'Get Should Attack'; Condition: epcAttacker),
(Name: 'Get Should Assist'; Condition: epcAttackerAttackee),
(Name: 'Calculate Buy Price'; Condition: epcItem),
(Name: 'Get Bad Karma'),
(Name: 'Get Good Karma'),
(Name: 'Ignore Locked Terminal'),
(Name: 'Add Leveled List On Death'; Condition: epcTarget; FunctionType: epfLeveledItem),
(Name: 'Get Max Carry Weight'),
(Name: 'Modify Addiction Chance'),
(Name: 'Modify Addiction Duration'),
(Name: 'Modify Positive Chem Duration'),
(Name: 'Adjust Drinking Radiation'),
(Name: 'Activate'; Condition: epcTarget; FunctionType: epfScript),
(Name: 'Mysterious Stranger'),
(Name: 'Has Paralyzing Palm'),
(Name: 'Hacking Science Bonus'),
(Name: 'Ignore Running During Detection'),
(Name: 'Ignore Broken Lock'),
(Name: 'Has Concentrated Fire'),
(Name: 'Calculate Gun Spread'; Condition: epcWeapon),
(Name: 'Player Kill AP Reward'; Condition: epcWeaponTarget),
(Name: 'Modify Enemy Critical Hit Chance'; Condition: epcWeaponTarget)
);
wbPERKFunctionParams: array[TPERKEntryPointFunctionParamType] of string = (
'None',
'Float',
'Float, Float',
'Leveled Item',
'Script'
);
procedure wbPERKEntryPointAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldEntryPoint : PPERKEntryPoint;
NewEntryPoint : PPERKEntryPoint;
OldCondition : PPERKCondition;
NewCondition : PPERKCondition;
OldFunction : PPERKFunction;
EntryPoint : IwbContainerElementRef;
Effect : IwbContainerElementRef;
PerkConditions : IwbContainerElementRef;
PerkCondition : IwbContainerElementRef;
Container : IwbContainerElementRef;
i : Integer;
begin
if aOldValue <> aNewValue then begin
OldEntryPoint := @wbPERKEntryPoints[Integer(aOldValue)];
NewEntryPoint := @wbPERKEntryPoints[Integer(aNewValue)];
OldCondition := @wbPERKCondition[OldEntryPoint.Condition];
NewCondition := @wbPERKCondition[NewEntryPoint.Condition];
if not Assigned(aElement) then
Exit;
if not Supports(aElement.Container, IwbContainerElementRef, EntryPoint) then
Exit;
i := EntryPoint.ElementNativeValues['Function'];
if (i >= Low(wbPERKFunctions)) and (i <= High(wbPERKFunctions)) then
OldFunction := @wbPERKFunctions[i]
else
OldFunction := nil;
if not Assigned(OldFunction) or (OldFunction.FunctionType <> NewEntryPoint.FunctionType) then
for i := Low(wbPERKFunctions) to High(wbPERKFunctions) do
with wbPERKFunctions[i] do
if FunctionType = NewEntryPoint.FunctionType then begin
EntryPoint.ElementNativeValues['Function'] := i;
Break;
end;
EntryPoint.ElementNativeValues['Perk Condition Tab Count'] := NewCondition.Count;
if not Supports(EntryPoint.Container, IwbContainerElementRef, Container) then
Exit;
if not Supports(Container.Container, IwbContainerElementRef, Effect) then
Exit;
if not Supports(Effect.ElementByName['Perk Conditions'], IwbContainerElementRef, PerkConditions) then
Exit;
for i := Pred(PerkConditions.ElementCount) downto 0 do
if Supports(PerkConditions.Elements[i], IwbContainerElementRef, PerkCondition) then
if Integer(PerkCondition.ElementNativeValues['PRKC']) >= NewCondition.Count then
PerkCondition.Remove
else
case Integer(PerkCondition.ElementNativeValues['PRKC']) of
2: if OldCondition.Caption2 <> NewCondition.Caption2 then
PerkCondition.Remove;
3: if OldCondition.Caption3 <> NewCondition.Caption3 then
PerkCondition.Remove;
end;
end;
end;
function wbPRKCToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
EntryPointVar : Variant;
EntryPoint : Integer;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
EntryPointVar := Container.ElementNativeValues['..\..\..\DATA\Entry Point\Entry Point'];
if VarIsNull(EntryPointVar) or VarIsClear(EntryPointVar) then
Exit;
EntryPoint := EntryPointVar;
if (EntryPoint < Low(wbPERKEntryPoints)) or (EntryPoint > High(wbPERKEntryPoints)) then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
with wbPERKEntryPoints[EntryPoint] do begin
with wbPERKCondition[Condition] do begin
case aType of
ctEditType: Result := 'ComboBox';
ctEditInfo: with TStringList.Create do try
if Caption1 <> '' then
Add(Caption1);
if Caption2 <> '' then
Add(Caption2);
if Caption3 <> '' then
Add(Caption3);
Sort;
Result := CommaText;
finally
Free;
end;
else
if (aInt < 0) or (aInt >= Count) then
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end
else
case aType of
ctToStr, ctToEditValue: case Integer(aInt) of
0: Result := Caption1;
1: Result := Caption2;
2: Result := Caption3;
end;
ctCheck: Result := '';
end;
end;
end;
end;
end;
function wbPRKCToInt(const aString: string; const aElement: IwbElement): Int64;
var
Container : IwbContainerElementRef;
EntryPointVar : Variant;
EntryPoint : Integer;
s : string;
begin
s := Trim(aString);
Result := StrToInt64Def(s, Low(Integer));
if Result <> Low(Integer) then
Exit;
if s = '' then begin
Result := 0;
Exit;
end;
if not Supports(aElement, IwbContainerElementRef, Container) then
raise Exception.Create('Could not resolve Entry Point');
EntryPointVar := Container.ElementNativeValues['..\..\..\DATA\Entry Point\Entry Point'];
if VarIsNull(EntryPointVar) or VarIsClear(EntryPointVar) then
raise Exception.Create('Could not resolve Entry Point');
EntryPoint := EntryPointVar;
if (EntryPoint < Low(wbPERKEntryPoints)) or (EntryPoint > High(wbPERKEntryPoints)) then
raise Exception.Create('Unknown Entry Point #'+IntToStr(EntryPoint));
with wbPERKEntryPoints[EntryPoint] do
with wbPERKCondition[Condition] do
if SameText(aString, Caption1) then
Result := 0
else if SameText(aString, Caption2) then
Result := 1
else if SameText(aString, Caption3) then
Result := 2
else
raise Exception.Create('"'+s+'" is not valid for this Entry Point');
end;
function wbNeverShow(const aElement: IwbElement): Boolean;
begin
Result := wbHideNeverShow;
end;
function GetREGNType(aElement: IwbElement): Integer;
var
Container: IwbContainerElementRef;
begin
Result := -1;
if not Assigned(aElement) then
Exit;
while aElement.Name <> 'Region Data Entry' do begin
aElement := aElement.Container;
if not Assigned(aElement) then
Exit;
end;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
Result := Container.ElementNativeValues['RDAT\Type'];
end;
function wbREGNObjectsDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 2;
end;
function wbREGNWeatherDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 3;
end;
function wbREGNMapDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 4;
end;
function wbREGNLandDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 5;
end;
function wbREGNGrassDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 6;
end;
function wbREGNSoundDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 7;
end;
function wbMESGTNAMDontShow(const aElement: IwbElement): Boolean;
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
Result := False;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Integer(Container.ElementNativeValues['DNAM']) and 1 <> 0 then
Result := True;
end;
function wbEPFDDontShow(const aElement: IwbElement): Boolean;
var
Container: IwbContainerElementRef;
begin
Result := False;
if aElement.Name <> 'Entry Point Function Parameters' then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if not (Integer(Container.ElementNativeValues['EPFT']) in [1..3]) then
Result := True;
end;
function wbTES4ONAMDontShow(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
Result := False;
if not Assigned(aElement) then
Exit;
MainRecord := aElement.ContainingMainRecord;
if not Assigned(MainRecord) then
Exit;
if not MainRecord.IsESM then
Result := True;
end;
function wbEPF2DontShow(const aElement: IwbElement): Boolean;
var
Container: IwbContainerElementRef;
begin
Result := False;
if aElement.Name <> 'Entry Point Function Parameters' then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if not (Integer(Container.ElementNativeValues['EPFT']) in [4]) then
Result := True;
end;
function wbPERKPRKCDontShow(const aElement: IwbElement): Boolean;
var
Container: IwbContainerElementRef;
begin
Result := False;
if aElement.Name <> 'Effect' then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Integer(Container.ElementNativeValues['PRKE\Type']) <> 2 then
Result := True;
end;
function wbPerkDATAFunctionToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
EntryPointVar : Variant;
EntryPoint : Integer;
i : Integer;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
EntryPointVar := Container.ElementNativeValues['..\Entry Point'];
if VarIsNull(EntryPointVar) or VarIsClear(EntryPointVar) then
Exit;
EntryPoint := EntryPointVar;
if (EntryPoint < Low(wbPERKEntryPoints)) or (EntryPoint > High(wbPERKEntryPoints)) then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
with wbPERKEntryPoints[EntryPoint] do begin
case aType of
ctEditType: Result := 'ComboBox';
ctEditInfo: with TStringList.Create do try
for i := Low(wbPERKFunctions) to High(wbPERKFunctions) do
if wbPERKFunctions[i].FunctionType = FunctionType then
if (wbPERKFunctions[i].Name <> '') then
Add(wbPERKFunctions[i].Name);
Sort;
Result := CommaText;
finally
Free;
end;
else
if (aInt < Low(wbPERKFunctions)) or (aInt > High(wbPERKFunctions)) then
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end
else
case aType of
ctToStr, ctToEditValue: begin
Result := wbPERKFunctions[Integer(aInt)].Name;
if (aType = ctToStr) and (wbPERKFunctions[Integer(aInt)].FunctionType <> FunctionType) then
Result := Result + ' ';
end;
ctCheck:
if wbPERKFunctions[Integer(aInt)].FunctionType <> FunctionType then
Result := ''
else
Result := '';
end;
end;
end;
end;
function wbPerkDATAFunctionToInt(const aString: string; const aElement: IwbElement): Int64;
var
Container : IwbContainerElementRef;
EntryPointVar : Variant;
EntryPoint : Integer;
s : string;
i : Integer;
begin
s := Trim(aString);
Result := StrToInt64Def(s, Low(Integer));
if Result <> Low(Integer) then
Exit;
if s = '' then
raise Exception.Create('"" is not a valid value for this field');
if not Supports(aElement, IwbContainerElementRef, Container) then
raise Exception.Create('Could not resolve Entry Point');
EntryPointVar := Container.ElementNativeValues['..\Entry Point'];
if VarIsNull(EntryPointVar) or VarIsClear(EntryPointVar) then
raise Exception.Create('Could not resolve Entry Point');
EntryPoint := EntryPointVar;
if (EntryPoint < Low(wbPERKEntryPoints)) or (EntryPoint > High(wbPERKEntryPoints)) then
raise Exception.Create('Unknown Entry Point #'+IntToStr(EntryPoint));
with wbPERKEntryPoints[EntryPoint] do
for i := Low(wbPERKFunctions) to High(wbPERKFunctions) do
if wbPERKFunctions[i].FunctionType = FunctionType then
if SameText(s, wbPERKFunctions[i].Name) then begin
Result := i;
Exit;
end;
raise Exception.Create('"'+s+'" is not valid for this Entry Point');
end;
procedure wbPerkDATAFunctionAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
NewFunction : Integer;
Container : IwbContainerElementRef;
OldParamType: Integer;
NewParamType: Integer;
begin
NewFunction := aNewValue;
if (NewFunction < Low(wbPERKFunctions)) or (NewFunction > High(wbPERKFunctions)) then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
OldParamType := Container.ElementNativeValues['..\..\..\Entry Point Function Parameters\EPFT'];
NewParamType := Ord(wbPERKFunctions[NewFunction].ParamType);
if (OldParamType = NewParamType) and not VarSameValue(aOldValue, aNewValue) and (NewFunction in [4,5]) then
Container.ElementNativeValues['..\..\..\Entry Point Function Parameters\EPFT'] := 0;
Container.ElementNativeValues['..\..\..\Entry Point Function Parameters\EPFT'] := NewParamType;
end;
function wbPerkEPFTToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
FunctionTypeVar : Variant;
FunctionType : Integer;
// i : Integer;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
FunctionTypeVar := Container.ElementNativeValues['..\..\DATA\Entry Point\Function'];
if VarIsNull(FunctionTypeVar) or VarIsClear(FunctionTypeVar) then
Exit;
FunctionType := FunctionTypeVar;
if (FunctionType < Low(wbPERKFunctions)) or (FunctionType > High(wbPERKFunctions)) then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
with wbPERKFunctions[FunctionType] do begin
case aType of
ctEditType: Result := 'ComboBox';
ctEditInfo: Result := '"' + wbPERKFunctionParams[ParamType] + '"';
else
if (aInt < Ord(Low(wbPERKFunctionParams))) or (aInt > Ord(High(wbPERKFunctionParams))) then
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end
else
case aType of
ctToStr, ctToEditValue: begin
Result := wbPERKFunctionParams[TPERKEntryPointFunctionParamType(aInt)];
if (aType = ctToStr) and (TPERKEntryPointFunctionParamType(aInt) <> ParamType) then
Result := Result + ' ';
end;
ctCheck:
if TPERKEntryPointFunctionParamType(aInt) <> ParamType then
Result := Result + ' '
else
Result := '';
end;
end;
end;
end;
function wbPerkEPFTToInt(const aString: string; const aElement: IwbElement): Int64;
var
Container : IwbContainerElementRef;
FunctionTypeVar : Variant;
FunctionType : Integer;
s : string;
// i : Integer;
j : TPERKEntryPointFunctionParamType;
begin
s := Trim(aString);
Result := StrToInt64Def(s, Low(Integer));
if Result <> Low(Integer) then
Exit;
if s = '' then
raise Exception.Create('"" is not a valid value for this field');
if not Supports(aElement, IwbContainerElementRef, Container) then
raise Exception.Create('Could not resolve Function');
FunctionTypeVar := Container.ElementNativeValues['..\..\DATA\Entry Point\Function'];
if VarIsNull(FunctionTypeVar) or VarIsClear(FunctionTypeVar) then
raise Exception.Create('Could not resolve Function');
FunctionType := FunctionTypeVar;
if (FunctionType < Low(wbPERKFunctions)) or (FunctionType > High(wbPERKFunctions)) then
raise Exception.Create('Unknown Function #'+IntToStr(FunctionType));
with wbPERKFunctions[FunctionType] do begin
for j := Low(wbPERKFunctionParams) to High(wbPERKFunctionParams) do
if SameText(s, wbPERKFunctionParams[j]) then begin
if j <> ParamType then
raise Exception.Create('"'+s+'" is not a valid Parameter Type for Function "'+Name+'"');
Result := Ord(j);
Exit;
end;
end;
raise Exception.Create('"'+s+'" is not a valid Parameter Type');
end;
procedure wbPerkEPFTAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
i: Integer;
Container: IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
i := aNewValue;
if (i < Ord(Low(wbPERKFunctionParams))) or (i> Ord(High(wbPERKFunctionParams))) then
Exit;
if not Supports(aElement.Container, IwbContainerElementRef, Container) then
Exit;
Container.RemoveElement('EPFD');
Container.RemoveElement('EPF2');
Container.RemoveElement('EPF3');
Container.RemoveElement('Embedded Script');
case TPERKEntryPointFunctionParamType(i) of
epfpFloat, epfpFloatFloat, epfpLeveledItem:
Container.Add('EPFD', True);
epfpScript: begin
Container.Add('EPF2', True);
Container.Add('EPF3', True);
Container.Add('SCHR', True);
end;
end;
end;
procedure wbRemoveOFST(const aElement: IwbElement);
var
Container: IwbContainer;
rOFST: IwbRecord;
begin
if not wbRemoveOffsetData then
Exit;
if Supports(aElement, IwbContainer, Container) then begin
if wbBeginInternalEdit then try
Container.RemoveElement(OFST);
finally
wbEndInternalEdit;
end else begin
rOFST := Container.RecordBySignature[OFST];
if Assigned(rOFST) then
Container.RemoveElement(rOFST);
end;
end;
end;
function wbActorTemplateUseTraits(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000001) <> 0;
end;
end;
function wbActorTemplateUseStats(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000002) <> 0;
end;
end;
function wbActorAutoCalcDontShow(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Flags'];
Result := (i and $00000010) <> 0;
end;
end;
function wbActorTemplateUseStatsAutoCalc(const aElement: IwbElement): Boolean;
begin
if not wbActorTemplateHide then
Result := False
else
Result := wbActorTemplateUseStats(aElement) or wbActorAutoCalcDontShow(aElement);
end;
function wbActorTemplateUseFactions(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000004) <> 0;
end;
end;
function wbActorTemplateUseActorEffectList(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000008) <> 0;
end;
end;
function wbActorTemplateUseAIData(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000010) <> 0;
end;
end;
function wbActorTemplateUseAIPackages(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000020) <> 0;
end;
end;
function wbActorTemplateUseModelAnimation(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000040) <> 0;
end;
end;
function wbActorTemplateUseBaseData(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000080) <> 0;
end;
end;
function wbActorTemplateUseInventory(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000100) <> 0;
end;
end;
function wbActorTemplateUseScript(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
if not wbActorTemplateHide then Exit;
Element := GetElementFromUnion(aElement);
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000200) <> 0;
end;
end;
procedure wbCTDAAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
//Size : Cardinal;
TypeFlags : Cardinal;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
TypeFlags := Container.ElementNativeValues['Type'];
if (TypeFlags and $02) <> 0 then begin
if Container.DataSize = 20 then
Container.DataSize := 28;
Container.ElementNativeValues['Type'] := TypeFlags and not $02;
Container.ElementEditValues['Run On'] := 'Target';
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbMGEFAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
OldActorValue : Integer;
NewActorValue : Integer;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
OldActorValue := Container.ElementNativeValues['DATA - Data\Actor Value'];
NewActorValue := OldActorValue;
case Integer(Container.ElementNativeValues['DATA - Data\Archtype']) of
01, //Script
02, //Dispel
03, //Cure Disease
13, //Light
16, //Lock
17, //Open
18, //Bound Item
19, //Summon Creature
30, //Cure Paralysis
31, //Cure Addiction
32, //Cure Poison
33: //Concussion
NewActorValue := -1;
11: //Invisibility
NewActorValue := 48; //Invisibility
12: //Chameleon
NewActorValue := 49; //Chameleon
24: //Paralysis
NewActorValue := 47; //Paralysis
end;
if OldActorValue <> NewActorValue then
Container.ElementNativeValues['DATA - Data\Actor Value'] := NewActorValue;
finally
wbEndInternalEdit;
end;
end;
procedure wbPACKAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
NewContainer : IwbContainerElementRef;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
case Integer(Container.ElementNativeValues['PKDT - General\Type']) of
0: begin {Find}
Container.Add('PTDT');
end;
1: begin {Follow}
Container.Add('PKFD');
end;
2: begin {Escort}
end;
3: begin {Eat}
Container.Add('PTDT');
Container.Add('PKED');
end;
4: begin {Sleep}
if not Container.ElementExists['Locations'] then
if Supports(Container.Add('Locations'), IwbContainerElementRef, NewContainer) then
NewContainer.ElementEditValues['PLDT - Location 1\Type'] := 'Near editor location';
end;
5: begin {Wander}
end;
6: begin {Travel}
end;
7: begin {Accompany}
end;
8: begin {Use Item At}
end;
9: begin {Ambush}
end;
10: begin {Flee Not Combat}
end;
12: begin {Sandbox}
end;
13: begin {Patrol}
if not Container.ElementExists['Locations'] then
if Supports(Container.Add('Locations'), IwbContainerElementRef, NewContainer) then
NewContainer.ElementEditValues['PLDT - Location 1\Type'] := 'Near linked reference';
Container.Add('PKPT');
end;
14: begin {Guard}
end;
15: begin {Dialogue}
end;
16: begin {Use Weapon}
end;
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbNPCAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
// BaseRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if Container.ElementNativeValues['NAM5'] > 255 then
Container.ElementNativeValues['NAM5'] := 255;
finally
wbEndInternalEdit;
end;
end;
procedure wbREFRAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
BaseRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
Container.RemoveElement('RCLR');
if Container.ElementExists['Ammo'] then begin
BaseRecord := MainRecord.BaseRecord;
if Assigned(BaseRecord) and (BaseRecord.Signature <> 'WEAP') then
Container.RemoveElement('Ammo');
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbINFOAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if (Integer(Container.ElementNativeValues['DATA\Flags 1']) and $80) = 0 then
Container.RemoveElement('DNAM');
Container.RemoveElement('SNDD');
if Container.ElementNativeValues['DATA\Type'] = 3 {Persuasion} then
Container.ElementNativeValues['DATA\Type'] := 0 {Topic};
finally
wbEndInternalEdit;
end;
end;
procedure wbCELLAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
// Container2 : IwbContainerElementRef;
MainRecord : IwbMainRecord;
// i : Integer;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if (not Container.ElementExists['XCLW']) and ((Integer(Container.ElementNativeValues['DATA']) and $02) <> 0) then begin
Container.Add('XCLW', True);
Container.ElementEditValues['XCLW'] := 'Default';
end;
if (not Container.ElementExists['XNAM']) and ((Integer(Container.ElementNativeValues['DATA']) and $02) <> 0) then
Container.Add('XNAM', True);
// if Supports(Container.ElementBySignature[XCLR], IwbContainerElementRef, Container2) then begin
// for i:= Pred(Container2.ElementCount) downto 0 do
// if not Supports(Container2.Elements[i].LinksTo, IwbMainRecord, MainRecord) or (MainRecord.Signature <> 'REGN') then
// Container2.RemoveElement(i);
// if Container2.ElementCount < 1 then
// Container2.Remove;
// end;
finally
wbEndInternalEdit;
end;
end;
procedure wbEmbeddedScriptAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if Container.ElementEditValues['SCHR\Type'] = 'Quest' then
Container.ElementEditValues['SCHR\Type'] := 'Object';
finally
wbEndInternalEdit;
end;
end;
procedure wbSOUNAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
OldCntr: IwbContainerElementRef;
NewCntr: IwbContainerElementRef;
NewCntr2: IwbContainerElementRef;
i: Integer;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if Container.ElementExists['SNDD'] then
Exit;
if not Supports(Container.RemoveElement('SNDX - Sound Data'), IwbContainerElementRef, OldCntr) then
Exit;
if not Supports(Container.Add('SNDD', True), IwbContainerElementRef, NewCntr) then
Exit;
for i := 0 to Pred(Min(OldCntr.ElementCount, NewCntr.ElementCount)) do
NewCntr.Elements[i].Assign(Low(Integer), OldCntr.Elements[i], False);
if not Supports(NewCntr.ElementByName['Attenuation Curve'], IwbContainerElementRef, NewCntr2) then
Assert(False);
Assert(NewCntr2.ElementCount = 5);
if Supports(Container.RemoveElement('ANAM'), IwbContainerElementRef, OldCntr) then begin
Assert(OldCntr.ElementCount = 5);
for i := 0 to Pred(Min(OldCntr.ElementCount, NewCntr2.ElementCount)) do
NewCntr2.Elements[i].Assign(Low(Integer), OldCntr.Elements[i], False);
end else begin
NewCntr2.Elements[0].NativeValue := 100;
NewCntr2.Elements[1].NativeValue := 50;
NewCntr2.Elements[2].NativeValue := 20;
NewCntr2.Elements[3].NativeValue := 5;
NewCntr2.Elements[4].NativeValue := 0;
end;
if not Supports(NewCntr.ElementByName['Reverb Attenuation Control'], IwbContainerElementRef, NewCntr2) then
Assert(False);
if Supports(Container.RemoveElement('GNAM'), IwbContainerElementRef, OldCntr) then
NewCntr2.Assign(Low(Integer), OldCntr, False)
else
NewCntr2.NativeValue := 80;
if not Supports(NewCntr.ElementByName['Priority'], IwbContainerElementRef, NewCntr2) then
Assert(False);
if Supports(Container.RemoveElement('HNAM'), IwbContainerElementRef, OldCntr) then
NewCntr2.Assign(Low(Integer), OldCntr, False)
else
NewCntr2.NativeValue := 128;
finally
wbEndInternalEdit;
end;
end;
procedure wbWATRAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
// AnimationMultiplier : Extended;
// AnimationAttackMultiplier : Extended;
OldCntr: IwbContainerElementRef;
NewCntr: IwbContainerElementRef;
i: Integer;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if Container.ElementExists['DNAM'] then
Exit;
if not Supports(Container.RemoveElement('DATA - Visual Data'), IwbContainerElementRef, OldCntr) then
Exit;
if not Supports(Container.Add('DNAM', True), IwbContainerElementRef, NewCntr) then
Exit;
for i := 0 to Pred(Min(OldCntr.ElementCount, NewCntr.ElementCount)) do
if OldCntr.Elements[i].Name = 'Damage (Old Format)' then
Container.ElementNativeValues['DATA - Damage'] := OldCntr.Elements[i].NativeValue
else
NewCntr.Elements[i].Assign(Low(Integer), OldCntr.Elements[i], False);
NewCntr.ElementNativeValues['Noise Properties - Noise Layer One - Amplitude Scale'] := 1.0;
NewCntr.ElementNativeValues['Noise Properties - Noise Layer Two - Amplitude Scale'] := 0.5;
NewCntr.ElementNativeValues['Noise Properties - Noise Layer Three - Amplitude Scale'] := 0.25;
finally
wbEndInternalEdit;
end;
end;
procedure wbWEAPAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if not Container.ElementExists['DNAM'] then
Exit;
if Container.ElementNativeValues['DNAM\Animation Multiplier'] = 0.0 then
Container.ElementNativeValues['DNAM\Animation Multiplier'] := 1.0;
if Container.ElementNativeValues['DNAM\Animation Attack Multiplier'] = 0.0 then
Container.ElementNativeValues['DNAM\Animation Attack Multiplier'] := 1.0;
finally
wbEndInternalEdit;
end;
end;
procedure wbMESGAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
IsMessageBox : Boolean;
HasTimeDelay : Boolean;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
IsMessageBox := (Integer(Container.ElementNativeValues['DNAM']) and 1) = 1;
HasTimeDelay := Container.ElementExists['TNAM'];
if IsMessageBox = HasTimeDelay then
if IsMessageBox then
Container.RemoveElement('TNAM')
else begin
if not Container.ElementExists['DNAM'] then
Container.Add('DNAM', True);
Container.ElementNativeValues['DNAM'] := Integer(Container.ElementNativeValues['DNAM']) or 1;
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbEFSHAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
FullParticleBirthRatio : Extended;
PersistantParticleBirthRatio : Extended;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if not Container.ElementExists['DATA'] then
Exit;
FullParticleBirthRatio := Container.ElementNativeValues['DATA\Particle Shader - Full Particle Birth Ratio'];
PersistantParticleBirthRatio := Container.ElementNativeValues['DATA\Particle Shader - Persistant Particle Birth Ratio'];
if ((FullParticleBirthRatio <> 0) and (FullParticleBirthRatio <= 1)) then begin
FullParticleBirthRatio := FullParticleBirthRatio * 78.0;
Container.ElementNativeValues['DATA\Particle Shader - Full Particle Birth Ratio'] := FullParticleBirthRatio;
end;
if ((PersistantParticleBirthRatio <> 0) and (PersistantParticleBirthRatio <= 1)) then begin
PersistantParticleBirthRatio := PersistantParticleBirthRatio * 78.0;
Container.ElementNativeValues['DATA\Particle Shader - Persistant Particle Birth Ratio'] := PersistantParticleBirthRatio;
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbFACTAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Container.ElementExists['CNAM'] then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
Container.RemoveElement('CNAM');
finally
wbEndInternalEdit;
end;
end;
procedure wbLIGHAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if not Container.ElementExists['FNAM'] then begin
Container.Add('FNAM', True);
Container.ElementNativeValues['FNAM'] := 1.0;
end;
if Container.ElementExists['DATA'] then begin
if SameValue(Container.ElementNativeValues['DATA\Falloff Exponent'], 0.0) then
Container.ElementNativeValues['DATA\Falloff Exponent'] := 1.0;
if SameValue(Container.ElementNativeValues['DATA\FOV'], 0.0) then
Container.ElementNativeValues['DATA\FOV'] := 90.0;
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbEFITAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
Element : IwbElement;
ActorValue: Variant;
MainRecord: IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
MainRecord := Container.ContainingMainRecord;
if not Assigned(MainRecord) or MainRecord.IsDeleted then
Exit;
Element := Container.ElementByPath['..\EFID'];
if not Assigned(Element) then
Exit;
if not Supports(Element.LinksTo, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.Signature <> 'MGEF' then
Exit;
ActorValue := MainRecord.ElementNativeValues['DATA - Data\Actor Value'];
if VarIsNull(ActorValue) or VarIsClear(ActorValue) then
Exit;
if VarCompareValue(ActorValue, Container.ElementNativeValues['Actor Value']) <> vrEqual then
Container.ElementNativeValues['Actor Value'] := ActorValue;
finally
wbEndInternalEdit;
end;
end;
procedure wbRPLDAfterLoad(const aElement: IwbElement);
var
Container: IwbContainer;
a, b: Single;
NeedsFlip: Boolean;
begin
if wbBeginInternalEdit then try
if Supports(aElement, IwbContainer, Container) then begin
NeedsFlip := False;
if Container.ElementCount > 1 then begin
a := StrToFloat((Container.Elements[0] as IwbContainer).Elements[0].Value);
b := StrToFloat((Container.Elements[Pred(Container.ElementCount)] as IwbContainer).Elements[0].Value);
case CompareValue(a, b) of
EqualsValue: begin
a := StrToFloat((Container.Elements[0] as IwbContainer).Elements[1].Value);
b := StrToFloat((Container.Elements[Pred(Container.ElementCount)] as IwbContainer).Elements[1].Value);
NeedsFlip := CompareValue(a, b) = GreaterThanValue;
end;
GreaterThanValue:
NeedsFlip := True;
end;
end;
if NeedsFlip then
Container.ReverseElements;
end;
finally
wbEndInternalEdit;
end;
end;
function wbPxDTLocationDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Result := Container.ElementByName['Type'].NativeValue;
end;
function wbPKDTFalloutBehaviorFlagsDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
SubRecord : IwbSubRecord;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Supports(Container, IwbSubRecord, SubRecord) then
if SubRecord.SubRecordHeaderSize = 8 then
Result := 1;
end;
function wbPKDTSpecificFlagsDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
SubRecord : IwbSubRecord;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Supports(Container, IwbSubRecord, SubRecord) then
if SubRecord.SubRecordHeaderSize = 8 then
Exit;
Result := Container.ElementByName['Type'].NativeValue + 1;
end;
procedure wbIDLAsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Element : IwbElement;
Container : IwbContainer;
SelfAsContainer : IwbContainer;
begin
if wbBeginInternalEdit then try
// if not wbCounterAfterSet('IDLC - Animation Count', aElement) then
if Supports(aElement.Container, IwbContainer, Container) then begin
Element := Container.ElementByPath['IDLC\Animation Count'];
if Assigned(Element) and Supports(aElement, IwbContainer, SelfAsContainer) and
(Element.GetNativeValue<>SelfAsContainer.GetElementCount) then
Element.SetNativeValue(SelfAsContainer.GetElementCount);
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbAnimationsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Element : IwbElement;
Elems : IwbElement;
Container : IwbContainer;
begin
if wbBeginInternalEdit then try
// if not wbCounterContainerAfterSet('IDLC - Animation Count', 'IDLA - Animations', aElement) then
if Supports(aElement, IwbContainer, Container) then begin
Element := Container.ElementByPath['IDLC\Animation Count'];
Elems := Container.ElementByName['IDLA - Animations'];
if Assigned(Element) and not Assigned(Elems) then
if Element.GetNativeValue<>0 then
Element.SetNativeValue(0);
end;
finally
wbEndInternalEdit;
end;
end;
function wbOffsetDataColsCounter(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Cardinal;
var
Container : IwbDataContainer;
Element : IwbElement;
fResult : Extended;
begin
Result := 0;
if Supports(aElement.Container, IwbDataContainer, Container) and (Container.Name = 'OFST - Offset Data') and
Supports(Container.Container, IwbDataContainer, Container) then begin
Element := Container.ElementByPath['Object Bounds\NAM0 - Min\X'];
if Assigned(Element) then begin
fResult := Element.NativeValue;
if fResult >= MaxInt then
Result := 0
else
Result := Trunc(fResult);
Element := Container.ElementByPath['Object Bounds\NAM9 - Max\X'];
if Assigned(Element) then begin
fResult := Element.NativeValue;
if fResult >= MaxInt then
Result := 1
else
Result := Trunc(fResult) - Result + 1;
end;
end;
end;
end;
procedure DefineFO3a;
begin
wbRecordFlags := wbInteger('Record Flags', itU32, wbFlags([
{0x00000001}'ESM',
{0x00000002}'',
{0x00000004}'', // Plugin selected (Editor)
{0x00000008}'', // Form cannot be saved (Runtime)/Plugin active (Editor)
{0x00000010}'Form initialized (Runtime only)', // Plugin cannot be active or selected (Editor)
{0x00000020}'Deleted',
{0x00000040}'Border Region / Has Tree LOD / Constant / Hidden From Local Map',
{0x00000080}'Turn Off Fire',
{0x00000100}'Inaccessible',
{0x00000200}'Casts shadows / On Local Map / Motion Blur',
{0x00000400}'Quest item / Persistent reference',
{0x00000800}'Initially disabled',
{0x00001000}'Ignored',
{0x00002000}'No Voice Filter',
{0x00004000}'Cannot Save (Runtime only)',
{0x00008000}'Visible when distant',
{0x00010000}'Random Anim Start / High Priority LOD',
{0x00020000}'Dangerous / Off limits (Interior cell) / Radio Station (Talking Activator)',
{0x00040000}'Compressed',
{0x00080000}'Can''t wait / Platform Specific Texture / Dead',
{0x00100000}'Unknown 21',
{0x00200000}'Load Started', // set when beginning to load the form from save
{0x00400000}'Unknown 23',
{0x00800000}'Unknown 24',
{0x01000000}'Destructible (Runtime only)',
{0x02000000}'Obstacle / No AI Acquire',
{0x03000000}'NavMesh Generation - Filter',
{0x08000000}'NavMesh Generation - Bounding Box',
{0x10000000}'Non-Pipboy / Reflected by Auto Water',
{0x20000000}'Child Can Use / Refracted by Auto Water',
{0x40000000}'NavMesh Generation - Ground',
{0x80000000}'Multibound'
]));
(* wbInteger('Record Flags 2', itU32, wbFlags([
{0x00000001}'Unknown 1',
{0x00000002}'Unknown 2',
{0x00000004}'Unknown 3',
{0x00000008}'Unknown 4',
{0x00000010}'Unknown 5',
{0x00000020}'Unknown 6',
{0x00000040}'Unknown 7',
{0x00000080}'Unknown 8',
{0x00000100}'Unknown 9',
{0x00000200}'Unknown 10',
{0x00000400}'Unknown 11',
{0x00000800}'Unknown 12',
{0x00001000}'Unknown 13',
{0x00002000}'Unknown 14',
{0x00004000}'Unknown 15',
{0x00008000}'Unknown 16',
{0x00010000}'Unknown 17',
{0x00020000}'Unknown 18',
{0x00040000}'Unknown 19',
{0x00080000}'Unknown 20',
{0x00100000}'Unknown 21',
{0x00200000}'Unknown 22',
{0x00400000}'Unknown 23',
{0x00800000}'Unknown 24',
{0x01000000}'Unknown 25',
{0x02000000}'Unknown 26',
{0x03000000}'Unknown 27',
{0x08000000}'Unknown 28',
{0x10000000}'Unknown 29',
{0x20000000}'Unknown 30',
{0x40000000}'Unknown 31',
{0x80000000}'Unknown 32'
])); (**)
wbMainRecordHeader := wbStruct('Record Header', [
wbString('Signature', 4, cpCritical),
wbInteger('Data Size', itU32, nil, cpIgnore),
wbRecordFlags,
wbFormID('FormID', cpFormID),
wbByteArray('Version Control Info 1', 4, cpIgnore),
wbInteger('Form Version', itU16, nil, cpIgnore),
wbByteArray('Version Control Info 2', 2, cpIgnore)
]);
wbSizeOfMainRecordStruct := 24;
wbIgnoreRecords.Add(XXXX);
wbXRGD := wbByteArray(XRGD, 'Ragdoll Data');
wbXRGB := wbByteArray(XRGB, 'Ragdoll Biped Data');
wbMusicEnum := wbEnum(['Default', 'Public', 'Dungeon']);
wbSoundLevelEnum := wbEnum([
'Loud',
'Normal',
'Silent'
]);
wbWeaponAnimTypeEnum := wbEnum([
{00} 'Hand to Hand',
{01} 'Melee (1 Hand)',
{02} 'Melee (2 Hand)',
{03} 'Pistol - Balistic (1 Hand)',
{04} 'Pistol - Energy (1 Hand)',
{05} 'Rifle - Balistic (2 Hand)',
{06} 'Rifle - Automatic (2 Hand)',
{07} 'Rifle - Energy (2 Hand)',
{08} 'Handle (2 Hand)',
{09} 'Launcher (2 Hand)',
{10} 'Grenade Throw (1 Hand)',
{11} 'Land Mine (1 Hand)',
{12} 'Mine Drop (1 Hand)'
]);
wbReloadAnimEnum := wbEnum([
'ReloadA',
'ReloadB',
'ReloadC',
'ReloadD',
'ReloadE',
'ReloadF',
'ReloadG',
'ReloadH',
'ReloadI',
'ReloadJ',
'ReloadK'
],[255, 'None']);
wbEDID := wbString(EDID, 'Editor ID', 0, cpNormal); // not cpBenign according to Arthmoor
wbEDIDReq := wbString(EDID, 'Editor ID', 0, cpNormal, True); // not cpBenign according to Arthmoor
wbFULL := wbString(FULL, 'Name', 0, cpTranslate);
wbFULLActor := wbString(FULL, 'Name', 0, cpTranslate, False, wbActorTemplateUseBaseData);
wbFULLReq := wbString(FULL, 'Name', 0, cpNormal, True);
wbDESC := wbString(DESC, 'Description', 0, cpTranslate);
wbDESCReq := wbString(DESC, 'Description', 0, cpTranslate, True);
wbXSCL := wbFloat(XSCL, 'Scale');
wbOBND := wbStruct(OBND, 'Object Bounds', [
wbInteger('X1', itS16),
wbInteger('Y1', itS16),
wbInteger('Z1', itS16),
wbInteger('X2', itS16),
wbInteger('Y2', itS16),
wbInteger('Z2', itS16)
]);
wbOBNDReq := wbStruct(OBND, 'Object Bounds', [
wbInteger('X1', itS16),
wbInteger('Y1', itS16),
wbInteger('Z1', itS16),
wbInteger('X2', itS16),
wbInteger('Y2', itS16),
wbInteger('Z2', itS16)
], cpNormal, True);
wbREPL := wbFormIDCkNoReach(REPL, 'Repair List', [FLST]);
wbEITM := wbFormIDCk(EITM, 'Object Effect', [ENCH, SPEL]);
wbBIPL := wbFormIDCk(BIPL, 'Biped Model List', [FLST]);
wbCOED := wbStructExSK(COED, [2], [0, 1], 'Extra Data', [
{00} wbFormIDCkNoReach('Owner', [NPC_, FACT, NULL]),
{04} wbUnion('Global Variable / Required Rank', wbCOEDOwnerDecider, [
wbByteArray('Unused', 4, cpIgnore),
wbFormIDCk('Global Variable', [GLOB, NULL]),
wbInteger('Required Rank', itU32)
]),
{08} wbFloat('Item Condition')
]);
wbYNAM := wbFormIDCk(YNAM, 'Sound - Pick Up', [SOUN]);
wbZNAM := wbFormIDCk(ZNAM, 'Sound - Drop', [SOUN]);
wbPosRot :=
wbStruct('Position/Rotation', [
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation', [
wbFloat('X', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Y', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Z', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize)
])
]);
wbDATAPosRot :=
wbStruct(DATA, 'Position/Rotation', [
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation', [
wbFloat('X', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Y', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Z', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize)
])
], cpNormal, True);
wbMODS :=
wbArrayS(MODS, 'Alternate Textures',
wbStructSK([0, 2], 'Alternate Texture', [
wbLenString('3D Name'),
wbFormIDCk('New Texture', [TXST]),
wbInteger('3D Index', itS32)
]),
-1);
wbMO2S :=
wbArrayS(MO2S, 'Alternate Textures',
wbStructSK([0, 2], 'Alternate Texture', [
wbLenString('3D Name'),
wbFormIDCk('New Texture', [TXST]),
wbInteger('3D Index', itS32)
]),
-1);
wbMO3S :=
wbArrayS(MO3S, 'Alternate Textures',
wbStructSK([0, 2], 'Alternate Texture', [
wbLenString('3D Name'),
wbFormIDCk('New Texture', [TXST]),
wbInteger('3D Index', itS32)
]),
-1);
wbMO4S :=
wbArrayS(MO4S, 'Alternate Textures',
wbStructSK([0, 2], 'Alternate Texture', [
wbLenString('3D Name'),
wbFormIDCk('New Texture', [TXST]),
wbInteger('3D Index', itS32)
]),
-1);
wbMODD :=
wbInteger(MODD, 'FaceGen Model Flags', itU8, wbFlags([
'Head',
'Torso',
'Right Hand',
'Left Hand'
]));
wbMOSD :=
wbInteger(MOSD, 'FaceGen Model Flags', itU8, wbFlags([
'Head',
'Torso',
'Right Hand',
'Left Hand'
]));
wbMODL :=
wbRStructSK([0], 'Model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbByteArray(MODB, 'Unknown', 4, cpIgnore),
wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore),
// wbArray(MODT, 'Texture Files Hashes',
// wbByteArray('Unknown', 24, cpBenign),
// wbArray('Hashes', wbInteger('Hash', itU64, wbMODTCallback), 3),
// 0, nil, nil, cpBenign),
wbMODS,
wbMODD
], [], cpNormal, False, nil, True);
wbMODLActor :=
wbRStructSK([0], 'Model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbByteArray(MODB, 'Unknown', 4, cpIgnore),
wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore),
// wbArray(MODT, 'Texture Files Hashes',
// wbByteArray('Unknown', 24, cpBenign),
// wbArray('Hashes', wbInteger('Hash', itU64, wbMODTCallback), 3),
// 0, nil, nil, cpBenign),
wbMODS,
wbMODD
], [], cpNormal, False, wbActorTemplateUseModelAnimation, True);
wbMODLReq :=
wbRStructSK([0], 'Model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbByteArray(MODB, 'Unknown', 4, cpIgnore),
wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore),
// wbArray(MODT, 'Texture Files',
// wbByteArray('Unknown', 24, cpBenign),
// wbArray('Hashes', wbInteger('Hash', itU64, wbMODTCallback), 3),
// 0, nil, nil, cpBenign),
wbMODS,
wbMODD
], [], cpNormal, True, nil, True);
wbDEST := wbRStruct('Destructable', [
wbStruct(DEST, 'Header', [
wbInteger('Health', itS32),
wbInteger('Count', itU8),
wbInteger('Flags', itU8, wbFlags([
'VATS Targetable'
], True)),
wbByteArray('Unused', 2)
]),
wbRArray('Stages',
wbRStruct('Stage', [
wbStruct(DSTD, 'Destruction Stage Data', [
wbInteger('Health %', itU8),
wbInteger('Index', itU8),
wbInteger('Damage Stage', itU8),
wbInteger('Flags', itU8, wbFlags([
'Cap Damage',
'Disable',
'Destroy'
])),
wbInteger('Self Damage per Second', itS32),
wbFormIDCk('Explosion', [EXPL, NULL]),
wbFormIDCk('Debris', [DEBR, NULL]),
wbInteger('Debris Count', itS32)
], cpNormal, True),
wbRStructSK([0], 'Model', [
wbString(DMDL, 'Model Filename'),
wbByteArray(DMDT, 'Texture Files Hashes', 0, cpIgnore)
// wbArray(DMDT, 'Unknown',
// wbByteArray('Unknown', 24, cpBenign),
// 0, nil, nil, cpBenign)
], []),
wbEmpty(DSTF, 'End Marker', cpNormal, True)
], [])
)
], []);
wbDESTActor := wbRStruct('Destructable', [
wbStruct(DEST, 'Header', [
wbInteger('Health', itS32),
wbInteger('Count', itU8),
wbInteger('Flags', itU8, wbFlags([
'VATS Targetable'
])),
wbByteArray('Unused', 2)
]),
wbRArray('Stages',
wbRStruct('Stage', [
wbStruct(DSTD, 'Destruction Stage Data', [
wbInteger('Health %', itU8),
wbInteger('Index', itU8),
wbInteger('Damage Stage', itU8),
wbInteger('Flags', itU8, wbFlags([
'Cap Damage',
'Disable',
'Destroy'
])),
wbInteger('Self Damage per Second', itS32),
wbFormIDCk('Explosion', [EXPL, NULL]),
wbFormIDCk('Debris', [DEBR, NULL]),
wbInteger('Debris Count', itS32)
], cpNormal, True),
wbRStructSK([0], 'Model', [
wbString(DMDL, 'Model Filename'),
wbByteArray(DMDT, 'Texture Files Hashes', 0, cpIgnore)
// wbArray(DMDT, 'Unknown',
// wbByteArray('Unknown', 24, cpBenign),
// 0, nil, nil, cpBenign)
], []),
wbEmpty(DSTF, 'End Marker', cpNormal, True)
], [])
)
], [], cpNormal, False, wbActorTemplateUseModelAnimation);
wbSCRI := wbFormIDCk(SCRI, 'Script', [SCPT]);
wbSCRIActor := wbFormIDCk(SCRI, 'Script', [SCPT], False, cpNormal, False, wbActorTemplateUseScript);
wbENAM := wbFormIDCk(ENAM, 'Object Effect', [ENCH]);
wbXLOD := wbArray(XLOD, 'Distant LOD Data', wbFloat('Unknown'), 3);
wbXESP := wbStruct(XESP, 'Enable Parent', [
wbFormIDCk('Reference', [PLYR, REFR, ACRE, ACHR, PGRE, PMIS, PBEA]),
wbInteger('Flags', itU8, wbFlags([
'Set Enable State to Opposite of Parent',
'Pop In'
])),
wbByteArray('Unused', 3)
]);
wbSCHRReq := wbStruct(SCHR, 'Basic Script Data', [
wbByteArray('Unused', 4),
wbInteger('RefCount', itU32),
wbInteger('CompiledSize', itU32),
wbInteger('VariableCount', itU32),
wbInteger('Type', itU16, wbEnum([
'Object',
'Quest'
], [
$100, 'Effect'
])),
wbInteger('Flags', itU16, wbFlags([
'Enabled'
]), cpNormal, False, nil, nil, 1)
], cpNormal, True);
wbSCROs :=
wbRArray('References',
wbRUnion('', [
wbFormID(SCRO, 'Global Reference'),
// wbFormIDCk(SCRO, 'Global Reference',
// [ACTI, DOOR, STAT, FURN, CREA, SPEL, NPC_, CONT, ARMO, AMMO, MISC, WEAP, IMAD,
// BOOK, KEYM, ALCH, LIGH, QUST, PLYR, PACK, LVLI, ECZN, EXPL, FLST, IDLM, PMIS,
// FACT, ACHR, REFR, ACRE, GLOB, DIAL, CELL, SOUN, MGEF, WTHR, CLAS, EFSH, RACE,
// LVLC, CSTY, WRLD, SCPT, IMGS, MESG, MSTT, MUSC, NOTE, PERK, PGRE, PROJ, LVLN,
// WATR, ENCH, TREE, TERM, HAIR, EYES, ADDN, NULL]),
wbInteger(SCRV, 'Local Variable', itU32)
], [])
);
wbSLSD := wbStructSK(SLSD, [0], 'Local Variable Data', [
wbInteger('Index', itU32),
wbByteArray('Unused', 12),
wbInteger('Flags', itU8, wbFlags(['IsLongOrShort']), cpCritical),
wbByteArray('Unused', 7)
]);
wbEmbeddedScript := wbRStruct('Embedded Script', [
wbSCHRReq,
wbByteArray(SCDA, 'Compiled Embedded Script', 0, cpNormal{, True}),
wbStringScript(SCTX, 'Embedded Script Source', 0, cpNormal{, True}),
wbRArrayS('Local Variables', wbRStructSK([0], 'Local Variable', [
wbSLSD,
wbString(SCVR, 'Name', 0, cpCritical, True)
], [])),
wbSCROs
], [], cpNormal, False, nil, False, wbEmbeddedScriptAfterLoad);
wbEmbeddedScriptPerk := wbRStruct('Embedded Script', [
wbSCHRReq,
wbByteArray(SCDA, 'Compiled Embedded Script', 0, cpNormal, True),
wbStringScript(SCTX, 'Embedded Script Source', 0, cpNormal, True),
wbRArrayS('Local Variables', wbRStructSK([0], 'Local Variable', [
wbSLSD,
wbString(SCVR, 'Name', 0, cpCritical, True)
], [])),
wbSCROs
], [], cpNormal, False, wbEPF2DontShow, False, wbEmbeddedScriptAfterLoad);
wbEmbeddedScriptReq := wbRStruct('Embedded Script', [
wbSCHRReq,
wbByteArray(SCDA, 'Compiled Embedded Script', 0, cpNormal{, True}),
wbStringScript(SCTX, 'Embedded Script Source', 0, cpNormal{, True}),
wbRArrayS('Local Variables', wbRStructSK([0], 'Local Variable', [
wbSLSD,
wbString(SCVR, 'Name', 0, cpCritical, True)
], [])),
wbSCROs
], [], cpNormal, True, nil, False, wbEmbeddedScriptAfterLoad);
wbXLCM := wbInteger(XLCM, 'Level Modifier', itS32);
wbRecord(ACHR, 'Placed NPC', [
wbEDID,
wbFormIDCk(NAME, 'Base', [NPC_], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
{--- Ragdoll ---}
wbXRGD,
wbXRGB,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], []),
{--- Leveled Actor ----}
wbXLCM,
{--- Merchant Container ----}
wbFormIDCk(XMRC, 'Merchant Container', [REFR], True),
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbFloat(XHLP, 'Health'),
{--- Decals ---}
wbRArrayS('Linked Decals',
wbStructSK(XDCR, [0], 'Decal', [
wbFormIDCk('Reference', [REFR]),
wbUnknown
])
),
{--- Linked Ref ---}
wbFormIDCk(XLKR, 'Linked Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbStruct(XCLP, 'Linked Reference Color', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbFloat('Delay')
])
)
], []),
{--- Enable Parent ---}
wbXESP,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Flags ---}
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot
], True, wbPlacedAddInfo);
wbXOWN := wbFormIDCkNoReach(XOWN, 'Owner', [FACT, ACHR, CREA, NPC_]); // Ghouls can own too aparently !
wbXGLB := wbFormIDCk(XGLB, 'Global variable', [GLOB]);
wbRecord(ACRE, 'Placed Creature', [
wbEDID,
wbFormIDCk(NAME, 'Base', [CREA], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbXRGD,
wbXRGB,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], []),
{--- Leveled Actor ----}
wbXLCM,
{--- Ownership ---}
wbRStruct('Ownership', [
wbXOWN,
wbInteger(XRNK, 'Faction rank', itS32)
], [XCMT, XCMO]),
{--- Merchant Container ----}
wbFormIDCk(XMRC, 'Merchant Container', [REFR], True),
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbFloat(XHLP, 'Health'),
{--- Decals ---}
wbRArrayS('Linked Decals',
wbStructSK(XDCR, [0], 'Decal', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA]),
wbUnknown
])
),
{--- Linked Ref ---}
wbFormIDCk(XLKR, 'Linked Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbStruct(XCLP, 'Linked Reference Color', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbFloat('Delay')
])
)
], []),
{--- Enable Parent ---}
wbXESP,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Flags ---}
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot
], True, wbPlacedAddInfo);
wbRecord(ACTI, 'Activator', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbSCRI,
wbDEST,
wbFormIDCk(SNAM, 'Sound - Looping', [SOUN]),
wbFormIDCk(VNAM, 'Sound - Activation', [SOUN]),
wbFormIDCk(RNAM, 'Radio Station', [TACT]),
wbFormIDCk(WNAM, 'Water Type', [WATR])
]);
wbICON := wbRStruct('Icon', [
wbString(ICON, 'Large Icon filename'),
wbString(MICO, 'Small Icon filename')
], []);
wbICONReq := wbRStruct('Icon', [
wbString(ICON, 'Large Icon filename'),
wbString(MICO, 'Small Icon filename')
], [], cpNormal, True);
wbVatsValueFunctionEnum :=
wbEnum([
'Weapon Is',
'Weapon In List',
'Target Is',
'Target In List',
'Target Distance',
'Target Part',
'VATS Action',
'Is Success',
'Is Critical',
'Critical Effect Is',
'Critical Effect In List',
'Is Fatal',
'Explode Part',
'Dismember Part',
'Cripple Part',
'Weapon Type Is',
'Is Stranger',
'Is Paralyzing Palm'
]);
wbActorValueEnum :=
wbEnum([
{00} 'Aggresion',
{01} 'Confidence',
{02} 'Energy',
{03} 'Responsibility',
{04} 'Mood',
{05} 'Strength',
{06} 'Perception',
{07} 'Endurance',
{08} 'Charisma',
{09} 'Intelligence',
{10} 'Agility',
{11} 'Luck',
{12} 'Action Points',
{13} 'Carry Weight',
{14} 'Critical Chance',
{15} 'Heal Rate',
{16} 'Health',
{17} 'Melee Damage',
{18} 'Damage Resistance',
{19} 'Poison Resistance',
{20} 'Rad Resistance',
{21} 'Speed Multiplier',
{22} 'Fatigue',
{23} 'Karma',
{24} 'XP',
{25} 'Perception Condition',
{26} 'Endurance Condition',
{27} 'Left Attack Condition',
{28} 'Right Attack Condition',
{29} 'Left Mobility Condition',
{30} 'Right Mobility Condition',
{31} 'Brain Condition',
{32} 'Barter',
{33} 'Big Guns',
{34} 'Energy Weapons',
{35} 'Explosives',
{36} 'Lockpick',
{37} 'Medicine',
{38} 'Melee Weapons',
{39} 'Repair',
{40} 'Science',
{41} 'Small Guns',
{42} 'Sneak',
{43} 'Speech',
{44} 'Throwing (unused)',
{45} 'Unarmed',
{46} 'Inventory Weight',
{47} 'Paralysis',
{48} 'Invisibility',
{49} 'Chameleon',
{50} 'Night Eye',
{51} 'Detect Life Range',
{52} 'Fire Resistance',
{53} 'Water Breathing',
{54} 'Rad Level',
{55} 'Bloody Mess',
{56} 'Unarmed Damage',
{57} 'Assistance',
{58} 'Electric Resistance',
{59} 'Frost Resistance',
{60} 'Energy Resistance',
{61} 'EMP Resistance',
{62} 'Variable01',
{63} 'Variable02',
{64} 'Variable03',
{65} 'Variable04',
{66} 'Variable05',
{67} 'Variable06',
{68} 'Variable07',
{79} 'Variable08',
{70} 'Variable09',
{71} 'Variable10',
{72} 'Ignore Negative Effects'
], [
-1, 'None'
]);
wbSkillEnum :=
wbEnum([
'Barter',
'Big Guns',
'Energy Weapons',
'Explosives',
'Lockpick',
'Medicine',
'Melee Weapons',
'Repair',
'Science',
'Small Guns',
'Sneak',
'Speech',
'Throwing (unused)',
'Unarmed'
], [
-1, 'None'
]);
wbCrimeTypeEnum :=
wbEnum([
'Steal',
'Pickpocket',
'Trespass',
'Attack',
'Murder'
], [
-1, 'None'
]);
wbActorValue := wbInteger('Actor Value', itS32, wbActorValueEnum);
wbEquipTypeEnum :=
wbEnum([
{00} 'Big Guns',
{01} 'Energy Weapons',
{02} 'Small Guns',
{03} 'Melee Weapons',
{04} 'Unarmed Weapon',
{05} 'Thrown Weapons',
{06} 'Mine',
{07} 'Body Wear',
{08} 'Head Wear',
{09} 'Hand Wear',
{10} 'Chems',
{11} 'Stimpack',
{12} 'Food',
{13} 'Alcohol'
], [
-1, 'None'
]);
wbETYP := wbInteger(ETYP, 'Equiptment Type', itS32, wbEquipTypeEnum);
wbETYPReq := wbInteger(ETYP, 'Equiptment Type', itS32, wbEquipTypeEnum, cpNormal, True);
wbFormTypeEnum :=
wbEnum([], [
$04, 'Texture Set',
$05, 'Menu Icon',
$06, 'Global',
$07, 'Class',
$08, 'Faction',
$09, 'Head Part',
$0A, 'Hair',
$0B, 'Eyes',
$0C, 'Race',
$0D, 'Sound',
$0E, 'Acoustic Space',
$0F, 'Skill',
$10, 'Base Effect',
$11, 'Script',
$12, 'Landscape Texture',
$13, 'Object Effect',
$14, 'Actor Effect',
$15, 'Activator',
$16, 'Talking Activator',
$17, 'Terminal',
$18, 'Armor',
$19, 'Book',
$1A, 'Clothing',
$1B, 'Container',
$1C, 'Door',
$1D, 'Ingredient',
$1E, 'Light',
$1F, 'Misc',
$20, 'Static',
$21, 'Static Collection',
$22, 'Movable Static',
$23, 'Placeable Water',
$24, 'Grass',
$25, 'Tree',
$26, 'Flora',
$27, 'Furniture',
$28, 'Weapon',
$29, 'Ammo',
$2A, 'NPC',
$2B, 'Creature',
$2C, 'Leveled Creature',
$2D, 'Leveled NPC',
$2E, 'Key',
$2F, 'Ingestible',
$30, 'Idle Marker',
$31, 'Note',
$32, 'Constructible Object',
$33, 'Projectile',
$34, 'Leveled Item',
$35, 'Weather',
$36, 'Climate',
$37, 'Region',
$39, 'Cell',
$3A, 'Placed Object',
$3B, 'Placed Character',
$3C, 'Placed Creature',
$3E, 'Placed Grenade',
$41, 'Worldspace',
$42, 'Landscape',
$43, 'Navigation Mesh',
$45, 'Dialog Topic',
$46, 'Dialog Response',
$47, 'Quest',
$48, 'Idle Animation',
$49, 'Package',
$4A, 'Combat Style',
$4B, 'Load Screen',
$4C, 'Leveled Spell',
$4D, 'Animated Object',
$4E, 'Water',
$4F, 'Effect Shader',
$51, 'Explosion',
$52, 'Debris',
$53, 'Image Space',
$54, 'Image Space Modifier',
$55, 'FormID List',
$56, 'Perk',
$57, 'Body Part Data',
$58, 'Addon Node',
$59, 'Actor Value Info',
$5A, 'Radiation Stage',
$5B, 'Camera Shot',
$5C, 'Camera Path',
$5D, 'Voice Type',
$5E, 'Impact Data',
$5F, 'Impact DataSet',
$60, 'Armor Addon',
$61, 'Encounter Zone',
$62, 'Message',
$63, 'Ragdoll',
$64, 'Default Object Manager',
$65, 'Lighting Template',
$66, 'Music Type'
]);
wbMenuModeEnum :=
wbEnum([],[
1, 'Type: Character Interface',
2, 'Type: Other',
3, 'Type: Console',
1001, 'Specific: Message',
1002, 'Specific: Inventory',
1003, 'Specific: Stats',
1004, 'Specific: HUDMainMenu',
1007, 'Specific: Loading',
1008, 'Specific: Container',
1009, 'Specific: Dialog',
1012, 'Specific: Sleep/Wait',
1013, 'Specific: Pause',
1014, 'Specific: LockPick',
1016, 'Specific: Quantity',
1027, 'Specific: Level Up',
1035, 'Specific: Pipboy Repair',
1036, 'Specific: Race / Sex',
1047, 'Specific: Credits',
1048, 'Specific: CharGen',
1051, 'Specific: TextEdit',
1053, 'Specific: Barter',
1054, 'Specific: Surgery',
1055, 'Specific: Hacking',
1056, 'Specific: VATS',
1057, 'Specific: Computers',
1058, 'Specific: Vendor Repair',
1059, 'Specific: Tutorial',
1060, 'Specific: You''re SPECIAL book'
]);
end;
procedure DefineFO3b;
begin
wbMiscStatEnum :=
wbEnum([
'Quests Completed',
'Locations Discovered',
'People Killed',
'Creatures Killed',
'Locks Picked',
'Computers Hacked',
'Stimpaks Taken',
'Rad-X Taken',
'RadAway Taken',
'Chems Taken',
'Times Addicted',
'Mines Disarmed',
'Speech Successes',
'Pockets Picked',
'Pants Exploded',
'Books Read',
'Bobbleheads Found',
'Weapons Created',
'People Mezzed',
'Captives Rescued',
'Sandman Kills',
'Paralyzing Punches',
'Robots Disabled',
'Contracts Completed',
'Corpses Eaten',
'Mysterious Stranger Visits'
]);
wbAlignmentEnum :=
wbEnum([
'Good',
'Neutral',
'Evil',
'Very Good',
'Very Evil'
]);
wbAxisEnum :=
wbEnum([], [
88, 'X',
89, 'Y',
90, 'Z'
]);
wbCriticalStageEnum :=
wbEnum([
'None',
'Goo Start',
'Goo End',
'Disintegrate Start',
'Disintegrate End'
]);
wbSexEnum :=
wbEnum(['Male','Female']);
wbCreatureTypeEnum :=
wbEnum([
'Animal',
'Mutated Animal',
'Mutated Insect',
'Abomination',
'Super Mutant',
'Feral Ghoul',
'Robot',
'Giant'
]);
wbPlayerActionEnum :=
wbEnum([
'',
'Swinging Melee Weapon',
'Throwing Grenade',
'Fire Weapon',
'Lay Mine',
'Z Key Object',
'Jumping',
'Knocking over Objects',
'Stand on Table/Chair',
'Iron Sites',
'Destroying Object'
]);
wbBodyLocationEnum :=
wbEnum([
'Torso',
'Head 1',
'Head 2',
'Left Arm 1',
'Left Arm 2',
'Right Arm 1',
'Right Arm 2',
'Left Leg 1',
'Left Leg 2',
'Left Leg 3',
'Right Leg 1',
'Right Leg 2',
'Right Leg 3',
'Brain'
], [
-1, 'None'
]);
wbEFID := wbFormIDCk(EFID, 'Base Effect', [MGEF]);
wbEFIT :=
wbStructSK(EFIT, [3, 4], '', [
wbInteger('Magnitude', itU32),
wbInteger('Area', itU32),
wbInteger('Duration', itU32),
wbInteger('Type', itU32, wbEnum(['Self', 'Touch', 'Target'])),
wbActorValue
], cpNormal, True, nil, -1, wbEFITAfterLoad);
wbCTDA :=
wbStruct(CTDA, 'Condition', [
wbInteger('Type', itU8, wbCtdaTypeToStr, wbCtdaTypeToInt, cpNormal, False, nil, wbCtdaTypeAfterSet),
wbByteArray('Unused', 3),
wbUnion('Comparison Value', wbCTDACompValueDecider, [
wbFloat('Comparison Value - Float'),
wbFormIDCk('Comparison Value - Global', [GLOB])
]),
wbInteger('Function', itU32, wbCTDAFunctionToStr, wbCTDAFunctionToInt), // Limited to itu16
wbUnion('Parameter #1', wbCTDAParam1Decider, [
{00} wbByteArray('Unknown', 4),
{01} wbByteArray('None', 4, cpIgnore),
{02} wbInteger('Integer', itS32),
{03} wbInteger('Variable Name (INVALID)', itS32),
{04} wbInteger('Sex', itU32, wbSexEnum),
{05} wbInteger('Actor Value', itS32, wbActorValueEnum),
{06} wbInteger('Crime Type', itU32, wbCrimeTypeEnum),
{07} wbInteger('Axis', itU32, wbAxisEnum),
{08} wbInteger('Quest Stage (INVALID)', itS32),
{09} wbInteger('Misc Stat', itU32, wbMiscStatEnum),
{10} wbInteger('Alignment', itU32, wbAlignmentEnum),
{11} wbInteger('Equip Type', itU32, wbEquipTypeEnum),
{12} wbInteger('Form Type', itU32, wbFormTypeEnum),
{13} wbInteger('Critical Stage', itU32, wbCriticalStageEnum),
{14} wbFormIDCkNoReach('Object Reference', [PLYR, REFR, ACHR, ACRE, PGRE, PMIS, PBEA, TRGT], True),
{16} wbFormIDCkNoReach('Inventory Object', [ARMO, BOOK, MISC, WEAP, AMMO, KEYM, ALCH, NOTE, FLST]),
{17} wbFormIDCkNoReach('Actor', [PLYR, ACHR, ACRE, TRGT], True),
{18} wbFormIDCkNoReach('Voice Type', [VTYP]),
{19} wbFormIDCkNoReach('Idle', [IDLE]),
{20} wbFormIDCkNoReach('Form List', [FLST]),
{21} wbFormIDCkNoReach('Note', [NOTE]),
{22} wbFormIDCkNoReach('Quest', [QUST]),
{23} wbFormIDCkNoReach('Faction', [FACT]),
{24} wbFormIDCkNoReach('Weapon', [WEAP]),
{25} wbFormIDCkNoReach('Cell', [CELL]),
{26} wbFormIDCkNoReach('Class', [CLAS]),
{27} wbFormIDCkNoReach('Race', [RACE]),
{28} wbFormIDCkNoReach('Actor Base', [NPC_, CREA, ACTI, TACT]),
{29} wbFormIDCkNoReach('Global', [GLOB]),
{30} wbFormIDCkNoReach('Weather', [WTHR]),
{31} wbFormIDCkNoReach('Package', [PACK]),
{32} wbFormIDCkNoReach('Encounter Zone', [ECZN]),
{33} wbFormIDCkNoReach('Perk', [PERK]),
{34} wbFormIDCkNoReach('Owner', [FACT, NPC_]),
{35} wbFormIDCkNoReach('Furniture', [FURN, FLST]),
{36} wbFormIDCkNoReach('Effect Item', [SPEL, ENCH, ALCH, INGR]),
{37} wbFormIDCkNoReach('Base Effect', [MGEF]),
{38} wbFormIDCkNoReach('Worldspace', [WRLD]),
{39} wbInteger('VATS Value Function', itU32, wbVATSValueFunctionEnum),
{40} wbInteger('VATS Value Param (INVALID)', itU32),
{41} wbInteger('Creature Type', itU32, wbCreatureTypeEnum),
{42} wbInteger('Menu Mode', itU32, wbMenuModeEnum),
{43} wbInteger('Player Action', itU32, wbPlayerActionEnum),
{44} wbInteger('Body Location', itS32, wbBodyLocationEnum),
{45} wbFormIDCkNoReach('Referenceable Object', [CREA, NPC_, PROJ, TREE, SOUN, ACTI, DOOR, STAT, FURN, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS, ASPC, IDLM, ARMA, MSTT, NOTE, PWAT, SCOL, TACT, TERM, FLST, LVLC, LVLN],
[CREA, NPC_, PROJ, TREE, SOUN, ACTI, DOOR, STAT, FURN, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS, ASPC, IDLM, ARMA, MSTT, NOTE, PWAT, SCOL, TACT, TERM, LVLC, LVLN])
]),
wbUnion('Parameter #2', wbCTDAParam2Decider, [
{00} wbByteArray('Unknown', 4),
{01} wbByteArray('None', 4, cpIgnore),
{02} wbInteger('Integer', itS32),
{03} wbInteger('Variable Name', itS32, wbCTDAParam2VariableNameToStr, wbCTDAParam2VariableNameToInt),
{04} wbInteger('Sex', itU32, wbSexEnum),
{05} wbInteger('Actor Value', itS32, wbActorValueEnum),
{06} wbInteger('Crime Type', itU32, wbCrimeTypeEnum),
{07} wbInteger('Axis', itU32, wbAxisEnum),
{08} wbInteger('Quest Stage', itS32, wbCTDAParam2QuestStageToStr, wbCTDAParam2QuestStageToInt),
{09} wbInteger('Misc Stat', itU32, wbMiscStatEnum),
{10} wbInteger('Alignment', itU32, wbAlignmentEnum),
{11} wbInteger('Equip Type', itU32, wbEquipTypeEnum),
{12} wbInteger('Form Type', itU32, wbFormTypeEnum),
{13} wbInteger('Critical Stage', itU32, wbCriticalStageEnum),
{14} wbFormIDCkNoReach('Object Reference', [PLYR, REFR, PMIS, PBEA, ACHR, ACRE, PGRE, TRGT], True),
{16} wbFormIDCkNoReach('Inventory Object', [ARMO, BOOK, MISC, WEAP, AMMO, KEYM, ALCH, NOTE, FLST]),
{17} wbFormIDCkNoReach('Actor', [PLYR, ACHR, ACRE, TRGT], True),
{18} wbFormIDCkNoReach('Voice Type', [VTYP]),
{19} wbFormIDCkNoReach('Idle', [IDLE]),
{20} wbFormIDCkNoReach('Form List', [FLST]),
{21} wbFormIDCkNoReach('Note', [NOTE]),
{22} wbFormIDCkNoReach('Quest', [QUST]),
{23} wbFormIDCkNoReach('Faction', [FACT]),
{24} wbFormIDCkNoReach('Weapon', [WEAP]),
{25} wbFormIDCkNoReach('Cell', [CELL]),
{26} wbFormIDCkNoReach('Class', [CLAS]),
{27} wbFormIDCkNoReach('Race', [RACE]),
{28} wbFormIDCkNoReach('Actor Base', [NPC_, CREA, ACTI, TACT]),
{29} wbFormIDCkNoReach('Global', [GLOB]),
{30} wbFormIDCkNoReach('Weather', [WTHR]),
{31} wbFormIDCkNoReach('Package', [PACK]),
{32} wbFormIDCkNoReach('Encounter Zone', [ECZN]),
{33} wbFormIDCkNoReach('Perk', [PERK]),
{34} wbFormIDCkNoReach('Owner', [FACT, NPC_]),
{35} wbFormIDCkNoReach('Furniture', [FURN, FLST]),
{36} wbFormIDCkNoReach('Effect Item', [SPEL, ENCH, ALCH, INGR]),
{37} wbFormIDCkNoReach('Base Effect', [MGEF]),
{38} wbFormIDCkNoReach('Worldspace', [WRLD]),
{39} wbInteger('VATS Value Function (INVALID)', itU32),
{40} wbUnion('VATS Value Param', wbCTDAParam2VATSValueParam, [
wbFormIDCkNoReach('Weapon', [WEAP]),
wbFormIDCkNoReach('Weapon List', [FLST], [WEAP]),
wbFormIDCkNoReach('Target', [NPC_, CREA]),
wbFormIDCkNoReach('Target List', [FLST], [NPC_, CREA]),
wbByteArray('Unused', 4, cpIgnore),
wbInteger('Target Part', itS32, wbActorValueEnum),
wbInteger('VATS Action', itU32, wbEnum([
'Unarmed Attack',
'One Hand Melee Attack',
'Two Hand Melee Attack',
'Fire Pistol',
'Fire Rifle',
'Fire Handle Weapon',
'Fire Launcher',
'Throw Grenade',
'Place Mine',
'Reload',
'Crouch',
'Stand',
'Switch Weapon',
'Toggle Weapon Drawn',
'Heal',
'Player Death'
])),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbFormIDCkNoReach('Critical Effect', [SPEL]),
wbFormIDCkNoReach('Critical Effect List', [FLST], [SPEL]),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbInteger('Weapon Type', itU32, wbWeaponAnimTypeEnum),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore)
]),
{41} wbInteger('Creature Type', itU32, wbCreatureTypeEnum),
{42} wbInteger('Menu Mode', itU32, wbMenuModeEnum),
{43} wbInteger('Player Action', itU32, wbPlayerActionEnum),
{44} wbInteger('Body Location', itS32, wbBodyLocationEnum),
{45} wbFormIDCkNoReach('Referenceable Object', [CREA, NPC_, PROJ, TREE, SOUN, ACTI, DOOR, STAT, FURN, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS, ASPC, IDLM, ARMA, MSTT, NOTE, PWAT, SCOL, TACT, TERM, FLST, LVLC, LVLN],
[CREA, NPC_, PROJ, TREE, SOUN, ACTI, DOOR, STAT, FURN, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS, ASPC, IDLM, ARMA, MSTT, NOTE, PWAT, SCOL, TACT, TERM, LVLC, LVLN])
]),
wbInteger('Run On', itU32, wbEnum([
'Subject',
'Target',
'Reference',
'Combat Target',
'Linked Reference'
]), cpNormal, False, nil, wbCTDARunOnAfterSet),
wbUnion('Reference', wbCTDAReferenceDecider, [
wbInteger('Unused', itU32, nil, cpIgnore),
wbFormIDCkNoReach('Reference', [PLYR, ACHR, ACRE, REFR, PMIS, PBEA, PGRE], True)
])
], cpNormal, False, nil, 6, wbCTDAAfterLoad);
wbCTDAs := wbRArray('Conditions', wbCTDA);
wbCTDAsReq := wbRArray('Conditions', wbCTDA, cpNormal, True);
wbEffects :=
wbRStructs('Effects','Effect', [
wbEFID,
wbEFIT,
wbCTDAs
], []);
wbEffectsReq :=
wbRStructs('Effects','Effect', [
wbEFID,
wbEFIT,
wbCTDAs
], [], cpNormal, True);
wbRecord(ALCH, 'Ingestible', [
wbEDIDReq,
wbOBNDReq,
wbFULLReq,
wbMODL,
wbICON,
wbSCRI,
wbDEST,
wbYNAM,
wbZNAM,
wbETYPReq,
wbFloat(DATA, 'Weight', cpNormal, True),
wbStruct(ENIT, 'Effect Data', [
wbInteger('Value', itS32),
wbInteger('Flags?', itU8, wbFlags([
'No Auto-Calc (Unused)',
'Food Item',
'Medicine'
])),
wbByteArray('Unused', 3),
wbFormIDCk('Withdrawal Effect', [SPEL, NULL]),
wbFloat('Addiction Chance'),
wbFormIDCk('Sound - Consume', [SOUN])
], cpNormal, True),
wbEffectsReq
]);
wbRecord(AMMO, 'Ammunition', [
wbEDIDReq,
wbOBNDReq,
wbFULLReq,
wbMODL,
wbICON,
wbDEST,
wbYNAM,
wbZNAM,
wbStruct(DATA, 'Data', [
wbFloat('Speed'),
wbInteger('Flags', itU8, wbFlags([
'Ignores Normal Weapon Resistance',
'Non-Playable'
])),
wbByteArray('Unused', 3),
wbInteger('Value', itS32),
wbInteger('Clip Rounds', itU8)
], cpNormal, True),
wbString(ONAM, 'Short Name')
]);
wbRecord(ANIO, 'Animated Object', [
wbEDIDReq,
wbMODLReq,
wbFormIDCk(DATA, 'Animation', [IDLE], False, cpNormal, True)
]);
wbBMDT := wbStruct(BMDT, 'Biped Data', [
wbInteger('Biped Flags', itU32, wbFlags([
{0x00000001} 'Head',
{0x00000002} 'Hair',
{0x00000004} 'Upper Body',
{0x00000008} 'Left Hand',
{0x00000010} 'Right Hand',
{0x00000020} 'Weapon',
{0x00000040} 'PipBoy',
{0x00000080} 'Backpack',
{0x00000100} 'Necklace',
{0x00000200} 'Headband',
{0x00000400} 'Hat',
{0x00000800} 'Eye Glasses',
{0x00001000} 'Nose Ring',
{0x00002000} 'Earrings',
{0x00004000} 'Mask',
{0x00008000} 'Choker',
{0x00010000} 'Mouth Object',
{0x00020000} 'Body AddOn 1',
{0x00040000} 'Body AddOn 2',
{0x00080000} 'Body AddOn 3'
])),
wbInteger('General Flags', itU8, wbFlags([
{0x0001} '',
{0x0002} '',
{0x0004} '',
{0x0008} '',
{0x0010} '',
{0x0020} 'Power Armor',
{0x0040} 'Non-Playable',
{0x0080} 'Heavy'
], True)),
wbByteArray('Unused', 3)
], cpNormal, True);
wbRecord(ARMO, 'Armor', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbSCRI,
wbEITM,
wbBMDT,
wbRStruct('Male biped model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore),
wbMODS,
wbMODD
], [], cpNormal, False, nil, True),
wbRStruct('Male world model', [
wbString(MOD2, 'Model Filename'),
wbByteArray(MO2T, 'Texture Files Hashes', 0, cpIgnore),
wbMO2S
], []),
wbString(ICON, 'Male icon filename'),
wbString(MICO, 'Male mico filename'),
wbRStruct('Female biped model', [
wbString(MOD3, 'Model Filename', 0, cpNormal, True),
wbByteArray(MO3T, 'Texture Files Hashes', 0, cpIgnore),
wbMO3S,
wbMOSD
], [], cpNormal, False, nil, True),
wbRStruct('Female world model', [
wbString(MOD4, 'Model Filename'),
wbByteArray(MO4T, 'Texture Files Hashes', 0, cpIgnore),
wbMO4S
], []),
wbString(ICO2, 'Female icon filename'),
wbString(MIC2, 'Female mico filename'),
wbString(BMCT, 'Ragdoll Constraint Template'),
wbDEST,
wbREPL,
wbBIPL,
wbETYPReq,
wbYNAM,
wbZNAM,
wbStruct(DATA, 'Data', [
wbInteger('Value', itS32),
wbInteger('Max Condition', itS32),
wbFloat('Weight')
], cpNormal, True),
wbStruct(DNAM, '', [
wbInteger('AR', itS16, wbDiv(100)),
wbInteger('Flags', itU16, wbFlags([
'Modulates Voice'
]))
], cpNormal, True)
]);
wbRecord(ARMA, 'Armor Addon', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbBMDT,
wbRStruct('Male biped model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore),
wbMODS,
wbMODD
], [], cpNormal, False, nil, True),
wbRStruct('Male world model', [
wbString(MOD2, 'Model Filename'),
wbByteArray(MO2T, 'Texture Files Hashes', 0, cpIgnore),
wbMO2S
], []),
wbString(ICON, 'Male icon filename'),
wbString(MICO, 'Male mico filename'),
wbRStruct('Female biped model', [
wbString(MOD3, 'Model Filename', 0, cpNormal, True),
wbByteArray(MO3T, 'Texture Files Hashes', 0, cpIgnore),
wbMO3S,
wbMOSD
], [], cpNormal, False, nil, True),
wbRStruct('Female world model', [
wbString(MOD4, 'Model Filename'),
wbByteArray(MO4T, 'Texture Files Hashes', 0, cpIgnore),
wbMO4S
], []),
wbString(ICO2, 'Female icon filename'),
wbString(MIC2, 'Female mico filename'),
wbETYPReq,
wbStruct(DATA, 'Data', [
wbInteger('Value', itS32),
wbInteger('Max Condition', itS32),
wbFloat('Weight')
], cpNormal, True),
wbStruct(DNAM, '', [
wbInteger('AR', itS16, wbDiv(100)),
wbInteger('Flags', itU16, wbFlags([
'Modulates Voice'
]))
], cpNormal, True)
]);
wbRecord(BOOK, 'Book', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbSCRI,
wbDESCReq,
wbDEST,
wbYNAM,
wbZNAM,
wbStruct(DATA, 'Data', [
wbInteger('Flags', itU8, wbFlags([
'',
'Can''t be Taken'
])),
wbInteger('Skill', itS8, wbSkillEnum),
wbInteger('Value', itS32),
wbFloat('Weight')
], cpNormal, True)
]);
wbSPLO := wbFormIDCk(SPLO, 'Actor Effect', [SPEL]);
wbSPLOs := wbRArrayS('Actor Effects', wbSPLO, cpNormal, False, nil, nil, wbActorTemplateUseActorEffectList);
wbRecord(CELL, 'Cell', [
wbEDID,
wbFULL,
wbInteger(DATA, 'Flags', itU8, wbFlags([
{0x01} 'Is Interior Cell',
{0x02} 'Has water',
{0x04} 'Invert Fast Travel behavior',
{0x08} 'No LOD Water',
{0x10} '',
{0x20} 'Public place',
{0x40} 'Hand changed',
{0x80} 'Behave like exterior'
]), cpNormal, True),
wbStruct(XCLC, 'Grid', [
wbInteger('X', itS32),
wbInteger('Y', itS32),
wbInteger('Force Hide Land', itU32, wbFlags([
'Quad 1',
'Quad 2',
'Quad 3',
'Quad 4'
], True))
], cpNormal, False, nil, 2),
wbStruct(XCLL, 'Lighting', [
wbStruct('Ambient Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Directional Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Fog Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbFloat('Fog Near'),
wbFloat('Fog Far'),
wbInteger('Directional Rotation XY', itS32),
wbInteger('Directional Rotation Z', itS32),
wbFloat('Directional Fade'),
wbFloat('Fog Clip Dist'),
wbFloat('Fog Power')
], cpNormal, False, nil, 7),
wbArray(IMPF, 'Footstep Materials', wbString('Unknown', 30), [
'ConcSolid',
'ConcBroken',
'MetalSolid',
'MetalHollow',
'MetalSheet',
'Wood',
'Sand',
'Dirt',
'Grass',
'Water'
]),
wbRStruct('Light Template', [
wbFormIDCk(LTMP, 'Template', [LGTM, NULL]),
wbInteger(LNAM, 'Inherit', itU32, wbFlags([
{0x00000001}'Ambient Color',
{0x00000002}'Directional Color',
{0x00000004}'Fog Color',
{0x00000008}'Fog Near',
{0x00000010}'Fog Far',
{0x00000020}'Directional Rotation',
{0x00000040}'Directional Fade',
{0x00000080}'Clip Distance',
{0x00000100}'Fog Power'
]), cpNormal, True)
], [], cpNormal, True ),
wbFloat(XCLW, 'Water Height'),
wbString(XNAM, 'Water Noise Texture'),
wbArrayS(XCLR, 'Regions', wbFormIDCk('Region', [REGN])),
wbFormIDCk(XCIM, 'Image Space', [IMGS]),
wbByteArray(XCET, 'Unknown', 1, cpIgnore),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbFormIDCk(XCCM, 'Climate', [CLMT]),
wbFormIDCk(XCWT, 'Water', [WATR]),
wbRStruct('Ownership', [
wbXOWN,
wbInteger(XRNK, 'Faction rank', itS32)
], [XCMT, XCMO]),
wbFormIDCk(XCAS, 'Acoustic Space', [ASPC]),
wbByteArray(XCMT, 'Unused', 1, cpIgnore),
wbFormIDCk(XCMO, 'Music Type', [MUSC])
], True, wbCellAddInfo, cpNormal, False, wbCELLAfterLoad);
wbServiceFlags :=
wbFlags([
{0x00000001} 'Weapons',
{0x00000002} 'Armor',
{0x00000004} 'Alcohol',
{0x00000008} 'Books',
{0x00000010} 'Food',
{0x00000020} 'Chems',
{0x00000040} 'Stimpacks',
{0x00000080} 'Lights?',
{0x00000100} '',
{0x00000200} '',
{0x00000400} 'Miscellaneous',
{0x00000800} '',
{0x00001000} '',
{0x00002000} 'Potions?',
{0x00004000} 'Training',
{0x00008000} '',
{0x00010000} 'Recharge',
{0x00020000} 'Repair'
]);
wbSpecializationEnum := wbEnum(['Combat', 'Magic', 'Stealth']);
wbRecord(CLAS, 'Class', [
wbEDIDReq,
wbFULLReq,
wbDESCReq,
wbICON,
wbStruct(DATA, '', [
wbArray('Tag Skills', wbInteger('Tag Skill', itS32, wbActorValueEnum), 4),
wbInteger('Flags', itU32, wbFlags(['Playable', 'Guard'], True)),
wbInteger('Buys/Sells and Services', itU32, wbServiceFlags),
wbInteger('Teaches', itS8, wbSkillEnum),
wbInteger('Maximum training level', itU8),
wbByteArray('Unused', 2)
], cpNormal, True),
wbArray(ATTR, 'Attributes', wbInteger('Attribute', itU8), [
'Strength',
'Perception',
'Endurance',
'Charisma',
'Intelligence',
'Agility',
'Luck'
], cpNormal, True)
]);
end;
procedure DefineFO3c;
begin
wbRecord(CLMT, 'Climate', [
wbEDIDReq,
wbArrayS(WLST, 'Weather Types', wbStructSK([0], 'Weather Type', [
wbFormIDCk('Weather', [WTHR, NULL]),
wbInteger('Chance', itS32),
wbFormIDCk('Global', [GLOB, NULL])
])),
wbString(FNAM, 'Sun Texture'),
wbString(GNAM, 'Sun Glare Texture'),
wbMODL,
wbStruct(TNAM, 'Timing', [
wbStruct('Sunrise', [
wbInteger('Begin', itU8, wbClmtTime),
wbInteger('End', itU8, wbClmtTime)
]),
wbStruct('Sunset', [
wbInteger('Begin', itU8, wbClmtTime),
wbInteger('End', itU8, wbClmtTime)
]),
wbInteger('Volatility', itU8),
wbInteger('Moons / Phase Length', itU8, wbClmtMoonsPhaseLength)
], cpNormal, True)
]);
wbCNTO :=
wbRStructExSK([0], [1], 'Item', [
wbStructExSK(CNTO, [0], [1], 'Item', [
wbFormIDCk('Item', [ARMO, AMMO, MISC, WEAP, BOOK, LVLI, KEYM, ALCH, NOTE, MSTT{?}, STAT{?}]),
wbInteger('Count', itS32)
]),
wbCOED
], []);
wbCNTOs := wbRArrayS('Items', wbCNTO);
wbRecord(CONT, 'Container', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbSCRI,
wbCNTOs,
wbDEST,
wbStruct(DATA, '', [
wbInteger('Flags', itU8, wbFlags(['', 'Respawns'])),
wbFloat('Weight')
], cpNormal, True),
wbFormIDCk(SNAM, 'Sound - Open', [SOUN]),
wbFormIDCk(QNAM, 'Sound - Close', [SOUN])
], True);
wbCSDT := wbRStructSK([0], 'Sound Type', [
wbInteger(CSDT, 'Type', itU32,wbEnum([
{0x00} 'Left Foot',
{0x01} 'Right Foot',
{0x02} 'Left Back Foot',
{0x03} 'Right Back Foot',
{0x04} 'Idle',
{0x05} 'Aware',
{0x06} 'Attack',
{0x07} 'Hit',
{0x08} 'Death',
{0x09} 'Weapon',
{0x0A} 'Movement',
{0x0B} 'Conscious'
])),
wbRArrayS('Sounds', wbRStructSK([0], 'Sound', [
wbFormIDCk(CSDI, 'Sound', [SOUN], False, cpNormal, True),
wbInteger(CSDC, 'Sound Chance', itU8, nil, cpNormal, True)
], []), cpNormal, True)
], []);
wbCSDTs := wbRArrayS('Sound Types', wbCSDT, cpNormal, False, nil, nil, wbActorTemplateUseModelAnimation);
wbAgressionEnum := wbEnum([
'Unaggressive',
'Aggressive',
'Very Aggressive',
'Frenzied'
]);
wbConfidenceEnum := wbEnum([
'Cowardly',
'Cautious',
'Average',
'Brave',
'Foolhardy'
]);
wbMoodEnum := wbEnum([
'Neutral',
'Afraid',
'Annoyed',
'Cocky',
'Drugged',
'Pleasant',
'Angry',
'Sad'
]);
wbAssistanceEnum := wbEnum([
'Helps Nobody',
'Helps Allies',
'Helps Friends and Allies'
]);
wbAggroRadiusFlags := wbFlags([
'Aggro Radius Behavior'
]);
wbAIDT :=
wbStruct(AIDT, 'AI Data', [
{00} wbInteger('Aggression', itU8, wbAgressionEnum),
{01} wbInteger('Confidence', itU8, wbConfidenceEnum),
{02} wbInteger('Energy Level', itU8),
{03} wbInteger('Responsibility', itU8),
{04} wbInteger('Mood', itU8, wbMoodEnum),
wbByteArray('Unused', 3),
{08} wbInteger('Buys/Sells and Services', itU32, wbServiceFlags),
{0C} wbInteger('Teaches', itS8, wbSkillEnum),
{0D} wbInteger('Maximum training level', itU8),
{0E} wbInteger('Assistance', itS8, wbAssistanceEnum),
{0F} wbInteger('Aggro Radius Behavior', itU8, wbAggroRadiusFlags),
{10} wbInteger('Aggro Radius', itS32)
], cpNormal, True, wbActorTemplateUseAIData);
wbAttackAnimationEnum :=
wbEnum([
], [
26, 'AttackLeft',
27, 'AttackLeftUp',
28, 'AttackLeftDown',
29, 'AttackLeftIS',
30, 'AttackLeftISUp',
31, 'AttackLeftISDown',
32, 'AttackRight',
33, 'AttackRightUp',
34, 'AttackRightDown',
35, 'AttackRightIS',
36, 'AttackRightISUp',
37, 'AttackRightISDown',
38, 'Attack3',
39, 'Attack3Up',
40, 'Attack3Down',
41, 'Attack3IS',
42, 'Attack3ISUp',
43, 'Attack3ISDown',
44, 'Attack4',
45, 'Attack4Up',
46, 'Attack4Down',
47, 'Attack4IS',
48, 'Attack4ISUp',
49, 'Attack4ISDown',
50, 'Attack5',
51, 'Attack5Up',
52, 'Attack5Down',
53, 'Attack5IS',
54, 'Attack5ISUp',
55, 'Attack5ISDown',
56, 'Attack6',
57, 'Attack6Up',
58, 'Attack6Down',
59, 'Attack6IS',
60, 'Attack6ISUp',
61, 'Attack6ISDown',
62, 'Attack7',
63, 'Attack7Up',
64, 'Attack7Down',
65, 'Attack7IS',
66, 'Attack7ISUp',
67, 'Attack7ISDown',
68, 'Attack8',
69, 'Attack8Up',
70, 'Attack8Down',
71, 'Attack8IS',
72, 'Attack8ISUp',
73, 'Attack8ISDown',
74, 'AttackLoop',
75, 'AttackLoopUp',
76, 'AttackLoopDown',
77, 'AttackLoopIS',
78, 'AttackLoopISUp',
79, 'AttackLoopISDown',
80, 'AttackSpin',
81, 'AttackSpinUp',
82, 'AttackSpinDown',
83, 'AttackSpinIS',
84, 'AttackSpinISUp',
85, 'AttackSpinISDown',
86, 'AttackSpin2',
87, 'AttackSpin2Up',
88, 'AttackSpin2Down',
89, 'AttackSpin2IS',
90, 'AttackSpin2ISUp',
91, 'AttackSpin2ISDown',
92, 'AttackPower',
93, 'AttackForwardPower',
94, 'AttackBackPower',
95, 'AttackLeftPower',
96, 'AttackRightPower',
97, 'PlaceMine',
98, 'PlaceMineUp',
99, 'PlaceMineDown',
100, 'PlaceMineIS',
101, 'PlaceMineISUp',
102, 'PlaceMineISDown',
103, 'PlaceMine2',
104, 'PlaceMine2Up',
105, 'PlaceMine2Down',
106, 'PlaceMine2IS',
107, 'PlaceMine2ISUp',
108, 'PlaceMine2ISDown',
109, 'AttackThrow',
110, 'AttackThrowUp',
111, 'AttackThrowDown',
112, 'AttackThrowIS',
113, 'AttackThrowISUp',
114, 'AttackThrowISDown',
115, 'AttackThrow2',
116, 'AttackThrow2Up',
117, 'AttackThrow2Down',
118, 'AttackThrow2IS',
119, 'AttackThrow2ISUp',
120, 'AttackThrow2ISDown',
121, 'AttackThrow3',
122, 'AttackThrow3Up',
123, 'AttackThrow3Down',
124, 'AttackThrow3IS',
125, 'AttackThrow3ISUp',
126, 'AttackThrow3ISDown',
127, 'AttackThrow4',
128, 'AttackThrow4Up',
129, 'AttackThrow4Down',
130, 'AttackThrow4IS',
131, 'AttackThrow4ISUp',
132, 'AttackThrow4ISDown',
133, 'AttackThrow5',
134, 'AttackThrow5Up',
135, 'AttackThrow5Down',
136, 'AttackThrow5IS',
137, 'AttackThrow5ISUp',
138, 'AttackThrow5ISDown',
167, 'PipBoy',
178, 'PipBoyChild',
255, ' ANY'
]);
wbImpactMaterialTypeEnum :=
wbEnum([
'Stone',
'Dirt',
'Grass',
'Glass',
'Metal',
'Wood',
'Organic',
'Cloth',
'Water',
'Hollow Metal',
'Organic Bug',
'Organic Glow'
]);
wbTemplateFlags := wbFlags([
'Use Traits',
'Use Stats',
'Use Factions',
'Use Actor Effect List',
'Use AI Data',
'Use AI Packages',
'Use Model/Animation',
'Use Base Data',
'Use Inventory',
'Use Script'
]);
wbRecord(CREA, 'Creature', [
wbEDIDReq,
wbOBNDReq,
wbFULLActor,
wbMODLActor,
wbSPLOs,
wbFormIDCk(EITM, 'Unarmed Attack Effect', [ENCH, SPEL], False, cpNormal, False, wbActorTemplateUseActorEffectList),
wbInteger(EAMT, 'Unarmed Attack Animation', itU16, wbAttackAnimationEnum, cpNormal, True, False, wbActorTemplateUseActorEffectList),
wbArrayS(NIFZ, 'Model List', wbStringLC('Model'), 0, cpNormal, False, nil, nil, wbActorTemplateUseModelAnimation),
wbByteArray(NIFT, 'Texture Files Hashes', 0, cpIgnore, False, False, wbActorTemplateUseModelAnimation),
wbStruct(ACBS, 'Configuration', [
{00} wbInteger('Flags', itU32, wbFlags([
{0x000001} 'Biped',
{0x000002} 'Essential',
{0x000004} 'Weapon & Shield?',
{0x000008} 'Respawn',
{0x000010} 'Swims',
{0x000020} 'Flies',
{0x000040} 'Walks',
{0x000080} 'PC Level Mult',
{0x000100} 'Unknown 8',
{0x000200} 'No Low Level Processing',
{0x000400} '',
{0x000800} 'No Blood Spray',
{0x001000} 'No Blood Decal',
{0x002000} '',
{0x004000} '',
{0x008000} 'No Head',
{0x010000} 'No Right Arm',
{0x020000} 'No Left Arm',
{0x040000} 'No Combat in Water',
{0x080000} 'No Shadow',
{0x100000} 'No VATS Melee',
{0x00200000} 'Allow PC Dialogue',
{0x00400000} 'Can''t Open Doors',
{0x00800000} 'Immobile',
{0x01000000} 'Tilt Front/Back',
{0x02000000} 'Tilt Left/Right',
{0x03000000} 'No Knockdowns',
{0x08000000} 'Not Pushable',
{0x10000000} 'Allow Pickpocket',
{0x20000000} 'Is Ghost',
{0x40000000} 'No Rotating To Head-track',
{0x80000000} 'Invulnerable'
], [
{0x000001 Biped} wbActorTemplateUseModelAnimation,
{0x000002 Essential} wbActorTemplateUseBaseData,
{0x000004 Weapon & Shield} nil,
{0x000008 Respawn} wbActorTemplateUseBaseData,
{0x000010 Swims} wbActorTemplateUseModelAnimation,
{0x000020 Flies} wbActorTemplateUseModelAnimation,
{0x000040 Walks} wbActorTemplateUseModelAnimation,
{0x000080 PC Level Mult} wbActorTemplateUseStats,
{0x000100 Unknown 8} nil,
{0x000200 No Low Level Processing} wbActorTemplateUseBaseData,
{0x000400 } nil,
{0x000800 No Blood Spray} wbActorTemplateUseModelAnimation,
{0x001000 No Blood Decal} wbActorTemplateUseModelAnimation,
{0x002000 } nil,
{0x004000 } nil,
{0x008000 No Head} wbActorTemplateUseModelAnimation,
{0x010000 No Right Arm} wbActorTemplateUseModelAnimation,
{0x020000 No Left Arm} wbActorTemplateUseModelAnimation,
{0x040000 No Combat in Water} wbActorTemplateUseModelAnimation,
{0x080000 No Shadow} wbActorTemplateUseModelAnimation,
{0x100000 No VATS Melee} nil,
{0x00200000 Allow PC Dialogue} wbActorTemplateUseBaseData,
{0x00400000 Can''t Open Doors} wbActorTemplateUseBaseData,
{0x00800000 Immobile} wbActorTemplateUseModelAnimation,
{0x01000000 Tilt Front/Back} wbActorTemplateUseModelAnimation,
{0x02000000 Tilt Left/Right} wbActorTemplateUseModelAnimation,
{0x03000000 No Knockdowns} nil,
{0x08000000 Not Pushable} wbActorTemplateUseModelAnimation,
{0x10000000 Allow Pickpocket} wbActorTemplateUseBaseData,
{0x20000000 Is Ghost} nil,
{0x40000000 No Rotating To Head-track} wbActorTemplateUseModelAnimation,
{0x80000000 Invulnerable} nil
])),
{04} wbInteger('Fatigue', itU16, nil, cpNormal, False, wbActorTemplateUseStats),
{06} wbInteger('Barter gold', itU16, nil, cpNormal, False, wbActorTemplateUseAIData),
{08} wbUnion('Level', wbCreaLevelDecider, [
wbInteger('Level', itS16, nil, cpNormal, False, wbActorTemplateUseStats),
wbInteger('Level Mult', itS16, wbDiv(1000), cpNormal, False, wbActorTemplateUseStats)
], cpNormal, False, wbActorTemplateUseStats),
{10} wbInteger('Calc min', itU16, nil, cpNormal, False, wbActorTemplateUseStats),
{12} wbInteger('Calc max', itU16, nil, cpNormal, False, wbActorTemplateUseStats),
{14} wbInteger('Speed Multiplier', itU16, nil, cpNormal, False, wbActorTemplateUseStats),
{16} wbFloat('Karma (Alignment)', cpNormal, False, 1, -1, wbActorTemplateUseTraits),
{20} wbInteger('Disposition Base', itS16, nil, cpNormal, False, wbActorTemplateUseTraits),
{22} wbInteger('Template Flags', itU16, wbTemplateFlags)
], cpNormal, True),
wbRArrayS('Factions',
wbStructSK(SNAM, [0], 'Faction', [
wbFormIDCk('Faction', [FACT]),
wbInteger('Rank', itU8),
wbByteArray('Unused', 3)
]),
cpNormal, False, nil, nil, wbActorTemplateUseFactions),
wbFormIDCk(INAM, 'Death item', [LVLI], False, cpNormal, False, wbActorTemplateUseTraits),
wbFormIDCk(VTCK, 'Voice', [VTYP], False, cpNormal, False, wbActorTemplateUseTraits),
wbFormIDCk(TPLT, 'Template', [CREA, LVLC]),
wbDESTActor,
wbSCRIActor,
wbRArrayS('Items', wbCNTO, cpNormal, False, nil, nil, wbActorTemplateUseInventory),
wbAIDT,
wbRArray('Packages', wbFormIDCk(PKID, 'Package', [PACK]), cpNormal, False, nil, nil, wbActorTemplateUseAIPackages),
wbArrayS(KFFZ, 'Animations', wbStringLC('Animation'), 0, cpNormal, False, nil, nil, wbActorTemplateUseModelAnimation),
wbStruct(DATA, '', [
{00} wbInteger('Type', itU8, wbCreatureTypeEnum, cpNormal, False, wbActorTemplateUseTraits),
{01} wbInteger('Combat Skill', itU8, nil, cpNormal, False, wbActorTemplateUseStats),
{02} wbInteger('Magic Skill', itU8, nil, cpNormal, False, wbActorTemplateUseStats),
{03} wbInteger('Stealth Skill', itU8, nil, cpNormal, False, wbActorTemplateUseStats),
{04} wbInteger('Health', itS16, nil, cpNormal, False, wbActorTemplateUseStats),
{06} wbByteArray('Unused', 2),
{08} wbInteger('Damage', itS16, nil, cpNormal, False, wbActorTemplateUseStats),
{10} wbArray('Attributes', wbInteger('Attribute', itU8), [
'Strength',
'Perception',
'Endurance',
'Charisma',
'Intelligence',
'Agility',
'Luck'
], cpNormal, False, wbActorTemplateUseStats)
], cpNormal, True),
wbInteger(RNAM, 'Attack reach', itU8, nil, cpNormal, True, False, wbActorTemplateUseTraits),
wbFormIDCk(ZNAM, 'Combat Style', [CSTY], False, cpNormal, False, wbActorTemplateUseTraits),
wbFormIDCk(PNAM, 'Body Part Data', [BPTD], False, cpNormal, True, wbActorTemplateUseModelAnimation),
wbFloat(TNAM, 'Turning Speed', cpNormal, True, 1, -1, wbActorTemplateUseStats),
wbFloat(BNAM, 'Base Scale', cpNormal, True, 1, -1, wbActorTemplateUseStats),
wbFloat(WNAM, 'Foot Weight', cpNormal, True, 1, -1, wbActorTemplateUseStats),
wbInteger(NAM4, 'Impact Material Type', itU32, wbImpactMaterialTypeEnum, cpNormal, True, False, wbActorTemplateUseModelAnimation),
wbInteger(NAM5, 'Sound Level', itU32, wbSoundLevelEnum, cpNormal, True, False, wbActorTemplateUseModelAnimation),
wbFormIDCk(CSCR, 'Inherits Sounds from', [CREA], False, cpNormal, False, wbActorTemplateUseModelAnimation),
wbCSDTs,
wbFormIDCk(CNAM, 'Impact Dataset', [IPDS], False, cpNormal, False, wbActorTemplateUseModelAnimation),
wbFormIDCk(LNAM, 'Melee Weapon List', [FLST], False, cpNormal, False, wbActorTemplateUseTraits)
], True);
end;
procedure DefineFO3d;
begin
wbRecord(CSTY, 'Combat Style', [
wbEDIDReq,
wbStruct(CSTD, 'Advanced - Standard', [
{000}wbInteger('Maneuver Decision - Dodge % Chance', itU8),
{001}wbInteger('Maneuver Decision - Left/Right % Chance', itU8),
{002}wbByteArray('Unused', 2),
{004}wbFloat('Maneuver Decision - Dodge L/R Timer (min)'),
{008}wbFloat('Maneuver Decision - Dodge L/R Timer (max)'),
{012}wbFloat('Maneuver Decision - Dodge Forward Timer (min)'),
{016}wbFloat('Maneuver Decision - Dodge Forward Timer (max)'),
{020}wbFloat('Maneuver Decision - Dodge Back Timer Min'),
{024}wbFloat('Maneuver Decision - Dodge Back Timer Max'),
{028}wbFloat('Maneuver Decision - Idle Timer min'),
{032}wbFloat('Maneuver Decision - Idle Timer max'),
{036}wbInteger('Melee Decision - Block % Chance', itU8),
{037}wbInteger('Melee Decision - Attack % Chance', itU8),
{038}wbByteArray('Unused', 2),
{040}wbFloat('Melee Decision - Recoil/Stagger Bonus to Attack'),
{044}wbFloat('Melee Decision - Unconscious Bonus to Attack'),
{048}wbFloat('Melee Decision - Hand-To-Hand Bonus to Attack'),
{052}wbInteger('Melee Decision - Power Attacks - Power Attack % Chance', itU8),
{053}wbByteArray('Unused', 3),
{056}wbFloat('Melee Decision - Power Attacks - Recoil/Stagger Bonus to Power'),
{060}wbFloat('Melee Decision - Power Attacks - Unconscious Bonus to Power Attack'),
{064}wbInteger('Melee Decision - Power Attacks - Normal', itU8),
{065}wbInteger('Melee Decision - Power Attacks - Forward', itU8),
{066}wbInteger('Melee Decision - Power Attacks - Back', itU8),
{067}wbInteger('Melee Decision - Power Attacks - Left', itU8),
{068}wbInteger('Melee Decision - Power Attacks - Right', itU8),
{069}wbByteArray('Unused', 3),
{072}wbFloat('Melee Decision - Hold Timer (min)'),
{076}wbFloat('Melee Decision - Hold Timer (max)'),
{080}wbInteger('Flags', itU16, wbFlags([
'Choose Attack using % Chance',
'Melee Alert OK',
'Flee Based on Personal Survival',
'',
'Ignore Threats',
'Ignore Damaging Self',
'Ignore Damaging Group',
'Ignore Damaging Spectators',
'Cannot Use Stealthboy'
])),
{082}wbByteArray('Unused', 2),
{085}wbInteger('Maneuver Decision - Acrobatic Dodge % Chance', itU8),
{085}wbInteger('Melee Decision - Power Attacks - Rushing Attack % Chance', itU8),
{086}wbByteArray('Unused', 2),
{088}wbFloat('Melee Decision - Power Attacks - Rushing Attack Distance Mult')
], cpNormal, True),
wbStruct(CSAD, 'Advanced - Advanced', [
wbFloat('Dodge Fatigue Mod Mult'),
wbFloat('Dodge Fatigue Mod Base'),
wbFloat('Encumb. Speed Mod Base'),
wbFloat('Encumb. Speed Mod Mult'),
wbFloat('Dodge While Under Attack Mult'),
wbFloat('Dodge Not Under Attack Mult'),
wbFloat('Dodge Back While Under Attack Mult'),
wbFloat('Dodge Back Not Under Attack Mult'),
wbFloat('Dodge Forward While Attacking Mult'),
wbFloat('Dodge Forward Not Attacking Mult'),
wbFloat('Block Skill Modifier Mult'),
wbFloat('Block Skill Modifier Base'),
wbFloat('Block While Under Attack Mult'),
wbFloat('Block Not Under Attack Mult'),
wbFloat('Attack Skill Modifier Mult'),
wbFloat('Attack Skill Modifier Base'),
wbFloat('Attack While Under Attack Mult'),
wbFloat('Attack Not Under Attack Mult'),
wbFloat('Attack During Block Mult'),
wbFloat('Power Att. Fatigue Mod Base'),
wbFloat('Power Att. Fatigue Mod Mult')
], cpNormal, True),
wbStruct(CSSD, 'Simple', [
{00} wbFloat('Cover Search Radius'),
{04} wbFloat('Take Cover Chance'),
{08} wbFloat('Wait Timer (min)'),
{12} wbFloat('Wait Timer (max)'),
{16} wbFloat('Wait to Fire Timer (min)'),
{20} wbFloat('Wait to Fire Timer (max)'),
{24} wbFloat('Fire Timer (min)'),
{28} wbFloat('Fire Timer (max)'),
{32} wbFloat('Ranged Weapon Range Mult (min)'),
{36} wbByteArray('Unused', 4),
{40} wbInteger('Weapon Restrictions', itU32, wbEnum([
'None',
'Melee Only',
'Ranged Only'
])),
{44} wbFloat('Ranged Weapon Range Mult (max)'),
{48} wbFloat('Max Targeting FOV'),
{52} wbFloat('Combat Radius'),
{56} wbFloat('Semi-Auto Firing Delay Mult (min)'),
{60} wbFloat('Semi-Auto Firing Delay Mult (max)')
], cpNormal, True)
]);
wbRecord(DIAL, 'Dialog Topic', [
wbEDIDReq,
wbRArrayS('Quests', wbFormIDCkNoReach(QSTI, 'Quest', [QUST], False, cpBenign)),
wbRArrayS('Quests?', wbFormIDCkNoReach(QSTR, 'Quest?', [QUST], False, cpBenign)),
wbFULL,
wbFloat(PNAM, 'Priority', cpNormal, True, 1, -1, nil, nil, 50.0),
wbStruct(DATA, '', [
wbInteger('Type', itU8, wbEnum([
{0} 'Topic',
{1} 'Conversation',
{2} 'Combat',
{3} 'Persuasion',
{4} 'Detection',
{5} 'Service',
{6} 'Miscellaneous',
{7} 'Radio'
])),
wbInteger('Flags', itU8, wbFlags([
'Rumors',
'Top-level'
]))
], cpNormal, True, nil, 1)
], True);
wbRecord(DOOR, 'Door', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODLReq,
wbSCRI,
wbDEST,
wbFormIDCk(SNAM, 'Sound - Open', [SOUN]),
wbFormIDCk(ANAM, 'Sound - Close', [SOUN]),
wbFormIDCk(BNAM, 'Sound - Looping', [SOUN]),
wbInteger(FNAM, 'Flags', itU8, wbFlags([
'',
'Automatic Door',
'Hidden',
'Minimal Use',
'Sliding Door'
]), cpNormal, True)
]);
wbBlendModeEnum := wbEnum([
'',
'Zero',
'One',
'Source Color',
'Source Inverse Color',
'Source Alpha',
'Source Inverted Alpha',
'Dest Alpha',
'Dest Inverted Alpha',
'Dest Color',
'Dest Inverse Color',
'Source Alpha SAT'
]);
wbBlendOpEnum := wbEnum([
'',
'Add',
'Subtract',
'Reverse Subtract',
'Minimum',
'Maximum'
]);
wbZTestFuncEnum := wbEnum([
'',
'',
'',
'Equal To',
'Normal',
'Greater Than',
'',
'Greater Than or Equal Than',
'Always Show'
]);
wbRecord(EFSH, 'Effect Shader', [
wbEDID,
wbString(ICON, 'Fill Texture'),
wbString(ICO2, 'Particle Shader Texture'),
wbString(NAM7, 'Holes Texture'),
wbStruct(DATA, '', [
wbInteger('Flags', itU8, wbFlags([
{0} 'No Membrane Shader',
{1} '',
{2} '',
{3} 'No Particle Shader',
{4} 'Edge Effect - Inverse',
{5} 'Membrane Shader - Affect Skin Only'
])),
wbByteArray('Unused', 3),
wbInteger('Membrane Shader - Source Blend Mode', itU32, wbBlendModeEnum),
wbInteger('Membrane Shader - Blend Operation', itU32, wbBlendOpEnum),
wbInteger('Membrane Shader - Z Test Function', itU32, wbZTestFuncEnum),
wbStruct('Fill/Texture Effect - Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbFloat('Fill/Texture Effect - Alpha Fade In Time'),
wbFloat('Fill/Texture Effect - Full Alpha Time'),
wbFloat('Fill/Texture Effect - Alpha Fade Out Time'),
wbFloat('Fill/Texture Effect - Presistent Alpha Ratio'),
wbFloat('Fill/Texture Effect - Alpha Pulse Amplitude'),
wbFloat('Fill/Texture Effect - Alpha Pulse Frequency'),
wbFloat('Fill/Texture Effect - Texture Animation Speed (U)'),
wbFloat('Fill/Texture Effect - Texture Animation Speed (V)'),
wbFloat('Edge Effect - Fall Off'),
wbStruct('Edge Effect - Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbFloat('Edge Effect - Alpha Fade In Time'),
wbFloat('Edge Effect - Full Alpha Time'),
wbFloat('Edge Effect - Alpha Fade Out Time'),
wbFloat('Edge Effect - Persistent Alpha Ratio'),
wbFloat('Edge Effect - Alpha Pulse Amplitude'),
wbFloat('Edge Effect - Alpha Pusle Frequence'),
wbFloat('Fill/Texture Effect - Full Alpha Ratio'),
wbFloat('Edge Effect - Full Alpha Ratio'),
wbInteger('Membrane Shader - Dest Blend Mode', itU32, wbBlendModeEnum),
wbInteger('Particle Shader - Source Blend Mode', itU32, wbBlendModeEnum),
wbInteger('Particle Shader - Blend Operation', itU32, wbBlendOpEnum),
wbInteger('Particle Shader - Z Test Function', itU32, wbZTestFuncEnum),
wbInteger('Particle Shader - Dest Blend Mode', itU32, wbBlendModeEnum),
wbFloat('Particle Shader - Particle Birth Ramp Up Time'),
wbFloat('Particle Shader - Full Particle Birth Time'),
wbFloat('Particle Shader - Particle Birth Ramp Down Time'),
wbFloat('Particle Shader - Full Particle Birth Ratio'),
wbFloat('Particle Shader - Persistant Particle Birth Ratio'),
wbFloat('Particle Shader - Particle Lifetime'),
wbFloat('Particle Shader - Particle Lifetime +/-'),
wbFloat('Particle Shader - Initial Speed Along Normal'),
wbFloat('Particle Shader - Acceleration Along Normal'),
wbFloat('Particle Shader - Initial Velocity #1'),
wbFloat('Particle Shader - Initial Velocity #2'),
wbFloat('Particle Shader - Initial Velocity #3'),
wbFloat('Particle Shader - Acceleration #1'),
wbFloat('Particle Shader - Acceleration #2'),
wbFloat('Particle Shader - Acceleration #3'),
wbFloat('Particle Shader - Scale Key 1'),
wbFloat('Particle Shader - Scale Key 2'),
wbFloat('Particle Shader - Scale Key 1 Time'),
wbFloat('Particle Shader - Scale Key 2 Time'),
wbStruct('Color Key 1 - Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Color Key 2 - Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Color Key 3 - Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbFloat('Color Key 1 - Color Alpha'),
wbFloat('Color Key 2 - Color Alpha'),
wbFloat('Color Key 3 - Color Alpha'),
wbFloat('Color Key 1 - Color Key Time'),
wbFloat('Color Key 2 - Color Key Time'),
wbFloat('Color Key 3 - Color Key Time'),
wbFloat('Particle Shader - Initial Speed Along Normal +/-'),
wbFloat('Particle Shader - Initial Rotation (deg)'),
wbFloat('Particle Shader - Initial Rotation (deg) +/-'),
wbFloat('Particle Shader - Rotation Speed (deg/sec)'),
wbFloat('Particle Shader - Rotation Speed (deg/sec) +/-'),
wbFormIDCk('Addon Models', [DEBR, NULL]),
wbFloat('Holes - Start Time'),
wbFloat('Holes - End Time'),
wbFloat('Holes - Start Val'),
wbFloat('Holes - End Val'),
wbFloat('Edge Width (alpha units)'),
wbStruct('Edge Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbFloat('Explosion Wind Speed'),
wbInteger('Texture Count U', itU32),
wbInteger('Texture Count V', itU32),
wbFloat('Addon Models - Fade In Time'),
wbFloat('Addon Models - Fade Out Time'),
wbFloat('Addon Models - Scale Start'),
wbFloat('Addon Models - Scale End'),
wbFloat('Addon Models - Scale In Time'),
wbFloat('Addon Models - Scale Out Time')
], cpNormal, True, nil, 57)
], False, nil, cpNormal, False, wbEFSHAfterLoad);
wbRecord(ENCH, 'Object Effect', [
wbEDIDReq,
wbFULL,
wbStruct(ENIT, 'Effect Data', [
wbInteger('Type', itU32, wbEnum([
{0} '',
{1} '',
{2} 'Weapon',
{3} 'Apparel'
])),
wbByteArray('Unused', 4),
wbByteArray('Unused', 4),
wbInteger('Flags', itU8, wbFlags([
'No Auto-Calc',
'',
'Hide Effect'
])),
wbByteArray('Unused', 3)
], cpNormal, True),
wbEffectsReq
]);
wbRecord(EYES, 'Eyes', [
wbEDIDReq,
wbFULLReq,
wbString(ICON, 'Texture', 0{, cpNormal, True??}),
wbInteger(DATA, 'Flags', itU8, wbFlags([
'Playable',
'Not Male',
'Not Female'
]), cpNormal, True)
]);
wbXNAM :=
wbStructSK(XNAM, [0], 'Relation', [
wbFormIDCkNoReach('Faction', [FACT, RACE]),
wbInteger('Modifier', itS32),
wbInteger('Group Combat Reaction', itU32, wbEnum([
'Neutral',
'Enemy',
'Ally',
'Friend'
]))
]);
wbXNAMs := wbRArrayS('Relations', wbXNAM);
wbRecord(FACT, 'Faction', [
wbEDIDReq,
wbFULL,
wbXNAMs,
wbStruct(DATA, '', [
wbInteger('Flags 1', itU8, wbFlags([
'Hidden from PC',
'Evil',
'Special Combat'
])),
wbInteger('Flags 2', itU8, wbFlags([
'Track Crime',
'Allow Sell'
])),
wbByteArray('Unused', 2)
], cpNormal, True, nil, 1),
wbFloat(CNAM, 'Unused'),
wbRStructsSK('Ranks', 'Rank', [0], [
wbInteger(RNAM, 'Rank#', itS32),
wbString(MNAM, 'Male', 0, cpTranslate),
wbString(FNAM, 'Female', 0, cpTranslate),
wbString(INAM, 'Insignia (Unused)')
], [])
], False, nil, cpNormal, False, wbFACTAfterLoad);
wbRecord(FURN, 'Furniture', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODLReq,
wbSCRI,
wbDEST,
wbByteArray(MNAM, 'Marker Flags', 0, cpNormal, True)
]);
wbRecord(GLOB, 'Global', [
wbEDIDReq,
wbInteger(FNAM, 'Type', itU8, wbGLOBFNAM, nil, cpNormal, True),
wbFloat(FLTV, 'Value', cpNormal, True)
]);
wbRecord(GMST, 'Game Setting', [
wbString(EDID, 'Editor ID', 0, cpCritical, True, nil, wbGMSTEDIDAfterSet),
wbUnion(DATA, 'Value', wbGMSTUnionDecider, [
wbString('', 0, cpTranslate),
wbInteger('', itS32),
wbFloat('')
], cpNormal, True)
]);
wbDODT := wbStruct(DODT, 'Decal Data', [
wbFloat('Min Width'),
wbFloat('Max Width'),
wbFloat('Min Height'),
wbFloat('Max Height'),
wbFloat('Depth'),
wbFloat('Shininess'),
wbStruct('Parallax', [
wbFloat('Scale'),
wbInteger('Passes', itU8)
]),
wbInteger('Flags', itU8, wbFlags([
'Parallax',
'Alpha - Blending',
'Alpha - Testing'
], True)),
wbByteArray('Unused', 2),
wbStruct('Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]);
wbRecord(TXST, 'Texture Set', [
wbEDIDReq,
wbOBNDReq,
wbRStruct('Textures (RGB/A)', [
wbString(TX00,'Base Image / Transparency'),
wbString(TX01,'Normal Map / Specular'),
wbString(TX02,'Environment Map Mask / ?'),
wbString(TX03,'Glow Map / Unused'),
wbString(TX04,'Parallax Map / Unused'),
wbString(TX05,'Environment Map / Unused')
], []),
wbDODT,
wbInteger(DNAM, 'Flags', itU16, wbFlags([
'No Specular Map'
]), cpNormal, True)
]);
wbRecord(MICN, 'Menu Icon', [
wbEDIDReq,
wbICONReq
]);
wbRecord(HDPT, 'Head Part', [
wbEDIDReq,
wbFULLReq,
wbMODL,
wbInteger(DATA, 'Flags', itU8, wbFlags([
'Playable'
]), cpNormal, True),
wbRArrayS('Extra Parts',
wbFormIDCk(HNAM, 'Part', [HDPT])
)
]);
wbRecord(ASPC, 'Acoustic Space', [
wbEDIDReq,
wbOBNDReq,
wbFormIDCk(SNAM, 'Sound - Looping', [SOUN]),
wbFormIDCk(RDAT, 'Use Sound from Region (Interiors Only)', [REGN]),
wbInteger(ANAM, 'Environment Type', itU32, wbEnum([
'None',
'Default',
'Generic',
'Padded Cell',
'Room',
'Bathroom',
'Livingroom',
'Stone Room',
'Auditorium',
'Concerthall',
'Cave',
'Arena',
'Hangar',
'Carpeted Hallway',
'Hallway',
'Stone Corridor',
'Alley',
'Forest',
'City',
'Mountains',
'Quarry',
'Plain',
'Parkinglot',
'Sewerpipe',
'Underwater',
'Small Room',
'Medium Room',
'Large Room',
'Medium Hall',
'Large Hall',
'Plate'
]), cpNormal, True)
]);
wbRecord(TACT, 'Talking Activator', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODLReq,
wbSCRI,
wbDEST,
wbFormIDCk(SNAM, 'Sound', [SOUN]),
wbFormIDCk(VNAM, 'Voice Type', [VTYP])
]);
wbRecord(SCPT, 'Script', [
wbEDIDReq,
wbSCHRReq,
wbByteArray(SCDA, 'Compiled Script'),
wbStringScript(SCTX, 'Script Source', 0, cpNormal{, True}),
wbRArrayS('Local Variables', wbRStructSK([0], 'Local Variable', [
wbSLSD,
wbString(SCVR, 'Name', 0, cpCritical, True)
], [])),
wbSCROs
]);
wbRecord(TERM, 'Terminal', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbSCRI,
wbDEST,
wbDESCReq,
wbFormIDCk(SNAM, 'Sound - Looping', [SOUN]),
wbFormIDCk(PNAM, 'Password Note', [NOTE]),
wbStruct(DNAM, '', [
wbInteger('Base Hacking Difficulty', itU8, wbEnum([
'Very Easy',
'Easy',
'Average',
'Hard',
'Very Hard',
'Requires Key'
])),
wbInteger('Flags', itU8, wbFlags([
'Leveled',
'Unlocked',
'Alternate Colors',
'Hide Welcome Text when displaying Image'
])),
wbInteger('ServerType', itU8, wbEnum([
'-Server 1-',
'-Server 2-',
'-Server 3-',
'-Server 4-',
'-Server 5-',
'-Server 6-',
'-Server 7-',
'-Server 8-',
'-Server 9-',
'-Server 10-'
])),
wbByteArray('Unused', 1)
], cpNormal, True),
wbRArray('Menu Items',
wbRStruct('Menu Item', [
wbString(ITXT, 'Item Text'),
wbString(RNAM, 'Result Text', 0, cpNormal, True),
wbInteger(ANAM, 'Flags', itU8, wbFlags([
'Add Note',
'Force Redraw'
]), cpNormal, True),
wbFormIDCk(INAM, 'Display Note', [NOTE]),
wbFormIDCk(TNAM, 'Sub Menu', [TERM]),
wbEmbeddedScriptReq,
wbCTDAs
], [])
)
]);
wbRecord(SCOL, 'Static Collection', [
wbEDIDReq,
wbOBNDReq,
wbMODLReq,
wbRStructsSK('Parts', 'Part', [0], [
wbFormIDCk(ONAM, 'Static', [STAT]),
wbArrayS(DATA, 'Placements', wbStruct('Placement', [
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation', [
wbFloat('X', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Y', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Z', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize)
]),
wbFloat('Scale')
]), 0, cpNormal, True)
], [], cpNormal, True)
]);
wbRecord(MSTT, 'Moveable Static', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODLReq,
wbDEST,
wbByteArray(DATA, 'Unknown', 1, cpNormal, True),
wbFormIDCk(SNAM, 'Sound', [SOUN])
]);
wbRecord(PWAT, 'Placeable Water', [
wbEDIDReq,
wbOBNDReq,
wbMODLReq,
wbStruct(DNAM, '', [
wbInteger('Flags', itU32, wbFlags([
{0x00000001}'Reflects',
{0x00000002}'Reflects - Actors',
{0x00000004}'Reflects - Land',
{0x00000008}'Reflects - LOD Land',
{0x00000010}'Reflects - LOD Buildings',
{0x00000020}'Reflects - Trees',
{0x00000040}'Reflects - Sky',
{0x00000080}'Reflects - Dynamic Objects',
{0x00000100}'Reflects - Dead Bodies',
{0x00000200}'Refracts',
{0x00000400}'Refracts - Actors',
{0x00000800}'Refracts - Land',
{0x00001000}'',
{0x00002000}'',
{0x00004000}'',
{0x00008000}'',
{0x00010000}'Refracts - Dynamic Objects',
{0x00020000}'Refracts - Dead Bodies',
{0x00040000}'Silhouette Reflections',
{0x00080000}'',
{0x00100000}'',
{0x00200000}'',
{0x00400000}'',
{0x00800000}'',
{0x01000000}'',
{0x02000000}'',
{0x03000000}'',
{0x08000000}'',
{0x10000000}'Depth',
{0x20000000}'Object Texture Coordinates',
{0x40000000}'',
{0x80000000}'No Underwater Fog'
])),
wbFormIDCk('Water', [WATR])
], cpNormal, True)
]);
wbRecord(IDLM, 'Idle Marker', [
wbEDIDReq,
wbOBNDReq,
wbInteger(IDLF, 'Flags', itU8, wbFlags([
'Run in Sequence',
'',
'Do Once'
]), cpNormal, True),
wbStruct(IDLC, '', [
wbInteger('Animation Count', itU8),
wbByteArray('Unused', 3)
], cpNormal, True, nil, 1),
wbFloat(IDLT, 'Idle Timer Setting', cpNormal, True),
wbArray(IDLA, 'Animations', wbFormIDCk('Animation', [IDLE, NULL]), 0, nil, wbIDLAsAfterSet, cpNormal, True) // NULL looks valid if IDLS\Animation Count is 0
], False, nil, cpNormal, False, nil, wbAnimationsAfterSet);
wbRecord(NOTE, 'Note', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbYNAM,
wbZNAM,
wbInteger(DATA, 'Type', itU8, wbEnum([
'Sound',
'Text',
'Image',
'Voice'
]), cpNormal, True),
wbRArrayS('Quests',
wbFormIDCkNoReach(ONAM, 'Quest', [QUST])
),
wbString(XNAM, 'Texture'),
wbUnion(TNAM, 'Text / Topic', wbNOTETNAMDecide, [
wbString('Text'),
wbFormIDCk('Topic', [DIAL])
]),
wbUnion(SNAM, 'Sound / NPC', wbNOTESNAMDecide, [
wbFormIDCk('Sound', [SOUN]),
wbFormIDCk('NPC', [NPC_])
])
]);
end;
procedure DefineFO3e;
begin
wbRecord(PROJ, 'Projectile', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODLReq,
wbDEST,
wbStruct(DATA, 'Data', [
{00} wbInteger('Flags', itU16, wbFlags([
'Hitscan',
'Explosion',
'Alt. Trigger',
'Muzzle Flash',
'',
'Can Be Disabled',
'Can Be Picked Up',
'Supersonic',
'Pins Limbs',
'Pass Through Small Transparent'
])),
{00} wbInteger('Type', itU16, wbEnum([
{00} '',
{01} 'Missile',
{02} 'Lobber',
{03} '',
{04} 'Beam',
{05} '',
{06} '',
{07} '',
{08} 'Flame'
])),
{04} wbFloat('Gravity'),
{08} wbFloat('Speed'),
{12} wbFloat('Range'),
{16} wbFormIDCk('Light', [LIGH, NULL]),
{20} wbFormIDCk('Muzzle Flash - Light', [LIGH, NULL]),
{24} wbFloat('Tracer Chance'),
{28} wbFloat('Explosion - Alt. Trigger - Proximity'),
{32} wbFloat('Explosion - Alt. Trigger - Timer'),
{36} wbFormIDCk('Explosion', [EXPL, NULL]),
{40} wbFormIDCk('Sound', [SOUN, NULL]),
{44} wbFloat('Muzzle Flash - Duration'),
{48} wbFloat('Fade Duration'),
{52} wbFloat('Impact Force'),
{56} wbFormIDCk('Sound - Countdown', [SOUN, NULL]),
{60} wbFormIDCk('Sound - Disable', [SOUN, NULL]),
{64} wbFormIDCk('Default Weapon Source', [WEAP, NULL])
], cpNormal, True),
wbRStructSK([0], 'Muzzle Flash Model', [
wbString(NAM1, 'Model Filename'),
wbByteArray(NAM2, 'Texture Files Hashes', 0, cpIgnore)
], [], cpNormal, True),
wbInteger(VNAM, 'Sound Level', itU32, wbSoundLevelEnum, cpNormal, True)
]);
wbRecord(NAVI, 'Navigation Mesh Info Map', [
wbEDID,
wbInteger(NVER, 'Version', itU32),
wbRArray('Navigation Map Infos',
wbStruct(NVMI, 'Navigation Map Info', [
wbByteArray('Unknown', 4),
wbFormIDCk('Navigation Mesh', [NAVM]),
wbFormIDCk('Location', [CELL, WRLD]),
wbStruct('Grid', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
]),
wbUnknown
{ wbUnion('Data', wbNAVINVMIDecider, [
wbStruct('Data', [
wbUnknown
]),
wbStruct('Data', [
wbArray('Unknown', wbFloat('Unknown'), 3),
wbByteArray('Unknown', 4)
]),
wbStruct('Data', [
wbArray('Unknown', wbArray('Unknown', wbFloat('Unknown'), 3), 3),
wbInteger('Count 1', itU16),
wbInteger('Count 2', itU16),
wbArray('Unknown', wbArray('Unknown', wbFloat('Unknown'), 3), [], wbNAVINAVMGetCount1),
wbUnknown
]),
wbStruct('Data', [
wbUnknown
])
])}
])
),
wbRArray('Unknown',
wbStruct(NVCI, 'Unknown', [
wbFormIDCk('Unknown', [NAVM]),
wbArray('Unknown', wbFormIDCk('Unknown', [NAVM]), -1),
wbArray('Unknown', wbFormIDCk('Unknown', [NAVM]), -1),
wbArray('Doors', wbFormIDCk('Door', [REFR]), -1)
])
)
]);
if wbSimpleRecords then begin
wbRecord(NAVM, 'Navigation Mesh', [
wbEDID,
wbInteger(NVER, 'Version', itU32),
wbStruct(DATA, '', [
wbFormIDCk('Cell', [CELL]),
wbInteger('Vertex Count', itU32),
wbInteger('Triangle Count', itU32),
wbInteger('External Connections Count', itU32),
wbInteger('NVCA Count', itU32),
wbInteger('Doors Count', itU32)
]),
wbByteArray(NVVX, 'Vertices'),
wbByteArray(NVTR, 'Triangles'),
wbByteArray(NVCA, 'Unknown'),
wbArray(NVDP, 'Doors', wbStruct('Door', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Triangle', itU16),
wbByteArray('Unused', 2)
])),
wbByteArray(NVGD, 'Unknown'),
wbArray(NVEX, 'External Connections', wbStruct('Connection', [
wbByteArray('Unknown', 4),
wbFormIDCk('Navigation Mesh', [NAVM], False, cpNormal),
wbInteger('Triangle', itU16, nil, cpNormal)
]))
], False, wbNAVMAddInfo);
end else begin
wbRecord(NAVM, 'Navigation Mesh', [
wbEDID,
wbInteger(NVER, 'Version', itU32),
wbStruct(DATA, '', [
wbFormIDCk('Cell', [CELL]),
wbInteger('Vertex Count', itU32),
wbInteger('Triangle Count', itU32),
wbInteger('External Connections Count', itU32),
wbInteger('NVCA Count', itU32),
wbInteger('Doors Count', itU32) // as of version = 5 (earliest NavMesh version I saw (Fallout3 1.7) is already 11)
]),
wbArray(NVVX, 'Vertices', wbStruct('Vertex', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
])),
wbArray(NVTR, 'Triangles', wbStruct('Triangle', [
wbArray('Vertices', wbInteger('Vertex', itS16), 3),
wbArray('Edges', wbInteger('Triangle', itS16, wbNVTREdgeToStr, wbNVTREdgeToInt), [
'0 <-> 1',
'1 <-> 2',
'2 <-> 0'
]),
wbInteger('Flags', itU32, wbFlags([
'Triangle #0 Is External',
'Triangle #1 Is External',
'Triangle #2 Is External',
'Unknown 4',
'Unknown 5',
'Unknown 6',
'Unknown 7',
'Unknown 8',
'Unknown 9',
'Unknown 10',
'Unknown 11',
'Unknown 12',
'Unknown 13',
'Unknown 14',
'Unknown 15',
'Unknown 16',
'Unknown 17',
'Unknown 18',
'Unknown 19',
'Unknown 20',
'Unknown 21',
'Unknown 22',
'Unknown 23',
'Unknown 24',
'Unknown 25',
'Unknown 26',
'Unknown 27',
'Unknown 28',
'Unknown 29',
'Unknown 30',
'Unknown 31',
'Unknown 32'
]))
])),
wbArray(NVCA, 'Unknown', wbInteger('Unknown', itS16)),
wbArray(NVDP, 'Doors', wbStruct('Door', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Triangle', itU16),
wbByteArray('Unused', 2)
])),
wbStruct(NVGD, 'Unknown', [
wbByteArray('Unknown', 4),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbArray('Unknown', wbArray('Unknown', wbInteger('Unknown', itU16), -2))
]),
wbArray(NVEX, 'External Connections', wbStruct('Connection', [
wbByteArray('Unknown', 4),
wbFormIDCk('Navigation Mesh', [NAVM], False, cpNormal),
wbInteger('Triangle', itU16, nil, cpNormal)
]))
], False, wbNAVMAddInfo);
end;
wbRecord(PGRE, 'Placed Grenade', [
wbEDID,
wbFormIDCk(NAME, 'Base', [PROJ], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbXRGD,
wbXRGB,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], []),
{--- Ownership ---}
wbRStruct('Ownership', [
wbXOWN,
wbInteger(XRNK, 'Faction rank', itS32)
], [XCMT, XCMO]),
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbFloat(XHLP, 'Health'),
{--- Reflected By / Refracted By ---}
wbRArrayS('Reflected/Refracted By',
wbStructSK(XPWR, [0], 'Water', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Type', itU32, wbFlags([
'Reflection',
'Refraction'
]))
])
),
{--- Decals ---}
wbRArrayS('Linked Decals',
wbStructSK(XDCR, [0], 'Decal', [
wbFormIDCk('Reference', [REFR]),
wbUnknown
])
),
{--- Linked Ref ---}
wbFormIDCk(XLKR, 'Linked Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbStruct(XCLP, 'Linked Reference Color', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbFloat('Delay')
])
)
], []),
{--- Enable Parent ---}
wbXESP,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Flags ---}
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot
], True, wbPlacedAddInfo);
wbRecord(PMIS, 'Placed Missile', [
wbEDID,
wbFormIDCk(NAME, 'Base', [PROJ], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbXRGD,
wbXRGB,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], []),
{--- Ownership ---}
wbRStruct('Ownership', [
wbXOWN,
wbInteger(XRNK, 'Faction rank', itS32)
], [XCMT, XCMO]),
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbFloat(XHLP, 'Health'),
{--- Reflected By / Refracted By ---}
wbRArrayS('Reflected/Refracted By',
wbStructSK(XPWR, [0], 'Water', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Type', itU32, wbFlags([
'Reflection',
'Refraction'
]))
])
),
{--- Decals ---}
wbRArrayS('Linked Decals',
wbStructSK(XDCR, [0], 'Decal', [
wbFormIDCk('Reference', [REFR]),
wbUnknown
])
),
{--- Linked Ref ---}
wbFormIDCk(XLKR, 'Linked Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbStruct(XCLP, 'Linked Reference Color', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbFloat('Delay')
])
)
], []),
{--- Enable Parent ---}
wbXESP,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Flags ---}
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot
], True, wbPlacedAddInfo);
wbRecord(PBEA, 'Placed Beam', [
wbEDID,
wbFormIDCk(NAME, 'Base', [PROJ], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbXRGD,
wbXRGB,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], []),
{--- Ownership ---}
wbRStruct('Ownership', [
wbXOWN,
wbInteger(XRNK, 'Faction rank', itS32)
], [XCMT, XCMO]),
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbFloat(XHLP, 'Health'),
{--- Reflected By / Refracted By ---}
wbRArrayS('Reflected/Refracted By',
wbStructSK(XPWR, [0], 'Water', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Type', itU32, wbFlags([
'Reflection',
'Refraction'
]))
])
),
{--- Decals ---}
wbRArrayS('Linked Decals',
wbStructSK(XDCR, [0], 'Decal', [
wbFormIDCk('Reference', [REFR]),
wbUnknown
])
),
{--- Linked Ref ---}
wbFormIDCk(XLKR, 'Linked Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbStruct(XCLP, 'Linked Reference Color', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbFloat('Delay')
])
)
], []),
{--- Enable Parent ---}
wbXESP,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Flags ---}
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot
], True, wbPlacedAddInfo);
wbRecord(EXPL, 'Explosion', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbEITM,
wbFormIDCk(MNAM, 'Image Space Modifier', [IMAD]),
wbStruct(DATA, 'Data', [
{00} wbFloat('Force'),
{04} wbFloat('Damage'),
{08} wbFloat('Radius'),
{12} wbFormIDCk('Light', [LIGH, NULL]),
{16} wbFormIDCk('Sound 1', [SOUN, NULL]),
{20} wbInteger('Flags', itU32, wbFlags([
{0x00000001}'Unknown 1',
{0x00000002}'Always Uses World Orientation',
{0x00000004}'Knock Down - Always',
{0x00000008}'Knock Down - By Formula',
{0x00000010}'Ignore LOS Check',
{0x00000020}'Push Explosion Source Ref Only',
{0x00000040}'Ignore Image Space Swap'
])),
{24} wbFloat('IS Radius'),
{28} wbFormIDCk('Impact DataSet', [IPDS, NULL]),
{32} wbFormIDCk('Sound 2', [SOUN, NULL]),
wbStruct('Radiation', [
{36} wbFloat('Level'),
{40} wbFloat('Dissipation Time'),
{44} wbFloat('Radius')
]),
{48} wbInteger('Sound Level', itU32, wbSoundLevelEnum, cpNormal, True)
], cpNormal, True),
wbFormIDCk(INAM, 'Placed Impact Object', [TREE, SOUN, ACTI, DOOR, STAT, FURN,
CONT, ARMO, AMMO, LVLN, LVLC, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS,
ASPC, IDLM, ARMA, MSTT, NOTE, PWAT, SCOL, TACT, TERM, TXST])
]);
wbRecord(DEBR, 'Debris', [
wbEDIDReq,
wbRStructs('Models', 'Model', [
wbStruct(DATA, 'Data', [
wbInteger('Percentage', itU8),
wbString('Model Filename'),
wbInteger('Flags', itU8, wbFlags([
'Has Collission Data'
]))
], cpNormal, True),
wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore)
], [], cpNormal, True)
]);
wbRecord(IMGS, 'Image Space', [
wbEDIDReq,
wbStruct(DNAM, '', [
wbStruct('HDR', [
{00} wbFloat('Eye Adapt Speed'),
{04} wbFloat('Blur Radius'),
{08} wbFloat('Blur Passes'),
{12} wbFloat('Emissive Mult'),
{16} wbFloat('Target LUM'),
{20} wbFloat('Upper LUM Clamp'),
{24} wbFloat('Bright Scale'),
{28} wbFloat('Bright Clamp'),
{32} wbFloat('LUM Ramp No Tex'),
{36} wbFloat('LUM Ramp Min'),
{40} wbFloat('LUM Ramp Max'),
{44} wbFloat('Sunlight Dimmer'),
{48} wbFloat('Grass Dimmer'),
{52} wbFloat('Tree Dimmer'),
{56} wbUnion('Skin Dimmer', wbIMGSSkinDimmerDecider, [
wbFloat('Skin Dimmer'),
wbEmpty('Skin Dimmer', cpIgnore)
])
], cpNormal, False, nil, 14),
wbStruct('Bloom', [
{60} wbFloat('Blur Radius'),
{64} wbFloat('Alpha Mult Interior'),
{68} wbFloat('Alpha Mult Exterior')
]),
wbStruct('Get Hit', [
{72} wbFloat('Blur Radius'),
{76} wbFloat('Blur Damping Constant'),
{80} wbFloat('Damping Constant')
]),
wbStruct('Night Eye', [
wbStruct('Tint Color', [
{84} wbFloat('Red', cpNormal, False, 255, 0),
{88} wbFloat('Green', cpNormal, False, 255, 0),
{92} wbFloat('Blue', cpNormal, False, 255, 0)
]),
{96} wbFloat('Brightness')
]),
wbStruct('Cinematic', [
{100} wbFloat('Saturation'),
wbStruct('Contrast', [
{104} wbFloat('Avg Lum Value'),
{108} wbFloat('Value')
]),
{112} wbFloat('Cinematic - Brightness - Value'),
wbStruct('Tint', [
wbStruct('Color', [
{116} wbFloat('Red', cpNormal, False, 255, 0),
{120} wbFloat('Green', cpNormal, False, 255, 0),
{124} wbFloat('Blue', cpNormal, False, 255, 0)
]),
{128} wbFloat('Value')
])
]),
wbByteArray('Unused', 4),
wbByteArray('Unused', 4),
wbByteArray('Unused', 4),
wbByteArray('Unused', 4),
wbInteger('Flags', itU8, wbFlags([
'Saturation',
'Contrast',
'Tint',
'Brightness'
], True)),
wbByteArray('Unused', 3)
], cpNormal, True, nil, 5)
]);
wbTimeInterpolator := wbStruct('Data', [
wbFloat('Time'),
wbFloat('Value')
]);
wbColorInterpolator := wbStruct('Data', [
wbFloat('Time'),
wbFloat('Red', cpNormal, False, 255, 0),
wbFloat('Green', cpNormal, False, 255, 0),
wbFloat('Blue', cpNormal, False, 255, 0),
wbFloat('Alpha', cpNormal, False, 255, 0)
]);
wbRecord(IMAD, 'Image Space Adapter', [
wbEDID,
wbStruct(DNAM, 'Data Count', [
wbInteger('Flags', itU32, wbFlags(['Animatable'])),
wbFloat('Duration'),
wbStruct('HDR', [
wbInteger('Eye Adapt Speed Mult', itU32),
wbInteger('Eye Adapt Speed Add', itU32),
wbInteger('Bloom Blur Radius Mult', itU32),
wbInteger('Bloom Blur Radius Add', itU32),
wbInteger('Bloom Threshold Mult', itU32),
wbInteger('Bloom Threshold Add', itU32),
wbInteger('Bloom Scale Mult', itU32),
wbInteger('Bloom Scale Add', itU32),
wbInteger('Target Lum Min Mult', itU32),
wbInteger('Target Lum Min Add', itU32),
wbInteger('Target Lum Max Mult', itU32),
wbInteger('Target Lum Max Add', itU32),
wbInteger('Sunlight Scale Mult', itU32),
wbInteger('Sunlight Scale Add', itU32),
wbInteger('Sky Scale Mult', itU32),
wbInteger('Sky Scale Add', itU32)
]),
wbInteger('Unknown08 Mult', itU32),
wbInteger('Unknown48 Add', itU32),
wbInteger('Unknown09 Mult', itU32),
wbInteger('Unknown49 Add', itU32),
wbInteger('Unknown0A Mult', itU32),
wbInteger('Unknown4A Add', itU32),
wbInteger('Unknown0B Mult', itU32),
wbInteger('Unknown4B Add', itU32),
wbInteger('Unknown0C Mult', itU32),
wbInteger('Unknown4C Add', itU32),
wbInteger('Unknown0D Mult', itU32),
wbInteger('Unknown4D Add', itU32),
wbInteger('Unknown0E Mult', itU32),
wbInteger('Unknown4E Add', itU32),
wbInteger('Unknown0F Mult', itU32),
wbInteger('Unknown4F Add', itU32),
wbInteger('Unknown10 Mult', itU32),
wbInteger('Unknown50 Add', itU32),
wbStruct('Cinematic', [
wbInteger('Saturation Mult', itU32),
wbInteger('Saturation Add', itU32),
wbInteger('Brightness Mult', itU32),
wbInteger('Brightness Add', itU32),
wbInteger('Contrast Mult', itU32),
wbInteger('Contrast Add', itU32)
]),
wbInteger('Unknown14 Mult', itU32),
wbInteger('Unknown54 Add', itU32),
wbInteger('Tint Color', itU32),
wbInteger('Blur Radius', itU32),
wbInteger('Double Vision Strength', itU32),
wbInteger('Radial Blur Strength', itU32),
wbInteger('Radial Blur Ramp Up', itU32),
wbInteger('Radial Blur Start', itU32),
wbInteger('Radial Blur Flags', itU32, wbFlags(['Use Target'])),
wbFloat('Radial Blur Center X'),
wbFloat('Radial Blur Center Y'),
wbInteger('DoF Strength', itU32),
wbInteger('DoF Distance', itU32),
wbInteger('DoF Range', itU32),
wbInteger('DoF Flags', itU32, wbFlags(['Use Target'])),
wbInteger('Radial Blur Ramp Down', itU32),
wbInteger('Radial Blur Down Start', itU32),
wbInteger('Fade Color', itU32),
wbInteger('Motion Blur Strength', itU32)
], cpNormal, True, nil, 26),
wbArray(BNAM, 'Blur Radius', wbTimeInterpolator),
wbArray(VNAM, 'Double Vision Strength', wbTimeInterpolator),
wbArray(TNAM, 'Tint Color', wbColorInterpolator),
wbArray(NAM3, 'Fade Color', wbColorInterpolator),
wbArray(RNAM, 'Radial Blur Strength', wbTimeInterpolator),
wbArray(SNAM, 'Radial Blur Ramp Up', wbTimeInterpolator),
wbArray(UNAM, 'Radial Blur Start', wbTimeInterpolator),
wbArray(NAM1, 'Radial Blur Ramp Down', wbTimeInterpolator),
wbArray(NAM2, 'Radial Blur Down Start', wbTimeInterpolator),
wbArray(WNAM, 'DoF Strength', wbTimeInterpolator),
wbArray(XNAM, 'DoF Distance', wbTimeInterpolator),
wbArray(YNAM, 'DoF Range', wbTimeInterpolator),
wbArray(NAM4, 'Motion Blur Strength', wbTimeInterpolator),
wbRStruct('HDR', [
wbArray(_00_IAD, 'Eye Adapt Speed Mult', wbTimeInterpolator),
wbArray(_40_IAD, 'Eye Adapt Speed Add', wbTimeInterpolator),
wbArray(_01_IAD, 'Bloom Blur Radius Mult', wbTimeInterpolator),
wbArray(_41_IAD, 'Bloom Blur Radius Add', wbTimeInterpolator),
wbArray(_02_IAD, 'Bloom Threshold Mult', wbTimeInterpolator),
wbArray(_42_IAD, 'Bloom Threshold Add', wbTimeInterpolator),
wbArray(_03_IAD, 'Bloom Scale Mult', wbTimeInterpolator),
wbArray(_43_IAD, 'Bloom Scale Add', wbTimeInterpolator),
wbArray(_04_IAD, 'Target Lum Min Mult', wbTimeInterpolator),
wbArray(_44_IAD, 'Target Lum Min Add', wbTimeInterpolator),
wbArray(_05_IAD, 'Target Lum Max Mult', wbTimeInterpolator),
wbArray(_45_IAD, 'Target Lum Max Add', wbTimeInterpolator),
wbArray(_06_IAD, 'Sunlight Scale Mult', wbTimeInterpolator),
wbArray(_46_IAD, 'Sunlight Scale Add', wbTimeInterpolator),
wbArray(_07_IAD, 'Sky Scale Mult', wbTimeInterpolator),
wbArray(_47_IAD, 'Sky Scale Add', wbTimeInterpolator)
], []),
wbUnknown(_08_IAD),
wbUnknown(_48_IAD),
wbUnknown(_09_IAD),
wbUnknown(_49_IAD),
wbUnknown(_0A_IAD),
wbUnknown(_4A_IAD),
wbUnknown(_0B_IAD),
wbUnknown(_4B_IAD),
wbUnknown(_0C_IAD),
wbUnknown(_4C_IAD),
wbUnknown(_0D_IAD),
wbUnknown(_4D_IAD),
wbUnknown(_0E_IAD),
wbUnknown(_4E_IAD),
wbUnknown(_0F_IAD),
wbUnknown(_4F_IAD),
wbUnknown(_10_IAD),
wbUnknown(_50_IAD),
wbRStruct('Cinematic', [
wbArray(_11_IAD, 'Saturation Mult', wbTimeInterpolator),
wbArray(_51_IAD, 'Saturation Add', wbTimeInterpolator),
wbArray(_12_IAD, 'Brightness Mult', wbTimeInterpolator),
wbArray(_52_IAD, 'Brightness Add', wbTimeInterpolator),
wbArray(_13_IAD, 'Contrast Mult', wbTimeInterpolator),
wbArray(_53_IAD, 'Contrast Add', wbTimeInterpolator)
], []),
wbUnknown(_14_IAD),
wbUnknown(_54_IAD)
]);
wbRecord(FLST, 'FormID List', [
wbString(EDID, 'Editor ID', 0, cpBenign, True, nil, wbFLSTEDIDAfterSet),
wbRArrayS('FormIDs', wbFormID(LNAM, 'FormID'), cpNormal, False, nil, nil, nil, wbFLSTLNAMIsSorted)
]);
wbRecord(PERK, 'Perk', [
wbEDIDReq,
wbFULL,
wbDESCReq,
wbICON,
wbCTDAs,
wbStruct(DATA, 'Data', [
wbInteger('Trait', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Min Level', itU8),
wbInteger('Ranks', itU8),
wbInteger('Playable', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Hidden', itU8, wbEnum(['No', 'Yes']))
], cpNormal, True, nil, 4),
wbRStructsSK('Effects', 'Effect', [0, 1], [
wbStructSK(PRKE, [1, 2, 0], 'Header', [
wbInteger('Type', itU8, wbEnum([
'Quest + Stage',
'Ability',
'Entry Point'
]), cpNormal, False, nil, wbPERKPRKETypeAfterSet),
wbInteger('Rank', itU8),
wbInteger('Priority', itU8)
]),
wbUnion(DATA, 'Effect Data', wbPerkDATADecider, [
wbStructSK([0, 1], 'Quest + Stage', [
wbFormIDCk('Quest', [QUST]),
wbInteger('Quest Stage', itU8, wbPerkDATAQuestStageToStr, wbCTDAParam2QuestStageToInt),
wbByteArray('Unused', 3)
]),
wbFormIDCk('Ability', [SPEL]),
wbStructSK([0, 1], 'Entry Point', [
wbInteger('Entry Point', itU8, wbEnum([
{00} 'Calculate Weapon Damage',
{01} 'Calculate My Critical Hit Chance',
{02} 'Calculate My Critical Hit Damage',
{03} 'Calculate Weapon Attack AP Cost',
{04} 'Calculate Mine Explode Chance',
{05} 'Adjust Range Penalty',
{06} 'Adjust Limb Damage',
{07} 'Calculate Weapon Range',
{08} 'Calculate To Hit Chance',
{09} 'Adjust Experience Points',
{10} 'Adjust Gained Skill Points',
{11} 'Adjust Book Skill Points',
{12} 'Modify Recovered Health',
{13} 'Calculate Inventory AP Cost',
{14} 'Get Disposition',
{15} 'Get Should Attack',
{16} 'Get Should Assist',
{17} 'Calculate Buy Price',
{18} 'Get Bad Karma',
{19} 'Get Good Karma',
{20} 'Ignore Locked Terminal',
{21} 'Add Leveled List On Death',
{22} 'Get Max Carry Weight',
{23} 'Modify Addiction Chance',
{24} 'Modify Addiction Duration',
{25} 'Modify Positive Chem Duration',
{26} 'Adjust Drinking Radiation',
{27} 'Activate',
{28} 'Mysterious Stranger',
{29} 'Has Paralyzing Palm',
{30} 'Hacking Science Bonus',
{31} 'Ignore Running During Detection',
{32} 'Ignore Broken Lock',
{33} 'Has Concentrated Fire',
{34} 'Calculate Gun Spread',
{35} 'Player Kill AP Reward',
{36} 'Modify Enemy Critical Hit Chance'
]), cpNormal, True, nil, wbPERKEntryPointAfterSet),
wbInteger('Function', itU8, wbPerkDATAFunctionToStr, wbPerkDATAFunctionToInt, cpNormal, False, nil, wbPerkDATAFunctionAfterSet),
wbInteger('Perk Condition Tab Count', itU8, nil, cpIgnore)
])
], cpNormal, True),
wbRStructsSK('Perk Conditions', 'Perk Condition', [0], [
wbInteger(PRKC, 'Run On', itS8, wbPRKCToStr, wbPRKCToInt),
wbCTDAsReq
], [], cpNormal, False, nil, nil, wbPERKPRKCDontShow),
wbRStruct('Entry Point Function Parameters', [
wbInteger(EPFT, 'Type', itU8, wbPerkEPFTToStr, wbPerkEPFTToInt, cpIgnore, False, nil, wbPerkEPFTAfterSet),
wbUnion(EPFD, 'Data', wbEPFDDecider, [
wbByteArray('Unknown'),
wbFloat('Float'),
wbStruct('Float, Float', [
wbFloat('Float 1'),
wbFloat('Float 2')
]),
wbFormIDCk('Leveled Item', [LVLI]),
wbEmpty('None (Script)'),
wbStruct('Actor Value, Float', [
wbInteger('Actor Value', itU32, wbEPFDActorValueToStr, wbEPFDActorValueToInt),
wbFloat('Float')
])
], cpNormal, False, wbEPFDDontShow),
wbString(EPF2, 'Button Label', 0, cpNormal, False, wbEPF2DontShow),
wbInteger(EPF3, 'Script Flags', itU16, wbFlags([
'Run Immediately'
]), cpNormal, False, False, wbEPF2DontShow),
wbEmbeddedScriptPerk
], [], cpNormal, False, wbPERKPRKCDontShow),
wbEmpty(PRKF, 'End Marker', cpIgnore, True)
], [])
]);
wbBPNDStruct := wbStruct(BPND, '', [
{00} wbFloat('Damage Mult'),
{04} wbInteger('Flags', itU8, wbFlags([
'Severable',
'IK Data',
'IK Data - Biped Data',
'Explodable',
'IK Data - Is Head',
'IK Data - Headtracking',
'To Hit Chance - Absolute'
])),
{05} wbInteger('Part Type', itU8, wbEnum([
'Torso',
'Head 1',
'Head 2',
'Left Arm 1',
'Left Arm 2',
'Right Arm 1',
'Right Arm 2',
'Left Leg 1',
'Left Leg 2',
'Left Leg 3',
'Right Leg 1',
'Right Leg 2',
'Right Leg 3',
'Brain',
'Weapon'
])),
{06} wbInteger('Health Percent', itU8),
{07} wbInteger('Actor Value', itS8, wbActorValueEnum),
{08} wbInteger('To Hit Chance', itU8),
{09} wbInteger('Explodable - Explosion Chance %', itU8),
{10} wbInteger('Explodable - Debris Count', itU16),
{12} wbFormIDCk('Explodable - Debris', [DEBR, NULL]),
{16} wbFormIDCk('Explodable - Explosion', [EXPL, NULL]),
{20} wbFloat('Tracking Max Angle'),
{24} wbFloat('Explodable - Debris Scale'),
{28} wbInteger('Severable - Debris Count', itS32),
{32} wbFormIDCk('Severable - Debris', [DEBR, NULL]),
{36} wbFormIDCk('Severable - Explosion', [EXPL, NULL]),
{40} wbFloat('Severable - Debris Scale'),
wbStruct('Gore Effects Positioning', [
wbStruct('Translate', [
{44} wbFloat('X'),
{48} wbFloat('Y'),
{52} wbFloat('Z')
]),
wbStruct('Rotation', [
{56} wbFloat('X', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
{60} wbFloat('Y', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
{64} wbFloat('Z', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize)
])
]),
{68} wbFormIDCk('Severable - Impact DataSet', [IPDS, NULL]),
{72} wbFormIDCk('Explodable - Impact DataSet', [IPDS, NULL]),
{28} wbInteger('Severable - Decal Count', itU8),
{28} wbInteger('Explodable - Decal Count', itU8),
{76} wbByteArray('Unused', 2),
{80} wbFloat('Limb Replacement Scale')
], cpNormal, True);
wbRecord(BPTD, 'Body Part Data', [
wbEDIDReq,
wbMODLReq,
wbRStructS('Body Parts', 'Body Part', [
wbString(BPTN, 'Part Name', 0, cpNormal, True),
wbString(BPNN, 'Part Node', 0, cpNormal, True),
wbString(BPNT, 'VATS Target', 0, cpNormal, True),
wbString(BPNI, 'IK Data - Start Node', 0, cpNormal, True),
wbBPNDStruct,
wbString(NAM1, 'Limb Replacement Model', 0, cpNormal, True),
wbString(NAM4, 'Gore Effects - Target Bone', 0, cpNormal, True),
wbByteArray(NAM5, 'Texture Files Hashes', 0, cpIgnore)
], [], cpNormal, True),
wbFormIDCk(RAGA, 'Ragdoll', [RGDL])
]);
wbRecord(ADDN, 'Addon Node', [
wbEDIDReq,
wbOBNDReq,
wbMODLReq,
wbInteger(DATA, 'Node Index', itS32, nil, cpNormal, True),
wbFormIDCk(SNAM, 'Sound', [SOUN]),
wbStruct(DNAM, 'Data', [
wbInteger('Master Particle System Cap', itU16),
wbByteArray('Unknown', 2)
], cpNormal, True)
]);
wbRecord(AVIF, 'ActorValue Information', [
wbEDIDReq,
wbFULL,
wbDESCReq,
wbICON,
wbString(ANAM, 'Short Name')
]);
wbRecord(RADS, 'Radiation Stage', [
wbEDIDReq,
wbStruct(DATA, '', [
wbInteger('Trigger Threshold', itU32),
wbFormIDCk('Actor Effect', [SPEL])
], cpNormal, True)
]);
wbRecord(CAMS, 'Camera Shot', [
wbEDIDReq,
wbMODL,
wbStruct(DATA, 'Data', [
{00} wbInteger('Action', itU32, wbEnum([
'Shoot',
'Fly',
'Hit',
'Zoom'
])),
{04} wbInteger('Location', itU32, wbEnum([
'Attacker',
'Projectile',
'Target'
])),
{08} wbInteger('Target', itU32, wbEnum([
'Attacker',
'Projectile',
'Target'
])),
{12} wbInteger('Flags', itU32, wbFlags([
'Position Follows Location',
'Rotation Follows Target',
'Don''t Follow Bone',
'First Person Camera',
'No Tracer',
'Start At Time Zero'
])),
wbStruct('Time Multipliers', [
{16} wbFloat('Player'),
{20} wbFloat('Target'),
{24} wbFloat('Global')
]),
{28} wbFloat('Max Time'),
{32} wbFloat('Min Time'),
{36} wbFloat('Target % Between Actors')
], cpNormal, True, nil, 7),
wbFormIDCk(MNAM, 'Image Space Modifier', [IMAD])
]);
wbRecord(CPTH, 'Camera Path', [
wbEDIDReq,
wbCTDAs,
wbArray(ANAM, 'Related Camera Paths', wbFormIDCk('Related Camera Path', [CPTH, NULL]), ['Parent', 'Previous Sibling'], cpNormal, True),
wbInteger(DATA, 'Camera Zoom', itU8, wbEnum([
'Default',
'Disable',
'Shot List'
]), cpNormal, True),
wbRArray('Camera Shots', wbFormIDCk(SNAM, 'Camera Shot', [CAMS]))
]);
wbRecord(VTYP, 'Voice Type', [
wbEDIDReq,
wbInteger(DNAM, 'Flags', itU8, wbFlags([
'Allow Default Dialog',
'Female'
]), cpNormal, True)
]);
wbRecord(IPCT, 'Impact', [
wbEDIDReq,
wbMODL,
wbStruct(DATA, '', [
wbFloat('Effect - Duration'),
wbInteger('Effect - Orientation', itU32, wbEnum([
'Surface Normal',
'Projectile Vector',
'Projectile Reflection'
])),
wbFloat('Angle Threshold'),
wbFloat('Placement Radius'),
wbInteger('Sound Level', itU32, wbSoundLevelEnum),
wbInteger('Flags', itU32, wbFlags([
'No Decal Data'
]))
], cpNormal, True),
wbDODT,
wbFormIDCk(DNAM, 'Texture Set', [TXST]),
wbFormIDCk(SNAM, 'Sound 1', [SOUN]),
wbFormIDCk(NAM1, 'Sound 2', [SOUN])
]);
wbRecord(IPDS, 'Impact DataSet', [
wbEDIDReq,
wbStruct(DATA, 'Impacts', [
wbFormIDCk('Stone', [IPCT, NULL]),
wbFormIDCk('Dirt', [IPCT, NULL]),
wbFormIDCk('Grass', [IPCT, NULL]),
wbFormIDCk('Glass', [IPCT, NULL]),
wbFormIDCk('Metal', [IPCT, NULL]),
wbFormIDCk('Wood', [IPCT, NULL]),
wbFormIDCk('Organic', [IPCT, NULL]),
wbFormIDCk('Cloth', [IPCT, NULL]),
wbFormIDCk('Water', [IPCT, NULL]),
wbFormIDCk('Hollow Metal', [IPCT, NULL]),
wbFormIDCk('Organic Bug', [IPCT, NULL]),
wbFormIDCk('Organic Glow', [IPCT, NULL])
], cpNormal, True, nil, 9)
]);
wbRecord(ECZN, 'Encounter Zone', [
wbEDIDReq,
wbStruct(DATA, '', [
wbFormIDCkNoReach('Owner', [NPC_, FACT, NULL]),
wbInteger('Rank', itS8),
wbInteger('Minimum Level', itS8),
wbInteger('Flags', itU8, wbFlags([
'Never Resets',
'Match PC Below Minimum Level'
])),
wbByteArray('Unused', 1)
], cpNormal, True)
]);
wbRecord(MESG, 'Message', [
wbEDIDReq,
wbDESCReq,
wbFULL,
wbFormIDCk(INAM, 'Icon', [MICN, NULL], False, cpNormal, True),
wbByteArray(NAM0, 'Unused', 0, cpIgnore),
wbByteArray(NAM1, 'Unused', 0, cpIgnore),
wbByteArray(NAM2, 'Unused', 0, cpIgnore),
wbByteArray(NAM3, 'Unused', 0, cpIgnore),
wbByteArray(NAM4, 'Unused', 0, cpIgnore),
wbByteArray(NAM5, 'Unused', 0, cpIgnore),
wbByteArray(NAM6, 'Unused', 0, cpIgnore),
wbByteArray(NAM7, 'Unused', 0, cpIgnore),
wbByteArray(NAM8, 'Unused', 0, cpIgnore),
wbByteArray(NAM9, 'Unused', 0, cpIgnore),
wbInteger(DNAM, 'Flags', itU32, wbFlags([
'Message Box',
'Auto Display'
]), cpNormal, True, False, nil, wbMESGDNAMAfterSet),
wbInteger(TNAM, 'Display Time', itU32, nil, cpNormal, False, False, wbMESGTNAMDontShow),
wbRStructs('Menu Buttons', 'Menu Button', [
wbString(ITXT, 'Button Text'),
wbCTDAs
], [])
], False, nil, cpNormal, False, wbMESGAfterLoad);
wbRecord(RGDL, 'Ragdoll', [
wbEDIDReq,
wbInteger(NVER, 'Version', itU32, nil, cpNormal, True),
wbStruct(DATA, 'General Data', [
wbInteger('Dynamic Bone Count', itU32),
wbByteArray('Unused', 4),
wbStruct('Enabled', [
wbInteger('Feedback', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Foot IK (broken, don''t use)', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Look IK (broken, don''t use)', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Grab IK (broken, don''t use)', itU8, wbEnum(['No', 'Yes'])),
wbInteger('Pose Matching', itU8, wbEnum(['No', 'Yes']))
]),
wbByteArray('Unused', 1)
], cpNormal, True),
wbFormIDCk(XNAM, 'Actor Base', [CREA, NPC_], False, cpNormal, True),
wbFormIDCk(TNAM, 'Body Part Data', [BPTD], False, cpNormal, True),
wbStruct(RAFD, 'Feedback Data', [
{00} wbFloat('Dynamic/Keyframe Blend Amount'),
{04} wbFloat('Hierarchy Gain'),
{08} wbFloat('Position Gain'),
{12} wbFloat('Velocity Gain'),
{16} wbFloat('Acceleration Gain'),
{20} wbFloat('Snap Gain'),
{24} wbFloat('Velocity Damping'),
wbStruct('Snap Max Settings', [
{28} wbFloat('Linear Velocity'),
{32} wbFloat('Angular Velocity'),
{36} wbFloat('Linear Distance'),
{40} wbFloat('Angular Distance')
]),
wbStruct('Position Max Velocity', [
{44} wbFloat('Linear'),
{48} wbFloat('Angular')
]),
wbStruct('Position Max Velocity', [
{52} wbInteger('Projectile', itS32, wbDiv(1000)),
{56} wbInteger('Melee', itS32, wbDiv(1000))
])
], cpNormal, False),
wbArray(RAFB, 'Feedback Dynamic Bones', wbInteger('Bone', itU16), 0, nil, nil, cpNormal, False),
wbStruct(RAPS, 'Pose Matching Data', [
{00} wbArray('Match Bones', wbInteger('Bone', itU16, wbHideFFFF), 3),
{06} wbInteger('Flags', itU8, wbFlags([
'Disable On Move'
])),
{07} wbByteArray('Unused', 1),
{08} wbFloat('Motors Strength'),
{12} wbFloat('Pose Activation Delay Time'),
{16} wbFloat('Match Error Allowance'),
{20} wbFloat('Displacement To Disable')
], cpNormal, True),
wbString(ANAM, 'Death Pose')
]);
wbRecord(DOBJ, 'Default Object Manager', [
wbEDIDReq,
wbArray(DATA, 'Default Objects', wbFormID('Default Object'), [
'Stimpack',
'SuperStimpack',
'RadX',
'RadAway',
'Morphine',
'Perk Paralysis',
'Player Faction',
'Mysterious Stranger NPC',
'Mysterious Stranger Faction',
'Default Music',
'Battle Music',
'Death Music',
'Success Music',
'Level Up Music',
'Player Voice (Male)',
'Player Voice (Male Child)',
'Player Voice (Female)',
'Player Voice (Female Child)',
'Eat Package Default Food',
'Every Actor Ability',
'Drug Wears Off Image Space'
], cpNormal, True)
]);
wbRecord(LGTM, 'Lighting Template', [
wbEDIDReq,
wbStruct(DATA, 'Lighting', [
wbStruct('Ambient Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Directional Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Fog Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbFloat('Fog Near'),
wbFloat('Fog Far'),
wbInteger('Directional Rotation XY', itS32),
wbInteger('Directional Rotation Z', itS32),
wbFloat('Directional Fade'),
wbFloat('Fog Clip Dist'),
wbFloat('Fog Power')
], cpNormal, True)
]);
wbRecord(MUSC, 'Music Type', [
wbEDIDReq,
wbString(FNAM, 'Filename')
]);
wbRecord(GRAS, 'Grass', [
wbEDIDReq,
wbOBNDReq,
wbMODLReq,
wbStruct(DATA, '', [
wbInteger('Density', itU8),
wbInteger('Min Slope', itU8),
wbInteger('Max Slope', itU8),
wbByteArray('Unused', 1),
wbInteger('Unit from water amount', itU16),
wbByteArray('Unused', 2),
wbInteger('Unit from water type', itU32, wbEnum([
'Above - At Least',
'Above - At Most',
'Below - At Least',
'Below - At Most',
'Either - At Least',
'Either - At Most',
'Either - At Most Above',
'Either - At Most Below'
])),
wbFloat('Position Range'),
wbFloat('Height Range'),
wbFloat('Color Range'),
wbFloat('Wave Period'),
wbInteger('Flags', itU8, wbFlags([
'Vertex Lighting',
'Uniform Scaling',
'Fit to Slope'
])),
wbByteArray('Unused', 3)
], cpNormal, True)
]);
wbRecord(HAIR, 'Hair', [
wbEDIDReq,
wbFULLReq,
wbMODLReq,
wbString(ICON, 'Texture', 0, cpNormal, True),
wbInteger(DATA, 'Flags', itU8, wbFlags([
'Playable',
'Not Male',
'Not Female',
'Fixed'
]), cpNormal, True)
]);
wbRecord(IDLE, 'Idle Animation', [
wbEDID,
wbMODLReq,
wbCTDAs,
wbArray(ANAM, 'Related Idle Animations', wbFormIDCk('Related Idle Animation', [IDLE, NULL]), ['Parent', 'Previous Sibling'], cpNormal, True),
wbStruct(DATA, '', [
wbInteger('Animation Group Section', itU8, wbIdleAnam),
wbStruct('Looping', [
wbInteger('Min', itU8),
wbInteger('Max', itU8)
]),
wbByteArray('Unused', 1),
wbInteger('Replay Delay', itS16),
wbInteger('Flags', itU8, wbFlags([
'No attacking'
])),
wbByteArray('Unused', 1)
], cpNormal, True, nil, 4)
]);
wbRecord(INFO, 'Dialog response', [
wbStruct(DATA, '', [
wbInteger('Type', itU8, wbEnum([
{0} 'Topic',
{1} 'Conversation',
{2} 'Combat',
{3} 'Persuasion',
{4} 'Detection',
{5} 'Service',
{6} 'Miscellaneous',
{7} 'Radio'
])),
wbInteger('Next Speaker', itU8, wbEnum([
{0} 'Target',
{1} 'Self',
{2} 'Either'
])),
wbInteger('Flags 1', itU8, wbFlags([
{0x01} 'Goodbye',
{0x02} 'Random',
{0x04} 'Say Once',
{0x08} 'Run Immediately',
{0x10} 'Info Refusal',
{0x20} 'Random End',
{0x40} 'Run for Rumors',
{0x80} 'Speech Challenge'
])),
wbInteger('Flags 2', itU8, wbFlags([
{0x01} 'Say Once a Day',
{0x02} 'Always Darken'
]))
], cpNormal, True, nil, 3),
wbFormIDCkNoReach(QSTI, 'Quest', [QUST], False, cpNormal, True),
wbFormIDCk(TPIC, 'Topic', [DIAL]),
wbFormIDCkNoReach(PNAM, 'Previous INFO', [INFO, NULL]),
wbRArray('Add Topics', wbFormIDCk(NAME, 'Topic', [DIAL])),
wbRArray('Responses',
wbRStruct('Response', [
wbStruct(TRDT, 'Response Data', [
wbInteger('Emotion Type', itU32, wbEnum([
{0} 'Neutral',
{1} 'Anger',
{2} 'Disgust',
{3} 'Fear',
{4} 'Sad',
{5} 'Happy',
{6} 'Surprise',
{7} 'Pained'
])),
wbInteger('Emotion Value', itS32),
wbByteArray('Unused', 4),
wbInteger('Response number', itU8),
wbByteArray('Unused', 3),
wbFormIDCk('Sound', [SOUN, NULL]),
wbInteger('Flags', itU8, wbFlags([
'Use Emotion Animation'
])),
wbByteArray('Unused', 3)
], cpNormal, False, nil, 5),
wbStringKC(NAM1, 'Response Text', 0, cpTranslate, True),
wbString(NAM2, 'Script Notes', 0, cpTranslate, True),
wbString(NAM3, 'Edits'),
wbFormIDCk(SNAM, 'Speaker Animation', [IDLE]),
wbFormIDCk(LNAM, 'Listener Animation', [IDLE])
], [])
),
wbCTDAs,
wbRArray('Choices', wbFormIDCk(TCLT, 'Choice', [DIAL])),
wbRArray('Link From', wbFormIDCk(TCLF, 'Topic', [DIAL])),
wbRStruct('Script (Begin)', [
wbEmbeddedScriptReq
], [], cpNormal, True),
wbRStruct('Script (End)', [
wbEmpty(NEXT, 'Marker'),
wbEmbeddedScriptReq
], [], cpNormal, True),
wbFormIDCk(SNDD, 'Unused', [SOUN]),
wbString(RNAM, 'Prompt'),
wbFormIDCk(ANAM, 'Speaker', [CREA, NPC_]),
wbFormIDCk(KNAM, 'ActorValue/Perk', [AVIF, PERK]),
wbInteger(DNAM, 'Speech Challenge', itU32, wbEnum([
'---',
'Very Easy',
'Easy',
'Average',
'Hard',
'Very Hard'
]))
], False, wbINFOAddInfo, cpNormal, False, wbINFOAfterLoad);
wbRecord(INGR, 'Ingredient', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbSCRI,
wbETYPReq,
wbFloat(DATA, 'Weight', cpNormal, True),
wbStruct(ENIT, 'Effect Data', [
wbInteger('Value', itS32),
wbInteger('Flags', itU8, wbFlags(['No auto-calculation', 'Food item'])),
wbByteArray('Unused', 3)
], cpNormal, True),
wbEffectsReq
]);
wbRecord(KEYM, 'Key', [
wbEDIDReq,
wbOBNDReq,
wbFULLReq,
wbMODL,
wbICONReq,
wbSCRI,
wbDEST,
wbYNAM,
wbZNAM,
wbStruct(DATA, '', [
wbInteger('Value', itS32),
wbFloat('Weight')
], cpNormal, True)
]);
wbQuadrantEnum := wbEnum([
{0} 'Bottom Left',
{1} 'Bottom Right',
{2} 'Top Left',
{3} 'Top Right'
]);
if wbSimpleRecords then begin
wbRecord(LAND, 'Landscape', [
wbByteArray(DATA, 'Unknown'),
wbByteArray(VNML, 'Vertex Normals'),
wbByteArray(VHGT, 'Vertext Height Map'),
wbByteArray(VCLR, 'Vertex Colours'),
wbRArrayS('Layers', wbRUnion('Layer', [
wbRStructSK([0],'Base Layer', [
wbStructSK(BTXT, [1, 3], 'Base Layer Header', [
wbFormIDCk('Texture', [LTEX, NULL]),
wbInteger('Quadrant', itU8, wbQuadrantEnum),
wbByteArray('Unused', 1),
wbInteger('Layer', itS16)
])
], []),
wbRStructSK([0],'Alpha Layer', [
wbStructSK(ATXT, [1, 3], 'Alpha Layer Header', [
wbFormIDCk('Texture', [LTEX, NULL]),
wbInteger('Quadrant', itU8, wbQuadrantEnum),
wbByteArray('Unused', 1),
wbInteger('Layer', itS16)
]),
wbByteArray(VTXT, 'Alpha Layer Data')
], [])
], [])),
wbArray(VTEX, 'Textures', wbFormIDCk('Texture', [LTEX, NULL]))
]);
end else begin
wbRecord(LAND, 'Landscape', [
wbByteArray(DATA, 'Unknown'),
wbArray(VNML, 'Vertex Normals', wbStruct('Row', [
wbArray('Columns', wbStruct('Column', [
wbInteger('X', itU8),
wbInteger('Y', itU8),
wbInteger('Z', itU8)
]), 33)
]), 33),
wbStruct(VHGT, 'Vertext Height Map', [
wbFloat('Offset'),
wbArray('Rows', wbStruct('Row', [
wbArray('Columns', wbInteger('Column', itU8), 33)
]), 33),
wbByteArray('Unused', 3)
]),
wbArray(VCLR, 'Vertex Colours', wbStruct('Row', [
wbArray('Columns', wbStruct('Column', [
wbInteger('X', itU8),
wbInteger('Y', itU8),
wbInteger('Z', itU8)
]), 33)
]), 33),
wbRArrayS('Layers', wbRUnion('Layer', [
wbRStructSK([0],'Base Layer', [
wbStructSK(BTXT, [1, 3], 'Base Layer Header', [
wbFormIDCk('Texture', [LTEX, NULL]),
wbInteger('Quadrant', itU8, wbQuadrantEnum),
wbByteArray('Unused', 1),
wbInteger('Layer', itS16)
])
], []),
wbRStructSK([0],'Alpha Layer', [
wbStructSK(ATXT, [1, 3], 'Alpha Layer Header', [
wbFormIDCk('Texture', [LTEX, NULL]),
wbInteger('Quadrant', itU8, wbQuadrantEnum),
wbByteArray('Unused', 1),
wbInteger('Layer', itS16)
]),
wbArrayS(VTXT, 'Alpha Layer Data', wbStructSK([0], 'Cell', [
wbInteger('Position', itU16, wbAtxtPosition),
wbByteArray('Unused', 2),
wbFloat('Opacity')
]))
], [])
], [])),
wbArray(VTEX, 'Textures', wbFormIDCk('Texture', [LTEX, NULL]))
]);
end;
wbRecord(LIGH, 'Light', [
wbEDIDReq,
wbOBNDReq,
wbMODL,
wbSCRI,
wbDEST,
wbFULL,
wbICON,
wbStruct(DATA, '', [
wbInteger('Time', itS32),
wbInteger('Radius', itU32),
wbStruct('Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbInteger('Unused', itU8)
]),
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Dynamic',
{0x00000002} 'Can be Carried',
{0x00000004} 'Negative',
{0x00000008} 'Flicker',
{0x00000010} 'Unused',
{0x00000020} 'Off By Default',
{0x00000040} 'Flicker Slow',
{0x00000080} 'Pulse',
{0x00000100} 'Pulse Slow',
{0x00000200} 'Spot Light',
{0x00000400} 'Spot Shadow'
])),
wbFloat('Falloff Exponent'),
wbFloat('FOV'),
wbInteger('Value', itU32),
wbFloat('Weight')
], cpNormal, True),
wbFloat(FNAM, 'Fade value', cpNormal, True),
wbFormIDCk(SNAM, 'Sound', [SOUN])
], False, nil, cpNormal, False, wbLIGHAfterLoad);
wbRecord(LSCR, 'Load Screen', [
wbEDIDReq,
wbICONReq,
wbDESCReq,
wbRArrayS('Locations', wbStructSK(LNAM, [0, 1], 'Location', [
wbFormIDCkNoReach('Cell', [CELL, WRLD]),
wbByteArray('Unused', 8)
]))
]);
wbRecord(LTEX, 'Landscape Texture', [
wbEDIDReq,
wbICON,
wbFormIDCk(TNAM, 'Texture', [TXST], False, cpNormal, True),
wbStruct(HNAM, 'Havok Data', [
wbInteger('Material Type', itU8, wbEnum([
{00} 'STONE',
{01} 'CLOTH',
{02} 'DIRT',
{03} 'GLASS',
{04} 'GRASS',
{05} 'METAL',
{06} 'ORGANIC',
{07} 'SKIN',
{08} 'WATER',
{09} 'WOOD',
{10} 'HEAVY STONE',
{11} 'HEAVY METAL',
{12} 'HEAVY WOOD',
{13} 'CHAIN',
{14} 'SNOW',
{15} 'ELEVATOR',
{16} 'HOLLOW METAL',
{17} 'SHEET METAL',
{18} 'SAND',
{19} 'BRIKEN CONCRETE',
{20} 'VEHILCE BODY',
{21} 'VEHILCE PART SOLID',
{22} 'VEHILCE PART HOLLOW',
{23} 'BARREL',
{24} 'BOTTLE',
{25} 'SODA CAN',
{26} 'PISTOL',
{27} 'RIFLE',
{28} 'SHOPPING CART',
{29} 'LUNCHBOX',
{30} 'BABY RATTLE',
{31} 'RUBER BALL'
])),
wbInteger('Friction', itU8),
wbInteger('Restitution', itU8)
], cpNormal, True),
wbInteger(SNAM, 'Texture Specular Exponent', itU8, nil, cpNormal, True),
wbRArrayS('Grasses', wbFormIDCk(GNAM, 'Grass', [GRAS]))
]);
wbRecord(LVLC, 'Leveled Creature', [
wbEDIDReq,
wbOBNDReq,
wbInteger(LVLD, 'Chance none', itU8, nil, cpNormal, True),
wbInteger(LVLF, 'Flags', itU8, wbFlags([
{0x01} 'Calculate from all levels <= player''s level',
{0x02} 'Calculate for each item in count'
]), cpNormal, True),
wbRArrayS('Leveled List Entries',
wbRStructExSK([0], [1], 'Leveled List Entry', [
wbStructExSK(LVLO , [0, 2], [3], 'Base Data', [
wbInteger('Level', itS16),
wbByteArray('Unused', 2),
wbFormIDCk('Reference', [CREA, LVLC]),
wbInteger('Count', itS16),
wbByteArray('Unused', 2)
]),
wbCOED
], []),
cpNormal, True),
wbMODL
]);
wbRecord(LVLN, 'Leveled NPC', [
wbEDIDReq,
wbOBNDReq,
wbInteger(LVLD, 'Chance none', itU8, nil, cpNormal, True),
wbInteger(LVLF, 'Flags', itU8, wbFlags([
{0x01} 'Calculate from all levels <= player''s level',
{0x02} 'Calculate for each item in count'
]), cpNormal, True),
wbRArrayS('Leveled List Entries',
wbRStructExSK([0], [1], 'Leveled List Entry', [
wbStructExSK(LVLO , [0, 2], [3], 'Base Data', [
wbInteger('Level', itS16),
wbByteArray('Unused', 2),
wbFormIDCk('Reference', [NPC_, LVLN]),
wbInteger('Count', itS16),
wbByteArray('Unused', 2)
]),
wbCOED
], []),
cpNormal, True),
wbMODL
]);
wbRecord(LVLI, 'Leveled Item', [
wbEDIDReq,
wbOBNDReq,
wbInteger(LVLD, 'Chance none', itU8, nil, cpNormal, True),
wbInteger(LVLF, 'Flags', itU8, wbFlags([
{0x01} 'Calculate from all levels <= player''s level',
{0x02} 'Calculate for each item in count',
{0x04} 'Use All'
]), cpNormal, True),
wbFormIDCk(LVLG, 'Global', [GLOB]),
wbRArrayS('Leveled List Entries',
wbRStructExSK([0], [1], 'Leveled List Entry', [
wbStructExSK(LVLO , [0, 2], [3], 'Base Data', [
wbInteger('Level', itS16),
wbByteArray('Unused', 2),
wbFormIDCk('Reference', [ARMO, AMMO, MISC, WEAP, BOOK, LVLI, KEYM, ALCH, NOTE]),
wbInteger('Count', itS16),
wbByteArray('Unused', 2)
]),
wbCOED
], [])
)
]);
wbArchtypeEnum := wbEnum([
{00} 'Value Modifier',
{01} 'Script',
{02} 'Dispel',
{03} 'Cure Disease',
{04} '',
{05} '',
{06} '',
{07} '',
{08} '',
{09} '',
{10} '',
{11} 'Invisibility',
{12} 'Chameleon',
{13} 'Light',
{14} '',
{15} '',
{16} 'Lock',
{17} 'Open',
{18} 'Bound Item',
{19} 'Summon Creature',
{20} '',
{21} '',
{22} '',
{23} '',
{24} 'Paralysis',
{25} '',
{26} '',
{27} '',
{28} '',
{29} '',
{30} 'Cure Paralysis',
{31} 'Cure Addiction',
{32} 'Cure Poison',
{33} 'Concussion',
{34} 'Value And Parts'
]);
wbRecord(MGEF, 'Base Effect', [
wbEDIDReq,
wbFULL,
wbDESCReq,
wbICON,
wbMODL,
wbStruct(DATA, 'Data', [
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Hostile',
{0x00000002} 'Recover',
{0x00000004} 'Detrimental',
{0x00000008} '',
{0x00000010} 'Self',
{0x00000020} 'Touch',
{0x00000040} 'Target',
{0x00000080} 'No Duration',
{0x00000100} 'No Magnitude',
{0x00000200} 'No Area',
{0x00000400} 'FX Persist',
{0x00000800} '',
{0x00001000} 'Gory Visuals',
{0x00002000} 'Display Name Only',
{0x00004000} '',
{0x00008000} 'Radio Broadcast ??',
{0x00010000} '',
{0x00020000} '',
{0x00040000} '',
{0x00080000} 'Use skill',
{0x00100000} 'Use attribute',
{0x00200000} '',
{0x00400000} '',
{0x00800000} '',
{0x01000000} 'Painless',
{0x02000000} 'Spray projectile type (or Fog if Bolt is specified as well)',
{0x04000000} 'Bolt projectile type (or Fog if Spray is specified as well)',
{0x08000000} 'No Hit Effect',
{0x10000000} 'No Death Dispel',
{0x20000000} '????'
])),
{04} wbFloat('Base cost (Unused)'),
{08} wbUnion('Assoc. Item', wbMGEFFAssocItemDecider, [
wbFormID('Unused', cpIgnore),
wbFormID('Assoc. Item'),
wbFormIDCk('Assoc. Script', [SCPT, NULL]), //Script
wbFormIDCk('Assoc. Item', [WEAP, ARMO, NULL]), //Bound Item
wbFormIDCk('Assoc. Creature', [CREA]) //Summon Creature
], cpNormal, false, nil, wbMGEFFAssocItemAfterSet),
{12} wbInteger('Magic School (Unused)', itS32, wbEnum([
], [
-1, 'None'
])),
{16} wbInteger('Resistance Type', itS32, wbActorValueEnum),
{20} wbInteger('Counter effect count', itU16),
{22} wbByteArray('Unused', 2),
{24} wbFormIDCk('Light', [LIGH, NULL]),
{28} wbFloat('Projectile speed'),
{32} wbFormIDCk('Effect Shader', [EFSH, NULL]),
{36} wbFormIDCk('Object Display Shader', [EFSH, NULL]),
{40} wbFormIDCk('Effect sound', [NULL, SOUN]),
{44} wbFormIDCk('Bolt sound', [NULL, SOUN]),
{48} wbFormIDCk('Hit sound', [NULL, SOUN]),
{52} wbFormIDCk('Area sound', [NULL, SOUN]),
{56} wbFloat('Constant Effect enchantment factor (Unused)'),
{60} wbFloat('Constant Effect barter factor (Unused)'),
{64} wbInteger('Archtype', itU32, wbArchtypeEnum, cpNormal, False, nil, wbMGEFArchtypeAfterSet),
{68} wbActorValue
], cpNormal, True),
wbRArrayS('Counter Effects', wbFormIDCk(ESCE, 'Effect', [MGEF]), cpNormal, False, nil, wbCounterEffectsAfterSet)
], False, nil, cpNormal, False, wbMGEFAfterLoad, wbMGEFAfterSet);
wbRecord(MISC, 'Misc. Item', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbSCRI,
wbDEST,
wbYNAM,
wbZNAM,
wbStruct(DATA, '', [
wbInteger('Value', itS32),
wbFloat('Weight')
], cpNormal, True)
]);
wbRecord(COBJ, 'Constructible Object', [
wbEDID,
wbOBND,
wbFULL,
wbMODL,
wbICON,
wbSCRI,
wbYNAM,
wbZNAM,
wbStruct(DATA, '', [
wbInteger('Value', itS32),
wbFloat('Weight')
], cpNormal, True)
]);
wbFaceGen := wbRStruct('FaceGen Data', [
wbByteArray(FGGS, 'FaceGen Geometry-Symmetric', 0, cpNormal, True),
wbByteArray(FGGA, 'FaceGen Geometry-Asymmetric', 0, cpNormal, True),
wbByteArray(FGTS, 'FaceGen Texture-Symmetric', 0, cpNormal, True)
], [], cpNormal, True);
wbFaceGenNPC := wbRStruct('FaceGen Data', [
wbByteArray(FGGS, 'FaceGen Geometry-Symmetric', 0, cpNormal, True),
wbByteArray(FGGA, 'FaceGen Geometry-Asymmetric', 0, cpNormal, True),
wbByteArray(FGTS, 'FaceGen Texture-Symmetric', 0, cpNormal, True)
], [], cpNormal, True, wbActorTemplateUseModelAnimation);
wbRecord(NPC_, 'Non-Player Character', [
wbEDIDReq,
wbOBNDReq,
wbFULLActor,
wbMODLActor,
wbStruct(ACBS, 'Configuration', [
{00} wbInteger('Flags', itU32, wbFlags([
{0x000001} 'Female',
{0x000002} 'Essential',
{0x000004} 'Is CharGen Face Preset',
{0x000008} 'Respawn',
{0x000010} 'Auto-calc stats',
{0x000020} '',
{0x000040} '',
{0x000080} 'PC Level Mult',
{0x000100} 'Use Template',
{0x000200} 'No Low Level Processing',
{0x000400} '',
{0x000800} 'No Blood Spray',
{0x001000} 'No Blood Decal',
{0x002000} '',
{0x004000} '',
{0x008000} '',
{0x010000} '',
{0x020000} '',
{0x040000} '',
{0x080000} '',
{0x100000} 'No VATS Melee',
{0x00200000} '',
{0x00400000} 'Can be all races',
{0x00800000} '',
{0x01000000} '',
{0x02000000} '',
{0x03000000} 'No Knockdowns',
{0x08000000} 'Not Pushable',
{0x10000000} '', {28}
{0x20000000} '',
{0x40000000} 'No Rotating To Head-track',
{0x80000000} ''
], [
{0x000001 Female} wbActorTemplateUseTraits,
{0x000002 Essential} wbActorTemplateUseBaseData,
{0x000004 Is CharGen Face Preset} nil,
{0x000008 Respawn} wbActorTemplateUseBaseData,
{0x000010 Auto-calc stats} wbActorTemplateUseStats,
{0x000020 } nil,
{0x000040 } nil,
{0x000080 PC Level Mult} wbActorTemplateUseStats,
{0x000100 Use Template} nil,
{0x000200 No Low Level Processing} wbActorTemplateUseBaseData,
{0x000400 } nil,
{0x000800 No Blood Spray} wbActorTemplateUseModelAnimation,
{0x001000 No Blood Decal} wbActorTemplateUseModelAnimation,
{0x002000 } nil,
{0x004000 } nil,
{0x008000 } nil,
{0x010000 } nil,
{0x020000 } nil,
{0x040000 } nil,
{0x080000 } nil,
{0x100000 No VATS Melee} nil,
{0x00200000 } nil,
{0x00400000 Can be all races} nil,
{0x00800000 } nil,
{0x01000000 } nil,
{0x02000000 } nil,
{0x03000000 No Knockdowns} nil,
{0x08000000 Not Pushable} wbActorTemplateUseModelAnimation,
{0x10000000 } nil,
{0x20000000 } nil,
{0x40000000 No Rotating To Head-track} wbActorTemplateUseModelAnimation,
{0x80000000 } nil
])),
{04} wbInteger('Fatigue', itU16, nil, cpNormal, True, wbActorTemplateUseStats),
{06} wbInteger('Barter gold', itU16, nil, cpNormal, False, wbActorTemplateUseAIData),
{08} wbUnion('Level', wbCreaLevelDecider, [
wbInteger('Level', itS16, nil, cpNormal, True, wbActorTemplateUseStats),
wbInteger('Level Mult', itS16, wbDiv(1000), cpNormal, True, wbActorTemplateUseStats)
], cpNormal, True, wbActorTemplateUseStats),
{10} wbInteger('Calc min', itU16, nil, cpNormal, True, wbActorTemplateUseStats),
{12} wbInteger('Calc max', itU16, nil, cpNormal, True, wbActorTemplateUseStats),
{14} wbInteger('Speed Multiplier', itU16, nil, cpNormal, True, wbActorTemplateUseStats),
{16} wbFloat('Karma (Alignment)', cpNormal, False, 1, -1, wbActorTemplateUseTraits),
{20} wbInteger('Disposition Base', itS16, nil, cpNormal, False, wbActorTemplateUseTraits),
{22} wbInteger('Template Flags', itU16, wbTemplateFlags)
], cpNormal, True),
wbRArrayS('Factions',
wbStructSK(SNAM, [0], 'Faction', [
wbFormIDCk('Faction', [FACT]),
wbInteger('Rank', itU8),
wbByteArray('Unused', 3)
]),
cpNormal, False, nil, nil, wbActorTemplateUseFactions),
wbFormIDCk(INAM, 'Death item', [LVLI], False, cpNormal, False, wbActorTemplateUseTraits),
wbFormIDCk(VTCK, 'Voice', [VTYP], False, cpNormal, True, wbActorTemplateUseTraits),
wbFormIDCk(TPLT, 'Template', [LVLN, NPC_]),
wbFormIDCk(RNAM, 'Race', [RACE], False, cpNormal, True, wbActorTemplateUseTraits),
wbSPLOs,
wbFormIDCk(EITM, 'Unarmed Attack Effect', [ENCH, SPEL], False, cpNormal, False, wbActorTemplateUseActorEffectList),
wbInteger(EAMT, 'Unarmed Attack Animation', itU16, wbAttackAnimationEnum, cpNormal, True, False, wbActorTemplateUseActorEffectList),
wbDESTActor,
wbSCRIActor,
wbRArrayS('Items', wbCNTO, cpNormal, False, nil, nil, wbActorTemplateUseInventory),
wbAIDT,
wbRArray('Packages', wbFormIDCk(PKID, 'Package', [PACK]), cpNormal, False, nil, nil, wbActorTemplateUseAIPackages),
wbArrayS(KFFZ, 'Animations', wbStringLC('Animation'), 0, cpNormal, False, nil, nil, wbActorTemplateUseModelAnimation),
wbFormIDCk(CNAM, 'Class', [CLAS], False, cpNormal, True, wbActorTemplateUseTraits),
wbStruct(DATA, '', [
{00} wbInteger('Base Health', itS32),
{04} wbArray('Attributes', wbInteger('Attribute', itU8), [
'Strength',
'Perception',
'Endurance',
'Charisma',
'Intelligence',
'Agility',
'Luck'
], cpNormal, False, wbActorAutoCalcDontShow),
wbByteArray('Unused'{, 14 - only present in old record versions})
], cpNormal, True, wbActorTemplateUseStats),
wbStruct(DNAM, '', [
{00} wbArray('Skill Values', wbInteger('Skill', itU8), [
'Barter',
'Big Guns',
'Energy Weapons',
'Explosives',
'Lockpick',
'Medicine',
'Melee Weapons',
'Repair',
'Science',
'Small Guns',
'Sneak',
'Speech',
'Throwing (unused)',
'Unarmed'
]),
{14} wbArray('Skill Offsets', wbInteger('Skill', itU8), [
'Barter',
'Big Guns',
'Energy Weapons',
'Explosives',
'Lockpick',
'Medicine',
'Melee Weapons',
'Repair',
'Science',
'Small Guns',
'Sneak',
'Speech',
'Throwing (unused)',
'Unarmed'
])
], cpNormal, False, wbActorTemplateUseStatsAutoCalc),
wbRArrayS('Head Parts',
wbFormIDCk(PNAM, 'Head Part', [HDPT]),
cpNormal, False, nil, nil, wbActorTemplateUseModelAnimation),
wbFormIDCk(HNAM, 'Hair', [HAIR], False, cpNormal, False, wbActorTemplateUseModelAnimation),
wbFloat(LNAM, 'Hair length', cpNormal, False, 1, -1, wbActorTemplateUseModelAnimation),
wbFormIDCk(ENAM, 'Eyes', [EYES], False, cpNormal, False, wbActorTemplateUseModelAnimation),
wbStruct(HCLR, 'Hair color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
], cpNormal, True, wbActorTemplateUseModelAnimation),
wbFormIDCk(ZNAM, 'Combat Style', [CSTY], False, cpNormal, False, wbActorTemplateUseTraits),
wbInteger(NAM4, 'Impact Material Type', itU32, wbImpactMaterialTypeEnum, cpNormal, True, False, wbActorTemplateUseModelAnimation),
wbFaceGenNPC,
wbInteger(NAM5, 'Unknown', itU16, nil, cpNormal, True, False, nil, nil, 255),
wbFloat(NAM6, 'Height', cpNormal, True, 1, -1, wbActorTemplateUseTraits),
wbFloat(NAM7, 'Weight', cpNormal, True, 1, -1, wbActorTemplateUseTraits)
], True, nil, cpNormal, False, wbNPCAfterLoad);
wbPKDTFlags := wbFlags([
{0x00000001} 'Offers Services',
{0x00000002} 'Must reach location',
{0x00000004} 'Must complete',
{0x00000008} 'Lock doors at package start',
{0x00000010} 'Lock doors at package end',
{0x00000020} 'Lock doors at location',
{0x00000040} 'Unlock doors at package start',
{0x00000080} 'Unlock doors at package end',
{0x00000100} 'Unlock doors at location',
{0x00000200} 'Continue if PC near',
{0x00000400} 'Once per day',
{0x00000800} '',
{0x00001000} 'Skip fallout behavior',
{0x00002000} 'Always run',
{0x00004000} '',
{0x00008000} '',
{0x00010000} '',
{0x00020000} 'Always sneak',
{0x00040000} 'Allow swimming',
{0x00080000} 'Allow falls',
{0x00100000} 'Head-Tracking off',
{0x00200000} 'Weapons unequipped',
{0x00400000} 'Defensive combat',
{0x00800000} 'Weapon Drawn',
{0x01000000} 'No idle anims',
{0x02000000} 'Pretend In Combat',
{0x04000000} 'Continue During Combat',
{0x08000000} 'No Combat Alert',
{0x10000000} 'No Warn/Attack Behaviour',
{0x20000000} '',
{0x40000000} '',
{0x80000000} ''
]);
wbPKDTType := wbEnum([
{0} 'Find',
{1} 'Follow',
{2} 'Escort',
{3} 'Eat',
{4} 'Sleep',
{5} 'Wander',
{6} 'Travel',
{7} 'Accompany',
{8} 'Use Item At',
{9} 'Ambush',
{10} 'Flee Not Combat',
{11} '',
{12} 'Sandbox',
{13} 'Patrol',
{14} 'Guard',
{15} 'Dialogue',
{16} 'Use Weapon'
]);
wbObjectTypeEnum := wbEnum([
' NONE',
'Activators',
'Armor',
'Books',
'Clothing',
'Containers',
'Doors',
'Ingredients',
'Lights',
'Misc',
'Flora',
'Furniture',
'Weapons: Any',
'Ammo',
'NPCs',
'Creatures',
'Keys',
'Alchemy',
'Food',
' All: Combat Wearable',
' All: Wearable',
'Weapons: Ranged',
'Weapons: Melee',
'Weapons: NONE',
'Actor Effects: Any',
'Actor Effects: Range Target',
'Actor Effects: Range Touch',
'Actor Effects: Range Self',
'',
'Actors: Any'
]);
wbPKDTSpecificFlagsUnused := True;
wbRecord(PACK, 'Package', [
wbEDIDReq,
wbStruct(PKDT, 'General', [
wbInteger('General Flags', itU32, wbPKDTFlags),
wbInteger('Type', itU8, wbPKDTType),
wbByteArray('Unused', 1),
wbInteger('Fallout Behavior Flags', itU16, wbFlags([
{0x00000001}'Hellos To Player',
{0x00000002}'Random Conversations',
{0x00000004}'Observe Combat Behavior',
{0x00000008}'Unknown 4',
{0x00000010}'Reaction To Player Actions',
{0x00000020}'Friendly Fire Comments',
{0x00000040}'Aggro Radius Behavior',
{0x00000080}'Allow Idle Chatter',
{0x00000100}'Avoid Radiation'
], True)),
wbUnion('Type Specific Flags', wbPKDTSpecificFlagsDecider, [
wbEmpty('Type Specific Flags (missing)', cpIgnore, False, nil, True),
wbInteger('Type Specific Flags - Find', itU16, wbFlags([
{0x00000001}'',
{0x00000002}'',
{0x00000004}'',
{0x00000008}'',
{0x00000010}'',
{0x00000020}'',
{0x00000040}'',
{0x00000080}'',
{0x00000100}'Find - Allow Buying',
{0x00000200}'Find - Allow Killing',
{0x00000400}'Find - Allow Stealing'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Follow', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Escort', itU16, wbFlags([
{0x00000001}'',
{0x00000002}'',
{0x00000004}'',
{0x00000008}'',
{0x00000010}'',
{0x00000020}'',
{0x00000040}'',
{0x00000080}'',
{0x00000100}'Escort - Allow Buying',
{0x00000200}'Escort - Allow Killing',
{0x00000400}'Escort - Allow Stealing'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Eat', itU16, wbFlags([
{0x00000001}'',
{0x00000002}'',
{0x00000004}'',
{0x00000008}'',
{0x00000010}'',
{0x00000020}'',
{0x00000040}'',
{0x00000080}'',
{0x00000100}'Eat - Allow Buying',
{0x00000200}'Eat - Allow Killing',
{0x00000400}'Eat - Allow Stealing'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Sleep', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Wander', itU16, wbFlags([
{0x00000001}'Wander - No Eating',
{0x00000002}'Wander - No Sleeping',
{0x00000004}'Wander - No Conversation',
{0x00000008}'Wander - No Idle Markers',
{0x00000010}'Wander - No Furniture',
{0x00000020}'Wander - No Wandering'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Travel', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Accompany', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Use Item At', itU16, wbFlags([
{0x00000001}'',
{0x00000002}'Use Item At - Sit Down',
{0x00000004}'',
{0x00000008}'',
{0x00000010}'',
{0x00000020}'',
{0x00000040}'',
{0x00000080}'',
{0x00000100}'Use Item At - Allow Buying',
{0x00000200}'Use Item At - Allow Killing',
{0x00000400}'Use Item At - Allow Stealing'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Ambush', itU16, wbFlags([
{0x00000001}'Ambush - Hide While Ambushing'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Flee Not Combat', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - ?', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Sandbox', itU16, wbFlags([
{0x00000001}'Sandbox - No Eating',
{0x00000002}'Sandbox - No Sleeping',
{0x00000004}'Sandbox - No Conversation',
{0x00000008}'Sandbox - No Idle Markers',
{0x00000010}'Sandbox - No Furniture',
{0x00000020}'Sandbox - No Wandering'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Patrol', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Guard', itU16, wbFlags([
{0x00000001}'',
{0x00000002}'',
{0x00000004}'Guard - Remain Near Reference to Guard'
], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Dialogue', itU16, wbFlags([], wbPKDTSpecificFlagsUnused)),
wbInteger('Type Specific Flags - Use Weapon', itU16, wbFlags([], wbPKDTSpecificFlagsUnused))
]),
wbByteArray('Unused', 2)
], cpNormal, True, nil, 2),
wbRStruct('Locations', [
wbStruct(PLDT, 'Location 1', [
wbInteger('Type', itS32, wbEnum([ // Byte + filler
{0} 'Near reference',
{1} 'In cell',
{2} 'Near current location',
{3} 'Near editor location',
{4} 'Object ID',
{5} 'Object Type',
{6} 'Near linked reference',
{7} 'At package location'
])),
wbUnion('Location', wbPxDTLocationDecider, [
wbFormIDCkNoReach('Reference', [REFR, PGRE, PMIS, PBEA, ACHR, ACRE, PLYR], True),
wbFormIDCkNoReach('Cell', [CELL]),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbFormIDCkNoReach('Object ID', [ACTI, DOOR, STAT, FURN, CREA, SPEL, NPC_, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH]),
wbInteger('Object Type', itU32, wbObjectTypeEnum),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore)
]),
wbInteger('Radius', itS32)
]),
wbStruct(PLD2, 'Location 2', [
wbInteger('Type', itS32, wbEnum([
{0} 'Near reference',
{1} 'In cell',
{2} 'Near current location',
{3} 'Near editor location',
{4} 'Object ID',
{5} 'Object Type',
{6} 'Near linked reference',
{7} 'At package location'
])),
wbUnion('Location', wbPxDTLocationDecider, [
wbFormIDCkNoReach('Reference', [REFR, PGRE, PMIS, PBEA, ACHR, ACRE, PLYR], True),
wbFormIDCkNoReach('Cell', [CELL]),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbFormIDCkNoReach('Object ID', [ACTI, DOOR, STAT, FURN, CREA, SPEL, NPC_, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH]),
wbInteger('Object Type', itU32, wbObjectTypeEnum),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore)
]),
wbInteger('Radius', itS32)
])
], []),
wbStruct(PSDT, 'Schedule', [
wbInteger('Month', itS8),
wbInteger('Day of week', itS8, wbEnum([
'Sunday',
'Monday',
'Tuesday',
'Wednesday',
'Thursday',
'Friday',
'Saturday',
'Weekdays',
'Weekends',
'Monday, Wednesday, Friday',
'Tuesday, Thursday'
], [
-1, 'Any'
])),
wbInteger('Date', itU8),
wbInteger('Time', itS8),
wbInteger('Duration', itS32)
], cpNormal, True),
wbStruct(PTDT, 'Target 1', [
wbInteger('Type', itS32, wbEnum([
{0} 'Specific Reference',
{1} 'Object ID',
{2} 'Object Type',
{3} 'Linked Reference'
]), cpNormal, False, nil, nil, 2),
wbUnion('Target', wbPxDTLocationDecider, [
wbFormIDCkNoReach('Reference', [ACHR, ACRE, REFR, PGRE, PMIS, PBEA, PLYR], True),
wbFormIDCkNoReach('Object ID', [ACTI, DOOR, STAT, FURN, CREA, SPEL, NPC_, LVLN, LVLC, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, FACT, FLST]),
wbInteger('Object Type', itU32, wbObjectTypeEnum),
wbByteArray('Unused', 4, cpIgnore)
]),
wbInteger('Count / Distance', itS32),
wbFloat('Unknown')
], cpNormal, False, nil, 3),
wbCTDAs,
wbRStruct('Idle Animations', [
wbInteger(IDLF, 'Flags', itU8, wbFlags([
'Run in Sequence',
'',
'Do Once'
]), cpNormal, True),
wbStruct(IDLC, '', [
wbInteger( 'Animation Count', itU8),
wbByteArray('Unused', 3)
], cpNormal, True, nil, 1),
wbFloat(IDLT, 'Idle Timer Setting', cpNormal, True),
wbArray(IDLA, 'Animations', wbFormIDCk('Animation', [IDLE]), 0, nil, wbIDLAsAfterSet, cpNormal, True),
wbByteArray(IDLB, 'Unused', 4, cpIgnore)
], [], cpNormal, False, nil, False, nil {cannot be totally removed , wbAnimationsAfterSet}),
wbFormIDCk(CNAM, 'Combat Style', [CSTY]),
wbEmpty(PKED, 'Eat Marker'),
wbInteger(PKE2, 'Escort Distance', itU32),
wbFloat(PKFD, 'Follow - Start Location - Trigger Radius'),
wbStruct(PKPT, 'Patrol Flags', [
wbInteger('Repeatable', itU8, wbEnum(['No', 'Yes']), cpNormal, False, nil, nil, 1),
wbByteArray('Unused', 1)
], cpNormal, False, nil, 1),
wbStruct(PKW3, 'Use Weapon Data', [
wbInteger('Flags', itU32, wbFlags([
'Always Hit',
'',
'',
'',
'',
'',
'',
'',
'Do No Damage',
'',
'',
'',
'',
'',
'',
'',
'Crouch To Reload',
'',
'',
'',
'',
'',
'',
'',
'Hold Fire When Blocked'
])),
wbInteger('Fire Rate', itU8, wbEnum([
'Auto Fire',
'Volley Fire'
])),
wbInteger('Fire Count', itU8, wbEnum([
'Number of Bursts',
'Repeat Fire'
])),
wbInteger('Number of Bursts', itU16),
wbStruct('Shoots Per Volleys', [
wbInteger('Min', itU16),
wbInteger('Max', itU16)
]),
wbStruct('Pause Between Volleys', [
wbFloat('Min'),
wbFloat('Max')
]),
wbByteArray('Unused', 4)
]),
wbStruct(PTD2, 'Target 2', [
wbInteger('Type', itS32, wbEnum([
{0} 'Specific reference',
{1} 'Object ID',
{2} 'Object Type',
{3} 'Linked Reference'
])),
wbUnion('Target', wbPxDTLocationDecider, [
wbFormIDCkNoReach('Reference', [ACHR, ACRE, REFR, PGRE, PMIS, PBEA, PLYR], True),
wbFormIDCkNoReach('Object ID', [ACTI, DOOR, STAT, FURN, CREA, SPEL, NPC_, LVLN, LVLC, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH, FACT, FLST]),
wbInteger('Object Type', itU32, wbObjectTypeEnum),
wbByteArray('Unused', 4, cpIgnore)
]),
wbInteger('Count / Distance', itS32),
wbFloat('Unknown')
], cpNormal, False, nil, 3),
wbEmpty(PUID, 'Use Item Marker'),
wbEmpty(PKAM, 'Ambush Marker'),
wbStruct(PKDD, 'Dialogue Data', [
wbFloat('FOV'),
wbFormIDCk('Topic', [DIAL, NULL]),
wbInteger('Flags', itU32, wbFlags([
'No Headtracking',
'',
'',
'',
'',
'',
'',
'',
'Don''t Control Target Movement'
])),
wbByteArray('Unused', 4),
wbInteger('Dialogue Type', itU32, wbEnum([
'Conversation',
'Say To'
])),
wbByteArray('Unknown', 4)
], cpNormal, False, nil, 3),
wbStruct(PLD2, 'Location 2 (again??)', [
wbInteger('Type', itS32, wbEnum([
{0} 'Near reference',
{1} 'In cell',
{2} 'Near current location',
{3} 'Near editor location',
{4} 'Object ID',
{5} 'Object Type',
{6} 'Near linked reference',
{7} 'At package location'
])),
wbUnion('Location', wbPxDTLocationDecider, [
wbFormIDCkNoReach('Reference', [REFR, PGRE, PMIS, PBEA, ACHR, ACRE, PLYR], True),
wbFormIDCkNoReach('Cell', [CELL]),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore),
wbFormIDCkNoReach('Object ID', [ACTI, DOOR, STAT, FURN, CREA, SPEL, NPC_, CONT, ARMO, AMMO, MISC, WEAP, BOOK, KEYM, ALCH, LIGH]),
wbInteger('Object Type', itU32, wbObjectTypeEnum),
wbByteArray('Unused', 4, cpIgnore),
wbByteArray('Unused', 4, cpIgnore)
]),
wbInteger('Radius', itS32)
]),
wbRStruct('OnBegin', [
wbEmpty(POBA, 'OnBegin Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], [], cpNormal, True),
wbRStruct('OnEnd', [
wbEmpty(POEA, 'OnEnd Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], [], cpNormal, True),
wbRStruct('OnChange', [
wbEmpty(POCA, 'OnChange Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], [], cpNormal, True)
], False, nil, cpNormal, False, wbPACKAfterLoad);
wbRecord(QUST, 'Quest', [
wbEDIDReq,
wbSCRI,
wbFULL,
wbICON,
wbStruct(DATA, 'General', [
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Start game enabled',
{0x02} '',
{0x04} 'Allow repeated conversation topics',
{0x08} 'Allow repeated stages',
{0x10} 'Unknown 4'
])),
wbInteger('Priority', itU8),
wbByteArray('Unused', 2),
wbFloat('Quest Delay')
], cpNormal, True, nil, 3),
wbCTDAs,
wbRArrayS('Stages', wbRStructSK([0], 'Stage', [
wbInteger(INDX, 'Stage Index', itS16),
wbRArray('Log Entries', wbRStruct('Log Entry', [
wbInteger(QSDT, 'Stage Flags', itU8, wbFlags([
{0x01} 'Complete Quest',
{0x02} 'Fail Quest'
])),
wbCTDAs,
wbString(CNAM, 'Log Entry', 0, cpTranslate),
wbEmbeddedScriptReq,
wbFormIDCk(NAM0, 'Next Quest', [QUST])
], []))
], [])),
wbRArray('Objectives', wbRStruct('Objective', [
wbInteger(QOBJ, 'Objective Index', itS32),
wbString(NNAM, 'Description', 0, cpNormal, True),
wbRArray('Targets', wbRStruct('Target', [
wbStruct(QSTA, 'Target', [
wbFormIDCkNoReach('Target', [REFR, PGRE, PMIS, PBEA, ACRE, ACHR], True),
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Compass Marker Ignores Locks'
])),
wbByteArray('Unused', 3)
]),
wbCTDAs
], []))
], []))
]);
wbHeadPartIndexEnum := wbEnum([
'Head',
'Ears',
'Mouth',
'Teeth Lower',
'Teeth Upper',
'Tongue',
'Left Eye',
'Right Eye'
]);
wbBodyPartIndexEnum := wbEnum([
'Upper Body',
'Left Hand',
'Right Hand',
'Upper Body Texture'
]);
wbRecord(RACE, 'Race', [
wbEDIDReq,
wbFULLReq,
wbDESCReq,
wbXNAMs,
wbStruct(DATA, '', [
wbArrayS('Skill Boosts', wbStructSK([0], 'Skill Boost', [
wbInteger('Skill', itS8, wbActorValueEnum),
wbInteger('Boost', itS8)
]), 7),
wbByteArray('Unused', 2),
wbFloat('Male Height'),
wbFloat('Female Height'),
wbFloat('Male Weight'),
wbFloat('Female Weight'),
wbInteger('Flags', itU32, wbFlags([
'Playable',
'',
'Child'
]))
], cpNormal, True),
wbFormIDCk(ONAM, 'Older', [RACE]),
wbFormIDCk(YNAM, 'Younger', [RACE]),
wbEmpty(NAM2, 'Unknown Marker', cpNormal, True),
wbArray(VTCK, 'Voices', wbFormIDCk('Voice', [VTYP]), ['Male', 'Female'], cpNormal, True),
wbArray(DNAM, 'Default Hair Styles', wbFormIDCk('Default Hair Style', [HAIR, NULL]), ['Male', 'Female'], cpNormal, True),
wbArray(CNAM, 'Default Hair Colors', wbInteger('Default Hair Color', itU8, wbEnum([
'Bleached',
'Brown',
'Chocolate',
'Platinum',
'Cornsilk',
'Suede',
'Pecan',
'Auburn',
'Ginger',
'Honey',
'Gold',
'Rosewood',
'Black',
'Chestnut',
'Steel',
'Champagne'
])), ['Male', 'Female'], cpNormal, True),
wbFloat(PNAM, 'FaceGen - Main clamp', cpNormal, True),
wbFloat(UNAM, 'FaceGen - Face clamp', cpNormal, True),
wbByteArray(ATTR, 'Unused', 0, cpNormal, True),
wbRStruct('Head Data', [
wbEmpty(NAM0, 'Head Data Marker', cpNormal, True),
wbRStruct('Male Head Data', [
wbEmpty(MNAM, 'Male Data Marker', cpNormal, True),
wbRArrayS('Parts', wbRStructSK([0], 'Part', [
wbInteger(INDX, 'Index', itU32, wbHeadPartIndexEnum),
wbMODLReq,
wbICON
], [], cpNormal, False, nil, False, nil, wbHeadPartsAfterSet), cpNormal, True)
], [], cpNormal, True),
wbRStruct('Female Head Data', [
wbEmpty(FNAM, 'Female Data Marker', cpNormal, True),
wbRArrayS('Parts', wbRStructSK([0], 'Part', [
wbInteger(INDX, 'Index', itU32, wbHeadPartIndexEnum),
wbMODLReq,
wbICON
], [], cpNormal, False, nil, False, nil, wbHeadPartsAfterSet), cpNormal, True)
], [], cpNormal, True)
], [], cpNormal, True),
wbRStruct('Body Data', [
wbEmpty(NAM1, 'Body Data Marker', cpNormal, True),
wbRStruct('Male Body Data', [
wbEmpty(MNAM, 'Male Data Marker'),
wbRArrayS('Parts', wbRStructSK([0], 'Part', [
wbInteger(INDX, 'Index', itU32, wbBodyPartIndexEnum),
wbICON,
wbMODLReq
], []), cpNormal, True)
], [], cpNormal, True),
wbRStruct('Female Body Data', [
wbEmpty(FNAM, 'Female Data Marker', cpNormal, True),
wbRArrayS('Parts', wbRStructSK([0], 'Part', [
wbInteger(INDX, 'Index', itU32, wbBodyPartIndexEnum),
wbICON,
wbMODLReq
], []), cpNormal, True)
], [], cpNormal, True)
], [], cpNormal, True),
wbArrayS(HNAM, 'Hairs', wbFormIDCk('Hair', [HAIR]), 0, cpNormal, True),
wbArrayS(ENAM, 'Eyes', wbFormIDCk('Eye', [EYES]), 0, cpNormal, True),
wbRStruct('FaceGen Data', [
wbRStruct('Male FaceGen Data', [
wbEmpty(MNAM, 'Male Data Marker', cpNormal, True),
wbFaceGen,
wbUnknown(SNAM, cpNormal, True)
], [], cpNormal, True),
wbRStruct('Female FaceGen Data', [
wbEmpty(FNAM, 'Female Data Marker', cpNormal, True),
wbFaceGen,
wbUnknown(SNAM, cpNormal, True)
], [], cpNormal, True)
], [], cpNormal, True)
]);
wbRecord(REFR, 'Placed Object', [
wbEDID,
{
wbStruct(RCLR, 'Linked Reference Color (Old Format?)', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
], cpIgnore),}
wbByteArray(RCLR, 'Unused', 0, cpIgnore),
wbFormIDCk(NAME, 'Base', [TREE, SOUN, ACTI, DOOR, STAT, FURN, CONT, ARMO, AMMO, LVLN, LVLC,
MISC, WEAP, BOOK, KEYM, ALCH, LIGH, GRAS, ASPC, IDLM, ARMA,
MSTT, NOTE, PWAT, SCOL, TACT, TERM, TXST], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
{--- ?? ---}
wbXRGD,
wbXRGB,
{--- Primitive ---}
wbStruct(XPRM, 'Primitive', [
wbStruct('Bounds', [
wbFloat('X', cpNormal, True, 2, 4),
wbFloat('Y', cpNormal, True, 2, 4),
wbFloat('Z', cpNormal, True, 2, 4)
]),
wbStruct('Color', [
{84} wbFloat('Red', cpNormal, False, 255, 0),
{88} wbFloat('Green', cpNormal, False, 255, 0),
{92} wbFloat('Blue', cpNormal, False, 255, 0)
]),
wbFloat('Unknown'),
wbInteger('Type', itU32, wbEnum([
'None',
'Box',
'Sphere',
'Portal Box'
]))
]),
wbInteger(XTRI, 'Collision Layer', itU32, wbEnum([
'Unidentified',
'Static',
'AnimStatic',
'Transparent',
'Clutter',
'Weapon',
'Projectile',
'Spell',
'Biped',
'Trees',
'Props',
'Water',
'Trigger',
'Terrain',
'Trap',
'Non Collidable',
'Cloud Trap',
'Ground',
'Portal',
'Debris Small',
'Debris Large',
'Acustic Space',
'Actor Zone',
'Projectile Zone',
'Gas Trap',
'Shell Casing',
'Transparent Small',
'Invisible Wall',
'Transparent Small Anim',
'Dead Bip',
'Char Controller',
'Avoid Box',
'Collision Box',
'Camera Sphere',
'Door Detection',
'Camera Pick',
'Item Pick',
'Line Of Sight',
'Path Pick',
'Custom Pick 1',
'Custom Pick 2',
'Spell Explosion',
'Dropping Pick'
])),
wbEmpty(XMBP, 'MultiBound Primitive Marker'),
{--- Bound Contents ---}
{--- Bound Data ---}
wbStruct(XMBO, 'Bound Half Extents', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
{--- Teleport ---}
wbStruct(XTEL, 'Teleport Destination', [
wbFormIDCk('Door', [REFR], True),
wbPosRot,
wbInteger('Flags', itU32, wbFlags([
'No Alarm'
]))
]),
{--- Map Data ---}
wbRStruct('Map Marker', [
wbEmpty(XMRK, 'Map Marker Data'),
wbInteger(FNAM, 'Flags', itU8, wbFlags([
{0x01} 'Visible',
{0x02} 'Can Travel To',
{0x04} '"Show All" Hidden'
]), cpNormal, True),
wbFULLReq,
wbStruct(TNAM, '', [
wbInteger('Type', itU8, wbEnum([
'None',
'City',
'Settlement',
'Encampment',
'Natural Landmark',
'Cave',
'Factory',
'Monument',
'Military',
'Office',
'Town Ruins',
'Urban Ruins',
'Sewer Ruins',
'Metro',
'Vault'
])),
wbByteArray('Unused', 1)
], cpNormal, True)
], []),
wbInteger(XSRF, 'Special Rendering Flags', itU32, wbFlags([
'Unknown 0',
'Imposter',
'Use Full Shader in LOD'
])),
wbByteArray(XSRD, 'Special Rendering Data', 4),
{--- X Target Data ---}
wbFormIDCk(XTRG, 'Target', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA], True),
{--- Leveled Actor ----}
wbXLCM,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbEmbeddedScriptReq,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal, True)
], []),
{--- Radio ---}
wbStruct(XRDO, 'Radio Data', [
wbFloat('Range Radius'),
wbInteger('Broadcast Range Type', itU32, wbEnum([
'Radius',
'Everywhere',
'Worldspace and Linked Interiors',
'Linked Interiors',
'Current Cell Only'
])),
wbFloat('Static Percentage'),
wbFormIDCkNoReach('Position Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, NULL])
]),
{--- Ownership ---}
wbRStruct('Ownership', [
wbXOWN,
wbInteger(XRNK, 'Faction rank', itS32)
], [XCMT, XCMO]),
{--- Lock ---}
wbStruct(XLOC, 'Lock Data', [
wbInteger('Level', itU8),
wbByteArray('Unused', 3),
wbFormIDCkNoReach('Key', [KEYM, NULL]),
wbInteger('Flags', itU8, wbFlags(['', '', 'Leveled Lock'])),
wbByteArray('Unused', 3),
wbByteArray('Unknown', 8)
], cpNormal, False, nil, 5),
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbFloat(XHLP, 'Health'),
wbFloat(XRAD, 'Radiation'),
wbFloat(XCHG, 'Charge'),
wbRStruct('Ammo', [
wbFormIDCk(XAMT, 'Type', [AMMO], False, cpNormal, True),
wbInteger(XAMC, 'Count', itS32, nil, cpNormal, True)
], []),
{--- Reflected By / Refracted By ---}
wbRArrayS('Reflected/Refracted By',
wbStructSK(XPWR, [0], 'Water', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Type', itU32, wbFlags([
'Reflection',
'Refraction'
]))
])
),
{--- Lit Water ---}
wbRArrayS('Lit Water',
wbFormIDCk(XLTW, 'Water', [REFR])
),
{--- Decals ---}
wbRArrayS('Linked Decals',
wbStructSK(XDCR, [0], 'Decal', [
wbFormIDCk('Reference', [REFR]),
wbUnknown
])
),
{--- Linked Ref ---}
wbFormIDCk(XLKR, 'Linked Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbStruct(XCLP, 'Linked Reference Color', [
wbStruct('Link Start Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Link End Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
])
]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', [REFR, ACRE, ACHR, PGRE, PMIS, PBEA, PLYR]),
wbFloat('Delay')
])
)
], []),
{--- Enable Parent ---}
wbXESP,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Flags ---}
wbInteger(XACT, 'Action Flag', itU32, wbFlags([
'Use Default',
'Activate',
'Open',
'Open by Default'
])),
wbEmpty(ONAM, 'Open by Default'),
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- Generated Data ---}
wbStruct(XNDP, 'Navigation Door Link', [
wbFormIDCk('Navigation Mesh', [NAVM]),
wbInteger('Teleport Marker Triangle', itS16, wbREFRNavmeshTriangleToStr, wbStringToInt),
wbByteArray('Unused', 2)
]),
wbArray(XPOD, 'Portal Data', wbFormIDCk('Room', [REFR, NULL]), 2),
wbStruct(XPTL, 'Portal Data', [
wbStruct('Size', [
wbFloat('Width', cpNormal, False, 2),
wbFloat('Height', cpNormal, False, 2)
]),
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation (Quaternion?)', [
wbFloat('q1'),
wbFloat('q2'),
wbFloat('q3'),
wbFloat('q4')
])
]),
wbInteger(XSED, 'SpeedTree Seed', itU8),
wbRStruct('Room Data', [
wbStruct(XRMR, 'Header', [
wbInteger('Linked Rooms Count', itU16),
wbByteArray('Unknown', 2)
]),
wbRArrayS('Linked Rooms',
wbFormIDCk(XLRM, 'Linked Room', [REFR])
)
], []),
wbStruct(XOCP, 'Occlusion Plane Data', [
wbStruct('Size', [
wbFloat('Width', cpNormal, False, 2),
wbFloat('Height', cpNormal, False, 2)
]),
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation (Quaternion?)', [
wbFloat('q1'),
wbFloat('q2'),
wbFloat('q3'),
wbFloat('q4')
])
]),
wbArray(XORD, 'Linked Occlusion Planes', wbFormIDCk('Plane', [REFR, NULL]), [
'Right',
'Left',
'Bottom',
'Top'
]),
wbXLOD,
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot
], True, wbPlacedAddInfo, cpNormal, False, wbREFRAfterLoad);
wbRecord(REGN, 'Region', [
wbEDID,
wbICON,
wbStruct(RCLR, 'Map Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
], cpNormal, True),
wbFormIDCkNoReach(WNAM, 'Worldspace', [WRLD]),
wbRArray('Region Areas', wbRStruct('Region Area', [
wbInteger(RPLI, 'Edge Fall-off', itU32),
wbArray(RPLD, 'Region Point List Data', wbStruct('Point', [
wbFloat('X'),
wbFloat('Y')
]), 0, wbRPLDAfterLoad)
], [])),
wbRArrayS('Region Data Entries', wbRStructSK([0], 'Region Data Entry', [
{always starts with an RDAT}
wbStructSK(RDAT, [0], 'Data Header', [
wbInteger('Type', itU32, wbEnum([
{0}'',
{1}'',
{2}'Objects',
{3}'Weather',
{4}'Map',
{5}'Land',
{6}'Grass',
{7}'Sound',
{8}'',
{9}''
])),
wbInteger('Flags', itU8, wbFlags([
'Override'
])),
wbInteger('Priority', itU8),
wbByteArray('Unused')
], cpNormal, True),
{followed by one of these: }
{--- Objects ---}
wbArray(RDOT, 'Objects', wbStruct('Object', [
wbFormIDCk('Object', [TREE, STAT, LTEX]),
wbInteger('Parent Index', itU16, wbHideFFFF),
wbByteArray('Unused', 2),
wbFloat('Density'),
wbInteger('Clustering', itU8),
wbInteger('Min Slope', itU8),
wbInteger('Max Slope', itU8),
wbInteger('Flags', itU8, wbFlags([
{0}'Conform to slope',
{1}'Paint Vertices',
{2}'Size Variance +/-',
{3}'X +/-',
{4}'Y +/-',
{5}'Z +/-',
{6}'Tree',
{7}'Huge Rock'
])),
wbInteger('Radius wrt Parent', itU16),
wbInteger('Radius', itU16),
wbFloat('Min Height'),
wbFloat('Max Height'),
wbFloat('Sink'),
wbFloat('Sink Variance'),
wbFloat('Size Variance'),
wbStruct('Angle Variance', [
wbInteger('X', itU16),
wbInteger('Y', itU16),
wbInteger('Z', itU16)
]),
wbByteArray('Unused', 2),
wbByteArray('Unknown', 4)
]), 0, nil, nil, cpNormal, False, wbREGNObjectsDontShow),
{--- Map ---}
wbString(RDMP, 'Map Name', 0, cpTranslate, False, wbREGNMapDontShow),
{--- Grass ---}
wbArrayS(RDGS, 'Grasses', wbStructSK([0], 'Grass', [
wbFormIDCk('Grass', [GRAS]),
wbByteArray('Unknown',4)
]), 0, cpNormal, False, nil, nil, wbREGNGrassDontShow),
{--- Sound ---}
wbInteger(RDMD, 'Music Type', itU32, wbMusicEnum, cpIgnore, False, False, wbNeverShow),
wbFormIDCk(RDMO, 'Music', [MUSC], False, cpNormal, False, wbREGNSoundDontShow),
wbArrayS(RDSD, 'Sounds', wbStructSK([0], 'Sound', [
wbFormIDCk('Sound', [SOUN]),
wbInteger('Flags', itU32, wbFlags([
'Pleasant',
'Cloudy',
'Rainy',
'Snowy'
])),
wbInteger('Chance', itU32, wbScaledInt4ToStr, wbScaledInt4ToInt)
]), 0, cpNormal, False, nil, nil, wbREGNSoundDontShow),
{--- Weather ---}
wbArrayS(RDWT, 'Weather Types', wbStructSK([0], 'Weather Type', [
wbFormIDCk('Weather', [WTHR]),
wbInteger('Chance', itU32),
wbFormIDCk('Global', [GLOB, NULL])
]), 0, cpNormal, False, nil, nil, wbREGNWeatherDontShow)
], []))
], True);
wbRecord(SOUN, 'Sound', [
wbEDIDReq,
wbOBNDReq,
wbString(FNAM, 'Sound Filename'),
wbRUnion('Sound Data', [
wbStruct(SNDD, 'Sound Data', [
wbInteger('Minimum Attentuation Distance', itU8, wbMul(5)),
wbInteger('Maximum Attentuation Distance', itU8, wbMul(100)),
wbInteger('Frequency Adjustment %', itS8),
wbByteArray('Unused', 1),
wbInteger('Flags', itU32, wbFlags([
{0x0001} 'Random Frequency Shift',
{0x0002} 'Play At Random',
{0x0004} 'Environment Ignored',
{0x0008} 'Random Location',
{0x0010} 'Loop',
{0x0020} 'Menu Sound',
{0x0040} '2D',
{0x0080} '360 LFE',
{0x0100} 'Dialogue Sound',
{0x0200} 'Envelope Fast',
{0x0400} 'Envelope Slow',
{0x0800} '2D Radius',
{0x1000} 'Mute When Submerged'
])),
wbInteger('Static attentuation cdB', itS16),
wbInteger('Stop time ', itU8),
wbInteger('Start time ', itU8),
wbArray('Attenuation Curve', wbInteger('Point', itS16), 5),
wbInteger('Reverb Attenuation Control', itS16),
wbInteger('Priority', itS32),
wbByteArray('Unknown', 8)
], cpNormal, True),
wbStruct(SNDX, 'Sound Data', [
wbInteger('Minimum attentuation distance', itU8, wbMul(5)),
wbInteger('Maximum attentuation distance', itU8, wbMul(100)),
wbInteger('Frequency adjustment %', itS8),
wbByteArray('Unused', 1),
wbInteger('Flags', itU32, wbFlags([
{0x0001} 'Random Frequency Shift',
{0x0002} 'Play At Random',
{0x0004} 'Environment Ignored',
{0x0008} 'Random Location',
{0x0010} 'Loop',
{0x0020} 'Menu Sound',
{0x0040} '2D',
{0x0080} '360 LFE',
{0x0100} 'Dialogue Sound',
{0x0200} 'Envelope Fast',
{0x0400} 'Envelope Slow',
{0x0800} '2D Radius',
{0x1000} 'Mute When Submerged'
])),
wbInteger('Static attentuation cdB', itS16),
wbInteger('Stop time ', itU8),
wbInteger('Start time ', itU8)
], cpNormal, True)
], [], cpNormal, True),
wbArray(ANAM, 'Attenuation Curve', wbInteger('Point', itS16), 5, nil, nil, cpNormal, False, wbNeverShow),
wbInteger(GNAM, 'Reverb Attenuation Control', itS16, nil, cpNormal, False, False, wbNeverShow),
wbInteger(HNAM, 'Priority', itS32, nil, cpNormal, False, False, wbNeverShow)
], False, nil, cpNormal, False, wbSOUNAfterLoad);
wbRecord(SPEL, 'Actor Effect', [
wbEDIDReq,
wbFULL,
wbStruct(SPIT, '', [
wbInteger('Type', itU32, wbEnum([
{0} 'Actor Effect',
{1} 'Disease',
{2} 'Power',
{3} 'Lesser Power',
{4} 'Ability',
{5} 'Poison',
{6} '',
{7} '',
{8} '',
{9} '',
{10} 'Addiction'
])),
wbInteger('Cost (Unused)', itU32),
wbInteger('Level (Unused)', itU32, wbEnum([
{0} 'Unused'
])),
wbInteger('Flags', itU8, wbFlags([
{0x00000001} 'No Auto-Calc',
{0x00000002} 'Immune to Silence 1?',
{0x00000004} 'PC Start Effect',
{0x00000008} 'Immune to Silence 2?',
{0x00000010} 'Area Effect Ignores LOS',
{0x00000020} 'Script Effect Always Applies',
{0x00000040} 'Disable Absorb/Reflect',
{0x00000080} 'Force Touch Explode'
])),
wbByteArray('Unused', 3)
], cpNormal, True),
wbEffectsReq
]);
wbRecord(STAT, 'Static', [
wbEDIDReq,
wbOBNDReq,
wbMODL
]);
wbRecord(TES4, 'Main File Header', [
wbStruct(HEDR, 'Header', [
wbFloat('Version'),
wbInteger('Number of Records', itU32),
wbInteger('Next Object ID', itU32)
], cpNormal, True),
wbByteArray(OFST, 'Unknown', 0, cpIgnore),
wbByteArray(DELE, 'Unknown', 0, cpIgnore),
wbString(CNAM, 'Author', 0, cpTranslate, True),
wbString(SNAM, 'Description', 0, cpTranslate),
wbRArray('Master Files', wbRStruct('Master File', [
wbString(MAST, 'Filename', 0, cpNormal, True),
wbByteArray(DATA, 'Unused', 8, cpIgnore, True)
], [ONAM])),
wbArray(ONAM, 'Overriden Forms', wbFormIDCk('Form', [REFR, ACHR, ACRE, PMIS, PBEA, PGRE, LAND, NAVM]), 0, nil, nil, cpNormal, False, wbTES4ONAMDontShow),
wbByteArray(SCRN, 'Screenshot')
], True, nil, cpNormal, True, wbRemoveOFST);
wbRecord(TREE, 'Tree', [
wbEDIDReq,
wbOBNDReq,
wbMODLReq,
wbICONReq,
wbArrayS(SNAM, 'SpeedTree Seeds', wbInteger('SpeedTree Seed', itU32), 0, cpNormal, True),
wbStruct(CNAM, 'Tree Data', [
wbFloat('Leaf Curvature'),
wbFloat('Minimum Leaf Angle'),
wbFloat('Maximum Leaf Angle'),
wbFloat('Branch Dimming Value'),
wbFloat('Leaf Dimming Value'),
wbInteger('Shadow Radius', itS32),
wbFloat('Rock Speed'),
wbFloat('Rustle Speed')
], cpNormal, True),
wbStruct(BNAM, 'Billboard Dimensions', [
wbFloat('Width'),
wbFloat('Height')
], cpNormal, True)
]);
end;
procedure DefineFO3f;
begin
wbRecord(WATR, 'Water', [
wbEDIDReq,
wbFULL,
wbString(NNAM, 'Noise Map', 0, cpNormal, True),
wbInteger(ANAM, 'Opacity', itU8, nil, cpNormal, True),
wbInteger(FNAM, 'Flags', itU8, wbFlags([
{0}'Causes Damage',
{1}'Reflective'
]), cpNormal, True),
wbString(MNAM, 'Material ID', 0, cpNormal, True),
wbFormIDCk(SNAM, 'Sound', [SOUN]),
wbFormIDCk(XNAM, 'Actor Effect', [SPEL]),
wbInteger(DATA, 'Damage', itU16, nil, cpNormal, True, True),
wbRUnion('Visual Data', [
wbStruct(DNAM, 'Visual Data', [
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Water Properties - Sun Power'),
wbFloat('Water Properties - Reflectivity Amount'),
wbFloat('Water Properties - Fresnel Amount'),
wbByteArray('Unused', 4),
wbFloat('Fog Properties - Above Water - Fog Distance - Near Plane'),
wbFloat('Fog Properties - Above Water - Fog Distance - Far Plane'),
wbStruct('Shallow Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Deep Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Reflection Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbByteArray('Unused', 4),
wbFloat('Rain Simulator - Force'),
wbFloat('Rain Simulator - Velocity'),
wbFloat('Rain Simulator - Falloff'),
wbFloat('Rain Simulator - Dampner'),
wbFloat('Displacement Simulator - Starting Size'),
wbFloat('Displacement Simulator - Force'),
wbFloat('Displacement Simulator - Velocity'),
wbFloat('Displacement Simulator - Falloff'),
wbFloat('Displacement Simulator - Dampner'),
wbFloat('Rain Simulator - Starting Size'),
wbFloat('Noise Properties - Normals - Noise Scale'),
wbFloat('Noise Properties - Noise Layer One - Wind Direction'),
wbFloat('Noise Properties - Noise Layer Two - Wind Direction'),
wbFloat('Noise Properties - Noise Layer Three - Wind Direction'),
wbFloat('Noise Properties - Noise Layer One - Wind Speed'),
wbFloat('Noise Properties - Noise Layer Two - Wind Speed'),
wbFloat('Noise Properties - Noise Layer Three - Wind Speed'),
wbFloat('Noise Properties - Normals - Depth Falloff Start'),
wbFloat('Noise Properties - Normals - Depth Falloff End'),
wbFloat('Fog Properties - Above Water - Fog Amount'),
wbFloat('Noise Properties - Normals - UV Scale'),
wbFloat('Fog Properties - Under Water - Fog Amount'),
wbFloat('Fog Properties - Under Water - Fog Distance - Near Plane'),
wbFloat('Fog Properties - Under Water - Fog Distance - Far Plane'),
wbFloat('Water Properties - Distortion Amount'),
wbFloat('Water Properties - Shininess'),
wbFloat('Water Properties - Reflection HDR Multiplier'),
wbFloat('Water Properties - Light Radius'),
wbFloat('Water Properties - Light Brightness'),
wbFloat('Noise Properties - Noise Layer One - UV Scale'),
wbFloat('Noise Properties - Noise Layer Two - UV Scale'),
wbFloat('Noise Properties - Noise Layer Three - UV Scale'),
wbFloat('Noise Properties - Noise Layer One - Amplitude Scale'),
wbFloat('Noise Properties - Noise Layer Two - Amplitude Scale'),
wbFloat('Noise Properties - Noise Layer Three - Amplitude Scale')
], cpNormal, True, nil, 46),
wbStruct(DATA, 'Visual Data', [
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Water Properties - Sun Power'),
wbFloat('Water Properties - Reflectivity Amount'),
wbFloat('Water Properties - Fresnel Amount'),
wbByteArray('Unused', 4),
wbFloat('Fog Properties - Above Water - Fog Distance - Near Plane'),
wbFloat('Fog Properties - Above Water - Fog Distance - Far Plane'),
wbStruct('Shallow Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Deep Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbStruct('Reflection Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
wbByteArray('Unused', 4),
wbFloat('Rain Simulator - Force'),
wbFloat('Rain Simulator - Velocity'),
wbFloat('Rain Simulator - Falloff'),
wbFloat('Rain Simulator - Dampner'),
wbFloat('Displacement Simulator - Starting Size'),
wbFloat('Displacement Simulator - Force'),
wbFloat('Displacement Simulator - Velocity'),
wbFloat('Displacement Simulator - Falloff'),
wbFloat('Displacement Simulator - Dampner'),
wbFloat('Rain Simulator - Starting Size'),
wbFloat('Noise Properties - Normals - Noise Scale'),
wbFloat('Noise Properties - Noise Layer One - Wind Direction'),
wbFloat('Noise Properties - Noise Layer Two - Wind Direction'),
wbFloat('Noise Properties - Noise Layer Three - Wind Direction'),
wbFloat('Noise Properties - Noise Layer One - Wind Speed'),
wbFloat('Noise Properties - Noise Layer Two - Wind Speed'),
wbFloat('Noise Properties - Noise Layer Three - Wind Speed'),
wbFloat('Noise Properties - Normals - Depth Falloff Start'),
wbFloat('Noise Properties - Normals - Depth Falloff End'),
wbFloat('Fog Properties - Above Water - Fog Amount'),
wbFloat('Noise Properties - Normals - UV Scale'),
wbFloat('Fog Properties - Under Water - Fog Amount'),
wbFloat('Fog Properties - Under Water - Fog Distance - Near Plane'),
wbFloat('Fog Properties - Under Water - Fog Distance - Far Plane'),
wbFloat('Water Properties - Distortion Amount'),
wbFloat('Water Properties - Shininess'),
wbFloat('Water Properties - Reflection HDR Multiplier'),
wbFloat('Water Properties - Light Radius'),
wbFloat('Water Properties - Light Brightness'),
wbFloat('Noise Properties - Noise Layer One - UV Scale'),
wbFloat('Noise Properties - Noise Layer Two - UV Scale'),
wbFloat('Noise Properties - Noise Layer Three - UV Scale'),
wbEmpty('Noise Properties - Noise Layer One - Amplitude Scale'),
wbEmpty('Noise Properties - Noise Layer Two - Amplitude Scale'),
wbEmpty('Noise Properties - Noise Layer Three - Amplitude Scale'),
wbInteger('Damage (Old Format)', itU16)
], cpNormal, True)
], [], cpNormal, True),
wbStruct(GNAM, 'Related Waters (Unused)', [
wbFormIDCk('Daytime', [WATR, NULL]),
wbFormIDCk('Nighttime', [WATR, NULL]),
wbFormIDCk('Underwater', [WATR, NULL])
], cpNormal, True)
], False, nil, cpNormal, False, wbWATRAfterLoad);
wbRecord(WEAP, 'Weapon', [
wbEDIDReq,
wbOBNDReq,
wbFULL,
wbMODL,
wbICON,
wbSCRI,
wbEITM,
wbInteger(EAMT, 'Enchantment Charge Amount', itS16),
wbFormIDCkNoReach(NAM0, 'Ammo', [AMMO, FLST]),
wbDEST,
wbREPL,
wbETYPReq,
wbBIPL,
wbYNAM,
wbZNAM,
wbRStruct('Shell Casing Model', [
wbString(MOD2, 'Model Filename'),
wbByteArray(MO2T, 'Texture Files Hashes', 0, cpIgnore),
wbMO2S
], []),
wbRStruct('Scope Model', [
wbString(MOD3, 'Model Filename'),
wbByteArray(MO3T, 'Texture Files Hashes', 0, cpIgnore),
wbMO3S
], []),
wbFormIDCK(EFSD, 'Scope Effect', [EFSH]),
wbRStruct('World Model', [
wbString(MOD4, 'Model Filename'),
wbByteArray(MO4T, 'Texture Files Hashes', 0, cpIgnore),
wbMO4S
], []),
wbString(NNAM, 'Embedded Weapon Node'),
wbFormIDCk(INAM, 'Impact DataSet', [IPDS]),
wbFormIDCk(WNAM, '1st Person Model', [STAT]),
wbFormIDCk(SNAM, 'Sound - Gun - Shoot 3D', [SOUN]),
wbFormIDCk(XNAM, 'Sound - Gun - Shoot 2D', [SOUN]),
wbFormIDCk(NAM7, 'Sound - Gun - Shoot 3D Looping', [SOUN]),
wbFormIDCk(TNAM, 'Sound - Melee - Swing / Gun - No Ammo', [SOUN]),
wbFormIDCk(NAM6, 'Sound - Block', [SOUN]),
wbFormIDCk(UNAM, 'Sound - Idle', [SOUN]),
wbFormIDCk(NAM9, 'Sound - Equip', [SOUN]),
wbFormIDCk(NAM8, 'Sound - Unequip', [SOUN]),
wbStruct(DATA, '', [
wbInteger('Value', itS32),
wbInteger('Health', itS32),
wbFloat('Weight'),
wbInteger('Base Damage', itS16),
wbInteger('Clip Size', itU8)
], cpNormal, True),
wbStruct(DNAM, '', [
{00} wbInteger('Animation Type', itU32, wbWeaponAnimTypeEnum),
{04} wbFloat('Animation Multiplier'),
{08} wbFloat('Reach'),
{12} wbInteger('Flags 1', itU8, wbFlags([
'Ignores Normal Weapon Resistance',
'Is Automatic',
'Has Scope',
'Can''t Drop',
'Hide Backpack',
'Embedded Weapon',
'Don''t Use 1st Person IS Animations',
'Non-Playable'
])),
{13} wbInteger('Grip Animation', itU8, wbEnum([
], [
171, 'HandGrip1',
172, 'HandGrip2',
173, 'HandGrip3',
255, 'DEFAULT'
])),
{14} wbInteger('Ammo Use', itU8),
{15} wbInteger('Reload Animation', itU8, wbReloadAnimEnum),
{16} wbFloat('Min Spread'),
{20} wbFloat('Spread'),
{24} wbFloat('Unknown'),
{28} wbFloat('Sight FOV'),
{32} wbByteArray('Unused', 4),
{36} wbFormIDCk('Projectile', [PROJ, NULL]),
{40} wbInteger('Base VATS To-Hit Chance', itU8),
{41} wbInteger('Attack Animation', itU8, wbEnum([
], [
26, 'AttackLeft',
32, 'AttackRight',
38, 'Attack3',
44, 'Attack4',
50, 'Attack5',
56, 'Attack6',
62, 'Attack7',
68, 'Attack8',
74, 'AttackLoop',
80, 'AttackSpin',
86, 'AttackSpin2',
97, 'PlaceMine',
103, 'PlaceMine2',
109, 'AttackThrow',
115, 'AttackThrow2',
121, 'AttackThrow3',
127, 'AttackThrow4',
133, 'AttackThrow5',
255, 'DEFAULT'
])),
{42} wbInteger('Projectile Count', itU8),
{43} wbInteger('Embedded Weapon - Actor Value', itU8, wbEnum([
{00} 'Perception',
{01} 'Endurance',
{02} 'Left Attack',
{03} 'Right Attack',
{04} 'Left Mobility',
{05} 'Right Mobilty',
{06} 'Brain'
])),
{44} wbFloat('Min Range'),
{48} wbFloat('Max Range'),
{52} wbInteger('On Hit', itU32, wbEnum([
'Normal formula behavior',
'Dismember Only',
'Explode Only',
'No Dismember/Explode'
])),
{56} wbInteger('Flags 2', itU32, wbFlags([
{0x00000001}'Player Only',
{0x00000002}'NPCs Use Ammo',
{0x00000004}'No Jam After Reload',
{0x00000008}'Override - Action Points',
{0x00000010}'Minor Crime',
{0x00000020}'Range - Fixed',
{0x00000040}'Not Used In Normal Combat',
{0x00000080}'Override - Damage to Weapon Mult',
{0x00000100}'Don''t Use 3rd Person IS Animations',
{0x00000200}'Short Burst',
{0x00000400}'Rumble Alternate',
{0x00000800}'Long Burst'
])),
{60} wbFloat('Animation Attack Multiplier'),
{64} wbFloat('Fire Rate'),
{68} wbFloat('Override - Action Points'),
{72} wbFloat('Rumble - Left Motor Strength'),
{76} wbFloat('Rumble - Right Motor Strength'),
{80} wbFloat('Rumble - Duration'),
{84} wbFloat('Override - Damage to Weapon Mult'),
{88} wbFloat('Attack Shots/Sec'),
{92} wbFloat('Reload Time'),
{96} wbFloat('Jam Time'),
{100} wbFloat('Aim Arc'),
{104} wbInteger('Skill', itS32, wbActorValueEnum),
{108} wbInteger('Rumble - Pattern', itU32, wbEnum([
'Constant',
'Square',
'Triangle',
'Sawtooth'
])),
{112} wbFloat('Rumble - Wavelength'),
{116} wbFloat('Limb Dmg Mult'),
{120} wbInteger('Resist Type', itS32, wbActorValueEnum),
{124} wbFloat('Sight Usage'),
{128} wbFloat('Semi-Automatic Fire Delay Min'),
{132} wbFloat('Semi-Automatic Fire Delay Max')
], cpNormal, True, nil, 36),
wbStruct(CRDT, 'Critical Data', [
{00} wbInteger('Critical Damage', itU16),
{09} wbByteArray('Unused', 2),
{04} wbFloat('Crit % Mult'),
{08} wbInteger('Flags', itU8, wbFlags([
'On Death'
])),
{09} wbByteArray('Unused', 3),
{12} wbFormIDCk('Effect', [SPEL, NULL])
], cpNormal, True),
wbInteger(VNAM, 'Sound Level', itU32, wbSoundLevelEnum, cpNormal, True)
], False, nil, cpNormal, False, wbWEAPAfterLoad);
if wbSimpleRecords then
wbRecord(WRLD, 'Worldspace', [
wbEDIDReq,
wbFULL,
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbRStruct('Parent', [
wbFormIDCk(WNAM, 'Worldspace', [WRLD]),
wbStruct(PNAM, '', [
wbInteger('Flags', itU8, wbFlags([
{0x00000001}'Use Land Data',
{0x00000002}'Use LOD Data',
{0x00000004}'Use Map Data',
{0x00000008}'Use Water Data',
{0x00000010}'Use Climate Data',
{0x00000020}'Use Image Space Data',
{0x00000040}'',
{0x00000080}'Needs Water Adjustment'
], True)),
wbByteArray('Unknown', 1)
], cpNormal, True)
], []),
wbFormIDCk(CNAM, 'Climate', [CLMT]),
wbFormIDCk(NAM2, 'Water', [WATR]),
wbFormIDCk(NAM3, 'LOD Water Type', [WATR]),
wbFloat(NAM4, 'LOD Water Height'),
wbStruct(DNAM, 'Land Data', [
wbFloat('Default Land Height'),
wbFloat('Default Water Height')
]),
wbICON,
wbStruct(MNAM, 'Map Data', [
wbStruct('Usable Dimensions', [
wbInteger('X', itS32),
wbInteger('Y', itS32)
]),
wbStruct('Cell Coordinates', [
wbStruct('NW Cell', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
]),
wbStruct('SE Cell', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
])
])
]),
wbStruct(ONAM, 'World Map Offset Data', [
wbFloat('World Map Scale'),
wbFloat('Cell X Offset'),
wbFloat('Cell Y Offset')
], cpNormal, True),
wbFormIDCk(INAM, 'Image Space', [IMGS]),
wbInteger(DATA, 'Flags', itU8, wbFlags([
{0x01} 'Small World',
{0x02} 'Can''t Fast Travel',
{0x04} '',
{0x08} '',
{0x10} 'No LOD Water',
{0x20} 'No LOD Noise',
{0x40} 'Don''t Allow NPC Fall Damage',
{0x80} 'Needs Water Adjustment'
]), cpNormal, True),
wbRStruct('Object Bounds', [
wbStruct(NAM0, 'Min', [
wbFloat('X', cpNormal, False, 1/4096),
wbFloat('Y', cpNormal, False, 1/4096)
], cpIgnore, True),
wbStruct(NAM9, 'Max', [
wbFloat('X', cpNormal, False, 1/4096),
wbFloat('Y', cpNormal, False, 1/4096)
], cpIgnore, True)
], []),
wbFormIDCk(ZNAM, 'Music', [MUSC]),
wbString(NNAM, 'Canopy Shadow', 0, cpNormal, True),
wbString(XNAM, 'Water Noise Texture', 0, cpNormal, True),
wbRArrayS('Swapped Impacts', wbStructExSK(IMPS, [0, 1], [2], 'Swapped Impact', [
wbInteger('Material Type', itU32, wbImpactMaterialTypeEnum),
wbFormIDCkNoReach('Old', [IPCT]),
wbFormIDCk('New', [IPCT, NULL])
])),
wbArray(IMPF, 'Footstep Materials', wbString('Unknown', 30), [
'ConcSolid',
'ConcBroken',
'MetalSolid',
'MetalHollow',
'MetalSheet',
'Wood',
'Sand',
'Dirt',
'Grass',
'Water'
]),
wbByteArray(OFST, 'Offset Data')
], False, nil, cpNormal, False, wbRemoveOFST)
else
wbRecord(WRLD, 'Worldspace', [
wbEDIDReq,
wbFULL,
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbRStruct('Parent', [
wbFormIDCk(WNAM, 'Worldspace', [WRLD]),
wbStruct(PNAM, '', [
wbInteger('Flags', itU8, wbFlags([
{0x00000001}'Use Land Data',
{0x00000002}'Use LOD Data',
{0x00000004}'Use Map Data',
{0x00000008}'Use Water Data',
{0x00000010}'Use Climate Data',
{0x00000020}'Use Image Space Data',
{0x00000040}'',
{0x00000080}'Needs Water Adjustment'
], True)),
wbByteArray('Unknown', 1)
], cpNormal, True)
], []),
wbFormIDCk(CNAM, 'Climate', [CLMT]),
wbFormIDCk(NAM2, 'Water', [WATR]),
wbFormIDCk(NAM3, 'LOD Water Type', [WATR]),
wbFloat(NAM4, 'LOD Water Height'),
wbStruct(DNAM, 'Land Data', [
wbFloat('Default Land Height'),
wbFloat('Default Water Height')
]),
wbICON,
wbStruct(MNAM, 'Map Data', [
wbStruct('Usable Dimensions', [
wbInteger('X', itS32),
wbInteger('Y', itS32)
]),
wbStruct('Cell Coordinates', [
wbStruct('NW Cell', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
]),
wbStruct('SE Cell', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
])
])
]),
wbStruct(ONAM, 'World Map Offset Data', [
wbFloat('World Map Scale'),
wbFloat('Cell X Offset'),
wbFloat('Cell Y Offset')
], cpNormal, True),
wbFormIDCk(INAM, 'Image Space', [IMGS]),
wbInteger(DATA, 'Flags', itU8, wbFlags([
{0x01} 'Small World',
{0x02} 'Can''t Fast Travel',
{0x04} '',
{0x08} '',
{0x10} 'No LOD Water',
{0x20} 'No LOD Noise',
{0x40} 'Don''t Allow NPC Fall Damage',
{0x80} 'Needs Water Adjustment'
]), cpNormal, True),
wbRStruct('Object Bounds', [
wbStruct(NAM0, 'Min', [
wbFloat('X', cpNormal, False, 1/4096),
wbFloat('Y', cpNormal, False, 1/4096)
], cpIgnore, True),
wbStruct(NAM9, 'Max', [
wbFloat('X', cpNormal, False, 1/4096),
wbFloat('Y', cpNormal, False, 1/4096)
], cpIgnore, True)
], []),
wbFormIDCk(ZNAM, 'Music', [MUSC]),
wbString(NNAM, 'Canopy Shadow', 0, cpNormal, True),
wbString(XNAM, 'Water Noise Texture', 0, cpNormal, True),
wbRArrayS('Swapped Impacts', wbStructExSK(IMPS, [0, 1], [2], 'Swapped Impact', [
wbInteger('Material Type', itU32, wbImpactMaterialTypeEnum),
wbFormIDCkNoReach('Old', [IPCT]),
wbFormIDCk('New', [IPCT, NULL])
])),
wbArray(IMPF, 'Footstep Materials', wbString('Unknown', 30), [
'ConcSolid',
'ConcBroken',
'MetalSolid',
'MetalHollow',
'MetalSheet',
'Wood',
'Sand',
'Dirt',
'Grass',
'Water'
]),
wbArray(OFST, 'Offset Data', wbArray('Rows', wbInteger('Offset', itU32), wbOffsetDataColsCounter), 0)
], False, nil, cpNormal, False, wbRemoveOFST);
wbRecord(WTHR, 'Weather', [
wbEDIDReq,
wbFormIDCk(_0_IAD, 'Sunrise Image Space Modifier', [IMAD]),
wbFormIDCk(_1_IAD, 'Day Image Space Modifier', [IMAD]),
wbFormIDCk(_2_IAD, 'Sunset Image Space Modifier', [IMAD]),
wbFormIDCk(_3_IAD, 'Night Image Space Modifier', [IMAD]),
wbString(DNAM, 'Cloud Textures - Layer 0', 0, cpNormal, True),
wbString(CNAM, 'Cloud Textures - Layer 1', 0, cpNormal, True),
wbString(ANAM, 'Cloud Textures - Layer 2', 0, cpNormal, True),
wbString(BNAM, 'Cloud Textures - Layer 3', 0, cpNormal, True),
wbMODL,
wbByteArray(LNAM, 'Unknown', 4, cpNormal, True),
wbArray(ONAM, 'Cloud Speed', wbInteger('Layer', itU8{, wbDiv(2550)}), 4, nil, nil, cpNormal, True),
wbArray(PNAM, 'Cloud Layer Colors',
wbArray('Layer',
wbStruct('Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
['Sunrise', 'Day', 'Sunset', 'Night']
),
4),
wbArray(NAM0, 'Colors by Types/Times',
wbArray('Type',
wbStruct('Time', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]),
['Sunrise', 'Day', 'Sunset', 'Night']
),
['Sky-Upper','Fog','Unused','Ambient','Sunlight','Sun','Stars','Sky-Lower','Horizon','Unused']
, cpNormal, True),
wbStruct(FNAM, 'Fog Distance', [
wbFloat('Day - Near'),
wbFloat('Day - Far'),
wbFloat('Night - Near'),
wbFloat('Night - Far'),
wbFloat('Day - Power'),
wbFloat('Night - Fower')
], cpNormal, True),
wbByteArray(INAM, 'Unused', 304, cpIgnore, True),
wbStruct(DATA, '', [
wbInteger('Wind Speed', itU8),
wbInteger('Cloud Speed (Lower)', itU8),
wbInteger('Cloud Speed (Upper)', itU8),
wbInteger('Trans Delta', itU8),
wbInteger('Sun Glare', itU8),
wbInteger('Sun Damage', itU8),
wbInteger('Precipitation - Begin Fade In', itU8),
wbInteger('Precipitation - End Fade Out', itU8),
wbInteger('Thunder/Lightning - Begin Fade In', itU8),
wbInteger('Thunder/Lightning - End Fade Out', itU8),
wbInteger('Thunder/Lightning - Frequency', itU8),
wbInteger('Weather Classification', itU8, wbWthrDataClassification),
wbStruct('Lightning Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8)
])
], cpNormal, True),
wbRArray('Sounds', wbStruct(SNAM, 'Sound', [
wbFormIDCk('Sound', [SOUN]),
wbInteger('Type', itU32, wbEnum([
{0}'Default',
{1}'Precip',
{2}'Wind',
{3}'Thunder'
]))
]))
]);
wbAddGroupOrder(GMST);
wbAddGroupOrder(TXST);
wbAddGroupOrder(MICN);
wbAddGroupOrder(GLOB);
wbAddGroupOrder(CLAS);
wbAddGroupOrder(FACT);
wbAddGroupOrder(HDPT);
wbAddGroupOrder(HAIR);
wbAddGroupOrder(EYES);
wbAddGroupOrder(RACE);
wbAddGroupOrder(SOUN);
wbAddGroupOrder(ASPC);
wbAddGroupOrder(MGEF);
wbAddGroupOrder(SCPT);
wbAddGroupOrder(LTEX);
wbAddGroupOrder(ENCH);
wbAddGroupOrder(SPEL);
wbAddGroupOrder(ACTI);
wbAddGroupOrder(TACT);
wbAddGroupOrder(TERM);
wbAddGroupOrder(ARMO);
wbAddGroupOrder(BOOK);
wbAddGroupOrder(CONT);
wbAddGroupOrder(DOOR);
wbAddGroupOrder(INGR);
wbAddGroupOrder(LIGH);
wbAddGroupOrder(MISC);
wbAddGroupOrder(STAT);
wbAddGroupOrder(SCOL);
wbAddGroupOrder(MSTT);
wbAddGroupOrder(PWAT);
wbAddGroupOrder(GRAS);
wbAddGroupOrder(TREE);
wbAddGroupOrder(FURN);
wbAddGroupOrder(WEAP);
wbAddGroupOrder(AMMO);
wbAddGroupOrder(NPC_);
wbAddGroupOrder(CREA);
wbAddGroupOrder(LVLC);
wbAddGroupOrder(LVLN);
wbAddGroupOrder(KEYM);
wbAddGroupOrder(ALCH);
wbAddGroupOrder(IDLM);
wbAddGroupOrder(NOTE);
wbAddGroupOrder(PROJ);
wbAddGroupOrder(LVLI);
wbAddGroupOrder(WTHR);
wbAddGroupOrder(CLMT);
wbAddGroupOrder(COBJ);
wbAddGroupOrder(REGN);
wbAddGroupOrder(NAVI);
wbAddGroupOrder(CELL);
wbAddGroupOrder(WRLD);
wbAddGroupOrder(DIAL);
wbAddGroupOrder(QUST);
wbAddGroupOrder(IDLE);
wbAddGroupOrder(PACK);
wbAddGroupOrder(CSTY);
wbAddGroupOrder(LSCR);
wbAddGroupOrder(ANIO);
wbAddGroupOrder(WATR);
wbAddGroupOrder(EFSH);
wbAddGroupOrder(EXPL);
wbAddGroupOrder(DEBR);
wbAddGroupOrder(IMGS);
wbAddGroupOrder(IMAD);
wbAddGroupOrder(FLST);
wbAddGroupOrder(PERK);
wbAddGroupOrder(BPTD);
wbAddGroupOrder(ADDN);
wbAddGroupOrder(AVIF);
wbAddGroupOrder(RADS);
wbAddGroupOrder(CAMS);
wbAddGroupOrder(CPTH);
wbAddGroupOrder(VTYP);
wbAddGroupOrder(IPCT);
wbAddGroupOrder(IPDS);
wbAddGroupOrder(ARMA);
wbAddGroupOrder(ECZN);
wbAddGroupOrder(MESG);
wbAddGroupOrder(RGDL);
wbAddGroupOrder(DOBJ);
wbAddGroupOrder(LGTM);
wbAddGroupOrder(MUSC);
end;
procedure DefineFO3;
begin
DefineFO3a;
DefineFO3b;
DefineFO3c;
DefineFO3d;
DefineFO3e;
DefineFO3f;
end;
end.
================================================
FILE: lib/xedit/wbDefinitionsFO4.pas
================================================
{*******************************************************************************
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in
compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/
Software distributed under the License is distributed on an "AS IS"
basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
License for the specific language governing rights and limitations
under the License.
*******************************************************************************}
unit wbDefinitionsFO4;
{$I wbDefines.inc}
interface
uses
wbInterface;
var
wbBipedObjectFlags: IwbFlagsDef;
wbEquipType: IwbFlagsDef;
wbFurnitureEntryTypeFlags: IwbFlagsDef;
wbPKDTFlags: IwbFlagsDef;
wbPKDTInterruptFlags: IwbFlagsDef;
wbSMNodeFlags: IwbFlagsDef;
wbActorPropertyEnum: IwbEnumDef;
wbAdvanceActionEnum: IwbEnumDef;
wbStaggerEnum: IwbEnumDef;
wbAlignmentEnum: IwbEnumDef;
wbArmorPropertyEnum: IwbEnumDef;
wbAxisEnum: IwbEnumDef;
wbBipedObjectEnum: IwbEnumDef;
wbBlendModeEnum: IwbEnumDef;
wbBlendOpEnum: IwbEnumDef;
wbBodyPartIndexEnum: IwbEnumDef;
wbCastEnum: IwbEnumDef;
wbCastingSourceEnum: IwbEnumDef;
wbCrimeTypeEnum: IwbEnumDef;
wbCriticalStageEnum: IwbEnumDef;
wbEmotionTypeEnum: IwbEnumDef;
wbEntryPointsEnum: IwbEnumDef;
wbEventFunctionEnum: IwbEnumDef;
wbEventMemberEnum: IwbEnumDef;
wbFormTypeEnum: IwbEnumDef;
wbFurnitureAnimTypeEnum: IwbEnumDef;
wbLocationEnum: IwbEnumDef;
wbMiscStatEnum: IwbEnumDef;
wbMusicEnum: IwbEnumDef;
wbObjectModProperties: IwbArrayDef;
wbObjectTypeEnum: IwbEnumDef;
wbPropTypeEnum: IwbEnumDef;
wbQuadrantEnum: IwbEnumDef;
wbSexEnum: IwbEnumDef;
wbSkillEnum: IwbEnumDef;
wbSoulGemEnum: IwbEnumDef;
wbSoundLevelEnum: IwbEnumDef;
wbTargetEnum: IwbEnumDef;
wbVatsValueFunctionEnum: IwbEnumDef;
wbWardStateEnum: IwbEnumDef;
wbWeaponAnimTypeEnum: IwbEnumDef;
wbWeaponPropertyEnum: IwbEnumDef;
wbZTestFuncEnum: IwbEnumDef;
wbKeywordTypeEnum: IwbEnumDef;
wbReverbClassEnum: IwbEnumDef;
wbHitBehaviourEnum: IwbEnumDef;
wbBoolEnum: IwbEnumDef;
procedure DefineFO4;
implementation
uses
Types,
Classes,
SysUtils,
Math,
Variants,
wbHelpers;
const
_00_IAD: TwbSignature = #$00'IAD';
_01_IAD: TwbSignature = #$01'IAD';
_02_IAD: TwbSignature = #$02'IAD';
_03_IAD: TwbSignature = #$03'IAD';
_04_IAD: TwbSignature = #$04'IAD';
_05_IAD: TwbSignature = #$05'IAD';
_06_IAD: TwbSignature = #$06'IAD';
_07_IAD: TwbSignature = #$07'IAD';
_08_IAD: TwbSignature = #$08'IAD';
_09_IAD: TwbSignature = #$09'IAD';
_0A_IAD: TwbSignature = #$0A'IAD';
_0B_IAD: TwbSignature = #$0B'IAD';
_0C_IAD: TwbSignature = #$0C'IAD';
_0D_IAD: TwbSignature = #$0D'IAD';
_0E_IAD: TwbSignature = #$0E'IAD';
_0F_IAD: TwbSignature = #$0F'IAD';
_10_IAD: TwbSignature = #$10'IAD';
_11_IAD: TwbSignature = #$11'IAD';
_12_IAD: TwbSignature = #$12'IAD';
_13_IAD: TwbSignature = #$13'IAD';
_14_IAD: TwbSignature = #$14'IAD';
_40_IAD: TwbSignature = #$40'IAD';
_41_IAD: TwbSignature = #$41'IAD';
_42_IAD: TwbSignature = #$42'IAD';
_43_IAD: TwbSignature = #$43'IAD';
_44_IAD: TwbSignature = #$44'IAD';
_45_IAD: TwbSignature = #$45'IAD';
_46_IAD: TwbSignature = #$46'IAD';
_47_IAD: TwbSignature = #$47'IAD';
_48_IAD: TwbSignature = #$48'IAD';
_49_IAD: TwbSignature = #$49'IAD';
_4A_IAD: TwbSignature = #$4A'IAD';
_4B_IAD: TwbSignature = #$4B'IAD';
_4C_IAD: TwbSignature = #$4C'IAD';
_4D_IAD: TwbSignature = #$4D'IAD';
_4E_IAD: TwbSignature = #$4E'IAD';
_4F_IAD: TwbSignature = #$4F'IAD';
_50_IAD: TwbSignature = #$50'IAD';
_51_IAD: TwbSignature = #$51'IAD';
_52_IAD: TwbSignature = #$52'IAD';
_53_IAD: TwbSignature = #$53'IAD';
_54_IAD: TwbSignature = #$54'IAD';
{00TX} _00_0TX: TwbSignature = #$30'0TX';
{10TX} _10_0TX: TwbSignature = #$31'0TX';
{20TX} _20_0TX: TwbSignature = #$32'0TX';
{30TX} _30_0TX: TwbSignature = #$33'0TX';
{40TX} _40_0TX: TwbSignature = #$34'0TX';
{50TX} _50_0TX: TwbSignature = #$35'0TX';
{60TX} _60_0TX: TwbSignature = #$36'0TX';
{70TX} _70_0TX: TwbSignature = #$37'0TX';
{80TX} _80_0TX: TwbSignature = #$38'0TX';
{90TX} _90_0TX: TwbSignature = #$39'0TX';
{:0TX} _3A_0TX: TwbSignature = #$3A'0TX';
{;0TX} _3B_0TX: TwbSignature = #$3B'0TX';
{<0TX} _3C_0TX: TwbSignature = #$3C'0TX';
{=0TX} _3D_0TX: TwbSignature = #$3D'0TX';
{>0TX} _3E_0TX: TwbSignature = #$3E'0TX';
{?0TX} _3F_0TX: TwbSignature = #$3F'0TX';
{@0TX} _40h_0TX: TwbSignature = #$40'0TX';
{A0TX} A0TX: TwbSignature = 'A0TX';
{B0TX} B0TX: TwbSignature = 'B0TX';
{C0TX} C0TX: TwbSignature = 'C0TX';
{D0TX} D0TX: TwbSignature = 'D0TX';
{E0TX} E0TX: TwbSignature = 'E0TX';
{F0TX} F0TX: TwbSignature = 'F0TX';
{G0TX} G0TX: TwbSignature = 'G0TX';
{H0TX} H0TX: TwbSignature = 'H0TX';
{I0TX} I0TX: TwbSignature = 'I0TX';
{J0TX} J0TX: TwbSignature = 'J0TX';
{K0TX} K0TX: TwbSignature = 'K0TX';
{L0TX} L0TX: TwbSignature = 'L0TX';
AACT : TwbSignature = 'AACT';
ACBS : TwbSignature = 'ACBS';
ACEC : TwbSignature = 'ACEC'; { New To Dawnguard }
ACEP : TwbSignature = 'ACEP'; { New To Dawnguard }
ACHR : TwbSignature = 'ACHR';
ACID : TwbSignature = 'ACID'; { New To Dawnguard }
ACPR : TwbSignature = 'ACPR'; { New To Skyrim }
ACSR : TwbSignature = 'ACSR'; { New To Dawnguard }
ACTI : TwbSignature = 'ACTI';
ACTV : TwbSignature = 'ACTV'; { New To Fallout 4 }
ACUN : TwbSignature = 'ACUN'; { New To Dawnguard }
ADDN : TwbSignature = 'ADDN';
AECH : TwbSignature = 'AECH'; { New To Fallout 4 }
AHCF : TwbSignature = 'AHCF'; { New To Skyrim }
AHCM : TwbSignature = 'AHCM'; { New To Skyrim }
AIDT : TwbSignature = 'AIDT';
ALCA : TwbSignature = 'ALCA'; { New To Skyrim }
ALCC : TwbSignature = 'ALCC'; { New To Fallout 4 }
ALCH : TwbSignature = 'ALCH';
ALCL : TwbSignature = 'ALCL'; { New To Skyrim }
ALCO : TwbSignature = 'ALCO'; { New To Skyrim }
ALCS : TwbSignature = 'ALCS'; { New To Fallout 4 }
ALDI : TwbSignature = 'ALDI'; { New To Fallout 4 }
ALDN : TwbSignature = 'ALDN'; { New To Skyrim }
ALEA : TwbSignature = 'ALEA'; { New To Skyrim }
ALED : TwbSignature = 'ALED'; { New To Skyrim }
ALEQ : TwbSignature = 'ALEQ'; { New To Skyrim }
ALFA : TwbSignature = 'ALFA'; { New To Skyrim }
ALFC : TwbSignature = 'ALFC'; { New To Skyrim }
ALFD : TwbSignature = 'ALFD'; { New To Skyrim }
ALFE : TwbSignature = 'ALFE'; { New To Skyrim }
ALFI : TwbSignature = 'ALFI'; { New To Skyrim }
ALFL : TwbSignature = 'ALFL'; { New To Skyrim }
ALFR : TwbSignature = 'ALFR'; { New To Skyrim }
ALFV : TwbSignature = 'ALFV'; { New To Fallout 4 }
ALID : TwbSignature = 'ALID'; { New To Skyrim }
ALLA : TwbSignature = 'ALLA'; { New To Fallout 4 }
ALLS : TwbSignature = 'ALLS'; { New To Skyrim }
ALMI : TwbSignature = 'ALMI'; { New To Fallout 4 }
ALNA : TwbSignature = 'ALNA'; { New To Skyrim }
ALNT : TwbSignature = 'ALNT'; { New To Skyrim }
ALPC : TwbSignature = 'ALPC'; { New To Skyrim }
ALRT : TwbSignature = 'ALRT'; { New To Skyrim }
ALSP : TwbSignature = 'ALSP'; { New To Skyrim }
ALST : TwbSignature = 'ALST'; { New To Skyrim }
ALUA : TwbSignature = 'ALUA'; { New To Skyrim }
AMDL : TwbSignature = 'AMDL'; { New To Fallout 4 }
AMMO : TwbSignature = 'AMMO';
ANAM : TwbSignature = 'ANAM';
ANIO : TwbSignature = 'ANIO';
AOR2 : TwbSignature = 'AOR2'; { New To Fallout 4 }
AORU : TwbSignature = 'AORU'; { New To Fallout 4 }
APPR : TwbSignature = 'APPR'; { New To Fallout 4 }
ARMA : TwbSignature = 'ARMA';
ARMO : TwbSignature = 'ARMO';
ARTO : TwbSignature = 'ARTO';
ASPC : TwbSignature = 'ASPC';
ASTP : TwbSignature = 'ASTP';
ATKD : TwbSignature = 'ATKD'; { New to Skyrim }
ATKE : TwbSignature = 'ATKE'; { New to Skyrim }
ATKR : TwbSignature = 'ATKR'; { New to Skyrim }
ATKT : TwbSignature = 'ATKT'; { New To Fallout 4 }
ATKS : TwbSignature = 'ATKS'; { New To Fallout 4 }
ATKW : TwbSignature = 'ATKW'; { New To Fallout 4 }
ATTN : TwbSignature = 'ATTN'; { New To Fallout 4 }
ATTX : TwbSignature = 'ATTX'; { New To Fallout 4 }
ATXT : TwbSignature = 'ATXT';
AVFL : TwbSignature = 'AVFL'; { New To Fallout 4 }
AVIF : TwbSignature = 'AVIF';
AVSK : TwbSignature = 'AVSK'; { New to Skyrim }
BAMT : TwbSignature = 'BAMT'; { New to Skyrim }
BCLF : TwbSignature = 'BCLF'; { New to Fallout 4 }
BIDS : TwbSignature = 'BIDS'; { New to Skyrim }
BIPL : TwbSignature = 'BIPL';
BMCT : TwbSignature = 'BMCT';
BMMP : TwbSignature = 'BMMP'; { New to Fallout 4 }
BNAM : TwbSignature = 'BNAM';
BNDS : TwbSignature = 'BNDS'; { New to Fallout 4 }
BOD2 : TwbSignature = 'BOD2'; { New to Skyrim 1.6.91 CK}
BODT : TwbSignature = 'BODT'; { New to Skyrim }
BOOK : TwbSignature = 'BOOK';
BPND : TwbSignature = 'BPND';
BPNI : TwbSignature = 'BPNI';
BPNN : TwbSignature = 'BPNN';
BPNT : TwbSignature = 'BPNT';
BPTD : TwbSignature = 'BPTD';
BPTN : TwbSignature = 'BPTN';
BSIZ : TwbSignature = 'BSIZ'; { New to Fallout 4 }
BSMB : TwbSignature = 'BSMB'; { New to Fallout 4 }
BSMP : TwbSignature = 'BSMP'; { New to Fallout 4 }
BSMS : TwbSignature = 'BSMS'; { New to Fallout 4 }
BTXT : TwbSignature = 'BTXT';
CAMS : TwbSignature = 'CAMS';
CDIX : TwbSignature = 'CDIX'; { New to Fallout 4 }
CELL : TwbSignature = 'CELL';
CIS1 : TwbSignature = 'CIS1'; { New to Skyrim }
CIS2 : TwbSignature = 'CIS2'; { New to Skyrim }
CITC : TwbSignature = 'CITC'; { New to Skyrim }
CLAS : TwbSignature = 'CLAS';
CLFM : TwbSignature = 'CLFM';
CLMT : TwbSignature = 'CLMT';
CLSZ : TwbSignature = 'CLSZ'; { New to Fallout 4 }
CMPO : TwbSignature = 'CMPO'; { New to Fallout 4 }
CNAM : TwbSignature = 'CNAM';
CNTO : TwbSignature = 'CNTO';
COBJ : TwbSignature = 'COBJ';
COCT : TwbSignature = 'COCT'; { New to Skyrim 'Count'}
COED : TwbSignature = 'COED';
COLL : TwbSignature = 'COLL';
CONT : TwbSignature = 'CONT';
CPTH : TwbSignature = 'CPTH';
CRDT : TwbSignature = 'CRDT';
CRGR : TwbSignature = 'CRGR'; { New to Skyrim }
CRIF : TwbSignature = 'CRIF'; { New to Skyrim }
CRIS : TwbSignature = 'CRIS'; { New to Fallout 4 }
CRVA : TwbSignature = 'CRVA'; { New to Skyrim }
CS2H : TwbSignature = 'CS2H'; { New To Fallout 4 }
CS2D : TwbSignature = 'CS2D'; { New To Fallout 4 }
CS2E : TwbSignature = 'CS2E'; { New To Fallout 4 }
CS2F : TwbSignature = 'CS2F'; { New To Fallout 4 }
CS2K : TwbSignature = 'CS2K'; { New To Fallout 4 }
CSCR : TwbSignature = 'CSCR';
CSCV : TwbSignature = 'CSCV'; { New To Fallout 4 }
CSDC : TwbSignature = 'CSDC';
CSDI : TwbSignature = 'CSDI';
CSDT : TwbSignature = 'CSDT';
CSFL : TwbSignature = 'CSFL'; { New to Skyrim }
CSGD : TwbSignature = 'CSGD'; { New to Skyrim }
CSLR : TwbSignature = 'CSLR'; { New to Skyrim }
CSMD : TwbSignature = 'CSMD'; { New to Skyrim }
CSME : TwbSignature = 'CSME'; { New to Skyrim }
CSRA : TwbSignature = 'CSRA'; { New To Fallout 4 }
CSTY : TwbSignature = 'CSTY';
CTDA : TwbSignature = 'CTDA';
CUSD : TwbSignature = 'CUSD'; { New to Fallout 4 }
CVPA : TwbSignature = 'CVPA'; { New to Fallout 4 }
DALC : TwbSignature = 'DALC'; { New to Skyrim }
DAMA : TwbSignature = 'DAMA'; { New to Fallout 4 }
DAMC : TwbSignature = 'DAMC'; { New to Fallout 4 }
DATA : TwbSignature = 'DATA';
DEBR : TwbSignature = 'DEBR';
DELE : TwbSignature = 'DELE';
DEMO : TwbSignature = 'DEMO'; { New to Skyrim }
DESC : TwbSignature = 'DESC';
DEST : TwbSignature = 'DEST';
DEVA : TwbSignature = 'DEVA'; { New to Skyrim }
DFOB : TwbSignature = 'DFOB'; { New to Fallout 4 }
DFTF : TwbSignature = 'DFTF'; { New To Skyrim }
DFTM : TwbSignature = 'DFTM'; { New To Skyrim }
DIAL : TwbSignature = 'DIAL';
DLBR : TwbSignature = 'DLBR';
DLVW : TwbSignature = 'DLVW';
DMAX : TwbSignature = 'DMAX'; { New to Skyrim }
DMDC : TwbSignature = 'DMDC'; { New to Fallout 4 }
DMDL : TwbSignature = 'DMDL';
DMDS : TwbSignature = 'DMDS'; { New to Skyrim }
DMDT : TwbSignature = 'DMDT';
DMGT : TwbSignature = 'DMGT'; { New to Fallout 4 }
DMIN : TwbSignature = 'DMIN'; { New to Skyrim }
DNAM : TwbSignature = 'DNAM';
DOBJ : TwbSignature = 'DOBJ';
DODT : TwbSignature = 'DODT';
DOFT : TwbSignature = 'DOFT'; { New to Skyrim }
DOOR : TwbSignature = 'DOOR';
DPLT : TwbSignature = 'DPLT'; { New to Skyrim }
DSTA : TwbSignature = 'DSTA'; { New To Fallout 4 }
DSTD : TwbSignature = 'DSTD';
DSTF : TwbSignature = 'DSTF';
DTGT : TwbSignature = 'DTGT'; { New To Fallout 4 }
DTID : TwbSignature = 'DTID'; { New To Fallout 4 }
DUAL : TwbSignature = 'DUAL';
EAMT : TwbSignature = 'EAMT';
ECOR : TwbSignature = 'ECOR'; { New to Skyrim }
ECZN : TwbSignature = 'ECZN';
EDID : TwbSignature = 'EDID';
EFID : TwbSignature = 'EFID';
EFIT : TwbSignature = 'EFIT';
EFSH : TwbSignature = 'EFSH';
EITM : TwbSignature = 'EITM';
ENAM : TwbSignature = 'ENAM';
ENCH : TwbSignature = 'ENCH';
ENIT : TwbSignature = 'ENIT';
EPF2 : TwbSignature = 'EPF2';
EPF3 : TwbSignature = 'EPF3';
EPFB : TwbSignature = 'EPFB'; { New To Fallout 4 }
EPFD : TwbSignature = 'EPFD';
EPFT : TwbSignature = 'EPFT';
EQUP : TwbSignature = 'EQUP';
ESCE : TwbSignature = 'ESCE';
ETYP : TwbSignature = 'ETYP';
EXPL : TwbSignature = 'EXPL';
EYES : TwbSignature = 'EYES';
FACT : TwbSignature = 'FACT';
FCHT : TwbSignature = 'FCHT'; { New to Skyrim }
FCPL : TwbSignature = 'FCPL'; { New To Fallout 4 }
FFFF : TwbSignature = 'FFFF';
FIMD : TwbSignature = 'FIMD'; { New To Fallout 4 }
FLMV : TwbSignature = 'FLMV'; { New to Skyrim }
FLOR : TwbSignature = 'FLOR';
FLST : TwbSignature = 'FLST';
FLTR : TwbSignature = 'FLTR'; { New to Skyrim }
FLTV : TwbSignature = 'FLTV';
FMIN : TwbSignature = 'FMIN'; { New To Fallout 4 }
FMRI : TwbSignature = 'FMRI'; { New To Fallout 4 }
FMRN : TwbSignature = 'FMRN'; { New To Fallout 4 }
FMRS : TwbSignature = 'FMRS'; { New To Fallout 4 }
FNAM : TwbSignature = 'FNAM';
FNMK : TwbSignature = 'FNMK'; { New to Skyrim }
FNPR : TwbSignature = 'FNPR'; { New to Skyrim }
FPRT : TwbSignature = 'FPRT'; { New to Skyrim }
FSTP : TwbSignature = 'FSTP';
FSTS : TwbSignature = 'FSTS';
FTSF : TwbSignature = 'FTSF'; { New to Skyrim }
FTSM : TwbSignature = 'FTSM'; { New to Skyrim }
FTST : TwbSignature = 'FTST'; { New to Skyrim }
FTYP : TwbSignature = 'FTYP'; { New To Fallout 4 }
FULL : TwbSignature = 'FULL';
FURN : TwbSignature = 'FURN';
FVPA : TwbSignature = 'FVPA'; { New To Fallout 4 }
GDRY : TwbSignature = 'GDRY'; { New to Fallout 4 }
GLOB : TwbSignature = 'GLOB';
GMST : TwbSignature = 'GMST';
GNAM : TwbSignature = 'GNAM';
GRAS : TwbSignature = 'GRAS';
GREE : TwbSignature = 'GREE'; { New to Fallout 4 }
GWOR : TwbSignature = 'GWOR'; { New to Skyrim }
HAZD : TwbSignature = 'HAZD';
HCLF : TwbSignature = 'HCLF'; { New to Skyrim }
HDPT : TwbSignature = 'HDPT';
HEAD : TwbSignature = 'HEAD'; { New to Skyrim }
HEDR : TwbSignature = 'HEDR';
HLTX : TwbSignature = 'HLTX'; { New to Fallout 4 }
HNAM : TwbSignature = 'HNAM';
HTID : TwbSignature = 'HTID'; { New to Skyrim }
ICO2 : TwbSignature = 'ICO2';
ICON : TwbSignature = 'ICON';
IDLA : TwbSignature = 'IDLA';
IDLB : TwbSignature = 'IDLB';
IDLC : TwbSignature = 'IDLC';
IDLE : TwbSignature = 'IDLE';
IDLF : TwbSignature = 'IDLF';
IDLM : TwbSignature = 'IDLM';
IDLT : TwbSignature = 'IDLT';
IMAD : TwbSignature = 'IMAD';
IMGS : TwbSignature = 'IMGS';
IMSP : TwbSignature = 'IMSP'; { New to Skyrim }
INAM : TwbSignature = 'INAM';
INCC : TwbSignature = 'INCC'; { New to Skyrim }
INDX : TwbSignature = 'INDX';
INFO : TwbSignature = 'INFO';
INGR : TwbSignature = 'INGR';
INNR : TwbSignature = 'INNR'; { New To Fallout 4 }
INRD : TwbSignature = 'INRD'; { New To Fallout 4 }
INTT : TwbSignature = 'INTT'; { New To Fallout 4 }
INTV : TwbSignature = 'INTV';
IOVR : TwbSignature = 'IOVR'; { New To Fallout 4 }
IPCT : TwbSignature = 'IPCT';
IPDS : TwbSignature = 'IPDS';
ISIZ : TwbSignature = 'ISIZ'; { New To Fallout 4 }
ITID : TwbSignature = 'ITID'; { New To Fallout 4 }
ITMC : TwbSignature = 'ITMC'; { New To Fallout 4 }
ITME : TwbSignature = 'ITME'; { New To Fallout 4 }
ITMS : TwbSignature = 'ITMS'; { New To Fallout 4 }
ITXT : TwbSignature = 'ITXT';
JAIL : TwbSignature = 'JAIL'; { New To Skyrim }
JNAM : TwbSignature = 'JNAM';
JOUT : TwbSignature = 'JOUT'; { New To Skyrim }
KEYM : TwbSignature = 'KEYM';
KNAM : TwbSignature = 'KNAM';
KSIZ : TwbSignature = 'KSIZ';
KSSM : TwbSignature = 'KSSM'; { New To Fallout 4 }
KWDA : TwbSignature = 'KWDA';
KYWD : TwbSignature = 'KYWD';
LAND : TwbSignature = 'LAND';
LAYR : TwbSignature = 'LAYR'; { New to Fallout 4 }
LCEC : TwbSignature = 'LCEC'; { New to Skyrim }
LCEP : TwbSignature = 'LCEP'; { New to Skyrim }
LCID : TwbSignature = 'LCID'; { New to Skyrim }
LCPR : TwbSignature = 'LCPR'; { New to Skyrim }
LCRT : TwbSignature = 'LCRT';
LCSR : TwbSignature = 'LCSR'; { New to Skyrim }
LCTN : TwbSignature = 'LCTN';
LCUN : TwbSignature = 'LCUN'; { New to Skyrim }
LENS : TwbSignature = 'LENS'; { New to Fallout 4 }
LFSD : TwbSignature = 'LFSD'; { New to Fallout 4 }
LFSP : TwbSignature = 'LFSP'; { New to Fallout 4 }
LGTM : TwbSignature = 'LGTM';
LIGH : TwbSignature = 'LIGH';
LLCT : TwbSignature = 'LLCT'; {New to Skyrim, part of LVLI 'Count'}
LLKC : TwbSignature = 'LLKC'; { New to Fallout 4 }
LNAM : TwbSignature = 'LNAM';
LSCR : TwbSignature = 'LSCR';
LSPR : TwbSignature = 'LSPR'; { New to Fallout 4 }
LTEX : TwbSignature = 'LTEX';
LTMP : TwbSignature = 'LTMP';
LTPT : TwbSignature = 'LTPT'; { New to Fallout 4 }
LTPC : TwbSignature = 'LTPC'; { New to Fallout 4 }
LVLC : TwbSignature = 'LVLC';
LVLD : TwbSignature = 'LVLD';
LVLF : TwbSignature = 'LVLF';
LVLG : TwbSignature = 'LVLG';
LVLI : TwbSignature = 'LVLI';
LVLM : TwbSignature = 'LVLM'; { New to Fallout 4 }
LVLN : TwbSignature = 'LVLN';
LVLO : TwbSignature = 'LVLO';
LVSG : TwbSignature = 'LVSG'; { New to Fallout 4 }
LVSP : TwbSignature = 'LVSP';
MASE : TwbSignature = 'MASE'; { New To Fallout 4 }
MAST : TwbSignature = 'MAST';
MATO : TwbSignature = 'MATO';
MATT : TwbSignature = 'MATT';
MCHT : TwbSignature = 'MCHT'; { New to Skyrim }
MDOB : TwbSignature = 'MDOB';
MESG : TwbSignature = 'MESG';
MGEF : TwbSignature = 'MGEF';
MHDT : TwbSignature = 'MHDT'; { New to Skyrim }
MIC2 : TwbSignature = 'MIC2';
MICN : TwbSignature = 'MICN'; { New to Fallout 4 }
MICO : TwbSignature = 'MICO';
MISC : TwbSignature = 'MISC';
MLSI : TwbSignature = 'MLSI'; { New to Fallout 4 }
MNAM : TwbSignature = 'MNAM';
MO2C : TwbSignature = 'MO2C'; { New to Fallout 4 }
MO2F : TwbSignature = 'MO2F'; { New to Fallout 4 }
MO2S : TwbSignature = 'MO2S';
MO2T : TwbSignature = 'MO2T';
MO3C : TwbSignature = 'MO3C'; { New to Fallout 4 }
MO3F : TwbSignature = 'MO3F'; { New to Fallout 4 }
MO3S : TwbSignature = 'MO3S';
MO3T : TwbSignature = 'MO3T';
MO4C : TwbSignature = 'MO4C'; { New to Fallout 4 }
MO4F : TwbSignature = 'MO4F'; { New to Fallout 4 }
MO4S : TwbSignature = 'MO4S';
MO4T : TwbSignature = 'MO4T';
MO5C : TwbSignature = 'MO5C'; { New to Fallout 4 }
MO5F : TwbSignature = 'MO5F'; { New to Fallout 4 }
MO5S : TwbSignature = 'MO5S'; { New to Skyrim }
MO5T : TwbSignature = 'MO5T'; { New to Skyrim }
MOD2 : TwbSignature = 'MOD2';
MOD3 : TwbSignature = 'MOD3';
MOD4 : TwbSignature = 'MOD4';
MOD5 : TwbSignature = 'MOD5'; { New to Skyrim }
MODC : TwbSignature = 'MODC'; { New to Fallout 4 }
MODF : TwbSignature = 'MODF'; { New to Fallout 4 }
MODL : TwbSignature = 'MODL';
MODS : TwbSignature = 'MODS';
MODT : TwbSignature = 'MODT';
MODQ : TwbSignature = 'MODQ'; { New to Fallout 4 }
MOVT : TwbSignature = 'MOVT';
MPAI : TwbSignature = 'MPAI'; { New To Skyrim }
MPAV : TwbSignature = 'MPAV'; { New To Skyrim }
MPCD : TwbSignature = 'MPCD'; { New to Fallout 4 }
MPGN : TwbSignature = 'MPGN'; { New to Fallout 4 }
MPGS : TwbSignature = 'MPGS'; { New to Fallout 4 }
MPPC : TwbSignature = 'MPPC'; { New to Fallout 4 }
MPPF : TwbSignature = 'MPPF'; { New to Fallout 4 }
MPPI : TwbSignature = 'MPPI'; { New to Fallout 4 }
MPPK : TwbSignature = 'MPPK'; { New to Fallout 4 }
MPPM : TwbSignature = 'MPPM'; { New to Fallout 4 }
MPPN : TwbSignature = 'MPPN'; { New to Fallout 4 }
MPPT : TwbSignature = 'MPPT'; { New to Fallout 4 }
MPRT : TwbSignature = 'MPRT'; { New to Skyrim }
MRSV : TwbSignature = 'MRSV'; { New to Fallout 4 }
MSDK : TwbSignature = 'MSDK'; { New to Fallout 4 }
MSDV : TwbSignature = 'MSDV'; { New to Fallout 4 }
MSID : TwbSignature = 'MSID'; { New to Fallout 4 }
MSM0 : TwbSignature = 'MSM0'; { New to Fallout 4 }
MSM1 : TwbSignature = 'MSM1'; { New to Fallout 4 }
MSTT : TwbSignature = 'MSTT';
MSWP : TwbSignature = 'MSWP'; { New to Fallout 4 }
MTNM : TwbSignature = 'MTNM'; { New to Skyrim }
MTYP : TwbSignature = 'MTYP'; { New To Skyrim }
MUSC : TwbSignature = 'MUSC';
MUST : TwbSignature = 'MUST';
MWGT : TwbSignature = 'MWGT'; { New to Fallout 4 }
NAM0 : TwbSignature = 'NAM0';
NAM1 : TwbSignature = 'NAM1';
NAM2 : TwbSignature = 'NAM2';
NAM3 : TwbSignature = 'NAM3';
NAM4 : TwbSignature = 'NAM4';
NAM5 : TwbSignature = 'NAM5';
NAM6 : TwbSignature = 'NAM6';
NAM7 : TwbSignature = 'NAM7';
NAM8 : TwbSignature = 'NAM8';
NAM9 : TwbSignature = 'NAM9';
NAMA : TwbSignature = 'NAMA'; { New to Skyrim }
NAME : TwbSignature = 'NAME';
NAVI : TwbSignature = 'NAVI';
NAVM : TwbSignature = 'NAVM';
NETO : TwbSignature = 'NETO'; { New to Fallout 4 }
NEXT : TwbSignature = 'NEXT';
NNAM : TwbSignature = 'NNAM';
NNGT : TwbSignature = 'NNGT'; { New to Fallout 4 }
NNGS : TwbSignature = 'NNGS'; { New to Fallout 4 }
NNUS : TwbSignature = 'NNUS'; { New to Fallout 4 }
NNUT : TwbSignature = 'NNUT'; { New to Fallout 4 }
NOCM : TwbSignature = 'NOCM'; { New to Fallout 4 }
NONE : TwbSignature = 'NONE'; { New to Fallout 4, used in OMOD Form Type }
NOTE : TwbSignature = 'NOTE'; { New to Fallout 4 }
NPC_ : TwbSignature = 'NPC_';
NPOS : TwbSignature = 'NPOS'; { New to Fallout 4 }
NPOT : TwbSignature = 'NPOT'; { New to Fallout 4 }
NQUS : TwbSignature = 'NQUS'; { New to Fallout 4 }
NQUT : TwbSignature = 'NQUT'; { New to Fallout 4 }
NTOP : TwbSignature = 'NTOP'; { New to Fallout 4 }
NTRM : TwbSignature = 'NTRM'; { New to Fallout 4 }
NULL : TwbSignature = 'NULL';
NVER : TwbSignature = 'NVER';
NVMI : TwbSignature = 'NVMI';
NVNM : TwbSignature = 'NVNM'; { New to Skyrim }
NVPP : TwbSignature = 'NVPP'; { New to Skyrim }
NVSI : TwbSignature = 'NVSI'; { New to Dawnguard }
OBND : TwbSignature = 'OBND';
OBTE : TwbSignature = 'OBTE'; { New to Fallout 4 }
OBTF : TwbSignature = 'OBTF'; { New to Fallout 4 }
OBTS : TwbSignature = 'OBTS'; { New to Fallout 4 }
OCOR : TwbSignature = 'OCOR'; { New to Skyrim }
OFST : TwbSignature = 'OFST';
OMOD : TwbSignature = 'OMOD'; { New to Fallout 4 }
ONAM : TwbSignature = 'ONAM';
OTFT : TwbSignature = 'OTFT';
OVIS : TwbSignature = 'OVIS'; { New to Fallout 4 }
PACK : TwbSignature = 'PACK';
PARW : TwbSignature = 'PARW'; { New to Skyrim }
PBAR : TwbSignature = 'PBAR'; { New to Skyrim }
PBEA : TwbSignature = 'PBEA'; { New to Skyrim }
PCMB : TwbSignature = 'PCMB'; { New to Fallout 4 }
PCON : TwbSignature = 'PCON'; { New to Skyrim }
PDTO : TwbSignature = 'PDTO'; { New to Skyrim }
PERK : TwbSignature = 'PERK';
PFIG : TwbSignature = 'PFIG';
PFLA : TwbSignature = 'PFLA'; { New to Skyrim }
PFO2 : TwbSignature = 'PFO2'; { New to Skyrim }
PFOR : TwbSignature = 'PFOR'; { New to Skyrim }
PFPC : TwbSignature = 'PFPC';
PFRN : TwbSignature = 'PFRN'; { New to Fallout 4 }
PGRE : TwbSignature = 'PGRE';
PHTN : TwbSignature = 'PHTN'; { New to Skyrim }
PHWT : TwbSignature = 'PHWT'; { New to Skyrim }
PHZD : TwbSignature = 'PHZD';
PKC2 : TwbSignature = 'PKC2'; { New to Skyrim }
PKCU : TwbSignature = 'PKCU'; { New to Skyrim }
PKDT : TwbSignature = 'PKDT';
PKID : TwbSignature = 'PKID';
PKIN : TwbSignature = 'PKIN'; { New to Fallout 4 }
PLCN : TwbSignature = 'PLCN'; { New to Skyrim }
PLDT : TwbSignature = 'PLDT';
PLVD : TwbSignature = 'PLVD'; { New to Skyrim }
PLYR : TwbSignature = 'PLYR';
PMIS : TwbSignature = 'PMIS';
PNAM : TwbSignature = 'PNAM';
POBA : TwbSignature = 'POBA';
POCA : TwbSignature = 'POCA';
POEA : TwbSignature = 'POEA';
PRCB : TwbSignature = 'PRCB'; { New to Skyrim }
PRKC : TwbSignature = 'PRKC';
PRKE : TwbSignature = 'PRKE';
PRKF : TwbSignature = 'PRKF';
PRKR : TwbSignature = 'PRKR'; { New to Skyrim }
PRKZ : TwbSignature = 'PRKZ'; { New to Skyrim }
PROJ : TwbSignature = 'PROJ';
PRPS : TwbSignature = 'PRPS'; { New to Fallout 4 }
PSDT : TwbSignature = 'PSDT';
PTDA : TwbSignature = 'PTDA'; { New to Skyrim }
PTOP : TwbSignature = 'PTOP'; { New to Fallout 4 }
PTRN : TwbSignature = 'PTRN'; { New to Fallout 4 }
QNAM : TwbSignature = 'QNAM';
QOBJ : TwbSignature = 'QOBJ';
QSDT : TwbSignature = 'QSDT';
QSTA : TwbSignature = 'QSTA';
QSTI : TwbSignature = 'QSTI'; { New to Fallout 4 }
QTGL : TwbSignature = 'QTGL'; { New To Skyrim }
QTOP : TwbSignature = 'QTOP'; { New to Fallout 4 }
QUAL : TwbSignature = 'QUAL'; { New To Skyrim }
QUST : TwbSignature = 'QUST';
RACE : TwbSignature = 'RACE';
RADR : TwbSignature = 'RADR'; { New To Fallout 4 }
RBPC : TwbSignature = 'RBPC'; { New To Fallout 4 }
RCEC : TwbSignature = 'RCEC'; { New To Skyrim }
RCLR : TwbSignature = 'RCLR';
RCPR : TwbSignature = 'RCPR'; { New to Dawnguard }
RCSR : TwbSignature = 'RCSR'; { New To Skyrim }
RCUN : TwbSignature = 'RCUN'; { New To Skyrim }
RDAT : TwbSignature = 'RDAT';
RDGS : TwbSignature = 'RDGS';
RDMO : TwbSignature = 'RDMO';
RDMP : TwbSignature = 'RDMP';
RDOT : TwbSignature = 'RDOT';
RDSA : TwbSignature = 'RDSA'; { New to Skyrim }
RDWT : TwbSignature = 'RDWT';
REFR : TwbSignature = 'REFR';
REGN : TwbSignature = 'REGN';
RELA : TwbSignature = 'RELA';
REPL : TwbSignature = 'REPL';
REPT : TwbSignature = 'REPT'; { New To Fallout 4 }
REVB : TwbSignature = 'REVB';
RFCT : TwbSignature = 'RFCT';
RFGP : TwbSignature = 'RFGP'; { New to Fallout 4 }
RGDL : TwbSignature = 'RGDL'; { Unused in Skyrim, but contained in Skyrim.esm }
RLDM : TwbSignature = 'RLDM'; { New to Fallout 4 }
RNAM : TwbSignature = 'RNAM';
RNMV : TwbSignature = 'RNMV'; { New to Skyrim }
RPLD : TwbSignature = 'RPLD';
RPLI : TwbSignature = 'RPLI';
RPRF : TwbSignature = 'RPRF'; { New To Skyrim }
RPRM : TwbSignature = 'RPRM'; { New To Skyrim }
RVIS : TwbSignature = 'RVIS'; { New to Fallout 4 }
SADD : TwbSignature = 'SADD'; { New To Fallout 4 }
SAKD : TwbSignature = 'SAKD'; { New To Fallout 4 }
SAPT : TwbSignature = 'SAPT'; { New To Fallout 4 }
SCCO : TwbSignature = 'SCCO'; { New To Fallout 4 }
SCDA : TwbSignature = 'SCDA';
SCEN : TwbSignature = 'SCEN';
SCHR : TwbSignature = 'SCHR';
SCOL : TwbSignature = 'SCOL'; { Unused in Skyrim, but contained in Skyrim.esm }
SCPT : TwbSignature = 'SCPT'; { Unused in Skyrim, but contained in Skyrim.esm }
SCQS : TwbSignature = 'SCQS'; { New To Fallout 4 }
SCRL : TwbSignature = 'SCRL';
SCRN : TwbSignature = 'SCRN';
SCRO : TwbSignature = 'SCRO';
SCSN : TwbSignature = 'SCSN'; { New To Fallout 4 }
SCTX : TwbSignature = 'SCTX';
SDSC : TwbSignature = 'SDSC'; { New to Skyrim }
SGNM : TwbSignature = 'SGNM'; { New to Fallout 4 }
SHOU : TwbSignature = 'SHOU';
SHRT : TwbSignature = 'SHRT'; { New to Skyrim }
SKIL : TwbSignature = 'SKIL'; { New to Fallout 4 }
SLCP : TwbSignature = 'SLCP';
SLGM : TwbSignature = 'SLGM';
SMBN : TwbSignature = 'SMBN';
SMEN : TwbSignature = 'SMEN';
SMQN : TwbSignature = 'SMQN';
SNAM : TwbSignature = 'SNAM';
SNCT : TwbSignature = 'SNCT';
SNDD : TwbSignature = 'SNDD';
SNDR : TwbSignature = 'SNDR';
SNMV : TwbSignature = 'SNMV'; { New to Skyrim }
SOFT : TwbSignature = 'SOFT'; { New to Skyrim }
SOPM : TwbSignature = 'SOPM';
SOUL : TwbSignature = 'SOUL';
SOUN : TwbSignature = 'SOUN';
SPCT : TwbSignature = 'SPCT'; { New to Skyrim }
SPED : TwbSignature = 'SPED'; { New To Skyrim }
SPEL : TwbSignature = 'SPEL';
SPGD : TwbSignature = 'SPGD';
SPIT : TwbSignature = 'SPIT';
SPLO : TwbSignature = 'SPLO';
SPMV : TwbSignature = 'SPMV'; { New To Skyrim }
SPOR : TwbSignature = 'SPOR'; { New to Skyrim }
SRAC : TwbSignature = 'SRAC'; { New to Fallout 4 }
SRAF : TwbSignature = 'SRAF'; { New to Fallout 4 }
SSPN : TwbSignature = 'SSPN'; { New to Fallout 4 }
STAG : TwbSignature = 'STAG'; { New to Fallout 4 }
STAT : TwbSignature = 'STAT';
STCP : TwbSignature = 'STCP'; { New to Fallout 4 }
STKD : TwbSignature = 'STKD'; { New to Fallout 4 }
STOL : TwbSignature = 'STOL'; { New to Skyrim }
STOP : TwbSignature = 'STOP'; { New to Fallout 4 }
STSC : TwbSignature = 'STSC'; { New to Fallout 4 }
SWMV : TwbSignature = 'SWMV'; { New to Skyrim }
TACT : TwbSignature = 'TACT';
TCLT : TwbSignature = 'TCLT';
TERM : TwbSignature = 'TERM'; { New to Fallout 4 }
TES4 : TwbSignature = 'TES4';
TETI : TwbSignature = 'TETI'; { New to Fallout 4 }
TEND : TwbSignature = 'TEND'; { New to Fallout 4 }
TIAS : TwbSignature = 'TIAS'; { New to Skyrim }
TIFC : TwbSignature = 'TIFC'; { New To Skyrim }
TINC : TwbSignature = 'TINC'; { New to Skyrim }
TIND : TwbSignature = 'TIND'; { New to Skyrim }
TINI : TwbSignature = 'TINI'; { New to Skyrim }
TINL : TwbSignature = 'TINL'; { New to Skyrim }
TINP : TwbSignature = 'TINP'; { New to Skyrim }
TINT : TwbSignature = 'TINT'; { New to Skyrim }
TINV : TwbSignature = 'TINV'; { New to Skyrim }
TIQS : TwbSignature = 'TIQS'; { New to Fallout 4 }
TIRS : TwbSignature = 'TIRS'; { New to Skyrim }
TLOD : TwbSignature = 'TLOD'; { New to Fallout 4 }
TNAM : TwbSignature = 'TNAM';
TOFT : TwbSignature = 'TOFT'; { New to Fallout 4 }
TPIC : TwbSignature = 'TPIC';
TPLT : TwbSignature = 'TPLT';
TPTA : TwbSignature = 'TPTA'; { New To Fallout 4 }
TRDA : TwbSignature = 'TRDA'; { New To Fallout 4 }
TRDT : TwbSignature = 'TRDT';
TREE : TwbSignature = 'TREE';
TRNS : TwbSignature = 'TRNS'; { New To Fallout 4 }
TSCE : TwbSignature = 'TSCE'; { New To Fallout 4 }
TTEB : TwbSignature = 'TTEB'; { New To Fallout 4 }
TTEC : TwbSignature = 'TTEC'; { New To Fallout 4 }
TTED : TwbSignature = 'TTED'; { New To Fallout 4 }
TTEF : TwbSignature = 'TTEF'; { New To Fallout 4 }
TTET : TwbSignature = 'TTET'; { New To Fallout 4 }
TTGE : TwbSignature = 'TTGE'; { New To Fallout 4 }
TTGP : TwbSignature = 'TTGP'; { New To Fallout 4 }
TVDT : TwbSignature = 'TVDT'; { New To Skyrim }
TWAT : TwbSignature = 'TWAT'; { New To Skyrim }
TX00 : TwbSignature = 'TX00';
TX01 : TwbSignature = 'TX01';
TX02 : TwbSignature = 'TX02';
TX03 : TwbSignature = 'TX03';
TX04 : TwbSignature = 'TX04';
TX05 : TwbSignature = 'TX05';
TX06 : TwbSignature = 'TX06'; { New To Skyrim }
TX07 : TwbSignature = 'TX07'; { New To Skyrim }
TXST : TwbSignature = 'TXST';
UNAM : TwbSignature = 'UNAM';
UNES : TwbSignature = 'UNES'; { New To Skyrim }
UNWP : TwbSignature = 'UNWP'; { New To Fallout 4 }
VATS : TwbSignature = 'VATS';
VCLR : TwbSignature = 'VCLR';
VENC : TwbSignature = 'VENC'; { New To Skyrim }
VEND : TwbSignature = 'VEND'; { New To Skyrim }
VENV : TwbSignature = 'VENV'; { New To Skyrim }
VHGT : TwbSignature = 'VHGT';
VISI : TwbSignature = 'VISI'; { New To Fallout 4 }
VMAD : TwbSignature = 'VMAD';
VNAM : TwbSignature = 'VNAM';
VNML : TwbSignature = 'VNML';
VTCK : TwbSignature = 'VTCK';
VTEX : TwbSignature = 'VTEX';
VTXT : TwbSignature = 'VTXT';
VTYP : TwbSignature = 'VTYP';
WAIT : TwbSignature = 'WAIT'; { New To Skyrim }
WAMD : TwbSignature = 'WAMD'; { New To Fallout 4 }
WATR : TwbSignature = 'WATR';
WBDT : TwbSignature = 'WBDT'; { New to Skyrim }
WCTR : TwbSignature = 'WCTR'; { New To Skyrim }
WEAP : TwbSignature = 'WEAP';
WGDR : TwbSignature = 'WGDR'; { New To Fallout 4 }
WKMV : TwbSignature = 'WKMV'; { New to Skyrim }
WLEV : TwbSignature = 'WLEV'; { New To Fallout 4 }
WLST : TwbSignature = 'WLST';
WMAP : TwbSignature = 'WMAP'; { New To Fallout 4 }
WNAM : TwbSignature = 'WNAM';
WOOP : TwbSignature = 'WOOP';
WRLD : TwbSignature = 'WRLD';
WTHR : TwbSignature = 'WTHR';
WZMD : TwbSignature = 'WZMD'; { New To Fallout 4 }
XACT : TwbSignature = 'XACT';
XALP : TwbSignature = 'XALP'; { New To Skyrim }
XAMC : TwbSignature = 'XAMC'; { New To Fallout 4 }
XAPD : TwbSignature = 'XAPD';
XAPR : TwbSignature = 'XAPR';
XASP : TwbSignature = 'XASP'; { New To Fallout 4 }
XATP : TwbSignature = 'XATP'; { New To Fallout 4 }
XATR : TwbSignature = 'XATR'; { New To Dawnguard }
XBSD : TwbSignature = 'XBSD'; { New To Fallout 4 }
XCAS : TwbSignature = 'XCAS';
XCCM : TwbSignature = 'XCCM';
XCHG : TwbSignature = 'XCHG';
XCIM : TwbSignature = 'XCIM';
XCLC : TwbSignature = 'XCLC';
XCLL : TwbSignature = 'XCLL';
XCLP : TwbSignature = 'XCLP';
XCLR : TwbSignature = 'XCLR';
XCLW : TwbSignature = 'XCLW';
XCMO : TwbSignature = 'XCMO';
XCNT : TwbSignature = 'XCNT';
XCRI : TwbSignature = 'XCRI'; { New To Fallout 4 }
XCVL : TwbSignature = 'XCVL'; { New To Skyrim }
XCVR : TwbSignature = 'XCVR'; { New To Fallout 4 }
XCWT : TwbSignature = 'XCWT';
XCZA : TwbSignature = 'XCZA'; { New To Skyrim }
XCZC : TwbSignature = 'XCZC'; { New To Skyrim }
XCZR : TwbSignature = 'XCZR'; { New To Skyrim }
XDCR : TwbSignature = 'XDCR';
XEMI : TwbSignature = 'XEMI';
XESP : TwbSignature = 'XESP';
XEZN : TwbSignature = 'XEZN';
XFVC : TwbSignature = 'XFVC'; { New To Skyrim }
XGDR : TwbSignature = 'XGDR'; { New To Fallout 4 }
XGLB : TwbSignature = 'XGLB';
XHLP : TwbSignature = 'XHLP';
XHLT : TwbSignature = 'XHLT'; { New To Fallout 4 }
XHOR : TwbSignature = 'XHOR'; { New To Skyrim }
XHTW : TwbSignature = 'XHTW'; { New To Skyrim }
XIBS : TwbSignature = 'XIBS';
XILL : TwbSignature = 'XILL'; { New To Skyrim }
XILW : TwbSignature = 'XILW'; { New To Fallout 4 }
XIS2 : TwbSignature = 'XIS2'; { New To Skyrim }
XLCM : TwbSignature = 'XLCM';
XLCN : TwbSignature = 'XLCN'; { New To Skyrim }
XLIB : TwbSignature = 'XLIB'; { New To Skyrim }
XLIG : TwbSignature = 'XLIG'; { New To Skyrim }
XLKR : TwbSignature = 'XLKR';
XLKT : TwbSignature = 'XLKT'; { New To Fallout 4 }
XLOC : TwbSignature = 'XLOC';
XLOD : TwbSignature = 'XLOD';
XLRL : TwbSignature = 'XLRL'; { New To Skyrim }
XLRM : TwbSignature = 'XLRM';
XLRT : TwbSignature = 'XLRT'; { New To Skyrim }
XLTW : TwbSignature = 'XLTW';
XLYR : TwbSignature = 'XLYR'; { New To Fallout 4 }
XMBO : TwbSignature = 'XMBO';
XMBP : TwbSignature = 'XMBP';
XMBR : TwbSignature = 'XMBR';
XMRC : TwbSignature = 'XMRC';
XMRK : TwbSignature = 'XMRK';
XMSP : TwbSignature = 'XMSP'; { New To Fallout 4 }
XNAM : TwbSignature = 'XNAM';
XNDP : TwbSignature = 'XNDP';
XOCP : TwbSignature = 'XOCP';
XORD : TwbSignature = 'XORD';
XOWN : TwbSignature = 'XOWN';
XPDD : TwbSignature = 'XPDD'; { New To Fallout 4 }
XPLK : TwbSignature = 'XPLK'; { New To Fallout 4 }
XPOD : TwbSignature = 'XPOD';
XPPA : TwbSignature = 'XPPA';
XPRD : TwbSignature = 'XPRD';
XPRI : TwbSignature = 'XPRI'; { New To Fallout 4 }
XPRM : TwbSignature = 'XPRM';
XPTL : TwbSignature = 'XPTL';
XPWR : TwbSignature = 'XPWR';
XRDO : TwbSignature = 'XRDO'; { New To Fallout 4 }
XRDS : TwbSignature = 'XRDS';
XRFG : TwbSignature = 'XRFG'; { New To Fallout 4 }
XRGB : TwbSignature = 'XRGB';
XRGD : TwbSignature = 'XRGD';
XRMR : TwbSignature = 'XRMR';
XRNK : TwbSignature = 'XRNK';
XSCL : TwbSignature = 'XSCL';
XSPC : TwbSignature = 'XSPC'; { New To Skyrim }
XTEL : TwbSignature = 'XTEL';
XTNM : TwbSignature = 'XTNM'; { New To Skyrim }
XTRI : TwbSignature = 'XTRI';
XWCN : TwbSignature = 'XWCN'; { New To Skyrim }
XWCS : TwbSignature = 'XWCS'; { New To Skyrim }
XWCU : TwbSignature = 'XWCU'; { New To Skyrim }
XWEM : TwbSignature = 'XWEM'; { New To Skyrim }
XWPG : TwbSignature = 'XWPG'; { New To Fallout 4 }
XWPN : TwbSignature = 'XWPN'; { New To Fallout 4 }
XXXX : TwbSignature = 'XXXX';
YNAM : TwbSignature = 'YNAM';
ZNAM : TwbSignature = 'ZNAM';
ZOOM : TwbSignature = 'ZOOM'; { New To Fallout 4 }
// signatures of reference records
sigReferences : array [0..11] of TwbSignature = (
'NULL', 'PLYR', 'ACHR', 'REFR', 'PGRE', 'PHZD',
'PMIS', 'PARW', 'PBAR', 'PBEA', 'PCON', 'PFLA'
);
// signatures of referenceable records (placed by references or constructable)
sigBaseObjects : array [0..43] of TwbSignature = (
'NULL', 'ACTI', 'ADDN', 'ALCH', 'AMMO', 'ARMO',
'ARTO', 'ASPC', 'BNDS', 'BOOK', 'CMPO', 'COBJ',
'CONT', 'DEBR', 'DOOR', 'EXPL', 'FLST', 'FLOR',
'FURN', 'HAZD', 'IDLM', 'INGR', 'KEYM', 'LIGH',
'LVLI', 'LVLN', 'LVSP', 'MISC', 'MSTT', 'NOTE',
'NPC_', 'OMOD', 'PROJ', 'SCOL', 'SCRL', 'SOUN',
'SPEL', 'STAT', 'TACT', 'TERM', 'TREE', 'TXST',
'WATR', 'WEAP'
);
var
wbPKDTSpecificFlagsUnused : Boolean;
wbEDID: IwbSubRecordDef;
wbCOED: IwbSubRecordDef;
wbXLCM: IwbSubRecordDef;
wbEITM: IwbSubRecordDef;
wbOBND: IwbSubRecordDef;
wbOBNDReq: IwbSubRecordDef;
wbDEST: IwbSubRecordStructDef;
wbDESTActor: IwbSubRecordStructDef;
wbDODT: IwbSubRecordDef;
wbXRGD: IwbSubRecordDef;
wbXRGB: IwbSubRecordDef;
wbSPLO: IwbSubRecordDef;
wbSPLOs: IwbSubRecordArrayDef;
wbCNTO: IwbSubRecordStructDef;
wbCNTOs: IwbSubRecordArrayDef;
wbAIDT: IwbSubRecordDef;
wbFULL: IwbSubRecordDef;
wbFULLActor: IwbSubRecordDef;
wbFULLReq: IwbSubRecordDef;
wbDESC: IwbSubRecordDef;
wbDESCReq: IwbSubRecordDef;
wbXSCL: IwbSubRecordDef;
wbDATAPosRot: IwbSubRecordDef;
wbPosRot: IwbStructDef;
wbMODC: IwbSubRecordDef;
wbMODF: IwbSubRecordDef;
wbMODL: IwbSubRecordStructDef;
wbMODS: IwbSubRecordDef;
wbMO2S: IwbSubRecordDef;
wbMO3S: IwbSubRecordDef;
wbMO4S: IwbSubRecordDef;
wbMO2F: IwbSubRecordDef;
wbMO3F: IwbSubRecordDef;
wbMO4F: IwbSubRecordDef;
wbMO5F: IwbSubRecordDef;
wbMO2C: IwbSubRecordDef;
wbMO3C: IwbSubRecordDef;
wbMO4C: IwbSubRecordDef;
wbMO5C: IwbSubRecordDef;
wbMODLActor: IwbSubRecordStructDef;
wbMODLReq: IwbSubRecordStructDef;
wbCTDA: IwbSubRecordStructDef;
wbCTDAs: IwbSubRecordArrayDef;
wbCTDAsReq: IwbSubRecordArrayDef;
wbCTDAsCount: IwbSubRecordArrayDef;
wbCTDAsReqCount: IwbSubRecordArrayDef;
wbXLOD: IwbSubRecordDef;
wbXESP: IwbSubRecordDef;
wbICON: IwbSubRecordDef;
wbMICO: IwbSubRecordDef;
wbActorValue: IwbIntegerDef;
wbETYP: IwbSubRecordDef;
wbETYPReq: IwbSubRecordDef;
wbEFID: IwbSubRecordDef;
wbEFIT: IwbSubRecordDef;
wbEffectsReq: IwbSubRecordArrayDef;
wbFirstPersonFlagsU32: IwbIntegerDef;
wbBOD2: IwbSubRecordDef;
wbScriptEntry: IwbStructDef;
wbScriptFlags: IwbIntegerDef;
wbScriptPropertyObject: IwbUnionDef;
wbScriptPropertyStruct: IwbArrayDef;
wbScriptProperties: IwbArrayDef;
wbScriptFragments: IwbStructDef;
wbScriptFragmentsQuest: IwbStructDef;
wbScriptFragmentsInfo: IwbStructDef;
wbScriptFragmentsPack: IwbStructDef;
wbScriptFragmentsScen: IwbStructDef;
wbPLDT: IwbSubRecordDef;
wbPLVD: IwbSubRecordDef;
wbTargetData: IwbStructDef;
wbAttackData: IwbSubRecordStructDef;
wbLLCT: IwbSubRecordDef;
wbLVLD: IwbSubRecordDef;
wbVMAD: IwbSubRecordDef;
wbVMADFragmentedPERK: IwbSubRecordDef;
wbVMADFragmentedPACK: IwbSubRecordDef;
wbVMADFragmentedQUST: IwbSubRecordDef;
wbVMADFragmentedSCEN: IwbSubRecordDef;
wbVMADFragmentedINFO: IwbSubRecordDef;
wbCOCT: IwbSubRecordDef;
wbKSIZ: IwbSubRecordDef;
wbKWDAs: IwbSubRecordDef;
wbReqKWDAs: IwbSubRecordDef;
wbKeywords: IwbSubRecordStructDef;
wbCNAM: IwbSubRecordDef;
wbCITC: IwbSubRecordDef;
wbMGEFData: IwbSubRecordStructDef;
wbMGEFType: IwbIntegerDef;
wbMDOB: IwbSubRecordDef;
wbSPIT: IwbSubRecordDef;
wbDMDC: IwbSubRecordDef;
wbDMDS: IwbSubRecordDef;
wbMO5S: IwbSubRecordDef;
wbSPCT: IwbSubRecordDef;
wbMODT: IwbSubRecordDef;
wbDMDT: IwbSubRecordDef;
wbXOWN: IwbSubRecordDef;
wbXRNK: IwbSubRecordDef;
wbPhonemeTargets: IwbSubRecordDef;
wbPHWT: IwbSubRecordStructDef;
wbHeadPart: IwbSubRecordStructDef;
wbQUSTAliasFlags: IwbSubRecordDef;
wbPDTO: IwbSubRecordDef;
wbPDTOs: IwbSubRecordArrayDef;
wbUNAMs: IwbSubRecordArrayDef;
wbNull: IwbValueDef;
wbTimeInterpolator: IwbStructDef;
wbColorInterpolator: IwbStructDef;
wbYNAM: IwbSubRecordDef;
wbZNAM: IwbSubRecordDef;
wbSPED: IwbSubRecordDef;
wbCUSD: IwbSubRecordDef;
wbINRD: IwbSubRecordDef;
wbPTRN: IwbSubRecordDef;
wbNTRM: IwbSubRecordDef;
wbPRPS: IwbSubRecordDef;
wbFLTR: IwbSubRecordDef;
wbAPPR: IwbSubRecordDef;
wbObjectTemplate: IwbSubRecordStructDef;
wbBSMPSequence: IwbSubRecordArrayDef;
wbFTYP: IwbSubRecordDef;
wbATTX: IwbSubRecordDef;
wbMNAMFurnitureMarker: IwbSubRecordDef;
wbSNAMMarkerParams: IwbSubRecordDef;
wbOBTSReq: IwbSubRecordDef;
//wbTintTemplateGroups: IwbSubrecordArrayDef;
//wbMorphGroups: IwbSubrecordArrayDef;
//wbRaceFRMI: IwbSubrecordArrayDef;
wbRaceRBPC: IwbSubRecordDef;
wbNVNM: IwbSubRecordDef;
wbMaxHeightDataCELL: IwbSubRecordDef;
wbMaxHeightDataWRLD: IwbSubRecordDef;
wbOFST: IwbSubRecordDef;
function Sig2Int(aSignature: TwbSignature): Cardinal; inline;
begin
Result := PCardinal(@aSignature)^;
end;
function wbEPFDActorValueToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
AsCardinal : Cardinal;
AsFloat : Single;
begin
AsCardinal := aInt;
AsFloat := PSingle(@AsCardinal)^;
aInt := Round(AsFloat);
case aType of
ctToStr: Result := wbActorValueEnum.ToString(aInt, aElement);
ctToSortKey: Result := wbActorValueEnum.ToSortKey(aInt, aElement);
ctCheck: Result := wbActorValueEnum.Check(aInt, aElement);
ctToEditValue: Result := wbActorValueEnum.ToEditValue(aInt, aElement);
ctEditType: Result := 'ComboBox';
ctEditInfo: Result := wbActorValueEnum.EditInfo[aInt, aElement];
end;
end;
function wbEPFDActorValueToInt(const aString: string; const aElement: IwbElement): Int64;
var
AsCardinal : Cardinal;
AsFloat : Single;
begin
AsFloat := wbActorValueEnum.FromEditValue(aString, aElement);
PSingle(@AsCardinal)^ := AsFloat;
Result := AsCardinal;
end;
function wbCTDAParam2QuestStageToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
EditInfos : TStringList;
Stages : IwbContainerElementRef;
Stage : IwbContainerElementRef;
i, j : Integer;
s, t : string;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Param1 := Container.ElementByName['Parameter #1'];
if not Assigned(Param1) then
Exit;
if not Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
Exit;
// get winning quest override except for partial forms
if MainRecord.WinningOverride.Flags._Flags and $00004000 = 0 then
MainRecord := MainRecord.WinningOverride
else if MainRecord.Flags._Flags and $00004000 <> 0 then
MainRecord := MainRecord.MasterOrSelf;
if MainRecord.Signature <> QUST then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
case aType of
ctEditType: begin
Result := 'ComboBox';
Exit;
end;
ctEditInfo:
EditInfos := TStringList.Create;
else
EditInfos := nil;
end;
try
if Supports(MainRecord.ElementByName['Stages'], IwbContainerElementRef, Stages) then begin
for i := 0 to Pred(Stages.ElementCount) do
if Supports(Stages.Elements[i], IwbContainerElementRef, Stage) then begin
j := Stage.ElementNativeValues['INDX\Stage Index'];
s := Trim(Stage.ElementValues['Log Entries\Log Entry\CNAM']);
t := IntToStr(j);
while Length(t) < 3 do
t := '0' + t;
if s <> '' then
t := t + ' ' + s;
if Assigned(EditInfos) then
EditInfos.AddObject(t, TObject(j))
else if j = aInt then begin
case aType of
ctToStr, ctToEditValue: Result := t;
ctCheck: Result := '';
end;
Exit;
end;
end;
end;
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
ctEditInfo: begin
EditInfos.Sort;
Result := EditInfos.CommaText;
end;
end;
finally
FreeAndNil(EditInfos);
end;
end;
function wbPerkDATAQuestStageToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
EditInfos : TStringList;
Stages : IwbContainerElementRef;
Stage : IwbContainerElementRef;
i, j : Integer;
s, t : string;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Param1 := Container.ElementByName['Quest'];
if not Assigned(Param1) then
Exit;
if not Supports(Param1.LinksTo, IwbMainRecord, MainRecord) then
Exit;
// get winning quest override except for partial forms
if MainRecord.WinningOverride.Flags._Flags and $00004000 = 0 then
MainRecord := MainRecord.WinningOverride
else if MainRecord.Flags._Flags and $00004000 <> 0 then
MainRecord := MainRecord.MasterOrSelf;
if MainRecord.Signature <> QUST then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
case aType of
ctEditType: begin
Result := 'ComboBox';
Exit;
end;
ctEditInfo:
EditInfos := TStringList.Create;
else
EditInfos := nil;
end;
try
if Supports(MainRecord.ElementByName['Stages'], IwbContainerElementRef, Stages) then begin
for i := 0 to Pred(Stages.ElementCount) do
if Supports(Stages.Elements[i], IwbContainerElementRef, Stage) then begin
j := Stage.ElementNativeValues['INDX\Stage Index'];
s := Trim(Stage.ElementValues['Log Entries\Log Entry\CNAM']);
t := IntToStr(j);
while Length(t) < 3 do
t := '0' + t;
if s <> '' then
t := t + ' ' + s;
if Assigned(EditInfos) then
EditInfos.AddObject(t, TObject(j))
else if j = aInt then begin
case aType of
ctToStr, ctToEditValue: Result := t;
ctCheck: Result := '';
end;
Exit;
end;
end;
end;
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
ctEditInfo: begin
EditInfos.Sort;
Result := EditInfos.CommaText;
end;
end;
finally
FreeAndNil(EditInfos);
end;
end;
function wbCTDAParam2QuestStageToInt(const aString: string; const aElement: IwbElement): Int64;
var
i : Integer;
s : string;
begin
i := 1;
s := Trim(aString);
while (i <= Length(s)) and (s[i] in ['0'..'9']) do
Inc(i);
s := Copy(s, 1, Pred(i));
Result := StrToInt(s);
end;
function wbREFRNavmeshTriangleToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
Navmesh : IwbElement;
MainRecord : IwbMainRecord;
Triangles : IwbContainerElementRef;
begin
case aType of
ctToStr: Result := IntToStr(aInt);
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if not Assigned(aElement) then Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then Exit;
Navmesh := Container.Elements[0];
if not Assigned(Navmesh) then
Exit;
if not Supports(Navmesh.LinksTo, IwbMainRecord, MainRecord) then
Exit;
MainRecord := MainRecord.WinningOverride;
if MainRecord.Signature <> NAVM then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
if Supports(MainRecord.ElementByPath['NVNM\Triangles'], IwbContainerElementRef, Triangles) and (aType = ctCheck) then
if aInt >= Triangles.ElementCount then
Result := '';
end;
function wbStringToInt(const aString: string; const aElement: IwbElement): Int64;
begin
Result := StrToIntDef(aString, 0);
end;
{ Alias to string conversion, requires quest reference or quest record specific to record that references alias }
function wbAliasToStr(aInt: Int64; const aQuestRef: IwbElement; aType: TwbCallbackType): string;
var
MainRecord : IwbMainRecord;
EditInfos : TStringList;
Aliases : IwbContainerElementRef;
Alias : IwbContainerElementRef;
i, j : Integer;
s, t : string;
begin
case aType of
ctToStr: if aInt = -1 then
Result := 'None'
else if aInt = -2 then
Result := 'Player'
else
Result := IntToStr(aInt) + ' ';
ctToEditValue: if aInt = -1 then Result := 'None' else
Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: if (aInt = -1) or (aInt = -2) then Result := '' else
Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
if ((aInt = -1) or (aInt = -2)) and (aType <> ctEditType) and (aType <> ctEditInfo) then
Exit;
if not Assigned(aQuestRef) then
Exit;
// aQuestRef can be a QUST record or reference to QUST record
if not Supports(aQuestRef, IwbMainRecord, MainRecord) then
if not Supports(aQuestRef.LinksTo, IwbMainRecord, MainRecord) then
Exit;
// get winning quest override except for partial forms
if MainRecord.WinningOverride.Flags._Flags and $00004000 = 0 then
MainRecord := MainRecord.WinningOverride
else if MainRecord.Flags._Flags and $00004000 <> 0 then
MainRecord := MainRecord.MasterOrSelf;
if MainRecord.Signature <> QUST then begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
end;
Exit;
end;
case aType of
ctEditType: begin
Result := 'ComboBox';
Exit;
end;
ctEditInfo: begin
EditInfos := TStringList.Create;
end;
else
EditInfos := nil;
end;
try
if Supports(MainRecord.ElementByName['Aliases'], IwbContainerElementRef, Aliases) then begin
for i := 0 to Pred(Aliases.ElementCount) do
if Supports(Aliases.Elements[i], IwbContainerElementRef, Alias) then begin
// skip alias collection
if Assigned(Alias.ElementBySignature['ALCS']) then
Continue;
j := Alias.Elements[0].NativeValue;
s := Alias.ElementEditValues['ALID'];
t := IntToStr(j);
while Length(t) < 3 do
t := '0' + t;
if s <> '' then
t := t + ' ' + s;
if Assigned(EditInfos) then
EditInfos.Add(t)
else if j = aInt then begin
case aType of
ctToStr, ctToEditValue: Result := t;
ctCheck: Result := '';
end;
Exit;
end;
end;
end;
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctCheck: Result := '';
ctEditInfo: begin
EditInfos.Add('None');
EditInfos.Sort;
Result := EditInfos.CommaText;
end;
end;
finally
FreeAndNil(EditInfos);
end;
end;
function wbStrToAlias(const aString: string; const aElement: IwbElement): Int64;
var
i : Integer;
s : string;
begin
Result := -1;
if aString = 'None' then
Exit
else if aString = 'Player' then begin
Result := -2;
Exit;
end;
i := 1;
s := Trim(aString);
while (i <= Length(s)) and (s[i] in ['-', '0'..'9']) do
Inc(i);
s := Copy(s, 1, Pred(i));
Result := StrToIntDef(s, -1);
end;
function wbScriptObjectAliasToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
begin
if not wbResolveAlias then begin
case aType of
ctToStr, ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: Result := IntToHex64(aInt, 8);
else
Result := '';
end;
Exit;
end;
if not Assigned(aElement) then
Exit;
Container := GetContainerRefFromUnionOrValue(aElement);
if not Assigned(Container) then
Exit;
Result := wbAliasToStr(aInt, Container.ElementByName['FormID'], aType);
end;
function wbPackageLocationAliasToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainer;
begin
if not wbResolveAlias then begin
case aType of
ctToStr, ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: Result := IntToHex64(aInt, 8);
else
Result := '';
end;
Exit;
end;
if not Assigned(aElement) then
Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
while Assigned(Container) and (Container.ElementType <> etMainRecord) do
Container := Container.Container;
if not Assigned(Container) then
Exit;
Result := wbAliasToStr(aInt, Container.ElementBySignature['QNAM'], aType);
end;
function wbQuestAliasToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainer;
begin
if not wbResolveAlias then begin
case aType of
ctToStr, ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: Result := IntToHex64(aInt, 8);
else
Result := '';
end;
Exit;
end;
if not Assigned(aElement) then
Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
while Assigned(Container) and (Container.ElementType <> etMainRecord) do
Container := Container.Container;
if not Assigned(Container) then
Exit;
Result := wbAliasToStr(aInt, Container, aType);
end;
function wbQuestExternalAliasToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainer;
begin
if not wbResolveAlias then begin
case aType of
ctToStr, ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: Result := IntToHex64(aInt, 8);
else
Result := '';
end;
Exit;
end;
if not Assigned(aElement) then
Exit;
Container := aElement.Container;
if not Assigned(Container) then
Exit;
Result := wbAliasToStr(aInt, Container.ElementBySignature['ALEQ'] , aType);
end;
function wbConditionAliasToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainer;
MainRecord : IwbMainRecord;
GroupRecord : IwbGroupRecord;
begin
if not wbResolveAlias then begin
case aType of
ctToStr, ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: Result := IntToHex64(aInt, 8);
else
Result := '';
end;
Exit;
end;
if not Assigned(aElement) then
Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
while Assigned(Container) and (Container.ElementType <> etMainRecord) do
Container := Container.Container;
if not Assigned(Container) then
Exit;
if not Supports(Container, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.Signature = QUST then
Result := wbAliasToStr(aInt, Container, aType)
else if MainRecord.Signature = SCEN then
Result := wbAliasToStr(aInt, Container.ElementBySignature['PNAM'], aType)
else if MainRecord.Signature = PACK then
Result := wbAliasToStr(aInt, Container.ElementBySignature['QNAM'], aType)
else if MainRecord.Signature = INFO then begin
// get DIAL for INFO
if Supports(MainRecord.Container, IwbGroupRecord, GroupRecord) then
if Supports(GroupRecord.ChildrenOf, IwbMainRecord, MainRecord) then
Result := wbAliasToStr(aInt, MainRecord.ElementBySignature['QNAM'], aType);
end else
// this should never be called since aliases in conditions can be in the forms above only
// but just in case
case aType of
ctToStr, ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: Result := IntToHex64(aInt, 8);
else
Result := '';
end;
end;
function wbClmtMoonsPhaseLength(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
PhaseLength : Byte;
Masser : Boolean;
Secunda : Boolean;
begin
Result := '';
if aType = ctToSortKey then begin
Result := IntToHex64(aInt, 2);
end else if aType = ctToStr then begin
PhaseLength := aInt mod 64;
Masser := (aInt and 64) <> 0;
Secunda := (aInt and 128) <> 0;
if Masser then
if Secunda then
Result := 'Masser, Secunda / '
else
Result := 'Masser / '
else
if Secunda then
Result := 'Secunda / '
else
Result := 'No Moon / ';
Result := Result + IntToStr(PhaseLength);
end;
end;
function wbClmtTime(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
if aType = ctToSortKey then
Result := IntToHex64(aInt, 4)
else if aType = ctToStr then
Result := TimeToStr( EncodeTime(aInt div 6, (aInt mod 6) * 10, 0, 0) )
else
Result := '';
end;
var
wbCtdaTypeFlags : IwbFlagsDef;
function wbCtdaTypeToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
s: string;
begin
Result := '';
if not Assigned(wbCtdaTypeFlags) then
wbCtdaTypeFlags := wbFlags([
{0x01} 'Or',
{0x02} 'Use aliases',
{0x04} 'Use global',
{0x08} 'Use packdata',
{0x10} 'Swap Subject and Target'
]);
{
Compare operator (upper 3 bits)
LGE
000 0=Equal to
001 1=Not equal to
010 2=Greater than
011 3=Greater than or equal to
100 4=Less than
101 5=Less than or equal to
Flags (lower 5 bits)
0x01=OR (default is to AND conditions together)
0x02=Parameters (use aliases) : Force function parameters to use quest alias data (exclusive with "use pack data")
0x04=Use global
0x08=Use Pack Data : Force function parameters to use pack data (exclusive with "use aliases")
0x10=Swap Subject and Target
}
case aType of
ctEditType:
Result := 'CheckComboBox';
ctEditInfo:
Result := 'Equal,Greater,Lesser,Or,"Use Aliases","Use Global","Use Packdata","Swap Subject and Target"';
ctToEditValue: begin
Result := '00000000';
case aInt and $E0 of
$00 : Result[1] := '1';
$40 : Result[2] := '1';
$60 : begin
Result[1] := '1';
Result[2] := '1';
end;
$80 : Result[3] := '1';
$A0 : begin
Result[1] := '1';
Result[3] := '1';
end;
end;
if (aInt and $01) <> 0 then // Or
Result[4] := '1';
if (aInt and $02) <> 0 then // Use aliases
Result[5] := '1';
if (aInt and $04) <> 0 then // Use global
Result[6] := '1';
if (aInt and $08) <> 0 then // Use packdata
Result[7] := '1';
if (aInt and $10) <> 0 then // Swap Subject and Target
Result[8] := '1';
end;
ctToStr: begin
case aInt and $E0 of
$00 : Result := 'Equal to';
$20 : Result := 'Not equal to';
$40 : Result := 'Greater than';
$60 : Result := 'Greater than or equal to';
$80 : Result := 'Less than';
$A0 : Result := 'Less than or equal to';
else
Result := ''
end;
s := wbCtdaTypeFlags.ToString(aInt and $1F, aElement);
if s <> '' then
Result := Result + ' / ' + s;
end;
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
Exit;
end;
ctCheck: begin
case aInt and $E0 of
$00, $20, $40, $60, $80, $A0 : Result := '';
else
Result := ''
end;
s := wbCtdaTypeFlags.Check(aInt and $1F, aElement);
if s <> '' then
Result := Result + ' / ' + s;
end;
end;
end;
function wbCtdaTypeToInt(const aString: string; const aElement: IwbElement): Int64;
var
s: string;
begin
s := aString + '00000000';
if s[1] = '1' then begin
if s[2] = '1' then begin
if s[3] = '1' then begin
Result := $00;
end else begin
Result := $60;
end;
end else begin
if s[3] = '1' then begin
Result := $A0;
end else begin
Result := $00;
end;
end;
end else begin
if s[2] = '1' then begin
if s[3] = '1' then begin
Result := $20;
end else begin
Result := $40;
end;
end else begin
if s[3] = '1' then begin
Result := $80;
end else begin
Result := $20;
end;
end;
end;
// Or
if s[4] = '1' then
Result := Result or $01;
// Use aliases
if s[5] = '1' then
Result := Result or $02;
// Use global
if s[6] = '1' then
Result := Result or $04;
// Use packdata
if s[7] = '1' then
Result := Result or $08;
// Swap Subject and Target
if s[8] = '1' then
Result := Result or $10;
end;
var
wbEventFunctionAndMemberEditInfo: string;
function wbEventFunctionAndMemberToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
EventFunction, EventMember: Integer;
i, j: Integer;
s1, s2: string;
slMember: TStringList;
begin
Result := '';
EventFunction := aInt and $FFFF;
EventMember := aInt shr 16;
case aType of
ctToStr, ctToEditValue: begin
Result := wbEventFunctionEnum.ToEditValue(EventFunction, nil);
Result := Result + ':' + wbEventMemberEnum.ToEditValue(EventMember, nil);
end;
ctToSortKey: Result := IntToHex(aInt, 8);
ctCheck: begin
s1 := wbEventFunctionEnum.Check(EventFunction, nil);
if s1 <> '' then
s1 := 'EventFunction' + s1;
s2 := wbEventMemberEnum.Check(EventMember, nil);
if s2 <> '' then
s2 := 'EventMember' + s2;
if (s1 <> '') or (s2 <> '') then
Result := s1 + ':' + s2;
end;
ctEditType:
Result := 'ComboBox';
ctEditInfo: begin
Result := wbEventFunctionAndMemberEditInfo;
if Result = '' then try
slMember := TStringList.Create;
slMember.CommaText := wbEventMemberEnum.EditInfo[0, nil];
with TStringList.Create do try
for i := 0 to Pred(wbEventFunctionEnum.NameCount) do
for j := 0 to Pred(slMember.Count) do
Add(wbEventFunctionEnum.Names[i] + ':' + slMember[j]);
Sort;
Result := CommaText;
finally
Free;
end;
wbEventFunctionAndMemberEditInfo := Result;
finally
FreeAndNil(slMember);
end
end;
end;
end;
function wbEventFunctionAndMemberToInt(const aString: string; const aElement: IwbElement): Int64;
var
EventFunction, EventMember, i: Integer;
begin
i := Pos(':', aString);
if i > 0 then begin
EventFunction := wbEventFunctionEnum.FromEditValue(Copy(aString, 1, i-1), nil);
EventMember := wbEventMemberEnum.FromEditValue(Copy(aString, i+1, Length(aString)), nil);
end
else begin
EventFunction := 0;
EventMember := 0;
end;
Result := EventMember shl 16 + EventFunction;
end;
procedure wbMESGDNAMAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldValue, NewValue : Integer;
Container : IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if Supports(aElement.Container, IwbContainerElementRef, Container) then begin
OldValue := Integer(aOldValue) and 1;
NewValue := Integer(aNewValue) and 1;
if NewValue = OldValue then
Exit;
if NewValue = 1 then
Container.RemoveElement('TNAM')
else
Container.Add('TNAM', True);
end;
end;
procedure wbGMSTEDIDAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldValue, NewValue : string;
Container : IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if Supports(aElement.Container, IwbContainerElementRef, Container) then begin
OldValue := aOldValue;
NewValue := aNewValue;
if (Length(OldValue) < 1) or (Length(OldValue) < 1) or (OldValue[1] <> NewValue[1]) then begin
Container.RemoveElement('DATA');
Container.Add('DATA', True);
end;
end;
end;
procedure wbFLSTEDIDAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldValue, NewValue : string;
OldOrdered, NewOrdered : Boolean;
Container : IwbContainerElementRef;
const
OrderedList = 'OrderedList';
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if Supports(aElement.Container, IwbContainerElementRef, Container) then begin
OldValue := aOldValue;
NewValue := aNewValue;
if Length(OldValue) > Length(OrderedList) then
Delete(OldValue, 1, Length(OldValue)-Length(OrderedList));
if Length(NewValue) > Length(OrderedList) then
Delete(NewValue, 1, Length(NewValue)-Length(OrderedList));
OldOrdered := SameText(OldValue, OrderedList);
NewOrdered := SameText(NewValue, OrderedList);
if OldOrdered <> NewOrdered then
Container.RemoveElement('FormIDs');
end;
end;
procedure wbCtdaTypeAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
OldValue, NewValue: Integer;
Container: IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
// reset value if "use global" has changed
OldValue := aOldValue and $04;
NewValue := aNewValue and $04;
if OldValue <> NewValue then
Container.ElementNativeValues['..\Comparison Value'] := 0;
{>>> "run on target", no such flag in Skyrim <<<}
// if aNewValue and $02 then begin
// Container.ElementNativeValues['..\Run On'] := 1;
// if Integer(Container.ElementNativeValues['..\Run On']) = 1 then
// aElement.NativeValue := Byte(aNewValue) and not $02;
// end;
end;
procedure wbAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
Exit;
end;
function wbMODTCallback(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Strings: TDynStrings;
i: Integer;
begin
Result := '';
if wbLoaderDone and (aType in [ctToStr, ctToSortKey] ) then begin
Strings := wbContainerHandler.ResolveHash(aInt);
for i := Low(Strings) to High(Strings) do
Result := Result + Strings[i] + ', ';
SetLength(Result, Length(Result) -2 );
end;
end;
{>>> Needs revision for Skyrim <<<}
//function wbIdleAnam(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
//begin
// Result := '';
// case aType of
// ctToStr: begin
// case aInt and not $C0 of
// 0: Result := 'Idle';
// 1: Result := 'Movement';
// 2: Result := 'Left Arm';
// 3: Result := 'Left Hand';
// 4: Result := 'Weapon';
// 5: Result := 'Weapon Up';
// 6: Result := 'Weapon Down';
// 7: Result := 'Special Idle';
// 20: Result := 'Whole Body';
// 21: Result := 'Upper Body';
// else
// Result := '';
// end;
//
// if (aInt and $80) = 0 then
// Result := Result + ', Must return a file';
// if (aInt and $40) = 1 then
// Result := Result + ', Unknown Flag';
// end;
// ctToSortKey: begin
// Result := IntToHex64(aInt, 2);
// end;
// ctCheck: begin
// case aInt and not $C0 of
// 0..7, 20, 21: Result := '';
// else
// Result := '';
// end;
// end;
// end;
//end;
function wbScaledInt4ToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
const
PlusMinus : array[Boolean] of string = ('+', '-');
begin
Result := '';
case aType of
ctToStr, ctToEditValue: Result := FloatToStrF(aInt / 10000, ffFixed, 99, 4);
ctToSortKey: begin
Result := FloatToStrF(aInt / 10000, ffFixed, 99, 4);
if Length(Result) < 22 then
Result := StringOfChar('0', 22 - Length(Result)) + Result;
Result := PlusMinus[aInt < 0] + Result;
end;
ctCheck: Result := '';
end;
end;
function wbScaledInt4ToInt(const aString: string; const aElement: IwbElement): Int64;
var
f: Extended;
begin
f := StrToFloat(aString);
f := f * 10000;
Result := Round(f);
end;
function wbCloudSpeedToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
case aType of
ctToStr, ctToEditValue: Result := FloatToStrF((aInt - 127)/127/10, ffFixed, 99, 4);
ctCheck: Result := '';
end;
end;
function wbCloudSpeedToInt(const aString: string; const aElement: IwbElement): Int64;
var
f: Extended;
begin
f := StrToFloat(aString);
f := f*10*127 + 127;
Result := Min(Round(f), 254);
end;
function wbShortXYtoStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
x, y: SmallInt;
begin
y := aInt and $FFFF;
x := aInt shr 16 and $FFFF;
Result := '';
case aType of
ctToStr, ctToEditValue: Result := Format('%d, %d', [x, y]);
ctCheck: Result := '';
end;
end;
function wbStrToShortXY(const aString: string; const aElement: IwbElement): Int64;
var
x, y: SmallInt;
Value: Cardinal;
begin
y := StrToIntDef(Copy(aString, 1, Pred(Pos(', ', aString))), 0);
x := StrToIntDef(Copy(aString, Pos(', ', aString) + 2, Length(aString)), 0);
PWord(@Value)^ := x;
PWord(Cardinal(@Value) + SizeOf(SmallInt))^ := y;
Result := Value;
end;
function wbHideFFFF(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
if aType = ctToSortKey then
Result := IntToHex64(aInt, 4)
else if aType = ctToStr then
if aInt = $FFFF then
Result := 'None'
else
Result := IntToStr(aInt);
end;
function wbAtxtPosition(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
if aType = ctToSortKey then
Result := IntToHex64(aInt div 17, 2) + IntToHex64(aInt mod 17, 2)
else if aType = ctCheck then begin
if (aInt < 0) or (aInt > 288) then
Result := ''
else
Result := '';
end else if aType = ctToStr then
Result := IntToStr(aInt) + ' -> ' + IntToStr(aInt div 17) + ':' + IntToStr(aInt mod 17);
end;
function wbPlacedAddInfo(const aMainRecord: IwbMainRecord): string;
var
Rec: IwbRecord;
Container: IwbContainer;
s: string;
Cell: IwbMainRecord;
Position: TwbVector;
Grid: TwbGridCell;
begin
Result := '';
Rec := aMainRecord.RecordBySignature['NAME'];
if Assigned(Rec) then begin
s := Trim(Rec.Value);
if s <> '' then
Result := 'places ' + s;
end;
Container := aMainRecord.Container;
while Assigned(Container) and (Container.ElementType <> etGroupRecord) do
Container := Container.Container;
if Assigned(Container) then begin
s := Trim(Container.Name);
if s <> '' then begin
if Result <> '' then
Result := Result + ' ';
Result := Result + 'in ' + s;
// grid position of persistent reference in exterior persistent cell (interior cells are not persistent)
if Supports(aMainRecord.Container, IwbGroupRecord, Container) then
Cell := IwbGroupRecord(Container).ChildrenOf;
if Assigned(Cell) and Cell.IsPersistent and (Cell.Signature = 'CELL') then
if aMainRecord.GetPosition(Position) then begin
Grid := wbPositionToGridCell(Position);
Result := Result + ' at ' + IntToStr(Grid.x) + ',' + IntToStr(Grid.y);
end;
// in precombined mesh
if aMainRecord.HasPrecombinedMesh then
Result := Result + ' in ' + aMainRecord.PrecombinedMesh;
end;
end;
end;
function wbINFOAddInfo(const aMainRecord: IwbMainRecord): string;
var
Container: IwbContainer;
s: string;
begin
Result := Trim(aMainRecord.ElementValues['Responses\Response\NAM1']);
if Result <> '' then
Result := '''' + Result + '''';
Container := aMainRecord.Container;
while Assigned(Container) and (Container.ElementType <> etGroupRecord) do
Container := Container.Container;
if Assigned(Container) then begin
s := Trim(Container.Name);
if s <> '' then begin
if Result <> '' then
Result := Result + ' ';
Result := Result + 'in ' + s;
end;
end;
s := Trim(aMainRecord.ElementValues['QNAM']);
if s <> '' then begin
if Result <> '' then
Result := Result + ' ';
Result := Result + 'for ' + s;
end;
end;
function wbNAVMAddInfo(const aMainRecord: IwbMainRecord): string;
var
Container: IwbContainer;
s: string;
begin
Result := '';
Container := aMainRecord.Container;
while Assigned(Container) and (Container.ElementType <> etGroupRecord) do
Container := Container.Container;
if Assigned(Container) then begin
s := Trim(Container.Name);
if s <> '' then begin
if Result <> '' then
Result := Result + ' ';
Result := Result + 'in ' + s;
end;
end;
end;
//function wbNAVMAddInfo(const aMainRecord: IwbMainRecord): string;
//var
// Rec : IwbRecord;
// Element : IwbElement;
// s : string;
//begin
// Result := '';
//
// Rec := aMainRecord.RecordBySignature['DATA'];
// if Assigned(Rec) then begin
// Element := Rec.ElementByName['Cell'];
// if Assigned(Element) then
// Element := Element.LinksTo;
// if Assigned(Element) then
// s := Trim(Element.Name);
// if s <> '' then
// Result := 'for ' + s;
// end;
//end;
function wbCellAddInfo(const aMainRecord: IwbMainRecord): string;
var
Rec: IwbRecord;
Container: IwbContainer;
GroupRecord : IwbGroupRecord;
s: string;
begin
Result := '';
if not aMainRecord.IsPersistent then begin
Rec := aMainRecord.RecordBySignature['XCLC'];
if Assigned(Rec) then
Result := 'at ' + Rec.Elements[0].Value + ',' + Rec.Elements[1].Value;
end;
Container := aMainRecord.Container;
while Assigned(Container) and not
(Supports(Container, IwbGroupRecord, GroupRecord) and (GroupRecord.GroupType = 1)) do
Container := Container.Container;
if Assigned(Container) then begin
s := wbFormID.ToString(GroupRecord.GroupLabel, aMainRecord);
if s <> '' then begin
if Result <> '' then
s := s + ' ';
Result := 'in ' + s + Result;
end;
end;
end;
procedure wbCTDARunOnAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
if aOldValue <> aNewValue then
if aNewValue <> 2 then
aElement.Container.ElementNativeValues['Reference'] := 0;
end;
{>>> Needs revision for Skyrim <<<}
procedure wbPERKPRKETypeAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container : IwbContainerElementRef;
// rDATA : IwbRecord;
begin
if aOldValue <> aNewValue then
if Supports(aElement.Container, IwbContainerElementRef, Container) then begin
if Supports(Container.Container, IwbContainerElementRef, Container) then begin
Container.RemoveElement('DATA');
Container.Add('DATA', True);
Container.RemoveElement('Perk Conditions');
Container.RemoveElement('Entry Point Function Parameters');
if aNewValue = 2 then begin
Container.Add('EPFT', True);
Container.ElementNativeValues['DATA\Entry Point\Function'] := 2;
end;
end;
end;
end;
function wbNPCLevelDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
i: Int64;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
i := Container.ElementByName['Flags'].NativeValue;
if i and $00000080 <> 0 then
Result := 1;
end;
function wbMGEFAssocItemDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
Archtype : Variant;
DataContainer : IwbDataContainer;
Element : IwbElement;
const
OffsetArchtype = 56;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
VarClear(ArchType);
Element := Container.ElementByName['Archetype'];
if Assigned(Element) then
ArchType := Element.NativeValue
else if Supports(Container, IwbDataContainer, DataContainer) and
DataContainer.IsValidOffset(aBasePtr, aEndPtr, OffsetArchtype) then begin // we are part a proper structure
aBasePtr := Pointer(Cardinal(aBasePtr) + OffsetArchtype);
ArchType := PCardinal(aBasePtr)^;
end;
if not VarIsEmpty(ArchType) then
case Integer(ArchType) of
12: Result := 1; // Light
17: Result := 2; // Bound Item
18: Result := 3; // Summon Creature
25: Result := 4; // Guide
34: Result := 8; // Peak Mod
35: Result := 5; // Cloak
36: Result := 6; // Werewolf
39: Result := 7; // Enhance Weapon
40: Result := 4; // Spawn Hazard
46: Result := 6; // Vampire Lord
end;
end;
procedure wbMGEFAssocItemAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container : IwbContainer;
Element : IwbElement;
begin
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if (aNewValue <> 0) then begin
Element := Container.ElementByName['Archetype'];
if Assigned(Element) and (Element.NativeValue = 0) then
Element.NativeValue := $FF; // Signals ArchType that it should not mess with us on the next change!
// I assume this will alo protect Second AV Weight (The two actor values are after ArchType)
end;
end;
procedure wbMGEFAV2WeightAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container : IwbContainer;
Element : IwbElement;
begin
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if (aNewValue <> 0.0) then begin
Element := Container.ElementByName['Archetype'];
if Assigned(Element) and (Element.NativeValue = 0) then
Element.NativeValue := $FF; // Signals ArchType that it should not mess with us on the next change!
end;
end;
procedure wbMGEFArchtypeAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container: IwbContainerElementRef;
begin
if VarSameValue(aOldValue, aNewValue) then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if (aNewValue < $FF) and (aOldValue < $FF) then begin
Container.ElementNativeValues['..\Assoc. Item'] := 0;
case Integer(aNewValue) of
06: Container.ElementNativeValues['..\Actor Value'] := 00;//Agression
07: Container.ElementNativeValues['..\Actor Value'] := 01;//Confidence
08: Container.ElementNativeValues['..\Actor Value'] := 00;//Agression
11: Container.ElementNativeValues['..\Actor Value'] := 54;//Invisibility
21: Container.ElementNativeValues['..\Actor Value'] := 53;//Paralysis
24: Container.ElementNativeValues['..\Actor Value'] := 01;//Confidence
38: Container.ElementNativeValues['..\Actor Value'] := 01;//Confidence
42: Container.ElementNativeValues['..\Actor Value'] := 01;//Confidence
else
Container.ElementNativeValues['..\Actor Value'] := -1;
end;
Container.ElementNativeValues['..\Second Actor Value'] := -1;
Container.ElementNativeValues['..\Second AV Weight'] := 0.0;
end;
end;
function wbCTDAReferenceDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Integer(Container.ElementNativeValues['Run On']) = 2 then
Result := 1;
end;
function wbNAVIIslandDataDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
SubRecord : IwbMainRecord;
Element : IwbElement;
begin
Result := 0;
Container := aElement.Container;
while Assigned(Container) and (Container.ElementType <> etSubRecord) do
Container := Container.Container;
if not Supports(Container, IwbSubRecord, SubRecord) then
Exit;
Element := SubRecord.ElementByName['Is Island'];
if not Assigned(Element) then
Exit;
Result := Element.NativeValue;
end;
function wbNAVIParentDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
SubRecord : IwbMainRecord;
Element : IwbElement;
begin
Result := 0;
Container := aElement.Container;
while Assigned(Container) and (Container.ElementType <> etsubRecord) do
Container := Container.Container;
if not Supports(Container, IwbSubRecord, SubRecord) then
Exit;
Element := SubRecord.ElementByName['Parent Worldspace'];
if not Assigned(Element) then
Exit;
if (Element.NativeValue = 0) then
Result := 1;
end;
function wbNVNMParentDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
Parent : IwbElement;
i : integer;
begin // Could be simplified by checking if Parent Worldspace is NULL, that's what the runtime does :)
Result := 0;
Container := aElement.Container;
Parent := Container.ElementByName['Parent Worldspace'];
if not Assigned(Parent) then
Exit;
i := Parent.NativeValue;
// is interior cell?
if i = 0 then
Result := 1;
end;
function wbDoorTriangleDoorTriangleDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
Parent : IwbElement;
i : int64;
begin
Result := 0;
Container := aElement.Container;
Parent := Container.ElementByName['DTUnknown'];
if not Assigned(Parent) then
Exit;
i := Parent.NativeValue;
// not sure if it would be an error in the file or if it really possible
if i <> 0 then
Result := 1;
end;
function wbSubrecordSizeDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
SubRecord : IwbSubRecord;
begin
Result := 0;
if not Assigned(aElement) then Exit;
if Supports(aElement, IwbSubRecord, SubRecord) then
if SubRecord.DataSize > 0 then
Result := 1;
end;
function wbCOEDOwnerDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
LinksTo : IwbElement;
MainRecord : IwbMainRecord;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
LinksTo := Container.ElementByName['Owner'].LinksTo;
if Supports(LinksTo, IwbMainRecord, MainRecord) then
if MainRecord.Signature = 'NPC_' then
Result := 1
else if MainRecord.Signature = 'FACT' then
Result := 2;
end;
function wbGMSTUnionDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
rEDID: IwbRecord;
s: string;
begin
Result := 1;
rEDID := aElement.Container.RecordBySignature[EDID];
if Assigned(rEDID) then begin
s := rEDID.Value;
if Length(s) > 0 then
case s[1] of
's': Result := 0; {String} {>>> Localization Strings <<<}
'i': Result := 1; {intS32}
'f': Result := 2; {Float}
'b': Result := 3; {Boolean}
end;
end;
end;
function wbFLSTLNAMIsSorted(const aContainer: IwbContainer): Boolean;
var
rEDID : IwbRecord;
s : string;
const
OrderedList = 'OrderedList';
begin
Result := False; {>>> Should not be sorted according to Arthmoor and JustinOther <<<}
rEDID := aContainer.RecordBySignature[EDID];
if Assigned(rEDID) then begin
s := rEDID.Value;
if Length(s) > Length(OrderedList) then
Delete(s, 1, Length(s)-Length(OrderedList));
if SameText(s, OrderedList) then
Result := False;
end;
end;
function wbPerkDATADecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
rPRKE: IwbRecord;
eType: IwbElement;
begin
Result := 0;
rPRKE := aElement.Container.RecordBySignature[PRKE];
if Assigned(rPRKE) then begin
eType := rPRKE.ElementByName['Type'];
if Assigned(eType) then begin
Result := eType.NativeValue;
end;
end;
end;
function wbEPFDDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainerElementRef;
begin
Result := 0;
if not Assigned(aElement) then
Exit;
if not Supports(aElement.Container, IwbContainerElementRef, Container) then
Exit;
Result := Container.ElementNativeValues['EPFT'];
if Result = 2 then
case Integer(Container.ElementNativeValues['..\DATA\Entry Point\Function']) of
5, 12, 13, 14: Result := 8;
end;
end;
function wbSceneActionSoundDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainerElementRef;
begin
Result := 0;
if not Assigned(aElement) then
Exit;
if not Supports(aElement.Container, IwbContainerElementRef, Container) then
Exit;
if Container.ElementNativeValues['ANAM'] <> 4 then
Result := 1;
end;
function wbEFSHFormatDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
MainRecord: IwbMainRecord;
begin
Result := 0;
if not Assigned(aElement) then
Exit;
if not Supports(aElement.Container, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.Version < 102 then
Result := 1;
end;
function wbDeciderFormVersion99(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
begin
Result := wbFormVerDecider(aBasePtr, aEndPtr, aElement, 99);
end;
function wbAECHDataDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
rKNAM : IwbElement;
s: string;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Container := Container.Container;
if not Assigned(Container) then Exit;
rKNAM := Container.ElementBySignature['KNAM'];
if not Assigned(rKNAM) then Exit;
s := rKNAM.EditValue;
if s = 'BSOverdrive' then
Result := 0
else if s = 'BSStateVariableFilter' then
Result := 1
else if s = 'BSDelayEffect' then
Result := 2;
end;
function wbCLFMColorDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
rFNAM : IwbElement;
i : Integer;
begin
Result := 0;
// resolving to a float causes data loss when copying
// since deciding field FNAM comes after a value CNAM
Exit;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Container := Container.Container;
if not Assigned(Container) then Exit;
rFNAM := Container.ElementBySignature['FNAM'];
if not Assigned(rFNAM) then Exit;
i := rFNAM.NativeValue;
if i and 2 <> 0 then
Result := 1;
end;
function wbCLFMColorToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainer;
rFNAM : IwbElement;
i : Integer;
s : string;
begin
i := 0;
Container := aElement.Container;
if Assigned(Container) then begin
rFNAM := Container.ElementBySignature['FNAM'];
if Assigned(rFNAM) then
i := rFNAM.NativeValue;
end;
if i and 2 <> 0 then
s := FloatToStrF(PSingle(@aInt)^, ffFixed, 99, wbFloatDigits)
else
s := 'rgba(' + IntToStr(aInt and $FF) + ', ' +
IntToStr(aInt shr 8 and $FF) + ', ' +
IntToStr(aInt shr 16 and $FF) + ', ' +
IntToStr(aInt shr 24 and $FF) + ')';
case aType of
ctToStr: Result := s;
ctToSortKey: Result := IntToHex(aInt, 8);
ctToEditValue: Result := s;
end;
end;
function wbCLFMColorToInt(const aString: string; const aElement: IwbElement): Int64;
var
s: string;
value: Single;
begin
if SameText(Copy(aString, 1, 5), 'rgba(') then begin
s := Copy(aString, 6, Pos(')', aString) - 6);
with TStringList.Create do try
Delimiter := ',';
StrictDelimiter := True;
DelimitedText := s;
Result := 0;
if Count = 4 then begin
PByte(@Result)[0] := StrToIntDef(Strings[0], 0);
PByte(@Result)[1] := StrToIntDef(Strings[1], 0);
PByte(@Result)[2] := StrToIntDef(Strings[2], 0);
PByte(@Result)[3] := StrToIntDef(Strings[3], 0);
end;
finally
Free;
end;
end
else begin
try value := StrToFloat(aString) except value := 0.0 end;
Result := PInteger(@value)^;
end;
end;
function wbNOTEDataDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
rDNAM : IwbElement;
i : Integer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Container := Container.Container;
if not Assigned(Container) then Exit;
rDNAM := Container.ElementBySignature['DNAM'];
if not Assigned(rDNAM) then Exit;
i := rDNAM.NativeValue;
case i of
0: Result := 1;
1: Result := 2;
3: Result := 3;
end;
end;
function wbSNDRDataDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
rCNAM : IwbElement;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Container := Container.Container;
if not Assigned(Container) then Exit;
rCNAM := Container.ElementBySignature['CNAM'];
if not Assigned(rCNAM) then Exit;
if rCNAM.EditValue = 'AutoWeapon' then
Result := 1;
end;
{>>> For VMAD <<<}
function wbScriptObjFormatDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
ObjFormat: Integer;
Container: IwbContainer;
begin
Result := 0;
Container := aElement.Container;
while Assigned(Container) and (Container.ElementType <> etSubRecord) do
Container := Container.Container;
if not Assigned(Container) then Exit;
ObjFormat := Container.ElementNativeValues['Object Format'];
if ObjFormat = 1 then
Result := 1;
end;
{>>> For VMAD <<<}
function wbScriptPropertyDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
case Integer(Container.ElementNativeValues['Type']) of
1: Result := 1;
2: Result := 2;
3: Result := 3;
4: Result := 4;
5: Result := 5;
6: Result := 6;
7: Result := 7;
11: Result := 8;
12: Result := 9;
13: Result := 10;
14: Result := 11;
15: Result := 12;
17: Result := 13;
end;
end;
function wbScriptPropertyStructMemberDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
case Integer(Container.ElementNativeValues['Type']) of
1: Result := 1;
2: Result := 2;
3: Result := 3;
4: Result := 4;
5: Result := 5;
11: Result := 6;
12: Result := 7;
13: Result := 8;
14: Result := 9;
15: Result := 10;
end;
end;
procedure wbScriptPropertyTypeAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container : IwbContainerElementRef;
begin
if aOldValue <> aNewValue then
if Supports(aElement.Container, IwbContainerElementRef, Container) then
Container.ElementByName['Value'].SetToDefault;
end;
{>>> For VMAD <<<}
function wbScriptFragmentsDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
MainRecord : IwbMainRecord;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
while Assigned(Container) and (Container.ElementType <> etMainRecord) do
Container := Container.Container;
if not Assigned(Container) then Exit;
Supports(Container, IwbMainRecord, MainRecord);
if MainRecord.Signature = PERK then
Result := 1
else if MainRecord.Signature = TERM then
Result := 1
else if MainRecord.Signature = INFO then
Result := 2
else if MainRecord.Signature = PACK then
Result := 3
else if MainRecord.Signature = QUST then
Result := 4
else if MainRecord.Signature = SCEN then
Result := 5;
end;
{>>> For VMAD <<<}
function wbScriptFragmentsQuestCounter(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Cardinal;
var
Container : IwbContainer;
begin
Result := 0;
if aElement.ElementType = etValue then
Container := aElement.Container
else
Container := aElement as IwbContainer;
if not Assigned(Container) then Exit;
while Assigned(Container) and (Container.Name <> 'Script Fragments') do
Container := Container.Container;
if not Assigned(Container) then Exit;
Result := Cardinal(Container.ElementNativeValues['fragmentCount']);
end;
{>>> For VMAD <<<}
function wbScriptFragmentsInfoCounter(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Cardinal;
var
Container : IwbContainer;
F : Integer;
i : Integer;
begin
Result := 0;
if aElement.ElementType = etValue then
Container := aElement.Container
else
Container := aElement as IwbContainer;
if not Assigned(Container) then Exit;
while Assigned(Container) and (Container.Name <> 'Script Fragments') do
Container := Container.Container;
if not Assigned(Container) then Exit;
F := Container.ElementByName['Flags'].NativeValue;
for i := 0 to 2 do begin
if (F and 1) = 1 then
Inc(Result);
F := F shr 1;
end;
for i := 3 to 7 do begin
if (F and 1) = 1 then begin
Inc(Result);
if Assigned(wbProgressCallback) then
wbProgressCallback('==='+aElement.Name+' ['+Container.Name+':'+Container.Path+'] = unknown info VMAD flag bit '+IntToStr(i));
end;
F := F shr 1;
end;
end;
{>>> For VMAD <<<}
function wbScriptFragmentsSceneCounter(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Cardinal;
var
Container : IwbContainer;
F : Integer;
i : Integer;
begin
Result := 0;
if aElement.ElementType = etValue then
Container := aElement.Container
else
Container := aElement as IwbContainer;
if not Assigned(Container) then Exit;
while Assigned(Container) and (Container.Name <> 'Script Fragments') do
Container := Container.Container;
if not Assigned(Container) then Exit;
F := Container.ElementByName['Flags'].NativeValue;
for i := 0 to 2 do begin
if (F and 1) = 1 then
Inc(Result);
F := F shr 1;
end;
for i := 3 to 7 do begin
if (F and 1) = 1 then begin
Inc(Result);
if Assigned(wbProgressCallback) then
wbProgressCallback('==='+aElement.Name+' ['+Container.Name+':'+Container.Path+'] = unknown scene VMAD flag bit '+IntToStr(i));
end;
F := F shr 1;
end;
end;
{>>> For VMAD <<<}
function wbScriptFragmentsPackCounter(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Cardinal;
var
Container : IwbContainer;
F : Integer;
i : Integer;
begin
Result := 0;
if aElement.ElementType = etValue then
Container := aElement.Container
else
Container := aElement as IwbContainer;
if not Assigned(Container) then Exit;
while Assigned(Container) and (Container.Name <> 'Script Fragments') do
Container := Container.Container;
if not Assigned(Container) then Exit;
F := Container.ElementByName['Flags'].NativeValue;
for i := 0 to 7 do begin
if (F and 1) = 1 then
Inc(Result);
F := F shr 1;
end;
end;
{>>> For VMAD <<<}
function wbScriptFragmentsEmptyScriptDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Container.ElementEditValues['scriptName'] = '' then
Result := 1;
end;
function wbBOOKTeachesDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
i: Int64;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
i := Container.ElementByName['Flags'].NativeValue;
if i and $01 <> 0 then
Result := 1
else if i and $04 <> 0 then
Result := 2
else if i and $10 <> 0 then
Result := 3
else
Result := 0;
end;
type
TCTDAFunctionParamType = (
{ 0} ptNone,
{ 1} ptInteger,
{ 2} ptFloat,
{ 3} ptActor, // ACHR
{ 4} ptActorBase, // NPC_
{ 5} ptActorValue, // Enum: wbActorValue
{ 6} ptAdvanceAction, // ?? Enum
{ 7} ptAlias, // index into QUST quest aliases
{ 8} ptAlignment, // ?? Enum
{ 9} ptAssociationType, // ASTP
{10} ptAxis, // ?? Char
{11} ptCastingSource, // ?? Enum
{12} ptCell, // CELL
{13} ptClass, // CLAS
{14} ptCrimeType, // ?? Enum
{15} ptCriticalStage, // ?? Enum
{16} ptEncounterZone, // ECZN
{17} ptEquipType, // ?? Enum
{18} ptEvent, // Struct
{19} ptEventData, // LCTN, KYWD or FLST
{20} ptFaction, // FACT
{21} ptFormList, // FLST
{22} ptFormType, // ?? Enum
{23} ptFurniture, // FURN
{24} ptFurnitureAnim, // enum
{25} ptFurnitureEntry, // flags
{26} ptGlobal, // GLOB
{27} ptIdleForm, // IDLE
{28} ptInventoryObject, // ARMO, BOOK, MISC, WEAP, AMMO, KEYM, ALCH, ARMA, LIGH, LVLI, COBJ
{29} ptKeyword, // KYWD
{30} ptLocation, // LCTN
{31} ptMagicEffect, // MGEF
{32} ptMagicItem, // SPEL
{33} ptMiscStat, // ?? Enum
{34} ptObjectReference, // REFR, ACHR
{35} ptOwner, // FACT, NPC_
{36} ptPackage, // PACK
{37} ptPackdata, // index into PACK package data inputs
{38} ptPerk, // PERK
{39} ptQuest, // QUST
{40} ptQuestStage, // ?? Integer
{41} ptRace, // RACE
{42} ptReferencableObject,
{43} ptRefType, // LCRT
{44} ptRegion, // REGN
{45} ptScene, // SCEN
{46} ptSex, // Enum: Male, Female
{47} ptShout, // SHOU
{48} ptVariableName, // Integer
{49} ptVATSValueFunction, //
{50} ptVATSValueParam,
{51} ptVoiceType, // VTYP
{52} ptWardState, // enum
{53} ptWeather, // WTHR
{54} ptWorldspace, // WRLD
{55} ptDamageType // DMGT
);
PCTDAFunction = ^TCTDAFunction;
TCTDAFunction = record
Index: Integer;
Name: string;
ParamType1: TCTDAFunctionParamType;
ParamType2: TCTDAFunctionParamType;
ParamType3: TCTDAFunctionParamType;
end;
const
wbCTDAFunctions : array[0..514] of TCTDAFunction = (
(Index: 0; Name: 'GetWantBlocking'),
(Index: 1; Name: 'GetDistance'; ParamType1: ptObjectReference),
(Index: 5; Name: 'GetLocked'),
(Index: 6; Name: 'GetPos'; ParamType1: ptAxis),
(Index: 8; Name: 'GetAngle'; ParamType1: ptAxis),
(Index: 10; Name: 'GetStartingPos'; ParamType1: ptAxis),
(Index: 11; Name: 'GetStartingAngle'; ParamType1: ptAxis),
(Index: 12; Name: 'GetSecondsPassed'),
(Index: 14; Name: 'GetValue'; ParamType1: ptActorValue),
(Index: 18; Name: 'GetCurrentTime'),
(Index: 24; Name: 'GetScale'),
(Index: 25; Name: 'IsMoving'),
(Index: 26; Name: 'IsTurning'),
(Index: 27; Name: 'GetLineOfSight'; ParamType1: ptObjectReference),
(Index: 31; Name: 'GetButtonPressed'),
(Index: 32; Name: 'GetInSameCell'; ParamType1: ptObjectReference),
(Index: 35; Name: 'GetDisabled'),
(Index: 39; Name: 'GetDisease'),
(Index: 41; Name: 'GetClothingValue'),
(Index: 42; Name: 'SameFaction'; ParamType1: ptActor),
(Index: 43; Name: 'SameRace'; ParamType1: ptActor),
(Index: 44; Name: 'SameSex'; ParamType1: ptActor),
(Index: 45; Name: 'GetDetected'; ParamType1: ptActor),
(Index: 46; Name: 'GetDead'),
(Index: 47; Name: 'GetItemCount'; ParamType1: ptReferencableObject),
(Index: 48; Name: 'GetGold'),
(Index: 49; Name: 'GetSleeping'),
(Index: 50; Name: 'GetTalkedToPC'),
(Index: 56; Name: 'GetQuestRunning'; ParamType1: ptQuest),
(Index: 58; Name: 'GetStage'; ParamType1: ptQuest),
(Index: 59; Name: 'GetStageDone'; ParamType1: ptQuest; ParamType2: ptQuestStage),
(Index: 60; Name: 'GetFactionRankDifference'; ParamType1: ptFaction; ParamType2: ptActor),
(Index: 61; Name: 'GetAlarmed'),
(Index: 62; Name: 'IsRaining'),
(Index: 63; Name: 'GetAttacked'),
(Index: 64; Name: 'GetIsCreature'),
(Index: 65; Name: 'GetLockLevel'),
(Index: 66; Name: 'GetShouldAttack'; ParamType1: ptActor),
(Index: 67; Name: 'GetInCell'; ParamType1: ptCell),
(Index: 68; Name: 'GetIsClass'; ParamType1: ptClass),
(Index: 69; Name: 'GetIsRace'; ParamType1: ptRace),
(Index: 70; Name: 'GetIsSex'; ParamType1: ptSex),
(Index: 71; Name: 'GetInFaction'; ParamType1: ptFaction),
(Index: 72; Name: 'GetIsID'; ParamType1: ptReferencableObject),
(Index: 73; Name: 'GetFactionRank'; ParamType1: ptFaction),
(Index: 74; Name: 'GetGlobalValue'; ParamType1: ptGlobal),
(Index: 75; Name: 'IsSnowing'),
(Index: 77; Name: 'GetRandomPercent'),
(Index: 79; Name: 'WouldBeStealing'; ParamType1: ptObjectReference),
(Index: 80; Name: 'GetLevel'),
(Index: 81; Name: 'IsRotating'),
(Index: 83; Name: 'GetLeveledEncounterValue'; ParamType1: ptInteger),
(Index: 84; Name: 'GetDeadCount'; ParamType1: ptActorBase),
(Index: 91; Name: 'GetIsAlerted'),
(Index: 99; Name: 'GetHeadingAngle'; ParamType1: ptObjectReference),
(Index: 101; Name: 'IsWeaponMagicOut'),
(Index: 102; Name: 'IsTorchOut'),
(Index: 103; Name: 'IsShieldOut'),
(Index: 105; Name: 'IsActionRef'; ParamType1: ptObjectReference),
(Index: 106; Name: 'IsFacingUp'),
(Index: 107; Name: 'GetKnockedState'),
(Index: 108; Name: 'GetWeaponAnimType'),
(Index: 109; Name: 'IsWeaponSkillType'; ParamType1: ptActorValue),
(Index: 110; Name: 'GetCurrentAIPackage'),
(Index: 111; Name: 'IsWaiting'),
(Index: 112; Name: 'IsIdlePlaying'),
(Index: 116; Name: 'IsIntimidatedbyPlayer'),
(Index: 117; Name: 'IsPlayerInRegion'; ParamType1: ptRegion),
(Index: 118; Name: 'GetActorAggroRadiusViolated'),
(Index: 119; Name: 'GetCrimeKnown'; ParamType1: ptCrimeType; ParamType2: ptActor; ParamType3: ptActor),
(Index: 122; Name: 'GetCrime'; ParamType1: ptActor; ParamType2: ptCrimeType),
(Index: 123; Name: 'IsGreetingPlayer'),
(Index: 125; Name: 'IsGuard'),
(Index: 127; Name: 'HasBeenEaten'),
(Index: 128; Name: 'GetStaminaPercentage'),
(Index: 129; Name: 'HasBeenRead'),
(Index: 130; Name: 'GetDying'),
(Index: 131; Name: 'GetSceneActionPercent'; ParamType1: ptScene; ParamType2: ptInteger),
(Index: 132; Name: 'WouldRefuseCommand'; ParamType1: ptObjectReference),
(Index: 133; Name: 'SameFactionAsPC'),
(Index: 134; Name: 'SameRaceAsPC'),
(Index: 135; Name: 'SameSexAsPC'),
(Index: 136; Name: 'GetIsReference'; ParamType1: ptObjectReference),
(Index: 141; Name: 'IsTalking'),
(Index: 142; Name: 'GetComponentCount'; ParamType1: ptReferencableObject),
(Index: 143; Name: 'GetCurrentAIProcedure'),
(Index: 144; Name: 'GetTrespassWarningLevel'),
(Index: 145; Name: 'IsTrespassing'),
(Index: 146; Name: 'IsInMyOwnedCell'),
(Index: 147; Name: 'GetWindSpeed'),
(Index: 148; Name: 'GetCurrentWeatherPercent'),
(Index: 149; Name: 'GetIsCurrentWeather'; ParamType1: ptWeather),
(Index: 150; Name: 'IsContinuingPackagePCNear'),
(Index: 152; Name: 'GetIsCrimeFaction'; ParamType1: ptFaction),
(Index: 153; Name: 'CanHaveFlames'),
(Index: 154; Name: 'HasFlames'),
(Index: 157; Name: 'GetOpenState'),
(Index: 159; Name: 'GetSitting'),
(Index: 160; Name: 'GetFurnitureMarkerID'),
(Index: 161; Name: 'GetIsCurrentPackage'; ParamType1: ptPackage),
(Index: 162; Name: 'IsCurrentFurnitureRef'; ParamType1: ptObjectReference),
(Index: 163; Name: 'IsCurrentFurnitureObj'; ParamType1: ptFurniture),
(Index: 167; Name: 'GetFactionReaction'; ParamType1: ptFaction; ParamType2: ptFaction),
(Index: 170; Name: 'GetDayOfWeek'),
(Index: 172; Name: 'GetTalkedToPCParam'; ParamType1: ptActor),
(Index: 175; Name: 'IsPCSleeping'),
(Index: 176; Name: 'IsPCAMurderer'),
(Index: 180; Name: 'HasSameEditorLocationAsRef'; ParamType1: ptObjectReference; ParamType2: ptKeyword),
(Index: 181; Name: 'HasSameEditorLocationAsRefAlias'; ParamType1: ptAlias; ParamType2: ptKeyword),
(Index: 182; Name: 'GetEquipped'; ParamType1: ptReferencableObject),
(Index: 185; Name: 'IsSwimming'),
(Index: 186; Name: 'ScriptEffectElapsedSeconds'),
(Index: 188; Name: 'GetPCSleepHours'),
(Index: 190; Name: 'GetAmountSoldStolen'),
(Index: 192; Name: 'GetIgnoreCrime'),
(Index: 193; Name: 'GetPCExpelled'; ParamType1: ptFaction),
(Index: 195; Name: 'GetPCFactionMurder'; ParamType1: ptFaction),
(Index: 197; Name: 'GetPCEnemyofFaction'; ParamType1: ptFaction),
(Index: 199; Name: 'GetPCFactionAttack'; ParamType1: ptFaction),
(Index: 203; Name: 'GetDestroyed'),
(Index: 205; Name: 'GetActionRef'),
(Index: 206; Name: 'GetSelf'),
(Index: 207; Name: 'GetContainer'),
(Index: 208; Name: 'GetForceRun'),
(Index: 210; Name: 'GetForceSneak'),
(Index: 214; Name: 'HasMagicEffect'; ParamType1: ptMagicEffect),
(Index: 215; Name: 'GetDefaultOpen'),
(Index: 223; Name: 'IsSpellTarget'; ParamType1: ptMagicItem),
(Index: 224; Name: 'GetVATSMode'),
(Index: 225; Name: 'GetPersuasionNumber'),
(Index: 226; Name: 'GetVampireFeed'),
(Index: 227; Name: 'GetCannibal'),
(Index: 228; Name: 'GetIsClassDefault'; ParamType1: ptClass),
(Index: 229; Name: 'GetClassDefaultMatch'),
(Index: 230; Name: 'GetInCellParam'; ParamType1: ptCell; ParamType2: ptObjectReference),
(Index: 231; Name: 'GetPlayerDialogueInput'),
(Index: 232; Name: 'GetCombatTarget'),
(Index: 233; Name: 'GetPackageTarget'),
(Index: 235; Name: 'GetVatsTargetHeight'),
(Index: 237; Name: 'GetIsGhost'),
(Index: 242; Name: 'GetUnconscious'),
(Index: 244; Name: 'GetRestrained'),
(Index: 246; Name: 'GetIsUsedItem'; ParamType1: ptReferencableObject),
(Index: 247; Name: 'GetIsUsedItemType'; ParamType1: ptFormType),
(Index: 248; Name: 'IsScenePlaying'; ParamType1: ptScene),
(Index: 249; Name: 'IsInDialogueWithPlayer'),
(Index: 250; Name: 'GetLocationCleared'; ParamType1: ptLocation),
(Index: 254; Name: 'GetIsPlayableRace'),
(Index: 255; Name: 'GetOffersServicesNow'),
(Index: 256; Name: 'GetGameSetting'; ParamType1: ptNone),
(Index: 258; Name: 'HasAssociationType'; ParamType1: ptActor; ParamType2: ptAssociationType),
(Index: 259; Name: 'HasFamilyRelationship'; ParamType1: ptActor),
(Index: 261; Name: 'HasParentRelationship'; ParamType1: ptActor),
(Index: 262; Name: 'IsWarningAbout'; ParamType1: ptFormList),
(Index: 263; Name: 'IsWeaponOut'),
(Index: 264; Name: 'HasSpell'; ParamType1: ptMagicItem),
(Index: 265; Name: 'IsTimePassing'),
(Index: 266; Name: 'IsPleasant'),
(Index: 267; Name: 'IsCloudy'),
(Index: 274; Name: 'IsSmallBump'),
(Index: 275; Name: 'GetParentRef'),
(Index: 277; Name: 'GetBaseValue'; ParamType1: ptActorValue),
(Index: 278; Name: 'IsOwner'; ParamType1: ptOwner),
(Index: 280; Name: 'IsCellOwner'; ParamType1: ptCell; ParamType2: ptOwner),
(Index: 282; Name: 'IsHorseStolen'),
(Index: 285; Name: 'IsLeftUp'),
(Index: 286; Name: 'IsSneaking'),
(Index: 287; Name: 'IsRunning'),
(Index: 288; Name: 'GetFriendHit'),
(Index: 289; Name: 'IsInCombat'; ParamType1: ptInteger),
(Index: 296; Name: 'IsAnimPlaying'; ParamType1: ptReferencableObject),
(Index: 300; Name: 'IsInInterior'),
(Index: 303; Name: 'IsActorsAIOff'),
(Index: 304; Name: 'IsWaterObject'),
(Index: 305; Name: 'GetPlayerAction'),
(Index: 306; Name: 'IsActorUsingATorch'),
(Index: 309; Name: 'IsXBox'),
(Index: 310; Name: 'GetInWorldspace'; ParamType1: ptWorldspace),
(Index: 312; Name: 'GetPCMiscStat'; ParamType1: ptMiscStat),
(Index: 313; Name: 'GetPairedAnimation'),
(Index: 314; Name: 'IsActorAVictim'),
(Index: 315; Name: 'GetTotalPersuasionNumber'),
(Index: 318; Name: 'GetIdleDoneOnce'),
(Index: 320; Name: 'GetNoRumors'),
(Index: 323; Name: 'GetCombatState'),
(Index: 325; Name: 'GetWithinPackageLocation'; ParamType1: ptPackdata),
(Index: 327; Name: 'IsRidingMount'),
(Index: 329; Name: 'IsFleeing'),
(Index: 332; Name: 'IsInDangerousWater'),
(Index: 338; Name: 'GetIgnoreFriendlyHits'),
(Index: 339; Name: 'IsPlayersLastRiddenMount'),
(Index: 344; Name: 'ReleaseWeatherOverride'),
(Index: 348; Name: 'SendTrespassAlarm'; ParamType1: ptActor),
(Index: 353; Name: 'IsActor'),
(Index: 354; Name: 'IsEssential'),
(Index: 358; Name: 'IsPlayerMovingIntoNewSpace'),
(Index: 359; Name: 'GetInCurrentLocation'; ParamType1: ptLocation),
(Index: 360; Name: 'GetInCurrentLocationAlias'; ParamType1: ptAlias),
(Index: 361; Name: 'GetTimeDead'),
(Index: 362; Name: 'HasLinkedRef'; ParamType1: ptKeyword),
(Index: 363; Name: 'GetLinkedRef'; ParamType1: ptKeyword),
(Index: 365; Name: 'IsChild'),
(Index: 366; Name: 'GetStolenItemValueNoCrime'; ParamType1: ptFaction),
(Index: 367; Name: 'GetLastPlayerAction'),
(Index: 368; Name: 'IsPlayerActionActive'; ParamType1: ptInteger),
(Index: 370; Name: 'IsTalkingActivatorActor'; ParamType1: ptActor),
(Index: 372; Name: 'IsInList'; ParamType1: ptFormList),
(Index: 373; Name: 'GetStolenItemValue'; ParamType1: ptFaction),
(Index: 375; Name: 'GetCrimeGoldViolent'; ParamType1: ptFaction),
(Index: 376; Name: 'GetCrimeGoldNonviolent'; ParamType1: ptFaction),
(Index: 378; Name: 'IsOwnedBy'; ParamType1: ptActor),
(Index: 380; Name: 'GetCommandDistance'),
(Index: 381; Name: 'GetCommandLocationDistance'),
(Index: 387; Name: 'GetObjectiveFailed'; ParamType1: ptQuest; ParamType2: ptInteger),
(Index: 390; Name: 'GetHitLocation'),
(Index: 391; Name: 'IsPC1stPerson'),
(Index: 396; Name: 'GetCauseofDeath'),
(Index: 397; Name: 'IsLimbGone'; ParamType1: ptInteger),
(Index: 398; Name: 'IsWeaponInList'; ParamType1: ptFormList),
(Index: 402; Name: 'IsBribedbyPlayer'),
(Index: 403; Name: 'GetRelationshipRank'; ParamType1: ptActor),
(Index: 407; Name: 'GetVATSValue'; ParamType1: ptInteger; ParamType2: ptInteger),
(Index: 408; Name: 'IsKiller'; ParamType1: ptActor),
(Index: 409; Name: 'IsKillerObject'; ParamType1: ptFormList),
(Index: 410; Name: 'GetFactionCombatReaction'; ParamType1: ptFaction; ParamType2: ptFaction),
(Index: 414; Name: 'Exists'; ParamType1: ptObjectReference),
(Index: 415; Name: 'GetGroupMemberCount'),
(Index: 416; Name: 'GetGroupTargetCount'),
(Index: 419; Name: 'GetObjectiveCompleted'; ParamType1: ptQuest; ParamType2: ptInteger),
(Index: 420; Name: 'GetObjectiveDisplayed'; ParamType1: ptQuest; ParamType2: ptInteger),
(Index: 425; Name: 'GetIsFormType'),
(Index: 426; Name: 'GetIsVoiceType'; ParamType1: ptVoiceType),
(Index: 427; Name: 'GetPlantedExplosive'),
(Index: 429; Name: 'IsScenePackageRunning'),
(Index: 430; Name: 'GetHealthPercentage'),
(Index: 432; Name: 'GetIsObjectType'; ParamType1: ptFormType),
(Index: 437; Name: 'GetIsCreatureType'; ParamType1: ptInteger),
(Index: 438; Name: 'HasKey'; ParamType1: ptObjectReference),
(Index: 439; Name: 'IsFurnitureEntryType'; ParamType1: ptReferencableObject),
(Index: 444; Name: 'GetInCurrentLocationFormList'; ParamType1: ptFormList),
(Index: 445; Name: 'GetInZone'; ParamType1: ptEncounterZone),
(Index: 446; Name: 'GetVelocity'; ParamType1: ptAxis),
(Index: 447; Name: 'GetGraphVariableFloat'),
(Index: 448; Name: 'HasPerk'; ParamType1: ptPerk),
(Index: 449; Name: 'GetFactionRelation'; ParamType1: ptActor),
(Index: 450; Name: 'IsLastIdlePlayed'; ParamType1: ptIdleForm),
(Index: 453; Name: 'GetPlayerTeammate'),
(Index: 454; Name: 'GetPlayerTeammateCount'),
(Index: 458; Name: 'GetActorCrimePlayerEnemy'),
(Index: 459; Name: 'GetCrimeGold'; ParamType1: ptFaction),
(Index: 462; Name: 'GetPlayerGrabbedRef'),
(Index: 463; Name: 'IsPlayerGrabbedRef'; ParamType1: ptObjectReference),
(Index: 465; Name: 'GetKeywordItemCount'; ParamType1: ptKeyword),
(Index: 467; Name: 'GetBroadcastState'),
(Index: 470; Name: 'GetDestructionStage'),
(Index: 473; Name: 'GetIsAlignment'; ParamType1: ptAlignment),
(Index: 476; Name: 'IsProtected'),
(Index: 477; Name: 'GetThreatRatio'; ParamType1: ptActor),
(Index: 479; Name: 'GetIsUsedItemEquipType'; ParamType1: ptEquipType),
(Index: 480; Name: 'GetPlayerName'),
(Index: 483; Name: 'GetPlayerActivated'),
(Index: 485; Name: 'GetFullyEnabledActorsInHigh'),
(Index: 487; Name: 'IsCarryable'),
(Index: 488; Name: 'GetConcussed'),
(Index: 489; Name: 'SetZoneRespawns'; ParamType1: ptEncounterZone; ParamType2: ptInteger),
(Index: 490; Name: 'SetVATSTarget'; ParamType1: ptInteger),
(Index: 491; Name: 'GetMapMarkerVisible'),
(Index: 493; Name: 'PlayerKnows'; ParamType1: ptReferencableObject),
(Index: 494; Name: 'GetPermanentValue'; ParamType1: ptActorValue),
(Index: 495; Name: 'GetKillingBlowLimb'),
(Index: 497; Name: 'CanPayCrimeGold'; ParamType1: ptFaction),
(Index: 499; Name: 'GetDaysInJail'),
(Index: 500; Name: 'EPAlchemyGetMakingPoison'),
(Index: 501; Name: 'EPAlchemyEffectHasKeyword'; ParamType1: ptKeyword),
(Index: 503; Name: 'GetAllowWorldInteractions'),
(Index: 506; Name: 'DialogueGetAv'; ParamType1: ptActorValue),
(Index: 507; Name: 'DialogueHasPerk'; ParamType1: ptPerk),
(Index: 508; Name: 'GetLastHitCritical'),
(Index: 510; Name: 'DialogueGetItemCount'; ParamType1: ptReferencableObject),
(Index: 511; Name: 'LastCrippledCondition'; ParamType1: ptActorValue),
(Index: 512; Name: 'HasSharedPowerGrid'; ParamType1: ptObjectReference),
(Index: 513; Name: 'IsCombatTarget'; ParamType1: ptActor),
(Index: 515; Name: 'GetVATSRightAreaFree'; ParamType1: ptObjectReference),
(Index: 516; Name: 'GetVATSLeftAreaFree'; ParamType1: ptObjectReference),
(Index: 517; Name: 'GetVATSBackAreaFree'; ParamType1: ptObjectReference),
(Index: 518; Name: 'GetVATSFrontAreaFree'; ParamType1: ptObjectReference),
(Index: 519; Name: 'GetIsLockBroken'),
(Index: 520; Name: 'IsPS3'),
(Index: 521; Name: 'IsWindowsPC'),
(Index: 522; Name: 'GetVATSRightTargetVisible'; ParamType1: ptObjectReference),
(Index: 523; Name: 'GetVATSLeftTargetVisible'; ParamType1: ptObjectReference),
(Index: 524; Name: 'GetVATSBackTargetVisible'; ParamType1: ptObjectReference),
(Index: 525; Name: 'GetVATSFrontTargetVisible'; ParamType1: ptObjectReference),
(Index: 528; Name: 'IsInCriticalStage'; ParamType1: ptCriticalStage),
(Index: 530; Name: 'GetXPForNextLevel'),
(Index: 533; Name: 'GetInfamy'; ParamType1: ptFaction),
(Index: 534; Name: 'GetInfamyViolent'; ParamType1: ptFaction),
(Index: 535; Name: 'GetInfamyNonViolent'; ParamType1: ptFaction),
(Index: 536; Name: 'GetTypeCommandPerforming'),
(Index: 543; Name: 'GetQuestCompleted'; ParamType1: ptQuest),
(Index: 544; Name: 'GetSpeechChallengeSuccessLevel'),
(Index: 545; Name: 'PipBoyRadioOff'),
(Index: 547; Name: 'IsGoreDisabled'),
(Index: 550; Name: 'IsSceneActionComplete'; ParamType1: ptScene; ParamType2: ptInteger),
(Index: 552; Name: 'GetSpellUsageNum'; ParamType1: ptMagicItem),
(Index: 554; Name: 'GetActorsInHigh'),
(Index: 555; Name: 'HasLoaded3D'),
(Index: 559; Name: 'IsImageSpaceActive'; ParamType1: ptReferencableObject),
(Index: 560; Name: 'HasKeyword'; ParamType1: ptKeyword),
(Index: 561; Name: 'HasRefType'; ParamType1: ptRefType),
(Index: 562; Name: 'LocationHasKeyword'; ParamType1: ptKeyword),
(Index: 563; Name: 'LocationHasRefType'; ParamType1: ptRefType),
(Index: 565; Name: 'GetIsEditorLocation'; ParamType1: ptLocation),
(Index: 566; Name: 'GetIsAliasRef'; ParamType1: ptAlias),
(Index: 567; Name: 'GetIsEditorLocationAlias'; ParamType1: ptAlias),
(Index: 568; Name: 'IsSprinting'),
(Index: 569; Name: 'IsBlocking'),
(Index: 570; Name: 'HasEquippedSpell'; ParamType1: ptCastingSource),
(Index: 571; Name: 'GetCurrentCastingType'; ParamType1: ptCastingSource),
(Index: 572; Name: 'GetCurrentDeliveryType'; ParamType1: ptCastingSource),
(Index: 574; Name: 'GetAttackState'),
(Index: 575; Name: 'GetAliasedRef'; ParamType1: ptAlias),
(Index: 576; Name: 'GetEventData'; ParamType1: ptEvent; ParamType2: ptEventData; ParamType3: ptNone), // fireundubh: Event Function, Event Member, Data (FO4)
(Index: 577; Name: 'IsCloserToAThanB'; ParamType1: ptObjectReference; ParamType2: ptObjectReference),
(Index: 578; Name: 'LevelMinusPCLevel'),
(Index: 580; Name: 'IsBleedingOut'),
(Index: 584; Name: 'GetRelativeAngle'; ParamType1: ptObjectReference; ParamType2: ptAxis),
(Index: 589; Name: 'GetMovementDirection'),
(Index: 590; Name: 'IsInScene'),
(Index: 591; Name: 'GetRefTypeDeadCount'; ParamType1: ptLocation; ParamType2: ptRefType),
(Index: 592; Name: 'GetRefTypeAliveCount'; ParamType1: ptLocation; ParamType2: ptRefType),
(Index: 594; Name: 'GetIsFlying'),
(Index: 595; Name: 'IsCurrentSpell'; ParamType1: ptMagicItem; ParamType2: ptCastingSource),
(Index: 596; Name: 'SpellHasKeyword'; ParamType1: ptCastingSource; ParamType2: ptKeyword),
(Index: 597; Name: 'GetEquippedItemType'; ParamType1: ptCastingSource),
(Index: 598; Name: 'GetLocationAliasCleared'; ParamType1: ptAlias),
(Index: 600; Name: 'GetLocationAliasRefTypeDeadCount'; ParamType1: ptAlias; ParamType2: ptRefType),
(Index: 601; Name: 'GetLocationAliasRefTypeAliveCount'; ParamType1: ptAlias; ParamType2: ptRefType),
(Index: 602; Name: 'IsWardState'; ParamType1: ptWardState),
(Index: 603; Name: 'IsInSameCurrentLocationAsRef'; ParamType1: ptObjectReference; ParamType2: ptKeyword),
(Index: 604; Name: 'IsInSameCurrentLocationAsRefAlias'; ParamType1: ptAlias; ParamType2: ptKeyword),
(Index: 605; Name: 'LocationAliasIsLocation'; ParamType1: ptAlias; ParamType2: ptLocation),
(Index: 606; Name: 'GetKeywordDataForLocation'; ParamType1: ptLocation; ParamType2: ptKeyword),
(Index: 608; Name: 'GetKeywordDataForAlias'; ParamType1: ptAlias; ParamType2: ptKeyword),
(Index: 610; Name: 'LocationAliasHasKeyword'; ParamType1: ptAlias; ParamType2: ptKeyword),
(Index: 611; Name: 'IsNullPackageData'; ParamType1: ptPackdata),
(Index: 612; Name: 'GetNumericPackageData'; ParamType1: ptPackdata),
(Index: 613; Name: 'IsPlayerRadioOn'),
(Index: 614; Name: 'GetPlayerRadioFrequency'),
(Index: 615; Name: 'GetHighestRelationshipRank'),
(Index: 616; Name: 'GetLowestRelationshipRank'),
(Index: 617; Name: 'HasAssociationTypeAny'; ParamType1: ptAssociationType),
(Index: 618; Name: 'HasFamilyRelationshipAny'),
(Index: 619; Name: 'GetPathingTargetOffset'; ParamType1: ptAxis),
(Index: 620; Name: 'GetPathingTargetAngleOffset'; ParamType1: ptAxis),
(Index: 621; Name: 'GetPathingTargetSpeed'),
(Index: 622; Name: 'GetPathingTargetSpeedAngle'; ParamType1: ptAxis),
(Index: 623; Name: 'GetMovementSpeed'),
(Index: 624; Name: 'GetInContainer'; ParamType1: ptObjectReference),
(Index: 625; Name: 'IsLocationLoaded'; ParamType1: ptLocation),
(Index: 626; Name: 'IsLocationAliasLoaded'; ParamType1: ptAlias),
(Index: 627; Name: 'IsDualCasting'),
(Index: 629; Name: 'GetVMQuestVariable'; ParamType1: ptQuest; ParamType2: ptNone),
(Index: 630; Name: 'GetCombatAudioDetection'),
(Index: 631; Name: 'GetCombatVisualDetection'),
(Index: 632; Name: 'IsCasting'),
(Index: 633; Name: 'GetFlyingState'),
(Index: 635; Name: 'IsInFavorState'),
(Index: 636; Name: 'HasTwoHandedWeaponEquipped'),
(Index: 637; Name: 'IsFurnitureExitType'; ParamType1: ptReferencableObject),
(Index: 638; Name: 'IsInFriendStatewithPlayer'),
(Index: 639; Name: 'GetWithinDistance'; ParamType1: ptObjectReference; ParamType2: ptFloat),
(Index: 640; Name: 'GetValuePercent'; ParamType1: ptActorValue),
(Index: 641; Name: 'IsUnique'),
(Index: 642; Name: 'GetLastBumpDirection'),
(Index: 644; Name: 'GetInfoChallangeSuccess'),
(Index: 645; Name: 'GetIsInjured'),
(Index: 646; Name: 'GetIsCrashLandRequest'),
(Index: 647; Name: 'GetIsHastyLandRequest'),
(Index: 650; Name: 'IsLinkedTo'; ParamType1: ptObjectReference; ParamType2: ptKeyword),
(Index: 651; Name: 'GetKeywordDataForCurrentLocation'; ParamType1: ptKeyword),
(Index: 652; Name: 'GetInSharedCrimeFaction'; ParamType1: ptObjectReference),
(Index: 653; Name: 'GetBribeAmount'),
(Index: 654; Name: 'GetBribeSuccess'),
(Index: 655; Name: 'GetIntimidateSuccess'),
(Index: 656; Name: 'GetArrestedState'),
(Index: 657; Name: 'GetArrestingActor'),
(Index: 659; Name: 'HasVMScript'; ParamType1: ptNone),
(Index: 660; Name: 'GetVMScriptVariable'; ParamType1: ptNone; ParamType2: ptNone),
(Index: 661; Name: 'GetWorkshopResourceDamage'; ParamType1: ptActorValue),
(Index: 664; Name: 'HasValidRumorTopic'; ParamType1: ptQuest),
(Index: 672; Name: 'IsAttacking'),
(Index: 673; Name: 'IsPowerAttacking'),
(Index: 674; Name: 'IsLastHostileActor'),
(Index: 675; Name: 'GetGraphVariableInt'; ParamType1: ptNone),
(Index: 678; Name: 'ShouldAttackKill'; ParamType1: ptActor),
(Index: 680; Name: 'GetActivationHeight'),
(Index: 682; Name: 'WornHasKeyword'; ParamType1: ptKeyword),
(Index: 683; Name: 'GetPathingCurrentSpeed'),
(Index: 684; Name: 'GetPathingCurrentSpeedAngle'; ParamType1: ptAxis),
(Index: 691; Name: 'GetWorkshopObjectCount'; ParamType1: ptReferencableObject),
(Index: 693; Name: 'EPMagic_SpellHasKeyword'; ParamType1: ptKeyword),
(Index: 694; Name: 'GetNoBleedoutRecovery'),
(Index: 696; Name: 'EPMagic_SpellHasSkill'; ParamType1: ptActorValue),
(Index: 697; Name: 'IsAttackType'; ParamType1: ptKeyword),
(Index: 698; Name: 'IsAllowedToFly'),
(Index: 699; Name: 'HasMagicEffectKeyword'; ParamType1: ptKeyword),
(Index: 700; Name: 'IsCommandedActor'),
(Index: 701; Name: 'IsStaggered'),
(Index: 702; Name: 'IsRecoiling'),
(Index: 703; Name: 'HasScopeWeaponEquipped'),
(Index: 704; Name: 'IsPathing'),
(Index: 705; Name: 'GetShouldHelp'; ParamType1: ptActor),
(Index: 706; Name: 'HasBoundWeaponEquipped'; ParamType1: ptCastingSource),
(Index: 707; Name: 'GetCombatTargetHasKeyword'; ParamType1: ptKeyword),
(Index: 709; Name: 'GetCombatGroupMemberCount'),
(Index: 710; Name: 'IsIgnoringCombat'),
(Index: 711; Name: 'GetLightLevel'),
(Index: 713; Name: 'SpellHasCastingPerk'; ParamType1: ptPerk),
(Index: 714; Name: 'IsBeingRidden'),
(Index: 715; Name: 'IsUndead'),
(Index: 716; Name: 'GetRealHoursPassed'),
(Index: 718; Name: 'IsUnlockedDoor'),
(Index: 719; Name: 'IsHostileToActor'; ParamType1: ptActor),
(Index: 720; Name: 'GetTargetHeight'; ParamType1: ptObjectReference),
(Index: 721; Name: 'IsPoison'),
(Index: 722; Name: 'WornApparelHasKeywordCount'; ParamType1: ptKeyword),
(Index: 723; Name: 'GetItemHealthPercent'),
(Index: 724; Name: 'EffectWasDualCast'),
(Index: 725; Name: 'GetKnockStateEnum'),
(Index: 726; Name: 'DoesNotExist'),
(Index: 728; Name: 'GetPlayerWalkAwayFromDialogueScene'),
(Index: 729; Name: 'GetActorStance'),
(Index: 734; Name: 'CanProduceForWorkshop'),
(Index: 735; Name: 'CanFlyHere'),
(Index: 736; Name: 'EPIsDamageType'; ParamType1: ptDamageType),
(Index: 738; Name: 'GetActorGunState'),
(Index: 739; Name: 'GetVoiceLineLength'),
(Index: 741; Name: 'ObjectTemplateItem_HasKeyword'; ParamType1: ptKeyword),
(Index: 742; Name: 'ObjectTemplateItem_HasUniqueKeyword'; ParamType1: ptKeyword),
(Index: 743; Name: 'ObjectTemplateItem_GetLevel'),
(Index: 744; Name: 'MovementIdleMatches'; ParamType1: ptInteger; ParamType2: ptInteger), // TODO: determine correct param types (2)
(Index: 745; Name: 'GetActionData'),
(Index: 746; Name: 'GetActionDataShort'; ParamType1: ptInteger),
(Index: 747; Name: 'GetActionDataByte'; ParamType1: ptInteger),
(Index: 748; Name: 'GetActionDataFlag'; ParamType1: ptInteger),
(Index: 749; Name: 'ModdedItemHasKeyword'; ParamType1: ptKeyword),
(Index: 750; Name: 'GetAngryWithPlayer'),
(Index: 751; Name: 'IsCameraUnderWater'),
(Index: 753; Name: 'IsActorRefOwner'; ParamType1: ptActor),
(Index: 754; Name: 'HasActorRefOwner'; ParamType1: ptActor),
(Index: 756; Name: 'GetLoadedAmmoCount'),
(Index: 757; Name: 'IsTimeSpanSunrise'),
(Index: 758; Name: 'IsTimeSpanMorning'),
(Index: 759; Name: 'IsTimeSpanAfternoon'),
(Index: 760; Name: 'IsTimeSpanEvening'),
(Index: 761; Name: 'IsTimeSpanSunset'),
(Index: 762; Name: 'IsTimeSpanNight'),
(Index: 763; Name: 'IsTimeSpanMidnight'),
(Index: 764; Name: 'IsTimeSpanAnyDay'),
(Index: 765; Name: 'IsTimeSpanAnyNight'),
(Index: 766; Name: 'CurrentFurnitureHasKeyword'; ParamType1: ptKeyword),
(Index: 767; Name: 'GetWeaponEquipIndex'),
(Index: 769; Name: 'IsOverEncumbered'),
(Index: 770; Name: 'IsPackageRequestingBlockedIdles'),
(Index: 771; Name: 'GetActionDataInt'),
(Index: 772; Name: 'GetVATSRightMinusLeftAreaFree'; ParamType1: ptObjectReference),
(Index: 773; Name: 'GetInIronSights'; ParamType1: ptObjectReference),
(Index: 774; Name: 'GetActorStaggerDirection'),
(Index: 775; Name: 'GetActorStaggerMagnitude'),
(Index: 776; Name: 'WornCoversBipedSlot'; ParamType1: ptInteger),
(Index: 777; Name: 'GetInventoryValue'),
(Index: 778; Name: 'IsPlayerInConversation'),
(Index: 779; Name: 'IsInDialogueCamera'),
(Index: 780; Name: 'IsMyDialogueTargetPlayer'),
(Index: 781; Name: 'IsMyDialogueTargetActor'),
(Index: 782; Name: 'GetMyDialogueTargetDistance'),
(Index: 783; Name: 'IsSeatOccupied'; ParamType1: ptKeyword),
(Index: 784; Name: 'IsPlayerRiding'),
(Index: 785; Name: 'IsTryingEventCamera'),
(Index: 786; Name: 'UseLeftSideCamera'),
(Index: 787; Name: 'GetNoteType'),
(Index: 788; Name: 'LocationHasPlayerOwnedWorkshop'),
(Index: 789; Name: 'IsStartingAction'),
(Index: 790; Name: 'IsMidAction'),
(Index: 791; Name: 'IsWeaponChargeAttack'),
(Index: 792; Name: 'IsInWorkshopMode'),
(Index: 793; Name: 'IsWeaponChargingHoldAttack'),
(Index: 794; Name: 'IsEncounterAbovePlayerLevel'),
(Index: 795; Name: 'IsMeleeAttacking'),
(Index: 796; Name: 'GetVATSQueuedTargetsUnique'),
(Index: 797; Name: 'GetCurrentLocationCleared'),
(Index: 798; Name: 'IsPowered'),
(Index: 799; Name: 'GetTransmitterDistance'),
(Index: 800; Name: 'GetCameraPlaybackTime'),
(Index: 801; Name: 'IsInWater'),
(Index: 802; Name: 'GetWithinActivateDistance'; ParamType1: ptObjectReference),
(Index: 803; Name: 'IsUnderWater'),
(Index: 804; Name: 'IsInSameSpace'; ParamType1: ptObjectReference),
(Index: 805; Name: 'LocationAllowsReset'),
(Index: 806; Name: 'GetVATSBackRightAreaFree'; ParamType1: ptObjectReference),
(Index: 807; Name: 'GetVATSBackLeftAreaFree'; ParamType1: ptObjectReference),
(Index: 808; Name: 'GetVATSBackRightTargetVisible'; ParamType1: ptObjectReference),
(Index: 809; Name: 'GetVATSBackLeftTargetVisible'; ParamType1: ptObjectReference),
(Index: 810; Name: 'GetVATSTargetLimbVisible'; ParamType1: ptObjectReference),
(Index: 811; Name: 'IsPlayerListening'; ParamType1: ptFloat),
(Index: 812; Name: 'GetPathingRequestedQuickTurn'),
(Index: 813; Name: 'EPIsCalculatingBaseDamage'),
(Index: 814; Name: 'GetReanimating'),
(Index: 817; Name: 'IsInRobotWorkbench'),
// F4SE
(Index: 1024; Name: 'GetSKSEVersion'; ),
(Index: 1025; Name: 'GetSKSEVersionMinor'; ),
(Index: 1026; Name: 'GetSKSEVersionBeta'; ),
(Index: 1027; Name: 'GetSKSERelease'; ),
(Index: 1028; Name: 'ClearInvalidRegistrations'; )
);
var
wbCTDAFunctionEditInfo: string;
function wbCTDAParamDescFromIndex(aIndex: Integer): PCTDAFunction;
var
L, H, I, C: Integer;
begin
Result := nil;
L := Low(wbCTDAFunctions);
H := High(wbCTDAFunctions);
while L <= H do begin
I := (L + H) shr 1;
C := CmpW32(wbCTDAFunctions[I].Index, aIndex);
if C < 0 then
L := I + 1
else begin
H := I - 1;
if C = 0 then begin
L := I;
Result := @wbCTDAFunctions[L];
end;
end;
end;
end;
function wbCTDACompValueDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
// "use global" flag
if Integer(Container.ElementByName['Type'].NativeValue) and $04 <> 0 then
Result := 1;
end;
function wbCTDAParam1Decider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Desc: PCTDAFunction;
Container: IwbContainer;
ParamFlag: Byte;
ParamType: TCTDAFunctionParamType;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Desc := wbCTDAParamDescFromIndex(Container.ElementByName['Function'].NativeValue);
if Assigned(Desc) then begin
ParamType := Desc.ParamType1;
ParamFlag := Container.ElementByName['Type'].NativeValue;
if ParamType in [ptObjectReference, ptActor, ptPackage] then begin
if ParamFlag and $02 > 0 then begin
// except for this func when Run On = Quest Alias, then alias is param3 and package is param1
// [INFO:00020D3C]
if not ((Container.ElementByName['Run On'].NativeValue = 5) and (Desc.Name = 'GetIsCurrentPackage')) then
ParamType := ptAlias {>>> 'use aliases' is set <<<}
end
else if ParamFlag and $08 > 0 then
ParamType := ptPackdata; {>>> 'use packdata' is set <<<}
end;
Result := Succ(Integer(ParamType));
end;
end;
function wbCTDAParam2Decider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Desc: PCTDAFunction;
Container: IwbContainer;
ParamFlag: Byte;
ParamType: TCTDAFunctionParamType;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Desc := wbCTDAParamDescFromIndex(Container.ElementByName['Function'].NativeValue);
if Assigned(Desc) then begin
ParamType := Desc.ParamType2;
ParamFlag := Container.ElementByName['Type'].NativeValue;
if ParamType in [ptObjectReference, ptActor, ptPackage] then begin
if ParamFlag and $02 > 0 then ParamType := ptAlias else {>>> 'use aliases' is set <<<}
if ParamFlag and $08 > 0 then ParamType := ptPackdata; {>>> 'use packdata' is set <<<}
end;
Result := Succ(Integer(ParamType));
end;
end;
function wbCTDAParam2VATSValueParamDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Result := Container.ElementByName['Parameter #1'].NativeValue;
end;
function wbCTDAFunctionToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Desc : PCTDAFunction;
i : Integer;
begin
Result := '';
case aType of
ctToStr, ctToEditValue: begin
Desc := wbCTDAParamDescFromIndex(aInt);
if Assigned(Desc) then
Result := Desc.Name
else if aType = ctToEditValue then
Result := IntToStr(aInt)
else
Result := '';
end;
ctToSortKey: Result := IntToHex(aInt, 8);
ctCheck: begin
Desc := wbCTDAParamDescFromIndex(aInt);
if Assigned(Desc) then
Result := ''
else
Result := '';
end;
ctEditType:
Result := 'ComboBox';
ctEditInfo: begin
Result := wbCTDAFunctionEditInfo;
if Result = '' then begin
with TStringList.Create do try
for i := Low(wbCTDAFunctions) to High(wbCTDAFunctions) do
Add(wbCTDAFunctions[i].Name);
Sort;
Result := CommaText;
finally
Free;
end;
wbCTDAFunctionEditInfo := Result;
end;
end;
end;
end;
function wbCTDAFunctionToInt(const aString: string; const aElement: IwbElement): Int64;
var
i: Integer;
begin
for i := Low(wbCTDAFunctions) to High(wbCTDAFunctions) do
with wbCTDAFunctions[i] do
if SameText(Name, aString) then begin
Result := Index;
Exit;
end;
Result := StrToInt64(aString);
end;
function wbNeverShow(const aElement: IwbElement): Boolean;
begin
Result := wbHideNeverShow;
end;
function GetREGNType(aElement: IwbElement): Integer;
var
Container: IwbContainerElementRef;
begin
Result := -1;
if not Assigned(aElement) then
Exit;
while aElement.Name <> 'Region Data Entry' do begin
aElement := aElement.Container;
if not Assigned(aElement) then
Exit;
end;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
Result := Container.ElementNativeValues['RDAT\Type'];
end;
function wbREGNObjectsDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 2;
end;
function wbREGNWeatherDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 3;
end;
function wbREGNMapDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 4;
end;
function wbREGNLandDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 5;
end;
function wbREGNGrassDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 6;
end;
function wbREGNSoundDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 7;
end;
function wbREGNImposterDontShow(const aElement: IwbElement): Boolean;
begin
Result := GetREGNType(aElement) <> 8;
end;
function wbMESGTNAMDontShow(const aElement: IwbElement): Boolean;
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
Result := False;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Integer(Container.ElementNativeValues['DNAM']) and 1 <> 0 then
Result := True;
end;
function wbEPFDDontShow(const aElement: IwbElement): Boolean;
var
Container: IwbContainerElementRef;
begin
Result := False;
if aElement.Name <> 'Entry Point Function Parameters' then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if not (Integer(Container.ElementNativeValues['EPFT']) in [1..3]) then
Result := True;
end;
function wbTES4ONAMDontShow(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
Result := False;
if not Assigned(aElement) then
Exit;
MainRecord := aElement.ContainingMainRecord;
if not Assigned(MainRecord) then
Exit;
if not MainRecord.IsESM then
Result := True;
end;
function wbEPF2DontShow(const aElement: IwbElement): Boolean;
var
Container: IwbContainerElementRef;
begin
Result := False;
if aElement.Name <> 'Entry Point Function Parameters' then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if not (Integer(Container.ElementNativeValues['EPFT']) in [4]) then
Result := True;
end;
procedure wbRemoveOFST(const aElement: IwbElement);
var
Container: IwbContainer;
rOFST: IwbRecord;
begin
if not wbRemoveOffsetData then
Exit;
if Supports(aElement, IwbContainer, Container) then begin
if wbBeginInternalEdit then try
Container.RemoveElement(OFST);
finally
wbEndInternalEdit;
end else begin
rOFST := Container.RecordBySignature[OFST];
if Assigned(rOFST) then
Container.RemoveElement(rOFST);
end;
end;
end;
procedure wbWRLDAfterLoad(const aElement: IwbElement);
function OutOfRange(aValue: Integer; aRange: Integer = 256): Boolean;
begin
Result := (aValue < -aRange) or (aValue > aRange);
end;
var
MainRecord: IwbMainRecord;
Container: IwbContainer;
begin
wbRemoveOFST(aElement);
if wbBeginInternalEdit then try
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.ElementExists['Unused RNAM'] then
MainRecord.RemoveElement('Unused RNAM');
//if MainRecord.ElementExists['World Default Level Data'] then
// MainRecord.RemoveElement('World Default Level Data');
//if MainRecord.ElementExists['MHDT'] then
// MainRecord.RemoveElement('MHDT');
if MainRecord.ElementExists['CLSZ'] then
MainRecord.RemoveElement('CLSZ');
// large values in object bounds cause stutter and performance issues in game (reported by Arthmoor)
// CK can occasionally set them wrong, so make a warning
if Supports(MainRecord.ElementByName['Object Bounds'], IwbContainer, Container) then
if OutOfRange(StrToIntDef(Container.ElementEditValues['NAM0\X'], 0)) or
OutOfRange(StrToIntDef(Container.ElementEditValues['NAM0\Y'], 0)) or
OutOfRange(StrToIntDef(Container.ElementEditValues['NAM9\X'], 0)) or
OutOfRange(StrToIntDef(Container.ElementEditValues['NAM9\Y'], 0))
then
wbProgressCallback('');
finally
wbEndInternalEdit;
end;
end;
procedure wbDOBJObjectsAfterLoad(const aElement: IwbElement);
var
ObjectsContainer : IwbContainerElementRef;
i : Integer;
ObjectContainer : IwbContainerElementRef;
begin
wbRemoveOFST(aElement);
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, ObjectsContainer) then
Exit;
for i := Pred(ObjectsContainer.ElementCount) downto 0 do
if Supports(ObjectsContainer.Elements[i], IwbContainerElementRef, ObjectContainer) then
if ObjectContainer.ElementNativeValues['Use'] = 0 then
ObjectsContainer.RemoveElement(i, True);
finally
wbEndInternalEdit;
end;
end;
function wbActorTemplateUseTraits(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
Element := aElement;
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000001) <> 0;
end;
end;
function wbActorTemplateUseStats(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
Element := aElement;
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000002) <> 0;
end;
end;
function wbActorAutoCalcDontShow(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
Element := aElement;
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Flags'];
Result := (i and $00000010) <> 0;
end;
end;
function wbActorTemplateUseStatsAutoCalc(const aElement: IwbElement): Boolean;
begin
Result := wbActorTemplateUseStats(aElement) or wbActorAutoCalcDontShow(aElement);
end;
function wbActorTemplateUseFactions(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
Element := aElement;
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000004) <> 0;
end;
end;
function wbActorTemplateUseActorEffectList(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
Element := aElement;
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000008) <> 0;
end;
end;
function wbActorTemplateUseAIData(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
Element := aElement;
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000010) <> 0;
end;
end;
function wbActorTemplateUseAIPackages(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
Element := aElement;
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000020) <> 0;
end;
end;
function wbActorTemplateUseModelAnimation(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
Element := aElement;
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000040) <> 0;
end;
end;
function wbActorTemplateUseBaseData(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
Element := aElement;
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000080) <> 0;
end;
end;
function wbActorTemplateUseInventory(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
Element := aElement;
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000100) <> 0;
end;
end;
function wbActorTemplateUseScript(const aElement: IwbElement): Boolean;
var
Element : IwbElement;
MainRecord : IwbMainRecord;
i : Int64;
begin
Result := False;
Element := aElement;
MainRecord := nil;
while Assigned(Element) and not Supports(Element, IwbMainRecord, MainRecord) do
Element := Element.Container;
if Assigned(MainRecord) then begin
i := MainRecord.ElementNativeValues['ACBS\Template Flags'];
Result := (i and $00000200) <> 0;
end;
end;
function wbActorTemplatesUseTemplate0(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 0 and 1) = 0
else
Result := False;
end;
function wbActorTemplatesUseTemplate1(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 1 and 1) = 0
else
Result := False;
end;
function wbActorTemplatesUseTemplate2(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 2 and 1) = 0
else
Result := False;
end;
function wbActorTemplatesUseTemplate3(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 3 and 1) = 0
else
Result := False;
end;
function wbActorTemplatesUseTemplate4(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 4 and 1) = 0
else
Result := False;
end;
function wbActorTemplatesUseTemplate5(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 5 and 1) = 0
else
Result := False;
end;
function wbActorTemplatesUseTemplate6(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 6 and 1) = 0
else
Result := False;
end;
function wbActorTemplatesUseTemplate7(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 7 and 1) = 0
else
Result := False;
end;
function wbActorTemplatesUseTemplate8(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 8 and 1) = 0
else
Result := False;
end;
function wbActorTemplatesUseTemplate9(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 9 and 1) = 0
else
Result := False;
end;
function wbActorTemplatesUseTemplate10(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 10 and 1) = 0
else
Result := False;
end;
function wbActorTemplatesUseTemplate11(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 11 and 1) = 0
else
Result := False;
end;
function wbActorTemplatesUseTemplate12(const aElement: IwbElement): Boolean;
var
MainRecord : IwbMainRecord;
begin
MainRecord := aElement.ContainingMainRecord;
if Assigned(MainRecord) then
Result := (Cardinal(MainRecord.ElementNativeValues['ACBS\Use Template Actors']) shr 12 and 1) = 0
else
Result := False;
end;
procedure wbRemoveEmptyKWDA(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if not Assigned(Container.ElementBySignature['KSIZ']) then
if Assigned(Container.ElementBySignature['KWDA']) then
Container.ElementBySignature['KWDA'].Remove;
finally
wbEndInternalEdit;
end;
end;
procedure wbReplaceBODTwithBOD2(const aElement: IwbElement);
var
MainRecord : IwbMainRecord;
ContainerBOD2 : IwbContainerElementRef;
ContainerBODT : IwbContainerElementRef;
begin
Exit; {>>> Looks like causes problems with Dawnguard.esm <<<}
if wbBeginInternalEdit then try
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if not Supports(MainRecord.ElementBySignature[BODT], IwbContainerElementRef, ContainerBODT) then
Exit;
if Supports(MainRecord.Add('BOD2', True), IwbContainerElementRef, ContainerBOD2) then begin
ContainerBOD2.ElementNativeValues['First Person Flags'] := ContainerBODT.ElementNativeValues['First Person Flags'];
ContainerBOD2.ElementNativeValues['Armor Type'] := ContainerBODT.ElementNativeValues['Armor Type'];
MainRecord.RemoveElement(BODT);
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbARMOAfterLoad(const aElement: IwbElement);
begin
wbRemoveEmptyKWDA(aElement);
wbReplaceBODTwithBOD2(aElement);
end;
procedure wbARMAAfterLoad(const aElement: IwbElement);
{var
MainRecord : IwbMainRecord;}
begin
wbReplaceBODTwithBOD2(aElement);
{if wbBeginInternalEdit then try
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.ElementNativeValues['DNAM\Weight slider - Male'] = 0 then
MainRecord.ElementNativeValues['DNAM\Weight slider - Male'] := 2;
if MainRecord.ElementNativeValues['DNAM\Weight slider - Female'] = 0 then
MainRecord.ElementNativeValues['DNAM\Weight slider - Female'] := 2;
finally
wbEndInternalEdit;
end;}
end;
procedure wbNPCAfterLoad(const aElement: IwbElement);
begin
wbRemoveEmptyKWDA(aElement);
end;
procedure wbREFRAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if Container.ElementExists['XLOC'] then begin
if Container.ElementNativeValues['XLOC - Lock Data\Level'] = 0 then
Container.ElementNativeValues['XLOC - Lock Data\Level'] := 1;
end;
Container.RemoveElement('XPTL');
finally
wbEndInternalEdit;
end;
end;
procedure wbWEAPAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
Flags : Cardinal;
begin
wbRemoveEmptyKWDA(aElement);
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
// clear IronSights flags which are randomly assigned in CK
if Container.ElementExists['DNAM'] then begin
Flags := Container.ElementNativeValues['DNAM - Data\Flags'];
Flags := Flags and ($FFFF xor $0040);
Container.ElementNativeValues['DNAM - Data\Flags'] := Flags;
Flags := Container.ElementNativeValues['DNAM - Data\Flags2'];
Flags := Flags and ($FFFFFFFF xor $0100);
Container.ElementNativeValues['DNAM - Data\Flags2'] := Flags;
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbCELLXCLWGetConflictPriority(const aElement: IwbElement; var aCP: TwbConflictPriority);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
DataRec : IwbElement;
Flags : Cardinal;
begin
if not Assigned(aElement) then
Exit;
if not Supports(aElement.Container, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(Container, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
DataRec := MainRecord.ElementBySignature[DATA];
if not Assigned(DataRec) then
Exit;
Flags := DataRec.NativeValue;
{0x0001 Is Interior Cell}
if (Flags and 1) = 1 then
{Interior cells don't use water level in Skyrim at all}
aCP := cpIgnore;
end;
procedure wbCELLDATAAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Container : IwbContainer;
begin
if not Assigned(aElement) then
Exit;
Container := aElement.Container;
while Assigned(Container) and not (Container.Def.DefType = dtRecord) do
Container := Container.Container;
if Assigned(Container) then
Container.ResetConflict;
end;
procedure wbCELLAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
// Container2 : IwbContainerElementRef;
MainRecord : IwbMainRecord;
DataSubRec : IwbSubrecord;
Flags : Byte;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if Supports(Container.ElementBySignature['DATA'] , IwbSubRecord, DataSubRec) then begin
// expand itU8 flags to itU16
if DataSubRec.SubRecordHeaderSize = 1 then begin
Flags := PByte(DataSubRec.DataBasePtr)^;
DataSubRec.SetToDefault;
DataSubRec.NativeValue := Flags;
end;
// 'Default' water height for exterior cells if not set (so water height will be taken from WRLD by game)
if (not Container.ElementExists['XCLW']) and ((Integer(DataSubRec.NativeValue) and $02) <> 0) then begin
Container.Add('XCLW', True);
Container.ElementEditValues['XCLW'] := 'Default';
end;
end;
// Min (-0 as in CK) water height is set to 0 when saving in CK
if Container.ElementEditValues['XCLW'] = 'Min' then
Container.ElementEditValues['XCLW'] := '0.0';
// if Supports(Container.ElementBySignature[XCLR], IwbContainerElementRef, Container2) then begin
// for i := Pred(Container2.ElementCount) downto 0 do
// if not Supports(Container2.Elements[i].LinksTo, IwbMainRecord, MainRecord) or (MainRecord.Signature <> 'REGN') then
// Container2.RemoveElement(i);
// if Container2.ElementCount < 1 then
// Container2.Remove;
// end;
finally
wbEndInternalEdit;
end;
end;
procedure wbMESGAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
MainRecord : IwbMainRecord;
IsMessageBox : Boolean;
HasTimeDelay : Boolean;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
IsMessageBox := (Integer(Container.ElementNativeValues['DNAM']) and 1) = 1;
HasTimeDelay := Container.ElementExists['TNAM'];
if IsMessageBox = HasTimeDelay then
if IsMessageBox then
Container.RemoveElement('TNAM')
else begin
if not Container.ElementExists['DNAM'] then
Container.Add('DNAM', True);
Container.ElementNativeValues['DNAM'] := Integer(Container.ElementNativeValues['DNAM']) or 1;
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbLIGHAfterLoad(const aElement: IwbElement);
var
Container: IwbContainerElementRef;
MainRecord : IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if not Container.ElementExists['FNAM'] then begin
Container.Add('FNAM', True);
Container.ElementNativeValues['FNAM'] := 1.0;
end;
if Container.ElementExists['DATA'] then begin
if SameValue(Container.ElementNativeValues['DATA\Falloff Exponent'], 0.0) then
Container.ElementNativeValues['DATA\Falloff Exponent'] := 1.0;
if SameValue(Container.ElementNativeValues['DATA\FOV'], 0.0) then
Container.ElementNativeValues['DATA\FOV'] := 90.0;
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbEFITAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
Element : IwbElement;
ActorValue: Variant;
MainRecord: IwbMainRecord;
begin
if wbBeginInternalEdit then try
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
MainRecord := Container.ContainingMainRecord;
if not Assigned(MainRecord) or MainRecord.IsDeleted then
Exit;
Element := Container.ElementByPath['..\EFID'];
if not Assigned(Element) then
Exit;
if not Supports(Element.LinksTo, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.Signature <> 'MGEF' then
Exit;
ActorValue := MainRecord.ElementNativeValues['DATA - Data\Actor Value'];
if VarIsNull(ActorValue) or VarIsClear(ActorValue) then
Exit;
if VarCompareValue(ActorValue, Container.ElementNativeValues['Actor Value']) <> vrEqual then
Container.ElementNativeValues['Actor Value'] := ActorValue;
finally
wbEndInternalEdit;
end;
end;
procedure wbRPLDAfterLoad(const aElement: IwbElement);
var
Container: IwbContainer;
a, b: Single;
NeedsFlip: Boolean;
begin
if wbBeginInternalEdit then try
if Supports(aElement, IwbContainer, Container) then begin
NeedsFlip := False;
if Container.ElementCount > 1 then begin
a := StrToFloat((Container.Elements[0] as IwbContainer).Elements[0].Value);
b := StrToFloat((Container.Elements[Pred(Container.ElementCount)] as IwbContainer).Elements[0].Value);
case CompareValue(a, b) of
EqualsValue: begin
a := StrToFloat((Container.Elements[0] as IwbContainer).Elements[1].Value);
b := StrToFloat((Container.Elements[Pred(Container.ElementCount)] as IwbContainer).Elements[1].Value);
NeedsFlip := CompareValue(a, b) = GreaterThanValue;
end;
GreaterThanValue:
NeedsFlip := True;
end;
end;
if NeedsFlip then
Container.ReverseElements;
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbLLEAfterLoad(const aElement: IwbElement);
var
Container : IwbContainerElementRef;
Entries : IwbContainerElementRef;
MainRecord : IwbMainRecord;
i : integer;
begin
if wbBeginInternalEdit then try
// zero entries' Chance None if Form Version < 69
if wbFormVerDecider(nil, nil, aElement, 69) = 1 then
Exit;
if not Supports(aElement, IwbContainerElementRef, Container) then
Exit;
if Container.ElementCount < 1 then
Exit;
if not Supports(aElement, IwbMainRecord, MainRecord) then
Exit;
if MainRecord.IsDeleted then
Exit;
if not Supports(MainRecord.ElementByName['Leveled List Entries'], IwbContainerElementRef, Entries) then
Exit;
for i := 0 to Pred(Entries.ElementCount) do begin
if not Supports(Entries.Elements[i], IwbContainerElementRef, Container) then
Exit;
Container.ElementNativeValues['LVLO\Chance None'] := 0;
end;
finally
wbEndInternalEdit;
end;
end;
function wbPubPackCNAMDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
rANAM: IwbRecord;
ctype: string;
begin
Result := 0;
rANAM := aElement.Container.RecordBySignature[ANAM];
if Assigned(rANAM) then begin
ctype := rANAM.NativeValue;
if ctype = 'Bool' then Result := 1 else
if ctype = 'Int' then Result := 2 else
if ctype = 'Float' then Result := 3 else
if ctype = 'ObjectList' then Result := 3;
end;
end;
function wbTypeDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
Element : IwbElement;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Element := Container.ElementByName['Type'];
if Assigned(Element) then
Result := Element.NativeValue
else if wbMoreInfoForDecider then
wbProgressCallback('"'+Container.Name+'" does not contain an element named Type');
end;
procedure wbCNTOsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('COCT - Count', aElement);
end;
procedure wbContainerAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterContainerAfterSet('COCT - Count', 'Items', aElement);
wbCounterContainerAfterSet('KSIZ - Keyword Count', 'KWDA - Keywords', aElement);
end;
procedure wbSPLOsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('SPCT - Count', aElement);
end;
procedure wbKWDAsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('KSIZ - Keyword Count', aElement);
end;
procedure wbNPCAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterContainerAfterSet('COCT - Count', 'Items', aElement);
wbCounterContainerAfterSet('SPCT - Count', 'Actor Effects', aElement);
wbCounterContainerAfterSet('LLCT - Count', 'Leveled List Entries', aElement);
wbCounterContainerAfterSet('KSIZ - Keyword Count', 'KWDA - Keywords', aElement);
wbCounterContainerAfterSet('PRKZ - Perk Count', 'Perks', aElement);
end;
procedure wbRaceAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterContainerAfterSet('SPCT - Count', 'Actor Effects', aElement);
wbCounterContainerAfterSet('KSIZ - Keyword Count', 'KWDA - Keywords', aElement);
end;
procedure wbKeywordsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterContainerAfterSet('KSIZ - Keyword Count', 'KWDA - Keywords', aElement);
end;
procedure wbLVLOsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('LLCT - Count', aElement);
end;
procedure wbLLEAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterContainerAfterSet('LLCT - Count', 'Leveled List Entries', aElement);
end;
procedure wbPRKRsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('PRKZ - Perk Count', aElement);
end;
procedure wbSMQNQuestsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('QNAM - Quest Count', aElement);
end;
procedure wbCTDAsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('CITC - Condition Count', aElement);
end;
procedure wbConditionsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterContainerAfterSet('CITC - Condition Count', 'Conditions', aElement);
end;
procedure wbCounterEffectsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
// if it is really possible to have both counter effects and multiple data, this is going to be tricky.
wbCounterByPathAfterSet('Magic Effect Data\DATA - Data\Counter effect count', aElement);
end;
procedure wbMGEFAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbKeywordsAfterSet(aElement, aOldValue, aNewValue);
wbCounterContainerByPathAfterSet('Magic Effect Data\DATA - Data\Counter effect count', 'Counter Effects', aElement);
end;
procedure wbTERMDisplayItemsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('BSIZ - Count', aElement);
end;
procedure wbTERMMenuItemsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('ISIZ - Count', aElement);
end;
procedure wbSNDRRatesOfFireAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('ITMC - Count', aElement);
end;
procedure wbNPCActorSoundsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('CS2H - Count', aElement);
end;
procedure wbMorphPresetsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('MPPC - Count', aElement);
end;
procedure wbLENSAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('LFSP - Count', aElement);
end;
procedure wbIDLAsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Element : IwbElement;
Container : IwbContainer;
SelfAsContainer : IwbContainer;
begin
if wbBeginInternalEdit then try
if not wbCounterAfterSet('IDLC - Animation Count', aElement) then
if Supports(aElement.Container, IwbContainer, Container) then begin
Element := Container.ElementByPath['IDLC'];
if Assigned(Element) and Supports(aElement, IwbContainer, SelfAsContainer) and
(Element.GetNativeValue<>SelfAsContainer.GetElementCount) then
Element.SetNativeValue(SelfAsContainer.GetElementCount);
end;
finally
wbEndInternalEdit;
end;
end;
procedure wbAnimationsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Element : IwbElement;
Elems : IwbElement;
Container : IwbContainer;
begin
if wbBeginInternalEdit then try
if not wbCounterContainerAfterSet('IDLC - Animation Count', 'IDLA - Animations', aElement) then
if Supports(aElement, IwbContainer, Container) then begin
Element := Container.ElementByPath['IDLC\Animation Count'];
Elems := Container.ElementByName['IDLA - Animations'];
if Assigned(Element) and not Assigned(Elems) then
if Element.GetNativeValue<>0 then
Element.SetNativeValue(0);
end;
finally
wbEndInternalEdit;
end;
end;
function wbOffsetDataColsCounter(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Cardinal;
var
Container : IwbDataContainer;
Element : IwbElement;
fResult : Extended;
begin
Result := 0;
if Supports(aElement.Container, IwbDataContainer, Container) and (Container.Name = 'OFST - Offset Data') and
Supports(Container.Container, IwbDataContainer, Container) then begin
Element := Container.ElementByPath['Object Bounds\NAM0 - Min\X'];
if Assigned(Element) then begin
fResult := Element.NativeValue;
if fResult >= MaxInt then
Result := 0
else
Result := Trunc(fResult);
Element := Container.ElementByPath['Object Bounds\NAM9 - Max\X'];
if Assigned(Element) then begin
fResult := Element.NativeValue;
if fResult >= MaxInt then
Result := 1
else
Result := Trunc(fResult) - Result + 1;
end;
end;
end;
end;
procedure wbOMODpropertyAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('Property Count', aElement);
end;
procedure wbOMODincludeAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('Include Count', aElement);
end;
procedure wbOMODdataAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterContainerAfterSet('Property Count', 'Properties', aElement);
wbCounterContainerAfterSet('Include Count', 'Includes', aElement);
end;
function wbOMODDataIncludeCounter(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Cardinal;
var
Container : IwbContainer;
begin
if Supports(aElement.Container, IwbContainer, Container) then
Result := Container.ElementNativeValues['Include Count']
else
Result := 0;
end;
function wbOMODDataPropertyCounter(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Cardinal;
var
Container : IwbContainer;
begin
if Supports(aElement.Container, IwbContainer, Container) then
Result := Container.ElementNativeValues['Property Count']
else
Result := 0;
end;
function GetObjectModPropertyEnum(const aElement: IwbElement): IwbEnumDef;
var
MainRecord: IwbMainRecord;
rDATA: IwbContainer;
Signature: TwbSignature;
FormType: Cardinal;
begin
Result := nil;
MainRecord := aElement.ContainingMainRecord;
if not Assigned(MainRecord) then
Exit;
Signature := MainRecord.Signature;
if Signature = OMOD then
if Supports(MainRecord.ElementBySignature['DATA'], IwbContainer, rDATA) then begin
FormType := rDATA.ElementNativeValues['Form Type'];
Signature := PwbSignature(@FormType)^;
end;
if Signature = ARMO then
Result := wbArmorPropertyEnum
else if Signature = WEAP then
Result := wbWeaponPropertyEnum
else if Signature = NPC_ then
Result := wbActorPropertyEnum;
end;
function wbObjectModPropertyToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
PropEnum: IwbEnumDef;
begin
Result := '';
PropEnum := GetObjectModPropertyEnum(aElement);
if not Assigned(PropEnum) then
case aType of
ctToStr, ctToSortKey, ctToEditValue: Result := IntToStr(aInt);
end
else
case aType of
ctToStr: Result := PropEnum.ToString(aInt, aElement);
ctToSortKey: Result := PropEnum.ToSortKey(aInt, aElement);
ctCheck: Result := PropEnum.Check(aInt, aElement);
ctToEditValue: Result := PropEnum.ToEditValue(aInt, aElement);
ctEditType: Result := 'ComboBox';
ctEditInfo: Result := PropEnum.EditInfo[aInt, aElement];
end;
end;
function wbObjectModPropertyToInt(const aString: string; const aElement: IwbElement): Int64;
var
PropEnum: IwbEnumDef;
begin
PropEnum := GetObjectModPropertyEnum(aElement);
if not Assigned(PropEnum) then
Result := StrToIntDef(aString, 0)
else
Result := PropEnum.FromEditValue(aString, aElement);
end;
function wbOMODDataFunctionTypeDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
ValueType : Integer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
ValueType := Container.ElementNativeValues['Value Type'];
case ValueType of
0: Result := 0;
1: Result := 0;
2: Result := 1;
4: Result := 3;
5: Result := 2;
6: Result := 3;
end;
end;
function wbOMODDataPropertyValue1Decider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
ValueType : Integer;
PropName : string;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
ValueType := Container.ElementNativeValues['Value Type'];
PropName := Container.ElementEditValues['Property'];
case ValueType of
0: Result := 1;
1: Result := 2;
2: Result := 3;
4, 6: Result := 4;
5: begin
if PropName = 'SoundLevel' then Result := 6 else
if PropName = 'StaggerValue' then Result := 7 else
if PropName = 'HitBehaviour' then Result := 8 else
Result := 5;
end;
end;
end;
function wbOMODDataPropertyValue2Decider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container : IwbContainer;
ValueType : Integer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
ValueType := Container.ElementNativeValues['Value Type'];
case ValueType of
0: Result := 1;
1: Result := 2;
2: Result := 3;
4: Result := 1;
6: Result := 2;
end;
end;
procedure wbOBTSCombinationsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('OBTE - Count', aElement);
end;
procedure wbINNRAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('VNAM - Count', aElement);
end;
function wbCELLCombinedMeshesCounter(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Cardinal;
var
Container : IwbContainer;
begin
if Supports(aElement.Container, IwbContainer, Container) then
Result := Container.ElementNativeValues['Meshes Count']
else
Result := 0;
end;
procedure wbCELLCombinedMeshesAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
begin
wbCounterAfterSet('Meshes Count', aElement);
end;
function wbCELLCombinedRefsCounter(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Cardinal;
var
Container : IwbContainer;
begin
// the counter is double of entries (each member of struct is counted)
if Supports(aElement.Container, IwbContainer, Container) then
Result := Container.ElementNativeValues['References Count'] div 2
else
Result := 0;
end;
procedure wbCELLCombinedRefsAfterSet(const aElement: IwbElement; const aOldValue, aNewValue: Variant);
var
Element : IwbElement;
Container : IwbContainer;
SelfAsContainer : IwbContainer;
begin
// the counter is double of entries (each member of struct is counted)
if wbBeginInternalEdit then try
if Supports(aElement.Container, IwbContainer, Container) and
Supports(aElement, IwbContainer, SelfAsContainer) then begin
Element := Container.ElementByName['References Count'];
if Assigned(Element) then try
if (Element.GetNativeValue <> (SelfAsContainer.GetElementCount * 2)) then
Element.SetNativeValue(SelfAsContainer.GetElementCount * 2);
except end;
end;
finally
wbEndInternalEdit;
end;
end;
function wbCombinedMeshIDToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Cell: IwbMainRecord;
begin
Result := IntToHex(aInt, 8);
Cell := aElement.ContainingMainRecord;
if not Assigned(Cell) then
Exit;
case aType of
ctToStr, ctToEditValue: begin
Result := 'Precombined\' + IntToHex(Cell.FormID and $00FFFFFF, 8) + '_' + Result + '_OC.nif';
end;
ctCheck: Result := '';
end;
end;
function wbCombinedMeshIDToInt(const aString: string; const aElement: IwbElement): Int64;
var
s: string;
i: Integer;
begin
Result := 0;
// hex number between first and second underscope
i := Pos('_', aString);
if i <> 0 then begin
s := Copy(aString, i + 1, Length(aString) - i);
i := Pos('_', s);
if i <> 0 then begin
s := Copy(s, 1, i - 1);
if Length(s) = 8 then try
Result := StrToInt64('$' + s);
except end;
end;
end;
end;
function wbREFRRecordFlagsDecider(const aElement: IwbElement): Integer;
var
MainRecord : IwbMainRecord;
NameRec : IwbElement;
begin
Result := 0;
if not Assigned(aElement) then
Exit;
MainRecord := aElement.ContainingMainRecord;
if not Assigned(MainRecord) then
Exit;
NameRec := MainRecord.ElementBySignature[NAME];
if not Assigned(NameRec) then
Exit;
if not Supports(NameRec.LinksTo, IwbMainRecord, MainRecord) then
Exit;
if (MainRecord.Signature = ACTI) or
(MainRecord.Signature = STAT) or
(MainRecord.Signature = SCOL) or
(MainRecord.Signature = TREE)
then
Result := 1
else if
(MainRecord.Signature = CONT) or
(MainRecord.Signature = TERM)
then
Result := 2
else if MainRecord.Signature = DOOR then
Result := 3
else if MainRecord.Signature = LIGH then
Result := 4
else if MainRecord.Signature = MSTT then
Result := 5
else if MainRecord.Signature = ADDN then
Result := 6
else if
(MainRecord.Signature = SCRL) or
(MainRecord.Signature = AMMO) or
(MainRecord.Signature = ARMO) or
(MainRecord.Signature = BOOK) or
(MainRecord.Signature = INGR) or
(MainRecord.Signature = KEYM) or
(MainRecord.Signature = MISC) or
(MainRecord.Signature = FURN) or
(MainRecord.Signature = WEAP) or
(MainRecord.Signature = ALCH)
then
Result := 7;
end;
function wbByteColors(const aName: string = 'Color'): IwbStructDef;
begin
Result := wbStruct(aName, [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unused', 1)
]);
end;
function wbFloatColors(const aName: string = 'Color'): IwbStructDef;
begin
Result := wbStruct(aName, [
wbFloat('Red', cpNormal, True, 255, 0),
wbFloat('Green', cpNormal, True, 255, 0),
wbFloat('Blue', cpNormal, True, 255, 0)
]);
end;
function wbWeatherColors(const aName: string): IwbStructDef;
begin
Result := wbStruct(aName, [
wbByteColors('Sunrise'),
wbByteColors('Day'),
wbByteColors('Sunset'),
wbByteColors('Night'),
wbByteColors('EarlySunrise'),
wbByteColors('LateSunrise'),
wbByteColors('EarlySunset'),
wbByteColors('LateSunset')
], cpNormal, True, nil, 4);
end;
function wbAmbientColors(const aSignature: TwbSignature; const aName: string = 'Directional Ambient Lighting Colors'): IwbSubRecordDef; overload;
begin
Result := wbStruct(aSignature, aName, [
wbStruct('Directional', [
wbByteColors('X+'),
wbByteColors('X-'),
wbByteColors('Y+'),
wbByteColors('Y-'),
wbByteColors('Z+'),
wbByteColors('Z-')
]),
wbByteColors('Specular'),
wbFloat('Scale')
])
end;
function wbAmbientColors(const aName: string = 'Directional Ambient Lighting Colors'): IwbStructDef; overload;
begin
Result := wbStruct(aName, [
wbStruct('Directional', [
wbByteColors('X+'),
wbByteColors('X-'),
wbByteColors('Y+'),
wbByteColors('Y-'),
wbByteColors('Z+'),
wbByteColors('Z-')
]),
wbByteColors('Specular'),
wbFloat('Scale', cpIgnore)
]);
end;
function wbIntToHexStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
case aType of
ctToStr, ctToSortKey, ctToEditValue: Result := IntToHex(aInt, 8);
else
Result := '';
end;
end;
function wbStrToInt(const aString: string; const aElement: IwbElement): Int64;
var
s: string;
i: integer;
begin
// ignore anything after space or :
i := Pos(' ', aString);
if i = 0 then
i := Pos(':', aString);
if i <> 0 then
s := Copy(aString, 1, i - 1)
else
s := aString;
try
Result := StrToInt64(s)
except
Result := 0;
end;
end;
function wbHexStrToInt(const aString: string; const aElement: IwbElement): Int64;
var
s: string;
i: integer;
begin
// ignore anything after space or :
i := Pos(' ', aString);
if i = 0 then
i := Pos(':', aString);
if i <> 0 then
s := Copy(aString, 1, i - 1)
else
s := aString;
try
Result := StrToInt64('$' + s)
except
Result := 0;
end;
end;
type
TFaceGenFeature = record
RaceID : String;
Female : Boolean;
Entries : array of record
Index: Cardinal;
Name : String;
end;
end;
PFaceGenFeature = ^TFaceGenFeature;
var
// cache of race specific face morphs
FaceMorphs: array of TFaceGenFeature;
// cache of race specific tint layers
TintLayers: array of TFaceGenFeature;
// cache of race specific morph groups/presets and values
MorphValues: array of TFaceGenFeature;
function wbMorphValueToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
function GetCached(const aRaceID: string; aFemale: boolean): PFaceGenFeature;
var
i: integer;
begin
Result := nil;
if Length(MorphValues) <> 0 then
for i := Low(MorphValues) to High(MorphValues) do
if (MorphValues[i].Female = aFemale) and (MorphValues[i].RaceID = aRaceID) then begin
Result := @MorphValues[i];
Break;
end;
end;
var
Actor, Race : IwbMainRecord;
Element : IwbElement;
Container, Entry : IwbContainerElementRef;
Container2, Entry2: IwbContainerElementRef;
Female, Female2 : Boolean;
RaceID, EntryName : string;
Cache : PFaceGenFeature;
Index : Cardinal;
i, j, k : integer;
slList : TStringList;
begin
// defaults
case aType of
ctToStr, ctToEditValue: Result := IntToHex64(aInt, 8);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
Actor := aElement.ContainingMainRecord;
if not Assigned(Actor) then
Exit;
Female := Actor.ElementEditValues['ACBS\Flags\Female'] = '1';
Element := Actor.ElementBySignature['RNAM'];
if not Assigned(Element) then
Exit;
Element := Element.LinksTo;
if not Supports(Element, IwbMainRecord, Race) then
Exit;
Race := Race.WinningOverride;
RaceID := Race.EditorID;
Cache := GetCached(RaceID, Female);
// cache not found, fill with data from RACE
if not Assigned(Cache) then begin
slList := TStringList.Create;
for i := 0 to 1 do begin
Female2 := i = 1;
SetLength(MorphValues, Succ(Length(MorphValues)));
Cache := @MorphValues[Pred(Length(MorphValues))];
Cache.RaceID := RaceID;
Cache.Female := Female2;
slList.Clear;
if not Female2 then
Element := Race.ElementByName['Male Morph Groups']
else
Element := Race.ElementByName['Female Morph Groups'];
// iterate over morph groups
if Supports(Element, IwbContainerElementRef, Container) then
for j := 0 to Pred(Container.ElementCount) do begin
if not Supports(Container.Elements[j], IwbContainerElementRef, Entry) then
Break;
// group name
EntryName := Entry.ElementEditValues['MPGN'];
// iterate over morph group presets
if not Supports(Entry.ElementByName['Morph Presets'], IwbContainerElementRef, Container2) then
Continue;
for k := 0 to Pred(Container2.ElementCount) do
if Supports(Container2.Elements[k], IwbContainerElementRef, Entry2) then
slList.AddObject(
EntryName + ' - ' + Entry2.ElementEditValues['MPPN'],
TObject(Cardinal(Entry2.ElementNativeValues['MPPI']))
);
end;
// append morph values, same for both sexes
if Supports(Race.ElementByName['Morph Values'], IwbContainerElementRef, Container) then
for j := 0 to Pred(Container.ElementCount) do
if Supports(Container.Elements[j], IwbContainerElementRef, Entry) then
slList.AddObject(
Entry.ElementEditValues['MSM0'] + '/' + Entry.ElementEditValues['MSM1'],
TObject(Cardinal(Entry.ElementNativeValues['MSID']))
);
SetLength(Cache.Entries, slList.Count);
for j := 0 to Pred(slList.Count) do begin
Cache.Entries[j].Index := Cardinal(slList.Objects[j]);
Cache.Entries[j].Name := slList[j];
end;
end;
slList.Free;
Cache := GetCached(RaceID, Female);
end;
if not Assigned(Cache) then
Exit;
EntryName := '';
Index := Cardinal(aInt);
if Length(Cache.Entries) <> 0 then
for i := Low(Cache.Entries) to High(Cache.Entries) do
if Cache.Entries[i].Index = Index then begin
EntryName := Cache.Entries[i].Name;
Break;
end;
case aType of
ctToStr: begin
if EntryName <> '' then
Result := IntToHex64(aInt, 8) + ' ' + EntryName
else
Result := IntToHex64(aInt, 8) + ' ';
end;
ctCheck: begin
if EntryName = '' then
Result := ''
else
Result := '';
end;
ctEditType: Result := 'ComboBox';
ctEditInfo: begin
Result := '';
if Length(Cache.Entries) <> 0 then
for i := Low(Cache.Entries) to High(Cache.Entries) do begin
if Result <> '' then Result := Result + ',';
Result := Result + '"' + IntToHex(Cache.Entries[i].Index, 8) + ' ' + Cache.Entries[i].Name + '"';
end;
end;
end;
end;
function wbFaceMorphToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
function GetCached(const aRaceID: string; aFemale: boolean): PFaceGenFeature;
var
i: integer;
begin
Result := nil;
if Length(FaceMorphs) <> 0 then
for i := Low(FaceMorphs) to High(FaceMorphs) do
if (FaceMorphs[i].Female = aFemale) and (FaceMorphs[i].RaceID = aRaceID) then begin
Result := @FaceMorphs[i];
Break;
end;
end;
var
Actor, Race : IwbMainRecord;
Element : IwbElement;
Container, Entry : IwbContainerElementRef;
Female, Female2 : Boolean;
RaceID, EntryName : string;
Cache : PFaceGenFeature;
Index : Cardinal;
i, j : integer;
begin
// defaults
case aType of
ctToStr, ctToEditValue: Result := IntToHex64(aInt, 8);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
Actor := aElement.ContainingMainRecord;
if not Assigned(Actor) then
Exit;
Female := Actor.ElementEditValues['ACBS\Flags\Female'] = '1';
Element := Actor.ElementBySignature['RNAM'];
if not Assigned(Element) then
Exit;
Element := Element.LinksTo;
if not Supports(Element, IwbMainRecord, Race) then
Exit;
Race := Race.WinningOverride;
RaceID := Race.EditorID;
Cache := GetCached(RaceID, Female);
// cache not found, fill with data from RACE
if not Assigned(Cache) then begin
for i := 0 to 1 do begin
Female2 := i = 1;
SetLength(FaceMorphs, Succ(Length(FaceMorphs)));
Cache := @FaceMorphs[Pred(Length(FaceMorphs))];
Cache.RaceID := RaceID;
Cache.Female := Female2;
if not Female2 then
Element := Race.ElementByName['Male Face Morphs']
else
Element := Race.ElementByName['Female Face Morphs'];
if not Supports(Element, IwbContainerElementRef, Container) then
Continue;
SetLength(Cache.Entries, Container.ElementCount);
for j := 0 to Pred(Container.ElementCount) do begin
if not Supports(Container.Elements[j], IwbContainerElementRef, Entry) then
Break;
Cache.Entries[j].Index := Entry.ElementNativeValues['FMRI'];
Cache.Entries[j].Name := Entry.ElementEditValues['FMRN'];
end;
end;
Cache := GetCached(RaceID, Female);
end;
if not Assigned(Cache) then
Exit;
EntryName := '';
Index := Cardinal(aInt);
if Length(Cache.Entries) <> 0 then
for i := Low(Cache.Entries) to High(Cache.Entries) do
if Cache.Entries[i].Index = Index then begin
EntryName := Cache.Entries[i].Name;
Break;
end;
case aType of
ctToStr: begin
if EntryName <> '' then
Result := IntToHex64(aInt, 8) + ' ' + EntryName
else
Result := IntToHex64(aInt, 8) + ' ';
end;
ctCheck: begin
if EntryName = '' then
Result := ''
else
Result := '';
end;
ctEditType: Result := 'ComboBox';
ctEditInfo: begin
Result := '';
if Length(Cache.Entries) <> 0 then
for i := Low(Cache.Entries) to High(Cache.Entries) do begin
if Result <> '' then Result := Result + ',';
Result := Result + '"' + IntToHex(Cache.Entries[i].Index, 8) + ' ' + Cache.Entries[i].Name + '"';
end;
end;
end;
end;
function wbTintLayerToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
function GetCached(const aRaceID: string; aFemale: boolean): PFaceGenFeature;
var
i: integer;
begin
Result := nil;
if Length(TintLayers) <> 0 then
for i := Low(TintLayers) to High(TintLayers) do
if (TintLayers[i].Female = aFemale) and (TintLayers[i].RaceID = aRaceID) then begin
Result := @TintLayers[i];
Break;
end;
end;
var
Actor, Race : IwbMainRecord;
Element : IwbElement;
Container, Entry : IwbContainerElementRef;
Container2, Entry2: IwbContainerElementRef;
Female, Female2 : Boolean;
RaceID, EntryName : string;
Cache : PFaceGenFeature;
Index : Cardinal;
i, j, k : integer;
slList : TStringList;
begin
// defaults
case aType of
ctToStr, ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '';
ctEditType: Result := '';
ctEditInfo: Result := '';
end;
Actor := aElement.ContainingMainRecord;
if not Assigned(Actor) then
Exit;
Female := Actor.ElementEditValues['ACBS\Flags\Female'] = '1';
Element := Actor.ElementBySignature['RNAM'];
if not Assigned(Element) then
Exit;
Element := Element.LinksTo;
if not Supports(Element, IwbMainRecord, Race) then
Exit;
Race := Race.WinningOverride;
RaceID := Race.EditorID;
Cache := GetCached(RaceID, Female);
// cache not found, fill with data from RACE
if not Assigned(Cache) then begin
slList := TStringList.Create;
for i := 0 to 1 do begin
Female2 := i = 1;
SetLength(TintLayers, Succ(Length(TintLayers)));
Cache := @TintLayers[Pred(Length(TintLayers))];
Cache.RaceID := RaceID;
Cache.Female := Female2;
if not Female2 then
Element := Race.ElementByName['Male Tint Layers']
else
Element := Race.ElementByName['Female Tint Layers'];
if not Supports(Element, IwbContainerElementRef, Container) then
Continue;
slList.Clear;
// iterate over tint groups
for j := 0 to Pred(Container.ElementCount) do
if Supports(Container.Elements[j], IwbContainerElementRef, Entry) then
// iterate over tint group options
if Supports(Entry.ElementByName['Options'], IwbContainerElementRef, Container2) then
for k := 0 to Pred(Container2.ElementCount) do
if Supports(Container2.Elements[k], IwbContainerElementRef, Entry2) then
slList.AddObject(
Entry.ElementEditValues['TTGP'] + ' - ' + Entry2.ElementEditValues['TTGP'],
TObject(Cardinal(Entry2.ElementNativeValues['TETI\Index']))
);
SetLength(Cache.Entries, slList.Count);
for j := 0 to Pred(slList.Count) do begin
Cache.Entries[j].Index := Cardinal(slList.Objects[j]);
Cache.Entries[j].Name := slList[j];
end;
end;
slList.Free;
Cache := GetCached(RaceID, Female);
end;
if not Assigned(Cache) then
Exit;
EntryName := '';
Index := Cardinal(aInt);
if Length(Cache.Entries) <> 0 then
for i := Low(Cache.Entries) to High(Cache.Entries) do
if Cache.Entries[i].Index = Index then begin
EntryName := Cache.Entries[i].Name;
Break;
end;
case aType of
ctToStr: begin
if EntryName <> '' then
Result := IntToStr(aInt) + ' ' + EntryName
else
Result := IntToStr(aInt) + ' ';
end;
ctCheck: begin
if EntryName = '' then
Result := ''
else
Result := '';
end;
ctEditType: Result := 'ComboBox';
ctEditInfo: begin
Result := '';
if Length(Cache.Entries) <> 0 then
for i := Low(Cache.Entries) to High(Cache.Entries) do begin
if Result <> '' then Result := Result + ',';
Result := Result + '"' + IntToStr(Cache.Entries[i].Index) + ' ' + Cache.Entries[i].Name + '"';
end;
end;
end;
end;
var
wbRecordFlagsFlags : IwbFlagsDef;
procedure DefineFO4a;
begin
wbNull := wbByteArray('Unused', -255);
wbBoolEnum := wbEnum(['False', 'True']);
wbLLCT := wbInteger(LLCT, 'Count', itU8, nil, cpBenign);
wbCITC := wbInteger(CITC, 'Condition Count', itU32, nil, cpBenign);
wbLVLD := wbInteger(LVLD, 'Chance None', itU8, nil, cpNormal, True);
wbSPCT := wbInteger(SPCT, 'Count', itU32, nil, cpBenign);
wbSPLO := wbFormIDCk(SPLO, 'Actor Effect', [SPEL, LVSP]);
wbSPLOs := wbRArrayS('Actor Effects', wbSPLO, cpNormal, False, nil, wbSPLOsAfterSet, nil{wbActorTemplateUseActorEffectList});
wbKSIZ := wbInteger(KSIZ, 'Keyword Count', itU32, nil, cpBenign);
wbKWDAs := wbArrayS(KWDA, 'Keywords', wbFormIDCk('Keyword', [KYWD, NULL]), 0, cpNormal, False, nil, wbKWDAsAfterSet);
wbReqKWDAs := wbArrayS(KWDA, 'Keywords', wbFormIDCk('Keyword', [KYWD, NULL]), 0, cpNormal, True, nil, wbKWDAsAfterSet);
wbKeywords := wbRStruct('Keywords', [
wbKSIZ,
wbReqKWDAs
], []);
//wbActorValue := wbInteger('Actor Value', itS32, wbActorValueEnum);
wbActorValue := wbFormIDCkNoReach('Actor Value', [AVIF, NULL]);
wbCOED := wbStructExSK(COED, [2], [0, 1], 'Extra Data', [
{00} wbFormIDCkNoReach('Owner', [NPC_, FACT, NULL]),
{04} wbUnion('Global Variable / Required Rank', wbCOEDOwnerDecider, [
wbByteArray('Unused', 4, cpIgnore),
wbFormIDCk('Global Variable', [GLOB, NULL]),
wbInteger('Required Rank', itS32)
]),
{08} wbFloat('Item Condition')
]);
wbCNTO :=
wbRStructExSK([0], [1], 'Item', [
wbStructExSK(CNTO, [0], [1], 'Item', [
wbFormIDCk('Item', sigBaseObjects),
wbInteger('Count', itS32)
]),
wbCOED
], []);
wbCOCT := wbInteger(COCT, 'Count', itU32, nil, cpBenign);
wbCNTOs := wbRArrayS('Items', wbCNTO, cpNormal, False, nil, wbCNTOsAfterSet);
{>>> When NAME is user defined these will be incorrect <<<}
wbBipedObjectEnum := wbEnum([
'30 - Hair Top',
'31 - Hair Long',
'32 - FaceGen Head',
'33 - BODY',
'34 - L Hand',
'35 - R Hand',
'36 - [U] Torso',
'37 - [U] L Arm',
'38 - [U] R Arm',
'39 - [U] L Leg',
'40 - [U] R Leg',
'41 - [A] Torso',
'42 - [A] L Arm',
'43 - [A] R Arm',
'44 - [A] L Leg',
'45 - [A] R Leg',
'46 - Headband',
'47 - Eyes',
'48 - Beard',
'49 - Mouth',
'50 - Neck',
'51 - Ring',
'52 - Scalp',
'53 - Decapitation',
'54 - Unnamed',
'55 - Unnamed',
'56 - Unnamed',
'57 - Unnamed',
'58 - Unnamed',
'59 - Shield',
'60 - Pipboy',
'61 - FX'
], [
-1, 'None'
]);
wbBipedObjectFlags := wbFlags([
{0x00000001} '30 - Hair Top',
{0x00000002} '31 - Hair Long',
{0x00000004} '32 - FaceGen Head',
{0x00000008} '33 - BODY',
{0x00000010} '34 - L Hand',
{0x00000020} '35 - R Hand',
{0x00000040} '36 - [U] Torso',
{0x00000080} '37 - [U] L Arm',
{0x00000100} '38 - [U] R Arm',
{0x00000200} '39 - [U] L Leg',
{0x00000400} '40 - [U] R Leg',
{0x00000800} '41 - [A] Torso',
{0x00001000} '42 - [A] L Arm',
{0x00002000} '43 - [A] R Arm',
{0x00004000} '44 - [A] L Leg',
{0x00008000} '45 - [A] R Leg',
{0x00010000} '46 - Headband',
{0x00020000} '47 - Eyes',
{0x00040000} '48 - Beard',
{0x00080000} '49 - Mouth',
{0x00100000} '50 - Neck',
{0x00200000} '51 - Ring',
{0x00400000} '52 - Scalp',
{0x00800000} '53 - Decapitation',
{0x01000000} '54 - Unnamed',
{0x02000000} '55 - Unnamed',
{0x04000000} '56 - Unnamed',
{0x08000000} '57 - Unnamed',
{0x10000000} '58 - Unnamed',
{0x20000000} '59 - Shield',
{0x40000000} '60 - Pipboy',
{0x80000000} '61 - FX'
], True);
wbFirstPersonFlagsU32 := wbInteger('First Person Flags', itU32, wbBipedObjectFlags);
wbBOD2 := wbStruct(BOD2, 'Biped Body Template', [
wbFirstPersonFlagsU32
], cpNormal, False);
wbMDOB := wbFormID(MDOB, 'Menu Display Object', cpNormal, False);
wbCNAM := wbStruct(CNAM, 'Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unknown', 1)
]);
wbDODT := wbStruct(DODT, 'Decal Data', [
wbFloat('Min Width'),
wbFloat('Max Width'),
wbFloat('Min Height'),
wbFloat('Max Height'),
wbFloat('Depth'),
wbFloat('Shininess'),
wbStruct('Parallax', [
wbFloat('Scale'),
wbInteger('Passes', itU8) {>>> This can't be higher than 30 <<<}
]),
wbInteger('Flags', itU8, wbFlags([
{0x01} 'POM Shadows',
{0x02} 'Alpha - Blending',
{0x04} 'Alpha - Testing',
{0x08} 'No Subtextures'
], True)),
wbInteger('Alpha Threshold?', itU16),
wbByteColors('Color')
]);
// wbRecordFlagsFlags := wbFlags([
// {>>> 0x00000000 ACTI: Collision Geometry (default) <<<}
// {0x00000001}'ESM',
// {0x00000002}'Unknown 2',
// {>>> 0x00000004 ARMO: Not playable <<<}
// {0x00000004}'NotPlayable',
// {0x00000008}'Unknown 4',
// {0x00000010}'Unknown 5',
// {0x00000020}'Deleted',
// {>>> 0x00000040 ACTI: Has Tree LOD <<<}
// {>>> 0x00000040 REGN: Border Region <<<}
// {>>> 0x00000040 STAT: Has Tree LOD <<<}
// {>>> 0x00000040 REFR: Hidden From Local Map <<<}
// {0x00000040}'Constant HiddenFromLocalMap BorderRegion HasTreeLOD',
// {>>> 0x00000080 TES4: Localized <<<}
// {>>> 0x00000080 PHZD: Turn Off Fire <<<}
// {>>> 0x00000080 SHOU: Treat Spells as Powers <<<}
// {>>> 0x00000080 STAT: Add-on LOD Object <<<}
// {0x00000080}'Localized IsPerch AddOnLODObject TurnOffFire TreatSpellsAsPowers',
// {>>> 0x00000100 ACTI: Must Update Anims <<<}
// {>>> 0x00000100 REFR: Inaccessible <<<}
// {>>> 0x00000100 REFR for LIGH: Doesn't light water <<<}
// {0x00000100}'MustUpdateAnims Inaccessible DoesntLightWater',
// {>>> 0x00000200 ACTI: Local Map - Turns Flag Off, therefore it is Hidden <<<}
// {>>> 0x00000200 REFR: MotionBlurCastsShadows <<<}
// {0x00000200}'HiddenFromLocalMap StartsDead MotionBlurCastsShadows',
// {>>> 0x00000400 LSCR: Displays in Main Menu <<<}
// {0x00000400}'PersistentReference QuestItem DisplaysInMainMenu',
// {0x00000800}'InitiallyDisabled',
// {0x00001000}'Ignored',
// {0x00002000}'ActorChanged',
// {0x00004000}'Unknown 15',
// {>>> 0x00008000 STAT: Has Distant LOD <<<}
// {0x00008000}'VWD',
// {>>> 0x00010000 ACTI: Random Animation Start <<<}
// {>>> 0x00010000 REFR light: Never fades <<<}
// {0x00010000}'RandomAnimationStart NeverFades',
// {>>> 0x00020000 ACTI: Dangerous <<<}
// {>>> 0x00020000 REFR light: Doesn't light landscape <<<}
// {>>> 0x00020000 SLGM: Can hold NPC's soul <<<}
// {>>> 0x00020000 STAT: Use High-Detail LOD Texture <<<}
// {0x00020000}'Dangerous OffLimits DoesntLightLandscape HighDetailLOD CanHoldNPC',
// {0x00040000}'Compressed',
// {>>> 0x00080000 STAT: Has Currents <<<}
// {0x00080000}'CantWait HasCurrents',
// {>>> 0x00100000 ACTI: Ignore Object Interaction <<<}
// {0x00100000}'IgnoreObjectInteraction',
// {0x00200000}'(Used in Memory Changed Form)',
// {0x00400000}'Unknown 23',
// {>>> 0x00800000 ACTI: Is Marker <<<}
// {0x00800000}'IsMarker',
// {0x01000000}'Unknown 25',
// {>>> 0x02000000 ACTI: Obstacle <<<}
// {>>> 0x02000000 REFR: No AI Acquire <<<}
// {0x02000000}'Obstacle NoAIAcquire',
// {>>> 0x04000000 ACTI: Filter <<<}
// {0x04000000}'NavMeshFilter',
// {>>> 0x08000000 ACTI: Bounding Box <<<}
// {0x08000000}'NavMeshBoundingBox',
// {>>> 0x10000000 STAT: Show in World Map <<<}
// {0x10000000}'MustExitToTalk ShowInWorldMap',
// {>>> 0x20000000 ACTI: Child Can Use <<<}
// {>>> 0x20000000 REFR: Don't Havok Settle <<<}
// {0x20000000}'ChildCanUse DontHavokSettle',
// {>>> 0x40000000 ACTI: GROUND <<<}
// {>>> 0x40000000 REFR: NoRespawn <<<}
// {0x40000000}'NavMeshGround NoRespawn',
// {>>> 0x80000000 REFR: MultiBound <<<}
// {0x80000000}'MultiBound'
// ], [18]);
wbRecordFlagsFlags := wbFlags(wbRecordFlagsFlags, [
{0x00000001} { 0} 'Unknown 0',
{0x00000002} { 1} 'Unknown 1',
{0x00000004} { 2} 'Unknown 2',
{0x00000008} { 3} 'Unknown 3',
{0x00000010} { 4} 'Unknown 4',
{0x00000020} { 4} 'Unknown 5',
{0x00000040} { 6} 'Unknown 6',
{0x00000080} { 7} 'Unknown 7',
{0x00000100} { 8} 'Unknown 8',
{0x00000200} { 9} 'Unknown 9',
{0x00000400} {10} 'Unknown 10',
{0x00000800} {11} 'Unknown 11',
{0x00001000} {12} 'Unknown 12',
{0x00002000} {13} 'Unknown 13',
{0x00004000} {14} 'Unknown 14',
{0x00008000} {15} 'Unknown 15',
{0x00010000} {16} 'Unknown 16',
{0x00020000} {17} 'Unknown 17',
{0x00040000} {18} 'Unknown 18',
{0x00080000} {19} 'Unknown 19',
{0x00100000} {20} 'Unknown 20',
{0x00200000} {21} 'Unknown 21',
{0x00400000} {22} 'Unknown 22',
{0x00800000} {23} 'Unknown 23',
{0x01000000} {24} 'Unknown 24',
{0x02000000} {25} 'Unknown 25',
{0x04000000} {26} 'Unknown 26',
{0x08000000} {27} 'Unknown 27',
{0x10000000} {28} 'Unknown 28',
{0x20000000} {29} 'Unknown 29',
{0x40000000} {30} 'Unknown 30',
{0x80000000} {31} 'Unknown 31'
]);
wbRecordFlags := wbInteger('Record Flags', itU32, wbFlags(wbRecordFlagsFlags, wbFlagsList([])));
wbMainRecordHeader := wbStruct('Record Header', [
wbString('Signature', 4, cpCritical),
wbInteger('Data Size', itU32, nil, cpIgnore),
wbRecordFlags,
wbFormID('FormID', cpFormID),
wbByteArray('Version Control Info 1', 4, cpIgnore),
wbInteger('Form Version', itU16, nil, cpIgnore),
wbByteArray('Version Control Info 2', 2, cpIgnore)
]);
wbSizeOfMainRecordStruct := 24;
wbIgnoreRecords.Add(XXXX);
wbXRGD := wbByteArray(XRGD, 'Ragdoll Data');
wbXRGB := wbByteArray(XRGB, 'Ragdoll Biped Data');
wbMusicEnum := wbEnum(['Default', 'Public', 'Dungeon']);
wbSoundLevelEnum := wbEnum([
'Loud',
'Normal',
'Silent',
'Very Loud',
'Quiet'
]);
wbEntryPointsEnum := wbEnum([
{ 0} 'Mod Breath Timer',
{ 1} 'Mod My Critical Hit Chance',
{ 2} 'Mod My Critical Hit Damage Mult',
{ 3} 'Mod Mine Explode Chance',
{ 4} 'Mod Incoming Limb Damage',
{ 5} 'Mod Book Actor Value Bonus',
{ 6} 'Mod Recovered Health',
{ 7} 'Set Should Attack',
{ 8} 'Mod Buy Prices',
{ 9} 'Add Leveled List On Death',
{10} 'Set Max Carry Weight',
{11} 'Mod Addiction Chance',
{12} 'Mod Addiction Duration',
{13} 'Mod Positive Chem Duration',
{14} 'Activate',
{15} 'Ignore Running During Detection',
{16} 'Ignore Broken Lock',
{17} 'Mod Enemy Critical Hit Chance',
{18} 'Mod Sneak Attack Mult',
{19} 'Mod Max Placeable Mines',
{20} 'Mod Bow Zoom',
{21} 'Mod Recover Arrow Chance',
{22} 'Mod Exp',
{23} 'Mod Telekinesis Distance',
{24} 'Mod Telekinesis Damage Mult',
{25} 'Mod Telekinesis Damage',
{26} 'Mod Bashing Damage',
{27} 'Mod Power Attack Action Points',
{28} 'Mod Power Attack Damage',
{29} 'Mod Spell Magnitude',
{30} 'Mod Spell Duration',
{31} 'Mod Secondary Value Weight',
{32} 'Mod Armor Weight',
{33} 'Mod Incoming Stagger',
{34} 'Mod Target Stagger',
{35} 'Mod Weapon Attack Damage',
{36} 'Mod Incoming Weapon Damage',
{37} 'Mod Target Damage Resistance',
{38} 'Mod Spell Cost',
{39} 'Mod Percent Blocked',
{40} 'Mod Shield Deflect Arrow Chance',
{41} 'Mod Incoming Spell Magnitude',
{42} 'Mod Incoming Spell Duration',
{43} 'Mod Player Intimidation',
{44} 'Mod Ricochet Chance',
{45} 'Mod Ricochet Damage',
{46} 'Mod Bribe Amount',
{47} 'Mod Detection Light',
{48} 'Mod Detection Movement',
{49} 'Mod Scrap Reward Mult',
{50} 'Set Sweep Attack',
{51} 'Apply Combat Hit Spell',
{52} 'Apply Bashing Spell',
{53} 'Apply Reanimate Spell',
{54} 'Set Boolean Graph Variable',
{55} 'Mod Spell Casting Sound Event',
{56} 'Mod Pickpocket Chance',
{57} 'Mod Detection Sneak Skill',
{58} 'Mod Falling Damage',
{59} 'Mod Lockpick Sweet Spot',
{60} 'Mod Sell Prices',
{61} 'Set Pickpocket Equipped Item',
{62} 'Set Player Gate Lockpick',
{63} 'Set Lockpick Starting Arc',
{64} 'Set Progression Picking',
{65} 'Set Lockpicks Unbreakable',
{66} 'Mod Alchemy Effectiveness',
{67} 'Apply Weapon Swing Spell',
{68} 'Mod Commanded Actor Limit',
{69} 'Apply Sneaking Spell',
{70} 'Mod Player Magic Slowdown',
{71} 'Mod Ward Magicka Absorption Pct',
{72} 'Mod Initial Ingredient Effects Learned',
{73} 'Purify Alchemy Ingredients',
{74} 'Set Filter Activation',
{75} 'Set Dual Cast',
{76} 'Mod Outgoing Explosion Limb Damage',
{77} 'Mod Enchantment Power',
{78} 'Mod Soul Pct Captured to Weapon',
{79} 'Mod VATS Attack Action Points',
{80} 'Mod Reflect Damage Chance',
{81} 'Set Activate Label',
{82} 'Mod Kill Experience',
{83} 'Mod Poison Dose Count',
{84} 'Set Apply Placed Item',
{85} 'Mod Armor Rating',
{86} 'Mod lockpicking crime chance',
{87} 'Mod ingredients harvested',
{88} 'Mod Spell Range (Target Loc.)',
{89} 'Mod Critical Charge Mult on Ricochet',
{90} 'Mod lockpicking key reward chance',
{91} 'Mod Auto Lockpicking Chance',
{92} 'Mod Auto Hacking Chance',
{93} 'Mod Typed Weapon Attack Damage',
{94} 'Mod Typed Incoming Weapon Damage',
{95} 'Mod Charisma Challenge Chance',
{96} 'Mod Sprint AP Drain Rate',
{97} 'Mod Drawn Weapon Weight Speed Effect',
{98} 'Set Player Gate Hacking',
{99} 'Mod Player Explosion Damage',
{100} 'Mod Player Explosion Scale',
{101} 'Set Rads To Health Mult',
{102} 'Mod Actor Scope Stability',
{103} 'Mod Actor Grenade Speed Mult',
{104} 'Mod Explosion Force',
{105} 'Mod VATS Penetration Min Visibility',
{106} 'Mod Rads for Rad Health Max',
{107} 'Mod VATS Player AP On Kill Chance',
{108} 'Set VATS Fill Critical Bar On Hit',
{109} 'Mod VATS Concentrated Fire Chance Bonus',
{110} 'Mod VATS Critical Count',
{111} 'Mod VATS Hold Em Steady Bonus',
{112} 'Mod Typed Spell Magnitude',
{113} 'Mod Typed Incoming Spell Magnitude',
{114} 'Set VATS Gun-Fu Num Targets For Crits',
{115} 'Mod Outgoing Limb Damage',
{116} 'Mod Restore Action Cost Value',
{117} 'Mod VATS Reload Action Points',
{118} 'Mod Incoming Battery Damage',
{119} 'Mod VATS Critical Charge',
{120} 'Mod Exp Location',
{121} 'Mod Exp Speech',
{122} 'Mod VATS Head Shot Chance',
{123} 'Mod VATS Hit Chance',
{124} 'Mod Incoming Explosion Damage',
{125} 'Mod Ammo Health Mult',
{126} 'Mod Hacking Guesses',
{127} 'Mod Terminal Lockout Time',
{128} 'Set Undetectable',
{129} 'Invest In Vendor',
{130} 'Mod Outgoing Limb Bash Damage',
{131} 'Set Run While Over Encumbered',
{132} 'Get Component Radar Distance',
{133} 'Show Grenade Trajectory',
{134} 'Mod Cone-of-fire Mult',
{135} 'Mod VATS Concentrated Fire Damage Mult',
{136} 'Apply Bloody Mess Spell',
{137} 'Mod VATS Critical Fill Chance On Bank',
{138} 'Mod VATS Critical Fill Chance On Use',
{139} 'Set VATS Critical Fill On AP Reward',
{140} 'Set VATS Critical Fill On Stranger',
{141} 'Mod Gun Range Mult',
{142} 'Mod Scope Hold Breath AP Drain Mult',
{143} 'Set Force Decapitate',
{144} 'Mod VATS Shoot Explosive Damage Mult',
{145} 'Mod Scrounger Fill Ammo Chance',
{146} 'Set Can Explode Pants',
{147} 'Set VATS Penetration Full Damage',
{148} 'Mod VATS Gun-Fu 2nd Target Dmg Mult',
{149} 'Mod VATS Gun-Fu 3rd Target Dmg Mult',
{150} 'Mod VATS Gun-Fu 4th+ Target Dmg Mult',
{151} 'Mod VATS Blitz Max Distance',
{152} 'Set VATS Blitz Max Dmg Mult',
{153} 'Mod VATS Blitz Dmg Bonus Dist',
{154} 'Mod Bash Critical Chance',
{155} 'VATS Apply Paralyzing Palm Spell',
{156} 'Null Function'
]);
wbEquipType := wbFlags([
{0x00000001} 'Hand To Hand Melee',
{0x00000002} 'One Hand Sword',
{0x00000004} 'One Hand Dagger',
{0x00000008} 'One Hand Axe',
{0x00000010} 'One Hand Mace',
{0x00000020} 'Two Hand Sword',
{0x00000040} 'Two Hand Axe',
{0x00000080} 'Bow',
{0x00000100} 'Staff',
{0x00000200} 'Gun',
{0x00000400} 'Grenade',
{0x00000800} 'Mine',
{0x00001000} 'Spell',
{0x00002000} 'Shield',
{0x00004000} 'Torch'
], True);
wbEmotionTypeEnum := wbEnum([
{0} 'Neutral',
{1} 'Anger',
{2} 'Disgust',
{3} 'Fear',
{4} 'Sad',
{5} 'Happy',
{6} 'Surprise',
{7} 'Puzzled'
]);
wbFurnitureAnimTypeEnum := wbEnum([
{0} '',
{1} 'Sit',
{2} 'Lay',
{3} '',
{4} 'Lean'
]);
wbFurnitureEntryTypeFlags := wbFlags([
{0x01} 'Front',
{0x02} 'Behind',
{0x04} 'Right',
{0x08} 'Left',
{0x10} 'Up'
]);
wbWardStateEnum := wbEnum([
'None',
'Absorb',
'Break'
]);
wbEventFunctionEnum := wbEnum([
'GetIsID',
'IsInList',
'GetValue',
'HasKeyword',
'GetItemValue'
]);
// Event member names and availability are different depending on event type
// Using generic names for the last 3 of them: Form, Value1, Value2
wbEventMemberEnum := wbEnum([], [
$0000, 'None',
$314F, 'CreatedObject',
$314C, '(Old)Location',
$324C, '(New)Location',
$314B, 'Keyword',
$3146, 'Form',
$3156, 'Value1',
$3256, 'Value2'
]);
wbWeaponAnimTypeEnum := wbEnum([
{0} 'HandToHandMelee',
{1} 'OneHandSword',
{2} 'OneHandDagger',
{3} 'OneHandAxe',
{4} 'OneHandMace',
{5} 'TwoHandSword',
{6} 'TwoHandAxe',
{7} 'Bow',
{8} 'Staff',
{9} 'Crossbow'
]);
wbReverbClassEnum := wbEnum([
'Default',
'Class A',
'Class B',
'Class C',
'Class D',
'Class E'
]);
wbHitBehaviourEnum := wbEnum([
'Normal formula behaviour',
'Dismember only',
'Explode only',
'No dismember/explode'
]);
wbEDID := wbString(EDID, 'Editor ID', 0, cpNormal); // not cpBenign according to Arthmoor
wbFULL := wbLStringKC(FULL, 'Name', 0, cpTranslate);
wbFULLActor := wbLStringKC(FULL, 'Name', 0, cpTranslate, False, nil{wbActorTemplateUseBaseData});
wbFULLReq := wbLStringKC(FULL, 'Name', 0, cpTranslate, True);
wbDESC := wbLStringKC(DESC, 'Description', 0, cpTranslate);
wbDESCReq := wbLStringKC(DESC, 'Description', 0, cpTranslate, True);
wbXSCL := wbFloat(XSCL, 'Scale');
wbOBND := wbStruct(OBND, 'Object Bounds', [
wbInteger('X1', itS16),
wbInteger('Y1', itS16),
wbInteger('Z1', itS16),
wbInteger('X2', itS16),
wbInteger('Y2', itS16),
wbInteger('Z2', itS16)
]);
wbOBNDReq := wbStruct(OBND, 'Object Bounds', [
wbInteger('X1', itS16),
wbInteger('Y1', itS16),
wbInteger('Z1', itS16),
wbInteger('X2', itS16),
wbInteger('Y2', itS16),
wbInteger('Z2', itS16)
], cpNormal, True);
wbPropTypeEnum := wbEnum([
{00} 'None',
{01} 'Object',
{02} 'String',
{03} 'Int32',
{04} 'Float',
{05} 'Bool',
{06} 'Variable',
{07} 'Struct',
{08} '',
{09} '',
{10} '',
{11} 'Array of Object',
{12} 'Array of String',
{13} 'Array of Int32',
{14} 'Array of Float',
{15} 'Array of Bool',
{16} 'Array of Variable',
{17} 'Array of Struct'
]);
wbScriptFlags := wbInteger('Flags', itU8, wbEnum([
{0x00} 'Local',
{0x01} 'Inherited',
{0x02} 'Removed',
{0x03} 'Inherited and Removed'
]));
wbScriptPropertyObject := wbUnion('Object Union', wbScriptObjFormatDecider, [
wbStructSK([1], 'Object v2', [
wbInteger('Unused', itU16, nil, cpIgnore),
wbInteger('Alias', itS16, wbScriptObjectAliasToStr, wbStrToAlias),
wbFormID('FormID')
], [2, 1, 0]),
wbStructSK([1], 'Object v1', [
wbFormID('FormID'),
wbInteger('Alias', itS16, wbScriptObjectAliasToStr, wbStrToAlias),
wbInteger('Unused', itU16, nil, cpIgnore)
])
]);
wbScriptPropertyStruct :=
wbArrayS('Struct', wbStructSK([0], 'Member', [
wbLenString('memberName', 2),
wbInteger('Type', itU8, wbPropTypeEnum, cpNormal, False, nil, wbScriptPropertyTypeAfterSet),
wbInteger('Flags', itU8, wbEnum([
{0x00} '',
{0x01} 'Edited',
{0x02} '',
{0x03} 'Removed'
])),
wbUnion('Value', wbScriptPropertyStructMemberDecider, [
{00} wbNull,
{01} wbScriptPropertyObject,
{02} wbLenString('String', 2),
{03} wbInteger('Int32', itS32),
{04} wbFloat('Float'),
{05} wbInteger('Bool', itU8, wbBoolEnum),
{11} wbArray('Array of Object', wbScriptPropertyObject, -1),
{12} wbArray('Array of String', wbLenString('Element', 2), -1),
{13} wbArray('Array of Int32', wbInteger('Element', itS32), -1),
{14} wbArray('Array of Float', wbFloat('Element'), -1),
{15} wbArray('Array of Bool', wbInteger('Element', itU8, wbBoolEnum), -1)
])
]), -1, cpNormal, False);
wbScriptProperties :=
wbArrayS('Properties', wbStructSK([0], 'Property', [
wbLenString('propertyName', 2),
wbInteger('Type', itU8, wbPropTypeEnum, cpNormal, False, nil, wbScriptPropertyTypeAfterSet),
wbInteger('Flags', itU8, wbEnum([
{0x00} '',
{0x01} 'Edited',
{0x02} '',
{0x03} 'Removed'
])),
wbUnion('Value', wbScriptPropertyDecider, [
{00} wbNull,
{01} wbScriptPropertyObject,
{02} wbLenString('String', 2),
{03} wbInteger('Int32', itS32),
{04} wbFloat('Float'),
{05} wbInteger('Bool', itU8, wbBoolEnum),
{06} wbScriptPropertyStruct, // Variable. No idea if possible or how to decode, leaving like that for the moment
{07} wbScriptPropertyStruct,
{11} wbArray('Array of Object', wbScriptPropertyObject, -1),
{12} wbArray('Array of String', wbLenString('Element', 2), -1),
{13} wbArray('Array of Int32', wbInteger('Element', itS32), -1),
{14} wbArray('Array of Float', wbFloat('Element'), -1),
{15} wbArray('Array of Bool', wbInteger('Element', itU8, wbBoolEnum), -1),
{17} wbArray('Array of Struct', wbScriptPropertyStruct, -1)
])
]), -2, cpNormal, False, nil, nil, nil, False);
wbScriptEntry := wbStructSK([0], 'Script', [
wbLenString('scriptName', 2),
wbScriptFlags,
wbScriptProperties
]);
wbScriptFragmentsInfo := wbStruct('Script Fragments', [
wbInteger('Unknown', itS8),
wbInteger('Flags', itU8, wbFlags([
{1} 'OnBegin',
{2} 'OnEnd'
])),
wbScriptEntry,
wbArray('Fragments', // Do NOT sort, ordered OnBegin, OnEnd
wbStruct('Fragment', [
wbInteger('Unknown', itS8),
wbLenString('scriptName', 2),
wbLenString('fragmentName', 2)
]), [], wbScriptFragmentsInfoCounter)
]);
wbScriptFragmentsPack := wbStruct('Script Fragments', [
wbInteger('Unknown', itS8),
wbInteger('Flags', itU8, wbFlags([
{1} 'OnBegin',
{2} 'OnEnd',
{4} 'OnChange'
])),
wbScriptEntry,
wbArray('Fragments', // Do NOT sort, ordered OnBegin, OnEnd, OnChange
wbStruct('Fragment', [
wbInteger('Unknown', itS8),
wbLenString('scriptName', 2),
wbLenString('fragmentName', 2)
]), [], wbScriptFragmentsPackCounter)
]);
wbScriptFragmentsQuest := wbStruct('Script Fragments', [
wbInteger('Unknown', itS8),
wbInteger('fragmentCount', itU16),
wbLenString('scriptName', 2),
// if scriptName = "" then no Flags and Properties
wbUnion('Script', wbScriptFragmentsEmptyScriptDecider, [
wbStruct('Script Data', [
wbScriptFlags,
wbScriptProperties
]),
// Quest [000179EF]
// Quest [000792CA] "Merchant Dialogue System"
// Quest [00091FE1]
// MQ101KelloggSequence "Kellogg Sequence in Vault 111" [QUST:000D3997]
// DialogueGlowingSeaAtom "Children of the Atom Dialogue" [QUST:0012DB31]
// BoSIdleHandlerQuest [QUST:00157460]
wbNull
]),
wbArrayS('Fragments',
wbStructSK([0, 2], 'Fragment', [
wbInteger('Quest Stage', itU16),
wbInteger('Unknown', itS16),
wbInteger('Quest Stage Index', itS32),
wbInteger('Unknown', itS8),
wbLenString('scriptName', 2),
wbLenString('fragmentName', 2)
]),
wbScriptFragmentsQuestCounter)
]);
wbScriptFragmentsScen := wbStruct('Script Fragments', [
wbInteger('Unknown', itS8),
wbInteger('Flags', itU8, wbFlags([
{1} 'OnBegin',
{2} 'OnEnd'
])),
wbScriptEntry,
wbArray('Fragments', // Do NOT sort, ordered OnBegin, OnEnd
wbStruct('Fragment', [
wbInteger('Unknown', itS8),
wbLenString('scriptName', 2),
wbLenString('fragmentName', 2)
]), [], wbScriptFragmentsSceneCounter),
wbArray('Phase Fragments',
wbStructSK([0, 1], 'Phase Fragment', [
wbInteger('Phase Flag', itU8, wbFlags([
{1} 'OnStart',
{2} 'OnCompletion'
])),
wbInteger('Phase Index', itU8),
wbInteger('Unknown', itS16),
wbInteger('Unknown', itS8),
wbInteger('Unknown', itS8),
wbLenString('scriptName', 2),
wbLenString('fragmentName', 2)
]), -2)
]);
wbScriptFragments := wbStruct('Script Fragments', [
wbInteger('Unknown', itS8),
wbScriptEntry,
wbArrayS('Fragments',
wbStructSK([0], 'Fragment', [
wbInteger('Fragment Index', itU16),
wbInteger('Unknown', itS16),
wbInteger('Unknown', itS8),
wbLenString('scriptName', 2),
wbLenString('fragmentName', 2)
]), -2)
]);
{>>> http://www.uesp.net/wiki/Tes5Mod:Mod_File_Format/VMAD_Field <<<}
wbVMAD := wbStruct(VMAD, 'Virtual Machine Adapter', [
wbInteger('Version', itS16, nil, cpIgnore),
wbInteger('Object Format', itS16, nil, cpIgnore),
wbArrayS('Scripts', wbScriptEntry, -2, cpNormal, False, nil, nil, nil, False)
]);
wbVMADFragmentedPERK := wbStruct(VMAD, 'Virtual Machine Adapter', [
wbInteger('Version', itS16, nil, cpIgnore),
wbInteger('Object Format', itS16, nil, cpIgnore),
wbArrayS('Scripts', wbScriptEntry, -2, cpNormal, False, nil, nil, nil, False),
wbScriptFragments
], cpNormal, False, nil, 3);
wbVMADFragmentedPACK := wbStruct(VMAD, 'Virtual Machine Adapter', [
wbInteger('Version', itS16, nil, cpIgnore),
wbInteger('Object Format', itS16, nil, cpIgnore),
wbArrayS('Scripts', wbScriptEntry, -2, cpNormal, False, nil, nil, nil, False),
wbScriptFragmentsPack
], cpNormal, False, nil, 3);
wbVMADFragmentedQUST := wbStruct(VMAD, 'Virtual Machine Adapter', [
wbInteger('Version', itS16, nil, cpIgnore),
wbInteger('Object Format', itS16, nil, cpIgnore),
wbArrayS('Scripts', wbScriptEntry, -2, cpNormal, False, nil, nil, nil, False),
wbScriptFragmentsQuest,
wbArrayS('Aliases', wbStructSK([0], 'Alias', [
wbScriptPropertyObject,
wbInteger('Version', itS16, nil, cpIgnore),
wbInteger('Object Format', itS16, nil, cpIgnore),
wbArrayS('Alias Scripts', wbScriptEntry, -2)
]), -2)
], cpNormal, False, nil, 3);
wbVMADFragmentedSCEN := wbStruct(VMAD, 'Virtual Machine Adapter', [
wbInteger('Version', itS16, nil, cpIgnore),
wbInteger('Object Format', itS16, nil, cpIgnore),
wbArrayS('Scripts', wbScriptEntry, -2, cpNormal, False, nil, nil, nil, False),
wbScriptFragmentsScen
], cpNormal, False, nil, 3);
wbVMADFragmentedINFO := wbStruct(VMAD, 'Virtual Machine Adapter', [
wbInteger('Version', itS16, nil, cpIgnore),
wbInteger('Object Format', itS16, nil, cpIgnore),
wbArrayS('Scripts', wbScriptEntry, -2, cpNormal, False, nil, nil, nil, False),
wbScriptFragmentsInfo
], cpNormal, False, nil, 3);
wbAttackData := wbRStructSK([1], 'Attack', [
wbStruct(ATKD, 'Attack Data', [
wbFloat('Damage Mult'),
wbFloat('Attack Chance'),
wbFormIDCk('Attack Spell', [SPEL, NULL]),
wbInteger('Attack Flags', itU32, wbFlags([
{0x00000001} 'Ignore Weapon',
{0x00000002} 'Bash Attack',
{0x00000004} 'Power Attack',
{0x00000008} 'Charge Attack',
{0x00000010} 'Rotating Attack',
{0x00000020} 'Continuous Attack',
{0x00000040} 'Unknown 6',
{0x00000080} 'Unknown 7',
{0x00000100} 'Unknown 8',
{0x00000200} 'Unknown 9',
{0x00000400} 'Unknown 10',
{0x00000800} 'Unknown 11',
{0x00001000} 'Unknown 12',
{0x00002000} 'Unknown 13',
{0x00004000} 'Unknown 14',
{0x00008000} 'Unknown 15',
{0x00010000} 'Unknown 16',
{0x00020000} 'Unknown 17',
{0x00040000} 'Unknown 18',
{0x00080000} 'Unknown 19',
{0x00100000} 'Unknown 20',
{0x00200000} 'Unknown 21',
{0x00400000} 'Unknown 22',
{0x00800000} 'Unknown 23',
{0x01000000} 'Unknown 24',
{0x02000000} 'Unknown 25',
{0x04000000} 'Unknown 26',
{0x08000000} 'Unknown 27',
{0x10000000} 'Unknown 28',
{0x20000000} 'Unknown 29',
{0x40000000} 'Unknown 30',
{0x80000000} 'Override Data'
])),
wbFloat('Attack Angle'),
wbFloat('Strike Angle'),
wbFloat('Stagger'),
wbFloat('Knockdown'),
wbFloat('Recovery Time'),
wbFloat('Action Points Mult'),
wbInteger('Stagger Offset', itS32)
]),
wbString(ATKE, 'Attack Event'),
wbFormIDCk(ATKW, 'Weapon Slot', [EQUP]),
wbFormIDCk(ATKS, 'Required Slot', [EQUP]),
wbString(ATKT, 'Description')
], []);
wbLocationEnum := wbEnum([
{0} 'Near reference', // string dump: '%s' in '%s' radius %u
{1} 'In cell', // string dump: In cell '%s'
{2} 'Near package start location', // string dump: Near package start location, radius %u
{3} 'Near editor location', // string dump: Near editor location, radius %u
{4} 'Object ID',
{5} 'Object Type',
{6} 'Near linked reference', // string dump: Near linked reference, radius %u%s%s
{7} 'At package location', // string dump: At package location, radius %u
{8} 'Alias (reference)', // string dump: Alias: %s [item #%u], radius %u
{9} 'Alias (location)', // string dump: Alias: %s, radius %u
{10} 'Target', // string dump:
{11} 'Target (location)', // string dump: Target: %s, radius %u
{12} 'Near self', // Near Self, radius %u
{13} 'Near Editor Location Cell',
{14} 'Alias (ref collection)'
]);
wbObjectTypeEnum := wbEnum([
{ 0} ' NONE',
{ 1} 'Activators',
{ 2} 'Armor',
{ 3} 'Books',
{ 4} 'Containers',
{ 5} 'Doors',
{ 6} 'Ingredients',
{ 7} 'Lights',
{ 8} 'Miscellaneous',
{ 9} 'Flora',
{10} 'Furniture',
{11} 'Weapons: Any',
{12} 'Ammo',
{13} 'Keys',
{14} 'Alchemy',
{15} 'Food',
{16} 'Clothing',
{17} 'All: Wearable',
{18} 'Weapons: NONE',
{19} 'Weapons: Melee',
{20} 'Weapons: Ranged',
{21} 'Spells: Any',
{22} 'Spells: Range Target',
{23} 'Spells: Range Touch',
{24} 'Spells: Range Self',
{25} 'Actors: Any',
{26} 'Furniture: Beds',
{27} 'Furniture: Chairs',
{28} 'Shouts',
{29} 'Headtrack Markers'
]);
wbPLDT := wbStruct(PLDT, 'Location', [
wbInteger('Type', itS32, wbLocationEnum),
wbUnion('Location Value', wbTypeDecider, [
{0} wbFormIDCkNoReach('Reference', sigReferences),
{1} wbFormIDCkNoReach('Cell', [NULL, CELL]),
{2} wbByteArray('Near Package Start Location', 4, cpIgnore),
{3} wbByteArray('Near Editor Location', 4, cpIgnore),
{4} wbFormIDCkNoReach('Object ID', [NULL, ACTI, DOOR, STAT, MSTT, FURN, SPEL, NPC_, CONT, ARMO, AMMO, MISC, WEAP, OMOD, BOOK, NOTE, KEYM, ALCH, INGR, LIGH, FACT, FLST, IDLM, TXST, PROJ]),
{5} wbInteger('Object Type', itU32, wbObjectTypeEnum),
{6} wbFormIDCk('Keyword', [NULL, KYWD]),
{7} wbByteArray('Unused', 4, cpIgnore),
{8} wbInteger('Ref Alias', itS32, wbPackageLocationAliasToStr, wbStrToAlias),
{9} wbInteger('Loc Alias', itS32, wbPackageLocationAliasToStr, wbStrToAlias),
{10} wbInteger('Interrupt Data', itU32),
{11} wbInteger('Packdata Target', itU32),
{12} wbByteArray('Unknown', 4, cpIgnore),
{13} wbByteArray('Unknown', 4),
{14} wbInteger('Ref Collection Alias', itS32, wbPackageLocationAliasToStr, wbStrToAlias)
]),
wbInteger('Radius', itS32),
wbInteger('Collection Index', itU32)
], cpNormal, False, nil, 3);
wbPLVD := wbStruct(PLVD, 'Location', [
wbInteger('Type', itS32, wbLocationEnum),
wbUnion('Location Value', wbTypeDecider, [
{0} wbFormIDCkNoReach('Reference', sigReferences),
{1} wbFormIDCkNoReach('Cell', [NULL, CELL]),
{2} wbByteArray('Near Package Start Location', 4, cpIgnore),
{3} wbByteArray('Near Editor Location', 4, cpIgnore),
{4} wbFormIDCkNoReach('Object ID', [NULL, ACTI, DOOR, STAT, MSTT, FURN, SPEL, NPC_, CONT, ARMO, AMMO, MISC, WEAP, OMOD, BOOK, NOTE, KEYM, ALCH, INGR, LIGH, FACT, FLST, IDLM, TXST, PROJ]),
{5} wbInteger('Object Type', itU32, wbObjectTypeEnum),
{6} wbFormIDCk('Keyword', [NULL, KYWD]),
{7} wbByteArray('Unused', 4, cpIgnore),
{8} wbInteger('Ref Alias', itS32, wbPackageLocationAliasToStr, wbStrToAlias),
{9} wbInteger('Loc Alias', itS32, wbPackageLocationAliasToStr, wbStrToAlias),
{10} wbInteger('Interrupt Data', itU32),
{11} wbInteger('Packdata Target', itU32),
{12} wbByteArray('Unknown', 4, cpIgnore),
{13} wbByteArray('Unknown', 4),
{14} wbInteger('Ref Collection Alias', itS32, wbPackageLocationAliasToStr, wbStrToAlias)
]),
wbInteger('Radius', itS32),
wbInteger('Collection Index', itU32)
], cpNormal, False, nil, 3);
wbTargetData := wbStruct('Target Data', [
wbInteger('Type', itS32, wbEnum([
{0} 'Specific Reference',
{1} 'Object ID',
{2} 'Object Type',
{3} 'Linked Reference',
{4} 'Ref Alias',
{5} 'Interrupt Data',
{6} 'Self',
{7} 'Keyword',
{8} 'Unknown 8'
]), cpNormal, False, nil, nil, 2),
wbUnion('Target', wbTypeDecider, [
{0} wbFormIDCkNoReach('Reference', sigReferences, True),
{1} wbFormIDCkNoReach('Object ID', [NULL, ACTI, DOOR, STAT, MSTT, FURN, SPEL, NPC_, CONT, ARMO, AMMO, MISC, WEAP, OMOD, BOOK, NOTE, KEYM, ALCH, INGR, LIGH, FACT, FLST, IDLM, TXST, PROJ]),
{2} wbInteger('Object Type', itU32, wbObjectTypeEnum),
{3} wbFormIDCk('Keyword', [KYWD, NULL]),
{4} wbInteger('Alias', itS32, wbPackageLocationAliasToStr, wbStrToAlias),
{5} wbInteger('Interrupt Data', itU32),
{6} wbByteArray('Unknown', 4, cpIgnore),
{7} wbFormIDCk('Keyword', [KYWD, NULL]),
{8} wbByteArray('Unknown', 4, cpIgnore)
]),
wbInteger('Count / Distance', itS32)
]);
wbEITM := wbFormIDCk(EITM, 'Object Effect', [ENCH, SPEL]);
wbPosRot :=
wbStruct('Position/Rotation', [
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation', [
wbFloat('X', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Y', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Z', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize)
])
]);
wbDATAPosRot :=
wbStruct(DATA, 'Position/Rotation', [
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation', [
wbFloat('X', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Y', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Z', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize)
])
], cpNormal, True);
wbMODS := wbFormIDCk(MODS, 'Material Swap', [MSWP]);
wbMO2S := wbFormIDCk(MO2S, 'Material Swap', [MSWP]);
wbMO3S := wbFormIDCk(MO3S, 'Material Swap', [MSWP]);
wbMO4S := wbFormIDCk(MO4S, 'Material Swap', [MSWP]);
wbMO5S := wbFormIDCk(MO5S, 'Material Swap', [MSWP]);
wbMODF := wbUnknown(MODF);
wbMO2F := wbUnknown(MO2F);
wbMO3F := wbUnknown(MO3F);
wbMO4F := wbUnknown(MO4F);
wbMO5F := wbUnknown(MO5F);
wbMODC := wbFloat(MODC, 'Color Remapping Index');
wbMO2C := wbFloat(MO2C, 'Color Remapping Index');
wbMO3C := wbFloat(MO3C, 'Color Remapping Index');
wbMO4C := wbFloat(MO4C, 'Color Remapping Index');
wbMO5C := wbFloat(MO5C, 'Color Remapping Index');
wbMODT := wbByteArray(MODT, 'Texture Files Hashes', 0, cpIgnore, false, false, wbNeverShow);
wbDMDT := wbByteArray(DMDT, 'Texture Files Hashes', 0, cpIgnore, false, false, wbNeverShow);
{wbMODT := wbStruct(MODT, 'Texture Files Hashes', [
wbInteger('Number of headers', itU32),
wbInteger('Textures count', itU32),
wbByteArray('Unused', 4),
wbInteger('Unique textures count', itU32),
wbInteger('Materials count', itU32),
wbArray('Hashes', wbStruct('Hash', [
wbByteArray('Flags', 4),
wbString('Type', 4),
wbByteArray('Texture hash', 4)
]))
]);}
wbMODL :=
wbRStructSK([0], 'Model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbMODT,
wbMODS,
wbMODC,
wbMODF
], [], cpNormal, False, nil, True);
wbMODLActor :=
wbRStructSK([0], 'Model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbMODT,
wbMODS
], [], cpNormal, False, nil{wbActorTemplateUseModelAnimation}, True);
wbMODLReq :=
wbRStructSK([0], 'Model', [
wbString(MODL, 'Model Filename', 0, cpNormal, True),
wbMODT,
wbMODS,
wbMODC,
wbMODF
], [], cpNormal, True, nil, True);
wbDMDS := wbFormIDCk(DMDS, 'Material Swap', [MSWP]);
wbDMDC := wbFloat(DMDC, 'Color Remapping Index');
wbDEST := wbRStruct('Destructible', [
wbStruct(DEST, 'Header', [
wbInteger('Health', itS32),
wbInteger('DEST Count', itU8),
wbInteger('Flags', itU8, wbFlags([
'VATS Targetable',
'Large Actor Destroys'
])),
wbByteArray('Unknown', 2)
]),
wbArrayS(DAMC, 'Resistances', wbStructSK([0], 'Resistance', [
wbFormIDCk('Damage Type', [DMGT]),
wbInteger('Value', itU32)
])),
wbRArray('Stages',
wbRStruct('Stage', [
wbStruct(DSTD, 'Destruction Stage Data', [
wbInteger('Health %', itU8),
wbInteger('Index', itU8),
wbInteger('Model Damage Stage', itU8),
wbInteger('Flags', itU8, wbFlags([
'Cap Damage',
'Disable',
'Destroy',
'Ignore External Dmg',
'Becomes Dynamic'
])),
wbInteger('Self Damage per Second', itS32),
wbFormIDCk('Explosion', [EXPL, NULL]),
wbFormIDCk('Debris', [DEBR, NULL]),
wbInteger('Debris Count', itS32)
], cpNormal, True),
wbString(DSTA, 'Sequence Name'),
wbRStructSK([0], 'Model', [
wbString(DMDL, 'Model Filename', 0, cpNormal, True),
wbDMDT,
wbDMDC,
wbDMDS
], [], cpNormal, False, nil, True),
wbEmpty(DSTF, 'End Marker', cpNormal, True)
], [], cpNormal, False, nil)
)
], [], cpNormal, False, nil);
wbDESTActor := wbRStruct('Destructible', [
wbStruct(DEST, 'Header', [
wbInteger('Health', itS32),
wbInteger('Count', itU8),
wbInteger('VATS Targetable', itU8, wbBoolEnum),
wbByteArray('Unknown', 2)
]),
wbRArray('Stages', // Begin Stage Array
wbRStruct('Stage', [ // Begin Stage RStruct
wbStruct(DSTD, 'Destruction Stage Data', [ // Begin DSTD
wbInteger('Health %', itU8),
wbInteger('Index', itU8),
wbInteger('Damage Stage', itU8),
wbInteger('Flags', itU8, wbFlags([
'Cap Damage',
'Disable',
'Destroy'
])),
wbInteger('Self Damage per Second', itS32),
wbFormIDCk('Explosion', [EXPL, NULL]),
wbFormIDCk('Debris', [DEBR, NULL]),
wbInteger('Debris Count', itS32)
], cpNormal, True), // End DSTD
wbRStructSK([0], 'Model', [ // Begin DMDL
wbString(DMDL, 'Model Filename')
], []), // End DMDL
wbDMDT,
wbDMDC,
wbDMDS,
wbEmpty(DSTF, 'End Marker', cpNormal, True)
], []) // Begin Stage RStruct
) // End Stage Array
], [], cpNormal, False, nil{wbActorTemplateUseModelAnimation});
wbXLOD := wbArray(XLOD, 'Distant LOD Data', wbFloat('Unknown'), 3);
wbXESP := wbStruct(XESP, 'Enable Parent', [
wbFormIDCk('Reference', sigReferences),
wbInteger('Flags', itU8, wbFlags([
'Set Enable State to Opposite of Parent',
'Pop In'
])),
wbByteArray('Unused', 3, cpIgnore)
]);
wbPDTO :=
wbStruct(PDTO, 'Topic Data', [
wbInteger('Type', itU32, wbEnum([
'Topic Ref',
'Topic Subtype'
])),
wbUnion('Data', wbTypeDecider, [
wbFormIDCk('Topic', [DIAL, NULL]),
wbString('Subtype', 4)
])
]);
wbPDTOs := wbRArray('Topic', wbPDTO, cpNormal, False, nil);
wbXLCM := wbInteger(XLCM, 'Level Modifier', itS32, wbEnum([
'Easy',
'Medium',
'Hard',
'Very Hard'
]));
if wbSimpleRecords then begin
wbMaxHeightDataCELL := wbByteArray(MHDT, 'Max Height Data', 0, cpNormal);
wbMaxHeightDataWRLD := wbByteArray(MHDT, 'Max Height Data', 0, cpNormal);
end
else begin
wbMaxHeightDataCELL := wbStruct(MHDT, 'Max Height Data', [
wbFloat('Offset'),
wbArray('Rows',
wbByteArray('Columns', 32)
// way too verbose for no practical use
//wbStruct('Row', [ wbArray('Columns', wbInteger('Column', itU8), 32) ])
, 32)
]);
wbMaxHeightDataWRLD := wbStruct(MHDT, 'Max Height Data', [
wbStruct('Min', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
]),
wbStruct('Max', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
]),
wbByteArray('Cell Data', 0)
// way too verbose for no practical use
{wbArray('Cell Data', wbStruct('Quad Height', [
wbInteger('Bottom Left', itU8),
wbInteger('Bottom Right', itU8),
wbInteger('Top Left', itU8),
wbInteger('Top Right', itU8)
]))}
]);
end;
if wbSimpleRecords then
wbOFST := wbByteArray(OFST, 'Offset Data')
else
wbOFST := wbArray(OFST, 'Offset Data', wbArray('Rows', wbInteger('Offset', itU32), wbOffsetDataColsCounter), 0);
wbXOWN := wbStruct(XOWN, 'Owner', [
wbFormIDCkNoReach('Owner', [FACT, ACHR, NPC_]),
wbByteArray('Unknown', 4),
wbInteger('Flags', itU8, wbFlags(['No Crime'])),
wbByteArray('Unknown', 3)
]);
wbXRNK := wbInteger(XRNK, 'Owner Faction Rank', itS32);
if wbSimpleRecords then
wbNVNM := wbStruct(NVNM, 'Navmesh Geometry', [
wbInteger('Version', itU32),
wbByteArray('Magic', 4),
wbFormIDCk('Parent Worldspace', [WRLD, NULL]),
wbUnion('Parent', wbNVNMParentDecider, [
wbStruct('Coordinates', [
wbInteger('Grid Y', itS16),
wbInteger('Grid X', itS16)
]),
wbFormIDCk('Parent Cell', [CELL])
]),
wbByteArray('Vertices and Triangles')
])
else
wbNVNM := wbStruct(NVNM, 'Navmesh Geometry', [
wbInteger('Version', itU32), // Changes how the struct is loaded, should be 15 in FO4
wbStruct('Pathing Cell', [
wbInteger('Magic', itU32), // This looks like a magic number (always $A5E9A03C), loaded with the parents
wbFormIDCk('Parent Worldspace', [WRLD, NULL]),
wbUnion('Parent', wbNVNMParentDecider, [ // same as TES5 cell if worldspace is null or Grid X Y
wbStruct('Coordinates', [
wbInteger('Grid Y', itS16),
wbInteger('Grid X', itS16)
]),
wbFormIDCk('Parent Cell', [CELL])
])
]),
wbArray('Vertices', wbStruct('Vertex', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]), -1),
wbArray('Triangles',
wbStruct('Triangle', [
wbInteger('Vertex 0', itS16),
wbInteger('Vertex 1', itS16),
wbInteger('Vertex 2', itS16),
wbInteger('Edge 0-1', itS16),
wbInteger('Edge 1-2', itS16),
wbInteger('Edge 2-0', itS16),
wbFloat('Height'), // this and next if form ver > 57
wbInteger('Unknown', itU8, wbFlags([])), // flags
wbInteger('Unknown', itU32) // encoding or flags
])
, -1),
wbArray('Edge Links',
wbStruct('Edge Link', [
wbInteger('Unknown', itU32),
wbFormIDCk('Mesh', [NAVM]), // those last three are a structure
wbInteger('Triangle', itS16),
wbInteger('Unknown', itU8) // if form ver > 127
])
, -1),
wbArray('Door Triangles',
wbStruct('Door Triangle', [
wbInteger('Triangle before door', itU16), // I would say itU16
wbInteger('DTUnknown', itU32), // used as a key to lookup in a map of PathingDoor
wbUnion('Door', wbDoorTriangleDoorTriangleDecider, [wbNull, wbFormIDCk('Door', [REFR])])
])
, -1),
wbArray('Unknown 5', // if navmesh version gt 12
wbStruct('Unknown', [
wbInteger('Unknown', itU16),
wbInteger('Unknown', itU16),
wbInteger('Unknown', itU32 {, wbFlags([]) ? })
])
, -1),
wbArray('Unknown 6',
wbStruct('Uknown', [
wbInteger('Unknown', itU16),
wbInteger('Unknown', itU16)
])
, -1),
wbArray('Unknown 7', // if navmesh version gt 11
wbStruct('Unknown', [
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbInteger('Unknown', itU16),
wbInteger('Unknown', itU32)
])
, -1),
wbStruct('Navmesh Grid', [
wbInteger('Navmesh Grid Size', itU32), // max 12
wbFloat('Max X Distance'),
wbFloat('Max Y Distance'),
wbFloat('Min X'),
wbFloat('Min Y'),
wbFloat('Min Z'),
wbFloat('Max X'),
wbFloat('Max Y'),
wbFloat('Max Z'),
wbArray('NavMesh Grid Arrays', wbArray('NavMeshGridCell', wbInteger('Triangle', itS16), -1)) // There are NavMeshGridSize^2 arrays to load
])
]);
end;
procedure DefineFO4b;
begin
wbRecord(ACHR, 'Placed NPC',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000200} 9, 'Starts Dead',
{0x00000400} 10, 'Persistent',
{0x00000800} 11, 'Initially Disabled',
{0x02000000} 25, 'No AI Acquire',
{0x20000000} 29, 'Don''t Havok Settle'
], True, True)), [
wbEDID,
wbVMAD,
wbFormIDCk(NAME, 'Base', [NPC_], False, cpNormal, True),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
{--- Ragdoll ---}
wbXRGD,
wbXRGB,
{--- Patrol Data ---}
wbRStruct('Patrol Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbPDTOs,
wbFormIDCk(TNAM, 'Topic', [DIAL, NULL], False, cpNormal)
], []),
{--- Leveled Actor ----}
wbXLCM,
{--- Extra ---}
wbInteger(XCNT, 'Count', itS32),
wbFloat(XRDS, 'Radius'),
wbInteger(XHLT, 'Health %', itU32),
wbRArrayS('Linked References', wbStructSK(XLKR, [0], 'Linked Reference', [
wbFormIDCk('Keyword/Ref', [KYWD, PLYR, ACHR, REFR, PGRE, PHZD, PMIS, PARW, PBAR, PBEA, PCON, PFLA, NULL]),
wbFormIDCk('Ref', sigReferences)
], cpNormal, False, nil, 1)),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', sigReferences),
wbFloat('Delay')
])
)
], []),
wbEmpty(XLKT, 'Linked Ref Transient'),
wbFormIDCk(XRFG, 'Reference Group', [RFGP]),
wbFormIDCk(XLYR, 'Layer', [LAYR]),
wbFormIDCk(XMSP, 'Material Swap', [MSWP]),
wbFormIDCk(XLCN, 'Persistent Location', [LCTN]),
wbFormIDCk(XLRL, 'Location Reference', [LCRT, LCTN, NULL], False, cpBenignIfAdded),
wbArray(XLRT, 'Location Ref Type', wbFormIDCk('Ref', [LCRT, NULL])),
wbEmpty(XIS2, 'Ignored by Sandbox'),
wbRArray('Spline Connection', wbStruct(XPLK, 'Link', [
wbFormIDCk('Ref', [REFR, ACHR]),
wbUnknown // always 00 00 00 00 so far in DLCWorkshop03.esm
])),
wbFloat(XHTW, 'Head-Tracking Weight'),
wbFloat(XFVC, 'Favor Cost'),
{--- Enable Parent ---}
wbXESP,
{--- Ownership ---}
wbXOWN,
wbXRNK,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', sigReferences),
{--- Flags ---}
wbEmpty(XIBS, 'Ignored By Sandbox'),
{--- 3D Data ---}
wbXSCL,
wbDATAPosRot,
wbString(MNAM, 'Comments')
], True, wbPlacedAddInfo);
wbVatsValueFunctionEnum :=
wbEnum([
{ 0} 'Weapon Is',
{ 1} 'Weapon In List',
{ 2} 'Target Is',
{ 3} 'Target In List',
{ 4} 'Target Distance',
{ 5} 'Target Part',
{ 6} 'VATS Action',
{ 7} 'Is Success',
{ 8} 'Is Critical',
{ 9} 'Critical Effect Is',
{10} 'Critical Effect In List',
{11} 'Is Fatal',
{12} 'Explode Part',
{13} 'Dismember Part',
{14} 'Cripple Part',
{15} 'Weapon Type Is',
{16} 'Is Stranger',
{17} 'Is Paralyzing Palm',
{18} 'Projectile Type Is',
{19} 'Delivery Type Is',
{20} 'Casting Type Is'
]);
wbActorValueEnum :=
wbEnum([
{00} 'Aggression',
{01} 'Confidence',
{02} 'Energy',
{03} 'Morality',
{04} 'Mood',
{05} 'Assistance',
{06} 'One-Handed',
{07} 'Two-Handed',
{08} 'Archery',
{09} 'Block',
{10} 'Smithing',
{11} 'Heavy Armor',
{12} 'Light Armor',
{13} 'Pickpocket',
{14} 'Lockpicking',
{15} 'Sneak',
{16} 'Alchemy',
{17} 'Speech',
{18} 'Alteration',
{19} 'Conjuration',
{20} 'Destruction',
{21} 'Illusion',
{22} 'Restoration',
{23} 'Enchanting',
{24} 'Health',
{25} 'Magicka',
{26} 'Stamina',
{27} 'Heal Rate',
{28} 'Magicka Rate',
{29} 'Stamina Rate',
{30} 'Speed Mult',
{31} 'Inventory Weight',
{32} 'Carry Weight',
{33} 'Critical Chance',
{34} 'Melee Damage',
{35} 'Unarmed Damage',
{36} 'Mass',
{37} 'Voice Points',
{38} 'Voice Rate',
{39} 'Damage Resist',
{40} 'Poison Resist',
{41} 'Resist Fire',
{42} 'Resist Shock',
{43} 'Resist Frost',
{44} 'Resist Magic',
{45} 'Resist Disease',
{46} 'Unknown 46',
{47} 'Unknown 47',
{48} 'Unknown 48',
{49} 'Unknown 49',
{50} 'Unknown 50',
{51} 'Unknown 51',
{52} 'Unknown 52',
{53} 'Paralysis',
{54} 'Invisibility',
{55} 'Night Eye',
{56} 'Detect Life Range',
{57} 'Water Breathing',
{58} 'Water Walking',
{59} 'Unknown 59',
{60} 'Fame',
{61} 'Infamy',
{62} 'Jumping Bonus',
{63} 'Ward Power',
{64} 'Right Item Charge',
{65} 'Armor Perks',
{66} 'Shield Perks',
{67} 'Ward Deflection',
{68} 'Variable01',
{69} 'Variable02',
{70} 'Variable03',
{71} 'Variable04',
{72} 'Variable05',
{73} 'Variable06',
{74} 'Variable07',
{75} 'Variable08',
{76} 'Variable09',
{77} 'Variable10',
{78} 'Bow Speed Bonus',
{79} 'Favor Active',
{80} 'Favors Per Day',
{81} 'Favors Per Day Timer',
{82} 'Left Item Charge',
{83} 'Absorb Chance',
{84} 'Blindness',
{85} 'Weapon Speed Mult',
{86} 'Shout Recovery Mult',
{87} 'Bow Stagger Bonus',
{88} 'Telekinesis',
{89} 'Favor Points Bonus',
{90} 'Last Bribed Intimidated',
{91} 'Last Flattered',
{92} 'Movement Noise Mult',
{93} 'Bypass Vendor Stolen Check',
{94} 'Bypass Vendor Keyword Check',
{95} 'Waiting For Player',
{96} 'One-Handed Modifier',
{97} 'Two-Handed Modifier',
{98} 'Marksman Modifier',
{99} 'Block Modifier',
{100} 'Smithing Modifier',
{101} 'Heavy Armor Modifier',
{102} 'Light Armor Modifier',
{103} 'Pickpocket Modifier',
{104} 'Lockpicking Modifier',
{105} 'Sneaking Modifier',
{106} 'Alchemy Modifier',
{107} 'Speechcraft Modifier',
{108} 'Alteration Modifier',
{109} 'Conjuration Modifier',
{110} 'Destruction Modifier',
{111} 'Illusion Modifier',
{112} 'Restoration Modifier',
{113} 'Enchanting Modifier',
{114} 'One-Handed Skill Advance',
{115} 'Two-Handed Skill Advance',
{116} 'Marksman Skill Advance',
{117} 'Block Skill Advance',
{118} 'Smithing Skill Advance',
{119} 'Heavy Armor Skill Advance',
{120} 'Light Armor Skill Advance',
{121} 'Pickpocket Skill Advance',
{122} 'Lockpicking Skill Advance',
{123} 'Sneaking Skill Advance',
{124} 'Alchemy Skill Advance',
{125} 'Speechcraft Skill Advance',
{126} 'Alteration Skill Advance',
{127} 'Conjuration Skill Advance',
{128} 'Destruction Skill Advance',
{129} 'Illusion Skill Advance',
{130} 'Restoration Skill Advance',
{131} 'Enchanting Skill Advance',
{132} 'Left Weapon Speed Multiply',
{133} 'Dragon Souls',
{134} 'Combat Health Regen Multiply',
{135} 'One-Handed Power Modifier',
{136} 'Two-Handed Power Modifier',
{137} 'Marksman Power Modifier',
{138} 'Block Power Modifier',
{139} 'Smithing Power Modifier',
{140} 'Heavy Armor Power Modifier',
{141} 'Light Armor Power Modifier',
{142} 'Pickpocket Power Modifier',
{143} 'Lockpicking Power Modifier',
{144} 'Sneaking Power Modifier',
{145} 'Alchemy Power Modifier',
{146} 'Speechcraft Power Modifier',
{147} 'Alteration Power Modifier',
{148} 'Conjuration Power Modifier',
{149} 'Destruction Power Modifier',
{150} 'Illusion Power Modifier',
{151} 'Restoration Power Modifier',
{152} 'Enchanting Power Modifier',
{153} 'Dragon Rend',
{154} 'Attack Damage Mult',
{155} 'Heal Rate Mult',
{156} 'Magicka Rate Mult',
{157} 'Stamina Rate Mult',
{158} 'Werewolf Perks',
{159} 'Vampire Perks',
{160} 'Grab Actor Offset',
{161} 'Grabbed',
{162} 'Unknown 162',
{163} 'Reflect Damage'
], [
-1, 'None'
]);
wbSkillEnum :=
wbEnum([
'Unknown 1',
'Unknown 2',
'Unknown 3',
'Unknown 4',
'Unknown 5',
'Unknown 6',
'One Handed',
'Two Handed',
'Archery',
'Block',
'Smithing',
'Heavy Armor',
'Light Armor',
'Pickpocket',
'Lockpicking',
'Sneak',
'Alchemy',
'Speech',
'Alteration',
'Conjuration',
'Destruction',
'Illusion',
'Restoration',
'Enchanting'
], [
-1, 'None'
]);
wbCastEnum := wbEnum([
{0} 'Constant Effect',
{1} 'Fire and Forget',
{2} 'Concentration',
{3} 'Scroll'
]);
wbTargetEnum := wbEnum([
{0} 'Self',
{1} 'Touch',
{2} 'Aimed',
{3} 'Target Actor',
{4} 'Target Location'
]);
wbCastingSourceEnum := wbEnum([
'Left',
'Right',
'Voice',
'Instant'
]);
wbCrimeTypeEnum :=
wbEnum([
'Steal',
'Pickpocket',
'Trespass',
'Attack',
'Murder',
'Escape Jail',
'Werewolf Transformation'
], [
-1, 'None'
]);
wbKeywordTypeEnum :=
wbEnum([
{00} 'None',
{01} 'Component Tech Level',
{02} 'Attach Point',
{03} 'Component Property',
{04} 'Instantiation Filter',
{05} 'Mod Association',
{06} 'Sound',
{07} 'Anim Archetype',
{08} 'Function Call',
{09} 'Recipe Filter',
{10} 'Attraction Type',
{11} 'Dialogue Subtype',
{12} 'Quest Target',
{13} 'Anim Flavor',
{14} 'Anim Gender',
{15} 'Anim Face',
{16} 'Quest Group',
{17} 'Anim Injured',
{18} 'Dispel Effect'
]);
wbETYP := wbFormIDCk(ETYP, 'Equipment Type', [EQUP, NULL]);
wbETYPReq := wbFormIDCk(ETYP, 'Equipment Type', [EQUP, NULL], False, cpNormal, True);
wbFormTypeEnum := wbEnum([], [
0, 'Activator',
1, 'Armor',
2, 'Book',
3, 'Container',
4, 'Door',
5, 'Ingredient',
6, 'Light',
7, 'MiscItem',
8, 'Static',
9, 'Grass',
10, 'Tree',
12, 'Weapon',
13, 'Actor',
14, 'LeveledCharacter',
15, 'Spell',
16, 'Enchantment',
17, 'Potion',
18, 'LeveledItem',
19, 'Key',
20, 'Ammo',
21, 'Flora',
22, 'Furniture',
23, 'Sound Marker',
24, 'LandTexture',
25, 'CombatStyle',
26, 'LoadScreen',
27, 'LeveledSpell',
28, 'AnimObject',
29, 'WaterType',
30, 'IdleMarker',
31, 'EffectShader',
32, 'Projectile',
33, 'TalkingActivator',
34, 'Explosion',
35, 'TextureSet',
36, 'Debris',
37, 'MenuIcon',
38, 'FormList',
39, 'Perk',
40, 'BodyPartData',
41, 'AddOnNode',
42, 'MovableStatic',
43, 'CameraShot',
44, 'ImpactData',
45, 'ImpactDataSet',
46, 'Quest',
47, 'Package',
48, 'VoiceType',
49, 'Class',
50, 'Race',
51, 'Eyes',
52, 'HeadPart',
53, 'Faction',
54, 'Note',
55, 'Weather',
56, 'Climate',
57, 'ArmorAddon',
58, 'Global',
59, 'Imagespace',
60, 'Imagespace Modifier',
61, 'Encounter Zone',
62, 'Message',
63, 'Constructible Object',
64, 'Acoustic Space',
65, 'Ragdoll',
66, 'Script',
67, 'Magic Effect',
68, 'Music Type',
69, 'Static Collection',
70, 'Keyword',
71, 'Location',
72, 'Location Ref Type',
73, 'Footstep',
74, 'Footstep Set',
75, 'Material Type',
76, 'Actor Action',
77, 'Music Track',
78, 'Word of Power',
79, 'Shout',
80, 'Relationship',
81, 'Equip Slot',
82, 'Association Type',
83, 'Outfit',
84, 'Art Object',
85, 'Material Object',
87, 'Lighting Template',
88, 'Shader Particle Geometry',
89, 'Visual Effect',
90, 'Apparatus',
91, 'Movement Type',
92, 'Hazard',
93, 'SM Event Node',
94, 'Sound Descriptor',
95, 'Dual Cast Data',
96, 'Sound Category',
97, 'Soul Gem',
98, 'Sound Output Model',
99, 'Collision Layer',
100, 'Scroll',
101, 'ColorForm',
102, 'Reverb Parameters',
116, 'Terminal'
]);
wbMiscStatEnum := wbEnum([], [
Int64($1EE71DBC), 'Animals Friended',
Int64($FCDD5011), 'Animals Killed',
Int64($366D84CF), 'Armor Improved',
Int64($8E20D7C9), 'Assaults',
Int64($B9B50725), 'Backstabs',
Int64($EA01A954), 'Bobbleheads Collected',
Int64($6932624D), 'Bright Ideas',
Int64($7FF0CC3B), 'Brotherhood of Steel Quests Completed',
Int64($FEA920AA), 'Buildings',
Int64($1F84743B), 'Caps Found',
Int64($9360004C), 'Chems Crafted',
Int64($B2A78B7A), 'Chems Taken',
Int64($53D9E9B5), 'Chests Looted',
Int64($1E258BEE), 'Computers Hacked',
Int64($3DE99B41), 'Cores Ejected',
Int64($737EAA97), 'Corpses Eaten',
Int64($40B11EFE), 'Creatures Killed',
Int64($4C4B8DF3), 'Creatures Killed DLC03',
Int64($22D5BA38), 'Critical Strikes',
Int64($3C626A90), 'Days Passed',
Int64($C5A52FD0), 'Days Survived',
Int64($45FDBB1C), 'DLC01 Quests Completed',
Int64($FA7CC7F9), 'DLC03 Locations Discovered',
Int64($AA444695), 'Dungeons Cleared',
Int64($F4E8FFD6), 'Fatman Deaths',
Int64($66DAF3CF), 'Fits of Rage',
Int64($554E59D5), 'Food',
Int64($E1EB3490), 'Food Cooked',
Int64($9311B22B), 'Food Eaten',
Int64($F947D866), 'Four Leaf Clovers',
Int64($7C586E7A), 'Fusion Cores Consumed',
Int64($2826309E), 'Game Difficulty',
Int64($A5EA7ABC), 'Grand Slams',
Int64($F5A36770), 'Grim Reaper Sprints',
Int64($52984AA4), 'Happiness',
Int64($FA024018), 'Hours Slept',
Int64($CAD2ECA1), 'Hours Waiting',
Int64($8CC5DAB6), 'HSAtomicCommand',
Int64($A2E4C1F2), 'HSAutomatron',
Int64($20F9993D), 'HSGrognak',
Int64($8D882844), 'HSJangles',
Int64($910B02C0), 'HSPipfall',
Int64($860E0723), 'HSRedMenace',
Int64($3FFA8658), 'HSZetaInvaders',
Int64($40CA9C83), 'Institute Quests Completed',
Int64($7D2E57C0), 'Intimidations',
Int64($FFE8010B), 'Investments Made',
Int64($9AF17D9D), 'Items Crafted DLC03',
Int64($CF48C0B9), 'Items Scrapped',
Int64($82F190C2), 'Items Stolen',
Int64($6D8671DD), 'Junk Collected',
Int64($110B8D2F), 'Legendary Enemies Killed',
Int64($8A24FDE2), 'Locations Discovered',
Int64($5829CC2E), 'Locks Picked',
Int64($7EA26C2D), 'Main Quests Completed',
Int64($493B803C), 'Mines Disarmed',
Int64($B1511B82), 'Minuteman Quests Completed',
Int64($98EE55DC), 'Misc Objectives Completed',
Int64($0F3315AC), 'Money Shots',
Int64($5E457DAC), 'Most Caps Carried',
Int64($D37C6909), 'Murders',
Int64($B91253A4), 'Mysterious Strabger Visits',
Int64($1DEEA18A), 'Nuka Cola Flavors Created',
Int64($9CE72536), 'Nuka World Creatures Killed',
Int64($EB0D60AC), 'Objects Built',
Int64($73AD915B), 'Pants Exploded',
Int64($53706A04), 'Paralyzing Punches',
Int64($9E78CEB3), 'People',
Int64($F22A8133), 'People Killed',
Int64($D3F632FF), 'Plants Harvested',
Int64($856FA4C1), 'PlayedFutureRetroHolotape',
Int64($F2BAC234), 'Pockets Picked',
Int64($AC69D9B9), 'Power',
Int64($0D7B8B16), 'Quests Completed',
Int64($0580BB9F), 'RadAway Taken',
Int64($D2960073), 'Rad-X Taken',
Int64($FDE20426), 'Railroad Quests Completed',
Int64($3CBF7E59), 'Ricochets',
Int64($01E1BC85), 'Robots Disabled',
Int64($2CA4ECC0), 'Robots Improved',
Int64($C8BC93BE), 'Robots Killed',
Int64($98D5710C), 'Sandman Kills',
Int64($B1AE4792), 'Side Quests Completed',
Int64($ACE470D7), 'Skill Books Read',
Int64($B556CC52), 'Sneak Attacks',
Int64($32D1B38F), 'Speach Successes',
Int64($5D6B18F1), 'Stimpacks Taken',
Int64($C5321BC5), 'Supply Lines Created',
Int64($3869002E), 'Survival Denied',
Int64($F9DEC209), 'Survival Level-Ups',
Int64($69AF5B9A), 'Synths Killed',
Int64($0A872FA3), 'Times Addicted',
Int64($7AEA9C2B), 'Trespasses',
Int64($13752285), 'Turrets Killed',
Int64($0B479511), 'Wasteland Whispers',
Int64($FCD0CCC3), 'Water',
Int64($61A5C5A9), 'Weapons Disarmed',
Int64($1D3BA844), 'Weapons Improved',
Int64($60A11697), 'Workshops Unlocked'
]);
wbAdvanceActionEnum := wbEnum([
'Normal Usage',
'Power Attack',
'Bash',
'Lockpick Success',
'Lockpick Broken'
]);
wbAlignmentEnum :=
wbEnum([
'Good',
'Neutral',
'Evil',
'Very Good',
'Very Evil'
]);
wbAxisEnum :=
wbEnum([], [
88, 'X',
89, 'Y',
90, 'Z'
]);
wbCriticalStageEnum :=
wbEnum([
'None',
'Goo Start',
'Goo End',
'Disintegrate Start',
'Disintegrate End'
]);
wbStaggerEnum := wbEnum([
'None',
'Small',
'Medium',
'Large',
'Extra Large'
]);
wbSexEnum := wbEnum(['Male','Female']);
wbEFID := wbFormIDCk(EFID, 'Base Effect', [MGEF]);
wbEFIT :=
wbStructSK(EFIT, [3, 4], '', [
wbFloat('Magnitude', cpNormal, True),
wbInteger('Area', itU32),
wbInteger('Duration', itU32)
], cpNormal, True, nil, -1, wbEFITAfterLoad);
wbCTDA := wbRStruct('Condition', [
wbStruct(CTDA, '', [
wbInteger('Type', itU8, wbCtdaTypeToStr, wbCtdaTypeToInt, cpNormal, False, nil, wbCtdaTypeAfterSet),
wbByteArray('Unused', 3, cpIgnore, False, wbNeverShow),
wbUnion('Comparison Value', wbCTDACompValueDecider, [
wbFloat('Comparison Value - Float'),
wbFormIDCk('Comparison Value - Global', [GLOB])
]),
wbInteger('Function', itU16, wbCTDAFunctionToStr, wbCTDAFunctionToInt),
wbByteArray('Unused', 2, cpIgnore, False, wbNeverShow),
wbUnion('Parameter #1', wbCTDAParam1Decider, [
{ unknown }
wbByteArray('Unknown', 4),
{ 0 ptNone}
wbByteArray('None', 4, cpIgnore),
{ 1 ptInteger}
wbInteger('Integer', itS32),
{ 2 ptFloat}
wbFloat('Float'),
{ 3 ptActor}
wbFormIDCkNoReach('Actor', [NULL, PLYR, ACHR, REFR]),
{ 4 ptActorBase}
wbFormIDCkNoReach('Actor Base', [NPC_]),
{ 5 ptActorValue}
wbActorValue,
{ 6 ptAdvanceAction}
wbInteger('Player Action', itU32, wbAdvanceActionEnum),
{ 7 ptAlias}
wbInteger('Alias', itS32, wbConditionAliasToStr, wbStrToAlias),
{ 8 ptAlignment}
wbInteger('Alignment', itU32, wbAlignmentEnum),
{ 9 ptAssociationType}
wbFormIDCk('Association Type', [ASTP]),
{10 ptAxis}
wbInteger('Axis', itU32, wbAxisEnum),
{11 ptCastingSource}
wbInteger('Casting Type', itU32, wbCastingSourceEnum),
{12 ptCell}
wbFormIDCkNoReach('Cell', [CELL]),
{13 ptClass}
wbFormIDCkNoReach('Class', [CLAS]),
{14 ptCrimeType}
wbInteger('Crime Type', itU32, wbCrimeTypeEnum),
{15 ptCriticalStage}
wbInteger('Critical Stage', itU32, wbCriticalStageEnum),
{16 ptEncounterZone}
wbFormIDCkNoReach('Encounter Zone', [ECZN]),
{17 ptEquipType}
wbFormIDCkNoReach('Equip Type', [EQUP]),
{18 ptEvent}
wbInteger('Event', itU32, wbEventFunctionAndMemberToStr, wbEventFunctionAndMemberToInt),
{19 ptEventData}
wbFormID('Event Data'),
{20 ptFaction}
wbFormIDCkNoReach('Faction', [FACT]),
{21 ptFormList}
wbFormIDCkNoReach('Form List', [FLST]),
{22 ptFormType}
wbInteger('Form Type', itU32, wbFormTypeEnum),
{23 ptFurniture}
wbFormIDCkNoReach('Furniture', [FURN, FLST]),
{24 ptFurnitureAnim}
wbInteger('Furniture Anim', itU32, wbFurnitureAnimTypeEnum),
{25 ptFurnitureEntry}
wbInteger('Furniture Entry', itU32, wbEnum([], [$010000, 'Front', $020000, 'Behind', $040000, 'Right', $80000, 'Left', $100000, 'Up'])),
{26 ptGlobal}
wbFormIDCkNoReach('Global', [GLOB]),
{27 ptIdleForm}
wbFormIDCkNoReach('Idle', [IDLE]),
{28 ptInventoryObject}
wbFormIDCkNoReach('Inventory Object', sigBaseObjects),
{29 ptKeyword}
wbFormIDCkNoReach('Keyword', [KYWD, FLST, NULL]),
{30 ptLocation}
wbFormIDCkNoReach('Location', [LCTN]),
{31 ptMagicEffect}
wbFormIDCkNoReach('Base Effect', [MGEF]),
{32 ptMagicItem}
wbFormIDCkNoReach('Effect Item', [SPEL, ENCH, ALCH, INGR, SCRL]),
{33 ptMiscStat}
wbInteger('Misc Stat', itU32, wbMiscStatEnum),
{34 ptObjectReference}
wbFormIDCkNoReach('Object Reference', sigReferences),
{35 ptOwner}
wbFormIDCkNoReach('Owner', [NULL, FACT, NPC_]),
{36 ptPackage}
wbFormIDCkNoReach('Package', [PACK]),
{37 ptPackdata}
wbInteger('Packdata ID', itU32),
{38 ptPerk}
wbFormIDCkNoReach('Perk', [PERK]),
{39 ptQuest}
wbFormIDCkNoReach('Quest', [QUST]),
{40 ptQuestStage}
wbInteger('Quest Stage', itU32, wbCTDAParam2QuestStageToStr, wbCTDAParam2QuestStageToInt),
{41 ptRace}
wbFormIDCkNoReach('Race', [RACE]),
{42 ptReferencableObject}
wbFormIDCkNoReach('Referenceable Object', sigBaseObjects),
{43 ptRefType}
wbFormIDCkNoReach('Location Ref Type', [LCRT]),
{44 ptRegion}
wbFormIDCkNoReach('Region', [REGN]),
{45 ptScene}
wbFormIDCk('Scene', [NULL, SCEN]),
{46 ptSex}
wbInteger('Sex', itU32, wbSexEnum),
{47 ptShout}
wbFormIDCkNoReach('Shout', [SHOU]),
{48 ptVariableName}
wbByteArray('Variable Name (unused)', 4, cpIgnore),
{49 ptVATSValueFunction}
wbInteger('VATS Value Function', itU32, wbVATSValueFunctionEnum),
{50 ptVATSValueParam}
wbInteger('VATS Value Param (unused)', itU32),
{51 ptVoiceType}
wbFormIDCkNoReach('Voice Type', [VTYP, FLST]),
{52 ptWardState}
wbInteger('Ward State', itU32, wbWardStateEnum),
{53 ptWeather}
wbFormIDCkNoReach('Weather', [WTHR]),
{54 ptWorldspace}
wbFormIDCkNoReach('Worldspace', [WRLD, FLST]),
{55 ptDamageType}
wbFormIDCkNoReach('Damage Type', [DMGT, FLST])
]),
wbUnion('Parameter #2', wbCTDAParam2Decider, [
{ unknown }
wbByteArray('Unknown', 4),
{ 0 ptNone}
wbByteArray('None', 4, cpIgnore),
{ 1 ptInteger}
wbInteger('Integer', itS32),
{ 2 ptFloat}
wbFloat('Float'),
{ 3 ptActor}
wbFormIDCkNoReach('Actor', [NULL, PLYR, ACHR, REFR]),
{ 4 ptActorBase}
wbFormIDCkNoReach('Actor Base', [NPC_]),
{ 5 ptActorValue}
wbActorValue,
{ 6 ptAdvanceAction}
wbInteger('Player Action', itU32, wbAdvanceActionEnum),
{ 7 ptAlias}
wbInteger('Alias', itS32, wbConditionAliasToStr, wbStrToAlias),
{ 8 ptAlignment}
wbInteger('Alignment', itU32, wbAlignmentEnum),
{ 9 ptAssociationType}
wbFormIDCk('Association Type', [ASTP]),
{10 ptAxis}
wbInteger('Axis', itU32, wbAxisEnum),
{11 ptCastingSource}
wbInteger('Casting Type', itU32, wbCastingSourceEnum),
{12 ptCell}
wbFormIDCkNoReach('Cell', [CELL]),
{13 ptClass}
wbFormIDCkNoReach('Class', [CLAS]),
{14 ptCrimeType}
wbInteger('Crime Type', itU32, wbCrimeTypeEnum),
{15 ptCriticalStage}
wbInteger('Critical Stage', itU32, wbCriticalStageEnum),
{16 ptEncounterZone}
wbFormIDCkNoReach('Encounter Zone', [ECZN]),
{17 ptEquipType}
wbFormIDCkNoReach('Equip Type', [EQUP]),
{18 ptEvent}
wbInteger('Event', itU32, wbEventFunctionAndMemberToStr, wbEventFunctionAndMemberToInt),
{19 ptEventData}
wbFormID('Event Data'),
{20 ptFaction}
wbFormIDCkNoReach('Faction', [FACT]),
{21 ptFormList}
wbFormIDCkNoReach('Form List', [FLST]),
{22 ptFormType}
wbInteger('Form Type', itU32, wbFormTypeEnum),
{23 ptFurniture}
wbFormIDCkNoReach('Furniture', [FURN, FLST]),
{24 ptFurnitureAnim}
wbInteger('Furniture Anim', itU32, wbFurnitureAnimTypeEnum),
{25 ptFurnitureEntry}
wbInteger('Furniture Entry', itU32, wbEnum([], [$010000, 'Front', $020000, 'Behind', $040000, 'Right', $80000, 'Left', $100000, 'Up'])),
{26 ptGlobal}
wbFormIDCkNoReach('Global', [GLOB]),
{27 ptIdleForm}
wbFormIDCkNoReach('Idle', [IDLE]),
{28 ptInventoryObject}
wbFormIDCkNoReach('Inventory Object', sigBaseObjects),
{29 ptKeyword}
wbFormIDCkNoReach('Keyword', [KYWD, FLST, NULL]),
{30 ptLocation}
wbFormIDCkNoReach('Location', [LCTN]),
{31 ptMagicEffect}
wbFormIDCkNoReach('Base Effect', [MGEF]),
{32 ptMagicItem}
wbFormIDCkNoReach('Effect Item', [SPEL, ENCH, ALCH, INGR, SCRL]),
{33 ptMiscStat}
wbInteger('Misc Stat', itU32, wbMiscStatEnum),
{34 ptObjectReference}
wbFormIDCkNoReach('Object Reference', sigReferences),
{35 ptOwner}
wbFormIDCkNoReach('Owner', [NULL, FACT, NPC_]),
{36 ptPackage}
wbFormIDCkNoReach('Package', [PACK]),
{37 ptPackdata}
wbInteger('Packdata ID', itU32),
{38 ptPerk}
wbFormIDCkNoReach('Perk', [PERK]),
{39 ptQuest}
wbFormIDCkNoReach('Quest', [QUST]),
{40 ptQuestStage}
wbInteger('Quest Stage', itU32, wbCTDAParam2QuestStageToStr, wbCTDAParam2QuestStageToInt),
{41 ptRace}
wbFormIDCkNoReach('Race', [RACE]),
{42 ptReferencableObject}
wbFormIDCkNoReach('Referenceable Object', sigBaseObjects),
{43 ptRefType}
wbFormIDCkNoReach('Location Ref Type', [LCRT]),
{44 ptRegion}
wbFormIDCkNoReach('Region', [REGN]),
{45 ptScene}
wbFormIDCk('Scene', [NULL, SCEN]),
{46 ptSex}
wbInteger('Sex', itU32, wbSexEnum),
{47 ptShout}
wbFormIDCkNoReach('Shout', [SHOU]),
{48 ptVariableName}
wbByteArray('Variable Name (unused)', 4, cpIgnore),
{49 ptVATSValueFunction}
wbInteger('VATS Value Function', itU32, wbVATSValueFunctionEnum),
{50 ptVATSValueParam}
wbUnion('VATS Value Param', wbCTDAParam2VATSValueParamDecider, [
{ 0} wbFormIDCkNoReach('Weapon', [WEAP]),
{ 1} wbFormIDCkNoReach('Weapon List', [FLST], [WEAP]),
{ 2} wbFormIDCkNoReach('Target', [NPC_]),
{ 3} wbFormIDCkNoReach('Target List', [FLST], [NPC_]),
{ 4} wbByteArray('Unknown', 4, cpIgnore),
{ 5} wbInteger('Target Part', itS32, wbActorValueEnum),
{ 6} wbInteger('VATS Action', itU32, wbEnum([
'Unarmed Attack',
'One Hand Melee Attack',
'Two Hand Melee Attack',
'Magic Attack',
'Ranged Attack',
'Reload',
'Crouch',
'Stand',
'Switch Weapon',
'Toggle Weapon Drawn',
'Heal',
'Player Death'
])),
{ 7} wbByteArray('Unknown', 4, cpIgnore),
{ 8} wbByteArray('Unknown', 4, cpIgnore),
{ 9} wbFormIDCkNoReach('Critical Effect', [SPEL]),
{10} wbFormIDCkNoReach('Critical Effect List', [FLST], [SPEL]),
{11} wbByteArray('Unknown', 4, cpIgnore),
{12} wbByteArray('Unknown', 4, cpIgnore),
{13} wbByteArray('Unknown', 4, cpIgnore),
{14} wbByteArray('Unknown', 4, cpIgnore),
{15} wbInteger('Weapon Type', itU32, wbWeaponAnimTypeEnum),
{16} wbByteArray('Unknown', 4, cpIgnore),
{17} wbByteArray('Unknown', 4, cpIgnore),
{18} wbInteger('Projectile Type', itU32, wbEnum([
'Missile',
'Lobber',
'Beam',
'Flame',
'Cone',
'Barrier',
'Arrow'
])),
{19} wbInteger('Delivery Type', itU32, wbTargetEnum),
{20} wbInteger('Casting Type', itU32, wbCastEnum)
]),
{51 ptVoiceType}
wbFormIDCkNoReach('Voice Type', [VTYP, FLST]),
{52 ptWardState}
wbInteger('Ward State', itU32, wbWardStateEnum),
{53 ptWeather}
wbFormIDCkNoReach('Weather', [WTHR]),
{54 ptWorldspace}
wbFormIDCkNoReach('Worldspace', [WRLD, FLST]),
{55 ptDamageType}
wbFormIDCkNoReach('Damage Type', [DMGT, FLST])
]),
wbInteger('Run On', itU32, wbEnum([
{ 0} 'Subject',
{ 1} 'Target',
{ 2} 'Reference',
{ 3} 'Combat Target',
{ 4} 'Linked Reference',
{ 5} 'Quest Alias',
{ 6} 'Package Data',
{ 7} 'Event Data',
{ 9} 'Command Target',
{10} 'Event Camera Ref',
{11} 'My Killer'
]), cpNormal, False, nil, wbCTDARunOnAfterSet),
wbUnion('Reference', wbCTDAReferenceDecider, [
wbInteger('Unused', itU32, nil, cpIgnore),
wbFormIDCkNoReach('Reference', sigReferences, False)
]),
wbInteger('Parameter #3', itS32, nil, cpNormal, False, nil, nil, -1)
], cpNormal, False{, nil, 0, wbCTDAAfterLoad}),
wbString(CIS1, 'Parameter #1'),
wbString(CIS2, 'Parameter #2')
], [], cpNormal);
wbCTDAs := wbRArray('Conditions', wbCTDA, cpNormal, False);
wbCTDAsCount := wbRArray('Conditions', wbCTDA, cpNormal, False, nil, wbCTDAsAfterSet);
wbCTDAsReq := wbRArray('Conditions', wbCTDA, cpNormal, True);
wbCTDAsReqCount := wbRArray('Conditions', wbCTDA, cpNormal, True, nil, wbCTDAsAfterSet);
wbICON := wbString(ICON, 'Inventory Image');
wbMICO := wbString(MICO, 'Message Icon');
wbPTRN := wbFormIDCk(PTRN, 'Preview Transform', [TRNS]);
wbNTRM := wbFormIDCk(NTRM, 'Native Terminal', [TERM]);
wbYNAM := wbFormIDCk(YNAM, 'Sound - Pick Up', [SNDR]);
wbZNAM := wbFormIDCk(ZNAM, 'Sound - Put Down', [SNDR]);
wbCUSD := wbFormIDCk(CUSD, 'Sound - Crafting', [SNDR]);
wbINRD := wbFormIDCk(INRD, 'Instance Naming', [INNR]);
wbPRPS := wbArrayS(PRPS, 'Properties', wbStructSK([0], 'Property', [
wbActorValue,
wbFloat('Value')
]));
wbFLTR := wbString(FLTR, 'Filter');
wbAPPR := wbArray(APPR, 'Attach Parent Slots', wbFormIDCk('Keyword', [KYWD]));
wbFTYP := wbFormIDCk(FTYP, 'Forced Loc Ref Type', [LCRT]);
wbATTX := wbLString(ATTX, 'Activate Text Override', 0, cpTranslate);
wbMNAMFurnitureMarker := wbInteger(MNAM, 'Active Markers / Flags', itU32, wbFlags([
{0x00000001} 'Interaction Point 0',
{0x00000002} 'Interaction Point 1',
{0x00000004} 'Interaction Point 2',
{0x00000008} 'Interaction Point 3',
{0x00000010} 'Interaction Point 4',
{0x00000020} 'Interaction Point 5',
{0x00000040} 'Interaction Point 6',
{0x00000080} 'Interaction Point 7',
{0x00000100} 'Interaction Point 8',
{0x00000200} 'Interaction Point 9',
{0x00000400} 'Interaction Point 10',
{0x00000800} 'Interaction Point 11',
{0x00001000} 'Interaction Point 12',
{0x00002000} 'Interaction Point 13',
{0x00004000} 'Interaction Point 14',
{0x00008000} 'Interaction Point 15',
{0x00010000} 'Interaction Point 16',
{0x00020000} 'Interaction Point 17',
{0x00040000} 'Interaction Point 18',
{0x00080000} 'Interaction Point 19',
{0x00100000} 'Interaction Point 20',
{0x00200000} 'Interaction Point 21',
{0x00400000} 'Allow Awake Sound',
{0x00800000} 'Enter With Weapon Drawn',
{0x01000000} 'Play Anim When Full',
{0x02000000} 'Disables Activation',
{0x04000000} 'Is Perch',
{0x08000000} 'Must Exit to Talk',
{0x10000000} 'Use Static Avoid Node',
{0x20000000} 'Unknown 29',
{0x40000000} 'Has Model?',
{0x80000000} 'Unknown 31'
]));
wbSNAMMarkerParams :=
wbArray(SNAM, 'Marker Paramaters', wbStruct('Marker', [
wbFloat('Offset X'),
wbFloat('Offset Y'),
wbFloat('Offset Z'),
wbFloat('Rotation Z', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFormIDCk('Keyword', [KYWD, NULL]),
wbInteger('Entry Types', itU8, wbFlags([
'Front',
'Rear',
'Right',
'Left',
'Other',
'Unused 5',
'Unused 6',
'Unused 7'
])),
wbByteArray('Unknown', 3)
], cpNormal, False, nil, 4));
wbArmorPropertyEnum := wbEnum([
{ 0} 'Enchantments',
{ 1} 'BashImpactDataSet',
{ 2} 'BlockMaterial',
{ 3} 'Keywords',
{ 4} 'Weight',
{ 5} 'Value',
{ 6} 'Rating',
{ 7} 'AddonIndex',
{ 8} 'BodyPart',
{ 9} 'DamageTypeValue',
{10} 'ActorValues',
{11} 'Health',
{12} 'ColorRemappingIndex',
{13} 'MaterialSwaps'
]);
wbActorPropertyEnum := wbEnum([
{ 0} 'Keywords',
{ 1} 'ForcedInventory',
{ 2} 'XPOffset',
{ 3} 'Enchantments',
{ 4} 'ColorRemappingIndex',
{ 5} 'MaterialSwaps'
]);
wbWeaponPropertyEnum := wbEnum([
{ 0} 'Speed',
{ 1} 'Reach',
{ 2} 'MinRange',
{ 3} 'MaxRange',
{ 4} 'AttackDelaySec',
{ 5} 'Unknown 5',
{ 6} 'OutOfRangeDamageMult',
{ 7} 'SecondaryDamage',
{ 8} 'CriticalChargeBonus',
{ 9} 'HitBehaviour',
{10} 'Rank',
{11} 'Unknown 11',
{12} 'AmmoCapacity',
{13} 'Unknown 13',
{14} 'Unknown 14',
{15} 'Type',
{16} 'IsPlayerOnly',
{17} 'NPCsUseAmmo',
{18} 'HasChargingReload',
{19} 'IsMinorCrime',
{20} 'IsFixedRange',
{21} 'HasEffectOnDeath',
{22} 'HasAlternateRumble',
{23} 'IsNonHostile',
{24} 'IgnoreResist',
{25} 'IsAutomatic',
{26} 'CantDrop',
{27} 'IsNonPlayable',
{28} 'AttackDamage',
{29} 'Value',
{30} 'Weight',
{31} 'Keywords',
{32} 'AimModel',
{33} 'AimModelMinConeDegrees',
{34} 'AimModelMaxConeDegrees',
{35} 'AimModelConeIncreasePerShot',
{36} 'AimModelConeDecreasePerSec',
{37} 'AimModelConeDecreaseDelayMs',
{38} 'AimModelConeSneakMultiplier',
{39} 'AimModelRecoilDiminishSpringForce',
{40} 'AimModelRecoilDiminishSightsMult',
{41} 'AimModelRecoilMaxDegPerShot',
{42} 'AimModelRecoilMinDegPerShot',
{43} 'AimModelRecoilHipMult',
{44} 'AimModelRecoilShotsForRunaway',
{45} 'AimModelRecoilArcDeg',
{46} 'AimModelRecoilArcRotateDeg',
{47} 'AimModelConeIronSightsMultiplier',
{48} 'HasScope',
{49} 'ZoomDataFOVMult',
{50} 'FireSeconds',
{51} 'NumProjectiles',
{52} 'AttackSound',
{53} 'AttackSound2D',
{54} 'AttackLoop',
{55} 'AttackFailSound',
{56} 'IdleSound',
{57} 'EquipSound',
{58} 'UnEquipSound',
{59} 'SoundLevel',
{50} 'ImpactDataSet',
{61} 'Ammo',
{62} 'CritEffect',
{63} 'BashImpactDataSet',
{64} 'BlockMaterial',
{65} 'Enchantments',
{66} 'AimModelBaseStability',
{67} 'ZoomData',
{68} 'ZoomDataOverlay',
{69} 'ZoomDataImageSpace',
{70} 'ZoomDataCameraOffsetX',
{71} 'ZoomDataCameraOffsetY',
{72} 'ZoomDataCameraOffsetZ',
{73} 'EquipSlot',
{74} 'SoundLevelMult',
{75} 'NPCAmmoList',
{76} 'ReloadSpeed',
{77} 'DamageTypeValues',
{78} 'AccuracyBonus',
{79} 'AttackActionPointCost',
{80} 'OverrideProjectile',
{81} 'HasBoltAction',
{82} 'StaggerValue',
{83} 'SightedTransitionSeconds',
{84} 'FullPowerSeconds',
{85} 'HoldInputToPower',
{86} 'HasRepeatableSingleFire',
{87} 'MinPowerPerShot',
{88} 'ColorRemappingIndex',
{89} 'MaterialSwaps',
{90} 'CriticalDamageMult',
{91} 'FastEquipSound',
{92} 'DisableShells',
{93} 'HasChargingAttack',
{94} 'ActorValues'
]);
wbObjectModProperties :=
wbArrayS('Properties', wbStructSK([4], 'Property', [
wbInteger('Value Type', itU8, wbEnum([
{0} 'Int',
{1} 'Float',
{2} 'Bool',
{3} 'Unknown 3',
{4} 'FormID,Int',
{5} 'Enum',
{6} 'FormID,Float'
])),
wbByteArray('Unused', 3, cpIgnore),
wbUnion('Function Type', wbOMODDataFunctionTypeDecider, [
{ Float } wbInteger('Function Type', itU8, wbEnum(['SET', 'MUL+ADD', 'ADD'])),
{ Bool } wbInteger('Function Type', itU8, wbEnum(['SET', 'AND', 'OR'])),
{ Enum } wbInteger('Function Type', itU8, wbEnum(['SET'])),
{ FormID } wbInteger('Function Type', itU8, wbEnum(['SET', 'REM', 'ADD']))
]),
wbByteArray('Unused', 3, cpIgnore),
wbInteger('Property', itU16, wbObjectModPropertyToStr, wbObjectModPropertyToInt),
wbByteArray('Unused', 2, cpIgnore),
wbUnion('Value 1', wbOMODDataPropertyValue1Decider, [
{ 0} wbByteArray('Value 1 - Unknown', 4),
{ 1} wbInteger('Value 1 - Int', itU32),
{ 2} wbFloat('Value 1 - Float'),
{ 3} wbInteger('Value 1 - Bool', itU32, wbBoolEnum),
{ 4} wbFormID('Value 1 - FormID'),
{ 5} wbInteger('Value 1 - Enum', itU32),
{ 6} wbInteger('Sound Level', itU32, wbSoundLevelEnum),
{ 7} wbInteger('Stagger Value', itU32, wbStaggerEnum),
{ 8} wbInteger('Hit Behaviour', itU32, wbHitBehaviourEnum)
]),
wbUnion('Value 2', wbOMODDataPropertyValue2Decider, [
wbByteArray('Unused', 4, cpIgnore),
wbInteger('Value 2 - Int', itU32),
wbFloat('Value 2 - Float'),
wbInteger('Value 2 - Bool', itU32, wbBoolEnum)
]),
wbFloat('Step')
]), wbOMODDataPropertyCounter, cpNormal, False, nil, wbOMODpropertyAfterSet);
wbOBTSReq := wbStruct(OBTS, 'Object Mod Template Item', [
wbInteger('Include Count', itU32), // fixed name for wbOMOD* handlers
wbInteger('Property Count', itU32), // fixed name for wbOMOD* handlers
wbInteger('Level Min', itU8),
wbByteArray('Unused', 1),
wbInteger('Level Max', itU8),
wbByteArray('Unused', 1),
wbInteger('ID', itS16),
wbInteger('Default', itU8, wbBoolEnum),
wbArray('Keywords', wbFormIDCk('Keyword', [KYWD, NULL]), -4),
wbInteger('Min Level For Ranks', itU8),
wbInteger('Alt Levels Per Tier', itU8),
wbArray('Includes', wbStruct('Include', [
wbFormIDCk('Mod', [OMOD]),
wbInteger('Attach Point Index', itU8),
wbInteger('Optional', itU8, wbBoolEnum),
wbInteger('Don''t Use All', itU8, wbBoolEnum)
]), wbOMODDataIncludeCounter, cpNormal, False, nil, wbOMODincludeAfterSet),
wbObjectModProperties
], cpNormal, True);
wbObjectTemplate := wbRStruct('Object Template', [
wbInteger(OBTE, 'Count', itU32, nil, cpBenign),
wbRArray('Combinations',
wbRStruct('Combination', [
wbEmpty(OBTF, 'Editor Only'),
wbFULL,
wbOBTSReq
], [], cpNormal, False, nil, True),
cpNormal, False, nil, wbOBTSCombinationsAfterSet),
wbEmpty(STOP, 'Marker', cpNormal, True)
], []);
wbBSMPSequence := wbRStructs('Bone Data', 'Data', [
wbInteger(BSMP, 'Gender', itU32, wbEnum(['Male', 'Female'])),
// should not be sorted!!!
wbRArray('Bones',
wbRStruct('Bone', [
wbString(BSMB, 'Name'),
wbArray(BSMS, 'Values', wbFloat('Value')),
wbUnknown(BMMP)
], [])
)
], []);
wbEffectsReq :=
wbRStructs('Effects', 'Effect', [
wbEFID,
wbEFIT,
wbCTDAs
], [], cpNormal, True);
wbRecord(ACTI, 'Activator',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000002} 2, 'Never Fades',
{0x00000004} 4, 'Non Occluder',
{0x00000040} 6, 'Unknown 6',
{0x00000080} 7, 'Heading Marker',
{0x00000100} 8, 'Must Update Anims',
{0x00000200} 9, 'Hidden From Local Map',
{0x00000400} 10, 'Headtrack Marker',
{0x00000800} 11, 'Used as Platform',
{0x00001000} 13, 'Pack-In Use Only',
{0x00008000} 15, 'Has Distant LOD',
{0x00010000} 16, 'Random Anim Start',
{0x00020000} 17, 'Dangerous',
{0x00100000} 20, 'Ignore Object Interaction',
{0x00800000} 23, 'Is Marker',
{0x02000000} 25, 'Obstacle',
{0x04000000} 26, 'NavMesh Generation - Filter',
{0x08000000} 27, 'NavMesh Generation - Bounding Box',
{0x20000000} 29, 'Child Can Use',
{0x40000000} 30, 'NavMesh Generation - Ground'
])), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFormIDCk(STCP, 'Sound', [STAG]),
wbFULL,
wbMODL,
wbDEST,
wbKSIZ,
wbKWDAs,
wbPRPS,
wbNTRM,
wbFTYP,
wbStruct(PNAM, 'Marker Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbInteger('Unused', itU8)
]),
wbFormIDCk(SNAM, 'Sound - Looping', [SNDR]),
wbFormIDCk(VNAM, 'Sound - Activation', [SNDR]),
wbFormIDCk(WNAM, 'Water Type', [WATR]),
wbATTX,
wbInteger(FNAM, 'Flags', itU16, wbFlags([
'No Displacement',
'Ignored by Sandbox',
'Unknown 2',
'Unknown 3',
'Is a Radio'
])),
wbFormIDCk(KNAM, 'Interaction Keyword', [KYWD]),
wbStruct(RADR, 'Radio Receiver', [
wbFormIDCk('Sound Model', [SOPM, NULL]),
wbFloat('Frequency'),
wbFloat('Volume'),
wbInteger('Starts Active', itU8, wbBoolEnum),
wbInteger('No Signal Static', itU8, wbBoolEnum)
], cpNormal, False, nil, 4),
wbCITC,
wbCTDAs,
wbNVNM
], False, nil, cpNormal, False, nil, wbKeywordsAfterSet);
wbRecord(TACT, 'Talking Activator',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000200} 9, 'Hidden From Local Map',
{0x00010000} 16, 'Random Anim Start',
{0x00020000} 17, 'Radio Station'
]), [17]), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbFULL,
wbMODL,
wbDEST,
wbKSIZ,
wbKWDAs,
wbUnknown(PNAM, cpIgnore, True),
wbFormIDCk(SNAM, 'Looping Sound', [SNDR]),
wbUnknown(FNAM, cpIgnore, True),
wbFormIDCk(VNAM, 'Voice Type', [VTYP])
], False, nil, cpNormal, False, nil, wbKeywordsAfterSet);
wbRecord(ALCH, 'Ingestible',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x20000000} 29, 'Medicine'
])), [
wbEDID,
wbOBNDReq,
wbPTRN,
wbFULL,
wbKSIZ,
wbKWDAs,
wbMODL,
wbICON,
wbMICO,
wbYNAM,
wbZNAM,
wbETYP,
wbCUSD,
wbDEST,
wbDESC,
wbFloat(DATA, 'Weight', cpNormal, True),
wbStruct(ENIT, 'Effect Data', [
wbInteger('Value', itS32),
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'No Auto-Calc',
{0x00000002} 'Food Item',
{0x00000004} 'Unknown 3',
{0x00000008} 'Unknown 4',
{0x00000010} 'Unknown 5',
{0x00000020} 'Unknown 6',
{0x00000040} 'Unknown 7',
{0x00000080} 'Unknown 8',
{0x00000100} 'Unknown 9',
{0x00000200} 'Unknown 10',
{0x00000400} 'Unknown 11',
{0x00000800} 'Unknown 12',
{0x00001000} 'Unknown 13',
{0x00002000} 'Unknown 14',
{0x00004000} 'Unknown 15',
{0x00008000} 'Unknown 16',
{0x00010000} 'Medicine',
{0x00020000} 'Poison'
])),
wbFormID('Addiction'),
wbFloat('Addiction Chance'),
wbFormIDCk('Sound - Consume', [SNDR, NULL])
], cpNormal, True),
wbLString(DNAM, 'Addiction Name', 0, cpTranslate),
wbEffectsReq
], False, nil, cpNormal, False, wbRemoveEmptyKWDA, wbKeywordsAfterSet);
wbRecord(AMMO, 'Ammunition',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000004} 2, 'Non-Playable'
])), [
wbEDID,
wbOBNDReq,
wbPTRN,
wbFULL,
wbMODL,
wbDEST,
wbYNAM,
wbZNAM,
wbDESC,
wbKSIZ,
wbKWDAs,
wbStruct(DATA, 'Data', [
wbInteger('Value', itU32),
wbFloat('Weight')
], cpNormal, True, nil, 1),
wbStruct(DNAM, '', [
wbFormIDCk('Projectile', [PROJ, NULL]),
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Ignores Normal Weapon Resistance',
{0x02} 'Non-Playable',
{0x04} 'Has Count Based 3D'
])),
wbByteArray('Unused', 3),
wbFloat('Damage'),
wbInteger('Health', itU32)
], cpNormal, True),
wbLStringKC(ONAM, 'Short Name', 0, cpTranslate),
wbString(NAM1, 'Casing Model'),
wbByteArray(NAM2, 'Texture Files Hashes', 0, cpIgnore, false, false, wbNeverShow)
], False, nil, cpNormal, False, wbRemoveEmptyKWDA, wbKeywordsAfterSet);
wbRecord(ANIO, 'Animated Object',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000200} 9, 'Unknown 9'
]), [9]), [
wbEDID,
wbMODL,
wbString(BNAM, 'Unload Event')
]);
wbRecord(ARMO, 'Armor',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000004} 2, 'Non-Playable',
{0x00000040} 6, 'Shield',
{0x00000400} 10, 'Unknown 10',
{0x00008000} 15, 'Unknown 15'
])), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFULL,
wbEITM,
wbRStruct('Male world model', [
wbString(MOD2, 'Model Filename'),
wbByteArray(MO2T, 'Texture Files Hashes', 0, cpIgnore, false, false, wbNeverShow),
wbMO2S
], []),
wbString(ICON, 'Male Inventory Image'),
wbString(MICO, 'Male Message Icon'),
wbRStruct('Female world model', [
wbString(MOD4, 'Model Filename'),
wbByteArray(MO4T, 'Texture Files Hashes', 0, cpIgnore, false, false, wbNeverShow),
wbMO4S
], []),
wbString(ICO2, 'Female Inventory Image'),
wbString(MIC2, 'Female Message Icon'),
wbBOD2,
wbDEST,
wbYNAM,
wbZNAM,
wbETYP,
wbFormIDCk(BIDS, 'Block Bash Impact Data Set', [IPDS, NULL]),
wbFormIDCk(BAMT, 'Alternate Block Material', [MATT, NULL]),
wbFormIDCk(RNAM, 'Race', [RACE]),
wbKSIZ,
wbKWDAs,
wbDESC,
wbINRD,
wbRArray('Models',
wbRStruct('Model', [
wbInteger(INDX, 'Addon Index', itU16),
wbFormIDCk(MODL, 'Armor Addon', [ARMA])
], [])
),
wbStruct(DATA, '', [
wbInteger('Value', itS32),
wbFloat('Weight'),
wbInteger('Health', itU32)
], cpNormal, True),
wbStruct(FNAM, '', [
wbInteger('Armor Rating', itU16),
wbInteger('Base Addon Index', itU16),
wbInteger('Stagger Rating', itU8, wbStaggerEnum),
wbUnknown
]),
wbArrayS(DAMA, 'Resistances', wbStructSK([0], 'Resistance', [
wbFormIDCk('Damage Type', [DMGT]),
wbInteger('Value', itU32)
])),
wbFormIDCk(TNAM, 'Template Armor', [ARMO]),
wbAPPR,
wbObjectTemplate
], False, nil, cpNormal, False, wbARMOAfterLoad, wbKeywordsAfterSet);
wbRecord(ARMA, 'Armor Addon',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000040} 6, 'No Underarmor Scaling',
{0x00000200} 9, 'Unknown 9',
{0x40000000} 30, 'Hi-Res 1st Person Only'
])), [
wbEDID,
wbBOD2,
wbFormIDCk(RNAM, 'Race', [RACE]),
wbStruct(DNAM, 'Data', [
wbInteger('Male Priority', itU8),
wbInteger('Female Priority', itU8),
// essentialy a number of world models for different weights (Enabled = 2 models _0.nif and _1.nif)
wbInteger('Weight slider - Male', itU8, wbFlags([
{0x01} 'Unknown 0',
{0x02} 'Enabled'
])),
wbInteger('Weight slider - Female', itU8, wbFlags([
{0x01} 'Unknown 0',
{0x02} 'Enabled'
])),
wbByteArray('Unknown', 2),
wbInteger('Detection Sound Value', itU8),
wbByteArray('Unknown', 1),
wbFloat('Weapon Adjust')
], cpNormal, True),
wbRStruct('Male world model', [
wbString(MOD2, 'Model Filename'),
wbByteArray(MO2T, 'Texture Files Hashes', 0, cpIgnore, false, false, wbNeverShow),
wbMO2S,
wbMO2C,
wbMO2F
], [], cpNormal, False),
wbRStruct('Female world model', [
wbString(MOD3, 'Model Filename'),
wbByteArray(MO3T, 'Texture Files Hashes', 0, cpIgnore, false, false, wbNeverShow),
wbMO3S,
wbMO3C,
wbMO3F
], []),
wbRStruct('Male 1st Person', [
wbString(MOD4, 'Model Filename'),
wbByteArray(MO4T, 'Texture Files Hashes', 0, cpIgnore, false, false, wbNeverShow),
wbMO4S,
wbMO4C,
wbMO4F
], []),
wbRStruct('Female 1st Person', [
wbString(MOD5, 'Model Filename'),
wbByteArray(MO5T, 'Texture Files Hashes', 0, cpIgnore, false, false, wbNeverShow),
wbMO5S,
wbMO5C,
wbMO5F
], []),
wbFormIDCK(NAM0, 'Male Skin Texture', [TXST, NULL]),
wbFormIDCK(NAM1, 'Female Skin Texture', [TXST, NULL]),
wbFormIDCK(NAM2, 'Male Skin Texture Swap List', [FLST, NULL]),
wbFormIDCK(NAM3, 'Female Skin Texture Swap List', [FLST, NULL]),
wbRArrayS('Additional Races', wbFormIDCK(MODL, 'Race', [RACE, NULL])),
wbFormIDCk(SNDD, 'Footstep Sound', [FSTS, NULL]),
wbFormIDCk(ONAM, 'Art Object', [ARTO]),
wbBSMPSequence
], False, nil, cpNormal, False, wbARMAAfterLoad);
wbRecord(BOOK, 'Book', [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFULL,
wbMODL,
wbICON,
wbMICO,
wbDESCreq,
wbDEST,
wbYNAM,
wbZNAM,
wbKSIZ,
wbKWDAs,
wbFormIDCk(FIMD, 'Featured Item Message', [MESG]),
wbStruct(DATA, 'Data', [
wbInteger('Value', itU32),
wbFloat('Weight')
], cpNormal, True),
wbStruct(DNAM, '', [
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Advance Actor Value',
{0x02} 'Can''t be Taken',
{0x04} 'Add Spell',
{0x08} 'Unknown 3',
{0x10} 'Add Perk'
])),
wbUnion('Teaches', wbBOOKTeachesDecider, [
wbByteArray('Unused', 4),
wbFormIDCk('Actor Value', [AVIF, NULL]),
wbFormIDCk('Spell', [SPEL, NULL]),
wbFormIDCk('Perk', [PERK, NULL])
]),
wbStruct('Text Offset' , [
wbInteger('X', itU32),
wbInteger('Y', itU32)
])
], cpNormal, True),
wbLString(CNAM, 'Description', 0, cpTranslate),
wbFormIDCk(INAM, 'Inventory Art', [STAT])
], False, nil, cpNormal, False, nil, wbKeywordsAfterSet);
end;
procedure DefineFO4c;
procedure ReferenceRecord(aSignature: TwbSignature; const aName: string);
begin
wbRecord(aSignature, aName,
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000080} 7, 'Turn Off Fire',
{0x00000400} 10, 'Persistent',
{0x00000800} 11, 'Initially Disabled',
{0x10000000} 28, 'Reflected By Auto Water',
{0x20000000} 29, 'Don''t Havok Settle',
{0x40000000} 30, 'No Respawn'
], True, True)), [
wbEDID,
wbVMAD,
wbFormIDCk(NAME, 'Projectile', [PROJ, HAZD]),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbFloat(XHTW, 'Head-Tracking Weight'),
wbFloat(XFVC, 'Favor Cost'),
wbRArrayS('Reflected/Refracted By',
wbStructSK(XPWR, [0], 'Water', [
wbFormIDCk('Reference', [REFR]),
wbInteger('Type', itU32, wbFlags([
'Reflection',
'Refraction'
]))
], cpNormal, False, nil, 1)
),
wbRArrayS('Linked References', wbStructSK(XLKR, [0], 'Linked Reference', [
wbFormIDCk('Keyword/Ref', [KYWD, PLYR, ACHR, REFR, PGRE, PHZD, PMIS, PARW, PBAR, PBEA, PCON, PFLA, NULL]),
wbFormIDCk('Ref', sigReferences)
], cpNormal, False, nil, 1)),
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', sigReferences),
wbFloat('Delay')
])
)
], []),
wbFormIDCk(XASP, 'Unknown', [REFR]),
wbUnknown(XATP),
wbInteger(XAMC, 'Ammo Count', itU32),
wbEmpty(XLKT, 'Linked Ref Transient'),
wbFormIDCk(XLYR, 'Layer', [LAYR]),
wbFormIDCk(XMSP, 'Material Swap', [MSWP]),
wbFormIDCk(XRFG, 'Reference Group', [RFGP]),
wbUnknown(XCVR),
wbXESP,
wbXOWN,
wbXRNK,
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
wbEmpty(XIS2, 'Ignored by Sandbox'),
wbArray(XLRT, 'Location Ref Type', wbFormIDCk('Ref', [LCRT, NULL])),
wbFormIDCk(XLRL, 'Location Reference', [LCRT, LCTN, NULL], False, cpBenignIfAdded),
wbXSCL,
wbXLOD,
wbDataPosRot,
wbString(MNAM, 'Comments')
], True, wbPlacedAddInfo);
end;
begin
{>>>
Skrim has its own ref record for every projectile type
PARW 'Arrow'
PBEA 'Beam'
PFLA 'Flame'
PCON 'Cone' (voice)
PBAR 'Barrier'
PGRE 'Traps'
PHZD 'Hazards'
I guess all of them have the same structure
<<<}
ReferenceRecord(PARW, 'Placed Arrow');
ReferenceRecord(PBAR, 'Placed Barrier');
ReferenceRecord(PBEA, 'Placed Beam');
ReferenceRecord(PCON, 'Placed Cone/Voice');
ReferenceRecord(PFLA, 'Placed Flame');
ReferenceRecord(PGRE, 'Placed Projectile');
ReferenceRecord(PHZD, 'Placed Hazard');
ReferenceRecord(PMIS, 'Placed Missile');
wbRecord(CELL, 'Cell',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000400} 7, 'No Pre Vis',
{0x00000400} 10, 'Persistent',
{0x00020000} 17, 'Off Limits',
{0x00040000} 18, 'Compressed',
{0x00080000} 19, 'Can''t Wait'
]), [18]), [
wbEDID,
wbFULL,
wbInteger(DATA, 'Flags', itU16, wbFlags([
{0x0001} 'Is Interior Cell',
{0x0002} 'Has Water',
{0x0004} 'Can''t Travel From Here',
{0x0008} 'No LOD Water',
{0x0010} 'Unknown 5',
{0x0020} 'Public Area',
{0x0040} 'Hand Changed',
{0x0080} 'Show Sky',
{0x0100} 'Use Sky Lighting',
{0x0200} 'Unknown 10',
{0x0400} 'Unknown 11',
{0x0800} 'Sunlight Shadows',
{0x1000} 'Distant LOD only',
{0x2000} 'Player Followers Can''t Travel Here',
{0x4000} 'Unknown 15',
{0x8000} 'Unknown 16'
]), cpNormal, True, False, nil, wbCELLDATAAfterSet),
wbStruct(XCLC, 'Grid', [
wbInteger('X', itS32),
wbInteger('Y', itS32),
wbInteger('Force Hide Land', itU32, wbFlags([
'Quad 1',
'Quad 2',
'Quad 3',
'Quad 4'
], True))
], cpNormal, False, nil, 2),
wbByteArray(VISI, 'PreVis Files Timestamp', 2),
wbFormIDCk(RVIS, 'In PreVis File Of', [CELL]),
wbByteArray(PCMB, 'PreCombined Files Timestamp', 2),
wbStruct(XCLL, 'Lighting', [
wbByteColors('Ambient Color'),
wbByteColors('Directional Color'),
wbByteColors('Fog Color Near'),
wbFloat('Fog Near'),
wbFloat('Fog Far'),
wbInteger('Directional Rotation XY', itS32),
wbInteger('Directional Rotation Z', itS32),
wbFloat('Directional Fade'),
wbFloat('Fog Clip Distance'),
wbFloat('Fog Power'),
wbAmbientColors,
wbByteColors('Fog Color Far'),
wbFloat('Fog Max'),
wbFloat('Light Fade Begin'),
wbFloat('Light Fade End'),
wbInteger('Inherits', itU32, wbFlags([
{0x00000001} 'Ambient Color',
{0x00000002} 'Directional Color',
{0x00000004} 'Fog Color',
{0x00000008} 'Fog Near',
{0x00000010} 'Fog Far',
{0x00000020} 'Directional Rotation',
{0x00000040} 'Directional Fade',
{0x00000080} 'Clip Distance',
{0x00000100} 'Fog Power',
{0x00000200} 'Fog Max',
{0x00000400} 'Light Fade Distances'
])),
wbFloat('Near Height Mid'),
wbFloat('Near Height Range'),
wbByteColors('Fog Color High Near'),
wbByteColors('Fog Color High Far'),
wbFloat('High Density Scale'),
wbFloat('Fog Near Scale'),
wbFloat('Fog Far Scale'),
wbFloat('Fog High Near Scale'),
wbFloat('Fog High Far Scale'),
wbFloat('Far Height Mid'),
wbFloat('Far Height Range')
], cpNormal, False, nil, 11),
wbInteger(CNAM, 'Precombined Object Level XY', itU8),
wbInteger(ZNAM, 'Precombined Object Level Z', itU8),
wbByteArray(TVDT, 'Unknown', 0, cpNormal),
wbMaxHeightDataCELL,
wbFormIDCk(LTMP, 'Lighting Template', [LGTM, NULL], False, cpNormal, True),
{>>> XCLW sometimes has $FF7FFFFF and causes invalid floation point <<<}
wbFloat(XCLW, 'Water Height', cpNormal, False, 1, -1, nil, nil, 0, wbCELLXCLWGetConflictPriority),
wbArrayS(XCLR, 'Regions', wbFormIDCk('Region', [REGN])),
wbFormIDCk(XLCN, 'Location', [LCTN]),
wbByteArray(XWCN, 'Unknown', 0, cpIgnore), // leftover
wbStruct(XWCU, 'Water Velocity', [
wbFloat('X Offset'),
wbFloat('Y Offset'),
wbFloat('Z Offset'),
wbByteArray('Unknown', 4),
wbFloat('X Angle'),
wbFloat('Y Angle'),
wbFloat('Z Angle'),
wbByteArray('Unknown', 0)
]),
wbFormIDCk(XCWT, 'Water', [WATR]),
{--- Ownership ---}
wbXOWN,
wbXRNK,
wbFormIDCk(XILL, 'Lock List', [FLST, NPC_]),
wbStruct(XILW, 'Exterior LOD', [
wbFormIDCk('Worldspace', [WRLD]),
wbFloat('Offset X'),
wbFloat('Offset Y'),
wbFloat('Offset Z')
]),
wbString(XWEM, 'Water Environment Map'),
wbFormIDCk(XCCM, 'Sky/Weather from Region', [REGN]),
wbFormIDCk(XCAS, 'Acoustic Space', [ASPC]),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
wbFormIDCk(XCMO, 'Music Type', [MUSC]),
wbFormIDCk(XCIM, 'Image Space', [IMGS]),
wbFormIDCk(XGDR, 'God Rays', [GDRY]),
// those can be sorted I think, but makes copying records very slow since some cells have over 22000+ entries
// DLC01Lair01 "The Mechanist's Lair" [CELL:010008A3]
wbArrayS(XPRI, 'Physics References', wbFormIDCk('Reference', [REFR, PGRE, PHZD, PMIS, PARW, PBAR, PBEA, PCON, PFLA])),
wbStruct(XCRI, 'Combined References', [
wbInteger('Meshes Count', itU32),
wbInteger('References Count', itU32),
wbArrayS('Meshes', wbInteger('Combined Mesh', itU32, wbCombinedMeshIDToStr, wbCombinedMeshIDToInt), wbCELLCombinedMeshesCounter, cpNormal, False, nil, wbCELLCombinedMeshesAfterSet),
wbArrayS('References', wbStructSK([1, 0], 'Reference', [
wbFormIDCk('Reference', [REFR, PGRE, PHZD, PMIS, PARW, PBAR, PBEA, PCON, PFLA]),
wbInteger('Combined Mesh', itU32, wbCombinedMeshIDToStr, wbCombinedMeshIDToInt)
]), wbCELLCombinedRefsCounter, cpNormal, False, nil, wbCELLCombinedRefsAfterSet)
])
], True, wbCellAddInfo, cpNormal, False{, wbCELLAfterLoad});
wbRecord(CLAS, 'Class', [
wbEDID,
wbFULLReq,
wbDESCReq,
wbICON,
wbPRPS,
wbStruct(DATA, 'Data', [
wbByteArray('Unknown', 4),
wbFloat('Bleedout Default')
])
]);
wbRecord(CLMT, 'Climate', [
wbEDID,
wbArrayS(WLST, 'Weather Types', wbStructSK([0], 'Weather Type', [
wbFormIDCk('Weather', [WTHR, NULL]),
wbInteger('Chance', itS32),
wbFormIDCk('Global', [GLOB, NULL])
])),
wbString(FNAM, 'Sun Texture'),
wbString(GNAM, 'Sun Glare Texture'),
wbMODL,
wbStruct(TNAM, 'Timing', [
wbStruct('Sunrise', [
wbInteger('Begin', itU8, wbClmtTime),
wbInteger('End', itU8, wbClmtTime)
]),
wbStruct('Sunset', [
wbInteger('Begin', itU8, wbClmtTime),
wbInteger('End', itU8, wbClmtTime)
]),
wbInteger('Volatility', itU8),
wbInteger('Moons / Phase Length', itU8, wbClmtMoonsPhaseLength)
], cpNormal, True)
]);
wbRecord(SPGD, 'Shader Particle Geometry', [
wbEDID,
wbStruct(DATA, 'Data', [
wbFloat('Gravity Velocity'),
wbByteArray('Unknown', 4),
wbFloat('Rotation Velocity'),
wbByteArray('Unknown', 4),
wbFloat('Particle Size X'),
wbFloat('Center Offset Min'),
wbFloat('Particle Size Y'),
wbByteArray('Unknown', 4),
wbFloat('Center Offset Min'),
wbByteArray('Unknown', 4),
wbFloat('Center Offset Max'),
wbByteArray('Unknown', 4),
wbFloat('Initial Rotation'),
wbByteArray('Unknown', 4),
wbInteger('# of Subtextures X', itU32),
wbByteArray('Unknown', 4),
wbInteger('# of Subtextures Y', itU32),
wbByteArray('Unknown', 4),
wbInteger('Type', itU32, wbEnum([
'Rain',
'Snow'
])),
wbByteArray('Unknown', 4),
wbInteger('Box Size', itU32),
wbByteArray('Unknown', 4),
wbFloat('Particle Density'),
wbUnknown
], cpNormal, True, nil, 10),
wbString(MNAM, 'Particle Texture')
]);
wbRecord(RFCT, 'Visual Effect', [
wbEDID,
wbStruct(DATA, 'Effect Data', [
wbFormIDCK('Effect Art', [ARTO, NULL]),
wbFormIDCK('Shader', [EFSH, NULL]),
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Rotate to Face Target',
{0x00000002} 'Attach to Camera',
{0x00000004} 'Inherit Rotation'
]))
], cpNormal, True)
]);
wbRecord(CONT, 'Container',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00008000} 15, 'Has Distant LOD',
{0x00010000} 16, 'Random Anim Start',
{0x02000000} 25, 'Obstacle',
{0x04000000} 26, 'NavMesh Generation - Filter',
{0x08000000} 27, 'NavMesh Generation - Bounding Box',
{0x40000000} 30, 'NavMesh Generation - Ground'
])), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFULL,
wbMODL,
wbCOCT,
wbCNTOs,
wbDEST,
wbStruct(DATA, '', [
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Allow Sounds When Animation',
{0x02} 'Respawns',
{0x04} 'Show Owner'
])),
wbFloat('Weight')
], cpNormal, True),
wbKSIZ,
wbKWDAs,
wbFTYP,
wbPRPS,
wbNTRM,
wbFormIDCk(SNAM, 'Sound - Open', [SNDR]),
wbFormIDCk(QNAM, 'Sound - Close', [SNDR]),
wbFormIDCk(TNAM, 'Sound - Take All', [SNDR]),
wbFormIDCk(ONAM, 'Filter List', [FLST])
], True, nil, cpNormal, False, nil, wbContainerAfterSet);
wbAIDT :=
wbStruct(AIDT, 'AI Data', [
{00} wbInteger('Aggression', itU8, wbEnum([
'Unaggressive',
'Aggressive',
'Very Aggressive',
'Frenzied'
])),
{01} wbInteger('Confidence', itU8, wbEnum([
'Cowardly',
'Cautious',
'Average',
'Brave',
'Foolhardy'
])),
{02} wbInteger('Energy Level', itU8),
{03} wbInteger('Responsibility', itU8, wbEnum([
'Any crime',
'Violence against enemies',
'Property crime only',
'No crime'
])),
{04} wbInteger('Mood', itU8, wbEnum([
'Neutral',
'Angry',
'Fear',
'Happy',
'Sad',
'Surprised',
'Puzzled',
'Disgusted'
])),
wbInteger('Assistance', itU8, wbEnum([
'Helps Nobody',
'Helps Allies',
'Helps Friends and Allies'
])),
wbStruct('Aggro', [
wbInteger('Aggro Radius Behavior', itU8, wbBoolEnum),
wbInteger('Unknown', itU8),
wbInteger('Warn', itU32),
wbInteger('Warn/Attack', itU32),
wbInteger('Attack', itU32)
]),
wbByteArray('Unknown', 4)
], cpNormal, True, nil{wbActorTemplateUseAIData});
wbRecord(CSTY, 'Combat Style',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00080000} 19, 'Allow Dual Wielding'
])), [
wbEDID,
wbStruct(CSGD, 'General', [
wbFloat('Offensive Mult'),
wbFloat('Defensive Mult'),
wbFloat('Group Offensive Mult'),
wbFloat('Equipment Score Mult - Melee'),
wbFloat('Equipment Score Mult - Magic'),
wbFloat('Equipment Score Mult - Ranged'),
wbFloat('Equipment Score Mult - Shout'),
wbFloat('Equipment Score Mult - Unarmed'),
wbFloat('Equipment Score Mult - Staff'),
wbFloat('Avoid Threat Chance'),
wbFloat('Dodge Threat Chance'),
wbFloat('Evade Threat Chance')
], cpNormal, True),
wbUnknown(CSMD, cpIgnore),
wbStruct(CSME, 'Melee', [
wbFloat('Attack Staggered Mult'),
wbFloat('Power Attack Staggered Mult'),
wbFloat('Power Attack Blocking Mult'),
wbFloat('Bash Mult'),
wbFloat('Bash Recoil Mult'),
wbFloat('Bash Attack Mult'),
wbFloat('Bash Power Attack Mult'),
wbFloat('Special Attack Mult'),
wbFloat('Block When Staggered Mult'),
wbFloat('Attack When Staggered Mult')
], cpNormal, True, nil, 9),
wbFloat(CSRA, 'Ranged Accuracy Mult', cpNormal, True),
wbStruct(CSCR, 'Close Range', [
wbFloat('Dueling - Circle Mult'),
wbFloat('Dueling - Fallback Mult'),
wbFloat('Flanking - Flank Distance'),
wbFloat('Flanking - Stalk Time'),
wbFloat('Charging - Charge Distance'),
wbFloat('Charging - Throw Probability'),
wbFloat('Charging - Sprint Fast Probability'),
wbFloat('Charging - Sideswipe Probability'),
wbFloat('Charging - Disengane Probability'),
wbInteger('Charging - Throw Max Targets', itU32),
wbFloat('Flanking - Flank Variance')
], cpNormal, True),
wbStruct(CSLR, 'Long Range', [
wbFloat('Strafe Mult'),
wbFloat('Adjust Range Mult'),
wbFloat('Crouch Mult'),
wbFloat('Wait Mult'),
wbFloat('Range Mult')
], cpNormal, True, nil, 3),
wbFloat(CSCV, 'Cover Search Distance Mult', cpNormal, True),
wbStruct(CSFL, 'Flight', [
wbFloat('Hover Chance'),
wbFloat('Dive Bomb Chance'),
wbFloat('Ground Attack Chance'),
wbFloat('Hover Time'),
wbFloat('Ground Attack Time'),
wbFloat('Perch Attack Chance'),
wbFloat('Perch Attack Time'),
wbFloat('Flying Attack Chance')
], cpNormal, True),
wbInteger(DATA, 'Flags', itU32, wbFlags([
{0x01} 'Dueling',
{0x02} 'Flanking',
{0x04} 'Allow Dual Wielding',
{0x08} 'Charging',
{0x10} 'Retarget Any Nearby Melee Target',
{0x20} 'Unknown 5'
]), cpNormal, True)
]);
end;
procedure DefineFO4d;
begin
wbRecord(DIAL, 'Dialog Topic', [
wbEDID,
wbFULL,
wbFloat(PNAM, 'Priority', cpNormal, True, 1, -1, nil, nil, 50.0),
wbFormIDCk(BNAM, 'Branch', [DLBR]),
wbFormIDCk(QNAM, 'Quest', [QUST], False, cpNormal, False),
wbFormIDCk(KNAM, 'Keyword', [KYWD]),
wbStruct(DATA, 'Data', [
// this should not be named Flags since TwbFile.BuildReachable
// expects Top-Level flag here from FNV
wbInteger('Topic Flags', itU8, wbFlags([
'Do All Before Repeating',
'Unknown 1',
'Unknown 2'
]), cpNormal, True),
wbInteger('Category', itU8, wbEnum([
{0} 'Player',
{1} 'Command',
{2} 'Scene',
{3} 'Combat',
{4} 'Favor',
{5} 'Detection',
{6} 'Service',
{7} 'Miscellaneous'
])),
wbInteger('Subtype', itU16, wbEnum([
{ 0} 'Custom',
{ 1} 'ForceGreet',
{ 2} 'Rumors',
{ 3} 'Custom',
{ 4} 'Call',
{ 5} 'Follow',
{ 6} 'Move',
{ 7} 'Attack',
{ 8} 'Inspect',
{ 9} 'Retrieve',
{10} 'Stay',
{11} 'Release',
{12} 'ShowRelationships',
{13} 'Reject',
{14} 'Heal',
{15} 'Assign',
{16} 'Enter',
{17} 'Custom',
{18} 'Show',
{19} 'Agree',
{20} 'Refuse',
{21} 'ExitFavorState',
{22} 'MoralRefusal',
{23} 'Trade',
{24} 'PathingRefusal',
{25} 'Attack',
{26} 'PowerAttack',
{27} 'Bash',
{28} 'Hit',
{29} 'Flee',
{30} 'BleedOut',
{31} 'AvoidThreat',
{32} 'Death',
{33} 'Block',
{34} 'Taunt',
{35} 'ThrowGrenade',
{36} 'AllyKilled',
{37} 'OrderFallback',
{38} 'OrderMoveUp',
{39} 'OrderFlank',
{40} 'OrderTakeCover',
{41} 'Retreat',
{42} 'CoverMe',
{43} 'SuppressiveFire',
{44} 'CrippledLimb',
{45} 'PairedAttack',
{46} 'Steal',
{47} 'Yield',
{48} 'AcceptYield',
{49} 'PickpocketCombat',
{50} 'Assault',
{51} 'Murder',
{52} 'AssaultNC',
{53} 'MurderNC',
{54} 'PickpocketNC',
{55} 'StealFromNC',
{56} 'TrespassAgainstNC',
{57} 'Trespass',
{58} 'UNUSED01',
{59} 'VoicePowerStartShort',
{60} 'VoicePowerStartLong',
{61} 'VoicePowerEndShort',
{62} 'VoicePowerEndLong',
{63} 'AlertIdle',
{64} 'LostIdle',
{65} 'NormalToAlert',
{66} 'NormalToCombat',
{67} 'NormalToLost',
{68} 'AlertToNormal',
{69} 'AlertToCombat',
{70} 'CombatToNormal',
{71} 'CombatToLost',
{72} 'LostToNormal',
{73} 'LostToCombat',
{74} 'DetectFriendDie',
{75} 'ServiceRefusal',
{76} 'Repair',
{77} 'Travel',
{78} 'Training',
{79} 'BarterExit',
{80} 'RepairExit',
{81} 'Recharge',
{82} 'RechargeExit',
{83} 'TrainingExit',
{84} 'ObserveCombat',
{85} 'NoticeCorpse',
{86} 'TimeToGo',
{87} 'Goodbye',
{88} 'Hello',
{89} 'SwingMeleeWeapon',
{90} 'ShootBow',
{91} 'ZKeyObject',
{92} 'Jump',
{93} 'KnockOverObject',
{94} 'DestroyObject',
{95} 'StandonFurniture',
{96} 'LockedObject',
{97} 'PickpocketTopic',
{98} 'PursueIdleTopic',
{99} 'SharedInfo',
{100} 'SceneChoice',
{101} 'PlayerCastProjectileSpell',
{102} 'PlayerCastSelfSpell',
{103} 'PlayerShout',
{104} 'Idle',
{105} 'EnterSprintBreath',
{106} 'EnterBowZoomBreath',
{107} 'ExitBowZoomBreath',
{108} 'ActorCollidewithActor',
{109} 'PlayerinIronSights',
{110} 'OutofBreath',
{111} 'CombatGrunt',
{112} 'LeaveWaterBreath',
{113} 'ImpatientPostitive',
{114} 'ImpatientNegative',
{115} 'ImpatientNeutral',
{116} 'ImpatientQuestion',
{117} 'WaitingForPlayerInput',
{118} 'Greeting',
{119} 'PlayerActivateDoor',
{120} 'PlayerActivateTerminals',
{121} 'PlayerActivateFurniture',
{122} 'PlayerActivateActivators',
{123} 'PlayerActivateContainer',
{124} 'PlayerAquireFeaturedItem'
]))
]),
wbString(SNAM, 'Subtype Name', 4),
wbInteger(TIFC, 'Info Count', itU32, nil, cpBenign)
]);
wbRecord(DOOR, 'Door',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000010} 4, 'Non Occluder',
{0x00008000} 15, 'Has Distant LOD',
{0x00010000} 16, 'Random Anim Start',
{0x00800000} 23, 'Is Marker'
])), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFULL,
wbMODL,
wbDEST,
wbKSIZ,
wbKWDAs,
wbNTRM,
wbFormIDCk(SNAM, 'Sound - Open', [SNDR]),
wbFormIDCk(ANAM, 'Sound - Close', [SNDR]),
wbFormIDCk(BNAM, 'Sound - Loop', [SNDR]),
wbInteger(FNAM, 'Flags', itU8, wbFlags([
'',
'Automatic',
'Hidden',
'Minimal Use',
'Sliding',
'Do Not Open in Combat Search',
'No "To" Text'
]), cpNormal, True),
wbLStringKC(ONAM, 'Alternate Text - Open', 0, cpTranslate),
wbLStringKC(CNAM, 'Alternate Text - Close', 0, cpTranslate)
]);
wbBlendModeEnum := wbEnum([
'',
'Zero',
'One',
'Source Color',
'Source Inverse Color',
'Source Alpha',
'Source Inverted Alpha',
'Dest Alpha',
'Dest Inverted Alpha',
'Dest Color',
'Dest Inverse Color',
'Source Alpha SAT'
]);
wbBlendOpEnum := wbEnum([
'',
'Add',
'Subtract',
'Reverse Subtract',
'Minimum',
'Maximum'
]);
wbZTestFuncEnum := wbEnum([
'',
'',
'',
'Equal To',
'',
'Greater Than',
'',
'Greater Than or Equal To'
]);
wbRecord(EFSH, 'Effect Shader', [
wbEDID,
wbString(ICON, 'Fill Texture'),
wbString(ICO2, 'Particle Shader Texture'),
wbString(NAM7, 'Holes Texture'),
wbString(NAM8, 'Membrane Palette Texture'),
wbString(NAM9, 'Particle Palette Texture'),
wbUnknown(DATA), // if form version < 62, ignored otherwise
// format depends on Form Version (appear with form version 62, changed in form version 106), different for older records starting from the first field
wbUnion(DNAM, '', wbEFSHFormatDecider, [
wbStruct('Data', [
wbInteger('Membrane Shader - Source Blend Mode', itU32, wbBlendModeEnum),
wbInteger('Membrane Shader - Blend Operation', itU32, wbBlendOpEnum),
wbInteger('Membrane Shader - Z Test Function', itU32, wbZTestFuncEnum),
wbByteColors('Fill/Texture Effect - Color Key 1'),
wbFloat('Fill/Texture Effect - Alpha Fade In Time'),
wbFloat('Fill/Texture Effect - Full Alpha Time'),
wbFloat('Fill/Texture Effect - Alpha Fade Out Time'),
wbFloat('Fill/Texture Effect - Presistent Alpha Ratio'),
wbFloat('Fill/Texture Effect - Alpha Pulse Amplitude'),
wbFloat('Fill/Texture Effect - Alpha Pulse Frequency'),
wbFloat('Fill/Texture Effect - Texture Animation Speed (U)'),
wbFloat('Fill/Texture Effect - Texture Animation Speed (V)'),
wbFloat('Edge Effect - Fall Off'),
wbByteColors('Edge Effect - Color'),
wbFloat('Edge Effect - Alpha Fade In Time'),
wbFloat('Edge Effect - Full Alpha Time'),
wbFloat('Edge Effect - Alpha Fade Out Time'),
wbFloat('Edge Effect - Persistent Alpha Ratio'),
wbFloat('Edge Effect - Alpha Pulse Amplitude'),
wbFloat('Edge Effect - Alpha Pulse Frequency'),
wbFloat('Fill/Texture Effect - Full Alpha Ratio'),
wbFloat('Edge Effect - Full Alpha Ratio'),
wbInteger('Membrane Shader - Dest Blend Mode', itU32, wbBlendModeEnum),
wbFloat('Holes Animation - Start Time'),
wbFloat('Holes Animation - End Time'),
wbFloat('Holes Animation - Start Value'),
wbFloat('Holes Animation - End Value'),
wbFormIDCk('Ambient Sound', [SNDR, NULL]),
wbByteColors('Fill/Texture Effect - Color Key 2'),
wbByteColors('Fill/Texture Effect - Color Key 3'),
wbInteger('Unknown', itU8),
wbStruct('Fill/Texture Effect - Color Key Scale/Time', [
wbFloat('Color Key 1 - Scale'),
wbFloat('Color Key 2 - Scale'),
wbFloat('Color Key 3 - Scale'),
wbFloat('Color Key 1 - Time'),
wbFloat('Color Key 2 - Time'),
wbFloat('Color Key 3 - Time')
]),
wbInteger('Flags', itU32, wbFlags([
'No Membrane Shader',
'Membrane Grayscale Color',
'Membrane Grayscale Alpha',
'No Particle Shader',
'Edge Effect - Inverse',
'Affect Skin Only',
'Texture Effect - Ignore Alpha',
'Texture Effect - Project UVs',
'Ignore Base Geometry Alpha',
'Texture Effect - Lighting',
'Texture Effect - No Weapons',
'Use Alpha Sorting',
'Prefer Dismembered Limbs',
'Unknown 13',
'Unknown 14',
'Particle Animated',
'Particle Grayscale Color',
'Particle Grayscale Alpha',
'Unknown 18',
'Unknown 19',
'Unknown 20',
'Unknown 21',
'Unknown 22',
'Unknown 23',
'Use Blood Geometry (Weapons Only)'
])),
wbFloat('Fill/Texture Effect - Texture Scale (U)'),
wbFloat('Fill/Texture Effect - Texture Scale (V)')
]),
wbStruct('Data (old format)', [
wbByteArray('Unknown', 1),
wbInteger('Membrane Shader - Source Blend Mode', itU32, wbBlendModeEnum),
wbInteger('Membrane Shader - Blend Operation', itU32, wbBlendOpEnum),
wbInteger('Membrane Shader - Z Test Function', itU32, wbZTestFuncEnum),
wbByteColors('Fill/Texture Effect - Color Key 1'),
wbFloat('Fill/Texture Effect - Alpha Fade In Time'),
wbFloat('Fill/Texture Effect - Full Alpha Time'),
wbFloat('Fill/Texture Effect - Alpha Fade Out Time'),
wbFloat('Fill/Texture Effect - Presistent Alpha Ratio'),
wbFloat('Fill/Texture Effect - Alpha Pulse Amplitude'),
wbFloat('Fill/Texture Effect - Alpha Pulse Frequency'),
wbFloat('Fill/Texture Effect - Texture Animation Speed (U)'),
wbFloat('Fill/Texture Effect - Texture Animation Speed (V)'),
wbFloat('Edge Effect - Fall Off'),
wbByteColors('Edge Effect - Color'),
wbFloat('Edge Effect - Alpha Fade In Time'),
wbFloat('Edge Effect - Full Alpha Time'),
wbFloat('Edge Effect - Alpha Fade Out Time'),
wbFloat('Edge Effect - Persistent Alpha Ratio'),
wbFloat('Edge Effect - Alpha Pulse Amplitude'),
wbFloat('Edge Effect - Alpha Pulse Frequency'),
wbFloat('Fill/Texture Effect - Full Alpha Ratio'),
wbFloat('Edge Effect - Full Alpha Ratio'),
wbInteger('Membrane Shader - Dest Blend Mode', itU32, wbBlendModeEnum),
wbInteger('Particle Shader - Source Blend Mode', itU32, wbBlendModeEnum),
wbInteger('Particle Shader - Blend Operation', itU32, wbBlendOpEnum),
wbInteger('Particle Shader - Z Test Function', itU32, wbZTestFuncEnum),
wbInteger('Particle Shader - Dest Blend Mode', itU32, wbBlendModeEnum),
wbFloat('Particle Shader - Particle Birth Ramp Up Time'),
wbFloat('Particle Shader - Full Particle Birth Time'),
wbFloat('Particle Shader - Particle Birth Ramp Down Time'),
wbFloat('Particle Shader - Full Particle Birth Ratio'),
wbFloat('Particle Shader - Persistant Particle Count'),
wbFloat('Particle Shader - Particle Lifetime'),
wbFloat('Particle Shader - Particle Lifetime +/-'),
wbFloat('Particle Shader - Initial Speed Along Normal'),
wbFloat('Particle Shader - Acceleration Along Normal'),
wbFloat('Particle Shader - Initial Velocity #1'),
wbFloat('Particle Shader - Initial Velocity #2'),
wbFloat('Particle Shader - Initial Velocity #3'),
wbFloat('Particle Shader - Acceleration #1'),
wbFloat('Particle Shader - Acceleration #2'),
wbFloat('Particle Shader - Acceleration #3'),
wbFloat('Particle Shader - Scale Key 1'),
wbFloat('Particle Shader - Scale Key 2'),
wbFloat('Particle Shader - Scale Key 1 Time'),
wbFloat('Particle Shader - Scale Key 2 Time'),
wbByteColors('Color Key 1 - Color'),
wbByteColors('Color Key 2 - Color'),
wbByteColors('Color Key 3 - Color'),
wbFloat('Color Key 1 - Color Alpha'),
wbFloat('Color Key 2 - Color Alpha'),
wbFloat('Color Key 3 - Color Alpha'),
wbFloat('Color Key 1 - Color Key Time'),
wbFloat('Color Key 2 - Color Key Time'),
wbFloat('Color Key 3 - Color Key Time'),
wbFloat('Particle Shader - Initial Speed Along Normal +/-'),
wbFloat('Particle Shader - Initial Rotation (deg)'),
wbFloat('Particle Shader - Initial Rotation (deg) +/-'),
wbFloat('Particle Shader - Rotation Speed (deg/sec)'),
wbFloat('Particle Shader - Rotation Speed (deg/sec) +/-'),
wbFormIDCk('Addon Models', [DEBR, NULL]),
wbFloat('Holes - Start Time'),
wbFloat('Holes - End Time'),
wbFloat('Holes - Start Val'),
wbFloat('Holes - End Val'),
wbFloat('Edge Width (alpha units)'),
wbByteColors('Edge Color'),
wbFloat('Explosion Wind Speed'),
wbInteger('Texture Count U', itU32),
wbInteger('Texture Count V', itU32),
wbFloat('Addon Models - Fade In Time'),
wbFloat('Addon Models - Fade Out Time'),
wbFloat('Addon Models - Scale Start'),
wbFloat('Addon Models - Scale End'),
wbFloat('Addon Models - Scale In Time'),
wbFloat('Addon Models - Scale Out Time'),
wbFormIDCk('Ambient Sound', [SNDR, NULL]),
wbByteColors('Fill/Texture Effect - Color Key 2'),
wbByteColors('Fill/Texture Effect - Color Key 3'),
wbStruct('Fill/Texture Effect - Color Key Scale/Time', [
wbFloat('Color Key 1 - Scale'),
wbFloat('Color Key 2 - Scale'),
wbFloat('Color Key 3 - Scale'),
wbFloat('Color Key 1 - Time'),
wbFloat('Color Key 2 - Time'),
wbFloat('Color Key 3 - Time')
]),
wbFloat('Color Scale'),
wbFloat('Birth Position Offset'),
wbFloat('Birth Position Offset Range +/-'),
wbStruct('Particle Shader Animated', [
wbInteger('Start Frame', itU32),
wbInteger('Start Frame Variation', itU32),
wbInteger('End Frame', itU32),
wbInteger('Loop Start Frame', itU32),
wbInteger('Loop Start Variation', itU32),
wbInteger('Frame Count', itU32),
wbInteger('Frame Count Variation', itU32)
]),
wbInteger('Flags', itU32, wbFlags([
'No Membrane Shader',
'Membrane Grayscale Color',
'Membrane Grayscale Alpha',
'No Particle Shader',
'Edge Effect Inverse',
'Affect Skin Only',
'Ignore Alpha',
'Project UVs',
'Ignore Base Geometry Alpha',
'Lighting',
'No Weapons',
'Unknown 11',
'Unknown 12',
'Unknown 13',
'Unknown 14',
'Particle Animated',
'Particle Grayscale Color',
'Particle Grayscale Alpha',
'Unknown 18',
'Unknown 19',
'Unknown 20',
'Unknown 21',
'Unknown 22',
'Unknown 23',
'Use Blood Geometry'
])),
wbFloat('Fill/Texture Effect - Texture Scale (U)'),
wbFloat('Fill/Texture Effect - Texture Scale (V)'),
wbInteger('Scene Graph Emit Depth Limit (unused)', itU16)
])
], cpNormal, True),
wbMODL
]);
wbRecord(ENCH, 'Object Effect', [
wbEDID,
wbOBNDReq,
wbFULL,
wbStruct(ENIT, 'Effect Data', [
wbInteger('Enchantment Cost', itS32),
wbInteger('Flags', itU32, wbFlags([
'No Auto-Calc',
'',
'Extend Duration On Recast'
])),
wbInteger('Cast Type', itU32, wbCastEnum),
wbInteger('Enchantment Amount', itS32),
wbInteger('Target Type', itU32, wbTargetEnum),
wbInteger('Enchant Type', itU32, wbEnum([], [
$06, 'Enchantment',
$0C, 'Staff Enchantment'
])),
wbFloat('Charge Time'),
wbFormIDCk('Base Enchantment', [ENCH, NULL]),
wbFormIDCk('Worn Restrictions', [FLST, NULL])
], cpNormal, True, nil, 8),
wbEffectsReq
]);
{wbRecord(EYES, 'Eyes', [
wbEDID
]);}
wbRecord(FACT, 'Faction', [
wbEDID,
wbFULL,
wbRArrayS('Relations',
wbStructSK(XNAM, [0], 'Relation', [
wbFormIDCkNoReach('Faction', [FACT, RACE]),
wbInteger('Modifier', itS32),
wbInteger('Group Combat Reaction', itU32, wbEnum([
{0x00000001} 'Neutral',
{0x00000002} 'Enemy',
{0x00000004} 'Ally',
{0x00000008} 'Friend'
]))
])),
wbStruct(DATA, 'Flags', [
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Hidden From NPC',
{0x00000002} 'Special Combat',
{0x00000004} 'Unknown 3',
{0x00000008} 'Unknown 4',
{0x00000010} 'Unknown 5',
{0x00000020} 'Unknown 6',
{0x00000040} 'Track Crime',
{0x00000080} 'Ignore Crimes: Murder',
{0x00000100} 'Ignore Crimes: Assault',
{0x00000200} 'Ignore Crimes: Stealing',
{0x00000400} 'Ignore Crimes: Trespass',
{0x00000800} 'Do Not Report Crimes Against Members',
{0x00001000} 'Crime Gold - Use Defaults',
{0x00002000} 'Ignore Crimes: Pickpocket',
{0x00004000} 'Vendor',
{0x00008000} 'Can Be Owner',
{0x00010000} 'Ignore Crimes: Werewolf (unused)'
]))
], cpNormal, True, nil, 1),
wbFormIDCk(JAIL, 'Exterior Jail Marker', [REFR]),
wbFormIDCk(WAIT, 'Follower Wait Marker', [REFR]),
wbFormIDCk(STOL, 'Stolen Goods Container', [REFR]),
wbFormIDCk(PLCN, 'Player Inventory Container', [REFR]),
wbFormIDCk(CRGR, 'Shared Crime Faction List', [FLST]),
wbFormIDCk(JOUT, 'Jail Outfit', [OTFT]),
wbStruct(CRVA, 'Crime Values', [
wbInteger('Arrest', itU8, wbBoolEnum),
wbInteger('Attack On Sight', itU8, wbBoolEnum),
wbInteger('Murder', itU16),
wbInteger('Assault', itU16),
wbInteger('Trespass', itU16),
wbInteger('Pickpocket', itU16),
wbInteger('Unknown', itU16),
wbFloat('Steal Multiplier'),
wbInteger('Escape', itU16),
wbInteger('Werewolf (unused)', itU16)
], cpNormal, False, nil, 7),
wbRStructsSK('Ranks', 'Rank', [0], [
wbInteger(RNAM, 'Rank#', itU32),
wbLString(MNAM, 'Male Title', 0, cpTranslate),
wbLString(FNAM, 'Female Title', 0, cpTranslate),
wbString(INAM, 'Insignia (unused)')
], []),
wbFormIDCk(VEND, 'Vendor Buy/Sell List', [FLST]),
wbFormIDCk(VENC, 'Merchant Container', [REFR]),
wbStruct(VENV, 'Vendor Values', [
wbInteger('Start Hour', itU16),
wbInteger('End Hour', itU16),
wbInteger('Radius', itU16),
wbByteArray('Unknown 1', 2),
wbInteger('Buys Stolen Items', itU8, wbBoolEnum),
wbInteger('Buy/Sell Everything Not In List?', itU8, wbBoolEnum),
wbInteger('Buys NonStolen Items', itU8, wbBoolEnum),
wbInteger('Unknown', itU8)
]),
wbPLVD,
wbCITC,
wbCTDAsCount
], False, nil, cpNormal, False, nil {wbFACTAfterLoad}, wbConditionsAfterSet);
wbRecord(FURN, 'Furniture',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000004} 2, 'Unknown 2',
{0x00000010} 4, 'Unknown 4',
{0x00000080} 7, 'Is Perch',
{0x00002000} 13, 'Unknown 13',
{0x00008000} 15, 'Has Distant LOD',
{0x00010000} 16, 'Random Anim Start',
{0x00800000} 23, 'Is Marker',
{0x02000000} 25, 'Power Armor',
{0x10000000} 28, 'Must Exit To Talk',
{0x20000000} 29, 'Child Can Use'
])), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFULL,
wbMODL,
wbDEST,
wbKSIZ,
wbKWDAs,
wbPRPS,
wbNTRM,
wbFTYP,
wbUnknown(PNAM),
wbFormIDCk(WNAM, 'Drinking Water Type', [WATR]),
wbATTX,
wbInteger(FNAM, 'Flags', itU16, wbFlags([
{0x0001} 'Unknown 0',
{0x0002} 'Ignored By Sandbox'
])),
wbCITC,
wbCTDAsCount,
wbCOCT,
wbCNTOs,
wbMNAMFurnitureMarker,
wbStruct(WBDT, 'Workbench Data', [
wbInteger('Bench Type', itU8, wbEnum([
{0} 'None',
{1} 'Create Object', // used only for MS11Workbench [FURN:00091FD5]
{2} 'Weapons', // used for the Weapons (plural) workbench
{3} 'Enchanting (unused)', // not used
{4} 'Enchanting Experiment (unused)', // not used
{5} 'Alchemy', // used for Chemistry and Cooking, so Alchemy is probably okay
{6} 'Alchemy Experiment (unused)', // not used
{7} 'Armor', // FO4 calls this the Armor workbench, no mention of Smithing
{8} 'Power Armor', // used for Power Armor stations
{9} 'Robot Mod' // used for Robot stations
])),
wbInteger('Uses Skill', itS8, wbSkillEnum)
], cpNormal, True, nil, 1),
wbFormIDCk(NAM1, 'Associated Form', [ARMO, WEAP, PERK, SPEL, HAZD]),
wbRArray('Markers', wbRStruct('Marker', [
wbInteger(ENAM, 'Marker Index', itS32),
wbStruct(NAM0, 'Disabled Entry Points', [
wbByteArray('Unknown', 2),
wbInteger('Disabled Points', itU16, wbFurnitureEntryTypeFlags)
])
//wbFormIDCk(FNMK, 'Marker Keyword', [KYWD, NULL])
], [])),
wbRArray('Marker Entry Points', wbStruct(FNPR, 'Marker', [
wbInteger('Type', itU16, wbFurnitureAnimTypeEnum),
wbInteger('Entry Points', itU16, wbFurnitureEntryTypeFlags)
])),
wbString(XMRK, 'Marker Model'),
wbSNAMMarkerParams,
wbNVNM,
wbAPPR,
wbObjectTemplate
], False, nil, cpNormal, False, nil, wbKeywordsAfterSet);
wbRecord(GLOB, 'Global',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000040} 6, 'Constant'
])), [
wbEDID,
wbInteger(FNAM, 'Type', itU8, wbEnum([], [
0, 'Unknown 0',
Ord('s'), 'Short',
Ord('l'), 'Long',
Ord('f'), 'Float',
Ord('b'), 'Boolean'
]), cpNormal, True),
wbFloat(FLTV, 'Value', cpNormal, True)
]);
wbRecord(GMST, 'Game Setting', [
wbString(EDID, 'Editor ID', 0, cpCritical, True, nil, wbGMSTEDIDAfterSet),
wbUnion(DATA, 'Value', wbGMSTUnionDecider, [
wbLString('Name', 0, cpTranslate),
wbInteger('Int', itS32),
wbFloat('Float'),
wbInteger('Bool', itU32, wbBoolEnum)
], cpNormal, True)
]);
wbRecord(KYWD, 'Keyword',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00080000} {15} 15, 'Restricted'
])), [
wbEDID,
wbCNAM,
wbString(DNAM, 'Notes'),
wbInteger(TNAM, 'Type', itU32, wbKeywordTypeEnum),
wbFormIDCk(DATA, 'Attraction Rule', [AORU]),
wbFULL,
wbString(NNAM, 'Display Name') {Legacy record replaced with FULL}
]);
end;
procedure DefineFO4e;
begin
wbRecord(LCRT, 'Location Reference Type', [
wbEDID,
wbCNAM,
wbUnknown(TNAM)
]);
wbRecord(AACT, 'Action',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00080000} {15} 15, 'Restricted'
])), [
wbEDID,
wbCNAM,
wbString(DNAM, 'Notes'),
wbInteger(TNAM, 'Type', itU32, wbKeywordTypeEnum),
wbFormIDCk(DATA, 'Attraction Rule', [AORU]),
wbFULL
]);
wbRecord(TXST, 'Texture Set', [
wbEDID,
wbOBNDReq,
wbRStruct('Textures (RGB/A)', [
wbString(TX00, 'Difuse'),
wbString(TX01, 'Normal/Gloss'),
wbString(TX03, 'Glow'),
wbString(TX04, 'Height'),
wbString(TX05, 'Environment'),
wbString(TX02, 'Wrinkles'), {TX05 TX02 TX06 Yes this has to go here}
wbString(TX06, 'Multilayer'),
wbString(TX07, 'Smooth Spec')
], []),
wbDODT,
wbInteger(DNAM, 'Flags', itU16, wbFlags([
{0x0001} 'No Specular Map',
{0x0002} 'Facegen Textures',
{0x0004} 'Has Model Space Normal Map'
]), cpNormal, True),
wbString(MNAM, 'Material')
]);
wbRecord(HDPT, 'Head Part',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000004} 2, 'Non-Playable'
])), [
wbEDID,
wbFULL,
wbMODL,
wbInteger(DATA, 'Flags', itU8, wbFlags([
{0x01} 'Playable',
{0x02} 'Male',
{0x04} 'Female',
{0x10} 'Is Extra Part',
{0x20} 'Use Solid Tint',
{0x40} 'Uses Body Texture'
]), cpNormal, True),
wbInteger(PNAM, 'Type', itU32, wbEnum([
'Misc',
'Face',
'Eyes',
'Hair',
'Facial Hair',
'Scar',
'Eyebrows',
'Meatcaps',
'Teeth',
'Head Rear'
])),
wbRArrayS('Extra Parts',
wbFormIDCk(HNAM, 'Part', [HDPT])
),
wbRStructs('Parts', 'Part', [
wbInteger(NAM0, 'Part Type', itU32, wbEnum([
'Race Morph',
'Tri',
'Chargen Morph'
])),
wbString(NAM1, 'Filename', 0, cpTranslate, True)
], []),
wbFormIDCk(TNAM, 'Texture Set', [TXST]),
wbFormIDCk(CNAM, 'Color', [CLFM]),
wbFormIDCk(RNAM, 'Valid Races', [FLST]),
wbCTDAs
]);
wbRecord(ASPC, 'Acoustic Space', [
wbEDID,
wbOBNDReq,
wbFormIDCk(SNAM, 'Looping Sound', [SNDR]),
wbFormIDCk(RDAT, 'Use Sound from Region (Interiors Only)', [REGN]),
wbFormIDCk(BNAM, 'Environment Type', [REVB]),
wbInteger(XTRI, 'Is Interior', itU8, wbBoolEnum, cpNormal, True),
wbInteger(WNAM, 'Weather Attenuation (dB)', itU16, wbDiv(100))
]);
wbRecord(MSTT, 'Moveable Static',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000100} 8, 'Must Update Anims',
{0x00000200} 9, 'Hidden From Local Map',
{0x00000800} 11, 'Used As Platform',
{0x00002000} 13, 'Pack-In Use Only',
{0x00008000} 15, 'Has Distant LOD',
{0x00010000} 16, 'Random Anim Start',
{0x00080000} 19, 'Has Currents',
{0x02000000} 25, 'Obstacle',
{0x04000000} 26, 'NavMesh Generation - Filter',
{0x08000000} 27, 'NavMesh Generation - Bounding Box',
{0x40000000} 30, 'NavMesh Generation - Ground'
])), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFULL,
wbMODL,
wbDEST,
wbKSIZ,
wbKWDAs,
wbPRPS,
wbInteger(DATA, 'On Local Map', itU8, wbBoolEnum, cpNormal, True),
wbFormIDCk(SNAM, 'Looping Sound', [SNDR])
]);
end;
procedure DefineFO4f;
begin
wbRecord(IDLM, 'Idle Marker',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x20000000} 29, 'Child Can Use'
])), [
wbEDID,
wbOBNDReq,
wbKSIZ,
wbKWDAs,
wbInteger(IDLF, 'Flags', itU8, wbFlags([
'Run in Sequence',
'Unknown 1',
'Do Once',
'Unknown 3',
'Ignored by Sandbox'
]), cpNormal, False),
wbInteger(IDLC, 'Animation Count', itU8, nil, cpBenign),
wbFloat(IDLT, 'Idle Timer Setting', cpNormal, False),
wbArray(IDLA, 'Animations', wbFormIDCk('Animation', [IDLE]), 0, nil, wbIDLAsAfterSet, cpNormal, False),
wbFormIDCk(QNAM, 'Unknown', [KYWD]),
wbMODL
], False, nil, cpNormal, False, nil, wbAnimationsAfterSet);
wbRecord(PROJ, 'Projectile', [
wbEDID,
wbOBNDReq,
wbFULL,
wbMODL,
wbDEST,
wbByteArray(DATA, 'Unused', 0, cpIgnore),
wbStruct(DNAM, 'Data', [
wbInteger('Flags', itU16, wbFlags([
{0x00001} 'Hitscan',
{0x00002} 'Explosion',
{0x00004} 'Alt. Trigger',
{0x00008} 'Muzzle Flash',
{0x00010} 'Unknown 4',
{0x00020} 'Can Be Disabled',
{0x00040} 'Can Be Picked Up',
{0x00080} 'Supersonic',
{0x00100} 'Pins Limbs',
{0x00200} 'Pass Through Small Transparent',
{0x00400} 'Disable Combat Aim Correction',
{0x00800} 'Penetrates Geometry',
{0x01000} 'Continuous Update',
{0x02000} 'Seeks Target'
])),
wbInteger('Type', itU16, wbEnum([], [
$01, 'Missile',
$02, 'Lobber',
$04, 'Beam',
$08, 'Flame',
$10, 'Cone',
$20, 'Barrier',
$40, 'Arrow'
])),
wbFloat('Gravity'),
wbFloat('Speed'),
wbFloat('Range'),
wbFormIDCk('Light', [LIGH, NULL]),
wbFormIDCk('Muzzle Flash - Light', [LIGH, NULL]),
wbFloat('Explosion - Alt. Trigger - Proximity'),
wbFloat('Explosion - Alt. Trigger - Timer'),
wbFormIDCk('Explosion', [EXPL, NULL]),
wbFormIDCk('Sound', [SNDR, NULL]),
wbFloat('Muzzle Flash - Duration'),
wbFloat('Fade Duration'),
wbFloat('Impact Force'),
wbFormIDCk('Sound - Countdown', [SNDR, NULL]),
wbFormIDCk('Sound - Disable', [SNDR, NULL]),
wbFormIDCk('Default Weapon Source', [WEAP, NULL]),
wbFloat('Cone Spread'),
wbFloat('Collision Radius'),
wbFloat('Lifetime'),
wbFloat('Relaunch Interval'),
wbFormIDCk('Decal Data', [TXST, NULL]),
wbFormIDCk('Collision Layer', [COLL, NULL]),
wbInteger('Tracer Frequency', itU8),
wbFormIDCk('VATS Projectile', [PROJ, NULL])
]),
wbRStructSK([0], 'Muzzle Flash Model', [
wbString(NAM1, 'Model Filename'),
wbByteArray(NAM2, 'Texture Files Hashes', 0, cpIgnore, false, false, wbNeverShow)
], [], cpNormal, True),
wbInteger(VNAM, 'Sound Level', itU32, wbSoundLevelEnum, cpNormal, True)
]);
wbRecord(HAZD, 'Hazard', [
wbEDID,
wbOBNDReq,
wbFULL,
wbMODL,
wbFormIDCk(MNAM, 'Image Space Modifier', [IMAD, NULL]),
wbStruct(DNAM, 'Data', [
wbInteger('Limit', itU32),
wbFloat('Radius'),
wbFloat('Lifetime'),
wbFloat('Image Space Radius'),
wbFloat('Target Interval'),
wbInteger('Flags', itU32, wbFlags([
{0x01} 'Affects Player Only',
{0x02} 'Inherit Duration from Spawn Spell',
{0x04} 'Align to Impact Normal',
{0x08} 'Inherit Radius from Spawn Spell',
{0x10} 'Drop to Ground',
{0x20} 'Taper Effectiveness by Proximity'
])),
wbFormIDCk('Effect', [SPEL, ENCH, NULL]),
wbFormIDCk('Light', [LIGH, NULL]),
wbFormIDCk('Impact Data Set', [IPDS, NULL]),
wbFormIDCk('Sound', [SNDR, NULL]),
wbStruct('Taper Effectiveness', [
wbFloat('Full Effect Radius'),
wbFloat('Taper Weight'),
wbFloat('Taper Curse')
])
])
]);
wbSoulGemEnum := wbEnum([
{0} 'None',
{1} 'Petty',
{2} 'Lesser',
{3} 'Common',
{4} 'Greater',
{5} 'Grand'
]);
{wbRecord(SLGM, 'Soul Gem', [
wbEDID
]);}
if wbSimpleRecords then begin
wbRecord(NAVI, 'Navigation Mesh Info Map', [
wbEDID,
wbInteger(NVER, 'Version', itU32),
wbRArray('Navigation Map Infos',
wbStruct(NVMI, 'Navigation Map Info', [
wbFormIDCk('Navigation Mesh', [NAVM]),
wbByteArray('Data', 20),
wbArray('Merged To', wbFormIDCk('Mesh', [NAVM]), -1),
wbArray('Preferred Merges', wbFormIDCk('Mesh', [NAVM]), -1),
wbArray('Linked Doors', wbStruct('Door', [
wbByteArray('Unknown', 4),
wbFormIDCk('Door Ref', [REFR])
]), -1),
wbInteger('Is Island', itU8, wbBoolEnum),
wbUnion('Island', wbNAVIIslandDataDecider, [
wbNull,
wbStruct('Island Data', [
wbByteArray('Unknown', 24),
wbArray('Triangles', wbByteArray('Triangle', 6), -1),
wbArray('Vertices', wbByteArray('Vertex', 12), -1)
])
]),
wbByteArray('Unknown', 4),
wbFormIDCk('Parent Worldspace', [WRLD, NULL]),
wbUnion('Parent', wbNAVIParentDecider, [
wbStruct('Coordinates', [
wbInteger('Grid Y', itS16),
wbInteger('Grid X', itS16)
]),
wbFormIDCk('Parent Cell', [CELL])
])
])
),
wbStruct(NVPP, 'Preferred Pathing', [
wbArray('NavMeshes', wbArray('Set', wbFormIDCk('', [NAVM]), -1), -1),
wbArray('NavMesh Tree?', wbStruct('', [
wbFormIDCk('NavMesh', [NAVM]),
wbInteger('Index/Node', itU32)
]), -1)
]),
//wbArray(NVSI, 'Unknown', wbFormIDCk('Navigation Mesh', [NAVM]))
wbUnknown(NVSI)
]);
wbRecord(NAVM, 'Navigation Mesh',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00040000} 18, 'Compressed',
{0x04000000} 26, 'AutoGen',
{0x80000000} 31, 'Unknown 31'
]), [18]), [
wbEDID,
wbNVNM,
// wbStruct(NVNM, 'Geometry', [
// wbByteArray('Unknown', 8),
// wbFormIDCk('Parent Worldspace', [WRLD, NULL]),
// wbUnion('Parent', wbNVNMParentDecider, [
// wbStruct('Coordinates', [
// wbInteger('Grid Y', itS16),
// wbInteger('Grid X', itS16)
// ]),
// wbFormIDCk('Parent Cell', [CELL])
// ]),
// wbArray('Vertices', wbByteArray('Vertex', 12), -1),
// wbArray('Triangles', wbByteArray('Triangle', 21), -1),
// wbArray('Edge Links',
// wbStruct('Edge Link', [
// wbByteArray('Unknown', 4),
// wbFormIDCk('Mesh', [NAVM]),
// wbInteger('Triangle', itS16),
// wbInteger('Unknown', itU8)
// ])
// , -1),
// wbArray('Door Triangles',
// wbStruct('Door Triangle', [
// wbInteger('Triangle before door', itS16),
// wbByteArray('Unknown', 4),
// wbFormIDCk('Door', [REFR])
// ])
// , -1),
// wbUnknown
// ]),
wbUnknown(ONAM),
wbUnknown(NNAM),
wbUnknown(MNAM)
], False, wbNAVMAddInfo);
end else begin
wbRecord(NAVI, 'Navigation Mesh Info Map', [
wbEDID,
wbInteger(NVER, 'Version', itU32),
wbRArray('Navigation Map Infos',
wbStruct(NVMI, 'Navigation Map Info', [
wbFormIDCk('Navigation Mesh', [NAVM]),
wbByteArray('Unknown', 4),
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z'),
wbInteger('Preferred Merges Flag', itU32),
wbArray('Merged To', wbFormIDCk('Mesh', [NAVM]), -1),
wbArray('Preferred Merges', wbFormIDCk('Mesh', [NAVM]), -1),
wbArray('Linked Doors', wbStruct('Door', [
wbByteArray('Unknown', 4),
wbFormIDCk('Door Ref', [REFR])
]), -1),
wbInteger('Is Island', itU8, wbBoolEnum),
wbUnion('Island', wbNAVIIslandDataDecider, [
wbNull,
wbStruct('Island Data', [
wbFloat('Min X'),
wbFloat('Min Y'),
wbFloat('Min Z'),
wbFloat('Max X'),
wbFloat('Max Y'),
wbFloat('Max Z'),
wbArray('Triangles',
wbStruct('Triangle', [
wbArray('Vertices', wbInteger('Vertex', itS16), 3)
])
, -1),
wbArray('Vertices', wbStruct('Vertex', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]), -1)
])
]),
wbByteArray('Unknown', 4),
wbFormIDCk('Parent Worldspace', [WRLD, NULL]),
wbUnion('Parent', wbNAVIParentDecider, [
wbStruct('Coordinates', [
wbInteger('Grid Y', itS16),
wbInteger('Grid X', itS16)
]),
wbFormIDCk('Parent Cell', [CELL])
])
])
),
wbStruct(NVPP, 'Preferred Pathing', [
wbArray('NavMeshes', wbArray('Set', wbFormIDCk('', [NAVM]), -1), -1),
wbArray('NavMesh Tree?', wbStruct('', [
wbFormIDCk('NavMesh', [NAVM]),
wbInteger('Index/Node', itU32)
]), -1)
]),
wbArray(NVSI, 'Unknown', wbFormIDCk('Navigation Mesh', [NAVM]))
]);
wbRecord(NAVM, 'Navigation Mesh',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00040000} 18, 'Compressed',
{0x04000000} 26, 'AutoGen'
]), [18]), [
wbEDID,
wbNVNM,
// wbStruct(NVNM, 'Geometry', [
// wbInteger('Unknown', itU32),
// wbByteArray('Unknown', 4),
// wbFormIDCk('Parent Worldspace', [WRLD, NULL]),
// wbUnion('Parent', wbNVNMParentDecider, [
// wbStruct('Coordinates', [
// wbInteger('Grid Y', itS16),
// wbInteger('Grid X', itS16)
// ]),
// wbFormIDCk('Parent Cell', [CELL])
// ]),
// wbArray('Vertices', wbStruct('Vertex', [
// wbFloat('X'),
// wbFloat('Y'),
// wbFloat('Z')
// ]), -1),
// wbArray('Triangles',
// wbStruct('Triangle', [
// wbInteger('Vertex 0', itS16),
// wbInteger('Vertex 1', itS16),
// wbInteger('Vertex 2', itS16),
// wbInteger('Edge 0-1', itS16),
// wbInteger('Edge 1-2', itS16),
// wbInteger('Edge 2-0', itS16),
// wbFloat('Height'),
// wbByteArray('Unknown', 5)
// ])
// , -1),
// wbArray('Edge Links',
// wbStruct('Edge Link', [
// wbByteArray('Unknown', 4),
// wbFormIDCk('Mesh', [NAVM]),
// wbInteger('Triangle', itS16),
// wbInteger('Unknown', itU8)
// ])
// , -1),
// wbArray('Door Triangles',
// wbStruct('Door Triangle', [
// wbInteger('Triangle before door', itS16),
// wbByteArray('Unknown', 4),
// wbFormIDCk('Door', [REFR])
// ])
// , -1),
// wbUnknown
// ]),
wbFormID(ONAM),
wbArray(NNAM, 'Unknown', wbInteger('Unknown', itU16)),
wbUnion(MNAM, 'Unknown', wbSubrecordSizeDecider, [wbNull,
wbStruct('Unknown', [
wbFormID('Unknown'),
wbInteger('Unknown', itU16),
wbInteger('Unused', itU16),
wbUnknown
])
])
], False, wbNAVMAddInfo);
end;
end;
procedure DefineFO4g;
begin
wbRecord(EXPL, 'Explosion', [
wbEDID,
wbOBNDReq,
wbFULL,
wbMODL,
wbEITM,
wbFormIDCk(MNAM, 'Image Space Modifier', [IMAD]),
wbStruct(DATA, 'Data', [
wbFormIDCk('Light', [LIGH, NULL]),
wbFormIDCk('Sound 1', [SNDR, NULL]),
wbFormIDCk('Sound 2', [SNDR, NULL]),
wbFormIDCk('Impact Data Set', [IPDS, NULL]),
wbFormID('Placed Object'),
wbFormIDCk('Spawn Projectile', [PROJ, NULL]),
wbFloat('Force'),
wbFloat('Damage'),
wbFloat('Inner Radius'),
wbFloat('Outer Radius'),
wbFloat('IS Radius'),
wbUnion('Vertical Offset Mult', wbDeciderFormVersion99, [
wbByteArray('Unknown', 4),
wbFloat('Vertical Offset Mult')
]),
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Unknown 0',
{0x00000002} 'Always Uses World Orientation',
{0x00000004} 'Knock Down - Always',
{0x00000008} 'Knock Down - By Formula',
{0x00000010} 'Ignore LOS Check',
{0x00000020} 'Push Explosion Source Ref Only',
{0x00000040} 'Ignore Image Space Swap',
{0x00000080} 'Chain',
{0x00000100} 'No Controller Vibration',
{0x00000200} 'Placed Object Persists',
{0x00000400} 'Skip Underwater Tests'
])),
wbInteger('Sound Level', itU32, wbSoundLevelEnum),
wbFloat('Placed Object AutoFade Delay'),
wbInteger('Stagger', itU32, wbEnum([
'None',
'Small',
'Medium',
'Large',
'Extra Large'
])),
wbStruct('Spawn', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z'),
wbFloat('Spread Degrees'),
wbInteger('Count', itU32)
])
], cpNormal, True, nil, 13)
]);
wbRecord(DEBR, 'Debris', [
wbEDID,
wbRStructs('Models', 'Model', [
wbStruct(DATA, 'Data', [
wbInteger('Percentage', itU8),
wbString('Model Filename'),
wbInteger('Flags', itU8, wbFlags([
'Has Collision Data'
]))
], cpNormal, True),
wbMODT
], [], cpNormal, True)
]);
wbRecord(IMGS, 'Image Space', [
wbEDID,
wbByteArray(ENAM, 'Unused', 0, cpIgnore),
wbStruct(HNAM, 'HDR', [
wbFloat('Eye Adapt Speed'),
wbFloat('Tonemap E'),
wbFloat('Bloom Threshold'),
wbFloat('Bloom Scale'),
wbFloat('Auto Exposure Max'),
wbFloat('Auto Exposure Min'),
wbFloat('Sunlight Scale'),
wbFloat('Sky Scale'),
wbFloat('Middle Gray')
], cpNormal, True),
wbStruct(CNAM, 'Cinematic', [
wbFloat('Saturation'),
wbFloat('Brightness'),
wbFloat('Contrast')
], cpNormal, True),
wbStruct(TNAM, 'Tint', [
wbFloat('Amount'),
wbFloatColors('Color')
], cpNormal, True),
wbStruct(DNAM, 'Depth of Field', [
wbFloat('Strength'),
wbFloat('Distance'),
wbFloat('Range'),
wbByteArray('Unused', 2, cpIgnore),
wbInteger('Sky / Blur Radius', itU16, wbEnum([], [
16384, 'Radius 0',
16672, 'Radius 1',
16784, 'Radius 2',
16848, 'Radius 3',
16904, 'Radius 4',
16936, 'Radius 5',
16968, 'Radius 6',
17000, 'Radius 7',
16576, 'No Sky, Radius 0',
16736, 'No Sky, Radius 1',
16816, 'No Sky, Radius 2',
16880, 'No Sky, Radius 3',
16920, 'No Sky, Radius 4',
16952, 'No Sky, Radius 5',
16984, 'No Sky, Radius 6',
17016, 'No Sky, Radius 7'
])),
wbFloat('Vignette Radius'),
wbFloat('Vignette Strength')
], cpNormal, True, nil, 5),
wbString(TX00, 'LUT')
]);
wbTimeInterpolator := wbStruct('Data', [
wbFloat('Time'),
wbFloat('Value')
]);
wbColorInterpolator := wbStruct('Data', [
wbFloat('Time'),
wbFloat('Red', cpNormal, False, 255, 0),
wbFloat('Green', cpNormal, False, 255, 0),
wbFloat('Blue', cpNormal, False, 255, 0),
wbFloat('Alpha', cpNormal, False, 255, 0)
]);
wbRecord(IMAD, 'Image Space Adapter', [
wbEDID,
wbStruct(DNAM, 'Data Count', [
wbInteger('Flags', itU32, wbFlags(['Animatable'])),
wbFloat('Duration'),
wbStruct('HDR', [
wbInteger('Eye Adapt Speed Mult', itU32),
wbInteger('Eye Adapt Speed Add', itU32),
wbInteger('Bloom Blur Radius Mult', itU32),
wbInteger('Bloom Blur Radius Add', itU32),
wbInteger('Bloom Threshold Mult', itU32),
wbInteger('Bloom Threshold Add', itU32),
wbInteger('Bloom Scale Mult', itU32),
wbInteger('Bloom Scale Add', itU32),
wbInteger('Target Lum Min Mult', itU32),
wbInteger('Target Lum Min Add', itU32),
wbInteger('Target Lum Max Mult', itU32),
wbInteger('Target Lum Max Add', itU32),
wbInteger('Sunlight Scale Mult', itU32),
wbInteger('Sunlight Scale Add', itU32),
wbInteger('Sky Scale Mult', itU32),
wbInteger('Sky Scale Add', itU32)
]),
wbInteger('Unknown08 Mult', itU32),
wbInteger('Unknown48 Add', itU32),
wbInteger('Unknown09 Mult', itU32),
wbInteger('Unknown49 Add', itU32),
wbInteger('Unknown0A Mult', itU32),
wbInteger('Unknown4A Add', itU32),
wbInteger('Unknown0B Mult', itU32),
wbInteger('Unknown4B Add', itU32),
wbInteger('Unknown0C Mult', itU32),
wbInteger('Unknown4C Add', itU32),
wbInteger('Unknown0D Mult', itU32),
wbInteger('Unknown4D Add', itU32),
wbInteger('Unknown0E Mult', itU32),
wbInteger('Unknown4E Add', itU32),
wbInteger('Unknown0F Mult', itU32),
wbInteger('Unknown4F Add', itU32),
wbInteger('Unknown10 Mult', itU32),
wbInteger('Unknown50 Add', itU32),
wbStruct('Cinematic', [
wbInteger('Saturation Mult', itU32),
wbInteger('Saturation Add', itU32),
wbInteger('Brightness Mult', itU32),
wbInteger('Brightness Add', itU32),
wbInteger('Contrast Mult', itU32),
wbInteger('Contrast Add', itU32)
]),
wbInteger('Unknown14 Mult', itU32),
wbInteger('Unknown54 Add', itU32),
wbInteger('Tint Color', itU32),
wbInteger('Blur Radius', itU32),
wbInteger('Double Vision Strength', itU32),
wbInteger('Radial Blur Strength', itU32),
wbInteger('Radial Blur Ramp Up', itU32),
wbInteger('Radial Blur Start', itU32),
wbInteger('Radial Blur Flags', itU32, wbFlags(['Use Target'])),
wbFloat('Radial Blur Center X'),
wbFloat('Radial Blur Center Y'),
wbInteger('DoF Strength', itU32),
wbInteger('DoF Distance', itU32),
wbInteger('DoF Range', itU32),
wbInteger('DoF Flags', itU32, wbFlags([
{0x00000001} 'Use Target',
{0x00000002} 'Unknown 2',
{0x00000004} 'Unknown 3',
{0x00000008} 'Unknown 4',
{0x00000010} 'Unknown 5',
{0x00000020} 'Unknown 6',
{0x00000040} 'Unknown 7',
{0x00000080} 'Unknown 8',
{0x00000100} 'Mode - Front',
{0x00000200} 'Mode - Back',
{0x00000400} 'No Sky',
{0x00000800} 'Blur Radius Bit 2',
{0x00001000} 'Blur Radius Bit 1',
{0x00002000} 'Blur Radius Bit 0'
])),
wbInteger('Radial Blur Ramp Down', itU32),
wbInteger('Radial Blur Down Start', itU32),
wbInteger('Fade Color', itU32),
wbInteger('Motion Blur Strength', itU32),
wbUnknown
]),
wbArray(BNAM, 'Blur Radius', wbTimeInterpolator),
wbArray(VNAM, 'Double Vision Strength', wbTimeInterpolator),
wbArray(TNAM, 'Tint Color', wbColorInterpolator),
wbArray(NAM3, 'Fade Color', wbColorInterpolator),
wbRStruct('Radial Blur', [
wbArray(RNAM, 'Strength', wbTimeInterpolator),
wbArray(SNAM, 'RampUp', wbTimeInterpolator),
wbArray(UNAM, 'Start', wbTimeInterpolator),
wbArray(NAM1, 'RampDown', wbTimeInterpolator),
wbArray(NAM2, 'DownStart', wbTimeInterpolator)
], []),
wbRStruct('Depth of Field', [
wbArray(WNAM, 'Strength', wbTimeInterpolator),
wbArray(XNAM, 'Distance', wbTimeInterpolator),
wbArray(YNAM, 'Range', wbTimeInterpolator),
wbArray(NAM5, 'Vignette Radius', wbTimeInterpolator),
wbArray(NAM6, 'Vignette Strength', wbTimeInterpolator)
], []),
wbArray(NAM4, 'Motion Blur Strength', wbTimeInterpolator),
wbRStruct('HDR', [
wbArray(_00_IAD, 'Eye Adapt Speed Mult', wbTimeInterpolator),
wbArray(_40_IAD, 'Eye Adapt Speed Add', wbTimeInterpolator),
wbArray(_01_IAD, 'Bloom Blur Radius Mult', wbTimeInterpolator),
wbArray(_41_IAD, 'Bloom Blur Radius Add', wbTimeInterpolator),
wbArray(_02_IAD, 'Bloom Threshold Mult', wbTimeInterpolator),
wbArray(_42_IAD, 'Bloom Threshold Add', wbTimeInterpolator),
wbArray(_03_IAD, 'Bloom Scale Mult', wbTimeInterpolator),
wbArray(_43_IAD, 'Bloom Scale Add', wbTimeInterpolator),
wbArray(_04_IAD, 'Target Lum Min Mult', wbTimeInterpolator),
wbArray(_44_IAD, 'Target Lum Min Add', wbTimeInterpolator),
wbArray(_05_IAD, 'Target Lum Max Mult', wbTimeInterpolator),
wbArray(_45_IAD, 'Target Lum Max Add', wbTimeInterpolator),
wbArray(_06_IAD, 'Sunlight Scale Mult', wbTimeInterpolator),
wbArray(_46_IAD, 'Sunlight Scale Add', wbTimeInterpolator),
wbArray(_07_IAD, 'Sky Scale Mult', wbTimeInterpolator),
wbArray(_47_IAD, 'Sky Scale Add', wbTimeInterpolator)
], []),
wbUnknown(_08_IAD),
wbUnknown(_48_IAD),
wbUnknown(_09_IAD),
wbUnknown(_49_IAD),
wbUnknown(_0A_IAD),
wbUnknown(_4A_IAD),
wbUnknown(_0B_IAD),
wbUnknown(_4B_IAD),
wbUnknown(_0C_IAD),
wbUnknown(_4C_IAD),
wbUnknown(_0D_IAD),
wbUnknown(_4D_IAD),
wbUnknown(_0E_IAD),
wbUnknown(_4E_IAD),
wbUnknown(_0F_IAD),
wbUnknown(_4F_IAD),
wbUnknown(_10_IAD),
wbUnknown(_50_IAD),
wbRStruct('Cinematic', [
wbArray(_11_IAD, 'Saturation Mult', wbTimeInterpolator),
wbArray(_51_IAD, 'Saturation Add', wbTimeInterpolator),
wbArray(_12_IAD, 'Brightness Mult', wbTimeInterpolator),
wbArray(_52_IAD, 'Brightness Add', wbTimeInterpolator),
wbArray(_13_IAD, 'Contrast Mult', wbTimeInterpolator),
wbArray(_53_IAD, 'Contrast Add', wbTimeInterpolator)
], []),
wbUnknown(_14_IAD),
wbUnknown(_54_IAD)
]);
wbRecord(FLST, 'FormID List', [
wbString(EDID, 'Editor ID', 0, cpBenign, True, nil, wbFLSTEDIDAfterSet),
wbFULL,
wbRArrayS('FormIDs', wbFormID(LNAM, 'FormID'), cpNormal, False, nil, nil, nil, wbFLSTLNAMIsSorted)
]);
wbRecord(PERK, 'Perk',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000004} 2, 'Non-Playable'
])), [
wbEDID,
wbVMADFragmentedPERK,
wbFULL,
wbDESCReq,
wbString(ICON, 'Image'),
wbCTDAs,
wbStruct(DATA, 'Data', [
wbInteger('Trait', itU8, wbBoolEnum),
wbInteger('Level', itU8),
wbInteger('Num Ranks', itU8),
wbInteger('Playable', itU8, wbBoolEnum),
wbInteger('Hidden', itU8, wbBoolEnum)
], cpNormal, True),
wbFormIDCk(SNAM, 'Sound', [SNDR]),
wbFormIDCK(NNAM, 'Next Perk', [PERK, NULL]),
wbString(FNAM, 'SWF'),
wbRStructsSK('Effects', 'Effect', [0, 1], [
wbStructSK(PRKE, [1, 2, 0], 'Header', [
wbInteger('Type', itU8, wbEnum([
'Quest + Stage',
'Ability',
'Entry Point'
]), cpNormal, False, nil, wbPERKPRKETypeAfterSet),
wbInteger('Rank', itU8),
wbInteger('Priority', itU8)
]),
wbUnion(DATA, 'Effect Data', wbPerkDATADecider, [
wbStructSK([0, 1], 'Quest + Stage', [
wbFormIDCk('Quest', [QUST]),
wbInteger('Quest Stage', itU16, wbPerkDATAQuestStageToStr, wbCTDAParam2QuestStageToInt),
wbByteArray('Unused', 2)
]),
wbFormIDCk('Ability', [SPEL]),
wbStructSK([0, 1], 'Entry Point', [
wbInteger('Entry Point', itU8, wbEntryPointsEnum, cpNormal, True, nil{, wbPERKEntryPointAfterSet}),
wbInteger('Function', itU8, wbEnum([
{0} 'Unknown 0',
{1} 'Set Value', // EPFT=1
{2} 'Add Value', // EPFT=1
{3} 'Multiply Value', // EPFT=1
{4} 'Add Range To Value', // EPFT=2
{5} 'Add Actor Value Mult', // EPFT=2
{6} 'Absolute Value', // no params
{7} 'Negative Absolute Value', // no params
{8} 'Add Leveled List', // EPFT=3
{9} 'Add Activate Choice', // EPFT=4
{10} 'Select Spell', // EPFT=5
{11} 'Select Text', // EPFT=6
{12} 'Set to Actor Value Mult', // EPFT=2
{13} 'Multiply Actor Value Mult', // EPFT=2
{14} 'Multiply 1 + Actor Value Mult', // EPFT=2
{15} 'Set Text' // EPFT=7
])),
wbInteger('Perk Condition Tab Count', itU8, nil, cpIgnore)
])
], cpNormal, True),
wbRStructsSK('Perk Conditions', 'Perk Condition', [0], [
wbInteger(PRKC, 'Run On (Tab Index)', itS8{, wbPRKCToStr, wbPRKCToInt}),
wbCTDAsReq
], [], cpNormal, False{, nil, nil, wbPERKPRKCDontShow}),
wbRStruct('Function Parameters', [
wbInteger(EPFT, 'Type', itU8, wbEnum([
{0} 'None',
{1} 'Float',
{2} 'Float/AV,Float',
{3} 'LVLI',
{4} 'SPEL,lstring,flags',
{5} 'SPEL',
{6} 'string',
{7} 'lstring',
{8} 'AVIF'
])),
// case(EPFT) of
// 1: EPFD=float
// 2: EPFD=float,float
// 3: EPFD=LVLI
// 4: EPFD=SPEL, EPF2=lstring, EPF3=int32 flags
// 5: EPFD=SPEL
// 6: EPFD=string
// 7: EPFD=lstring
wbInteger(EPFB, 'Perk Entry ID (unique)', itU16),
wbLString(EPF2, 'Button Label', 0, cpTranslate),
wbStruct(EPF3, 'Script Flags', [
wbInteger('Script Flags', itU8, wbFlags([
'Run Immediately',
'Replace Default'
])),
wbByteArray('Unknown', 1)
]),
wbUnion(EPFD, 'Data', wbEPFDDecider, [
{0} wbByteArray('Unknown'),
{1} wbFloat('Float'),
{2} wbStruct('Float, Float', [
wbFloat('Float 1'),
wbFloat('Float 2')
]),
{3} wbFormIDCk('Leveled Item', [LVLI]),
{4} wbFormIDCk('Spell', [SPEL]),
{5} wbFormIDCk('Spell', [SPEL]),
{6} wbString('Text', 0, cpTranslate),
{7} wbLString('Text', 0, cpTranslate),
{8} wbStruct('Actor Value, Float', [
wbActorValue, // wbInteger('Actor Value', itU32, wbEPFDActorValueToStr, wbEPFDActorValueToInt),
wbFloat('Float')
])
], cpNormal, False{, wbEPFDDontShow})
], [], cpNormal, False{, wbPERKPRKCDontShow}),
wbEmpty(PRKF, 'End Marker', cpIgnore, True)
], [])
]);
wbRecord(BPTD, 'Body Part Data', [
wbEDID,
wbMODL,
wbRArrayS('Body Parts',
wbRStructSK([1], 'Body Part', [
wbLString(BPTN, 'Part Name', 0, cpTranslate), // optional
wbString(BPNN, 'Part Node', 0, cpNormal, True),
wbString(BPNT, 'VATS Target', 0, cpNormal, True),
wbStruct(BPND, '', [
wbFloat('Damage Mult'),
wbFormIDCk('Explodable - Debris', [DEBR, NULL]),
wbFormIDCk('Explodable - Explosion', [EXPL, NULL]),
wbFloat('Explodable - Debris Scale'),
wbFormIDCk('Severable - Debris', [DEBR, NULL]),
wbFormIDCk('Severable - Explosion', [EXPL, NULL]),
wbFloat('Severable - Debris Scale'),
wbFloat('Cut - Min'),
wbFloat('Cut - Max'),
wbFloat('Cut - Radius'),
wbFloat('Gore Effects - Local Rotate X', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Gore Effects - Local Rotate Y', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Cut - Tesselation'),
wbFormIDCk('Severable - Impact DataSet', [IPDS, NULL]),
wbFormIDCk('Explodable - Impact DataSet', [IPDS, NULL]),
wbFloat('Explodable - Limb Replacement Scale'),
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Severable',
{0x02} 'Hit Reaction',
{0x04} 'Hit Reaction - Default',
{0x08} 'Explodable',
{0x10} 'Cut - Meat Cap Sever',
{0x20} 'On Cripple',
{0x40} 'Explodable - Absolute Chance',
{0x80} 'Show Cripple Geometry'
])),
wbInteger('Part Type', itU8, wbEnum([
{ 0} 'Torso',
{ 1} 'Head1',
{ 2} 'Eye',
{ 3} 'LookAt',
{ 4} 'Fly Grab',
{ 5} 'Head2',
{ 6} 'LeftArm1',
{ 7} 'LeftArm2',
{ 8} 'RightArm1',
{ 9} 'RightArm2',
{10} 'LeftLeg1',
{11} 'LeftLeg2',
{12} 'LeftLeg3',
{13} 'RightLeg1',
{14} 'RightLeg2',
{15} 'RightLeg3',
{16} 'Brain',
{17} 'Weapon',
{18} 'Root',
{19} 'COM',
{20} 'Pelvis',
{21} 'Camera',
{22} 'Offset Root',
{23} 'Left Foot',
{24} 'Right Foot',
{25} 'Face Target Source'
])),
wbInteger('Health Percent', itU8),
wbFormIDCk('Actor Value', [AVIF, NULL]),
wbInteger('To Hit Chance', itU8),
wbInteger('Explodable - Explosion Chance %', itU8),
wbInteger('Non-Lethal Dismemberment Chance', itU8),
wbInteger('Severable - Debris Count', itU8),
wbInteger('Explodable - Debris Count', itU8),
wbInteger('Severable - Decal Count', itU8),
wbInteger('Explodable - Decal Count', itU8),
wbInteger('Geometry Segment Index', itU8),
wbFormIDCk('On Cripple - Art Object', [ARTO, NULL]),
wbFormIDCk('On Cripple - Debris', [DEBR, NULL]),
wbFormIDCk('On Cripple - Explosion', [EXPL, NULL]),
wbFormIDCk('On Cripple - Impact DataSet', [IPDS, NULL]),
wbFloat('On Cripple - Debris Scale'),
wbInteger('On Cripple - Debris Count', itU8),
wbInteger('On Cripple - Decal Count', itU8)
], cpNormal, True),
wbString(NAM1, 'Limb Replacement Model', 0, cpNormal, True),
wbString(NAM4, 'Gore Effects - Target Bone', 0, cpNormal, True),
wbByteArray(NAM5, 'Texture Files Hashes', 0, cpNormal),
wbString(ENAM, 'Hit Reaction - Start'),
wbString(FNAM, 'Hit Reaction - End'),
wbFormIDCk(BNAM, 'Gore Effects - Dismember Blood Art', [ARTO]),
wbFormIDCk(INAM, 'Gore Effects - Blood Impact Material Type', [MATT]),
wbFormIDCk(JNAM, 'On Cripple - Blood Impact Material Type', [MATT]),
wbFormIDCk(CNAM, 'Meat Cap TextureSet', [TXST]),
wbFormIDCk(NAM2, 'Collar TextureSet', [TXST]),
wbString(DNAM, 'Twist Variable Prefix')
], [], cpNormal, False, nil, True)
)
]);
wbRecord(ADDN, 'Addon Node', [
wbEDID,
wbOBNDReq,
wbMODL,
wbInteger(DATA, 'Node Index', itS32, nil, cpNormal, True),
wbFormIDCk(SNAM, 'Sound', [SNDR]),
wbFormIDCk(LNAM, 'Light', [LIGH]),
wbStruct(DNAM, 'Data', [
wbInteger('Master Particle System Cap', itU16),
wbInteger('Flags', itU16, wbEnum([
'No Master Particle System',
'Master Particle System',
'Always Loaded',
'Master Particle System and Always Loaded'
]))
], cpNormal, True)
]);
end;
procedure DefineFO4h;
begin
wbRecord(AVIF, 'Actor Value Information', [
wbEDID,
wbFULL,
wbDESCReq,
wbLString(ANAM, 'Abbreviation', 0, cpTranslate),
wbFloat(NAM0, 'Default Value'), // Prior to form version 81, it was either 0.0, 1.0 or 100.0, so scale or multiplier ?
wbInteger(AVFL, 'Flags', itU32, wbFlags([ // 32 bits Flags, it used to impact NAM0 loading (bits 10, 11, 12) (even though it loads later :) )
'Unknown 1',
'Unknown 2',
'Unknown 3',
'Unknown 4',
'Unknown 5',
'Unknown 6',
'Unknown 7',
'Unknown 8',
'Unknown 9',
'Unknown 10',
'Unknown 11',
'Unknown 12',
'Unknown 13',
'Unknown 14',
'Unknown 15',
'Unknown 16',
'Unknown 17',
'Unknown 18',
'Unknown 19',
'Unknown 20',
'Minimum 1',
'Maximum 10',
'Maximum 100',
'Multiply By 100',
'Percentage',
'Unknown 26',
'Damage Is Positive',
'God Mode Immune',
'Unknown 29',
'Unknown 30',
'Unknown 31',
'Hardcoded'
])),
wbInteger(NAM1, 'Type', itU32, wbEnum([
'Derived Attribute',
'Special (Attribute)',
'Skill',
'AI Attribute',
'Resistance',
'Condition',
'Charge',
'Int Value',
'Variable',
'Resource'
]))
]); // S.P.E.C.I.A.L start at index 5, so FormID 0x2bc+5 to 0x2bc+11, RadResistIngestion at index 0x29
wbRecord(CAMS, 'Camera Shot', [
wbEDID,
wbMODL,
wbCTDAs,
wbStruct(DATA, 'Data', [
wbInteger('Action', itU32, wbEnum([
{0} 'Shoot',
{1} 'Fly',
{2} 'Hit',
{3} 'Zoom'
])),
wbInteger('Location', itU32, wbEnum([
{0} 'Attacker',
{1} 'Projectile',
{2} 'Target',
{3} 'Lead Actor'
])),
wbInteger('Target', itU32, wbEnum([
{0} 'Attacker',
{1} 'Projectile',
{2} 'Target',
{3} 'Lead Actor'
])),
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Position Follows Location',
{0x00000002} 'Rotation Follows Target',
{0x00000004} 'Don''t Follow Bone',
{0x00000008} 'First Person Camera',
{0x00000010} 'No Tracer',
{0x00000020} 'Start At Time Zero',
{0x00000040} 'Don''t Reset Location Spring',
{0x00000080} 'Don''t Reset Target Spring'
])),
wbStruct('Time Multipliers', [
wbFloat('Player'),
wbFloat('Target'),
wbFloat('Global')
]),
wbFloat('Max Time'),
wbFloat('Min Time'),
wbFloat('Target % Between Actors'),
wbFloat('Near Target Distance'),
wbFloat('Location Spring'),
wbFloat('Target Spring'),
wbStruct('Rotation Offset', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
])
], cpNormal, True, nil, 9),
wbFormIDCk(MNAM, 'Image Space Modifier', [IMAD])
]);
wbRecord(CPTH, 'Camera Path', [
wbEDID,
wbCTDAs,
wbArray(ANAM, 'Related Camera Paths', wbFormIDCk('Related Camera Path', [CPTH, NULL]), ['Parent', 'Previous Sibling'], cpNormal, True),
wbInteger(DATA, 'Camera Zoom / Flags', itU8, wbFlags([
{0x01} 'Disable',
{0x02} 'Shot List',
{0x04} 'Dynamic Camera Times',
{0x08} 'Unknown 3',
{0x10} 'Unknown 4',
{0x20} 'Unknown 5',
{0x40} 'Randomize Paths',
{0x80} 'Not Must Have Camera Shots'
]), cpNormal, True),
wbRArray('Camera Shots', wbFormIDCk(SNAM, 'Camera Shot', [CAMS]))
]);
wbRecord(VTYP, 'Voice Type', [
wbEDID,
wbInteger(DNAM, 'Flags', itU8, wbFlags([
'Allow Default Dialog',
'Female'
]), cpNormal, True)
]);
wbRecord(MATT, 'Material Type', [
wbEDID,
wbFormIDCk(PNAM, 'Material Parent', [MATT, NULL]),
wbString(MNAM, 'Material Name'),
wbStruct(CNAM, 'Havok Display Color', [
wbFloat('Red', cpNormal, True, 255, 0),
wbFloat('Green', cpNormal, True, 255, 0),
wbFloat('Blue', cpNormal, True, 255, 0)
]),
wbFloat(BNAM, 'Buoyancy'),
wbInteger(FNAM, 'Flags', itU32, wbFlags([
'Stair Material',
'Arrows Stick',
'Can Tunnel'
], False)),
wbFormIDCk(HNAM, 'Havok Impact Data Set', [IPDS]),
wbString(ANAM, 'Breakable FX'),
wbMODT
]);
wbRecord(IPCT, 'Impact', [
wbEDID,
wbMODL,
wbStruct(DATA, '', [
wbFloat('Effect - Duration'),
wbInteger('Effect - Orientation', itU32, wbEnum([
'Surface Normal',
'Projectile Vector',
'Projectile Reflection'
])),
wbFloat('Angle Threshold'),
wbFloat('Placement Radius'),
wbInteger('Sound Level', itU32, wbSoundLevelEnum),
wbInteger('Flags', itU8, wbFlags([
{0x01} 'No Decal Data'
])),
wbInteger('Impact Result', itU8, wbEnum([
{0} 'Default',
{1} 'Destroy',
{2} 'Bounce',
{3} 'Impale',
{4} 'Stick'
])),
wbByteArray('Unknown', 2)
], cpNormal, True),
wbDODT,
wbFormIDCk(DNAM, 'Texture Set', [TXST]),
wbFormIDCk(ENAM, 'Secondary Texture Set', [TXST]),
wbFormIDCk(SNAM, 'Sound 1', [SNDR]),
wbFormIDCk(NAM1, 'Sound 2', [SNDR]),
wbFormIDCk(NAM3, 'Footstep Explosion', [EXPL]),
wbFormIDCk(NAM2, 'Hazard', [HAZD]),
wbFloat(FNAM, 'Footstep Particle Max Dist')
]);
wbRecord(IPDS, 'Impact Data Set', [
wbEDID,
wbRArrayS('Data', wbStructSK(PNAM, [0], '', [
wbFormIDCk('Material', [MATT]),
wbFormIDCk('Impact', [IPCT])
]))
]);
wbRecord(ECZN, 'Encounter Zone', [
wbEDID,
wbStruct(DATA, '', [
wbFormIDCkNoReach('Owner', [NPC_, FACT, NULL]),
wbFormIDCk('Location', [LCTN, NULL]),
wbInteger('Rank', itS8),
wbInteger('Min Level', itS8),
wbInteger('Flags', itU8, wbFlags([
'Never Resets',
'Match PC Below Minimum Level',
'Disable Combat Boundary',
'Workshop'
])),
wbInteger('Max Level', itS8)
], cpNormal, True)
]);
wbRecord(LCTN, 'Location', [
wbEDID,
wbArray(ACPR, 'Actor Cell Persistent Reference', wbStruct('', [
wbFormIDCk('Actor', sigReferences, False, cpBenign),
wbFormIDCk('Location', [WRLD, CELL], False, cpBenign),
wbInteger('Grid Y', itS16, nil, cpBenign),
wbInteger('Grid X', itS16, nil, cpBenign)
])),
wbArray(LCPR, 'Location Cell Persistent Reference', wbStruct('', [
wbFormIDCk('Actor', sigReferences, False, cpBenign),
wbFormIDCk('Location', [WRLD, CELL], False, cpBenign),
wbInteger('Grid Y', itS16, nil, cpBenign),
wbInteger('Grid X', itS16, nil, cpBenign)
])),
wbArray(RCPR, 'Reference Cell Persistent Reference', wbFormIDCk('Ref', [ACHR, REFR], False, cpBenign)),
wbArray(ACUN, 'Actor Cell Unique', wbStruct('', [
wbFormIDCk('Actor', [NPC_], False, cpBenign),
wbFormIDCk('Ref', [ACHR], False, cpBenign),
wbFormIDCk('Location', [LCTN, NULL], False, cpBenign)
])),
wbArray(LCUN, 'Location Cell Unique', wbStruct('', [
wbFormIDCk('Actor', [NPC_], False, cpBenign),
wbFormIDCk('Ref', [ACHR], False, cpBenign),
wbFormIDCk('Location', [LCTN, NULL], False, cpBenign)
])),
wbArray(RCUN, 'Reference Cell Unique', wbFormIDCk('Actor', [NPC_], False, cpBenign)),
wbArray(ACSR, 'Actor Cell Static Reference', wbStruct('', [
wbFormIDCk('Loc Ref Type', [LCRT], False, cpBenign),
wbFormIDCk('Marker', sigReferences, False, cpBenign),
wbFormIDCk('Location', [WRLD, CELL], False, cpBenign),
wbInteger('Grid Y', itS16, nil, cpBenign),
wbInteger('Grid X', itS16, nil, cpBenign)
])),
wbArray(LCSR, 'Location Cell Static Reference', wbStruct('', [
wbFormIDCk('Loc Ref Type', [LCRT], False, cpBenign),
wbFormIDCk('Marker', sigReferences, False, cpBenign),
wbFormIDCk('Location', [WRLD, CELL], False, cpBenign),
wbInteger('Grid Y', itS16, nil, cpBenign),
wbInteger('Grid X', itS16, nil, cpBenign)
])),
wbArray(RCSR, 'Reference Cell Static Reference', wbFormIDCk('Ref', [ACHR, REFR], False, cpBenign)),
wbRArray('Actor Cell Encounter Cell',
wbStruct(ACEC, 'Unknown', [
wbFormIDCk('Location', [WRLD, CELL], False, cpBenign),
wbArray('Coordinates', wbStruct('', [
wbInteger('Grid Y', itS16, nil, cpBenign),
wbInteger('Grid X', itS16, nil, cpBenign)
]))
])
),
wbRArray('Location Cell Encounter Cell',
wbStruct(LCEC, 'Unknown', [
wbFormIDCk('Location', [WRLD, CELL], False, cpBenign),
wbArray('Coordinates', wbStruct('', [
wbInteger('Grid Y', itS16, nil, cpBenign),
wbInteger('Grid X', itS16, nil, cpBenign)
]))
])
),
wbRArray('Reference Cell Encounter Cell',
wbStruct(RCEC, 'Unknown', [
wbFormIDCk('Location', [WRLD, CELL], False, cpBenign),
wbArray('Coordinates', wbStruct('', [
wbInteger('Grid Y', itS16, nil, cpBenign),
wbInteger('Grid X', itS16, nil, cpBenign)
]))
])
),
wbArray(ACID, 'Actor Cell Marker Reference', wbFormIDCk('Ref', sigReferences, False, cpBenign)),
wbArray(LCID, 'Location Cell Marker Reference', wbFormIDCk('Ref', sigReferences, False, cpBenign)),
wbArray(ACEP, 'Actor Cell Enable Point', wbStruct('', [
wbFormIDCk('Actor', sigReferences, False, cpBenign),
wbFormIDCk('Ref', sigReferences, False, cpBenign),
wbInteger('Grid Y', itS16, nil, cpBenign),
wbInteger('Grid X', itS16, nil, cpBenign)
])),
wbArray(LCEP, 'Location Cell Enable Point', wbStruct('', [
wbFormIDCk('Actor', sigReferences, False, cpBenign),
wbFormIDCk('Ref', sigReferences, False, cpBenign),
wbInteger('Grid Y', itS16, nil, cpBenign),
wbInteger('Grid X', itS16, nil, cpBenign)
])),
wbFULL,
wbKSIZ,
wbKWDAs,
wbFormIDCk(PNAM, 'Parent Location', [LCTN, NULL]),
wbFormIDCk(NAM1, 'Music', [MUSC, NULL]),
wbFormIDCk(FNAM, 'Unreported Crime Faction', [FACT]),
wbFormIDCk(MNAM, 'World Location Marker Ref', [REFR, ACHR]),
wbFloat(RNAM, 'World Location Radius'),
//wbFormIDCk(NAM0, 'Horse Marker Ref', [REFR]),
wbFloat(ANAM, 'Unknown'),
wbCNAM
], False, nil, cpNormal, False, nil, wbKeywordsAfterSet);
end;
{this is required to prevent XE6 compiler error}
type
TVarRecs = array of TVarRec;
function CombineVarRecs(const a, b : array of const)
: TVarRecs;
begin
SetLength(Result, Length(a) + Length(b));
if Length(a) > 0 then
Move(a[0], Result[0], SizeOf(TVarRec) * Length(a));
if Length(b) > 0 then
Move(b[0], Result[Length(a)], SizeOf(TVarRec) * Length(b));
end;
function MakeVarRecs(const a : array of const)
: TVarRecs;
begin
SetLength(Result, Length(a));
if Length(a) > 0 then
Move(a[0], Result[0], SizeOf(TVarRec) * Length(a));
end;
procedure DefineFO4i;
var
a, b, c : TVarRecs;
begin
wbRecord(MESG, 'Message', [
wbEDID,
wbDESCReq,
wbFULL,
wbFormIDCk(INAM, 'Icon (unused)', [NULL], False, cpIgnore, True), // leftover
wbFormIDCk(QNAM, 'Owner Quest', [QUST]),
wbInteger(DNAM, 'Flags', itU32, wbFlags([
'Message Box',
'Delay Initial Display'
]), cpNormal, True, False, nil, wbMESGDNAMAfterSet),
wbInteger(TNAM, 'Display Time', itU32, nil, cpNormal, False, False, wbMESGTNAMDontShow),
wbString(SNAM, 'SWF'),
wbLString(NNAM, 'Short Title', 0, cpTranslate),
wbRStructs('Menu Buttons', 'Menu Button', [
wbLString(ITXT, 'Button Text', 0, cpTranslate),
wbCTDAs
], [])
], False, nil, cpNormal, False, wbMESGAfterLoad);
a := MakeVarRecs([
0, 'None',
Sig2Int('AAAC'), 'Action Activate',
Sig2Int('AAB1'), 'Action Bleedout Start',
Sig2Int('AAB2'), 'Action Bleedout Stop',
Sig2Int('AABA'), 'Action Block Anticipate',
Sig2Int('AABH'), 'Action Block Hit',
Sig2Int('AABI'), 'Action Bumped Into',
Sig2Int('AADA'), 'Action Dual Attack',
Sig2Int('AADE'), 'Action Death',
Sig2Int('AADL'), 'Action Dual Release',
Sig2Int('AADR'), 'Action Draw',
Sig2Int('AADW'), 'Action Death Wait',
Sig2Int('AAF1'), 'Action Fly Start',
Sig2Int('AAF2'), 'Action Fly Stop',
Sig2Int('AAFA'), 'Action Fall',
Sig2Int('AAFQ'), 'Action Force Equip',
Sig2Int('AAGU'), 'Action Get Up',
Sig2Int('AAH1'), 'Action Hover Start',
Sig2Int('AAH2'), 'Action Hover Stop',
Sig2Int('AAID'), 'Action Idle',
Sig2Int('AAIS'), 'Action Idle Stop',
Sig2Int('AAJP'), 'Action Jump',
Sig2Int('AALA'), 'Action Left Attack',
Sig2Int('AALD'), 'Action Left Ready',
Sig2Int('AALI'), 'Action Left Interrupt',
Sig2Int('AALK'), 'Action Look',
Sig2Int('AALM'), 'Action Large Movement Delta',
Sig2Int('AALN'), 'Action Land',
Sig2Int('AALR'), 'Action Left Release',
Sig2Int('AALS'), 'Action Left Sync Attack',
Sig2Int('AAMT'), 'Action Mantle',
Sig2Int('AAOE'), 'Action AoE Attack',
Sig2Int('AAPA'), 'Action Right Power Attack',
Sig2Int('AAPE'), 'Action Path End',
Sig2Int('AAPS'), 'Action Path Start',
Sig2Int('AAR2'), 'Action Large Recoil',
Sig2Int('AARA'), 'Action Right Attack',
Sig2Int('AARC'), 'Action Recoil',
Sig2Int('AARD'), 'Action Right Ready',
Sig2Int('AARI'), 'Action Right Interrupt',
Sig2Int('AARR'), 'Action Right Release',
Sig2Int('AARS'), 'Action Right Sync Attack',
Sig2Int('AAS1'), 'Action Stagger Start',
Sig2Int('AASC'), 'Action Shield Change',
Sig2Int('AASH'), 'Action Sheath',
Sig2Int('AASN'), 'Action Sneak',
Sig2Int('AASP'), 'Action Sprint Stop',
Sig2Int('AASS'), 'Action Summoned Start',
Sig2Int('AAST'), 'Action Sprint Start',
Sig2Int('AASW'), 'Action Swim State Change',
Sig2Int('AAVC'), 'Action Voice',
Sig2Int('AAVD'), 'Action Voice Ready',
Sig2Int('AAVI'), 'Action Voice Interrupt',
Sig2Int('AAVR'), 'Action Voice Release',
Sig2Int('AAWH'), 'Action Ward Hit',
Sig2Int('ABLA'), 'Action Begin Looping Activate',
Sig2Int('ABOL'), 'Action Bolt Charge',
Sig2Int('ABSE'), 'Art Object Absorb Effect',
Sig2Int('ACHI'), 'Action Hide',
Sig2Int('ACSS'), 'Action Cover Sprint Start',
Sig2Int('ACTN'), 'Action Tunnel',
Sig2Int('ACWR'), 'Action Cower',
Sig2Int('ADGE'), 'Action Dodge',
Sig2Int('ADPA'), 'Action Dual Power Attack',
Sig2Int('AECL'), 'Action Enter Cover',
Sig2Int('AELA'), 'Action End Looping Activate',
Sig2Int('AENC'), 'Action Enter Combat',
Sig2Int('AENI'), 'Action Dialogue Enter',
Sig2Int('AEVD'), 'Action Evade',
Sig2Int('AEXC'), 'Action Exit Cover',
Sig2Int('AEXI'), 'Action Dialogue Exit',
Sig2Int('AEXT'), 'Action Exit Combat',
Sig2Int('AFCH'), 'Action Fire Charge',
Sig2Int('AFCO'), 'Action Fire Charge Hold',
Sig2Int('AFEM'), 'Action Fire Empty',
Sig2Int('AFIA'), 'Action Fire Auto',
Sig2Int('AFIS'), 'Action Fire Single',
Sig2Int('AFLT'), 'Action Flip-Throw',
Sig2Int('AFNP'), 'Keyword Activator Furniture No Player',
Sig2Int('AGAL'), 'Action Gun Alert',
Sig2Int('AGCS'), 'Action Gun Charge Start',
Sig2Int('AGDN'), 'Action Gun Down',
Sig2Int('AGRX'), 'Action Gun Relaxed',
Sig2Int('AGRY'), 'Action Gun Ready',
Sig2Int('AIDW'), 'Action Idle Warn',
Sig2Int('AIEN'), 'Action Interaction Enter',
Sig2Int('AIEQ'), 'Action Interaction Exit Quick',
Sig2Int('AIEX'), 'Action Interaction Exit',
Sig2Int('AILN'), 'Action Dialogue Listen Negative',
Sig2Int('AILp'), 'Action Dialogue Listen Positive',
Sig2Int('AILQ'), 'Action Dialogue Listen Question',
Sig2Int('AINT'), 'Action Intimidate',
Sig2Int('AIVC'), 'Verlet Cape',
Sig2Int('AIXA'), 'Action Interaction Exit Alternate',
Sig2Int('AKDN'), 'Action Knockdown',
Sig2Int('ALIC'), 'Action Limb Critical',
Sig2Int('ALIK'), 'Alcohol Item keyword',
Sig2Int('ALPA'), 'Action Left Power Attack',
Sig2Int('ALTI'), 'Action Dialogue Listen',
Sig2Int('AMBK'), 'Action Move Backward',
Sig2Int('AMEL'), 'Action Melee',
Sig2Int('AMFD'), 'Action Move Forward',
Sig2Int('AMLT'), 'Action Move Left',
Sig2Int('AMRT'), 'Action Move Right',
Sig2Int('AMSP'), 'Action Move Stop',
Sig2Int('AMST'), 'Action Move Start',
Sig2Int('ANML'), 'Keyword Animal',
Sig2Int('ANSC'), 'Action NonSupport Contact',
Sig2Int('AODA'), 'Keyword Armor Material Daedric',
Sig2Int('AODB'), 'Keyword Armor Material Dragonbone',
Sig2Int('AODP'), 'Keyword Armor Material Dragonplate',
Sig2Int('AODS'), 'Keyword Armor Material Dragonscale',
Sig2Int('AODW'), 'Keyword Armor Material Dwarven',
Sig2Int('AOEB'), 'Keyword Armor Material Ebony',
Sig2Int('AOEL'), 'Keyword Armor Material Elven',
Sig2Int('AOES'), 'Keyword Armor Material ElvenSplinted',
Sig2Int('AOFE'), 'Keyword Armor Material Iron',
Sig2Int('AOFL'), 'Keyword Armor Material FullLeather',
Sig2Int('AOGL'), 'Keyword Armor Material Glass',
Sig2Int('AOHI'), 'Keyword Armor Material Hide',
Sig2Int('AOIB'), 'Keyword Armor Material IronBanded',
Sig2Int('AOIH'), 'Keyword Armor Material ImperialHeavy',
Sig2Int('AOIM'), 'Keyword Armor Material Imperial',
Sig2Int('AOIR'), 'Keyword Armor Material ImperialReinforced',
Sig2Int('AOOR'), 'Keyword Armor Material Orcish',
Sig2Int('AOSC'), 'Keyword Armor Material Scaled',
Sig2Int('AOSD'), 'Keyword Armor Material Studded',
Sig2Int('AOSK'), 'Keyword Armor Material Stormcloak',
Sig2Int('AOSP'), 'Keyword Armor Material SteelPlate',
Sig2Int('AOST'), 'Keyword Armor Material Steel',
Sig2Int('APIC'), 'Action Pipboy Close',
Sig2Int('APID'), 'Action Pipboy Data',
Sig2Int('APII'), 'Action Pipboy Inventory',
Sig2Int('APIM'), 'Action Pipboy Map',
Sig2Int('APIN'), 'Action Pipboy Inspect',
Sig2Int('APIP'), 'Action Pipboy',
Sig2Int('APIS'), 'Action Pipboy Stats',
Sig2Int('APIT'), 'Action Pipboy Tab',
Sig2Int('APIZ'), 'Action Pipboy Zoom',
Sig2Int('APLH'), 'Action Pipboy Load Holotape',
Sig2Int('APLN'), 'Action Dialogue Listen Neutral',
Sig2Int('APNC'), 'Action Panic',
Sig2Int('APPS'), 'Action Pipboy Select',
Sig2Int('APR0'), 'Action Pipboy Radio Off',
Sig2Int('APR1'), 'Action Pipboy Radio On',
Sig2Int('APSH'), 'Allow Player Shout',
Sig2Int('APTP'), 'Action Pipboy Tab Previous',
Sig2Int('AREL'), 'Action Reload',
Sig2Int('ARGI'), 'Action Ragdoll Instant',
Sig2Int('ARTL'), 'Armor Material List',
Sig2Int('ASFL'), 'Action Shuffle',
Sig2Int('ASID'), 'Action Idle Stop Instant',
Sig2Int('ASIR'), 'Action Sighted Release',
Sig2Int('ASIT'), 'Action Sighted',
Sig2Int('ATHR'), 'Action Throw',
Sig2Int('ATKI'), 'Action Dialogue Talking',
Sig2Int('ATLE'), 'Action Turn Left',
Sig2Int('ATRI'), 'Action Turn Right',
Sig2Int('ATSP'), 'Action Turn Stop',
Sig2Int('AVVP'), 'Vampire Available Perks',
Sig2Int('AVWP'), 'Unused',
Sig2Int('AWWS'), 'Action Waterwalk Start',
Sig2Int('AWWW'), 'Bunny Faction',
Sig2Int('BAPO'), 'Base Potion',
Sig2Int('BAPS'), 'Base Poison',
Sig2Int('BEEP'), 'Keyword Robot',
Sig2Int('BENA'), 'Base Armor Enchantment',
Sig2Int('BENW'), 'Base Weapon Enchantment',
Sig2Int('BTMS'), 'Battle Music',
Sig2Int('CACA'), 'Commanded Actor Ability',
Sig2Int('CHIK'), 'Chem Item keyword',
Sig2Int('CLIK'), 'Clothes Item keyword',
Sig2Int('CMPX'), 'Complex Scene Object',
Sig2Int('CNMK'), 'Keyword nullptr Mod',
Sig2Int('COEX'), 'Keyword Conditional Explosion',
Sig2Int('COOK'), 'Keyword Cooking Pot',
Sig2Int('CSTY'), 'Combat Style',
Sig2Int('CWNE'), 'Keyword Civil War Neutral',
Sig2Int('CWOK'), 'Keyword Civil War Owner',
Sig2Int('DAED'), 'Keyword Daedra',
Sig2Int('DBHF'), 'Dark Brotherhood Faction',
Sig2Int('DCMS'), 'Dungeon Cleared Music',
Sig2Int('DCZM'), 'Dragon Crash Zone Marker',
Sig2Int('DDSC'), 'Dialogue Voice Category',
Sig2Int('DEIS'), 'Drug Wears Off Image Space',
Sig2Int('DFTS'), 'Footstep Set',
Sig2Int('DGFL'), 'DialogueFollower Quest',
Sig2Int('DIEN'), 'Keyword Disallow Enchanting',
Sig2Int('DLMT'), 'Landscape Material',
Sig2Int('DLZM'), 'Dragon Land Zone Marker',
Sig2Int('DMFL'), 'Default Movement Type: Fly',
Sig2Int('DMSN'), 'Default Movement Type: Sneak',
Sig2Int('DMSW'), 'Default Movement Type: Swim',
Sig2Int('DMWL'), 'Default Movement Type: Default',
Sig2Int('DOP2'), 'Dialogue Output Model 3D',
Sig2Int('DOP3'), 'Dialogue Output Model 2D',
Sig2Int('DRAK'), 'Keyword Dragon',
Sig2Int('DTMS'), 'Death Music',
Sig2Int('EACA'), 'Every Actor Ability',
Sig2Int('EPDF'), 'Eat Package Default Food',
Sig2Int('FFFP'), 'Keyword Furniture Forces 1st Person',
Sig2Int('FFTP'), 'Keyword Furniture Forces 3rd Person',
Sig2Int('FOIK'), 'Food Item Keyword',
Sig2Int('FORG'), 'Keyword Forge',
Sig2Int('FTEL'), 'Male Face Texture Set: Eyes',
Sig2Int('FTGF'), 'Fighters'' Guild Faction',
Sig2Int('FTHD'), 'Male Face Texture Set: Head',
Sig2Int('FTHF'), 'Female Face Texture Set: Head',
Sig2Int('FTMF'), 'Female Face Texture Set: Mouth',
Sig2Int('FTML'), 'Favor travel marker location',
Sig2Int('FTMO'), 'Male Face Texture Set: Mouth',
Sig2Int('FTNP'), 'Furniture Test NPC',
Sig2Int('FTRF'), 'Female Face Texture Set: Eyes'
]);
b := MakeVarRecs([
Sig2Int('GCK1'), 'Keyword Generic Craftable Keyword 01',
Sig2Int('GCK2'), 'Keyword Generic Craftable Keyword 02',
Sig2Int('GCK3'), 'Keyword Generic Craftable Keyword 03',
Sig2Int('GCK4'), 'Keyword Generic Craftable Keyword 04',
Sig2Int('GCK5'), 'Keyword Generic Craftable Keyword 05',
Sig2Int('GCK6'), 'Keyword Generic Craftable Keyword 06',
Sig2Int('GCK7'), 'Keyword Generic Craftable Keyword 07',
Sig2Int('GCK8'), 'Keyword Generic Craftable Keyword 08',
Sig2Int('GCK9'), 'Keyword Generic Craftable Keyword 09',
Sig2Int('GCKX'), 'Keyword Generic Craftable Keyword 10',
Sig2Int('GFAC'), 'Guard Faction',
Sig2Int('GLIK'), 'Gloves Item Keyword',
Sig2Int('GOLD'), 'Gold',
Sig2Int('GRIK'), 'Grenade Item Keyword',
Sig2Int('HBAL'), 'Help Basic Alchemy',
Sig2Int('HBBR'), 'Help Barter',
Sig2Int('HBCO'), 'Help Basic Cooking',
Sig2Int('HBEC'), 'Help Basic Enchanting',
Sig2Int('HBFG'), 'Help Basic Forging',
Sig2Int('HBFS'), 'Help Favorites',
Sig2Int('HBFT'), 'Help Teamate Favor',
Sig2Int('HBHJ'), 'Help Jail',
Sig2Int('HBJL'), 'Help Journal',
Sig2Int('HBLH'), 'Help Low Health',
Sig2Int('HBLK'), 'Help Basic Lockpicking PC',
Sig2Int('HBLM'), 'Help Low Magicka',
Sig2Int('HBLS'), 'Help Low Stamina',
Sig2Int('HBLU'), 'Help Leveling up',
Sig2Int('HBLX'), 'Help Basic Lockpicking Console',
Sig2Int('HBML'), 'Help Basic Smelting',
Sig2Int('HBMM'), 'Help Map Menu',
Sig2Int('HBOC'), 'Help Basic Object Creation',
Sig2Int('HBSA'), 'Help Basic Smithing Armor',
Sig2Int('HBSK'), 'Help Skills Menu',
Sig2Int('HBSM'), 'Help Basic Smithing Weapon',
Sig2Int('HBTA'), 'Help Basic Tanning',
Sig2Int('HBWC'), 'Help Weapon Charge',
Sig2Int('HCLL'), 'FormList Hair Color List',
Sig2Int('HEIK'), 'Helmet Item Keyword',
Sig2Int('HFSD'), 'Heartbeat Sound Fast',
Sig2Int('HMPC'), 'Help Manual PC',
Sig2Int('HMXB'), 'Help Manual XBox',
Sig2Int('HRSK'), 'Keyword Horse',
Sig2Int('HSSD'), 'Heartbeat Sound Slow',
Sig2Int('HVFS'), 'Harvest Failed Sound',
Sig2Int('HVSS'), 'Harvest Sound',
Sig2Int('HWIK'), 'Heavy Weapon Item keyword',
Sig2Int('IMDI'), 'Dialogue Imagespace',
Sig2Int('IMID'), 'ImageSpaceModifier for inventory menu.',
Sig2Int('IMLH'), 'Imagespace: Low Health',
Sig2Int('IMPP'), 'ImageSpaceModifier for Pipboy menu in Power armor.',
Sig2Int('IOPM'), 'Interface Output Model',
Sig2Int('JRLF'), 'Jarl Faction',
Sig2Int('JWLR'), 'Keyword Jewelry',
Sig2Int('KHFL'), 'Kinect Help FormList',
Sig2Int('KTRW'), 'Teammate Ready Weapon',
Sig2Int('KWBR'), 'Color Form',
Sig2Int('KWCU'), 'Keyword Cuirass',
Sig2Int('KWDM'), 'Keyword DummyObject',
Sig2Int('KWDO'), 'Keyword ClearableLocation',
Sig2Int('KWGE'), 'Keyword UseGeometryEmitter',
Sig2Int('KWMS'), 'Keyword MustStop',
Sig2Int('LGH1'), 'Default Light 1',
Sig2Int('LGH2'), 'Default Light 2',
Sig2Int('LGH3'), 'Default Light 3',
Sig2Int('LGH4'), 'Default Light 4',
Sig2Int('LGHP'), 'Pipboy Light',
Sig2Int('LKHO'), 'Keyword Hold Location',
Sig2Int('LKPK'), 'Lockpick',
Sig2Int('LMHP'), 'Local Map Hide Plane',
Sig2Int('LRRD'), 'LocRefType Resource Destructible',
Sig2Int('LRSO'), 'LocRefType Civil War Soldier',
Sig2Int('LSIS'), 'Imagespace: Load screen',
Sig2Int('MBIK'), 'Med Bag Item Keyword',
Sig2Int('MDSC'), 'Music Sound Category',
Sig2Int('MFSN'), 'Magic Fail Sound',
Sig2Int('MGGF'), 'Mages'' Guild Faction',
Sig2Int('MIIK'), 'Mine Item Keyword',
Sig2Int('MMCL'), 'Main Menu Cell',
Sig2Int('MMSD'), 'Map Menu Looping Sound',
Sig2Int('MNTK'), 'Keyword Mount',
Sig2Int('MTSC'), 'Master Sound Category',
Sig2Int('MVBL'), 'Keyword Movable',
Sig2Int('NASD'), 'No-Activation Sound',
Sig2Int('NDSC'), 'Non-Dialogue Voice Category',
Sig2Int('NMRD'), 'Road Marker',
Sig2Int('NPCK'), 'Keyword NPC',
Sig2Int('NRNT'), 'Keyword Nirnroot',
Sig2Int('P3OM'), 'Player''s Output Model 3rd Person',
Sig2Int('PDLC'), 'Pause During Loading Menu Category',
Sig2Int('PDMC'), 'Pause During Menu Category Fade',
Sig2Int('PDSA'), 'Putdown Sound Armor',
Sig2Int('PDSB'), 'Putdown Sound Book',
Sig2Int('PDSG'), 'Putdown Sound Generic',
Sig2Int('PDSI'), 'Putdown Sound Ingredient',
Sig2Int('PDSW'), 'Putdown Sound Weapon',
Sig2Int('PFAC'), 'Player Faction',
Sig2Int('PIMC'), 'Pause During Menu Category Immediate',
Sig2Int('PIVV'), 'Player Is Vampire Variable',
Sig2Int('PIWV'), 'UNUSED01',
Sig2Int('PLOC'), 'PersistAll Location',
Sig2Int('PLST'), 'Default Pack List',
Sig2Int('POEQ'), 'Potion Equip',
Sig2Int('POPM'), 'Player''s Output Model 1st Person',
Sig2Int('PTEM'), 'Package Template',
Sig2Int('PTFR'), 'PotentialFollower Faction',
Sig2Int('PTNP'), 'Pathing Test NPC',
Sig2Int('PUSA'), 'Pickup Sound Armor',
Sig2Int('PUSB'), 'Pickup Sound Book',
Sig2Int('PUSG'), 'Pickup Sound Generic',
Sig2Int('PUSI'), 'Pickup Sound Ingredient',
Sig2Int('PUSW'), 'Pickup Sound Weapon',
Sig2Int('PVFA'), 'Player Voice Female',
Sig2Int('PVFC'), 'Player Voice Female Child',
Sig2Int('PVMA'), 'Player Voice Male',
Sig2Int('PVMC'), 'Player Voice Male Child',
Sig2Int('PWFD'), 'Wait-For-Dialogue Package',
Sig2Int('QMEA'), 'Quest Marker Enemy Above',
Sig2Int('QMEB'), 'Quest Marker Enemy Below',
Sig2Int('QMEN'), 'Quest Marker Enemy',
Sig2Int('QMFO'), 'Quest Marker Follower',
Sig2Int('QMLO'), 'Quest Marker Location',
Sig2Int('RIVR'), 'Vampire Race',
Sig2Int('RIVS'), 'Vampire Spells',
Sig2Int('RIWR'), 'UNUSED02',
Sig2Int('RKIK'), 'Repair Kit Item Keyword',
Sig2Int('RUSG'), 'Keyword Reusable SoulGem',
Sig2Int('RVBT'), 'Reverb Type',
Sig2Int('SALT'), 'Sitting Angle Limit',
Sig2Int('SAT1'), 'Keyword Scale Actor To 1.0',
Sig2Int('SCSD'), 'Soul Captured Sound',
Sig2Int('SFDC'), 'SFX To Fade In Dialogue Category',
Sig2Int('SFSN'), 'Shout Fail Sound',
Sig2Int('SKLK'), 'Skeleton Key',
Sig2Int('SLDM'), 'Snow LOD Material',
Sig2Int('SLHD'), 'Snow LOD Material HD',
Sig2Int('SMLT'), 'Keyword Smelter',
Sig2Int('SMSC'), 'Stats Mute Category',
Sig2Int('SPFK'), 'Keyword Special Furniture',
Sig2Int('SSSC'), 'Stats Music',
Sig2Int('TANN'), 'Keyword Tanning Rack',
Sig2Int('TKAM'), 'Keyword Type Ammo',
Sig2Int('TKAR'), 'Keyword Type Armor',
Sig2Int('TKBK'), 'Keyword Type Book',
Sig2Int('TKGS'), 'Telekinesis Grab Sound',
Sig2Int('TKIG'), 'Keyword Type Ingredient',
Sig2Int('TKKY'), 'Keyword Type Key',
Sig2Int('TKMS'), 'Keyword Type Misc',
Sig2Int('TKPT'), 'Keyword Type Potion',
Sig2Int('TKSG'), 'Keyword Type SoulGem',
Sig2Int('TKTS'), 'Telekinesis Throw Sound',
Sig2Int('TKWP'), 'Keyword Type Weapon',
Sig2Int('TVGF'), 'Thieves'' Guild Faction',
Sig2Int('UNDK'), 'Keyword Undead',
Sig2Int('URVT'), 'Underwater Reverb Type',
Sig2Int('UWLS'), 'Underwater Loop Sound',
Sig2Int('VAMP'), 'Keyword Vampire',
Sig2Int('VLOC'), 'Virtual Location',
Sig2Int('VOEQ'), 'Voice Equip',
Sig2Int('WASN'), 'Ward Absorb Sound',
Sig2Int('WBSN'), 'Ward Break Sound',
Sig2Int('WDSN'), 'Ward Deflect Sound',
Sig2Int('WEML'), 'Weapon Material List',
Sig2Int('WMDA'), 'Keyword Weapon Material Daedric',
Sig2Int('WMDH'), 'Keyword Weapon Material DraugrHoned',
Sig2Int('WMDR'), 'Keyword Weapon Material Draugr',
Sig2Int('WMDW'), 'Keyword Weapon Material Dwarven',
Sig2Int('WMEB'), 'Keyword Weapon Material Ebony',
Sig2Int('WMEL'), 'Keyword Weapon Material Elven',
Sig2Int('WMFA'), 'Keyword Weapon Material Falmer',
Sig2Int('WMFH'), 'Keyword Weapon Material FalmerHoned',
Sig2Int('WMGL'), 'Keyword Weapon Material Glass',
Sig2Int('WMIK'), 'Workshop Misc Item Keyword',
Sig2Int('WMIM'), 'Keyword Weapon Material Imperial',
Sig2Int('WMIR'), 'Keyword Weapon Material Iron',
Sig2Int('WMOR'), 'Keyword Weapon Material Orcish',
Sig2Int('WMST'), 'Keyword Weapon Material Steel',
Sig2Int('WMWE'), 'World Map Weather',
Sig2Int('WMWO'), 'Keyword Weapon Material Wood',
Sig2Int('WPOK'), 'Workshop Player Ownership',
Sig2Int('WTBA'), 'Keyword WeaponTypeBoundArrow',
Sig2Int('WWSP'), 'UNUSED03'
]);
c := CombineVarRecs(a, b);
wbRecord(DOBJ, 'Default Object Manager', [
wbEDID,
wbArrayS(DNAM, 'Objects',
wbStructSK([0], 'Object', [
wbInteger('Use', itU32, wbEnum([], c), cpNormalIgnoreEmpty),
wbFormID('Object ID', cpNormalIgnoreEmpty)
]), 0, cpNormalIgnoreEmpty, True, wbDOBJObjectsAfterLoad
)
]);
wbRecord(LGTM, 'Lighting Template', [
wbEDID,
wbStruct(DATA, 'Lighting', [
wbByteColors('Ambient Color'),
wbByteColors('Directional Color'),
wbByteColors('Fog Color Near'),
wbFloat('Fog Near'),
wbFloat('Fog Far'),
wbInteger('Directional Rotation XY', itS32),
wbInteger('Directional Rotation Z', itS32),
wbFloat('Directional Fade'),
wbFloat('Fog Clip Distance'),
wbFloat('Fog Power'),
wbByteArray('Unused', 32, cpIgnore),
wbByteColors('Fog Color Far'),
wbFloat('Fog Max'),
wbFloat('Light Fade Begin'),
wbFloat('Light Fade End'),
wbByteArray('Unused', 4, cpIgnore),
wbFloat('Near Height Mid'),
wbFloat('Near Height Range'),
wbByteColors('Fog Color High Near'),
wbByteColors('Fog Color High Far'),
wbFloat('High Density Scale'),
wbFloat('Fog Near Scale'),
wbFloat('Fog Far Scale'),
wbFloat('Fog High Near Scale'),
wbFloat('Fog High Far Scale'),
wbFloat('Far Height Mid'),
wbFloat('Far Height Range')
], cpNormal, True, nil, 15),
wbAmbientColors(DALC),
wbFormIDCk(WGDR, 'God Rays', [GDRY])
]);
wbRecord(MUSC, 'Music Type', [
wbEDID,
wbInteger(FNAM, 'Flags', itU32, wbFlags([
{0x01} 'Plays One Selection',
{0x02} 'Abrupt Transition',
{0x04} 'Cycle Tracks',
{0x08} 'Maintain Track Order',
{0x10} 'Unknown 5',
{0x20} 'Ducks Current Track',
{0x40} 'Doesn''t Queue'
]), cpNormal, True),
wbStruct(PNAM, 'Data', [
wbInteger('Priority', itU16),
wbInteger('Ducking (dB)', itU16, wbDiv(100))
]),
wbFloat(WNAM, 'Fade Duration'),
wbArray(TNAM, 'Music Tracks', wbFormIDCk('Track', [MUST, NULL]))
]);
wbRecord(FSTP, 'Footstep', [
wbEDID,
wbFormIDCk(DATA, 'Impact Data Set', [IPDS, NULL], False, cpNormal, True),
wbString(ANAM, 'Tag', 0, cpNormal, True)
]);
wbRecord(FSTS, 'Footstep Set', [
wbEDID,
wbStruct(XCNT, 'Count', [
wbInteger('Walking', itU32),
wbInteger('Running', itU32),
wbInteger('Sprinting', itU32),
wbInteger('Sneaking', itU32),
wbInteger('Swimming', itU32)
], cpNormal, True),
wbArray(DATA, 'Footstep Sets', wbFormIDCk('Footstep', [FSTP]), 0, nil, nil, cpNormal, True)
]);
wbSMNodeFlags := wbFlags([
'Random',
'Warn if no child quest started'
]);
wbRecord(SMBN, 'Story Manager Branch Node', [
wbEDID,
wbFormIDCk(PNAM, 'Parent ', [SMQN, SMBN, SMEN, NULL]),
wbFormIDCk(SNAM, 'Child ', [SMQN, SMBN, SMEN, NULL], False, cpBenign),
wbCITC,
wbCTDAsCount,
wbInteger(DNAM, 'Flags', itU32, wbSMNodeFlags),
wbUnknown(XNAM)
], False, nil, cpNormal, False, nil, wbConditionsAfterSet);
wbRecord(SMQN, 'Story Manager Quest Node', [
wbEDID,
wbFormIDCk(PNAM, 'Parent ', [SMQN, SMBN, SMEN, NULL]),
wbFormIDCk(SNAM, 'Child ', [SMQN, SMBN, SMEN, NULL], False, cpBenign),
wbCITC,
wbCTDAsCount,
wbStruct(DNAM, 'Flags', [
wbInteger('Node Flags', itU16, wbSMNodeFlags),
wbInteger('Quest Flags', itU16, wbFlags([
'Do all before repeating',
'Shares event',
'Num quests to run'
]))
]),
wbInteger(XNAM, 'Max concurrent quests', itU32),
wbInteger(MNAM, 'Num quests to run', itU32),
wbFloat(HNAM, 'Hours until reset'),
wbInteger(QNAM, 'Quest Count', itU32, nil, cpBenign),
wbRArray('Quests', wbRStructSK([0], 'Quest', [
wbFormIDCk(NNAM, 'Quest', [QUST]),
wbUnknown(FNAM),
wbFloat(RNAM, 'Hours until reset', cpNormal, False, 1/24)
], []), cpNormal, False, nil, wbSMQNQuestsAfterSet)
], False, nil, cpNormal, False, nil, wbConditionsAfterSet);
wbRecord(SMEN, 'Story Manager Event Node', [
wbEDID,
wbFormIDCk(PNAM, 'Parent ', [SMQN, SMBN, SMEN, NULL]),
wbFormIDCk(SNAM, 'Child ', [SMQN, SMBN, SMEN, NULL]),
wbCITC,
wbCTDAsCount,
wbInteger(DNAM, 'Flags', itU32, wbSMNodeFlags),
wbUnknown(XNAM),
wbString(ENAM, 'Type', 4)
], False, nil, cpNormal, False, nil, wbConditionsAfterSet);
end;
procedure DefineFO4j;
begin
wbRecord(DLBR, 'Dialog Branch', [
wbEDID,
wbFormIDCk(QNAM, 'Quest', [QUST], False, cpNormal, True),
wbInteger(TNAM, 'Unknown', itU32),
wbInteger(DNAM, 'Flags', itU32, wbFlags([
{0x01} 'Top-Level',
{0x02} 'Blocking',
{0x04} 'Exclusive'
])),
wbFormIDCk(SNAM, 'Starting Topic', [DIAL], False, cpNormal, True)
]);
wbRecord(MUST, 'Music Track', [
wbEDID,
wbInteger(CNAM, 'Track Type', itU32, wbEnum([], [
Int64($23F678C3), 'Palette',
Int64($6ED7E048), 'Single Track',
Int64($A1A9C4D5), 'Silent Track'
]), cpNormal, True),
wbFloat(FLTV, 'Duration'),
wbFloat(DNAM, 'Fade-Out'),
wbString(ANAM, 'Track Filename'),
wbString(BNAM, 'Finale Filename'),
wbStruct(LNAM, 'Loop Data', [
wbFloat('Loop Begins'),
wbFloat('Loop Ends'),
wbInteger('Loop Count', itU32)
]),
wbArray(FNAM, 'Cue Points', wbFloat('Point')),
wbCITC,
wbCTDAsCount,
wbArray(SNAM, 'Tracks', wbFormIDCk('Track', [MUST, NULL]))
], False, nil, cpNormal, False, nil, wbConditionsAfterSet);
wbRecord(DLVW, 'Dialog View', [
wbEDID,
wbFormIDCk(QNAM, 'Quest', [QUST], False, cpNormal, True),
wbRArray('Branches', wbFormIDCk(BNAM, 'Branch', [DLBR])),
wbRArray('Unknown TNAM', wbRStruct('Unknown', [
wbUnknown(TNAM)
], [])),
wbUnknown(ENAM),
wbUnknown(DNAM)
]);
{wbRecord(WOOP, 'Word of Power', [
wbEDID
]);}
{wbRecord(SHOU, 'Shout', [
wbEDID
]);}
wbRecord(EQUP, 'Equip Type', [
wbEDID,
wbArray(PNAM, 'Slot Parents', wbFormIDCk('Parent', [EQUP])),
wbInteger(DATA, 'Flags', itU32, wbFlags([
'Use All Parents',
'Parents Optional',
'Item Slot'
])),
wbFormIDCk(ANAM, 'Condition Actor Value', [AVIF, NULL, FFFF])
]);
wbRecord(RELA, 'Relationship', [
wbEDID,
wbStruct(DATA, 'Data', [
wbFormIDCk('Parent', [NPC_, NULL]),
wbFormIDCk('Child', [NPC_, NULL]),
wbInteger('Rank', itU8, wbEnum([
'Lover',
'Ally',
'Confidant',
'Friend',
'Acquaitance',
'Rival',
'Foe',
'Enemy',
'Archnemesis'
])),
wbByteArray('Unknown', 2),
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Unknown 1',
{0x02} 'Unknown 2',
{0x04} 'Unknown 3',
{0x08} 'Unknown 4',
{0x10} 'Unknown 5',
{0x20} 'Unknown 6',
{0x40} 'Unknown 7',
{0x80} 'Secret'
])),
wbFormIDCk('Association Type', [ASTP, NULL])
])
]);
wbRecord(SCEN, 'Scene', [
wbEDID,
wbVMADFragmentedSCEN,
wbInteger(FNAM, 'Flags', itU32, wbFlags([
{0x00000001} 'Begin on Quest Start',
{0x00000002} 'Stop on Quest End',
{0x00000004} 'Unknown 2',
{0x00000008} 'Repeat Conditions While True',
{0x00000010} 'Interruptible',
{0x00000020} 'Unknown 5',
{0x00000040} 'Prevent Player Exit Dialogue',
{0x00000080} 'Unknown 7',
{0x00000100} 'Unknown 8',
{0x00000200} 'Unknown 9',
{0x00000400} 'Unknown 10',
{0x00000800} 'Disable Dialogue Camera',
{0x00001000} 'No Follower Idle Chatter'
])),
wbRArray('Phases',
wbRStruct('Phase', [
wbEmpty(HNAM, 'Marker Phase Start'),
wbString(NAM0, 'Name'),
wbRStruct('Start Conditions', [wbCTDAs], []),
wbEmpty(NEXT, 'Marker Start Conditions'),
wbRStruct('Completion Conditions', [wbCTDAs], []),
wbEmpty(NEXT, 'Marker Completion Conditions'),
wbInteger(WNAM, 'Editor Width', itU32),
wbInteger(FNAM, 'Flags', itU16, wbFlags([
{0x0001} 'Start - WalkAway Phase',
{0x0002} 'Don''t Run End Scripts on Scene Jump',
{0x0004} 'Start - Inherit In Templated Scenes'
])),
wbStruct(SCQS, 'Set Parent Quest Stage', [
wbInteger('On Start', itS16),
wbInteger('On Completion', itS16)
]),
wbEmpty(HNAM, 'Marker Phase End')
], [])
),
wbRArray('Actors', wbRStruct('Actor', [
wbInteger(ALID, 'Alias ID', itS32),
wbInteger(LNAM, 'Flags', itU32, wbFlags([
'No Player Activation',
'Optional',
'Run Only Scene Packages',
'No Command State'
])),
wbInteger(DNAM, 'Behaviour Flags', itU32, wbFlags([
'Death Pause',
'Death End',
'Combat Pause',
'Combat End',
'Dialogue Pause',
'Dialogue End',
'OBS_COM Pause',
'OBS_COM End'
]))
], [])),
wbRArray('Actions', wbRStruct('Action', [
wbInteger(ANAM, 'Type', itU16, wbEnum([
{0} 'Dialogue',
{1} 'Package',
{2} 'Timer',
{3} 'Player Dialogue',
{4} 'Start Scene',
{5} 'NPC Response Dialogue',
{6} 'Radio'
])),
wbString(NAM0, 'Name'),
wbInteger(ALID, 'Alias ID', itS32),
wbInteger(INAM, 'Index', itU32),
wbInteger(FNAM, 'Flags', itU32, wbFlags([
{0x00000001} 'Unknown 0',
{0x00000002} 'Unknown 1',
{0x00000004} 'Unknown 2',
{0x00000008} 'Unknown 3',
{0x00000010} 'Unknown 4',
{0x00000020} 'Unknown 5',
{0x00000040} 'Unknown 6',
{0x00000080} 'Player Positive Use Dialogue Subtype / Hold Into Next Scene',
{0x00000100} 'Player Negative Use Dialogue Subtype',
{0x00000200} 'Player Neutral Use Dialogue Subtype',
{0x00000400} 'Use Dialogue Subtype',
{0x00000800} 'Player Question Use Dialogue Subtype',
{0x00001000} 'Keep/Clear Target on Action End',
{0x00002000} 'Unknown 13',
{0x00004000} 'Unknown 14',
{0x00008000} 'Face Target',
{0x00010000} 'Looping',
{0x00020000} 'Headtrack Player',
{0x00040000} 'Unknown 18',
{0x00080000} 'Ignore For Completion',
{0x00100000} 'Unknown 20',
{0x00200000} 'Camera Speaker Target',
{0x00400000} 'Complete Face Target',
{0x00800000} 'Unknown 23',
{0x01000000} 'Unknown 24',
{0x02000000} 'Unknown 25',
{0x04000000} 'Unknown 26',
{0x08000000} 'NPC Positive Use Dialogue Subtype',
{0x10000000} 'NPC Negative Use Dialogue Subtype',
{0x20000000} 'NPC Neutral Use Dialogue Subtype',
{0x40000000} 'NPC Question Use Dialogue Subtype'
])),
wbInteger(SNAM, 'Start Phase', itU32),
wbInteger(ENAM, 'End Phase', itU32),
wbFloat(SNAM, 'Timer - Max Seconds'),
wbInteger(SCQS, 'Set Parent Quest Stage', itS16),
wbFloat(TNAM, 'Timer - Min Seconds'),
wbUnknown(STSC),
wbRStructs('Start Scenes', 'Start Scene', [
wbFormIDCk(LCEP, 'Scene', [SCEN]),
wbInteger(INTT, 'Phase Index', itU16),
wbString(SSPN, 'Start Phase for Scene'),
wbCITC,
wbCTDAs
], []),
wbFormIDCk(PTOP, 'Player Positive Response', [DIAL]),
wbFormIDCk(NTOP, 'Player Negative Response', [DIAL]),
wbFormIDCk(NETO, 'Player Neutral Response', [DIAL]),
wbFormIDCk(QTOP, 'Player Question Response', [DIAL]),
wbFormIDCk(VENC, 'Player Positive Dialogue Subtype', [KYWD]),
wbFormIDCk(PLVD, 'Player Negative Dialogue Subtype', [KYWD]),
wbFormIDCk(JOUT, 'Player Neutral Dialogue Subtype', [KYWD]),
wbFormIDCk(DALC, 'Player Question Dialogue Subtype', [KYWD]),
wbArray(DTID, 'NPC Headtracking', wbInteger('Actor ID', itS32)),
wbFormIDCk(NPOT, 'NPC Positive Response', [DIAL]),
wbFormIDCk(NNGT, 'NPC Negative Response', [DIAL]),
wbFormIDCk(NNUT, 'NPC Neutral Response', [DIAL]),
wbFormIDCk(NQUT, 'NPC Question Response', [DIAL]),
wbFormIDCk(NPOS, 'NPC Positive Dialogue Subtype', [KYWD]),
wbFormIDCk(NNGS, 'NPC Negative Dialogue Subtype', [KYWD]),
wbFormIDCk(NNUS, 'NPC Neutral Dialogue Subtype', [KYWD]),
wbFormIDCk(NQUS, 'NPC Question Dialogue Subtype', [KYWD]),
wbInteger(DTGT, 'Dialogue Target Actor', itS32),
wbRArray('Packages', wbFormIDCk(PNAM, 'Package', [PACK])),
wbFormIDCk(DATA, 'Topic', [DIAL, NULL]),
wbUnion(HTID, '', wbSceneActionSoundDecider, [
wbEmpty('End Scene Say Greeting'),
wbFormIDCk('Play Sound', [SNDR, NULL])
]),
wbFloat(DMAX, 'Looping - Max'),
wbFloat(DMIN, 'Looping - Min'),
wbStruct(CRIS, 'Camera', [
wbFloat('FOV On Player Camera'),
wbFloat('Rate Of Camera Change')
]),
wbInteger(DEMO, 'Emotion Type', itU32, wbEmotionTypeEnum),
wbInteger(DEVA, 'Emotion Value', itU32),
wbArray(HTID, 'Player Headtracking', wbInteger('Actor ID', itS32)),
wbFormIDCk(VENC, 'Dialogue Subtype', [KYWD]),
wbFormIDCk(PNAM, 'AnimArchType', [KYWD]),
wbFormIDCk(ONAM, 'Audio Output Override', [SOPM]),
wbEmpty(ANAM, 'End Marker')
], [])),
wbFormIDCk(PNAM, 'Quest', [QUST]),
wbInteger(INAM, 'Last Action Index', itU32),
wbUnknown(VNAM),
wbFloat(CNAM, 'Camera Distance Override'),
wbFloat(ACTV, 'Dialogue Distance Override'),
wbFloat(CRIS, 'FOV Override'),
wbKSIZ,
wbKWDAs,
wbCTDAs,
wbStruct(SCQS, 'Set Parent Quest Stage', [
wbInteger('On Begin', itS16),
wbInteger('On End', itS16)
]),
wbString(NNAM, 'Notes'),
wbFormIDCk(TNAM, 'Template Scene', [SCEN]),
wbInteger(XNAM, 'Index', itU32)
]);
wbRecord(ASTP, 'Association Type', [
wbEDID,
wbString(MPRT, 'Male Parent Title'),
wbString(FPRT, 'Female Parent Title'),
wbString(MCHT, 'Male Child Title'),
wbString(FCHT, 'Female Child Title'),
wbInteger(DATA, 'Flags', itU32, wbFlags([
'Family Association'
]))
]);
end;
procedure DefineFO4k;
begin
wbSPED := wbStruct(SPED, 'Movement Data', [
wbFloat('Unknown'),
wbFloat('Walk - Left'),
wbFloat('Run - Left'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Walk - Right'),
wbFloat('Run - Right'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Walk - Forward'),
wbFloat('Run - Forward'),
wbFloat('Sprint - Forward'),
wbFloat('Unknown'),
wbFloat('Walk - Back'),
wbFloat('Run - Back'),
wbFloat('Unknown'),
wbFloat('Standing - Pitch', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Walk - Pitch', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Run - Pitch', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Sprint - Pitch', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Unknown'{, cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize}),
wbFloat('Unknown'{, cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize}),
wbFloat('Unknown'{, cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize}),
wbFloat('Unknown'{, cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize}),
wbFloat('Standing - Yaw', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Walk - Yaw', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Run - Yaw', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Sprint - Yaw', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize)
], cpNormal, True, nil, 10);
wbRecord(OTFT, 'Outfit', [
wbEDID,
wbArrayS(INAM, 'Items', wbFormIDCk('Item', [ARMO, LVLI]))
]);
wbRecord(ARTO, 'Art Object', [
wbEDID,
wbOBNDReq,
wbPTRN,
wbKSIZ,
wbKWDAs,
wbMODL,
wbInteger(DNAM, 'Art Type', itU32, wbEnum([
'Magic Casting',
'Magic Hit Effect',
'Enchantment Effect'
]))
]);
wbRecord(MATO, 'Material Object', [
wbEDID,
wbMODL,
wbRArray('Property Data',
wbByteArray(DNAM, 'Data', 0, cpIgnore, False, False, wbNeverShow)
),
wbStruct(DATA, 'Directional Material Data', [
wbFloat('Falloff Scale'),
wbFloat('Falloff Bias'),
wbFloat('Noise UV Scale'),
wbFloat('Material UV Scale'),
wbStruct('Projection Vector', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbFloat('Normal Dampener'),
wbFloatColors('Single Pass Color'),
wbInteger('Flags', itU32, wbFlags(['Single Pass']))
], cpNormal, True, nil, 5)
]);
wbRecord(MOVT, 'Movement Type', [
wbEDID,
wbString(MNAM, 'Name'),
wbSPED,
wbStruct(INAM, 'Anim Change Thresholds (unused)', [
wbFloat('Directional', cpNormal, True, 180/Pi),
wbFloat('Movement Speed'),
wbFloat('Rotation Speed', cpNormal, True, 180/Pi)
]),
wbFloat(JNAM, 'Float Height'),
wbFloat(LNAM, 'Flight - Angle Gain')
]);
wbRecord(SNDR, 'Sound Descriptor', [
wbEDID,
wbString(NNAM, 'Notes'),
wbInteger(CNAM, 'Descriptor Type', itU32, wbEnum([], [
Int64($1EEF540A), 'Standard',
Int64($54651A43), 'Compound',
Int64($ED157AE3), 'AutoWeapon'
])),
wbFormIDCk(GNAM, 'Category', [SNCT]),
wbFormIDCk(SNAM, 'Alternate Sound For', [SNDR]),
wbRArray('Sounds',
wbRStruct('Sound Files', [
wbString(ANAM, 'File Name')
], [])
),
wbFormIDCk(ONAM, 'Output Model', [SOPM]),
wbCTDAs,
wbStruct(LNAM, 'Values', [
wbByteArray('Unknown', 1),
wbInteger('Looping', itU8, wbEnum([], [
$00, 'None',
$08, 'Loop',
$10, 'Envelope Fast',
$20, 'Envelope Slow'
])),
wbInteger('Sidechain', itU8),
wbInteger('Rumble Send Value = (Small / 7) + ((Big / 7) * 16)', itU8)
]),
wbUnion(BNAM, 'Data', wbSNDRDataDecider, [
wbStruct('Values', [
wbInteger('% Frequency Shift', itS8),
wbInteger('% Frequency Variance', itS8),
wbInteger('Priority', itU8),
wbInteger('db Variance', itU8),
wbInteger('Static Attenuation (db)', itU16, wbDiv(100))
]),
wbFormIDCk('Base Descriptor', [SNDR])
]),
wbRArray('Descriptors', wbFormIDCk(DNAM, 'Descriptor', [SNDR])),
wbInteger(ITMC, 'Count', itU32, nil, cpBenign),
wbRArrayS('Rates of Fire',
wbRStructSK([1], 'Sound', [
wbEmpty(ITMS, 'Marker Start'),
wbInteger(INTV, 'RoF (RPM)', itU32),
wbString(FNAM, 'File'),
wbEmpty(ITME, 'Marker End')
], []),
cpNormal, False, nil, wbSNDRRatesOfFireAfterSet
)
]);
wbRecord(DUAL, 'Dual Cast Data', [
wbEDID
]);
wbRecord(SNCT, 'Sound Category', [
wbEDID,
wbFULL,
wbInteger(FNAM, 'Flags', itU32, wbFlags([
{0x0000001} 'Mute When Submerged',
{0x0000002} 'Should Appear on Menu',
{0x0000004} 'Immune to Time Speedup',
{0x0000008} 'Pause During Menus (Immed)',
{0x0000010} 'Pause During Menus (Fade)',
{0x0000020} 'Exclude from Player OPM Override',
{0x0000040} 'Pause During Start Menu'
]), cpNormal, True),
wbFormIDCk(PNAM, 'Parent Category', [SNCT]),
wbFormIDCk(ONAM, 'Menu Slider Category', [SNCT]),
wbInteger(VNAM, 'Static Volume Multiplier', itU16, wbDiv(65535)),
wbInteger(UNAM, 'Default Menu Value', itU16, wbDiv(65535)),
wbFloat(MNAM, 'Min Frequency Multiplier'),
wbFloat(CNAM, 'Sidechain Target Multiplier')
]);
wbRecord(SOPM, 'Sound Output Model', [
wbEDID,
wbStruct(NAM1, 'Data', [
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Attenuates With Distance',
{0x02} 'Allows Rumble',
{0x04} 'Applies Doppler',
{0x08} 'Applies Distance Delay',
{0x10} 'Player Output Model',
{0x20} 'Try Play on Controller',
{0x40} 'Causes Ducking',
{0x80} 'Avoids Ducking'
])),
wbByteArray('Unknown', 2),
wbInteger('Reverb Send %', itU8)
]),
wbInteger(MNAM, 'Type', itU32, wbEnum([
'Uses HRTF',
'Defined Speaker Output'
])),
wbInteger(VNAM, 'Static Attenuation', itS16, wbDiv(100)),
wbStruct(ONAM, 'Output Values', [
wbArray('Channels', wbStruct('', [
wbInteger('FL', itU8),
wbInteger('FR', itU8),
wbInteger('C', itU8),
wbInteger('LFE', itU8),
wbInteger('RL', itU8),
wbInteger('RR', itU8),
wbInteger('SL', itU8),
wbInteger('SR', itU8)
]), [
'Channel 0',
'Channel 1',
'Channel 2? (unused)'
])
]),
wbStruct(ATTN, 'Attenuation Values', [
wbFloat('Fade In Distance - Start'),
wbFloat('Fade In Distance - End'),
wbFloat('Fade Out Distance - Start'),
wbFloat('Fade Out Distance - End'),
wbStruct('Fade In Curve', [
wbInteger('Value 1', itU8),
wbInteger('Value 2', itU8),
wbInteger('Value 3', itU8),
wbInteger('Value 4', itU8)
]),
wbStruct('Fade Out Curve', [
wbInteger('Value 1', itU8),
wbInteger('Value 2', itU8),
wbInteger('Value 3', itU8),
wbInteger('Value 4', itU8)
])
]),
wbFormIDCk(ENAM, 'Effect Chain', [AECH])
]);
wbRecord(COLL, 'Collision Layer', [
wbEDID,
wbDESCReq,
wbInteger(BNAM, 'Index', itU32, nil, cpNormal, True),
wbStruct(FNAM, 'Debug Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbInteger('Unused', itU8)
], cpNormal, True),
wbInteger(GNAM, 'Flags', itU32, wbFlags([
{0x00000001} 'Trigger Volume',
{0x00000002} 'Sensor',
{0x00000004} 'Navmesh Obstacle'
]), cpNormal, True),
wbString(MNAM, 'Name', 0, cpNormal, True),
wbInteger(INTV, 'Interactables Count', itU32, nil, cpNormal, True),
wbArrayS(CNAM, 'Collides With', wbFormIDCk('Forms', [COLL]), 0, cpNormal, False)
]);
wbRecord(CLFM, 'Color',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000004} 2, 'Non-Playable'
])), [
wbEDID,
wbFULL,
// union decider doesn't work during copying since decision data FNAM is located after it
// workaround using integer formatters
wbInteger(CNAM, 'Color/Index', itU32, wbCLFMColorToStr, wbCLFMColorToInt),
{wbUnion(CNAM, 'Value', wbCLFMColorDecider, [
wbByteColors('Color'),
wbFloat('Remapping Index')
]),}
wbInteger(FNAM, 'Flags', itU32, wbFlags([
'Playable',
'Remapping Index',
'Extended LUT'
]), cpNormal, True),
wbCTDAs
]);
end;
procedure DefineFO4l;
begin
wbRecord(REVB, 'Reverb Parameters', [
wbEDID,
wbStruct(DATA, 'Data', [
wbInteger('Decay Time (ms)', itU16),
wbInteger('HF Reference (Hz)', itU16),
wbInteger('Room Filter', itS8),
wbInteger('Room HF Filter', itS8),
wbInteger('Reflections', itS8),
wbInteger('Reverb Amp', itS8),
wbInteger('Decay HF Ratio', itU8, wbDiv(100)),
wbInteger('Reflect Delay (ms), scaled', itU8),
wbInteger('Reverb Delay (ms)', itU8),
wbInteger('Diffusion %', itU8),
wbInteger('Density %', itU8),
wbInteger('Unknown', itU8)
], cpNormal, True),
wbInteger(ANAM, 'Reverb Class', itU32, wbReverbClassEnum, cpNormal, True)
]);
wbRecord(GRAS, 'Grass', [
wbEDID,
wbOBNDReq,
wbMODL,
wbStruct(DATA, '', [
wbInteger('Density', itU8),
wbInteger('Min Slope', itU8),
wbInteger('Max Slope', itU8),
wbByteArray('Unknown', 1),
wbInteger('Units From Water', itU16),
wbByteArray('Unknown', 2),
wbInteger('Units From Water Type', itU32, wbEnum([
'Above - At Least',
'Above - At Most',
'Below - At Least',
'Below - At Most',
'Either - At Least',
'Either - At Most',
'Either - At Most Above',
'Either - At Most Below'
])),
wbFloat('Position Range'),
wbFloat('Height Range'),
wbFloat('Color Range'),
wbFloat('Wave Period'),
wbInteger('Flags', itU8, wbFlags([
'Vertex Lighting',
'Uniform Scaling',
'Fit to Slope'
])),
wbByteArray('Unknown', 3)
], cpNormal, True)
]);
wbRecord(IDLE, 'Idle Animation', [
wbEDID,
wbCTDAs,
wbString(DNAM, 'Behavior Graph'),
wbString(ENAM, 'Animation Event'),
wbArray(ANAM, 'Related Idle Animations', wbFormIDCk('Related Idle Animation', [AACT, IDLE, NULL]),
['Parent', 'Previous Sibling'], cpNormal, True),
wbStruct(DATA, '', [
wbStruct('Looping seconds (both 255 forever)', [
wbInteger('Min', itU8),
wbInteger('Max', itU8)
]),
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Parent',
{0x02} 'Sequence',
{0x04} 'No Attacking',
{0x04} 'Blocking'
], True)),
wbInteger('Animation Group Section', itU8{, wbIdleAnam}),
wbInteger('Replay Delay', itU16)
], cpNormal, True),
wbString(GNAM, 'Animation File')
]);
wbRecord(INFO, 'Dialog response',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000040} 6, 'Unknown 6',
{0x00000080} 7, 'Exclude From Export',
{0x00002000} 13, 'Actor Changed'
])), [
wbEDID,
wbVMADFragmentedINFO,
wbStruct(ENAM, 'Response flags', [
wbInteger('Flags', itU16, wbFlags([
{0x0001} 'Start Scene on End',
{0x0002} 'Random',
{0x0004} 'Say Once',
{0x0008} 'Requires Player Activation',
{0x0010} 'Unknown 4',
{0x0020} 'Random End',
{0x0040} 'End Running Scene',
{0x0080} 'ForceGreet Hello',
{0x0100} 'Player Address',
{0x0200} 'Unknown 9',
{0x0400} 'Can Move While Greeting',
{0x0800} 'No LIP File',
{0x1000} 'Requires post-processing',
{0x2000} 'Audio Output Override',
{0x4000} 'Has Capture',
{0x8000} 'Unknown 16'
])),
wbInteger('Reset Hours', itU16, wbDiv(2730))
]),
wbFormIDCk(TPIC, 'Topic', [DIAL]),
wbFormIDCkNoReach(PNAM, 'Previous INFO', [INFO, NULL], False, cpBenign),
wbFormIDCk(DNAM, 'Shared INFO', [INFO]),
wbFormIDCk(GNAM, 'Unknown', [INFO]),
wbString(IOVR, 'Override Filename'),
wbRArray('Responses', wbRStruct('Response', [
wbStruct(TRDA, 'Response Data', [
wbFormIDCk('Emotion', [KYWD, FFFF]),
wbInteger('Response number', itU8),
wbByteArray('Unused', 3),
wbByteArray('Unknown', 2),
wbInteger('Interrupt Percentage', itU16),
wbInteger('Camera Target Alias', itS32),
wbInteger('Camera Location Alias', itS32)
]),
wbLStringKC(NAM1, 'Response Text', 0, cpTranslate, True),
wbString(NAM2, 'Script Notes', 0, cpNormal, True),
wbString(NAM3, 'Edits', 0, cpNormal, True),
wbString(NAM4, 'Alternate LIP Text', 0, cpNormal, True),
wbFormIDCk(SNAM, 'Idle Animations: Speaker', [IDLE]),
wbFormIDCk(LNAM, 'Idle Animations: Listener', [IDLE]),
wbInteger(TNAM, 'Interrupt Percentage', itU16),
wbByteArray(NAM9, 'Text Hash'),
wbFormIDCk(SRAF, 'Camera Path', [CPTH]),
wbEmpty(WZMD, 'Stop on Scene End')
], [])),
wbCTDAs,
wbLString(RNAM, 'Prompt', 0, cpTranslate),
wbFormIDCk(ANAM, 'Speaker', [NPC_]),
wbFormIDCk(TSCE, 'Start Scene', [SCEN]),
wbInteger(ALFA, 'Forced Alias', itS32),
wbUnknown(INTV),
wbFormIDCk(ONAM, 'Audio Output Override', [SOPM]),
wbInteger(GREE, 'Greet Distance', itU32),
wbStruct(TIQS, 'Set Parent Quest Stage', [
wbInteger('On Begin', itS16),
wbInteger('On End', itS16)
]),
wbString(NAM0, 'Start Scene Phase'),
wbInteger(INCC, 'Challenge', itU32, wbEnum([
{0} 'None',
{1} 'Easy',
{2} 'Medium',
{3} 'Hard',
{4} 'Always Succeeds',
{5} 'Easy Repeatable',
{6} 'Medium Repeatable',
{7} 'Hard Repeatable'
])),
wbFormIDCk(MODQ, 'Reset Global', [GLOB]),
wbInteger(INAM, 'Subtitle Priority', itU32, wbEnum([
'Low',
'Normal',
'Unknown 2',
'Force'
]))
], False, wbINFOAddInfo, cpNormal, False, nil{wbINFOAfterLoad});
wbRecord(INGR, 'Ingredient', [
wbEDID,
wbVMAD,
wbOBNDReq,
wbFULL,
wbKSIZ,
wbKWDAs,
wbMODL,
wbICON,
wbMICO,
wbDEST,
wbETYP,
wbYNAM,
wbZNAM,
wbStruct(DATA, '', [
wbInteger('Value', itS32),
wbFloat('Weight')
], cpNormal, True),
wbStruct(ENIT, 'Effect Data', [
wbInteger('Ingredient Value', itS32),
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'No auto-calculation',
{0x00000002} 'Food item',
{0x00000004} 'Unknown 3',
{0x00000008} 'Unknown 4',
{0x00000010} 'Unknown 5',
{0x00000020} 'Unknown 6',
{0x00000040} 'Unknown 7',
{0x00000080} 'Unknown 8',
{0x00000100} 'References Persist'
]))
], cpNormal, True),
wbEffectsReq
], False, nil, cpNormal, False, nil, wbKeywordsAfterSet);
wbRecord(KEYM, 'Key',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000800} 11, 'Calc Value From Components',
{0x00002000} 13, 'Pack-In Use Only'
])), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFULLReq,
wbMODL,
wbICON,
wbMICO,
wbDEST,
wbYNAM,
wbZNAM,
wbKSIZ,
wbKWDAs,
wbStruct(DATA, '', [
wbInteger('Value', itS32),
wbFloat('Weight')
], cpNormal, True)
], False, nil, cpNormal, False, nil, wbKeywordsAfterSet);
wbQuadrantEnum := wbEnum([
{0} 'Bottom Left',
{1} 'Bottom Right',
{2} 'Top Left',
{3} 'Top Right'
]);
if wbSimpleRecords then begin
wbRecord(LAND, 'Landscape',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00040000} 18, 'Compressed'
]), [18]), [
wbByteArray(DATA, 'Unknown'),
wbByteArray(VNML, 'Vertex Normals'),
wbByteArray(VHGT, 'Vertext Height Map'),
wbByteArray(VCLR, 'Vertex Colours'),
wbRArrayS('Layers', wbRUnion('Layer', [
wbRStructSK([0],'Base Layer', [
wbStructSK(BTXT, [1, 3], 'Base Layer Header', [
wbFormIDCk('Texture', [LTEX, NULL]),
wbInteger('Quadrant', itU8, wbQuadrantEnum),
wbByteArray('Unknown', 1),
wbInteger('Layer', itS16)
])
], []),
wbRStructSK([0],'Alpha Layer', [
wbStructSK(ATXT, [1, 3], 'Alpha Layer Header', [
wbFormIDCk('Texture', [LTEX, NULL]),
wbInteger('Quadrant', itU8, wbQuadrantEnum),
wbByteArray('Unknown', 1),
wbInteger('Layer', itS16)
]),
wbByteArray(VTXT, 'Alpha Layer Data')
], [])
], [])),
wbArray(VTEX, 'Textures', wbFormIDCk('Texture', [LTEX, NULL])),
wbRArray('Unknown', wbUnknown(MPCD))
]);
end else begin
wbRecord(LAND, 'Landscape',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00040000} 18, 'Compressed'
]), [18]), [
wbByteArray(DATA, 'Unknown'),
wbArray(VNML, 'Vertex Normals', wbStruct('Row', [
wbArray('Columns', wbStruct('Column', [
wbInteger('X', itU8),
wbInteger('Y', itU8),
wbInteger('Z', itU8)
]), 33)
]), 33),
wbStruct(VHGT, 'Vertext Height Map', [
wbFloat('Offset'),
wbArray('Rows', wbStruct('Row', [
wbArray('Columns', wbInteger('Column', itU8), 33)
]), 33),
wbByteArray('Unknown', 3)
]),
wbArray(VCLR, 'Vertex Colours', wbStruct('Row', [
wbArray('Columns', wbStruct('Column', [
wbInteger('X', itU8),
wbInteger('Y', itU8),
wbInteger('Z', itU8)
]), 33)
]), 33),
wbRArrayS('Layers', wbRUnion('Layer', [
wbRStructSK([0],'Base Layer', [
wbStructSK(BTXT, [1, 3], 'Base Layer Header', [
wbFormIDCk('Texture', [LTEX, NULL]),
wbInteger('Quadrant', itU8, wbQuadrantEnum),
wbByteArray('Unknown', 1),
wbInteger('Layer', itS16)
])
], []),
wbRStructSK([0],'Alpha Layer', [
wbStructSK(ATXT, [1, 3], 'Alpha Layer Header', [
wbFormIDCk('Texture', [LTEX, NULL]),
wbInteger('Quadrant', itU8, wbQuadrantEnum),
wbByteArray('Unknown', 1),
wbInteger('Layer', itS16)
]),
wbArrayS(VTXT, 'Alpha Layer Data', wbStructSK([0], 'Cell', [
wbInteger('Position', itU16, wbAtxtPosition),
wbByteArray('Unknown', 2),
wbFloat('Opacity')
]))
], [])
], [])),
wbArray(VTEX, 'Textures', wbFormIDCk('Texture', [LTEX, NULL])),
wbRArray('Unknown', wbUnknown(MPCD))
]);
end;
wbRecord(LIGH, 'Light',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00010000} 16, 'Random Anim Start',
{0x00020000} 17, 'Unknown 17',
{0x00020000} 25, 'Obstacle',
{0x00020000} 28, 'Portal-strict'
])), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbMODL,
wbKSIZ,
wbKWDAs,
wbDEST,
wbPRPS,
wbFULL,
wbICON,
wbMICO,
wbStruct(DATA, '', [
wbInteger('Time', itS32),
wbInteger('Radius', itU32),
wbByteColors('Color'),
// Omnidirectional is the default type
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Unknown 0',
{0x00000002} 'Can be Carried',
{0x00000004} 'Unknown 2',
{0x00000008} 'Flicker',
{0x00000010} 'Unknown 4',
{0x00000020} 'Off By Default',
{0x00000040} 'Unknown 6',
{0x00000080} 'Pulse',
{0x00000100} 'Unknown 8',
{0x00000200} 'Unknown 9',
{0x00000400} 'Shadow Spotlight',
{0x00000800} 'Shadow Hemisphere',
{0x00001000} 'Shadow OmniDirectional',
{0x00002000} 'Unknown 13',
{0x00004000} 'NonShadow Spotlight',
{0x00008000} 'Non Specular',
{0x00010000} 'Attenuation Only',
{0x00020000} 'NonShadow Box',
{0x00040000} 'Ignore Roughness',
{0x00080000} 'No Rim Lighting',
{0x00100000} 'Ambient Only',
{0x00200000} 'Unknown 21' // only in [001C7F0C]
])),
wbFloat('Falloff Exponent'),
wbFloat('FOV'),
wbFloat('Near Clip'),
wbStruct('Flicker Effect', [
wbFloat('Period'),
wbFloat('Intensity Amplitude'),
wbFloat('Movement Amplitude')
]),
wbFloat('Constant'),
wbFloat('Scalar'),
wbFloat('Exponent'),
wbFloat('God Rays - Near Clip'),
wbInteger('Value', itU32),
wbFloat('Weight')
], cpNormal, True, nil, 10),
wbFloat(FNAM, 'Fade value', cpNormal, True),
wbString(NAM0, 'Gobo'),
wbFormIDCk(LNAM, 'Lens', [LENS]),
wbFormIDCk(WGDR, 'God Rays', [GDRY]),
wbFormIDCk(SNAM, 'Sound', [SNDR])
], False, nil, cpNormal, False, wbLIGHAfterLoad);
end;
procedure DefineFO4m;
begin
wbRecord(LSCR, 'Load Screen',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000400} 10, 'Displays In Main Menu',
{0x00008000} 15, 'No Rotation'
])), [
wbEDID,
wbDESCReq,
wbCTDAs,
wbFormIDCk(NNAM, 'Loading Screen NIF', [STAT, SCOL, NULL], False, cpNormal, True),
wbFormIDCk(TNAM, 'Transform', [TRNS]),
wbStruct(ONAM, 'Rotation', [
wbInteger('Min', itS16),
wbInteger('Max', itS16)
]),
wbStruct(ZNAM, 'Zoom', [
wbFloat('Min'),
wbFloat('Max')
]),
wbString(MOD2, 'Camera Path', 0, cpNormal, False)
]);
wbRecord(LTEX, 'Landscape Texture', [
wbEDID,
wbFormIDCk(TNAM, 'Texture Set', [TXST], False, cpNormal, False),
wbFormIDCk(MNAM, 'Material Type', [MATT, NULL], False, cpNormal, True),
wbStruct(HNAM, 'Havok Data', [
wbInteger('Friction', itU8),
wbInteger('Restitution', itU8)
], cpNormal, True),
wbInteger(SNAM, 'Texture Specular Exponent', itU8, nil, cpNormal, True),
wbRArray('Grasses', wbFormIDCk(GNAM, 'Grass', [GRAS]))
]);
wbRecord(LVLN, 'Leveled NPC', [
wbEDID,
wbOBNDReq,
wbLVLD,
wbInteger(LVLM, 'Max Count', itU8), { Always 00 } {Unavailable}
wbInteger(LVLF, 'Flags', itU8, wbFlags([
{0x01} 'Calculate from all levels <= player''s level',
{0x02} 'Calculate for each item in count',
{0x04} 'Calculate All' {Still picks just one}
]), cpNormal, True),
wbFormIDCk(LVLG, 'Use Global', [GLOB]),
wbLLCT,
wbRArrayS('Leveled List Entries',
wbRStructExSK([0], [1], 'Leveled List Entry', [
wbStructExSK(LVLO , [0, 2], [3], 'Base Data', [
wbInteger('Level', itU16),
wbByteArray('Unused', 2, cpIgnore, false, wbNeverShow),
wbFormIDCk('Reference', [NPC_, LVLN]),
wbInteger('Count', itS16),
wbInteger('Chance None', itU8),
wbByteArray('Unused', 1, cpIgnore, false, wbNeverShow)
]),
wbCOED
], []), cpNormal, False, nil, wbLVLOsAfterSet),
wbArrayS(LLKC, 'Filter Keyword Chances',
wbStructSK([0], 'Filter', [
wbFormIDCk('Keyword', [KYWD]),
wbInteger('Chance', itU32)
])
),
wbMODL
], False, nil, cpNormal, False, wbLLEAfterLoad, wbLLEAfterSet);
wbRecord(LVLI, 'Leveled Item', [
wbEDID,
wbOBNDReq,
wbLVLD,
wbInteger(LVLM, 'Max Count', itU8), { Always 00 }
wbInteger(LVLF, 'Flags', itU8, wbFlags([
{0x01} 'Calculate from all levels <= player''s level',
{0x02} 'Calculate for each item in count',
{0x04} 'Use All'
]), cpNormal, True),
wbFormIDCk(LVLG, 'Use Global', [GLOB]),
wbLLCT,
wbRArrayS('Leveled List Entries',
wbRStructExSK([0], [1], 'Leveled List Entry', [
wbStructExSK(LVLO , [0, 2], [3], 'Base Data', [
wbInteger('Level', itU16),
wbByteArray('Unused', 2, cpIgnore, false, wbNeverShow),
wbFormIDCk('Reference', sigBaseObjects),
wbInteger('Count', itU16),
wbInteger('Chance None', itU8),
wbByteArray('Unused', 1, cpIgnore, false, wbNeverShow)
]),
wbCOED
], []), cpNormal, False, nil, wbLVLOsAfterSet
),
wbArrayS(LLKC, 'Filter Keyword Chances',
wbStructSK([0], 'Filter', [
wbFormIDCk('Keyword', [KYWD]),
wbInteger('Chance', itU32)
])
),
wbFormIDCk(LVSG, 'Epic Loot Chance', [GLOB]),
wbLStringKC(ONAM, 'Override Name', 0, cpTranslate)
], False, nil, cpNormal, False, wbLLEAfterLoad, wbLLEAfterSet);
wbRecord(LVSP, 'Leveled Spell', [
wbEDID
]);
wbMGEFType := wbInteger('Archetype', itU32, wbEnum([
{00} 'Value Modifier',
{01} 'Script',
{02} 'Dispel',
{03} 'Cure Disease',
{04} 'Absorb',
{05} 'Dual Value Modifier',
{06} 'Calm',
{07} 'Demoralize',
{08} 'Frenzy',
{09} 'Disarm',
{10} 'Command Summoned',
{11} 'Invisibility',
{12} 'Light',
{13} 'Darkness',
{14} 'Nighteye',
{15} 'Lock',
{16} 'Open',
{17} 'Bound Weapon',
{18} 'Summon Creature',
{19} 'Detect Life',
{20} 'Telekinesis',
{21} 'Paralysis',
{22} 'Reanimate',
{23} 'Soul Trap',
{24} 'Turn Undead',
{25} 'Guide',
{26} 'Unknown 26',
{27} 'Cure Paralysis',
{28} 'Cure Addiction',
{29} 'Cure Poison',
{30} 'Concussion',
{31} 'Stimpack',
{32} 'Accumulate Magnitude',
{33} 'Stagger',
{34} 'Peak Value Modifier',
{35} 'Cloak',
{36} 'Unknown 36',
{37} 'Slow Time',
{38} 'Rally',
{39} 'Enhance Weapon',
{40} 'Spawn Hazard',
{41} 'Etherealize',
{42} 'Banish',
{43} 'Spawn Scripted Ref',
{44} 'Disguise',
{45} 'Damage',
{46} 'Immunity',
{47} 'Permanent Reanimate',
{48} 'Jetpack',
{49} 'Chameleon'
]), cpNormal, False, nil, wbMGEFArchtypeAfterSet);
wbMGEFData := wbRStruct('Magic Effect Data', [
wbStruct(DATA, 'Data', [
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Hostile',
{0x00000002} 'Recover',
{0x00000004} 'Detrimental',
{0x00000008} 'Snap to Navmesh',
{0x00000010} 'No Hit Event',
{0x00000020} 'Unknown 6',
{0x00000040} 'Unknown 7',
{0x00000080} 'Unknown 8',
{0x00000100} 'Dispel with Keywords',
{0x00000200} 'No Duration',
{0x00000400} 'No Magnitude',
{0x00000800} 'No Area',
{0x00001000} 'FX Persist',
{0x00002000} 'Unknown 14',
{0x00004000} 'Gory Visuals',
{0x00008000} 'Hide in UI',
{0x00010000} 'Unknown 17',
{0x00020000} 'No Recast',
{0x00040000} 'Unknown 19',
{0x00080000} 'Unknown 20',
{0x00100000} 'Unknown 21',
{0x00200000} 'Power Affects Magnitude',
{0x00400000} 'Power Affects Duration',
{0x00800000} 'Unknown 24',
{0x01000000} 'Unknown 25',
{0x02000000} 'Unknown 26',
{0x04000000} 'Painless',
{0x08000000} 'No Hit Effect',
{0x10000000} 'No Death Dispel',
{0x20000000} 'Unknown 30',
{0x40000000} 'Unknown 31',
{0x80000000} 'Unknown 32'
])),
wbFloat('Base Cost'),
wbUnion('Assoc. Item', wbMGEFAssocItemDecider, [
wbFormID('Unused', cpIgnore),
wbFormIDCk('Assoc. Item', [LIGH, NULL]),
wbFormIDCk('Assoc. Item', [WEAP, ARMO, NULL]),
wbFormIDCk('Assoc. Item', [NPC_, NULL]),
wbFormIDCk('Assoc. Item', [HAZD, NULL]),
wbFormIDCk('Assoc. Item', [SPEL, NULL]),
wbFormIDCk('Assoc. Item', [RACE, NULL]),
wbFormIDCk('Assoc. Item', [ENCH, NULL]),
wbFormIDCk('Assoc. Item', [KYWD, NULL])
], cpNormal, False, nil, wbMGEFAssocItemAfterSet),
wbByteArray('Magic Skill (unused)', 4),
wbFormIDCk('Resist Value', [AVIF, NULL]),
wbInteger('Counter Effect count', itU16),
wbByteArray('Unused', 2),
wbFormIDCk('Casting Light', [LIGH, NULL]),
wbFloat('Taper Weight'),
wbFormIDCk('Hit Shader', [EFSH, NULL]),
wbFormIDCk('Enchant Shader', [EFSH, NULL]),
wbInteger('Minimum Skill Level', itU32),
wbStruct('Spellmaking', [
wbInteger('Area', itU32),
wbFloat('Casting Time')
]),
wbFloat('Taper Curve'),
wbFloat('Taper Duration'),
wbFloat('Second AV Weight', cpNormal, False, nil, wbMGEFAV2WeightAfterSet),
wbMGEFType,
wbActorValue,
wbFormIDCk('Projectile', [PROJ, NULL]),
wbFormIDCk('Explosion', [EXPL, NULL]),
wbInteger('Casting Type', itU32, wbCastEnum),
wbInteger('Delivery', itU32, wbTargetEnum),
wbActorValue, //wbInteger('Second Actor Value', itS32, wbActorValueEnum),
wbFormIDCk('Casting Art', [ARTO, NULL]),
wbFormIDCk('Hit Effect Art', [ARTO, NULL]),
wbFormIDCk('Impact Data', [IPDS, NULL]),
wbFloat('Skill Usage Multiplier'),
wbStruct('Dual Casting', [
wbFormIDCk('Art', [DUAL, NULL]),
wbFloat('Scale')
]),
wbFormIDCk('Enchant Art', [ARTO, NULL]),
wbByteArray('Unknown', 4),
wbByteArray('Unknown', 4),
wbFormIDCk('Equip Ability', [SPEL, NULL]),
wbFormIDCk('Image Space Modifier', [IMAD, NULL]),
wbFormIDCk('Perk to Apply', [PERK, NULL]),
wbInteger('Casting Sound Level', itU32, wbSoundLevelEnum),
wbStruct('Script Effect AI', [
wbFloat('Score'),
wbFloat('Delay Time')
])
], cpNormal, True)
], []);
wbRecord(MGEF, 'Magic Effect', [
wbEDID,
wbVMAD,
wbFULL,
wbMDOB,
wbKSIZ,
wbKWDAs,
wbMGEFData,
wbRArrayS('Counter Effects', wbFormIDCk(ESCE, 'Effect', [MGEF]), cpNormal, False, nil, wbCounterEffectsAfterSet),
wbArray(SNDD, 'Sounds', wbStruct('', [
wbInteger('Type', itU32, wbEnum([
'Sheathe/Draw',
'Charge',
'Ready',
'Release',
'Concentration Cast Loop',
'On Hit'
])),
wbFormIDCk('Sound', [SNDR])
])),
wbLStringKC(DNAM, 'Magic Item Description', 0, cpTranslate),
wbCTDAs
], False, nil, cpNormal, False, nil {wbMGEFAfterLoad}, wbMGEFAfterSet);
wbRecord(MISC, 'Misc. Item',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000004} 11, 'Calc From Components',
{0x00000004} 13, 'Pack-In Use Only'
])), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFULL,
wbMODL,
wbICON,
wbMICO,
wbDEST,
wbYNAM,
wbZNAM,
wbKSIZ,
wbKWDAs,
wbFormID(FIMD, 'Featured Item Message'),
wbStruct(DATA, 'Data', [
wbInteger('Value', itS32),
wbFloat('Weight')
], cpNormal, True),
// the amount of components is the same as size of CDIX, so should not be sorted probably
wbStructs(CVPA, 'Components', 'Component', [
wbFormIDCk('Component', sigBaseObjects), // CK allows only CMPO
wbInteger('Count', itU32)
]),
wbArray(CDIX, 'Component Display Indices', wbInteger('Display Index', itU8))
], False, nil, cpNormal, False, wbRemoveEmptyKWDA, wbKeywordsAfterSet);
wbRecord(COBJ, 'Constructible Object', [
wbEDID,
wbYNAM,
wbZNAM,
wbArrayS(FVPA, 'Components',
wbStructSK([0], 'Component', [
wbFormIDCk('Component', sigBaseObjects),
wbInteger('Count', itU32)
])
),
wbDESC,
wbCTDAs,
wbFormIDCk(CNAM, 'Created Object', sigBaseObjects),
wbFormIDCk(BNAM, 'Workbench Keyword', [KYWD]),
wbByteArray(NAM1, 'Unused', 0, cpIgnore, False, False, wbNeverShow), // co_PA_FusionCore01
wbByteArray(NAM2, 'Unused', 0, cpIgnore, False, False, wbNeverShow), // co_PA_FusionCore01
wbByteArray(NAM3, 'Unused', 0, cpIgnore, False, False, wbNeverShow), // co_PA_FusionCore01
wbFormIDCk(ANAM, 'Menu Art Object', [ARTO]),
wbArrayS(FNAM, 'Category', wbFormIDCk('Keyword', [KYWD])),
wbStruct(INTV, 'Data', [
wbInteger('Created Object Count', itU16),
wbInteger('Priority', itU16)
], cpNormal, False, nil, 1)
]);
wbRecord(NPC_, 'Non-Player Character (Actor)',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000400} 10, 'Unknown 10',
{0x00040000} 18, 'Compressed',
{0x00080000} 19, 'Unknown 19',
{0x20000000} 29, 'Bleedout Override'
]), [18]), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFormIDCk(STCP, 'Unknown', [STAG]),
wbStruct(ACBS, 'Configuration', [
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Female',
{0x00000002} 'Essential',
{0x00000004} 'Is CharGen Face Preset',
{0x00000008} 'Respawn',
{0x00000010} 'Auto-calc stats',
{0x00000020} 'Unique',
{0x00000040} 'Doesn''t affect stealth meter',
{0x00000080} 'PC Level Mult',
{0x00000100} 'Unknown 8',
{0x00000200} 'Calc For Each Template',
{0x00000400} 'Unknown 10',
{0x00000800} 'Protected',
{0x00001000} 'Unknown 12',
{0x00002000} 'Unknown 13',
{0x00004000} 'Summonable',
{0x00008000} 'Unknown 15',
{0x00010000} 'Doesn''t bleed',
{0x00020000} 'Unknown 17',
{0x00040000} 'Bleedout Override',
{0x00080000} 'Opposite Gender Anims',
{0x00100000} 'Simple Actor',
{0x00200000} 'Unknown 21',
{0x00400000} 'Unknown 22',
{0x00800000} 'No Activation/Hellos',
{0x01000000} 'Diffuse Alpha Test',
{0x02000000} 'Unknown 25',
{0x04000000} 'Unknown 26',
{0x08000000} 'Unknown 27',
{0x10000000} 'Unknown 28',
{0x20000000} 'Is Ghost',
{0x40000000} 'Unknown 30',
{0x80000000} 'Invulnerable'
])),
wbInteger('XP Value Offset', itS16, nil, cpNormal, True, nil{wbActorTemplateUseStats}),
wbUnion('Level', wbNPCLevelDecider, [
wbInteger('Level', itS16, nil, cpNormal, True, nil{wbActorTemplateUseStats}),
wbInteger('Level Mult', itS16, wbDiv(1000), cpNormal, True, nil{wbActorTemplateUseStats})
], cpNormal, True, nil{wbActorTemplateUseStats}),
wbInteger('Calc min level', itU16, nil, cpNormal, True, nil{wbActorTemplateUseStats}),
wbInteger('Calc max level', itU16, nil, cpNormal, True, nil{wbActorTemplateUseStats}),
wbInteger('Disposition Base', itS16),
wbInteger('Use Template Actors', itU16, wbFlags([
{0x0001} 'Traits',
{0x0002} 'Stats',
{0x0004} 'Factions',
{0x0008} 'Spell List',
{0x0010} 'AI Data',
{0x0020} 'AI Packages',
{0x0040} 'Model/Animation',
{0x0080} 'Base Data',
{0x0100} 'Inventory',
{0x0200} 'Script',
{0x0400} 'Def Pack List',
{0x0800} 'Attack Data',
{0x1000} 'Keywords'
])),
wbInteger('Bleedout Override', itU16),
wbByteArray('Unknown', 2)
], cpNormal, True),
wbRArrayS('Factions',
wbStructSK(SNAM, [0], 'Faction', [
wbFormIDCk('Faction', [FACT]),
wbInteger('Rank', itS8)
]), cpNormal, False, nil, nil, nil{wbActorTemplateUseFactions}
),
wbFormIDCk(INAM, 'Death item', [LVLI], False, cpNormal, False, nil{wbActorTemplateUseTraits}),
wbFormIDCk(VTCK, 'Voice', [VTYP], False, cpNormal, False, nil{wbActorTemplateUseTraits}),
wbFormIDCk(TPLT, 'Default Template', [LVLN, NPC_]),
wbFormIDCk(LTPT, 'Legendary Template', [LVLN, NPC_]),
wbFormIDCk(LTPC, 'Legendary Chance', [GLOB]),
wbStruct(TPTA, 'Template Actors', [
wbFormIDCk('Traits', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate0),
wbFormIDCk('Stats', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate1),
wbFormIDCk('Factions', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate2),
wbFormIDCk('Spell List', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate3),
wbFormIDCk('AI Data', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate4),
wbFormIDCk('AI Packages', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate5),
wbFormIDCk('Model/Animation', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate6),
wbFormIDCk('Base Data', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate7),
wbFormIDCk('Inventory', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate8),
wbFormIDCk('Script', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate9),
wbFormIDCk('Def Pack List', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate10),
wbFormIDCk('Attack Data', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate11),
wbFormIDCk('Keywords', [LVLN, NPC_, NULL], False, cpNormal, False, wbActorTemplatesUseTemplate12)
]),
wbFormIDCk(RNAM, 'Race', [RACE], False, cpNormal, True, nil{wbActorTemplateUseTraits}),
wbSPCT,
wbSPLOs,
wbDEST,
wbFormIDCk(WNAM, 'Skin', [ARMO], False, cpNormal, False),
wbFormIDCk(ANAM, 'Far away model', [ARMO], False, cpNormal, False, nil{wbActorTemplateUseTraits}),
wbFormIDCk(ATKR, 'Attack Race', [RACE], False, cpNormal, False),
wbRArrayS('Attacks', wbAttackData),
wbFormIDCk(SPOR, 'Spectator Override Package List', [FLST]),
wbFormIDCk(OCOR, 'Observe Dead Body Override Package List', [FLST]),
wbFormIDCk(GWOR, 'Guard Warn Override Package List', [FLST]),
wbFormIDCk(ECOR, 'Combat Override Package List', [FLST]),
wbFormIDCk(FCPL, 'Follower Command Package List', [FLST]),
wbFormIDCk(RCLR, 'Follower Elevator Package List', [FLST]),
wbInteger(PRKZ, 'Perk Count', itU32, nil, cpBenign),
wbRArrayS('Perks',
wbStructSK(PRKR, [0], 'Perk', [
wbFormIDCk('Perk', [PERK]),
wbInteger('Rank', itU8)
]), cpNormal, False, nil, wbPRKRsAfterSet
),
wbPRPS,
wbFTYP,
wbNTRM,
wbCOCT,
wbCNTOs,
wbAIDT,
wbRArray('Packages', wbFormIDCk(PKID, 'Package', [PACK]), cpNormal, False, nil{wbActorTemplateUseAIPackages}),
wbKSIZ,
wbKWDAs,
wbAPPR,
wbObjectTemplate,
wbFormIDCk(CNAM, 'Class', [CLAS], False, cpNormal, True),
wbFULL,
wbLString(SHRT, 'Short Name', 0, cpTranslate),
wbByteArray(DATA, 'Marker'),
wbStruct(DNAM, '', [
wbInteger('Unknown', itU16),
wbInteger('Unknown', itU16),
wbInteger('Far Away Model Distance', itU16),
wbInteger('Geared Up Weapons', itU16)
]),
wbRArrayS('Head Parts', wbFormIDCk(PNAM, 'Head Part', [HDPT]), cpNormal, False, nil, nil, nil{wbActorTemplateUseModelAnimation}),
wbFormIDCk(HCLF, 'Hair Color', [CLFM], False, cpNormal, False),
wbFormIDCk(BCLF, 'Facial Hair Color', [CLFM], False, cpNormal, False),
wbFormIDCk(ZNAM, 'Combat Style', [CSTY], False, cpNormal, False),
wbFormIDCk(GNAM, 'Gift Filter', [FLST], False, cpNormal, False),
wbUnknown(NAM5, cpNormal, True),
wbFloat(NAM6, 'Height Min', cpNormal, True),
wbFloat(NAM7, 'Unused', cpNormal, True),
wbFloat(NAM4, 'Height Max'),
wbStruct(MWGT, 'Weight', [
wbFloat('Thin'),
wbFloat('Muscular'),
wbFloat('Fat')
]),
wbInteger(NAM8, 'Sound Level', itU32, wbSoundLevelEnum, cpNormal, True),
wbRStruct('Actor Sounds', [
wbInteger(CS2H, 'Count', itU32, nil, cpBenign, True),
wbRArrayS('Sounds',
wbRStructSK([0], 'Sound', [
wbFormIDCk(CS2K, 'Keyword', [KYWD]),
wbFormIDCk(CS2D, 'Sound', [SNDR], False, cpNormal, True)
], [], cpNormal, False, nil, True),
cpNormal, False, nil, wbNPCActorSoundsAfterSet
),
wbEmpty(CS2E, 'End Marker', cpNormal, True),
wbByteArray(CS2F, 'Finalize', 1, cpNormal, True)
], []),
wbFormIDCk(CSCR, 'Inherits Sounds From', [NPC_], False, cpNormal, False),
wbFormIDCk(PFRN, 'Power Armor Stand', [FURN]),
wbFormIDCk(DOFT, 'Default Outfit', [OTFT], False, cpNormal, False),
wbFormIDCk(SOFT, 'Sleeping Outfit', [OTFT], False, cpNormal, False),
wbFormIDCk(DPLT, 'Default Package List', [FLST], False, cpNormal, False),
wbFormIDCk(CRIF, 'Crime Faction', [FACT], False, cpNormal, False),
wbFormIDCk(FTST, 'Head Texture', [TXST], False, cpNormal, False),
wbStruct(QNAM, 'Texture lighting', [
wbFloat('Red', cpNormal, True, 255, 0),
wbFloat('Green', cpNormal, True, 255, 0),
wbFloat('Blue', cpNormal, True, 255, 0),
wbFloat('Alpha')
]),
wbArray(MSDK, 'Morph Keys', wbInteger('Key', itU32, wbMorphValueToStr, wbHexStrToInt)),
wbArray(MSDV, 'Morph Values', wbFloat('Value')),
wbRArrayS('Face Tinting Layers',
wbRStructSK([0], 'Layer', [
wbStructSK(TETI, [1], 'Index', [
wbInteger('Data Type', itU16, wbEnum(['', 'Value/Color', 'Value'])),
wbInteger('Index', itU16, wbTintLayerToStr, wbStrToInt)
]),
//wbByteArray(TEND, 'Data')
wbStruct(TEND, 'Data', [
wbInteger('Value', itU8, wbDiv(100)),
wbByteColors('Color'),
wbInteger('Template Color Index', itS16)
], cpNormal, True, nil, 1)
], [])
),
wbStruct(MRSV, 'Body Morph Region Values', [
wbFloat('Head'),
wbFloat('Upper Torso'),
wbFloat('Arms'),
wbFloat('Lower Torso'),
wbFloat('Legs')
]),
// reported to cause issues when sorted
wbRArrayS('Face Morphs',
wbRStructSK([0], 'Face Morph', [
wbInteger(FMRI, 'Index', itU32, wbFaceMorphToStr, wbHexStrToInt),
//wbArray(FMRS, 'Unknown', wbFloat('Unknown'))
wbStruct(FMRS, 'Values', [
wbFloat('Position - X'),
wbFloat('Position - Y'),
wbFloat('Position - Z'),
wbFloat('Rotation - X'),
wbFloat('Rotation - Y'),
wbFloat('Rotation - Z'),
wbFloat('Scale'),
wbByteArray('Unknown')
])
], [])
),
wbFloat(FMIN, 'Facial Morph Intensity'),
wbATTX
], False, nil, cpNormal, False, wbNPCAfterLoad, wbNPCAfterSet);
wbPKDTSpecificFlagsUnused := False;
wbPKDTFlags := wbFlags([
{0x00000001} 'Offers Services',
{0x00000002} 'Unknown 2',
{0x00000004} 'Must complete',
{0x00000008} 'Maintain Speed at Goal',
{0x00000010} 'Treat As Player Follower',
{0x00000020} 'Unknown 6',
{0x00000040} 'Unlock doors at package start',
{0x00000080} 'Unlock doors at package end',
{0x00000100} 'Request Block Idles',
{0x00000200} 'Continue if PC Near',
{0x00000400} 'Once per day',
{0x00000800} 'Unknown 12',
{0x00001000} 'Skip Load Into Furniture',
{0x00002000} 'Preferred Speed',
{0x00004000} 'Unknown 15',
{0x00008000} 'Unknown 16',
{0x00010000} 'Unknown 17',
{0x00020000} 'Always Sneak',
{0x00040000} 'Allow Swimming',
{0x00080000} 'Unknown 20',
{0x00100000} 'Ignore Combat',
{0x00200000} 'Weapons Unequipped',
{0x00400000} 'Unknown 23',
{0x00800000} 'Weapon Drawn',
{0x01000000} 'Unknown 25',
{0x02000000} 'Unknown 26',
{0x04000000} 'Unknown 27',
{0x08000000} 'No Combat Alert',
{0x10000000} 'Unknown 29',
{0x20000000} 'Wear Sleep Outfit',
{0x40000000} 'Unknown 31',
{0x80000000} 'Unknown 32'
], [29]);
wbPKDTInterruptFlags := wbFlags([
{0x0001} 'Hellos to player',
{0x0002} 'Random conversations',
{0x0004} 'Observe combat behavior',
{0x0008} 'Greet corpse behavior',
{0x0010} 'Reaction to player actions',
{0x0020} 'Friendly fire comments',
{0x0040} 'Aggro Radius Behavior',
{0x0080} 'Allow Idle Chatter',
{0x0100} 'Unknown 9',
{0x0200} 'World Interactions',
{0x0400} 'Off For Important Scene',
{0x0800} 'Unknown 12',
{0x1000} 'Unknown 13',
{0x2000} 'Unknown 14',
{0x4000} 'Unknown 15',
{0x8000} 'Unknown 16'
]);
end;
procedure DefineFO4n;
function wbTintTemplateGroups(const aName: string): IwbSubRecordArrayDef;
begin
Result :=
wbRStructs(aName, 'Group', [
wbLString(TTGP, 'Group Name', 0, cpTranslate),
wbRStructs('Options', 'Option', [
wbStruct(TETI, 'Index', [
wbByteArray('Unknown', 2),
wbInteger('Index', itU16)
]),
wbLString(TTGP, 'Name', 0, cpTranslate),
wbUnknown(TTEF),
wbCTDAs,
wbRArray('Textures', wbString(TTET, 'Texture')),
wbUnknown(TTEB),
wbArray(TTEC, 'Template Colors', wbStruct('Template Color', [
wbFormIDCk('Color', [CLFM]),
wbFloat('Alpha'),
wbInteger('Template Index', itU16),
wbByteArray('Unknown', 4)
])),
wbFloat(TTED, 'Unknown')
], []),
wbByteArray(TTGE, 'Group End', 4)
], []);
end;
function wbMorphGroups(const aName: string): IwbSubRecordArrayDef;
begin
Result :=
wbRArray(aName,
wbRStruct('Morph Group', [
wbString(MPGN, 'Name'),
wbInteger(MPPC, 'Count', itU32, nil, cpBenign),
wbRArray('Morph Presets',
wbRStruct('Morph Preset', [
wbInteger(MPPI, 'Index', itU32, wbIntToHexStr, wbHexStrToInt),
wbLString(MPPN, 'Name', 0, cpTranslate),
wbString(MPPM, 'Unknown'),
wbFormIDCk(MPPT, 'Texture', [TXST]),
wbUnknown(MPPF)
], []),
cpNormal, False, nil, wbMorphPresetsAfterSet
),
wbUnknown(MPPK),
wbUnknown(MPGS)
], [])
);
end;
function wbFaceMorphs(const aName: string): IwbSubRecordArrayDef;
begin
Result :=
wbRArray(aName,
wbRStruct('Face Morph', [
wbInteger(FMRI, 'Index', itU32, wbIntToHexStr, wbHexStrToInt),
wbLString(FMRN, 'Name')
], [])
);
end;
begin
wbUNAMs := wbRArray('Data Inputs', wbRStruct('Data Input', [
wbInteger(UNAM, 'Index', itS8),
wbString(BNAM, 'Name'),
wbInteger(PNAM, 'Flags', itU32, wbFlags([
'Public'
]))
], []));
wbRecord(PACK, 'Package', [
wbEDID,
wbVMADFragmentedPACK,
wbStruct(PKDT, 'Pack Data', [
wbInteger('General Flags', itU32, wbPKDTFlags),
wbInteger('Type', itU8, wbEnum ([], [
18, 'Package',
19, 'Package Template'
])),
wbInteger('Interrupt Override', itU8, wbEnum([
{0} 'None',
{1} 'Spectator',
{2} 'ObserveDead',
{3} 'GuardWarn',
{4} 'Combat',
{5} 'Command Travel',
{6} 'Command Activate',
{7} 'Leave Workstation'
])),
wbInteger('Preferred Speed', itU8, wbEnum([
'Walk',
'Jog',
'Run',
'Fast Walk'
])),
wbByteArray('Unknown', 1),
wbInteger('Interrupt Flags', itU16, wbPKDTInterruptFlags),
wbByteArray('Unknown', 2)
], cpNormal, True),
wbStruct(PSDT, 'Schedule', [
wbInteger('Month', itS8),
wbInteger('Day of week', itS8, wbEnum([
'Sunday',
'Monday',
'Tuesday',
'Wednesday',
'Thursday',
'Friday',
'Saturday',
'Weekdays',
'Weekends',
'Monday, Wednesday, Friday',
'Tuesday, Thursday'
], [
-1, 'Any'
])),
wbInteger('Date', itU8),
wbInteger('Hour', itS8),
wbInteger('Minute', itS8),
wbByteArray('Unused', 3, cpIgnore),
wbInteger('Duration (minutes)', itS32)
], cpNormal, True),
wbCTDAs,
wbRStruct('Idle Animations', [
wbInteger(IDLF, 'Flags', itU8, wbEnum([], [
0, 'Unknown',
8, 'Random',
9, 'Run in Sequence',
12, 'Random, Do Once',
13, 'Run in Sequence, Do Once'
]), cpNormal, True),
wbInteger(IDLC, 'Animation Count', itU8, nil, cpBenign),
wbFloat(IDLT, 'Idle Timer Setting', cpNormal, True),
wbArray(IDLA, 'Animations', wbFormIDCk('Animation', [IDLE]), 0, nil, wbIDLAsAfterSet, cpNormal, True),
wbByteArray(IDLB, 'Unknown', 4, cpIgnore)
], [], cpNormal, False, nil, False, nil {cannot be totally removed , wbAnimationsAfterSet}),
wbFormIDCk(CNAM, 'Combat Style', [CSTY]),
wbFormIDCk(QNAM, 'Owner Quest', [QUST]),
wbStruct(PKCU, 'Counter', [
wbInteger('Data Input Count', itU32),
wbFormIDCk('Package Template', [PACK, NULL]),
wbInteger('Version Counter (autoincremented)', itU32)
], cpNormal, True),
wbRStruct('Package Data', [
wbRArray('Data Input Values', wbRStruct('Value', [
wbString(ANAM, 'Type'),
wbUnion(CNAM, 'Value', wbPubPackCNAMDecider, [
{0} wbByteArray('Unknown'),
{1} wbInteger('Bool', itU8, wbBoolEnum),
{2} wbInteger('Integer', itU32),
{3} wbFloat('Float')
]),
wbUnknown(BNAM),
wbPDTOs,
wbPLDT,
wbStruct(PTDA, 'Target', [wbTargetData]),
wbUnknown(TPIC)
], [], cpNormal, False)),
wbUNAMs
], []),
wbByteArray(XNAM, 'Marker'),
wbRStruct('Procedure Tree', [
wbRArray('Branches', wbRStruct('Branch', [
wbString(ANAM, 'Branch Type'),
wbCITC,
wbCTDAsCount,
wbStruct(PRCB, 'Root', [
wbInteger('Branch Count', itU32),
wbInteger('Flags', itU32, wbFlags([
'Repeat when Complete',
'Unknown 1'
]))
]),
wbString(PNAM, 'Procedure Type'),
wbInteger(FNAM, 'Flags', itU32, wbFlags(['Success Completes Package'])),
wbRArray('Data Input Indexes', wbInteger(PKC2, 'Index', itU8)),
{>>> PFO2 should be single, there is only 1 PACK [00095F46] in Skyrim.esm with 2xPFO2 <<<}
wbRArray('Flags Override',
wbStruct(PFO2, 'Data', [
wbInteger('Set General Flags', itU32, wbPKDTFlags),
wbInteger('Clear General Flags', itU32, wbPKDTFlags),
wbInteger('Set Interrupt Flags', itU16, wbPKDTInterruptFlags),
wbInteger('Clear Interrupt Flags', itU16, wbPKDTInterruptFlags),
wbInteger('Preferred Speed Override', itU8, wbEnum([
'Walk',
'Jog',
'Run',
'Fast Walk'
])),
wbByteArray('Unknown', 3)
])
),
wbRArray('Unknown', wbUnknown(PFOR), cpIgnore)
], [], cpNormal, False, nil, False, nil, wbConditionsAfterSet))
], []),
wbUNAMs,
wbRStruct('OnBegin', [
wbEmpty(POBA, 'OnBegin Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbPDTOs
], []),
wbRStruct('OnEnd', [
wbEmpty(POEA, 'OnEnd Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbPDTOs
], []),
wbRStruct('OnChange', [
wbEmpty(POCA, 'OnChange Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbPDTOs
], [])
], False, nil, cpNormal, False, nil {wbPACKAfterLoad});
wbQUSTAliasFlags :=
wbInteger(FNAM, 'Flags', itU32, wbFlags([
{0x00000001} 'Reserves Location/Reference',
{0x00000002} 'Optional',
{0x00000004} 'Quest Object',
{0x00000008} 'Allow Reuse in Quest',
{0x00000010} 'Allow Dead',
{0x00000020} 'Matching Ref - In Loaded Area',
{0x00000040} 'Essential',
{0x00000080} 'Allow Disabled',
{0x00000100} 'Stores Text',
{0x00000200} 'Allow Reserved',
{0x00000400} 'Protected',
{0x00000800} 'Forced by Aliases',
{0x00001000} 'Allow Destroyed',
{0x00002000} 'Matching Ref - Closest',
{0x00004000} 'Uses Stored Text',
{0x00008000} 'Initially Disabled',
{0x00010000} 'Allow Cleared',
{0x00020000} 'Clear Names When Removed',
{0x00040000} 'Matching Ref - Actors Only',
{0x00080000} 'Create Ref - Temp',
{0x00100000} 'External Alias - Linked',
{0x00200000} 'No Pickpocket',
{0x00400000} 'Can Apply Data To Non-Aliased Refs',
{0x00800000} 'Is Companion',
{0x01000000} 'Optional All Scenes'
]));
wbRecord(QUST, 'Quest',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00004000} 14, 'Partial Form' // Allows the Record to inherit some subrecords from its master
])), [
wbEDID,
wbVMADFragmentedQUST,
wbFULL,
wbStruct(DNAM, 'General', [
wbInteger('Flags', itU16, wbFlags([
{0x0001} 'Start Game Enabled',
{0x0002} 'Unknown 2',
{0x0004} 'Add Idle Topic To Hello',
{0x0008} 'Allow repeated stages',
{0x0010} 'Unknown 5',
{0x0020} 'Unknown 6',
{0x0040} 'Unknown 7',
{0x0080} 'Unknown 8',
{0x0100} 'Run Once',
{0x0200} 'Exclude from dialogue export',
{0x0400} 'Warn on alias fill failure',
{0x0800} 'Unknown 12',
{0x1000} 'Unknown 13'
])),
wbInteger('Priority', itU8),
wbInteger('Form Version', itU8, nil, cpIgnore),
wbByteArray('Unknown', 4),
wbInteger('Type', itU32, wbEnum([
{0} 'None',
{1} 'Main Quest',
{2} 'Brotherhood of Steel',
{3} 'Institute',
{4} 'Minutemen',
{5} 'Railroad',
{6} 'Miscellaneous',
{7} 'Side Quests',
{8} 'DLC01',
{9} 'DLC02',
{10} 'DLC03',
{11} 'DLC04',
{12} 'DLC05',
{13} 'DLC06',
{14} 'DLC07'
]))
]),
wbString(ENAM, 'Event', 4),
wbFormIDCk(LNAM, 'Location', [LCTN]),
wbFormIDCk(XNAM, 'Quest Completion XP', [GLOB]),
wbRArray('Text Display Globals', wbFormIDCk(QTGL, 'Global', [GLOB])),
wbFLTR,
wbRStruct('Quest Dialogue Conditions', [wbCTDAs], [], cpNormal, False),
wbEmpty(NEXT, 'Marker'),
wbCTDAs, {>>> Unknown, doesn't show up in CK <<<}
wbRArrayS('Stages', wbRStructSK([0], 'Stage', [
wbStructSK(INDX, [0], 'Stage Index', [
wbInteger('Stage Index', itU16),
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Unknown 1',
{0x02} 'Run On Start',
{0x04} 'Run On Stop',
{0x08} 'Keep Instance Data From Here On'
])),
wbInteger('Unknown', itU8)
]),
wbRArray('Log Entries', wbRStruct('Log Entry', [
wbInteger(QSDT, 'Stage Flags', itU8, wbFlags([
{0x01} 'Complete Quest',
{0x02} 'Fail Quest'
])),
wbCTDAs,
wbString(NAM2, 'Note'),
wbLString(CNAM, 'Log Entry', 0, cpTranslate),
wbFormIDCk(NAM0, 'Next Quest', [QUST])
], []))
], [])),
wbRArray('Objectives', wbRStruct('Objective', [
wbInteger(QOBJ, 'Objective Index', itU16),
wbInteger(FNAM, 'Flags', itU32, wbFlags([
{0x01} 'ORed With Previous',
{0x02} 'No Stats Tracking'
])),
wbLString(NNAM, 'Display Text', 0, cpTranslate, True),
wbRArray('Targets', wbRStruct('Target', [
wbStruct(QSTA, 'Target', [
wbInteger('Alias', itS32, wbQuestAliasToStr, wbStrToAlias),
wbInteger('Flags', itU32, wbFlags([
{0x01} 'Compass Marker Ignores Locks',
{0x02} 'Hostile',
{0x04} 'Use Straight Line Pathing'
])),
wbFormIDCk('Keyword', [KYWD, NULL])
]),
wbCTDAs
], []))
], [])),
wbByteArray(ANAM, 'Aliases Marker', 4),
wbRArray('Aliases',
wbRUnion('Alias', [
// Reference Alias
wbRStruct('Alias', [
wbInteger(ALST, 'Reference Alias ID', itU32),
wbString(ALID, 'Alias Name'),
wbQUSTAliasFlags,
wbInteger(ALFI, 'Force Into Alias When Filled', itS32, wbQuestAliasToStr, wbStrToAlias),
//wbFormIDCk(ALFL, 'Specific Location', [LCTN]),
wbFormID(ALFR, 'Forced Reference'),
wbFormIDCk(ALUA, 'Unique Actor', [NPC_]),
wbRStruct('Location Alias Reference', [
wbInteger(ALFA, 'Alias', itS32, wbQuestAliasToStr, wbStrToAlias),
wbFormIDCk(KNAM, 'Keyword', [KYWD]),
wbFormIDCk(ALRT, 'Ref Type', [LCRT])
], []),
wbRStruct('External Alias Reference', [
wbFormIDCk(ALEQ, 'Quest', [QUST]),
wbInteger(ALEA, 'Alias', itS32, wbQuestExternalAliasToStr, wbStrToAlias)
], []),
wbRStruct('Create Reference to Object', [
wbFormID(ALCO, 'Object'),
wbStruct(ALCA, 'Alias', [
wbInteger('Alias', itS16, wbQuestAliasToStr, wbStrToAlias),
wbInteger('Create', itU16, wbEnum([] ,[
$0000, 'At',
$8000, 'In'
]))
]),
wbInteger(ALCL, 'Level', itU32, wbEnum([
'Easy',
'Medium',
'Hard',
'Very Hard',
'None'
]))
], []),
wbRStruct('Find Matching Reference Near Alias', [
wbInteger(ALNA, 'Alias', itS32, wbQuestAliasToStr, wbStrToAlias),
wbInteger(ALNT, 'Type', itU32, wbEnum([
'Linked From',
'Linked Ref'
]))
], []),
wbRStruct('Find Matching Reference From Event', [
wbString(ALFE, 'From Event', 4),
wbByteArray(ALFD, 'Event Data')
], []),
wbInteger(ALCC, 'Closest To Alias', itS32, wbQuestAliasToStr, wbStrToAlias),
wbCTDAs,
wbKSIZ,
wbKWDAs,
wbCOCT,
wbCNTOs,
wbFormIDCk(SPOR, 'Spectator override package list', [FLST], False, cpNormal, False),
wbFormIDCk(OCOR, 'Observe dead body override package list', [FLST], False, cpNormal, False),
wbFormIDCk(GWOR, 'Guard warn override package list', [FLST], False, cpNormal, False),
wbFormIDCk(ECOR, 'Combat override package list', [FLST], False, cpNormal, False),
wbArray(ALLA, 'Linked Aliases', wbStruct('Linked Alias', [
wbFormIDCk('Keyword', [KYWD, NULL]),
wbInteger('Alias', itS32, wbQuestAliasToStr, wbStrToAlias)
])),
wbFormIDCk(ALDN, 'Display Name', [MESG]),
wbFormIDCk(ALFV, 'Forced Voice', [VTYP]),
wbFormIDCk(ALDI, 'Death Item', [LVLI]),
wbRArrayS('Alias Spells', wbFormIDCk(ALSP, 'Spell', [SPEL])),
wbRArrayS('Alias Factions', wbFormIDCk(ALFC, 'Faction', [FACT])),
wbRArray('Alias Package Data', wbFormIDCk(ALPC, 'Package', [PACK])),
wbFormIDCk(VTCK, 'Voice Types', [NPC_, FACT, FLST, VTYP, NULL]),
wbEmpty(ALED, 'Alias End', cpNormal, True)
], [], cpNormal, False, nil, False, nil, wbContainerAfterSet),
// Location Alias
wbRStruct('Alias', [
wbInteger(ALLS, 'Location Alias ID', itU32),
wbString(ALID, 'Alias Name'),
wbQUSTAliasFlags,
wbInteger(ALFI, 'Force Into Alias When Filled', itS32, wbQuestAliasToStr, wbStrToAlias),
wbFormIDCk(ALFL, 'Specific Location', [LCTN]),
wbRStruct('Reference Alias Location', [
wbInteger(ALFA, 'Alias', itS32, wbQuestAliasToStr, wbStrToAlias),
wbFormIDCk(KNAM, 'Keyword', [KYWD])
], []),
wbRStruct('External Alias Location', [
wbFormIDCk(ALEQ, 'Quest', [QUST]),
wbInteger(ALEA, 'Alias', itS32, wbQuestExternalAliasToStr, wbStrToAlias)
], []),
wbRStruct('Find Matching Location From Event', [
wbString(ALFE, 'From Event', 4),
wbByteArray(ALFD, 'Event Data')
], []),
wbCTDAs,
wbInteger(ALCC, 'Closest To Alias', itS32, wbQuestAliasToStr, wbStrToAlias),
wbEmpty(ALED, 'Alias End', cpNormal, True)
], []),
// Ref Collection Alias
wbRStruct('Alias', [
wbInteger(ALCS, 'Collection Alias ID', itU32),
wbInteger(ALMI, 'Max Initial Fill Count', itU8)
], [])
], [])
),
wbString(NNAM, 'Description', 0, cpTranslate, False),
wbFormIDCk(GNAM, 'Quest Group', [KYWD]),
wbString(SNAM, 'SWF File')
]);
wbBodyPartIndexEnum := wbEnum([
'Body Texture'
]);
wbPhonemeTargets := wbStruct(PHWT, 'Phoneme Target Weight', [
wbFloat('Aah / LipBigAah'),
wbFloat('BigAah / LipDST'),
wbFloat('BMP / LipEee'),
wbFloat('ChJsh / LipFV'),
wbFloat('DST / LipK'),
wbFloat('Eee / LipL'),
wbFloat('Eh / LipR'),
wbFloat('FV / LipTh'),
wbFloat('I'),
wbFloat('K'),
wbFloat('N'),
wbFloat('Oh'),
wbFloat('OohQ'),
wbFloat('R'),
wbFloat('TH'),
wbFloat('W'),
wbUnknown
], cpNormal, False, nil, 1); // only a single value in HandyRace
wbPHWT := wbRStruct('FaceFX Phonemes', [
wbRStruct('IY', [wbPhonemeTargets], []),
wbRStruct('IH', [wbPhonemeTargets], []),
wbRStruct('EH', [wbPhonemeTargets], []),
wbRStruct('EY', [wbPhonemeTargets], []),
wbRStruct('AE', [wbPhonemeTargets], []),
wbRStruct('AA', [wbPhonemeTargets], []),
wbRStruct('AW', [wbPhonemeTargets], []),
wbRStruct('AY', [wbPhonemeTargets], []),
wbRStruct('AH', [wbPhonemeTargets], []),
wbRStruct('AO', [wbPhonemeTargets], []),
wbRStruct('OY', [wbPhonemeTargets], []),
wbRStruct('OW', [wbPhonemeTargets], []),
wbRStruct('UH', [wbPhonemeTargets], []),
wbRStruct('UW', [wbPhonemeTargets], []),
wbRStruct('ER', [wbPhonemeTargets], []),
wbRStruct('AX', [wbPhonemeTargets], []),
wbRStruct('S', [wbPhonemeTargets], []),
wbRStruct('SH', [wbPhonemeTargets], []),
wbRStruct('Z', [wbPhonemeTargets], []),
wbRStruct('ZH', [wbPhonemeTargets], []),
wbRStruct('F', [wbPhonemeTargets], []),
wbRStruct('TH', [wbPhonemeTargets], []),
wbRStruct('V', [wbPhonemeTargets], []),
wbRStruct('DH', [wbPhonemeTargets], []),
wbRStruct('M', [wbPhonemeTargets], []),
wbRStruct('N', [wbPhonemeTargets], []),
wbRStruct('NG', [wbPhonemeTargets], []),
wbRStruct('L', [wbPhonemeTargets], []),
wbRStruct('R', [wbPhonemeTargets], []),
wbRStruct('W', [wbPhonemeTargets], []),
wbRStruct('Y', [wbPhonemeTargets], []),
wbRStruct('HH', [wbPhonemeTargets], []),
wbRStruct('B', [wbPhonemeTargets], []),
wbRStruct('D', [wbPhonemeTargets], []),
wbRStruct('JH', [wbPhonemeTargets], []),
wbRStruct('G', [wbPhonemeTargets], []),
wbRStruct('P', [wbPhonemeTargets], []),
wbRStruct('T', [wbPhonemeTargets], []),
wbRStruct('K', [wbPhonemeTargets], []),
wbRStruct('CH', [wbPhonemeTargets], []),
wbRStruct('SIL', [wbPhonemeTargets], []),
wbRStruct('SHOTSIL', [wbPhonemeTargets], []),
wbRStruct('FLAP', [wbPhonemeTargets], [])
], []);
wbHeadPart := wbRStructSK([0], 'Head Part', [
wbInteger(INDX, 'Head Part Number', itU32),
wbFormIDCk(HEAD, 'Head', [HDPT, NULL])
], []);
wbRaceRBPC :=
wbArray(RBPC, 'Biped Object Conditions',
wbUnion('Slot 30+', wbFormVer78Decider, [
wbInteger('Slot 30+', itU32),
wbFormIDCk('Slot 30+', [AVIF, NULL])
])
);
// since version 78: array of pair of AVIF FormID, before array of AVIF index. Similar to DamageType (and MGEF also somehow).
{wbUnion(RBPC, 'Biped Object Conditions', wbFormVer78Decider, [
wbArray('Biped Object Conditions', wbInteger('Condition AV', itU32)),
wbArray('Biped Object Conditions', wbStruct('Condition AV', [
wbFormIDck('AVIF 1', [AVIF, NULL]),
wbFormIDck('AVIF 2', [AVIF, NULL])
]))
]);}
wbRecord(RACE, 'Race',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00080000} 19, 'Unknown 19'
])), [
wbEDID,
wbFormIDCk(STCP, 'Sound', [STAG]),
wbFULL,
wbDESCReq,
wbSPCT,
wbSPLOs,
wbFormIDCk(WNAM, 'Skin', [ARMO, NULL]),
wbBOD2,
wbKSIZ,
wbKWDAs,
wbPRPS,
wbAPPR,
wbStruct(DATA, 'Data', [
wbFloat('Male Height'),
wbFloat('Female Height'),
wbStruct('Male Default Weight', [
wbFloat('Thin'),
wbFloat('Muscular'),
wbFloat('Fat')
]),
wbStruct('Female Default Weight', [
wbFloat('Thin'),
wbFloat('Muscular'),
wbFloat('Fat')
]),
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Playable',
{0x00000002} 'FaceGen Head',
{0x00000004} 'Child',
{0x00000008} 'Tilt Front/Back',
{0x00000010} 'Tilt Left/Right',
{0x00000020} 'No Shadow',
{0x00000040} 'Swims',
{0x00000080} 'Flies',
{0x00000100} 'Walks',
{0x00000200} 'Immobile',
{0x00000400} 'Not Pushable',
{0x00000800} 'No Combat In Water',
{0x00001000} 'No Rotating to Head-Track',
{0x00002000} 'Don''t Show Blood Spray',
{0x00004000} 'Don''t Show Blood Decal',
{0x00008000} 'Uses Head Track Anims',
{0x00010000} 'Spells Align w/Magic Node',
{0x00020000} 'Use World Raycasts For FootIK',
{0x00040000} 'Allow Ragdoll Collision',
{0x00080000} 'Regen HP In Combat',
{0x00100000} 'Can''t Open Doors',
{0x00200000} 'Allow PC Dialogue',
{0x00400000} 'No Knockdowns',
{0x00800000} 'Allow Pickpocket',
{0x01000000} 'Always Use Proxy Controller',
{0x02000000} 'Don''t Show Weapon Blood',
{0x04000000} 'Overlay Head Part List', {>>>Only one can be active<<<}
{0x08000000} 'Override Head Part List', {>>>Only one can be active<<<}
{0x10000000} 'Can Pickup Items',
{0x20000000} 'Allow Multiple Membrane Shaders',
{0x40000000} 'Can Dual Wield',
{0x80000000} 'Avoids Roads'
])),
wbFloat('Acceleration Rate'),
wbFloat('Deceleration Rate'),
wbInteger('Size', itU32, wbEnum([
'Small',
'Medium',
'Large',
'Extra Large'
])),
wbByteArray('Unknown', 8),
wbFloat('Injured Health Pct'),
wbInteger('Shield Biped Object', itS32, wbBipedObjectEnum),
wbInteger('Beard Biped Object', itS32, wbBipedObjectEnum),
wbInteger('Body Biped Object', itS32, wbBipedObjectEnum),
wbFloat('Aim Angle Tolerance'),
wbFloat('Flight Radius'),
wbFloat('Angular Acceleration Rate'),
wbFloat('Angular Tolerance'),
wbInteger('Flags 2', itU32, wbFlags([
{0x00000001} 'Use Advanced Avoidance',
{0x00000002} 'Non-Hostile',
{0x00000004} 'Floats',
{0x00000008} 'Unknown 3',
{0x00000010} 'Unknown 4',
{0x00000020} 'Head Axis Bit 0',
{0x00000040} 'Head Axis Bit 1',
{0x00000080} 'Can Melee When Knocked Down',
{0x00000100} 'Use Idle Chatter During Combat',
{0x00000200} 'Ungendered',
{0x00000400} 'Can Move When Knocked Down',
{0x00000800} 'Use Large Actor Pathing',
{0x00001000} 'Use Subsegmented Damage',
{0x00002000} 'Flight - Defer Kill',
{0x00004000} 'Unknown 14',
{0x00008000} 'Flight - Allow Procedural Crash Land',
{0x00010000} 'Disable Weapon Culling',
{0x00020000} 'Use Optimal Speeds',
{0x00040000} 'Has Facial Rig',
{0x00080000} 'Can Use Crippled Limbs',
{0x00100000} 'Use Quadruped Controller',
{0x00200000} 'Low Priority Pushable',
{0x00400000} 'Cannot Use Playable Items'
])),
wbByteArray('Unknown', 36),
wbInteger('Pipboy Biped Object', itS32, wbBipedObjectEnum),
wbInteger('XP Value', itS16),
wbFloat('Severable - Debris Scale'),
wbInteger('Severable - Debris Count', itU8),
wbInteger('Severable - Decal Count', itU8),
wbFloat('Explodable - Debris Scale'),
wbInteger('Explodable - Debris Count', itU8),
wbInteger('Explodable - Decal Count', itU8),
wbFormIDCk('Severable - Explosion', [EXPL, NULL]),
wbFormIDCk('Severable - Debris', [DEBR, NULL]),
wbFormIDCk('Severable - Impact DataSet', [IPDS, NULL]),
wbFormIDCk('Explodable - Explosion', [EXPL, NULL]),
wbFormIDCk('Explodable - Debris', [DEBR, NULL]),
wbFormIDCk('Explodable - Impact DataSet', [IPDS, NULL]),
wbFloat('OnCripple - Debris Scale'),
wbInteger('OnCripple - Debris Count', itU8),
wbInteger('OnCripple - Decal Count', itU8),
wbFormIDCk('OnCripple - Explosion', [EXPL, NULL]),
wbFormIDCk('OnCripple - Debris', [DEBR, NULL]),
wbFormIDCk('OnCripple - Impact DataSet', [IPDS, NULL]),
wbFormIDCk('Explodable - Subsegment Explosion', [EXPL, NULL]),
wbFloat('Orientation Limits - Pitch'),
wbFloat('Orientation Limits - Roll')
], cpNormal, True),
wbEmpty(MNAM, 'Male Marker'),
wbString(ANAM, 'Male Skeletal Model'),
wbMODT,
wbEmpty(FNAM, 'Female Marker'),
wbString(ANAM, 'Female Skeletal Model'),
wbMODT,
wbEmpty(NAM2, 'Marker NAM2 #1'),
wbRArrayS('Movement Type Names', wbString(MTNM, 'Name')),
wbArray(VTCK, 'Voices', wbFormIDCk('Voice', [VTYP]), ['Male', 'Female'], cpNormal, True),
//wbArray(DNAM, 'Decapitate Armors', wbFormIDCk('Decapitate Armor', [NULL, ARMO]), ['Male', 'Female'], cpNormal, False),
wbArray(HCLF, 'Default Hair Colors', wbFormIDCk('Default Hair Color', [NULL, CLFM]), ['Male', 'Female'], cpNormal, False),
wbInteger(TINL, 'Total Number of Tints in List', itU16, nil, nil, cpNormal, False), {>>> Needs Count Updated <<<}
wbFloat(PNAM, 'FaceGen - Main clamp', cpNormal, True),
wbFloat(UNAM, 'FaceGen - Face clamp', cpNormal, True),
wbFormIDCk(ATKR, 'Attack Race', [RACE], False, cpNormal, False),
wbRArrayS('Attacks', wbAttackData),
wbRStruct('Body Data', [
wbEmpty(NAM1, 'Body Data Marker', cpNormal, True),
wbRStruct('Male Body Data', [
wbEmpty(MNAM, 'Male Data Marker'),
wbRArrayS('Parts', wbRStructSK([0], 'Part', [
wbInteger(INDX, 'Index', itU32, wbBodyPartIndexEnum),
wbMODL
], []), cpNormal, True)
], [], cpNormal, True),
wbRStruct('Female Body Data', [
wbEmpty(FNAM, 'Female Data Marker', cpNormal, True),
wbRArrayS('Parts', wbRStructSK([0], 'Part', [
wbInteger(INDX, 'Index', itU32, wbBodyPartIndexEnum),
wbMODL
], []), cpNormal, True)
], [], cpNormal, True)
], [], cpNormal, True),
wbFormIDCk(GNAM, 'Body Part Data', [BPTD]),
wbEmpty(NAM2, 'Marker NAM2 #2', cpNormal),
wbEmpty(NAM3, 'Marker NAM3 #3', cpNormal, True),
wbRStruct('Male Behavior Graph', [
wbEmpty(MNAM, 'Male Data Marker'),
wbMODL
], [], cpNormal, True),
wbRStruct('Female Behavior Graph', [
wbEmpty(FNAM, 'Female Data Marker', cpNormal, True),
wbMODL
], [], cpNormal, True),
wbFormIDCk(NAM4, 'Impact Material Type', [MATT]),
wbFormIDCk(NAM5, 'Impact Data Set', [IPDS]),
wbFormIDCk(NAM7, 'Dismember Blood Art', [ARTO]),
wbFormIDCk(CNAM, 'Meat Cap TextureSet', [TXST]),
wbFormIDCk(NAM2, 'Collar TextureSet', [TXST]),
wbFormIDCk(ONAM, 'Sound - Open Corpse', [SNDR]),
wbFormIDCk(LNAM, 'Sound - Close Corpse', [SNDR]),
wbRArray('Biped Object Names', wbString(NAME, 'Name')),
wbRaceRBPC,
wbRArrayS('Movement Data Overrides', wbRStructSK([0], 'Override', [
wbFormIDCk(MTYP, 'Movement Type', [MOVT]),
wbSPED
], [])),
wbInteger(VNAM, 'Equipment Flags', itU32, wbEquipType),
wbRArray('Equip Slots',
wbRStruct('Equip Slot', [
wbFormIDCk(QNAM, 'Equip Slot', [EQUP]),
wbString(ZNAM, 'Node')
], [])
),
wbFormIDCk(UNWP, 'Unarmed Weapon', [WEAP]),
wbRArray('Phoneme Target Names', wbString(PHTN, 'Name')),
wbPHWT,
wbFormIDCk(WKMV, 'Base Movement Defaults - Default', [MOVT]),
wbFormIDCk(SWMV, 'Base Movement Defaults - Swim', [MOVT]),
wbFormIDCk(FLMV, 'Base Movement Defaults - Fly', [MOVT]),
wbFormIDCk(SNMV, 'Base Movement Defaults - Sneak', [MOVT]),
// Male head
wbEmpty(NAM0, 'Head Data Marker'),
wbEmpty(MNAM, 'Male Data Marker'),
wbStruct(NNAM, 'Male Neck Fat Adjustments Scale', [
wbByteArray('Unknown', 4),
wbFloat('X'),
wbFloat('Y')
]),
wbRArrayS('Male Head Parts', wbHeadPart),
wbRArray('Male Race Presets', wbFormIDCk(RPRM, 'Preset NPC', [NPC_, NULL])),
wbRArray('Male Hair Colors', wbFormIDCk(AHCM, 'Hair Color', [CLFM, NULL])),
wbRArrayS('Male Face Details', wbFormIDCk(FTSM, 'Texture Set', [TXST, NULL])),
wbFormIDCk(DFTM, 'Male Default Face Texture', [TXST]),
wbTintTemplateGroups('Male Tint Layers'),
wbMorphGroups('Male Morph Groups'),
wbFaceMorphs('Male Face Morphs'),
wbString(WMAP, 'Male Wrinkle Map Path'),
// Female head
wbEmpty(NAM0, 'Head Data Marker'),
wbEmpty(FNAM, 'Female Data Marker'),
wbStruct(NNAM, 'Female Neck Fat Adjustments Scale', [
wbByteArray('Unknown', 4),
wbFloat('X'),
wbFloat('Y')
]),
wbRArrayS('Female Head Parts', wbHeadPart),
wbRArray('Female Race Presets', wbFormIDCk(RPRF, 'Preset NPC', [NPC_, NULL])),
wbRArray('Female Hair Colors', wbFormIDCk(AHCF, 'Hair Color', [CLFM, NULL])),
wbRArrayS('Female Face Details', wbFormIDCk(FTSF, 'Texture Set', [TXST, NULL])),
wbFormIDCk(DFTF, 'Female Default Face Texture', [TXST]),
wbTintTemplateGroups('Female Tint Layers'),
wbMorphGroups('Female Morph Groups'),
wbFaceMorphs('Female Face Morphs'),
wbString(WMAP, 'Female Wrinkle Map Path'),
wbFormIDCk(NAM8, 'Morph Race', [RACE]),
wbFormIDCk(RNAM, 'Armor Race', [RACE]),
wbFormIDCk(SRAC, 'Subgraph Template Race', [RACE]),
wbFormIDCk(SADD, 'Subgraph Additive Race', [RACE]),
wbRArray('Subgraph Data',
wbRStruct('Data', [
wbString(SGNM, 'Behaviour Graph'),
wbRArray('Actor Keywords', wbFormIDCk(SAKD, 'Keyword', [KYWD])),
wbRArray('Target Keywords', wbFormIDCk(STKD, 'Keyword', [KYWD])),
wbRArray('Animation Paths', wbString(SAPT, 'Path'), cpNormal, True),
// Values greater than $10000 sets a bool. Reading this "closes" the current record.
wbStruct(SRAF, 'Flags', [
wbInteger('Role', itU16, wbEnum([
{0} 'MT',
{1} 'Weapon',
{2} 'Furniture',
{3} 'Idle',
{4} 'Pipboy'
])),
wbInteger('Perspective', itU16, wbEnum([
'3rd',
'1st'
]))
], cpNormal, True)
], [], cpNormal, False, nil, True)
),
wbFloat(PTOP, 'Idle Chatter Time Min'),
wbFloat(NTOP, 'Idle Chatter Time Max'),
wbRArray('Morph Values',
wbRStruct('Value', [
wbInteger(MSID, 'Index', itU32, wbIntToHexStr, wbHexStrToInt),
wbString(MSM0, 'Min Name'),
wbString(MSM1, 'Max Name')
], [])
),
wbUnknown(MLSI),
wbString(HNAM, 'Hair Color Lookup Texture'),
wbString(HLTX, 'Hair Color Extended Lookup Texture'),
wbFormIDCk(QSTI, 'Dialogue Quest', [QUST]),
wbBSMPSequence
], False, nil, cpNormal, False, nil, wbRACEAfterSet);
wbRecord(REFR, 'Placed Object', wbFormaterUnion(wbREFRRecordFlagsDecider, [
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000010} 4, 'Ground Piece',
{0x00000100} 8, 'LOD Respects Enable State',
{0x00000400} 10, 'Persistent',
{0x00000800} 11, 'Initially Disabled',
{0x00010000} 16, 'Is Full LOD',
{0x04000000} 26, 'Filter (Collision Geometry)',
{0x08000000} 27, 'Bounding Box (Collision Geometry)',
{0x10000000} 28, 'Reflected By Auto Water',
{0x40000000} 30, 'Ground',
{0x80000000} 31, 'Multibound'
], True, True)),
{ACTI STAT SCOL TREE} wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000010} 4, 'Ground Piece',
{0x00000100} 8, 'LOD Respects Enable State',
{0x00000200} 9, 'Hidden From Local Map',
{0x00000400} 10, 'Persistent',
{0x00000800} 11, 'Initially Disabled',
{0x00008000} 15, 'Visible when distant',
{0x00010000} 16, 'Is Full LOD',
{0x04000000} 26, 'Filter (Collision Geometry)',
{0x08000000} 27, 'Bounding Box (Collision Geometry)',
{0x10000000} 28, 'Reflected By Auto Water',
{0x20000000} 29, 'Don''t Havok Settle',
{0x40000000} 30, 'No Respawn',
{0x80000000} 31, 'Multibound'
], True, True)),
{CONT TERM} wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000010} 4, 'Ground Piece',
{0x00000400} 10, 'Persistent',
{0x00000800} 11, 'Initially Disabled',
{0x00010000} 16, 'Is Full LOD',
{0x02000000} 25, 'No AI Acquire',
{0x04000000} 26, 'Filter (Collision Geometry)',
{0x08000000} 27, 'Bounding Box (Collision Geometry)',
{0x20000000} 29, 'Don''t Havok Settle',
{0x40000000} 30, 'Ground',
{0x80000000} 31, 'Multibound'
], True, True)),
{DOOR} wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000004} 2, 'Minimal Use Door',
{0x00000040} 6, 'Hidden From Local Map',
{0x00000100} 8, 'Inaccessible',
{0x00000400} 10, 'Persistent',
{0x00000800} 11, 'Initially Disabled',
{0x00010000} 16, 'Is Full LOD',
{0x04000000} 26, 'Filter (Collision Geometry)',
{0x08000000} 27, 'Bounding Box (Collision Geometry)',
{0x20000000} 29, 'Don''t Havok Settle',
{0x40000000} 30, 'No Respawn',
{0x80000000} 31, 'Multibound'
], True, True)),
{LIGH} wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000100} 8, 'Doesn''t Light Water',
{0x00000200} 9, 'Casts Shadows',
{0x00000400} 10, 'Persistent',
{0x00000800} 11, 'Initially Disabled',
{0x00010000} 16, 'Never Fades',
{0x00020000} 17, 'Doesn''t Light Landscape',
{0x02000000} 25, 'No AI Acquire',
{0x10000000} 28, 'Reflected By Auto Water',
{0x20000000} 29, 'Don''t Havok Settle',
{0x40000000} 30, 'No Respawn',
{0x80000000} 31, 'Multibound'
], True, True)),
{MSTT} wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000010} 4, 'Ground Piece',
{0x00000200} 9, 'Motion Blur',
{0x00000400} 10, 'Persistent',
{0x00000800} 11, 'Initially Disabled',
{0x00010000} 16, 'Is Full LOD',
{0x04000000} 26, 'Filter (Collision Geometry)',
{0x08000000} 27, 'Bounding Box (Collision Geometry)',
{0x10000000} 28, 'Reflected By Auto Water',
{0x20000000} 29, 'Don''t Havok Settle',
{0x40000000} 30, 'No Respawn',
{0x80000000} 31, 'Multibound'
], True, True)),
{ADDN} wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000400} 10, 'Persistent',
{0x00000800} 11, 'Initially Disabled',
{0x00010000} 16, 'Is Full LOD',
{0x10000000} 28, 'Reflected By Auto Water',
{0x20000000} 29, 'Don''t Havok Settle',
{0x40000000} 30, 'No Respawn',
{0x80000000} 31, 'Multibound'
], True, True)),
{ALCH BOOK SCRL AMMO ARMO INGR KEYM MISC FURN WEAP}
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000010} 4, 'Ground Piece',
{0x00000400} 10, 'Persistent',
{0x00000800} 11, 'Initially Disabled',
{0x00010000} 16, 'Is Full LOD',
{0x02000000} 25, 'No AI Acquire',
{0x10000000} 28, 'Reflected By Auto Water',
{0x20000000} 29, 'Don''t Havok Settle',
{0x40000000} 30, 'No Respawn',
{0x80000000} 31, 'Multibound'
], True, True))
]), [
wbEDID,
wbVMAD,
wbFormIDCk(NAME, 'Base', sigBaseObjects, False, cpNormal, True),
{--- Bound Contents ---}
{--- Bound Data ---}
wbStruct(XMBO, 'Bound Half Extents', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
{--- Primitive ---}
wbStruct(XPRM, 'Primitive', [
wbStruct('Bounds', [
wbFloat('X', cpNormal, True, 2, 4),
wbFloat('Y', cpNormal, True, 2, 4),
wbFloat('Z', cpNormal, True, 2, 4)
]),
wbFloatColors('Color'),
wbFloat('Unknown'),
wbInteger('Type', itU32, wbEnum([
'None',
'Box',
'Sphere',
'Plane',
'Line',
'Ellipsoid'
]))
]),
wbArray(XPOD, 'Portal Data', wbStruct('References', [
wbFormIDCk('Origin', [REFR, NULL]),
wbFormIDCk('Destination', [REFR, NULL])
])),
wbUnknown(XORD),
wbStruct(XOCP, 'Occlusion Plane Data', [
wbStruct('Size', [
wbFloat('Width', cpNormal, False, 2),
wbFloat('Height', cpNormal, False, 2)
]),
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation (Quaternion?)', [
wbFloat('q1'),
wbFloat('q2'),
wbFloat('q3'),
wbFloat('q4')
])
]),
wbRStruct('Bound Data', [
wbStruct(XRMR, 'Header', [
wbInteger('Linked Rooms Count', itU8),
wbInteger('Flags', itU8, wbFlags([
'Unknown 1',
'Unknown 2',
'Unknown 3',
'Unknown 4',
'Unknown 5',
'Unknown 6',
'Has Image Space',
'Has Lighting Template'
])),
wbByteArray('Unknown', 2)
]),
wbFormIDCk(LNAM, 'Lighting Template', [LGTM]),
wbFormIDCk(INAM, 'Image Space', [IMGS]),
wbRArrayS('Linked Rooms',
wbFormIDCk(XLRM, 'Linked Room', [REFR])
)
], []),
wbEmpty(XMBP, 'MultiBound Primitive Marker', cpIgnore),
{--- Ragdoll ---}
wbXRGD,
wbXRGB,
wbFloat(XRDS, 'Radius'),
wbXSCL,
{--- Emittance ---}
wbFormIDCk(XEMI, 'Emittance', [LIGH, REGN]),
wbStruct(XLIG, 'Light Data', [
wbFloat('FOV 90+/-'),
wbFloat('Fade 1.0+/-'),
wbFloat('End Distance Cap'),
wbFloat('Shadow Depth Bias'),
wbFloat('Near Clip'),
wbFloat('Volumetric Intensity')
], cpNormal, False, nil, 4),
wbStruct(XALP, 'Alpha', [
wbInteger('Cutoff', itU8),
wbInteger('Base', itU8)
]),
{--- Teleport ---}
wbStruct(XTEL, 'Teleport Destination', [
wbFormIDCk('Door', [REFR], True),
wbPosRot,
wbInteger('Flags', itU32, wbFlags([
'No Alarm',
'No Load Screen',
'Relative Position'
])),
wbFormIDCk('Transition Interior', [CELL, NULL])
]),
wbFormIDCk(XTNM, 'Teleport Loc Name', [MESG]),
{--- MultiBound ---}
wbFormIDCk(XMBR, 'MultiBound Reference', [REFR]),
{--- Placed Water ---}
wbUnknown(XWCN),
wbStruct(XWCU, 'Water Velocity', [
wbFloat('X Offset'),
wbFloat('Y Offset'),
wbFloat('Z Offset'),
wbByteArray('Unknown', 4),
wbFloat('X Angle'),
wbFloat('Y Angle'),
wbFloat('Z Angle'),
wbByteArray('Unknown', 0)
]),
wbFormIDCk(XASP, 'Acoustic Restriction', [REFR]),
wbEmpty(XATP, 'Activation Point'),
wbInteger(XAMC, 'Ammo Count', itU32),
wbEmpty(XLKT, 'Linked Ref Transient'),
wbFormIDCk(XLYR, 'Layer', [LAYR]),
wbFormIDCk(XMSP, 'Material Swap', [MSWP]),
wbFormIDCk(XRFG, 'Reference Group', [RFGP]),
wbStruct(XRDO, 'Radio', [
wbFloat('Frequency'),
wbFloat('Min Weak Distance'),
wbFloat('Max Weak Distance'),
wbInteger('Flags', itU32, wbFlags(['Ignores Distance Checks']))
]),
wbStruct(XBSD, 'Spline', [
wbFloat('Slack'),
wbFloat('Thickness'),
wbFloat('Unknown'), // not shown in editor
wbFloat('Unknown'), // not shown in editor
wbFloat('Unknown'), // not shown in editor
wbInteger('Wind - Detached End', itU8, wbBoolEnum),
wbByteArray('Unused', 0) // junk data?
], cpNormal, False, nil, 5),
wbStruct(XPDD, 'Projected Decal', [
wbFloat('Width Scale'),
wbFloat('Height Scale')
// "Uses Box Primitive" checkbox does the following:
// 1. "Rounds" above floats (probably due to floating point precision) [DIRTY EDITS?]
// 2. "Rounds" DATA\Position floats (probably due to floating point precision) [DIRTY EDITS?]
// 3. Creates an XPRM subrecord (this is the "Primitive" tab in the editor)
// 4. Fills out Primitive data:
// 4a. Primitive type: Box
// 4b. Collision layer: XTRI subrecord = 15
// 4c. Bounds (XYZ): 256.0, 215.0, 256.0
// 4d. Color (RGB): 0, 128, 128
// 4e. Unknown: 0.4
]),
wbFormIDCk(XSPC, 'Spawn Container', [REFR]),
{--- Activate Parents ---}
wbRStruct('Activate Parents', [
wbInteger(XAPD, 'Flags', itU8, wbFlags([
'Parent Activate Only'
], True)),
wbRArrayS('Activate Parent Refs',
wbStructSK(XAPR, [0], 'Activate Parent Ref', [
wbFormIDCk('Reference', sigReferences),
wbFloat('Delay')
])
)
], []),
wbFormIDCk(XLIB, 'Leveled Item Base Object', [LVLI]),
wbXLCM,
wbFormIDCk(XLCN, 'Persistent Location', [LCTN]),
{>>> COLL form Index value <<<}
wbInteger(XTRI, 'Collision Layer', itU32),
{--- Lock ---}
wbStruct(XLOC, 'Lock Data', [
wbInteger('Level', itU8, wbEnum([], [
0, 'None',
1, 'Novice 1',
25, 'Novice 25',
50, 'Advanced',
75, 'Expert',
100, 'Master',
253, 'Requires Terminal',
251, 'Barred',
252, 'Chained',
254, 'Inaccessible',
255, 'Requires Key'
])),
wbByteArray('Unused', 3, cpIgnore),
wbFormIDCkNoReach('Key', [KEYM, NULL]),
wbInteger('Flags', itU8, wbFlags(['', '', 'Leveled Lock'])),
wbByteArray('Unused', 3, cpIgnore),
wbUnknown
], cpNormal, False, nil, 4),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN]),
{--- Generated Data ---}
wbStruct(XNDP, 'Navigation Door Link', [
wbFormIDCk('Navigation Mesh', [NAVM]),
wbInteger('Teleport Marker Triangle', itS16, wbREFRNavmeshTriangleToStr, wbStringToInt),
wbByteArray('Unused', 2, cpIgnore)
]),
wbFormIDCk(XLRL, 'Location Reference', [LCRT, LCTN, NULL], False, cpBenignIfAdded),
wbArray(XLRT, 'Location Ref Type', wbFormIDCk('Ref', [LCRT, NULL])),
wbEmpty(XIS2, 'Ignored by Sandbox'),
{--- Ownership ---}
wbXOWN,
wbXRNK,
wbInteger(XCNT, 'Item Count', itS32),
wbInteger(XHLT, 'Health %', itU32),
wbXESP,
wbRArray('Linked References', wbStruct(XLKR, 'Linked Reference', [
wbFormIDCk('Keyword/Ref', [KYWD, PLYR, ACHR, REFR, PGRE, PHZD, PMIS, PARW, PBAR, PBEA, PCON, PFLA, NULL]),
wbFormIDCk('Ref', sigReferences)
], cpNormal, False, nil, 1)),
wbRArray('Patrol', wbRStruct('Data', [
wbFloat(XPRD, 'Idle Time', cpNormal, True),
wbEmpty(XPPA, 'Patrol Script Marker', cpNormal, True),
wbFormIDCk(INAM, 'Idle', [IDLE, NULL], False, cpNormal, True),
wbPDTOs
], [])),
{--- Flags ---}
wbInteger(XACT, 'Action Flag', itU32, wbFlags([
'Use Default',
'Activate',
'Open',
'Open by Default'
])),
wbFloat(XHTW, 'Head-Tracking Weight'),
wbFloat(XFVC, 'Favor Cost'),
wbEmpty(ONAM, 'Open by Default'),
{--- Map Data ---}
wbRStruct('Map Marker', [
wbEmpty(XMRK, 'Map Marker Data'),
wbInteger(FNAM, 'Map Flags', itU8, wbFlags([
{0x01} 'Visible',
{0x02} 'Can Travel To',
{0x04} '"Show All" Hidden',
{0x08} 'Use Location Name'
]), cpNormal, True),
wbFULLReq,
wbStruct(TNAM, '', [
wbInteger('Type', itU8, wbEnum([], [
{Vv = Verified Vanilla}
{No new map markers for Automatron or Workshop}
0, 'Cave', {Vv}
1, 'City', {Vv}
2, 'Diamond City', {Vv}
3, 'Encampment', {Vv}
4, 'Factory / Industrial Site', {Vv}
5, 'Gov''t Building / Monument', {Vv}
6, 'Metro Station', {Vv}
7, 'Military Base', {Vv}
8, 'Natural Landmark', {Vv}
9, 'Office / Civic Building', {Vv}
10, 'Ruins - Town', {Vv}
11, 'Ruins - Urban', {Vv}
12, 'Sanctuary', {Vv}
13, 'Settlement', {Vv}
14, 'Sewer / Utility Tunnels', {Vv}
15, 'Vault', {Vv}
16, 'Airfield', {Vv}
17, 'Bunker Hill', {Vv}
18, 'Camper', {Vv}
19, 'Car', {Vv}
20, 'Church', {Vv}
21, 'Country Club', {Vv}
22, 'Custom House', {Vv}
23, 'Drive-In', {Vv}
24, 'Elevated Highway', {Vv}
25, 'Faneuil Hall', {Vv}
26, 'Farm', {Vv}
27, 'Filling Station', {Vv}
28, 'Forested', {Vv}
29, 'Goodneighbor', {Vv}
30, 'Graveyard', {Vv}
31, 'Hospital', {Vv}
32, 'Industrial Dome', {Vv}
33, 'Industrial Stacks', {Vv}
34, 'Institute', {Vv}
35, 'Irish Pride', {Vv}
36, 'Junkyard', {Vv}
37, 'Observatory', {Vv}
38, 'Pier', {Vv}
39, 'Pond / Lake', {Vv}
40, 'Quarry', {Vv}
41, 'Radioactive Area', {Vv}
42, 'Radio Tower', {Vv}
43, 'Salem', {Vv}
44, 'School', {Vv}
45, 'Shipwreck', {Vv}
46, 'Submarine', {Vv}
47, 'Swan Pond', {Vv}
48, 'Synth Head', {Vv}
49, 'Town', {Vv}
50, 'Brotherhood of Steel', {Vv}
51, 'Brownstone Townhouse', {Vv}
52, 'Bunker', {Vv}
53, 'Castle', {Vv}
54, 'Skyscraper', {Vv}
55, 'Libertalia', {Vv}
56, 'Low-Rise Building', {Vv}
57, 'Minutemen', {Vv}
58, 'Police Station', {Vv}
59, 'Prydwen', {Vv}
60, 'Railroad - Faction', {Vv}
61, 'Railroad', {Vv}
62, 'Satellite', {Vv}
63, 'Sentinel', {Vv}
64, 'USS Constitution', {Vv}
65, 'Mechanist LairRaider settlementVassal settlementPotential Vassal settlement', {Vv}
66, 'Custom 66',
67, 'Custom 67',
68, 'Custom 68',
69, 'Custom 69',
70, 'Custom 70',
71, 'Custom 71',
72, 'Custom 72',
73, 'Custom 73',
74, 'Custom 74',
75, 'Custom 75',
76, 'Custom 76',
77, 'Custom 77',
78, 'Custom 78',
79, 'Custom 79',
80, 'Custom 80',
81, 'Custom 81',
82, 'Custom 82',
83, 'Custom 83',
84, 'Custom 84',
85, 'Custom 85',
86, 'Custom 86',
87, 'Custom 87',
88, 'Custom 88',
89, 'Custom 89',
90, 'Custom 90',
91, 'Custom 91',
92, 'Custom 92',
93, 'Custom 93',
94, 'Custom 94',
95, 'Custom 95',
96, 'Custom 96',
97, 'Custom 97',
98, 'Custom 98',
99, 'Custom 99'
])),
wbByteArray('Unused', 1)
], cpNormal, True)
], []),
{--- Attach reference ---}
wbFormIDCk(XATR, 'Attach Ref', [REFR, PGRE, PHZD, PMIS, PARW, PBAR, PBEA, PCON, PFLA]),
wbRArray('Spline Connection', wbStruct(XPLK, 'Link', [
wbFormIDCk('Ref', [REFR, ACHR]),
wbUnknown // always 00 00 00 00 so far in DLCWorkshop03.esm
])),
wbRStruct('Power Grid', [
wbInteger(XWPG, 'Count', itU32),
wbRArray('Connections', wbStruct(XWPN, 'Connection', [
wbFormIDCk('Node 1', [REFR, ACHR, NULL]),
wbFormIDCk('Node 2', [REFR, ACHR, NULL]),
wbFormIDCk('Line', [REFR, NULL]) // BNDS ref
]))
], []),
wbUnknown(XCVR),
wbUnknown(XCVL),
wbFormIDCk(XCZR, 'Unknown', sigReferences),
wbUnknown(XCZA),
wbFormIDCk(XCZC, 'Unknown', [CELL, NULL]),
wbXLOD, // not seen in FO4 vanilla files
wbDataPosRot,
wbString(MNAM, 'Comments')
], True, wbPlacedAddInfo, cpNormal, False, wbREFRAfterLoad);
wbRecord(REGN, 'Region',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000040} 6, 'Border Region'
])), [
wbEDID,
wbStruct(RCLR, 'Map Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8),
wbByteArray('Unknown', 1)
], cpNormal, True),
wbFormIDCkNoReach(WNAM, 'Worldspace', [WRLD]),
wbRArray('Region Areas', wbRStruct('Region Area', [
wbInteger(RPLI, 'Edge Fall-off', itU32),
wbArray(RPLD, 'Region Point List Data', wbStruct('Point', [
wbFloat('X'),
wbFloat('Y')
]), 0, wbRPLDAfterLoad),
wbUnknown(ANAM)
], [])),
wbRArrayS('Region Data Entries', wbRStructSK([0], 'Region Data Entry', [
{always starts with an RDAT}
wbStructSK(RDAT, [0], 'Data Header', [
wbInteger('Type', itU32, wbEnum([
{0} 'Unknown 0',
{1} 'Unknown 1',
{2} 'Objects',
{3} 'Weather',
{4} 'Map',
{5} 'Land',
{6} 'Grass',
{7} 'Sound',
{8} 'Imposter',
{9} 'Unknown 10',
{10}'Unknown 11',
{11}'Unknown 12',
{12}'Unknown 13',
{13}'Unknown 14',
{14}'Unknown 15',
{15}'Unknown 16'
])),
wbInteger('Flags', itU8, wbFlags([
'Override'
])),
wbInteger('Priority', itU8),
wbByteArray('Unknown')
], cpNormal, True),
{--- Icon ---}
wbICON,
{--- Sound ---}
wbFormIDCk(RDMO, 'Music', [MUSC], False, cpNormal, False, wbREGNSoundDontShow),
wbArrayS(RDSA, 'Sounds', wbStructSK([0], 'Sound', [
wbFormIDCk('Sound', [SNDR, NULL]),
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Pleasant',
{0x00000002} 'Cloudy',
{0x00000004} 'Rainy',
{0x00000008} 'Snowy'
])),
wbFloat('Chance')
]), 0, cpNormal, False, nil, nil, wbREGNSoundDontShow),
{--- Map ---}
wbLString(RDMP, 'Map Name', 0, cpTranslate, False, wbREGNMapDontShow),
{followed by one of these: }
{--- Objects ---}
wbArray(RDOT, 'Objects', wbStruct('Object', [
wbFormIDCk('Object', [TREE, FLOR, STAT, LTEX, MSTT]),
wbInteger('Parent Index', itU16, wbHideFFFF),
wbByteArray('Unknown', 2),
wbFloat('Density'),
wbInteger('Clustering', itU8),
wbInteger('Min Slope', itU8),
wbInteger('Max Slope', itU8),
wbInteger('Flags', itU8, wbFlags([
{0}'Conform to slope',
{1}'Paint Vertices',
{2}'Size Variance +/-',
{3}'X +/-',
{4}'Y +/-',
{5}'Z +/-',
{6}'Tree',
{7}'Huge Rock'
])),
wbInteger('Radius wrt Parent', itU16),
wbInteger('Radius', itU16),
wbFloat('Min Height'),
wbFloat('Max Height'),
wbFloat('Sink'),
wbFloat('Sink Variance'),
wbFloat('Size Variance'),
wbStruct('Angle Variance', [
wbInteger('X', itU16),
wbInteger('Y', itU16),
wbInteger('Z', itU16)
]),
wbByteArray('Unknown', 2),
wbByteArray('Unknown', 4)
]), 0, nil, nil, cpNormal, False, wbREGNObjectsDontShow),
{--- Grass ---}
wbArrayS(RDGS, 'Grasses', wbStructSK([0], 'Grass', [
wbFormIDCk('Grass', [GRAS]),
wbByteArray('Unknown',4)
]), 0, cpNormal, False, nil, nil, wbREGNGrassDontShow),
{--- Weather ---}
wbArrayS(RDWT, 'Weather Types', wbStructSK([0], 'Weather Type', [
wbFormIDCk('Weather', [WTHR]),
wbInteger('Chance', itU32),
wbFormIDCk('Global', [GLOB, NULL])
]), 0, cpNormal, False, nil, nil, wbREGNWeatherDontShow),
wbFloat(RLDM, 'LOD Display Distance Multiplier'),
wbFloat(ANAM, 'Occlusion Accuracy Dist')
], []))
], True);
wbRecord(SOUN, 'Sound Marker', [
wbEDID,
wbOBNDReq,
wbFormIDCk(SDSC, 'Sound Descriptor', [SNDR, NULL]),
wbStruct(REPT, 'Repeat', [
wbFloat('Min Time'),
wbFloat('Max Time'),
wbInteger('Stackable', itU8, wbBoolEnum)
], cpNormal, False, nil, 2)
]);
wbSPIT := wbStruct(SPIT, 'Data', [
wbInteger('Base Cost', itU32),
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Manual Cost Calc',
{0x00000002} 'Unknown 2',
{0x00000004} 'Unknown 3',
{0x00000008} 'Unknown 4',
{0x00000010} 'Unknown 5',
{0x00000020} 'Unknown 6',
{0x00000040} 'Unknown 7',
{0x00000080} 'Unknown 8',
{0x00000100} 'Unknown 9',
{0x00000200} 'Unknown 10',
{0x00000400} 'Unknown 11',
{0x00000800} 'Unknown 12',
{0x00001000} 'Unknown 13',
{0x00002000} 'Unknown 14',
{0x00004000} 'Unknown 15',
{0x00008000} 'Unknown 16',
{0x00010000} 'Unknown 17',
{0x00020000} 'PC Start Spell',
{0x00040000} 'Instant Cast',
{0x00080000} 'Area Effect Ignores LOS',
{0x00100000} 'Ignore Resistance',
{0x00200000} 'No Absorb/Reflect',
{0x00400000} 'Unknown 23',
{0x00800000} 'No Dual Cast Modification',
{0x01000000} 'Unknown 25',
{0x02000000} 'Unknown 26',
{0x04000000} 'Unknown 27',
{0x08000000} 'Unknown 28',
{0x10000000} 'Unknown 29',
{0x20000000} 'Unknown 30',
{0x40000000} 'Unknown 31',
{0x80000000} 'Unknown 32'
])),
wbInteger('Type', itU32, wbEnum([
{0} 'Spell',
{1} 'Disease',
{2} 'Power',
{3} 'Lesser Power',
{4} 'Ability',
{5} 'Poison',
{6} 'Unknown 6',
{7} 'Unknown 7',
{8} 'Unknown 8',
{9} 'Unknown 9',
{10} 'Addiction',
{11} 'Voice'
])),
wbFloat('Charge Time'),
wbInteger('Cast Type', itU32, wbCastEnum),
wbInteger('Target Type', itU32, wbTargetEnum),
wbFloat('Cast Duration'),
wbFloat('Range'),
wbFormIDCk('Casting Perk', [NULL, PERK])
], cpNormal, True);
wbRecord(SPEL, 'Spell', [
wbEDID,
wbOBNDReq,
wbFULL,
wbKSIZ,
wbKWDAs,
wbETYP,
wbDESCReq,
wbSPIT,
wbEffectsReq
], False, nil, cpNormal, False, nil, wbKeywordsAfterSet);
{wbRecord(SCRL, 'Scroll', [
wbEDID
]);}
wbRecord(STAT, 'Static',
wbFlags(wbRecordFlagsFlags, [
{0x00000001} { 0} '',
{0x00000002} { 1} '',
{0x00000004} { 2} 'Heading Marker',
{0x00000008} { 3} '',
{0x00000010} { 4} 'Non Occluder',
{0x00000020} { 5} 'Deleted',
{0x00000040} { 6} 'Has Tree LOD', // Used in Fallout 4 ?
{0x00000080} { 7} 'Add-On LOD Object',
{0x00000100} { 8} '',
{0x00000200} { 9} 'Hidden From Local Map',
{0x00000400} {10} 'Headtrack Marker',
{0x00000800} {11} 'Used as Platform',
{0x00001000} {12} '',
{0x00002000} {13} 'Pack-In Use Only',
{0x00004000} {14} '',
{0x00008000} {15} 'Has Distant LOD',
{0x00010000} {16} '',
{0x00020000} {17} 'Uses HD LOD Texture',
{0x00040000} {18} '',
{0x00080000} {19} 'Has Currents',
{0x00100000} {20} '',
{0x00200000} {21} '',
{0x00400000} {22} '',
{0x00800000} {23} 'Is Marker',
{0x01000000} {24} '',
{0x02000000} {25} 'Obstacle',
{0x04000000} {26} 'NavMesh Generation - Filter',
{0x08000000} {27} 'NavMesh Generation - Bounding Box',
{0x10000000} {28} 'Show In World Map (Sky Cell Only)',
{0x20000000} {29} '',
{0x40000000} {30} 'NavMesh Generation - Ground',
{0x80000000} {31} ''
]), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFTYP,
wbMODL,
wbPRPS,
wbFULL,
wbStruct(DNAM, 'Direction Material', [
wbFloat('Max Angle (30-120)'),
wbFormIDCk('Material', [MATO, NULL]),
wbFloat('Leaf Amplitude'),
wbFloat('Leaf Frequency')
], cpNormal, True, nil, 2),
wbNVNM,
wbArray(MNAM, 'Distant LOD',
wbStruct('LOD', [
{>>> Contains null-terminated mesh filename followed by random data up to 260 bytes <<<}
wbString(True, 'Mesh', 260)
//wbByteArray('Mesh', 260, cpIgnore)
]), [
'Level 0',
'Level 1',
'Level 2',
'Level 3'
],
cpNormal, False
)
], True); // unordered, NVNM can be before or after MNAM
wbRecord(TES4, 'Main File Header',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000001} 0, 'ESM',
{0x00000080} 7, 'Localized'
], False), True), [
wbStruct(HEDR, 'Header', [
wbFloat('Version'),
wbInteger('Number of Records', itU32),
wbInteger('Next Object ID', itU32)
], cpNormal, True),
wbByteArray(OFST, 'Unknown', 0, cpIgnore), // If possible then ignored by the runtime. Neither from the CK
wbByteArray(DELE, 'Unknown', 0, cpIgnore), // If possible then ignored by the runtime. Neither from the CK
wbString(CNAM, 'Author', 0, cpTranslate, True),
wbString(SNAM, 'Description', 0, cpTranslate),
wbRArray('Master Files', wbRStruct('Master File', [
wbString(MAST, 'Filename', 0, cpNormal, True),
// wbInteger(DATA, 'Filesize', itU64, nil, nil, cpIgnore, True) // Should be set by CK but usually null
wbByteArray(DATA, 'Unknown', 8, cpIgnore, True)
], [ONAM])),
wbArray(ONAM, 'Overridden Forms', // Valid in CK
wbFormIDCk('Form', [ACHR, LAND, NAVM, REFR, PGRE, PHZD, PMIS, PARW, PBAR, PBEA, PCON, PFLA, DLBR, DIAL, INFO, SCEN]),
0, nil, nil, cpNormal, False{, wbTES4ONAMDontShow}),
wbByteArray(SCRN, 'Screenshot'), // If possible then ignored by the runtime. Neither from the CK
wbRArray('Transient Types (CK only)', wbStruct(TNAM, 'Transient Type', [
wbInteger('FormType', itU32), // seen TESTopic 78 (array of DIAL) and BGSScene 126 (array of SCEN)
wbArray('Unknown', wbFormID('Unknown'))
])), // Ignored by the runtime
wbInteger(INTV, 'Unknown', itU32), // Ignored by the runtime, 4 bytes loaded in CK
wbInteger(INCC, 'Unknown', itU32) // Size of some array of 12 bytes elements
], True, nil, cpNormal, True, wbRemoveOFST);
end;
procedure DefineFO4o;
begin
wbRecord(TREE, 'Tree',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00008000} 15, 'Has Distant LOD'
])), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbMODL,
wbFormIDCK(PFIG, 'Ingredient', sigBaseObjects),
wbFormIDCK(SNAM, 'Harvest Sound', [SNDR, NULL]),
wbStruct(PFPC, 'Ingredient Production', [
wbInteger('Spring', itU8),
wbInteger('Summer', itU8),
wbInteger('Fall', itU8),
wbInteger('Winter', itU8)
]),
wbFULL,
wbStruct(CNAM, 'Tree Data', [
wbFloat('Trunk Flexibility'),
wbFloat('Branch Flexibility'),
//wbByteArray('Unknown', 32),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Unknown'),
wbFloat('Leaf Amplitude'),
wbFloat('Leaf Frequency')
], cpNormal, True)
]);
wbRecord(FLOR, 'Flora', [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFULLReq,
wbMODL,
wbDEST,
wbKSIZ,
wbKWDAs,
wbPRPS,
wbUnknown(PNAM),
wbATTX,
wbLString(RNAM, 'Activate Text Override', 0, cpTranslate),
wbUnknown(FNAM),
wbFormIDCk(PFIG, 'Ingredient', sigBaseObjects),
wbFormIDCK(SNAM, 'Harvest Sound', [SNDR]),
wbStruct(PFPC, 'Ingredient Production', [
wbInteger('Spring', itU8),
wbInteger('Summer ', itU8),
wbInteger('Fall', itU8),
wbInteger('Winter', itU8)
], cpNormal, True)
], False, nil, cpNormal, False, nil, wbKeywordsAfterSet);
wbRecord(WATR, 'Water', [
wbEDID,
wbFULL,
wbInteger(ANAM, 'Opacity (unused)', itU8),
wbInteger(FNAM, 'Flags', itU8, wbFlags([
{0x01} 'Dangerous',
{0x02} 'Unknown 1',
{0x04} 'Directional Sound'
]), cpNormal, True),
wbFormIDCk(TNAM, 'Material (unused)', [MATT]),
wbFormIDCk(SNAM, 'Open Sound', [SNDR, NULL]),
wbFormIDCk(XNAM, 'Consume Spell', [SPEL]),
wbFormIDCk(YNAM, 'Contact Spell', [SPEL]),
wbFormIDCk(INAM, 'Image Space', [IMGS]),
wbByteArray(DATA, 'Unused', 0),
wbStruct(DNAM, 'Visual Data', [
wbStruct('Fog Properties', [
wbFloat('Depth Amount'),
wbByteColors('Shallow Color'),
wbByteColors('Deep Color'),
wbFloat('Color Shallow Range'),
wbFloat('Color Deep Range'),
wbFloat('Shallow Alpha'),
wbFloat('Deep Alpha'),
wbFloat('Alpha Shallow Range'),
wbFloat('Alpha Deep Range'),
wbByteColors('Underwater Color'),
wbFloat('Underwater Fog Amount'),
wbFloat('Underwater Near Fog'),
wbFloat('Underwater Far Fog')
]),
wbStruct('Physical Properties', [
wbFloat('Normal Magnitude'),
wbFloat('Shallow Normal Falloff'),
wbFloat('Deep Normal Falloff'),
wbFloat('Reflectivity Amount'),
wbFloat('Fresnel Amount'),
wbFloat('Surface Effect Falloff'),
wbStruct('Displacement Simulator', [
wbFloat('Force'),
wbFloat('Velocity'),
wbFloat('Falloff'),
wbFloat('Dampener'),
wbFloat('Starting Size')
]),
wbByteColors('Reflection Color')
]),
wbStruct('Specular Properties', [
wbFloat('Sun Specular Power'),
wbFloat('Sun Specular Magnitude'),
wbFloat('Sun Sparkle Power'),
wbFloat('Sun Sparkle Magnitude'),
wbFloat('Interior Specular Radius'),
wbFloat('Interior Specular Brightness'),
wbFloat('Interior Specular Power')
]),
wbStruct('Noise Properties', [
wbFloat('Layer 1 - Wind Direction'),
wbFloat('Layer 2 - Wind Direction'),
wbFloat('Layer 3 - Wind Direction'),
wbFloat('Layer 1 - Wind Speed'),
wbFloat('Layer 2 - Wind Speed'),
wbFloat('Layer 3 - Wind Speed'),
wbFloat('Layer 1 - Amplitude Scale'),
wbFloat('Layer 2 - Amplitude Scale'),
wbFloat('Layer 3 - Amplitude Scale'),
wbFloat('Layer 1 - UV Scale'),
wbFloat('Layer 2 - UV Scale'),
wbFloat('Layer 3 - UV Scale'),
wbFloat('Layer 1 - Noise Falloff'),
wbFloat('Layer 2 - Noise Falloff'),
wbFloat('Layer 3 - Noise Falloff')
]),
wbStruct('Silt Properties', [
wbFloat('Silt Amount'),
wbByteColors('Light Color'),
wbByteColors('Dark Color')
]),
wbInteger('Screen Space Reflections', itU8, wbBoolEnum)
], cpNormal, True, nil, 4),
wbByteArray(GNAM, 'Unused', 0),
wbStruct(NAM0, 'Linear Velocity', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
], cpNormal, False),
wbStruct(NAM1, 'Angular Velocity', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
], cpNormal, False),
wbString(NAM2, 'Layer 1 Noise Texture'),
wbString(NAM3, 'Layer 2 Noise Texture'),
wbString(NAM4, 'Layer 3 Noise Texture')
]);
wbRecord(WEAP, 'Weapon',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000004} 2, 'Non-Playable',
{0x20000000} 30, 'High-Res 1st Person Only'
])), [
wbEDID,
wbVMAD,
wbOBNDReq,
wbPTRN,
wbFULL,
wbMODL,
wbICON,
wbMICO,
wbEITM,
wbInteger(EAMT, 'Enchantment Amount', itU16),
wbDEST,
wbETYP,
wbFormIDCk(BIDS, 'Block Bash Impact Data Set', [IPDS, NULL]),
wbFormIDCk(BAMT, 'Alternate Block Material', [MATT, NULL]),
wbYNAM,
wbZNAM,
wbKSIZ,
wbKWDAs,
wbDESC,
wbFormIDCk(INRD, 'Instance Naming', [INNR]),
wbAPPR,
wbObjectTemplate,
wbFormIDCk(NNAM, 'Embedded Weapon Mod', [OMOD]),
wbRStruct('1st Person Model', [
wbString(MOD4, 'Model Filename'),
wbByteArray(MO4T, 'Texture Files Hashes', 0, cpIgnore, false, false, wbNeverShow),
wbMO4S,
wbMO4C,
wbMO4F
], []),
wbStruct(DNAM, 'Data', [
wbFormIDCk('Ammo', [AMMO, NULL]),
wbFloat('Speed'),
wbFloat('Reload Speed'),
wbFloat('Reach'),
wbFloat('Min Range'),
wbFloat('Max Range'),
wbFloat('Attack Delay'),
wbByteArray('Unknown', 4),
wbFloat('Damage - OutOfRange Mult'),
wbInteger('On Hit', itU32, wbHitBehaviourEnum),
wbFormIDCk('Skill', [AVIF, NULL]),
wbFormIDCk('Resist', [AVIF, NULL]),
wbInteger('Flags', itU32, wbFlags([
{0x00000001} 'Player Only',
{0x00000002} 'NPCs Use Ammo',
{0x00000004} 'No Jam After Reload',
{0x00000008} 'Charging Reload',
{0x00000010} 'Minor Crime',
{0x00000020} 'Fixed Range',
{0x00000040} 'Not Used In Normal Combat',
{0x00000080} 'Unknown 8',
{0x00000100} 'Crit Effect - on Death',
{0x00000200} 'Charging Attack',
{0x00000400} 'Unknown 11',
{0x00000800} 'Hold Input To Power',
{0x00001000} 'Non Hostile',
{0x00002000} 'Bound Weapon',
{0x00004000} 'Ignores Normal Weapon Resistance',
{0x00008000} 'Automatic',
{0x00010000} 'Repeatable Single Fire',
{0x00020000} 'Can''t Drop',
{0x00040000} 'Hide Backpack',
{0x00080000} 'Embedded Weapon',
{0x00100000} 'Not Playable',
{0x00200000} 'Has Scope',
{0x00400000} 'Bolt Action',
{0x00800000} 'Secondary Weapon',
{0x01000000} 'Disable Shells',
{0x02000000} 'Unknown 26',
{0x04000000} 'Unknown 27',
{0x08000000} 'Unknown 28',
{0x10000000} 'Unknown 29',
{0x20000000} 'Unknown 30',
{0x40000000} 'Unknown 31',
{0x80000000} 'Unknown 32'
])),
wbInteger('Capacity', itU16),
wbInteger('Animation Type', itU8, wbEnum([
'HandToHandMelee',
'OneHandSword',
'OneHandDagger',
'OneHandAxe',
'OneHandMace',
'TwoHandSword',
'TwoHandAxe',
'Bow',
'Staff',
'Gun',
'Grenade',
'Mine'
])),
wbFloat('Damage - Secondary'),
wbFloat('Weight'),
wbInteger('Value', itU32),
wbInteger('Damage - Base', itU16),
wbInteger('Sound Level', itU32, wbSoundLevelEnum),
wbFormIDCk('Sound - Attack', [SNDR, NULL]),
wbFormIDCk('Sound - Attack 2D', [SNDR, NULL]),
wbFormIDCk('Sound - Attack Loop', [SNDR, NULL]),
wbFormIDCk('Sound - Attack Fail', [SNDR, NULL]),
wbFormIDCk('Sound - Idle', [SNDR, NULL]),
wbFormIDCk('Sound - Equip Sound', [SNDR, NULL]),
wbFormIDCk('Sound - UnEquip Sound', [SNDR, NULL]),
wbFormIDCk('Sound - Fast Equip Sound', [SNDR, NULL]),
wbInteger('Accuracy Bonus', itU8),
wbFloat('Animation Attack Seconds'),
wbByteArray('Unknown', 2),
wbFloat('Action Point Cost'),
wbFloat('Full Power Seconds'),
wbFloat('Min Power Per Shot'),
wbInteger('Stagger', itU32, wbStaggerEnum),
wbByteArray('Unknown', 4)
]),
wbStruct(FNAM, '', [
wbFloat('Animation Fire Seconds'),
wbFloat('Rumble - Left Motor Strength'),
wbFloat('Rumble - Right Motor Strength'),
wbFloat('Rumble - Duration'),
wbFloat('Animation Reload Seconds'),
wbByteArray('Unknown', 4),
wbFloat('Sighted Transition Seconds'),
wbInteger('# Projectiles', itU8),
wbFormIDCk('Override Projectile', [PROJ, NULL]),
wbInteger('Pattern', itU32, wbEnum([
'Constant',
'Square',
'Triangle',
'Sawtooth'
])),
wbInteger('Rumble - Peroid (ms)', itU32)
]),
wbStruct(CRDT, 'Critical Data', [
wbFloat('Crit Damage Mult'),
wbFloat('Crit Charge Bonus'),
wbFormIDCk('Crit Effect', [SPEL, NULL])
]),
wbFormIDCk(INAM, 'Impact Data Set', [IPDS]),
wbFormIDCk(LNAM, 'NPC Add Ammo List', [LVLI]),
wbFormIDCk(WAMD, 'Aim Model', [AMDL]),
wbFormIDCk(WZMD, 'Zoom', [ZOOM]),
wbFormIDCk(CNAM, 'Template', [WEAP]),
wbStructs(DAMA, 'Damage Types', 'Damage Type', [
wbFormIDCk('Type', [DMGT]),
wbInteger('Amount', itU32)
]),
wbFLTR,
wbInteger(MASE, 'Melee Speed', itU32, wbEnum([
'Very Slow',
'Slow',
'Medium',
'Fast',
'Very Fast'
]))
], False, nil, cpNormal, False, nil{wbWEAPAfterLoad}, wbKeywordsAfterSet);
wbRecord(WRLD, 'Worldspace',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00080000} 19, 'Can''t Wait'
])), [
wbEDID,
wbRArray('Unused RNAM', wbUnknown(RNAM), cpIgnore, False{, wbNeverShow}),
wbMaxHeightDataWRLD,
wbFULL,
wbStruct(WCTR, 'Fixed Dimensions Center Cell', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
]),
wbFormIDCk(LTMP, 'Interior Lighting', [LGTM]),
wbFormIDCk(XEZN, 'Encounter Zone', [ECZN, NULL]),
wbFormIDCk(XLCN, 'Location', [LCTN, NULL]),
wbRStruct('Parent', [
wbFormIDCk(WNAM, 'Worldspace', [WRLD]),
wbStruct(PNAM, '', [
wbInteger('Flags', itU8, wbFlags([
{0x0001} 'Use Land Data',
{0x0002} 'Use LOD Data',
{0x0004} 'Don''t Use Map Data',
{0x0008} 'Use Water Data',
{0x0010} 'Use Climate Data',
{0x0020} 'Use Image Space Data (unused)',
{0x0040} 'Use Sky Cell'
], [5])),
wbByteArray('Unknown', 1)
], cpNormal, True)
], []),
wbFormIDCk(CNAM, 'Climate', [CLMT]),
wbFormIDCk(NAM2, 'Water', [WATR]),
wbFormIDCk(NAM3, 'LOD Water Type', [WATR]),
wbFloat(NAM4, 'LOD Water Height'),
wbStruct(DNAM, 'Land Data', [
wbFloat('Default Land Height'),
wbFloat('Default Water Height')
]),
wbString(ICON, 'Map Image'),
wbRStruct('Cloud Model', [wbMODL], []),
wbStruct(MNAM, 'Map Data', [
wbStruct('Usable Dimensions', [
wbInteger('X', itS32),
wbInteger('Y', itS32)
]),
wbStruct('Cell Coordinates', [
wbStruct('NW Cell', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
]),
wbStruct('SE Cell', [
wbInteger('X', itS16),
wbInteger('Y', itS16)
])
])
]),
wbStruct(ONAM, 'World Map Offset Data', [
wbFloat('World Map Scale'),
wbFloat('Cell X Offset'),
wbFloat('Cell Y Offset'),
wbFloat('Cell Z Offset')
], cpNormal, True),
wbFloat(NAMA, 'Distant LOD Multiplier'),
wbInteger(DATA, 'Flags', itU8, wbFlags([
{0x01} 'Small World',
{0x02} 'Can''t Fast Travel',
{0x04} 'Unknown 3',
{0x08} 'No LOD Water',
{0x10} 'No Landscape',
{0x20} 'No Sky',
{0x40} 'Fixed Dimensions',
{0x80} 'No Grass'
]), cpNormal, True),
{>>> Object Bounds doesn't show up in CK <<<}
wbRStruct('Object Bounds', [
wbStruct(NAM0, 'Min', [
wbFloat('X', cpNormal, False, 1/4096),
wbFloat('Y', cpNormal, False, 1/4096)
], cpIgnore, True),
wbStruct(NAM9, 'Max', [
wbFloat('X', cpNormal, False, 1/4096),
wbFloat('Y', cpNormal, False, 1/4096)
], cpIgnore, True)
], []),
wbFormIDCk(ZNAM, 'Music', [MUSC]),
wbString(NNAM, 'Canopy Shadow (unused)', 0, cpIgnore),
wbString(XWEM, 'Water Environment Map'),
wbString(TNAM, 'HD LOD Diffuse Texture'),
wbString(UNAM, 'HD LOD Normal Texture'),
wbRStruct('World Default Level Data', [
wbStruct(WLEV, 'Dimension', [
wbStruct('NW Cell', [
wbInteger('X', itS8),
wbInteger('Y', itS8)
]),
wbStruct('Size', [
wbInteger('Width', itU8),
wbInteger('Height', itU8)
])
]),
wbByteArray(WLEV, 'Data')
], []),
wbOFST,
wbUnknown(CLSZ)
], False, nil, cpNormal, False, wbWRLDAfterLoad);
wbRecord(WTHR, 'Weather',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000200} 9, 'Unknown 9'
])), [
wbEDID,
wbString(_00_0TX, 'Cloud Texture Layer #0'),
wbString(_10_0TX, 'Cloud Texture Layer #1'),
wbString(_20_0TX, 'Cloud Texture Layer #2'),
wbString(_30_0TX, 'Cloud Texture Layer #3'),
wbString(_40_0TX, 'Cloud Texture Layer #4'),
wbString(_50_0TX, 'Cloud Texture Layer #5'),
wbString(_60_0TX, 'Cloud Texture Layer #6'),
wbString(_70_0TX, 'Cloud Texture Layer #7'),
wbString(_80_0TX, 'Cloud Texture Layer #8'),
wbString(_90_0TX, 'Cloud Texture Layer #9'),
wbString(_3A_0TX, 'Cloud Texture Layer #10'),
wbString(_3B_0TX, 'Cloud Texture Layer #11'),
wbString(_3C_0TX, 'Cloud Texture Layer #12'),
wbString(_3D_0TX, 'Cloud Texture Layer #13'),
wbString(_3E_0TX, 'Cloud Texture Layer #14'),
wbString(_3F_0TX, 'Cloud Texture Layer #15'),
wbString(_40h_0TX, 'Cloud Texture Layer #16'),
wbString(A0TX, 'Cloud Texture Layer #17'),
wbString(B0TX, 'Cloud Texture Layer #18'),
wbString(C0TX, 'Cloud Texture Layer #19'),
wbString(D0TX, 'Cloud Texture Layer #20'),
wbString(E0TX, 'Cloud Texture Layer #21'),
wbString(F0TX, 'Cloud Texture Layer #22'),
wbString(G0TX, 'Cloud Texture Layer #23'),
wbString(H0TX, 'Cloud Texture Layer #24'),
wbString(I0TX, 'Cloud Texture Layer #25'),
wbString(J0TX, 'Cloud Texture Layer #26'),
wbString(K0TX, 'Cloud Texture Layer #27'),
wbString(L0TX, 'Cloud Texture Layer #28'),
wbUnknown(LNAM),
wbFormIDCK(MNAM, 'Precipitation Type', [SPGD, NULL]),
wbFormIDCK(NNAM, 'Visual Effect', [RFCT, NULL], False, cpNormal, True),
wbByteArray(ONAM, 'Unused', 0, cpIgnore),
wbRStruct('Cloud Speed', [
wbArray(RNAM, 'Y Speed', wbInteger('Layer', itU8, wbCloudSpeedToStr, wbCloudSpeedToInt)),
wbArray(QNAM, 'X Speed', wbInteger('Layer', itU8, wbCloudSpeedToStr, wbCloudSpeedToInt))
], []),
wbArray(PNAM, 'Cloud Colors', wbWeatherColors('Layer')),
wbArray(JNAM, 'Cloud Alphas', wbStruct('Layer', [
wbFloat('Sunrise'),
wbFloat('Day'),
wbFloat('Sunset'),
wbFloat('Night'),
wbFloat('EarlySunrise'),
wbFloat('LateSunrise'),
wbFloat('EarlySunset'),
wbFloat('LateSunset')
])),
wbStruct(NAM0, 'Weather Colors', [
wbWeatherColors('Sky-Upper'),
wbWeatherColors('Fog Near'),
wbWeatherColors('Unknown'),
wbWeatherColors('Ambient'),
wbWeatherColors('Sunlight'),
wbWeatherColors('Sun'),
wbWeatherColors('Stars'),
wbWeatherColors('Sky-Lower'),
wbWeatherColors('Horizon'),
wbWeatherColors('Effect Lighting'),
wbWeatherColors('Cloud LOD Diffuse'),
wbWeatherColors('Cloud LOD Ambient'),
wbWeatherColors('Fog Far'),
wbWeatherColors('Sky Statics'),
wbWeatherColors('Water Multiplier'),
wbWeatherColors('Sun Glare'),
wbWeatherColors('Moon Glare'),
wbWeatherColors('Fog Near High'),
wbWeatherColors('Fog Far High')
], cpNormal, True, nil, 8),
wbArray(NAM4, 'Unknown', wbFloat('Unknown')),
wbStruct(FNAM, 'Fog Distance', [
wbFloat('Day - Near'),
wbFloat('Day - Far'),
wbFloat('Night - Near'),
wbFloat('Night - Far'),
wbFloat('Day - Power'),
wbFloat('Night - Power'),
wbFloat('Day - Max'),
wbFloat('Night - Max'),
wbFloat('Day - Near Height Mid'),
wbFloat('Day - Near Height Range'),
wbFloat('Night - Near Height Mid'),
wbFloat('Night - Near Height Range'),
wbFloat('Day - High Density Scale'),
wbFloat('Night - High Density Scale'),
wbFloat('Day - Far Height Mid'),
wbFloat('Day - Far Height Range'),
wbFloat('Night - Far Height Mid'),
wbFloat('Night - Far Height Range')
], cpNormal, True, nil, 8),
wbStruct(DATA, 'Data', [
wbInteger('Wind Speed', itU8), // scaled 0..1
wbByteArray('Unknown', 2),
wbInteger('Trans Delta', itU8), // scaled 0..0,25
wbInteger('Sun Glare', itU8), // scaled 0..1
wbInteger('Sun Damage', itU8), // scaled 0..1
wbInteger('Precipitation - Begin Fade In', itU8), // scaled 0..1
wbInteger('Precipitation - End Fade Out', itU8), // scaled 0..1
wbInteger('Thunder/Lightning - Begin Fade In', itU8),
wbInteger('Thunder/Lightning - End Fade Out', itU8),
wbInteger('Thunder/Lightning - Frequency', itU8),
wbInteger('Flags', itU8, wbFlags([
{0x01} 'Weather - Pleasant',
{0x02} 'Weather - Cloudy',
{0x04} 'Weather - Rainy',
{0x08} 'Weather - Snow',
{0x10} 'Sky Statics - Always Visible',
{0x20} 'Sky Statics - Follows Sun Position',
{0x40} 'Rain Occlusion',
{0x80} 'HUD Rain Effects'
])),
wbStruct('Lightning Color', [
wbInteger('Red', itU8),
wbInteger('Green', itU8),
wbInteger('Blue', itU8)
]),
wbInteger('Visual Effect - Begin', itU8), // scaled 0..1
wbInteger('Visual Effect - End', itU8), // scaled 0..1
wbInteger('Wind Direction', itU8), // scaled 0..360
wbInteger('Wind Direction Range', itU8), // scaled 0..180
wbInteger('Unknown', itU8)
], cpNormal, True, nil, 16),
wbInteger(NAM1, 'Disabled Cloud Layers', itU32, wbFlags(['0','1','2','3','4','5','6','7','8','9','10','11','12','13','14','15','16','17','18','19','20','21','22','23','24','25','26','27','28','29','30','31'])),
wbRArray('Sounds',
wbStruct(SNAM, 'Sound', [
wbFormIDCK('Sound', [SNDR, NULL]),
wbInteger('Type', itU32, wbEnum([
{0x01} 'Default',
{0x02} 'Precipitation',
{0x04} 'Wind',
{0x08} 'Thunder'
]))
])
),
wbRArrayS('Sky Statics', wbFormIDCk(TNAM, 'Static', [STAT, NULL])),
wbStruct(IMSP, 'Image Spaces', [
wbFormIDCK('Sunrise', [IMGS, NULL]),
wbFormIDCK('Day', [IMGS, NULL]),
wbFormIDCK('Sunset', [IMGS, NULL]),
wbFormIDCK('Night', [IMGS, NULL]),
wbFormIDCK('EarlySunrise', [IMGS, NULL]),
wbFormIDCK('LateSunrise', [IMGS, NULL]),
wbFormIDCK('EarlySunset', [IMGS, NULL]),
wbFormIDCK('LateSunset', [IMGS, NULL])
], cpNormal, True, nil, 4),
wbStruct(WGDR, 'God Rays', [
wbFormIDCK('Sunrise', [GDRY, NULL]),
wbFormIDCK('Day', [GDRY, NULL]),
wbFormIDCK('Sunset', [GDRY, NULL]),
wbFormIDCK('Night', [GDRY, NULL]),
wbFormIDCK('EarlySunrise', [GDRY, NULL]),
wbFormIDCK('LateSunrise', [GDRY, NULL]),
wbFormIDCK('EarlySunset', [GDRY, NULL]),
wbFormIDCK('LateSunset', [GDRY, NULL])
]),
wbRStruct('Directional Ambient Lighting Colors', [
wbAmbientColors(DALC, 'Sunrise'),
wbAmbientColors(DALC, 'Day'),
wbAmbientColors(DALC, 'Sunset'),
wbAmbientColors(DALC, 'Night'),
wbAmbientColors(DALC, 'EarlySunrise'),
wbAmbientColors(DALC, 'LateSunrise'),
wbAmbientColors(DALC, 'EarlySunset'),
wbAmbientColors(DALC, 'LateSunset')
], [], cpNormal, True),
wbRStruct('Aurora', [wbMODL], []),
wbFormIDCk(GNAM, 'Sun Glare Lens Flare', [LENS]),
wbStruct(UNAM, 'Magic', [
wbFormIDCk('On Lightning Strike - Spell', [SPEL, NULL]),
wbFloat('On Lightning Strike - Threshold'),
wbFormIDCk('On Weather Activate - Spell', [SPEL, NULL]),
wbFloat('On Weather Activate - Threshold'),
wbByteArray('Unknown', 4), // SPEL FormID for another context but unresolved in Fallout4.esm, legacy data
wbFloat('Unknown')
], cpNormal, False, nil, 3),
wbFloat(VNAM, 'Volatility Mult'),
wbFloat(WNAM, 'Visibility Mult')
]);
end;
procedure DefineFO4p;
begin
{wbRecord(SCPT, 'SCPT', [
wbEDID
]);}
end;
{>>> Start of new Fallout 4 Records <<<}
procedure DefineFO4q;
begin
wbRecord(AECH, 'Audio Effect Chain', [
wbEDID,
wbRArray('Effects',
wbRStruct('Effect', [
wbInteger(KNAM, 'Type', itU32, wbEnum([], [
Int64($864804BE), 'BSOverdrive',
Int64($EF575F7F), 'BSStateVariableFilter',
Int64($18837B4F), 'BSDelayEffect'
]), cpNormal, False, False, nil, nil, Int64($864804BE)),
wbStruct(DNAM, 'Data', [
wbInteger('Enabled', itU32, wbBoolEnum),
wbUnion('Value 1', wbAECHDataDecider, [
wbFloat('Input Gain'), // exponentially(?) normalized from 0..10 to -80..20
wbFloat('Center Freq'),
wbFloat('Feedback %')
]),
wbUnion('Value 2', wbAECHDataDecider, [
wbFloat('Output Gain'), // exponentially(?) normalized from 0..10 to -80..20
wbFloat('Q Value'),
wbFloat('Wet Mix %')
]),
wbUnion('Value 3', wbAECHDataDecider, [
wbFloat('Upper Threshold'), // exponentially(?) normalized from 0..1 to -74..0
wbInteger('Filter Mode', itU32, wbEnum([
'High Pass',
'Low Pass',
'Band Pass',
'Notch'
])),
wbInteger('Delay MS', itU32)
]),
wbUnion('Value 4', wbAECHDataDecider, [
wbFloat('Lower Threshold'), // exponentially(?) normalized from 0..1 to -80..0
wbByteArray('Unused', 0),
wbByteArray('Unused', 0)
])
])
], [])
)
]);
wbRecord(AMDL, 'Aim Model', [
wbEDID,
wbStruct(DNAM, 'Data', [
wbFloat('Cone of Fire - Min Angle'),
wbFloat('Cone of Fire - Max Angle'),
wbFloat('Cone of Fire - Increase Per Shot'),
wbFloat('Cone of Fire - Decrease Per Sec'),
wbInteger('Cone of Fire - Decrease Delay MS', itU32),
wbFloat('Cone of Fire - Sneak Mult'),
wbFloat('Recoil - Diminish Spring Force'),
wbFloat('Recoil - Diminish Sights Mult'),
wbFloat('Recoil - Max Per Shot'),
wbFloat('Recoil - Min Per Shot'),
wbFloat('Recoil - Hip Mult'),
wbInteger('Runaway - Recoil Shots', itU32),
wbFloat('Recoil - Arc'),
wbFloat('Recoil - Arc Rotate'),
wbFloat('Cone of Fire - Iron Sights Mult'),
wbFloat('Stability - Base Stability')
])
]);
wbRecord(AORU, 'Attraction Rule', [
wbEDID,
wbStruct(AOR2, 'Data', [
wbFloat('Radius'),
wbFloat('Min Delay'),
wbFloat('Max Delay'),
wbInteger('Requires Line of Sight', itU8, wbBoolEnum),
wbInteger('Combat Target', itU8, wbBoolEnum),
wbByteArray('Unused', 2)
], cpNormal, True)
]);
wbRecord(BNDS, 'Bendable Spline', [
wbEDID,
wbOBND,
wbStruct(DNAM, 'Data', [
wbFloat('Default Number of Tiles'),
wbInteger('Default Number of Slices', itU16),
wbInteger('Default Number of Tiles - Relative to Length', itU16, wbBoolEnum),
wbFloatColors('Default Color'),
wbFloat('Wind Settings - Sensibility'),
wbFloat('Wind Settings - Flexibility')
]),
wbFormIDCk(TNAM, 'Texture', [TXST])
]);
wbRecord(CMPO, 'Component', [
wbEDID,
wbOBND,
wbFULL,
wbCUSD,
wbInteger(DATA, 'Auto Calc Value', itU32),
wbFormIDCk(MNAM, 'Scrap Item', [MISC]),
wbFormIDCk(GNAM, 'Mod Scrap Scalar', [GLOB])
]);
wbRecord(DFOB, 'Default Object', [
wbEDID,
wbFormID(DATA, 'Object')
]);
wbRecord(DMGT, 'Damage Type', [
wbEDID,
// Before form version 78, it was an array of AVIF index, since then array of AVIF formID, coupled with a SPEL formID
wbUnion(DNAM, 'Data', wbFormVer78Decider, [
wbArray('Damage Types', wbInteger('Actor Value Index', itU32)),
wbArray('Damage Types', wbStruct('Damage Type', [
wbFormIDck('Actor Value', [AVIF, NULL]),
wbFormIDck('Spell', [SPEL, NULL])
]))
])
]);
wbRecord(GDRY, 'God Rays', [
wbEDID,
wbStruct(DATA, 'Data', [
wbFloatColors('Back Color'),
wbFloatColors('Fwd Color'),
wbFloat('Intensity'),
wbFloat('Air Color - Scale'),
wbFloat('Back Color - Scale'),
wbFloat('Fwd Color - Scale'),
wbFloat('Back Phase'),
wbFloatColors('Air Color'),
wbFloat('Fwd Phase')
])
]);
end;
procedure DefineFO4r;
begin
wbRecord(INNR, 'Instance Naming Rules', [
wbEDID,
wbInteger(UNAM, 'Target', itU32, wbEnum([], [
0, 'None',
$1D, 'Armor',
$2D, 'Actor',
$2A, 'Furniture',
$2B, 'Weapon'
])),
wbRArray('Naming Rules',
wbRStruct('Ruleset', [
wbInteger(VNAM, 'Count', itU32),
// should not be sorted
wbRArray('Names',
wbRStruct('Name', [
wbLString(WNAM, 'Text', 0, cpTranslate),
wbKSIZ,
wbKWDAs,
wbStruct(XNAM, 'Property', [
wbFloat('Value'),
wbInteger('Target', itU8, wbEnum([
{ 0} 'Enchantments',
{ 1} 'BashImpactDataSet',
{ 2} 'BlockMaterial',
{ 3} 'Keywords',
{ 4} 'Weight',
{ 5} 'Value',
{ 6} 'Rating',
{ 7} 'AddonIndex',
{ 8} 'BodyPart',
{ 9} 'DamageTypeValues',
{10} 'ActorValues',
{11} 'Health',
{12} 'ColorRemappingIndex',
{13} 'MaterialSwaps'
])),
wbInteger('Op', itU8, wbEnum([
{0} '>=',
{1} '>',
{2} '<=',
{3} '<',
{4} '='
]))
]),
wbInteger(YNAM, 'Index', itU16)
], []),
cpNormal, False, nil, wbINNRAfterSet
)
], [])
)
]);
wbRecord(KSSM, 'Sound Keyword Mapping', [
wbEDID,
wbFormIDCk(DNAM, 'Primary Descriptor', [SNDR]),
wbFormIDCk(ENAM, 'Exterior Tail', [SNDR]),
wbFormIDCk(VNAM, 'VATS Descriptor', [SNDR]),
wbFloat(TNAM, 'VATS Threshold'),
wbRArray('Keywords', wbFormIDCk(KNAM, 'Keyword', [KYWD])),
wbRArrayS('Sounds', wbStructSK(RNAM, [0], 'Sound', [
wbInteger('Reverb Class', itU32, wbReverbClassEnum),
wbFormIDCk('Descriptor', [SNDR])
]))
]);
wbRecord(LAYR, 'Layer', [
wbEDID,
wbFormIDCk(PNAM, 'Parent', [LAYR])
]);
wbRecord(LENS, 'Lens Flare', [
wbEDID,
wbFloat(CNAM, 'Color Influence'),
wbFloat(DNAM, 'Fade Distance Radius Scale'),
wbInteger(LFSP, 'Count', itU32, nil, cpBenign),
wbRArrayS('Lens Flare Sprites',
wbRStructSK([0], 'Flare', [
wbString(DNAM, 'Lens Flare Sprite ID'),
wbString(FNAM, 'Texture'),
wbStruct(LFSD, 'Lens Flare Data', [
wbFloatColors('Tint'),
wbFloat('Width'),
wbFloat('Height'),
wbFloat('Position'),
wbFloat('Angular Fade'),
wbFloat('Opacity'),
wbInteger('Flags', itU32, wbFlags([
{0x01} 'Rotates',
{0x02} 'Shrinks When Occluded'
]))
])
], []),
cpNormal, False, nil, wbLENSAfterSet
)
]);
{wbRecord(LSPR, 'LSPR', [
wbEDID
]);
wbRecord(MICN, 'MICN', [
wbEDID
]);}
wbRecord(MSWP, 'Material Swap',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00010000} 16, 'Custom Swap'
])), [
wbEDID,
wbString(FNAM, 'Tree Folder'), {First FNAM}
wbRArrayS('Material Substitutions',
wbRStructSK([0], 'Substitution', [
wbString(BNAM, 'Original Material'),
wbString(SNAM, 'Replacement Material'),
wbString(FNAM, 'Tree Folder (obsolete)'), {Unused, will be moved up to First FNAM}
wbFloat(CNAM, 'Color Remapping Index')
], [])
)
]);
wbRecord(NOCM, 'Navigation Mesh Obstacle Manager', [
wbRArray('Unknown',
wbRStruct('Unknown', [
wbInteger(INDX, 'Index', itU32),
wbRArray('Unknown', wbUnknown(DATA)),
wbUnknown(INTV),
wbString(NAM1, 'Model')
], [])
)
]);
end;
procedure DefineFO4s;
begin
wbRecord(NOTE, 'Note', [
wbEDID,
wbVMAD,
wbOBND,
wbPTRN,
wbFULL,
wbMODL,
wbICON,
wbYNAM,
wbZNAM,
wbInteger(DNAM, 'Type', itU8, wbEnum([
'Sound',
'Voice',
'Program',
'Terminal'
]), cpNormal, True),
wbStruct(DATA, '', [ // was DNAM before form version 65. Now holds value and weight
wbInteger('Value', itU32),
wbFloat('Weight')
]),
wbUnion(SNAM, 'Data', wbNOTEDataDecider, [
wbByteArray('Unused', 4),
wbFormIDCk('Sound', [SNDR]),
wbFormIDCk('Scene', [SCEN]),
wbFormIDCk('Terminal', [TERM])
]),
wbString(PNAM, 'Program File')
]);
wbRecord(OMOD, 'Object Modification',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000008} 4, 'Legendary Mod',
{0x00000040} 7, 'Mod Collection'
])), [
wbEDID,
wbFULL,
wbDESC,
wbMODL,
wbStruct(DATA, 'Data', [
wbInteger('Include Count', itU32),
wbInteger('Property Count', itU32),
wbByteArray('Unused', 2, cpIgnore),
wbInteger('Form Type', itU32, wbEnum([], [
Sig2Int(ARMO), 'Armor',
Sig2Int(NPC_), 'Non-player character',
Sig2Int(WEAP), 'Weapon',
Sig2Int(NONE), 'None'
])),
wbByteArray('Unused', 2, cpIgnore),
wbFormIDCk('Attach Point', [KYWD, NULL]),
wbArray('Attach Parent Slots', wbFormIDCk('Keyword', [KYWD, NULL]), -1),
// no way to change these in CK, legacy data leftover?
wbArray('Items', wbStruct('Item', [
wbByteArray('Value 1', 4),
wbByteArray('Value 2', 4)
]), -1),
// should not be sorted
wbArray('Includes', wbStruct('Include', [
wbFormIDCk('Mod', [OMOD]),
wbInteger('Minimum Level', itU8),
wbInteger('Optional', itU8, wbBoolEnum),
wbInteger('Don''t Use All', itU8, wbBoolEnum)
]), wbOMODDataIncludeCounter, cpNormal, False, nil, wbOMODincludeAfterSet),
wbObjectModProperties
], cpNormal, False, nil, -1, nil, wbOMODdataAfterSet),
wbArray(MNAM, 'Target OMOD Keywords', wbFormIDCk('Keyword', [KYWD])),
wbArray(FNAM, 'Filter Keywords', wbFormIDCk('Keyword', [KYWD])),
wbFormIDCk(LNAM, 'Loose Mod', sigBaseObjects),
wbInteger(NAM1, 'Priority', itU8),
wbFLTR
]);
wbRecord(OVIS, 'Object Visibility Manager', [
wbRArray('Unknown',
wbRStruct('Unknown', [
wbFormIDCk(INDX, 'Object', [STAT]),
wbStruct(DATA, 'Object Bounds', [
wbFloat('X1'),
wbFloat('Y1'),
wbFloat('Z1'),
wbFloat('X2'),
wbFloat('Y2'),
wbFloat('Z2')
])
], [])
)
]);
wbRecord(PKIN, 'Pack-In',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000200} 9, 'Prefab'
])), [
wbEDID,
wbOBND,
wbFLTR,
wbFormIDCk(CNAM, 'Cell', [CELL]),
wbInteger(VNAM, 'Version', itU32)
]);
wbRecord(RFGP, 'Reference Group', [
wbEDID,
wbString(NNAM, 'Name'),
wbFormIDCk(RNAM, 'Reference', sigReferences),
wbUnknown(PNAM)
]);
{wbRecord(RGDL, 'RGDL', [
wbEDID
]);}
wbRecord(SCCO, 'Scene Collection', [
wbEDID,
wbFormIDCk(QNAM, 'Quest', [QUST]),
wbRArray('Scenes',
wbRStruct('Scene', [
wbFormIDCk(SNAM, 'Scene', [SCEN]),
wbStruct(XNAM, 'Unknown', [
wbInteger('Unknown', itS32),
wbInteger('Unknown', itS32)
])
], [])
),
wbUnknown(VNAM, cpNormal, True),
wbRArray('Unknown', wbStruct(XNAM, 'Unknown', [
wbInteger('Unknown', itS32),
wbInteger('Unknown', itS32)
])),
wbUnknown(VNAM, cpNormal, True)
]);
wbRecord(SCOL, 'Static Collection',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000004} 4, 'Non Occluder',
{0x00000200} 9, 'Hidden From Local Map',
{0x00000400} 10, 'Unknown 10',
{0x00000800} 11, 'Used as Platform',
{0x00008000} 15, 'Has Distant LOD',
{0x02000000} 25, 'Obstacle',
{0x04000000} 26, 'NavMesh Generation - Filter',
{0x08000000} 27, 'NavMesh Generation - Bounding Box',
{0x40000000} 30, 'NavMesh Generation - Ground'
])), [
wbEDID,
wbOBNDReq,
wbPTRN,
wbMODL,
wbFULL,
wbFLTR,
wbRStructsSK('Parts', 'Part', [0], [
wbFormIDCk(ONAM, 'Static', [ACTI, ALCH, AMMO, BOOK, CONT, DOOR, FURN, MISC, MSTT, STAT, TERM, WEAP]),
wbArrayS(DATA, 'Placements', wbStruct('Placement', [
wbStruct('Position', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
]),
wbStruct('Rotation', [
wbFloat('X', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Y', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize),
wbFloat('Z', cpNormal, True, wbRotationFactor, wbRotationScale, nil, RadiansNormalize)
]),
wbFloat('Scale')
]), 0, cpNormal, True)
], [], cpNormal, True)
]);
wbRecord(SCSN, 'Audio Category Snapshot', [
wbEDID,
wbInteger(PNAM, 'Priority', itU16),
wbRArray('Category Multipliers', wbStruct(CNAM, 'Category Multiplier', [
wbFormIDCk('Categoty', [SNCT]),
wbFloat('Multiplier')
]))
]);
end;
procedure DefineFO4t;
begin
{wbRecord(SKIL, 'SKIL', [
wbEDID
]);}
wbRecord(STAG, 'Animation Sound Tag Set', [
wbEDID,
wbRArray('Sounds', wbStruct(TNAM, 'Sound', [
wbFormIDCk('Sound', [SNDR, NULL]),
wbString('Action')
]))
]);
wbRecord(TERM, 'Terminal',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00000004} 4, 'Unknown 4',
{0x00002000} 13, 'Unknown 13',
{0x00008000} 15, 'Has Distant LOD',
{0x00010000} 16, 'Random Anim Start'
])), [
wbEDID,
wbVMADFragmentedPERK, // same fragments format as in PERK
wbOBNDReq,
wbPTRN,
wbLString(NAM0, 'Header Text'),
wbLString(WNAM, 'Welcome Text'),
wbFULL,
wbMODL,
wbKSIZ,
wbKWDAs,
wbPRPS,
wbUnknown(PNAM),
wbFormIDCk(SNAM, 'Looping Sound', [SNDR]),
wbUnknown(FNAM),
wbCOCT,
wbCNTOs,
wbMNAMFurnitureMarker,
wbByteArray(WBDT, 'Workbench Data (unused)', 0),
wbString(XMRK, 'Marker Model'),
wbSNAMMarkerParams,
wbInteger(BSIZ, 'Count', itU32, nil, cpBenign),
wbRArray('Body Text',
wbRStruct('Item', [
wbLString(BTXT, 'Text', 0, cpTranslate),
wbCTDAs
], []),
cpNormal, False, nil, wbTERMDisplayItemsAfterSet
),
wbInteger(ISIZ, 'Count', itU32, nil, cpBenign),
wbRArray('Menu Items',
wbRStruct('Menu Item', [
wbLString(ITXT, 'Item Text', 0, cpTranslate),
wbLString(RNAM, 'Response Text', 0, cpTranslate),
wbInteger(ANAM, 'Type', itU8, wbEnum([
{0} 'Unknown 0',
{1} 'Unknown 1',
{2} 'Unknown 2',
{3} 'Unknown 3',
{4} 'Submenu - Terminal',
{5} 'Submenu - Return to Top Level',
{6} 'Submenu - Force Redraw',
{7} 'Unknown 7',
{8} 'Display Text'
]), cpNormal, True),
wbInteger(ITID, 'Item ID', itU16),
wbLString(UNAM, 'Display Text', 0, cpTranslate),
wbString(VNAM, 'Show Image'),
wbFormIDCk(TNAM, 'Submenu', [TERM]),
wbCTDAs
], []),
cpNormal, False, nil, wbTERMMenuItemsAfterSet
)
]);
{wbRecord(TLOD, 'TLOD', [
wbEDID
]);
wbRecord(TOFT, 'TOFT', [
wbEDID
]);}
wbRecord(TRNS, 'Transform',
wbFlags(wbRecordFlagsFlags, wbFlagsList([
{0x00008000} 16, 'Around Origin'
])), [
wbEDID,
wbStruct(DATA, 'Data', [
wbPosRot,
wbFloat('Scale'),
wbFloat('Zoom Min'),
wbFloat('Zoom Max')
], cpNormal, True, nil, 2)
]);
wbRecord(ZOOM, 'Zoom', [
wbEDID,
wbStruct(GNAM, 'Data', [
wbFloat('FOV Mult'),
wbInteger('Overlay', itU32, wbEnum([
{ 0} 'Default',
{ 1} 'Fine',
{ 2} 'Duplex',
{ 3} 'German',
{ 4} 'Dot',
{ 5} 'Mil-Dot',
{ 6} 'Circle',
{ 7} 'Old Rangefind',
{ 8} 'Modern Rangefind',
{ 9} 'SVD',
{10} 'Hand Painted',
{11} 'Binoculars',
{12} 'Cross',
{13} 'Double Zero',
{14} 'Rangefinder 1',
{15} 'Rangefinder 2',
{16} 'Rectangle'
])),
wbFormIDCk('Imagespace Modifier', [IMAD, NULL]),
wbStruct('Camera Offset', [
wbFloat('X'),
wbFloat('Y'),
wbFloat('Z')
])
])
]);
end;
procedure DefineFO4u;
begin
wbAddGroupOrder(GMST);
wbAddGroupOrder(KYWD);
wbAddGroupOrder(LCRT);
wbAddGroupOrder(AACT);
wbAddGroupOrder(TRNS);
wbAddGroupOrder(CMPO);
wbAddGroupOrder(TXST);
//wbAddGroupOrder(MICN);
wbAddGroupOrder(GLOB);
wbAddGroupOrder(DMGT);
wbAddGroupOrder(CLAS);
wbAddGroupOrder(FACT);
wbAddGroupOrder(HDPT);
//wbAddGroupOrder(EYES);
wbAddGroupOrder(RACE);
wbAddGroupOrder(SOUN);
wbAddGroupOrder(ASPC);
//wbAddGroupOrder(SKIL);
wbAddGroupOrder(MGEF);
//wbAddGroupOrder(SCPT);{>>> Unused in Skyrim, but contained in Skyrim.esm <<<}
wbAddGroupOrder(LTEX);
wbAddGroupOrder(ENCH);
wbAddGroupOrder(SPEL);
//wbAddGroupOrder(SCRL);
wbAddGroupOrder(ACTI);
wbAddGroupOrder(TACT);
wbAddGroupOrder(ARMO);
wbAddGroupOrder(BOOK);
wbAddGroupOrder(CONT);
wbAddGroupOrder(DOOR);
wbAddGroupOrder(INGR);
wbAddGroupOrder(LIGH);
wbAddGroupOrder(MISC);
wbAddGroupOrder(STAT);
wbAddGroupOrder(SCOL);
wbAddGroupOrder(MSTT);
wbAddGroupOrder(GRAS);
wbAddGroupOrder(TREE);
wbAddGroupOrder(FLOR);
wbAddGroupOrder(FURN);
wbAddGroupOrder(WEAP);
wbAddGroupOrder(AMMO);
wbAddGroupOrder(NPC_);
wbAddGroupOrder(LVLN);
wbAddGroupOrder(KEYM);
wbAddGroupOrder(ALCH);
wbAddGroupOrder(IDLM);
wbAddGroupOrder(NOTE);
wbAddGroupOrder(PROJ);
wbAddGroupOrder(HAZD);
wbAddGroupOrder(BNDS);
//wbAddGroupOrder(SLGM);
wbAddGroupOrder(TERM);
wbAddGroupOrder(LVLI);
wbAddGroupOrder(WTHR);
wbAddGroupOrder(CLMT);
wbAddGroupOrder(SPGD);
wbAddGroupOrder(RFCT);
wbAddGroupOrder(REGN);
wbAddGroupOrder(NAVI);
wbAddGroupOrder(CELL);
//wbAddGroupOrder(REFR);
//wbAddGroupOrder(ACHR);
//wbAddGroupOrder(PMIS);
//wbAddGroupOrder(PARW);
//wbAddGroupOrder(PGRE);
//wbAddGroupOrder(PBEA);
//wbAddGroupOrder(PFLA);
//wbAddGroupOrder(PCON);
//wbAddGroupOrder(PBAR);
//wbAddGroupOrder(PHZD);
wbAddGroupOrder(WRLD);
//wbAddGroupOrder(LAND);
//wbAddGroupOrder(NAVM);
//wbAddGroupOrder(TLOD);
//wbAddGroupOrder(DIAL);
//wbAddGroupOrder(INFO);
wbAddGroupOrder(QUST);
wbAddGroupOrder(IDLE);
wbAddGroupOrder(PACK);
wbAddGroupOrder(CSTY);
wbAddGroupOrder(LSCR);
wbAddGroupOrder(LVSP);
wbAddGroupOrder(ANIO);
wbAddGroupOrder(WATR);
wbAddGroupOrder(EFSH);
//wbAddGroupOrder(TOFT);
wbAddGroupOrder(EXPL);
wbAddGroupOrder(DEBR);
wbAddGroupOrder(IMGS);
wbAddGroupOrder(IMAD);
wbAddGroupOrder(FLST);
wbAddGroupOrder(PERK);
wbAddGroupOrder(BPTD);
wbAddGroupOrder(ADDN);
wbAddGroupOrder(AVIF);
wbAddGroupOrder(CAMS);
wbAddGroupOrder(CPTH);
wbAddGroupOrder(VTYP);
wbAddGroupOrder(MATT);
wbAddGroupOrder(IPCT);
wbAddGroupOrder(IPDS);
wbAddGroupOrder(ARMA);
wbAddGroupOrder(ECZN);
wbAddGroupOrder(LCTN);
wbAddGroupOrder(MESG);
//wbAddGroupOrder(RGDL);{>>> Unused in Skyrim, but contained in Skyrim.esm <<<}
wbAddGroupOrder(DOBJ);
wbAddGroupOrder(DFOB);
wbAddGroupOrder(LGTM);
wbAddGroupOrder(MUSC);
wbAddGroupOrder(FSTP);
wbAddGroupOrder(FSTS);
wbAddGroupOrder(SMBN);
wbAddGroupOrder(SMQN);
wbAddGroupOrder(SMEN);
wbAddGroupOrder(DLBR);
wbAddGroupOrder(MUST);
wbAddGroupOrder(DLVW);
//wbAddGroupOrder(WOOP);
//wbAddGroupOrder(SHOU);
wbAddGroupOrder(EQUP);
wbAddGroupOrder(RELA);
wbAddGroupOrder(SCEN);
wbAddGroupOrder(ASTP);
wbAddGroupOrder(OTFT);
wbAddGroupOrder(ARTO);
wbAddGroupOrder(MATO);
wbAddGroupOrder(MOVT);
wbAddGroupOrder(SNDR);
wbAddGroupOrder(DUAL); // doesn't exist but can be created in CK
wbAddGroupOrder(SNCT);
wbAddGroupOrder(SOPM);
wbAddGroupOrder(COLL);
wbAddGroupOrder(CLFM);
wbAddGroupOrder(REVB);
wbAddGroupOrder(PKIN);
wbAddGroupOrder(RFGP);
wbAddGroupOrder(AMDL);
wbAddGroupOrder(LAYR);
wbAddGroupOrder(COBJ);
wbAddGroupOrder(OMOD);
wbAddGroupOrder(MSWP);
wbAddGroupOrder(ZOOM);
wbAddGroupOrder(INNR);
wbAddGroupOrder(KSSM);
wbAddGroupOrder(AECH);
wbAddGroupOrder(SCCO);
wbAddGroupOrder(AORU);
wbAddGroupOrder(SCSN);
wbAddGroupOrder(STAG);
wbAddGroupOrder(NOCM);
wbAddGroupOrder(LENS);
//wbAddGroupOrder(LSPR);
wbAddGroupOrder(GDRY);
wbAddGroupOrder(OVIS);
end;
procedure DefineFO4;
begin
DefineFO4a;
DefineFO4b;
DefineFO4c;
DefineFO4d;
DefineFO4e;
DefineFO4f;
DefineFO4g;
DefineFO4h;
DefineFO4i;
DefineFO4j;
DefineFO4k;
DefineFO4l;
DefineFO4m;
DefineFO4n;
DefineFO4o;
DefineFO4p;
DefineFO4q;
DefineFO4r;
DefineFO4s;
DefineFO4t;
DefineFO4u;
SetLength(wbOfficialDLC, 6);
wbOfficialDLC[0] := 'DLCRobot.esm';
wbOfficialDLC[1] := 'DLCWorkshop01.esm';
wbOfficialDLC[2] := 'DLCCoast.esm';
wbOfficialDLC[3] := 'DLCWorkshop02.esm';
wbOfficialDLC[4] := 'DLCWorkshop03.esm';
wbOfficialDLC[5] := 'DLCNukaWorld.esm';
end;
initialization
end.
================================================
FILE: lib/xedit/wbDefinitionsTES3.pas
================================================
{*******************************************************************************
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in
compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/
Software distributed under the License is distributed on an "AS IS"
basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
License for the specific language governing rights and limitations
under the License.
*******************************************************************************}
//------------------------------------------------------------------------------
// Placeholder for future expansion
//------------------------------------------------------------------------------
unit wbDefinitionsTES3;
interface
uses
wbInterface;
var
wbPKDTFlags: IwbFlagsDef;
wbServiceFlags: IwbFlagsDef;
wbAxisEnum: IwbEnumDef;
wbBlendModeEnum: IwbEnumDef;
wbBlendOpEnum: IwbEnumDef;
wbCrimeTypeEnum: IwbEnumDef;
wbFormTypeEnum: IwbEnumDef;
wbFunctionsEnum: IwbEnumDef;
wbMagicSchoolEnum: IwbEnumDef;
wbMusicEnum: IwbEnumDef;
wbOBMEResolutionInfo: IwbEnumDef;
wbPKDTType: IwbEnumDef;
wbQuadrantEnum: IwbEnumDef;
wbSexEnum: IwbEnumDef;
wbSkillEnum: IwbEnumDef;
wbSoulGemEnum: IwbEnumDef;
wbSpecializationEnum: IwbEnumDef;
wbZTestFuncEnum: IwbEnumDef;
procedure DefineTES3;
implementation
uses
Types,
Classes,
SysUtils,
Math,
Variants;
const
ACBS : TwbSignature = 'ACBS';
ACHR : TwbSignature = 'ACHR';
ACRE : TwbSignature = 'ACRE';
TRGT : TwbSignature = 'TRGT';
ACTI : TwbSignature = 'ACTI';
AIDT : TwbSignature = 'AIDT';
ALCH : TwbSignature = 'ALCH';
AMMO : TwbSignature = 'AMMO';
ANAM : TwbSignature = 'ANAM';
ANIO : TwbSignature = 'ANIO';
APPA : TwbSignature = 'APPA';
ARMO : TwbSignature = 'ARMO';
ATTR : TwbSignature = 'ATTR';
ATXT : TwbSignature = 'ATXT';
BMDT : TwbSignature = 'BMDT';
BNAM : TwbSignature = 'BNAM';
BOOK : TwbSignature = 'BOOK';
BSGN : TwbSignature = 'BSGN';
BTXT : TwbSignature = 'BTXT';
CELL : TwbSignature = 'CELL';
CLAS : TwbSignature = 'CLAS';
CLMT : TwbSignature = 'CLMT';
CLOT : TwbSignature = 'CLOT';
CNAM : TwbSignature = 'CNAM';
CNTO : TwbSignature = 'CNTO';
CONT : TwbSignature = 'CONT';
CREA : TwbSignature = 'CREA';
CSAD : TwbSignature = 'CSAD';
CSCR : TwbSignature = 'CSCR';
CSDC : TwbSignature = 'CSDC';
CSDI : TwbSignature = 'CSDI';
CSDT : TwbSignature = 'CSDT';
CSTD : TwbSignature = 'CSTD';
CSTY : TwbSignature = 'CSTY';
CTDA : TwbSignature = 'CTDA';
CTDT : TwbSignature = 'CTDT';
DATA : TwbSignature = 'DATA';
DATX : TwbSignature = 'DATX';
DELE : TwbSignature = 'DELE';
DESC : TwbSignature = 'DESC';
DIAL : TwbSignature = 'DIAL';
DNAM : TwbSignature = 'DNAM';
DOOR : TwbSignature = 'DOOR';
EDID : TwbSignature = 'EDID';
EDDX : TwbSignature = 'EDDX';
EFID : TwbSignature = 'EFID';
EFIT : TwbSignature = 'EFIT';
ACVA : TwbSignature = 'ACVA';
EFII : TwbSignature = 'EFII';
EFXX : TwbSignature = 'EFXX';
EFIX : TwbSignature = 'EFIX';
EFME : TwbSignature = 'EFME';
EFSH : TwbSignature = 'EFSH';
ENAM : TwbSignature = 'ENAM';
ENCH : TwbSignature = 'ENCH';
ENIT : TwbSignature = 'ENIT';
ESCE : TwbSignature = 'ESCE';
EYES : TwbSignature = 'EYES';
FACT : TwbSignature = 'FACT';
FGGA : TwbSignature = 'FGGA';
FGGS : TwbSignature = 'FGGS';
FGTS : TwbSignature = 'FGTS';
FLOR : TwbSignature = 'FLOR';
FLTV : TwbSignature = 'FLTV';
FNAM : TwbSignature = 'FNAM';
FULL : TwbSignature = 'FULL';
FURN : TwbSignature = 'FURN';
GLOB : TwbSignature = 'GLOB';
GMST : TwbSignature = 'GMST';
GNAM : TwbSignature = 'GNAM';
GRAS : TwbSignature = 'GRAS';
HAIR : TwbSignature = 'HAIR';
HCLR : TwbSignature = 'HCLR';
HEDR : TwbSignature = 'HEDR';
HNAM : TwbSignature = 'HNAM';
ICO2 : TwbSignature = 'ICO2';
ICON : TwbSignature = 'ICON';
IDLE : TwbSignature = 'IDLE';
NULL : TwbSignature = 'NULL';
INAM : TwbSignature = 'INAM';
INDX : TwbSignature = 'INDX';
INFO : TwbSignature = 'INFO';
INGR : TwbSignature = 'INGR';
JNAM : TwbSignature = 'JNAM';
KEYM : TwbSignature = 'KEYM';
KFFZ : TwbSignature = 'KFFZ';
LAND : TwbSignature = 'LAND';
LIGH : TwbSignature = 'LIGH';
LNAM : TwbSignature = 'LNAM';
LSCR : TwbSignature = 'LSCR';
LTEX : TwbSignature = 'LTEX';
LVLC : TwbSignature = 'LVLC';
LVLD : TwbSignature = 'LVLD';
LVLF : TwbSignature = 'LVLF';
LVLI : TwbSignature = 'LVLI';
LVLO : TwbSignature = 'LVLO';
LVSP : TwbSignature = 'LVSP';
MAST : TwbSignature = 'MAST';
MGEF : TwbSignature = 'MGEF';
MISC : TwbSignature = 'MISC';
MNAM : TwbSignature = 'MNAM';
MO2B : TwbSignature = 'MO2B';
MO2T : TwbSignature = 'MO2T';
MO3B : TwbSignature = 'MO3B';
MO3T : TwbSignature = 'MO3T';
MO4B : TwbSignature = 'MO4B';
MO4T : TwbSignature = 'MO4T';
MOD2 : TwbSignature = 'MOD2';
MOD3 : TwbSignature = 'MOD3';
MOD4 : TwbSignature = 'MOD4';
MODB : TwbSignature = 'MODB';
MODL : TwbSignature = 'MODL';
MODT : TwbSignature = 'MODT';
NAM0 : TwbSignature = 'NAM0';
NAM1 : TwbSignature = 'NAM1';
NAM2 : TwbSignature = 'NAM2';
NAM9 : TwbSignature = 'NAM9';
NAME : TwbSignature = 'NAME';
NIFT : TwbSignature = 'NIFT';
NIFZ : TwbSignature = 'NIFZ';
NPC_ : TwbSignature = 'NPC_';
OFST : TwbSignature = 'OFST';
OBME : TwbSignature = 'OBME';
ONAM : TwbSignature = 'ONAM';
PACK : TwbSignature = 'PACK';
PFIG : TwbSignature = 'PFIG';
PFPC : TwbSignature = 'PFPC';
PGAG : TwbSignature = 'PGAG';
PGRD : TwbSignature = 'PGRD';
PGRI : TwbSignature = 'PGRI';
PGRL : TwbSignature = 'PGRL';
PGRP : TwbSignature = 'PGRP';
PGRR : TwbSignature = 'PGRR';
PKDT : TwbSignature = 'PKDT';
PKID : TwbSignature = 'PKID';
PLDT : TwbSignature = 'PLDT';
PNAM : TwbSignature = 'PNAM';
PSDT : TwbSignature = 'PSDT';
PTDT : TwbSignature = 'PTDT';
QNAM : TwbSignature = 'QNAM';
QSDT : TwbSignature = 'QSDT';
QSTA : TwbSignature = 'QSTA';
QSTI : TwbSignature = 'QSTI';
QSTR : TwbSignature = 'QSTR';
TPIC : TwbSignature = 'TPIC';
QUST : TwbSignature = 'QUST';
RACE : TwbSignature = 'RACE';
RCLR : TwbSignature = 'RCLR';
RDAT : TwbSignature = 'RDAT';
RDGS : TwbSignature = 'RDGS';
RDMD : TwbSignature = 'RDMD';
RDMP : TwbSignature = 'RDMP';
RDOT : TwbSignature = 'RDOT';
RDSD : TwbSignature = 'RDSD';
RDWT : TwbSignature = 'RDWT';
REFR : TwbSignature = 'REFR';
PLYR : TwbSignature = 'PLYR';
REGN : TwbSignature = 'REGN';
RNAM : TwbSignature = 'RNAM';
ROAD : TwbSignature = 'ROAD';
RPLD : TwbSignature = 'RPLD';
RPLI : TwbSignature = 'RPLI';
SBSP : TwbSignature = 'SBSP';
SCDA : TwbSignature = 'SCDA';
SCHD : TwbSignature = 'SCHD';
SCHR : TwbSignature = 'SCHR';
SCIT : TwbSignature = 'SCIT';
SCPT : TwbSignature = 'SCPT';
SCRI : TwbSignature = 'SCRI';
SCRO : TwbSignature = 'SCRO';
SCRV : TwbSignature = 'SCRV';
SCTX : TwbSignature = 'SCTX';
SCVR : TwbSignature = 'SCVR';
SGST : TwbSignature = 'SGST';
SKIL : TwbSignature = 'SKIL';
SLCP : TwbSignature = 'SLCP';
SLGM : TwbSignature = 'SLGM';
SLSD : TwbSignature = 'SLSD';
SNAM : TwbSignature = 'SNAM';
SNDD : TwbSignature = 'SNDD';
SNDX : TwbSignature = 'SNDX';
SOUL : TwbSignature = 'SOUL';
SOUN : TwbSignature = 'SOUN';
SPEL : TwbSignature = 'SPEL';
SPIT : TwbSignature = 'SPIT';
SPLO : TwbSignature = 'SPLO';
STAT : TwbSignature = 'STAT';
TCLF : TwbSignature = 'TCLF';
TCLT : TwbSignature = 'TCLT';
TES3 : TwbSignature = 'TES3';
TNAM : TwbSignature = 'TNAM';
TRDT : TwbSignature = 'TRDT';
TREE : TwbSignature = 'TREE';
UNAM : TwbSignature = 'UNAM';
VCLR : TwbSignature = 'VCLR';
VHGT : TwbSignature = 'VHGT';
VNAM : TwbSignature = 'VNAM';
VNML : TwbSignature = 'VNML';
VTEX : TwbSignature = 'VTEX';
VTXT : TwbSignature = 'VTXT';
WATR : TwbSignature = 'WATR';
WEAP : TwbSignature = 'WEAP';
WLST : TwbSignature = 'WLST';
WNAM : TwbSignature = 'WNAM';
WRLD : TwbSignature = 'WRLD';
WTHR : TwbSignature = 'WTHR';
XACT : TwbSignature = 'XACT';
XCCM : TwbSignature = 'XCCM';
XCHG : TwbSignature = 'XCHG';
XCLC : TwbSignature = 'XCLC';
XCLL : TwbSignature = 'XCLL';
XCLR : TwbSignature = 'XCLR';
XCLW : TwbSignature = 'XCLW';
XCMT : TwbSignature = 'XCMT';
XCNT : TwbSignature = 'XCNT';
XCWT : TwbSignature = 'XCWT';
XESP : TwbSignature = 'XESP';
XGLB : TwbSignature = 'XGLB';
XHLT : TwbSignature = 'XHLT';
XHRS : TwbSignature = 'XHRS';
XLCM : TwbSignature = 'XLCM';
XLOC : TwbSignature = 'XLOC';
XLOD : TwbSignature = 'XLOD';
XMRC : TwbSignature = 'XMRC';
XMRK : TwbSignature = 'XMRK';
XNAM : TwbSignature = 'XNAM';
XOWN : TwbSignature = 'XOWN';
XPCI : TwbSignature = 'XPCI';
XRGD : TwbSignature = 'XRGD';
XRNK : TwbSignature = 'XRNK';
XRTM : TwbSignature = 'XRTM';
XSCL : TwbSignature = 'XSCL';
XSED : TwbSignature = 'XSED';
XSOL : TwbSignature = 'XSOL';
XTEL : TwbSignature = 'XTEL';
XTRG : TwbSignature = 'XTRG';
XXXX : TwbSignature = 'XXXX';
ZNAM : TwbSignature = 'ZNAM';
var
wbEDID: IwbSubRecordDef;
wbXOWN: IwbSubRecordDef;
wbXGLB: IwbSubRecordDef;
wbXRGD: IwbSubRecordDef;
wbSLSD: IwbSubRecordDef;
wbBodyDataIndex: IwbSubRecordDef;
wbSPLO: IwbSubRecordDef;
wbSPLOs: IwbSubRecordArrayDef;
wbCNTO: IwbSubRecordDef;
wbCNTOs: IwbSubRecordArrayDef;
wbCSDT: IwbSubRecordStructDef;
wbCSDTs: IwbSubRecordArrayDef;
wbFULL: IwbSubRecordDef;
wbFULLReq: IwbSubRecordDef;
wbXNAM: IwbSubRecordDef;
wbXNAMs: IwbSubRecordArrayDef;
wbDESC: IwbSubRecordDef;
wbXSCL: IwbSubRecordDef;
wbDATAPosRot : IwbSubRecordDef;
wbPosRot : IwbStructDef;
wbMODL: IwbSubRecordStructDef;
wbCTDA: IwbSubRecordUnionDef;
wbSCHR: IwbSubRecordUnionDef;
wbCTDAs: IwbSubRecordArrayDef;
wbSCROs: IwbSubRecordArrayDef;
wbPGRP: IwbSubRecordDef;
wbResultScript: IwbSubRecordStructDef;
// wbResultScriptOld: IwbSubRecordStructDef;
wbSCRI: IwbSubRecordDef;
wbFaceGen: IwbSubRecordStructDef;
wbENAM: IwbSubRecordDef;
wbFGGS: IwbSubRecordDef;
wbXLOD: IwbSubRecordDef;
wbXESP: IwbSubRecordDef;
wbICON: IwbSubRecordDef;
wbEFID: IwbSubRecordDef;
wbEFIDOBME: IwbSubRecordDef;
wbEFIT: IwbSubRecordDef;
wbEFITOBME: IwbSubRecordDef;
wbEFIX: IwbSubRecordDef;
wbSCIT: IwbSubRecordStructDef;
wbSCITOBME: IwbSubRecordStructDef;
wbEffects: IwbSubRecordUnionDef;
function wbClmtMoonsPhaseLength(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
PhaseLength : Byte;
Masser : Boolean;
Secunda : Boolean;
begin
Result := '';
if aType = ctToSortKey then begin
Result := IntToHex64(aInt, 2);
end else if aType = ctToStr then begin
PhaseLength := aInt mod 64;
Masser := (aInt and 64) <> 0;
Secunda := (aInt and 128) <> 0;
if Masser then
if Secunda then
Result := 'Masser, Secunda / '
else
Result := 'Masser / '
else
if Secunda then
Result := 'Secunda / '
else
Result := 'No Moon / ';
Result := Result + IntToStr(PhaseLength);
end;
end;
function wbClmtTime(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
if aType = ctToSortKey then
Result := IntToHex64(aInt, 4)
else if aType = ctToStr then
Result := TimeToStr( EncodeTime(aInt div 6, (aInt mod 6) * 10, 0, 0) );
end;
var
wbCtdaTypeFlags : IwbFlagsDef;
function wbCtdaType(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
s: string;
begin
Result := '';
case aType of
ctToStr: begin
case aInt and $F0 of
$00 : Result := 'Equal to';
$20 : Result := 'Not equal to';
$40 : Result := 'Greater than';
$60 : Result := 'Greater than or equal to';
$80 : Result := 'Less than';
$A0 : Result := 'Less than or equal to';
else
Result := ''
end;
if not Assigned(wbCtdaTypeFlags) then
wbCtdaTypeFlags := wbFlags([
{0x01} 'Or',
{0x02} 'Run on target',
{0x04} 'Use global'
]);
s := wbCtdaTypeFlags.ToString(aInt and $0F, aElement);
if s <> '' then
Result := Result + ' / ' + s;
end;
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
Exit;
end;
ctCheck: begin
case aInt and $F0 of
$00, $20, $40, $60, $80, $A0 : Result := '';
else
Result := ''
end;
if not Assigned(wbCtdaTypeFlags) then
wbCtdaTypeFlags := wbFlags([
{0x01} 'Or',
{0x02} 'Run on target',
{0x04} 'Use global'
]);
s := wbCtdaTypeFlags.Check(aInt and $0F, aElement);
if s <> '' then
Result := Result + ' / ' + s;
end;
end;
end;
function wbIdleAnam(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
case aType of
ctToStr: begin
case aInt and not $80 of
0: Result := 'Lower Body';
1: Result := 'Left Arm';
2: Result := 'Left Hand';
3: Result := 'Right Arm';
4: Result := 'Special Idle';
5: Result := 'Whole Body';
6: Result := 'Upper Body';
else
Result := '';
end;
if (aInt and $80) = 0 then
Result := Result + ', Must return a file';
end;
ctToSortKey: begin
Result := IntToHex64(aInt, 2);
end;
ctCheck: begin
case aInt and not $80 of
0..6: Result := '';
else
Result := '';
end;
end;
end;
end;
function wbScaledInt4ToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
const
PlusMinus : array[Boolean] of string = ('+', '-');
begin
Result := '';
case aType of
ctToStr, ctToEditValue: Result := FloatToStrF(aInt / 10000, ffFixed, 99, 4);
ctToSortKey: begin
Result := FloatToStrF(aInt / 10000, ffFixed, 99, 4);
if Length(Result) < 22 then
Result := StringOfChar('0', 22 - Length(Result)) + Result;
Result := PlusMinus[aInt < 0] + Result;
end;
ctCheck: Result := '';
end;
end;
function wbScaledInt4ToInt(const aString: string; const aElement: IwbElement): Int64;
var
f: Extended;
begin
f := StrToFloat(aString);
f := f * 10000;
Result := Round(f);
end;
function wbHideFFFF(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
if aType = ctToSortKey then
Result := IntToHex64(aInt, 4)
else if aType = ctToStr then
if aInt = $FFFF then
Result := 'None'
else
Result := IntToStr(aInt);
end;
function wbAtxtPosition(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
if aType = ctToSortKey then
Result := IntToHex64(aInt div 17, 2) + IntToHex64(aInt mod 17, 2)
else if aType = ctCheck then begin
if (aInt < 0) or (aInt > 288) then
Result := ''
else
Result := '';
end else if aType = ctToStr then
Result := IntToStr(aInt) + ' -> ' + IntToStr(aInt div 17) + ':' + IntToStr(aInt mod 17);
end;
function wbWthrDataClassification(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
case aType of
ctToStr: begin
case aInt and not 192 of
0: Result := 'None';
1: Result := 'Pleasant';
2: Result := 'Cloudy';
3: Result := 'Rainy';
4: Result := 'Snow';
else
Result := '';
end;
end;
ctToSortKey: begin
Result := IntToHex64(aInt, 2)
end;
ctCheck: begin
case aInt and not 192 of
0..4: Result := '';
else
Result := '';
end;
end;
end;
end;
function wbGLOBFNAM(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
begin
Result := '';
case aType of
ctToStr: begin
case aInt of
Ord('s'): Result := 'Short';
Ord('l'): Result := 'Long';
Ord('f'): Result := 'Float';
else
Result := '';
end;
end;
ctToSortKey: Result := Chr(aInt);
ctCheck: begin
case aInt of
Ord('s'), Ord('l'), Ord('f'): Result := '';
else
Result := '';
end;
end;
end;
end;
function wbPlacedAddInfo(const aMainRecord: IwbMainRecord): string;
var
Rec: IwbRecord;
Container: IwbContainer;
s: string;
begin
Result := '';
Rec := aMainRecord.RecordBySignature['NAME'];
if Assigned(Rec) then begin
s := Trim(Rec.Value);
if s <> '' then
Result := 'places ' + s;
end;
Container := aMainRecord.Container;
while Assigned(Container) and (Container.ElementType <> etGroupRecord) do
Container := Container.Container;
if Assigned(Container) then begin
s := Trim(Container.Name);
if s <> '' then begin
if Result <> '' then
Result := Result + ' ';
Result := Result + 'in ' + s;
end;
end;
end;
function wbCellAddInfo(const aMainRecord: IwbMainRecord): string;
var
Rec: IwbRecord;
Container: IwbContainer;
GroupRecord : IwbGroupRecord;
s: string;
begin
Result := '';
Rec := aMainRecord.RecordBySignature['XCLC'];
if Assigned(Rec) then
Result := 'at ' + Rec.Elements[0].Value + ',' + Rec.Elements[1].Value;
Container := aMainRecord.Container;
while Assigned(Container) and not
(Supports(Container, IwbGroupRecord, GroupRecord) and (GroupRecord.GroupType = 1)) do
Container := Container.Container;
if Assigned(Container) then begin
s := wbFormID.ToString(GroupRecord.GroupLabel, aMainRecord);
if s <> '' then begin
if Result <> '' then
s := s + ' ';
Result := 'in ' + s + Result;
end;
end;
end;
function wbGMSTUnionDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
rEDID: IwbRecord;
s: string;
begin
Result := 1;
rEDID := aElement.Container.RecordBySignature[EDID];
if Assigned(rEDID) then begin
s := rEDID.Value;
if Length(s) > 0 then
case s[1] of
's': Result := 0;
'f': Result := 2;
end;
end;
end;
function wbMISCActorValueDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
MainRecord : IwbMainRecord;
begin
Result := 0;
if not Assigned(aElement) then
Exit;
MainRecord := aElement.ContainingMainRecord;
if not Assigned(MainRecord) then
Exit;
if (MainRecord.Flags._Flags and $000000C0) = $000000C0 then
Result := 1;
end;
function wbXLOCFillerDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Container.DataSize = 16 then
Result := 1;
end;
function wbPACKPKDTDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
begin
Result := 1;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Container.DataSize = 4 then
Result := 0;
end;
function wbREFRXSEDDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Container.DataSize = 4 then
Result := 1;
end;
type
TCTDAFunctionParamType = (
ptNone,
ptInteger,
ptVariableName, //Integer
ptSex, //Enum: Male, Female
ptActorValue, //Enum: wbActorValue
ptCrimeType, //?? Enum
ptAxis, //?? Char
ptFormType, //?? Enum
ptQuestStage,
ptObjectReference, //REFR, ACHR, ACRE, PGRE
ptInventoryObject, //ARMO, BOOK, MISC, WEAP, AMMO, KEYM, ALCH, NOTE, ARMA
ptActor, //ACHR, ACRE
ptQuest, //QUST
ptFaction, //FACT
ptCell, //CELL
ptClass, //CLAS
ptRace, //RACE
ptActorBase, //NPC_, CREA
ptGlobal, //GLOB
ptWeather, //WTHR
ptPackage, //PACK
ptOwnerOpt, //FACT, NPC_
ptBirthsign, //BSGN
ptFurniture, //FURN
ptMagicItem, //SPEL
ptMagicEffect, //MGEF
ptWorldspace, //WRLD
ptReferencableObject
);
PCTDAFunction = ^TCTDAFunction;
TCTDAFunction = record
Index: Integer;
Name: string;
ParamType1: TCTDAFunctionParamType;
ParamType2: TCTDAFunctionParamType;
end;
const
wbCTDAFunctions : array[0..168] of TCTDAFunction = (
(Index: 1; Name: 'GetDistance'; ParamType1: ptObjectReference),
(Index: 5; Name: 'GetLocked'),
(Index: 6; Name: 'GetPos'; ParamType1: ptAxis),
(Index: 8; Name: 'GetAngle'; ParamType1: ptAxis),
(Index: 10; Name: 'GetStartingPos'; ParamType1: ptAxis),
(Index: 11; Name: 'GetStartingAngle'; ParamType1: ptAxis),
(Index: 12; Name: 'GetSecondsPassed'),
(Index: 14; Name: 'GetActorValue'; ParamType1: ptActorValue),
(Index: 18; Name: 'GetCurrentTime'),
(Index: 24; Name: 'GetScale'),
(Index: 27; Name: 'GetLineOfSight'; ParamType1: ptObjectReference),
(Index: 32; Name: 'GetInSameCell'; ParamType1: ptObjectReference),
(Index: 35; Name: 'GetDisabled'),
(Index: 36; Name: 'MenuMode'; ParamType1: ptInteger),
(Index: 39; Name: 'GetDisease'),
(Index: 40; Name: 'GetVampire'),
(Index: 41; Name: 'GetClothingValue'),
(Index: 42; Name: 'SameFaction'; ParamType1: ptActor),
(Index: 43; Name: 'SameRace'; ParamType1: ptActor),
(Index: 44; Name: 'SameSex'; ParamType1: ptActor),
(Index: 45; Name: 'GetDetected'; ParamType1: ptActor),
(Index: 46; Name: 'GetDead'),
(Index: 47; Name: 'GetItemCount'; ParamType1: ptInventoryObject),
(Index: 48; Name: 'GetGold'),
(Index: 49; Name: 'GetSleeping'),
(Index: 50; Name: 'GetTalkedToPC'),
(Index: 53; Name: 'GetScriptVariable'; ParamType1: ptObjectReference; ParamType2: ptVariableName),
(Index: 56; Name: 'GetQuestRunning'; ParamType1: ptQuest),
(Index: 58; Name: 'GetStage'; ParamType1: ptQuest),
(Index: 59; Name: 'GetStageDone'; ParamType1: ptQuest; ParamType2: ptQuestStage),
(Index: 60; Name: 'GetFactionRankDifference'; ParamType1: ptFaction; ParamType2: ptActor),
(Index: 61; Name: 'GetAlarmed'),
(Index: 62; Name: 'IsRaining'),
(Index: 63; Name: 'GetAttacked'),
(Index: 64; Name: 'GetIsCreature'),
(Index: 65; Name: 'GetLockLevel'),
(Index: 66; Name: 'GetShouldAttack'; ParamType1: ptActor),
(Index: 67; Name: 'GetInCell'; ParamType1: ptCell),
(Index: 68; Name: 'GetIsClass'; ParamType1: ptClass),
(Index: 69; Name: 'GetIsRace'; ParamType1: ptRace),
(Index: 70; Name: 'GetIsSex'; ParamType1: ptSex),
(Index: 71; Name: 'GetInFaction'; ParamType1: ptFaction),
(Index: 72; Name: 'GetIsID'; ParamType1: ptReferencableObject),
(Index: 73; Name: 'GetFactionRank'; ParamType1: ptFaction),
(Index: 74; Name: 'GetGlobalValue'; ParamType1: ptGlobal),
(Index: 75; Name: 'IsSnowing'),
(Index: 76; Name: 'GetDisposition'; ParamType1: ptActor),
(Index: 77; Name: 'GetRandomPercent'),
(Index: 79; Name: 'GetQuestVariable'; ParamType1: ptQuest; ParamType2: ptVariableName),
(Index: 80; Name: 'GetLevel'),
(Index: 81; Name: 'GetArmorRating'),
(Index: 84; Name: 'GetDeadCount'; ParamType1: ptActorBase),
(Index: 91; Name: 'GetIsAlerted'),
(Index: 98; Name: 'GetPlayerControlsDisabled'),
(Index: 99; Name: 'GetHeadingAngle'; ParamType1: ptObjectReference),
(Index: 101; Name: 'IsWeaponOut'),
(Index: 102; Name: 'IsTorchOut'),
(Index: 103; Name: 'IsShieldOut'),
(Index: 104; Name: 'IsYielding'),
(Index: 106; Name: 'IsFacingUp'),
(Index: 107; Name: 'GetKnockedState'),
(Index: 108; Name: 'GetWeaponAnimType'),
(Index: 109; Name: 'GetWeaponSkillType'),
(Index: 110; Name: 'GetCurrentAIPackage'),
(Index: 111; Name: 'IsWaiting'),
(Index: 112; Name: 'IsIdlePlaying'),
(Index: 116; Name: 'GetCrimeGold'),
(Index: 122; Name: 'GetCrime'; ParamType1: ptActor; ParamType2: ptCrimeType),
(Index: 125; Name: 'IsGuard'),
(Index: 127; Name: 'CanPayCrimeGold'),
(Index: 128; Name: 'GetFatiguePercentage'),
(Index: 129; Name: 'GetPCIsClass'; ParamType1: ptClass),
(Index: 130; Name: 'GetPCIsRace'; ParamType1: ptRace),
(Index: 131; Name: 'GetPCIsSex'; ParamType1: ptSex),
(Index: 132; Name: 'GetPCInFaction'; ParamType1: ptFaction),
(Index: 133; Name: 'SameFactionAsPC'),
(Index: 134; Name: 'SameRaceAsPC'),
(Index: 135; Name: 'SameSexAsPC'),
(Index: 136; Name: 'GetIsReference'; ParamType1: ptObjectReference),
(Index: 141; Name: 'IsTalking'),
(Index: 142; Name: 'GetWalkSpeed'),
(Index: 143; Name: 'GetCurrentAIProcedure'),
(Index: 144; Name: 'GetTrespassWarningLevel'),
(Index: 145; Name: 'IsTrespassing'),
(Index: 146; Name: 'IsInMyOwnedCell'),
(Index: 147; Name: 'GetWindSpeed'),
(Index: 148; Name: 'GetCurrentWeatherPercent'),
(Index: 149; Name: 'GetIsCurrentWeather'; ParamType1: ptWeather),
(Index: 150; Name: 'IsContinuingPackagePCNear'),
(Index: 153; Name: 'CanHaveFlames'),
(Index: 154; Name: 'HasFlames'),
(Index: 157; Name: 'GetOpenState'),
(Index: 159; Name: 'GetSitting'),
(Index: 160; Name: 'GetFurnitureMarkerID'),
(Index: 161; Name: 'GetIsCurrentPackage'; ParamType1: ptPackage),
(Index: 162; Name: 'IsCurrentFurnitureRef'; ParamType1: ptObjectReference),
(Index: 163; Name: 'IsCurrentFurnitureObj'; ParamType1: ptFurniture),
(Index: 170; Name: 'GetDayOfWeek'),
(Index: 171; Name: 'IsPlayerInJail'),
(Index: 172; Name: 'GetTalkedToPCParam'; ParamType1: ptActor),
(Index: 175; Name: 'IsPCSleeping'),
(Index: 176; Name: 'IsPCAMurderer'),
(Index: 180; Name: 'GetDetectionLevel'; ParamType1: ptActor),
(Index: 182; Name: 'GetEquipped'; ParamType1: ptInventoryObject),
(Index: 185; Name: 'IsSwimming'),
(Index: 190; Name: 'GetAmountSoldStolen'),
(Index: 193; Name: 'GetPCExpelled'; ParamType1: ptFaction),
(Index: 195; Name: 'GetPCFactionMurder'; ParamType1: ptFaction),
(Index: 197; Name: 'GetPCFactionSteal'; ParamType1: ptFaction),
(Index: 199; Name: 'GetPCFactionAttack'; ParamType1: ptFaction),
(Index: 201; Name: 'GetPCFactionSubmitAuthority'; ParamType1: ptFaction),
(Index: 203; Name: 'GetDestroyed'),
(Index: 214; Name: 'HasMagicEffect'; ParamType1: ptMagicEffect),
(Index: 215; Name: 'GetDoorDefaultOpen'),
(Index: 223; Name: 'IsSpellTarget'; ParamType1: ptMagicItem),
(Index: 224; Name: 'GetIsPlayerBirthsign'; ParamType1: ptBirthsign),
(Index: 225; Name: 'GetPersuasionNumber'),
(Index: 227; Name: 'HasVampireFed'),
(Index: 228; Name: 'GetIsClassDefault'; ParamType1: ptClass),
(Index: 229; Name: 'GetClassDefaultMatch'),
(Index: 230; Name: 'GetInCellParam'; ParamType1: ptCell; ParamType2: ptObjectReference),
(Index: 237; Name: 'GetIsGhost'),
(Index: 242; Name: 'GetUnconscious'),
(Index: 244; Name: 'GetRestrained'),
(Index: 246; Name: 'GetIsUsedItem'; ParamType1: ptReferencableObject),
(Index: 247; Name: 'GetIsUsedItemType'; ParamType1: ptFormType),
(Index: 249; Name: 'GetPCFame'),
(Index: 251; Name: 'GetPCInfamy'),
(Index: 254; Name: 'GetIsPlayableRace'),
(Index: 255; Name: 'GetOffersServicesNow'),
(Index: 258; Name: 'GetUsedItemLevel'),
(Index: 259; Name: 'GetUsedItemActivate'),
(Index: 264; Name: 'GetBarterGold'),
(Index: 265; Name: 'IsTimePassing'),
(Index: 266; Name: 'IsPleasant'),
(Index: 267; Name: 'IsCloudy'),
(Index: 274; Name: 'GetArmorRatingUpperBody'),
(Index: 277; Name: 'GetBaseActorValue'; ParamType1: ptActorValue),
(Index: 278; Name: 'IsOwner'; ParamType1: ptOwnerOpt),
(Index: 280; Name: 'IsCellOwner'; ParamType1: ptCell; ParamType2: ptOwnerOpt),
(Index: 282; Name: 'IsHorseStolen'),
(Index: 285; Name: 'IsLeftUp'),
(Index: 286; Name: 'IsSneaking'),
(Index: 287; Name: 'IsRunning'),
(Index: 288; Name: 'GetFriendHit'; ParamType1: ptActor),
(Index: 289; Name: 'IsInCombat'),
(Index: 300; Name: 'IsInInterior'),
(Index: 305; Name: 'GetInvestmentGold'),
(Index: 306; Name: 'IsActorUsingATorch'),
(Index: 309; Name: 'IsXBox'),
(Index: 310; Name: 'GetInWorldspace'; ParamType1: ptWorldSpace),
(Index: 312; Name: 'GetPCMiscStat'; ParamType1: ptInteger),
(Index: 313; Name: 'IsActorEvil'),
(Index: 314; Name: 'IsActorAVictim'),
(Index: 315; Name: 'GetTotalPersuasionNumber'),
(Index: 318; Name: 'GetIdleDoneOnce'),
(Index: 320; Name: 'GetNoRumors'),
(Index: 323; Name: 'WhichServiceMenu'),
(Index: 327; Name: 'IsRidingHorse'),
(Index: 329; Name: 'IsTurnArrest'),
(Index: 332; Name: 'IsInDangerousWater'),
(Index: 338; Name: 'GetIgnoreFriendlyHits'),
(Index: 339; Name: 'IsPlayersLastRiddenHorse'),
(Index: 353; Name: 'IsActor'),
(Index: 354; Name: 'IsEssential'),
(Index: 358; Name: 'IsPlayerMovingIntoNewSpace'),
(Index: 361; Name: 'GetTimeDead'),
(Index: 362; Name: 'GetPlayerHasLastRiddenHorse'),
(Index: 365; Name: 'GetPlayerInSEWorld')
);
var
wbCTDAFunctionEditInfo : string;
function wbCTDAParamDescFromIndex(aIndex: Integer): PCTDAFunction;
var
L, H, I, C: Integer;
begin
Result := nil;
L := Low(wbCTDAFunctions);
H := High(wbCTDAFunctions);
while L <= H do begin
I := (L + H) shr 1;
C := CmpW32(wbCTDAFunctions[I].Index, aIndex);
if C < 0 then
L := I + 1
else begin
H := I - 1;
if C = 0 then begin
L := I;
Result := @wbCTDAFunctions[L];
end;
end;
end;
end;
function wbCTDACompValueDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
if Integer(Container.ElementByName['Type'].NativeValue) and $04 <> 0 then
Result := 1;
end;
function wbEFITOBMEParamDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
ParamInfo: Variant;
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
ParamInfo := Container.ElementNativeValues['..\EFME\EFIT Param Info'];
if VarIsNull(ParamInfo) or VarIsEmpty(ParamInfo) then
else
Result := ParamInfo;
end;
function wbEFIXParamDecider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
ParamInfo: Variant;
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
ParamInfo := Container.ElementNativeValues['..\EFME\EFIX Param Info'];
if VarIsNull(ParamInfo) or VarIsEmpty(ParamInfo) then
else
Result := ParamInfo;
end;
function wbCTDAParam1Decider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Desc: PCTDAFunction;
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Desc := wbCTDAParamDescFromIndex(Container.ElementByName['Function'].NativeValue);
if Assigned(Desc) then
Result := Succ(Integer(Desc.ParamType1));
end;
function wbCTDAParam2Decider(aBasePtr: Pointer; aEndPtr: Pointer; const aElement: IwbElement): Integer;
var
Desc: PCTDAFunction;
Container: IwbContainer;
begin
Result := 0;
if not Assigned(aElement) then Exit;
Container := GetContainerFromUnion(aElement);
if not Assigned(Container) then Exit;
Desc := wbCTDAParamDescFromIndex(Container.ElementByName['Function'].NativeValue);
if Assigned(Desc) then
Result := Succ(Integer(Desc.ParamType2));
end;
{
function wbCTDAFunction(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Desc: PCTDAFunction;
begin
Result := '';
case aType of
ctToStr: begin
Desc := wbCTDAParamDescFromIndex(aInt);
if Assigned(Desc) then
Result := Desc.Name
else
Result := '';
end;
ctToSortKey: Result := IntToHex(aInt, 8);
ctCheck: begin
Desc := wbCTDAParamDescFromIndex(aInt);
if Assigned(Desc) then
Result := ''
else
Result := '';
end;
end;
end;
}
function wbCTDAFunctionToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Desc : PCTDAFunction;
i : Integer;
begin
Result := '';
case aType of
ctToStr, ctToEditValue: begin
Desc := wbCTDAParamDescFromIndex(aInt);
if Assigned(Desc) then
Result := Desc.Name
else if aType = ctToEditValue then
Result := IntToStr(aInt)
else
Result := '';
end;
ctToSortKey: Result := IntToHex(aInt, 8);
ctCheck: begin
Desc := wbCTDAParamDescFromIndex(aInt);
if Assigned(Desc) then
Result := ''
else
Result := '';
end;
ctEditType:
Result := 'ComboBox';
ctEditInfo: begin
Result := wbCTDAFunctionEditInfo;
if Result = '' then begin
with TStringList.Create do try
for i := Low(wbCTDAFunctions) to High(wbCTDAFunctions) do
Add(wbCTDAFunctions[i].Name);
Sort;
Result := CommaText;
finally
Free;
end;
wbCTDAFunctionEditInfo := Result;
end;
end;
end;
end;
function wbCTDAFunctionToInt(const aString: string; const aElement: IwbElement): Int64;
var
i: Integer;
begin
for i := Low(wbCTDAFunctions) to High(wbCTDAFunctions) do
with wbCTDAFunctions[i] do
if SameText(Name, aString) then begin
Result := Index;
Exit;
end;
Result := StrToInt64(aString);
end;
function wbCTDAParam2VariableNameToStr(aInt: Int64; const aElement: IwbElement; aType: TwbCallbackType): string;
var
Container : IwbContainerElementRef;
Param1 : IwbElement;
MainRecord : IwbMainRecord;
BaseRecord : IwbMainRecord;
ScriptRef : IwbElement;
Script : IwbMainRecord;
Variables : TStringList;
LocalVars : IwbContainerElementRef;
LocalVar : IwbContainerElementRef;
i, j : Integer;
s : string;
begin
case aType of
ctToStr: Result := IntToStr(aInt) + ' ';
ctToEditValue: Result := IntToStr(aInt);
ctToSortKey: begin
Result := IntToHex64(aInt, 8);
Exit;
end;
ctCheck: Result := '