Program Tpac; { TPAC v1.7 by Tim Gordon 18/06/97 }
{ Updated and Commented for September Computer Project  14/09/97 }
{ Updated for submission to SWAG 20/09/97 }

{----------------------------------------------------------------------------}
{- TPAC v1.7   Public Domain Release  By Tim Gordon -------------------------}
{----------------------------------------------------------------------------}

{ A Quick note on the PAC File format :-

 <- PAC File header/version ->
 <- 1st File header (Name/size) ->
 <- 1st File Contents - >
 <- 2nd File header ->
 ...

}

uses crt,dos;

type
    FileHeaderType = record { Header for individual files in PAC File }
                   Fname : string[12]; { name of file }
                   Fsize : longint; { size of file }
    end;

const
     PacHeader : string = 'TPAC'; { Pac File header }
     PacVersion : string = '1.7'; { Pac file version }

var
   extractfile : array[1..10] of string[12]; { List of file specs to extract }
   buf         : array[1..10240] of byte; { Input Buffer }
   Header      : string[4]; { PAC File Header }
   version     : string[3]; { PAC File Version }
   x           : integer; { Counter }
   Fileheader  : fileheadertype; { File Header }

procedure DrawPercentage(x1,y1 : integer;num : real);
{ Draw Percentage Complete as a Bar }
{ ²²²²°°°°°°°° }
var
   yy,z    : integer;
   percentage : byte;
begin
     num := num / 100;
     percentage := round(num*11);
     { Work out percentage out of 11 }
     textbackground(black);
     textcolor(lightgray);
     gotoxy(x1,y1);
     write('(');
     for z := 1 to percentage do write('²');
     for yy := percentage to 10 do write('°');
     { Draw up percentage }
     write(')');
end;

Procedure DisplayHelp;
{ Show Command Line Help }
begin
     writeln('Usage : ');
     writeln(' TPAC.EXE [pac_file] [option]... [filename]');
     writeln;
     writeln('Valid Options are :');
     writeln(' -a    Add Files');
     writeln(' -e    Extract Files');
     writeln(' -x    Extract Files (too)');
     writeln(' -l    View Files');
     writeln(' -?    This Help');
     halt; { Halt program }
end;

Function WildCardMatch(filename : string;Wildcard : string) : boolean;
{ Check if filename matches with wildcard - where wildcard can contain
  *'s and ?'s.
  Eg. timothy.tim = tim*.t?? = *t?y.*im = *.*
  and timothy.tim <> h*.??h
}
var
   MainPart       : string[8]; { Actual name of file - before the '.' }
   Extention      : string[3]; { last part of filename }
   x              : integer; { counter }
   Wild_MP        : string[8]; { Wildcard Main Part }
   Wild_Ex        : string[3]; { Wildcard Extention }
begin
     wildcardmatch := false; { Default }
     if wildcard = '' then exit; { Wont match if there isn't a filespec! }
     { First... Convert to caps! }
     for x := 1 to 12 do filename[x] := upcase(filename[x]);
     for x := 1 to 12 do wildcard[x] := upcase(wildcard[x]);
     { Check if our file names are complete }
     if pos('.',filename) = 0 then
        filename := filename + '.???';
     if pos('.',wildcard) = 0 then
        wildcard := wildcard + '.   ';
     { Now, Split our filename into its main part, and extention }
     mainpart := copy(filename,1,pos('.',filename)-1);
     extention := copy(filename,pos('.',filename)+1,3);
     wild_mp := copy(wildcard,1,pos('.',wildcard)-1);
     wild_ex := copy(wildcard,pos('.',wildcard)+1,3);
     { And Check that they are the right length }
     while length(mainpart) < 8 do
           mainpart := mainpart + ' ';
     while length(extention) < 3 do
           extention := extention + ' ';
     { Remeber - an asterisk fills a string out with ?s }
     if pos('*',wild_mp) = 0 then
      while length(wild_mp) < 8 do
       wild_mp := wild_mp + ' '
     else
      while length(wild_mp) < 8 do
       wild_mp := wild_mp + '?';
     if pos('*',wild_ex) = 0 then
      while length(wild_ex) < 3 do
       wild_ex := wild_ex + ' '
     else
      while length(wild_ex) < 3 do
       wild_ex := wild_ex + '?';
     { Now to organize our asterisks... }
     while pos('*',wild_mp) <> 0 do
      wild_mp[pos('*',wild_mp)] := '?';
     while pos('*',wild_ex) <> 0 do
      wild_ex[pos('*',wild_ex)] := '?';
     { Now we need to check if they are compatible :) }
     for x := 1 to 8 do
         if wild_mp[x] = '?' then
            wild_mp[x] := mainpart[x];
     for x := 1 to 3 do
         if wild_ex[x] = '?' then
            wild_ex[x] := extention[x];
     if (mainpart = wild_mp) and
        (extention = wild_ex) then
        wildcardmatch := true;
