[Back to ARCHIVES SWAG index] [Back to Main SWAG index] [Original]

    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.

[Back to ARCHIVES SWAG index] [Back to Main SWAG index] [Original]