1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit Unit1;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls;
10
11 type
12
13 { TForm1 }
14
15 TForm1 = class(TForm)
16 Button1: TButton;
17 Button2: TButton;
18 EPath: TEdit;
19 Label1: TLabel;
20 Memo1: TMemo;
21 SelectDirectoryDialog1: TSelectDirectoryDialog;
22 procedure Button1Click(Sender: TObject);
23 procedure Button2Click(Sender: TObject);
24 private
25 { private declarations }
26 public
27 { public declarations }
28 end;
29
30 var
31 Form1: TForm1;
32
33 implementation
34
35 {$R *.lfm}
36
37 uses LazUTF8, FileUtil, LazFileUtils;
38
39 const
40 BoldKeywords : array[1..52] of string = ('var','procedure','function','and',
41 'or','xor','not','if','then','case','begin','end','of',
42 'exit','new','class','is','const','div','do','downto','to','else','for',
43 'in','mod','nil','object','record','repeat','self','shl','shr','string',
44 'unit','until','uses','while','array','interface', 'out', 'constructor',
45 'property','read','write','default', 'packed', 'operator', 'inline',
46 'overload', 'virtual', 'abstract');
47
48 { TForm1 }
49
50 procedure TForm1.Button1Click(Sender: TObject);
51 begin
52 if SelectDirectoryDialog1.Execute then
53 EPath.Text := SelectDirectoryDialog1.FileName;
54 end;
55
56 procedure HighlightKeywords(var s: string);
57 const keywordChars = ['a'..'z','A'..'Z'];
58 moreKeywordChars = ['a'..'z','A'..'Z','0'..'9','_'];
59 var
60 i,start: Integer;
61 w,wlower: string;
62 j: Integer;
63 found, first: boolean;
64 begin
65 i := 1;
66 first := true;
67 while i <= length(s) do
68 begin
69 if s[i] in keywordChars then
70 begin
71 start := i;
72 inc(i);
73 while i <= length(s) do
74 begin
75 if not (s[i] in moreKeywordChars) then break;
76 inc(i);
77 end;
78 w := copy(s,start,i-start);
79 wlower := lowercase(w);
80 found := false;
81 for j := low(BoldKeywords) to high(BoldKeywords) do
82 if BoldKeywords[j] = wlower then
83 begin
84 delete(s, start, length(w));
85 dec(i, length(w));
86 w := ''''''''+wlower+'''''''';
87 insert(w, s, start);
88 inc(i, length(w));
89 found := true;
90 break;
91 end;
92 if not found and first then
93 begin
94 delete(s, start, length(w));
95 dec(i, length(w));
96 w := ''''''+w+'''''';
97 insert(w, s, start);
98 inc(i, length(w));
99 end;
100 first := false;
101 end else
102 inc(i);
103 end;
104 end;
105
MakeDocFornull106 function MakeDocFor(AFilename: string): string;
107 var
108 t: textfile;
109 fileoutput,s,bgcolor: String;
110 description, element: String;
111 comStart,comEnd, idxColor: integer;
112 oddRow,indented : boolean;
113 docName, colorStr: string;
114 tableOpened: boolean;
115
116 procedure openTable;
117 begin
118 if not tableOpened then
119 begin
120 fileoutput += '<table style="border-collapse: collapse;">'+lineending;
121 oddRow := true;
122 tableOpened:= true;
123 end;
124 end;
125
126 procedure closeTable;
127 begin
128 if tableOpened then
129 begin
130 fileoutput += '</table>'+LineEnding;
131 tableOpened:= false;
132 end;
133 end;
134
135 procedure flushOutput;
136 var u: textfile;
137 path,fullname: string;
138 outname,
139 currentContent: string;
140 begin
141 if fileoutput <> '' then
142 begin
143 closeTable;
144 path := ExtractFilePath(AFilename);
145 CreateDirUTF8(path+DirectorySeparator+'doc');
146 outname := 'doc'+DirectorySeparator+docName+'.txt';
147 fullname := path+outname;
148 fileoutput := '=== ' + docName + ' ===' + LineEnding
149 + fileoutput;
150 if FileExistsUTF8(fullname) then
151 begin
152 currentContent := ReadFileToString(fullname);
153 if currentContent <> fileoutput then
154 begin
155 assignfile(u, UTF8ToSys(fullname));
156 rewrite(u);
157 write(u, fileoutput);
158 closefile(u);
159 result += outname + ' (updated)' + LineEnding;
160 end;
161 end else
162 begin
163 result += outname + ' (created)' + LineEnding;
164 assignfile(u, UTF8ToSys(fullname));
165 rewrite(u);
166 write(u, fileoutput);
167 closefile(u);
168 end;
169 fileoutput:= '';
170 end;
171 end;
172
173 begin
174 result := '';
175 docName := ExtractFileName(AFilename);
176 fileoutput := '';
177 tableOpened:= false;
178 assignfile(t, UTF8ToSys(AFilename));
179 reset(t);
180 while not eof(t) do
181 begin
182 readln(t,s);
183
184 comStart:= pos('{====',s);
185 if comStart <> 0 then
186 begin
187 comEnd:= pos('====}',s);
188 if comEnd <> 0 then
189 begin
190 closeTable;
191 fileOutput += trim(copy(s,comStart+1,comEnd+3 -(comStart+1)+1)) + LineEnding;
192 continue;
193 end;
194 end;
195
196 comStart:= pos('{===',s);
197 if comStart <> 0 then
198 begin
199 comEnd:= pos('===}',s);
200 if comEnd <> 0 then
201 begin
202 flushOutput;
203 docName:= trim(copy(s,comStart+4,comEnd-1 -(comStart+4)+1));
204 continue;
205 end;
206 end;
207
208 comStart:= pos('{* ',s+' ');
209 indented:= false;
210 if comStart <> 0 then
211 comStart += 2
212 else
213 begin
214 comStart := pos('{** ',s+' ');
215 if comStart <> 0 then
216 comStart += 3;
217 indented := true;
218 end;
219 if comStart<>0 then
220 begin
221 delete(s,1,comStart-1);
222 comStart := 1;
223 description := '';
224 comEnd := pos('}',s);
225 if comEnd = 0 then
226 begin
227 description += trim(copy(s,comStart,length(s)-comStart+1));
228 while not eof(t) do
229 begin
230 readln(t,s);
231 s := trim(s);
232 if (length(s) > 0) and (s[1]='*') then
233 begin
234 delete(s,1,1);
235 s := trim(s);
236 s := '<br/>'+s;
237 end;
238 comEnd := pos('}',s);
239 if comEnd = 0 then
240 description += ' '+s else
241 begin
242 description += ' '+trim(copy(s,1,comEnd-1));
243 break;
244 end;
245 end;
246 end
247 else
248 description += trim(copy(s,comStart,comEnd-comStart));
249
250 while pos('[#',description) <> 0 do
251 begin
252 idxColor := pos('[#',description);
253 colorStr := copy(description, idxColor, 9);
254 if (length(colorStr) = 9) and (colorStr[9] = ']') then
255 begin
256 delete(description, idxColor, length(colorStr));
257 insert('<span style="width:8px; height: 8px; display: inline-block; border: 1px solid black; background: '+copy(colorStr,2,7)+';"></span>', description, idxColor);
258 end;
259 end;
260
261 if not eof(t) then
262 readln(t,element) else element := '?';
263
264 HighlightKeywords(element);
265 element := trim(element);
266
267 openTable;
268 if oddRow then bgcolor := 'white' else bgcolor := '#f0f0ff';
269
270 if indented then
271 begin
272 fileoutput += '<tr><td width="10%"></td><td colspan="2" style="background: '+bgcolor+';">'+element+'</td></tr>'+LineEnding;
273 fileoutput += '<tr><td width="10%"></td><td width="10%" style="background: '+bgcolor+';"></td>'+
274 '<td style="border: 1px solid #e0e0a0; background: #ffffe4;">'+description+'</td></tr>'+LineEnding;
275 end else
276 begin
277 fileoutput += '<tr style="background: '+bgcolor+';"><td colspan="3">'+element+'</td></tr>'+LineEnding;
278 fileoutput += '<tr style="background: '+bgcolor+';"><td width="10%"></td>'+
279 '<td style="border: 1px solid #e0e0a0; background: #ffffe4;" colspan="2">'+description+'</td></tr>'+LineEnding;
280 end;
281
282 fileoutput += '<tr style="height: 8px;"><td colspan="3"></td></tr>'+LineEnding;
283 oddRow := not oddRow;
284 end;
285 end;
286 closefile(t);
287 flushOutput;
288 end;
289
290 procedure TForm1.Button2Click(Sender: TObject);
291 var sr: TSearchRec;
292 output,ext: string;
293 path,fileoutput: string;
294 begin
295 memo1.Text := 'Analyzing...';
296 memo1.Update;
297 path := AppendPathDelim(EPath.Text);
298 if FindFirstUTF8(path+'*.*', faAnyFile, sr) = 0 then
299 begin
300 output := '';
301 repeat
302 if sr.Attr and (faDirectory or faVolumeId or faSymLink) <> 0 then continue;
303 ext := AnsiLowerCase(ExtractFileExt(sr.Name));
304 if (ext = '.pas') or (ext = '.inc') then
305 begin
306 fileoutput:= MakeDocFor(path+sr.Name);
307 if fileoutput <> '' then
308 begin
309 output += fileoutput;
310 end;
311 end;
312 until FindNextUTF8(sr) <> 0;
313 FindCloseUTF8(sr);
314 if output = '' then
315 Memo1.Text := 'No change'
316 else
317 Memo1.text := output;
318 end
319 else
320 Memo1.Text := 'Nothing to do';
321 end;
322
323 end.
324
325