mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 11:09:42 +02:00
* add emulation for go32v2 and display currently extraced file
and changes by Gabor for scrolling support (merged)
This commit is contained in:
pierre
parent
83d20f9b14
commit
9edea136d0
@ -63,6 +63,9 @@ program install;
|
||||
{$ENDIF VirtualPascal}
|
||||
{$ENDIF FPC}
|
||||
{$ENDIF OS2}
|
||||
{$IFDEF GO32V2}
|
||||
emu387,
|
||||
{$ENDIF}
|
||||
{$ifdef HEAPTRC}
|
||||
heaptrc,
|
||||
{$endif HEAPTRC}
|
||||
@ -74,12 +77,15 @@ program install;
|
||||
{$IFDEF DLL}
|
||||
unzipdll,
|
||||
{$ENDIF}
|
||||
app,dialogs,views,menus,msgbox,colortxt,tabs,inststr;
|
||||
app,dialogs,views,menus,msgbox,colortxt,tabs,inststr,scroll;
|
||||
|
||||
|
||||
const
|
||||
installerversion='1.02';
|
||||
|
||||
|
||||
{$ifdef TP}lfnsupport=false;{$endif}
|
||||
|
||||
maxpacks=10;
|
||||
maxpackages=20;
|
||||
maxdefcfgs=1024;
|
||||
@ -149,6 +155,7 @@ program install;
|
||||
punzipdialog=^tunzipdialog;
|
||||
tunzipdialog=object(tdialog)
|
||||
filetext : pstatictext;
|
||||
extractfiletext : pstatictext;
|
||||
constructor Init(var Bounds: TRect; ATitle: TTitleStr);
|
||||
procedure do_unzip(s,topath:string);
|
||||
end;
|
||||
@ -466,17 +473,33 @@ program install;
|
||||
begin
|
||||
inherited init(bounds,atitle);
|
||||
(* R.Assign (11, 4, 38, 6);*)
|
||||
R.Assign (1, 4, 39, 6);
|
||||
R.Assign (1, 4,bounds.B.X-Bounds.A.X-2, 6);
|
||||
filetext:=new(pstatictext,init(r,#3'File: '));
|
||||
insert(filetext);
|
||||
R.Assign (1, 7,bounds.B.X-Bounds.A.X-2, 9);
|
||||
extractfiletext:=new(pstatictext,init(r,#3' '));
|
||||
insert(extractfiletext);
|
||||
end;
|
||||
|
||||
{$IFNDEF DLL}
|
||||
procedure UnzipCheckFn (Retcode: longint; Rec: pReportRec );{$ifdef Delphi32}STDCALL;{$endif}
|
||||
{$IFNDEF BIT32} FAR;{$ENDIF BIT32}
|
||||
var
|
||||
name : string;
|
||||
begin
|
||||
case Rec^.Status of
|
||||
unzip_starting: UnzipErr := 0;
|
||||
unzip_starting:
|
||||
UnzipErr := 0;
|
||||
file_starting:
|
||||
begin
|
||||
with UnzDlg^.extractfiletext^ do
|
||||
begin
|
||||
Disposestr(text);
|
||||
name:=Strpas(Rec^.FileName);
|
||||
Text:=NewStr(#3+name);
|
||||
DrawView;
|
||||
end;
|
||||
end;
|
||||
file_failure: UnzipErr := RetCode;
|
||||
file_unzipping:
|
||||
begin
|
||||
@ -730,6 +753,9 @@ program install;
|
||||
titletext : pcoloredtext;
|
||||
labcfg : plabel;
|
||||
cfgcb : pcheckboxes;
|
||||
scrollbox: pscrollbox;
|
||||
sbr,sbsbr: trect;
|
||||
sbsb: pscrollbar;
|
||||
begin
|
||||
f:=nil;
|
||||
{ walk packages reverse and insert a newsitem for each, and set the mask }
|
||||
@ -822,18 +848,39 @@ program install;
|
||||
{-------- Pack Sheets ----------}
|
||||
for j:=1 to cfg.packs do
|
||||
begin
|
||||
R.Copy (TabIR);
|
||||
R.Copy(TabIR);
|
||||
if R.A.Y+cfg.pack[j].packages>R.B.Y then
|
||||
R.B.Y:=R.A.Y+cfg.pack[j].packages;
|
||||
new(packcbs[j],init(r,items[j]));
|
||||
if data.packmask[j]=$ffff then
|
||||
data.packmask[j]:=packmask[j];
|
||||
packcbs[j]^.enablemask:=packmask[j];
|
||||
packcbs[j]^.enablemask:={$ifdef DEV}$7fffffff{$else}packmask[j]{$endif};
|
||||
packcbs[j]^.movedto(firstitem[j]);
|
||||
end;
|
||||
|
||||
{--------- Main ---------}
|
||||
packtd:=nil;
|
||||
sbr.assign(1,3,tabr.b.x-tabr.a.x-3,tabr.b.y-tabr.a.y-1);
|
||||
for j:=cfg.packs downto 1 do
|
||||
packtd:=NewTabDef(cfg.pack[j].name,packcbs[j],NewTabItem(packcbs[j],nil),packtd);
|
||||
begin
|
||||
if (sbr.b.y-sbr.a.y)<cfg.pack[j].packages then
|
||||
begin
|
||||
sbsbr.assign(sbr.b.x,sbr.a.y,sbr.b.x+1,sbr.b.y);
|
||||
New(sbsb, init(sbsbr));
|
||||
end
|
||||
else
|
||||
sbsb:=nil;
|
||||
New(ScrollBox, Init(sbr, nil, sbsb));
|
||||
PackCbs[j]^.MoveTo(0,0);
|
||||
ScrollBox^.Insert(PackCbs[j]);
|
||||
|
||||
packtd:=NewTabDef(
|
||||
cfg.pack[j].name,ScrollBox,
|
||||
NewTabItem(sbsb,
|
||||
NewTabItem(ScrollBox,
|
||||
nil)),
|
||||
packtd);
|
||||
end;
|
||||
|
||||
New(Tab, Init(TabR,
|
||||
NewTabDef(dialog_install_general,IlPath,
|
||||
@ -846,6 +893,7 @@ program install;
|
||||
packtd)
|
||||
));
|
||||
Tab^.GrowMode:=0;
|
||||
|
||||
Insert(Tab);
|
||||
|
||||
line:=tabr.b.y;
|
||||
@ -1038,7 +1086,7 @@ program install;
|
||||
for j:=1 to cfg.packs do
|
||||
with cfg.pack[j] do
|
||||
begin
|
||||
r.assign(20,7,60,16);
|
||||
r.assign(10,7,70,18);
|
||||
UnzDlg:=new(punzipdialog,init(r,dialog_unzipdialog_title));
|
||||
desktop^.insert(UnzDlg);
|
||||
for i:=1 to packages do
|
||||
@ -1442,7 +1490,11 @@ begin
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.6 2000-09-22 12:15:49 florian
|
||||
Revision 1.7 2000-09-22 23:13:37 pierre
|
||||
* add emulation for go32v2 and display currently extraced file
|
||||
and changes by Gabor for scrolling support (merged)
|
||||
|
||||
Revision 1.6 2000/09/22 12:15:49 florian
|
||||
+ support of Russian (Windows)
|
||||
|
||||
Revision 1.5 2000/09/22 11:07:51 florian
|
||||
@ -1461,112 +1513,4 @@ end.
|
||||
Revision 1.1 2000/07/13 06:30:21 michael
|
||||
+ Initial import
|
||||
|
||||
Revision 1.20 2000/07/09 12:55:45 hajny
|
||||
* updated for version 1.0
|
||||
|
||||
Revision 1.19 2000/06/18 18:27:32 hajny
|
||||
+ archive validity checking, progress indicator, better error checking
|
||||
|
||||
Revision 1.18 2000/02/24 17:47:47 peter
|
||||
* last fixes for 0.99.14a release
|
||||
|
||||
Revision 1.17 2000/02/23 17:17:56 peter
|
||||
* write ppc386.cfg for all found targets
|
||||
|
||||
Revision 1.16 2000/02/06 12:59:39 peter
|
||||
* change upper -> upcase
|
||||
* fixed stupid debugging leftover with diskspace check
|
||||
|
||||
Revision 1.15 2000/02/02 17:19:10 pierre
|
||||
* avoid diskfree problem and get mouse visible
|
||||
|
||||
Revision 1.14 2000/02/02 15:21:31 peter
|
||||
* show errorcode in message when error in unzipping
|
||||
|
||||
Revision 1.13 2000/01/26 21:49:33 peter
|
||||
* install.pas compilable by FPC again
|
||||
* removed some notes from unzip.pas
|
||||
* support installer creation under linux (install has name conflict)
|
||||
|
||||
Revision 1.12 2000/01/26 21:15:59 hajny
|
||||
* compilable with TP again (lines < 127install.pas, ifdef around findclose)
|
||||
|
||||
Revision 1.11 2000/01/24 22:21:48 peter
|
||||
* new install version (keys not wrong correct yet)
|
||||
|
||||
Revision 1.10 2000/01/18 00:22:48 peter
|
||||
* fixed uninited local var
|
||||
|
||||
Revision 1.9 1999/08/03 20:21:53 peter
|
||||
* fixed sources mask which was not set correctly
|
||||
|
||||
Revision 1.7 1999/07/01 07:56:58 hajny
|
||||
* installation to root fixed
|
||||
|
||||
Revision 1.6 1999/06/29 22:20:19 peter
|
||||
* updated to use tab pages
|
||||
|
||||
Revision 1.5 1999/06/25 07:06:30 hajny
|
||||
+ searching for installation script updated
|
||||
|
||||
Revision 1.4 1999/06/10 20:01:23 peter
|
||||
+ fcl,fv,gtk support
|
||||
|
||||
Revision 1.3 1999/06/10 15:00:14 peter
|
||||
* fixed to compile for not os2
|
||||
* update install.dat
|
||||
|
||||
Revision 1.2 1999/06/10 07:28:27 hajny
|
||||
* compilable with TP again
|
||||
|
||||
Revision 1.1 1999/02/19 16:45:26 peter
|
||||
* moved to fpinst/ directory
|
||||
+ makefile
|
||||
|
||||
Revision 1.15 1999/02/17 22:34:08 peter
|
||||
* updates from TH for OS2
|
||||
|
||||
Revision 1.14 1998/12/22 22:47:34 peter
|
||||
* updates for OS2
|
||||
* small fixes
|
||||
|
||||
Revision 1.13 1998/12/21 13:11:39 peter
|
||||
* updates for 0.99.10
|
||||
|
||||
Revision 1.12 1998/12/16 00:25:34 peter
|
||||
* updated for 0.99.10
|
||||
* new end dialogbox
|
||||
|
||||
Revision 1.11 1998/11/01 20:32:25 peter
|
||||
* packed record
|
||||
|
||||
Revision 1.10 1998/10/25 23:38:35 peter
|
||||
* removed warnings
|
||||
|
||||
Revision 1.9 1998/10/23 16:57:40 pierre
|
||||
* compiles without -So option
|
||||
* the main dialog init was buggy !!
|
||||
|
||||
Revision 1.8 1998/09/22 21:10:31 jonas
|
||||
* initialize cfg and data with 0 at startup
|
||||
|
||||
Revision 1.7 1998/09/16 16:46:37 peter
|
||||
+ updates
|
||||
|
||||
Revision 1.6 1998/09/15 13:11:14 pierre
|
||||
small fix to cleanup if no package
|
||||
|
||||
Revision 1.5 1998/09/15 12:06:06 peter
|
||||
* install updated to support w32 and dos and config file
|
||||
|
||||
Revision 1.4 1998/09/10 10:50:49 florian
|
||||
* DOS install program updated
|
||||
|
||||
Revision 1.3 1998/09/09 13:39:58 peter
|
||||
+ internal unzip
|
||||
* dialog is showed automaticly
|
||||
|
||||
Revision 1.2 1998/04/07 22:47:57 florian
|
||||
+ version/release/patch numbers as string added
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
260
install/fpinst/scroll.pas
Normal file
260
install/fpinst/scroll.pas
Normal file
@ -0,0 +1,260 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2000 by B‚rczi, G bor
|
||||
member of the Free Pascal development team
|
||||
|
||||
Support objects for the install program
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
unit Scroll;
|
||||
|
||||
interface
|
||||
|
||||
uses Objects,Commands,Drivers,Views,App;
|
||||
|
||||
const
|
||||
CScrollBoxBackground = #6;
|
||||
|
||||
type
|
||||
PScrollBoxBackground = ^TScrollBoxBackground;
|
||||
TScrollBoxBackground = object(TBackground)
|
||||
function GetPalette: PPalette; virtual;
|
||||
end;
|
||||
|
||||
PScrollBox = ^TScrollBox;
|
||||
TScrollBox = object(TGroup)
|
||||
Delta,Limit: TPoint;
|
||||
HScrollBar,VScrollBar: PScrollBar;
|
||||
Background: PScrollBoxBackground;
|
||||
constructor Init(var Bounds: TRect; AHScrollBar, AVScrollBar: PScrollBar);
|
||||
procedure InitBackground; virtual;
|
||||
procedure HandleEvent(var Event: TEvent); virtual;
|
||||
procedure ChangeBounds(var Bounds: TRect); virtual;
|
||||
procedure ScrollDraw; virtual;
|
||||
procedure ScrollTo(X, Y: Sw_Integer);
|
||||
procedure SetLimit(X, Y: Sw_Integer);
|
||||
procedure SetState(AState: Word; Enable: Boolean); virtual;
|
||||
procedure TrackCursor;
|
||||
procedure Draw; virtual;
|
||||
function ClipChilds: boolean; virtual;
|
||||
procedure BeforeInsert(P: PView); virtual;
|
||||
procedure AfterInsert(P: PView); virtual;
|
||||
procedure AfterDelete(P: PView); virtual;
|
||||
private
|
||||
DrawLock: Byte;
|
||||
DrawFlag: Boolean;
|
||||
procedure CheckDraw;
|
||||
procedure UpdateLimits;
|
||||
procedure ShiftViews(DX,DY: sw_integer);
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
function TScrollBoxBackground.GetPalette: PPalette;
|
||||
const P: string[length(CScrollBoxBackground)] = CScrollBoxBackground;
|
||||
begin
|
||||
GetPalette:=@P;
|
||||
end;
|
||||
|
||||
constructor TScrollBox.Init(var Bounds: TRect; AHScrollBar, AVScrollBar: PScrollBar);
|
||||
begin
|
||||
inherited Init(Bounds);
|
||||
EventMask:=EventMask or evBroadcast;
|
||||
HScrollBar:=AHScrollBar; VScrollBar:=AVScrollBar;
|
||||
InitBackground;
|
||||
if Assigned(Background) then Insert(Background);
|
||||
ReDraw;
|
||||
end;
|
||||
|
||||
procedure TScrollBox.InitBackground;
|
||||
var R: TRect;
|
||||
begin
|
||||
GetExtent(R);
|
||||
New(Background, Init(R,' '));
|
||||
end;
|
||||
|
||||
procedure TScrollBox.HandleEvent(var Event: TEvent);
|
||||
begin
|
||||
if (Event.What=evBroadcast) and (Event.Command=cmCursorChanged) then
|
||||
TrackCursor;
|
||||
inherited HandleEvent(Event);
|
||||
end;
|
||||
|
||||
procedure TScrollBox.ChangeBounds(var Bounds: TRect);
|
||||
begin
|
||||
SetBounds(Bounds);
|
||||
Inc(DrawLock);
|
||||
SetLimit(Limit.X, Limit.Y);
|
||||
Dec(DrawLock);
|
||||
DrawFlag := False;
|
||||
DrawView;
|
||||
end;
|
||||
|
||||
procedure TScrollBox.CheckDraw;
|
||||
begin
|
||||
if (DrawLock = 0) and DrawFlag then
|
||||
begin
|
||||
DrawFlag := False;
|
||||
ReDraw; DrawView;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TScrollBox.ScrollDraw;
|
||||
var
|
||||
D: TPoint;
|
||||
begin
|
||||
if HScrollBar <> nil then
|
||||
D.X := HScrollBar^.Value
|
||||
else
|
||||
D.X := 0;
|
||||
if VScrollBar <> nil then
|
||||
D.Y := VScrollBar^.Value
|
||||
else
|
||||
D.Y := 0;
|
||||
if (D.X <> Delta.X) or (D.Y <> Delta.Y) then
|
||||
begin
|
||||
SetCursor(Cursor.X + Delta.X - D.X, Cursor.Y + Delta.Y - D.Y);
|
||||
Delta := D;
|
||||
if DrawLock <> 0 then
|
||||
DrawFlag := True
|
||||
else
|
||||
DrawView;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TScrollBox.ScrollTo(X, Y: Sw_Integer);
|
||||
var DX,DY: sw_integer;
|
||||
begin
|
||||
Inc(DrawLock);
|
||||
DX:=Delta.X-X; DY:=Delta.Y-Y;
|
||||
if HScrollBar <> nil then
|
||||
HScrollBar^.SetValue(X);
|
||||
if VScrollBar <> nil then
|
||||
VScrollBar^.SetValue(Y);
|
||||
ShiftViews(DX,DY);
|
||||
Dec(DrawLock);
|
||||
CheckDraw;
|
||||
end;
|
||||
|
||||
procedure TScrollBox.ShiftViews(DX,DY: sw_integer);
|
||||
procedure DoShift(P: PView); {$ifndef FPC}far;{$endif}
|
||||
begin
|
||||
P^.MoveTo(P^.Origin.X+DX,P^.Origin.Y+DY);
|
||||
end;
|
||||
begin
|
||||
ForEach(@DoShift);
|
||||
end;
|
||||
|
||||
procedure TScrollBox.SetLimit(X, Y: Sw_Integer);
|
||||
begin
|
||||
Limit.X := X;
|
||||
Limit.Y := Y;
|
||||
Inc(DrawLock);
|
||||
if HScrollBar <> nil then
|
||||
HScrollBar^.SetParams(HScrollBar^.Value, 0, X - Size.X, Size.X - 1, HScrollBar^.ArStep);
|
||||
if VScrollBar <> nil then
|
||||
VScrollBar^.SetParams(VScrollBar^.Value, 0, Y - Size.Y, Size.Y - 1, VScrollBar^.ArStep);
|
||||
Dec(DrawLock);
|
||||
CheckDraw;
|
||||
end;
|
||||
|
||||
procedure TScrollBox.SetState(AState: Word; Enable: Boolean);
|
||||
procedure ShowSBar(SBar: PScrollBar);
|
||||
begin
|
||||
if (SBar <> nil) then
|
||||
if GetState(sfActive + sfSelected) then
|
||||
SBar^.Show
|
||||
else
|
||||
SBar^.Hide;
|
||||
end;
|
||||
var OState: word;
|
||||
begin
|
||||
OState:=State;
|
||||
inherited SetState(AState, Enable);
|
||||
if AState and (sfActive + sfSelected) <> 0 then
|
||||
begin
|
||||
ShowSBar(HScrollBar);
|
||||
ShowSBar(VScrollBar);
|
||||
end;
|
||||
if ((OState xor State) and (sfFocused))<>0 then
|
||||
TrackCursor;
|
||||
end;
|
||||
|
||||
procedure TScrollBox.TrackCursor;
|
||||
var V: PView;
|
||||
P,ND: TPoint;
|
||||
begin
|
||||
V:=Current;
|
||||
if (not Assigned(V)) then Exit;
|
||||
P.X:=V^.Origin.X+V^.Cursor.X; P.Y:=V^.Origin.Y+V^.Cursor.Y;
|
||||
ND:=Delta;
|
||||
if (P.X<0) then Dec(ND.X,-P.X) else
|
||||
if (P.X>=Size.X) then Inc(ND.X,P.X-(Size.X-1));
|
||||
if (P.Y<0) then Dec(ND.Y,-P.Y) else
|
||||
if (P.Y>=Size.Y) then Inc(ND.Y,P.Y-(Size.Y-1));
|
||||
if (ND.X<>Delta.X) or (ND.Y<>Delta.Y) then
|
||||
ScrollTo(ND.X,ND.Y);
|
||||
end;
|
||||
|
||||
function TScrollBox.ClipChilds: boolean;
|
||||
begin
|
||||
ClipChilds:=false;
|
||||
end;
|
||||
|
||||
procedure TScrollBox.BeforeInsert(P: PView);
|
||||
begin
|
||||
if Assigned(P) then
|
||||
P^.MoveTo(P^.Origin.X-Delta.X,P^.Origin.Y-Delta.Y);
|
||||
end;
|
||||
|
||||
procedure TScrollBox.AfterInsert(P: PView);
|
||||
begin
|
||||
UpdateLimits;
|
||||
end;
|
||||
|
||||
procedure TScrollBox.AfterDelete(P: PView);
|
||||
begin
|
||||
UpdateLimits;
|
||||
end;
|
||||
|
||||
procedure TScrollBox.Draw;
|
||||
begin
|
||||
inherited Draw;
|
||||
end;
|
||||
|
||||
procedure TScrollBox.UpdateLimits;
|
||||
var Max: TPoint;
|
||||
procedure Check(P: PView); {$ifndef FPC}far;{$endif}
|
||||
var O: TPoint;
|
||||
begin
|
||||
O.X:=P^.Origin.X+P^.Size.X+Delta.X; O.Y:=P^.Origin.Y+P^.Size.Y+Delta.Y;
|
||||
if O.X>Max.X then Max.X:=O.X;
|
||||
if O.Y>Max.Y then Max.Y:=O.Y;
|
||||
end;
|
||||
begin
|
||||
Max.X:=0; Max.Y:=0;
|
||||
ForEach(@Check);
|
||||
if (Max.X<>Limit.X) or (Max.Y<>Limit.Y) then
|
||||
SetLimit(Max.X,Max.Y);
|
||||
end;
|
||||
|
||||
END.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2000-09-22 23:13:37 pierre
|
||||
* add emulation for go32v2 and display currently extraced file
|
||||
and changes by Gabor for scrolling support (merged)
|
||||
|
||||
Revision 1.1.2.1 2000/09/21 10:51:33 pierre
|
||||
new file from Gabor
|
||||
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user