February 25, 2014

Automate Word document print using Delphi

Automating Microsoft office Word from Delphi is really easy. I already blogged on the subject. This time, I will show you how to select a specific printer in your Delphi application and instruct Word to use that printer.


Using Delphi, create a new VCL forms application and drop a TComboBox, a TButton and a TWordApplication. Add the unit Printers to the uses clause. In the FormShow event handler, we will fill the combobox with the available printers:
?
1
2
3
4
5
procedure TForm1.FormShow(Sender: TObject);
begin
    ComboBox1.Items     := Printer.Printers;
    ComboBox1.ItemIndex := Printer.PrinterIndex;
end;
In the button's OnClick event handler, add the following code:
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
procedure TForm1.Button1Click(Sender: TObject);
var
    ADoc : _Document;
begin
    WordApplication1.Connect;
    WordApplication1.Visible := TRUE;
    ADoc := WordApplication1.Documents.Add(emptyParam,
                                        emptyParam, emptyParam, emptyParam);
    WordApplication1.Selection.Text := 'Embarcadero Delphi Rocks !' + #13 +
                                       'http://www.overbyte.be' + #13#10;
    WordApplication1.ActivePrinter := ComboBox1.Text;
    WordApplication1.PrintOut;
    WordApplication1.Disconnect;
end;
This code connect the application to Microsoft Word, launching Word if required. It makes Word visible on screen (by default it is not shown). It then insert some nice text in the document. To select the printer Word must use, it is enough to assign the property ActivePrinter with the name of the printer. We pick the name from the combobox. Finally, the document is printed out and the application disconnect from Word. That's it!


Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
Posted by at 1 comment:
Labels: , , , , , , ,

February 22, 2014

Coding in Delphi

Coding in Delphi is a new programming book by Nick Hodges that covers a variety of powerful Delphi programming features and techniques including Generics, Interfaces, Exception, Handling, Anonymous Methods, Collections, RTTI, Enumerators, Attributes, Dependency Injection and Unit Testing.

Available on paper from here.



Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
This article is available from http://francois-piette.blogspot.be
Posted by at No comments:
Labels: ,

HowTo: Create a DCR file for your Delphi component

When you create a component for Delphi, you need a bitmap to represent your component in the component palette. This bitmap must be saved as a DCR file and linked into the component package. DCR stands for Delphi Component Resource. It is a binary resource file (RES) renamed to DCR.


In the old days, Delphi was delivered with a simple image editor which let you draw your bitmap and create the DCR file. The last version which included that tool was Delphi 7 if memory serves me well.

Now, you have to use a "paint" program to build your bitmap. Any will do provided it is able to produce Windows bitmap file (BMP) with a 24x24 pixels image having 16 or 256 colors. Windows "Paint" is enough for that.

Then you must transform that bitmap into a DCR file which is easy using any "resource compiler" program. Delphi is delivered with one named BRCC32. A resource compiler produce a RES file.

A resource compiler takes a resource script as a source file (RC). This is a text file containing commands to describe the resource you want to build. There are many kind of resources that can be included in a resource file. Here we are only interested in a bitmap resource.

Assuming be are building a component whose class name is TDemoComponent and that the source code is in DemoComponent.pas, we need to create a DemoComponent.dcr resource file containing a bitmap resource named TDemoComponent. We thus need to create DemoComponent.bmp bitmap and DemoComponent.rc resource script.

?
1
TDemoComponent BITMAP "DemoComponent.bmp"

Then we run BRCC32 with the following command line:

?
1
brcc32 -fo"DemoComponent.dcr" "DemoComponent.rc"

The resulting file has to be included in the package source file (DPK) containing the component. This is done by adding a single line into the dpk:

?
1
{$R 'SimpleComponent.dcr'}

Usually you add this line right after the existing line

?
1
{$R *.res}

Summary of required files:

FilenameDescriptionHow
DemoComponent.pasComponent source codeYou create this with Delphi
DemoComponent.bmpComponent bitmapYou create this with Windows Paint
DemoComponent.rcResource scriptYou create this with NotePad
DemoComponent.dcrBinary resource fileYou use BRCC32 to create it

