← Back to branch summary

~ubuntu-branches/ubuntu/quantal/transgui/quantal-proposed

« back to all changes in this revision

Viewing changes to synapse/source/lib/synadbg.pas

  • Committer: Bazaar Package Importer
  • Author(s): Andreas Noteng
  • Date: 2011-04-30 19:43:19 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20110430194319-umpkh5ud1mjousbq
Tags: 3.1+svn607-1
http://bugs.debian.org/620713
* New upstream version
* Update with upstream svn revision 607 to correctly build with
  fpc-2.4.2 and lazarus-0.9.30 (Closes: #620713)
* Bump Standards-Version to 3.9.2 (no change)

Show diffs side-by-side

added added

removed removed

Lines of Context:
synapse/source/lib/synadbg.pas
1
 
{==============================================================================|
2
 
| Project : Ararat Synapse                                       | 001.001.001 |
3
 
|==============================================================================|
4
 
| Content: Socket debug tools                                                  |
5
 
|==============================================================================|
6
 
| Copyright (c)2008-2010, Lukas Gebauer                                        |
7
 
| All rights reserved.                                                         |
8
 
|                                                                              |
9
 
| Redistribution and use in source and binary forms, with or without           |
10
 
| modification, are permitted provided that the following conditions are met:  |
11
 
|                                                                              |
12
 
| Redistributions of source code must retain the above copyright notice, this  |
13
 
| list of conditions and the following disclaimer.                             |
14
 
|                                                                              |
15
 
| Redistributions in binary form must reproduce the above copyright notice,    |
16
 
| this list of conditions and the following disclaimer in the documentation    |
17
 
| and/or other materials provided with the distribution.                       |
18
 
|                                                                              |
19
 
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
20
 
| be used to endorse or promote products derived from this software without    |
21
 
| specific prior written permission.                                           |
22
 
|                                                                              |
23
 
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
24
 
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
25
 
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
26
 
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
27
 
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
28
 
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
29
 
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
30
 
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
31
 
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
32
 
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
33
 
| DAMAGE.                                                                      |
34
 
|==============================================================================|
35
 
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
36
 
| Portions created by Lukas Gebauer are Copyright (c)2008-2010.                |
37
 
| All Rights Reserved.                                                         |
38
 
|==============================================================================|
39
 
| Contributor(s):                                                              |
40
 
|==============================================================================|
41
 
| History: see HISTORY.HTM from distribution package                           |
42
 
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
43
 
|==============================================================================}
44
 
 
45
 
{:@abstract(Socket debug tools)
46
 
 
47
 
Routines for help with debugging of events on the Sockets.
48
 
}
49
 
 
50
 
{$IFDEF UNICODE}
51
 
  {$WARN IMPLICIT_STRING_CAST OFF}
52
 
  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
53
 
{$ENDIF}
54
 
 
55
 
unit synadbg;
56
 
 
57
 
interface
58
 
 
59
 
uses
60
 
  blcksock, synsock, synautil, classes, sysutils;
61
 
 
62
 
type
63
 
  TSynaDebug = class(TObject)
64
 
    class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
65
 
    class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
66
 
  end;
67
 
 
68
 
procedure AppendToLog(const value: Ansistring);
69
 
 
70
 
var
71
 
  LogFile: string;
72
 
 
73
 
implementation
74
 
 
75
 
procedure AppendToLog(const value: Ansistring);
76
 
var
77
 
  st: TFileStream;
78
 
  s: string;
79
 
  h, m, ss, ms: word;
80
 
  dt: Tdatetime;
81
 
begin
82
 
  if fileexists(LogFile) then
83
 
    st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite)
84
 
  else
85
 
    st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite);
86
 
  try
87
 
    st.Position := st.Size;
88
 
    dt := now;
89
 
    decodetime(dt, h, m, ss, ms);
90
 
    s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value;
91
 
    WriteStrToStream(st, s);
92
 
  finally
93
 
    st.free;
94
 
  end;
95
 
end;
96
 
 
97
 
class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
98
 
var
99
 
  s: string;
100
 
begin
101
 
  case Reason of
102
 
    HR_ResolvingBegin:
103
 
      s := 'HR_ResolvingBegin';
104
 
    HR_ResolvingEnd:
105
 
      s := 'HR_ResolvingEnd';
106
 
    HR_SocketCreate:
107
 
      s := 'HR_SocketCreate';
108
 
    HR_SocketClose:
109
 
      s := 'HR_SocketClose';
110
 
    HR_Bind:
111
 
      s := 'HR_Bind';
112
 
    HR_Connect:
113
 
      s := 'HR_Connect';
114
 
    HR_CanRead:
115
 
      s := 'HR_CanRead';
116
 
    HR_CanWrite:
117
 
      s := 'HR_CanWrite';
118
 
    HR_Listen:
119
 
      s := 'HR_Listen';
120
 
    HR_Accept:
121
 
      s := 'HR_Accept';
122
 
    HR_ReadCount:
123
 
      s := 'HR_ReadCount';
124
 
    HR_WriteCount:
125
 
      s := 'HR_WriteCount';
126
 
    HR_Wait:
127
 
      s := 'HR_Wait';
128
 
    HR_Error:
129
 
      s := 'HR_Error';
130
 
  else
131
 
    s := '-unknown-';
132
 
  end;
133
 
  s := inttohex(integer(Sender), 8) + s + ': ' + value + CRLF;
134
 
  AppendToLog(s);
135
 
end;
136
 
 
137
 
class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
138
 
var
139
 
  s, d: Ansistring;
140
 
begin
141
 
  setlength(s, len);
142
 
  move(Buffer^, pointer(s)^, len);
143
 
  if writing then
