aksdb/CentrED
1
0
Fork 0
Code Issues 2 Pull Requests Releases Wiki Activity

- Added hgeol

Browse Source 
- Fixed repository side eol to be LF
This commit is contained in:
Andreas Schneider 2010-07-25 00:18:54 +02:00
parent 0d84ac4b5d
commit 49599fdcf4
110 changed files with 40208 additions and 40202 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.hgeol Normal file
View File

@ -0,0 +1,6 @@
[patterns]
**.* = native
bin/nodraw.txt = CRLF
[repository]
native = LF

74
Client/Tools/UfrmConfirmation.lfm
View File

@ -1,37 +1,37 @@
object frmConfirmation: TfrmConfirmation
Left = 290
Height = 43
Top = 171
Width = 108
BorderIcons = []
BorderStyle = bsToolWindow
Caption = 'Apply?'
ClientHeight = 43
ClientWidth = 108
Font.Height = -11
LCLVersion = '0.9.25'
object btnYes: TButton
Left = 8
Height = 25
Top = 8
Width = 40
BorderSpacing.InnerBorder = 4
Caption = 'Yes'
Default = True
ModalResult = 6
ParentFont = True
TabOrder = 0
end
object btnNo: TButton
Left = 56
Height = 25
Top = 8
Width = 40
BorderSpacing.InnerBorder = 4
Cancel = True
Caption = 'No'
ModalResult = 7
ParentFont = True
TabOrder = 1
end
end
object frmConfirmation: TfrmConfirmation
Left = 290
Height = 43
Top = 171
Width = 108
BorderIcons = []
BorderStyle = bsToolWindow
Caption = 'Apply?'
ClientHeight = 43
ClientWidth = 108
Font.Height = -11
LCLVersion = '0.9.25'
object btnYes: TButton
Left = 8
Height = 25
Top = 8
Width = 40
BorderSpacing.InnerBorder = 4
Caption = 'Yes'
Default = True
ModalResult = 6
ParentFont = True
TabOrder = 0
end
object btnNo: TButton
Left = 56
Height = 25
Top = 8
Width = 40
BorderSpacing.InnerBorder = 4
Cancel = True
Caption = 'No'
ModalResult = 7
ParentFont = True
TabOrder = 1
end
end

114
Client/Tools/UfrmConfirmation.pas
View File

@ -1,57 +1,57 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UfrmConfirmation;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TfrmConfirmation }
TfrmConfirmation = class(TForm)
btnYes: TButton;
btnNo: TButton;
private
{ private declarations }
public
{ public declarations }
end;
var
frmConfirmation: TfrmConfirmation;
implementation
initialization
{$I UfrmConfirmation.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UfrmConfirmation;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TfrmConfirmation }
TfrmConfirmation = class(TForm)
btnYes: TButton;
btnNo: TButton;
private
{ private declarations }
public
{ public declarations }
end;
var
frmConfirmation: TfrmConfirmation;
implementation
initialization
{$I UfrmConfirmation.lrs}
end.

246
Client/Tools/UfrmDrawSettings.lfm
View File

@ -1,123 +1,123 @@
inherited frmDrawSettings: TfrmDrawSettings
Left = 268
Height = 180
Top = 165
Width = 242
ActiveControl = rbTileList
Caption = 'Draw settings'
ClientHeight = 180
ClientWidth = 242
OnCreate = FormCreate
object rbTileList: TRadioButton[0]
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Owner
Left = 8
Height = 22
Top = 8
Width = 146
BorderSpacing.Left = 8
BorderSpacing.Top = 8
BorderSpacing.Bottom = 4
Caption = 'Use tile from the list'
Checked = True
State = cbChecked
TabOrder = 0
end
object rbRandom: TRadioButton[1]
AnchorSideLeft.Control = rbTileList
AnchorSideTop.Control = rbTileList
AnchorSideTop.Side = asrBottom
Left = 8
Height = 22
Top = 34
Width = 213
BorderSpacing.Top = 4
Caption = 'Use tiles from the random pool'
TabOrder = 1
TabStop = False
end
object gbHue: TGroupBox[2]
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = seRandomHeight
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 8
Height = 49
Top = 132
Width = 226
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Around = 8
Caption = 'Hue (Statics only)'
ClientHeight = 45
ClientWidth = 222
TabOrder = 2
object pbHue: TPaintBox
Cursor = crHandPoint
Left = 4
Height = 41
Top = 0
Width = 214
Align = alClient
BorderSpacing.Left = 4
BorderSpacing.Right = 4
BorderSpacing.Bottom = 4
OnClick = pbHueClick
OnPaint = pbHuePaint
end
end
object cbRandomHeight: TCheckBox[3]
AnchorSideLeft.Control = cbForceAltitude
AnchorSideTop.Control = cbForceAltitude
AnchorSideTop.Side = asrBottom
Left = 8
Height = 22
Top = 102
Width = 149
BorderSpacing.Top = 12
Caption = 'Add Random Altitude'
TabOrder = 3
end
object seRandomHeight: TSpinEdit[4]
AnchorSideTop.Control = cbRandomHeight
AnchorSideTop.Side = asrCenter
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 184
Height = 21
Top = 103
Width = 50
Anchors = [akTop, akRight]
BorderSpacing.Right = 8
TabOrder = 4
end
object cbForceAltitude: TCheckBox[5]
AnchorSideLeft.Control = rbRandom
AnchorSideTop.Control = rbRandom
AnchorSideTop.Side = asrBottom
Left = 8
Height = 22
Top = 68
Width = 111
BorderSpacing.Top = 12
Caption = 'Force altitude:'
TabOrder = 5
end
object seForceAltitude: TSpinEdit[6]
AnchorSideTop.Control = cbForceAltitude
AnchorSideTop.Side = asrCenter
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 184
Height = 21
Top = 69
Width = 50
Anchors = [akTop, akRight]
BorderSpacing.Right = 8
MaxValue = 127
MinValue = -128
TabOrder = 6
end
inherited tmClose: TTimer[7]
end
end
inherited frmDrawSettings: TfrmDrawSettings
Left = 268
Height = 180
Top = 165
Width = 242
ActiveControl = rbTileList
Caption = 'Draw settings'
ClientHeight = 180
ClientWidth = 242
OnCreate = FormCreate
object rbTileList: TRadioButton[0]
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Owner
Left = 8
Height = 22
Top = 8
Width = 146
BorderSpacing.Left = 8
BorderSpacing.Top = 8
BorderSpacing.Bottom = 4
Caption = 'Use tile from the list'
Checked = True
State = cbChecked
TabOrder = 0
end
object rbRandom: TRadioButton[1]
AnchorSideLeft.Control = rbTileList
AnchorSideTop.Control = rbTileList
AnchorSideTop.Side = asrBottom
Left = 8
Height = 22
Top = 34
Width = 213
BorderSpacing.Top = 4
Caption = 'Use tiles from the random pool'
TabOrder = 1
TabStop = False
end
object gbHue: TGroupBox[2]
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = seRandomHeight
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 8
Height = 49
Top = 132
Width = 226
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Around = 8
Caption = 'Hue (Statics only)'
ClientHeight = 45
ClientWidth = 222
TabOrder = 2
object pbHue: TPaintBox
Cursor = crHandPoint
Left = 4
Height = 41
Top = 0
Width = 214
Align = alClient
BorderSpacing.Left = 4
BorderSpacing.Right = 4
BorderSpacing.Bottom = 4
OnClick = pbHueClick
OnPaint = pbHuePaint
end
end
object cbRandomHeight: TCheckBox[3]
AnchorSideLeft.Control = cbForceAltitude
AnchorSideTop.Control = cbForceAltitude
AnchorSideTop.Side = asrBottom
Left = 8
Height = 22
Top = 102
Width = 149
BorderSpacing.Top = 12
Caption = 'Add Random Altitude'
TabOrder = 3
end
object seRandomHeight: TSpinEdit[4]
AnchorSideTop.Control = cbRandomHeight
AnchorSideTop.Side = asrCenter
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 184
Height = 21
Top = 103
Width = 50
Anchors = [akTop, akRight]
BorderSpacing.Right = 8
TabOrder = 4
end
object cbForceAltitude: TCheckBox[5]
AnchorSideLeft.Control = rbRandom
AnchorSideTop.Control = rbRandom
AnchorSideTop.Side = asrBottom
Left = 8
Height = 22
Top = 68
Width = 111
BorderSpacing.Top = 12
Caption = 'Force altitude:'
TabOrder = 5
end
object seForceAltitude: TSpinEdit[6]
AnchorSideTop.Control = cbForceAltitude
AnchorSideTop.Side = asrCenter
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 184
Height = 21
Top = 69
Width = 50
Anchors = [akTop, akRight]
BorderSpacing.Right = 8
MaxValue = 127
MinValue = -128
TabOrder = 6
end
inherited tmClose: TTimer[7]
end
end

258
Client/Tools/UfrmDrawSettings.pas
View File

@ -1,129 +1,129 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UfrmDrawSettings;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
Spin, ExtCtrls, LMessages, UfrmToolWindow;
type
{ TfrmDrawSettings }
TfrmDrawSettings = class(TfrmToolWindow)
cbForceAltitude: TCheckBox;
cbRandomHeight: TCheckBox;
gbHue: TGroupBox;
pbHue: TPaintBox;
rbRandom: TRadioButton;
rbTileList: TRadioButton;
seForceAltitude: TSpinEdit;
seRandomHeight: TSpinEdit;
procedure FormCreate(Sender: TObject);
procedure pbHueClick(Sender: TObject);
procedure pbHuePaint(Sender: TObject);
procedure seForceAltitudeChange(Sender: TObject);
procedure seRandomHeightChange(Sender: TObject);
private
FCanClose: Boolean;
function CanClose: Boolean; override;
procedure OnHueClose(Sender: TObject; var ACloseAction: TCloseAction);
end;
var
frmDrawSettings: TfrmDrawSettings;
implementation
uses
UGameResources, UHue, UfrmHueSettings;
{ TfrmDrawSettings }
procedure TfrmDrawSettings.pbHueClick(Sender: TObject);
begin
frmHueSettings.Left := Mouse.CursorPos.x - 8;
frmHueSettings.Top := Mouse.CursorPos.y - 8;
frmHueSettings.OnClose := @OnHueClose;
frmHueSettings.Show;
FCanClose := False;
end;
procedure TfrmDrawSettings.FormCreate(Sender: TObject);
begin
FCanClose := True;
end;
procedure TfrmDrawSettings.pbHuePaint(Sender: TObject);
var
hue: THue;
begin
if frmHueSettings <> nil then
begin
if frmHueSettings.lbHue.ItemIndex > 0 then
hue := ResMan.Hue.Hues[frmHueSettings.lbHue.ItemIndex - 1]
else
hue := nil;
TfrmHueSettings.DrawHue(hue, pbHue.Canvas, pbHue.Canvas.ClipRect,
frmHueSettings.lbHue.Items.Strings[frmHueSettings.lbHue.ItemIndex]);
end;
end;
procedure TfrmDrawSettings.seForceAltitudeChange(Sender: TObject);
begin
cbForceAltitude.Checked := True;
end;
procedure TfrmDrawSettings.seRandomHeightChange(Sender: TObject);
begin
cbRandomHeight.Checked := True;
end;
function TfrmDrawSettings.CanClose: Boolean;
begin
Result := FCanClose and inherited CanClose;
end;
procedure TfrmDrawSettings.OnHueClose(Sender: TObject;
var ACloseAction: TCloseAction);
var
msg: TLMessage;
begin
FCanClose := True;
frmHueSettings.OnClose := nil;
pbHue.Repaint;
MouseLeave(msg);
end;
initialization
{$I UfrmDrawSettings.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UfrmDrawSettings;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
Spin, ExtCtrls, LMessages, UfrmToolWindow;
type
{ TfrmDrawSettings }
TfrmDrawSettings = class(TfrmToolWindow)
cbForceAltitude: TCheckBox;
cbRandomHeight: TCheckBox;
gbHue: TGroupBox;
pbHue: TPaintBox;
rbRandom: TRadioButton;
rbTileList: TRadioButton;
seForceAltitude: TSpinEdit;
seRandomHeight: TSpinEdit;
procedure FormCreate(Sender: TObject);
procedure pbHueClick(Sender: TObject);
procedure pbHuePaint(Sender: TObject);
procedure seForceAltitudeChange(Sender: TObject);
procedure seRandomHeightChange(Sender: TObject);
private
FCanClose: Boolean;
function CanClose: Boolean; override;
procedure OnHueClose(Sender: TObject; var ACloseAction: TCloseAction);
end;
var
frmDrawSettings: TfrmDrawSettings;
implementation
uses
UGameResources, UHue, UfrmHueSettings;
{ TfrmDrawSettings }
procedure TfrmDrawSettings.pbHueClick(Sender: TObject);
begin
frmHueSettings.Left := Mouse.CursorPos.x - 8;
frmHueSettings.Top := Mouse.CursorPos.y - 8;
frmHueSettings.OnClose := @OnHueClose;
frmHueSettings.Show;
FCanClose := False;
end;
procedure TfrmDrawSettings.FormCreate(Sender: TObject);
begin
FCanClose := True;
end;
procedure TfrmDrawSettings.pbHuePaint(Sender: TObject);
var
hue: THue;
begin
if frmHueSettings <> nil then
begin
if frmHueSettings.lbHue.ItemIndex > 0 then
hue := ResMan.Hue.Hues[frmHueSettings.lbHue.ItemIndex - 1]
else
hue := nil;
TfrmHueSettings.DrawHue(hue, pbHue.Canvas, pbHue.Canvas.ClipRect,
frmHueSettings.lbHue.Items.Strings[frmHueSettings.lbHue.ItemIndex]);
end;
end;
procedure TfrmDrawSettings.seForceAltitudeChange(Sender: TObject);
begin
cbForceAltitude.Checked := True;
end;
procedure TfrmDrawSettings.seRandomHeightChange(Sender: TObject);
begin
cbRandomHeight.Checked := True;
end;
function TfrmDrawSettings.CanClose: Boolean;
begin
Result := FCanClose and inherited CanClose;
end;
procedure TfrmDrawSettings.OnHueClose(Sender: TObject;
var ACloseAction: TCloseAction);
var
msg: TLMessage;
begin
FCanClose := True;
frmHueSettings.OnClose := nil;
pbHue.Repaint;
MouseLeave(msg);
end;
initialization
{$I UfrmDrawSettings.lrs}
end.

634
Client/Tools/UfrmFilter.lfm
View File

@ -1,317 +1,317 @@
object frmFilter: TfrmFilter
Left = 290
Height = 492
Top = 171
Width = 232
ActiveControl = rgFilterType.RadioButton0
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsToolWindow
Caption = 'Filter'
ClientHeight = 492
ClientWidth = 232
Font.Height = -11
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
LCLVersion = '0.9.29'
object rgFilterType: TRadioGroup
Left = 4
Height = 40
Top = 4
Width = 224
Align = alTop
AutoFill = True
BorderSpacing.Around = 4
Caption = 'Filter rule'
ChildSizing.LeftRightSpacing = 6
ChildSizing.TopBottomSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 2
ClientHeight = 26
ClientWidth = 222
Columns = 2
ItemIndex = 0
Items.Strings = (
'Exclusive'
'Inclusive'
)
OnClick = rgFilterTypeClick
TabOrder = 0
end
object GroupBox1: TGroupBox
Left = 4
Height = 259
Top = 48
Width = 224
Align = alClient
BorderSpacing.Around = 4
Caption = 'Tile filter'
ClientHeight = 245
ClientWidth = 222
TabOrder = 1
object Label1: TLabel
AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = cbTileFilter
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrBottom
Left = 4
Height = 30
Top = 30
Width = 214
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Around = 4
Caption = 'Drag and Drop static tiles from the tile list on this list to add them to the filter.'
ParentColor = False
WordWrap = True
end
object btnClear: TSpeedButton
AnchorSideLeft.Control = btnDelete
AnchorSideLeft.Side = asrBottom
AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrCenter
AnchorSideBottom.Control = btnDelete
AnchorSideBottom.Side = asrBottom
Left = 30
Height = 22
Hint = 'Clear'
Top = 219
Width = 22
Anchors = [akLeft, akBottom]
Color = clBtnFace
Glyph.Data = {
36040000424D3604000000000000360000002800000010000000100000000100
20000000000000040000640000006400000000000000000000003ADCFE004800
3A00FEFF4800FCFF1C00FCFF1C0080FF9C00003BD700AF9AFF00002CC600FDEB
9B000000000000000000000000000000000000000000000000000EECFF00B2FC
FF000046C00078D0FF000000F1FF0000F1FF0000F1FF0000F1FF0000EFFF0000
EFFF0000EDFF0000EDFFCBF3FC008905000024AEEF00E4A81C000000DB00B29E
FF0088000D000000F5FF1A20F5FF3C4CF9FF3A49F8FF3847F8FF3545F8FF3443
F7FF3242F7FF141BF1FF0000EDFFFCFF1C00FCFF1C0080FF9C0004000000FFBC
00000000F7FF1D23F9FF4453FAFF2429F9FF1212F7FF0F0FF6FF0C0CF5FF0909
F5FF161BF5FF3343F7FF141BF1FF0000EDFFE4FF5C000050FF004C0000000000
F9FF1F25FAFF4A58FBFF4247FBFFC9C9FDFF3B3BF9FF1313F7FF1010F6FF3333
F7FFC5C5FDFF3035F7FF3444F7FF141BF2FF0000EDFF000008000052FF000000
FBFF4F5DFDFF3237FBFFCBCBFEFFF2F2FFFFEBEBFEFF3B3BF9FF3939F8FFEAEA
FEFFF1F1FEFFC5C5FDFF181DF6FF3343F7FF0000EFFF0000CC0088005B000000
FDFF525FFDFF2828FCFF4747FCFFECECFFFFF2F2FFFFECECFFFFECECFEFFF1F1
FFFFEAEAFEFF3434F7FF0B0BF5FF3545F8FF0000EFFF00B8FF00E3FFA8000000
FDFF5562FEFF2C2CFDFF2929FCFF4848FCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
FEFF3A3AF9FF1212F7FF0F0FF6FF3848F8FF0000F1FF08009000FCFF72000000
FDFF5764FEFF3030FDFF2D2DFDFF4B4BFCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
FFFF3D3DF9FF1616F8FF1313F7FF3C4BF8FF0000F1FF02000000E4FF5C000000
FFFF5A67FEFF3333FEFF5050FDFFEDEDFFFFF3F3FFFFEDEDFFFFEDEDFFFFF2F2
FFFFECECFEFF3E3EFAFF1717F8FF3F4EF9FF0000F1FFFCFF1C00000000000000
FFFF5B68FFFF4347FEFFCFCFFFFFF3F3FFFFEDEDFFFF4C4CFCFF4A4AFCFFECEC
FFFFF2F2FFFFCACAFEFF2A2FFAFF4251FAFF0000F3FF00000000CCFF4C000000
FFFF262BFFFF5D6AFFFF585BFFFFCFCFFFFF5252FEFF2F2FFDFF2C2CFDFF4B4B
FCFFCCCCFEFF484CFBFF4957FBFF1D23F9FF0000F5FF00000000000000000000
00000000FFFF262BFFFF5D6AFFFF4347FFFF3434FEFF3232FEFF3030FDFF2D2D
FDFF383CFCFF4F5DFCFF1F25FAFF0000F7FF0000000000000000000000000000
0000000000000000FFFF262BFFFF5C69FFFF5B68FFFF5A67FEFF5865FEFF5663
FEFF5461FEFF2227FCFF0000FBFFFCFF1C00000000000000000008000000EFEF
EF00EFEFEF00EFEFEF000000FFFF0000FFFF0000FFFF0000FFFF0000FDFF0000
FDFF0000FDFF0000FDFF000000000000000000000000000000009034DE009034
DE00D86FDF00D86FDF00E0A223004AC6080000000000580000005870DF000C70
DF000000000000000000000000002070DF000000000000000000
}
NumGlyphs = 0
OnClick = btnClearClick
ShowHint = True
ParentShowHint = False
end
object btnDelete: TSpeedButton
AnchorSideLeft.Control = GroupBox1
AnchorSideBottom.Control = GroupBox1
AnchorSideBottom.Side = asrBottom
Left = 4
Height = 22
Hint = 'Delete'
Top = 219
Width = 22
Anchors = [akLeft, akBottom]
BorderSpacing.Around = 4
Color = clBtnFace
Glyph.Data = {
36040000424D3604000000000000360000002800000010000000100000000100
20000000000000040000640000006400000000000000000000004F91AB005588
9C0043718A004E6974003E4B4C00457796003E6A950037556C005C7E8800548B
A00031464100FFFFFF002B3238002D3B430074B9C8007FC4D5004788A7004A92
B500435E6F002E3040002E3538003D5E7B003853BEFF3551BDFF304BBCFF2E4E
B8FF303B3600FFFFFF00313637002C2D2B00588997007BC3D400365F8400396E
9A003B6282003A5564004255C6FF3C52CCFF757AE8FF8F92EEFF8F92EEFF7178
E4FF334DC1FF2B4AB7FFFFFFFF0036423900486B710061B4CE00396F9600375C
83004085B1004959CBFF5C65E0FFA1A6F5FF7E86EFFF5B63E9FF595DE7FF7D84
EEFF9EA0F4FF515DD7FF2B4AB7FFFFFFFF00354C4C004D94AF00375D7F003348
5C005361CFFF616BE3FFA1ACF5FF545FECFF505CEAFF4D59E9FF4E59E6FF4C56
E6FF5056E6FF9EA2F4FF5460D6FF2A4AB8FFFFFFFF004A90A6003B5864003D5B
6A004B56DBFFA2ABF6FF5664F0FF5266EEFF4D59E9FF4D59E9FF4D59E9FF4D59
E9FF4C58E6FF525AE6FF9FA3F5FF3450C4FF57929C00498BA40047676D005C62
D7FF818CEEFF7E91F7FF5D73F3FF4D59E9FF4D59E9FF4D59E9FF4D59E9FF4D59
E9FF4D59E9FF4F5BE9FF7B83F0FF757BE2FF2E4BBAFF54839500FFFFFF005F63
DAFFA1ABF7FF7086F8FF6882F6FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFF4D59E9FF5C66EAFF969CF1FF3250BCFF6FA2AF00000000006469
DBFFAFB9F9FF7F93FAFF7085F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFF4D59E9FF5E6AEEFF969DF1FF364FBEFF58B2E00000000000676A
DEFFA5AFF5FF9DABFAFF778CF0FF545FECFF545FECFF545FECFF545FECFF545F
ECFF545FECFF6377F2FF818EF4FF787FE9FF3A53C0FF000000000800000000E8
1D007D83EAFFCDD4FCFF8B9DFAFF7E93F7FF758AEEFF6C84F6FF6C84F6FF6C84
F6FF6C84F6FF6379F3FFA4AFF8FF3E4FD0FF000000000000000001000100DB12
C0006A69E0FFA3A7F3FFD4DBFDFF879AFAFF7F91F0FF7A8EF1FF7F94F8FF7E92
F9FF768CF8FFA8B6F8FF636EE3FF4557C7FF00000000000000002401AD00BA02
AE002301AE006A69E0FFAAADF2FFD8DCFDFFAEBAFAFF91A3FAFF8B9DFAFF9CA9
FBFFBAC7FCFF707BE9FF4C5BCCFFBB02F00000010000D8000000000000000000
000008000000010008006A6ADFFF8E93EDFFBEC3F8FFCCD3F9FFC4CBF9FFAAB4
F4FF6670E2FF535ED1FF5031DE005031DE002501AC00B902AD000D040400F804
0500F20005000A0106000C040500F8040600686ADDFF6364DCFF6164DAFF5D63
D9FFF2000700F804610000000000710900005031DE005031DE004034DE004034
DE0068B0E00068B0E0000E049300F8049500F2009500070102000F049500F804
0200F2000200080104000E040200F8040400F200040009010500
}
NumGlyphs = 0
OnClick = btnDeleteClick
ShowHint = True
ParentShowHint = False
end
object vdtFilter: TVirtualDrawTree
Tag = 1
AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = Label1
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = btnDelete
Cursor = 63
Left = 4
Height = 151
Top = 64
Width = 214
Anchors = [akTop, akLeft, akRight, akBottom]
BorderSpacing.Around = 4
DefaultNodeHeight = 44
DragType = dtVCL
Header.AutoSizeIndex = 0
Header.Columns = <
item
Position = 0
Text = 'ID'
end
item
Position = 1
Text = 'Tile'
Width = 44
end
item
Position = 2
Text = 'Name'
Width = 100
end>
Header.DefaultHeight = 17
Header.Options = [hoColumnResize, hoDrag, hoVisible]
Header.ParentFont = True
Header.Style = hsFlatButtons
TabOrder = 0
TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]
OnDragOver = vdtFilterDragOver
OnDragDrop = vdtFilterDragDrop
OnDrawNode = vdtFilterDrawNode
end
object cbTileFilter: TCheckBox
AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = GroupBox1
Left = 4
Height = 22
Top = 4
Width = 85
BorderSpacing.Around = 4
Caption = 'Filter active'
OnChange = cbTileFilterChange
TabOrder = 1
end
end
object GroupBox2: TGroupBox
Left = 4
Height = 168
Top = 320
Width = 224
Align = alBottom
BorderSpacing.Around = 4
Caption = 'Hue filter'
ClientHeight = 154
ClientWidth = 222
TabOrder = 2
object cbHueFilter: TCheckBox
Left = 4
Height = 22
Top = 4
Width = 214
Align = alTop
BorderSpacing.Around = 4
Caption = 'Filter active'
OnChange = cbHueFilterChange
TabOrder = 0
end
object vdtHues: TVirtualDrawTree
Cursor = 63
Left = 4
Height = 120
Top = 30
Width = 214
Align = alClient
BorderSpacing.Around = 4
Header.AutoSizeIndex = 2
Header.Columns = <
item
Position = 0
Width = 20
end
item
Position = 1
Text = 'Hue'
Width = 38
end
item
Position = 2
Text = 'Name'
Width = 154
end>
Header.DefaultHeight = 17
Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoVisible]
Header.ParentFont = True
Header.Style = hsFlatButtons
PopupMenu = pmHues
TabOrder = 1
TreeOptions.MiscOptions = [toCheckSupport, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]
TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toFullRowSelect]
OnChecked = vdtHuesChecked
OnDrawNode = vdtHuesDrawNode
end
end
object Splitter1: TSplitter
Cursor = crVSplit
Left = 0
Height = 5
Top = 311
Width = 232
Align = alBottom
ResizeAnchor = akBottom
end
object pmHues: TPopupMenu
left = 148
top = 404
object mnuCheckHues: TMenuItem
Caption = 'Check all hues'
OnClick = mnuCheckHuesClick
end
object mnuUncheckHues: TMenuItem
Caption = 'Uncheck all hues'
OnClick = mnuUncheckHuesClick
end
end
end
object frmFilter: TfrmFilter
Left = 290
Height = 492
Top = 171
Width = 232
ActiveControl = rgFilterType.RadioButton0
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsToolWindow
Caption = 'Filter'
ClientHeight = 492
ClientWidth = 232
Font.Height = -11
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
LCLVersion = '0.9.29'
object rgFilterType: TRadioGroup
Left = 4
Height = 40
Top = 4
Width = 224
Align = alTop
AutoFill = True
BorderSpacing.Around = 4
Caption = 'Filter rule'
ChildSizing.LeftRightSpacing = 6
ChildSizing.TopBottomSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 2
ClientHeight = 26
ClientWidth = 222
Columns = 2
ItemIndex = 0
Items.Strings = (
'Exclusive'
'Inclusive'
)
OnClick = rgFilterTypeClick
TabOrder = 0
end
object GroupBox1: TGroupBox
Left = 4
Height = 259
Top = 48
Width = 224
Align = alClient
BorderSpacing.Around = 4
Caption = 'Tile filter'
ClientHeight = 245
ClientWidth = 222
TabOrder = 1
object Label1: TLabel
AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = cbTileFilter
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrBottom
Left = 4
Height = 30
Top = 30
Width = 214
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Around = 4
Caption = 'Drag and Drop static tiles from the tile list on this list to add them to the filter.'
ParentColor = False
WordWrap = True
end
object btnClear: TSpeedButton
AnchorSideLeft.Control = btnDelete
AnchorSideLeft.Side = asrBottom
AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrCenter
AnchorSideBottom.Control = btnDelete
AnchorSideBottom.Side = asrBottom
Left = 30
Height = 22
Hint = 'Clear'
Top = 219
Width = 22
Anchors = [akLeft, akBottom]
Color = clBtnFace
Glyph.Data = {
36040000424D3604000000000000360000002800000010000000100000000100
20000000000000040000640000006400000000000000000000003ADCFE004800
3A00FEFF4800FCFF1C00FCFF1C0080FF9C00003BD700AF9AFF00002CC600FDEB
9B000000000000000000000000000000000000000000000000000EECFF00B2FC
FF000046C00078D0FF000000F1FF0000F1FF0000F1FF0000F1FF0000EFFF0000
EFFF0000EDFF0000EDFFCBF3FC008905000024AEEF00E4A81C000000DB00B29E
FF0088000D000000F5FF1A20F5FF3C4CF9FF3A49F8FF3847F8FF3545F8FF3443
F7FF3242F7FF141BF1FF0000EDFFFCFF1C00FCFF1C0080FF9C0004000000FFBC
00000000F7FF1D23F9FF4453FAFF2429F9FF1212F7FF0F0FF6FF0C0CF5FF0909
F5FF161BF5FF3343F7FF141BF1FF0000EDFFE4FF5C000050FF004C0000000000
F9FF1F25FAFF4A58FBFF4247FBFFC9C9FDFF3B3BF9FF1313F7FF1010F6FF3333
F7FFC5C5FDFF3035F7FF3444F7FF141BF2FF0000EDFF000008000052FF000000
FBFF4F5DFDFF3237FBFFCBCBFEFFF2F2FFFFEBEBFEFF3B3BF9FF3939F8FFEAEA
FEFFF1F1FEFFC5C5FDFF181DF6FF3343F7FF0000EFFF0000CC0088005B000000
FDFF525FFDFF2828FCFF4747FCFFECECFFFFF2F2FFFFECECFFFFECECFEFFF1F1
FFFFEAEAFEFF3434F7FF0B0BF5FF3545F8FF0000EFFF00B8FF00E3FFA8000000
FDFF5562FEFF2C2CFDFF2929FCFF4848FCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
FEFF3A3AF9FF1212F7FF0F0FF6FF3848F8FF0000F1FF08009000FCFF72000000
FDFF5764FEFF3030FDFF2D2DFDFF4B4BFCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
FFFF3D3DF9FF1616F8FF1313F7FF3C4BF8FF0000F1FF02000000E4FF5C000000
FFFF5A67FEFF3333FEFF5050FDFFEDEDFFFFF3F3FFFFEDEDFFFFEDEDFFFFF2F2
FFFFECECFEFF3E3EFAFF1717F8FF3F4EF9FF0000F1FFFCFF1C00000000000000
FFFF5B68FFFF4347FEFFCFCFFFFFF3F3FFFFEDEDFFFF4C4CFCFF4A4AFCFFECEC
FFFFF2F2FFFFCACAFEFF2A2FFAFF4251FAFF0000F3FF00000000CCFF4C000000
FFFF262BFFFF5D6AFFFF585BFFFFCFCFFFFF5252FEFF2F2FFDFF2C2CFDFF4B4B
FCFFCCCCFEFF484CFBFF4957FBFF1D23F9FF0000F5FF00000000000000000000
00000000FFFF262BFFFF5D6AFFFF4347FFFF3434FEFF3232FEFF3030FDFF2D2D
FDFF383CFCFF4F5DFCFF1F25FAFF0000F7FF0000000000000000000000000000
0000000000000000FFFF262BFFFF5C69FFFF5B68FFFF5A67FEFF5865FEFF5663
FEFF5461FEFF2227FCFF0000FBFFFCFF1C00000000000000000008000000EFEF
EF00EFEFEF00EFEFEF000000FFFF0000FFFF0000FFFF0000FFFF0000FDFF0000
FDFF0000FDFF0000FDFF000000000000000000000000000000009034DE009034
DE00D86FDF00D86FDF00E0A223004AC6080000000000580000005870DF000C70
DF000000000000000000000000002070DF000000000000000000
}
NumGlyphs = 0
OnClick = btnClearClick
ShowHint = True
ParentShowHint = False
end
object btnDelete: TSpeedButton
AnchorSideLeft.Control = GroupBox1
AnchorSideBottom.Control = GroupBox1
AnchorSideBottom.Side = asrBottom
Left = 4
Height = 22
Hint = 'Delete'
Top = 219
Width = 22
Anchors = [akLeft, akBottom]
BorderSpacing.Around = 4
Color = clBtnFace
Glyph.Data = {
36040000424D3604000000000000360000002800000010000000100000000100
20000000000000040000640000006400000000000000000000004F91AB005588
9C0043718A004E6974003E4B4C00457796003E6A950037556C005C7E8800548B
A00031464100FFFFFF002B3238002D3B430074B9C8007FC4D5004788A7004A92
B500435E6F002E3040002E3538003D5E7B003853BEFF3551BDFF304BBCFF2E4E
B8FF303B3600FFFFFF00313637002C2D2B00588997007BC3D400365F8400396E
9A003B6282003A5564004255C6FF3C52CCFF757AE8FF8F92EEFF8F92EEFF7178
E4FF334DC1FF2B4AB7FFFFFFFF0036423900486B710061B4CE00396F9600375C
83004085B1004959CBFF5C65E0FFA1A6F5FF7E86EFFF5B63E9FF595DE7FF7D84
EEFF9EA0F4FF515DD7FF2B4AB7FFFFFFFF00354C4C004D94AF00375D7F003348
5C005361CFFF616BE3FFA1ACF5FF545FECFF505CEAFF4D59E9FF4E59E6FF4C56
E6FF5056E6FF9EA2F4FF5460D6FF2A4AB8FFFFFFFF004A90A6003B5864003D5B
6A004B56DBFFA2ABF6FF5664F0FF5266EEFF4D59E9FF4D59E9FF4D59E9FF4D59
E9FF4C58E6FF525AE6FF9FA3F5FF3450C4FF57929C00498BA40047676D005C62
D7FF818CEEFF7E91F7FF5D73F3FF4D59E9FF4D59E9FF4D59E9FF4D59E9FF4D59
E9FF4D59E9FF4F5BE9FF7B83F0FF757BE2FF2E4BBAFF54839500FFFFFF005F63
DAFFA1ABF7FF7086F8FF6882F6FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFF4D59E9FF5C66EAFF969CF1FF3250BCFF6FA2AF00000000006469
DBFFAFB9F9FF7F93FAFF7085F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFF4D59E9FF5E6AEEFF969DF1FF364FBEFF58B2E00000000000676A
DEFFA5AFF5FF9DABFAFF778CF0FF545FECFF545FECFF545FECFF545FECFF545F
ECFF545FECFF6377F2FF818EF4FF787FE9FF3A53C0FF000000000800000000E8
1D007D83EAFFCDD4FCFF8B9DFAFF7E93F7FF758AEEFF6C84F6FF6C84F6FF6C84
F6FF6C84F6FF6379F3FFA4AFF8FF3E4FD0FF000000000000000001000100DB12
C0006A69E0FFA3A7F3FFD4DBFDFF879AFAFF7F91F0FF7A8EF1FF7F94F8FF7E92
F9FF768CF8FFA8B6F8FF636EE3FF4557C7FF00000000000000002401AD00BA02
AE002301AE006A69E0FFAAADF2FFD8DCFDFFAEBAFAFF91A3FAFF8B9DFAFF9CA9
FBFFBAC7FCFF707BE9FF4C5BCCFFBB02F00000010000D8000000000000000000
000008000000010008006A6ADFFF8E93EDFFBEC3F8FFCCD3F9FFC4CBF9FFAAB4
F4FF6670E2FF535ED1FF5031DE005031DE002501AC00B902AD000D040400F804
0500F20005000A0106000C040500F8040600686ADDFF6364DCFF6164DAFF5D63
D9FFF2000700F804610000000000710900005031DE005031DE004034DE004034
DE0068B0E00068B0E0000E049300F8049500F2009500070102000F049500F804
0200F2000200080104000E040200F8040400F200040009010500
}
NumGlyphs = 0
OnClick = btnDeleteClick
ShowHint = True
ParentShowHint = False
end
object vdtFilter: TVirtualDrawTree
Tag = 1
AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = Label1
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = btnDelete
Cursor = 63
Left = 4
Height = 151
Top = 64
Width = 214
Anchors = [akTop, akLeft, akRight, akBottom]
BorderSpacing.Around = 4
DefaultNodeHeight = 44
DragType = dtVCL
Header.AutoSizeIndex = 0
Header.Columns = <
item
Position = 0
Text = 'ID'
end
item
Position = 1
Text = 'Tile'
Width = 44
end
item
Position = 2
Text = 'Name'
Width = 100
end>
Header.DefaultHeight = 17
Header.Options = [hoColumnResize, hoDrag, hoVisible]
Header.ParentFont = True
Header.Style = hsFlatButtons
TabOrder = 0
TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]
OnDragOver = vdtFilterDragOver
OnDragDrop = vdtFilterDragDrop
OnDrawNode = vdtFilterDrawNode
end
object cbTileFilter: TCheckBox
AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = GroupBox1
Left = 4
Height = 22
Top = 4
Width = 85
BorderSpacing.Around = 4
Caption = 'Filter active'
OnChange = cbTileFilterChange
TabOrder = 1
end
end
object GroupBox2: TGroupBox
Left = 4
Height = 168
Top = 320
Width = 224
Align = alBottom
BorderSpacing.Around = 4
Caption = 'Hue filter'
ClientHeight = 154
ClientWidth = 222
TabOrder = 2
object cbHueFilter: TCheckBox
Left = 4
Height = 22
Top = 4
Width = 214
Align = alTop
BorderSpacing.Around = 4
Caption = 'Filter active'
OnChange = cbHueFilterChange
TabOrder = 0
end
object vdtHues: TVirtualDrawTree
Cursor = 63
Left = 4
Height = 120
Top = 30
Width = 214
Align = alClient
BorderSpacing.Around = 4
Header.AutoSizeIndex = 2
Header.Columns = <
item
Position = 0
Width = 20
end
item
Position = 1
Text = 'Hue'
Width = 38
end
item
Position = 2
Text = 'Name'
Width = 154
end>
Header.DefaultHeight = 17
Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoVisible]
Header.ParentFont = True
Header.Style = hsFlatButtons
PopupMenu = pmHues
TabOrder = 1
TreeOptions.MiscOptions = [toCheckSupport, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]
TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toFullRowSelect]
OnChecked = vdtHuesChecked
OnDrawNode = vdtHuesDrawNode
end
end
object Splitter1: TSplitter
Cursor = crVSplit
Left = 0
Height = 5
Top = 311
Width = 232
Align = alBottom
ResizeAnchor = akBottom
end
object pmHues: TPopupMenu
left = 148
top = 404
object mnuCheckHues: TMenuItem
Caption = 'Check all hues'
OnClick = mnuCheckHuesClick
end
object mnuUncheckHues: TMenuItem
Caption = 'Uncheck all hues'
OnClick = mnuUncheckHuesClick
end
end
end