This works for VCL and FireMonkey components. Visual and non visual components.

It is likely that you want to automate the process. Easy! Just add the BRCC32 command shown above in your package project option. Add it to the "Build Events" for target "All configurations", "Pre-build events". That's it. Doing this way, your DCR file will be recreated at each build. This takes time but BRCC32 is blazing fast at compiling a so simple RC file. Whenever you change the bitmap, just recompile/install the package and the updated bitmap will be shown.


Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
This article is available from http://francois-piette.blogspot.be
Posted by at 9 comments:
Labels: , , ,

February 16, 2014

In memory message logging

Message logging is a common activity used for either keeping track of what happens in an application or for debugging purpose.

Recently, I was developing a real time communication system which experimented strange errors. To find out what was happening, I decided to log all kind of informations that where available during the execution. After an error, I analyzed the message log and I eventually could determine what the error was.

But this was not so simple, actually. On a real time system, many errors come from that fact that concurrency is not handled correctly. When badly coded, an error may occur when two of more parts of the system (threads or asynchronous operation) are doing something simultaneously. When you introduce a message logging system, you also introduce some perturbation to the actual process and maybe your error goes away simply because the system is slowly writing messages to the log.

To solve this issue, instead of using my good old logging class, I have designed a brand new one. This new logging class stores all messages in pre-allocated memory for faster access. Of course the class also offers the feature of saving the recorded messages in a text file.

The class has been made “thread safe”. It means the methods can be called not only from the thread which created the class instance in the first place, but by any worker thread. The class takes care of writing message in the correct order without inserting a message from one thread in the middle of the message from another thread.

I just said that memory was pre-allocated. Actually this is more complex than that. I created a linked list of “buffers” to store messages. Buffers are of arbitrary size (more on this later). A new buffer is added to the linked list automatically when the current one is filled.

Buffers are removed from the list once they have been written to a file. But instead of freeing the buffer, it is moved to a list of available buffers where it is available when a new buffer is required. So before allocating a new buffer, the available buffer list is checked to reuse an existing buffer, avoiding the memory allocation.


Writing to the file is straightforward. It is done by iterating thru the linked list of buffers, writing each one to the file and then moving the buffer to the available buffer list.

Multithreading safety is achieved by using two critical sections. One protects the linked lists of buffers and the other make sure only one write to file take place at a time.

Usage


You create a variable to hold the class instance. This variable can have any scope but it is likely a global variable so that in can be used from anywhere, including initialization and finalization sections of units.

?
1
2
var
    GLog : TInMemoryLogger;

You create the object instance the same way as usual. If you selected a global variable, it is likely you create it from the initialization section of unit. You’ll make sure to put the unit in front of other units in the project source file so that it is initialized the first and makes the logger available for other units.

The code looks like this:

?
1
2
3
4
5
6
7
8
9
10
11
initialization
    CompanyFolder   := 'OverByte';
    GLog            := TInMemoryLogger.Create(nil);
    GLog.BufferSize := 4096;
    GLog.SetDefaultFileName;
    GLog.Options    := GLog.Options +
                       [imloAddCRLF,         // Add a CRLF at end of each Log()
                        imloAddDate,         // Add a date in front of each log()
                        imloAddTime,         // Add a time in front of each log()
                        imloAddTimeMSec,     // Add millisecond to time
                        imloFlushOnDestroy]; // Flush to file when destroyed

TInmemoryLogger is actually a component which could be installed and dropped onto a form. Here I use it as a simple class to the constructor takes a nil argument.

The then buffer size is initialized. This is the size in bytes for one buffer which will be part of the linked list. Any size is OK. Selecting a small size forces more allocations (once). Selecting a larger one uses less allocations but make flushing to disk a little bit heavier.

SetDefautFileName assign the filename for flushing the buffer to disk. It builds the file name from the executable file name and put the file in the user profile in Local\AppData branch, in a folder with your company name. Hence the variable “CompanyFolder” used to specify that name. Of course you may also initialize the FileName property with anything you like to store the file exactly where you like.

Finally, there are a number of options which are self-explanatory. Add or remove the options according to your needs and preferences.

Then to use the logger, you just call his Log() method, passing a string:

?
1
GLog.Log(‘This is my demo message’);

If you use a global variable and plan to use it from anywhere, it is better to encapsulate the Log method into a global Log procedure which will take care of the variable being created or destroyed. You’ll avoid many access violations if you don’t master initialization/finalization unit order.

?
1
2
3
4
5
procedure Log(const Msg : String);
begin
    if Assigned(GLog) then
        GLog.Log(Msg);
end;

When doing that, it is better to move the GLog variable to the unit implementation section so that it is not available from anywhere else.

Likely, you’ll create a wrapper procedure to flush the buffers to disk file and for any other access to the class members.

?
1
2
3
4
5
procedure LogFlush;
begin
    if Assigned(GLog) then
        GLog.FlushToFile;
end;


Implementation


The logger is made of two classes: the first one is TInMemoryLogger we saw the use above, the second is the class used to encapsulate a buffer.

Let’s have a look at TInMemoryChunk, the class encapsulating a buffer. It is quite simple. It is manly build around the memory used for storing data. I use a TBytes data type (Dynamic array of bytes). I also use a variable to store the buffer size, even if this could be derived from the array size because it is faster. Then there is an integer to count how many bytes have already been written to the buffer. Finally there is a reference to the next buffer to make the linked list of buffers.

There is a single method named “Write”. It is used to store a message to the buffer. The message is passed as a string argument. Passed also as a var parameter is the number of bytes actually written to the buffer. The method returns the last buffer used to store the message. A large message could be split into several buffers which are created as needed. The method always returns the last buffer used. The main class uses this returned value to update the linked list head.

As I said in the introduction, buffer are allocated once and not freed when emptied. Instead they are move to a list of available buffers for later reuse. TInMemoryChunk has to acquire a buffer from this available buffer list. The list in maintained by the main class and as such is inaccessible from TInMemoryChunk. The implementation makes use of an event that TInMemoryChunk triggers when a free buffer is required. The main class implements a handler for that event which will get a buffer from the available buffer list, or create a new one if no available buffer exists.

All in all, here is the class declaration:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
TInMemoryChunk = class(TObject)
strict private
    FBuffer         : TBytes;
    FBufferSize     : Integer;
    FBufferNext     : TInMemoryChunk;
    FWriteCount     : Integer;
    FOnAcquireChunk : TInMemoryChunkAcquireEvent;
    function  AcquireChunk : TInMemoryChunk;
public
    constructor Create(Size : Integer);
    function Write(const Msg       : String;
                   var   ByteCount : Integer) : TInMemoryChunk;
    property Buffer         : TBytes                  read  FBuffer
                                                      write FBuffer;
    property BufferNext     : TInMemoryChunk          read  FBufferNext
                                                      write FBufferNext;
    property BufferSize     : Integer                 read  FBufferSize
                                                      write FBufferSize;
    property WriteCount     : Integer                 read  FWriteCount
                                                      write FWriteCount;
    property OnAcquireChunk : TInMemoryChunkAcquireEvent
                                                      read  FOnAcquireChunk
                                                      write FOnAcquireChunk;
end;

You will recognize all the member variables I talked above, as well as their corresponding properties declarations. This is quite canonical and opens the door to easy customization.

Actual implementation code is really straightforward:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
constructor TInMemoryChunk.Create(Size: Integer);
begin
    if Size < 16 then
        raise EInMemoryRangeException.Create(ERROR_MSG_SIZE_TO_LOW);
    FWriteCount := 0;
    FBufferNext := nil;
    FBufferSize := Size;
    SetLength(FBuffer, FBufferSize);
end;
 
 
function TInMemoryChunk.AcquireChunk: TInMemoryChunk;
begin
    Result := nil;
    if Assigned(FOnAcquireChunk) then
        FOnAcquireChunk(Self, Result);
end;
 
 
// Write a msg into the buffer, allocating a new one if required
// Returns the last buffer used (The current one or the new allocated)
function TInMemoryChunk.Write(
    const Msg       : String;
    var   ByteCount : Integer) : TInMemoryChunk;
var
    I          : Integer;
    Len        : Integer;
    AvailBytes : Integer;
    NewBuffer  : TInMemoryChunk;