144
 
    d := '-> '
145
 
  else
146
 
    d := '<- ';
147
 
  s :=inttohex(integer(Sender), 8) + d + s + CRLF;
148
 
  AppendToLog(s);
149
 
end;
150
 
 
151
 
initialization
152
 
begin
153
 
  Logfile := changefileext(paramstr(0), '.slog');
154
 
end;
155
 
 
156
 
end.
 
1
{==============================================================================|
 
2
| Project : Ararat Synapse                                       | 001.001.001 |
 
3
|==============================================================================|
 
4
| Content: Socket debug tools                                                  |
 
5
|==============================================================================|
 
6
| Copyright (c)2008-2010, Lukas Gebauer                                        |
 
7
| All rights reserved.                                                         |
 
8
|                                                                              |
 
9
| Redistribution and use in source and binary forms, with or without           |
 
10
| modification, are permitted provided that the following conditions are met:  |
 
11
|                                                                              |
 
12
| Redistributions of source code must retain the above copyright notice, this  |
 
13
| list of conditions and the following disclaimer.                             |
 
14
|                                                                              |
 
15
| Redistributions in binary form must reproduce the above copyright notice,    |
 
16
| this list of conditions and the following disclaimer in the documentation    |
 
17
| and/or other materials provided with the distribution.                       |
 
18
|                                                                              |
 
19
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
 
20
| be used to endorse or promote products derived from this software without    |
 
21
| specific prior written permission.                                           |
 
22
|                                                                              |
 
23
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
 
24
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
 
25
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
 
26
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
 
27
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
 
28
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
 
29
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
 
30
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
 
31
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
 
32
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
 
33
| DAMAGE.                                                                      |
 
34
|==============================================================================|
 
35
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 
36
| Portions created by Lukas Gebauer are Copyright (c)2008-2010.                |
 
37
| All Rights Reserved.                                                         |
 
38
|==============================================================================|
 
39
| Contributor(s):                                                              |
 
40
|==============================================================================|
 
41
| History: see HISTORY.HTM from distribution package                           |
 
42
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
 
43
|==============================================================================}
 
44
 
 
45
{:@abstract(Socket debug tools)
 
46
 
 
47
Routines for help with debugging of events on the Sockets.
 
48
}
 
49
 
 
50
{$IFDEF UNICODE}
 
51
  {$WARN IMPLICIT_STRING_CAST OFF}
 
52
  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
 
53
{$ENDIF}
 
54
 
 
55
unit synadbg;
 
56
 
 
57
interface
 
58
 
 
59
uses
 
60
  blcksock, synsock, synautil, classes, sysutils;
 
61
 
 
62
type
 
63
  TSynaDebug = class(TObject)
 
64
    class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
 
65
    class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
 
66
  end;
 
67
 
 
68
procedure AppendToLog(const value: Ansistring);
 
69
 
 
70
var
 
71
  LogFile: string;
 
72
 
 
73
implementation
 
74
 
 
75
procedure AppendToLog(const value: Ansistring);
 
76
var
 
77
  st: TFileStream;
 
78
  s: string;
 
79
  h, m, ss, ms: word;
 
80
  dt: Tdatetime;
 
81
begin
 
82
  if fileexists(LogFile) then
 
83
    st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite)
 
84
  else
 
85
    st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite);
 
86
  try
 
87
    st.Position := st.Size;
 
88
    dt := now;
 
89
    decodetime(dt, h, m, ss, ms);
 
90
    s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value;
 
91
    WriteStrToStream(st, s);
 
92
  finally
 
93
    st.free;
 
94
  end;
 
95
end;
 
96
 
 
97
class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
 
98
var
 
99
  s: string;
 
100
begin
 
101
  case Reason of
 
102
    HR_ResolvingBegin:
 
103
      s := 'HR_ResolvingBegin';
 
104
    HR_ResolvingEnd:
 
105
      s := 'HR_ResolvingEnd';
 
106
    HR_SocketCreate:
 
107
      s := 'HR_SocketCreate';
 
108
    HR_SocketClose:
 
109
      s := 'HR_SocketClose';
 
110
    HR_Bind:
 
111
      s := 'HR_Bind';
 
112
    HR_Connect:
 
113
      s := 'HR_Connect';
 
114
    HR_CanRead:
 
115
      s := 'HR_CanRead';
 
116
    HR_CanWrite:
 
117
      s := 'HR_CanWrite';
 
118
    HR_Listen:
 
119
      s := 'HR_Listen';
 
120
    HR_Accept:
 
121
      s := 'HR_Accept';
 
122
    HR_ReadCount:
 
123
      s := 'HR_ReadCount';
 
124
    HR_WriteCount:
 
125
      s := 'HR_WriteCount';
 
126
    HR_Wait:
 
127
      s := 'HR_Wait';
 
128
    HR_Error:
 
129
      s := 'HR_Error';
 
130
  else
 
131
    s := '-unknown-';
 
132
  end;
 
133
  s := inttohex(integer(Sender), 8) + s + ': ' + value + CRLF;
 
134
  AppendToLog(s);
 
135
end;
 
136
 
 
137
class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
 
138
var
 
139
  s, d: Ansistring;
 
140
begin
 
141
  setlength(s, len);
 
142
  move(Buffer^, pointer(s)^, len);
 
143
  if writing then
 
144
    d := '-> '
 
145
  else
 
146
    d := '<- ';
 
147
  s :=inttohex(integer(Sender), 8) + d + s + CRLF;
 
148
  AppendToLog(s);
 
149
end;
 
150
 
 
151
initialization
 
152
begin
 
153
  Logfile := changefileext(paramstr(0), '.slog');
 
154
end;
 
155
 
 
156
end.