Dokan虚拟磁盘开发实战

 因工作需要，最近与同事合作使用Dokan开发了一个虚拟磁盘的简单程序，初步实现了远程目录映射到本地虚拟磁盘的功能。

    远程服务端是用Python写的，主要是将远程主机上的目录文件传给客戶端，在这里就不细说了。

    Dokan客户端则由Delphi开发，其参考代码来自网络上的Delphi例子，比如Mirror Driver。

    本篇文章主要是Dokan开发过程的一些总结，所以不会对Dokan本身做介绍，与Dokan有关的资料及代码，请到google里搜索，或到Dokan的官方网站去下载(Dokan官网)，源码是C语言的，应用例子有Ruby、.Net及C的。如果想要Delphi的例子代码，只能自己去找了。

    刚开始时由于不清楚如何用Dokan来实现一个文件系统，所以需要做一些试验，结果一不小心就蓝屏了！悲剧啊，用XP系统已经好多年没遇到蓝屏了。几次蓝屏之后，终于受不了了，于是在VMWare里装了个虚拟机的XP，这下不怕蓝屏了，哈哈。强烈建议装个虚拟机来玩Dokan，否则刚开始的时候你会蓝屏Ｎ次！

    为简单起见，我做的Dokan虚拟磁盘采用将远程目录缓存到本地目录的方法来实现，这样就不用自己维护一堆目录、文件的信息，只需要关注如何更新同步目录与文件就可以了。由于Dokan是多线程的，因此实现时需要做到线程安全；查看Dokan使用的结构类型，发现只有两个成员可以使用，即DOKAN_OPTIONS里的GlobalContext和DOKAN_FILE_INFO里的Context，其中GlobalContext只能用来存储全局的信息，比如存放线程实例的指针，这样一来，实际上就剩下 DOKAN_FILE_INFO里的Context 一个成员可以用来存储与文件有关的信息了，一般用它来存储文件指针。我这次实现没有自己定义类来管理目录与文件，而是直接利用缓存目录，因此只需要处理文件指针和是否需要更新文件两个信息就可以了，而 DOKAN_FILE_INFO里的Context是Int64的，在Ｗin32里可以用32位存文件指针，另32位用来存储文件更新信息。 

//以下来自于Dokan.pas里的定义

_DOKAN_OPTIONS = packed record
    DriveLetter: WCHAR; // Drive letter to be mounted
    ThreadCount: Word; // Number of threads to be used
    DebugMode: Boolean;
    UseStdErr: Boolean;
    UseAltStream: Boolean;
    UseKeepAlive: Boolean;
    GlobalContext: Int64; // User-mode filesystem can use this variable
end;
PDOKAN_OPTIONS = ^_DOKAN_OPTIONS;
DOKAN_OPTIONS = _DOKAN_OPTIONS;

TDokanOptions = _DOKAN_OPTIONS;
PDokanOptions = PDOKAN_OPTIONS;

_DOKAN_FILE_INFO = packed record
    Context: Int64; // User-mode filesystem can use this variable
    DokanContext: Int64; // Reserved. Don't touch this!
    DokanOptions: PDOKAN_OPTIONS;
    ProcessId: ULONG; // Process id for the thread that originally requested the I/O operation
    IsDirectory: Boolean; // Indicates a directory file
    DeleteOnClose: Boolean; // Delete when Cleanup is called
    PagingIo: Boolean; // Read or write is paging IO
    SynchronousIo: Boolean; // Read or write is synchronous IO
    Nocache: Boolean; // No caching
    WriteToEndOfFile: Boolean; // If true, write to the current end of file instead of Offset parameter
end;
PDOKAN_FILE_INFO = ^_DOKAN_FILE_INFO;
DOKAN_FILE_INFO = _DOKAN_FILE_INFO;

TDokanFileInfo = _DOKAN_FILE_INFO;
  PDokanFileInfo = PDOKAN_FILE_INFO;

    研究了几天，发现只需要实现少数几个回调函数就可以了：

    1.FindFiles: 在这个回调函数里可以实现从远程目录同步其下的所有目录及文件。当然也可以在OpenDirectory回调函数里做，但实际使用时我发现OpenDirectory调用太频繁，而FindFiles调用次数要少一些。

    2.CreateDirectory: 在这个回调函数里可以实现同步创建远程目录。

    3.DeleteDirectory: 实现同步删除远程目录。　

    4.CreateFile: 这个回调函数调用极其频繁，每次操作目录文件（包括打开文件）时首先都会调到它，我在这里实现了从远程目录同步更新本地文件的内容。需要注意的是，在虚拟磁盘里新建文件时，为了能在Cleanup里正确同步到远程目录，必须记下来。我使用了以下代码来实现：

if not DokanFileInfo.IsDirectory and (CreationDisposition in [CREATE_NEW, OPEN_ALWAYS, CREATE_ALWAYS]) then begin
  MySetFileDate(DokanFileInfo, DateTimeToFileDate(Now)); //Cleanup里会判断FileDate来决定是否保存到远程目录
end;

    5.WriteFile: 可用于指示文件是否已修改，和Cleanup配合，以便保存文件时能正确提交到远程服务器。需要注意的WriteFile可能会被调用多次，所以它并不适合提交修改，只能记录修改标志。

    6.Cleanup: 同步删除远程目录中的文件及保存本地修改的文件到远程目录。实现时我发现，在Cleanup中判断DokanFileInfo.DeleteOnClose及DokanFileInfo.IsDirectory来删除目录的代码根本就不会走到（所以我在DeleteDirectory里实现删除目录的同步），而删除文件则没问题。

    这里有一点需要注意：因为执行Cleanup之前，可能会多次调用CreateFile，比如记事本保存文档时就会执行两次CreateFile之后再调用Cleanup，所以我在Cleanup的最后执行MySetFileDate(DokanFileInfo, 0)来清空标志，而没有在CreateFile里清空标志。

    7.MoveFile: 这个回调函数仅在移动虚拟磁盘里的文件到另一个虚拟磁盘目录中去时才触发，故实现在远程目录中同步移动文件后，就可以正常实现目录文件的移动了。由于操作多个目录文件时，Windows会每个目录文件分别调用相关操作，因此实现这个回调函数后，自然就实现了多个目录文件的移动。如果是从其他盘移动目录文件到虚拟磁盘或从虚拟磁盘移动目录文件到其他盘，都不会触发MoveFile这个回调函数；而目录文件改名，则会触发MoveFile这个回调函数。

    实现时还有一个调试信息如何显示的问题，对控制台程序，可以直接写到控制台；而对带窗口的程序，可以写日志文件，也可以发Windows消息。我采用了SendMessage来处理调试信息，具体实现请参看下面的代码。

    最终的实现是由一个线程来实现Dokan虚拟磁盘的，目录与文件的同步函数则放到一个单独的单元文件里，连接远程服务端则采用IndyTCPClient实现，传输采用了JSON，以便于和服务端的Python脚本通讯。

    附录部分是实现的代码，Dokan.pas及superobject.pas等代码请自己搜索下载。

 

附录（代码部分）：

//Mirror Drive （从 Mirror Driver修改而来）

unit cfMirrorDrive;

(*******************************************************************************
*
* Copyright (c) 2007, 2008 Hiroki Asakawa [email protected]
*
* Delphi translation by Vincent Forman ([email protected])
*
* Permission is hereby granted, free of charge, to any person obtaining a copy
* of this software and associated documentation files (the "Software"), to deal
* in the Software without restriction, including without limitation the rights
* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
* copies of the Software, and to permit persons to whom the Software is
* furnished to do so, subject to the following conditions:
*
* The above copyright notice and this permission notice shall be included in
* all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
* THE SOFTWARE.
*
*******************************************************************************)

interface