44
Client/Tools/UfrmLightlevel.lfm
View File

@ -1,22 +1,22 @@
inherited frmLightlevel: TfrmLightlevel
Height = 171
Width = 40
ActiveControl = tbLightlevel
Caption = 'Lightlevel'
ClientHeight = 171
ClientWidth = 40
object tbLightlevel: TTrackBar[0]
Left = 0
Height = 171
Top = 0
Width = 40
Max = 32
OnChange = tbLightlevelChange
Orientation = trVertical
Position = 0
Align = alClient
TabOrder = 0
end
inherited tmClose: TTimer[1]
end
end
inherited frmLightlevel: TfrmLightlevel
Height = 171
Width = 40
ActiveControl = tbLightlevel
Caption = 'Lightlevel'
ClientHeight = 171
ClientWidth = 40
object tbLightlevel: TTrackBar[0]
Left = 0
Height = 171
Top = 0
Width = 40
Max = 32
OnChange = tbLightlevelChange
Orientation = trVertical
Position = 0
Align = alClient
TabOrder = 0
end
inherited tmClose: TTimer[1]
end
end

208
Client/Tools/UfrmToolWindow.pas
View File

@ -1,104 +1,104 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UfrmToolWindow;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
LCLIntf, LMessages, ExtCtrls;
type
{ TfrmToolWindow }
TfrmToolWindow = class(TForm)
tmClose: TTimer;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormDeactivate(Sender: TObject); virtual;
procedure FormShow(Sender: TObject); virtual;
procedure tmCloseTimer(Sender: TObject);
protected
function CanClose: Boolean; virtual;
procedure MouseLeave(var msg: TLMessage); message CM_MouseLeave;
public
{ public declarations }
end;
var
frmToolWindow: TfrmToolWindow;
implementation
{ TfrmToolWindow }
procedure TfrmToolWindow.FormDeactivate(Sender: TObject);
begin
if CanClose then
Close;
end;
procedure TfrmToolWindow.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caHide;
end;
procedure TfrmToolWindow.FormShow(Sender: TObject);
begin
Top := Mouse.CursorPos.y - 8;
Left := Mouse.CursorPos.x - 8;
OnDeactivate := nil;
tmClose.Enabled := True;
end;
procedure TfrmToolWindow.tmCloseTimer(Sender: TObject);
begin
tmClose.Enabled := False;
OnDeactivate := @FormDeactivate;
if CanClose then
Close;
end;
function TfrmToolWindow.CanClose: Boolean;
begin
Result := not PtInRect(ClientRect, ScreenToClient(Mouse.CursorPos));
end;
procedure TfrmToolWindow.MouseLeave(var msg: TLMessage);
begin
if CanClose then
Close;
end;
initialization
{$I UfrmToolWindow.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UfrmToolWindow;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
LCLIntf, LMessages, ExtCtrls;
type
{ TfrmToolWindow }
TfrmToolWindow = class(TForm)
tmClose: TTimer;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormDeactivate(Sender: TObject); virtual;
procedure FormShow(Sender: TObject); virtual;
procedure tmCloseTimer(Sender: TObject);
protected
function CanClose: Boolean; virtual;
procedure MouseLeave(var msg: TLMessage); message CM_MouseLeave;
public
{ public declarations }
end;
var
frmToolWindow: TfrmToolWindow;
implementation
{ TfrmToolWindow }
procedure TfrmToolWindow.FormDeactivate(Sender: TObject);
begin
if CanClose then
Close;
end;
procedure TfrmToolWindow.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caHide;
end;
procedure TfrmToolWindow.FormShow(Sender: TObject);
begin
Top := Mouse.CursorPos.y - 8;
Left := Mouse.CursorPos.x - 8;
OnDeactivate := nil;
tmClose.Enabled := True;
end;
procedure TfrmToolWindow.tmCloseTimer(Sender: TObject);
begin
tmClose.Enabled := False;
OnDeactivate := @FormDeactivate;
if CanClose then
Close;
end;
function TfrmToolWindow.CanClose: Boolean;
begin
Result := not PtInRect(ClientRect, ScreenToClient(Mouse.CursorPos));
end;
procedure TfrmToolWindow.MouseLeave(var msg: TLMessage);
begin
if CanClose then
Close;
end;
initialization
{$I UfrmToolWindow.lrs}
end.

250
Client/UGameResources.pas
View File

@ -1,125 +1,125 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UGameResources;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, UArtProvider, UTileDataProvider, UTexmapProvider,
ULandscape, UHueProvider, UAnimDataProvider, ULightProvider;
type
{ TGameResourceManager }
TGameResourceManager = class
constructor Create(ADataDir: String);
destructor Destroy; override;
protected
{ Members }
FDataDir: String;
FArtProvider: TArtProvider;
FTiledataProvider: TTiledataProvider;
FAnimdataProvider: TAnimdataProvider;
FTexmapProvider: TTexmapProvider;
FHueProvider: THueProvider;
FLightProvider: TLightProvider;
FLandscape: TLandscape;
public
{ Fields }
property Art: TArtProvider read FArtProvider;
property Hue: THueProvider read FHueProvider;
property Landscape: TLandscape read FLandscape;
property Tiledata: TTiledataProvider read FTiledataProvider;
property Animdata: TAnimDataProvider read FAnimdataProvider;
property Texmaps: TTexmapProvider read FTexmapProvider;
property Lights: TLightProvider read FLightProvider;
{ Methods }
function GetFile(AFileName: String): String;
procedure InitLandscape(AWidth, AHeight: Word);
end;
var
GameResourceManager: TGameResourceManager;
ResMan: TGameResourceManager absolute GameResourceManager;
procedure InitGameResourceManager(ADataDir: String);
implementation
procedure InitGameResourceManager(ADataDir: String);
begin
FreeAndNil(GameResourceManager);
GameResourceManager := TGameResourceManager.Create(ADataDir);
end;
{ TGameResourceManager }
constructor TGameResourceManager.Create(ADataDir: String);
begin
inherited Create;
FDataDir := IncludeTrailingPathDelimiter(ADataDir);
FArtProvider := TArtProvider.Create(GetFile('art.mul'), GetFile('artidx.mul'), True);
FTiledataProvider := TTiledataProvider.Create(GetFile('tiledata.mul'), True);
FAnimdataProvider := TAnimDataProvider.Create(GetFile('animdata.mul'), True);
FTexmapProvider := TTexmapProvider.Create(GetFile('texmaps.mul'),
GetFile('texidx.mul'), True);
FHueProvider := THueProvider.Create(GetFile('hues.mul'), True);
FLightProvider := TLightProvider.Create(GetFile('light.mul'),
GetFile('lightidx.mul'), True);
end;
destructor TGameResourceManager.Destroy;
begin
FreeAndNil(FArtProvider);
FreeAndNil(FTiledataProvider);
FreeAndNil(FAnimdataProvider);
FreeAndNil(FTexmapProvider);
FreeAndNil(FHueProvider);
FreeAndNil(FLightProvider);
FreeAndNil(FLandscape);
inherited Destroy;
end;
function TGameResourceManager.GetFile(AFileName: String): String;
begin
Result := FDataDir + AFileName;
end;
procedure TGameResourceManager.InitLandscape(AWidth, AHeight: Word);
begin
FreeAndNil(FLandscape);
FLandscape := TLandscape.Create(AWidth, AHeight);
end;
finalization
FreeAndNil(GameResourceManager);
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UGameResources;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, UArtProvider, UTileDataProvider, UTexmapProvider,
ULandscape, UHueProvider, UAnimDataProvider, ULightProvider;
type
{ TGameResourceManager }
TGameResourceManager = class
constructor Create(ADataDir: String);
destructor Destroy; override;
protected
{ Members }
FDataDir: String;
FArtProvider: TArtProvider;
FTiledataProvider: TTiledataProvider;
FAnimdataProvider: TAnimdataProvider;
FTexmapProvider: TTexmapProvider;
FHueProvider: THueProvider;
FLightProvider: TLightProvider;
FLandscape: TLandscape;
public
{ Fields }
property Art: TArtProvider read FArtProvider;
property Hue: THueProvider read FHueProvider;
property Landscape: TLandscape read FLandscape;
property Tiledata: TTiledataProvider read FTiledataProvider;
property Animdata: TAnimDataProvider read FAnimdataProvider;
property Texmaps: TTexmapProvider read FTexmapProvider;
property Lights: TLightProvider read FLightProvider;
{ Methods }
function GetFile(AFileName: String): String;
procedure InitLandscape(AWidth, AHeight: Word);
end;
var
GameResourceManager: TGameResourceManager;
ResMan: TGameResourceManager absolute GameResourceManager;
procedure InitGameResourceManager(ADataDir: String);
implementation
procedure InitGameResourceManager(ADataDir: String);
begin
FreeAndNil(GameResourceManager);
GameResourceManager := TGameResourceManager.Create(ADataDir);
end;
{ TGameResourceManager }
constructor TGameResourceManager.Create(ADataDir: String);
begin
inherited Create;
FDataDir := IncludeTrailingPathDelimiter(ADataDir);
FArtProvider := TArtProvider.Create(GetFile('art.mul'), GetFile('artidx.mul'), True);
FTiledataProvider := TTiledataProvider.Create(GetFile('tiledata.mul'), True);
FAnimdataProvider := TAnimDataProvider.Create(GetFile('animdata.mul'), True);
FTexmapProvider := TTexmapProvider.Create(GetFile('texmaps.mul'),
GetFile('texidx.mul'), True);
FHueProvider := THueProvider.Create(GetFile('hues.mul'), True);
FLightProvider := TLightProvider.Create(GetFile('light.mul'),
GetFile('lightidx.mul'), True);
end;
destructor TGameResourceManager.Destroy;
begin
FreeAndNil(FArtProvider);
FreeAndNil(FTiledataProvider);
FreeAndNil(FAnimdataProvider);
FreeAndNil(FTexmapProvider);
FreeAndNil(FHueProvider);
FreeAndNil(FLightProvider);
FreeAndNil(FLandscape);
inherited Destroy;
end;
function TGameResourceManager.GetFile(AFileName: String): String;
begin
Result := FDataDir + AFileName;
end;
procedure TGameResourceManager.InitLandscape(AWidth, AHeight: Word);
begin
FreeAndNil(FLandscape);
FLandscape := TLandscape.Create(AWidth, AHeight);
end;
finalization
FreeAndNil(GameResourceManager);
end.

510
Client/UOverlayUI.pas
View File

@ -1,255 +1,255 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UOverlayUI;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Gl, GLU, Imaging, ImagingTypes, ImagingClasses,
ImagingOpenGL, OpenGLContext, ImagingUtility;
type
{ TGLArrow }
TGLArrow = class(TObject)
constructor Create(AGraphic: TSingleImage);
destructor Destroy; override;
protected
FGraphic: TSingleImage;
FTexture: GLuint;
FRealWidth: Integer;
FRealHeight: Integer;
FWidth: Integer;
FHeight: Integer;
FCurrentX: Integer;
FCurrentY: Integer;
procedure UpdateTexture;
public
property Width: Integer read FWidth;
property Height: Integer read FHeight;
property CurrentX: Integer read FCurrentX;
property CurrentY: Integer read FCurrentY;
function HitTest(AX, AY: Integer): Boolean;
procedure DrawGL(AX, AY: Integer; AActive: Boolean = False);
end;
{ TOverlayUI }
TOverlayUI = class(TObject)
constructor Create;
destructor Destroy; override;
protected
FArrows: array[0..7] of TGLArrow;
FActiveArrow: Integer;
FVisible: Boolean;
public
property ActiveArrow: Integer read FActiveArrow write FActiveArrow;
property Visible: Boolean read FVisible write FVisible;
function HitTest(AX, AY: Integer): Integer;
procedure Draw(AContext: TOpenGLControl);
end;
implementation
uses
UResourceManager;
{ TGLArrow }
constructor TGLArrow.Create(AGraphic: TSingleImage);
var
caps: TGLTextureCaps;
begin
inherited Create;
FRealWidth := AGraphic.Width;
FRealHeight := AGraphic.Height;
GetGLTextureCaps(caps);
if caps.NonPowerOfTwo then
begin
FWidth := FRealWidth;
FHeight := FRealHeight;
end else
begin
if IsPow2(FRealWidth) then FWidth := FRealWidth else FWidth := NextPow2(FRealWidth);
if IsPow2(FRealHeight) then FHeight := FRealHeight else FHeight := NextPow2(FRealHeight);
end;
FGraphic := TSingleImage.CreateFromParams(FWidth, FHeight, ifA8R8G8B8);
AGraphic.CopyTo(0, 0, FRealWidth, FRealHeight, FGraphic, 0, 0);
FTexture := 0;
end;
destructor TGLArrow.Destroy;
begin
if FGraphic <> nil then FreeAndNil(FGraphic);
if FTexture <> 0 then glDeleteTextures(1, @FTexture);
inherited Destroy;
end;
procedure TGLArrow.UpdateTexture;
begin
if (FGraphic <> nil) and (FRealWidth > 0) and (FRealWidth > 0) then
begin
FTexture := CreateGLTextureFromImage(FGraphic.ImageDataPointer^, 0, 0, False);
glBindTexture(GL_TEXTURE_2D, FTexture);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP);
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP);
end;
end;
function TGLArrow.HitTest(AX, AY: Integer): Boolean;
var
pixel: TColor32Rec;
begin
if (AX > -1) and (AX < FRealWidth) and (AY > -1) and (AY < FRealHeight) then
begin
pixel := GetPixel32(FGraphic.ImageDataPointer^, AX, AY);
Result := pixel.A > 0;
end else
Result := False;
end;
procedure TGLArrow.DrawGL(AX, AY: Integer; AActive: Boolean = False);
begin
FCurrentX := AX;
FCurrentY := AY;
if FTexture = 0 then UpdateTexture;
if FTexture <> 0 then
begin
if AActive then
begin
glEnable(GL_COLOR_LOGIC_OP);
glLogicOp(GL_COPY_INVERTED);
end;
glBindTexture(GL_TEXTURE_2D, FTexture);
glBegin(GL_QUADS);
glTexCoord2f(0, 0); glVertex2d(AX, AY);
glTexCoord2f(1, 0); glVertex2d(AX + FWidth, AY);
glTexCoord2f(1, 1); glVertex2d(AX + FWidth, AY + FHeight);
glTexCoord2f(0, 1); glVertex2d(AX, AY + FHeight);
glEnd;
if AActive then
glDisable(GL_COLOR_LOGIC_OP);
end;
end;
{ TOverlayUI }
constructor TOverlayUI.Create;
var
i: Integer;
arrow: TSingleImage;
begin
inherited Create;
FActiveArrow := -1;
FVisible := False;
arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(0));
for i := 0 to 3 do
begin
FArrows[2*i] := TGLArrow.Create(arrow);
if i < 3 then
arrow.Rotate(-90);
end;
arrow.Free;
arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(1));
for i := 0 to 3 do
begin
FArrows[2*i+1] := TGLArrow.Create(arrow);
if i < 3 then
arrow.Rotate(-90);
end;
arrow.Free;
end;
destructor TOverlayUI.Destroy;
var
i: Integer;
begin
for i := 0 to 7 do
if FArrows[i] <> nil then FreeAndNil(FArrows[i]);
inherited Destroy;
end;
function TOverlayUI.HitTest(AX, AY: Integer): Integer;
var
i: Integer;
begin
Result := -1;
i := 0;
while (i <= 7) and (Result = -1) do
begin
if FArrows[i].HitTest(AX - FArrows[i].CurrentX, AY - FArrows[i].CurrentY) then
Result := i;
Inc(i);
end;
end;
procedure TOverlayUI.Draw(AContext: TOpenGLControl);
begin
if FVisible then
begin
glColor4f(1.0, 1.0, 1.0, 1.0);
glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
FArrows[0].DrawGL(10, 10, FActiveArrow = 0);
FArrows[1].DrawGL(AContext.Width div 2 - FArrows[1].Width div 2, 10,
FActiveArrow = 1);
FArrows[2].DrawGL(AContext.Width - 10 - FArrows[2].Width, 10,
FActiveArrow = 2);
FArrows[3].DrawGL(AContext.Width - 10 - FArrows[3].Width,
AContext.Height div 2 - FArrows[3].Height div 2,
FActiveArrow = 3);
FArrows[4].DrawGL(AContext.Width - 10 - FArrows[4].Width,
AContext.Height - 10 - FArrows[4].Height,
FActiveArrow = 4);
FArrows[5].DrawGL(AContext.Width div 2 - FArrows[5].Width div 2,
AContext.Height - 10 - FArrows[5].Height,
FActiveArrow = 5);
FArrows[6].DrawGL(10, AContext.Height - 10 - FArrows[6].Height,
FActiveArrow = 6);
FArrows[7].DrawGL(10, AContext.Height div 2 - FArrows[7].Height div 2,
FActiveArrow = 7);
end;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UOverlayUI;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Gl, GLU, Imaging, ImagingTypes, ImagingClasses,
ImagingOpenGL, OpenGLContext, ImagingUtility;
type
{ TGLArrow }
TGLArrow = class(TObject)
constructor Create(AGraphic: TSingleImage);
destructor Destroy; override;
protected
FGraphic: TSingleImage;
FTexture: GLuint;
FRealWidth: Integer;
FRealHeight: Integer;
FWidth: Integer;
FHeight: Integer;
FCurrentX: Integer;
FCurrentY: Integer;
procedure UpdateTexture;
public
property Width: Integer read FWidth;
property Height: Integer read FHeight;
property CurrentX: Integer read FCurrentX;
property CurrentY: Integer read FCurrentY;
function HitTest(AX, AY: Integer): Boolean;
procedure DrawGL(AX, AY: Integer; AActive: Boolean = False);
end;
{ TOverlayUI }
TOverlayUI = class(TObject)
constructor Create;
destructor Destroy; override;
protected
FArrows: array[0..7] of TGLArrow;
FActiveArrow: Integer;
FVisible: Boolean;
public
property ActiveArrow: Integer read FActiveArrow write FActiveArrow;
property Visible: Boolean read FVisible write FVisible;
function HitTest(AX, AY: Integer): Integer;
procedure Draw(AContext: TOpenGLControl);
end;
implementation
uses
UResourceManager;
{ TGLArrow }
constructor TGLArrow.Create(AGraphic: TSingleImage);
var
caps: TGLTextureCaps;
begin
inherited Create;
FRealWidth := AGraphic.Width;
FRealHeight := AGraphic.Height;
GetGLTextureCaps(caps);
if caps.NonPowerOfTwo then
begin
FWidth := FRealWidth;
FHeight := FRealHeight;
end else
begin
if IsPow2(FRealWidth) then FWidth := FRealWidth else FWidth := NextPow2(FRealWidth);
if IsPow2(FRealHeight) then FHeight := FRealHeight else FHeight := NextPow2(FRealHeight);
end;
FGraphic := TSingleImage.CreateFromParams(FWidth, FHeight, ifA8R8G8B8);
AGraphic.CopyTo(0, 0, FRealWidth, FRealHeight, FGraphic, 0, 0);
FTexture := 0;
end;
destructor TGLArrow.Destroy;
begin
if FGraphic <> nil then FreeAndNil(FGraphic);
if FTexture <> 0 then glDeleteTextures(1, @FTexture);
inherited Destroy;
end;
procedure TGLArrow.UpdateTexture;
begin
if (FGraphic <> nil) and (FRealWidth > 0) and (FRealWidth > 0) then
begin
FTexture := CreateGLTextureFromImage(FGraphic.ImageDataPointer^, 0, 0, False);
glBindTexture(GL_TEXTURE_2D, FTexture);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP);
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP);
end;
end;
function TGLArrow.HitTest(AX, AY: Integer): Boolean;
var
pixel: TColor32Rec;
begin
if (AX > -1) and (AX < FRealWidth) and (AY > -1) and (AY < FRealHeight) then
begin
pixel := GetPixel32(FGraphic.ImageDataPointer^, AX, AY);
Result := pixel.A > 0;
end else
Result := False;
end;
procedure TGLArrow.DrawGL(AX, AY: Integer; AActive: Boolean = False);
begin
FCurrentX := AX;
FCurrentY := AY;
if FTexture = 0 then UpdateTexture;
if FTexture <> 0 then
begin
if AActive then
begin
glEnable(GL_COLOR_LOGIC_OP);
glLogicOp(GL_COPY_INVERTED);
end;
glBindTexture(GL_TEXTURE_2D, FTexture);
glBegin(GL_QUADS);
glTexCoord2f(0, 0); glVertex2d(AX, AY);
glTexCoord2f(1, 0); glVertex2d(AX + FWidth, AY);
glTexCoord2f(1, 1); glVertex2d(AX + FWidth, AY + FHeight);
glTexCoord2f(0, 1); glVertex2d(AX, AY + FHeight);
glEnd;
if AActive then
glDisable(GL_COLOR_LOGIC_OP);
end;
end;
{ TOverlayUI }
constructor TOverlayUI.Create;
var
i: Integer;
arrow: TSingleImage;
begin
inherited Create;
FActiveArrow := -1;
FVisible := False;
arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(0));
for i := 0 to 3 do
begin
FArrows[2*i] := TGLArrow.Create(arrow);
if i < 3 then
arrow.Rotate(-90);
end;
arrow.Free;
arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(1));
for i := 0 to 3 do
begin
FArrows[2*i+1] := TGLArrow.Create(arrow);
if i < 3 then
arrow.Rotate(-90);
end;
arrow.Free;
end;
destructor TOverlayUI.Destroy;
var
i: Integer;
begin
for i := 0 to 7 do
if FArrows[i] <> nil then FreeAndNil(FArrows[i]);
inherited Destroy;
end;
function TOverlayUI.HitTest(AX, AY: Integer): Integer;
var
i: Integer;
begin
Result := -1;
i := 0;
while (i <= 7) and (Result = -1) do
begin
if FArrows[i].HitTest(AX - FArrows[i].CurrentX, AY - FArrows[i].CurrentY) then
Result := i;
Inc(i);
end;
end;
procedure TOverlayUI.Draw(AContext: TOpenGLControl);
begin
if FVisible then
begin
glColor4f(1.0, 1.0, 1.0, 1.0);
glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
FArrows[0].DrawGL(10, 10, FActiveArrow = 0);
FArrows[1].DrawGL(AContext.Width div 2 - FArrows[1].Width div 2, 10,
FActiveArrow = 1);
FArrows[2].DrawGL(AContext.Width - 10 - FArrows[2].Width, 10,
FActiveArrow = 2);
FArrows[3].DrawGL(AContext.Width - 10 - FArrows[3].Width,
AContext.Height div 2 - FArrows[3].Height div 2,
FActiveArrow = 3);
FArrows[4].DrawGL(AContext.Width - 10 - FArrows[4].Width,
AContext.Height - 10 - FArrows[4].Height,
FActiveArrow = 4);
FArrows[5].DrawGL(AContext.Width div 2 - FArrows[5].Width div 2,
AContext.Height - 10 - FArrows[5].Height,
FActiveArrow = 5);
FArrows[6].DrawGL(10, AContext.Height - 10 - FArrows[6].Height,
FActiveArrow = 6);
FArrows[7].DrawGL(10, AContext.Height div 2 - FArrows[7].Height div 2,
FActiveArrow = 7);
end;
end;
end.

