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

    Unit UnArc;
    {$O+}

    interface

    Type
      UnCompressFileProc  = Procedure (ArcP:string);
      UnCompressFileProc2 = Procedure;
      UnCompressFileProc3 = Procedure (command,param:string);

    Procedure LoadArchiveDef(fn:string);

    Function UnCompressFile(  filepath    : String;
                              PreStats    : UnCompressFileProc;
                              ExecProc    : UnCompressFileProc3;
                              PreExec,
                              PostExec    : UnCompressFileProc2;
                            var
                              broken,
                              Sfx         : boolean;
                              errorstring : String):boolean;

    Function CompressType:string;

    function Compress(Destpath,SourcePath: String;
                              ExecProc    : UnCompressFileProc3;
                              PreExec,
                              PostExec    : UnCompressFileProc2;
                              var errstr:string ):boolean;

    implementation

    Uses Dos,Etc;

    Const NumOfIDBytes = 20;

    type
         ByteUsed = record Used: boolean;Val : byte; end;
         ToArcDefType = ^ArcDefType;
         ArcDefType = record
           Next     : ToArcDefType;
           Sfx      : boolean;
           ProgID   : String[3];
           Prog     : String[12];
           Param    : String[20];
           IDBlock  : array[1..NumOfIDBytes] of ByteUsed;
         end;

         ReCompressType = Record
           ProgID : String[3];
           Prog   : String[12];
           Param  : String[20];
           end;

    Var ArcDefRoot: ToArcDefType;
        ArcP      : string[3];
        ReComp    : RecompressType;

    function compresstype:string;
      begin
      compresstype := recomp.progid;
      end;

    Procedure LoadArchiveDef(fn:string);
      type bt = array[1..2048] of byte;
      Var Cur: ToArcDefType;
          ADF: text;
          cl : string;
          b  : ^bt;

      procedure ProcessLine;
        var hdr:string[20];
            i  : byte;

        procedure Seek(a:char); begin cl:=copy(cl,pos(a,cl)+1,length(cl)); { seek to " } end;

        procedure Clean(a:char); begin cl:=copy(cl,pos(a,cl)+1,length(cl)) end;

        begin
        cl:=rtrim(ltrim(cl));
        if cl[1]<>';' then
          begin
          hdr:=upcasestr(copy(cl,1,pos(':',cl)));

          if copy(hdr,1,2)=copy('UN:',1,2) then {'UN'}
            begin
            if cur=nil then
                 begin
                 new(cur);
                 cur^.next:=nil;
                 ArcDefRoot:=Cur;
                 end
              else
                begin
                new(cur^.next);
                cur:=cur^.next;
                cur^.next:=nil;
                end;

            Seek('"');
            Cur^.ProgID:=copy(cl,1,pos('"',cl)-1);
            Clean('"');

            Seek('"');
            Cur^.Prog:=Copy(cl,1,pos('"',cl)-1);
            clean('"');

            Seek('"');
            Cur^.Param:=copy(cl,1,pos('"',cl)-1);
            Clean('"');

            For i:=1 to NumOfIDBytes do Cur^.IDBlock[i].Used:=false;

            For i:=1 to NumOfIDBytes do
             begin
             seek('$');
             if length(cl)>0 then
               begin
               if copy(cl,1,2)<>'--' then
                 begin
                 Cur^.IDBlock[i].Val:=Hex2Byte(copy(cl,1,2));
                 Cur^.IDBlock[i].used:=true;
                 end
               else Cur^.IDblock[i].used:=false;
               delete(cl,1,2);
               end;
             end;

            if hdr='UNSFX:' then Cur^.SFX:=true else Cur^.SFX:=false;
            end
          else
           if HDR='TOARC:' then
            begin
            seek('"');
            ReComp.ProgID:=copy(cl,1,pos('"',cl)-1);
            clean('"');

            Seek('"');
            ReComp.Prog:=copy(cl,1,pos('"',cl)-1);
            Clean('"');

            seek('"');
            ReComp.Param:=copy(cl,1,pos('"',cl)-1);
            clean('"');

            end;

         end;
        end;

      begin
      new(b);
      ArcDefRoot := nil;
      cur:=ArcDefRoot;

      Assign(adf,fn);
      reset(adf);
      settextbuf(adf,b^,sizeof(b^));

      readln(adf,cl);
      processline;

      while not eof(adf) do
         begin
         Readln(adf,cl);
         processline;
         end;

      close(adf);
      Dispose(b);
      end;

      function Compress(Destpath,SourcePath: String;
                              ExecProc    : UnCompressFileProc3;
                              PreExec,
                              PostExec    : UnCompressFileProc2;
                              var errstr:string ):boolean;
        var
         Dir   : DirStr;
         Name  : NameStr;
         Ext   : ExtStr;
         a     : byte;
         f     : file;
         runstr: string;
         runparmr:string;
         runparmd:string;
         derror: integer;

        begin
        Compress := TRUE;

        runstr:=FSearch(ReComp.Prog,GetEnv('PATH'));

        if runstr='' then
         begin
         errstr:='Could not find '+recomp.prog+' in PATH';
         compress := false;
         exit;
         end;

        runparmr:=ReComp.Param+' '+destpath+' '+sourcepath;

        PreExec;

        Execproc(RunStr, RunParmR);

        postexec;

       derror:=dosexitcode;

      if not ((derror)=0) then
        begin
        errstr:='Device Error or Low Mem';
        compress := false;
        exit;
        end

        end;

    Function UnCompressFile(  filepath    : String;
                              PreStats    : UnCompressFileProc;
                              ExecProc    : UnCompressFileProc3;
                              PreExec,
                              PostExec    : UnCompressFileProc2;
                            var
                              broken,
                              Sfx         : boolean;
                              errorstring : String):boolean;

      var tempfile :file;
          uncompstr:string;
          p        :string;
          bffr     :array[1..NumOfIDBytes] of byte;
          derror   :integer;

      var tts:string;

      Procedure WhichFormat;
        var cur      : ToArcDefType;

        function match:boolean;
         var i:byte;
         begin
         for i:=1 to NumOfIDBytes do
          if Cur^.IDBlock[i].Used then
           begin
           if not (bffr[i]=Cur^.IDBlock[i].Val) then
             begin
             Match:=False;
             Exit;
             end;
           end;
         Match:=true;
         end;

        begin

        { set uncompstr to '' for unrecognized compression }

        UnCompStr:='';

        Cur:=ArcDefRoot;

        while cur<>nil do
          begin
          if Match then begin
           UnCompStr:=Cur^.Prog;
           Sfx:=Cur^.Sfx;
           ArcP:=Cur^.ProgID;
           P:=Cur^.param;
           end;

          Cur:=Cur^.Next;
          end;
        end;

      var SizeToRead:word;

      begin

      errorstring:= '';

      assign(tempfile,filepath);
      reset(tempfile,1);

      if filesize(tempfile)<sizeof(bffr) then
          begin
          fillchar(bffr,sizeof(bffr),#0);
          sizetoread:=filesize(tempfile)-1;
          end
      else SizeToRead:=Sizeof(Bffr);

      blockread(tempfile,bffr,sizetoread);
      close(tempfile);

      Sfx:=false;

      WhichFormat;

      if UnCompStr='' then
         begin
         Broken:=False;
         errorstring :=  'Unknown Format';
         UnCompressFile:=False;
         Exit;
         end;

       uncompstr:=FSearch(UnCompStr,GetEnv('PATH'));

       if uncompstr='' then
         begin
         broken := false;
         ErrorString := 'Can''t Find UN-ARCHIVER for: '+ArcP;
         UnCompressFile := false;
         exit;
         end;

      PreStats (ArcP);

      tts:=fexpand('.\TEMP$$.$$');

      mkdir(tts);
      chdir( tts );

      PreExec;

      ExecProc(uncompstr,p+' '+filepath+' *.*');

      PostExec;

      derror:=dosexitcode;

      if not (hi(derror)=0) then
        begin
        ErrorString := 'Device Error - ^C or Low Memory';
        broken := false;
        UnCompressFile := false;
        exit;
        end;

      UnCompressFile := DError=0;

      Broken:=Not (DError=0);

      chdir( fexpand ('..') );

      end;

    begin
     ArcDefRoot := nil;

    end.

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