home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 8 Other
/
08-Other.zip
/
fss100.zip
/
FSS.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1994-11-08
|
14KB
|
428 lines
PROGRAM FileSaveSet;
{
Creates BackMaster-compatible (mostly....) SaveSet files
in the *.FSS format.
WARNING:
┌────────────────────────────────────────────────────┐
│ USES AND GLOBAL VARIABLES & CONSTANTS ! Ugly! │
└────────────────────────────────────────────────────┘
}
USES Crt,Dos;
TYPE
FPtr = ^Dir_Rec;
Dir_Rec = record { Double pointer record }
DirName : string;
DirNum : integer;
Next : Fptr;
Prev : Fptr;
END;
Str_type = string[65];
VAR
Dir : string;
Loop : boolean;
Level : integer;
Flag : array[1..5] of string;
Tree : boolean;
TotlBytes : longint;
DirChar : Char;
DriveNum : longint;
F : text;
Fbase,
Fext,
Fname : String;
Code,
Outfiles : integer;
BytesBacked,
TargetSize,
OutSize : longint;
{
┌────────────────────────────────────────────────────┐
│ PROCEDURE Beepit │
└────────────────────────────────────────────────────┘
}
Procedure OPENIT;
Begin
Inc(Outfiles);
Fbase := 'bs_';
Fext := '.FSS';
Fname := Fbase+Dir[1]+'_'+CHR(Outfiles)+Fext;
Assign(f,Fname);
ReWrite(f);
WriteLn(f,'BACKMASTER VERSION 1.1');
WriteLn(f,'SAVESET FILE ',Fname);
Writeln(f,'SOURCE DRIVE ',UPCASE(Dir[1]));
Writeln(f,'ENDHEADER');
Writeln(f,' This saveset file was created automatically!');
WriteLn(f,' Targeted Size is "less than" ',(TargetSize/1000000):8:2,' MBytes.');
Writeln(f,'ENDCOMMENT');
End;
PROCEDURE CLOSEIT;
Begin
Writeln(f,'ENDDIRS');
IF Outfiles = 65 then WriteLn(f,'\*.*'); {root dir files go in first set}
Writeln(f,'END');
WriteLn(f,'; MBytes Backed up by this saveset = ',(BytesBacked/1000000):8:2);
Flush(f);
Close(f);
End;
PROCEDURE Beepit;
BEGIN
SOUND (760); { Beep the speaker }
DELAY (80);
NOSOUND;
ClrScr;
END;
{
┌────────────────────────────────────────────────────┐
│ PROCEDURE Format_Num │
└────────────────────────────────────────────────────┘
}
PROCEDURE Format_Num (Number : longint; VAR NumStr : string);
BEGIN
STR(Number,NumStr);
IF (LENGTH (NumStr) > 6) THEN { Insert millions comma }
INSERT (',',NumStr,(LENGTH(NumStr) - 5));
IF (LENGTH (NumStr) > 3) THEN { Insert thousands comma }
INSERT (',',NumStr,(LENGTH(NumStr) - 2));
END;
{
┌────────────────────────────────────────────────────┐
│ PROCEDURE DisplayDir │
└────────────────────────────────────────────────────┘
}
PROCEDURE DisplayDir (DirP : str_type; DirN : str_type; Levl : integer;
NumSubsVar2 : integer; SubNumVar2 : integer;
NumSubsVar3 : integer;
NmbrFil : integer; FilLen : longint);
{NumSubsVar2 is the # of subdirs. in previous level;
NumSumsVar3 is the # of subdirs. in the current level.
DirN is the current subdir.; DirP is the previous path}
VAR
BegLine : string;
MidLine : string;
Blank : string;
WrtStr : string;
NumFil : string;
FilByte : string;
BEGIN
IF Levl > 5 THEN
BEGIN
BEEPIT;
WRITELN;
WRITELN ('CANNOT DISPLAY MORE THAN 5 LEVELS.');
WRITELN;
EXIT;
END;
Blank := ' '; { Init. variables }
BegLine := '';
MidLine := ' ──────────────────';
IF Levl = 0 THEN { Special handling for }
IF Dir = '' THEN { initial (0) dir. level }
IF Tree = False THEN
WrtStr := 'ROOT ──'
ELSE
WrtStr := 'ROOT'
ELSE
IF Tree = False THEN
begin
WrtStr := DirP + ' ──'
end
ELSE
WrtStr := DirP
ELSE
BEGIN { Level 1+ routines }
IF SubNumVar2 = NumSubsVar2 THEN { If last node in subtree, }
BEGIN { use └─ symbol & set flag }
BegLine := '└─'; { padded with blanks }
Flag[Levl] := ' ' + Blank;
END
ELSE { Otherwise, use ├─ symbol }
BEGIN { & set flag padded with }
BegLine := '├─'; { blanks }
Flag[Levl] := '│' + Blank;
END;
CASE Levl OF { Insert │ & blanks as }
1: BegLine := BegLine; { needed, based on level }
2: Begline := Flag[1] + BegLine;
3: Begline := Flag[1] + Flag[2] + BegLine;
4: Begline := Flag[1] + Flag[2] + Flag[3] + BegLine;
5: Begline := Flag[1] + Flag[2] + Flag[3] + Flag[4] + BegLine;
END; {end case}
IF Levl = 1 then
begin
WriteLn(f,'\',DirN);
If BytesBacked > TargetSize then
begin
Closeit;
BytesBacked :=0;
Openit
end;
end;
IF (NumSubsVar3 = 0) THEN { If cur. level has no }
WrtStr := BegLine + DirN { subdirs., leave end blank}
ELSE
IF Tree = False THEN
WrtStr := BegLine + DirN + COPY(Midline,1,(13-LENGTH(DirN))) + '─┬─'
ELSE
WrtStr := BegLine + DirN + COPY(Midline,1,(13-LENGTH(DirN))) + '─┐ ';
END; { End level 1+ routines }
Format_Num(NmbrFil,NumFil);
Format_Num(FilLen,FilByte);
IF ((Levl < 4) OR ((Levl = 4) AND (NumSubsVar3=0))) AND (Tree = False) THEN
WRITELN (WrtStr,'':(65 - LENGTH(WrtStr)),NumFil:3,FilByte:11)
ELSE
WRITELN (WrtStr); { Write # of files & bytes }
{ only if it fits, else }
END; { write only tree outline }
{
┌────────────────────────────────────────────────────┐
│ PROCEDURE ReadFiles │
└────────────────────────────────────────────────────┘
}
PROCEDURE ReadFiles (DirPrev : str_type; DirNext : str_type;
SubNumVar1 : integer; NumSubsVar1 : integer);
VAR
FileInfo : SearchRec;
FileBytes : longint;
NumFiles : integer;
NumSubs : integer;
Dir_Ptr : FPtr;
CurPtr : FPtr;
FirstPtr : FPtr;
BEGIN
FileBytes := 0;
Numfiles := 0;
NumSubs := 0;
Dir_Ptr := nil;
CurPtr := nil;
FirstPtr := nil;
IF Loop THEN FindFirst (DirPrev + DirNext + '\*.*', AnyFile, FileInfo);
Loop := False; { Get 1st file }
WHILE DosError = 0 DO { Loop until no more files }
BEGIN
IF (FileInfo.Name <> '.') AND (FileInfo.Name <> '..') THEN
BEGIN
IF (FileInfo.attr = directory) THEN { If fetched file is dir., }
BEGIN { store a record with dir. }
NEW (Dir_Ptr); { name & occurence number, }
Dir_Ptr^.DirName := FileInfo.name;{ and set links to }
INC (NumSubs); { other records if any }
Dir_Ptr^.DirNum := NumSubs;
IF CurPtr = nil THEN
BEGIN
Dir_Ptr^.Prev := nil;
Dir_Ptr^.Next := nil;
CurPtr := Dir_Ptr;
FirstPtr := Dir_Ptr;
END
ELSE
BEGIN
Dir_Ptr^.Prev := CurPtr;
Dir_Ptr^.Next := nil;
CurPtr^.Next := Dir_Ptr;
CurPtr := Dir_Ptr;
END;
END
ELSE
BEGIN { Tally # of bytes in file }
FileBytes := FileBytes + FileInfo.size;
INC(TotlBytes,FileInfo.size); { Add to total bytes, too }
INC(BytesBacked,FileInfo.Size);
INC(NumFiles); { Increment # of files, }
END; { excluding # of subdirs. }
END;
FindNext (FileInfo); { Get next file }
END; {end WHILE}
DisplayDir (DirPrev, DirNext, Level, NumSubsVar1, SubNumVar1, NumSubs,
NumFiles, FileBytes); { Pass info to & call }
INC (Level); { display routine, & inc. }
{ level number }
WHILE (FirstPtr <> nil) DO { If any subdirs., then }
BEGIN { recursively loop thru }
Loop := True; { ReadFiles proc. til done }
ReadFiles ((DirPrev + DirNext + '\'),FirstPtr^.DirName,
FirstPtr^.DirNum, NumSubs);
FirstPtr := FirstPtr^.Next;
END;
DEC (Level); { Decrement level when }
{ finish a recursive loop }
{ call to lower level of }
{ subdir. }
END;
{
┌────────────────────────────────────────────────────┐
│ PROCEDURE Read_Parm │
└────────────────────────────────────────────────────┘
}
PROCEDURE Read_Parm;
VAR
Cur_Dir : string;
Param : string;
i : integer;
BEGIN
IF ParamCount > 2 THEN
BEGIN
BEEPIT;
WRITELN ('Too many parameters -- only starting path and "SIZE"');
WRITELN ('option (/s or /S) is allowed.');
HALT;
END;
Param := '';
FOR i := 1 TO ParamCount DO { If either param. is a T, }
BEGIN { set Tree flag }
Param := ParamStr(i);
IF Param[1] = '/' THEN
CASE Param[2] OF
's','S': BEGIN
Val( copy(ParamStr(i),3,(length(paramStr(i))-2)),Targetsize,Code);
TargetSize := TargetSize *1000000;
IF ParamCount = 1 THEN EXIT;
END; { Exit if only one param }
ELSE
BEGIN
BEEPIT;
WRITELN ('Invalid parameter -- only /s or /S allowed.');
HALT;
END;
END; {case}
END;
GETDIR (0,Cur_Dir); { Save current dir }
FOR i := 1 TO ParamCount DO
BEGIN
Param := ParamStr(i); { Set var to param. string }
IF (POS ('/',Param) = 0) THEN
BEGIN
Dir := Param;
{$I-} CHDIR (Dir); { Try to change to input }
IF IOResult = 0 THEN { dir.; if it exists, go }
BEGIN { back to orig. dir. }
{$I+} CHDIR (Cur_Dir);
IF (POS ('\',Dir) = LENGTH (Dir)) THEN
DELETE (Dir,LENGTH(Dir),1); { Change root symbol back }
EXIT { to null, 'cause \ added }
END { in later }
ELSE
BEGIN
BEEPIT;
WRITELN ('No such directory -- please try again.');
HALT;
END;
END;
END;
END;
{
┌────────────────────────────────────────────────────┐
│ MAIN PROGRAM │
└────────────────────────────────────────────────────┘
}
VAR
Version : string;
BEGIN
TargetSize := 180000000; {should fit on one tape...}
BytesBacked := 0;
TotlBytes := 0;
Version := 'FSS Ver. 1.0a, 11-08-94'; { Sticks in EXE file }
Dir := ''; { Init. global vars. }
Loop := True;
Level := 0;
Tree := False;
OutFiles := 64;
ClrScr;
IF ParamCount > 0 THEN Read_Parm; { Deal with any params. }
If Length(Dir) < 2 then
begin
ClrScr;
WriteLn('You must enter the Drive: to be used - for example:');
WriteLn;
WriteLn('FSS c:');
Writeln;
WriteLn('In addition to the drive, you may specify an approximate');
Writeln('size limit for the saveset in millions of bytes - for example:');
WriteLn;
WriteLn('FSS D: /s40');
WriteLn;
WriteLn('would create as many FSS files as necessary to put about');
WriteLn('40,000,000 bytes per saveset.');
HALT(2)
end;
Openit;
ReadFiles (Dir,'',0,0); { Do main read routine }
DirChar := UpCase(Dir[1]);
Case DirChar of
'A'..'Z':DriveNum := Ord(DirChar)-64;
else
DriveNum := 0;
end;
WriteLn(' TOTAL BYTES used = ',TotlBytes);
Writeln(' BYTES FREE on drive ',Dir,' = ',DiskFree(DriveNum));
WriteLn(VERSION);
CloseIt;
END.