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