begin
    Result := Self;
    Len := Length(Msg);
    if Len <= 0 then
        Exit;
    AvailBytes := Result.BufferSize - Result.WriteCount;
    I          := Low(Msg);
    while I <= High(Msg) do begin
        // Simple and incorrect unicode to ascii conversion
        Result.Buffer[Result.WriteCount] := Ord(Msg[I]);
        Result.WriteCount := Result.WriteCount + 1;
        Inc(I);
        Inc(ByteCount);
        Dec(AvailBytes);
        if AvailBytes <= 0 then begin
            // No more room in current buffer, allocate new one
            NewBuffer           := AcquireChunk;       // Get a free chunk
            if not Assigned(NewBuffer) then begin
                Result := nil;
                Exit;
            end;
            Result.BufferNext   := NewBuffer;
            Result              := NewBuffer;
            Result.BufferNext   := nil;
            Result.WriteCount   := 0;
            AvailBytes          := Result.BufferSize;
        end;
    end;
end;

As you can see, I’m converting the string (Unicode) to ascii. I do it the rude way for performance reason. Of course you can preserve Unicode instead if you need it. This double the in memory size and write to disk time. For my application, keeping ascii is enough and I preferred better speed and less memory and disk space. Just a choice.
Now let’s see the main class. TInMemoryLogger is responsible for maintening the list of buffers and the list of available buffers. It receives the request to write a message thru the method Log() and the request to flush the buffers to disk thru the method FlushToFile(). Another important responsibility of the class it to manage concurrency so that the Log and FlushToFile methods can be called from different threads. So there are two critical sections: one two serialize access to the buffers and one to serialize access to the file.

The list of available buffers is managed by two protected methods: AcquireChunk and ReleaseChunk. AcquireChunk will check for available buffer and return it, or create a new buffer if no one is available. ReleaseChunk takes an emptied buffer (one which has been flushed to disk) and move it to the available buffer list.

The final code is quite simple. Here after you’ll find it complete.

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 
Author:       François PIETTE
Creation:     Feb 09, 2014
Description:  Fast multithread safe in memory logging
Version:      1.00
History:
 
 
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit OverbyteInMemoryLogger;
 
interface
 
uses
    Windows, ShlObj,
    Types, Classes, SysUtils, SyncObjs,
    Generics.Collections,
    OverbyteInMemoryChunk;
 
type
    TInMemoryLoggerOption  = (
        imloAddCRLF,        // Add a CRLF at end of each Log()
        imloAddDate,        // Add a date in front of each log()
        imloAddTime,        // Add a time in front of each log()
        imloAddTimeMSec,    // Add millisecond to time
        imloFlushOnDestroy  // Flush to file when destroyed
    );
    TInMemoryLoggerOptions = set of TInMemoryLoggerOption;
 
    TInMemoryLogger = class(TComponent)
    private
    protected
        FCritSectBuffer : TCriticalSection;  // To protect buffer access
        FCritSectFile   : TCriticalSection;  // To protect file write access
        FBufferHead     : TInMemoryChunk;
        FBufferCurrent  : TInMemoryChunk;
        FBuffe     : Integer;
        FOptions        : TInMemoryLoggerOptions;
        FFileName       : String;
        FBufferAvail    : TInMemoryChunk;
        FByteCount      : Integer;
        function  AcquireChunk: TInMemoryChunk;
        procedure ReleaseChunk(Chunk: TInMemoryChunk);
        procedure AcquireChunkHandler(Sender: TObject; var Chunk: TInMemoryChunk);
        function  GetByteCount: Integer;
    public
        constructor Create(AOwner : TComponent); override;
        destructor  Destroy; override;
        procedure Log(const Msg : String);
        procedure FlushToFile;
        procedure SetDefaultFileName;
    published
        property BufferSize    : Integer                read  FBufferSize
                                                        write FBufferSize;
        property Options       : TInMemoryLoggerOptions read  FOptions
                                                        write FOptions;
        property FileName      : String                 read  FFileName
                                                        write FFileName;
        property ByteCount     : Integer                read  GetByteCount;
    end;
 
