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 end;
 551
 552 procedure TWebModule1.setLastArticle;
 553 begin
 554   DataModule1.FDTable2.Last;
 555 end;
 556
 557 procedure TWebModule1.strsCheck(var Error: string; var list: TStringList);
 558 var
 559   s: TStringList;
 560   i, j: Integer;
 561   x: Boolean;
 562 begin
 563   x := false;
 564   s := TStringList.Create;
 565   try
 566     s.DelimitedText := DataModule1.FDTable3.FieldByName('ng').AsString;
 567     for i := 0 to s.count - 1 do
 568       for j := 0 to list.count - 1 do
 569       begin
 570         if Pos(s[i], list[j]) > 0 then
 571           x := true;
 572         list[j] := '<p>' + list[j];
 573       end;
 574   finally
 575     s.Free;
 576   end;
 577   if x = true then
 578     Error := Error + '<p>\8bÖ\8e~\8cê\8bå\82ª\8aÜ\82Ü\82ê\82Ä\82¢\82Ü\82·.';
 579 end;
 580
 581 procedure TWebModule1.tiHTMLTag(Sender: TObject; Tag: TTag;
 582   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 583 begin
 584   if TagString = 'count' then
 585     ReplaceText := DataModule1.FDTable2.RecordCount.ToString
 586   else if TagString = 'database' then
 587     ReplaceText := DataModule1.FDTable1.FieldByName('database').AsString
 588   else if TagString = 'date' then
 589     with DataModule1.FDTable2 do
 590     begin
 591       Last;
 592       ReplaceText := FieldByName('date').AsString;
 593     end;
 594 end;
 595
 596 procedure TWebModule1.titleHTMLTag(Sender: TObject; Tag: TTag;
 597   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 598 begin
 599   if TagString = 'pr' then
 600     ReplaceText := promotion
 601   else if TagString = 'js' then
 602     ReplaceText := detail(TagString, TagParams.Values['id'])
 603   else if TagString = 'main' then
 604     with DataModule1 do
 605     begin
 606       FDQuery1.Open;
 607       FDTable1.First;
 608       while (FDQuery1.Eof = false)and(FDTable1.Eof = false) do
 609       begin
 610         if FDTable1.FieldByName('dbnum').AsInteger = FDQuery1.FieldByName
 611           ('dbnum').AsInteger then
 612         begin
 613           ReplaceText := ReplaceText + ti.Content;
 614           FDQuery1.Next;
 615         end
 616         else if FDTable2.Eof = false then
 617         begin
 618           ti.DataSet := nil;
 619           try
 620             ReplaceText := ReplaceText + ti.Content;
 621           finally
 622             ti.DataSet := FDQuery1;
 623           end;
 624         end;
 625         FDTable1.Next;
 626       end;
 627       FDQuery1.Close;
 628     end;
 629 end;
 630
 631 procedure TWebModule1.topHTMLTag(Sender: TObject; Tag: TTag;
 632   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 633 var
 634   s, t: string;
 635   i, j, k: Integer;
 636 begin
 637   if TagString = 'pr' then
 638     ReplaceText := promotion
 639   else if TagString = 'list' then
 640   begin
 641     i := DataModule1.FDTable3.FieldByName('info').AsInteger;
 642     for k := 0 to tcnt do
 643     begin
 644       if DataModule1.FDTable1.Eof = true then
 645         break;
 646       t := '';
 647       j := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
 648       s := DataModule1.FDTable1.FieldByName('database').AsString;
 649       if (i = j) or (s = 'master') then
 650       begin
 651         DataModule1.FDTable1.Next;
 652         continue;
 653       end;
 654       DataModule1.FDTable2.Last;
 655       if (Now - DataModule1.FDTable2.FieldByName('date').AsDateTime < 1) and
 656         (DataModule1.FDTable2.RecordCount > 0) then
 657         t := 'background-color:aqua;';
 658       if DataModule1.FDTable2.RecordCount >= 10 *
 659         DataModule1.FDTable3.FieldByName('count').AsInteger then
 660         t := t + 'color:red;';
 661       if t <> '' then
 662         t := ' style=' + t;
 663       ReplaceText := ReplaceText +
 664         Format('<p><a%s target=_blank href="/index?db=%d">%s</a><br></p>',
 665         [t, j, s]);
 666       DataModule1.FDTable1.Next;
 667     end;
 668   end
 669   else if TagString = 'info' then
 670     ReplaceText := DataModule1.FDTable1.Lookup('dbnum',
 671       DataModule1.FDTable3.FieldByName('info').AsInteger, 'database')
 672   else if TagString = 'dbnum' then
 673     ReplaceText := DataModule1.FDTable3.FieldByName('info').AsString
 674   else if (TagString = 'css') or (TagString = 'js') then
 675     ReplaceText := detail(TagString, TagParams.Values['id'])
 676   else if TagString = 'slide' then
 677   begin
 678     for i := 1 to (DataModule1.FDTable1.RecordCount div tcnt) + 1 do
 679       ReplaceText := ReplaceText +
 680         '<div class="slide"><img src="/src?name=slide' + i.ToString +
 681         '.jpg" style=float:right;height:465px><#list></div>';
 682   end;
 683 end;
 684
 685 procedure TWebModule1.WebModule1admdelAction(Sender: TObject;
 686   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 687 var
 688   i, j, k, m: Integer;
 689   reg: TRegEx;
 690   match: TMatch;
 691 begin
 692   j := 0;
 693   DataModule1.FDTable2.RecNo := admin.Tag;
 694   for i := 0 to Request.ContentFields.count - 1 do
 695   begin
 696     reg := TRegEx.Create('\d+');
 697     match := reg.match(Request.ContentFields[i]);
 698     if match.Success = true then
 699     begin
 700       k := match.Value.ToInteger - j - 1;
 701       j := match.Value.ToInteger;
 702       for m := 1 to k do
 703         DataModule1.FDTable2.Next;
 704       DataModule1.FDTable2.Delete;
 705     end;
 706   end;
 707   WebModule1adminAction(nil, Request, Response, Handled);
 708 end;
 709
 710 procedure TWebModule1.WebModule1adminAction(Sender: TObject;
 711   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 712 var
 713   s, t: string;
 714   i: Integer;
 715 begin
 716   s := Request.CookieFields.Values['user'];
 717   if (s = '') or (loginCheck = false) then
 718   begin
 719     WebModule1loginAction(nil, Request, Response, Handled);
 720     Exit;
 721   end;
 722   admin.MaxRows := DataModule1.FDTable3.FieldByName('count').AsInteger;
 723   t := Request.QueryFields.Values['db'];
 724   if t <> '' then
 725     DataModule1.FDTable1.Locate('dbnum', t, []);
 726   s := Request.QueryFields.Values['num'];
 727   i := StrToIntDef(s, -1);
 728   pages(DataModule1.FDTable2.RecordCount, i);
 729   index.Tag := i;
 730   tagstr := '/admin';
 731   Self.Tag := Integer(@tagstr);
 732   admin.header.Text := adhead.Content;
 733   admin.footer.Clear;
 734   admin.footer.Add
 735     ('<input type=submit value=\8dí\8f\9c\82·\82é><input type=reset value=\83\8a\83Z\83b\83g></form>');
 736   admin.footer.Add(footer.Content);
 737   if t <> '' then
 738     t := '?db=' + t;
 739   admin.footer.Add('<p style=text-align:center><a href="/index' + t +
 740     '">\96ß\82é</a>');
 741   admin.Tag := DataModule1.FDTable2.RecNo;
 742   Response.ContentType := 'text/html;charset=utf-8';
 743   Response.Content := admin.Content;
 744 end;
 745
 746 procedure TWebModule1.WebModule1adminsetAction(Sender: TObject;
 747   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 748 var
 749   s: string;
 750 begin
 751   s := Request.ContentFields.Values['pass'];
 752   with DataModule1.FDTable3 do
 753   begin
 754     Edit;
 755     FieldByName('mente').AsBoolean := Request.ContentFields.Values
 756       ['mente'] = 'on';
 757     if s <> '' then
 758     begin
 759       s := hash(s);
 760       FieldByName('password').AsString := hash(s);
 761       with Response.Cookies.Add do
 762       begin
 763         Name := 'user';
 764         Value := s;
 765         Expires := Now + 14;
 766         Secure := true;
 767       end;
 768     end;
 769     Post;
 770   end;
 771   WebModule1adminAction(nil, Request, Response, Handled);
 772 end;
 773
 774 procedure TWebModule1.WebModule1alertAction(Sender: TObject;
 775   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 776 var
 777   num1, num2, i: Integer;
 778   s: string;
 779 begin
 780   num1 := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
 781   num2 := StrToIntDef(Request.QueryFields.Values['num'], -1);
 782   if num2 = -1 then
 783     num1 := -1;
 784   if Request.MethodType = mtGet then
 785   begin
 786     DataModule1.FDTable2.Locate('number', num2, []);
 787     Response.ContentType := 'text/html;charset=utf-8';
 788     Response.Content := mail.Content;
 789   end
 790   else
 791   begin
 792     with DataModule1.FDTable4 do
 793     begin
 794       Last;
 795       i := FieldByName('id').AsInteger + 1;
 796       s := Request.ContentFields.Values['request'];
 797       if s = '' then
 798         s := '(No Comment)';
 799       AppendRecord([i, num1, num2, Now, s]);
 800     end;
 801     if num1 > -1 then
 802       Response.SendRedirect(Format('/index?db=%d&num=%d#%d',
 803         [num1, num2, num2]))
 804     else
 805       Response.SendRedirect('/top');
 806   end;
 807 end;
 808
 809 procedure TWebModule1.WebModule1deleteAction(Sender: TObject;
 810   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 811 var
 812   num: Integer;
 813   s: string;
 814 begin
 815   s := Request.ContentFields.Values['num'];
 816   if s = '' then
 817     Exit;
 818   num := s.ToInteger;
 819   s := hash(Request.ContentFields.Values['password']);
 820   with DataModule1.FDTable2 do
 821     if Locate('number;pass', VarArrayOf([num, s])) = true then
 822     begin
 823       Edit;
 824       FieldByName('title').AsString := '';
 825       FieldByName('name').AsString := ' - - - ';
 826       FieldByName('comment').AsString := '<em>\93\8a\8de\8eÒ\82É\82æ\82è\8dí\8f\9c\82³\82ê\82Ü\82µ\82½.</em>';
 827       FieldByName('raw').AsString := '';
 828       FieldByName('date').AsDateTime := Now;
 829       Post;
 830       WebModule1jumpAction(nil, Request, Response, Handled);
 831     end
 832     else
 833       WebModule1indexpageAction(nil, Request, Response, Handled);
 834 end;
 835
 836 procedure TWebModule1.WebModule1fileAction(Sender: TObject;
 837   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 838 var
 839   s: string;
 840 begin
 841   s := Request.QueryFields.Values['type'];
 842   if s = 'js' then
 843     Response.ContentType := 'text/javascript'
 844   else if s = 'css' then
 845     Response.ContentType := 'text/css';
 846   Response.Content := detail(s, Request.QueryFields.Values['id']);
 847 end;
 848
 849 procedure TWebModule1.WebModule1helpAction(Sender: TObject;
 850   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 851 var
 852   k: Integer;
 853   s: string;
 854 begin
 855   Response.ContentType := 'text/html;charset=utf-8';
 856   if Request.MethodType = mtPost then
 857   begin
 858     s := Request.ContentFields.Values['help'];
 859     DataModule1.FDTable4.Last;
 860     k := DataModule1.FDTable4.FieldByName('id').AsInteger + 1;
 861     DataModule1.FDTable4.AppendRecord([k, -1, -1, Now, s]);
 862     help.Tag := 1;
 863   end
 864   else
 865     help.Tag := 0;
 866   Response.Content := help.Content;
 867 end;
 868
 869 procedure TWebModule1.WebModule1imgAction(Sender: TObject; Request: TWebRequest;
 870   Response: TWebResponse; var Handled: Boolean);
 871 var
 872   s: string;
 873   res: TResourceStream;
 874 begin
 875   with DataModule1.FDTable5 do
 876   begin
 877     s := Request.ContentFields.Values['name'];
 878     Response.ContentType := 'image/jpeg';
 879     if Locate('name', s) = true then
 880       Response.ContentStream := CreateBlobStream(FieldByName('source'), bmRead)
 881     else if s = 'sprites.png' then
 882     begin
 883       Response.ContentType := 'image/png';
 884       res := TResourceStream.Create(HInstance, 'PngImage_1', RT_RCDATA);
 885       Response.ContentStream := res;
 886     end
 887     else
 888       Response.ContentStream := nil;
 889   end;
 890 end;
 891
 892 procedure TWebModule1.WebModule1indexpageAction(Sender: TObject;
 893   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 894 var
 895   i: Integer;
 896   s: string;
 897 begin
 898   s := Request.QueryFields.Values['db'];
 899   if s <> '' then
 900     DataModule1.FDTable1.Locate('dbnum', s, []);
 901   i := StrToIntDef(Request.QueryFields.Values['num'], -1);
 902   isInfo;
 903   pages(DataModule1.FDTable2.RecordCount, i);
 904   index.Tag := i;
 905   tagstr := '/index';
 906   Self.Tag := Integer(@tagstr);
 907   Response.ContentType := 'text/html; charset="utf-8"';
 908   if mente = false then
 909     Response.Content := index.Content;
 910 end;
 911
 912 procedure TWebModule1.WebModule1jumpAction(Sender: TObject;
 913   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 914 var
 915   DB, s: string;
 916   page: Integer;
 917 begin
 918   DB := Request.QueryFields.Values['db'];
 919   s := Request.ContentFields.Values['num'];
 920   if DB <> '' then
 921     DataModule1.FDTable1.Locate('dbnum', DB.ToInteger, []);
 922   DataModule1.FDTable2.Locate('number', s.ToInteger, []);
 923   page := 10;
 924   pages(DataModule1.FDTable2.RecNo, page);
 925   Response.SendRedirect(Format('/index?db=%s&num=%d#%s', [DB, page, s]));
 926 end;
 927
 928 procedure TWebModule1.WebModule1linkAction(Sender: TObject;
 929   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 930 var
 931   num: Integer;
 932   s: string;
 933 begin
 934   s := Request.QueryFields.Values['num'];
 935   if s = '' then
 936     Exit;
 937   num := s.ToInteger;
 938   if DataModule1.FDTable2.Locate('number', num, []) = true then
 939   begin
 940     Response.ContentType := 'text/html;charset=utf-8';
 941     Response.Content := articles.Content;
 942   end;
 943 end;
 944
 945 procedure TWebModule1.WebModule1loginAction(Sender: TObject;
 946   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 947 var
 948   v: Variant;
 949   i: Integer;
 950   s: string;
 951 begin
 952   if Request.MethodType = mtGet then
 953   begin
 954     Response.ContentType := 'text/html;charset=utf-8';
 955     Response.Content := login.Content;
 956     Exit;
 957   end;
 958   s := Request.ContentFields.Values['record'];
 959   v := DataModule1.FDTable1.Lookup('database', s, 'dbnum');
 960   if VarIsNull(v) = false then
 961   begin
 962     with Response.Cookies.Add do
 963     begin
 964       Name := 'user';
 965       Value := hash(Request.ContentFields.Values['password']);
 966       Expires := Now + 14;
 967       // Secure := true;
 968     end;
 969     i := v;
 970     if s = 'master' then
 971       Response.SendRedirect('/master')
 972     else
 973       Response.SendRedirect('/admin?db=' + i.ToString);
 974   end
 975   else
 976   begin
 977     Response.ContentType := 'text/html;charset=utf-8';
 978     Response.Content := login.Content;
 979   end;
 980 end;
 981
 982 procedure TWebModule1.WebModule1logoutAction(Sender: TObject;
 983   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 984 var
 985   i: Integer;
 986   s: string;
 987   x: Boolean;
 988 begin
 989   with Response.Cookies.Add do
 990   begin
 991     Name := 'user';
 992     Expires := Now - 1;
 993   end;
 994   s := Request.QueryFields.Values['db'];
 995   i := StrToIntDef(s, -1);
 996   x := DataModule1.FDTable1.Locate('dbnum', i);
 997   if (x = true) and (DataModule1.FDTable1.FieldByName('database')
 998     .AsString = 'master') then
 999     x := false;
1000   if x = false then
1001     Response.SendRedirect('/')
1002   else
1003     Response.SendRedirect('/index?db=' + s);
1004 end;
1005
1006 procedure TWebModule1.WebModule1masterAction(Sender: TObject;
1007   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
1008 var
1009   s: string;
1010   i: Integer;
1011 begin
1012   if loginCheck = false then
1013   begin
1014     with DataModule1.FDTable1 do
1015       if Locate('database', 'master') = false then
1016       begin
1017         Last;
1018         i := FieldByName('dbnum').AsInteger + 1;
1019         AppendRecord([i, 'master']);
1020       end;
1021     WebModule1loginAction(nil, Request, Response, Handled);
1022     Exit;
1023   end;
1024   if Request.MethodType = mtPost then
1025   begin
1026     s := Request.ContentFields.Values['delete'];
1027     if s = 'all' then
1028       with DataModule1.FDTable4 do
1029         while (Bof = false) or (Eof = false) do
1030           Delete
1031     else
1032     begin
1033       DataModule1.FDTable4.First;
1034       while DataModule1.FDTable4.Eof = false do
1035       begin
1036         i := DataModule1.FDTable4.FieldByName('dbname').AsInteger;
1037         if DataModule1.FDTable1.Locate('dbnum', i) = true then
1038         begin
1039           i := DataModule1.FDTable4.FieldByName('posnum').AsInteger;
1040           if DataModule1.FDTable2.Locate('number', i) = false then
1041             DataModule1.FDTable4.Delete
1042           else
1043             DataModule1.FDTable4.Next;
1044         end
1045         else
1046           DataModule1.FDTable4.Delete;
1047       end;
1048     end;
1049   end;
1050   Response.ContentType := 'text/html;charset=utf-8';
1051   Response.Content := master.Content;
1052 end;
1053
1054 procedure TWebModule1.WebModule1registAction(Sender: TObject;
1055   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
1056 var
1057   number, i: Integer;
1058   title, na, raw, pass, kotoba, Error: string;
1059   comment: TStringList;
1060   function scan(Text: string): string;
1061   var
1062     reg: TRegEx;
1063     coll: TMatchCollection;
1064     j: Integer;
1065     s, t: string;
1066   begin
1067     Text := TNetEncoding.HTML.Encode(Text);
1068     s := TNetEncoding.HTML.Encode('>>');
1069     reg := TRegEx.Create(s + '(\d+)');
1070     coll := reg.Matches(Text);
1071     for j := coll.count - 1 downto 0 do
1072     begin
1073       Delete(Text, coll[j].index, coll[j].Length);
1074       t := Copy(coll[j].Value, Length(s) + 1, coll[j].Length);
1075       result := Format
1076         ('<a class=minpreview data-preview-url=/link?num=%s href=/jump?num=%s>>>%s</a>',
1077         [t, t, t]);
1078       Insert(result, Text, coll[j].index);
1079     end;
1080     result := Text;
1081   end;
1082
1083 begin
1084   kotoba := Request.ContentFields.Values['aikotoba'];
1085   Error := '';
1086   if kotoba <> '\82°\82ñ\82«' then
1087     Error := Error + '<p>\8d\87\8c¾\97t\82ª\82¿\82ª\82¢\82Ü\82·.';
1088   setLastArticle;
1089   number := DataModule1.FDTable2.FieldByName('number').AsInteger + 1;
1090   with Request.ContentFields do
1091   begin
1092     title := Values['title'];
1093     na := Values['name'];
1094     raw := Values['comment'];
1095     pass := hash(Values['password']);
1096   end;
1097   if title = '' then
1098     title := '\83^\83C\83g\83\8b\82È\82µ.';
1099   with Response.Cookies.Add do
1100   begin
1101     Name := 'name';
1102     if na = '' then
1103       Value := '\92N\82©\82³\82ñ.'
1104     else
1105       Value := na;
1106     Expires := Now + 14;
1107   end;
1108   if Error = '' then
1109     with Response.Cookies.Add do
1110     begin
1111       Name := 'aikotoba';
1112       Value := kotoba;
1113       Expires := Now + 14;
1114     end;
1115   comment := TStringList.Create;
1116   try
1117     comment.Text := raw;
1118     strsCheck(Error, comment);
1119     Request.ContentFields.Values['raw'] := raw;
1120     if Error <> '' then
1121       Request.ContentFields.Values['preview'] := '<section style=color:red>' +
1122         Error + '</section>'
1123     else if Request.ContentFields.Values['show'] = 'true' then
1124     begin
1125       Error := '<p style=font-size:2.3em;color:blue>\81«\81«\83v\83\8c\83r\83\85\81[\81«\81«<p>' +
1126         comment.Text;
1127       Request.ContentFields.Values['preview'] := Error;
1128       Request.ContentFields.Values['show'] := 'false';
1129     end
1130     else
1131     begin
1132       i := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
1133       DataModule1.FDTable2.AppendRecord([i, number, title, na, comment.Text,
1134         raw, Now, pass]);
1135       Response.SendRedirect('index?db=' + i.ToString + '#article');
1136       Exit;
1137     end;
1138   finally
1139     comment.Free;
1140   end;
1141   WebModule1indexpageAction(nil, Request, Response, Handled);
1142 end;
1143
1144 procedure TWebModule1.WebModule1searchAction(Sender: TObject;
1145   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
1146 begin
1147   Response.ContentType := 'text/html;charset=utf-8';
1148   Response.Content := search.Content;
1149 end;
1150
1151 procedure TWebModule1.WebModule1titleAction(Sender: TObject;
1152   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
1153 begin
1154   Response.ContentType := 'text/html;charset=utf-8';
1155   Response.Content := title.Content;
1156 end;
1157
1158 procedure TWebModule1.WebModule1topAction(Sender: TObject; Request: TWebRequest;
1159   Response: TWebResponse; var Handled: Boolean);
1160 begin
1161   Response.ContentType := 'text/html;charset=utf-8';
1162   DataModule1.FDTable1.First;
1163   if mente = false then
1164     Response.Content := top.ContentFromString(top.Content);
1165 end;
1166
1167 procedure TWebModule1.WebModuleCreate(Sender: TObject);
1168 var
1169   i: Integer;
1170   a: Variant;
1171   s: string;
1172 begin
1173   with DataModule1 do
1174   begin
1175     if FDTable1.Exists = false then
1176       FDTable1.CreateTable;
1177     if FDTable2.Exists = false then
1178       FDTable2.CreateTable;
1179     if FDTable3.Exists = false then
1180       FDTable3.CreateTable;
1181     if FDTable4.Exists = false then
1182       FDTable4.CreateTable;
1183     if FDTable5.Exists = false then
1184       FDTable5.CreateTable;
1185     FDTable1.Open;
1186     FDTable2.Open;
1187     FDTable3.Open;
1188     FDTable4.Open;
1189     FDTable5.Open;
1190     FDTable1.Refresh;
1191     FDTable3.Refresh;
1192     FDTable5.Refresh;
1193   end;
1194   if DataModule1.FDTable1.Bof and DataModule1.FDTable1.Eof then
1195   begin
1196     DataModule1.FDTable1.AppendRecord([0, 'info']);
1197     for i := 1 to 10 do
1198       DataModule1.FDTable1.AppendRecord([i, '\8cf\8e¦\94Â' + i.ToString]);
1199   end;
1200   if DataModule1.FDTable3.Bof and DataModule1.FDTable3.Eof then
1201   begin
1202     a := DataModule1.FDTable1.Lookup('database', 'info', 'dbnum');
1203     s := '\88¢\95Û,\94n\8e,\8e\80\82Ë';
1204     DataModule1.FDTable3.AppendRecord
1205       (['\82Æ\82é\82Ë\81`\82Ç\8d\86',
1206       '<h1 style=color:maron;text-align:center;font-style:italic>\82Æ\82é\82Ë\81`\82Ç\8d\86</h1>',
1207       false, a, 30, hash(hash('admin')), s]);
1208   end;
1209 end;
1210
1211 end.