paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 20:19:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ internal unzip

Browse Source 
* dialog is showed automaticly
This commit is contained in:
peter 1998-09-09 13:39:58 +00:00
parent 06104cdb46
commit 56b67785fd
4 changed files with 3652 additions and 544 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

482
install/install.pas
View File

@ -1,9 +1,11 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993,98 by Florian Klaempfl
Copyright (c) 1993-98 by Florian Klaempfl
member of the Free Pascal development team
This is the install program for the DOS version of Free Pascal
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -12,14 +14,12 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{ This is the install program for the DOS version of Free Pascal }
{$A+,B-,D+,E+,F-,G-,I-,L+,N-,O-,P-,Q+,R+,S+,T-,V-,X+,Y+}
{$M 16384,0,16384}
program install;
uses
app,dialogs,views,objects,menus,drivers,strings,msgbox,dos;
app,dialogs,views,objects,menus,drivers,strings,msgbox,dos,unzip,ziptypes;
var
binpath,startpath : string;
@ -27,13 +27,16 @@ program install;
const
version = '0';
release = '99'
patchlevel = '6';
release = '99';
patchlevel = '8';
filenr = version+release+patchlevel;
doc_version = '101';
{*****************************************************************************
Helpers
*****************************************************************************}
procedure uppervar(var s : string);
@ -51,25 +54,21 @@ program install;
file_exists:=fsearch(f,path)<>'';
end;
procedure do_install(const s : string);
function diskspace(const zipfile : string) : string;
var
compressed,uncompressed : longint;
s : string;
begin
if not(file_exists(s+'.ZIP',startpath)) then
begin
messagebox('File: '+s+' missed for the selected installation. '+
'Installation doesn''t becomes complete',nil,mferror+mfokbutton);
halt(1);
end;
swapvectors;
exec(startpath+'\UNZIP.EXE','-qq -o '+startpath+'\'+s);
swapvectors;
if doserror<>0 then
begin
messagebox('Error when extracting. Disk full?',nil,mferror+mfokbutton);
halt(1);
end;
s:=zipfile+#0;
uncompressed:=UnzipSize(@s[1],compressed);
uncompressed:=uncompressed shr 10;
str(uncompressed,s);
diskspace:=' ('+s+' Kb)';
end;
function createdir(const s : string) : boolean;
var
@ -79,80 +78,99 @@ program install;
chdir(s);
if ioresult=0 then
begin
{$ifdef german}
result:=messagebox('Das Installationsverzeichnis existiert schon. '+
'Soll ein neues Installationsverzeichnis angegeben werden?',nil,
mferror+mfyesbutton+mfnobutton);
{$else}
result:=messagebox('The installation directory exists already. '+
'Do want to enter a new installation directory ?',nil,
mferror+mfyesbutton+mfnobutton);
{$endif}
createdir:=result=cmyes;
exit;
end;
mkdir(s);
if ioresult<>0 then
begin
{$ifdef german}
messagebox('Das Installationsverzeichnis konnte nicht angelegt werden',
@s,mferror+mfokbutton);
{$else}
messagebox('The installation directory couldn''t be created',
@s,mferror+mfokbutton);
{$endif}
createdir:=true;
exit;
end;
createdir:=false;
end;
procedure changedir(const s : string);
begin
chdir(s);
if ioresult<>0 then
begin
{$ifdef german}
messagebox('Fehler beim Wechseln in das Installationsverzeichnis. '+
'Installationsprogramm wird beendet',@s,mferror+mfokbutton);
{$else}
messagebox('Error when changing directory ',@s,mferror+mfokbutton);
{$endif}
halt(1);
end;
end;
const
cmstart = 1000;
{*****************************************************************************
TUnZipDialog
*****************************************************************************}
type
punzipdialog=^tunzipdialog;
tunzipdialog=object(tdialog)
filetext : pstatictext;
constructor Init(var Bounds: TRect; ATitle: TTitleStr);
procedure do_unzip(s:string);
end;
constructor tunzipdialog.init;
var
r : trect;
begin
inherited init(bounds,atitle);
R.Assign(11, 4, 38, 5);
filetext:=new(pstatictext,init(r,'File: '));
insert(filetext);
end;
procedure tunzipdialog.do_unzip(s : string);
var
fn,dir,wild : string;
begin
s:=s+'.ZIP';
Disposestr(filetext^.text);
filetext^.Text:=NewStr('File: '+s);
filetext^.drawview;
if not(file_exists(s,startpath)) then
begin
messagebox('File: '+s+' missed for the selected installation. '+
'Installation doesn''t becomes complete',nil,mferror+mfokbutton);
halt(1);
end;
fn:=startpath+'\'+s+#0;
dir:='.'#0;
wild:='*.*'#0;
FileUnzipEx(@fn[1],@dir[1],@wild[1]);
if doserror<>0 then
begin
messagebox('Error when extracting. Disk full?',nil,mferror+mfokbutton);
halt(1);
end;
end;
{*****************************************************************************
TInstallDialog
*****************************************************************************}
type
pinstalldialog = ^tinstalldialog;
tinstalldialog = object(tdialog)
constructor init;
end;
tapp = object(tapplication)
procedure initmenubar;virtual;
procedure handleevent(var event : tevent);virtual;
end;
function diskspace(const zipfile : string) : string;
var
clustersize : longint;
f : file;
begin
diskspace:='';
end;
var
mask_components : longint;
constructor tinstalldialog.init;
constructor tinstalldialog.init;
var
r : trect;
line : integer;
@ -168,11 +186,7 @@ program install;
begin
r.assign(x1,y1,x2,y2);
{$ifdef german}
inherited init(r,'Installieren');
{$else}
inherited init(r,'Install');
{$endif}
line:=2;
r.assign(3,line+1,28,line+2);
p:=new(pinputline,init(r,79));
@ -227,11 +241,26 @@ program install;
f^.select;
end;
procedure tapp.handleevent(var event : tevent);
{*****************************************************************************
TApp
*****************************************************************************}
const
cmstart = 1000;
type
tapp = object(tapplication)
procedure initmenubar;virtual;
procedure handleevent(var event : tevent);virtual;
procedure do_installdialog;
end;
procedure tapp.do_installdialog;
var
p : pinstalldialog;
p2 : pdialog;
p2 : punzipdialog;
p3 : pstatictext;
r : trect;
c : word;
@ -241,6 +270,119 @@ program install;
components : word;
end;
f : file;
label
newpath;
begin
installdata.path:='C:\PP';
installdata.components:=0;
mask_components:=$0;
{ searching files }
if file_exists('BASEDOS.ZIP',startpath) then
inc(mask_components,1);
if file_exists('GNUASLD.ZIP',startpath) then
inc(mask_components,2);
if file_exists('DEMO.ZIP',startpath) then
inc(mask_components,4);
if file_exists('GDB.ZIP',startpath) then
inc(mask_components,8);
if file_exists('GNUUTILS.ZIP',startpath) then
inc(mask_components,16);
if file_exists('DOCS.ZIP',startpath) then
inc(mask_components,32);
if file_exists('DOC+doc_version+PS.ZIP',startpath) then
inc(mask_components,64);
if file_exists('RL'+filenr+'S.ZIP',startpath) then
inc(mask_components,128);
if file_exists('PP'+filenr+'S.ZIP',startpath) then
inc(mask_components,256);
if file_exists('DOC+doc_version+S.ZIP',startpath) then
inc(mask_components,512);
while true do
begin
newpath:
p:=new(pinstalldialog,init);
{ default settings }
c:=executedialog(p,@installdata);
if c=cmok then
begin
if installdata.path[length(installdata.path)]='\' then
dec(byte(installdata.path[0]));
uppervar(installdata.path);
binpath:=installdata.path+'\BIN';
if createdir(installdata.path) then
goto newpath;
changedir(installdata.path);
r.assign(20,7,60,16);
p2:=new(punzipdialog,init(r,'Extracting files'));
desktop^.insert(p2);
if (installdata.components and 1)<>0 then
p2^.do_unzip('BASEDOS');
if (installdata.components and 2)<>0 then
p2^.do_unzip('GNUASLD');
if (installdata.components and 4)<>0 then
p2^.do_unzip('DEMO');
if (installdata.components and 8)<>0 then
p2^.do_unzip('GDB');
if (installdata.components and 16)<>0 then
p2^.do_unzip('GNUUTILS');
if (installdata.components and 32)<>0 then
p2^.do_unzip('DOCS');
if (installdata.components and 64)<>0 then
p2^.do_unzip('DOC+doc_version+PS');
if (installdata.components and 128)<>0 then
p2^.do_unzip('RL'+filenr+'S');
if (installdata.components and 256)<>0 then
p2^.do_unzip('PP'+filenr+'S');
if (installdata.components and 512)<>0 then
p2^.do_unzip('DOC+doc_version+S');
assign(t,'BIN\PPC386.CFG');
rewrite(t);
writeln(t,'-l');
writeln(t,'#ifdef GO32V1');
writeln(t,'-Up',installdata.path+'\RTL\DOS\GO32V1');
writeln(t,'#endif GO32V1');
writeln(t,'#ifdef GO32V2');
writeln(t,'-Up',installdata.path+'\RTL\DOS\GO32V2');
writeln(t,'#endif GO32V2');
writeln(t,'#ifdef Win32');
writeln(t,'-Up',installdata.path+'\RTL\WIN32');
writeln(t,'#endif Win32');
close(t);
desktop^.delete(p2);
dispose(p2,done);
messagebox('Installation successfull',nil,mfinformation+mfokbutton);
successfull:=true;
end;
break;
end;
end;
procedure tapp.handleevent(var event : tevent);
label
insertdisk1,insertdisk2,newpath;
@ -251,185 +393,22 @@ program install;
if event.command=cmstart then
begin
clearevent(event);
installdata.path:='C:\PP';
installdata.components:=0;
mask_components:=$0;
{ searching files }
if file_exists('BASEDOS.ZIP',startpath) then
inc(mask_components,1);
if file_exists('GNUASLD.ZIP',startpath) then
inc(mask_components,2);
if file_exists('DEMO.ZIP',startpath) then
inc(mask_components,4);
if file_exists('GDB.ZIP',startpath) then
inc(mask_components,8);
if file_exists('GNUUTILS.ZIP',startpath) then
inc(mask_components,16);
if file_exists('DOCS.ZIP',startpath) then
inc(mask_components,32);
if file_exists('DOC+doc_version+PS.ZIP',startpath) then
inc(mask_components,64);
if file_exists('RL'+filenr+'S.ZIP',startpath) then
inc(mask_components,128);
if file_exists('PP'+filenr+'S.ZIP',startpath) then
inc(mask_components,256);
if file_exists('DOC+doc_version+S.ZIP',startpath) then
inc(mask_components,512);
while true do
begin
newpath:
p:=new(pinstalldialog,init);
{ default settings }
c:=executedialog(p,@installdata);
if c=cmok then
begin
if installdata.path[length(installdata.path)]='\' then
dec(byte(installdata.path[0]));
uppervar(installdata.path);
binpath:=installdata.path+'\BIN';
if createdir(installdata.path) then
goto newpath;
changedir(installdata.path);
{$ifdef unused_code}
assign(t,'SET_PP.BAT');
rewrite(t);
if ioresult<>0 then
{$ifdef german}
messagebox('Datei SET_PP.BAT konnte nicht erstellt werden',nil,mfokbutton+mferror)
{$else}
messagebox('File SET_PP.BAT can''t be created',nil,mfokbutton+mferror)
{$endif}
else
begin
{ never used:
writeln(t,'SET LINUXUNITS='+installdata.path+'\LINUXUNITS');
writeln(t,'SET PPBIN='+installdata.path+'\BIN');
writeln(t,'SET PASLIB='+installdata.path+'\LIB');
writeln(t,'SET OS2UNITS='+installdata.path+'\OS2UNITS');
writeln(t,'SET DOSUNITS='+installdata.path+'\DOSUNITS;'+installdata.path+'\BIN');
}
writeln('REM This file may contain nothing else');
write(t,'SET GO32=');
{$ifdef german}
if messagebox('Wollen Sie den Coprozessoremulator verwenden?',
nil,mfyesbutton+mfnobutton)=cmyes then
write(t,'emu '+installdata.path+'\DRIVERS\EMU387');
{$else}
if messagebox('Install math coprocessor emulation?',
nil,mfyesbutton+mfnobutton)=cmyes then
write(t,'emu '+installdata.path+'\DRIVERS\EMU387');
{$endif}
writeln(t);
close(t);
end;
{$endif unused_code}
if getenv('UNZIP')<>'' then
begin
{$ifdef german}
messagebox('Die Umgebungsvariable UNZIP sollte'#13+
'nicht gesetzt sein',nil,mfokbutton+mfinformation)
{$else}
messagebox('The enviroment variable UNZIP shouldn''t be set',nil,
mfokbutton+mfinformation)
{$endif}
end;
r.assign(20,7,60,16);
p2:=new(pdialog,init(r,'Information'));
r.assign(6,4,38,5);
{$ifdef german}
p3:=new(pstatictext,init(r,'Dateien werden entpackt ...'));
{$else}
p3:=new(pstatictext,init(r,'Extracting files ...'));
{$endif}
p2^.insert(p3);
desktop^.insert(p2);
if (installdata.components and 1)<>0 then
do_install('BASEDOS');
if (installdata.components and 2)<>0 then
do_install('GNUASLD');
if (installdata.components and 4)<>0 then
do_install('DEMO');
if (installdata.components and 8)<>0 then
do_install('GDB');
if (installdata.components and 16)<>0 then
do_install('GNUUTILS');
if (installdata.components and 32)<>0 then
do_install('DOCS');
if (installdata.components and 64)<>0 then
do_install('DOC+doc_version+PS');
if (installdata.components and 128)<>0 then
do_install('RL'+filenr+'S');
if (installdata.components and 256)<>0 then
do_install('PP'+filenr+'S');
if (installdata.components and 512)<>0 then
do_install('DOC+doc_version+S');
assign(t,'BIN\PPC386.CFG');
rewrite(t);
writeln(t,'-l');
writeln(t,'#section GO32V1');
writeln(t,'-Up',installdata.path+'\RTL\DOS\GO32V1');
writeln(t,'#section GO32V2');
writeln(t,'-Up',installdata.path+'\RTL\DOS\GO32V2');
close(t);
desktop^.delete(p2);
dispose(p2,done);
{$ifdef german}
messagebox('Installation erfolgreich abgeschlossen',nil,mfinformation+mfokbutton);
{$else}
messagebox('Installation successfull',nil,mfinformation+mfokbutton);
{$endif}
event.what:=evcommand;
event.command:=cmquit;
successfull:=true;
handleevent(event);
end;
break;
end;
do_installdialog;
if successfull then
begin
event.what:=evcommand;
event.command:=cmquit;
handleevent(event);
end;
end;
end;
procedure tapp.initmenubar;
var
r : trect;
begin
getextent(r);
r.b.y:=r.a.y+1;
{$ifdef german}
menubar:=new(pmenubar,init(r,newmenu(
newsubmenu('~I~nstallation',hcnocontext,newmenu(
newitem('~S~tart','',kbnokey,cmstart,hcnocontext,
newline(
newitem('~B~eenden','Alt+X',kbaltx,cmquit,hcnocontext,
nil)))
),
nil))));
{$else}
menubar:=new(pmenubar,init(r,newmenu(
newsubmenu('~I~nstallation',hcnocontext,newmenu(
newitem('~S~tart','',kbnokey,cmstart,hcnocontext,
@ -438,38 +417,16 @@ program install;
nil)))
),
nil))));
{$endif}
end;
var
installapp : tapp;
oldexitproc : pointer;
procedure myexitproc;far;
begin
exitproc:=oldexitproc;
end;
var
b : byte;
var
installapp : tapp;
begin
getdir(0,startpath);
{
startpath:=paramstr(0);
for b:=length(startpath) downto 1 do
if startpath[b]='\' then
begin
startpath[0]:=chr(b-1);
break;
end;
}
oldexitproc:=exitproc;
exitproc:=@myexitproc;
successfull:=false;
installapp.init;
installapp.run;
installapp.do_installdialog;
installapp.done;
if successfull then
begin
@ -477,11 +434,16 @@ begin
writeln(binpath);
writeln;
writeln('To compile files enter PPC386 [file]');
chdir(startpath);
end;
end.
{
$Log$
Revision 1.2 1998-04-07 22:47:57 florian
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
}
}