var
    CompanyFolder : String = 'OverByte';
 
 
implementation
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
{ TInMemoryLogger }
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TInMemoryLogger.Create(AOwner: TComponent);
begin
    FCritSectBuffer := TCriticalSection.Create;
    FCritSectFile   := TCriticalSection.Create;
    FBufferSize     := 4096;                      // Default buffer size;
    FOptions        := [imloAddCRLF, imloFlushOnDestroy,
                        imloAddDate, imloAddTime, imloAddTimeMSec];
    inherited Create(AOwner);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TInMemoryLogger.Destroy;
var
    Chunk1 : TInMemoryChunk;
    Chunk2 : TInMemoryChunk;
begin
    if imloFlushOnDestroy in FOptions then
        FlushToFile;
    if Assigned(FCritSectBuffer) then
        FCritSectBuffer.Acquire;
    try
        // Free currently active buffers
        Chunk1      := FBufferHead;
        FBufferHead := nil;
        while Assigned(Chunk1) do begin
            Chunk2 := Chunk1.BufferNext;
            FreeAndNil(Chunk1);
            Chunk1 := Chunk2;
        end;
        // Free available buffers
        Chunk1       := FBufferAvail;
        FBufferAvail := nil;
        while Assigned(Chunk1) do begin
            Chunk2 := Chunk1.BufferNext;
            FreeAndNil(Chunk1);
            Chunk1 := Chunk2;
        end;
    finally
        if Assigned(FCritSectBuffer) then begin
            FCritSectBuffer.Release;
            FreeAndNil(FCritSectBuffer);
        end;
    end;
    FreeAndNil(FCritSectFile);
    inherited Destroy;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TInMemoryLogger.AcquireChunk : TInMemoryChunk;
begin
    FCritSectBuffer.Acquire;
    try
        // Check if a buffer is available
        if not Assigned(FBufferAvail) then
            Result := nil
        else begin
            // Take one buffer from the buffer available list
            Result            := FBufferAvail;
            FBufferAvail      := FBufferAvail.BufferNext;
            Result.BufferNext := nil;
        end;
    finally
        FCritSectBuffer.Release;
    end;
 
    // If we got no buffer, then create a new one
    if not Assigned(Result) then begin
        Result                := TInMemoryChunk.Create(FBufferSize);
        Result.OnAcquireChunk := AcquireChunkHandler;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TInMemoryLogger.ReleaseChunk(Chunk : TInMemoryChunk);
begin
    if not Assigned(Chunk) then
        Exit;
    FCritSectBuffer.Acquire;
    try
        // Add the buffer to the available buffer list
        Chunk.BufferNext := FBufferAvail;
        FBufferAvail     := Chunk;
        // Clear data
        Chunk.WriteCount := 0;
{$IFDEF DEBUG}
        // When debugging, clear buffer memory
        if Assigned(Chunk.Buffer) then
            FillChar(PByte(Chunk.Buffer)^, Chunk.BufferSize, 0);
{$ENDIF}
    finally
        FCritSectBuffer.Release;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// Build filename with LocalApp data location, company folder and
// same filename es executable with .log extension
procedure TInMemoryLogger.SetDefaultFileName;
var
    ExeName : array [0 .. MAX_PATH] of Char;
    Path    : array [0 .. MAX_PATH] of Char;
    AppName : String;
begin
    // Fetch Windows LocalApp data folder location
    SHGetFolderPath(0, CSIDL_LOCAL_APPDATA, 0, SHGFP_TYPE_CURRENT, @Path[0]);
    // Fetch executable file path
    GetModuleFileName(0, ExeName, High(ExeName));
    AppName := ChangeFileExt(ExtractFileName(ExeName), '');
    // Build complete file name
    FFileName := IncludeTrailingPathDelimiter(Path) + CompanyFolder +
                 '\' + AppName + '\' + AppName + '.Log';
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TInMemoryLogger.AcquireChunkHandler(
    Sender     : TObject;
    var Chunk  : TInMemoryChunk);
begin
    Chunk := AcquireChunk;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TInMemoryLogger.FlushToFile;