uses
Windows,
SysUtils,
Classes,
{$IFNDEF CONSOLE}
Messages,
Forms,
{$ENDIF}
FileCtrl,
Dokan,
cfFileMapping;

{$IFNDEF CONSOLE}
const
WM_IW_LOGMSG = WM_USER + 1001;
{$ENDIF}

type
TMirrorDrive = class(TThread)
protected
FRootDirectory: string;
FDokanOperations: TDokanOperations;
FDokanOptions: TDokanOptions;
{$IFNDEF CONSOLE}
FHandle: THandle;
{$ENDIF}
procedure Execute; override;
public
constructor Create(const ADirectory: string; ADrive: WideChar; {$IFNDEF CONSOLE}AHandle: THandle;{$ENDIF} ADebugMode: Boolean = False);
end;

implementation

type
TMyInt64 = record
case Integer of
0: (MyInt64: Int64);
1: (LowInt32: Integer;
HighInt32: Integer)
end;
PMyInt64 = ^TMyInt64;

function GetMirrorDrive(const DokanFileInfo: TDokanFileInfo): TMirrorDrive;
begin
Result := TMirrorDrive(Integer(DokanFileInfo.DokanOptions.GlobalContext));
end;

function MyGetFileDate(const DokanFileInfo: TDokanFileInfo): Integer;
begin
Result := PMyInt64(@DokanFileInfo.Context).HighInt32;
end;

procedure MySetFileDate(const DokanFileInfo: TDokanFileInfo; ADate: Integer);
begin
PMyInt64(@DokanFileInfo.Context).HighInt32 := ADate;
end;

function MyGetFileHandle(const DokanFileInfo: TDokanFileInfo): THandle;
begin
Result := PMyInt64(@DokanFileInfo.Context).LowInt32;
end;

procedure MySetFileHandle(const DokanFileInfo: TDokanFileInfo; AHandle: THandle);
begin
PMyInt64(@DokanFileInfo.Context).LowInt32 := AHandle;
end;


// Not available in Windows.pas
function SetFilePointerEx(hFile: THandle; lDistanceToMove: LARGE_INTEGER; lpNewFilePointer: Pointer; dwMoveMethod: DWORD): BOOL; stdcall; external kernel32;

// Some additional Win32 flags
const
FILE_READ_DATA = $00000001;
FILE_WRITE_DATA = $00000002;
FILE_APPEND_DATA = $00000004;
FILE_READ_EA = $00000008;
FILE_WRITE_EA = $00000010;
FILE_EXECUTE = $00000020;
FILE_READ_ATTRIBUTES = $00000080;
FILE_WRITE_ATTRIBUTES = $00000100;

FILE_ATTRIBUTE_ENCRYPTED = $00000040;
FILE_ATTRIBUTE_NOT_CONTENT_INDEXED = $00002000;
FILE_FLAG_OPEN_NO_RECALL = $00100000;
FILE_FLAG_OPEN_REPARSE_POINT = $00200000;

STATUS_DIRECTORY_NOT_EMPTY = $C0000101;

INVALID_SET_FILE_POINTER = $FFFFFFFF;

// Utilities routines, to be defined later
procedure DbgPrint(const DokanFileInfo: TDokanFileInfo; const Message: string); overload; forward;
procedure DbgPrint(const DokanFileInfo: TDokanFileInfo; const Format: string; const Args: array of const); overload; forward;
function MirrorConvertPath(const DokanFileInfo: TDokanFileInfo; FileName: PWideChar): string; forward;

// Output the value of a flag by searching amongst an array of value/name pairs
procedure CheckFlag(const DokanFileInfo: TDokanFileInfo; const Flag: Cardinal;
Values: array of Cardinal;
Names: array of string);
var
i:Integer;
begin
for i:=Low(Values) to High(Values) do
if Values[i]=Flag then
DbgPrint(DokanFileInfo, ' %s',[Names[i]]);
end;

type
EDokanMainError = class(Exception)
public
constructor Create(DokanErrorCode: Integer);
end;

constructor EDokanMainError.Create(DokanErrorCode: Integer);
var
s:string;
begin
case DokanErrorCode of
DOKAN_SUCCESS: s := 'Success';
DOKAN_ERROR: s := 'Generic error';
DOKAN_DRIVE_LETTER_ERROR: s := 'Bad drive letter';
DOKAN_DRIVER_INSTALL_ERROR: s := 'Cannot install driver';
DOKAN_START_ERROR: s := 'Cannot start driver';
DOKAN_MOUNT_ERROR: s := 'Cannot mount on the specified drive letter';
else
s := 'Unknown error';
end;
inherited CreateFmt('Dokan Error: (%d) %s',[DokanErrorCode,s]);
end;

// Dokan callbacks
function MirrorCreateFile(FileName: PWideChar;
AccessMode, ShareMode, CreationDisposition, FlagsAndAttributes: Cardinal;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
const
AccessModeValues: array[1..19] of Cardinal = (
GENERIC_READ, GENERIC_WRITE, GENERIC_EXECUTE,
_DELETE, FILE_READ_DATA, FILE_READ_ATTRIBUTES, FILE_READ_EA, READ_CONTROL,
FILE_WRITE_DATA, FILE_WRITE_ATTRIBUTES, FILE_WRITE_EA, FILE_APPEND_DATA, WRITE_DAC, WRITE_OWNER,
SYNCHRONIZE, FILE_EXECUTE,
STANDARD_RIGHTS_READ, STANDARD_RIGHTS_WRITE, STANDARD_RIGHTS_EXECUTE
);
AccessModeNames: array[1..19] of string = (
'GENERIC_READ', 'GENERIC_WRITE', 'GENERIC_EXECUTE',
'DELETE', 'FILE_READ_DATA', 'FILE_READ_ATTRIBUTES', 'FILE_READ_EA', 'READ_CONTROL',
'FILE_WRITE_DATA', 'FILE_WRITE_ATTRIBUTES', 'FILE_WRITE_EA', 'FILE_APPEND_DATA', 'WRITE_DAC', 'WRITE_OWNER',
'SYNCHRONIZE', 'FILE_EXECUTE',
'STANDARD_RIGHTS_READ', 'STANDARD_RIGHTS_WRITE', 'STANDARD_RIGHTS_EXECUTE'
);
ShareModeValues: array[1..3] of Cardinal = (
FILE_SHARE_READ, FILE_SHARE_WRITE, FILE_SHARE_DELETE
);
ShareModeNames: array[1..3] of string = (
'FILE_SHARE_READ', 'FILE_SHARE_WRITE', 'FILE_SHARE_DELETE'
);
CreationDispositionValues: array[1..5] of Cardinal = (
CREATE_NEW, OPEN_ALWAYS, CREATE_ALWAYS, OPEN_EXISTING, TRUNCATE_EXISTING
);
CreationDispositionNames: array[1..5] of string = (
'CREATE_NEW', 'OPEN_ALWAYS', 'CREATE_ALWAYS', 'OPEN_EXISTING', 'TRUNCATE_EXISTING'
);
FlagsAndAttributesValues: array[1..26] of Cardinal = (
FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_ENCRYPTED, FILE_ATTRIBUTE_HIDDEN,
FILE_ATTRIBUTE_NORMAL, FILE_ATTRIBUTE_NOT_CONTENT_INDEXED, FILE_ATTRIBUTE_OFFLINE,
FILE_ATTRIBUTE_READONLY, FILE_ATTRIBUTE_SYSTEM, FILE_ATTRIBUTE_TEMPORARY,
FILE_FLAG_WRITE_THROUGH, FILE_FLAG_OVERLAPPED, FILE_FLAG_NO_BUFFERING,
FILE_FLAG_RANDOM_ACCESS, FILE_FLAG_SEQUENTIAL_SCAN, FILE_FLAG_DELETE_ON_CLOSE,
FILE_FLAG_BACKUP_SEMANTICS, FILE_FLAG_POSIX_SEMANTICS, FILE_FLAG_OPEN_REPARSE_POINT,
FILE_FLAG_OPEN_NO_RECALL,
SECURITY_ANONYMOUS, SECURITY_IDENTIFICATION, SECURITY_IMPERSONATION,
SECURITY_DELEGATION, SECURITY_CONTEXT_TRACKING, SECURITY_EFFECTIVE_ONLY,
SECURITY_SQOS_PRESENT
);
FlagsAndAttributesNames: array[1..26] of string = (
'FILE_ATTRIBUTE_ARCHIVE', 'FILE_ATTRIBUTE_ENCRYPTED', 'FILE_ATTRIBUTE_HIDDEN',
'FILE_ATTRIBUTE_NORMAL', 'FILE_ATTRIBUTE_NOT_CONTENT_INDEXED', 'FILE_ATTRIBUTE_OFFLINE',
'FILE_ATTRIBUTE_READONLY', 'FILE_ATTRIBUTE_SYSTEM', 'FILE_ATTRIBUTE_TEMPORARY',
'FILE_FLAG_WRITE_THROUGH', 'FILE_FLAG_OVERLAPPED', 'FILE_FLAG_NO_BUFFERING',
'FILE_FLAG_RANDOM_ACCESS', 'FILE_FLAG_SEQUENTIAL_SCAN', 'FILE_FLAG_DELETE_ON_CLOSE',
'FILE_FLAG_BACKUP_SEMANTICS', 'FILE_FLAG_POSIX_SEMANTICS', 'FILE_FLAG_OPEN_REPARSE_POINT',
'FILE_FLAG_OPEN_NO_RECALL',
'SECURITY_ANONYMOUS', 'SECURITY_IDENTIFICATION', 'SECURITY_IMPERSONATION',
'SECURITY_DELEGATION', 'SECURITY_CONTEXT_TRACKING', 'SECURITY_EFFECTIVE_ONLY',
'SECURITY_SQOS_PRESENT'
);
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'CreateFile: %s', [filePath]);