end;

Function CheckHeader(fname : string) : boolean;
{ Check if 'fname' is a valid PAC file }
var
   infile : file;
begin
     if fsearch(fname,getenv('name')) = '' then
     begin
          checkheader := false;
          exit;
     end;
     assign(infile,fname);
     reset(infile,1);
     blockread(infile,header,sizeof(header));
     blockread(infile,version,sizeof(version));
     close(infile);
     { Read in header/version }
     if (header = pacheader) and (version = pacversion) then
        checkheader := true
     else
         checkheader := false;
     { Validate }
     if (version <> pacversion) and (header = pacheader) then
     begin
          writeln('Version Mismatch!');
          writeln('Expected Version : ',pacversion);
          writeln('Version Received : ',version);
     end;
     { Show Error/wotever }
end;

Procedure Extractfiles(pacfilename : string);
var
   outfile : file; { Output File }
   pacfile : file; { .PAC File }
   extractit : boolean; { Used insead of ifs+elses }
   numread,
   numwrote  : word; { amount of file read/written }
   xpos,ypos : integer; { x/y positions on screen - for neatness }
begin
     extractit := false;
     writeln('Searching Archive : ',pacfilename);
     assign(pacfile,pacfilename);
     reset(pacfile,1);
     blockread(pacfile,header,sizeof(header));
     blockread(pacfile,version,sizeof(version));
     { Read header/version }
     if (header <> pacheader) or
        (version <> pacversion) then
     begin
          writeln('Major Stuff-up! : Header/version mismatch!');
          close(pacfile);
          halt;
     end;
     { validate header/version }
     repeat
           extractit := false;
           blockread(pacfile,fileheader,sizeof(fileheader));
           for x := 1 to 20 do
               if wildcardmatch(fileheader.fname,extractfile[x]) then
                  extractit := true;
           if extractit then
           begin
                writeln('Extracting: ',fileheader.fname:12,' ');
                xpos := wherex;
                ypos := wherey;
                assign(outfile,fileheader.fname);
                rewrite(outfile,1);
           end;
           if extractit then
           for x := 1 to fileheader.fsize div 10240 do
           begin
                blockread(pacfile,buf,sizeof(buf),numread);
                blockwrite(outfile,buf,numread,numwrote);
           end
           else
               seek(pacfile,filepos(pacfile)+fileheader.fsize);
           if extractit then
           begin
                blockread(pacfile,buf,(fileheader.fsize mod 10240),numread);
                blockwrite(outfile,buf,numread);
                close(outfile);
           end;
     until eof(pacfile);
     close(pacfile);
end;

procedure Addfiles(pacfilename : string);
var
   Infile : file;
   Pacfile : file;
   numread,
   numwrote  : word;
   DirInfo   : SearchRec;
   x,y       : integer;
   xpos,ypos : integer;
begin
     assign(pacfile,pacfilename);
     for x := 1 to length(pacfilename) do pacfilename[x] := upcasE(pacfilename[x]);
     if fsearch(pacfilename,getenv('name')) = '' then
     begin
          rewrite(pacfile,1);
          header := pacheader;
          version := pacversion;
          blockwrite(pacfile,header,sizeof(header));
          blockwrite(pacfile,version,sizeof(version));
          writeln('Creating PAC: ',pacfilename);
     end
     else
     begin
          writeln('Updating PAC: ',pacfilename);
          reset(pacfile,1);
          seek(pacfile,filesize(pacfile));
     end;
     FindFirst('*.*', Archive, DirInfo);
     while DosError = 0 do
     begin
          for x := 1 to 10 do
              if wildcardmatch(dirinfo.name,extractfile[x]) then
               if dirinfo.name <> pacfilename then
                 begin
                      x := 10;
                      assign(infile,dirinfo.name);
                      reset(infile,1);
                      fileheader.fname := dirinfo.name;
                      fileheader.fsize := filesize(infile);
                      blockwrite(pacfile,fileheader,sizeof(fileheader));
                      write('Adding: ',fileheader.fname:12,' ');
                      xpos := wherex;
                      ypos := wherey;
                      y := 0;
                      repeat
                                 drawpercentage(xpos,ypos,round(filepos(infile) / fileheader.fsize*100));
                                 {writeln(round(filepos(infile) / fileheader.fsize*100));}
                            blockread(infile,buf,sizeof(buf),numread);
                            blockwrite(pacfile,buf,numread,numwrote);
                            inc(Y);
                      until (numread <> numwrote) or (numread = 0);
                      gotoxy(xpos,ypos);
                      {write('[',filepos(infile) / fileheader.fsize*100:3:0,'%],Done.');}
                      writeln;
                      close(infile);
                 end;
          FindNext(DirInfo);
     end;
     close(pacfile);
