2024年1月6日发(作者：)

{$ENDIF}FileCtrl,Dokan,cfFileMapping;{$IFNDEF CONSOLE}constWM_IW_LOGMSG = WM_USER + 1001;{$ENDIF}typeTMirrorDrive = class(TThread)protectedFRootDirectory: string;FDokanOperations: TDokanOperations;FDokanOptions: TDokanOptions;{$IFNDEF CONSOLE}FHandle: THandle;{$ENDIF}procedure Execute; override;publicconstructor Create(const ADirectory: string; ADrive: WideChar; {$IFNDEF CONSOLE}AHandle: THandle;{$ENDIF} ADebugMode:Boolean = False);end;implementationtypeTMyInt64 = recordcase Integer of0: (MyInt64: Int64);1: (LowInt32: Integer;HighInt32: Integer)end;PMyInt64 = ^TMyInt64;function GetMirrorDrive(const DokanFileInfo: TDokanFileInfo): TMirrorDrive;beginResult := TMirrorDrive(Integer(Context));end;function MyGetFileDate(const DokanFileInfo: TDokanFileInfo): Integer;beginResult := PMyInt64(@t).HighInt32;end;procedure MySetFileDate(const DokanFileInfo: TDokanFileInfo; ADate: Integer);beginPMyInt64(@t).HighInt32 := ADate;end;function MyGetFileHandle(const DokanFileInfo: TDokanFileInfo): THandle;beginResult := PMyInt64(@t).LowInt32;end;procedure MySetFileHandle(const DokanFileInfo: TDokanFileInfo; AHandle: THandle);beginPMyInt64(@t).LowInt32 := AHandle;end;// Not available in ction SetFilePointerEx(hFile: THandle; lDistanceToMove: LARGE_INTEGER; lpNewFilePointer: Pointer; dwMoveMethod: DWORD):BOOL; stdcall; external kernel32;// Some additional Win32 flagsconst

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 laterprocedure 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 pairsprocedure CheckFlag(const DokanFileInfo: TDokanFileInfo; const Flag: Cardinal;Values: array of Cardinal;Names: array of string);vari:Integer;beginfor i:=Low(Values) to High(Values) doif Values[i]=Flag thenDbgPrint(DokanFileInfo, ' %s',[Names[i]]);end;typeEDokanMainError = class(Exception)publicconstructor Create(DokanErrorCode: Integer);end;constructor (DokanErrorCode: Integer);vars:string;begincase DokanErrorCode ofDOKAN_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';elses := 'Unknown error';end;inherited CreateFmt('Dokan Error: (%d) %s',[DokanErrorCode,s]);end;// Dokan callbacksfunction MirrorCreateFile(FileName: PWideChar;AccessMode, ShareMode, CreationDisposition, FlagsAndAttributes: Cardinal;var DokanFileInfo: TDokanFileInfo): Integer; stdcall;varFilePath: string;constAccessModeValues: 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');beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'CreateFile: %s', [filePath]);(*if (ShareMode = 0) and ((AccessMode and FILE_WRITE_DATA) <> 0) thenShareMode := FILE_SHARE_WRITEelseif ShareMode = 0 thenShareMode := 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 directoryif (GetFileAttributes(PChar(FilePath)) and FILE_ATTRIBUTE_DIRECTORY) <> 0 thenFlagsAndAttributes := FlagsAndAttributes or FILE_FLAG_BACKUP_SEMANTICS;if not ctory and (CreationDisposition in [CREATE_NEW, OPEN_ALWAYS, CREATE_ALWAYS]) then beginMySetFileDate(DokanFileInfo, DateTimeToFileDate(Now));end;DbgPrint(DokanFileInfo, ' FlagsAndAttributes = 0x%x', [FlagsAndAttributes]);CheckFlag(DokanFileInfo, FlagsAndAttributes, FlagsAndAttributesValues, FlagsAndAttributesNames);FmUpdateFile(FilePath, FileName);// Save the file handle in ContextMySetFileHandle(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 codesResult := -GetLastError;DbgPrint(DokanFileInfo, 'CreateFile failed, error code = %d', [-Result]);end elseResult := 0;DbgPrint(DokanFileInfo, '');end;function MirrorOpenDirectory(FileName: PWideChar;var DokanFileInfo: TDokanFileInfo): Integer; stdcall;varFilePath: string;beginFilePath := 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 beginResult := -GetLastError;DbgPrint(DokanFileInfo, 'CreateFile failed, error code = %d', [-Result]);end else beginResult := 0;end;DbgPrint(DokanFileInfo, '');end;function MirrorCreateDirectory(FileName: PWideChar;var DokanFileInfo: TDokanFileInfo): Integer; stdcall;varFilePath: string;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'CreateDirectory: %s', [FilePath]);if not CreateDirectory(PChar(FilePath), nil) then beginResult := -GetLastError;DbgPrint(DokanFileInfo, 'CreateDirectory failed, error code = %d', [-Result]);end else beginResult := 0;FmCreateDir(FilePath, FileName);end;DbgPrint(DokanFileInfo, '');end;function MirrorCleanup(FileName: PWideChar;var DokanFileInfo: TDokanFileInfo): Integer; stdcall;varFilePath: string;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'Cleanup: %s', [FilePath]);if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then beginResult := -1;DbgPrint(DokanFileInfo, 'Error: invalid handle', [FilePath]);end else begin

Result := 0;if not OnClose and not ctory and (MyGetFileDate(DokanFileInfo) > 0) then beginFlushFileBuffers(MyGetFileHandle(DokanFileInfo)); //?!end;CloseHandle(MyGetFileHandle(DokanFileInfo));MySetFileHandle(DokanFileInfo, INVALID_HANDLE_VALUE);if OnClose then beginif ctory then beginDbgPrint(DokanFileInfo, 'DeleteOnClose -> RemoveDirectory');if not RemoveDirectory(PChar(FilePath)) thenDbgPrint(DokanFileInfo, 'RemoveDirectory failed, error code = %d', [GetLastError]);end else beginFmDeleteFile(FilePath, FileName);DbgPrint(DokanFileInfo, 'DeleteOnClose -> DeleteFile');if not DeleteFile(PChar(FIlePath)) thenDbgPrint(DokanFileInfo, 'DeleteFile failed, error code = %d', [GetLastError]);end;end;if (MyGetFileDate(DokanFileInfo) > 0) and not OnClose then beginFmSaveFile(FilePath, FileName);DbgPrint(DokanFileInfo, '(%s) has modified, save it.', [FileName]);end;end;MySetFileDate(DokanFileInfo, 0);DbgPrint(DokanFileInfo, '');end;function MirrorCloseFile(FileName: PWideChar;var DokanFileInfo: TDokanFileInfo): Integer; stdcall;varFilePath: string;beginResult := 0;FilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'CloseFile: %s', [FilePath]);if MyGetFileHandle(DokanFileInfo) <> INVALID_HANDLE_VALUE then beginDbgPrint(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;varFilePath: string;Opened: Boolean;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'ReadFile: %s (Offset: %d, Length: %d)', [FilePath, Offset, NumberOfBytesToRead]);Opened := MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE;if Opened then beginDbgPrint(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 beginResult := -GetLastError;DbgPrint(DokanFileInfo, 'CreateFile failed, error code = %d', [-Result]);end elsetry

if SetFilePointerEx(MyGetFileHandle(DokanFileInfo), LARGE_INTEGER(Offset), nil, FILE_BEGIN) then beginif ReadFile(MyGetFileHandle(DokanFileInfo), Buffer, NumberOfBytesToRead, NumberOfBytesRead, nil) then beginResult := 0;DbgPrint(DokanFileInfo, 'Read: %d', [NumberOfBytesRead]);end else beginResult := -GetLastError;DbgPrint(DokanFileInfo, 'ReadFile failed, error code = %d', [-Result]);end;end else beginResult := -GetLastError;DbgPrint(DokanFileInfo, 'Seek failed, error code = %d', [-Result]);end;finallyif Opened then beginCloseHandle(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;varFilePath: string;Opened: Boolean;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'WriteFile: %s (Offset: %d, Length: %d)', [FilePath, Offset, NumberOfBytesToWrite]);Opened := MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE;if Opened then beginDbgPrint(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 beginResult := -GetLastError;DbgPrint(DokanFileInfo, 'CreateFile failed, error code = %d', [-Result]);end elsetryif not ctory and (MyGetFileDate(DokanFileInfo) = 0) then beginMySetFileDate(DokanFileInfo, FileGetDate(MyGetFileHandle(DokanFileInfo)));DbgPrint(DokanFileInfo, 'GetFileDate = %d', [MyGetFileDate(DokanFileInfo)]);end;if SetFilePointerEx(MyGetFileHandle(DokanFileInfo), LARGE_INTEGER(Offset), nil, FILE_BEGIN) then beginif WriteFile(MyGetFileHandle(DokanFileInfo), Buffer, NumberOfBytesToWrite, NumberOfBytesWritten, nil) then beginResult := 0;DbgPrint(DokanFileInfo, 'Written: %d', [NumberOfBytesWritten]);end else beginResult := -GetLastError;DbgPrint(DokanFileInfo, 'WriteFile failed, error code = %d', [-Result]);end;end else beginResult := -GetLastError;DbgPrint(DokanFileInfo, 'Seek failed, error code = %d', [-Result]);end;finallyif Opened then beginCloseHandle(MyGetFileHandle(DokanFileInfo));MySetFileHandle(DokanFileInfo, INVALID_HANDLE_VALUE);end;end;DbgPrint(DokanFileInfo, '');end;

function MirrorFlushFileBuffers(FileName: PWideChar;var DokanFileInfo: TDokanFileInfo): Integer; stdcall;varFilePath: string;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'FlushFileBuffers: %s', [FilePath]);if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then beginResult := -1;DbgPrint(DokanFileInfo, 'Error: invalid handle')end else beginif FlushFileBuffers(MyGetFileHandle(DokanFileInfo)) thenResult := 0else beginResult := -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;varFilePath: string;Opened: Boolean;FindData: WIN32_FIND_DATAA;FindHandle: THandle;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'GetFileInformation: %s', [FilePath]);Opened := MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE;if Opened then beginDbgPrint(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 beginResult := -1;DbgPrint(DokanFileInfo, 'CreateFile failed, error code = %d', [GetLastError]);end elsetryif GetFileInformationByHandle(MyGetFileHandle(DokanFileInfo), FileInformation^) thenResult := 0else beginDbgPrint(DokanFileInfo, 'GetFileInformationByHandle failed, error code = %d', [GetLastError]);if Length(FileName) = 1 then beginResult := 0;Attributes := GetFileAttributes(PChar(FilePath));end else beginZeroMemory(@FindData, SizeOf(FindData));FindHandle := FindFirstFile(PChar(FilePath), FindData);if FindHandle = INVALID_HANDLE_VALUE then beginResult := -1;DbgPrint(DokanFileInfo, 'FindFirstFile failed, error code = %d', [GetLastError]);end else beginResult := 0;Attributes := Attributes;tionTime := tionTime;AccessTime := AccessTime;WriteTime := WriteTime;izeHigh := izeHigh;izeLow := izeLow;ose(FindHandle);end;end;end;

finallyif Opened then beginCloseHandle(MyGetFileHandle(DokanFileInfo));MySetFileHandle(DokanFileInfo, INVALID_HANDLE_VALUE);end;end;DbgPrint(DokanFileInfo, '');end;function MirrorFindFiles(PathName: PWideChar;FillFindDataCallback: TDokanFillFindData;var DokanFileInfo: TDokanFileInfo): Integer; stdcall;varFilePath: widestring;FindData: WIN32_FIND_DATAW;FindHandle: THandle;beginFilePath := 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 beginResult := -1;DbgPrint(DokanFileInfo, 'FindFirstFile failed, error code = %d', [GetLastError]);end else beginResult := 0;tryFillFindDataCallback(FindData, DokanFileInfo);while FindNextFileW(FindHandle, FindData) doFillFindDataCallback(FindData, DokanFileInfo);ose(FindHandle);end;end;DbgPrint(DokanFileInfo, '');end;function MirrorSetFileAttributes(FileName: PWideChar;FileAttributes: Cardinal;var DokanFileInfo: TDokanFileInfo): Integer; stdcall;varFilePath: string;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'SetFileAttributes: %s', [FilePath]);if SetFileAttributes(PChar(FilePath), FileAttributes) thenResult := 0else beginResult := -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;varFilePath: string;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'SetFileTime: %s', [FilePath]);if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then beginResult := -1;DbgPrint(DokanFileInfo, 'Error: invalid handle');end else beginif SetFileTime(MyGetFileHandle(DokanFileInfo), CreationTime, LastAccessTime, LastWriteTime) then

