WebModuleUnit1.pas

   1 unit WebModuleUnit1;
   2
   3 interface
   4
   5 uses System.SysUtils, System.Classes, Web.HTTPApp, Web.DSProd, Web.HTTPProd,
   6   Web.DBWeb, System.Variants, System.NetEncoding, System.RegularExpressions,
   7   Data.DB, Web.DBXpressWeb, System.Types;
   8
   9 type
  10   TWebModule1 = class(TWebModule)
  11     articles: TDataSetPageProducer;
  12     index: TDataSetPageProducer;
  13     admin: TDataSetTableProducer;
  14     search: TPageProducer;
  15     items: TDataSetPageProducer;
  16     help: TPageProducer;
  17     top: TPageProducer;
  18     master: TPageProducer;
  19     alert: TDataSetPageProducer;
  20     footer: TDataSetPageProducer;
  21     mail: TPageProducer;
  22     css1: TPageProducer;
  23     css2: TPageProducer;
  24     css3: TPageProducer;
  25     css4: TPageProducer;
  26     header: TDataSetPageProducer;
  27     login: TDataSetPageProducer;
  28     js1: TPageProducer;
  29     js2: TPageProducer;
  30     js3: TPageProducer;
  31     js4: TPageProducer;
  32     adhead: TPageProducer;
  33     js5: TPageProducer;
  34     title: TPageProducer;
  35     ti: TDataSetPageProducer;
  36     procedure indexHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  37       TagParams: TStrings; var ReplaceText: string);
  38     procedure WebModule1indexpageAction(Sender: TObject; Request: TWebRequest;
  39       Response: TWebResponse; var Handled: Boolean);
  40     procedure WebModule1registAction(Sender: TObject; Request: TWebRequest;
  41       Response: TWebResponse; var Handled: Boolean);
  42     procedure WebModuleCreate(Sender: TObject);
  43     procedure WebModule1adminAction(Sender: TObject; Request: TWebRequest;
  44       Response: TWebResponse; var Handled: Boolean);
  45     procedure WebModule1topAction(Sender: TObject; Request: TWebRequest;
  46       Response: TWebResponse; var Handled: Boolean);
  47     procedure itemsHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  48       TagParams: TStrings; var ReplaceText: string);
  49     procedure topHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  50       TagParams: TStrings; var ReplaceText: string);
  51     procedure WebModule1searchAction(Sender: TObject; Request: TWebRequest;
  52       Response: TWebResponse; var Handled: Boolean);
  53     procedure WebModule1helpAction(Sender: TObject; Request: TWebRequest;
  54       Response: TWebResponse; var Handled: Boolean);
  55     procedure searchHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  56       TagParams: TStrings; var ReplaceText: string);
  57     procedure masterHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  58       TagParams: TStrings; var ReplaceText: string);
  59     procedure articlesHTMLTag(Sender: TObject; Tag: TTag;
  60       const TagString: string; TagParams: TStrings; var ReplaceText: string);
  61     procedure footerHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  62       TagParams: TStrings; var ReplaceText: string);
  63     procedure WebModule1alertAction(Sender: TObject; Request: TWebRequest;
  64       Response: TWebResponse; var Handled: Boolean);
  65     procedure WebModule1masterAction(Sender: TObject; Request: TWebRequest;
  66       Response: TWebResponse; var Handled: Boolean);
  67     procedure mailHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  68       TagParams: TStrings; var ReplaceText: string);
  69     procedure alertHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  70       TagParams: TStrings; var ReplaceText: string);
  71     procedure WebModule1deleteAction(Sender: TObject; Request: TWebRequest;
  72       Response: TWebResponse; var Handled: Boolean);
  73     procedure WebModule1jumpAction(Sender: TObject; Request: TWebRequest;
  74       Response: TWebResponse; var Handled: Boolean);
  75     procedure WebModule1linkAction(Sender: TObject; Request: TWebRequest;
  76       Response: TWebResponse; var Handled: Boolean);
  77     procedure headerHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  78       TagParams: TStrings; var ReplaceText: string);
  79     procedure adminFormatCell(Sender: TObject; CellRow, CellColumn: Integer;
  80       var BgColor: THTMLBgColor; var Align: THTMLAlign; var VAlign: THTMLVAlign;
  81       var CustomAttrs, CellData: string);
  82     procedure WebModule1admdelAction(Sender: TObject; Request: TWebRequest;
  83       Response: TWebResponse; var Handled: Boolean);
  84     procedure WebModule1loginAction(Sender: TObject; Request: TWebRequest;
  85       Response: TWebResponse; var Handled: Boolean);
  86     procedure WebModule1adminsetAction(Sender: TObject; Request: TWebRequest;
  87       Response: TWebResponse; var Handled: Boolean);
  88     procedure adheadHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  89       TagParams: TStrings; var ReplaceText: string);
  90     procedure WebModule1logoutAction(Sender: TObject; Request: TWebRequest;
  91       Response: TWebResponse; var Handled: Boolean);
  92     procedure WebModule1imgAction(Sender: TObject; Request: TWebRequest;
  93       Response: TWebResponse; var Handled: Boolean);
  94     procedure WebModule1fileAction(Sender: TObject; Request: TWebRequest;
  95       Response: TWebResponse; var Handled: Boolean);
  96     procedure titleHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  97       TagParams: TStrings; var ReplaceText: string);
  98     procedure WebModule1titleAction(Sender: TObject; Request: TWebRequest;
  99       Response: TWebResponse; var Handled: Boolean);
 100     procedure tiHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
 101       TagParams: TStrings; var ReplaceText: string);
 102     procedure helpHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
 103       TagParams: TStrings; var ReplaceText: string);
 104     procedure loginHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
 105       TagParams: TStrings; var ReplaceText: string);
 106   private
 107     { private \90é\8c¾ }
 108     ss: TStringList;
 109     procedure pages(count: Integer; var page: Integer);
 110     function hash(str: string): string;
 111     function mente: Boolean;
 112     function detail(ts, pid: string): string;
 113   public
 114     { public \90é\8c¾ }
 115   end;
 116
 117 var
 118   WebModuleClass: TComponentClass = TWebModule1;
 119
 120 implementation
 121
 122 { %CLASSGROUP 'Vcl.Controls.TControl' }
 123
 124 uses Unit1, IdHashSHA, IdGlobal, IdHash, IdHashMessageDigest;
 125
 126 {$R *.dfm}
 127
 128 const
 129   promotion = '\8dL\8d\90:';
 130   tcnt = 7;
 131
 132 procedure TWebModule1.adheadHTMLTag(Sender: TObject; Tag: TTag;
 133   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 134 begin
 135   if TagString = 'pr' then
 136     ReplaceText := promotion
 137   else if (TagString = 'mente') and
 138     (DataModule1.FDTable3.FieldByName('mente').AsBoolean = true) then
 139     ReplaceText := 'checked'
 140   else if TagString = 'password' then
 141     ReplaceText := Request.CookieFields.Values['user'];
 142 end;
 143
 144 procedure TWebModule1.adminFormatCell(Sender: TObject;
 145   CellRow, CellColumn: Integer; var BgColor: THTMLBgColor;
 146   var Align: THTMLAlign; var VAlign: THTMLVAlign;
 147   var CustomAttrs, CellData: string);
 148 begin
 149   if (CellColumn = 0) and (CellRow > 0) then
 150     CellData := Format('<input name=check%d type=checkbox>', [CellRow]);
 151 end;
 152
 153 procedure TWebModule1.alertHTMLTag(Sender: TObject; Tag: TTag;
 154   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 155 var
 156   s: TStringList;
 157   i: Integer;
 158 begin
 159   if TagString = 'article' then
 160   begin
 161     with DataModule1 do
 162     begin
 163       FDTable1.Locate('dbnum', FDTable4.FieldByName('dbname').AsInteger);
 164       FDTable2.Locate('number', FDTable4.FieldByName('posnum').AsInteger);
 165     end;
 166     s := TStringList.Create;
 167     try
 168       s.Text := articles.Content;
 169       for i := 1 to 2 do
 170         s.Delete(1);
 171       for i := s.count - 1 downto 0 do
 172         if Copy(s[i], 1, 18) = '<section id=master' then
 173         begin
 174           s.Delete(i);
 175           break;
 176         end;
 177       ReplaceText := s.Text;
 178     finally
 179       s.Free;
 180     end;
 181   end
 182   else if TagString = 'request' then
 183     ReplaceText := DataModule1.FDTable4.FieldByName('request').AsString;
 184 end;
 185
 186 procedure TWebModule1.articlesHTMLTag(Sender: TObject; Tag: TTag;
 187   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 188 begin
 189   if TagString = 'comment' then
 190     ReplaceText := DataModule1.FDTable2.FieldByName('comment').AsString;
 191 end;
 192
 193 function TWebModule1.detail(ts, pid: string): string;
 194 var
 195   i: Integer;
 196 begin
 197   for i := 0 to ComponentCount - 1 do
 198     if Components[i].Name = ts + pid then
 199       result := (Components[i] as TPageProducer).Content;
 200 end;
 201
 202 procedure TWebModule1.footerHTMLTag(Sender: TObject; Tag: TTag;
 203   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 204 var
 205   i: Integer;
 206 begin
 207   if TagString = 'link' then
 208   begin
 209     for i := 1 to 10 do
 210       if i = index.Tag then
 211         ReplaceText := ReplaceText + ' ' + i.ToString + ' '
 212       else
 213         ReplaceText := ReplaceText +
 214           Format(' <a style=text-decoration-line:none href="%s?db=%d&num=%d">%d</a> ',
 215           [PString(Self.Tag)^, DataModule1.FDTable1.FieldByName('dbnum')
 216           .AsInteger, i, i]);
 217   end
 218   else if TagString = 'recent' then
 219     if index.Tag = -1 then
 220       ReplaceText := TagString
 221     else
 222       ReplaceText := '<a style=text-decoration-line:none href="' +
 223         PString(Self.Tag)^ + '?db=' + DataModule1.FDTable1.FieldByName('dbnum')
 224         .AsString + '">recent</a>';
 225 end;
 226
 227 function TWebModule1.hash(str: string): string;
 228 begin
 229   with TIdHashSHA1.Create do
 230   begin
 231     try
 232       result := HashStringAsHex(str);
 233     finally
 234       Free;
 235     end;
 236   end;
 237 end;
 238
 239 procedure TWebModule1.headerHTMLTag(Sender: TObject; Tag: TTag;
 240   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 241 var
 242   s: string;
 243 begin
 244   if TagString = 'cookie' then
 245   begin
 246     s := TagParams.Values['param'];
 247     ReplaceText := TNetEncoding.URL.Decode(Request.CookieFields.Values[s]);
 248   end
 249   else if (TagString = 'check') and
 250     (Request.ContentFields.Values['show'] <> 'false') then
 251     ReplaceText := 'checked'
 252   else if TagString = 'preview' then
 253     ReplaceText := Request.ContentFields.Values['preview']
 254   else if TagString = 'raw' then
 255     ReplaceText := Request.ContentFields.Values['raw']
 256   else if TagString = 'pass' then
 257     ReplaceText := Request.ContentFields.Values['password']
 258   else if TagString = 'title' then
 259     ReplaceText := Request.ContentFields.Values['title'];
 260 end;
 261
 262 procedure TWebModule1.helpHTMLTag(Sender: TObject; Tag: TTag;
 263   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 264 begin
 265   if TagString = 'pr' then
 266     ReplaceText := promotion;
 267 end;
 268
 269 procedure TWebModule1.indexHTMLTag(Sender: TObject; Tag: TTag;
 270   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 271 var
 272   i: Integer;
 273   x: Boolean;
 274 begin
 275   if TagString = 'pr' then
 276     ReplaceText := promotion
 277   else if TagString = 'article' then
 278   begin
 279     x := DataModule1.FDTable1.FieldByName('dbnum')
 280       .AsInteger = DataModule1.FDTable3.FieldByName('info').AsInteger;
 281     for i := 1 to DataModule1.FDTable3.FieldByName('count').AsInteger do
 282     begin
 283       if DataModule1.FDTable2.Eof = true then
 284         break;
 285       if x = false then
 286         ReplaceText := ReplaceText + articles.Content
 287       else
 288         ReplaceText := articles.Content + ReplaceText;
 289       if DataModule1.FDTable2.Eof = false then
 290         DataModule1.FDTable2.Next;
 291     end;
 292   end
 293   else if TagString = 'footer' then
 294     ReplaceText := footer.Content
 295   else if TagString = 'header' then
 296   begin
 297     i := DataModule1.FDTable3.FieldByName('count').AsInteger;
 298     if 10 * i <= DataModule1.FDTable2.RecordCount then
 299       ReplaceText := '<h1>\82±\82ê\88È\8fã\93\8a\8de\82Å\82«\82Ü\82¹\82ñ.</h1>'
 300     else
 301       ReplaceText := header.Content;
 302   end
 303   else if (TagString = 'css') or (TagString = 'js') then
 304     ReplaceText := detail(TagString, TagParams.Values['id'])
 305   else if TagString = 'dbnum' then
 306     ReplaceText := DataModule1.FDTable1.FieldByName('dbnum').AsString
 307   else if TagString = 'database' then
 308     ReplaceText := DataModule1.FDTable1.FieldByName('database').AsString;
 309 end;
 310
 311 procedure TWebModule1.itemsHTMLTag(Sender: TObject; Tag: TTag;
 312   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 313 var
 314   s: TStringList;
 315   t, str: string;
 316   i, j: Integer;
 317 begin
 318   if TagString = 'item' then
 319   begin
 320     s := TStringList.Create;
 321     try
 322       s.Text := DataModule1.FDTable2.FieldByName('raw').AsString;
 323       for i := 0 to s.count - 1 do
 324         for j := 0 to ss.count - 1 do
 325           if Pos(ss[j], s[i]) > 0 then
 326             if Self.Tag = 0 then
 327               s[i] := '<p style=background-color:aqua>' + s[i]
 328             else
 329               s[i] := '<p style=background-color:yellow>' + s[i];
 330       with DataModule1.FDTable2 do
 331       begin
 332         i := FieldByName('dbnum').AsInteger;
 333         j := FieldByName('number').AsInteger;
 334         str := Request.QueryFields.Values['db'];
 335         if str = '' then
 336           t := Format('<a href="/jump?db=%d&num=%d">[ %d-%d ]</a>',
 337             [DataModule1.FDTable1.FieldByName('dbnum').AsInteger, j, i, j])
 338         else
 339           t := Format('<a href="/jump?db=%s&num=%d">[ %d ]</a>', [str, j, j]);
 340       end;
 341       ReplaceText := t + s.Text;
 342     finally
 343       s.Free;
 344     end;
 345   end;
 346 end;
 347
 348 procedure TWebModule1.loginHTMLTag(Sender: TObject; Tag: TTag;
 349   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 350 begin
 351   if TagString = 'pr' then
 352     ReplaceText := promotion;
 353 end;
 354
 355 procedure TWebModule1.masterHTMLTag(Sender: TObject; Tag: TTag;
 356   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 357 begin
 358   if TagString = 'pr' then
 359     ReplaceText := promotion
 360   else if TagString = 'request' then
 361     with DataModule1.FDTable4 do
 362     begin
 363       First;
 364       ReplaceText := '<table border=1 align=center>';
 365       while Eof = false do
 366       begin
 367         ReplaceText := ReplaceText + alert.Content;
 368         Next;
 369       end;
 370       ReplaceText := ReplaceText + '</table>';
 371     end;
 372 end;
 373
 374 function TWebModule1.mente: Boolean;
 375 begin
 376   if DataModule1.FDTable3.FieldByName('mente').AsBoolean = true then
 377   begin
 378     result := true;
 379     Response.Content :=
 380       '<p><br><h1 style=text-align:center>\82½\82¾\82¢\82Ü\83\81\83\93\83e\83i\83\93\83X\92\86\82Å\82·^_^</h1>' +
 381       '<p style=text-align:center><a href=/admin>\8aÇ\97\9d\8eÒ\97p\83\8d\83O\83C\83\93</a>'
 382   end
 383   else
 384     result := false;
 385 end;
 386
 387 procedure TWebModule1.pages(count: Integer; var page: Integer);
 388 var
 389   max: Integer;
 390 begin
 391   max := DataModule1.FDTable3.FieldByName('count').AsInteger;
 392   if (page > -1) and (count < max * (page - 1)) then
 393   begin
 394     page := (count div max) + 1;
 395     if count mod max = 0 then
 396       dec(page);
 397   end;
 398   case page of
 399     - 1:
 400       begin
 401         DataModule1.FDTable2.Last;
 402         DataModule1.FDTable2.MoveBy(1 - max);
 403       end;
 404   else
 405     DataModule1.FDTable2.First;
 406     DataModule1.FDTable2.MoveBy(max * (page - 1));
 407   end;
 408 end;
 409
 410 procedure TWebModule1.mailHTMLTag(Sender: TObject; Tag: TTag;
 411   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 412 begin
 413   if TagString = 'pr' then
 414     ReplaceText := promotion
 415   else if TagString = 'content' then
 416     ReplaceText := articles.Content
 417   else if TagString = 'query' then
 418     ReplaceText := '?' + Request.Query
 419   else if TagString = 'number' then
 420     ReplaceText := Request.QueryFields.Values['num'];
 421 end;
 422
 423 procedure TWebModule1.searchHTMLTag(Sender: TObject; Tag: TTag;
 424   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 425 var
 426   s: TStringList;
 427   procedure sub;
 428   var
 429     i: Integer;
 430     j: Integer;
 431   label jump;
 432   begin
 433     DataModule1.FDTable2.First;
 434     while DataModule1.FDTable2.Eof = false do
 435     begin
 436       s.Text := DataModule1.FDTable2.FieldByName('raw').AsString;
 437       ss.DelimitedText := Request.ContentFields.Values['word1'];
 438       for j := 0 to ss.count - 1 do
 439         for i := 0 to s.count - 1 do
 440           if Pos(ss[j], s[i]) > 0 then
 441             if Self.Tag = 0 then
 442             begin
 443               ReplaceText := ReplaceText + items.Content;
 444               goto jump;
 445             end
 446             else
 447             begin
 448               if j = ss.count - 1 then
 449               begin
 450                 ReplaceText := ReplaceText + items.Content;
 451                 goto jump;
 452               end
 453               else
 454                 break;
 455             end
 456           else if i = s.count - 1 then
 457             goto jump;
 458     jump:
 459       DataModule1.FDTable2.Next;
 460     end;
 461   end;
 462
 463 begin
 464   if TagString = 'pr' then
 465     ReplaceText := promotion
 466   else if (Request.MethodType = mtPost) and (TagString = 'items') then
 467   begin
 468     if Request.ContentFields.Values['type'] = 'OR' then
 469       Self.Tag := 0
 470     else
 471       Self.Tag := 1;
 472     s := TStringList.Create;
 473     ss := TStringList.Create;
 474     try
 475       ss.Delimiter := ' ';
 476       ss.StrictDelimiter := false;
 477       if Request.QueryFields.Values['db'] = '' then
 478       begin
 479         DataModule1.FDTable1.First;
 480         while DataModule1.FDTable1.Eof = false do
 481         begin
 482           sub;
 483           DataModule1.FDTable1.Next;
 484         end;
 485       end
 486       else
 487         sub;
 488     finally
 489       s.Free;
 490       ss.Free;
 491     end;
 492   end
 493   else if TagString = 'query' then
 494   begin
 495     ReplaceText := Request.Query;
 496     if ReplaceText <> '' then
 497       ReplaceText := '?' + ReplaceText;
 498   end
 499   else if TagString = 'css' then
 500     ReplaceText := css2.Content;
 501 end;
 502
 503 procedure TWebModule1.tiHTMLTag(Sender: TObject; Tag: TTag;
 504   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 505 begin
 506   if TagString = 'count' then
 507   begin
 508     DataModule1.FDTable1.Locate('dbnum',
 509       DataModule1.FDQuery1.FieldByName('dbnum').AsInteger);
 510     ReplaceText := DataModule1.FDTable2.RecordCount.ToString;
 511   end
 512   else if TagString = 'database' then
 513     ReplaceText := DataModule1.FDTable1.Lookup('dbnum',
 514       DataModule1.FDQuery1.FieldByName('dbnum').AsInteger, 'database');
 515 end;
 516
 517 procedure TWebModule1.titleHTMLTag(Sender: TObject; Tag: TTag;
 518   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 519 begin
 520   if TagString = 'pr' then
 521     ReplaceText := promotion
 522   else if TagString = 'js' then
 523     ReplaceText := detail(TagString, TagParams.Values['id'])
 524   else if TagString = 'main' then
 525     with DataModule1.FDQuery1 do
 526     begin
 527       Open;
 528       while Eof = false do
 529       begin
 530         ReplaceText := ReplaceText + ti.Content;
 531         Next;
 532       end;
 533       Close;
 534     end;
 535 end;
 536
 537 procedure TWebModule1.topHTMLTag(Sender: TObject; Tag: TTag;
 538   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 539 var
 540   s, t: string;
 541   i, j, k: Integer;
 542 begin
 543   if TagString = 'pr' then
 544     ReplaceText := promotion
 545   else if TagString = 'list' then
 546   begin
 547     i := DataModule1.FDTable3.FieldByName('info').AsInteger;
 548     for k := 0 to tcnt do
 549     begin
 550       if DataModule1.FDTable1.Eof = true then
 551         break;
 552       t := '';
 553       j := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
 554       if i = j then
 555       begin
 556         DataModule1.FDTable1.Next;
 557         continue;
 558       end;
 559       s := DataModule1.FDTable1.FieldByName('database').AsString;
 560       DataModule1.FDTable2.Last;
 561       if Now - DataModule1.FDTable2.FieldByName('date').AsDateTime < 1 then
 562         t := 'background-color:aqua;';
 563       if DataModule1.FDTable2.RecordCount >= 10 *
 564         DataModule1.FDTable3.FieldByName('count').AsInteger then
 565         t := t + 'color:red;';
 566       if t <> '' then
 567         t := ' style=' + t;
 568       ReplaceText := ReplaceText +
 569         Format('<p><a%s target=_blank href="/index?db=%d">%s</a><br></p>',
 570         [t, j, s]);
 571       DataModule1.FDTable1.Next;
 572     end;
 573   end
 574   else if TagString = 'info' then
 575     ReplaceText := DataModule1.FDTable1.Lookup('dbnum',
 576       DataModule1.FDTable3.FieldByName('info').AsInteger, 'database')
 577   else if TagString = 'dbnum' then
 578     ReplaceText := DataModule1.FDTable3.FieldByName('info').AsString
 579   else if (TagString = 'css') or (TagString = 'js') then
 580     ReplaceText := detail(TagString, TagParams.Values['id'])
 581   else if TagString = 'slide' then
 582   begin
 583     for i := 1 to (DataModule1.FDTable1.RecordCount div tcnt) + 1 do
 584       ReplaceText := ReplaceText +
 585         '<div class="slide"><img src="/src?name=slide' + i.ToString +
 586         '.jpg" style=float:right;height:465px><#list></div>';
 587   end;
 588 end;
 589
 590 procedure TWebModule1.WebModule1admdelAction(Sender: TObject;
 591   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 592 var
 593   i, j, k, m: Integer;
 594   reg: TRegEx;
 595   match: TMatch;
 596 begin
 597   j := 0;
 598   DataModule1.FDTable2.RecNo := admin.Tag;
 599   for i := 0 to Request.ContentFields.count - 1 do
 600   begin
 601     reg := TRegEx.Create('\d+');
 602     match := reg.match(Request.ContentFields[i]);
 603     if match.Success = true then
 604     begin
 605       k := match.Value.ToInteger - j - 1;
 606       j := match.Value.ToInteger;
 607       for m := 1 to k do
 608         DataModule1.FDTable2.Next;
 609       DataModule1.FDTable2.Delete;
 610     end;
 611   end;
 612   WebModule1adminAction(nil, Request, Response, Handled);
 613 end;
 614
 615 procedure TWebModule1.WebModule1adminAction(Sender: TObject;
 616   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 617 var
 618   s: string;
 619   i: Integer;
 620 begin
 621   if hash(Request.CookieFields.Values['user']) <>
 622     DataModule1.FDTable3.FieldByName('password').AsString then
 623   begin
 624     Response.SendRedirect('/login');
 625     Exit;
 626   end;
 627   admin.MaxRows := DataModule1.FDTable3.FieldByName('count').AsInteger;
 628   s := Request.QueryFields.Values['db'];
 629   if s <> '' then
 630     DataModule1.FDTable1.Locate('dbnum', s, []);
 631   s := Request.QueryFields.Values['num'];
 632   i := StrToIntDef(s, -1);
 633   pages(DataModule1.FDTable2.RecordCount, i);
 634   index.Tag := i;
 635   s := '/admin';
 636   Self.Tag := Integer(@s);
 637   i := footer.HTMLDoc.Add
 638     ('<p style=text-align:center><a href="/index?db=<#dbnum>">\96ß\82é</a>');
 639   admin.header.Text := adhead.Content;
 640   if admin.Tag = 0 then
 641     admin.footer.Insert(3, footer.Content)
 642   else
 643   begin
 644     admin.footer.Delete(3);
 645     admin.footer.Insert(3, footer.Content);
 646   end;
 647   admin.Tag := DataModule1.FDTable2.RecNo;
 648   footer.HTMLDoc.Delete(i);
 649   Response.ContentType := 'text/html;charset=utf-8';
 650   Response.Content := admin.Content;
 651 end;
 652
 653 procedure TWebModule1.WebModule1adminsetAction(Sender: TObject;
 654   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 655 var
 656   s: string;
 657 begin
 658   s := hash(Request.ContentFields.Values['pass']);
 659   with DataModule1.FDTable3 do
 660   begin
 661     Edit;
 662     FieldByName('mente').AsBoolean := Request.ContentFields.Values
 663       ['mente'] = 'on';
 664     FieldByName('password').AsString := hash(s);
 665     Post;
 666   end;
 667   with Response.Cookies.Add do
 668   begin
 669     Name := 'user';
 670     Value := s;
 671     Expires := Now + 14;
 672     Secure := true;
 673   end;
 674   Request.CookieFields.Values['user'] := s;
 675   WebModule1adminAction(nil, Request, Response, Handled);
 676 end;
 677
 678 procedure TWebModule1.WebModule1alertAction(Sender: TObject;
 679   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 680 var
 681   num1, num2, i, dbnum: Integer;
 682 begin
 683   dbnum := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
 684   num1 := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
 685   num2 := Request.QueryFields.Values['num'].ToInteger;
 686   if Request.MethodType = mtGet then
 687   begin
 688     DataModule1.FDTable2.Locate('number', num2, []);
 689     Response.ContentType := 'text/html;charset=utf-8';
 690     Response.Content := mail.Content;
 691   end
 692   else
 693     with DataModule1.FDTable4 do
 694     begin
 695       Last;
 696       i := FieldByName('id').AsInteger + 1;
 697       AppendRecord([i, num1, num2, Now, Request.ContentFields.Values
 698         ['request']]);
 699       pages(DataModule1.FDTable2.RecNo, i);
 700       Response.SendRedirect(Format('/index?db=%d&num=%d#%d', [dbnum, i, num2]));
 701     end;
 702 end;
 703
 704 procedure TWebModule1.WebModule1deleteAction(Sender: TObject;
 705   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 706 var
 707   num: Integer;
 708   s: string;
 709 begin
 710   s := Request.ContentFields.Values['num'];
 711   if s = '' then
 712     Exit;
 713   num := s.ToInteger;
 714   s := hash(Request.ContentFields.Values['password']);
 715   with DataModule1.FDTable2 do
 716     if Locate('number;pass', VarArrayOf([num, s])) = true then
 717     begin
 718       Edit;
 719       FieldByName('title').AsString := '';
 720       FieldByName('name').AsString := ' - - - ';
 721       FieldByName('comment').AsString := '<em>\93\8a\8de\8eÒ\82É\82æ\82è\8dí\8f\9c\82³\82ê\82Ü\82µ\82½.</em>';
 722       FieldByName('raw').AsString := '';
 723       FieldByName('date').AsDateTime := Now;
 724       Post;
 725       WebModule1jumpAction(nil, Request, Response, Handled);
 726     end
 727     else
 728       WebModule1indexpageAction(nil, Request, Response, Handled);
 729 end;
 730
 731 procedure TWebModule1.WebModule1fileAction(Sender: TObject;
 732   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 733 var
 734   s: string;
 735 begin
 736   s := Request.QueryFields.Values['type'];
 737   if s = 'js' then
 738     Response.ContentType := 'text/javascript'
 739   else if s = 'css' then
 740     Response.ContentType := 'text/css';
 741   Response.Content := detail(s, Request.QueryFields.Values['id']);
 742 end;
 743
 744 procedure TWebModule1.WebModule1helpAction(Sender: TObject;
 745   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 746 var
 747   i, j: Integer;
 748   s: string;
 749 begin
 750   Response.ContentType := 'text/html;charset=utf-8';
 751   if Request.MethodType = mtPost then
 752   begin
 753     i := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;;
 754     j := DataModule1.FDTable2.FieldByName('number').AsInteger;
 755     s := Request.ContentFields.Values['help'];
 756     DataModule1.FDTable4.AppendRecord([i, j, s]);
 757   end;
 758   Response.Content := help.Content;
 759 end;
 760
 761 procedure TWebModule1.WebModule1imgAction(Sender: TObject; Request: TWebRequest;
 762   Response: TWebResponse; var Handled: Boolean);
 763 var
 764   s: string;
 765   res: TResourceStream;
 766 begin
 767   with DataModule1.FDTable5 do
 768   begin
 769     s := Request.ContentFields.Values['name'];
 770     Response.ContentType := 'image/jpeg';
 771     if Locate('name', s) = true then
 772       Response.ContentStream := CreateBlobStream(FieldByName('source'), bmRead)
 773     else if s = 'sprites.png' then
 774     begin
 775       Response.ContentType := 'image/png';
 776       res := TResourceStream.Create(HInstance, 'PngImage_1', RT_RCDATA);
 777       Response.ContentStream := res;
 778     end
 779     else
 780       Response.ContentStream := nil;
 781   end;
 782 end;
 783
 784 procedure TWebModule1.WebModule1indexpageAction(Sender: TObject;
 785   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 786 var
 787   int: Integer;
 788   s: string;
 789 begin
 790   s := Request.QueryFields.Values['db'];
 791   if s <> '' then
 792     DataModule1.FDTable1.Locate('dbnum', s, []);
 793   int := StrToIntDef(Request.QueryFields.Values['num'], -1);
 794   pages(DataModule1.FDTable2.RecordCount, int);
 795   index.Tag := int;
 796   s := '/index';
 797   Self.Tag := Integer(@s);
 798   Response.ContentType := 'text/html; charset="utf-8"';
 799   if mente = false then
 800     Response.Content := index.Content;
 801 end;
 802
 803 procedure TWebModule1.WebModule1jumpAction(Sender: TObject;
 804   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 805 var
 806   DB, s: string;
 807   page: Integer;
 808 begin
 809   DB := Request.QueryFields.Values['db'];
 810   s := Request.ContentFields.Values['num'];
 811   if DB <> '' then
 812     DataModule1.FDTable1.Locate('dbnum', DB.ToInteger, []);
 813   DataModule1.FDTable2.Locate('number', s.ToInteger, []);
 814   page := 10;
 815   pages(DataModule1.FDTable2.RecNo, page);
 816   Response.SendRedirect(Format('/index?db=%s&num=%d#%s', [DB, page, s]));
 817 end;
 818
 819 procedure TWebModule1.WebModule1linkAction(Sender: TObject;
 820   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 821 var
 822   num: Integer;
 823   s: string;
 824 begin
 825   s := Request.QueryFields.Values['num'];
 826   if s = '' then
 827     Exit;
 828   num := s.ToInteger;
 829   if DataModule1.FDTable2.Locate('number', num, []) = true then
 830   begin
 831     Response.ContentType := 'text/html;charset=utf-8';
 832     Response.Content := articles.Content;
 833   end;
 834 end;
 835
 836 procedure TWebModule1.WebModule1loginAction(Sender: TObject;
 837   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 838 var
 839   i: Integer;
 840 begin
 841   if Request.MethodType = mtGet then
 842   begin
 843     Response.ContentType := 'text/html;charset=utf-8';
 844     Response.Content := login.Content;
 845     Exit;
 846   end;
 847   with Response.Cookies.Add do
 848   begin
 849     Name := 'user';
 850     Value := hash(Request.ContentFields.Values['password']);
 851     Expires := Now + 14;
 852 //    Secure := true;
 853   end;
 854   i := DataModule1.FDTable1.Lookup('database',
 855     Request.ContentFields.Values['record'], 'dbnum');
 856   Response.SendRedirect('/admin?db='+i.ToString);
 857 end;
 858
 859 procedure TWebModule1.WebModule1logoutAction(Sender: TObject;
 860   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 861 begin
 862   with Response.Cookies.Add do
 863   begin
 864     Name := 'user';
 865     Expires := Now - 1;
 866   end;
 867   WebModule1indexpageAction(nil, Request, Response, Handled);
 868 end;
 869
 870 procedure TWebModule1.WebModule1masterAction(Sender: TObject;
 871   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 872 var
 873   s: string;
 874   i: Integer;
 875 begin
 876   if Request.MethodType = mtPost then
 877   begin
 878     s := Request.ContentFields.Values['delete'];
 879     if s = 'all' then
 880       with DataModule1.FDTable4 do
 881         while (Bof = false) or (Eof = false) do
 882           Delete
 883     else
 884     begin
 885       DataModule1.FDTable4.First;
 886       while DataModule1.FDTable4.Eof = false do
 887       begin
 888         i := DataModule1.FDTable4.FieldByName('dbname').AsInteger;
 889         if DataModule1.FDTable1.Locate('dbnum', i) = true then
 890         begin
 891           i := DataModule1.FDTable4.FieldByName('posnum').AsInteger;
 892           if DataModule1.FDTable2.Locate('number', i) = false then
 893           begin
 894             DataModule1.FDTable4.Delete;
 895             continue;
 896           end;
 897         end;
 898         DataModule1.FDTable4.Next;
 899       end;
 900     end;
 901   end;
 902   Response.ContentType := 'text/html;charset=utf-8';
 903   Response.Content := master.Content;
 904 end;
 905
 906 procedure TWebModule1.WebModule1registAction(Sender: TObject;
 907   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 908 var
 909   number, i: Integer;
 910   title, na, raw, pass, kotoba, error: string;
 911   comment: TStringList;
 912   x: Boolean;
 913   function scan(Text: string): string;
 914   var
 915     reg: TRegEx;
 916     coll: TMatchCollection;
 917     j: Integer;
 918     s, t: string;
 919   begin
 920     Text := TNetEncoding.HTML.Encode(Text);
 921     s := TNetEncoding.HTML.Encode('>>');
 922     reg := TRegEx.Create(s + '(\d+)');
 923     coll := reg.Matches(Text);
 924     for j := coll.count - 1 downto 0 do
 925     begin
 926       Delete(Text, coll[j].index, coll[j].Length);
 927       t := Copy(coll[j].Value, Length(s) + 1, coll[j].Length);
 928       result := Format
 929         ('<a class=minpreview data-preview-url=/link?num=%s href=/jump?num=%s>>>%s</a>',
 930         [t, t, t]);
 931       Insert(result, Text, coll[j].index);
 932     end;
 933     result := Text;
 934   end;
 935
 936 begin
 937   error := '';
 938   kotoba := Request.ContentFields.Values['aikotoba'];
 939   if kotoba <> '\82°\82ñ\82«' then
 940     error := '<section style=color:red><p>\8d\87\8c¾\97t\82ª\82¿\82ª\82¢\82Ü\82·.';
 941   with DataModule1.FDTable2 do
 942   begin
 943     Last;
 944     number := FieldByName('number').AsInteger + 1;
 945   end;
 946   with Request.ContentFields do
 947   begin
 948     title := Values['title'];
 949     na := Values['name'];
 950     raw := Values['comment'];
 951     pass := hash(Values['password']);
 952   end;
 953   if title = '' then
 954     title := '\83^\83C\83g\83\8b\82È\82µ.';
 955   with Response.Cookies.Add do
 956   begin
 957     Name := 'name';
 958     if na = '' then
 959       Value := '\92N\82©\82³\82ñ.'
 960     else
 961       Value := na;
 962     Expires := Now + 14;
 963   end;
 964   if error = '' then
 965     with Response.Cookies.Add do
 966     begin
 967       Name := 'aikotoba';
 968       Value := kotoba;
 969       Expires := Now + 14;
 970     end;
 971   comment := TStringList.Create;
 972   try
 973     comment.Text := raw;
 974     for i := 0 to comment.count - 1 do
 975     begin
 976       if Pos('ng', comment[i]) > 0 then
 977       begin
 978         error := error + '<p>\8bÖ\8e~\8cê\8bå\82ª\8aÜ\82Ü\82ê\82Ä\82¢\82Ü\82·.';
 979         break;
 980       end;
 981       comment[i] := '<p>' + scan(comment[i]);
 982     end;
 983     x := Request.ContentFields.Values['show'] = 'true';
 984     if error <> '' then
 985       error := error + '</section>'
 986     else if x = true then
 987     begin
 988       error := '<p style=font-size:2.3em;color:blue>\81«\81«\83v\83\8c\83r\83\85\81[\81«\81«<p>' +
 989         comment.Text;
 990       Request.ContentFields.Values['show'] := 'false';
 991       Request.ContentFields.Values['preview'] := error;
 992       Request.ContentFields.Values['raw'] := raw;
 993     end
 994     else
 995     begin
 996       i := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
 997       DataModule1.FDTable2.AppendRecord([i, number, title, na, comment.Text,
 998         raw, Now, pass]);
 999       Response.SendRedirect('index?db=' + i.ToString + '#article');
1000       Exit;
1001     end;
1002   finally
1003     comment.Free;
1004   end;
1005   WebModule1indexpageAction(nil, Request, Response, Handled);
1006 end;
1007
1008 procedure TWebModule1.WebModule1searchAction(Sender: TObject;
1009   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
1010 begin
1011   Response.ContentType := 'text/html;charset=utf-8';
1012   Response.Content := search.Content;
1013 end;
1014
1015 procedure TWebModule1.WebModule1titleAction(Sender: TObject;
1016   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
1017 begin
1018   Response.ContentType := 'text/html;charset=utf-8';
1019   Response.Content := title.Content;
1020 end;
1021
1022 procedure TWebModule1.WebModule1topAction(Sender: TObject; Request: TWebRequest;
1023   Response: TWebResponse; var Handled: Boolean);
1024 begin
1025   Response.ContentType := 'text/html;charset=utf-8';
1026   DataModule1.FDTable1.First;
1027   if mente = false then
1028     Response.Content := top.ContentFromString(top.Content);
1029 end;
1030
1031 procedure TWebModule1.WebModuleCreate(Sender: TObject);
1032 var
1033   i: Integer;
1034   a: Variant;
1035 begin
1036   with DataModule1 do
1037   begin
1038     if FDTable1.Exists = false then
1039       FDTable1.CreateTable;
1040     if FDTable2.Exists = false then
1041       FDTable2.CreateTable;
1042     if FDTable3.Exists = false then
1043       FDTable3.CreateTable;
1044     if FDTable4.Exists = false then
1045       FDTable4.CreateTable;
1046     if FDTable5.Exists = false then
1047       FDTable5.CreateTable;
1048     FDTable1.Open;
1049     FDTable2.Open;
1050     FDTable3.Open;
1051     FDTable4.Open;
1052     FDTable5.Open;
1053     FDTable1.Refresh;
1054     FDTable3.Refresh;
1055     FDTable5.Refresh;
1056   end;
1057   if DataModule1.FDTable1.Bof and DataModule1.FDTable1.Eof then
1058   begin
1059     DataModule1.FDTable1.AppendRecord([0, 'info']);
1060     for i := 1 to 10 do
1061       DataModule1.FDTable1.AppendRecord([i, '\8cf\8e¦\94Â' + i.ToString]);
1062   end;
1063   if DataModule1.FDTable3.Bof and DataModule1.FDTable3.Eof then
1064   begin
1065     a := DataModule1.FDTable1.Lookup('database', 'info', 'dbnum');
1066     DataModule1.FDTable3.AppendRecord
1067       (['\82Æ\82é\82Ë\81`\82Ç\8d\86',
1068       '<h1 style=color:maron;text-align:center;font-style:italic>\82Æ\82é\82Ë\81`\82Ç\8d\86</h1>',
1069       false, a, 30, hash(hash('admin'))]);
1070   end;
1071 end;
1072
1073 end.