end;

procedure ListFiles(pacfilename : string);
var
   pacfile : file;
   numread,
   numwrote : word;
   y         : integer;
   totalsize : longint;
   numfiles  : integer;
begin
     numfiles := 0;
     totalsize := 0;
     y := 1;
     writeln('Searching Archive : ',pacfilename);
     assign(pacfile,pacfilename);
     reset(pacfile,1);
     blockread(pacfile,header,sizeof(header));
     blockread(pacfile,version,sizeof(version));
     if (header <> pacheader) or
        (version <> pacversion) then
     begin
          writeln('Major Stuff-up! : Header/Version Mismatch!');
          close(pacfile);
          halt;
     end;
     writeln(' Filename                             Size');
     writeln('------------------------------------------');
     repeat
           inc(y);
           if y = 24 then
           begin
                write('Press any key to continue.');
                readln;
                y := 1;
           end;
           blockread(pacfile,fileheader,sizeof(fileheader));
           writeln(fileheader.fname:12,fileheader.fsize:24,' bytes');
           seek(pacfile,filepos(pacfile)+fileheader.fsize);
           inc(totalsize,fileheader.fsize);
           inc(numfiles);
           { Move past current file in pacfile, to next file header }
     until eof(pacfile);
     writeln('------------------------------------------');
     writeln(numfiles:12,' Files',totalsize:18,' bytes');
     close(pacfile);
end;

Procedure RunProgram;
var
   PacFileName : string;
   param        : string;
begin
     PacFilename := paramstr(1);
     if pos('.',Pacfilename) = 0 then
        Pacfilename := Pacfilename + '.pac';
     param := paramstr(2);
     param[2] := upcase(param[2]);
     if (param[1] <> '-') and (param[1] <> '/') then
     begin
          writeln('And... what am I supposed to do now???');
          halt;
     end;
     if (param[2] = 'E') or (param[2] = 'X') then
     begin
          if fsearch(Pacfilename,getenv('name')) = '' then
          begin
               writeln('PAC File : ',Pacfilename,' isn''t there, stupid!');
               halt;
          end;
          if paramcount < 3 then
          begin
               writeln('No FileSpec... Assuming *.*');
               for x := 1 to 10 do extractfile[x] := '';
               extractfile[1] := '*.*';
          end
          else
          begin
               for x := 1 to 10 do extractfile[x] := '';
               for x := 1 to paramcount-2 do
                   extractfile[x] := paramstr(x+2);
          end;
          ExtractFiles(Pacfilename); { procedure uses "extractfile" var }
     end;
     if param[2] = 'A' then
     begin
          if paramcount < 3 then
          begin
               writeln('No Filespec... Assuming *.*');
               for x := 1 to 10 do extractfile[x] := '';
               extractfile[1] := '*.*';
          end
          else
          begin
               for x := 1 to 10 do extractfile[x] := '';
               for x := 1 to paramcount-2 do
                   extractfile[x] := paramstr(x+2);
          end;
          AddFiles(Pacfilename);
     end;
     if param[2] = 'L' then
     begin
          if fsearch(Pacfilename,getenv('name')) = '' then
          begin
               writeln('PAC File : ',Pacfilename,' isn''t there, stupid!');
               halt;
          end;
          ListFiles(Pacfilename);
     end;
end;

{- Main Program -------------------------------------------------------------}

begin
     textbackground(black);
     clrscr;
     writeln('TPAC v1.7 by Tim Gordon  (This one uses wildcards!)');
     writeln('---------------------------------------------------');
     if paramstr(1) = '-?' then
        displayhelp; { Displays Help if -? parameter is used }
     if paramcount = 0 then
        displayhelp; { Displays help if no parameters were used }
     RunProgram; { Run Main program }
end.