300
Client/UPacketHandlers.pas
View File

@ -1,150 +1,150 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UPacketHandlers;
interface
uses
SysUtils, dzlib, UEnhancedMemoryStream;
type
TPacketProcessor = procedure(ABuffer: TEnhancedMemoryStream);
TPacketProcessorMethod = procedure(ABuffer: TEnhancedMemoryStream) of object;
{ TPacketHandler }
TPacketHandler = class(TObject)
constructor Create(ALength: Cardinal; APacketProcessor: TPacketProcessor); overload;
constructor Create(ALength: Cardinal; APacketProcessorMethod: TPacketProcessorMethod); overload;
procedure Process(ABuffer: TEnhancedMemoryStream);
protected
FLength: Cardinal;
FPacketProcessor: TPacketProcessor;
FPacketProcessorMethod: TPacketProcessorMethod;
published
property PacketLength: Cardinal read FLength;
end;
var
PacketHandlers: array[0..$FF] of TPacketHandler;
procedure RegisterPacketHandler(AID: Byte; APacketHandler: TPacketHandler);
implementation
uses
UAdminHandling;
procedure RegisterPacketHandler(AID: Byte; APacketHandler: TPacketHandler);
begin
FreeAndNil(PacketHandlers[AID]);
PacketHandlers[AID] := APacketHandler;
end;
{ TPacketHandler }
constructor TPacketHandler.Create(ALength: Cardinal; APacketProcessor: TPacketProcessor);
begin
inherited Create;
FLength := ALength;
FPacketProcessor := APacketProcessor;
FPacketProcessorMethod := nil;
end;
constructor TPacketHandler.Create(ALength: Cardinal;
APacketProcessorMethod: TPacketProcessorMethod);
begin
inherited Create;
FLength := ALength;
FPacketProcessor := nil;
FPacketProcessorMethod := APacketProcessorMethod;
end;
procedure TPacketHandler.Process(ABuffer: TEnhancedMemoryStream);
begin
if Assigned(FPacketProcessor) then
FPacketProcessor(ABuffer)
else if Assigned(FPacketProcessorMethod) then
FPacketProcessorMethod(ABuffer);
end;
procedure OnCompressedPacket(ABuffer: TEnhancedMemoryStream);
var
uncompStream: TEnhancedMemoryStream;
uncompBuffer: TDecompressionStream;
targetSize: Cardinal;
packetID: Byte;
begin
//writeln('compressed size: ', ABuffer.Size);
targetSize := ABuffer.ReadCardinal;
//writeln('uncompressed size: ', targetSize);
uncompBuffer := TDecompressionStream.Create(ABuffer);
uncompStream := TEnhancedMemoryStream.Create;
try
uncompStream.CopyFrom(uncompBuffer, targetSize);
uncompStream.Position := 0;
packetID := uncompStream.ReadByte;
if PacketHandlers[packetID] <> nil then
begin
if PacketHandlers[PacketID].PacketLength = 0 then
uncompStream.Position := uncompStream.Position + 4;
uncompStream.Lock(uncompStream.Position, uncompStream.Size - uncompStream.Position);
PacketHandlers[PacketID].Process(uncompStream);
uncompStream.Unlock;
end else
begin
{Writeln('Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);
ANetState.Socket.Disconnect;
ANetState.ReceiveQueue.Clear;}
end;
finally
if uncompBuffer <> nil then uncompBuffer.Free;
if uncompStream <> nil then uncompStream.Free;
end;
end;
{$WARNINGS OFF}
var
i: Integer;
initialization
for i := 0 to $FF do
PacketHandlers[i] := nil;
PacketHandlers[$01] := TPacketHandler.Create(0, @OnCompressedPacket);
//$02 --> ConnectionHandling, done by TdmNetwork
PacketHandlers[$03] := TPacketHandler.Create(0, @OnAdminHandlerPacket);;
//$04 --> handled by TLandscape
//$06-$0B --> handled by TLandscape
//$0C --> ClientHandling, done by TfrmMain
//$0D --> RadarMapHandling, done by TfrmRadarMap
finalization
for i := 0 to $FF do
if PacketHandlers[i] <> nil then
PacketHandlers[i].Free;
{$WARNINGS ON}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UPacketHandlers;
interface
uses
SysUtils, dzlib, UEnhancedMemoryStream;
type
TPacketProcessor = procedure(ABuffer: TEnhancedMemoryStream);
TPacketProcessorMethod = procedure(ABuffer: TEnhancedMemoryStream) of object;
{ TPacketHandler }
TPacketHandler = class(TObject)
constructor Create(ALength: Cardinal; APacketProcessor: TPacketProcessor); overload;
constructor Create(ALength: Cardinal; APacketProcessorMethod: TPacketProcessorMethod); overload;
procedure Process(ABuffer: TEnhancedMemoryStream);
protected
FLength: Cardinal;
FPacketProcessor: TPacketProcessor;
FPacketProcessorMethod: TPacketProcessorMethod;
published
property PacketLength: Cardinal read FLength;
end;
var
PacketHandlers: array[0..$FF] of TPacketHandler;
procedure RegisterPacketHandler(AID: Byte; APacketHandler: TPacketHandler);
implementation
uses
UAdminHandling;
procedure RegisterPacketHandler(AID: Byte; APacketHandler: TPacketHandler);
begin
FreeAndNil(PacketHandlers[AID]);
PacketHandlers[AID] := APacketHandler;
end;
{ TPacketHandler }
constructor TPacketHandler.Create(ALength: Cardinal; APacketProcessor: TPacketProcessor);
begin
inherited Create;
FLength := ALength;
FPacketProcessor := APacketProcessor;
FPacketProcessorMethod := nil;
end;
constructor TPacketHandler.Create(ALength: Cardinal;
APacketProcessorMethod: TPacketProcessorMethod);
begin
inherited Create;
FLength := ALength;
FPacketProcessor := nil;
FPacketProcessorMethod := APacketProcessorMethod;
end;
procedure TPacketHandler.Process(ABuffer: TEnhancedMemoryStream);
begin
if Assigned(FPacketProcessor) then
FPacketProcessor(ABuffer)
else if Assigned(FPacketProcessorMethod) then
FPacketProcessorMethod(ABuffer);
end;
procedure OnCompressedPacket(ABuffer: TEnhancedMemoryStream);
var
uncompStream: TEnhancedMemoryStream;
uncompBuffer: TDecompressionStream;
targetSize: Cardinal;
packetID: Byte;
begin
//writeln('compressed size: ', ABuffer.Size);
targetSize := ABuffer.ReadCardinal;
//writeln('uncompressed size: ', targetSize);
uncompBuffer := TDecompressionStream.Create(ABuffer);
uncompStream := TEnhancedMemoryStream.Create;
try
uncompStream.CopyFrom(uncompBuffer, targetSize);
uncompStream.Position := 0;
packetID := uncompStream.ReadByte;
if PacketHandlers[packetID] <> nil then
begin
if PacketHandlers[PacketID].PacketLength = 0 then
uncompStream.Position := uncompStream.Position + 4;
uncompStream.Lock(uncompStream.Position, uncompStream.Size - uncompStream.Position);
PacketHandlers[PacketID].Process(uncompStream);
uncompStream.Unlock;
end else
begin
{Writeln('Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);
ANetState.Socket.Disconnect;
ANetState.ReceiveQueue.Clear;}
end;
finally
if uncompBuffer <> nil then uncompBuffer.Free;
if uncompStream <> nil then uncompStream.Free;
end;
end;
{$WARNINGS OFF}
var
i: Integer;
initialization
for i := 0 to $FF do
PacketHandlers[i] := nil;
PacketHandlers[$01] := TPacketHandler.Create(0, @OnCompressedPacket);
//$02 --> ConnectionHandling, done by TdmNetwork
PacketHandlers[$03] := TPacketHandler.Create(0, @OnAdminHandlerPacket);;
//$04 --> handled by TLandscape
//$06-$0B --> handled by TLandscape
//$0C --> ClientHandling, done by TfrmMain
//$0D --> RadarMapHandling, done by TfrmRadarMap
finalization
for i := 0 to $FF do
if PacketHandlers[i] <> nil then
PacketHandlers[i].Free;
{$WARNINGS ON}
end.

746
Client/UPackets.pas
View File

@ -1,373 +1,373 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UPackets;
interface
uses
Classes, dzlib, UEnhancedMemoryStream, UPacket, UStatics;
type
TBlockCoords = packed record
X: Word;
Y: Word;
end;
TBlockCoordsArray = array of TBlockCoords;
{ TCompressedPacket }
TCompressedPacket = class(TPacket)
constructor Create(APacket: TPacket);
end;
{ TLoginRequestPacket }
TLoginRequestPacket = class(TPacket)
constructor Create(AUsername, APassword: string);
end;
{ TQuitPacket }
TQuitPacket = class(TPacket)
constructor Create;
end;
{ TRequestBlocksPacket }
TRequestBlocksPacket = class(TPacket)
constructor Create(ACoords: TBlockCoordsArray);
end;
{ TFreeBlockPacket }
TFreeBlockPacket = class(TPacket)
constructor Create(AX, AY: Word);
end;
{ TDrawMapPacket }
TDrawMapPacket = class(TPacket)
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word);
end;
{ TStaticPacket }
TStaticPacket = class(TPacket)
protected
procedure WriteStaticItem(AStaticItem: TStaticItem);
end;
{ TInsertStaticPacket }
TInsertStaticPacket = class(TPacket)
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word);
end;
{ TDeleteStaticPacket }
TDeleteStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem);
end;
{ TElevateStaticPacket }
TElevateStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem; ANewZ: ShortInt);
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word;
ANewZ: Word);
end;
{ TMoveStaticPacket }
TMoveStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem; ANewX, ANewY: Word);
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word;
ANewX, ANewY: Word);
end;
{ THueStaticPacket }
THueStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem; ANewHue: Word);
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word;
ANewHue: Word);
end;
{ TUpdateClientPosPacket }
TUpdateClientPosPacket = class(TPacket)
constructor Create(AX, AY: Word);
end;
{ TChatMessagePacket }
TChatMessagePacket = class(TPacket)
constructor Create(AMessage: string);
end;
{ TGotoClientPosPacket }
TGotoClientPosPacket = class(TPacket)
constructor Create(AUsername: string);
end;
{ TRequestRadarChecksumPacket }
TRequestRadarChecksumPacket = class(TPacket)
constructor Create;
end;
{ TRequestRadarMapPacket }
TRequestRadarMapPacket = class(TPacket)
constructor Create;
end;
{ TNoOpPacket }
TNoOpPacket = class(TPacket)
constructor Create;
end;
implementation
{ TCompressedPacket }
constructor TCompressedPacket.Create(APacket: TPacket);
var
compBuffer: TEnhancedMemoryStream;
compStream: TCompressionStream;
sourceStream: TStream;
begin
inherited Create($01, 0);
compBuffer := TEnhancedMemoryStream.Create;
compStream := TCompressionStream.Create(clMax, compBuffer);
sourceStream := APacket.Stream;
compStream.CopyFrom(sourceStream, 0);
compStream.Free;
FStream.WriteCardinal(sourceStream.Size);
FStream.CopyFrom(compBuffer, 0);
compBuffer.Free;
APacket.Free;
end;
{ TLoginRequestPacket }
constructor TLoginRequestPacket.Create(AUsername, APassword: string);
begin
inherited Create($02, 0);
FStream.WriteByte($03);
FStream.WriteStringNull(AUsername);
FStream.WriteStringNull(APassword);
end;
{ TQuitPacket }
constructor TQuitPacket.Create;
begin
inherited Create($02, 0);
FStream.WriteByte($05);
end;
{ TRequestBlocksPacket }
constructor TRequestBlocksPacket.Create(ACoords: TBlockCoordsArray);
begin
inherited Create($04, 0);
FStream.Write(ACoords[0], Length(ACoords) * SizeOf(TBlockCoords));
end;
{ TFreeBlockPacket }
constructor TFreeBlockPacket.Create(AX, AY: Word);
begin
inherited Create($05, 5);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
end;
{ TDrawMapPacket }
constructor TDrawMapPacket.Create(AX, AY: Word; AZ: ShortInt; ATileID: Word);
begin
inherited Create($06, 8);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
end;
{ TStaticPacket }
procedure TStaticPacket.WriteStaticItem(AStaticItem: TStaticItem);
begin
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
end;
{ TInsertStaticPacket }
constructor TInsertStaticPacket.Create(AX, AY: Word; AZ: ShortInt;
ATileID: Word; AHue: Word);
begin
inherited Create($07, 10);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
end;
{ TDeleteStaticPacket }
constructor TDeleteStaticPacket.Create(AStaticItem: TStaticItem);
begin
inherited Create($08, 10);
WriteStaticItem(AStaticItem);
end;
{ TElevateStaticPacket }
constructor TElevateStaticPacket.Create(AStaticItem: TStaticItem; ANewZ: ShortInt);
begin
inherited Create($09, 11);
WriteStaticItem(AStaticItem);
FStream.WriteShortInt(ANewZ);
end;
constructor TElevateStaticPacket.Create(AX, AY: Word; AZ: ShortInt;
ATileID: Word; AHue: Word; ANewZ: Word);
begin
inherited Create($09, 11);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
FStream.WriteShortInt(ANewZ);
end;
{ TMoveStaticPacket }
constructor TMoveStaticPacket.Create(AStaticItem: TStaticItem; ANewX,
ANewY: Word);
begin
inherited Create($0A, 14);
WriteStaticItem(AStaticItem);
FStream.WriteWord(ANewX);
FStream.WriteWord(ANewY);
end;
constructor TMoveStaticPacket.Create(AX, AY: Word; AZ: ShortInt; ATileID: Word;
AHue: Word; ANewX, ANewY: Word);
begin
inherited Create($0A, 14);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
FStream.WriteWord(ANewX);
FStream.WriteWord(ANewY);
end;
{ THueStaticPacket }
constructor THueStaticPacket.Create(AStaticItem: TStaticItem; ANewHue: Word);
begin
inherited Create($0B, 12);
WriteStaticItem(AStaticItem);
FStream.WriteWord(ANewHue);
end;
constructor THueStaticPacket.Create(AX, AY: Word; AZ: ShortInt; ATileID: Word;
AHue: Word; ANewHue: Word);
begin
inherited Create($0B, 12);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
FStream.WriteWord(ANewHue);
end;
{ TUpdateClientPosPacket }
constructor TUpdateClientPosPacket.Create(AX, AY: Word);
begin
inherited Create($0C, 0);
FStream.WriteByte($04);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
end;
{ TChatMessagePacket }
constructor TChatMessagePacket.Create(AMessage: string);
begin
inherited Create($0C, 0);
FStream.WriteByte($05);
FStream.WriteStringNull(AMessage);
end;
{ TGotoClientPosPacket }
constructor TGotoClientPosPacket.Create(AUsername: string);
begin
inherited Create($0C, 0);
FStream.WriteByte($06);
FStream.WriteStringNull(AUsername);
end;
{ TRequestRadarChecksumPacket }
constructor TRequestRadarChecksumPacket.Create;
begin
inherited Create($0D, 2);
FStream.WriteByte($01);
end;
{ TRequestRadarMapPacket }
constructor TRequestRadarMapPacket.Create;
begin
inherited Create($0D, 2);
FStream.WriteByte($02);
end;
{ TNoOpPacket }
constructor TNoOpPacket.Create;
begin
inherited Create($FF, 1);
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UPackets;
interface
uses
Classes, dzlib, UEnhancedMemoryStream, UPacket, UStatics;
type
TBlockCoords = packed record
X: Word;
Y: Word;
end;
TBlockCoordsArray = array of TBlockCoords;
{ TCompressedPacket }
TCompressedPacket = class(TPacket)
constructor Create(APacket: TPacket);
end;
{ TLoginRequestPacket }
TLoginRequestPacket = class(TPacket)
constructor Create(AUsername, APassword: string);
end;
{ TQuitPacket }
TQuitPacket = class(TPacket)
constructor Create;
end;
{ TRequestBlocksPacket }
TRequestBlocksPacket = class(TPacket)
constructor Create(ACoords: TBlockCoordsArray);
end;
{ TFreeBlockPacket }
TFreeBlockPacket = class(TPacket)
constructor Create(AX, AY: Word);
end;
{ TDrawMapPacket }
TDrawMapPacket = class(TPacket)
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word);
end;
{ TStaticPacket }
TStaticPacket = class(TPacket)
protected
procedure WriteStaticItem(AStaticItem: TStaticItem);
end;
{ TInsertStaticPacket }
TInsertStaticPacket = class(TPacket)
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word);
end;
{ TDeleteStaticPacket }
TDeleteStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem);
end;
{ TElevateStaticPacket }
TElevateStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem; ANewZ: ShortInt);
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word;
ANewZ: Word);
end;
{ TMoveStaticPacket }
TMoveStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem; ANewX, ANewY: Word);
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word;
ANewX, ANewY: Word);
end;
{ THueStaticPacket }
THueStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem; ANewHue: Word);
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word;
ANewHue: Word);
end;
{ TUpdateClientPosPacket }
TUpdateClientPosPacket = class(TPacket)
constructor Create(AX, AY: Word);
end;
{ TChatMessagePacket }
TChatMessagePacket = class(TPacket)
constructor Create(AMessage: string);
end;
{ TGotoClientPosPacket }
TGotoClientPosPacket = class(TPacket)
constructor Create(AUsername: string);
end;
{ TRequestRadarChecksumPacket }
TRequestRadarChecksumPacket = class(TPacket)
constructor Create;
end;
{ TRequestRadarMapPacket }
TRequestRadarMapPacket = class(TPacket)
constructor Create;
end;
{ TNoOpPacket }
TNoOpPacket = class(TPacket)
constructor Create;
end;
implementation
{ TCompressedPacket }
constructor TCompressedPacket.Create(APacket: TPacket);
var
compBuffer: TEnhancedMemoryStream;
compStream: TCompressionStream;
sourceStream: TStream;
begin
inherited Create($01, 0);
compBuffer := TEnhancedMemoryStream.Create;
compStream := TCompressionStream.Create(clMax, compBuffer);
sourceStream := APacket.Stream;
compStream.CopyFrom(sourceStream, 0);
compStream.Free;
FStream.WriteCardinal(sourceStream.Size);
FStream.CopyFrom(compBuffer, 0);
compBuffer.Free;
APacket.Free;
end;
{ TLoginRequestPacket }
constructor TLoginRequestPacket.Create(AUsername, APassword: string);
begin
inherited Create($02, 0);
FStream.WriteByte($03);
FStream.WriteStringNull(AUsername);
FStream.WriteStringNull(APassword);
end;
{ TQuitPacket }
constructor TQuitPacket.Create;
begin
inherited Create($02, 0);
FStream.WriteByte($05);
end;
{ TRequestBlocksPacket }
constructor TRequestBlocksPacket.Create(ACoords: TBlockCoordsArray);
begin
inherited Create($04, 0);
FStream.Write(ACoords[0], Length(ACoords) * SizeOf(TBlockCoords));
end;
{ TFreeBlockPacket }
constructor TFreeBlockPacket.Create(AX, AY: Word);
begin
inherited Create($05, 5);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
end;
{ TDrawMapPacket }
constructor TDrawMapPacket.Create(AX, AY: Word; AZ: ShortInt; ATileID: Word);
begin
inherited Create($06, 8);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
end;
{ TStaticPacket }
procedure TStaticPacket.WriteStaticItem(AStaticItem: TStaticItem);
begin
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
end;
{ TInsertStaticPacket }
constructor TInsertStaticPacket.Create(AX, AY: Word; AZ: ShortInt;
ATileID: Word; AHue: Word);
begin
inherited Create($07, 10);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
end;
{ TDeleteStaticPacket }
constructor TDeleteStaticPacket.Create(AStaticItem: TStaticItem);
begin
inherited Create($08, 10);
WriteStaticItem(AStaticItem);
end;
{ TElevateStaticPacket }
constructor TElevateStaticPacket.Create(AStaticItem: TStaticItem; ANewZ: ShortInt);
begin
inherited Create($09, 11);
WriteStaticItem(AStaticItem);
FStream.WriteShortInt(ANewZ);
end;
constructor TElevateStaticPacket.Create(AX, AY: Word; AZ: ShortInt;
ATileID: Word; AHue: Word; ANewZ: Word);
begin
inherited Create($09, 11);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
FStream.WriteShortInt(ANewZ);
end;
{ TMoveStaticPacket }
constructor TMoveStaticPacket.Create(AStaticItem: TStaticItem; ANewX,
ANewY: Word);
begin
inherited Create($0A, 14);
WriteStaticItem(AStaticItem);
FStream.WriteWord(ANewX);
FStream.WriteWord(ANewY);
end;
constructor TMoveStaticPacket.Create(AX, AY: Word; AZ: ShortInt; ATileID: Word;
AHue: Word; ANewX, ANewY: Word);
begin
inherited Create($0A, 14);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
FStream.WriteWord(ANewX);
FStream.WriteWord(ANewY);
end;
{ THueStaticPacket }
constructor THueStaticPacket.Create(AStaticItem: TStaticItem; ANewHue: Word);
begin
inherited Create($0B, 12);
WriteStaticItem(AStaticItem);
FStream.WriteWord(ANewHue);
end;
constructor THueStaticPacket.Create(AX, AY: Word; AZ: ShortInt; ATileID: Word;
AHue: Word; ANewHue: Word);
begin
inherited Create($0B, 12);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
FStream.WriteWord(ANewHue);
end;
{ TUpdateClientPosPacket }
constructor TUpdateClientPosPacket.Create(AX, AY: Word);
begin
inherited Create($0C, 0);
FStream.WriteByte($04);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
end;
{ TChatMessagePacket }
constructor TChatMessagePacket.Create(AMessage: string);
begin
inherited Create($0C, 0);
FStream.WriteByte($05);
FStream.WriteStringNull(AMessage);
end;
{ TGotoClientPosPacket }
constructor TGotoClientPosPacket.Create(AUsername: string);
begin
inherited Create($0C, 0);
FStream.WriteByte($06);
FStream.WriteStringNull(AUsername);
end;
{ TRequestRadarChecksumPacket }
constructor TRequestRadarChecksumPacket.Create;
begin
inherited Create($0D, 2);
FStream.WriteByte($01);
end;
{ TRequestRadarMapPacket }
constructor TRequestRadarMapPacket.Create;
begin
inherited Create($0D, 2);
FStream.WriteByte($02);
end;
{ TNoOpPacket }
constructor TNoOpPacket.Create;
begin
inherited Create($FF, 1);
end;
end.

210
Client/UResourceManager.pas
View File

