💾 Archived View for blitter.com › OLGA › MUSIC › RESOURCES › MISC › OLGA_BROWSER › OLGA_EXTRACT › SR… captured on 2022-06-12 at 08:27:55.
-=-=-=-=-=-=-
program OLGA_archiver; {(C) 1995 by Sven Winnecke.
This program is made to handle OLGA's all*.tar.gz files. You have several
options to choose the files you'd like to get.
It is _neccesary_ to have the following files in the current archive:
* the allpt*.* files
* the all.idx file, which is made by calling tar -tvf all_pt#.tgz,
copying them together and removing all lines concerning links and
* the tar and tvedit executables.
See also the readme.now file.
Any comments/questions/complains to: sven.winnecke@mb2.tu-chemnitz.de. }
{$M 16384,0,65536} { preserve space for the external programs }
{$V-}
uses crt,dos,bold;
const hlp=' Press F1 for help. (Pg/Pg,/,Home/End,SPACE,Return, w,c,s,u,e,o, ESC)';
ent=455;
months:array [1..12] of string [3]=('jan','feb','mar','apr','may','jun','jul','aug',
'sep','oct','nov','dec');
type alink = ^archtype; { for assigning the entries to the tar files }
archtype = record
name : string; { name of tar file }
first : char; { 1st valid character }
last : char; { last " " }
count : integer; { count of matching items }
Next : alink; { link to next element }
end;
var f,ta,ts : text; { file variables: f=index file, ta=response file }
fi : file of byte;{ for determining the file size of the resp. file }
s,t,su : string; { temp. strings }
i,j,k,y : integer; { temp. variables, for loops and so on }
{ x : integer; { column where actual data starts }
a : array [0..ent] of string[128]; { list of the current items }
h,v,b,z : word; { for mouse handling }
mouse : boolean; { flag 'Is mouse driver already initialized ?' }
to_ma : boolean; { flag 'Too many items match search criteria.' }
no_upd : boolean; { flag 'don't re-read index file' (after 'w'/'c' }
sorted : boolean; { flag 'index file is sorted' }
c : char; { for readkey waits }
anc,cur,hp : alink; { anchor of tar spec list, current & temp. pointer}
sr : SearchRec; { for checking if files are present }
by : byte;
procedure mpos; { get the mouse position and buttons }
begin
asm
mov ax,0003h
int 33h { mouse position: dx=vert., cx=horic., bx=buttons, }
mov h,cx { buttons: bit 0 = left button, bit 1 = right }
mov v,dx
and bx,0003h
mov b,bx
end;
end;
function IToS(i: Longint): string; { make the str procedure to a function }
{ Convert any Integer type to a string }
var
s: string[11];
begin
Str(i, s);
IToS := s;
end;
procedure error (s:string);
begin
writeln (s); halt (1);
end;
procedure rmfiles; { rewrite the response files }
begin
assign (ta,'tarrespo.tmp'); rewrite (ta);
end;
procedure sort; { I know: bubble sort is sh*t, but it's the only one I know }
begin
for i:=1 to k do
for j:=1 to k-1 do
if a[j]>a[j+1] then
begin
a[0]:=a[j]; a[j]:=a[j+1]; a[j+1]:=a[0];
end;
end;
procedure out (nr:integer); { put the colored data lines onto the screen }
var st:string;
begin
s:=a[nr];
if pos('* marked *',s)>0 then textcolor (lightred)
else if s[length(s)]='/' then textcolor (lightmagenta)
else if pos('.crd',s)>0 then textcolor (lightcyan)
else if pos('.tab',s)>0 then textcolor (white)
else if pos('.lyr',s)>0 then textcolor (green)
else if pos('.btab',s)>0 then textcolor (cyan)
else if pos('.num',s)>0 then textcolor (lightgray)
else if pos('.pro',s)>0 then textcolor (lightgreen)
else textcolor (yellow);
st:=copy (' ',1,3-trunc(ln(nr)/ln(10)))+itos(nr)+' - '+s;
if length (st)>77 then st:=copy (st,1,74)+'...';
write (st);
end;
procedure bar (x:integer); { draw or hide the red bar }
begin
asm
mov ax,0002 { hide mouse to protect mouse cursor color inverting }
int 33h
end;
for i:=1 to 78 do
memw[$B800:160*y+2*i+1]:=memw[$B800:160*y+2*i+1] and $ff0f or ($0010+x*$0030);
asm
mov ax,0001 { show mouse cursor again }
int 33h
end;
end;
procedure move (arg:integer); { put a new page of data lines to screen }
const update : boolean = true;
var count : integer;
begin
case arg of
0: if j+42<k then j:=j+21 else j:=k-20;
1: if j>21 then j:=j-21 else j:=1;
2: begin j:=1; y:=1; end;
3: begin j:=k-20; if k<20 then y:=k else y:=21; end;
end;
if j<1 then j:=1;
clrscr;
if k<20 then count:=k-1 else count:=20;
for i:=0 to count do
begin if i>0 then writeln; out (j+i); end;
bar(1);
c:=#0;
end;
procedure lineup; { move bar 1 line up }
begin
if y>1 then
begin
bar (0);
dec(y);
bar (1)
end else if k>21 then
begin y:=21; move(1); end;
c:=#0;
end;
procedure linedown; { move bar 1 line down }
begin
if (y<21) and (y<k) then
begin
bar (0);
inc(y);
bar(1);
end else
begin y:=1; move (0); end;
c:=#0;
end;
procedure mark; { (de-)mark an entry }
begin
if pos ('* marked *',a[j+y-1])<=0 then
begin
a[j+y-1]:=a[j+y-1]+' * marked *';
linedown; move (4);
end
else
begin
a[j+y-1]:=copy (a[j+y-1],1,length(a[j+y-1])-11);
move (4);
end
end;
procedure mkfiles (st:string); { write marked lines to response files }
var tt:string;
begin
assign (ta,'tarrespo.tmp'); append (ta);
for i:=1 to k do
begin
if pos ('* marked *',a[i])>0 then
begin
tt:=a[i];
if pos('/',a[i])=1 then a[i]:=' * marked *';
t:=st+a[i];
if copy (t,length(t)-11,1)='/' then
writeln (ta,copy (t,1,length(t)-12))
else writeln (ta,copy (t,1,length(t)-11));
cur:=anc;
while cur<>NIL do
begin
if (t[1]>=cur^.first) and (t[1]<=cur^.last) then inc (cur^.count);
cur:=cur^.next;
end;
a[i]:=tt;
a[i]:=copy (a[i],1,length(a[i])-11);
end;
end; close (ta);
end;
procedure untar (n:integer); { edit response files and call tar }
begin
cur:=anc; i:=0;
while cur<>NIL do
begin
i:=i+cur^.count;
cur:=cur^.next;
end;
if i>0 then
begin
if n=1 then
begin
window (1,1,80,25); textcolor (lightgreen); clrscr;
writeln (#10,' Press a key to start the response file editor... ');
c:=readkey;
exec (fexpand(fsearch('tvedit.exe',getenv('path'))), 'tarrespo.tmp');
end;
c:=#0;
window (1,1,80,25); textcolor (yellow); clrscr;
write ('================================================================================');
writeln (' The marked files will now be unpacked. This mill take several minutes... ');
write ('================================================================================');
end else c:=#0;
cur:=anc;
while cur<>NIL do
begin
if cur^.count>0 then
begin
hp:=cur^.next;
while hp<>NIL do
begin
if hp^.name=cur^.name then hp^.count:=0;
hp:=hp^.next;
end;
writeln;
writeln ('tar -xvof@ ',cur^.name,' tarrespo.tmp');
swapvectors;
exec (fexpand(fsearch('tar.exe',getenv('path'))), '-xvof@ '+cur^.name+' tarrespo.tmp');
swapvectors;
end;
cur:=cur^.next;
end;
if i>0 then
begin
writeln; textcolor (lightgreen);
writeln('Done. Should the response file be deleted (y/n)?');
repeat
c:=readkey; c:=upcase(c);
until (c='Y') or (c='N');
if c='Y' then rmfiles;
end;
c:=#27;
end;
procedure cd; { navigate through the tar file }
begin
if a[y+j-1]<>'..' then
begin
if copy (a[y+j-1],length(a[y+j-1]),1)<>'/' then mark
else
begin
su:=su+a[y+j-1];
end
end
else
begin
i:=length (su)-1;
while (copy(su,i,1)<>'/') and (i>1) do dec (i);
su:=copy (su,1,length(su)-(length(su)-i));
end;
end;
procedure msg (st:string); { write a message and wait for confirmation }
begin
window (3,24,79,24); textcolor (lightred); clrscr;
write (st);
c:=#0;
repeat
if keypressed then c:=readkey;
if c='o' then begin chg_font; c:=#0; end;
until (c<>'o') and (c<>#0);
textcolor (yellow);
writeln;
write (hlp);
c:=#0;
window (2,2,79,22);
end;
procedure help;
begin
textcolor (white); clrscr;
writeln (' Keys :'); writeln ('========');
writeln (' Page up/down : move through the list page by page up or down');
writeln (' Cursor up/down : move bar up or down. If the bar is being moved beyond');
writeln (' the page limits, the previous or next page will be shown.');
writeln (' Home : go to the first item of the list');
writeln (' End : go to the last item of the list');
writeln (' SPACE : mark the highlighted entry the for extracting');
writeln (' Return : much like SPACE, but in alphabetic list mode it will allow');
writeln (' you to change into the directories rather than mark them.');
writeln (' w : write the names of the marked entries to the response file');
writeln (' c : clear the contents of the response files');
writeln (' s : sort the list');
writeln (' u : unTAR (extract) the marked files from the TAR archives');
writeln (' e : much like (u)nTAR, but allows to edit response file first');
writeln (' o : toggle used font between normal and bold font');
writeln (' ESC : end of search, return to main menu');
writeln (' Mouse actions :');
writeln ('=================');
writeln (' Left button : like pressing the Return key');
write (' Right button : like pressing the SPACE key');
msg (' Help screen. Press any key to return to the main program...');
move (4);
end;
procedure full; { do a full-text search }
begin
su:='';
writeln; write ('Searching for: '); readln (su);
if su='' then exit;
for i:=1 to length (su) do
begin
if (su[i]>='A') and (su[i]<='Z') then su[i]:=chr(ord(su[i])+32);
if (su[i]=' ') then su[i]:='_';
end;
write ('Searching for "',su,'"...');
window (2,2,79,22); clrscr;
to_ma:=false;
while not to_ma and not eof (f) do
begin
readln (f,s); inc(i); s:=' '+s;
if pos(su,s)>0 then
begin
inc(k); a[k]:=copy (s,2,length(s)-1);
if a[k]='' then
write;
if k>1 then writeln;
out (k);
if k=ent then to_ma:=true;
end;
end;
j:=k-20; y:=1;
if j<1 then j:=1;
window (3,24,78,24); textcolor (yellow); clrscr;
if to_ma=true then
begin
write ('Too many matches! Be more specific next time. <any Key>');
c:=readkey;
end;
if k=0 then
begin
write (' No matches for "',su,'" !! <any Key>');
c:=readkey; c:=#0;
exit;
end;
clrscr;
write (hlp);
window (2,2,79,22); c:=#0;
bar(1);
repeat
if keypressed then
begin c:=readkey; if c=#0 then c:=readkey; end;
mpos;
if (b>0) then
begin
z:=b;
repeat mpos until b=0;
if (v>7) and (v<22*8) then
begin
bar(0);
y:=v div 8;
bar (1);
if z=1 then c:=#13 else c:=#32;
end
else if v<8 then move (1)
else if v=22*8 then move(0)
else if (v=23*8) and (h>68*8) then c:=#27;
end;
case c of
#72: lineup; { cursor up key }
#80: linedown; { cursor down key }
#81: move (0); { page up key }
#73: move (1); { page down key }
#71: move (2); { Home key }
#79: move (3); { end key }
#32: mark; { space }
#13: mark; { return }
#59: help; { F1 }
'o': begin chg_font; c:=#0; end;
's': begin sort; move (2); end;
'u': begin mkfiles (''); untar(0); end;
'e': begin mkfiles (''); untar(1); end;
'w': begin
mkfiles(''); write (7); move (4);
msg (' The marked file names have been written to the response file. <Key>');
end;
'c': begin
rmfiles;
msg (' Content of the response file deleted. <any Key>');
end;
end;
until c=#27;
c:=#0
end;
procedure groups; { navigate by directories }
var sa:string;
sorted_out:boolean; { if the index file is sorted and we read an element
which is 'greater' than the last allowed entry the
output can be aborted. }
begin
su:=' ';
repeat
sorted_out:=true;
if su[length(su)]='/' then no_upd:=false;
if not no_upd then
begin
reset (f);
sa:='*'; k:=1; to_ma:=false;
window (2,2,79,22); clrscr;
to_ma:=false;
if su<>' ' then begin; a[k]:='..'; out (k); inc (k); end;
while not to_ma and not eof (f) and sorted_out do
begin
readln (f,s); s:=' '+s;
t:=copy (s,length(su)+1,length(s)-length(su)+1);
z:=pos(sa,t); if (z=1) and (t='') then z:=0;
if pos('/',s)=0 then z:=0;
if (su<copy(s,1,length(su))) and sorted then sorted_out:=false;
if (pos (su,s)=1) and (z<>1) then
begin
if pos ('/',t)>0 then sa:=copy (t,1,pos ('/',t)) else sa:=t;
if sa<>'' then a[k]:=sa else a[k]:='/'+copy (s,2,length(s)-1)+' ';
if k>1 then writeln; out (k);
inc (k); if k>ent then to_ma:=true;
end;
end;
dec (k);
j:=k-20; y:=1;
if j<1 then j:=1;
move (3);
no_upd:=false;
end;
no_upd:=false;
window (3,24,78,24); textcolor (yellow); clrscr;
if to_ma=true then
begin
write ('Too many matches! Be more specific next time. <any Key>');
c:=readkey;
end;
clrscr;
write (hlp);
window (2,2,79,22); c:=#0;
bar(1);
repeat
if keypressed then
begin c:=readkey; if c=#0 then c:=readkey; end;
mpos;
if (b>0) then
begin
z:=b;
repeat mpos until b=0;
if (v>7) and (v<22*8) then
begin
bar(0);
y:=v div 8;
bar (1);
if z=1 then c:=#13 else c:=#32;
end
else if v<8 then move (1)
else if v=22*8 then move(0)
else if (v=23*8) and (h>72*8) then c:=#27;
end;
case c of
#72: lineup; { cursor up key }
#80: linedown; { cursor down key }
#81: move (0); { page up key }
#73: move (1); { page down key }
#71: move (2); { Home key }
#79: move (3); { end key }
#32: mark; { space }
#13: cd; { return }
#59: help; { F1 }
'o': begin chg_font; c:=#0; end;
's': begin sort; move (2); end;
'u': begin mkfiles (copy (su,2,length(su)-1)); untar(0); end;
'e': begin mkfiles (copy (su,2,length(su)-1)); untar(1); end;
'w': begin
mkfiles(copy (su,2,length(su)-1)); write (7); move (4);
msg (' The marked file names have been written to the response file. <Key>');
no_upd:=true;
end;
'c': begin
rmfiles;
msg (' Contents of the response file deleted. <Key>');
no_upd:=true;
end;
end;
until (c=#27) or (c=#13);
until c=#27;
c:=#0;
end;
function LZ(w : Word) : String;
var
s : String;
begin
Str(w:0,s);
if Length(s) = 1 then
s := '0' + s;
LZ := s;
end;
procedure stat;
var st,so : string;
dt : datetime;
dl : longint;
begin
window (2,4,79,21); textcolor (white); clrscr;
writeln (' Calculating data...'); writeln; writeln;
window (4,6,79,21);
assign (ts,'all.idx');
reset (ts);
i:=0; j:=0; st:='*'; so:='*';
while not eof (ts) do
begin
readln (ts,s); s:=' '+s;
if s[length(s)]<>'/' then
begin
inc (i);
k:=length (s);
repeat
dec(k);
until s[k]='/';
repeat
dec(k);
until (s[k]='/') or (k=0);
st:=copy (s,k+1,pos ('/',copy (s,k+1,length(s)-k))-1);
if (st<>so) and (k>0) then
begin
inc (j);
so:=st;
end;
end;
end;
close (ts); assign (fi,anc^.name); reset (fi); read (fi,by);
getftime (fi,dl); unpacktime (dl,dt); close (fi); writeln;
write ('Total number of bands : '); textcolor (lightgreen); writeln (j);
textcolor (white);
write ('Total number of songs : '); textcolor (lightgreen); writeln (i);
textcolor (white); writeln;
dl:=0;
cur:=anc; so:='*';
while cur<>NIL do
begin
assign (fi,cur^.name); reset (fi);
if cur^.name<>so then
begin
dl:=dl+filesize(fi); so:=cur^.name;
end;
close (fi);
cur:=cur^.next;
end;
write ('Total amount of space used by the TAR archive files : ');
textcolor (lightgreen); write (dl/1024/1024:5:2);
textcolor (white); writeln (' MBytes.'); writeln;
write ('Date & time of archive '); textcolor (green);
write (anc^.name); textcolor (white); write (' : ');
textcolor (lightgreen); write (lz(dt.day),' ');
writeln (months[dt.month],' '+lz(dt.year)+', '+lz(dt.hour)+':'+lz(dt.min));
textcolor (white); writeln;
if by=$1f then writeln ('TAR archives are gzip packed.')
else writeln ('TAR archives seem not to be packed.');
msg ('Press any key to return to the menu.');
end;
begin { main }
doserror:=0;
findfirst('olga.cfg',anyfile and not directory,sr);
if doserror<>0 then error ('Configuration file not found! Use install program to re-install...');
assign (ta,'olga.cfg'); reset (ta);
new (anc); cur:=anc; { build tar spec list }
while not eof (ta) do
begin
repeat readln (ta,s); until s[1]<>';'; { read, ignore comment lines }
if pos('*sorted*',s)=1 then sorted:=true
else
begin
i:=pos (' ',s);
cur^.name:=copy (s,1,i-1);
cur^.first:=s[i+1];
cur^.last:=s[i+3];
cur^.count:=0;
if eof (ta) then cur^.next:=NIL else
begin
new (cur^.next); cur:=cur^.next;
end;
sorted:=false;
end;
end;
close (ta);
mouse:=false;
doserror:=0;
findfirst('all.idx',anyfile and not directory,sr);
if doserror<>0 then error ('IDX file not found! Use setup program to re-install or try to call OLGABR.BAT.' );
assign (f,'all.idx');
reset (f);
rmfiles;
no_upd:=false; b_on:=true; bold_on;
repeat
window (1,1,80,25); clrscr;
i:=0; j:=0; k:=0;
textcolor (yellow); textbackground (blue); clrscr;
for i:=0 to 77 do mem [$B800:2+2*i]:=ord('�');
memL [$B800:4+2*i]:=$1eBA1eBB;
mem [$B800:0]:=ord('�');
memL [$B8ef:14]:=$1eC81eBA;
for i:=0 to 77 do mem [$B8f0:2+2*i]:=ord('�');
mem [$B8f0:4+2*i]:=ord ('�');
for i:=1 to 22 do memL[$B800:158+160*i]:=$1eBA1eBA;
gotoxy (2,23); for i:=1 to 78 do write ('�');
gotoxy (23,1); write ('� OLGA - On-Line Guitar Archive �');
window (2,8,79,25); textcolor (lightblue);
WriteLn(' .oooooo. ooooo .oooooo. .o.');
WriteLn(' d8P'' `Y8b `888'' d8P'' `Y8b .888.');
WriteLn(' 888 888 888 888 .8"888.');
WriteLn(' 888 888 888 888 .8'' `888.');
WriteLn(' 888 888 888 888 ooooo .88ooo8888.');
WriteLn(' `88b d88'' 888 o `88. .88'' .8'' `888.');
WriteLn(' `Y8bood8P'' o888ooooood8 `Y8bood8P'' o88o o8888o');
WriteLn; WriteLn;
WriteLn(' ==================================================================');
WriteLn(' =================== The Online - Guitar archive ====================');
WriteLn(' ==========================================================================');
window (3,24,79,24); textcolor (yellow);
write ('Initializing...');
if mouse=false then
asm
mov ax,0000
int 33h { Init. mouse driver -> ax=-1 : no driver / no mouse }
mov h,ax
cmp ax,-1
jne @x
mov ax,0004 { set mouse position to upper left corner }
mov cx,0
mov dx,0
int 33h
mov ax,0001 { show mouse cursor }
int 33h
@x: nop
end;
if h=65535 then mouse:=true;
textcolor (white);
WriteLn;
textcolor (yellow); Write ('(');
textcolor (lightred); write ('A');
textcolor (yellow); write (')lphabetic order, (');
textcolor (lightred); write ('F');
textcolor (yellow); write (')ull text search, (');
textcolor (lightred); write ('S');
textcolor (yellow); write (')tatistics, F(');
textcolor (lightred); write ('o');
textcolor (yellow); write (')nt, (');
textcolor (lightred); write ('ESC');
textcolor (yellow); write (') for quit');
repeat
c:=readkey; if c<>'o' then c:=upcase(c);
until c in ['A','F','S','o',#27];
reset (f);
case c of
'A': groups;
'F': full;
'S': stat;
'o': begin if b_on then bold_off else bold_on; B_on:=not b_on; end;
end;
until c=#27;
close (f); window (1,1,80,25);
window (1,1,80,25); { restore normal screen conditions }
textcolor (lightgray); textbackground (black);
clrscr; bold_off;
assign (ta,'tarrespo.tmp'); erase (ta);
end.