(*
if (ShareMode = 0) and ((AccessMode and FILE_WRITE_DATA) <> 0) then
ShareMode := FILE_SHARE_WRITE
else
if ShareMode = 0 then
ShareMode := FILE_SHARE_READ;
*)

DbgPrint(DokanFileInfo, ' AccessMode = 0x%x', [AccessMode]);
CheckFlag(DokanFileInfo, AccessMode, AccessModeValues, AccessModeNames);

DbgPrint(DokanFileInfo, ' ShareMode = 0x%x', [ShareMode]);
CheckFlag(DokanFileInfo, ShareMode, ShareModeValues, ShareModeNames);

DbgPrint(DokanFileInfo, ' CreationDisposition = 0x%x', [CreationDisposition]);
CheckFlag(DokanFileInfo, CreationDisposition, CreationDispositionValues, CreationDispositionNames);

// Check if FilePath is a directory
if (GetFileAttributes(PChar(FilePath)) and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
FlagsAndAttributes := FlagsAndAttributes or FILE_FLAG_BACKUP_SEMANTICS;
if not DokanFileInfo.IsDirectory and (CreationDisposition in [CREATE_NEW, OPEN_ALWAYS, CREATE_ALWAYS]) then begin
MySetFileDate(DokanFileInfo, DateTimeToFileDate(Now));
end;
DbgPrint(DokanFileInfo, ' FlagsAndAttributes = 0x%x', [FlagsAndAttributes]);
CheckFlag(DokanFileInfo, FlagsAndAttributes, FlagsAndAttributesValues, FlagsAndAttributesNames);

FmUpdateFile(FilePath, FileName);

// Save the file handle in Context
MySetFileHandle(DokanFileInfo, CreateFile(PChar(FilePath), AccessMode, ShareMode, nil, CreationDisposition, FlagsAndAttributes, 0));
if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then begin
// Error codes are negated value of Win32 error codes
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'CreateFile failed, error code = %d', [-Result]);
end else
Result := 0;
DbgPrint(DokanFileInfo, '');
end;

function MirrorOpenDirectory(FileName: PWideChar;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'OpenDirectory: %s', [FilePath]);
MySetFileHandle(DokanFileInfo, CreateFile(PChar(FilePath), 0, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0));
if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'CreateFile failed, error code = %d', [-Result]);
end else begin
Result := 0;
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorCreateDirectory(FileName: PWideChar;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'CreateDirectory: %s', [FilePath]);
if not CreateDirectory(PChar(FilePath), nil) then begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'CreateDirectory failed, error code = %d', [-Result]);
end else begin
Result := 0;
FmCreateDir(FilePath, FileName);
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorCleanup(FileName: PWideChar;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'Cleanup: %s', [FilePath]);
if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then begin
Result := -1;
DbgPrint(DokanFileInfo, 'Error: invalid handle', [FilePath]);
end else begin
Result := 0;

if not DokanFileInfo.DeleteOnClose and not DokanFileInfo.IsDirectory and (MyGetFileDate(DokanFileInfo) > 0) then begin
FlushFileBuffers(MyGetFileHandle(DokanFileInfo)); //?!
end;

CloseHandle(MyGetFileHandle(DokanFileInfo));
MySetFileHandle(DokanFileInfo, INVALID_HANDLE_VALUE);
if DokanFileInfo.DeleteOnClose then begin
if DokanFileInfo.IsDirectory then begin
DbgPrint(DokanFileInfo, 'DeleteOnClose -> RemoveDirectory');
if not RemoveDirectory(PChar(FilePath)) then
DbgPrint(DokanFileInfo, 'RemoveDirectory failed, error code = %d', [GetLastError]);
end else begin
FmDeleteFile(FilePath, FileName);
DbgPrint(DokanFileInfo, 'DeleteOnClose -> DeleteFile');
if not DeleteFile(PChar(FIlePath)) then
DbgPrint(DokanFileInfo, 'DeleteFile failed, error code = %d', [GetLastError]);
end;
end;

if (MyGetFileDate(DokanFileInfo) > 0) and not DokanFileInfo.DeleteOnClose then begin
FmSaveFile(FilePath, FileName);
DbgPrint(DokanFileInfo, 'Cleanup.File(%s) has modified, save it.', [FileName]);
end;
end;
MySetFileDate(DokanFileInfo, 0);
DbgPrint(DokanFileInfo, '');
end;