var
    Stream : TFileStream;
    Mode   : Integer;
    Next   : TInMemoryChunk;
begin
    // Check if critical section are assigned. The may be not assigned
    // in case of exception raise during contructor execution.
    if not Assigned(FCritSectFile) then
        Exit;
    if not Assigned(FCritSectBuffer) then
        Exit;
 
    FCritSectFile.Acquire;
    try
        if (not Assigned(FBufferHead)) or (FBufferHead.WriteCount <= 0) then
            Exit;
        if FFileName = '' then
            Exit;
        if FileExists(FFileName) then
            Mode := fmOpenWrite
        else
            Mode := fmCreate;
        Stream := TFileStream.Create(FFileName, Mode);
        try
            Stream.Seek(0, TSeekOrigin.soEnd);
            FCritSectBuffer.Acquire;
            try
                while Assigned(FBufferHead) do begin
                    Stream.Write(FBufferHead.Buffer[0], FBufferHead.WriteCount);
                    Dec(FByteCount, FBufferHead.WriteCount);
                    FBufferHead.WriteCount := 0;
                    Next := FBufferHead.BufferNext;
                    ReleaseChunk(FBufferHead);
                    FBufferHead := Next;
                    // Release/Acquire the critical section to enhance concurrency
                    FCritSectBuffer.Release;
                    Sleep(0);           // Let other thread take hand
                    FCritSectBuffer.Acquire;
                end;
            finally
                FCritSectBuffer.Release;
            end;
        finally
            FreeAndNil(Stream);
        end;
    finally
        FCritSectFile.Release;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TInMemoryLogger.GetByteCount: Integer;
begin
    FCritSectBuffer.Acquire;
    try
        Result := FByteCount;
    finally
        FCritSectBuffer.Release;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TInMemoryLogger.Log(const Msg: String);
var
    NewBuffer : TInMemoryChunk;
    Buf       : String;
