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

    program CAT;

    {$I-}

    uses
       dos,
       files, { see end for this unit }
       crt;

    type
       arraybuf = array[1..65535] of byte;
       buffer = ^arraybuf;
       chksum = file of searchrec;

    procedure error(mess:string);
    var
       code:integer;
    begin
       code:= ioresult;
       writeln('ERROR:  ', mess);
       {writeln('ERROR CODE:  ', code);}
       halt(1);
    end;

    procedure delete(drive:char; var success:boolean);
       procedure recurse(tree:directory_tree; var success:boolean);
       var
          info:searchrec;
          buffer:text;
          success2:boolean;
          d:string[79];
       begin
          if tree <> nil then begin
          success2:= true;
          d:= tree^.dir;
             begin
                recurse(tree^.lower_dir, success2);
                tree:= tree^.next;
                success:= success and success2;
                recurse(tree, success2);
                success:= success and success2;
             end;
          chdir(d);
          findfirst('*.*', anyfile, info);
          while (doserror = 0) and (success) do
             begin
                if (info.name <> '.') and (info.name <> '..') then
                   begin
                      assign(buffer, info.name);
                      case info.attr of
                         $10: rmdir(info.name);
                         $20: erase(buffer);
                      else
                         success:= false;
                      end;
                   end;
                findnext(info);
             end;
       end;
       end;
    var
       tree:directory_tree;
    begin
       tree:= nil;
       chdir(drive+':\');
       fill_dirtree(drive+':\', tree);
       success:= true;
       recurse(tree, success);
    end;

    function DriveExist(drive:char):boolean;
    var
       fileinfo:searchrec;
    begin
       findfirst(drive+':\*.*', anyfile, fileinfo);
       if doserror = 3 then
          driveexist:= false
       else
          driveexist:= true;
    end;

    procedure work(max,done:longint);
    begin
       write(100*(done/max):4:1, '% complete.');
       gotoxy(1, wherey);
    end;

    procedure help;
    begin
       writeln('The Concatinator   Version 1.0   Copyright 1996 by Jack Neely');
       writeln('A large file disk storage and retrieval program.');
       writeln;
       writeln('Usage:   CAT s <storage drive> <filename>');
       writeln('         CAT r <storage dirve> <path>');
       writeln;
       writeln('Commands: ''s'' = Store   ''r'' = Retrive');
       writeln('Storage drive must be the disk drive to store or that a large file is');
       writeln('stored apon.  Specify a path where the file will be placed when');
       writeln('retriving a file.  Specify a filemane when storing a large file.');
       writeln;
       writeln('You can use this program to store those large files that are larger');
       writeln('than a single disk onto multiple disks.  Anything on the disk prior');
       writeln('to storage will be erased.  A checksum file will also be stored on the');
       writeln('first disk of each set.');
       writeln;
       writeln('The author can be reached at hneely@ac.net');
       writeln;
       halt(0);
    end;

    function num(d:char):word;
    begin
       num:= ord(upcase(d)) - 64;
    end;

    function strn(a:integer):string;
    var
       s:string;
       i:integer;
    begin
       str(a, s);
       if length(s) < 4 then
          for i:= 1 to 4 - length(s) do
             s:= '0' + s;
       strn:= s;
    end;

    function return(s:string; b:boolean):integer;
    var
       str:string;
       i, c:integer;
    begin
       str:= '';
       if b then
          for i:= 1 to 4 do
             str:= str + s[i]
       else
          for i:= 5 to 8 do
             str:= str + s[i];
       val(str, i, c);
       return:= i;
    end;

    procedure store(filename:string; drive:char);
    var
       input, output:file;
       fileinfo, test:searchrec;
       filedata:chksum;
       c, full, disk:longint;
       diskdone:boolean;
       fset, disknum:word;
       success:boolean;
       data:buffer;
       buffersize, readcount, writecount:word;
       ch:char;
    begin
       findfirst(filename, anyfile, fileinfo);
       if doserror <> 0 then
          error('File not found: ' + filename);
       new(data);
       c:= 0;
       disknum:= 0;
       diskdone:= true;
       if not DriveExist(drive) then error(drive+': does not exist.');
       randomize;
       fset:= random(9999);
       writeln('This is file set number ', fset, '.');
       assign(input, filename);
       reset(input, 1);
       while c < fileinfo.size do
          begin
             if diskdone then
                begin
                   if disknum <> 0 then
                      close(output);
                   clreol;
                   disk:= 0;
                   disknum:= disknum + 1;
                   write('Insert disk ', disknum, ' and press [ENTER].');
                   readln;
                   diskdone:= false;
                   buffersize:= sizeof(arraybuf);
                   full:= disksize(num(drive));
                   if disknum = 1 then
                      begin
                         writeln('Approximately ', (1+(fileinfo.size div disksize(num(drive)))), ' of these disks are needed.');
                         write('Continue? (Y/N)');
                         ch:= readkey;
                         if not ((ch = 'y') or (ch = 'Y')) then
                            halt(0);
                         writeln;
                      end;
                   if disksize(num(drive)) <> diskfree(num(drive)) then
                      begin
                         findfirst(drive+':\*.cat', anyfile, test);
                         if return(test.name, true) = fset then
                            error('This disk is of this same set.');
                         delete(drive, success);
                         if not success then
                            error('Some existing file(s) on destination disk could not be removed.');
                      end;
                      assign(output, drive+':\'+strn(fset)+strn(disknum)+'.cat');
                      rewrite(output, 1);
                   if disknum = 1 then
                      begin
                         assign(filedata, drive+':\check.sum');
                         rewrite(filedata);
                         write(filedata, fileinfo);
                         close(filedata);
                         full:= diskfree(num(drive));
                      end;
                end;
             if full - disk < buffersize then
                begin
                   buffersize:= full - disk;
                   diskdone:= true;
                end;
             blockread(input, data^, buffersize, readcount);
             if ioresult <> 0 then
                error('Errors on source disk.');
             blockwrite(output, data^, readcount, writecount);
             if ioresult <> 0 then
                error('Errors on target disk.');
             c:= c + readcount;
             disk:= disk + readcount;
             work(fileinfo.size, c);
             if readcount <> writecount then error('Unable to write to disk');
          end;
       clreol;
       close(input);
       close(output);
       dispose(data);
    end;

    procedure retrive(drive:char; path:string);
    var
       setnum, disknum:word;
       diskdone, complete:boolean;
       newfile, store:file;
       cs:chksum;
       fileinfo, data:searchrec;
       d:buffer;
       c:longint;
       buffersize, readcount, writecount:word;
    begin
       complete:= false;
       chdir(path);
       new(d);
       c:= 0;
       if ioresult <> 0 then
          error(path+' does not exist.');
       diskdone:= true;
       disknum:= 0;
       while not complete do
          begin
             if diskdone then
                begin
                   clreol;
                   disknum:= disknum + 1;
                   if disknum > 1 then
                      close(store);
                   diskdone:= false;
                   write('Insert disk ', disknum, ' and press [ENTER].');
                   readln;
                   buffersize:= sizeof(arraybuf);
                   if disknum = 1 then
                      begin
                         assign(cs, drive+':\check.sum');
                         reset(cs);
                         if ioresult <> 0 then error('No check sum file.');
                         read(cs, fileinfo);
                         close(cs);
                         assign(newfile, fileinfo.name);
                         rewrite(newfile, 1);
                         findfirst(drive+':\*.cat', archive, data);
                         if doserror = 18 then
                            begin
                               close(newfile);
                               erase(newfile);
                               error('Disk does not contain storage data.');
                            end;
                         assign(store, drive+':\'+data.name);
                         reset(store, 1);
                         setnum:= return(data.name, true);
                         if return(data.name, false) <> disknum then
                            begin
                               close(newfile);
                               erase(newfile);
                               error('Wrong disk.');
                            end;
                         writeln('File set number is: ', setnum);
                      end
                   else
                      begin
                         findfirst(drive+':\*.cat', archive, data);
                         if doserror = 18 then
                            begin
                               close(newfile);
                               erase(newfile);
                               error('Disk does not contain storage data.');
                            end;
                         assign(store, drive+':\'+data.name);
                         reset(store, 1);
                         if setnum <> return(data.name, true) then
                            begin
                               close(newfile);
                               erase(newfile);
                               error('Disk is of a different set.');
                            end;
                         if disknum <> return(data.name, false) then
                            begin
                               close(newfile);
                               erase(newfile);
                               error('Wrong disk.');
                            end;
                      end;
                end;
             blockread(store, d^, buffersize, readcount);
             if ioresult <> 0 then
                begin
                   close(newfile);
                   erase(newfile);
                   error('Errors on source disk.');
                end;
             blockwrite(newfile, d^, readcount, writecount);
             if ioresult <> 0 then
                begin
                   close(newfile);
                   erase(newfile);
                   error('Errors on target disk.');
                end;
             c:= c + readcount;
             if writecount <> readcount then
                begin
                   close(newfile);
                   erase(newfile);
                   error('Unable to write to disk.');
                end;
             if buffersize <> readcount then
                diskdone:= true;
             if fileinfo.size = c then complete:= true;
             work(fileinfo.size, c);
          end;
       clreol;
       close(newfile);
       close(store);
       dispose(d);
    end;

    var
       c1, c2:string;

    begin
       if paramcount = 0 then
          help;
       if paramcount <> 3 then
          error('Incorect number of parameters.');
       c1:= paramstr(1);
       c2:= paramstr(2);
       case c1[1] of
          's', 'S' : store(paramstr(3), c2[1]);
          'r', 'R' : retrive(c2[1], paramstr(3));
       else
          error('Incorect parameters.');
       end;
       writeln('Complete!');
    end.

    { ---------------  CUT ---------------- }

    unit files;

    interface

    uses
       dos;

    type
       filetype = string[12];
       {searchrec = record    This is how searchrec is defined in the DOS unit.
          Fill: array[1..21] of Byte;
          Attr: Byte;
          Time: Longint;
          Size: Longint;
          Name: string[12];
       end;  }
       filestack = ^ node;
       node = record
          fileinfo:searchrec;
          next:filestack;
       end;
       directory_tree = ^dnode;
       dnode = record
          dir:string;
          lower_dir:directory_tree;
          next:directory_tree;
       end;

    procedure fill_filestack(var stack:filestack);
       {Fills stack of type filestack with all the file enteries in the
       current directory.  Includes directoies and hidden file types.}

    procedure push_filestack(var stack:filestack; item:searchrec);
       {Pushes in alfa order a new node on a filestack.}

    procedure fill_dirtree(dir:string; var tree:directory_tree);
       {Fills a tree sturcture with the directory structure using dir string
       as the root.}

    implementation

    procedure push_filestack(var stack:filestack; item:searchrec);
    var
       temp:filestack;

       procedure insert(var stack, prev:filestack);
       begin
          if (stack = nil) then
             begin
                temp^.next:= stack;
                stack:= temp;
             end
          else
             if temp^.fileinfo.name > stack^.fileinfo.name then
                insert(stack^.next, stack)
             else
                if temp^.fileinfo.name < stack^.fileinfo.name then
                   begin
                      if prev = stack then
                         begin
                            temp^.next:= stack;
                            stack:= temp;
                         end
                      else
                         begin
                            temp^.next:= stack;
                            prev^.next:= temp;
                         end;
                   end;
       end;
    begin
       new(temp);
       temp^.fileinfo:= item;
       insert(stack, stack);
    end;

    procedure fill_filestack(var stack:filestack);
    var
       dirinfo:searchrec;
    begin
       findfirst('*.*', anyfile, dirinfo);
       while doserror <> 18 do
          begin
             push_filestack(stack, dirinfo);
             findnext(dirinfo);
          end;
    end;

    procedure push(var head:directory_tree; item:string);
    var
       temp:directory_tree;
    begin
       new(temp);
       temp^.dir:= item;
       temp^.next:= head;
       head:= temp;
       head^.lower_dir:= nil;
    end;

    procedure fill_dirtree(dir:string; var tree:directory_tree);
    procedure fill_dirlist(var head:directory_tree; directory:string; s:integer);
    var
       place:directory_tree;
       dirinfo:searchrec;
       found:boolean;
    begin
       writeln(directory);
       chdir(directory);
       findfirst('*.*', 16, dirinfo);
       while doserror = 0 do
          begin
             if (dirinfo.attr = 16) and ((dirinfo.name <> '..') and (dirinfo.name <> '.'))then
                begin
                   push(head, fexpand(dirinfo.name));
                   found:= true;
                end;
                findnext(dirinfo);
             end;
          if found then
             begin
                place:= head;
                while place <> nil do
                   begin
                      fill_dirlist(place^.lower_dir, place^.dir, s+3);
                      place:= place^.next;
                   end;
             end;
    end;

    var
       temp:directory_tree;
    begin
       tree:= nil;
       fill_dirlist(tree, dir, 0);
       new(temp);
       temp^.dir:= dir;
       temp^.lower_dir:= tree;
       temp^.next:= nil;
       tree:= temp;
    end;

    end.

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