function MirrorCloseFile(FileName: PWideChar;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
begin
Result := 0;
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'CloseFile: %s', [FilePath]);
if MyGetFileHandle(DokanFileInfo) <> INVALID_HANDLE_VALUE then begin
DbgPrint(DokanFileInfo, 'Error: file was not closed during cleanup');
CloseHandle(MyGetFileHandle(DokanFileInfo));
MySetFileHandle(DokanFileInfo, INVALID_HANDLE_VALUE);
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorReadFile(FileName: PWideChar;
var Buffer;
NumberOfBytesToRead: Cardinal;
var NumberOfBytesRead: Cardinal;
Offset: Int64;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
Opened: Boolean;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'ReadFile: %s (Offset: %d, Length: %d)', [FilePath, Offset, NumberOfBytesToRead]);
Opened := MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE;
if Opened then begin
DbgPrint(DokanFileInfo, 'Invalid handle (maybe passed through cleanup?), creating new one');
MySetFileHandle(DokanFileInfo, CreateFile(PChar(FilePath), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0));
end;
if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'CreateFile failed, error code = %d', [-Result]);
end else
try
if SetFilePointerEx(MyGetFileHandle(DokanFileInfo), LARGE_INTEGER(Offset), nil, FILE_BEGIN) then begin
if ReadFile(MyGetFileHandle(DokanFileInfo), Buffer, NumberOfBytesToRead, NumberOfBytesRead, nil) then begin
Result := 0;
DbgPrint(DokanFileInfo, 'Read: %d', [NumberOfBytesRead]);
end else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'ReadFile failed, error code = %d', [-Result]);
end;
end else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'Seek failed, error code = %d', [-Result]);
end;
finally
if Opened then begin
CloseHandle(MyGetFileHandle(DokanFileInfo));
MySetFileHandle(DokanFileInfo, INVALID_HANDLE_VALUE);
end;
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorWriteFile(FileName: PWideChar;
var Buffer;
NumberOfBytesToWrite: Cardinal;
var NumberOfBytesWritten: Cardinal;
Offset: Int64;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
Opened: Boolean;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'WriteFile: %s (Offset: %d, Length: %d)', [FilePath, Offset, NumberOfBytesToWrite]);
Opened := MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE;
if Opened then begin
DbgPrint(DokanFileInfo, 'Invalid handle (maybe passed through cleanup?), creating new one');
MySetFileHandle(DokanFileInfo, CreateFile(PChar(FilePath), GENERIC_WRITE, FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0));
end;
if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'CreateFile failed, error code = %d', [-Result]);
end else
try
if not DokanFileInfo.IsDirectory and (MyGetFileDate(DokanFileInfo) = 0) then begin
MySetFileDate(DokanFileInfo, FileGetDate(MyGetFileHandle(DokanFileInfo)));
DbgPrint(DokanFileInfo, 'GetFileDate = %d', [MyGetFileDate(DokanFileInfo)]);
end;
if SetFilePointerEx(MyGetFileHandle(DokanFileInfo), LARGE_INTEGER(Offset), nil, FILE_BEGIN) then begin
if WriteFile(MyGetFileHandle(DokanFileInfo), Buffer, NumberOfBytesToWrite, NumberOfBytesWritten, nil) then begin
Result := 0;
DbgPrint(DokanFileInfo, 'Written: %d', [NumberOfBytesWritten]);
end else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'WriteFile failed, error code = %d', [-Result]);
end;
end else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'Seek failed, error code = %d', [-Result]);
end;
finally
if Opened then begin
CloseHandle(MyGetFileHandle(DokanFileInfo));
MySetFileHandle(DokanFileInfo, INVALID_HANDLE_VALUE);
end;
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorFlushFileBuffers(FileName: PWideChar;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'FlushFileBuffers: %s', [FilePath]);
if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then begin
Result := -1;
DbgPrint(DokanFileInfo, 'Error: invalid handle')
end else begin
if FlushFileBuffers(MyGetFileHandle(DokanFileInfo)) then
Result := 0
else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'FlushFileBuffers failed, error code = %d', [-Result]);
end;
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorGetFileInformation(FileName: PWideChar;
FileInformation: PByHandleFileInformation;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
Opened: Boolean;
FindData: WIN32_FIND_DATAA;
FindHandle: THandle;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'GetFileInformation: %s', [FilePath]);
Opened := MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE;
if Opened then begin
DbgPrint(DokanFileInfo, 'Invalid handle (maybe passed through cleanup?), creating new one');
MySetFileHandle(DokanFileInfo, CreateFile(PChar(FilePath), GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0));
end;
if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then begin
Result := -1;
DbgPrint(DokanFileInfo, 'CreateFile failed, error code = %d', [GetLastError]);
end else
try
if GetFileInformationByHandle(MyGetFileHandle(DokanFileInfo), FileInformation^) then
Result := 0
else begin
DbgPrint(DokanFileInfo, 'GetFileInformationByHandle failed, error code = %d', [GetLastError]);
if Length(FileName) = 1 then begin
Result := 0;
FileInformation.dwFileAttributes := GetFileAttributes(PChar(FilePath));
end else begin
ZeroMemory(@FindData, SizeOf(FindData));
FindHandle := FindFirstFile(PChar(FilePath), FindData);
if FindHandle = INVALID_HANDLE_VALUE then begin
Result := -1;
DbgPrint(DokanFileInfo, 'FindFirstFile failed, error code = %d', [GetLastError]);
end else begin
Result := 0;
FileInformation.dwFileAttributes := FindData.dwFileAttributes;
FileInformation.ftCreationTime := FindData.ftCreationTime;
FileInformation.ftLastAccessTime := FindData.ftLastAccessTime;
FileInformation.ftLastWriteTime := FindData.ftLastWriteTime;
FileInformation.nFileSizeHigh := FindData.nFileSizeHigh;
FileInformation.nFileSizeLow := FindData.nFileSizeLow;
Windows.FindClose(FindHandle);
end;
end;
end;
finally
if Opened then begin
CloseHandle(MyGetFileHandle(DokanFileInfo));
MySetFileHandle(DokanFileInfo, INVALID_HANDLE_VALUE);
end;
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorFindFiles(PathName: PWideChar;
FillFindDataCallback: TDokanFillFindData;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: widestring;
FindData: WIN32_FIND_DATAW;
FindHandle: THandle;
begin
FilePath := MirrorConvertPath(DokanFileInfo, PathName);
FmListDir(FilePath, PathName);
FilePath := IncludeTrailingBackslash(FilePath) + '*';
DbgPrint(DokanFileInfo, 'FindFiles: %s', [FilePath]);
FindHandle := FindFirstFileW(PWideChar(FilePath), FindData);
if FindHandle = INVALID_HANDLE_VALUE then begin
Result := -1;
DbgPrint(DokanFileInfo, 'FindFirstFile failed, error code = %d', [GetLastError]);
end else begin
Result := 0;
try
FillFindDataCallback(FindData, DokanFileInfo);
while FindNextFileW(FindHandle, FindData) do
FillFindDataCallback(FindData, DokanFileInfo);
finally
Windows.FindClose(FindHandle);
end;
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorSetFileAttributes(FileName: PWideChar;
FileAttributes: Cardinal;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'SetFileAttributes: %s', [FilePath]);
if SetFileAttributes(PChar(FilePath), FileAttributes) then
Result := 0
else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'SetFileAttributes failed, error code = %d', [-Result]);
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorSetFileTime(FileName: PWideChar;
CreationTime, LastAccessTime, LastWriteTime: PFileTime;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'SetFileTime: %s', [FilePath]);
if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then begin
Result := -1;
DbgPrint(DokanFileInfo, 'Error: invalid handle');
end else begin
if SetFileTime(MyGetFileHandle(DokanFileInfo), CreationTime, LastAccessTime, LastWriteTime) then
Result := 0
else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'SetFileTime failed, error code = %d', [-Result]);
end;
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorDeleteFile(FileName: PWideChar;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
begin
Result := 0;
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'DeleteFile: %s', [FilePath]);
DbgPrint(DokanFileInfo, '');
end;

