source: branches/lazarus/UCore.pas

Last change on this file was 61, checked in by george, 15 years ago
  • Přidáno: Další chybějící soubory s vývojové větve ve Free Pascalu.
File size: 6.3 KB
Line 
1unit UCore;
2
3{$mode delphi}{$H+}
4
5interface
6
7uses
8 USqlDatabase;
9
10type
11 TArrayOfString = array of string;
12 TPageProducer = function: string;
13
14function InsertIcon(FileName: string): string;
15function HtmlLink(Text, Target: string): string;
16function ShowHeader(Title, Path: string): string;
17function ShowFooter: string;
18function Explode(Separator: Char; Data: string): TArrayOfString;
19function HumanDate(Date: string): string;
20procedure RegisterPage(Name: string; Producer: TPageProducer);
21function PagesList(URL: string; Page, TotalCount, CountPerPage: Integer): string;
22function StrRepeat(Data: string; Count: Integer): string;
23function FormatOutput(Data: string): string;
24
25type
26 TRegistredPage = record
27 Name: string;
28 Producer: TPageProducer;
29 end;
30
31var
32 Pages: array of TRegistredPage;
33 Database: TSqlDatabase;
34
35implementation
36
37uses
38 pwenvvar, pwmain, SysUtils, UConfig;
39
40procedure RegisterPage(Name: string; Producer: TPageProducer);
41begin
42 SetLength(Pages, Length(Pages) + 1);
43 Pages[High(Pages)].Name := Name;
44 Pages[High(Pages)].Producer := Producer;
45end;
46
47function HtmlLink(Text, Target: string): string;
48begin
49 Result := '<a href="' + Target + '">' + Text + '</a>';
50end;
51
52function ShowHeader(Title, Path: string): string;
53var
54 Navigace: string;
55begin
56 Navigace := CgiEnvVar.RequestURI;
57 Result := '<?xml version="1.0" encoding="utf-8"?>' +
58 '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">' +
59 '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">' +
60 '<head>' +
61 ' <meta http-equiv="Content-Language" content="cs" />' +
62 ' <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />' +
63 ' <link rel="stylesheet" href="style/style.css" type="text/css" media="all" />' +
64 ' <script type="text/javascript" src="style/global.js"></script>' +
65 ' <title>Centrála - ' + Path + '</title>' +
66 ' </head><body>' +
67 '<div class="PageTitle">' + Title + '</div>'+
68 '<div class="Navigation"><strong>Navigace &gt;&gt;</strong> ' + Navigace + '</div>';
69end;
70
71function ShowFooter: string;
72var
73 UpdateDate: string;
74 GenerateTime: string;
75begin
76 UpdateDate := '2.5.2007';
77 GenerateTime := '1 s';
78 Result := '<div class="Footer">| Web mistr: Jiří Hajda | e-mail: robie@centrum.cz | ICQ: 277158770 | Vygenerováno za ' + GenerateTime + ' s | Verze: 1.0 | Naposledy aktualizováno: ' + UpdateDate + ' |' +
79 '</div>';
80 //ShowArray($GLOBALS);
81 Result := Result + '</body></html>';
82end;
83
84function Explode(Separator: Char; Data: string): TArrayOfString;
85begin
86 SetLength(Result, 0);
87 while Pos(Separator, Data) > 0 do begin
88 SetLength(Result, Length(Result) + 1);
89 Result[High(Result)] := Copy(Data, 1, Pos(Separator, Data) - 1);
90 Delete(Data, 1, Pos(Separator, Data));
91 end;
92 SetLength(Result, Length(Result) + 1);
93 Result[High(Result)] := Data;
94end;
95
96function HumanDate(Date: string): string;
97var
98 Parts: TArrayOfString;
99 Parts2: TArrayOfString;
100begin
101 Parts := Explode(' ', Date);
102// Result := Date;
103 Parts2 := Explode('-', Parts[0]);
104 if Date <> '0000-00-00' then Result := IntToStr(StrToInt(Parts2[2])*1) + '.' + IntToStr(StrToInt(Parts2[1])*1) + '.' + Parts2[0]
105 else Result := '&nbsp;';
106end;
107
108function InsertIcon(FileName: string): string;
109begin
110 Result := '<img alt="" src="images/favicons/' + FileName + '" width="16" height="16" />';
111end;
112
113procedure Init;
114var
115 DbRows: TDbRows;
116begin
117 Database := TSqlDatabase.Create;
118 with Database do begin
119 Hostname := DatabaseHostName;
120 Database := DatabaseDatabase;
121 UserName := DatabaseUserName;
122 Password := DatabasePassword;
123 Connect;
124 end;
125 DbRows := Database.Query('SET NAMES utf8');
126 DbRows.Free;
127end;
128
129procedure Done;
130begin
131 Database.Free;
132end;
133
134function PagesList(URL: string; Page, TotalCount, CountPerPage: Integer): string;
135const
136 Around: Integer = 10;
137var
138 Count: Integer;
139 PagesMax: Integer;
140 PagesMin: Integer;
141 I: Integer;
142begin
143 Count := Round(TotalCount / CountPerPage);
144 Result := '';
145 if Count > 1 then begin
146 if Page > 0 then begin
147 Result := Result + '<a href="' + URL + '0">&lt;&lt;</a> ';
148 Result := Result + '<a href="' + URL + IntToStr(Page - 1) + '">&lt;</a> ';
149 end;
150 PagesMax := Count - 1;
151 PagesMin := 0;
152 if PagesMax > (Page + Around) then PagesMax := Page + Around;
153 if PagesMin < (Page - Around) then begin
154 Result := Result + ' .. ';
155 PagesMin := Page - Around;
156 end;
157 for I := PagesMin to PagesMax do begin
158 if I = Page then Result := Result + '<strong>';
159 Result := Result + '<a href="' + URL + IntToStr(I) + '">' + IntToStr(I + 1) + '</a> ';
160 if I = Page then Result := Result + '</strong>';
161 end;
162 if PagesMax < (Count - 1) then Result := Result + ' .. ';
163 if Page < (Count - 1) then begin
164 Result := Result + '<a href="' + URL + IntToStr(Page + 1) + '">&gt;</a> ';
165 Result := Result + '<a href="' + URL + IntToStr(Count - 1) + '">&gt;&gt;</a>';
166 end;
167 end;
168end;
169
170function StrRepeat(Data: string; Count: Integer): string;
171var
172 I: Integer;
173begin
174 Result := '';
175 for I := 1 to Count do
176 Result := Result + Data;
177end;
178
179function FormatOutput(Data: string): string;
180var
181 BlockStart, BlockEnd: Integer;
182 Indention: Integer;
183 Indention2: Integer;
184 Line: string;
185 Command: string;
186begin
187 Result := '';
188 Indention := 0;
189 Indention2 := 0;
190 while Data <> '' do begin
191 //WebWrite('.');
192 BlockStart := Pos('<', Data);
193 BlockEnd := Pos('>', Data);
194 if BlockStart > 1 then begin
195 BlockEnd := BlockStart - 1;
196 BlockStart := 1;
197 end;
198 Line := Trim(Copy(Data, BlockStart, BlockEnd));
199 //WebWriteLn(Line);
200 if Length(Line) > 0 then
201 if Line[1] = '<' then begin
202 if Data[BlockStart + 1] = '/' then begin
203 Indention := Indention - 2;
204 Indention2 := Indention;
205 end else begin
206 if Pos(' ', Line) > 0 then Command := Copy(Line, 2, Pos(' ', Line) - 2)
207 else Command := Copy(Line, 2, Length(Line) - 2);
208 //WebWriteLn(Command + ' ' + IntToStr(Indention));
209 if Pos('</' + Command + '>', Data) > 0 then Indention := Indention + 2;
210 //WebWriteLn(IntToStr(Indention) + ',' + IntToStr(Indention2));
211 end;
212 end;
213 if Line <> '' then Result := Result + StrRepeat(' ', Indention2) + Line + #13#10;
214 Data := Copy(Data, BlockEnd + 1, Length(Data));
215 Indention2 := Indention;
216 end;
217end;
218
219initialization
220
221Init;
222
223finalization
224
225Done;
226end.
Note: See TracBrowser for help on using the repository browser.