mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-03 01:09:40 +01:00
+ initial revisions
This commit is contained in:
florian
parent
9cb367642e
commit
81349e4e6d
455
install/install.pas
Normal file
455
install/install.pas
Normal file
@ -0,0 +1,455 @@
|
||||
{$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;
|
||||
|
||||
var
|
||||
binpath,startpath : string;
|
||||
successfull : boolean;
|
||||
|
||||
procedure uppervar(var s : string);
|
||||
|
||||
var
|
||||
i : integer;
|
||||
|
||||
begin
|
||||
for i:=1 to length(s) do
|
||||
s[i]:=upcase(s[i]);
|
||||
end;
|
||||
|
||||
function file_exists(const f : string;const path : string) : boolean;
|
||||
|
||||
begin
|
||||
file_exists:=fsearch(f,path)<>'';
|
||||
end;
|
||||
|
||||
procedure do_install(const 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;
|
||||
end;
|
||||
|
||||
function createdir(const s : string) : boolean;
|
||||
|
||||
var
|
||||
result : longint;
|
||||
|
||||
begin
|
||||
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;
|
||||
|
||||
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;
|
||||
|
||||
var
|
||||
r : trect;
|
||||
line : integer;
|
||||
p,f : pview;
|
||||
s : string;
|
||||
|
||||
const breite = 76;
|
||||
hoehe = 20;
|
||||
x1 = (80-breite) div 2;
|
||||
y1 = (23-hoehe) div 2;
|
||||
x2 = x1+breite;
|
||||
y2 = y1+hoehe;
|
||||
|
||||
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));
|
||||
f:=p;
|
||||
s:='C:\PP';
|
||||
p^.setdata(s);
|
||||
insert(p);
|
||||
r.assign(3,line,8,line+1);
|
||||
insert(new(plabel,init(r,'~P~ath',p)));
|
||||
insert(p);
|
||||
inc(line,3);
|
||||
r.assign(3,line+1,breite-3,line+11);
|
||||
p:=new(pcheckboxes,init(r,
|
||||
newsitem('~B~asic system (required)'+diskspace('BASEDOS.ZIP'),
|
||||
newsitem('GNU ~L~inker and GNU Assembler (required)'+diskspace('GNUASLD.ZIP'),
|
||||
newsitem('D~e~mos'+diskspace('DEMO.ZIP'),
|
||||
newsitem('GNU ~D~ebugger'+diskspace('GDB.ZIP'),
|
||||
newsitem('GNU ~U~tilities (required to recompile run time library)'+diskspace('GNUUTILS.ZIP'),
|
||||
newsitem('Documentation (~H~TML)'+diskspace('DOCS.ZIP'),
|
||||
newsitem('Documentation (~P~ostscript)'+diskspace('DOC100PS.ZIP'),
|
||||
newsitem('~R~un time library sources'+diskspace('RL09900S.ZIP'),
|
||||
newsitem('~C~ompiler sources'+diskspace('PP09900S.ZIP'),
|
||||
newsitem('Documentation sources (La~T~eX)'+diskspace('DOC100S.ZIP'),
|
||||
nil
|
||||
))))))))))));
|
||||
pcluster(p)^.enablemask:=mask_components;
|
||||
insert(p);
|
||||
|
||||
r.assign(3,line,14,line+1);
|
||||
insert(new(plabel,init(r,'~C~omponents',p)));
|
||||
|
||||
inc(line,12);
|
||||
{ Free Vision
|
||||
r.assign(3,line+1,breite-3,line+3);
|
||||
p:=new(pcheckboxes,init(r,
|
||||
newsitem('~B~asic system',
|
||||
newsitem('~D~ocumentation',
|
||||
newsitem('S~a~mples',
|
||||
newsitem('~S~ources',
|
||||
nil
|
||||
))))));
|
||||
pcluster(p)^.enablemask:=mask_freevision;
|
||||
insert(p);
|
||||
r.assign(3,line,15,line+1);
|
||||
insert(new(plabel,init(r,'~F~ree Vision',p)));
|
||||
inc(line,4);
|
||||
}
|
||||
r.assign((breite div 2)-14,line,(breite div 2)-4,line+2);
|
||||
insert(new(pbutton,init(r,'~O~k',cmok,bfdefault)));
|
||||
r.assign((breite div 2)+4,line,(breite div 2)+14,line+2);
|
||||
insert(new(pbutton,init(r,'~C~ancel',cmcancel,bfnormal)));
|
||||
f^.select;
|
||||
end;
|
||||
|
||||
procedure tapp.handleevent(var event : tevent);
|
||||
|
||||
var
|
||||
p : pinstalldialog;
|
||||
p2 : pdialog;
|
||||
p3 : pstatictext;
|
||||
r : trect;
|
||||
c : word;
|
||||
t : text;
|
||||
installdata : record
|
||||
path : string[79];
|
||||
components : word;
|
||||
end;
|
||||
f : file;
|
||||
|
||||
label
|
||||
insertdisk1,insertdisk2,newpath;
|
||||
|
||||
begin
|
||||
inherited handleevent(event);
|
||||
if event.what=evcommand then
|
||||
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('DOC100PS.ZIP',startpath) then
|
||||
inc(mask_components,64);
|
||||
|
||||
if file_exists('RL09900S.ZIP',startpath) then
|
||||
inc(mask_components,128);
|
||||
|
||||
if file_exists('PP09900S.ZIP',startpath) then
|
||||
inc(mask_components,256);
|
||||
|
||||
if file_exists('DOC100S.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('DOCS101PS');
|
||||
|
||||
if (installdata.components and 128)<>0 then
|
||||
do_install('RL09905S');
|
||||
|
||||
if (installdata.components and 256)<>0 then
|
||||
do_install('PP09905S');
|
||||
|
||||
if (installdata.components and 512)<>0 then
|
||||
do_install('DOC101S');
|
||||
|
||||
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;
|
||||
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,
|
||||
newline(
|
||||
newitem('~E~xit','Alt+X',kbaltx,cmquit,hcnocontext,
|
||||
nil)))
|
||||
),
|
||||
nil))));
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
var
|
||||
installapp : tapp;
|
||||
oldexitproc : pointer;
|
||||
|
||||
procedure myexitproc;far;
|
||||
|
||||
begin
|
||||
exitproc:=oldexitproc;
|
||||
end;
|
||||
|
||||
var
|
||||
b : byte;
|
||||
|
||||
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.done;
|
||||
if successfull then
|
||||
begin
|
||||
writeln('Extend your PATH variable with');
|
||||
writeln(binpath);
|
||||
writeln;
|
||||
writeln('To compile files enter PPC386 [file]');
|
||||
end;
|
||||
end.
|
||||
284
install/zipviewu.pas
Normal file
284
install/zipviewu.pas
Normal file
@ -0,0 +1,284 @@
|
||||
{------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.
|
||||
Loading…
Reference in New Issue
Block a user