function MirrorDeleteDirectory(FileName: PWideChar;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
FindData: WIN32_FIND_DATAA;
FindHandle: THandle;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'DeleteDirectory: %s', [FilePath]);
FindHandle := FindFirstFile(PChar(FilePath), FindData);
if FindHandle = INVALID_HANDLE_VALUE then begin
Result := -GetLastError;
if Result = -ERROR_NO_MORE_FILES then
Result := 0
else
DbgPrint(DokanFileInfo, 'FindFirstFile failed, error code = %d', [-Result]);
end else begin
Cardinal(Result) := STATUS_DIRECTORY_NOT_EMPTY;
Result := -Result;
Windows.FindClose(FindHandle);
end;
if (Result = 0) or (FindHandle <> INVALID_HANDLE_VALUE) then begin
FmDeleteDir(FilePath, FileName);
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorMoveFile(ExistingFileName, NewFileName: PWideChar;
ReplaceExisiting: LongBool;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
ExistingFilePath, NewFilePath: string;
Status: Boolean;
begin
ExistingFilePath := MirrorConvertPath(DokanFileInfo, ExistingFileName);
NewFilePath := MirrorConvertPath(DokanFileInfo, NewFileName);
DbgPrint(DokanFileInfo, 'MoveFile: %s -> %s', [ExistingFilePath, NewFilePath]);
if MyGetFileHandle(DokanFileInfo) <> INVALID_HANDLE_VALUE then begin
CloseHandle(MyGetFileHandle(DokanFileInfo));
MySetFileHandle(DokanFileInfo, INVALID_HANDLE_VALUE);
end;
FmMoveFile(ExistingFileName, NewFileName);
if ReplaceExisiting then
Status := MoveFileEx(PChar(ExistingFilePath), PChar(NewFilePath), MOVEFILE_REPLACE_EXISTING)
else
Status := MoveFile(PChar(ExistingFilePath), PChar(NewFilePath));
if Status then
Result := 0
else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'MoveFile failed, error code = %d', [-Result]);
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorSetEndOfFile(FileName: PWideChar;
Length: Int64;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'SetEndOfFile: %s', [FilePath]);
if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then begin
Result := -1;
DbgPrint(DokanFileInfo, 'Invalid handle');
end else begin
if SetFilePointerEx(MyGetFileHandle(DokanFileInfo), LARGE_INTEGER(Length), nil, FILE_BEGIN) then begin
if SetEndOfFile(MyGetFileHandle(DokanFileInfo)) then
Result := 0
else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'SetEndOfFile failed, error code = %d', [-Result]);
end;
end else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'Seek failed, error code = %d', [-Result]);
end;
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorSetAllocationSize(FileName: PWideChar; Length: Int64;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'SetAllocationSize: %s', [FilePath]);
if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then begin
Result := -1;
DbgPrint(DokanFileInfo, 'Invalid handle');
end else begin
if SetFilePointerEx(MyGetFileHandle(DokanFileInfo), LARGE_INTEGER(Length), nil, FILE_BEGIN) then begin
if SetEndOfFile(MyGetFileHandle(DokanFileInfo)) then
Result := 0
else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'SetEndOfFile failed, error code = %d', [-Result]);
end;
end else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'Seek failed, error code = %d', [-Result]);
end;
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorLockFile(FileName: PWideChar;
Offset, Length: Int64;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
var
FilePath: string;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'LockFile: %s', [FilePath]);
if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then begin
DbgPrint(DokanFileInfo, 'Invalid handle');
Result := -1;
end else begin
if LockFile(MyGetFileHandle(DokanFileInfo),
LARGE_INTEGER(Offset).LowPart, LARGE_INTEGER(Offset).HighPart,
LARGE_INTEGER(Length).LowPart, LARGE_INTEGER(Length).HighPart) then
Result := 0
else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'LockFile failed, error code = %d', [-Result]);
end;
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorUnlockFile(FileName: PWideChar;
Offset, Length: Int64;
var DokanFileInfo: TDokanFileInfo): Integer; stdcall;


var
FilePath: string;
begin
FilePath := MirrorConvertPath(DokanFileInfo, FileName);
DbgPrint(DokanFileInfo, 'UnlockFile: %s', [FilePath]);
if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then begin
DbgPrint(DokanFileInfo, 'Invalid handle');
Result := -1;
end else begin
if UnlockFile(MyGetFileHandle(DokanFileInfo),
LARGE_INTEGER(Offset).LowPart, LARGE_INTEGER(Offset).HighPart,
LARGE_INTEGER(Length).LowPart, LARGE_INTEGER(Length).HighPart) then
Result := 0
else begin
Result := -GetLastError;
DbgPrint(DokanFileInfo, 'UnlockFile failed, error code = %d', [-Result]);
end;
end;
DbgPrint(DokanFileInfo, '');
end;

function MirrorGetVolumeInfo(VolumeNameBuffer: LPWSTR; VolumeNameSize: DWORD;
var VolumeSerialNumber, MaximumComponentLength, FileSystemFlags: DWORD;
FileSystemNameBuffer: LPWSTR; FileSystemNameSize: DWORD;
var DokanFileInfo: DOKAN_FILE_INFO): Integer; stdcall;
var
sVolume: WideString;
begin
Result := 0;
sVolume := Format('Dokan(%s)', [MirrorConvertPath(DokanFileInfo, nil)]);
if VolumeNameSize < DWord((Length(sVolume)+1) * 2) then begin
Result := (Length(sVolume)+1) * 2;
end else begin
CopyMemory(VolumeNameBuffer, Pointer(sVolume), Length(sVolume)* 2);
VolumeNameBuffer[Length(sVolume)+1] := #0;
VolumeSerialNumber := $12345678; //testing
end;
end;

function MirrorUnmount(var DokanFileInfo: TDokanFileInfo): Integer; stdcall;
begin
Result := 0;
DbgPrint(DokanFileInfo, 'Unmount');
DbgPrint(DokanFileInfo, '');
end;

{ TMirror Thread (for multi thread testing) }

procedure TMirrorDrive.Execute;
var
i: integer;
begin
DokanUnmount(FDokanOptions.DriveLetter); //try to unmount
i := DokanMain(FDokanOptions, FDokanOperations);
if i <> DOKAN_SUCCESS then
raise EDokanMainError.Create(i);
end;

constructor TMirrorDrive.Create(const ADirectory: string; ADrive: WideChar;
{$IFNDEF CONSOLE}AHandle: THandle;{$ENDIF} ADebugMode: Boolean);
begin
FRootDirectory := ADirectory;

with FDokanOperations do begin
CreateFile := MirrorCreateFile;
OpenDirectory := MirrorOpenDirectory;
CreateDirectory := MirrorCreateDirectory;
Cleanup := MirrorCleanup;
CloseFile := MirrorCloseFile;
ReadFile := MirrorReadFile;
WriteFile := MirrorWriteFile;
FlushFileBuffers := MirrorFlushFileBuffers;
GetFileInformation := MirrorGetFileInformation;
FindFiles := MirrorFindFiles;
FindFilesWithPattern := nil;
SetFileAttributes := MirrorSetFileAttributes;
SetFileTime := MirrorSetFileTime;
DeleteFile := MirrorDeleteFile;
DeleteDirectory := MirrorDeleteDirectory;
MoveFile := MirrorMoveFile;
SetEndOfFile := MirrorSetEndOfFile;
SetAllocationSize := MirrorSetAllocationSize;
LockFile := MirrorLockFile;
UnlockFile := MirrorUnlockFile;
GetDiskFreeSpace := nil;
GetVolumeInformation := MirrorGetVolumeInfo;
Unmount := MirrorUnmount
end;

with FDokanOptions do begin
DriveLetter := ADrive;
ThreadCount := 0;
DebugMode := ADebugMode;
UseStdErr := False;
UseAltStream := False;
UseKeepAlive := False;
GlobalContext := Integer(Self);
end;

{$IFNDEF CONSOLE}
FHandle := AHandle;
{$ENDIF}

inherited Create(True);
end;

// Utilities routines
procedure DbgPrint(const DokanFileInfo: TDokanFileInfo; const Message: string); overload;
begin
if DokanFileInfo.DokanOptions.DebugMode then begin
// if g_DokanOptions.UseStdErr then
// Writeln(ErrOutput,Message)
// else
{$IFDEF CONSOLE}
Writeln(Message)
{$ELSE}
try
with GetMirrorDrive(DokanFileInfo) do begin
if FHandle > 0 then begin
SendMessage(FHandle, WM_IW_LOGMSG, Integer(PChar(Message)), Length(Message));
end;
end;
except
end;
{$ENDIF}
end;
end;

procedure DbgPrint(const DokanFileInfo: TDokanFileInfo; const Format: string; const Args: array of const); overload;
begin
DbgPrint(DokanFileInfo, SysUtils.Format(Format,Args));
end;