3256
install/unzip.pas Normal file
View File

File diff suppressed because it is too large Load Diff

174
install/ziptypes.pas Normal file
View File

@ -0,0 +1,174 @@
UNIT ziptypes;
{
Type definitions for UNZIP
* original version by Christian Ghisler
* extended
and
amended for Win32 by Dr Abimbola Olowofoyeku (The African Chief)
Homepage: http://ourworld.compuserve.com/homepages/African_Chief
}
INTERFACE
{$ifdef Win32}
TYPE
nWord = longint;
{$else Win32}
TYPE
nWord = Word;
{$endif Win32}
{$ifdef VirtualPascal}
TYPE
Integer = Longint; // Default Integer is 16 bit!
{$endif VirtualPascal}
CONST
tBufSize = {$ifdef Win32}256{$else}63{$endif} * 1024; {buffer size}
tFSize = {$ifdef Win32}259{$else}79{$endif}; {filename length}
{ Record for UNZIP }
TYPE buftype = ARRAY [ 0..tBufSize ] of char;
TYPE TDirtype = ARRAY [ 0..tFSize ] of char;
TZipRec = PACKED RECORD
buf : ^buftype; {please} {buffer containing central dir}
bufsize, {do not} {size of buffer}
localstart : word; {change these!} {start pos in buffer}
Time,
Size,
CompressSize,
headeroffset : Longint;
FileName : tdirtype;
PackMethod : word;
Attr : Byte;
END; { TZipRec }
{ record for callback progress Reports, etc. }
TYPE
pReportRec = ^TReportRec; {passed to callback functions}
TReportRec = PACKED RECORD
FileName : tdirtype; {name of individual file}
Time, {date and time stamp of individual file}
Size, {uncompressed and time stamp of individual file}
CompressSize : Longint;{compressed and time stamp of individual file}
Attr : integer; {file attribute of individual file}
PackMethod : Word; {compression method of individual file}
Ratio : byte; {compression ratio of individual file}
Status : longint; {callback status code to show where we are}
IsaDir : Boolean; {is this file a directory?}
END; {TReportRec}
{ callback status codes }
CONST
file_starting = -1000; {beginning the unzip process; file}
file_unzipping = -1001; {continuing the unzip process; file}
file_completed = -1002; {completed the unzip process; file}
file_Failure = -1003; {failure in unzipping file}
unzip_starting = -1004; {starting with a new ZIP file}
unzip_completed = -1005; {completed this ZIP file}
{ procedural types for callbacks }
TYPE
UnzipReportProc = PROCEDURE ( Retcode : longint;Rec : pReportRec );
{$ifdef Delphi32}STDCALL;{$endif}
{ procedural type for "Report" callback: the callback function
(if any) is called several times during the unzip process
Error codes are sent to the callback in "Retcode". Other
details are sent in the record pointed to by "Rec".
* Note particularly Rec^.Status - this contains information about
the current status or stage of the unzip process. It can have
any of the following values;
(archive status)
unzip_starting = starting with a new ZIP archive (rec^.filename)
unzip_completed = finished with the ZIP archive (rec^.filename)
(file status)
file_starting = starting to unzip (extract) a file (from archive)
file_unzipping = continuing to unzip a file (from archive)
(when this status value is reported, the actual number of
bytes written to the file are reported in "Retcode"; this is
valuable for updating any progress bar)
file_completed = finshed unzip a file (from archive)
file_Failure = could not extract the file (from archive)
}
UnzipQuestionProc = FUNCTION ( Rec : pReportRec ) : Boolean;
{$ifdef Delphi32}STDCALL;{$endif}
{ procedural type for "Question" callback:if a file already
exists, the callback (if any) will be called to ask whether
the file should be overwritten by the one in the ZIP file;
the details of the file in the ZIP archive are supplied in the
record pointed to by "Rec"
in your callback function, you should;
return TRUE if you want the existing file to be overwritten
return FALSE is you want the existing file to be skipped
}
{Error codes returned by the main unzip functions}
CONST
unzip_Ok = 0;
unzip_CRCErr = -1;
unzip_WriteErr = -2;
unzip_ReadErr = -3;
unzip_ZipFileErr = -4;
unzip_UserAbort = -5;
unzip_NotSupported = -6;
unzip_Encrypted = -7;
unzip_InUse = -8;
unzip_InternalError = -9; {Error in zip format}
unzip_NoMoreItems = -10;
unzip_FileError = -11; {Error Accessing file}
unzip_NotZipfile = -12; {not a zip file}
unzip_SeriousError = -100; {serious error}
unzip_MissingParameter = -500; {missing parameter}
{ the various unzip methods }
CONST
Unzipmethods : ARRAY [ 0..9 ] of pchar =
( 'stored', 'shrunk', 'reduced 1', 'reduced 2', 'reduced 3',
'reduced 4', 'imploded', 'tokenized', 'deflated', 'skipped' );
{ unzip actions being undertaken }
CONST
UnzipActions : ARRAY [ 0..9 ] of pchar =
( 'copying', 'unshrinking', 'unreducing 1', 'unreducing 2', 'unreducing 3',
'unreducing 4', 'exploding', 'un-tokenizing', 'inflating', 'skipping' );
{ rudimentary "uppercase" function }
FUNCTION Upper ( s : String ) : String;
{ remove path and return filename only }
FUNCTION StripPath ( CONST s : String ) : String;
IMPLEMENTATION
FUNCTION Upper ( s : String ) : String;
VAR i : integer;
BEGIN
FOR i := 1 TO length ( s ) DO s [ i ] := Upcase ( s [ i ] );
Upper := s;
END;
FUNCTION StripPath ( CONST s : String ) : String;
VAR
i, j : Word;
BEGIN
StripPath := s;
j := length ( s );
FOR i := j DOWNTO 1 DO BEGIN
IF s [ i ] in [ '\', ':', '/' ] THEN BEGIN
StripPath := Copy ( s, succ ( i ), j -i );
exit;
END;
END;
END;
END.

284
install/zipviewu.pas
View File

@ -1,284 +0,0 @@
{------8<-------------Snip---------------8<------------Snip------------8<-------}
{$I-}
UNIT zipviewu;
(*/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\\/\/\/\/\/\/\/\*)
(* Unit : Zip View Date : March 23, 1994 *)
(* By : John Shipley Ver : 1.0 *)
(* *)
(* Credits : Steve Wierenga - ZIPV.PAS found in SWAG - Got me started on the *)
(* zipviewu code since ZIPV.PAS was fairly easy to read unlike *)
(* some other code I had seen. *)
(* *)
(* Tom Guinther - ZIPPER.PAS found in ZIPPER.ZIP (1989) available *)
(* on my BBS "The Brook Forest Inn 714-951-5282" This code helped *)
(* clarify many things. The zipper code is probably better than *)
(* this code and well documented. *)
(* *)
(* PkWare's APPNOTE.TXT found in PKZ110.EXE *)
(* *)
(* This unit is offered to the Public Domain so long as credit is given *)
(* where credit is due. I accept NO liablity for what this code does to your *)
(* system or your friends or anyone elses. You have the code, so you can fix *)
(* it. If this code formats your hard drive and you loose your lifes work, *)
(* then all I can say is "Why didn't you back it up?" *)
(* *)
(* Purpose: To mimic "PKUNZIP -v <filename>" output. (v2.04g) *)
(* The code is pretty close to the purpose, but not perfect. *)
(* *)
(* Demo : *)
(* *)
(* PROGRAM zip_viewit; *)
(* USES DOS,CRT,zipviewu; *)
(* BEGIN *)
(* IF PARAMCOUNT<>0 THEN *)
(* BEGIN *)
(* zipview(PARAMSTR(1)); *)
(* END; *)
(* END. *)
(*/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\\/\/\/\/\/\/\/\*)
INTERFACE
USES DOS,CRT;
PROCEDURE zipview(zipfile: STRING);
IMPLEMENTATION
CONST hexdigit : ARRAY[0..15] OF CHAR = '0123456789abcdef';
FUNCTION hexbyte(b: byte): STRING; (* Byte to Hexbyte *)
BEGIN
hexbyte := hexdigit[b SHR 4]+hexdigit[b AND $f];
END;
FUNCTION hexlong(l: LONGINT): STRING; (* Longint to Hexlong *)
VAR n : ARRAY[1..4] OF BYTE ABSOLUTE l;
BEGIN
hexlong := hexbyte(n[4])+hexbyte(n[3])+hexbyte(n[2])+hexbyte(n[1]);
END;
FUNCTION lenn(s: STRING): INTEGER; (* Like LENGTH, but skips color codes *)
VAR i,len : INTEGER;
BEGIN
len := LENGTH(s);
i := 1;
WHILE (i<=LENGTH(s)) DO
BEGIN
IF (s[i] IN [#3,'^']) THEN
IF (i<LENGTH(s)) THEN
BEGIN
DEC(len,2);
INC(i);
END;
INC(i);
END;
lenn := len;
END;
FUNCTION mln(s: STRING; l: INTEGER): STRING; (* Left Justify *)
BEGIN
WHILE (lenn(s)<l) DO s := s+' ';
IF (lenn(s)>l) THEN
REPEAT
s := COPY(s,1,LENGTH(s)-1)
UNTIL (lenn(s)=l) OR (LENGTH(s)=0);
mln := s;
END;
FUNCTION mrn(s: STRING; l: INTEGER): STRING; (* Right Justify *)
BEGIN
WHILE lenn(s)<l DO s := ' '+s;
IF lenn(s)>l THEN s := COPY(s,1,l);
mrn := s;
END;
FUNCTION cstr(i: LONGINT): STRING; (* convert integer type to string *)
VAR c : STRING[16];
BEGIN
STR(i,c);
cstr := c;
END;
FUNCTION tch(s: STRING): STRING; (* Ensure 2 Digits *)
BEGIN
IF (LENGTH(s)>2) THEN s := COPY(s,LENGTH(s)-1,2)
ELSE IF (LENGTH(s)=1) THEN s := '0'+s;
tch := s;
END;
FUNCTION b2attr(a,g: BYTE): STRING; (* Byte to Attribute *)
VAR attr : STRING[5];
BEGIN
attr := '--w- ';
IF (g AND 1)=1 THEN attr[5]:='*'; (* Encrypted? *)
IF (a AND 1)=1 THEN attr[3]:='r'; (* Read Only? *)
IF (a AND 2)=2 THEN attr[2]:='h'; (* Hidden? *)
IF (a AND 4)=4 THEN attr[1]:='s'; (* System? *)
IF (a AND 8)=8 THEN attr[4]:='?'; (* Unknown at this time *)
b2attr := attr;
END;
FUNCTION w2date(d: WORD): STRING; (* Word to Date *)
VAR s : STRING;
BEGIN
s := tch(cstr((d SHR 5) AND 15 ))+'-'+ (* Month *)
tch(cstr((d ) AND 31 ))+'-'+ (* Day *)
tch(cstr(((d SHR 9) AND 127)+80)); (* Year *)
w2date := s;
END;
FUNCTION w2time(t: WORD): STRING; (* Word to Time *)
VAR s : STRING;
BEGIN
s := tch(cstr((t SHR 11) AND 31))+':'+ (* Hour *)
tch(cstr((t SHR 5) AND 63)); (* Minute *)
w2time := s;
END;
PROCEDURE zipview(zipfile: STRING); (* View the ZIP File *)
CONST lsig = $04034B50; (* Local Signature *)
csig = $02014b50; (* Central Signature *)
TYPE lheader = RECORD (* Local Header *)
signature : LONGINT; (* local file header signature *)
version, (* version mad by *)
gpflag, (* general purpose flags *)
compress, (* compression method *)
time,date : WORD; (* last mod file time and date *)
crc32, (* crc-32 *)
csize, (* compressed size *)
usize : LONGINT; (* uncompressed size *)
fnamelen, (* filename length *)
extrafield : WORD; (* extra field length *)
END;
cheader = RECORD (* Central Header *)
signature : LONGINT; (* central file header signature *)
version : WORD; (* version made by *)
vneeded : WORD; (* version needed to extract *)
gpflag : ARRAY[1..2] OF BYTE;(* general purpose flags *)
compress : WORD; (* compression method *)
time : WORD; (* last mod file time *)
date : WORD; (* last mod file date *)
crc32 : LONGINT; (* crc-32 *)
csize : LONGINT; (* compressed size *)
usize : LONGINT; (* uncompressed size *)
fnamelen : WORD; (* filename length *)
extrafield : WORD; (* extra field length *)
fcl : WORD; (* file comment length *)
dns : WORD; (* disk number start *)
ifa : WORD; (* internal file attributes *)
efa : ARRAY[1..4] OF BYTE; (* external file attr *)
roolh : LONGINT; (* relative offset of local header *)
END;
VAR z : INTEGER; (* Number of files processed counter *)
totalu, (* Total bytes that were compressed *)
totalc : LONGINT; (* result of total bytes being compressed *)
hdr : ^cheader; (* temporary cental header file record *)
f : FILE; (* file var *)
s : STRING; (* archive filename string *)
percent : BYTE; (* Temporary var holding percent compressed *)
numfiles : WORD; (* Number of files in archive *)
CONST comptypes : ARRAY[0..8] OF STRING[7] = (* Compression Types *)
('Stored ', (* Not Compressed *)
'Shrunk ', (* Shrunk *)
'Reduce1', (* Reduced 1 *)
'Reduce2', (* Reduced 2 *)
'Reduce3', (* Reduced 3 *)
'Reduce4', (* Reduced 4 *)
'Implode', (* Imploded *)
'NotSure', (* Unknown at this time *)
'DeflatN'); (* Deflated *)
FUNCTION seekc(VAR f: FILE): BOOLEAN;
VAR curpos : LONGINT; (* current file position *)
buf : lheader; (* Temporary local header record *)
ioerror : INTEGER; (* Temporary IOResult holder *)
result : WORD; (* Blockread Result *)
BEGIN
seekc := FALSE; (* init seekc *)
curpos := 0; (* init current file position *)
SEEK(f,0); (* goto start of file *)
BLOCKREAD(f,buf,SIZEOF(lheader),result); (* Grab first local header *)
ioerror := IORESULT; (* Test for error *)
WHILE (ioerror = 0) AND (buf.signature=lsig) DO (* Test if OK..continue *)
BEGIN
INC(numfiles); (* Increment number of files *)
WITH buf DO (* Find end of local header *)
curpos := FILEPOS(f)+fnamelen+extrafield+csize;
SEEK(f,curpos); (* Goto end of local header *)
BLOCKREAD(f,buf,SIZEOF(lheader),result); (* Grab next local header *)
ioerror := IORESULT; (* Test for error *)
END;
IF ioerror<>0 THEN EXIT; (* If error then exit function *)
IF (buf.signature=csig) THEN (* Did we find the first central header? *)
BEGIN
seekc := TRUE; (* Found first central header *)
SEEK(f,curpos); (* Ensure we are at central headers file position *)
END;
END;
VAR curpos : LONGINT;
BEGIN
numfiles := 0; (* Counter of Number of Files to Determine When Done *)
z := 0; (* Counter of Number of Files Processed *)
totalu := 0; (* Total Bytes of Uncompressed Files *)
totalc := 0; (* Total Size after being Compressed *)
NEW(hdr); (* Dynamically Allocate Memory for a Temp Header Record *)
ASSIGN(f,zipfile); (* Assign Filename to File Var *)
{$I-}
RESET(f,1); (* Open Untyped File *)
{$I+}
IF IORESULT<>0 THEN (* If we get an error, exit program *)
BEGIN
WRITELN('Error - File not found.');
HALT(253);
END;
IF NOT seekc(f) THEN (* Skip Local Headers and goto first Central Header *)
BEGIN (* If we could not locate a Central Header *)
CLOSE(f); (* Close Untyped File *)
WRITELN('Error - Corrupted or Not a ZIP File.');
HALT(254); (* Exit Program *)
END;
WRITELN(' Length Method Size Ratio Date Time CRC-32 '+
' Attr Name');
WRITELN(' ------ ------ ----- ----- ---- ---- --------'+
' ---- ----');
REPEAT
FILLCHAR(s,SIZEOF(s),#0); (* Clear Name String *)
BLOCKREAD(f,hdr^,SIZEOF(cheader)); (* Read File Header *)
BLOCKREAD(f,MEM[SEG(s):OFS(s)+1],hdr^.fnamelen); (* Read Archive Name *)
s[0] := CHR(hdr^.fnamelen); (* Get Archive Name Length *)
IF (hdr^.signature=csig) THEN (* Is a header *)
BEGIN
INC(z); (* Increment File Counter *)
WRITE(mrn(cstr(hdr^.usize),7)); (* Display Uncompressed Size *)
WRITE(' '+mrn(comptypes[hdr^.compress],7)); (* Compression Method *)
WRITE(mrn(cstr(hdr^.csize),8)); (* Display Compressed Size *)
percent := ROUND(100.0-(hdr^.csize/hdr^.usize*100.0));
WRITE(mrn(cstr(percent),4)+'% '); (* Display Compression Percent *)
WRITE(' '+w2date(hdr^.date)+' '); (* Display Date Last Modified *)
WRITE(' '+w2time(hdr^.time)+' '); (* Display Time Last Modified *)
WRITE(' '+hexlong(hdr^.crc32)+' '); (* Display CRC-32 in Hex *)
WRITE(b2attr(hdr^.efa[1],hdr^.gpflag[1])); (* Display Attributes *)
WRITELN(' '+mln(s,13)); (* Display Archive Filename *)
INC(totalu,hdr^.usize); (* Increment size uncompressed *)
INC(totalc,hdr^.csize); (* Increment size compressed *)
END;
SEEK(f,FILEPOS(f)+hdr^.extrafield+hdr^.fcl);
UNTIL (hdr^.signature<>csig) OR EOF(f) OR (z=numfiles); (* No more Files *)
WRITELN(' ------ ------ --- '+
' -------');
WRITE(mrn(cstr(totalu),7)+' '); (* Display Total Uncompressed *)
WRITE(mrn(cstr(totalc),7)+' '); (* Display Total Compressed *)
WRITE((100-TotalC/TotalU*100):3:0,'%'+mrn(' ',34)); (* Display Percent *)
WRITELN(mrn(cstr(z),7)); (* Display Number of Files *)
CLOSE(f); (* Close Untyped File *)
DISPOSE(hdr); (* Deallocate Header Var Memory *)
END;
END.