@ -1,105 +1,105 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UResourceManager;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
type
{ TResourceManager }
TResourceManager = class
constructor Create(AFileName: string);
destructor Destroy; override;
protected
FFileStream: TFileStream;
FCount: Integer;
FLookupTable: array of Cardinal;
FCurrentResource: Integer;
FResourceStream: TMemoryStream;
public
function GetResource(AIndex: Integer): TStream;
end;
var
ResourceManager: TResourceManager;
implementation
{ TResourceManager }
constructor TResourceManager.Create(AFileName: string);
begin
inherited Create;
FFileStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
FFileStream.Position := 0;
FFileStream.Read(FCount, SizeOf(Integer));
SetLength(FLookupTable, FCount);
FFileStream.Read(FLookupTable[0], FCount * SizeOf(Cardinal));
FCurrentResource := -1;
end;
destructor TResourceManager.Destroy;
begin
FreeAndNil(FFileStream);
FreeAndNil(FResourceStream);
inherited Destroy;
end;
function TResourceManager.GetResource(AIndex: Integer): TStream;
var
size: Cardinal;
begin
if AIndex <> FCurrentResource then
begin
FFileStream.Position := FLookupTable[AIndex];
FResourceStream.Free;
FResourceStream := TMemoryStream.Create;
FFileStream.Read(size, SizeOf(Cardinal));
FResourceStream.CopyFrom(FFileStream, size);
FCurrentResource := AIndex;
end;
FResourceStream.Position := 0;
Result := FResourceStream;
end;
initialization
begin
ResourceManager := TResourceManager.Create(ChangeFileExt(ParamStr(0), '.dat'));
end;
finalization
begin
if ResourceManager <> nil then FreeAndNil(ResourceManager);
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UResourceManager;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
type
{ TResourceManager }
TResourceManager = class
constructor Create(AFileName: string);
destructor Destroy; override;
protected
FFileStream: TFileStream;
FCount: Integer;
FLookupTable: array of Cardinal;
FCurrentResource: Integer;
FResourceStream: TMemoryStream;
public
function GetResource(AIndex: Integer): TStream;
end;
var
ResourceManager: TResourceManager;
implementation
{ TResourceManager }
constructor TResourceManager.Create(AFileName: string);
begin
inherited Create;
FFileStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
FFileStream.Position := 0;
FFileStream.Read(FCount, SizeOf(Integer));
SetLength(FLookupTable, FCount);
FFileStream.Read(FLookupTable[0], FCount * SizeOf(Cardinal));
FCurrentResource := -1;
end;
destructor TResourceManager.Destroy;
begin
FreeAndNil(FFileStream);
FreeAndNil(FResourceStream);
inherited Destroy;
end;
function TResourceManager.GetResource(AIndex: Integer): TStream;
var
size: Cardinal;
begin
if AIndex <> FCurrentResource then
begin
FFileStream.Position := FLookupTable[AIndex];
FResourceStream.Free;
FResourceStream := TMemoryStream.Create;
FFileStream.Read(size, SizeOf(Cardinal));
FResourceStream.CopyFrom(FFileStream, size);
FCurrentResource := AIndex;
end;
FResourceStream.Position := 0;
Result := FResourceStream;
end;
initialization
begin
ResourceManager := TResourceManager.Create(ChangeFileExt(ParamStr(0), '.dat'));
end;
finalization
begin
if ResourceManager <> nil then FreeAndNil(ResourceManager);
end;
end.

742
Client/UdmNetwork.pas
View File