Result := 0else beginResult := -GetLastError;DbgPrint(DokanFileInfo, 'SetFileTime failed, error code = %d', [-Result]);end;end;DbgPrint(DokanFileInfo, '');end;function MirrorDeleteFile(FileName: PWideChar;var DokanFileInfo: TDokanFileInfo): Integer; stdcall;varFilePath: string;beginResult := 0;FilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'DeleteFile: %s', [FilePath]);DbgPrint(DokanFileInfo, '');end;function MirrorDeleteDirectory(FileName: PWideChar;var DokanFileInfo: TDokanFileInfo): Integer; stdcall;varFilePath: string;FindData: WIN32_FIND_DATAA;FindHandle: THandle;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'DeleteDirectory: %s', [FilePath]);FindHandle := FindFirstFile(PChar(FilePath), FindData);if FindHandle = INVALID_HANDLE_VALUE then beginResult := -GetLastError;if Result = -ERROR_NO_MORE_FILES thenResult := 0elseDbgPrint(DokanFileInfo, 'FindFirstFile failed, error code = %d', [-Result]);end else beginCardinal(Result) := STATUS_DIRECTORY_NOT_EMPTY;Result := -Result;ose(FindHandle);end;if (Result = 0) or (FindHandle <> INVALID_HANDLE_VALUE) then beginFmDeleteDir(FilePath, FileName);end;DbgPrint(DokanFileInfo, '');end;function MirrorMoveFile(ExistingFileName, NewFileName: PWideChar;ReplaceExisiting: LongBool;var DokanFileInfo: TDokanFileInfo): Integer; stdcall;varExistingFilePath, NewFilePath: string;Status: Boolean;beginExistingFilePath := MirrorConvertPath(DokanFileInfo, ExistingFileName);NewFilePath := MirrorConvertPath(DokanFileInfo, NewFileName);DbgPrint(DokanFileInfo, 'MoveFile: %s -> %s', [ExistingFilePath, NewFilePath]);if MyGetFileHandle(DokanFileInfo) <> INVALID_HANDLE_VALUE then beginCloseHandle(MyGetFileHandle(DokanFileInfo));MySetFileHandle(DokanFileInfo, INVALID_HANDLE_VALUE);end;FmMoveFile(ExistingFileName, NewFileName);if ReplaceExisiting thenStatus := MoveFileEx(PChar(ExistingFilePath), PChar(NewFilePath), MOVEFILE_REPLACE_EXISTING)elseStatus := MoveFile(PChar(ExistingFilePath), PChar(NewFilePath));if Status thenResult := 0

