diff options
author | Matth?us G. Chajdas <dev@anteru.net> | 2019-11-10 13:56:53 +0100 |
---|---|---|
committer | Matth?us G. Chajdas <dev@anteru.net> | 2019-11-10 13:56:53 +0100 |
commit | 1dd3124a9770e11b6684e5dd1e6bc15a0aa3bc67 (patch) | |
tree | 87a171383266dd1f64196589af081bc2f8e497c3 /tests/examplefiles/test.pas | |
parent | f1c080e184dc1bbc36eaa7cd729ff3a499de568a (diff) | |
download | pygments-master.tar.gz |
Diffstat (limited to 'tests/examplefiles/test.pas')
-rw-r--r-- | tests/examplefiles/test.pas | 743 |
1 files changed, 0 insertions, 743 deletions
diff --git a/tests/examplefiles/test.pas b/tests/examplefiles/test.pas deleted file mode 100644 index 2724bbfd..00000000 --- a/tests/examplefiles/test.pas +++ /dev/null @@ -1,743 +0,0 @@ -// -// Sourcecode from http://www.delphi-library.de/topic_47880.html -// -uses Windows, Messages; - -const - FFM_INIT = WM_USER + 1976; - FFM_ONFILEFOUND = WM_USER + 1974; // wParam: not used, lParam: Filename - FFM_ONDIRFOUND = WM_USER + 1975; // wParam: NumFolder, lParam: Directory -var - CntFolders : Cardinal = 0; - NumFolder : Cardinal = 0; - - -//////////////////////////////////////////////////////////////////////////////// -// -// FindAllFilesInit -// -// -procedure FindAllFilesInit; external; -label foo; -begin - CntFolders := 0; - NumFolder := 0; -foo: - Blub; - goto foo; -end; - -//////////////////////////////////////////////////////////////////////////////// -// -// CountFolders -// -// -procedure CountFolders(Handle: THandle; RootFolder: string; Recurse: Boolean = True); -var - hFindFile : THandle; - wfd : TWin32FindData; -begin - SendMessage(Handle, FFM_INIT, 0, 0); - if RootFolder[length(RootFolder)] <> '\' then - RootFolder := RootFolder + '\'; - ZeroMemory(@wfd, sizeof(wfd)); - wfd.dwFileAttributes := FILE_ATTRIBUTE_NORMAL; - if Recurse then - begin - hFindFile := FindFirstFile(pointer(RootFolder + '*.*'), wfd); - if hFindFile <> 0 then - try - repeat - if wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = FILE_ATTRIBUTE_DIRECTORY then - begin - if (string(wfd.cFileName) <> '.') and (string(wfd.cFileName) <> '..') then - begin - CountFolders(Handle, RootFolder + wfd.cFileName, Recurse); - end; - end; - until FindNextFile(hFindFile, wfd) = False; - Inc(CntFolders); - finally - Windows.FindClose(hFindFile); - end; - end; -end; - -//////////////////////////////////////////////////////////////////////////////// -// -// FindAllFiles -// -procedure FindAllFiles(Handle: THandle; RootFolder: string; Mask: string; Recurse: Boolean = True); -var - hFindFile : THandle; - wfd : TWin32FindData; -begin - if RootFolder[length(RootFolder)] <> '\' then - RootFolder := RootFolder + '\'; - ZeroMemory(@wfd, sizeof(wfd)); - wfd.dwFileAttributes := FILE_ATTRIBUTE_NORMAL; - if Recurse then - begin - hFindFile := FindFirstFile(pointer(RootFolder + '*.*'), wfd); - if hFindFile <> 0 then - try - repeat - if wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = FILE_ATTRIBUTE_DIRECTORY then - begin - if (string(wfd.cFileName) <> '.') and (string(wfd.cFileName) <> '..') then - begin - FindAllFiles(Handle, RootFolder + wfd.cFileName, Mask, Recurse); - end; - end; - until FindNextFile(hFindFile, wfd) = False; - Inc(NumFolder); - SendMessage(Handle, FFM_ONDIRFOUND, NumFolder, lParam(string(RootFolder))); - finally - Windows.FindClose(hFindFile); - end; - end; - hFindFile := FindFirstFile(pointer(RootFolder + Mask), wfd); - if hFindFile <> INVALID_HANDLE_VALUE then - try - repeat - if (wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> FILE_ATTRIBUTE_DIRECTORY) then - begin - SendMessage(Handle, FFM_ONFILEFOUND, 0, lParam(string(RootFolder + wfd.cFileName))); - end; - until FindNextFile(hFindFile, wfd) = False; - finally - Windows.FindClose(hFindFile); - end; -end; - - -property test: boolean read ftest write ftest; -procedure test: boolean read ftest write ftest; - -// -// This sourcecode is part of omorphia -// - -Function IsValidHandle(Const Handle: THandle): Boolean; {$IFDEF OMORPHIA_FEATURES_USEASM} Assembler; -Asm - TEST EAX, EAX - JZ @@Finish - NOT EAX - TEST EAX, EAX - SETNZ AL - - {$IFDEF WINDOWS} - JZ @@Finish - - //Save the handle against modifications or loss - PUSH EAX - - //reserve some space for a later duplicate - PUSH EAX - - //Check if we are working on NT-Platform - CALL IsWindowsNTSystem - TEST EAX, EAX - JZ @@NoNTSystem - - PUSH DWORD PTR [ESP] - LEA EAX, DWORD PTR [ESP+$04] - PUSH EAX - CALL GetHandleInformation - TEST EAX, EAX - JNZ @@Finish2 - -@@NoNTSystem: - //Result := DuplicateHandle(GetCurrentProcess, Handle, GetCurrentProcess, - // @Duplicate, 0, False, DUPLICATE_SAME_ACCESS); - PUSH DUPLICATE_SAME_ACCESS - PUSH $00000000 - PUSH $00000000 - LEA EAX, DWORD PTR [ESP+$0C] - PUSH EAX - CALL GetCurrentProcess - PUSH EAX - PUSH DWORD PTR [ESP+$18] - PUSH EAX - CALL DuplicateHandle - - TEST EAX, EAX - JZ @@Finish2 - - // Result := CloseHandle(Duplicate); - PUSH DWORD PTR [ESP] - CALL CloseHandle - -@@Finish2: - POP EDX - POP EDX - - PUSH EAX - PUSH $00000000 - CALL SetLastError - POP EAX - {$ENDIF} - -@@Finish: -End; -{$ELSE} -Var - Duplicate: THandle; - Flags: DWORD; -Begin - If IsWinNT Then - Result := GetHandleInformation(Handle, Flags) - Else - Result := False; - If Not Result Then - Begin - // DuplicateHandle is used as an additional check for those object types not - // supported by GetHandleInformation (e.g. according to the documentation, - // GetHandleInformation doesn't support window stations and desktop although - // tests show that it does). GetHandleInformation is tried first because its - // much faster. Additionally GetHandleInformation is only supported on NT... - Result := DuplicateHandle(GetCurrentProcess, Handle, GetCurrentProcess, - @Duplicate, 0, False, DUPLICATE_SAME_ACCESS); - If Result Then - Result := CloseHandle(Duplicate); - End; -End; -{$ENDIF} - - - - -{*******************************************************} -{ } -{ Delphi Supplemental Components } -{ ZLIB Data Compression Interface Unit } -{ } -{ Copyright (c) 1997 Borland International } -{ } -{*******************************************************} - -{ Modified for zlib 1.1.3 by Davide Moretti <dave@rimini.com } - -unit zlib; - -interface - -uses Sysutils, Classes; - -type - TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer; - TFree = procedure (AppData, Block: Pointer); - - // Internal structure. Ignore. - TZStreamRec = packed record - next_in: PChar; // next input byte - avail_in: Integer; // number of bytes available at next_in - total_in: Integer; // total nb of input bytes read so far - - next_out: PChar; // next output byte should be put here - avail_out: Integer; // remaining free space at next_out - total_out: Integer; // total nb of bytes output so far - - msg: PChar; // last error message, NULL if no error - internal: Pointer; // not visible by applications - - zalloc: TAlloc; // used to allocate the internal state - zfree: TFree; // used to free the internal state - AppData: Pointer; // private data object passed to zalloc and zfree - - data_type: Integer; // best guess about the data type: ascii or binary - adler: Integer; // adler32 value of the uncompressed data - reserved: Integer; // reserved for future use - end; - - // Abstract ancestor class - TCustomZlibStream = class(TStream) - private - FStrm: TStream; - FStrmPos: Integer; - FOnProgress: TNotifyEvent; - FZRec: TZStreamRec; - FBuffer: array [Word] of Char; - protected - procedure Progress(Sender: TObject); dynamic; - property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; - constructor Create(Strm: TStream); - end; - -{ TCompressionStream compresses data on the fly as data is written to it, and - stores the compressed data to another stream. - - TCompressionStream is write-only and strictly sequential. Reading from the - stream will raise an exception. Using Seek to move the stream pointer - will raise an exception. - - Output data is cached internally, written to the output stream only when - the internal output buffer is full. All pending output data is flushed - when the stream is destroyed. - - The Position property returns the number of uncompressed bytes of - data that have been written to the stream so far. - - CompressionRate returns the on-the-fly percentage by which the original - data has been compressed: (1 - (CompressedBytes / UncompressedBytes)) * 100 - If raw data size = 100 and compressed data size = 25, the CompressionRate - is 75% - - The OnProgress event is called each time the output buffer is filled and - written to the output stream. This is useful for updating a progress - indicator when you are writing a large chunk of data to the compression - stream in a single call.} - - - TCompressionLevel = (clNone, clFastest, clDefault, clMax); - - TCompressionStream = class(TCustomZlibStream) - private - function GetCompressionRate: Single; - public - constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream); - destructor Destroy; override; - function Read(var Buffer; Count: Longint): Longint; override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; - property CompressionRate: Single read GetCompressionRate; - property OnProgress; - end; - -{ TDecompressionStream decompresses data on the fly as data is read from it. - - Compressed data comes from a separate source stream. TDecompressionStream - is read-only and unidirectional; you can seek forward in the stream, but not - backwards. The special case of setting the stream position to zero is - allowed. Seeking forward decompresses data until the requested position in - the uncompressed data has been reached. Seeking backwards, seeking relative - to the end of the stream, requesting the size of the stream, and writing to - the stream will raise an exception. - - The Position property returns the number of bytes of uncompressed data that - have been read from the stream so far. - - The OnProgress event is called each time the internal input buffer of - compressed data is exhausted and the next block is read from the input stream. - This is useful for updating a progress indicator when you are reading a - large chunk of data from the decompression stream in a single call.} - - TDecompressionStream = class(TCustomZlibStream) - public - constructor Create(Source: TStream); - destructor Destroy; override; - function Read(var Buffer; Count: Longint): Longint; override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; - property OnProgress; - end; - - - -{ CompressBuf compresses data, buffer to buffer, in one call. - In: InBuf = ptr to compressed data - InBytes = number of bytes in InBuf - Out: OutBuf = ptr to newly allocated buffer containing decompressed data - OutBytes = number of bytes in OutBuf } -procedure CompressBuf(const InBuf: Pointer; InBytes: Integer; - out OutBuf: Pointer; out OutBytes: Integer); - - -{ DecompressBuf decompresses data, buffer to buffer, in one call. - In: InBuf = ptr to compressed data - InBytes = number of bytes in InBuf - OutEstimate = zero, or est. size of the decompressed data - Out: OutBuf = ptr to newly allocated buffer containing decompressed data - OutBytes = number of bytes in OutBuf } -procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer; - OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer); - -const - zlib_version = '1.1.3'; - -type - EZlibError = class(Exception); - ECompressionError = class(EZlibError); - EDecompressionError = class(EZlibError); - -function adler32(adler: Integer; buf: PChar; len: Integer): Integer; - -implementation - -const - Z_NO_FLUSH = 0; - Z_PARTIAL_FLUSH = 1; - Z_SYNC_FLUSH = 2; - Z_FULL_FLUSH = 3; - Z_FINISH = 4; - - Z_OK = 0; - Z_STREAM_END = 1; - Z_NEED_DICT = 2; - Z_ERRNO = (-1); - Z_STREAM_ERROR = (-2); - Z_DATA_ERROR = (-3); - Z_MEM_ERROR = (-4); - Z_BUF_ERROR = (-5); - Z_VERSION_ERROR = (-6); - - Z_NO_COMPRESSION = 0; - Z_BEST_SPEED = 1; - Z_BEST_COMPRESSION = 9; - Z_DEFAULT_COMPRESSION = (-1); - - Z_FILTERED = 1; - Z_HUFFMAN_ONLY = 2; - Z_DEFAULT_STRATEGY = 0; - - Z_BINARY = 0; - Z_ASCII = 1; - Z_UNKNOWN = 2; - - Z_DEFLATED = 8; - - _z_errmsg: array[0..9] of PChar = ( - 'need dictionary', // Z_NEED_DICT (2) - 'stream end', // Z_STREAM_END (1) - '', // Z_OK (0) - 'file error', // Z_ERRNO (-1) - 'stream error', // Z_STREAM_ERROR (-2) - 'data error', // Z_DATA_ERROR (-3) - 'insufficient memory', // Z_MEM_ERROR (-4) - 'buffer error', // Z_BUF_ERROR (-5) - 'incompatible version', // Z_VERSION_ERROR (-6) - '' - ); - -{$L deflate.obj} -{$L inflate.obj} -{$L inftrees.obj} -{$L trees.obj} -{$L adler32.obj} -{$L infblock.obj} -{$L infcodes.obj} -{$L infutil.obj} -{$L inffast.obj} - -procedure _tr_init; external; -procedure _tr_tally; external; -procedure _tr_flush_block; external; -procedure _tr_align; external; -procedure _tr_stored_block; external; -function adler32; external; -procedure inflate_blocks_new; external; -procedure inflate_blocks; external; -procedure inflate_blocks_reset; external; -procedure inflate_blocks_free; external; -procedure inflate_set_dictionary; external; -procedure inflate_trees_bits; external; -procedure inflate_trees_dynamic; external; -procedure inflate_trees_fixed; external; -procedure inflate_codes_new; external; -procedure inflate_codes; external; -procedure inflate_codes_free; external; -procedure _inflate_mask; external; -procedure inflate_flush; external; -procedure inflate_fast; external; - -procedure _memset(P: Pointer; B: Byte; count: Integer);cdecl; -begin - FillChar(P^, count, B); -end; - -procedure _memcpy(dest, source: Pointer; count: Integer);cdecl; -begin - Move(source^, dest^, count); -end; - - - -// deflate compresses data -function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; - recsize: Integer): Integer; external; -function deflate(var strm: TZStreamRec; flush: Integer): Integer; external; -function deflateEnd(var strm: TZStreamRec): Integer; external; - -// inflate decompresses data -function inflateInit_(var strm: TZStreamRec; version: PChar; - recsize: Integer): Integer; external; -function inflate(var strm: TZStreamRec; flush: Integer): Integer; external; -function inflateEnd(var strm: TZStreamRec): Integer; external; -function inflateReset(var strm: TZStreamRec): Integer; external; - - -function zcalloc(AppData: Pointer; Items, Size: Integer): Pointer; -begin - GetMem(Result, Items*Size); -end; - -procedure zcfree(AppData, Block: Pointer); -begin - FreeMem(Block); -end; - -function zlibCheck(code: Integer): Integer; -begin - Result := code; - if code < 0 then - raise EZlibError.Create('error'); //!! -end; - -function CCheck(code: Integer): Integer; -begin - Result := code; - if code < 0 then - raise ECompressionError.Create('error'); //!! -end; - -function DCheck(code: Integer): Integer; -begin - Result := code; - if code < 0 then - raise EDecompressionError.Create('error'); //!! -end; - -procedure CompressBuf(const InBuf: Pointer; InBytes: Integer; - out OutBuf: Pointer; out OutBytes: Integer); -var - strm: TZStreamRec; - P: Pointer; -begin - FillChar(strm, sizeof(strm), 0); - OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255; - GetMem(OutBuf, OutBytes); - try - strm.next_in := InBuf; - strm.avail_in := InBytes; - strm.next_out := OutBuf; - strm.avail_out := OutBytes; - CCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm))); - try - while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do - begin - P := OutBuf; - Inc(OutBytes, 256); - ReallocMem(OutBuf, OutBytes); - strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P))); - strm.avail_out := 256; - end; - finally - CCheck(deflateEnd(strm)); - end; - ReallocMem(OutBuf, strm.total_out); - OutBytes := strm.total_out; - except - FreeMem(OutBuf); - raise - end; -end; - - -procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer; - OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer); -var - strm: TZStreamRec; - P: Pointer; - BufInc: Integer; -begin - FillChar(strm, sizeof(strm), 0); - BufInc := (InBytes + 255) and not 255; - if OutEstimate = 0 then - OutBytes := BufInc - else - OutBytes := OutEstimate; - GetMem(OutBuf, OutBytes); - try - strm.next_in := InBuf; - strm.avail_in := InBytes; - strm.next_out := OutBuf; - strm.avail_out := OutBytes; - DCheck(inflateInit_(strm, zlib_version, sizeof(strm))); - try - while DCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END do - begin - P := OutBuf; - Inc(OutBytes, BufInc); - ReallocMem(OutBuf, OutBytes); - strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P))); - strm.avail_out := BufInc; - end; - finally - DCheck(inflateEnd(strm)); - end; - ReallocMem(OutBuf, strm.total_out); - OutBytes := strm.total_out; - except - FreeMem(OutBuf); - raise - end; -end; - - -// TCustomZlibStream - -constructor TCustomZLibStream.Create(Strm: TStream); -begin - inherited Create; - FStrm := Strm; - FStrmPos := Strm.Position; -end; - -procedure TCustomZLibStream.Progress(Sender: TObject); -begin - if Assigned(FOnProgress) then FOnProgress(Sender); -end; - - -// TCompressionStream - -constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel; - Dest: TStream); -const - Levels: array [TCompressionLevel] of ShortInt = - (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION); -begin - inherited Create(Dest); - FZRec.next_out := FBuffer; - FZRec.avail_out := sizeof(FBuffer); - CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec))); -end; - -destructor TCompressionStream.Destroy; -begin - FZRec.next_in := nil; - FZRec.avail_in := 0; - try - if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; - while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END) - and (FZRec.avail_out = 0) do - begin - FStrm.WriteBuffer(FBuffer, sizeof(FBuffer)); - FZRec.next_out := FBuffer; - FZRec.avail_out := sizeof(FBuffer); - end; - if FZRec.avail_out < sizeof(FBuffer) then - FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out); - finally - deflateEnd(FZRec); - end; - inherited Destroy; -end; - -function TCompressionStream.Read(var Buffer; Count: Longint): Longint; -begin - raise ECompressionError.Create('Invalid stream operation'); -end; - -function TCompressionStream.Write(const Buffer; Count: Longint): Longint; -begin - FZRec.next_in := @Buffer; - FZRec.avail_in := Count; - if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; - while (FZRec.avail_in > 0) do - begin - CCheck(deflate(FZRec, 0)); - if FZRec.avail_out = 0 then - begin - FStrm.WriteBuffer(FBuffer, sizeof(FBuffer)); - FZRec.next_out := FBuffer; - FZRec.avail_out := sizeof(FBuffer); - FStrmPos := FStrm.Position; - Progress(Self); - end; - end; - Result := Count; -end; - -function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint; -begin - if (Offset = 0) and (Origin = soFromCurrent) then - Result := FZRec.total_in - else - raise ECompressionError.Create('Invalid stream operation'); -end; - -function TCompressionStream.GetCompressionRate: Single; -begin - if FZRec.total_in = 0 then - Result := 0 - else - Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0; -end; - - -// TDecompressionStream - -constructor TDecompressionStream.Create(Source: TStream); -begin - inherited Create(Source); - FZRec.next_in := FBuffer; - FZRec.avail_in := 0; - DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec))); -end; - -destructor TDecompressionStream.Destroy; -begin - inflateEnd(FZRec); - inherited Destroy; -end; - -function TDecompressionStream.Read(var Buffer; Count: Longint): Longint; -begin - FZRec.next_out := @Buffer; - FZRec.avail_out := Count; - if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; - while (FZRec.avail_out > 0) do - begin - if FZRec.avail_in = 0 then - begin - FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer)); - if FZRec.avail_in = 0 then - begin - Result := Count - FZRec.avail_out; - Exit; - end; - FZRec.next_in := FBuffer; - FStrmPos := FStrm.Position; - Progress(Self); - end; - DCheck(inflate(FZRec, 0)); - end; - Result := Count; -end; - -function TDecompressionStream.Write(const Buffer; Count: Longint): Longint; -begin - raise EDecompressionError.Create('Invalid stream operation'); -end; - -function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint; -var - I: Integer; - Buf: array [0..4095] of Char; -begin - if (Offset = 0) and (Origin = soFromBeginning) then - begin - DCheck(inflateReset(FZRec)); - FZRec.next_in := FBuffer; - FZRec.avail_in := 0; - FStrm.Position := 0; - FStrmPos := 0; - end - else if ( (Offset >= 0) and (Origin = soFromCurrent)) or - ( ((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then - begin - if Origin = soFromBeginning then Dec(Offset, FZRec.total_out); - if Offset > 0 then - begin - for I := 1 to Offset div sizeof(Buf) do - ReadBuffer(Buf, sizeof(Buf)); - ReadBuffer(Buf, Offset mod sizeof(Buf)); - end; - end - else - raise EDecompressionError.Create('Invalid stream operation'); - Result := FZRec.total_out; -end; - -end. |