Programmer 7500/MAX_PROGRAMMERS.iso/INFO/ARC_LBR/REPAK2.ARC/REPAK.PAS

Pascal/Delphi Source File | 1988-10-05 | 5.9 KB | 278 lines

(*

   Program   REPAK
   Version   1.00
   Author    Atkinson - Home Computer - 414-543-8929 - 154/666
   Language  Turbo Pascal 4
   Utilities Turbo Professional
   Dos       PC-DOS 3.3
   Purpose   To compress archives with newer method compression
   Date      10/03/88
   Disk      Two files are written - \arcstodo.$$$ and \deletes.$$$
             One directory is created \temp.$$$

   History   10/03/88 - Created the program
         10/04/88 - Added -r switch to unpak routine
         10/05/88 - Recoded .$$$ deletion code

   Usage: REPAK file

          Where file is desired .ARC

          Ex: *.*, *.ARC, A*.ARC AB*.ARC etc...

          Full Ex : REPAK A*.ARC

*)

{$B+}
{$D-}
{$F-}
{$I-}
{$L-}
{$M 16000,0,100000}
{$N-}
{$R-}
{$S-}
{$T-}
{$V+}

program repak;
uses    dos, tpstring, tpdos, tpcrt, tpint;

const
    inthandle = 15;
var
    quit : boolean;
    code, loop : integer;
    drive, startdir, arcname, filename, xpak_fullname, pak_fullname: string;
    ok : boolean;
    tempfilename, arcsfound, filestodelete : text;
    attr : word;
    searchfor : searchrec;

procedure findfirstarchive;
begin
    attr := $3f;
    findfirst(forceextension(paramstr(1),'ARC'), attr, searchfor);
    ok := doserror = 0;
    if ok
    then
      begin
        writeln(arcsfound, fullpathname(searchfor.name));
      end;

end;

procedure findrestarchive;
label 100;
begin
100:    findnext(searchfor);
    ok := doserror = 0;
    if ok
    then
      begin
        writeln(arcsfound, fullpathname(searchfor.name));
        searchfor.name := '';
      end;
    if ok then goto 100;
end;

procedure firstfiletodelete;
begin
    attr := $3f;
    findfirst('*.*', attr, searchfor);
    ok := doserror = 0;
    if ok
    then
      begin
        if searchfor.name <> '.'
        then
          writeln(filestodelete, fullpathname(searchfor.name));
      end;

end;

procedure restfilestodelete;
label 100;
begin
100:    findnext(searchfor);
    ok := doserror = 0;
    if ok
    then
      begin
        if searchfor.name <> '..'
        then
          writeln(filestodelete, fullpathname(searchfor.name));
      end;
    if ok then goto 100;
end;

procedure cleanup;
begin
    assign(filestodelete, '\deletes.$$$');
        rewrite(filestodelete);
    chdir('\temp.$$$');
        firstfiletodelete;
    restfilestodelete;
    close(filestodelete);
    reset(filestodelete);
    writeln;
    writeln('Delete work files pass...');
    writeln;
    while not eof(filestodelete) and (not quit) do
    begin
      readln(filestodelete, filename);
      writeln(filename);
      assign(tempfilename, filename);
      erase(tempfilename);
    end;
    close(filestodelete);
    if not eof(arcsfound)
    then
      begin
        writeln;
        write('Changing directory to ');
        writeln(justpathname(paramstr(1)));
            chdir(justpathname(paramstr(1)));
      end;
end;

procedure doarc;
begin
    reset(arcsfound);
        while not eof(arcsfound) and (not quit) do
    begin
      writeln;
      writeln('Get archive pass...');
      readln(arcsfound, arcname);
      writeln;
      writeln('Next file to process : ' + arcname);
      code := execdos(xpak_fullname + ' -r ' + arcname+' \temp.$$$', false, Nil);
      writeln;
      writeln('Unpak status...');
      writeln;
      writeln('DosError    : ', doserror);
      writeln('Using       : ', stupcase(xpak_fullname));
      writeln('On file     : ', arcname);
      writeln;
      writeln('Repak pass...');
      code := execdos(pak_fullname + ' -a '+arcname+' \temp.$$$\*.*', false, Nil);
      writeln;
      writeln('Pak status...');
      writeln;
      writeln('DosError    : ', doserror);
      writeln('Using       : ', stupcase(xpak_fullname));
      writeln('On file     : ', arcname);
      cleanup;
    end;
    close(arcsfound)
end;

procedure new1b(bp : word); interrupt;
var
    regs : intregisters absolute bp;
begin
    quit := true;
    chainint(regs, isr_array[inthandle].origaddr);
end;

procedure checkforfiles;
var
    notok1, notok2, notok3 : boolean;
begin
    attr := $10;
    findfirst('\temp.$$$', attr, searchfor);
    notok1 := doserror = 0;
    attr := $3f;
    findfirst('\arcstodo.$$$', attr, searchfor);
    notok2 := doserror = 0;
    attr := $3f;
    findfirst('\deletes.$$$', attr, searchfor);
    notok3 := doserror = 0;
    if notok1 or notok2 or notok3
    then
      begin
        writeln;
        writeln('\TEMP.$$$ - \DELETES.$$$ - \ARCSTODO.$$$');
        writeln;
        writeln('All of these items needed, please check root directory...');
        halt;
      end;
end;

procedure showhow;
begin
    writeln('');
        writeln('Usage:');
        writeln('');
        writeln('REPAK file');
        writeln('');
        writeln('Where file is desired .ARC');
        writeln('');
        writeln('Ex: *.*, *.ARC, A*.ARC AB*.ARC etc...');
    chdir(startdir);
    halt;
end;

procedure findprograms;
begin
        if (existonpath('PKARC.EXE', pak_fullname))
    and (existonpath('PKXARC.EXE', xpak_fullname))
    then
      exit
    else
          if (existonpath('PKPAK.EXE', pak_fullname))
    and (existonpath('PKUNPAK.EXE', xpak_fullname))
    then
      exit
    else
          begin
            writeln(' ');
            writeln('PKware .EXE compression programs not found on path...');
        writeln;
        writeln('PKARC.EXE and PKXARC.EXE or PKPAK.EXE and PKUNPAK.EXE...');
        halt;
          end;
end;

procedure main;
begin
    getdir(0, startdir);
        chdir(justpathname(paramstr(1)));
    if paramcount = 0 then showhow;
    checkforfiles;
    if initvector($1b, inthandle, @new1b) then {};
    ok := false;
    quit := false;
    assign(arcsfound, '\arcstodo.$$$');
    rewrite(arcsfound);
    findfirstarchive;
    findprograms;
    if ok
    then
      begin
            mkdir('\temp.$$$');
            findrestarchive;
            close(arcsfound);
            doarc
          end
        else
          begin
            writeln(' ');
            writeln('No .ARC files to process...')
          end;
    writeln;
    writeln('REPAK Finished...');
    assign(tempfilename, '\deletes.$$$');
    erase(tempfilename);
    erase(arcsfound);
    chdir('\');
    rmdir('temp.$$$');
    chdir(startdir);
end;

begin
    main;
end.