else beginResult := -GetLastError;DbgPrint(DokanFileInfo, 'MoveFile failed, error code = %d', [-Result]);end;DbgPrint(DokanFileInfo, '');end;function MirrorSetEndOfFile(FileName: PWideChar;Length: Int64;var DokanFileInfo: TDokanFileInfo): Integer; stdcall;varFilePath: string;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'SetEndOfFile: %s', [FilePath]);if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then beginResult := -1;DbgPrint(DokanFileInfo, 'Invalid handle');end else beginif SetFilePointerEx(MyGetFileHandle(DokanFileInfo), LARGE_INTEGER(Length), nil, FILE_BEGIN) then beginif SetEndOfFile(MyGetFileHandle(DokanFileInfo)) thenResult := 0else beginResult := -GetLastError;DbgPrint(DokanFileInfo, 'SetEndOfFile failed, error code = %d', [-Result]);end;end else beginResult := -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;varFilePath: string;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'SetAllocationSize: %s', [FilePath]);if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then beginResult := -1;DbgPrint(DokanFileInfo, 'Invalid handle');end else beginif SetFilePointerEx(MyGetFileHandle(DokanFileInfo), LARGE_INTEGER(Length), nil, FILE_BEGIN) then beginif SetEndOfFile(MyGetFileHandle(DokanFileInfo)) thenResult := 0else beginResult := -GetLastError;DbgPrint(DokanFileInfo, 'SetEndOfFile failed, error code = %d', [-Result]);end;end else beginResult := -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;varFilePath: string;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'LockFile: %s', [FilePath]);

