home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.update.uu.se
/
ftp.update.uu.se.2014.03.zip
/
ftp.update.uu.se
/
pub
/
rainbow
/
msdos
/
decus
/
RB120
/
treedupl.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-05-28
|
57KB
|
1,776 lines
PROGRAM TreeDuplicate; {008}
CONST
VersionIdentification = '2.0A';
(***********************************************************************
This software has been placed into the public domain by Digital
Equipment Corporation.
DISCLAIMER:
The information herein is subject to change without notice and should
not be construed as a commitment by Digital Equipment Corporation.
Digital Equipment Corporation assumes no responsibility for the use or
reliability of this software. This software is provided "as is,"
without any warranty of any kind, express or implied. Digital Equipment
Corporation will not be liable in any event for any damages including
any loss of data, profit, or savings, claims against the user by any
other party, or any other incidental or consequential damages arising
out of the use of, or inability to use, this software, even if Digital
Equipment Corporation is advised of the possibility of such damage.
DEFECT REPORTING AND SUGGESTIONS:
Please send reports of defects or suggestions for improvement directly
to the author:
Brian Hetrick
Digital Equipment Corporation
110 Spit Brook Road ZKO1-3/J10
Nashua NH 03062-2698
Do NOT file a Software Performance Report on this software, call the
Telephone Support Center regarding this software, contact your Digital
Field Office regarding this software, or use any other mechanism
provided for Digital's supported and warranted software.
FACILITY:
General user utilities
ABSTRACT:
Duplicates one directory tree into another, attempting not to copy{008}
data if possible. Intended for use as a backup utility using a DEC-
net-DOS virtual disk as the backup medium.
ENVIRONMENT:
MS-DOS compiled with Borland International's TURBO Pascal
AUTHOR: Brian Hetrick, CREATION DATE: 27 May 1986.
MODIFICATION HISTORY:
Brian Hetrick, 27-May-86: Version 1.0
000 - Original creation of module.
Released to Easynet 28-May-86.
Brian Hetrick, 30-May-86: Version 1.1
001 - Attributes on directories were not updated. Cause was that dir-
ectory modification date cannot be set, and IDAttrMatch routine
was testing modification date for directories. Main program
then attempted to replace the target directory, but ReplaceFile
simply returned. Fix is to have IDAttrMatch not look at mod-
ification dates for directories; main program now uses Match-
File to update the attributes.
002 - Included program name and version in banner.
Released to Easynet 30-May-86
Brian Hetrick, 31-May-86: Version 1.2
003 - Introduce hook for having files accumulate on target volume, to
match hook for event logging.
004 - Introduce procedure to check for MS-DOS error, instead of always
explicitly checking low bit of returned Flags register.
005 - Introduce function to form name from root directory, relative
directory, and file in relative directory, rather than always
building directly from volume letter, absolute directory, and
file in absolute directory, as a hook for later permitting root
to be any directory.
006 - Avoid exteraneous copy in ExpandDirectory.
007 - Use only ASCII in message text--replace MCS copyright symbol
with (c) as program may run on IBM PCs without MCS.
Not released to Easynet as no user-visible improvements.
Brian Hetrick, 03-Jun-86: Version 2.0
008 - Change name from VOLCOPY to TREEDUPL, as now will copy trees
rooted at other than the volume root directory.
009 - Use Bela Lubkin's public domain CommandLineArgument routine to
parse the command line.
010 - Deleted copyright notice as program will be submitted to DECUS
program library.
Released to Easynet on 3 June 1986.
Submitted to DECUS Program Library in September 1986.
Brian Hetrick, 03-Dec-86: Version 2.0A
011 - Discovered error day before verification master received from
DECUS Program Library. Error was command qualifiers were parsed
incorrectly if abbreviated.
***********************************************************************)
{.PA}
(*
* INCLUDE FILES:
*)
{$I CLA.PAS} {009}
(*
* LABEL DECLARATIONS:
*)
(*
* CONSTANT DECLARATIONS:
*)
CONST
DOSFunctionChangeAttributes = $43;
DOSFunctionCloseFile = $3E;
DOSFunctionCreateFile = $3C;
DOSFunctionCreateSubDirectory = $39;
DOSFunctionDeleteDirectoryEntry = $41;
DOSFunctionFindMatchFile = $4E;
DOSFunctionGetDTA = $2F;
DOSFunctionOpenFile = $3D;
DOSFunctionReadFromFile = $3F;
DOSFunctionRemoveDirectoryEntry = $3A;
DOSFunctionSetDTA = $1A;
DOSFunctionSetFileDateTime = $57;
DOSFunctionStepThroughDirectory = $4F;
DOSFunctionWriteToFile = $40;
CONST
DirectoryAttrMask = $10; { Attribute bit for directory }
DirectoryEntrySize = 5; { Base length of DirectoryEntry }
FileEntrySize = 20; { Base length of FileEntry }
FileSpecLength = 12; { Length of MS-DOS base name }
PathSpecLength = 127; { Length of MS-DOS path specification }
ReadOnlyAttrMask = $01; { Attribute bit for read-only }
(*
* TYPE DECLARATIONS:
*)
TYPE
FileSpec = STRING [FileSpecLength];
PathSpec = STRING [PathSpecLength];
DirectoryEntryPtr = ^ DirectoryEntry;
DirectoryEntry = RECORD
Next : DirectoryEntryPtr;
Name : PathSpec
END;
FileEntryPtr = ^ FileEntry;
FileEntry = RECORD
Next : FileEntryPtr;
Prev : FileEntryPtr;
Size : REAL;
Time : INTEGER;
Date : INTEGER;
Attr : BYTE;
Name : FileSpec
END;
FileEntryQueue = RECORD
Head : FileEntryPtr;
Tail : FileEntryPtr
END;
RegPack = RECORD
CASE INTEGER OF
0: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : INTEGER);
1: (AL, AH, BL, BH, CL, CH, DL, DH : BYTE)
END;
(*
* OWN STORAGE:
*)
VAR
Accumulating : BOOLEAN;
Logging : BOOLEAN;
SourceRoot : PathSpec;
TargetRoot : PathSpec;
(*
* TABLE OF CONTENTS:
*)
{.PA}
PROCEDURE ParseCommandLine; {009}
(***********************************************************************{009}
FUNCTIONAL DESCRIPTION: {009}
Parses the program command line. {009}
FORMAL PARAMETERS: {009}
None. {009}
RETURN VALUE: {009}
None. {009}
IMPLICIT INPUTS: {009}
None. {009}
IMPLICIT OUTPUTS: {009}
Accumulating - The BOOLEAN telling whether files on the target are{009}
to be retained if they are not on the source. {009}
Logging - The BOOLEAN telling whether messages informing the user of{009}
actions taken are to be written to the standard output. {009}
SourceRoot - The root directory of the source directory tree. {009}
TargetRoot - The root directory of the target directory tree. {009}
SIDE EFFECTS:
Will Halt the program if an error in the command line is discovered.{009}
***********************************************************************){009}
VAR {009}
CharIndex : INTEGER; {009}
CommandValid : BOOLEAN; {009}
SwitchSense : BOOLEAN; {009}
SwitchText : BigString; {009}
FUNCTION IsPrefix (Str1 : BigString; Str2 : BigString) : BOOLEAN; {009}
VAR {009}
CharIndex : INTEGER; {009}
BEGIN {009}
IF Length (Str1) > Length (Str2) {009}
THEN {009}
IsPrefix := FALSE {009}
ELSE {009}
IsPrefix := Str1 = Copy (Str2, 1, Length (Str1)) {011}
END; {009}
PROCEDURE UpCaseString (VAR Str : PathSpec); {009}
VAR {009}
CharIndex : INTEGER; {009}
BEGIN {009}
FOR CharIndex := 1 TO Length (Str) {009}
DO {009}
Str [CharIndex] := UpCase (Str [CharIndex]) {009}
END; {009}
BEGIN {009}
(* {009}
* Get source and destination roots {009}
*) {009}
SourceRoot := CommandLineArgument {009}
('Source directory: ', '/', FALSE); {009}
UpCaseString (SourceRoot); {009}
TargetRoot := CommandLineArgument {009}
('Destination directory: ', '/', FALSE); {009}
UpCaseString (TargetRoot); {009}
(* {009}
* Set defaults {009}
*) {009}
Accumulating := TRUE; {009}
Logging := TRUE; {009}
(* {009}
* Process switches {009}
*) {009}
CommandValid := TRUE; {009}
SwitchText := CommandLineArgument ('', '', TRUE); {009}
WHILE CommandValid AND (Length (SwitchText) > 0) {009}
DO {009}
BEGIN {009}
UpCaseString (SwitchText); {009}
(* {009}
* Get rid of the leading slash {009}
*) {009}
Delete (SwitchText, 1, 1); {009}
IF Length (SwitchText) = 0 {009}
THEN {009}
BEGIN {009}
WriteLn ('Invalid switch: "/"'); {009}
CommandValid := FALSE; {009}
END; {009}
IF CommandValid {009}
THEN {009}
(* {009}
* Check for "NO" prefix {009}
*) {009}
IF Copy (SwitchText, 1, 2) = 'NO' {009}
THEN {009}
BEGIN {009}
SwitchSense := FALSE; {009}
Delete (SwitchText, 1, 2); {009}
IF Length (SwitchText) = 0 {009}
THEN {009}
BEGIN {009}
WriteLn ('Invalid switch: "/NO"'); {009}
CommandValid := FALSE {009}
END {009}
END {009}
ELSE {009}
SwitchSense := TRUE; {009}
IF CommandValid {009}
THEN {009}
BEGIN {009}
(* {009}
* Check for switch names {009}
*) {009}
IF IsPrefix (SwitchText, 'LOG') {009}
THEN {009}
Logging := SwitchSense {009}
ELSE IF IsPrefix (SwitchText, 'ACCUMULATE') {009}
THEN {009}
Accumulating := SwitchSense {009}
ELSE {009}
BEGIN {009}
Write ('Invalid switch: "/'); {009}
IF SwitchSense = FALSE {009}
THEN {009}
Write ('NO'); {009}
WriteLn (SwitchText, '"'); {009}
CommandValid := FALSE {009}
END {009}
END; {009}
IF CommandValid {009}
THEN {009}
SwitchText := CommandLineArgument ('', '', TRUE) {009}
END; {009}
IF NOT CommandValid {009}
THEN {009}
Halt {009}
END; {009}
{.PA}
FUNCTION ErrorReturn {004}
( Registers : RegPack) : BOOLEAN; {004}
(***********************************************************************{004}
FUNCTIONAL DESCRIPTION: {004}
Checks a set of registers returned from the MsDos procedure and de-{004}
termines whether the function completed successfully. {004}
FORMAL PARAMETERS: {004}
Registers - A RegPack expression giving the register values returned{004}
by the MsDos procedure. {004}
RETURN VALUE: {004}
TRUE - The MsDos function failed. {004}
FALSE - The MsDos function succeeded. {004}
IMPLICIT INPUTS: {004}
None. {004}
IMPLICIT OUTPUTS: {004}
None. {004}
SIDE EFFECTS: {004}
None. {004}
***********************************************************************){004}
BEGIN {004}
ErrorReturn := (Registers . Flags AND 1) <> 0 {004}
END; {004}
{.PA}
FUNCTION ConstructFileName {005}
( RootDirectory : PathSpec; {005}
RelativeDirectory : PathSpec; {005}
FileName : FileSpec) : PathSpec; {005}
(***********************************************************************{005}
FUNCTIONAL DESCRIPTION: {005}
Constructs a path specification from a root directory, a relative{005}
directory, and file name by concatenating these elements, separating{005}
them by backslash if there is not already a separator. {005}
FORMAL PARAMETERS: {005}
RootDirectory - A PathSpec expression giving the root directory of{005}
the eventual path specification. {005}
RelativeDirectory - A PathSpec expression giving the directory{005}
relative to RootDirectory of the eventual path specification. {005}
FileName - A FileSpec expression giving the file name of the even-{005}
tual path specification. {005}
RETURN VALUE: {005}
The resultant path specification. {005}
IMPLICIT INPUTS: {005}
None. {005}
IMPLICIT OUTPUTS: {005}
None. {005}
SIDE EFFECTS: {005}
None. {005}
***********************************************************************){005}
CONST {005}
Separator : SET OF CHAR = [':', '\', '/']; {005}
VAR {005}
TempName : PathSpec; {005}
BEGIN {005}
TempName := RootDirectory; {005}
IF (Length (TempName) > 0) AND (Length (RelativeDirectory) > 0) {005}
THEN {005}
IF NOT (TempName [Length (TempName)] IN Separator) {005}
THEN {005}
Insert ('\', TempName, Length (TempName) + 1); {005}
Insert (RelativeDirectory, TempName, Length (TempName) + 1); {005}
IF (Length (TempName) > 0) AND (Length (FileName) > 0) {005}
THEN {005}
IF NOT (TempName [Length (TempName)] IN Separator) {005}
THEN {005}
Insert ('\', TempName, Length (TempName) + 1); {005}
Insert (FileName, TempName, Length (TempName) + 1); {005}
ConstructFileName := TempName {005}
END; {005}
{.PA}
PROCEDURE ExpandDirectory
( RootDirectory : PathSpec; {005}
DirectoryToExpand : DirectoryEntryPtr;
VAR FileQueue : FileEntryQueue);
(***********************************************************************
FUNCTIONAL DESCRIPTION:
Finds and lexicographically sorts the names of all files in a di-
rectory
FORMAL PARAMETERS:
RootDirectory - A PathSpec expression giving the root directory to{005}
which DirectoryName is a relative directory. {005}
DirectoryName - A DirectoryEntryPtr expression pointing to the Di-
recoryEntry describing the directory to be examined
FileQueue - A FileEntryQueue object which is modified to point to a
newly created queue of the names of files in the directory
RETURN VALUE:
None.
IMPLICIT INPUTS:
None.
IMPLICIT OUTPUTS:
None.
SIDE EFFECTS:
Modifies and resets the DTA. This should be observable only by in-
terrupt routines.
Dynamically allocates storage with GetMem.
***********************************************************************)
VAR
FoundPos : BOOLEAN;
FileNameLength : INTEGER;
FileName : FileSpec;
MSDOSBlock : RECORD
Reserved : ARRAY [1..21] OF BYTE;
Attribute : BYTE;
Time : INTEGER;
Date : INTEGER;
SizeLow : INTEGER;
SizeHigh : INTEGER;
Name : ARRAY [1..13] OF CHAR
END;
NextFile : FileEntryPtr;
OldDTA : ^ CHAR;
PrevFile : FileEntryPtr;
Registers : RegPack;
SearchSpec : PathSpec;
ThisFile : FileEntryPtr;
BEGIN
(*
* Initialize the file queue
*)
FileQueue . Head := NIL;
FileQueue . Tail := NIL;
(*
* Save the old DTA
*)
Registers.AH := DOSFunctionGetDTA;
MsDos (Registers);
OldDTA := Ptr (Registers.ES, Registers.BX);
(*
* Set the DTA to be the MS-DOS information block
*)
Registers.AH := DOSFunctionSetDTA;
Registers.DS := Seg (MSDOSBlock);
Registers.DX := Ofs (MSDOSBlock);
MsDos (Registers);
(*
* Find the contents of the directory
*)
SearchSpec := ConstructFileName (RootDirectory, {005}
DirectoryToExpand ^. Name, '*.*'); {005}
SearchSpec [Length (SearchSpec) + 1] := #$00; {005}
Registers.AH := DOSFunctionFindMatchFile;
Registers.DS := Seg (SearchSpec [1]);
Registers.DX := Ofs (SearchSpec [1]);
Registers.CX := $37;
MsDos (Registers);
WHILE NOT ErrorReturn (Registers) {004}
DO
BEGIN
(*
* Extract the file name
*)
FileNameLength := 1;
WHILE MSDOSBlock . Name [FileNameLength] <> #$00
DO
FileNameLength := FileNameLength + 1;
FileNameLength := FileNameLength - 1;
FileName := Copy (MSDOSBlock . Name, 1, FileNameLength);
(*
* Ignore relative directories
*)
IF (FileName <> '.') AND (FileName <> '..')
THEN
BEGIN
(*
* Create a file entry for this file
*)
GetMem (ThisFile, FileEntrySize + FileNameLength);
ThisFile ^. Attr := MSDOSBlock . Attribute;
ThisFile ^. Time := MSDOSBlock . Time;
ThisFile ^. Date := MSDOSBlock . Date;
IF MSDOSBlock . SizeHigh < 0
THEN
ThisFile ^. Size := MSDOSBlock . SizeHigh + 65536.0
ELSE
ThisFile ^. Size := MSDOSBlock . SizeHigh;
ThisFile ^. Size := ThisFile ^. Size * 65536.0;
IF MSDOSBlock . SizeLow < 0
THEN
ThisFile ^. Size := ThisFile ^. Size +
MSDOSBlock . SizeLow + 65536.0
ELSE
ThisFile ^. Size := ThisFile ^. Size +
MSDOSBlock . SizeLow;
ThisFile ^. Name := FileName; {006}
(*
* Insert the newly allocated entry into the sorted queue
*)
NextFile := FileQueue . Head;
PrevFile := NIL;
FoundPos := FALSE;
WHILE NOT FoundPos
DO
BEGIN
IF NextFile = NIL
THEN
FoundPos := TRUE
ELSE
IF NextFile ^. Name > ThisFile ^. Name
THEN
FoundPos := TRUE
ELSE
BEGIN
PrevFile := NextFile;
NextFile := NextFile ^. Next
END
END;
ThisFile ^. Prev := PrevFile;
IF PrevFile = NIL
THEN
FileQueue . Head := ThisFile
ELSE
PrevFile ^. Next := ThisFile;
ThisFile ^. Next := NextFile;
IF NextFile = NIL
THEN
FileQueue . Tail := ThisFile
ELSE
NextFile ^. Prev := ThisFile
END;
(*
* Get the next file in the directory
*)
Registers.AH := DOSFunctionStepThroughDirectory;
MsDos (Registers)
END;
(*
* The directory has been expanded. Reset the DTA
*)
Registers.AH := DOSFunctionSetDTA;
Registers.DS := Seg (OldDTA ^);
Registers.DX := Ofs (OldDTA ^);
MsDos (Registers)
END;
{.PA}
PROCEDURE ExtractDirectories
( CurrentDirectory : DirectoryEntryPtr;
FileQueue : FileEntryQueue;
VAR DirectoryList : DirectoryEntryPtr);
(***********************************************************************
FUNCTIONAL DESCRIPTION:
Examines the contents of the current directory, extracts the full
path names of all subdirectories, and places these subdirectory
names on a queue of pending directories.
FORMAL PARAMETERS:
CurrentDirectory - A DirectoryEntryPtr pointing to a DirectoryEntry
describing the directory whose contents are given by FileQueue.
FileQueue - A FileEntryQueue pointing to a list of FileEntry objects
describing the files in the directory described by Current-
Directory.
DirectoryList - A DirectoryEntryPtr pointing to a list of Directory-
Entry objects. New DirectoryEntry objects are created for the
subdirectories found on the list of FileEntry objects pointed to
by FileQueue, and are placed onto this list.
RETURN VALUE:
None.
IMPLICIT INPUTS:
None.
IMPLICIT OUTPUTS:
None.
SIDE EFFECTS:
Dynamically allocates storage with GetMem.
***********************************************************************)
VAR
DirectoryText : PathSpec;
ThisDirectory : DirectoryEntryPtr;
ThisEntry : FileEntryPtr;
BEGIN
(*
* Scan list backwards, looking for directories
*)
ThisEntry := FileQueue . Tail;
WHILE ThisEntry <> NIL
DO
BEGIN
IF (ThisEntry ^. Attr AND DirectoryAttrMask) <> 0
THEN
BEGIN
(*
* This entry is a directory.
*)
DirectoryText := {005}
ConstructFileName (CurrentDirectory ^. Name, {005}
ThisEntry ^. Name, ''); {005}
GetMem (ThisDirectory, DirectoryEntrySize +
Length (DirectoryText));
ThisDirectory ^. Next := DirectoryList;
ThisDirectory ^. Name := DirectoryText;
DirectoryList := ThisDirectory
END;
ThisEntry := ThisEntry ^. Prev
END
END;
{.PA}
PROCEDURE AdvanceFile
(VAR FileQueue : FileEntryQueue);
(***********************************************************************
FUNCTIONAL DESCRIPTION:
Deletes the first item on a file entry queue.
FORMAL PARAMETERS:
FileQueue - A FileEntryQueue object pointing to a queue of FileEntry
objects. The item pointed at by the Head pointer is deleted,
and the queue is adjusted for this deletion.
RETURN VALUE:
None.
IMPLICIT INPUTS:
None.
IMPLICIT OUTPUTS:
None.
SIDE EFFECTS:
Dynamically frees storage with FreeMem.
***********************************************************************)
VAR
ThisEntry : FileEntryPtr;
BEGIN
(*
* Ensure that there is an item to delete
*)
ThisEntry := FileQueue . Head;
IF ThisEntry <> NIL
THEN
BEGIN
(*
* There is. First, relink the queue around the item
*)
FileQueue . Head := ThisEntry ^. Next;
IF FileQueue . Head = NIL
THEN
FileQueue . Tail := NIL
ELSE
FileQueue . Head ^. Prev := NIL;
(*
* Now free the item's storage
*)
FreeMem (ThisEntry, FileEntrySize + Length (ThisEntry ^. Name))
END
END;
{.PA}
FUNCTION IDAttrMatch
( FileEntry1 : FileEntryPtr;
FileEntry2 : FileEntryPtr) : BOOLEAN;
(***********************************************************************
FUNCTIONAL DESCRIPTION:
Determine whether two files are putatively identical.
Two files are considered to be identical if they have the same name,
same directory attribute, and, in the case of non-directory files,{001}
the same creation/modification date and time and size. NO COM-{001}
PARISON OF THE FILE CONTENTS IS MADE.
FORMAL PARAMETERS:
File1Desc - A FileEntryPtr pointing to a FileEntry object describing
the first of the two files.
File2Desc - A FileEntryPtr pointing to a FileEntry object describing
the second of the two files.
RETURN VALUE:
TRUE - The files are considered to be identical.
FALSE - The files are not considered to be identical.
IMPLICIT INPUTS:
None.
IMPLICIT OUTPUTS:
None.
SIDE EFFECTS:
None.
***********************************************************************)
VAR
Difference : BOOLEAN;
BEGIN
Difference := FALSE;
IF FileEntry1 ^. Name <> FileEntry2 ^. Name
THEN
Difference := TRUE;
IF (FileEntry1 ^. Attr AND DirectoryAttrMask) <>
(FileEntry2 ^. Attr AND DirectoryAttrMask)
THEN
Difference := TRUE;
IF (FileEntry1 ^. Attr AND DirectoryAttrMask) = 0 {001}
THEN {001}
BEGIN {001}
IF FileEntry1 ^. Time <> FileEntry2 ^. Time
THEN
Difference := TRUE;
IF FileEntry1 ^. Date <> FileEntry2 ^. Date
THEN
Difference := TRUE;
IF FileEntry1 ^. Size <> FileEntry2 ^. Size
THEN
Difference := TRUE {001}
END; {001}
IDAttrMatch := NOT Difference
END;
{.PA}
PROCEDURE DeleteFile
( RootDirectory : PathSpec; {005}
CurrentDirectory : DirectoryEntryPtr;
FileInfo : FileEntryPtr);
(***********************************************************************
FUNCTIONAL DESCRIPTION:
Deletes a single file or an entire subdirectory tree. When deleting
an entire subdirectory tree, recurses to the depth of the subdirect-
ory tree.
FORMAL PARAMETERS:
RootDirectory - A PathSpec expression giving the root directory to{005}
which DirectoryName is a relative directory. {005}
CurrentDirectory - A DirectoryEntryPtr expression pointing to a Di-
rectoryEntry object describing the directory in which the file
resides.
FileInformation - A FileEntryPtr expression pointing to a FileEntry
object describing the file to be deleted.
RETURN VALUE:
None.
IMPLICIT INPUTS:
Logging - The BOOLEAN telling whether event logging is currently on.
IMPLICIT OUTPUTS:
None.
SIDE EFFECTS:
None.
***********************************************************************)
VAR
NewDirEntry : DirectoryEntry;
Registers : RegPack;
SubDirQueue : FileEntryQueue;
(*
* A DirectoryEntry is used in place of a PathSpec for the name of
* the single file to be deleted, in order to minimize local stor-
* age requirements. This is important only as this routine is
* recursive.
*)
BEGIN
(*
* If the "file" to be deleted is a directory, delete the entire
* tree rooted there
*)
IF (FileInfo ^. Attr AND DirectoryAttrMask) <> 0
THEN
BEGIN
(*
* Construct a directory entry for the directory
*)
NewDirEntry . Name := {005}
ConstructFileName (CurrentDirectory ^. Name, {005}
FileInfo ^. Name, ''); {005}
(*
* Get contents of directory
*)
ExpandDirectory (RootDirectory, Addr (NewDirEntry), {005}
SubDirQueue);
(*
* Recursively delete the contents of the directory
*)
WHILE SubDirQueue . Head <> NIL
DO
BEGIN
DeleteFile (RootDirectory, Addr (NewDirEntry), {005}
SubDirQueue . Head);
AdvanceFile (SubDirQueue)
END
END;
(*
* Generate the file specification
*)
NewDirEntry . Name := ConstructFileName (RootDirectory, {005}
CurrentDirectory ^. Name, FileInfo ^. Name); {005}
(*
* Put on the trailing NUL for MS-DOS calls
*)
NewDirEntry . Name [Length (NewDirEntry . Name) + 1] := #$00;
(*
* The Read-Only attribute implies that the file cannot be
* deleted. If the Read-Only attribute is on, turn it off.
*)
IF (FileInfo ^. Attr AND ReadOnlyAttrMask) <> 0
THEN
BEGIN
Registers . AH := DOSFunctionChangeAttributes;
Registers . DS := Seg (NewDirEntry . Name [1]);
Registers . DX := Ofs (NewDirEntry . Name [1]);
Registers . CX := FileInfo ^. Attr AND NOT {001}
(ReadOnlyAttrMask OR DirectoryAttrMask); {001}
Registers . AL := 1;
MsDos (Registers);
IF ErrorReturn (Registers) {004}
THEN
BEGIN
WriteLn ('Cannot change attributes on ', NewDirEntry . Name);
Halt
END
END;
(*
* Actually delete the file
*)
IF (FileInfo ^. Attr AND DirectoryAttrMask) <> 0
THEN
Registers . AH := DOSFunctionRemoveDirectoryEntry
ELSE
Registers . AH := DOSFunctionDeleteDirectoryEntry;
Registers . DS := Seg (NewDirEntry . Name [1]);
Registers . DX := Ofs (NewDirEntry . Name [1]);
MsDos (Registers);
IF ErrorReturn (Registers) {004}
THEN
BEGIN
Write ('Cannot delete ');
IF (FileInfo ^. Attr AND DirectoryAttrMask) <> 0
THEN
Write ('directory ');
WriteLn (NewDirEntry . Name);
Halt
END;
(*
* If logging is on, note the deletion
*)
IF Logging
THEN
WriteLn ('Deleted ', NewDirEntry . Name)
END;
{.PA}
PROCEDURE CopyFile
( SourceRootDir : PathSpec; {005}
CurrentDirectory : DirectoryEntryPtr;
FileInfo : FileEntryPtr;
DestinRootDir : PathSpec); {005}
(***********************************************************************
FUNCTIONAL DESCRIPTION:
Duplicates the source file on the destination. This duplication al-{005}
ways includes relative directory and file name, and file attributes.{005}
In the case of non-directory files, this also includes modification{005}
date and time, and contents. {005}
FORMAL PARAMETERS:
SourceRootDirectory - A PathSpec expression giving the root direct-{005}
ory to which DirectoryName is a relative directory for the{005}
source file. {005}
CurrentDirectory - A DirectoryEntryPtr pointing to a DirectoryEntry
object describing the directory in which the source file resides
and in which the target file is to reside.
FileInfo - A FileEntryPtr pointing to a FileEntry object describing
the source file, and which is to describe the target file.
TargetRootDirectory - A PathSpec expression giving the root direct-{005}
ory to which DirectoryName is a relative directory for the tar-{005}
get file. {005}
RETURN VALUE:
None.
IMPLICIT INPUTS:
Logging - The BOOLEAN telling whether event logging is currently on.
IMPLICIT OUTPUTS:
None.
SIDE EFFECTS:
None.
***********************************************************************)
CONST
BufferSize = 1024;
VAR
CopyBuffer : ARRAY [1..BufferSize] OF CHAR;
DestinHandle : INTEGER;
DestinName : PathSpec;
Registers : RegPack;
SourceHandle : INTEGER;
SourceName : PathSpec;
TransferSize : INTEGER;
BEGIN
(*
* Construct the source and destination file names
*)
SourceName := ConstructFileName (SourceRootDir, {005}
CurrentDirectory ^. Name, FileInfo ^. Name); {005}
DestinName := ConstructFileName (DestinRootDir, {005}
CurrentDirectory ^. Name, FileInfo ^. Name); {005}
SourceName [Length (SourceName) + 1] := #$00;
DestinName [Length (DestinName) + 1] := #$00;
(*
* Now copy the files
*)
IF (FileInfo ^. Attr AND DirectoryAttrMask) <> 0
THEN
BEGIN
(*
* For a directory, simply create the target directory
*)
Registers . AH := DOSFunctionCreateSubDirectory;
Registers . DS := Seg (DestinName [1]);
Registers . DX := Ofs (DestinName [1]);
MsDos (Registers);
IF ErrorReturn (Registers) {004}
THEN
BEGIN
WriteLn ('Cannot create directory ', DestinName);
Halt
END
END
ELSE
BEGIN
(*
* For a file, copy the data and set the creation date and time
*)
Registers . AH := DOSFunctionOpenFile;
Registers . AL := 0;
Registers . DS := Seg (SourceName [1]);
Registers . DX := Ofs (SourceName [1]);
MsDos (Registers);
IF ErrorReturn (Registers) {004}
THEN
BEGIN
WriteLn ('Cannot open ', SourceName);
Halt
END;
SourceHandle := Registers . AX;
Registers . AH := DOSFunctionCreateFile;
Registers . CX := 0;
Registers . DS := Seg (DestinName [1]);
Registers . DX := Ofs (DestinName [1]);
MsDos (Registers);
IF ErrorReturn (Registers) {004}
THEN
BEGIN
WriteLn ('Cannot create ', DestinName);
Halt
END;
DestinHandle := Registers . AX;
Registers . AH := DOSFunctionReadFromFile;
Registers . BX := SourceHandle;
Registers . CX := BufferSize;
Registers . DS := Seg (CopyBuffer);
Registers . DX := Ofs (CopyBuffer);
MsDos (Registers);
IF ErrorReturn (Registers) {004}
THEN
BEGIN
WriteLn ('Cannot read ', SourceName);
Halt
END;
TransferSize := Registers . AX;
WHILE TransferSize > 0
DO
BEGIN
Registers . AH := DOSFunctionWriteToFile;
Registers . BX := DestinHandle;
Registers . CX := TransferSize;
Registers . DS := Seg (CopyBuffer);
Registers . DX := Ofs (CopyBuffer);
MsDos (Registers);
IF ErrorReturn (Registers) OR {004}
(TransferSize <> Registers . AX)
THEN
BEGIN
WriteLn ('Cannot write ', DestinName);
Halt
END;
Registers . AH := DOSFunctionReadFromFile;
Registers . BX := SourceHandle;
Registers . CX := BufferSize;
Registers . DS := Seg (CopyBuffer);
Registers . DX := Ofs (CopyBuffer);
MsDos (Registers);
IF ErrorReturn (Registers) {004}
THEN
BEGIN
WriteLn ('Cannot read ', SourceName);
Halt
END;
TransferSize := Registers . AX
END;
(*
* The data have been copied. Set the creation date and time
* to be that of the source file.
*)
Registers . AH := DOSFunctionSetFileDateTime;
Registers . AL := 1;
Registers . BX := DestinHandle;
Registers . CX := FileInfo ^. Time;
Registers . DX := FileInfo ^. Date;
MsDos (Registers);
IF ErrorReturn (Registers) {004}
THEN
BEGIN
WriteLn ('Cannot set date and time on ', DestinName);
Halt
END;
(*
* Close the source and destination files
*)
Registers . AH := DOSFunctionCloseFile;
Registers . BX := SourceHandle;
MsDos (Registers);
IF ErrorReturn (Registers) {004}
THEN
BEGIN
WriteLn ('Cannot close ', SourceName);
Halt
END;
Registers . AH := DOSFunctionCloseFile;
Registers . BX := DestinHandle;
MsDos (Registers);
IF ErrorReturn (Registers) {004}
THEN
BEGIN
WriteLn ('Cannot close ', DestinName);
Halt
END
END;
(*
* Ensure that the source and target attributes match
*)
IF (FileInfo ^. Attr AND NOT DirectoryAttrMask) <> 0
THEN
BEGIN
Registers . AH := DOSFunctionChangeAttributes;
Registers . AL := 1;
Registers . DS := Seg (DestinName [1]);
Registers . DX := Ofs (DestinName [1]);
Registers . CX := FileInfo ^. Attr;
MsDos (Registers);
IF ErrorReturn (Registers) {004}
THEN
BEGIN
WriteLn ('Cannot set attributes for ', DestinName);
Halt
END
END;
(*
* If necessary, log the copying
*)
IF Logging
THEN
IF (FileInfo ^. Attr AND DirectoryAttrMask) <> 0
THEN
WriteLn ('Created directory ', DestinName)
ELSE
WriteLn ('Copied ', SourceName, ' to ', DestinName)
END;
{.PA}
PROCEDURE ReplaceFile
( SourceRootDir : PathSpec; {005}
CurrentDirectory : DirectoryEntryPtr;
SourceFile : FileEntryPtr;
DestinRootDir : PathSpec; {005}
DestinFile : FileEntryPtr);
(***********************************************************************
FUNCTIONAL DESCRIPTION:
Replaces a file on the destination drive with one of the same path
specification from the source drive.
FORMAL PARAMETERS:
SourceRootDirectory - A PathSpec expression giving the root direct-{005}
ory to which DirectoryName is a relative directory for the{005}
source file. {005}
CurrentDirectory - A DirectoryEntryPtr expression pointing to a
DirectoryEntry object describing the directory in which the
source and destination files are found.
SourceFile - A FileEntryPtr expression pointing to a FileEntry
object describing the source file.
TargetRootDirectory - A PathSpec expression giving the root direct-{005}
ory to which DirectoryName is a relative directory for the tar-{005}
get file. {005}
DestinationFile - A FileEntryPtr expression pointing to a FileEntry
object describing the destination file.
RETURN VALUE:
None.
IMPLICIT INPUTS:
None.
IMPLICIT OUTPUTS:
None.
SIDE EFFECTS:
None.
***********************************************************************)
BEGIN
(*
* For directories, nothing need be done
*)
IF ((SourceFile ^. Attr AND DirectoryAttrMask) = 0) OR
((DestinFile ^. Attr AND DirectoryAttrMask) = 0)
THEN
BEGIN
(*
* At least one is a file. Delete the existing thing, and copy
* the new thing
*)
DeleteFile (DestinRootDir, CurrentDirectory, DestinFile); {005}
CopyFile (SourceRootDir, CurrentDirectory, SourceFile, {005}
DestinRootDir) {005}
END
END;
{.PA}
PROCEDURE MatchFile
( SourceRootDir : PathSpec; {005}
CurrentDirectory : DirectoryEntryPtr;
SourceFile : FileEntryPtr;
DestinRootDir : PathSpec; {005}
DestinFile : FileEntryPtr);
(***********************************************************************
FUNCTIONAL DESCRIPTION:
Modifies the non-directory attributes of a destination file to dup-
licate those of a source file.
FORMAL PARAMETERS:
SourceRootDirectory - A PathSpec expression giving the root direct-{005}
ory to which DirectoryName is a relative directory for the{005}
source file. {005}
CurrentDirectory - A DirectoryEntryPtr expression pointing to a Dir-
ectoryEntry object describing the directory in which the destin-
ation file is to be found.
SourceFile - A FileEntryPtr expression pointing to a FileEntry ob-
ject describing the source file.
TargetRootDirectory - A PathSpec expression giving the root direct-{005}
ory to which DirectoryName is a relative directory for the tar-{005}
get file. {005}
DestinationFile - A FileEntryPtr expression pointing to a FileEntry
object describing the destination file.
RETURN VALUE:
None.
IMPLICIT INPUTS:
Logging - The BOOLEAN telling whether event logging is currently on.
IMPLICIT OUTPUTS:
None.
SIDE EFFECTS:
None.
***********************************************************************)
VAR
DestinName : PathSpec;
Registers : RegPack;
BEGIN
(*
* Ensure the attributes match
*)
IF SourceFile ^. Attr <> DestinFile ^. Attr
THEN
BEGIN
(*
* Copy attributes from the source to the destination
*)
DestinName := ConstructFileName (TargetRoot, {005}
CurrentDirectory ^. Name, DestinFile ^. Name); {005}
DestinName [Length (DestinName) + 1] := #$00;
Registers . AH := DOSFunctionChangeAttributes;
Registers . AL := 1;
Registers . DS := Seg (DestinName [1]);
Registers . DX := Ofs (DestinName [1]);
Registers . CX := SourceFile ^. Attr AND NOT DirectoryAttrMask; {001}
MsDos (Registers);
IF ErrorReturn (Registers) {004}
THEN
BEGIN
WriteLn ('Cannot change attributes on ', DestinName);
Halt
END;
(*
* If logging, note the change
*)
IF Logging
THEN
WriteLn ('Modified attributes of ', DestinName)
END
END;
{.PA}
(***********************************************************************
FUNCTIONAL DESCRIPTION:
Modifies a target volume to duplicate as closely as possible a
source volume.
COMMAND LINE:
<SourceRoot> <TargetRoot> [/[NO]LOG] [/[NO]ACCUMULATE] {009}
RETURN VALUE:
None.
IMPLICIT INPUTS:
SourceRoot - The root directory of the source directory tree. {009}
TargetRoot - The root directory of the target directory tree. {009}
Accumulating - The BOOLEAN telling whether files on the target are{009}
to be retained if they are not on the source. {009}
IMPLICIT OUTPUTS:
None.
SIDE EFFECTS:
None.
***********************************************************************)
VAR
CurrentDirectory : DirectoryEntryPtr;
DestinDirectory : FileEntryQueue;
PendingDirectories : DirectoryEntryPtr;
SourceDirectory : FileEntryQueue;
BEGIN
(*
* Print the copyright notice
*)
WriteLn ('TREEDUPL version ', VersionIdentification); {008,002}
WriteLn;
(* {009}
* Parse the command line {009}
*) {009}
ParseCommandLine; {009}
(*
* Initialize the directory needing duplication to be the root
*)
GetMem (PendingDirectories, DirectoryEntrySize); {005}
PendingDirectories ^. Next := NIL;
PendingDirectories ^. Name := ''; {005}
(*
* Copy the directories on the pending directory list
*)
WHILE PendingDirectories <> NIL
DO
BEGIN
CurrentDirectory := PendingDirectories;
PendingDirectories := PendingDirectories ^. Next;
(*
* Expand directories on the two volumes
*)
ExpandDirectory (SourceRoot, CurrentDirectory, SourceDirectory); {005}
ExpandDirectory (TargetRoot, CurrentDirectory, DestinDirectory); {005}
(*
* Extract the directories from the source listing
*)
ExtractDirectories (CurrentDirectory, SourceDirectory,
PendingDirectories);
(*
* Ensure that the contents of the source and destination direct-
* ories match
*)
WHILE (SourceDirectory . Head <> NIL) OR
(DestinDirectory . Head <> NIL)
DO
BEGIN
IF SourceDirectory . Head = NIL
THEN
BEGIN
(*
* The source directory has been exhausted before the
* destination directory. Delete the destination directory
* file if not accumulating files. {003}
*)
IF NOT Accumulating {003}
THEN {003}
DeleteFile (TargetRoot, CurrentDirectory, {005}
DestinDirectory . Head);
AdvanceFile (DestinDirectory)
END
ELSE IF DestinDirectory . Head = NIL
THEN
BEGIN
(*
* The destination directory has been exhausted before the
* source directory. Copy the file.
*)
CopyFile (SourceRoot, CurrentDirectory, {005}
SourceDirectory . Head, TargetRoot); {005}
AdvanceFile (SourceDirectory)
END
ELSE IF SourceDirectory . Head ^. Name <
DestinDirectory . Head ^. Name
THEN
BEGIN
(*
* The destination directory does not have a file of the
* same name as the file in the source directory. Copy the
* file.
*)
CopyFile (SourceRoot, CurrentDirectory, {005}
SourceDirectory . Head, TargetRoot); {005}
AdvanceFile (SourceDirectory)
END
ELSE IF SourceDirectory . Head ^. Name >
DestinDirectory . Head ^. Name
THEN
BEGIN
(*
* The destination directory has a file whose name is not
* in the source directory. Delete the destinatin file if{003}
* not accumulating files. {003}
*)
IF NOT Accumulating
THEN
DeleteFile (TargetRoot, CurrentDirectory, {005}
DestinDirectory . Head);
AdvanceFile (DestinDirectory)
END
ELSE IF NOT IDAttrMatch (SourceDirectory . Head,
DestinDirectory . Head)
THEN
BEGIN
(*
* The source and destination directories have files of the
* same name, but the identity attributes do not match.
* Delete the file in the destination directory, and copy
* the file from the source directory.
*)
ReplaceFile (SourceRoot, CurrentDirectory, {005}
SourceDirectory . Head, TargetRoot, {005}
DestinDirectory . Head);
AdvanceFile (SourceDirectory);
AdvanceFile (DestinDirectory)
END
ELSE
BEGIN
(*
* The source and destination directories have files of the
* same name and the identity attributes match. Make the
* MS-DOS file attributes match.
*)
MatchFile (SourceRoot, CurrentDirectory, {005}
SourceDirectory . Head, TargetRoot, {005}
DestinDirectory . Head);
AdvanceFile (SourceDirectory);
AdvanceFile (DestinDirectory)
END
END;
(*
* The current directory has been handled.
*)
FreeMem (CurrentDirectory, DirectoryEntrySize +
Length (CurrentDirectory ^. Name));
END
END.