function MirrorConvertPath(const DokanFileInfo: TDokanFileInfo; FileName: PWideChar): string;
var
path: string;
begin
path := GetMirrorDrive(DokanFileInfo).FRootDirectory;
if FileName = nil then begin
DbgPrint(DokanFileInfo, 'Null filename');
Result := path
end else
Result := path + FileName;
end;

end.

 

// File Mapping （与远程服务端同步）

unit cfFileMapping;

interface

uses
Windows, Messages, SysUtils, Classes, {$IFNDEF CONSOLE}Forms, {$ENDIF}
FileCtrl, ShellApi, Math, SuperObject, {$IFDEF VER130}Unicode, {$ENDIF}cfConnect;

procedure FmCreateDir(const vOriginDir, vMapDir: string);
procedure FmListDir(const vOriginDir, vMapDir: string);
procedure FmDeleteDir(const vOriginDir, vMapDir: string);

procedure FmUpdateFile(const vOriginFile, vMapFile: string);
procedure FmSaveFile(const vOriginFile, vMapFile: string);
procedure FmDeleteFile(const vOriginFile, vMapFile: string);

procedure FmMoveFile(const vOldMapFile, vNewMapFile: string);

implementation

{$IFNDEF CONSOLE}
const
WM_IW_LOGMSG = WM_USER + 1001;
{$ENDIF}

const
cLogonID = 100; // "logon",
cReceiveFile = 200; // "receivefile",
cSendFile = 300; // "sendfile",
cListDir = 400; // "listdir",
cCreateDir = 500; // "createfolder",
cDeleteDir = 600; // "deletefloder",
cDeleteFile = 700; // "deletefile",
cMoveFile = 800; // "movefile",
cDefault = 999; // "default"


function SetFilePointerEx(hFile: THandle; lDistanceToMove: LARGE_INTEGER;
lpNewFilePointer: Pointer; dwMoveMethod: DWORD): BOOL; stdcall; external kernel32;

{------------------------------------------------------------------------------
Internal functions
------------------------------------------------------------------------------}

procedure LogIt(const S: string);
begin
{$IFDEF CONSOLE}
WriteLn(S);
{$ELSE}
if Assigned(Application.MainForm) then begin //for testing
SendMessage(Application.MainForm.Handle, WM_IW_LOGMSG, Integer(PChar(S)), Length(S));
end;
{$ENDIF}
end;