if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then beginDbgPrint(DokanFileInfo, 'Invalid handle');Result := -1;end else beginif LockFile(MyGetFileHandle(DokanFileInfo),LARGE_INTEGER(Offset).LowPart, LARGE_INTEGER(Offset).HighPart,LARGE_INTEGER(Length).LowPart, LARGE_INTEGER(Length).HighPart) thenResult := 0else beginResult := -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;varFilePath: string;beginFilePath := MirrorConvertPath(DokanFileInfo, FileName);DbgPrint(DokanFileInfo, 'UnlockFile: %s', [FilePath]);if MyGetFileHandle(DokanFileInfo) = INVALID_HANDLE_VALUE then beginDbgPrint(DokanFileInfo, 'Invalid handle');Result := -1;end else beginif UnlockFile(MyGetFileHandle(DokanFileInfo),LARGE_INTEGER(Offset).LowPart, LARGE_INTEGER(Offset).HighPart,LARGE_INTEGER(Length).LowPart, LARGE_INTEGER(Length).HighPart) thenResult := 0else beginResult := -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;varsVolume: WideString;beginResult := 0;sVolume := Format('Dokan(%s)', [MirrorConvertPath(DokanFileInfo, nil)]);if VolumeNameSize < DWord((Length(sVolume)+1) * 2) then beginResult := (Length(sVolume)+1) * 2;end else beginCopyMemory(VolumeNameBuffer, Pointer(sVolume), Length(sVolume)* 2);VolumeNameBuffer[Length(sVolume)+1] := #0;VolumeSerialNumber := $12345678; //testingend;end;function MirrorUnmount(var DokanFileInfo: TDokanFileInfo): Integer; stdcall;beginResult := 0;DbgPrint(DokanFileInfo, 'Unmount');DbgPrint(DokanFileInfo, '');end;{ TMirror Thread (for multi thread testing) }