@ -1,371 +1,371 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UdmNetwork;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Dialogs, lNetComponents, lNet,
UEnhancedMemoryStream, UPacket, UEnums, ExtCtrls, dateutils;
type
{ TdmNetwork }
TdmNetwork = class(TDataModule)
TCPClient: TLTCPComponent;
tmNoOp: TTimer;
procedure DataModuleCreate(Sender: TObject);
procedure DataModuleDestroy(Sender: TObject);
procedure TCPClientConnect(aSocket: TLSocket);
procedure TCPClientDisconnect(aSocket: TLSocket);
procedure TCPClientError(const msg: string; aSocket: TLSocket);
procedure TCPClientReceive(aSocket: TLSocket);
procedure tmNoOpStartTimer(Sender: TObject);
procedure tmNoOpTimer(Sender: TObject);
protected
FSendQueue: TEnhancedMemoryStream;
FReceiveQueue: TEnhancedMemoryStream;
FUsername: string;
FPassword: string;
FAccessLevel: TAccessLevel;
FDataDir: string;
FLastPacket: TDateTime;
procedure OnCanSend(ASocket: TLSocket);
procedure OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
procedure ProcessQueue;
procedure DoLogin;
public
property Username: string read FUsername;
property AccessLevel: TAccessLevel read FAccessLevel write FAccessLevel;
procedure Send(APacket: TPacket);
procedure Disconnect;
procedure CheckClose(ASender: TForm);
end;
var
dmNetwork: TdmNetwork;
implementation
uses
UPacketHandlers, UPackets, UfrmMain, UfrmLogin, UfrmInitialize,
UGameResources, UfrmAccountControl, UfrmEditAccount, UfrmDrawSettings,
UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings,
UfrmAbout, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand,
UfrmVirtualLayer, UfrmFilter, UfrmRegionControl, UfrmLightlevel;
{$I version.inc}
{ TdmNetwork }
procedure TdmNetwork.DataModuleCreate(Sender: TObject);
begin
FSendQueue := TEnhancedMemoryStream.Create;
FReceiveQueue := TEnhancedMemoryStream.Create;
TCPClient.OnCanSend := @OnCanSend;
PacketHandlers[$02] := TPacketHandler.Create(0, @OnConnectionHandlingPacket);
DoLogin;
end;
procedure TdmNetwork.DataModuleDestroy(Sender: TObject);
begin
FreeAndNil(FSendQueue);
FreeAndNil(FReceiveQueue);
FreeAndNil(PacketHandlers[$02]);
end;
procedure TdmNetwork.TCPClientConnect(aSocket: TLSocket);
begin
FSendQueue.Clear;
FReceiveQueue.Clear;
end;
procedure TdmNetwork.TCPClientDisconnect(aSocket: TLSocket);
begin
FSendQueue.Clear;
FReceiveQueue.Clear;
DoLogin;
end;
procedure TdmNetwork.TCPClientError(const msg: string; aSocket: TLSocket);
begin
MessageDlg('Connection error', msg, mtError, [mbOK], 0);
if not TCPClient.Connected then
TCPClientDisconnect(aSocket);
end;
procedure TdmNetwork.TCPClientReceive(aSocket: TLSocket);
var
buffer: array[0..4095] of byte;
size: Integer;
begin
repeat
size := TCPClient.Get(buffer, 4096);
if size > 0 then
FReceiveQueue.Enqueue(buffer, size);
until size <= 0;
ProcessQueue;
end;
procedure TdmNetwork.tmNoOpStartTimer(Sender: TObject);
begin
FLastPacket := Now;
end;
procedure TdmNetwork.tmNoOpTimer(Sender: TObject);
begin
if SecondsBetween(FLastPacket, Now) > 25 then
Send(TNoOpPacket.Create);
end;
procedure TdmNetwork.OnCanSend(ASocket: TLSocket);
var
size: Integer;
begin
while FSendQueue.Size > 0 do
begin
FLastPacket := Now;
size := TCPClient.Send(FSendQueue.Memory^, FSendQueue.Size);
if size > 0 then
FSendQueue.Dequeue(size)
else
Break;
end;
end;
procedure TdmNetwork.OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
var
subID: Byte;
loginState: TLoginState;
width, height: Word;
serverState: TServerState;
begin
subID := ABuffer.ReadByte;
case subID of
$01:
begin
if ABuffer.ReadCardinal = ProtocolVersion then
begin
frmInitialize.lblStatus.Caption := 'Authenticating';
Send(TLoginRequestPacket.Create(FUsername, FPassword));
end else
begin
MessageDlg('Error', 'Invalid protocol version. Maybe your client is outdated.', mtError, [mbOK], 0);
Disconnect;
end;
end;
$03:
begin
loginState := TLoginState(ABuffer.ReadByte);
if loginState = lsOK then
begin
frmInitialize.lblStatus.Caption := 'Initializing';
frmInitialize.Repaint;
frmInitialize.lblStatus.Repaint;
Application.ProcessMessages;
FAccessLevel := TAccessLevel(ABuffer.ReadByte);
InitGameResourceManager(FDataDir);
width := ABuffer.ReadWord;
height := ABuffer.ReadWord;
ResMan.InitLandscape(width, height);
ResMan.Landscape.UpdateWriteMap(ABuffer);
frmMain := TfrmMain.Create(dmNetwork);
frmRadarMap := TfrmRadarMap.Create(frmMain);
frmLargeScaleCommand := TfrmLargeScaleCommand.Create(frmMain);
frmRegionControl := TfrmRegionControl.Create(frmMain);
frmAccountControl := TfrmAccountControl.Create(frmMain);
frmEditAccount := TfrmEditAccount.Create(frmAccountControl);
frmConfirmation := TfrmConfirmation.Create(frmMain);
frmDrawSettings := TfrmDrawSettings.Create(frmMain);
frmMoveSettings := TfrmMoveSettings.Create(frmMain);
frmElevateSettings := TfrmElevateSettings.Create(frmMain);
frmHueSettings := TfrmHueSettings.Create(frmMain);
frmBoundaries := TfrmBoundaries.Create(frmMain);
frmFilter := TfrmFilter.Create(frmMain);
frmVirtualLayer := TfrmVirtualLayer.Create(frmMain);
frmLightlevel := TfrmLightlevel.Create(frmMain);
frmAbout := TfrmAbout.Create(frmMain);
frmMain.Show;
frmInitialize.Hide;
tmNoOp.Enabled := True;
end else
begin
if loginState = lsInvalidUser then
MessageDlg('Error', 'The username you specified is incorrect.', mtWarning, [mbOK], 0)
else if loginState = lsInvalidPassword then
MessageDlg('Error', 'The password you specified is incorrect.', mtWarning, [mbOK], 0)
else if loginState = lsAlreadyLoggedIn then
MessageDlg('Error', 'There is already a client logged in using that account.', mtWarning, [mbOK], 0)
else if loginState = lsNoAccess then
MessageDlg('Error', 'This account has no access.', mtWarning, [mbOK], 0);
end;
end;
$04: //Server state
begin
serverState := TServerState(ABuffer.ReadByte);
if serverState = ssRunning then
begin
frmInitialize.UnsetModal;
frmInitialize.Hide;
tmNoOp.Enabled := True;
end else
begin
case serverState of
ssFrozen: frmInitialize.lblStatus.Caption := 'The server is currently paused.';
ssOther: frmInitialize.lblStatus.Caption := ABuffer.ReadStringNull
end;
tmNoOp.Enabled := False;
frmInitialize.Show;
frmInitialize.SetModal;
end;
end;
end;
end;
procedure TdmNetwork.ProcessQueue;
var
packetHandler: TPacketHandler;
size: Cardinal;
begin
FReceiveQueue.Position := 0;
while FReceiveQueue.Size >= 1 do
begin
packetHandler := PacketHandlers[FReceiveQueue.ReadByte];
if packetHandler <> nil then
begin
size := packetHandler.PacketLength;
if size = 0 then
begin
if FReceiveQueue.Size > 5 then
size := FReceiveQueue.ReadCardinal
else
Break; //wait for more data
end;
if FReceiveQueue.Size >= size then
begin
FReceiveQueue.Lock(FReceiveQueue.Position, size - FReceiveQueue.Position); //prevent handler from reading too much
packetHandler.Process(FReceiveQueue);
FReceiveQueue.Unlock;
FReceiveQueue.Dequeue(size);
end else
Break; //wait for more data
end else
begin
{Writeln('Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);}
Disconnect;
FReceiveQueue.Clear;
end;
end;
end;
procedure TdmNetwork.DoLogin;
begin
tmNoOp.Enabled := False;
frmLogin := TfrmLogin.Create(dmNetwork);
if frmInitialize = nil then
frmInitialize := TfrmInitialize.Create(dmNetwork);
FreeAndNil(frmEditAccount);
FreeAndNil(frmAccountControl);
FreeAndNil(frmConfirmation);
FreeAndNil(frmDrawSettings);
FreeAndNil(frmMoveSettings);
FreeAndNil(frmElevateSettings);
FreeAndNil(frmHueSettings);
FreeAndNil(frmBoundaries);
FreeAndNil(frmFilter);
FreeAndNil(frmVirtualLayer);
FreeAndNil(frmAbout);
FreeAndNil(frmRegionControl);
FreeAndNil(frmLargeScaleCommand);
FreeAndNil(frmRadarMap);
FreeAndNil(frmLightlevel);
if frmMain <> nil then
begin
frmMain.ApplicationProperties1.OnIdle := nil;
FreeAndNil(frmMain);
end;
FreeAndNil(GameResourceManager);
frmInitialize.Hide;
while frmLogin.ShowModal = mrOK do
begin
if TCPClient.Connect(frmLogin.edHost.Text, frmLogin.edPort.Value) then
begin
FUsername := frmLogin.edUsername.Text;
FPassword := frmLogin.edPassword.Text;
FDataDir := frmLogin.edData.Text;
frmInitialize.lblStatus.Caption := 'Connecting';
frmInitialize.Show;
Break;
end else
MessageDlg('Error', 'Cannot connect to the specified server.', mtError, [mbOK], 0);
end;
frmLogin.Close;
FreeAndNil(frmLogin);
end;
procedure TdmNetwork.Send(APacket: TPacket);
var
source: TEnhancedMemoryStream;
begin
if TCPClient.Connected then
begin
FSendQueue.Seek(0, soFromEnd);
source := APacket.Stream;
FSendQueue.CopyFrom(source, 0);
OnCanSend(nil);
end;
APacket.Free;
end;
procedure TdmNetwork.Disconnect;
begin
Send(TQuitPacket.Create);
end;
procedure TdmNetwork.CheckClose(ASender: TForm);
begin
if ((frmLogin = nil) or (ASender = frmLogin)) and
((frmMain = nil) or (ASender = frmMain)) and
((frmInitialize = nil) or (not frmInitialize.Visible)) then
begin
Application.Terminate;
end;
end;
initialization
{$I UdmNetwork.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UdmNetwork;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Dialogs, lNetComponents, lNet,
UEnhancedMemoryStream, UPacket, UEnums, ExtCtrls, dateutils;
type
{ TdmNetwork }
TdmNetwork = class(TDataModule)
TCPClient: TLTCPComponent;
tmNoOp: TTimer;
procedure DataModuleCreate(Sender: TObject);
procedure DataModuleDestroy(Sender: TObject);
procedure TCPClientConnect(aSocket: TLSocket);
procedure TCPClientDisconnect(aSocket: TLSocket);
procedure TCPClientError(const msg: string; aSocket: TLSocket);
procedure TCPClientReceive(aSocket: TLSocket);
procedure tmNoOpStartTimer(Sender: TObject);
procedure tmNoOpTimer(Sender: TObject);
protected
FSendQueue: TEnhancedMemoryStream;
FReceiveQueue: TEnhancedMemoryStream;
FUsername: string;
FPassword: string;
FAccessLevel: TAccessLevel;
FDataDir: string;
FLastPacket: TDateTime;
procedure OnCanSend(ASocket: TLSocket);
procedure OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
procedure ProcessQueue;
procedure DoLogin;
public
property Username: string read FUsername;
property AccessLevel: TAccessLevel read FAccessLevel write FAccessLevel;
procedure Send(APacket: TPacket);
procedure Disconnect;
procedure CheckClose(ASender: TForm);
end;
var
dmNetwork: TdmNetwork;
implementation
uses
UPacketHandlers, UPackets, UfrmMain, UfrmLogin, UfrmInitialize,
UGameResources, UfrmAccountControl, UfrmEditAccount, UfrmDrawSettings,
UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings,
UfrmAbout, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand,
UfrmVirtualLayer, UfrmFilter, UfrmRegionControl, UfrmLightlevel;
{$I version.inc}
{ TdmNetwork }
procedure TdmNetwork.DataModuleCreate(Sender: TObject);
begin
FSendQueue := TEnhancedMemoryStream.Create;
FReceiveQueue := TEnhancedMemoryStream.Create;
TCPClient.OnCanSend := @OnCanSend;
PacketHandlers[$02] := TPacketHandler.Create(0, @OnConnectionHandlingPacket);
DoLogin;
end;
procedure TdmNetwork.DataModuleDestroy(Sender: TObject);
begin
FreeAndNil(FSendQueue);
FreeAndNil(FReceiveQueue);
FreeAndNil(PacketHandlers[$02]);
end;
procedure TdmNetwork.TCPClientConnect(aSocket: TLSocket);
begin
FSendQueue.Clear;
FReceiveQueue.Clear;
end;
procedure TdmNetwork.TCPClientDisconnect(aSocket: TLSocket);
begin
FSendQueue.Clear;
FReceiveQueue.Clear;
DoLogin;
end;
procedure TdmNetwork.TCPClientError(const msg: string; aSocket: TLSocket);
begin
MessageDlg('Connection error', msg, mtError, [mbOK], 0);
if not TCPClient.Connected then
TCPClientDisconnect(aSocket);
end;
procedure TdmNetwork.TCPClientReceive(aSocket: TLSocket);
var
buffer: array[0..4095] of byte;
size: Integer;
begin
repeat
size := TCPClient.Get(buffer, 4096);
if size > 0 then
FReceiveQueue.Enqueue(buffer, size);
until size <= 0;
ProcessQueue;
end;
procedure TdmNetwork.tmNoOpStartTimer(Sender: TObject);
begin
FLastPacket := Now;
end;
procedure TdmNetwork.tmNoOpTimer(Sender: TObject);
begin
if SecondsBetween(FLastPacket, Now) > 25 then
Send(TNoOpPacket.Create);
end;
procedure TdmNetwork.OnCanSend(ASocket: TLSocket);
var
size: Integer;
begin
while FSendQueue.Size > 0 do
begin
FLastPacket := Now;
size := TCPClient.Send(FSendQueue.Memory^, FSendQueue.Size);
if size > 0 then
FSendQueue.Dequeue(size)
else
Break;
end;
end;
procedure TdmNetwork.OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
var
subID: Byte;
loginState: TLoginState;
width, height: Word;
serverState: TServerState;
begin
subID := ABuffer.ReadByte;
case subID of
$01:
begin
if ABuffer.ReadCardinal = ProtocolVersion then
begin
frmInitialize.lblStatus.Caption := 'Authenticating';
Send(TLoginRequestPacket.Create(FUsername, FPassword));
end else
begin
MessageDlg('Error', 'Invalid protocol version. Maybe your client is outdated.', mtError, [mbOK], 0);
Disconnect;
end;
end;
$03:
begin
loginState := TLoginState(ABuffer.ReadByte);
if loginState = lsOK then
begin
frmInitialize.lblStatus.Caption := 'Initializing';
frmInitialize.Repaint;
frmInitialize.lblStatus.Repaint;
Application.ProcessMessages;
FAccessLevel := TAccessLevel(ABuffer.ReadByte);
InitGameResourceManager(FDataDir);
width := ABuffer.ReadWord;
height := ABuffer.ReadWord;
ResMan.InitLandscape(width, height);
ResMan.Landscape.UpdateWriteMap(ABuffer);
frmMain := TfrmMain.Create(dmNetwork);
frmRadarMap := TfrmRadarMap.Create(frmMain);
frmLargeScaleCommand := TfrmLargeScaleCommand.Create(frmMain);
frmRegionControl := TfrmRegionControl.Create(frmMain);
frmAccountControl := TfrmAccountControl.Create(frmMain);
frmEditAccount := TfrmEditAccount.Create(frmAccountControl);
frmConfirmation := TfrmConfirmation.Create(frmMain);
frmDrawSettings := TfrmDrawSettings.Create(frmMain);
frmMoveSettings := TfrmMoveSettings.Create(frmMain);
frmElevateSettings := TfrmElevateSettings.Create(frmMain);
frmHueSettings := TfrmHueSettings.Create(frmMain);
frmBoundaries := TfrmBoundaries.Create(frmMain);
frmFilter := TfrmFilter.Create(frmMain);
frmVirtualLayer := TfrmVirtualLayer.Create(frmMain);
frmLightlevel := TfrmLightlevel.Create(frmMain);
frmAbout := TfrmAbout.Create(frmMain);
frmMain.Show;
frmInitialize.Hide;
tmNoOp.Enabled := True;
end else
begin
if loginState = lsInvalidUser then
MessageDlg('Error', 'The username you specified is incorrect.', mtWarning, [mbOK], 0)
else if loginState = lsInvalidPassword then
MessageDlg('Error', 'The password you specified is incorrect.', mtWarning, [mbOK], 0)
else if loginState = lsAlreadyLoggedIn then
MessageDlg('Error', 'There is already a client logged in using that account.', mtWarning, [mbOK], 0)
else if loginState = lsNoAccess then
MessageDlg('Error', 'This account has no access.', mtWarning, [mbOK], 0);
end;
end;
$04: //Server state
begin
serverState := TServerState(ABuffer.ReadByte);
if serverState = ssRunning then
begin
frmInitialize.UnsetModal;
frmInitialize.Hide;
tmNoOp.Enabled := True;
end else
begin
case serverState of
ssFrozen: frmInitialize.lblStatus.Caption := 'The server is currently paused.';
ssOther: frmInitialize.lblStatus.Caption := ABuffer.ReadStringNull
end;
tmNoOp.Enabled := False;
frmInitialize.Show;
frmInitialize.SetModal;
end;
end;
end;
end;
procedure TdmNetwork.ProcessQueue;
var
packetHandler: TPacketHandler;
size: Cardinal;
begin
FReceiveQueue.Position := 0;
while FReceiveQueue.Size >= 1 do
begin
packetHandler := PacketHandlers[FReceiveQueue.ReadByte];
if packetHandler <> nil then
begin
size := packetHandler.PacketLength;
if size = 0 then
begin
if FReceiveQueue.Size > 5 then
size := FReceiveQueue.ReadCardinal
else
Break; //wait for more data
end;
if FReceiveQueue.Size >= size then
begin
FReceiveQueue.Lock(FReceiveQueue.Position, size - FReceiveQueue.Position); //prevent handler from reading too much
packetHandler.Process(FReceiveQueue);
FReceiveQueue.Unlock;
FReceiveQueue.Dequeue(size);
end else
Break; //wait for more data
end else
begin
{Writeln('Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);}
Disconnect;
FReceiveQueue.Clear;
end;
end;
end;
procedure TdmNetwork.DoLogin;
begin
tmNoOp.Enabled := False;
frmLogin := TfrmLogin.Create(dmNetwork);
if frmInitialize = nil then
frmInitialize := TfrmInitialize.Create(dmNetwork);
FreeAndNil(frmEditAccount);
FreeAndNil(frmAccountControl);
FreeAndNil(frmConfirmation);
FreeAndNil(frmDrawSettings);
FreeAndNil(frmMoveSettings);
FreeAndNil(frmElevateSettings);
FreeAndNil(frmHueSettings);
FreeAndNil(frmBoundaries);
FreeAndNil(frmFilter);
FreeAndNil(frmVirtualLayer);
FreeAndNil(frmAbout);
FreeAndNil(frmRegionControl);
FreeAndNil(frmLargeScaleCommand);
FreeAndNil(frmRadarMap);
FreeAndNil(frmLightlevel);
if frmMain <> nil then
begin
frmMain.ApplicationProperties1.OnIdle := nil;
FreeAndNil(frmMain);
end;
FreeAndNil(GameResourceManager);
frmInitialize.Hide;
while frmLogin.ShowModal = mrOK do
begin
if TCPClient.Connect(frmLogin.edHost.Text, frmLogin.edPort.Value) then
begin
FUsername := frmLogin.edUsername.Text;
FPassword := frmLogin.edPassword.Text;
FDataDir := frmLogin.edData.Text;
frmInitialize.lblStatus.Caption := 'Connecting';
frmInitialize.Show;
Break;
end else
MessageDlg('Error', 'Cannot connect to the specified server.', mtError, [mbOK], 0);
end;
frmLogin.Close;
FreeAndNil(frmLogin);
end;
procedure TdmNetwork.Send(APacket: TPacket);
var
source: TEnhancedMemoryStream;
begin
if TCPClient.Connected then
begin
FSendQueue.Seek(0, soFromEnd);
source := APacket.Stream;
FSendQueue.CopyFrom(source, 0);
OnCanSend(nil);
end;
APacket.Free;
end;
procedure TdmNetwork.Disconnect;
begin
Send(TQuitPacket.Create);
end;
procedure TdmNetwork.CheckClose(ASender: TForm);
begin
if ((frmLogin = nil) or (ASender = frmLogin)) and
((frmMain = nil) or (ASender = frmMain)) and
((frmInitialize = nil) or (not frmInitialize.Visible)) then
begin
Application.Terminate;
end;
end;
initialization
{$I UdmNetwork.lrs}
end.

762
Client/UfrmAccountControl.lfm
View File

@ -1,381 +1,381 @@
object frmAccountControl: TfrmAccountControl
Left = 290
Height = 378
Top = 171
Width = 369
ActiveControl = vstAccounts
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Account Management'
ClientHeight = 378
ClientWidth = 369
Font.Height = -11
OnClose = FormClose
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
Position = poOwnerFormCenter
LCLVersion = '0.9.29'
object tbMain: TToolBar
Left = 0
Height = 26
Top = 0
Width = 369
Caption = 'tbMain'
Images = ilToolbar
TabOrder = 0
object tbRefresh: TToolButton
Left = 1
Hint = 'Refresh'
Top = 2
Caption = 'Refresh'
ImageIndex = 0
ParentShowHint = False
ShowHint = True
OnClick = tbRefreshClick
end
object tbAddUser: TToolButton
Left = 32
Hint = 'Add User'
Top = 2
Caption = 'Add User'
ImageIndex = 1
ParentShowHint = False
ShowHint = True
OnClick = tbAddUserClick
end
object tbEditUser: TToolButton
Left = 55
Hint = 'Edit User'
Top = 2
Caption = 'Edit User'
ImageIndex = 2
ParentShowHint = False
ShowHint = True
OnClick = tbEditUserClick
end
object tbDeleteUser: TToolButton
Left = 78
Hint = 'Delete User'
Top = 2
Caption = 'Delete User'
ImageIndex = 3
ParentShowHint = False
ShowHint = True
OnClick = tbDeleteUserClick
end
object tbSeparator1: TToolButton
Left = 24
Top = 2
Width = 8
Caption = 'tbSeparator1'
Style = tbsDivider
end
end
object vstAccounts: TVirtualStringTree
Left = 0
Height = 352
Top = 26
Width = 369
Align = alClient
DefaultText = 'Node'
Header.AutoSizeIndex = 1
Header.Columns = <
item
Position = 0
Width = 30
end
item
Position = 1
Text = 'Username'
Width = 200
end
item
Position = 2
Text = 'Accesslevel'
Width = 100
end>
Header.DefaultHeight = 17
Header.Options = [hoColumnResize, hoDrag, hoVisible]
Header.ParentFont = True
Header.Style = hsFlatButtons
Images = ilAccesslevel
TabOrder = 1
TreeOptions.AutoOptions = [toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
TreeOptions.MiscOptions = [toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]
TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toFullRowSelect]
OnDblClick = vstAccountsDblClick
OnFreeNode = vstAccountsFreeNode
OnGetText = vstAccountsGetText
OnGetImageIndex = vstAccountsGetImageIndex
end
object ilToolbar: TImageList
left = 144
Bitmap = {
4C69040000001000000010000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000047994FFF419149FF000000000000
0000000000000000000000000000000000000000000000000000000000005BB4
65FF56AD5FFF50A65AFF4B9E53FF45964DFF60A868FF5BA262FF347E3AFF0000
000000000000000000000000000000000000000000005EB968FF79C383FF89CA
92FF94D09CFF95D19EFF90CF99FF8CCB94FF87C98FFF80C487FF4E9554FF276D
2CFF000000000000000000000000000000005CB667FF85C98EFF9BD4A4FF8FCE
98FF92CF9AFF8DCC95FF88CA90FF83C68BFF7EC485FF79C17FFF478D4CFF2265
25FF0000000000000000000000000000000075BF7EFF98D2A1FF94CF9CFF86C7
8DFF5EA765FF398640FF347E3AFF2E7633FF49904FFF458B4AFF206324FF0000
000000000000000000000000000054AB5EFF80C389FF8DCC95FF83C48AFF3D8B
44FF37833EFF000000000000000000000000236627FF1F6123FF000000000000
00000000000000000000000000004DA155FF47994FFF419149FF3B8842FF3580
3CFF000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000004DA155FF4799
4FFF419149FF3B8842FF35803CFF000000000000000000000000000000000000
000063C06EFF5FBB6AFF0000000000000000000000004B9E53FF45964DFF86C6
8EFF88C98FFF6FB376FF2E7633FF0000000000000000000000000000000062BE
6DFF7BC785FF77C281FF54AB5EFF4EA357FF499B51FF63AC6BFF83C38BFF87C9
8FFF82C689FF509756FF0000000000000000000000000000000060BC6CFF79C4
83FF9ED7A7FF9BD4A4FF97D29FFF92CF9AFF8DCC95FF88CA90FF7AC282FF7EC4
85FF5DA463FF266B2AFF000000000000000000000000000000005BB465FF73BD
7CFF96D19FFF94CF9CFF8FCD96FF8ACA91FF85C78BFF7ABE81FF65AD6CFF4B92
51FF246829FF0000000000000000000000000000000000000000000000004EA3
57FF66B06EFF61AA68FF3D8B44FF37833EFF327B37FF2C7432FF276D2CFF0000
0000000000000000000000000000000000000000000000000000000000000000
0000419149FF3B8842FF00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000012488DFF104B90FF0F488AFF11427DFF15335BFF000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000114E96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF0000
0000000000000000000000000000000000000000000000000000000000000F4B
97FF12589FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF0000
0000000000000000000000000000000000000000000000000000000000000C3E
87FF7C97B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF0000
0000000000000000000000000000000000000000000000000000000000001F5E
9BFFD9E8F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000
0000000000000000000000000000000000000000000000000000000000002A5B
92FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D629AFF0000
0000000000000000000000000000000000000000000000000000000000006A3C
25FF346DA7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF3474AEFF683E2DFF0000
000000000000000000000000000000000000000000000000000000000000BC48
1CFFF4E2D4FF4E7BA9FF4D7BA8FF4D7BA8FF4E7BA9FFF3D6C3FFBE461CFF0000
0000000000000000000000000000000000000000000000000000C44C1FFFF6E4
D6FFFFE4A4FFFFD472FFFFC969FFFFC063FFFFB65FFFAEAB78FF609772FF4F8E
66FF428357FF000000000000000000000000000000008A5444FFFCC8ABFFFFD1
98FFFEC76DFFFEBF68FFFEB964FFFEB15EFFA79B61FF61AB81FF95D4B4FFBAE6
D0FF6ABB8FFF2D8F57FF196B37FF00000000287CCEFF78B3EAFFB39E94FFFFB7
60FFFFB663FFFEB261FFFEAC5DFFFEA559FF4A885DFF90D3B1FF92D6B1FFFFFF
FFFF65BC8CFF67BC8FFF196B37FF00000000297DD1FF82BAEEFF9F6658FFF5BB
84FFFFAC5BFFFEA85AFFFEA257FFFE9C53FF317B4CFF9CD4B6FFFFFFFFFFFFFF
FFFFFFFFFFFF95D2B2FF196B37FF00000000000000002579CDFF866161FFBF60
35FFFEB961FFFEB962FFFEB962FFFEB962FF226E3AFF62BA8BFF60BA87FFFFFF
FFFF60B987FF67BC8FFF196B37FF00000000000000000000000000000000B350
20FFA0401FFFAA4522FFAC4622FFAB4422FF5C572DFF288C53FF64BA8DFF95D2
B2FF64BA8DFF288C53FF196B37FF000000000000000000000000000000000000
00000000000000000000000000000000000000000000196B37FF196B37FF196B
37FF196B37FF196B37FF00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000012488DFF104B90FF0F488AFF11427DFF15335BFF00000000000000000000
000000000000000000000000000000000000000000000000000000000000114E
96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF000000000000
00000000000000000000000000000000000000000000000000000F4B97FF1258
9FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF000000000000
00000000000000000000000000000000000000000000000000000C3E87FF7C97
B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF000000000000
00000000000000000000000000000000000000000000000000001F5E9BFFD9E8
F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000000058A5
D8FF85B1DBFF469DD0FF000000000000000000000000000000002A5B92FFA6CA
EEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2884B7FF77BEE7FFB4D2
F0FFE5F3FFFFACD2EFFF488CC7FF0000000000000000000000006A3C25FF346D
A7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF2E8ABFFF7ED3EBFFB2E3F9FF8BC0
E7FFAED3F6FFC4E0FCFF669FD3FF000000000000000000000000BC481CFFF4E2
D4FF4E7BA9FF4D7BA8FF4D7BA8FF428CBAFF7DD4EEFFC4F6FDFF6CDDF6FF6DCA
EDFF63A3D7FF5D9BD2FF000000000000000000000000C44C1FFFF6E4D6FFFFE4
A4FFFFD472FFFFC969FFBFBB86FF79D3EEFFC7F7FDFF5FDCF5FF5BE2F7FF7AD6
F2FF4099DFFF0000000000000000000000008A5444FFFCC8ABFFFFD198FFFEC7
6DFFFEBF68FFB0A780FF77CBE7FFC7F7FDFF5EDCF5FF5AE1F7FF7BD4F1FF4691
D4FF686672FF0000000000000000287CCEFF78B3EAFFB39E94FFFFB760FFFFB6
63FFB3A37DFF76B8D3FFC2F6FDFF63DFF7FF5DE2F8FF79D3F0FF4795D8FF75B2
EAFF2974C7FF0000000000000000297DD1FF82BAEEFF9F6658FFF5BB84FFA792
74FF7AB6D5FF90B7D1FF55C9E4FF5BDFF5FF78D0EDFF5196D2FF96645DFF83BC
EFFF2A77CAFF0000000000000000000000002579CDFF866161FFBF6035FF4389
AAFFE0F2FFFF549AD8FF1A7ABEFF4998C5FF4988B7FF9C5442FF7A646DFF2E7E
CEFF6DA2D3FF0000000000000000000000000000000000000000B35020FF2D64
81FF94C7F9FF91C9F9FF4185C9FF2362A4FF89493DFFB24F24FF000000000000
000000000000000000000000000000000000000000000000000000000000113D
55FF285F87FF4988BDFF428DBCFF000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000012488DFF104B90FF0F488AFF11427DFF15335BFF000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000114E96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF0000
0000000000000000000000000000000000000000000000000000000000000F4B
97FF12589FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF0000
0000000000000000000000000000000000000000000000000000000000000C3E
87FF7C97B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF0000
0000000000000000000000000000000000000000000000000000000000001F5E
9BFFD9E8F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000
0000000000000000000000000000000000000000000000000000000000002A5B
92FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D629AFF0000
0000000000000000000000000000000000000000000000000000000000006A3C
25FF346DA7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF3474AEFF683E2DFF0000
000000000000000000000000000000000000000000000000000000000000BC48
1CFFF4E2D4FF4E7BA9FF4D7BA8FF4D7BA8FF4E7BA9FFF3D6C3FFBE461CFF0000
0000000000000000000000000000000000000000000000000000C44C1FFFF6E4
D6FFFFE4A4FFFFD472FFFFC969FFFFC063FFFFB65FFF9590A0FF295DC1FF0542
BBFF0B45B0FF000000000000000000000000000000008A5444FFFCC8ABFFFFD1
98FFFEC76DFFFEBF68FFFEB964FFFEB15EFF95828BFF3D74CEFF8DB5F7FFB8D6
FEFF72A8F5FF2D6BCAFF0000000000000000287CCEFF78B3EAFFB39E94FFFFB7
60FFFFB663FFFEB261FFFEAC5DFFFEA559FF2450ABFF8DB5F6FF4D92FFFF1177
FFFF2186FFFF408AEBFF0344B9FF00000000297DD1FF82BAEEFF9F6658FFF5BB
84FFFFAC5BFFFEA85AFFFEA257FFFE9C53FF0542BCFFAECDFEFFFFFFFFFFFFFF
FFFFFFFFFFFF187FEFFF0442BCFF00000000000000002579CDFF866161FFBF60
35FFFEB961FFFEB962FFFEB962FFFEB962FF1F52AFFF639DF4FF187FFFFF0076
F8FF0076EEFF0368E1FF0345B9FF00000000000000000000000000000000B350
20FFA0401FFFAA4522FFAC4622FFAB4422FF5F4C74FF2763C6FF2177E6FF0579
EAFF0164DDFF044DBDFF00000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000345B9FF0442
BCFF0345B9FF0000000000000000
}
end
object ilAccesslevel: TImageList
left = 176
Bitmap = {
4C69040000001000000010000000000000000000000000000000000000000000
0000A3A3A3FFA0A0A0FF9D9D9DFF9A9A9AFF979797FF949494FF000000000000
000000000000000000000000000000000000000000000000000000000000A2A2
A2FFBCBCBCFFCACACAFFCCCCCCFFCACACAFFC2C2C2FFADADADFF8C8C8CFF0000
0000000000000000000000000000000000000000000000000000A1A1A1FFC4C4
C4FFBEBEBEFFA1A1A1FF969696FF939393FF979797FFAEAEAEFFAEAEAEFF8484
84FF000000000000000000000000000000000000000000000000BABABAFFBFBF
BFFF989898FF00000000000000000000000000000000878787FFA8A8A8FF9E9E
9EFF00000000000000000000000000000000000000009D9D9DFFC4C4C4FFA1A1
A1FF000000000000000000000000000000000000000000000000898989FFA9A9
A9FF797979FF00000000000000000000000000000000999999FFC6C6C6FF9494
94FF0000000000000000000000000000000000000000000000007D7D7DFFABAB
ABFF767676FF00000000000000000000000061C3E1FF88A0A8FF919191FF8E8E
8EFF5AB9DCFF55B8DFFF51B5DEFF4DB1DDFF49ADDCFF46A8D7FF787878FF7676
76FF657E8DFF3199D8FF000000000000000060C2E1FFC9F3FCFFCBF3FDFFD4F6
FEFFD7F6FFFFD8F4FFFFE0F8FFFFDFF8FFFFDAF5FFFFCDF1FCFFC2EDFAFFBDEB
FAFFBDEBFAFF2B93D6FF00000000000000005CBFE0FFC8F3FCFF75DFF9FF89E6
FDFF95E7FFFF9AE5FFFFAAEEFFFFA8EDFFFF99E3FFFF74D5F9FF59CCF3FF4FC8
F1FFBBE9FAFF248DD5FF000000000000000058BBDFFFC7F1FCFF6FDCF9FF56BB
EDFF61BDEFFF9BE7FFFF35A6E2FF4BA4E1FF90E2FFFF49ADE9FF38A4E3FF49C4
F0FFB8E8F9FF1E88D4FF000000000000000053B7DEFFC6F0FCFF6AD9F8FF7CE2
FDFF90E8FFFF99E9FFFF329FDFFF548BB2FF8AE2FFFF6AD0F9FF50C5F1FF46C1
F0FFB6E7F9FF1883D3FF00000000000000004EB2DDFFC3EFFBFF65D6F8FF4CB6
ECFF5ABDEFFF95EBFFFF3097DDFF4D82ABFF84E1FFFF41A9E9FF329FE1FF42BE
EFFFB4E5F9FF137ED2FF000000000000000049ADDCFFC1EEFBFF5FD3F7FF6CDB
FCFF7FE5FFFF8FEDFFFF97F2FFFF93EDFFFF7CDFFFFF5BCCF8FF46BEEFFF3CBA
EEFFB3E3F9FF0E79D1FF000000000000000043A8DBFFBFECFBFF59CFF5FF41B0
ECFF4EBAEFFF5AC2EFFF60C6EFFF5CC4EFFF4CB6EFFF37A5E6FF2A9AE1FF38B8
EEFFB1E3F8FF0975D0FF00000000000000003DA3DAFFBCEBFAFFBCEBFCFFBFEE
FEFFC6F4FFFFCEF8FFFFD3FAFFFFD0F8FFFFC7F2FFFFBAE9FCFFB3E4F9FFB0E2
F8FFB0E2F8FF0571CFFF0000000000000000369DD9FF3199D8FF2C94D7FF2890
D6FF238CD5FF1E88D4FF1A84D3FF1580D2FF117CD1FF0E79D1FF0A76D0FF0773
CFFF0470CFFF016ECEFF00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000565D68FF133F7AFF0D3E7DFF0C3C76FF123969FF4E5663FF000000000000
0000000000000000000000000000000000000000000000000000000000005F63
69FF284D7DFF2D6196FF0F4988FF2C6093FF0C3E73FF1B3D60FF595E63FF0000
0000000000000000000000000000000000000000000000000000000000003752
79FF255A93FF0C3E76FF245485FF0E3E73FF265584FF163E69FF143050FF0000
0000000000000000000000000000000000000000000000000000000000001136
67FF2A4B71FF4C759EFF3B638EFF11355BFF28527BFF1C3959FF103255FF0000
0000000000000000000000000000000000000000000000000000000000001848
78FF9BB7D1FFA3C9EDFF9FC5E8FF74A1CDFF81B0DDFF96B3CEFF1A4C7EFF0000
000000000000000000000000000000000000000000000000000000000000305D
8FFFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2E629AFF0000
0000000000000000000000000000000000000000000000000000000000003D3D
3DFF416F9EFF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF4176A6FF373737FF0000
0000000000000000000000000000000000000000000000000000494949FF4B4B
4BFF989898FF5C5C5CFF557CA3FF557CA3FF4C4C4CFF989898FF4E4E4EFF4C4C
4CFF0000000000000000000000000000000000000000777777FF4C4C4CFF4E4E
4EFF979797FF595959FFABABABFFA5A5A5FF545454FF868686FF626262FF4A4A
4AFF0000000000000000000000000000000000000000636363FFA4A4A4FF5050
50FF525252FF5B5B5BFFB8B8B8FFC1C1C1FF575757FF4D4D4DFF5A5A5AFF7E7E
7EFF606060FF000000000000000000000000287CCEFF78B3EAFF7A7A7AFF8383
83FF7E7E7EFF5D5D5DFF494949FF4C4C4CFF555555FF646464FF5F5F5FFF6D6D
6DFF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFF5F5F5FFF8F8F
8FFF7A7A7AFF777777FF6D6D6DFF4E4E4EFF727272FF6F6F6FFF848484FF5555
55FF83BCEFFF2A77CAFF0000000000000000000000002579CDFF5E5E5EFF4F4F
4FFF848484FF848484FF808080FF545454FF838383FF848484FF4A4A4AFF4545
45FF2E7ECEFF6DA2D3FF00000000000000000000000000000000000000003D3D
3DFF4D4D4DFF494949FF474747FF474747FF454545FF474747FF383838FF0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000027B2E5FF1BA7F3FF1CACF4FF1CA8F4FF1BA1F1FF27ACDEFF000000000000
00000000000000000000000000000000000000000000000000000000000028B5
E5FF1BB6F5FF1CB6F5FF1CB6F5FF1CB2F5FF1CABF4FF1DAAF0FF28B0E0FF0000
0000000000000000000000000000000000000000000000000000000000001DBA
F5FF1CB6F5FF1CAAF4FF1CACF4FF1CACF4FF1CACF3FF1CA1F0FF1C93E4FF0000
0000000000000000000000000000000000000000000000000000000000001B9E
F3FF62ABCEFF8AB7E4FF3EC6EBFF1C9FEDFF1DA4EEFF1EA5EBFF1C9AE9FF0000
0000000000000000000000000000000000000000000000000000000000001E6D
ADFFBDD7EFFFA3C9EDFF9DC5E8FF44CEEFFF5BCDEFFFA8DCF1FF207CBDFF0000
0000000000000000000000000000000000000000000000000000000000002C61
8EFFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D6299FF0000
0000000000000000000000000000000000000000000000000000000000004C72
49FF347499FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF357AA1FF4A6A46FF0000
000000000000000000000000000000000000000000000000000079935DFF2785
4EFFB3F5C8FF49898FFF4B7FA0FF4B7FA0FF49898FFFA9E8BAFF26844DFF738C
59FF0000000000000000000000000000000000000000AFE0ACFF37945DFF9FFD
C6FF91EFB8FF78D69FFF6FCD96FF69C68FFF62BF88FF73CF98FF94F0B9FF3088
51FF788754FF000000000000000000000000849D6CFF45A26BFF82E0A9FF82E0
A9FF6FCD96FF69C790FF64C28BFF5EBC85FF57B57EFF50AE77FF6BC891FF67C0
8AFF4F9A66FF769264FF0000000000000000287CCEFF78B3EAFF5AB881FF62C0
89FF62C089FF5FBD86FF5AB881FF55B37CFF4FAD76FF49A770FF419E67FF4DAB
74FF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFF409E67FF6ECC
95FF5BB881FF58B57EFF53B17AFF4FAC75FF54B17AFF51AD76FF67C18AFF3B92
5CFF83BCEFFF2A77CAFF0000000000000000000000002579CDFF429D67FF318F
58FF63C18AFF63C18AFF63C18AFF63C18AFF63C18AFF63C18AFF2D8A53FF2F88
53FF2E7ECEFF6DA2D3FF0000000000000000000000000000000000000000668C
57FF428B55FF338952FF2E8851FF2D8750FF2E854EFF39854EFF4F824EFF0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000565D68FF133F7AFF0D3E7DFF0C3C76FF123969FF4E5663FF000000000000
0000000000000000000000000000000000000000000000000000000000005F63
69FF284D7DFF0F498AFF0F4988FF0E4581FF0C3E73FF1B3D60FF595E63FF0000
0000000000000000000000000000000000000000000000000000000000003752
79FF0F498FFF0C3E76FF0C3E73FF0E3E73FF113F70FF0F3661FF143050FF0000
0000000000000000000000000000000000000000000000000000000000001037
73FF7893B5FF8AB7E4FF6793C3FF11355BFF15395FFF1C3959FF103255FF0000
0000000000000000000000000000000000000000000000000000000000001F5C
99FFBDD7EFFFA3C9EDFF9FC5E8FF74A1CDFF81B0DDFFB7D3EBFF2365A4FF0000
000000000000000000000000000000000000000000000000000000000000395F
89FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2F6299FF0000
000000000000000000000000000000000000000000000000000000000000966B
3EFF537291FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF51799AFF8C643CFF0000
0000000000000000000000000000000000000000000000000000A57645FFB17D
3FFFD8BEA0FF968271FF5572A4FF435EB5FFA2795FFFD9BEA0FFB48042FFA875
46FF0000000000000000000000000000000000000000C29A70FFB27D41FFB480
42FFDCBF9EFFBE8A4CFFC4B6BCFF5E67C8FFB3814DFFD3B088FFC29159FFAF7A
3EFF9F6F41FF000000000000000000000000A5774AFFC3925BFFE2CAB0FFB682
44FFB78345FFB88855FF4A5BD0FF5060D2FFBA874CFFB37F41FFBF8A4EFFD0A9
7DFFBE8D57FF9C6F46FF0000000000000000287CCEFF78B3EAFFCEA679FFD2AE
83FFD0A97DFFB78859FF4D4EA6FF77627CFFB6844BFFC4935CFFC18E55FFC79A
67FF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFFC18F55FFD8B9
94FFCEA678FFCCA375FFBA9370FFB27F44FFCA9F6EFFC89C69FFD3AE85FFB884
49FF83BCEFFF2A77CAFF0000000000000000000000002579CDFFC08E54FFB581
43FFD3AF85FFD3AF85FFD1AB7FFFB98547FFD2AE83FFD3AF85FFB07B3FFFA976
3CFF2E7ECEFF6DA2D3FF00000000000000000000000000000000000000009966
34FFAF7A41FFAE793DFFAD783CFFAD783CFFAA7539FFAA753CFF936131FF0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000
}
end
end
object frmAccountControl: TfrmAccountControl
Left = 290
Height = 378
Top = 171
Width = 369
ActiveControl = vstAccounts
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Account Management'
ClientHeight = 378
ClientWidth = 369
Font.Height = -11
OnClose = FormClose
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
Position = poOwnerFormCenter
LCLVersion = '0.9.29'
object tbMain: TToolBar
Left = 0
Height = 26
Top = 0
Width = 369
Caption = 'tbMain'
Images = ilToolbar
TabOrder = 0
object tbRefresh: TToolButton
Left = 1
Hint = 'Refresh'
Top = 2
Caption = 'Refresh'
ImageIndex = 0
ParentShowHint = False
ShowHint = True
OnClick = tbRefreshClick
end
object tbAddUser: TToolButton
Left = 32
Hint = 'Add User'
Top = 2
Caption = 'Add User'
ImageIndex = 1
ParentShowHint = False
ShowHint = True
OnClick = tbAddUserClick
end
object tbEditUser: TToolButton
Left = 55
Hint = 'Edit User'
Top = 2
Caption = 'Edit User'
ImageIndex = 2
ParentShowHint = False
ShowHint = True
OnClick = tbEditUserClick
end
object tbDeleteUser: TToolButton
Left = 78
Hint = 'Delete User'
Top = 2
Caption = 'Delete User'
ImageIndex = 3
ParentShowHint = False
ShowHint = True
OnClick = tbDeleteUserClick
end
object tbSeparator1: TToolButton
Left = 24
Top = 2
Width = 8
Caption = 'tbSeparator1'
Style = tbsDivider
end
end
object vstAccounts: TVirtualStringTree
Left = 0
Height = 352
Top = 26
Width = 369
Align = alClient
DefaultText = 'Node'
Header.AutoSizeIndex = 1
Header.Columns = <
item
Position = 0
Width = 30
end
item
Position = 1
Text = 'Username'
Width = 200
end
item
Position = 2
Text = 'Accesslevel'
Width = 100
end>
Header.DefaultHeight = 17
Header.Options = [hoColumnResize, hoDrag, hoVisible]
Header.ParentFont = True
Header.Style = hsFlatButtons
Images = ilAccesslevel
TabOrder = 1
TreeOptions.AutoOptions = [toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
TreeOptions.MiscOptions = [toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]
TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toFullRowSelect]
OnDblClick = vstAccountsDblClick
OnFreeNode = vstAccountsFreeNode
OnGetText = vstAccountsGetText
OnGetImageIndex = vstAccountsGetImageIndex
end
object ilToolbar: TImageList
left = 144
Bitmap = {
4C69040000001000000010000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000047994FFF419149FF000000000000
0000000000000000000000000000000000000000000000000000000000005BB4
65FF56AD5FFF50A65AFF4B9E53FF45964DFF60A868FF5BA262FF347E3AFF0000
000000000000000000000000000000000000000000005EB968FF79C383FF89CA
92FF94D09CFF95D19EFF90CF99FF8CCB94FF87C98FFF80C487FF4E9554FF276D
2CFF000000000000000000000000000000005CB667FF85C98EFF9BD4A4FF8FCE
98FF92CF9AFF8DCC95FF88CA90FF83C68BFF7EC485FF79C17FFF478D4CFF2265
25FF0000000000000000000000000000000075BF7EFF98D2A1FF94CF9CFF86C7
8DFF5EA765FF398640FF347E3AFF2E7633FF49904FFF458B4AFF206324FF0000
000000000000000000000000000054AB5EFF80C389FF8DCC95FF83C48AFF3D8B
44FF37833EFF000000000000000000000000236627FF1F6123FF000000000000
00000000000000000000000000004DA155FF47994FFF419149FF3B8842FF3580
3CFF000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000004DA155FF4799
4FFF419149FF3B8842FF35803CFF000000000000000000000000000000000000
000063C06EFF5FBB6AFF0000000000000000000000004B9E53FF45964DFF86C6
8EFF88C98FFF6FB376FF2E7633FF0000000000000000000000000000000062BE
6DFF7BC785FF77C281FF54AB5EFF4EA357FF499B51FF63AC6BFF83C38BFF87C9
8FFF82C689FF509756FF0000000000000000000000000000000060BC6CFF79C4
83FF9ED7A7FF9BD4A4FF97D29FFF92CF9AFF8DCC95FF88CA90FF7AC282FF7EC4
85FF5DA463FF266B2AFF000000000000000000000000000000005BB465FF73BD
7CFF96D19FFF94CF9CFF8FCD96FF8ACA91FF85C78BFF7ABE81FF65AD6CFF4B92
51FF246829FF0000000000000000000000000000000000000000000000004EA3
57FF66B06EFF61AA68FF3D8B44FF37833EFF327B37FF2C7432FF276D2CFF0000
0000000000000000000000000000000000000000000000000000000000000000
0000419149FF3B8842FF00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000012488DFF104B90FF0F488AFF11427DFF15335BFF000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000114E96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF0000
0000000000000000000000000000000000000000000000000000000000000F4B
97FF12589FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF0000
0000000000000000000000000000000000000000000000000000000000000C3E
87FF7C97B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF0000
0000000000000000000000000000000000000000000000000000000000001F5E
9BFFD9E8F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000
0000000000000000000000000000000000000000000000000000000000002A5B
92FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D629AFF0000
0000000000000000000000000000000000000000000000000000000000006A3C
25FF346DA7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF3474AEFF683E2DFF0000
000000000000000000000000000000000000000000000000000000000000BC48
1CFFF4E2D4FF4E7BA9FF4D7BA8FF4D7BA8FF4E7BA9FFF3D6C3FFBE461CFF0000
0000000000000000000000000000000000000000000000000000C44C1FFFF6E4
D6FFFFE4A4FFFFD472FFFFC969FFFFC063FFFFB65FFFAEAB78FF609772FF4F8E
66FF428357FF000000000000000000000000000000008A5444FFFCC8ABFFFFD1
98FFFEC76DFFFEBF68FFFEB964FFFEB15EFFA79B61FF61AB81FF95D4B4FFBAE6
D0FF6ABB8FFF2D8F57FF196B37FF00000000287CCEFF78B3EAFFB39E94FFFFB7
60FFFFB663FFFEB261FFFEAC5DFFFEA559FF4A885DFF90D3B1FF92D6B1FFFFFF
FFFF65BC8CFF67BC8FFF196B37FF00000000297DD1FF82BAEEFF9F6658FFF5BB
84FFFFAC5BFFFEA85AFFFEA257FFFE9C53FF317B4CFF9CD4B6FFFFFFFFFFFFFF
FFFFFFFFFFFF95D2B2FF196B37FF00000000000000002579CDFF866161FFBF60
35FFFEB961FFFEB962FFFEB962FFFEB962FF226E3AFF62BA8BFF60BA87FFFFFF
FFFF60B987FF67BC8FFF196B37FF00000000000000000000000000000000B350
20FFA0401FFFAA4522FFAC4622FFAB4422FF5C572DFF288C53FF64BA8DFF95D2
B2FF64BA8DFF288C53FF196B37FF000000000000000000000000000000000000
00000000000000000000000000000000000000000000196B37FF196B37FF196B
37FF196B37FF196B37FF00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000012488DFF104B90FF0F488AFF11427DFF15335BFF00000000000000000000
000000000000000000000000000000000000000000000000000000000000114E
96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF000000000000
00000000000000000000000000000000000000000000000000000F4B97FF1258
9FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF000000000000
00000000000000000000000000000000000000000000000000000C3E87FF7C97
B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF000000000000
00000000000000000000000000000000000000000000000000001F5E9BFFD9E8
F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000000058A5
D8FF85B1DBFF469DD0FF000000000000000000000000000000002A5B92FFA6CA
EEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2884B7FF77BEE7FFB4D2
F0FFE5F3FFFFACD2EFFF488CC7FF0000000000000000000000006A3C25FF346D
A7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF2E8ABFFF7ED3EBFFB2E3F9FF8BC0
E7FFAED3F6FFC4E0FCFF669FD3FF000000000000000000000000BC481CFFF4E2
D4FF4E7BA9FF4D7BA8FF4D7BA8FF428CBAFF7DD4EEFFC4F6FDFF6CDDF6FF6DCA
EDFF63A3D7FF5D9BD2FF000000000000000000000000C44C1FFFF6E4D6FFFFE4
A4FFFFD472FFFFC969FFBFBB86FF79D3EEFFC7F7FDFF5FDCF5FF5BE2F7FF7AD6
F2FF4099DFFF0000000000000000000000008A5444FFFCC8ABFFFFD198FFFEC7
6DFFFEBF68FFB0A780FF77CBE7FFC7F7FDFF5EDCF5FF5AE1F7FF7BD4F1FF4691
D4FF686672FF0000000000000000287CCEFF78B3EAFFB39E94FFFFB760FFFFB6
63FFB3A37DFF76B8D3FFC2F6FDFF63DFF7FF5DE2F8FF79D3F0FF4795D8FF75B2
EAFF2974C7FF0000000000000000297DD1FF82BAEEFF9F6658FFF5BB84FFA792
74FF7AB6D5FF90B7D1FF55C9E4FF5BDFF5FF78D0EDFF5196D2FF96645DFF83BC
EFFF2A77CAFF0000000000000000000000002579CDFF866161FFBF6035FF4389
AAFFE0F2FFFF549AD8FF1A7ABEFF4998C5FF4988B7FF9C5442FF7A646DFF2E7E
CEFF6DA2D3FF0000000000000000000000000000000000000000B35020FF2D64
81FF94C7F9FF91C9F9FF4185C9FF2362A4FF89493DFFB24F24FF000000000000
000000000000000000000000000000000000000000000000000000000000113D
55FF285F87FF4988BDFF428DBCFF000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000012488DFF104B90FF0F488AFF11427DFF15335BFF000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000114E96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF0000
0000000000000000000000000000000000000000000000000000000000000F4B
97FF12589FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF0000
0000000000000000000000000000000000000000000000000000000000000C3E
87FF7C97B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF0000
0000000000000000000000000000000000000000000000000000000000001F5E
9BFFD9E8F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000
0000000000000000000000000000000000000000000000000000000000002A5B
92FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D629AFF0000
0000000000000000000000000000000000000000000000000000000000006A3C
25FF346DA7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF3474AEFF683E2DFF0000
000000000000000000000000000000000000000000000000000000000000BC48
1CFFF4E2D4FF4E7BA9FF4D7BA8FF4D7BA8FF4E7BA9FFF3D6C3FFBE461CFF0000
0000000000000000000000000000000000000000000000000000C44C1FFFF6E4
D6FFFFE4A4FFFFD472FFFFC969FFFFC063FFFFB65FFF9590A0FF295DC1FF0542
BBFF0B45B0FF000000000000000000000000000000008A5444FFFCC8ABFFFFD1
98FFFEC76DFFFEBF68FFFEB964FFFEB15EFF95828BFF3D74CEFF8DB5F7FFB8D6
FEFF72A8F5FF2D6BCAFF0000000000000000287CCEFF78B3EAFFB39E94FFFFB7
60FFFFB663FFFEB261FFFEAC5DFFFEA559FF2450ABFF8DB5F6FF4D92FFFF1177
FFFF2186FFFF408AEBFF0344B9FF00000000297DD1FF82BAEEFF9F6658FFF5BB
84FFFFAC5BFFFEA85AFFFEA257FFFE9C53FF0542BCFFAECDFEFFFFFFFFFFFFFF
FFFFFFFFFFFF187FEFFF0442BCFF00000000000000002579CDFF866161FFBF60
35FFFEB961FFFEB962FFFEB962FFFEB962FF1F52AFFF639DF4FF187FFFFF0076
F8FF0076EEFF0368E1FF0345B9FF00000000000000000000000000000000B350
20FFA0401FFFAA4522FFAC4622FFAB4422FF5F4C74FF2763C6FF2177E6FF0579
EAFF0164DDFF044DBDFF00000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000345B9FF0442
BCFF0345B9FF0000000000000000
}
end
object ilAccesslevel: TImageList
left = 176
Bitmap = {
4C69040000001000000010000000000000000000000000000000000000000000
0000A3A3A3FFA0A0A0FF9D9D9DFF9A9A9AFF979797FF949494FF000000000000
000000000000000000000000000000000000000000000000000000000000A2A2
A2FFBCBCBCFFCACACAFFCCCCCCFFCACACAFFC2C2C2FFADADADFF8C8C8CFF0000
0000000000000000000000000000000000000000000000000000A1A1A1FFC4C4
C4FFBEBEBEFFA1A1A1FF969696FF939393FF979797FFAEAEAEFFAEAEAEFF8484
84FF000000000000000000000000000000000000000000000000BABABAFFBFBF
BFFF989898FF00000000000000000000000000000000878787FFA8A8A8FF9E9E
9EFF00000000000000000000000000000000000000009D9D9DFFC4C4C4FFA1A1
A1FF000000000000000000000000000000000000000000000000898989FFA9A9
A9FF797979FF00000000000000000000000000000000999999FFC6C6C6FF9494
94FF0000000000000000000000000000000000000000000000007D7D7DFFABAB
ABFF767676FF00000000000000000000000061C3E1FF88A0A8FF919191FF8E8E
8EFF5AB9DCFF55B8DFFF51B5DEFF4DB1DDFF49ADDCFF46A8D7FF787878FF7676
76FF657E8DFF3199D8FF000000000000000060C2E1FFC9F3FCFFCBF3FDFFD4F6
FEFFD7F6FFFFD8F4FFFFE0F8FFFFDFF8FFFFDAF5FFFFCDF1FCFFC2EDFAFFBDEB
FAFFBDEBFAFF2B93D6FF00000000000000005CBFE0FFC8F3FCFF75DFF9FF89E6
FDFF95E7FFFF9AE5FFFFAAEEFFFFA8EDFFFF99E3FFFF74D5F9FF59CCF3FF4FC8
F1FFBBE9FAFF248DD5FF000000000000000058BBDFFFC7F1FCFF6FDCF9FF56BB
EDFF61BDEFFF9BE7FFFF35A6E2FF4BA4E1FF90E2FFFF49ADE9FF38A4E3FF49C4
F0FFB8E8F9FF1E88D4FF000000000000000053B7DEFFC6F0FCFF6AD9F8FF7CE2
FDFF90E8FFFF99E9FFFF329FDFFF548BB2FF8AE2FFFF6AD0F9FF50C5F1FF46C1
F0FFB6E7F9FF1883D3FF00000000000000004EB2DDFFC3EFFBFF65D6F8FF4CB6
ECFF5ABDEFFF95EBFFFF3097DDFF4D82ABFF84E1FFFF41A9E9FF329FE1FF42BE
EFFFB4E5F9FF137ED2FF000000000000000049ADDCFFC1EEFBFF5FD3F7FF6CDB
FCFF7FE5FFFF8FEDFFFF97F2FFFF93EDFFFF7CDFFFFF5BCCF8FF46BEEFFF3CBA
EEFFB3E3F9FF0E79D1FF000000000000000043A8DBFFBFECFBFF59CFF5FF41B0
ECFF4EBAEFFF5AC2EFFF60C6EFFF5CC4EFFF4CB6EFFF37A5E6FF2A9AE1FF38B8
EEFFB1E3F8FF0975D0FF00000000000000003DA3DAFFBCEBFAFFBCEBFCFFBFEE
FEFFC6F4FFFFCEF8FFFFD3FAFFFFD0F8FFFFC7F2FFFFBAE9FCFFB3E4F9FFB0E2
F8FFB0E2F8FF0571CFFF0000000000000000369DD9FF3199D8FF2C94D7FF2890
D6FF238CD5FF1E88D4FF1A84D3FF1580D2FF117CD1FF0E79D1FF0A76D0FF0773
CFFF0470CFFF016ECEFF00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000565D68FF133F7AFF0D3E7DFF0C3C76FF123969FF4E5663FF000000000000
0000000000000000000000000000000000000000000000000000000000005F63
69FF284D7DFF2D6196FF0F4988FF2C6093FF0C3E73FF1B3D60FF595E63FF0000
0000000000000000000000000000000000000000000000000000000000003752
79FF255A93FF0C3E76FF245485FF0E3E73FF265584FF163E69FF143050FF0000
0000000000000000000000000000000000000000000000000000000000001136
67FF2A4B71FF4C759EFF3B638EFF11355BFF28527BFF1C3959FF103255FF0000
0000000000000000000000000000000000000000000000000000000000001848
78FF9BB7D1FFA3C9EDFF9FC5E8FF74A1CDFF81B0DDFF96B3CEFF1A4C7EFF0000
000000000000000000000000000000000000000000000000000000000000305D
8FFFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2E629AFF0000
0000000000000000000000000000000000000000000000000000000000003D3D
3DFF416F9EFF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF4176A6FF373737FF0000
0000000000000000000000000000000000000000000000000000494949FF4B4B
4BFF989898FF5C5C5CFF557CA3FF557CA3FF4C4C4CFF989898FF4E4E4EFF4C4C
4CFF0000000000000000000000000000000000000000777777FF4C4C4CFF4E4E
4EFF979797FF595959FFABABABFFA5A5A5FF545454FF868686FF626262FF4A4A
4AFF0000000000000000000000000000000000000000636363FFA4A4A4FF5050
50FF525252FF5B5B5BFFB8B8B8FFC1C1C1FF575757FF4D4D4DFF5A5A5AFF7E7E
7EFF606060FF000000000000000000000000287CCEFF78B3EAFF7A7A7AFF8383
83FF7E7E7EFF5D5D5DFF494949FF4C4C4CFF555555FF646464FF5F5F5FFF6D6D
6DFF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFF5F5F5FFF8F8F
8FFF7A7A7AFF777777FF6D6D6DFF4E4E4EFF727272FF6F6F6FFF848484FF5555
55FF83BCEFFF2A77CAFF0000000000000000000000002579CDFF5E5E5EFF4F4F
4FFF848484FF848484FF808080FF545454FF838383FF848484FF4A4A4AFF4545
45FF2E7ECEFF6DA2D3FF00000000000000000000000000000000000000003D3D
3DFF4D4D4DFF494949FF474747FF474747FF454545FF474747FF383838FF0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000027B2E5FF1BA7F3FF1CACF4FF1CA8F4FF1BA1F1FF27ACDEFF000000000000
00000000000000000000000000000000000000000000000000000000000028B5
E5FF1BB6F5FF1CB6F5FF1CB6F5FF1CB2F5FF1CABF4FF1DAAF0FF28B0E0FF0000
0000000000000000000000000000000000000000000000000000000000001DBA
F5FF1CB6F5FF1CAAF4FF1CACF4FF1CACF4FF1CACF3FF1CA1F0FF1C93E4FF0000
0000000000000000000000000000000000000000000000000000000000001B9E
F3FF62ABCEFF8AB7E4FF3EC6EBFF1C9FEDFF1DA4EEFF1EA5EBFF1C9AE9FF0000
0000000000000000000000000000000000000000000000000000000000001E6D
ADFFBDD7EFFFA3C9EDFF9DC5E8FF44CEEFFF5BCDEFFFA8DCF1FF207CBDFF0000
0000000000000000000000000000000000000000000000000000000000002C61
8EFFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D6299FF0000
0000000000000000000000000000000000000000000000000000000000004C72
49FF347499FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF357AA1FF4A6A46FF0000
000000000000000000000000000000000000000000000000000079935DFF2785
4EFFB3F5C8FF49898FFF4B7FA0FF4B7FA0FF49898FFFA9E8BAFF26844DFF738C
59FF0000000000000000000000000000000000000000AFE0ACFF37945DFF9FFD
C6FF91EFB8FF78D69FFF6FCD96FF69C68FFF62BF88FF73CF98FF94F0B9FF3088
51FF788754FF000000000000000000000000849D6CFF45A26BFF82E0A9FF82E0
A9FF6FCD96FF69C790FF64C28BFF5EBC85FF57B57EFF50AE77FF6BC891FF67C0
8AFF4F9A66FF769264FF0000000000000000287CCEFF78B3EAFF5AB881FF62C0
89FF62C089FF5FBD86FF5AB881FF55B37CFF4FAD76FF49A770FF419E67FF4DAB
74FF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFF409E67FF6ECC
95FF5BB881FF58B57EFF53B17AFF4FAC75FF54B17AFF51AD76FF67C18AFF3B92
5CFF83BCEFFF2A77CAFF0000000000000000000000002579CDFF429D67FF318F
58FF63C18AFF63C18AFF63C18AFF63C18AFF63C18AFF63C18AFF2D8A53FF2F88
53FF2E7ECEFF6DA2D3FF0000000000000000000000000000000000000000668C
57FF428B55FF338952FF2E8851FF2D8750FF2E854EFF39854EFF4F824EFF0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000565D68FF133F7AFF0D3E7DFF0C3C76FF123969FF4E5663FF000000000000
0000000000000000000000000000000000000000000000000000000000005F63
69FF284D7DFF0F498AFF0F4988FF0E4581FF0C3E73FF1B3D60FF595E63FF0000
0000000000000000000000000000000000000000000000000000000000003752
79FF0F498FFF0C3E76FF0C3E73FF0E3E73FF113F70FF0F3661FF143050FF0000
0000000000000000000000000000000000000000000000000000000000001037
73FF7893B5FF8AB7E4FF6793C3FF11355BFF15395FFF1C3959FF103255FF0000
0000000000000000000000000000000000000000000000000000000000001F5C
99FFBDD7EFFFA3C9EDFF9FC5E8FF74A1CDFF81B0DDFFB7D3EBFF2365A4FF0000
000000000000000000000000000000000000000000000000000000000000395F
89FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2F6299FF0000
000000000000000000000000000000000000000000000000000000000000966B
3EFF537291FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF51799AFF8C643CFF0000
0000000000000000000000000000000000000000000000000000A57645FFB17D
3FFFD8BEA0FF968271FF5572A4FF435EB5FFA2795FFFD9BEA0FFB48042FFA875
46FF0000000000000000000000000000000000000000C29A70FFB27D41FFB480
42FFDCBF9EFFBE8A4CFFC4B6BCFF5E67C8FFB3814DFFD3B088FFC29159FFAF7A
3EFF9F6F41FF000000000000000000000000A5774AFFC3925BFFE2CAB0FFB682
44FFB78345FFB88855FF4A5BD0FF5060D2FFBA874CFFB37F41FFBF8A4EFFD0A9
7DFFBE8D57FF9C6F46FF0000000000000000287CCEFF78B3EAFFCEA679FFD2AE
83FFD0A97DFFB78859FF4D4EA6FF77627CFFB6844BFFC4935CFFC18E55FFC79A
67FF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFFC18F55FFD8B9
94FFCEA678FFCCA375FFBA9370FFB27F44FFCA9F6EFFC89C69FFD3AE85FFB884
49FF83BCEFFF2A77CAFF0000000000000000000000002579CDFFC08E54FFB581
43FFD3AF85FFD3AF85FFD1AB7FFFB98547FFD2AE83FFD3AF85FFB07B3FFFA976
3CFF2E7ECEFF6DA2D3FF00000000000000000000000000000000000000009966
34FFAF7A41FFAE793DFFAD783CFFAD783CFFAA7539FFAA753CFF936131FF0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000
}
end
end

822
Client/UfrmAccountControl.pas
View File

@ -1,411 +1,411 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2008 Andreas Schneider
*)
unit UfrmAccountControl;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ComCtrls,
VirtualTrees, Math, UEnhancedMemoryStream, UEnums;
type
{ TfrmAccountControl }
TfrmAccountControl = class(TForm)
ilToolbar: TImageList;
ilAccesslevel: TImageList;
tbMain: TToolBar;
tbRefresh: TToolButton;
tbAddUser: TToolButton;
tbEditUser: TToolButton;
tbDeleteUser: TToolButton;
tbSeparator1: TToolButton;
vstAccounts: TVirtualStringTree;
procedure tbEditUserClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure tbAddUserClick(Sender: TObject);
procedure tbDeleteUserClick(Sender: TObject);
procedure tbRefreshClick(Sender: TObject);
procedure vstAccountsDblClick(Sender: TObject);
procedure vstAccountsFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
procedure vstAccountsGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
procedure vstAccountsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: String);
protected
procedure OnModifyUserResponse(ABuffer: TEnhancedMemoryStream);
procedure OnDeleteUserResponse(ABuffer: TEnhancedMemoryStream);
procedure OnListUsersPacket(ABuffer: TEnhancedMemoryStream);
function FindNode(AUsername: string): PVirtualNode;
end;
var
frmAccountControl: TfrmAccountControl;
implementation
uses
UdmNetwork, UPacket, UPacketHandlers, UAdminHandling, UfrmEditAccount;
type
PAccountInfo = ^TAccountInfo;
TAccountInfo = record
Username: string;
AccessLevel: TAccessLevel;
Regions: TStringList;
end;
{ TModifyUserPacket }
TModifyUserPacket = class(TPacket)
constructor Create(AUsername, APassword: string; AAccessLevel: TAccessLevel;
ARegions: TStrings);
end;
{ TDeleteUserPacket }
TDeleteUserPacket = class(TPacket)
constructor Create(AUsername: string);
end;
{ TRequestUserListPacket }
TRequestUserListPacket = class(TPacket)
constructor Create;
end;
{ TModifyUserPacket }
constructor TModifyUserPacket.Create(AUsername, APassword: string;
AAccessLevel: TAccessLevel; ARegions: TStrings);
var
regionCount: Byte;
i: Integer;
begin
inherited Create($03, 0);
FStream.WriteByte($05);
FStream.WriteStringNull(AUsername);
FStream.WriteStringNull(APassword);
FStream.WriteByte(Byte(AAccessLevel));
regionCount := Min(ARegions.Count, 256);
FStream.WriteByte(regionCount);
for i := 0 to regionCount - 1 do
FStream.WriteStringNull(ARegions.Strings[i]);
end;
{ TDeleteUserPacket }
constructor TDeleteUserPacket.Create(AUsername: string);
begin
inherited Create($03, 0);
FStream.WriteByte($06);
FStream.WriteStringNull(AUsername);
end;
{ TRequestUserListPacket }
constructor TRequestUserListPacket.Create;
begin
inherited Create($03, 0);
FStream.WriteByte($07);
end;
{ TfrmAccountControl }
procedure TfrmAccountControl.FormCreate(Sender: TObject);
begin
vstAccounts.NodeDataSize := SizeOf(TAccountInfo);
AssignAdminPacketHandler($05, TPacketHandler.Create(0, @OnModifyUserResponse));
AssignAdminPacketHandler($06, TPacketHandler.Create(0, @OnDeleteUserResponse));
AssignAdminPacketHandler($07, TPacketHandler.Create(0, @OnListUsersPacket));
end;
procedure TfrmAccountControl.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caHide;
end;
procedure TfrmAccountControl.tbEditUserClick(Sender: TObject);
var
selected: PVirtualNode;
accountInfo: PAccountInfo;
regions: TStrings;
begin
selected := vstAccounts.GetFirstSelected;
if selected <> nil then
begin
accountInfo := vstAccounts.GetNodeData(selected);
with frmEditAccount do
begin
edUsername.Text := accountInfo^.Username;
edUsername.Color := clBtnFace;
edUsername.ReadOnly := True;
edPassword.Text := '';
lblPasswordHint.Visible := True;
SetAccessLevel(accountInfo^.AccessLevel);
SetRegions(accountInfo^.Regions);
if ShowModal = mrOK then
begin
regions := GetRegions;
dmNetwork.Send(TModifyUserPacket.Create(edUsername.Text,
edPassword.Text, GetAccessLevel, regions));
regions.Free;
end;
end;
end;
end;
procedure TfrmAccountControl.FormDestroy(Sender: TObject);
begin
if AdminPacketHandlers[$05] <> nil then FreeAndNil(AdminPacketHandlers[$05]);
if AdminPacketHandlers[$06] <> nil then FreeAndNil(AdminPacketHandlers[$06]);
if AdminPacketHandlers[$07] <> nil then FreeAndNil(AdminPacketHandlers[$07]);
end;
procedure TfrmAccountControl.FormShow(Sender: TObject);
begin
tbRefreshClick(Sender);
end;
procedure TfrmAccountControl.tbAddUserClick(Sender: TObject);
var
regions: TStrings;
begin
with frmEditAccount do
begin
edUsername.Text := '';
edUsername.Color := clWindow;
edUsername.ReadOnly := False;
edPassword.Text := '';
lblPasswordHint.Visible := False;
cbAccessLevel.ItemIndex := 2;
SetRegions(nil);
if ShowModal = mrOK then
begin
regions := GetRegions;
dmNetwork.Send(TModifyUserPacket.Create(edUsername.Text, edPassword.Text,
GetAccessLevel, regions));
regions.Free;
end;
end;
end;
procedure TfrmAccountControl.tbDeleteUserClick(Sender: TObject);
var
selected: PVirtualNode;
accountInfo: PAccountInfo;
begin
selected := vstAccounts.GetFirstSelected;
if selected <> nil then
begin
accountInfo := vstAccounts.GetNodeData(selected);
if MessageDlg('Confirmation', Format('Do you really want to delete "%s"?',
[accountInfo^.Username]), mtConfirmation, [mbYes, mbNo], 0) = mrYes then
dmNetwork.Send(TDeleteUserPacket.Create(accountInfo^.Username));
end;
end;
procedure TfrmAccountControl.tbRefreshClick(Sender: TObject);
begin
dmNetwork.Send(TRequestUserListPacket.Create);
end;
procedure TfrmAccountControl.vstAccountsDblClick(Sender: TObject);
begin
tbEditUserClick(Sender);
end;
procedure TfrmAccountControl.vstAccountsFreeNode(Sender: TBaseVirtualTree;
Node: PVirtualNode);
var
accountInfo: PAccountInfo;
begin
accountInfo := vstAccounts.GetNodeData(Node);
accountInfo^.Username := '';
if accountInfo^.Regions <> nil then FreeAndNil(accountInfo^.Regions);
end;
procedure TfrmAccountControl.vstAccountsGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
var
accountInfo: PAccountInfo;
begin
if Column = 0 then
begin
accountInfo := Sender.GetNodeData(Node);
case accountInfo^.AccessLevel of
alNone: ImageIndex := 0;
alView: ImageIndex := 1;
alNormal: ImageIndex := 2;
alAdministrator: ImageIndex := 3;
end;
end;
end;
procedure TfrmAccountControl.vstAccountsGetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: String);
var
accountInfo: PAccountInfo;
begin
accountInfo := Sender.GetNodeData(Node);
case Column of
1: CellText := accountInfo^.Username;
2: CellText := GetAccessLevelString(accountInfo^.AccessLevel);
else
CellText := '';
end;
end;
procedure TfrmAccountControl.OnModifyUserResponse(ABuffer: TEnhancedMemoryStream);
var
node: PVirtualNode;
modifyStatus: TModifyUserStatus;
username: string;
accountInfo: PAccountInfo;
i, regions: Integer;
begin
modifyStatus := TModifyUserStatus(ABuffer.ReadByte);
username := ABuffer.ReadStringNull;
case modifyStatus of
muAdded:
begin
node := vstAccounts.AddChild(nil);
accountInfo := vstAccounts.GetNodeData(node);
accountInfo^.Username := username;
accountInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
accountInfo^.Regions := TStringList.Create;
regions := ABuffer.ReadByte;
for i := 0 to regions - 1 do
accountInfo^.Regions.Add(ABuffer.ReadStringNull);
Messagedlg('Success', Format('The user "%s" has been added.', [username]),
mtInformation, [mbOK], 0);
end;
muModified:
begin
node := FindNode(username);
if node <> nil then
begin
accountInfo := vstAccounts.GetNodeData(node);
accountInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
accountInfo^.Regions.Clear;
regions := ABuffer.ReadByte;
for i := 0 to regions - 1 do
accountInfo^.Regions.Add(ABuffer.ReadStringNull);
Messagedlg('Success', Format('The user "%s" has been modified.', [username]),
mtInformation, [mbOK], 0);
end;
end;
muInvalidUsername:
MessageDlg('Error', Format('The username "%s" is not valid.', [username]),
mtError, [mbOK], 0);
end;
end;
procedure TfrmAccountControl.OnDeleteUserResponse(ABuffer: TEnhancedMemoryStream);
var
node: PVirtualNode;
deleteStatus: TDeleteUserStatus;
username: string;
begin
deleteStatus := TDeleteUserStatus(ABuffer.ReadByte);
username := ABuffer.ReadStringNull;
case deleteStatus of
duDeleted:
begin
node := FindNode(username);
if node <> nil then
begin
vstAccounts.DeleteNode(node);
Messagedlg('Success', Format('The user "%s" has been deleted.', [username]),
mtInformation, [mbOK], 0);
end;
end;
duNotFound:
MessageDlg('Error', Format('The user "%s" could not be deleted. Maybe ' +
'your list is out of date or you tried to delete yourself.', [username]),
mtError, [mbOK], 0);
end;
end;
procedure TfrmAccountControl.OnListUsersPacket(ABuffer: TEnhancedMemoryStream);
var
node: PVirtualNode;
accountInfo: PAccountInfo;
i, j, count, regions: Integer;
begin
vstAccounts.BeginUpdate;
vstAccounts.Clear;
count := ABuffer.ReadWord;
for i := 1 to count do
begin
node := vstAccounts.AddChild(nil);
accountInfo := vstAccounts.GetNodeData(node);
accountInfo^.Username := ABuffer.ReadStringNull;
accountInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
accountInfo^.Regions := TStringList.Create;
regions := ABuffer.ReadByte;
for j := 0 to regions - 1 do
accountInfo^.Regions.Add(ABuffer.ReadStringNull);
end;
vstAccounts.EndUpdate;
end;
function TfrmAccountControl.FindNode(AUsername: string): PVirtualNode;
var
node: PVirtualNode;
accountInfo: PAccountInfo;
begin
Result := nil;
node := vstAccounts.GetFirst;
while (node <> nil) and (Result = nil) do
begin
accountInfo := vstAccounts.GetNodeData(node);
if accountInfo^.Username = AUsername then
Result := node;
node := vstAccounts.GetNext(node);
end;
end;
initialization
{$I UfrmAccountControl.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2008 Andreas Schneider
*)
unit UfrmAccountControl;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ComCtrls,
VirtualTrees, Math, UEnhancedMemoryStream, UEnums;
type
{ TfrmAccountControl }
TfrmAccountControl = class(TForm)
ilToolbar: TImageList;
ilAccesslevel: TImageList;
tbMain: TToolBar;
tbRefresh: TToolButton;
tbAddUser: TToolButton;
tbEditUser: TToolButton;
tbDeleteUser: TToolButton;
tbSeparator1: TToolButton;
vstAccounts: TVirtualStringTree;
procedure tbEditUserClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure tbAddUserClick(Sender: TObject);
procedure tbDeleteUserClick(Sender: TObject);
procedure tbRefreshClick(Sender: TObject);
procedure vstAccountsDblClick(Sender: TObject);
procedure vstAccountsFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
procedure vstAccountsGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
procedure vstAccountsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: String);
protected
procedure OnModifyUserResponse(ABuffer: TEnhancedMemoryStream);
procedure OnDeleteUserResponse(ABuffer: TEnhancedMemoryStream);
procedure OnListUsersPacket(ABuffer: TEnhancedMemoryStream);
function FindNode(AUsername: string): PVirtualNode;
end;
var
frmAccountControl: TfrmAccountControl;
implementation
uses
UdmNetwork, UPacket, UPacketHandlers, UAdminHandling, UfrmEditAccount;
type
PAccountInfo = ^TAccountInfo;
TAccountInfo = record
Username: string;
AccessLevel: TAccessLevel;
Regions: TStringList;
end;
{ TModifyUserPacket }
TModifyUserPacket = class(TPacket)
constructor Create(AUsername, APassword: string; AAccessLevel: TAccessLevel;
ARegions: TStrings);
end;
{ TDeleteUserPacket }
TDeleteUserPacket = class(TPacket)
constructor Create(AUsername: string);
end;
{ TRequestUserListPacket }
TRequestUserListPacket = class(TPacket)
constructor Create;
end;
{ TModifyUserPacket }
constructor TModifyUserPacket.Create(AUsername, APassword: string;
AAccessLevel: TAccessLevel; ARegions: TStrings);
var
regionCount: Byte;
i: Integer;
begin
inherited Create($03, 0);
FStream.WriteByte($05);
FStream.WriteStringNull(AUsername);
FStream.WriteStringNull(APassword);
FStream.WriteByte(Byte(AAccessLevel));
regionCount := Min(ARegions.Count, 256);
FStream.WriteByte(regionCount);
for i := 0 to regionCount - 1 do
FStream.WriteStringNull(ARegions.Strings[i]);
end;
{ TDeleteUserPacket }
constructor TDeleteUserPacket.Create(AUsername: string);
begin
inherited Create($03, 0);
FStream.WriteByte($06);
FStream.WriteStringNull(AUsername);
end;
{ TRequestUserListPacket }
constructor TRequestUserListPacket.Create;
begin
inherited Create($03, 0);
FStream.WriteByte($07);
end;
{ TfrmAccountControl }
procedure TfrmAccountControl.FormCreate(Sender: TObject);
begin
vstAccounts.NodeDataSize := SizeOf(TAccountInfo);
AssignAdminPacketHandler($05, TPacketHandler.Create(0, @OnModifyUserResponse));
AssignAdminPacketHandler($06, TPacketHandler.Create(0, @OnDeleteUserResponse));
AssignAdminPacketHandler($07, TPacketHandler.Create(0, @OnListUsersPacket));
end;
procedure TfrmAccountControl.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caHide;
end;
procedure TfrmAccountControl.tbEditUserClick(Sender: TObject);
var
selected: PVirtualNode;
accountInfo: PAccountInfo;
regions: TStrings;
begin
selected := vstAccounts.GetFirstSelected;
if selected <> nil then
begin
accountInfo := vstAccounts.GetNodeData(selected);
with frmEditAccount do
begin
edUsername.Text := accountInfo^.Username;
edUsername.Color := clBtnFace;
edUsername.ReadOnly := True;
edPassword.Text := '';
lblPasswordHint.Visible := True;
SetAccessLevel(accountInfo^.AccessLevel);
SetRegions(accountInfo^.Regions);
if ShowModal = mrOK then
begin
regions := GetRegions;
dmNetwork.Send(TModifyUserPacket.Create(edUsername.Text,
edPassword.Text, GetAccessLevel, regions));
regions.Free;
end;
end;
end;
end;
procedure TfrmAccountControl.FormDestroy(Sender: TObject);
begin
if AdminPacketHandlers[$05] <> nil then FreeAndNil(AdminPacketHandlers[$05]);
if AdminPacketHandlers[$06] <> nil then FreeAndNil(AdminPacketHandlers[$06]);
if AdminPacketHandlers[$07] <> nil then FreeAndNil(AdminPacketHandlers[$07]);
end;
procedure TfrmAccountControl.FormShow(Sender: TObject);
begin
tbRefreshClick(Sender);
end;
procedure TfrmAccountControl.tbAddUserClick(Sender: TObject);
var
regions: TStrings;
begin
with frmEditAccount do
begin
edUsername.Text := '';
edUsername.Color := clWindow;
edUsername.ReadOnly := False;
edPassword.Text := '';
lblPasswordHint.Visible := False;
cbAccessLevel.ItemIndex := 2;
SetRegions(nil);
if ShowModal = mrOK then
begin
regions := GetRegions;
dmNetwork.Send(TModifyUserPacket.Create(edUsername.Text, edPassword.Text,
GetAccessLevel, regions));
regions.Free;
end;
end;
end;
procedure TfrmAccountControl.tbDeleteUserClick(Sender: TObject);
var
selected: PVirtualNode;
accountInfo: PAccountInfo;
begin
selected := vstAccounts.GetFirstSelected;
if selected <> nil then
begin
accountInfo := vstAccounts.GetNodeData(selected);
if MessageDlg('Confirmation', Format('Do you really want to delete "%s"?',
[accountInfo^.Username]), mtConfirmation, [mbYes, mbNo], 0) = mrYes then
dmNetwork.Send(TDeleteUserPacket.Create(accountInfo^.Username));
end;
end;
procedure TfrmAccountControl.tbRefreshClick(Sender: TObject);
begin
dmNetwork.Send(TRequestUserListPacket.Create);
end;
procedure TfrmAccountControl.vstAccountsDblClick(Sender: TObject);
begin
tbEditUserClick(Sender);
end;
procedure TfrmAccountControl.vstAccountsFreeNode(Sender: TBaseVirtualTree;
Node: PVirtualNode);
var
accountInfo: PAccountInfo;
begin
accountInfo := vstAccounts.GetNodeData(Node);
accountInfo^.Username := '';
if accountInfo^.Regions <> nil then FreeAndNil(accountInfo^.Regions);
end;
procedure TfrmAccountControl.vstAccountsGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
var
accountInfo: PAccountInfo;
begin
if Column = 0 then
begin
accountInfo := Sender.GetNodeData(Node);
case accountInfo^.AccessLevel of
alNone: ImageIndex := 0;
alView: ImageIndex := 1;
alNormal: ImageIndex := 2;
alAdministrator: ImageIndex := 3;
end;
end;
end;
procedure TfrmAccountControl.vstAccountsGetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: String);
var
accountInfo: PAccountInfo;
begin
accountInfo := Sender.GetNodeData(Node);
case Column of
1: CellText := accountInfo^.Username;
2: CellText := GetAccessLevelString(accountInfo^.AccessLevel);
else
CellText := '';
end;
end;
procedure TfrmAccountControl.OnModifyUserResponse(ABuffer: TEnhancedMemoryStream);
var
node: PVirtualNode;
modifyStatus: TModifyUserStatus;
username: string;
accountInfo: PAccountInfo;
i, regions: Integer;
begin
modifyStatus := TModifyUserStatus(ABuffer.ReadByte);
username := ABuffer.ReadStringNull;
case modifyStatus of
muAdded:
begin
node := vstAccounts.AddChild(nil);
accountInfo := vstAccounts.GetNodeData(node);
accountInfo^.Username := username;
accountInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
accountInfo^.Regions := TStringList.Create;
regions := ABuffer.ReadByte;
for i := 0 to regions - 1 do
accountInfo^.Regions.Add(ABuffer.ReadStringNull);
Messagedlg('Success', Format('The user "%s" has been added.', [username]),
mtInformation, [mbOK], 0);
end;
muModified:
begin
node := FindNode(username);
if node <> nil then
begin
accountInfo := vstAccounts.GetNodeData(node);
accountInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
accountInfo^.Regions.Clear;
regions := ABuffer.ReadByte;
for i := 0 to regions - 1 do
accountInfo^.Regions.Add(ABuffer.ReadStringNull);
Messagedlg('Success', Format('The user "%s" has been modified.', [username]),
mtInformation, [mbOK], 0);
end;
end;
muInvalidUsername:
MessageDlg('Error', Format('The username "%s" is not valid.', [username]),
mtError, [mbOK], 0);
end;
end;
procedure TfrmAccountControl.OnDeleteUserResponse(ABuffer: TEnhancedMemoryStream);
var
node: PVirtualNode;
deleteStatus: TDeleteUserStatus;
username: string;
begin
deleteStatus := TDeleteUserStatus(ABuffer.ReadByte);
username := ABuffer.ReadStringNull;
case deleteStatus of
duDeleted:
begin
node := FindNode(username);
if node <> nil then
begin
vstAccounts.DeleteNode(node);
Messagedlg('Success', Format('The user "%s" has been deleted.', [username]),
mtInformation, [mbOK], 0);
end;
end;
duNotFound:
MessageDlg('Error', Format('The user "%s" could not be deleted. Maybe ' +
'your list is out of date or you tried to delete yourself.', [username]),
mtError, [mbOK], 0);
end;
end;
procedure TfrmAccountControl.OnListUsersPacket(ABuffer: TEnhancedMemoryStream);
var
node: PVirtualNode;
accountInfo: PAccountInfo;
i, j, count, regions: Integer;
begin
vstAccounts.BeginUpdate;
vstAccounts.Clear;
count := ABuffer.ReadWord;
for i := 1 to count do
begin
node := vstAccounts.AddChild(nil);
accountInfo := vstAccounts.GetNodeData(node);
accountInfo^.Username := ABuffer.ReadStringNull;
accountInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
accountInfo^.Regions := TStringList.Create;
regions := ABuffer.ReadByte;
for j := 0 to regions - 1 do
accountInfo^.Regions.Add(ABuffer.ReadStringNull);
end;
vstAccounts.EndUpdate;
end;
function TfrmAccountControl.FindNode(AUsername: string): PVirtualNode;
var
node: PVirtualNode;
accountInfo: PAccountInfo;
begin
Result := nil;
node := vstAccounts.GetFirst;
while (node <> nil) and (Result = nil) do
begin
accountInfo := vstAccounts.GetNodeData(node);
if accountInfo^.Username = AUsername then
Result := node;
node := vstAccounts.GetNext(node);
end;
end;
initialization
{$I UfrmAccountControl.lrs}
end.