function FmtMapDir(const S: string): string;
var
i: Integer;
begin
Result := S;
if (Result <> '') and (Result[1] in ['/', '\']) then begin
Delete(Result, 1, 1);
end;
for i := 1 to Length(Result) do begin
if Result[i] = '\' then begin
Result[i] := '/';
end;
end;
end;

function MyDeleteDir(const vDir: string): Boolean;
var
fo: TSHFILEOPSTRUCT;
begin
FillChar(fo, SizeOf(fo), 0);
with fo do
begin
Wnd := 0;
wFunc := FO_DELETE;
pFrom := PChar(vDir + #0);
pTo := #0#0;
fFlags := FOF_NOCONFIRMATION + FOF_SILENT;
end;
Result := (SHFileOperation(fo) = 0);
end;

function MyStrToDateTime(const S: string): TDateTime;
const
DIGIT = ['0'..'9'];
var
i: Integer;

procedure ExtractNum(var vNum: Word);
begin
vNum := 0;
while (i <= Length(S)) and (S[i] in DIGIT) do begin
vNum := vNum * 10 + Ord(S[i]) - Ord('0');
Inc(i);
end;
while (i <= Length(S)) and not(S[i] in DIGIT) do Inc(i);
end;

var
y, m, d, hour, mins, secs: Word;
begin
Result := 0;
if S = '' then Exit;
try
// TBD: for "yyyy-mm-dd hh:nn:ss" or "yyyy/mm/dd hh:nn:ss" date format, ...
i := 1;
ExtractNum(y);
ExtractNum(m);
ExtractNum(d);
ExtractNum(hour);
ExtractNum(mins);
ExtractNum(secs);
Result := EncodeDate(y, m, d) + EncodeTime(hour, mins, secs, 0);
except
end;
end;

{ create map dir/files }

procedure CreateLocalMapping(const vDir, vName: string; vIsFile: Boolean;
vSize: Int64; vLastVisitTime, vCreateTime, vLastModifyTime: TDateTime);
const
cNullHead = #0#0#0#0#0#0#0#0;
var
hFile: Integer;
path: string;
begin
path := IncludeTrailingBackslash(vDir) + vName;
if vIsFile then begin
if FileExists(path) then begin
hFile := FileOpen(path, fmOpenReadWrite or fmShareDenyNone);
try
if FileGetDate(hFile) < DateTimeToFileDate(vLastModifyTime) then begin
FileWrite(hFile, PChar(cNullHead)^, Min(vSize, Length(cNullHead)));
if vSize <> GetFileSize(hFile, nil) then begin //
if SetFilePointerEx(hFile, LARGE_INTEGER(vSize), nil, FILE_BEGIN) then begin
SetEndOfFile(hFile);
end;
end;
FileSetDate(hFile, DateTimeToFileDate(vLastModifyTime));
end;
finally
FileClose(hFile);
end;
end else begin
hFile := FileCreate(path);
try
if SetFilePointerEx(hFile, LARGE_INTEGER(vSize), nil, FILE_BEGIN) then begin
SetEndOfFile(hFile);
end;
FileSetDate(hFile, DateTimeToFileDate(vLastModifyTime));
finally
FileClose(hFile);
end;
end;
end else begin
ForceDirectories(path);
hFile := FileOpen(path, fmOpenReadWrite or fmShareDenyNone);
try
FileSetDate(hFile, DateTimeToFileDate(vLastModifyTime));
finally
FileClose(hFile);
end;
end;
end;

{------------------------------------------------------------------------------
Public Interface
------------------------------------------------------------------------------}

procedure FmCreateDir(const vOriginDir, vMapDir: string);
begin
try
CloudConnector.ExecuteCommand(Format('{"msgid":%d,"path":"%s"}', [cCreateDir, AnsiToUtf8(FmtMapDir(vMapDir))]));
except
on E: Exception do begin
LogIt(E.Message);
end;
end;
end;

procedure FmListDir(const vOriginDir, vMapDir: string);
const
cDirFileFlags: array[Boolean] of Integer = (0, 1);
var
s: string;
jsonObj, subObj: ISuperObject;
jsonArray: TSuperArray;
i: Integer;
path: string;
dirFiles: TStringList;
sr: TSearchRec;
idx: Integer;
isFile: Boolean;
begin
try
s := CloudConnector.ExecuteCommand(Format('{"msgid":%d,"path":"%s"}', [cListDir, AnsiToUtf8(FmtMapDir(vMapDir))]));
jsonObj := SO(Utf8ToAnsi(s));
jsonArray := jsonObj.AsArray;
if jsonArray = nil then begin
LogIt('Error: Empty Array from JSon Object.');
Exit;
end;
dirFiles := TStringList.Create;
try
// delete obsolete directories/files
for i := 0 to jsonArray.Length -1 do begin
dirFiles.AddObject(jsonArray[i].S['name'], TObject(StrToIntDef(jsonArray[i].S['isfile'], 0)));
end;
path := IncludeTrailingBackslash(vOriginDir);
dirFiles.Sorted := True;
if FindFirst(path + '*.*', faAnyFile, sr) = 0 then try
repeat
if (sr.Name <> '.') and (sr.Name <> '..') then begin
// ignore hidden & system dir/file ??!!
if ((sr.Attr and faHidden) = 0) or ((sr.Attr and faSysFile) = 0) then begin
isFile := (sr.Attr and faDirectory) = 0;
if not dirFiles.Find(sr.Name, idx) or (Integer(dirFiles.Objects[idx]) <> cDirFileFlags[isFile]) then begin
if isFile then begin
DeleteFile(path + sr.Name);
LogIt('Delete Obsolete File: ' + path + sr.Name);
end else begin
MyDeleteDir(path + sr.Name);
LogIt('Delete Obsolete Folder: ' + path + sr.Name);
end;
end;
end;
end;
until FindNext(sr) <> 0;
finally
FindClose(sr);
end;
// save to local
for i := 0 to jsonArray.Length -1 do begin
subObj := jsonArray[i];
CreateLocalMapping(
vOriginDir,
subObj.S['name'],
'1'= subObj.S['isfile'],
subObj.I['size'],
MyStrToDateTime(subObj.S['lastvisittime']),
MyStrToDateTime(subObj.S['createtime']),
MyStrToDateTime(subObj.S['lastmodifytime'])
);
end;
finally
dirFiles.Free;
end;
except
on E: Exception do begin
LogIt(E.Message);
end;
end;
end;

procedure FmDeleteDir(const vOriginDir, vMapDir: string);
begin
try
CloudConnector.ExecuteCommand(Format('{"msgid":%d,"path":"%s"}', [cDeleteDir, AnsiToUtf8(FmtMapDir(vMapDir))]));
except
on E: Exception do begin
LogIt(E.Message);
end;
end;
end;

procedure FmUpdateFile(const vOriginFile, vMapFile: string);
var
stream: TFileStream;
fDate: Integer;
buf: string;
begin
try
if not FileExists(vOriginFile) then Exit;
stream := TFileStream.Create(vOriginFile, fmOpenReadWrite or fmShareDenyWrite);
try
if stream.Size > 0 then begin
SetLength(buf, Min(stream.Size, 8));
stream.Read(PChar(buf)^, Length(buf));
if buf <> StringOfChar(#0, Length(buf)) then begin
Exit;
end;
stream.Position := 0;
end;
fDate := FileGetDate(stream.Handle);
CloudConnector.ReadFile(Format('{"msgid":%d,"path":"%s"}', [cSendFile, AnsiToUtf8(FmtMapDir(vMapFile))]), stream);
FlushFileBuffers(stream.Handle);
FileSetDate(stream.Handle, fDate);
finally
stream.Free;
end;
except
on E: Exception do begin
LogIt(E.Message);
end;
end;
end;

procedure FmSaveFile(const vOriginFile, vMapFile: string);
var
stream: TFileStream;
fDate: Integer;
begin
try
stream := TFileStream.Create(vOriginFile, fmOpenRead or fmShareDenyNone);
try
fDate := DateTimeToFileDate(MyStrToDateTime(CloudConnector.SaveFile(
Format('{"msgid":%d,"path":"%s","size":%d}', [cReceiveFile, AnsiToUtf8(FmtMapDir(vMapFile)), stream.Size]),
stream)));
FileSetDate(stream.Handle, fDate);
finally
stream.Free;
end;
except
on E: Exception do begin
LogIt(E.Message);
end;
end;
end;

procedure FmDeleteFile(const vOriginFile, vMapFile: string);
begin
try
CloudConnector.ExecuteCommand(Format('{"msgid":%d,"path":"%s"}', [cDeleteFile, AnsiToUtf8(FmtMapDir(vMapFile))]));
except
on E: Exception do begin
LogIt(E.Message);
end;
end;
end;

procedure FmMoveFile(const vOldMapFile, vNewMapFile: string);
begin
try
CloudConnector.ExecuteCommand(Format('{"msgid":%d,"old":"%s","new":"%s"}',
[cMoveFile, AnsiToUtf8(FmtMapDir(vOldMapFile)), AnsiToUtf8(FmtMapDir(vNewMapFile))]));
except
on E: Exception do begin
LogIt(E.Message);
end;
end;
end;

end.

 

// Connector （通过IndyTCPClient与远程服务端通讯）

unit cfConnect;

interface

uses
Windows, Messages, SysUtils, Classes, Dialogs, IdBaseComponent, IdComponent,
IdTCPConnection, IdTCPClient, SyncObjs, superobject;

type
TCloudConnector = class
private
FLocker: TCriticalSection;
FConnector: TIdTCPClient;
FTimeout: Integer;
FUser: string;
FToken: string;
function AddInternalParams(const vCmdLine: string): string;
public
constructor Create;
destructor Destroy; override;
procedure Init(const vHost: string; vPort: Integer);
procedure Logon(const vUser, vPW: string; vTimeout: Integer = 5000);
function ExecuteCommand(const vCmdLine: string): string;
function ReadFile(const vCmdLine: string; vStream: TStream): Boolean;
function SaveFile(const vCmdLine: string; vStream: TStream): string;
end;

function CloudConnector: TCloudConnector;

implementation

const
LF = #10;

var
g_CloudConnector: TCloudConnector;

{ Public Functions }

function CloudConnector: TCloudConnector;
begin
if g_CloudConnector = nil then begin
g_CloudConnector := TCloudConnector.Create;
end;
Result := g_CloudConnector;
end;

{ Internal Functions }

function Fetch(var S: string; const vDelimiter: string): string;
var
idx: Integer;
begin
idx := Pos(vDelimiter, S);
if idx > 0 then begin
Result := Copy(S, 1, idx -1);
Delete(S, 1, idx + Length(vDelimiter) -1);
end else begin
Result := S;
S := '';
end;
end;

{ TCloudConnector }

constructor TCloudConnector.Create;
begin
FLocker := TCriticalSection.Create;
FConnector := TIdTCPClient.Create(nil);
FConnector.Host := '127.0.0.1';
FConnector.Port := 9288;
FTimeout := 5000;
end;

destructor TCloudConnector.Destroy;
begin
FConnector.Free;
FLocker.Free;
inherited;
end;

{ private interface }

function TCloudConnector.AddInternalParams(const vCmdLine: string): string;
var
idx: Integer;
begin
Result := vCmdLine;
idx := LastDelimiter('}', Result);
System.Insert(Format(',"user":"%s","token":"%s"', [FUser, FToken]), Result, idx);
end;

{ public interface }

procedure TCloudConnector.Init(const vHost: string; vPort: Integer);
begin
with FConnector do begin
Host := vHost;
Port := vPort;
end;
end;

procedure TCloudConnector.Logon(const vUser, vPW: string; vTimeout: Integer);
var
s: string;
code: Integer;
superObj: ISuperObject;
begin
FTimeout := vTimeout;
with FConnector do begin
Connect(FTimeout);
try
WriteLn('{"msgid":100}'); //logon
s := ReadLn(LF, FTimeout);
code := superObj.I['result'] ;
if code <> 100 then begin //process error
s := superObj.S['message'];
raise Exception.Create(Format('Error: %d - %s', [code, s]));
end;
FUser := vUser;
FToken := superObj.S['token'];
finally
Disconnect;
end;
end;
end;

function TCloudConnector.ExecuteCommand(const vCmdLine: string): string;
begin
FLocker.Enter;
try
Result := '';
with FConnector do begin
Connect(FTimeout);
try
WriteLn(AddInternalParams(vCmdLine));
Result := ReadLn(LF, FTimeout);
finally
Disconnect;
end;
end;
finally
FLocker.Leave;
end;
end;

function TCloudConnector.ReadFile(const vCmdLine: string;
vStream: TStream): Boolean;
var
superObj: ISuperObject;
begin
FLocker.Enter;
try
try
with FConnector do begin
Connect(FTimeout);
try
WriteLn(AddInternalParams(vCmdLine));
superObj := SO(ReadLn());
ReadStream(vStream, superObj.I['filesize']);
finally
Disconnect;
end;
end;
Result := True;
except
on E: Exception do begin
Result := False;
end;
end;
finally
FLocker.Leave;
end;
end;

function TCloudConnector.SaveFile(const vCmdLine: string;
vStream: TStream): string;
var
superObj: ISuperObject;
begin
Result := '';
FLocker.Enter;
try
try
with FConnector do begin
Connect(FTimeout);
try
WriteLn(AddInternalParams(vCmdLine));
WriteStream(vStream);
superObj := SO(ReadLn());
Result := superObj.S['lastmodifytime'];
finally
Disconnect;
end;
end;
except
on E: Exception do begin
end;
end;
finally
FLocker.Leave;
end;
end;

initialization

finalization
g_CloudConnector.Free;

end.

 

// 对Delphi5，还需要一个Unicode转换单元；Delphi6以上就不需要了

{****************************************************************************}
{ Some Function of Ansi, UTF8, Unicode Converting (copy from Delphi6) }
{****************************************************************************}

unit Unicode;

interface

uses
Classes, Windows, SysUtils;

type
UTF8String = type string;
PUTF8String = ^UTF8String;

{ PChar/PWideChar Unicode <-> UTF8 conversion }

// UnicodeToUTF8(3):
// UTF8ToUnicode(3):
// Scans the source data to find the null terminator, up to MaxBytes
// Dest must have MaxBytes available in Dest.
// MaxDestBytes includes the null terminator (last char in the buffer will be set to null)
// Function result includes the null terminator.

function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; overload; //deprecated;
function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; overload; //deprecated;

// UnicodeToUtf8(4):
// UTF8ToUnicode(4):
// MaxDestBytes includes the null terminator (last char in the buffer will be set to null)
// Function result includes the null terminator.
// Nulls in the source data are not considered terminators - SourceChars must be accurate

function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; overload;
function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; overload;

{ WideString <-> UTF8 conversion }

function UTF8Encode(const WS: WideString): UTF8String;
function UTF8Decode(const S: UTF8String): WideString;

{ Ansi <-> UTF8 conversion }

function AnsiToUtf8(const S: string): UTF8String;
function Utf8ToAnsi(const S: UTF8String): string;

function AnsiToUtf8Xml(const S: string): UTF8String;

implementation

// UnicodeToUTF8(3):
// Scans the source data to find the null terminator, up to MaxBytes
// Dest must have MaxBytes available in Dest.

function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer;
var
len: Cardinal;
begin
len := 0;
if Source <> nil then
while Source[len] <> #0 do
Inc(len);
Result := UnicodeToUtf8(Dest, MaxBytes, Source, len);
end;

// UnicodeToUtf8(4):
// MaxDestBytes includes the null terminator (last char in the buffer will be set to null)
// Function result includes the null terminator.
// Nulls in the source data are not considered terminators - SourceChars must be accurate

function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal;
var
i, count: Cardinal;
c: Cardinal;
begin
Result := 0;
if Source = nil then Exit;
count := 0;
i := 0;
if Dest <> nil then
begin
while (i < SourceChars) and (count < MaxDestBytes) do
begin
c := Cardinal(Source[i]);
Inc(i);
if c <= $7F then
begin
Dest[count] := Char(c);
Inc(count);
end
else if c > $7FF then
begin
if count + 3 > MaxDestBytes then
break;
Dest[count] := Char($E0 or (c shr 12));
Dest[count+1] := Char($80 or ((c shr 6) and $3F));
Dest[count+2] := Char($80 or (c and $3F));
Inc(count,3);
end
else // $7F < Source[i] <= $7FF
begin
if count + 2 > MaxDestBytes then
break;
Dest[count] := Char($C0 or (c shr 6));
Dest[count+1] := Char($80 or (c and $3F));
Inc(count,2);
end;
end;
if count >= MaxDestBytes then count := MaxDestBytes-1;
Dest[count] := #0;
end
else
begin
while i < SourceChars do
begin
c := Integer(Source[i]);
Inc(i);
if c > $7F then
begin
if c > $7FF then
Inc(count);
Inc(count);
end;
Inc(count);
end;
end;
Result := count+1; // convert zero based index to byte count
end;

function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer;
var
len: Cardinal;
begin
len := 0;
if Source <> nil then
while Source[len] <> #0 do
Inc(len);
Result := Utf8ToUnicode(Dest, MaxChars, Source, len);
end;

function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal;
var
i, count: Cardinal;
c: Byte;
wc: Cardinal;
begin
if Source = nil then
begin
Result := 0;
Exit;
end;
Result := Cardinal(-1);
count := 0;
i := 0;
if Dest <> nil then
begin
while (i < SourceBytes) and (count < MaxDestChars) do
begin
wc := Cardinal(Source[i]);
Inc(i);
if (wc and $80) <> 0 then
begin
wc := wc and $3F;
if i > SourceBytes then Exit; // incomplete multibyte char
if (wc and $20) <> 0 then
begin
c := Byte(Source[i]);
Inc(i);
if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char
if i > SourceBytes then Exit; // incomplete multibyte char
wc := (wc shl 6) or (c and $3F);
end;
c := Byte(Source[i]);
Inc(i);
if (c and $C0) <> $80 then Exit; // malformed trail byte

Dest[count] := WideChar((wc shl 6) or (c and $3F));
end
else
Dest[count] := WideChar(wc);
Inc(count);
end;
if count >= MaxDestChars then count := MaxDestChars-1;
Dest[count] := #0;
end
else
begin
while (i <= SourceBytes) do
begin
c := Byte(Source[i]);
Inc(i);
if (c and $80) <> 0 then
begin
if (c and $F0) = $F0 then Exit; // too many bytes for UCS2
if (c and $40) = 0 then Exit; // malformed lead byte
if i > SourceBytes then Exit; // incomplete multibyte char

if (Byte(Source[i]) and $C0) <> $80 then Exit; // malformed trail byte
Inc(i);
if i > SourceBytes then Exit; // incomplete multibyte char
if ((c and $20) <> 0) and ((Byte(Source[i]) and $C0) <> $80) then Exit; // malformed trail byte
Inc(i);
end;
Inc(count);
end;
end;
Result := count+1;
end;

function Utf8Encode(const WS: WideString): UTF8String;
var
L: Integer;
Temp: UTF8String;
begin
Result := '';
if WS = '' then Exit;
SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminator

L := UnicodeToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS));
if L > 0 then
SetLength(Temp, L-1)
else
Temp := '';
Result := Temp;
end;

function Utf8Decode(const S: UTF8String): WideString;
var
L: Integer;
Temp: WideString;
begin
Result := '';
if S = '' then Exit;
SetLength(Temp, Length(S));

L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S));
if L > 0 then
SetLength(Temp, L-1)
else
Temp := '';
Result := Temp;
end;