procedure e;vari: integer;beginDokanUnmount(etter); //try to unmounti := DokanMain(FDokanOptions, FDokanOperations);if i <> DOKAN_SUCCESS thenraise (i);end;constructor (const ADirectory: string; ADrive: WideChar;{$IFNDEF CONSOLE}AHandle: THandle;{$ENDIF} ADebugMode: Boolean);beginFRootDirectory := ADirectory;with FDokanOperations do beginCreateFile := 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 := MirrorUnmountend;with FDokanOptions do beginDriveLetter := 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 routinesprocedure DbgPrint(const DokanFileInfo: TDokanFileInfo; const Message: string); overload;beginif ode then begin// if g_Err then// Writeln(ErrOutput,Message)// else{$IFDEF CONSOLE}Writeln(Message)

{$ELSE}trywith GetMirrorDrive(DokanFileInfo) do beginif FHandle > 0 then beginSendMessage(FHandle, WM_IW_LOGMSG, Integer(PChar(Message)), Length(Message));end;end;exceptend;{$ENDIF}end;end;procedure DbgPrint(const DokanFileInfo: TDokanFileInfo; const Format: string; const Args: array of const); overload;beginDbgPrint(DokanFileInfo, (Format,Args));end;function MirrorConvertPath(const DokanFileInfo: TDokanFileInfo; FileName: PWideChar): string;varpath: string;beginpath := GetMirrorDrive(DokanFileInfo).FRootDirectory;if FileName = nil then beginDbgPrint(DokanFileInfo, 'Null filename');Result := pathend elseResult := path + FileName;end;end.

// File Mapping （与远程服务端同步）unit cfFileMapping;interfaceusesWindows, 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}constWM_IW_LOGMSG = WM_USER + 1001;{$ENDIF}constcLogonID = 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(rm) then begin //for testingSendMessage(, WM_IW_LOGMSG, Integer(PChar(S)), Length(S));end;{$ENDIF}end;function FmtMapDir(const S: string): string;vari: Integer;beginResult := S;if (Result <> '') and (Result[1] in ['/', '']) then beginDelete(Result, 1, 1);end;for i := 1 to Length(Result) do beginif Result[i] = '' then beginResult[i] := '/';end;end;end;function MyDeleteDir(const vDir: string): Boolean;varfo: TSHFILEOPSTRUCT;beginFillChar(fo, SizeOf(fo), 0);with fo dobeginWnd := 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;constDIGIT = ['0'..'9'];vari: Integer;procedure ExtractNum(var vNum: Word);beginvNum := 0;while (i <= Length(S)) and (S[i] in DIGIT) do beginvNum := vNum * 10 + Ord(S[i]) - Ord('0');Inc(i);end;while (i <= Length(S)) and not(S[i] in DIGIT) do Inc(i);