334
Client/UfrmEditAccount.lfm
View File

@ -1,167 +1,167 @@
object frmEditAccount: TfrmEditAccount
Left = 290
Height = 214
Top = 171
Width = 261
ActiveControl = PageControl1
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Edit Account'
ClientHeight = 214
ClientWidth = 261
Font.Height = -11
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
ParentFont = False
Position = poOwnerFormCenter
LCLVersion = '0.9.27'
object PageControl1: TPageControl
Height = 173
Width = 261
ActivePage = tsGeneral
Align = alClient
TabIndex = 0
TabOrder = 0
object tsGeneral: TTabSheet
Caption = 'General'
ClientHeight = 148
ClientWidth = 259
object lblPasswordHint: TLabel
Left = 86
Height = 28
Top = 64
Width = 160
AutoSize = False
Caption = 'Leave empty to leave the password unchanged.'
Enabled = False
ParentColor = False
WordWrap = True
end
object lblUsername: TLabel
Left = 6
Height = 14
Top = 12
Width = 58
Caption = 'Username:'
ParentColor = False
end
object lblPassword: TLabel
Left = 6
Height = 14
Top = 44
Width = 54
Caption = 'Password:'
ParentColor = False
end
object lblAccessLevel: TLabel
Left = 6
Height = 14
Top = 108
Width = 63
Caption = 'Accesslevel:'
ParentColor = False
end
object edUsername: TEdit
Left = 86
Height = 23
Top = 8
Width = 160
Color = clBtnFace
ReadOnly = True
TabOrder = 0
end
object edPassword: TEdit
Left = 86
Height = 23
Top = 40
Width = 160
EchoMode = emPassword
PasswordChar = '*'
TabOrder = 1
end
object cbAccessLevel: TComboBox
Left = 86
Height = 25
Top = 104
Width = 160
Items.Strings = (
'None'
'Viewer'
'Normal'
'Administrator'
)
Style = csDropDownList
TabOrder = 2
end
end
object tsRegions: TTabSheet
Caption = 'Regions'
ClientHeight = 148
ClientWidth = 259
object Label1: TLabel
Left = 8
Height = 14
Top = 8
Width = 243
Align = alTop
BorderSpacing.Left = 8
BorderSpacing.Top = 8
BorderSpacing.Right = 8
BorderSpacing.Bottom = 4
Caption = 'Allowed Regions:'
ParentColor = False
end
object cbRegions: TCheckListBox
Left = 8
Height = 114
Top = 26
Width = 243
Align = alClient
BorderSpacing.Left = 8
BorderSpacing.Top = 4
BorderSpacing.Right = 8
BorderSpacing.Bottom = 8
ItemHeight = 13
TabOrder = 0
TopIndex = -1
end
end
end
object Panel1: TPanel
Left = 8
Height = 25
Top = 181
Width = 245
Align = alBottom
BorderSpacing.Around = 8
BevelOuter = bvNone
ClientHeight = 25
ClientWidth = 245
TabOrder = 1
object btnCancel: TButton
Left = 170
Height = 25
Width = 75
Align = alRight
BorderSpacing.Left = 4
BorderSpacing.InnerBorder = 4
Cancel = True
Caption = 'Cancel'
ModalResult = 2
TabOrder = 0
end
object btnOK: TButton
Left = 91
Height = 25
Width = 75
Align = alRight
BorderSpacing.Right = 4
BorderSpacing.InnerBorder = 4
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 1
end
end
end
object frmEditAccount: TfrmEditAccount
Left = 290
Height = 214
Top = 171
Width = 261
ActiveControl = PageControl1
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Edit Account'
ClientHeight = 214
ClientWidth = 261
Font.Height = -11
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
ParentFont = False
Position = poOwnerFormCenter
LCLVersion = '0.9.27'
object PageControl1: TPageControl
Height = 173
Width = 261
ActivePage = tsGeneral
Align = alClient
TabIndex = 0
TabOrder = 0
object tsGeneral: TTabSheet
Caption = 'General'
ClientHeight = 148
ClientWidth = 259
object lblPasswordHint: TLabel
Left = 86
Height = 28
Top = 64
Width = 160
AutoSize = False
Caption = 'Leave empty to leave the password unchanged.'
Enabled = False
ParentColor = False
WordWrap = True
end
object lblUsername: TLabel
Left = 6
Height = 14
Top = 12
Width = 58
Caption = 'Username:'
ParentColor = False
end
object lblPassword: TLabel
Left = 6
Height = 14
Top = 44
Width = 54
Caption = 'Password:'
ParentColor = False
end
object lblAccessLevel: TLabel
Left = 6
Height = 14
Top = 108
Width = 63
Caption = 'Accesslevel:'
ParentColor = False
end
object edUsername: TEdit
Left = 86
Height = 23
Top = 8
Width = 160
Color = clBtnFace
ReadOnly = True
TabOrder = 0
end
object edPassword: TEdit
Left = 86
Height = 23
Top = 40
Width = 160
EchoMode = emPassword
PasswordChar = '*'
TabOrder = 1
end
object cbAccessLevel: TComboBox
Left = 86
Height = 25
Top = 104
Width = 160
Items.Strings = (
'None'
'Viewer'
'Normal'
'Administrator'
)
Style = csDropDownList
TabOrder = 2
end
end
object tsRegions: TTabSheet
Caption = 'Regions'
ClientHeight = 148
ClientWidth = 259
object Label1: TLabel
Left = 8
Height = 14
Top = 8
Width = 243
Align = alTop
BorderSpacing.Left = 8
BorderSpacing.Top = 8
BorderSpacing.Right = 8
BorderSpacing.Bottom = 4
Caption = 'Allowed Regions:'
ParentColor = False
end
object cbRegions: TCheckListBox
Left = 8
Height = 114
Top = 26
Width = 243
Align = alClient
BorderSpacing.Left = 8
BorderSpacing.Top = 4
BorderSpacing.Right = 8
BorderSpacing.Bottom = 8
ItemHeight = 13
TabOrder = 0
TopIndex = -1
end
end
end
object Panel1: TPanel
Left = 8
Height = 25
Top = 181
Width = 245
Align = alBottom
BorderSpacing.Around = 8
BevelOuter = bvNone
ClientHeight = 25
ClientWidth = 245
TabOrder = 1
object btnCancel: TButton
Left = 170
Height = 25
Width = 75
Align = alRight
BorderSpacing.Left = 4
BorderSpacing.InnerBorder = 4
Cancel = True
Caption = 'Cancel'
ModalResult = 2
TabOrder = 0
end
object btnOK: TButton
Left = 91
Height = 25
Width = 75
Align = alRight
BorderSpacing.Right = 4
BorderSpacing.InnerBorder = 4
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 1
end
end
end