function AnsiToUtf8(const S: string): UTF8String;
begin
Result := Utf8Encode(S);
end;

function Utf8ToAnsi(const S: UTF8String): string;
begin
Result := Utf8Decode(S);
end;

function AnsiToUtf8Xml(const S: string): UTF8String;
var //only process '&', ... &#xB4 ...
i: Integer;
begin
Result := S;
i := 1;
while i <= Length(Result) do begin
case Result[i] of
'&': begin
Insert('amp;', Result, i+1);
Inc(i, 4);
end;
'>': begin
Result[i] := '&';
Insert('gt;', Result, i+1);
Inc(i, 3);
end;
'<': begin
Result[i] := '&';
Insert('lt;', Result, i+1);
Inc(i, 3);
end;
'"': begin
Result[i] := '&';
Insert('quot;', Result, i+1);
Inc(i, 5);
end;
'''': begin
Result[i] := '&';
Insert('apos;', Result, i+1);
Inc(i, 5);
end;
#128..#255: //process wearer′s ′=&#xB4;
begin
Insert('#x' + IntToHex(Ord(Result[i]), 2) + ';', Result, i+1);
Result[i] := '&';
Inc(i, 5);
end;
end;
Inc(i);
end;
Result := AnsiToUtf8(Result);
end;

end.