end;vary, m, d, hour, mins, secs: Word;beginResult := 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);exceptend;end;{ create map dir/files }procedure CreateLocalMapping(const vDir, vName: string; vIsFile: Boolean;vSize: Int64; vLastVisitTime, vCreateTime, vLastModifyTime: TDateTime);constcNullHead = #0#0#0#0#0#0#0#0;varhFile: Integer;path: string;beginpath := IncludeTrailingBackslash(vDir) + vName;if vIsFile then beginif FileExists(path) then beginhFile := FileOpen(path, fmOpenReadWrite or fmShareDenyNone);tryif FileGetDate(hFile) < DateTimeToFileDate(vLastModifyTime) then beginFileWrite(hFile, PChar(cNullHead)^, Min(vSize, Length(cNullHead)));if vSize <> GetFileSize(hFile, nil) then begin //if SetFilePointerEx(hFile, LARGE_INTEGER(vSize), nil, FILE_BEGIN) then beginSetEndOfFile(hFile);end;end;FileSetDate(hFile, DateTimeToFileDate(vLastModifyTime));end;finallyFileClose(hFile);end;end else beginhFile := FileCreate(path);tryif SetFilePointerEx(hFile, LARGE_INTEGER(vSize), nil, FILE_BEGIN) then beginSetEndOfFile(hFile);end;FileSetDate(hFile, DateTimeToFileDate(vLastModifyTime));finallyFileClose(hFile);end;end;end else beginForceDirectories(path);hFile := FileOpen(path, fmOpenReadWrite or fmShareDenyNone);tryFileSetDate(hFile, DateTimeToFileDate(vLastModifyTime));finallyFileClose(hFile);end;end;

end;{------------------------------------------------------------------------------Public Interface------------------------------------------------------------------------------}procedure FmCreateDir(const vOriginDir, vMapDir: string);eCommand(Format('{"msgid":%d,"path":"%s"}', [cCreateDir, AnsiToUtf8(FmtMapDir(vMapDir))]));excepton E: Exception do beginLogIt(e);end;end;end;procedure FmListDir(const vOriginDir, vMapDir: string);constcDirFileFlags: array[Boolean] of Integer = (0, 1);vars: string;jsonObj, subObj: ISuperObject;jsonArray: TSuperArray;i: Integer;path: string;dirFiles: TStringList;sr: TSearchRec;idx: Integer;isFile: Boolean;begintrys := eCommand(Format('{"msgid":%d,"path":"%s"}', [cListDir, AnsiToUtf8(FmtMapDir(vMapDir))]));jsonObj := SO(Utf8ToAnsi(s));jsonArray := y;if jsonArray = nil then beginLogIt('Error: Empty Array from JSon Object.');Exit;end;dirFiles := ;try// delete obsolete directories/filesfor i := 0 to -1 do ect(jsonArray[i].S['name'], TObject(StrToIntDef(jsonArray[i].S['isfile'], 0)));end;path := IncludeTrailingBackslash(vOriginDir); := True;if FindFirst(path + '*.*', faAnyFile, sr) = 0 then tryrepeatif ( <> '.') and ( <> '..') then begin// ignore hidden & system dir/file

if (( and faHidden) = 0) or (( and faSysFile) = 0) then beginisFile := ( and faDirectory) = 0;if not (, idx) or (Integer(s[idx]) <> cDirFileFlags[isFile]) then beginif isFile then beginDeleteFile(path + );LogIt('Delete Obsolete File: ' + path + );end else beginMyDeleteDir(path + );LogIt('Delete Obsolete Folder: ' + path + );end;end;end;end;until FindNext(sr) <> 0;finallyFindClose(sr);end;

// save to localfor i := 0 to -1 do beginsubObj := 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;;end;excepton E: Exception do beginLogIt(e);end;end;end;procedure FmDeleteDir(const vOriginDir, vMapDir: string);eCommand(Format('{"msgid":%d,"path":"%s"}', [cDeleteDir, AnsiToUtf8(FmtMapDir(vMapDir))]));excepton E: Exception do beginLogIt(e);end;end;end;procedure FmUpdateFile(const vOriginFile, vMapFile: string);varstream: TFileStream;fDate: Integer;buf: string;begintryif not FileExists(vOriginFile) then Exit;stream := (vOriginFile, fmOpenReadWrite or fmShareDenyWrite);tryif > 0 then beginSetLength(buf, Min(, 8));(PChar(buf)^, Length(buf));if buf <> StringOfChar(#0, Length(buf)) then beginExit;end;on := 0;end;fDate := FileGetDate();le(Format('{"msgid":%d,"path":"%s"}', [cSendFile, AnsiToUtf8(FmtMapDir(vMapFile))]), stream);FlushFileBuffers();FileSetDate(, fDate);;end;excepton E: Exception do beginLogIt(e);end;end;end;procedure FmSaveFile(const vOriginFile, vMapFile: string);var