80
Client/UfrmInitialize.lfm
View File

@ -1,40 +1,40 @@
object frmInitialize: TfrmInitialize
Left = 290
Height = 65
Top = 171
Width = 241
BorderIcons = []
BorderStyle = bsDialog
Caption = 'Please wait ...'
ClientHeight = 65
ClientWidth = 241
Font.Height = -11
OnClose = FormClose
OnCreate = FormCreate
Position = poScreenCenter
LCLVersion = '0.9.25'
object pnlMain: TPanel
Left = 8
Height = 50
Top = 8
Width = 226
BevelInner = bvRaised
BevelOuter = bvLowered
ClientHeight = 50
ClientWidth = 226
ParentFont = True
TabOrder = 0
object lblStatus: TLabel
Left = 8
Height = 32
Top = 8
Width = 208
Alignment = taCenter
AutoSize = False
Layout = tlCenter
ParentColor = False
ParentFont = True
WordWrap = True
end
end
end
object frmInitialize: TfrmInitialize
Left = 290
Height = 65
Top = 171
Width = 241
BorderIcons = []
BorderStyle = bsDialog
Caption = 'Please wait ...'
ClientHeight = 65
ClientWidth = 241
Font.Height = -11
OnClose = FormClose
OnCreate = FormCreate
Position = poScreenCenter
LCLVersion = '0.9.25'
object pnlMain: TPanel
Left = 8
Height = 50
Top = 8
Width = 226
BevelInner = bvRaised
BevelOuter = bvLowered
ClientHeight = 50
ClientWidth = 226
ParentFont = True
TabOrder = 0
object lblStatus: TLabel
Left = 8
Height = 32
Top = 8
Width = 208
Alignment = taCenter
AutoSize = False
Layout = tlCenter
ParentColor = False
ParentFont = True
WordWrap = True
end
end
end

192
Client/UfrmInitialize.pas
View File