begin
    FCritSectBuffer.Acquire;
    try
        if not Assigned(FBufferHead) then begin
            NewBuffer      := AcquireChunk;
            FBufferHead    := NewBuffer;
            FBufferCurrent := NewBuffer;
        end;
        if not Assigned(FBufferCurrent) then
            raise EInMemoryNoBufferException.Create(ERROR_MSG_NO_BUFFER);
        if (imloAddTime in FOptions) and (imloAddDate in FOptions) then begin
            // Add both date and time
            if imloAddTimeMSec in FOptions then
                Buf := FormatDateTime('YYYYMMDD HHNNSS.ZZZ ', Now)
            else
                Buf := FormatDateTime('YYYYMMDD HHNNSS ', Now);
            FBufferCurrent := FBufferCurrent.Write(Buf, FByteCount);
        end
        else if imloAddDate in FOptions then begin
            // Add date only
            Buf := FormatDateTime('YYYYMMDD ', Now);
            FBufferCurrent := FBufferCurrent.Write(Buf, FByteCount);
        end
        else if imloAddTime in FOptions then begin
            // Add time only
            if imloAddTimeMSec in FOptions then
                Buf := FormatDateTime('HHNNSS.ZZZ ', Now)
            else
                Buf := FormatDateTime('HHNNSS ', Now);
            FBufferCurrent := FBufferCurrent.Write(Buf, FByteCount);
        end;
        if not Assigned(FBufferCurrent) then
            raise EInMemoryNoBufferException.Create(ERROR_MSG_NO_BUFFER);
        FBufferCurrent := FBufferCurrent.Write(Msg, FByteCount);
        if imloAddCRLF in FOptions then
            FBufferCurrent := FBufferCurrent.Write(#13#10, FByteCount);
    finally
        FCritSectBuffer.Release;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
end.
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 
Author:       François PIETTE
Creation:     Feb 09, 2014
Description:  Class to represent a buffer for TInMemoryLogger. Buffers
              are organized as a simply linked list.
Version:      1.00
History:
 
 
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit OverbyteInMemoryChunk;
 
interface
 
uses
    SysUtils;
 
type
    EInMemoryException         = class(Exception);
    EInMemoryRangeException    = class(EInMemoryException);
    EInMemoryNoBufferException = class(EInMemoryException);
 
    TInMemoryChunk = class;
    TInMemoryChunkAcquireEvent = procedure (Sender    : TObject;
                                            var Chunk : TInMemoryChunk)
                                            of object;
 
    // Store data in ASCII
    TInMemoryChunk = class(TObject)
    strict private
        FBuffer         : TBytes;
        FBufferSize     : Integer;
        FBufferNext     : TInMemoryChunk;
        FWriteCount     : Integer;
        FOnAcquireChunk : TInMemoryChunkAcquireEvent;
        function  AcquireChunk : TInMemoryChunk;
    public
        constructor Create(Size : Integer);
        destructor Destroy; override;
        function Write(const Msg       : String;
                       var   ByteCount : Integer) : TInMemoryChunk;
        property Buffer         : TBytes                  read  FBuffer
                                                          write FBuffer;
        property BufferNext     : TInMemoryChunk          read  FBufferNext
                                                          write FBufferNext;
        property BufferSize     : Integer                 read  FBufferSize
                                                          write FBufferSize;
        property WriteCount     : Integer                 read  FWriteCount
                                                          write FWriteCount;
        property OnAcquireChunk : TInMemoryChunkAcquireEvent
                                                          read  FOnAcquireChunk
                                                          write FOnAcquireChunk;
    end;
 
const
    ERROR_MSG_NO_BUFFER   = 'Log failed. No buffer available';
    ERROR_MSG_SIZE_TO_LOW = 'Create buffer failed. Min size is 16';
 
 
implementation
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
{ TInMemoryChunk }
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TInMemoryChunk.Create(Size: Integer);
begin
    if Size < 16 then
        raise EInMemoryRangeException.Create(ERROR_MSG_SIZE_TO_LOW);
    FWriteCount := 0;
    FBufferNext := nil;
    FBufferSize := Size;
    SetLength(FBuffer, FBufferSize);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TInMemoryChunk.Destroy;
begin
    inherited Destroy;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TInMemoryChunk.AcquireChunk: TInMemoryChunk;
begin
    Result := nil;
    if Assigned(FOnAcquireChunk) then
        FOnAcquireChunk(Self, Result);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// Write a msg into the buffer, allocating a new one if required
// Returns the last buffer used (The current one or the new allocated)
function TInMemoryChunk.Write(
    const Msg       : String;
    var   ByteCount : Integer) : TInMemoryChunk;
var
    I          : Integer;
    Len        : Integer;
    AvailBytes : Integer;
    NewBuffer  : TInMemoryChunk;
begin
    Result := Self;
    Len := Length(Msg);
    if Len <= 0 then
        Exit;
    AvailBytes := Result.BufferSize - Result.WriteCount;
    I          := Low(Msg);
    while I <= High(Msg) do begin
        // Simple and incorrect unicode to ascii conversion
        Result.Buffer[Result.WriteCount] := Ord(Msg[I]);
        Result.WriteCount := Result.WriteCount + 1;
        Inc(I);
        Inc(ByteCount);
        Dec(AvailBytes);
        if AvailBytes <= 0 then begin
            // No more room in current buffer, allocate new one
            NewBuffer           := AcquireChunk;       // Get a free chunk
            if not Assigned(NewBuffer) then begin
                Result := nil;
                Exit;
            end;
            Result.BufferNext   := NewBuffer;
            Result              := NewBuffer;
            Result.BufferNext   := nil;
            Result.WriteCount   := 0;
            AvailBytes          := Result.BufferSize;
        end;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
end.




Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
This article is available from http://francois-piette.blogspot.be
Posted by at 6 comments:
Labels: , , , , ,

February 13, 2014

The most interesting topics...

Maybe you'll be interested by the topics mostly read on my blog.
The number in front of the titles are the number of hits:

9007 Delphi XE5 to develop Android applications
5509 Automate Microsoft Office from Delphi
2612 Delphi XE4 and AnsiString
2528 Multithreading and PostMessage performance
2498 Inter Process Communication Using Pipes

Of course some articles are older than other so the counts do not exactly reflect interest.



Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
Posted by at No comments:
Labels: , ,
Subscribe to: Posts (Atom)