stream: TFileStream;fDate: Integer;begintrystream := (vOriginFile, fmOpenRead or fmShareDenyNone);tryfDate := DateTimeToFileDate(MyStrToDateTime(le(Format('{"msgid":%d,"path":"%s","size":%d}', [cReceiveFile, AnsiToUtf8(FmtMapDir(vMapFile)), ]),stream)));FileSetDate(, fDate);;end;excepton E: Exception do beginLogIt(e);end;end;end;procedure FmDeleteFile(const vOriginFile, vMapFile: string);eCommand(Format('{"msgid":%d,"path":"%s"}', [cDeleteFile, AnsiToUtf8(FmtMapDir(vMapFile))]));excepton E: Exception do beginLogIt(e);end;end;end;procedure FmMoveFile(const vOldMapFile, vNewMapFile: string);eCommand(Format('{"msgid":%d,"old":"%s","new":"%s"}',[cMoveFile, AnsiToUtf8(FmtMapDir(vOldMapFile)), AnsiToUtf8(FmtMapDir(vNewMapFile))]));excepton E: Exception do beginLogIt(e);end;end;end;end.

// Connector （通过IndyTCPClient与远程服务端通讯）unit cfConnect;interfaceusesWindows, Messages, SysUtils, Classes, Dialogs, IdBaseComponent, IdComponent,IdTCPConnection, IdTCPClient, SyncObjs, superobject;typeTCloudConnector = classprivateFLocker: TCriticalSection;FConnector: TIdTCPClient;FTimeout: Integer;FUser: string;FToken: string;function AddInternalParams(const vCmdLine: string): string;publicconstructor 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;implementationconstLF = #10;varg_CloudConnector: TCloudConnector;{ Public Functions }function CloudConnector: TCloudConnector;beginif g_CloudConnector = nil then beging_CloudConnector := ;end;Result := g_CloudConnector;end;{ Internal Functions }function Fetch(var S: string; const vDelimiter: string): string;varidx: Integer;beginidx := Pos(vDelimiter, S);if idx > 0 then beginResult := Copy(S, 1, idx -1);Delete(S, 1, idx + Length(vDelimiter) -1);end else beginResult := S;S := '';end;end;{ TCloudConnector }constructor ;beginFLocker := ;FConnector := (nil); := '127.0.0.1'; := 9288;FTimeout := 5000;end;destructor y;;;inherited;end;{ private interface }function ernalParams(const vCmdLine: string): string;varidx: Integer;begin

Result := vCmdLine;idx := LastDelimiter('}', Result);(Format(',"user":"%s","token":"%s"', [FUser, FToken]), Result, idx);end;{ public interface }procedure (const vHost: string; vPort: Integer);beginwith FConnector do beginHost := vHost;Port := vPort;end;end;procedure (const vUser, vPW: string; vTimeout: Integer);vars: string;code: Integer;superObj: ISuperObject;beginFTimeout := vTimeout;with FConnector do beginConnect(FTimeout);tryWriteLn('{"msgid":100}'); //logons := ReadLn(LF, FTimeout);code := superObj.I['result'] ;if code <> 100 then begin //process errors := superObj.S['message'];raise (Format('Error: %d - %s', [code, s]));end;FUser := vUser;FToken := superObj.S['token'];finallyDisconnect;end;end;end;function eCommand(const vCmdLine: string): string;;tryResult := '';with FConnector do beginConnect(FTimeout);tryWriteLn(AddInternalParams(vCmdLine));Result := ReadLn(LF, FTimeout);finallyDisconnect;end;end;;end;end;function le(const vCmdLine: string;vStream: TStream): Boolean;varsuperObj: ISuperObject;;trytrywith FConnector do begin

usesClasses, Windows, SysUtils;typeUTF8String = 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 on 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 accuratefunction 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 on UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer;varlen: Cardinal;beginlen := 0;if Source <> nil thenwhile Source[len] <> #0 doInc(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 accuratefunction UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal;vari, count: Cardinal;c: Cardinal;beginResult := 0;