@ -1,96 +1,96 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UfrmInitialize;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
StdCtrls, LCLIntf, LCLType, WSForms;
type
{ TfrmInitialize }
TfrmInitialize = class(TForm)
lblStatus: TLabel;
pnlMain: TPanel;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
protected
FActiveWindow: HWND;
FModal: Boolean;
public
procedure SetModal;
procedure UnsetModal;
end;
var
frmInitialize: TfrmInitialize;
implementation
{ TfrmInitialize }
procedure TfrmInitialize.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caNone;
end;
procedure TfrmInitialize.FormCreate(Sender: TObject);
begin
FModal := False;
end;
procedure TfrmInitialize.SetModal;
begin
if FModal then Exit;
FActiveWindow := GetActiveWindow;
TWSCustomFormClass(WidgetSetClass).ShowModal(Self);
{FormStyle := fsStayOnTop;
Screen.MoveFormToFocusFront(Self);
Screen.MoveFormToZFront(Self);}
FModal := True;
end;
procedure TfrmInitialize.UnsetModal;
begin
if not FModal then Exit;
TWSCustomFormClass(WidgetSetClass).CloseModal(Self);
if FActiveWindow <> 0 then SetActiveWindow(FActiveWindow);
FActiveWindow := 0;
//FormStyle := fsNormal;
FModal := False;
end;
initialization
{$I UfrmInitialize.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UfrmInitialize;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
StdCtrls, LCLIntf, LCLType, WSForms;
type
{ TfrmInitialize }
TfrmInitialize = class(TForm)
lblStatus: TLabel;
pnlMain: TPanel;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
protected
FActiveWindow: HWND;
FModal: Boolean;
public
procedure SetModal;
procedure UnsetModal;
end;
var
frmInitialize: TfrmInitialize;
implementation
{ TfrmInitialize }
procedure TfrmInitialize.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caNone;
end;
procedure TfrmInitialize.FormCreate(Sender: TObject);
begin
FModal := False;
end;
procedure TfrmInitialize.SetModal;
begin
if FModal then Exit;
FActiveWindow := GetActiveWindow;
TWSCustomFormClass(WidgetSetClass).ShowModal(Self);
{FormStyle := fsStayOnTop;
Screen.MoveFormToFocusFront(Self);
Screen.MoveFormToZFront(Self);}
FModal := True;
end;
procedure TfrmInitialize.UnsetModal;
begin
if not FModal then Exit;
TWSCustomFormClass(WidgetSetClass).CloseModal(Self);
if FActiveWindow <> 0 then SetActiveWindow(FActiveWindow);
FActiveWindow := 0;
//FormStyle := fsNormal;
FModal := False;
end;
initialization
{$I UfrmInitialize.lrs}
end.

3146
Client/UfrmLargeScaleCommand.lfm
View File

File diff suppressed because it is too large Load Diff

1564
Client/UfrmLargeScaleCommand.pas
View File

File diff suppressed because it is too large Load Diff

1368
Client/UfrmLogin.lfm
View File

File diff suppressed because it is too large Load Diff

384
Client/UfrmLogin.pas
View File

@ -1,192 +1,192 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UfrmLogin;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
ExtCtrls, Spin, EditBtn, Buttons, IniFiles;
type
{ TfrmLogin }
TfrmLogin = class(TForm)
btnOK: TButton;
btnCancel: TButton;
cbProfile: TComboBox;
edData: TDirectoryEdit;
edHost: TEdit;
edUsername: TEdit;
edPassword: TEdit;
gbConnection: TGroupBox;
gbData: TGroupBox;
gbActions: TGroupBox;
gbProfiles: TGroupBox;
imgHost: TImage;
imgUsername: TImage;
imgPassword: TImage;
lblCopyright: TLabel;
lblHost: TLabel;
lblUsername: TLabel;
lblPassword: TLabel;
edPort: TSpinEdit;
lblData: TLabel;
btnSaveProfile: TSpeedButton;
btnDeleteProfile: TSpeedButton;
procedure btnCancelClick(Sender: TObject);
procedure btnDeleteProfileClick(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure btnSaveProfileClick(Sender: TObject);
procedure cbProfileChange(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
protected
FProfilePath: string;
public
{ public declarations }
end;
var
frmLogin: TfrmLogin;
implementation
uses
UdmNetwork;
{$I version.inc}
{ TfrmLogin }
procedure TfrmLogin.btnCancelClick(Sender: TObject);
begin
Close;
end;
procedure TfrmLogin.btnDeleteProfileClick(Sender: TObject);
begin
if cbProfile.ItemIndex > -1 then
begin
DeleteFile(FProfilePath + cbProfile.Text + '.ini');
cbProfile.Items.Delete(cbProfile.ItemIndex);
end;
end;
procedure TfrmLogin.btnOKClick(Sender: TObject);
var
path: string;
begin
path := IncludeTrailingPathDelimiter(edData.Text);
if (not FileExists(path + 'art.mul')) or
(not FileExists(path + 'artidx.mul')) or
(not FileExists(path + 'hues.mul')) or
(not FileExists(path + 'tiledata.mul')) or
(not FileExists(path + 'animdata.mul')) or
(not FileExists(path + 'texmaps.mul')) or
(not FileExists(path + 'texidx.mul')) or
(not FileExists(path + 'light.mul')) or
(not FileExists(path + 'lightidx.mul')) then
begin
MessageDlg('Incorrect directory', 'The data path you specified does not '
+ 'seem to be correct.', mtWarning, [mbOK], 0);
edData.SetFocus;
end else
ModalResult := mrOK;
end;
procedure TfrmLogin.btnSaveProfileClick(Sender: TObject);
var
profileName: string;
profile: TIniFile;
begin
profileName := cbProfile.Text;
if InputQuery('Save profile', 'Enter the name of the profile:', profileName) then
begin
profile := TIniFile.Create(FProfilePath + profileName + '.ini');
profile.WriteString('Connection', 'Host', edHost.Text);
profile.WriteInteger('Connection', 'Port', edPort.Value);
profile.WriteString('Connection', 'Username', edUsername.Text);
profile.WriteString('Data', 'Path', edData.Text);
profile.Free;
cbProfile.ItemIndex := cbProfile.Items.IndexOf(profileName);
if cbProfile.ItemIndex = -1 then
begin
cbProfile.Items.Add(profileName);
cbProfile.ItemIndex := cbProfile.Items.Count - 1;
end;
end;
end;
procedure TfrmLogin.cbProfileChange(Sender: TObject);
var
profile: TIniFile;
begin
if cbProfile.ItemIndex > -1 then
begin
profile := TIniFile.Create(FProfilePath + cbProfile.Text + '.ini');
edHost.Text := profile.ReadString('Connection', 'Host', '');
edPort.Value := profile.ReadInteger('Connection', 'Port', 2597);
edUsername.Text := profile.ReadString('Connection', 'Username', '');
edPassword.Text := '';
edData.Text := profile.ReadString('Data', 'Path', '');
edPassword.SetFocus;
profile.Free;
end;
end;
procedure TfrmLogin.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
if ModalResult <> mrOK then
dmNetwork.CheckClose(Self);
end;
procedure TfrmLogin.FormCreate(Sender: TObject);
var
searchRec: TSearchRec;
begin
lblCopyright.Caption := Format('UO CentrED Client Version %s (c) %s',
[ProductVersion, Copyright]);
FProfilePath := GetAppConfigDir(False) + 'Profiles' + PathDelim;
ForceDirectories(FProfilePath);
if FindFirst(FProfilePath + '*.ini', faAnyFile, searchRec) = 0 then
begin
repeat
cbProfile.Items.Add(ChangeFileExt(searchRec.Name, ''));
until FindNext(searchRec) <> 0;
end;
FindClose(searchRec);
end;
initialization
{$I UfrmLogin.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UfrmLogin;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
ExtCtrls, Spin, EditBtn, Buttons, IniFiles;
type
{ TfrmLogin }
TfrmLogin = class(TForm)
btnOK: TButton;
btnCancel: TButton;
cbProfile: TComboBox;
edData: TDirectoryEdit;
edHost: TEdit;
edUsername: TEdit;
edPassword: TEdit;
gbConnection: TGroupBox;
gbData: TGroupBox;
gbActions: TGroupBox;
gbProfiles: TGroupBox;
imgHost: TImage;
imgUsername: TImage;
imgPassword: TImage;
lblCopyright: TLabel;
lblHost: TLabel;
lblUsername: TLabel;
lblPassword: TLabel;
edPort: TSpinEdit;
lblData: TLabel;
btnSaveProfile: TSpeedButton;
btnDeleteProfile: TSpeedButton;
procedure btnCancelClick(Sender: TObject);
procedure btnDeleteProfileClick(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure btnSaveProfileClick(Sender: TObject);
procedure cbProfileChange(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
protected
FProfilePath: string;
public
{ public declarations }
end;
var
frmLogin: TfrmLogin;
implementation
uses
UdmNetwork;
{$I version.inc}
{ TfrmLogin }
procedure TfrmLogin.btnCancelClick(Sender: TObject);
begin
Close;
end;
procedure TfrmLogin.btnDeleteProfileClick(Sender: TObject);
begin
if cbProfile.ItemIndex > -1 then
begin
DeleteFile(FProfilePath + cbProfile.Text + '.ini');
cbProfile.Items.Delete(cbProfile.ItemIndex);
end;
end;
procedure TfrmLogin.btnOKClick(Sender: TObject);
var
path: string;
begin
path := IncludeTrailingPathDelimiter(edData.Text);
if (not FileExists(path + 'art.mul')) or
(not FileExists(path + 'artidx.mul')) or
(not FileExists(path + 'hues.mul')) or
(not FileExists(path + 'tiledata.mul')) or
(not FileExists(path + 'animdata.mul')) or
(not FileExists(path + 'texmaps.mul')) or
(not FileExists(path + 'texidx.mul')) or
(not FileExists(path + 'light.mul')) or
(not FileExists(path + 'lightidx.mul')) then
begin
MessageDlg('Incorrect directory', 'The data path you specified does not '
+ 'seem to be correct.', mtWarning, [mbOK], 0);
edData.SetFocus;
end else
ModalResult := mrOK;
end;
procedure TfrmLogin.btnSaveProfileClick(Sender: TObject);
var
profileName: string;
profile: TIniFile;
begin
profileName := cbProfile.Text;
if InputQuery('Save profile', 'Enter the name of the profile:', profileName) then
begin
profile := TIniFile.Create(FProfilePath + profileName + '.ini');
profile.WriteString('Connection', 'Host', edHost.Text);
profile.WriteInteger('Connection', 'Port', edPort.Value);
profile.WriteString('Connection', 'Username', edUsername.Text);
profile.WriteString('Data', 'Path', edData.Text);
profile.Free;
cbProfile.ItemIndex := cbProfile.Items.IndexOf(profileName);
if cbProfile.ItemIndex = -1 then
begin
cbProfile.Items.Add(profileName);
cbProfile.ItemIndex := cbProfile.Items.Count - 1;
end;
end;
end;
procedure TfrmLogin.cbProfileChange(Sender: TObject);
var
profile: TIniFile;
begin
if cbProfile.ItemIndex > -1 then
begin
profile := TIniFile.Create(FProfilePath + cbProfile.Text + '.ini');
edHost.Text := profile.ReadString('Connection', 'Host', '');
edPort.Value := profile.ReadInteger('Connection', 'Port', 2597);
edUsername.Text := profile.ReadString('Connection', 'Username', '');
edPassword.Text := '';
edData.Text := profile.ReadString('Data', 'Path', '');
edPassword.SetFocus;
profile.Free;
end;
end;
procedure TfrmLogin.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
if ModalResult <> mrOK then
dmNetwork.CheckClose(Self);
end;
procedure TfrmLogin.FormCreate(Sender: TObject);
var
searchRec: TSearchRec;
begin
lblCopyright.Caption := Format('UO CentrED Client Version %s (c) %s',
[ProductVersion, Copyright]);
FProfilePath := GetAppConfigDir(False) + 'Profiles' + PathDelim;
ForceDirectories(FProfilePath);
if FindFirst(FProfilePath + '*.ini', faAnyFile, searchRec) = 0 then
begin
repeat
cbProfile.Items.Add(ChangeFileExt(searchRec.Name, ''));
until FindNext(searchRec) <> 0;
end;
FindClose(searchRec);
end;
initialization
{$I UfrmLogin.lrs}
end.

1270
Client/UfrmRegionControl.lfm
View File

File diff suppressed because it is too large Load Diff

1480
Client/UfrmRegionControl.pas
View File

File diff suppressed because it is too large Load Diff

802
Imaging/JpegLib/imjcapimin.pas
View File

@ -1,401 +1,401 @@
unit imjcapimin;
{$N+}
{ This file contains application interface code for the compression half
of the JPEG library. These are the "minimum" API routines that may be
needed in either the normal full-compression case or the transcoding-only
case.
Most of the routines intended to be called directly by an application
are in this file or in jcapistd.c. But also see jcparam.c for
parameter-setup helper routines, jcomapi.c for routines shared by
compression and decompression, and jctrans.c for the transcoding case. }
{ jcapimin.c ; Copyright (C) 1994-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjcomapi,
imjmemmgr,
imjcmarker;
{ Initialization of JPEG compression objects.
Nomssi: This is a macro in the original code.
jpeg_create_compress() and jpeg_create_decompress() are the exported
names that applications should call. These expand to calls on
jpeg_CreateCompress and jpeg_CreateDecompress with additional information
passed for version mismatch checking.
NB: you must set up the error-manager BEFORE calling jpeg_create_xxx. }
procedure jpeg_create_compress(cinfo : j_compress_ptr);
{ Initialization of a JPEG compression object.
The error manager must already be set up (in case memory manager fails). }
{GLOBAL}
procedure jpeg_CreateCompress (cinfo : j_compress_ptr;
version : int;
structsize : size_t);
{ Destruction of a JPEG compression object }
{GLOBAL}
procedure jpeg_destroy_compress (cinfo : j_compress_ptr);
{ Abort processing of a JPEG compression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort_compress (cinfo : j_compress_ptr);
{ Forcibly suppress or un-suppress all quantization and Huffman tables.
Marks all currently defined tables as already written (if suppress)
or not written (if !suppress). This will control whether they get emitted
by a subsequent jpeg_start_compress call.
This routine is exported for use by applications that want to produce
abbreviated JPEG datastreams. It logically belongs in jcparam.c, but
since it is called by jpeg_start_compress, we put it here --- otherwise
jcparam.o would be linked whether the application used it or not. }
{GLOBAL}
procedure jpeg_suppress_tables (cinfo : j_compress_ptr;
suppress : boolean);
{ Finish JPEG compression.
If a multipass operating mode was selected, this may do a great deal of
work including most of the actual output. }
{GLOBAL}
procedure jpeg_finish_compress (cinfo : j_compress_ptr);
{ Write a special marker.
This is only recommended for writing COM or APPn markers.
Must be called after jpeg_start_compress() and before
first call to jpeg_write_scanlines() or jpeg_write_raw_data(). }
{GLOBAL}
procedure jpeg_write_marker (cinfo : j_compress_ptr;
marker : int;
dataptr : JOCTETptr;
datalen : uInt);
{GLOBAL}
procedure jpeg_write_m_header (cinfo : j_compress_ptr;
marker : int;
datalen : uint);
{GLOBAL}
procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int);
{ Alternate compression function: just write an abbreviated table file.
Before calling this, all parameters and a data destination must be set up.
To produce a pair of files containing abbreviated tables and abbreviated
image data, one would proceed as follows:
initialize JPEG object
set JPEG parameters
set destination to table file
jpeg_write_tables(cinfo);
set destination to image file
jpeg_start_compress(cinfo, FALSE);
write data...
jpeg_finish_compress(cinfo);
jpeg_write_tables has the side effect of marking all tables written
(same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress
will not re-emit the tables unless it is passed write_all_tables=TRUE. }
{GLOBAL}
procedure jpeg_write_tables (cinfo : j_compress_ptr);
implementation
procedure jpeg_create_compress(cinfo : j_compress_ptr);
begin
jpeg_CreateCompress(cinfo, JPEG_LIB_VERSION,
size_t(sizeof(jpeg_compress_struct)));
end;
{ Initialization of a JPEG compression object.
The error manager must already be set up (in case memory manager fails). }
{GLOBAL}
procedure jpeg_CreateCompress (cinfo : j_compress_ptr;
version : int;
structsize : size_t);
var
i : int;
var
err : jpeg_error_mgr_ptr;
client_data : voidp;
begin
{ Guard against version mismatches between library and caller. }
cinfo^.mem := NIL; { so jpeg_destroy knows mem mgr not called }
if (version <> JPEG_LIB_VERSION) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_LIB_VERSION, JPEG_LIB_VERSION, version);
if (structsize <> SIZEOF(jpeg_compress_struct)) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_STRUCT_SIZE,
int(SIZEOF(jpeg_compress_struct)), int(structsize));
{ For debugging purposes, we zero the whole master structure.
But the application has already set the err pointer, and may have set
client_data, so we have to save and restore those fields.
Note: if application hasn't set client_data, tools like Purify may
complain here. }
err := cinfo^.err;
client_data := cinfo^.client_data; { ignore Purify complaint here }
MEMZERO(cinfo, SIZEOF(jpeg_compress_struct));
cinfo^.err := err;
cinfo^.is_decompressor := FALSE;
{ Initialize a memory manager instance for this object }
jinit_memory_mgr(j_common_ptr(cinfo));
{ Zero out pointers to permanent structures. }
cinfo^.progress := NIL;
cinfo^.dest := NIL;
cinfo^.comp_info := NIL;
for i := 0 to pred(NUM_QUANT_TBLS) do
cinfo^.quant_tbl_ptrs[i] := NIL;
for i := 0 to pred(NUM_HUFF_TBLS) do
begin
cinfo^.dc_huff_tbl_ptrs[i] := NIL;
cinfo^.ac_huff_tbl_ptrs[i] := NIL;
end;
cinfo^.script_space := NIL;
cinfo^.input_gamma := 1.0; { in case application forgets }
{ OK, I'm ready }
cinfo^.global_state := CSTATE_START;
end;
{ Destruction of a JPEG compression object }
{GLOBAL}
procedure jpeg_destroy_compress (cinfo : j_compress_ptr);
begin
jpeg_destroy(j_common_ptr(cinfo)); { use common routine }
end;
{ Abort processing of a JPEG compression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort_compress (cinfo : j_compress_ptr);
begin
jpeg_abort(j_common_ptr(cinfo)); { use common routine }
end;
{ Forcibly suppress or un-suppress all quantization and Huffman tables.
Marks all currently defined tables as already written (if suppress)
or not written (if !suppress). This will control whether they get emitted
by a subsequent jpeg_start_compress call.
This routine is exported for use by applications that want to produce
abbreviated JPEG datastreams. It logically belongs in jcparam.c, but
since it is called by jpeg_start_compress, we put it here --- otherwise
jcparam.o would be linked whether the application used it or not. }
{GLOBAL}
procedure jpeg_suppress_tables (cinfo : j_compress_ptr;
suppress : boolean);
var
i : int;
qtbl : JQUANT_TBL_PTR;
htbl : JHUFF_TBL_PTR;
begin
for i := 0 to pred(NUM_QUANT_TBLS) do
begin
qtbl := cinfo^.quant_tbl_ptrs[i];
if (qtbl <> NIL) then
qtbl^.sent_table := suppress;
end;
for i := 0 to pred(NUM_HUFF_TBLS) do
begin
htbl := cinfo^.dc_huff_tbl_ptrs[i];
if (htbl <> NIL) then
htbl^.sent_table := suppress;
htbl := cinfo^.ac_huff_tbl_ptrs[i];
if (htbl <> NIL) then
htbl^.sent_table := suppress;
end;
end;
{ Finish JPEG compression.
If a multipass operating mode was selected, this may do a great deal of
work including most of the actual output. }
{GLOBAL}
procedure jpeg_finish_compress (cinfo : j_compress_ptr);
var
iMCU_row : JDIMENSION;
begin
if (cinfo^.global_state = CSTATE_SCANNING) or
(cinfo^.global_state = CSTATE_RAW_OK) then
begin
{ Terminate first pass }
if (cinfo^.next_scanline < cinfo^.image_height) then
ERREXIT(j_common_ptr(cinfo), JERR_TOO_LITTLE_DATA);
cinfo^.master^.finish_pass (cinfo);
end
else
if (cinfo^.global_state <> CSTATE_WRCOEFS) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Perform any remaining passes }
while (not cinfo^.master^.is_last_pass) do
begin
cinfo^.master^.prepare_for_pass (cinfo);
for iMCU_row := 0 to pred(cinfo^.total_iMCU_rows) do
begin
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (iMCU_row);
cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ We bypass the main controller and invoke coef controller directly;
all work is being done from the coefficient buffer. }
if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(NIL))) then
ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND);
end;
cinfo^.master^.finish_pass (cinfo);
end;
{ Write EOI, do final cleanup }
cinfo^.marker^.write_file_trailer (cinfo);
cinfo^.dest^.term_destination (cinfo);
{ We can use jpeg_abort to release memory and reset global_state }
jpeg_abort(j_common_ptr(cinfo));
end;
{ Write a special marker.
This is only recommended for writing COM or APPn markers.
Must be called after jpeg_start_compress() and before
first call to jpeg_write_scanlines() or jpeg_write_raw_data(). }
{GLOBAL}
procedure jpeg_write_marker (cinfo : j_compress_ptr;
marker : int;
dataptr : JOCTETptr;
datalen : uInt);
var
write_marker_byte : procedure(info : j_compress_ptr; val : int);
begin
if (cinfo^.next_scanline <> 0) or
((cinfo^.global_state <> CSTATE_SCANNING) and
(cinfo^.global_state <> CSTATE_RAW_OK) and
(cinfo^.global_state <> CSTATE_WRCOEFS)) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
cinfo^.marker^.write_marker_header (cinfo, marker, datalen);
write_marker_byte := cinfo^.marker^.write_marker_byte; { copy for speed }
while (datalen <> 0) do
begin
Dec(datalen);
write_marker_byte (cinfo, dataptr^);
Inc(dataptr);
end;
end;
{ Same, but piecemeal. }
{GLOBAL}
procedure jpeg_write_m_header (cinfo : j_compress_ptr;
marker : int;
datalen : uint);
begin
if (cinfo^.next_scanline <> 0) or
((cinfo^.global_state <> CSTATE_SCANNING) and
(cinfo^.global_state <> CSTATE_RAW_OK) and
(cinfo^.global_state <> CSTATE_WRCOEFS)) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
cinfo^.marker^.write_marker_header (cinfo, marker, datalen);
end;
{GLOBAL}
procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int);
begin
cinfo^.marker^.write_marker_byte (cinfo, val);
end;
{ Alternate compression function: just write an abbreviated table file.
Before calling this, all parameters and a data destination must be set up.
To produce a pair of files containing abbreviated tables and abbreviated
image data, one would proceed as follows:
initialize JPEG object
set JPEG parameters
set destination to table file
jpeg_write_tables(cinfo);
set destination to image file
jpeg_start_compress(cinfo, FALSE);
write data...
jpeg_finish_compress(cinfo);
jpeg_write_tables has the side effect of marking all tables written
(same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress
will not re-emit the tables unless it is passed write_all_tables=TRUE. }
{GLOBAL}
procedure jpeg_write_tables (cinfo : j_compress_ptr);
begin
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ (Re)initialize error mgr and destination modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.dest^.init_destination (cinfo);
{ Initialize the marker writer ... bit of a crock to do it here. }
jinit_marker_writer(cinfo);
{ Write them tables! }
cinfo^.marker^.write_tables_only (cinfo);
{ And clean up. }
cinfo^.dest^.term_destination (cinfo);
{ In library releases up through v6a, we called jpeg_abort() here to free
any working memory allocated by the destination manager and marker
writer. Some applications had a problem with that: they allocated space
of their own from the library memory manager, and didn't want it to go
away during write_tables. So now we do nothing. This will cause a
memory leak if an app calls write_tables repeatedly without doing a full
compression cycle or otherwise resetting the JPEG object. However, that
seems less bad than unexpectedly freeing memory in the normal case.
An app that prefers the old behavior can call jpeg_abort for itself after
each call to jpeg_write_tables(). }
end;
end.
unit imjcapimin;
{$N+}
{ This file contains application interface code for the compression half
of the JPEG library. These are the "minimum" API routines that may be
needed in either the normal full-compression case or the transcoding-only
case.
Most of the routines intended to be called directly by an application
are in this file or in jcapistd.c. But also see jcparam.c for
parameter-setup helper routines, jcomapi.c for routines shared by
compression and decompression, and jctrans.c for the transcoding case. }
{ jcapimin.c ; Copyright (C) 1994-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjcomapi,
imjmemmgr,
imjcmarker;
{ Initialization of JPEG compression objects.
Nomssi: This is a macro in the original code.
jpeg_create_compress() and jpeg_create_decompress() are the exported
names that applications should call. These expand to calls on
jpeg_CreateCompress and jpeg_CreateDecompress with additional information
passed for version mismatch checking.
NB: you must set up the error-manager BEFORE calling jpeg_create_xxx. }
procedure jpeg_create_compress(cinfo : j_compress_ptr);
{ Initialization of a JPEG compression object.
The error manager must already be set up (in case memory manager fails). }
{GLOBAL}
procedure jpeg_CreateCompress (cinfo : j_compress_ptr;
version : int;
structsize : size_t);
{ Destruction of a JPEG compression object }
{GLOBAL}
procedure jpeg_destroy_compress (cinfo : j_compress_ptr);
{ Abort processing of a JPEG compression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort_compress (cinfo : j_compress_ptr);
{ Forcibly suppress or un-suppress all quantization and Huffman tables.
Marks all currently defined tables as already written (if suppress)
or not written (if !suppress). This will control whether they get emitted
by a subsequent jpeg_start_compress call.
This routine is exported for use by applications that want to produce
abbreviated JPEG datastreams. It logically belongs in jcparam.c, but
since it is called by jpeg_start_compress, we put it here --- otherwise
jcparam.o would be linked whether the application used it or not. }
{GLOBAL}
procedure jpeg_suppress_tables (cinfo : j_compress_ptr;
suppress : boolean);
{ Finish JPEG compression.
If a multipass operating mode was selected, this may do a great deal of
work including most of the actual output. }
{GLOBAL}
procedure jpeg_finish_compress (cinfo : j_compress_ptr);
{ Write a special marker.
This is only recommended for writing COM or APPn markers.
Must be called after jpeg_start_compress() and before
first call to jpeg_write_scanlines() or jpeg_write_raw_data(). }
{GLOBAL}
procedure jpeg_write_marker (cinfo : j_compress_ptr;
marker : int;
dataptr : JOCTETptr;
datalen : uInt);
{GLOBAL}
procedure jpeg_write_m_header (cinfo : j_compress_ptr;
marker : int;
datalen : uint);
{GLOBAL}
procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int);
{ Alternate compression function: just write an abbreviated table file.
Before calling this, all parameters and a data destination must be set up.
To produce a pair of files containing abbreviated tables and abbreviated
image data, one would proceed as follows:
initialize JPEG object
set JPEG parameters
set destination to table file
jpeg_write_tables(cinfo);
set destination to image file
jpeg_start_compress(cinfo, FALSE);
write data...
jpeg_finish_compress(cinfo);
jpeg_write_tables has the side effect of marking all tables written
(same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress
will not re-emit the tables unless it is passed write_all_tables=TRUE. }
{GLOBAL}
procedure jpeg_write_tables (cinfo : j_compress_ptr);
implementation
procedure jpeg_create_compress(cinfo : j_compress_ptr);
begin
jpeg_CreateCompress(cinfo, JPEG_LIB_VERSION,
size_t(sizeof(jpeg_compress_struct)));
end;
{ Initialization of a JPEG compression object.
The error manager must already be set up (in case memory manager fails). }
{GLOBAL}
procedure jpeg_CreateCompress (cinfo : j_compress_ptr;
version : int;
structsize : size_t);
var
i : int;
var
err : jpeg_error_mgr_ptr;
client_data : voidp;
begin
{ Guard against version mismatches between library and caller. }
cinfo^.mem := NIL; { so jpeg_destroy knows mem mgr not called }
if (version <> JPEG_LIB_VERSION) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_LIB_VERSION, JPEG_LIB_VERSION, version);
if (structsize <> SIZEOF(jpeg_compress_struct)) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_STRUCT_SIZE,
int(SIZEOF(jpeg_compress_struct)), int(structsize));
{ For debugging purposes, we zero the whole master structure.
But the application has already set the err pointer, and may have set
client_data, so we have to save and restore those fields.
Note: if application hasn't set client_data, tools like Purify may
complain here. }
err := cinfo^.err;
client_data := cinfo^.client_data; { ignore Purify complaint here }
MEMZERO(cinfo, SIZEOF(jpeg_compress_struct));
cinfo^.err := err;
cinfo^.is_decompressor := FALSE;
{ Initialize a memory manager instance for this object }
jinit_memory_mgr(j_common_ptr(cinfo));
{ Zero out pointers to permanent structures. }
cinfo^.progress := NIL;
cinfo^.dest := NIL;
cinfo^.comp_info := NIL;
for i := 0 to pred(NUM_QUANT_TBLS) do
cinfo^.quant_tbl_ptrs[i] := NIL;
for i := 0 to pred(NUM_HUFF_TBLS) do
begin
cinfo^.dc_huff_tbl_ptrs[i] := NIL;
cinfo^.ac_huff_tbl_ptrs[i] := NIL;
end;
cinfo^.script_space := NIL;
cinfo^.input_gamma := 1.0; { in case application forgets }
{ OK, I'm ready }
cinfo^.global_state := CSTATE_START;
end;
{ Destruction of a JPEG compression object }
{GLOBAL}
procedure jpeg_destroy_compress (cinfo : j_compress_ptr);
begin
jpeg_destroy(j_common_ptr(cinfo)); { use common routine }
end;
{ Abort processing of a JPEG compression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort_compress (cinfo : j_compress_ptr);
begin
jpeg_abort(j_common_ptr(cinfo)); { use common routine }
end;
{ Forcibly suppress or un-suppress all quantization and Huffman tables.
Marks all currently defined tables as already written (if suppress)
or not written (if !suppress). This will control whether they get emitted
by a subsequent jpeg_start_compress call.
This routine is exported for use by applications that want to produce
abbreviated JPEG datastreams. It logically belongs in jcparam.c, but
since it is called by jpeg_start_compress, we put it here --- otherwise
jcparam.o would be linked whether the application used it or not. }
{GLOBAL}
procedure jpeg_suppress_tables (cinfo : j_compress_ptr;
suppress : boolean);
var
i : int;
qtbl : JQUANT_TBL_PTR;
htbl : JHUFF_TBL_PTR;
begin
for i := 0 to pred(NUM_QUANT_TBLS) do
begin
qtbl := cinfo^.quant_tbl_ptrs[i];
if (qtbl <> NIL) then
qtbl^.sent_table := suppress;
end;
for i := 0 to pred(NUM_HUFF_TBLS) do
begin
htbl := cinfo^.dc_huff_tbl_ptrs[i];
if (htbl <> NIL) then
htbl^.sent_table := suppress;
htbl := cinfo^.ac_huff_tbl_ptrs[i];
if (htbl <> NIL) then
htbl^.sent_table := suppress;
end;
end;
{ Finish JPEG compression.
If a multipass operating mode was selected, this may do a great deal of
work including most of the actual output. }
{GLOBAL}
procedure jpeg_finish_compress (cinfo : j_compress_ptr);
var
iMCU_row : JDIMENSION;
begin
if (cinfo^.global_state = CSTATE_SCANNING) or
(cinfo^.global_state = CSTATE_RAW_OK) then
begin
{ Terminate first pass }
if (cinfo^.next_scanline < cinfo^.image_height) then
ERREXIT(j_common_ptr(cinfo), JERR_TOO_LITTLE_DATA);
cinfo^.master^.finish_pass (cinfo);
end
else
if (cinfo^.global_state <> CSTATE_WRCOEFS) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Perform any remaining passes }
while (not cinfo^.master^.is_last_pass) do
begin
cinfo^.master^.prepare_for_pass (cinfo);
for iMCU_row := 0 to pred(cinfo^.total_iMCU_rows) do
begin
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (iMCU_row);
cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ We bypass the main controller and invoke coef controller directly;
all work is being done from the coefficient buffer. }
if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(NIL))) then
ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND);
end;
cinfo^.master^.finish_pass (cinfo);
end;
{ Write EOI, do final cleanup }
cinfo^.marker^.write_file_trailer (cinfo);
cinfo^.dest^.term_destination (cinfo);
{ We can use jpeg_abort to release memory and reset global_state }
jpeg_abort(j_common_ptr(cinfo));
end;
{ Write a special marker.
This is only recommended for writing COM or APPn markers.
Must be called after jpeg_start_compress() and before
first call to jpeg_write_scanlines() or jpeg_write_raw_data(). }
{GLOBAL}
procedure jpeg_write_marker (cinfo : j_compress_ptr;
marker : int;
dataptr : JOCTETptr;
datalen : uInt);
var
write_marker_byte : procedure(info : j_compress_ptr; val : int);
begin
if (cinfo^.next_scanline <> 0) or
((cinfo^.global_state <> CSTATE_SCANNING) and
(cinfo^.global_state <> CSTATE_RAW_OK) and
(cinfo^.global_state <> CSTATE_WRCOEFS)) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
cinfo^.marker^.write_marker_header (cinfo, marker, datalen);
write_marker_byte := cinfo^.marker^.write_marker_byte; { copy for speed }
while (datalen <> 0) do
begin
Dec(datalen);
write_marker_byte (cinfo, dataptr^);
Inc(dataptr);
end;
end;
{ Same, but piecemeal. }
{GLOBAL}
procedure jpeg_write_m_header (cinfo : j_compress_ptr;
marker : int;
datalen : uint);
begin
if (cinfo^.next_scanline <> 0) or
((cinfo^.global_state <> CSTATE_SCANNING) and
(cinfo^.global_state <> CSTATE_RAW_OK) and
(cinfo^.global_state <> CSTATE_WRCOEFS)) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
cinfo^.marker^.write_marker_header (cinfo, marker, datalen);
end;
{GLOBAL}
procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int);
begin
cinfo^.marker^.write_marker_byte (cinfo, val);
end;
{ Alternate compression function: just write an abbreviated table file.
Before calling this, all parameters and a data destination must be set up.
To produce a pair of files containing abbreviated tables and abbreviated
image data, one would proceed as follows:
initialize JPEG object
set JPEG parameters
set destination to table file
jpeg_write_tables(cinfo);
set destination to image file
jpeg_start_compress(cinfo, FALSE);
write data...
jpeg_finish_compress(cinfo);
jpeg_write_tables has the side effect of marking all tables written
(same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress
will not re-emit the tables unless it is passed write_all_tables=TRUE. }
{GLOBAL}
procedure jpeg_write_tables (cinfo : j_compress_ptr);
begin
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ (Re)initialize error mgr and destination modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.dest^.init_destination (cinfo);
{ Initialize the marker writer ... bit of a crock to do it here. }
jinit_marker_writer(cinfo);
{ Write them tables! }
cinfo^.marker^.write_tables_only (cinfo);
{ And clean up. }
cinfo^.dest^.term_destination (cinfo);
{ In library releases up through v6a, we called jpeg_abort() here to free
any working memory allocated by the destination manager and marker
writer. Some applications had a problem with that: they allocated space
of their own from the library memory manager, and didn't want it to go
away during write_tables. So now we do nothing. This will cause a
memory leak if an app calls write_tables repeatedly without doing a full
compression cycle or otherwise resetting the JPEG object. However, that
seems less bad than unexpectedly freeing memory in the normal case.
An app that prefers the old behavior can call jpeg_abort for itself after
each call to jpeg_write_tables(). }
end;
end.

444
Imaging/JpegLib/imjcapistd.pas
View File

@ -1,222 +1,222 @@
unit imjcapistd;
{ Original : jcapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file.
This file contains application interface code for the compression half
of the JPEG library. These are the "standard" API routines that are
used in the normal full-compression case. They are not used by a
transcoding-only application. Note that if an application links in
jpeg_start_compress, it will end up linking in the entire compressor.
We thus must separate this file from jcapimin.c to avoid linking the
whole compression library into a transcoder. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjcapimin, imjcinit;
{ Compression initialization.
Before calling this, all parameters and a data destination must be set up.
We require a write_all_tables parameter as a failsafe check when writing
multiple datastreams from the same compression object. Since prior runs
will have left all the tables marked sent_table=TRUE, a subsequent run
would emit an abbreviated stream (no tables) by default. This may be what
is wanted, but for safety's sake it should not be the default behavior:
programmers should have to make a deliberate choice to emit abbreviated
images. Therefore the documentation and examples should encourage people
to pass write_all_tables=TRUE; then it will take active thought to do the
wrong thing. }
{GLOBAL}
procedure jpeg_start_compress (cinfo : j_compress_ptr;
write_all_tables : boolean);
{ Write some scanlines of data to the JPEG compressor.
The return value will be the number of lines actually written.
This should be less than the supplied num_lines only in case that
the data destination module has requested suspension of the compressor,
or if more than image_height scanlines are passed in.
Note: we warn about excess calls to jpeg_write_scanlines() since
this likely signals an application programmer error. However,
excess scanlines passed in the last valid call are *silently* ignored,
so that the application need not adjust num_lines for end-of-image
when using a multiple-scanline buffer. }
{GLOBAL}
function jpeg_write_scanlines (cinfo : j_compress_ptr;
scanlines : JSAMPARRAY;
num_lines : JDIMENSION) : JDIMENSION;
{ Alternate entry point to write raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_write_raw_data (cinfo : j_compress_ptr;
data : JSAMPIMAGE;
num_lines : JDIMENSION) : JDIMENSION;
implementation
{ Compression initialization.
Before calling this, all parameters and a data destination must be set up.
We require a write_all_tables parameter as a failsafe check when writing
multiple datastreams from the same compression object. Since prior runs
will have left all the tables marked sent_table=TRUE, a subsequent run
would emit an abbreviated stream (no tables) by default. This may be what
is wanted, but for safety's sake it should not be the default behavior:
programmers should have to make a deliberate choice to emit abbreviated
images. Therefore the documentation and examples should encourage people
to pass write_all_tables=TRUE; then it will take active thought to do the
wrong thing. }
{GLOBAL}
procedure jpeg_start_compress (cinfo : j_compress_ptr;
write_all_tables : boolean);
begin
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (write_all_tables) then
jpeg_suppress_tables(cinfo, FALSE); { mark all tables to be written }
{ (Re)initialize error mgr and destination modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.dest^.init_destination (cinfo);
{ Perform master selection of active modules }
jinit_compress_master(cinfo);
{ Set up for the first pass }
cinfo^.master^.prepare_for_pass (cinfo);
{ Ready for application to drive first pass through jpeg_write_scanlines
or jpeg_write_raw_data. }
cinfo^.next_scanline := 0;
if cinfo^.raw_data_in then
cinfo^.global_state := CSTATE_RAW_OK
else
cinfo^.global_state := CSTATE_SCANNING;
end;
{ Write some scanlines of data to the JPEG compressor.
The return value will be the number of lines actually written.
This should be less than the supplied num_lines only in case that
the data destination module has requested suspension of the compressor,
or if more than image_height scanlines are passed in.
Note: we warn about excess calls to jpeg_write_scanlines() since
this likely signals an application programmer error. However,
excess scanlines passed in the last valid call are *silently* ignored,
so that the application need not adjust num_lines for end-of-image
when using a multiple-scanline buffer. }
{GLOBAL}
function jpeg_write_scanlines (cinfo : j_compress_ptr;
scanlines : JSAMPARRAY;
num_lines : JDIMENSION) : JDIMENSION;
var
row_ctr, rows_left : JDIMENSION;
begin
if (cinfo^.global_state <> CSTATE_SCANNING) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.next_scanline >= cinfo^.image_height) then
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.next_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.image_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Give master control module another chance if this is first call to
jpeg_write_scanlines. This lets output of the frame/scan headers be
delayed so that application can write COM, etc, markers between
jpeg_start_compress and jpeg_write_scanlines. }
if (cinfo^.master^.call_pass_startup) then
cinfo^.master^.pass_startup (cinfo);
{ Ignore any extra scanlines at bottom of image. }
rows_left := cinfo^.image_height - cinfo^.next_scanline;
if (num_lines > rows_left) then
num_lines := rows_left;
row_ctr := 0;
cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, num_lines);
Inc(cinfo^.next_scanline, row_ctr);
jpeg_write_scanlines := row_ctr;
end;
{ Alternate entry point to write raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_write_raw_data (cinfo : j_compress_ptr;
data : JSAMPIMAGE;
num_lines : JDIMENSION) : JDIMENSION;
var
lines_per_iMCU_row : JDIMENSION;
begin
if (cinfo^.global_state <> CSTATE_RAW_OK) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.next_scanline >= cinfo^.image_height) then
begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_write_raw_data := 0;
exit;
end;
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long(cinfo^.next_scanline);
cinfo^.progress^.pass_limit := long(cinfo^.image_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Give master control module another chance if this is first call to
jpeg_write_raw_data. This lets output of the frame/scan headers be
delayed so that application can write COM, etc, markers between
jpeg_start_compress and jpeg_write_raw_data. }
if (cinfo^.master^.call_pass_startup) then
cinfo^.master^.pass_startup (cinfo);
{ Verify that at least one iMCU row has been passed. }
lines_per_iMCU_row := cinfo^.max_v_samp_factor * DCTSIZE;
if (num_lines < lines_per_iMCU_row) then
ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE);
{ Directly compress the row. }
if (not cinfo^.coef^.compress_data (cinfo, data)) then
begin
{ If compressor did not consume the whole row, suspend processing. }
jpeg_write_raw_data := 0;
exit;
end;