if Source = nil then Exit;count := 0;i := 0;if Dest <> nil thenbeginwhile (i < SourceChars) and (count < MaxDestBytes) dobeginc := Cardinal(Source[i]);Inc(i);if c <= $7F thenbeginDest[count] := Char(c);Inc(count);endelse if c > $7FF thenbeginif count + 3 > MaxDestBytes thenbreak;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);endelse // $7F < Source[i] <= $7FFbeginif count + 2 > MaxDestBytes thenbreak;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;endelsebeginwhile i < SourceChars dobeginc := Integer(Source[i]);Inc(i);if c > $7F thenbeginif c > $7FF thenInc(count);Inc(count);end;Inc(count);end;end;Result := count+1; // convert zero based index to byte countend;function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer;varlen: Cardinal;beginlen := 0;if Source <> nil thenwhile Source[len] <> #0 doInc(len);Result := Utf8ToUnicode(Dest, MaxChars, Source, len);end;function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal;vari, count: Cardinal;c: Byte;

wc: Cardinal;beginif Source = nil thenbeginResult := 0;Exit;end;Result := Cardinal(-1);count := 0;i := 0;if Dest <> nil thenbeginwhile (i < SourceBytes) and (count < MaxDestChars) dobeginwc := Cardinal(Source[i]);Inc(i);if (wc and $80) <> 0 thenbeginwc := wc and $3F;if i > SourceBytes then Exit; // incomplete multibyte charif (wc and $20) <> 0 thenbeginc := Byte(Source[i]);Inc(i);if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range charif i > SourceBytes then Exit; // incomplete multibyte charwc := (wc shl 6) or (c and $3F);end;c := Byte(Source[i]);Inc(i);if (c and $C0) <> $80 then Exit; // malformed trail byteDest[count] := WideChar((wc shl 6) or (c and $3F));endelseDest[count] := WideChar(wc);Inc(count);end;if count >= MaxDestChars then count := MaxDestChars-1;Dest[count] := #0;endelsebeginwhile (i <= SourceBytes) dobeginc := Byte(Source[i]);Inc(i);if (c and $80) <> 0 thenbeginif (c and $F0) = $F0 then Exit; // too many bytes for UCS2if (c and $40) = 0 then Exit; // malformed lead byteif i > SourceBytes then Exit; // incomplete multibyte charif (Byte(Source[i]) and $C0) <> $80 then Exit; // malformed trail byteInc(i);if i > SourceBytes then Exit; // incomplete multibyte charif ((c and $20) <> 0) and ((Byte(Source[i]) and $C0) <> $80) then Exit; // malformed trail byteInc(i);end;Inc(count);end;end;Result := count+1;end;function Utf8Encode(const WS: WideString): UTF8String;varL: Integer;

Temp: UTF8String;beginResult := '';if WS = '' then Exit;SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminatorL := UnicodeToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS));if L > 0 thenSetLength(Temp, L-1)elseTemp := '';Result := Temp;end;function Utf8Decode(const S: UTF8String): WideString;varL: Integer;Temp: WideString;beginResult := '';if S = '' then Exit;SetLength(Temp, Length(S));L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S));if L > 0 thenSetLength(Temp, L-1)elseTemp := '';Result := Temp;end;function AnsiToUtf8(const S: string): UTF8String;beginResult := Utf8Encode(S);end;function Utf8ToAnsi(const S: UTF8String): string;beginResult := Utf8Decode(S);end;function AnsiToUtf8Xml(const S: string): UTF8String;var //only process '&', ... ´ ...i: Integer;beginResult := S;i := 1;while i <= Length(Result) do begincase Result[i] of'&': beginInsert('amp;', Result, i+1);Inc(i, 4);end;'>': beginResult[i] := '&';Insert('gt;', Result, i+1);Inc(i, 3);end;'<': beginResult[i] := '&';Insert('lt;', Result, i+1);Inc(i, 3);end;'"': beginResult[i] := '&';Insert('quot;', Result, i+1);Inc(i, 5);end;

'''': beginResult[i] := '&';Insert('apos;', Result, i+1);Inc(i, 5);end;#128..#255: //process wearer′s ′=´beginInsert('#x' + IntToHex(Ord(Result[i]), 2) + ';', Result, i+1);Result[i] := '&';Inc(i, 5);end;end;Inc(i);end;Result := AnsiToUtf8(Result);end;end.