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     tagstr: string;
 110     procedure pages(count: Integer; var page: Integer);
 111     procedure strsCheck(var error: string; var list: TStringList);
 112     function isInfo: Boolean;
 113     function loginCheck: Boolean;
 114     function hash(str: string): string;
 115     function mente: Boolean;
 116     function detail(ts, pid: string): string;
 117   public
 118     { public \90é\8c¾ }
 119   end;
 120
 121 var
 122   WebModuleClass: TComponentClass = TWebModule1;
 123
 124 implementation
 125
 126 { %CLASSGROUP 'Vcl.Controls.TControl' }
 127
 128 uses Unit1, IdHashSHA, IdGlobal, IdHash, IdHashMessageDigest;
 129
 130 {$R *.dfm}
 131
 132 const
 133   promotion = '\8dL\8d\90:';
 134   tcnt = 7;
 135
 136 procedure TWebModule1.adheadHTMLTag(Sender: TObject; Tag: TTag;
 137   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 138 begin
 139   if TagString = 'pr' then
 140     ReplaceText := promotion
 141   else if (TagString = 'mente') and
 142     (DataModule1.FDTable3.FieldByName('mente').AsBoolean = true) then
 143     ReplaceText := 'checked'
 144   else if TagString = 'database' then
 145     ReplaceText := Request.QueryFields.Values['db'];
 146 end;
 147
 148 procedure TWebModule1.adminFormatCell(Sender: TObject;
 149   CellRow, CellColumn: Integer; var BgColor: THTMLBgColor;
 150   var Align: THTMLAlign; var VAlign: THTMLVAlign;
 151   var CustomAttrs, CellData: string);
 152 begin
 153   if (CellColumn = 0) and (CellRow > 0) then
 154     CellData := Format('<input name=check%d type=checkbox>', [CellRow]);
 155 end;
 156
 157 procedure TWebModule1.alertHTMLTag(Sender: TObject; Tag: TTag;
 158   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 159 var
 160   s: TStringList;
 161   i: Integer;
 162 begin
 163   if (TagString = 'plus') and (alert.Tag = 0) then
 164     ReplaceText :=
 165       '<a href=/jump?db=<#dbname>&num=<#posnum>>[ <#dbname>-<#posnum> ]</a>'
 166   else if TagString = 'article' then
 167   begin
 168     with DataModule1 do
 169       if (FDTable1.Locate('dbnum', FDTable4.FieldByName('dbname').AsInteger)
 170         = false) or (FDTable2.Locate('number', FDTable4.FieldByName('posnum')
 171         .AsInteger) = false) then
 172       begin
 173         ReplaceText := '<p>\83\8a\83N\83G\83X\83g';
 174         Exit;
 175       end;
 176     s := TStringList.Create;
 177     try
 178       s.Text := articles.Content;
 179       for i := 1 to 2 do
 180         s.Delete(1);
 181       for i := s.count - 1 downto 0 do
 182         if Copy(s[i], 1, 18) = '<section id=master' then
 183         begin
 184           s.Delete(i);
 185           break;
 186         end;
 187       ReplaceText := s.Text;
 188     finally
 189       s.Free;
 190     end;
 191   end
 192   else if TagString = 'request' then
 193     ReplaceText := DataModule1.FDTable4.FieldByName('request').AsString;
 194 end;
 195
 196 procedure TWebModule1.articlesHTMLTag(Sender: TObject; Tag: TTag;
 197   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 198 begin
 199   if TagString = 'comment' then
 200     ReplaceText := DataModule1.FDTable2.FieldByName('comment').AsString;
 201 end;
 202
 203 function TWebModule1.detail(ts, pid: string): string;
 204 var
 205   i: Integer;
 206 begin
 207   for i := 0 to ComponentCount - 1 do
 208     if Components[i].Name = ts + pid then
 209       result := (Components[i] as TPageProducer).Content;
 210 end;
 211
 212 procedure TWebModule1.footerHTMLTag(Sender: TObject; Tag: TTag;
 213   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 214 var
 215   i: Integer;
 216 begin
 217   if TagString = 'link' then
 218   begin
 219     for i := 1 to 10 do
 220       if i = index.Tag then
 221         ReplaceText := ReplaceText + ' ' + i.ToString + ' '
 222       else
 223         ReplaceText := ReplaceText +
 224           Format(' <a style=text-decoration-line:none href="%s?db=%d&num=%d">%d</a> ',
 225           [PString(Self.Tag)^, DataModule1.FDTable1.FieldByName('dbnum')
 226           .AsInteger, i, i]);
 227   end
 228   else if TagString = 'recent' then
 229     if index.Tag = -1 then
 230       ReplaceText := TagString
 231     else
 232       ReplaceText := '<a style=text-decoration-line:none href="' +
 233         PString(Self.Tag)^ + '?db=' + DataModule1.FDTable1.FieldByName('dbnum')
 234         .AsString + '">recent</a>';
 235 end;
 236
 237 function TWebModule1.hash(str: string): string;
 238 begin
 239   with TIdHashSHA1.Create do
 240   begin
 241     try
 242       result := HashStringAsHex(str);
 243     finally
 244       Free;
 245     end;
 246   end;
 247 end;
 248
 249 procedure TWebModule1.headerHTMLTag(Sender: TObject; Tag: TTag;
 250   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 251 var
 252   s: string;
 253 begin
 254   if TagString = 'cookie' then
 255   begin
 256     s := TagParams.Values['param'];
 257     ReplaceText := TNetEncoding.URL.Decode(Request.CookieFields.Values[s]);
 258   end
 259   else if (TagString = 'check') and
 260     (Request.ContentFields.Values['show'] <> 'false') then
 261     ReplaceText := 'checked'
 262   else if TagString = 'preview' then
 263     ReplaceText := Request.ContentFields.Values['preview']
 264   else if TagString = 'raw' then
 265     ReplaceText := Request.ContentFields.Values['raw']
 266   else if TagString = 'pass' then
 267     ReplaceText := Request.ContentFields.Values['password']
 268   else if TagString = 'title' then
 269     ReplaceText := Request.ContentFields.Values['title'];
 270 end;
 271
 272 procedure TWebModule1.helpHTMLTag(Sender: TObject; Tag: TTag;
 273   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 274 begin
 275   if TagString = 'pr' then
 276     ReplaceText := promotion
 277   else if TagString = 'area' then
 278     if help.Tag = 0 then
 279     begin
 280       ss := TStringList.Create;
 281       try
 282         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>');
 283         ss.Add('<textarea name=help style=height:100px;width:250px>\93\8a\8de\8eÒ\96¼\82È\82Ç\81F');
 284         ss.Add('\91\8a\92k\93à\97e\81F');
 285         ss.Add('\82»\82Ì\91¼\81F</textarea><br>');
 286         ss.Add('<input type=submit value="\91\97\90M"></form>');
 287         ReplaceText := ss.Text;
 288       finally
 289         ss.Free;
 290       end;
 291     end
 292     else
 293       ReplaceText :=
 294         '<p style=color:yellow;background-color:aqua>\82²\95ñ\8d\90\82 \82è\82ª\82Æ\82¤\82²\82´\82¢\82Ü\82·.';
 295 end;
 296
 297 procedure TWebModule1.indexHTMLTag(Sender: TObject; Tag: TTag;
 298   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 299 var
 300   i: Integer;
 301   x: Boolean;
 302 begin
 303   if TagString = 'pr' then
 304     ReplaceText := promotion
 305   else if TagString = 'article' then
 306   begin
 307     x := DataModule1.FDTable1.FieldByName('dbnum')
 308       .AsInteger = DataModule1.FDTable3.FieldByName('info').AsInteger;
 309     for i := 1 to DataModule1.FDTable3.FieldByName('count').AsInteger do
 310     begin
 311       if DataModule1.FDTable2.Eof = true then
 312         break;
 313       if x = false then
 314         ReplaceText := ReplaceText + articles.Content
 315       else
 316         ReplaceText := articles.Content + ReplaceText;
 317       if DataModule1.FDTable2.Eof = false then
 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.strsCheck(var error: string; var list: TStringList);
 553 var
 554   s: TStringList;
 555   i, j: Integer;
 556   x: Boolean;
 557 begin
 558   s := TStringList.Create;
 559   try
 560     s.DelimitedText := DataModule1.FDTable3.FieldByName('ng').AsString;
 561     for i := 0 to s.count - 1 do
 562       for j := 0 to list.count - 1 do
 563       begin
 564         if Pos(s[i], list[j]) > 0 then
 565           x := true;
 566         list[j] := '<p>' + list[j];
 567       end;
 568   finally
 569     s.Free;
 570   end;
 571   if x = true then
 572     error := error + '<p>\8bÖ\8e~\8cê\8bå\82ª\8aÜ\82Ü\82ê\82Ä\82¢\82Ü\82·.';
 573 end;
 574
 575 procedure TWebModule1.tiHTMLTag(Sender: TObject; Tag: TTag;
 576   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 577 begin
 578   if TagString = 'count' then
 579   begin
 580     DataModule1.FDTable1.Locate('dbnum',
 581       DataModule1.FDQuery1.FieldByName('dbnum').AsInteger);
 582     ReplaceText := DataModule1.FDTable2.RecordCount.ToString;
 583   end
 584   else if TagString = 'database' then
 585     ReplaceText := DataModule1.FDTable1.Lookup('dbnum',
 586       DataModule1.FDQuery1.FieldByName('dbnum').AsInteger, 'database');
 587 end;
 588
 589 procedure TWebModule1.titleHTMLTag(Sender: TObject; Tag: TTag;
 590   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 591 begin
 592   if TagString = 'pr' then
 593     ReplaceText := promotion
 594   else if TagString = 'js' then
 595     ReplaceText := detail(TagString, TagParams.Values['id'])
 596   else if TagString = 'main' then
 597     with DataModule1.FDQuery1 do
 598     begin
 599       Open;
 600       while Eof = false do
 601       begin
 602         ReplaceText := ReplaceText + ti.Content;
 603         Next;
 604       end;
 605       Close;
 606     end;
 607 end;
 608
 609 procedure TWebModule1.topHTMLTag(Sender: TObject; Tag: TTag;
 610   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 611 var
 612   s, t: string;
 613   i, j, k: Integer;
 614 begin
 615   if TagString = 'pr' then
 616     ReplaceText := promotion
 617   else if TagString = 'list' then
 618   begin
 619     i := DataModule1.FDTable3.FieldByName('info').AsInteger;
 620     for k := 0 to tcnt do
 621     begin
 622       if DataModule1.FDTable1.Eof = true then
 623         break;
 624       t := '';
 625       j := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
 626       s := DataModule1.FDTable1.FieldByName('database').AsString;
 627       if (i = j) or (s = 'master') then
 628       begin
 629         DataModule1.FDTable1.Next;
 630         continue;
 631       end;
 632       DataModule1.FDTable2.Last;
 633       if Now - DataModule1.FDTable2.FieldByName('date').AsDateTime < 1 then
 634         t := 'background-color:aqua;';
 635       if DataModule1.FDTable2.RecordCount >= 10 *
 636         DataModule1.FDTable3.FieldByName('count').AsInteger then
 637         t := t + 'color:red;';
 638       if t <> '' then
 639         t := ' style=' + t;
 640       ReplaceText := ReplaceText +
 641         Format('<p><a%s target=_blank href="/index?db=%d">%s</a><br></p>',
 642         [t, j, s]);
 643       DataModule1.FDTable1.Next;
 644     end;
 645   end
 646   else if TagString = 'info' then
 647     ReplaceText := DataModule1.FDTable1.Lookup('dbnum',
 648       DataModule1.FDTable3.FieldByName('info').AsInteger, 'database')
 649   else if TagString = 'dbnum' then
 650     ReplaceText := DataModule1.FDTable3.FieldByName('info').AsString
 651   else if (TagString = 'css') or (TagString = 'js') then
 652     ReplaceText := detail(TagString, TagParams.Values['id'])
 653   else if TagString = 'slide' then
 654   begin
 655     for i := 1 to (DataModule1.FDTable1.RecordCount div tcnt) + 1 do
 656       ReplaceText := ReplaceText +
 657         '<div class="slide"><img src="/src?name=slide' + i.ToString +
 658         '.jpg" style=float:right;height:465px><#list></div>';
 659   end;
 660 end;
 661
 662 procedure TWebModule1.WebModule1admdelAction(Sender: TObject;
 663   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 664 var
 665   i, j, k, m: Integer;
 666   reg: TRegEx;
 667   match: TMatch;
 668 begin
 669   j := 0;
 670   DataModule1.FDTable2.RecNo := admin.Tag;
 671   for i := 0 to Request.ContentFields.count - 1 do
 672   begin
 673     reg := TRegEx.Create('\d+');
 674     match := reg.match(Request.ContentFields[i]);
 675     if match.Success = true then
 676     begin
 677       k := match.Value.ToInteger - j - 1;
 678       j := match.Value.ToInteger;
 679       for m := 1 to k do
 680         DataModule1.FDTable2.Next;
 681       DataModule1.FDTable2.Delete;
 682     end;
 683   end;
 684   WebModule1adminAction(nil, Request, Response, Handled);
 685 end;
 686
 687 procedure TWebModule1.WebModule1adminAction(Sender: TObject;
 688   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 689 var
 690   s, t: string;
 691   i: Integer;
 692 begin
 693   s := Request.CookieFields.Values['user'];
 694   if (s = '') or (loginCheck = false) then
 695   begin
 696     WebModule1loginAction(nil, Request, Response, Handled);
 697     Exit;
 698   end;
 699   admin.MaxRows := DataModule1.FDTable3.FieldByName('count').AsInteger;
 700   t := Request.QueryFields.Values['db'];
 701   if t <> '' then
 702     DataModule1.FDTable1.Locate('dbnum', t, []);
 703   s := Request.QueryFields.Values['num'];
 704   i := StrToIntDef(s, -1);
 705   pages(DataModule1.FDTable2.RecordCount, i);
 706   index.Tag := i;
 707   tagstr := '/admin';
 708   Self.Tag := Integer(@tagstr);
 709   admin.header.Text := adhead.Content;
 710   admin.footer.Clear;
 711   admin.footer.Add
 712     ('<input type=submit value=\8dí\8f\9c\82·\82é><input type=reset value=\83\8a\83Z\83b\83g></form>');
 713   admin.footer.Add(footer.Content);
 714   if t <> '' then
 715     t := '?db=' + t;
 716   admin.footer.Add('<p style=text-align:center><a href="/index' + t +
 717     '">\96ß\82é</a>');
 718   admin.Tag := DataModule1.FDTable2.RecNo;
 719   Response.ContentType := 'text/html;charset=utf-8';
 720   Response.Content := admin.Content;
 721 end;
 722
 723 procedure TWebModule1.WebModule1adminsetAction(Sender: TObject;
 724   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 725 var
 726   s: string;
 727 begin
 728   s := Request.ContentFields.Values['pass'];
 729   with DataModule1.FDTable3 do
 730   begin
 731     Edit;
 732     FieldByName('mente').AsBoolean := Request.ContentFields.Values
 733       ['mente'] = 'on';
 734     if s <> '' then
 735     begin
 736       s := hash(s);
 737       FieldByName('password').AsString := hash(s);
 738       with Response.Cookies.Add do
 739       begin
 740         Name := 'user';
 741         Value := s;
 742         Expires := Now + 14;
 743         Secure := true;
 744       end;
 745     end;
 746     Post;
 747   end;
 748   WebModule1adminAction(nil, Request, Response, Handled);
 749 end;
 750
 751 procedure TWebModule1.WebModule1alertAction(Sender: TObject;
 752   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 753 var
 754   num1, num2, i: Integer;
 755   s: string;
 756 begin
 757   num1 := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
 758   num2 := StrToIntDef(Request.QueryFields.Values['num'], -1);
 759   if num2 = -1 then
 760     num1 := -1;
 761   if Request.MethodType = mtGet then
 762   begin
 763     DataModule1.FDTable2.Locate('number', num2, []);
 764     Response.ContentType := 'text/html;charset=utf-8';
 765     Response.Content := mail.Content;
 766   end
 767   else
 768   begin
 769     with DataModule1.FDTable4 do
 770     begin
 771       Last;
 772       i := FieldByName('id').AsInteger + 1;
 773       s := Request.ContentFields.Values['request'];
 774       if s = '' then
 775         s := '(No Comment)';
 776       AppendRecord([i, num1, num2, Now, s]);
 777     end;
 778     if num1 > -1 then
 779       Response.SendRedirect(Format('/index?db=%d&num=%d#%d',
 780         [num1, num2, num2]))
 781     else
 782       Response.SendRedirect('/top');
 783   end;
 784 end;
 785
 786 procedure TWebModule1.WebModule1deleteAction(Sender: TObject;
 787   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 788 var
 789   num: Integer;
 790   s: string;
 791 begin
 792   s := Request.ContentFields.Values['num'];
 793   if s = '' then
 794     Exit;
 795   num := s.ToInteger;
 796   s := hash(Request.ContentFields.Values['password']);
 797   with DataModule1.FDTable2 do
 798     if Locate('number;pass', VarArrayOf([num, s])) = true then
 799     begin
 800       Edit;
 801       FieldByName('title').AsString := '';
 802       FieldByName('name').AsString := ' - - - ';
 803       FieldByName('comment').AsString := '<em>\93\8a\8de\8eÒ\82É\82æ\82è\8dí\8f\9c\82³\82ê\82Ü\82µ\82½.</em>';
 804       FieldByName('raw').AsString := '';
 805       FieldByName('date').AsDateTime := Now;
 806       Post;
 807       WebModule1jumpAction(nil, Request, Response, Handled);
 808     end
 809     else
 810       WebModule1indexpageAction(nil, Request, Response, Handled);
 811 end;
 812
 813 procedure TWebModule1.WebModule1fileAction(Sender: TObject;
 814   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 815 var
 816   s: string;
 817 begin
 818   s := Request.QueryFields.Values['type'];
 819   if s = 'js' then
 820     Response.ContentType := 'text/javascript'
 821   else if s = 'css' then
 822     Response.ContentType := 'text/css';
 823   Response.Content := detail(s, Request.QueryFields.Values['id']);
 824 end;
 825
 826 procedure TWebModule1.WebModule1helpAction(Sender: TObject;
 827   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 828 var
 829   k: Integer;
 830   s: string;
 831 begin
 832   Response.ContentType := 'text/html;charset=utf-8';
 833   if Request.MethodType = mtPost then
 834   begin
 835     s := Request.ContentFields.Values['help'];
 836     DataModule1.FDTable4.Last;
 837     k := DataModule1.FDTable4.FieldByName('id').AsInteger + 1;
 838     DataModule1.FDTable4.AppendRecord([k, -1, -1, Now, s]);
 839     help.Tag := 1;
 840   end
 841   else
 842     help.Tag := 0;
 843   Response.Content := help.Content;
 844 end;
 845
 846 procedure TWebModule1.WebModule1imgAction(Sender: TObject; Request: TWebRequest;
 847   Response: TWebResponse; var Handled: Boolean);
 848 var
 849   s: string;
 850   res: TResourceStream;
 851 begin
 852   with DataModule1.FDTable5 do
 853   begin
 854     s := Request.ContentFields.Values['name'];
 855     Response.ContentType := 'image/jpeg';
 856     if Locate('name', s) = true then
 857       Response.ContentStream := CreateBlobStream(FieldByName('source'), bmRead)
 858     else if s = 'sprites.png' then
 859     begin
 860       Response.ContentType := 'image/png';
 861       res := TResourceStream.Create(HInstance, 'PngImage_1', RT_RCDATA);
 862       Response.ContentStream := res;
 863     end
 864     else
 865       Response.ContentStream := nil;
 866   end;
 867 end;
 868
 869 procedure TWebModule1.WebModule1indexpageAction(Sender: TObject;
 870   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 871 var
 872   i: Integer;
 873   s: string;
 874 begin
 875   s := Request.QueryFields.Values['db'];
 876   if s <> '' then
 877     DataModule1.FDTable1.Locate('dbnum', s, []);
 878   i := StrToIntDef(Request.QueryFields.Values['num'], -1);
 879   pages(DataModule1.FDTable2.RecordCount, i);
 880   index.Tag := i;
 881   tagstr := '/index';
 882   Self.Tag := Integer(@tagstr);
 883   Response.ContentType := 'text/html; charset="utf-8"';
 884   s := DataModule1.FDTable2.IndexFieldNames;
 885   if isInfo = true then
 886     DataModule1.FDTable2.IndexFieldNames := Copy(s, 1, Length(s) - 2) + 'DN'
 887   else
 888     DataModule1.FDTable2.IndexFieldNames := Copy(s, 1, Length(s) - 2) + 'AN';
 889   if mente = false then
 890     Response.Content := index.Content;
 891 end;
 892
 893 procedure TWebModule1.WebModule1jumpAction(Sender: TObject;
 894   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 895 var
 896   DB, s: string;
 897   page: Integer;
 898 begin
 899   DB := Request.QueryFields.Values['db'];
 900   s := Request.ContentFields.Values['num'];
 901   if DB <> '' then
 902     DataModule1.FDTable1.Locate('dbnum', DB.ToInteger, []);
 903   DataModule1.FDTable2.Locate('number', s.ToInteger, []);
 904   page := 10;
 905   pages(DataModule1.FDTable2.RecNo, page);
 906   Response.SendRedirect(Format('/index?db=%s&num=%d#%s', [DB, page, s]));
 907 end;
 908
 909 procedure TWebModule1.WebModule1linkAction(Sender: TObject;
 910   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 911 var
 912   num: Integer;
 913   s: string;
 914 begin
 915   s := Request.QueryFields.Values['num'];
 916   if s = '' then
 917     Exit;
 918   num := s.ToInteger;
 919   if DataModule1.FDTable2.Locate('number', num, []) = true then
 920   begin
 921     Response.ContentType := 'text/html;charset=utf-8';
 922     Response.Content := articles.Content;
 923   end;
 924 end;
 925
 926 procedure TWebModule1.WebModule1loginAction(Sender: TObject;
 927   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 928 var
 929   v: Variant;
 930   i: Integer;
 931   s: string;
 932 begin
 933   if Request.MethodType = mtGet then
 934   begin
 935     Response.ContentType := 'text/html;charset=utf-8';
 936     Response.Content := login.Content;
 937     Exit;
 938   end;
 939   s := Request.ContentFields.Values['record'];
 940   v := DataModule1.FDTable1.Lookup('database', s, 'dbnum');
 941   if VarIsNull(v) = false then
 942   begin
 943     with Response.Cookies.Add do
 944     begin
 945       Name := 'user';
 946       Value := hash(Request.ContentFields.Values['password']);
 947       Expires := Now + 14;
 948       // Secure := true;
 949     end;
 950     i := v;
 951     if s = 'master' then
 952       Response.SendRedirect('/master')
 953     else
 954       Response.SendRedirect('/admin?db=' + i.ToString);
 955   end
 956   else
 957   begin
 958     Response.ContentType := 'text/html;charset=utf-8';
 959     Response.Content := login.Content;
 960   end;
 961 end;
 962
 963 procedure TWebModule1.WebModule1logoutAction(Sender: TObject;
 964   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 965 var
 966   i: Integer;
 967   s: string;
 968   x: Boolean;
 969 begin
 970   with Response.Cookies.Add do
 971   begin
 972     Name := 'user';
 973     Expires := Now - 1;
 974   end;
 975   s := Request.QueryFields.Values['db'];
 976   i := StrToIntDef(s, -1);
 977   x := DataModule1.FDTable1.Locate('dbnum', i);
 978   if (x = true) and (DataModule1.FDTable1.FieldByName('database')
 979     .AsString = 'master') then
 980     x := false;
 981   if x = false then
 982     Response.SendRedirect('/')
 983   else
 984     Response.SendRedirect('/index?db=' + s);
 985 end;
 986
 987 procedure TWebModule1.WebModule1masterAction(Sender: TObject;
 988   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 989 var
 990   s: string;
 991   i: Integer;
 992 begin
 993   if loginCheck = false then
 994   begin
 995     with DataModule1.FDTable1 do
 996       if Locate('database', 'master') = false then
 997       begin
 998         Last;
 999         i := FieldByName('dbnum').AsInteger + 1;
1000         AppendRecord([i, 'master']);
1001       end;
1002     WebModule1loginAction(nil, Request, Response, Handled);
1003     Exit;
1004   end;
1005   if Request.MethodType = mtPost then
1006   begin
1007     s := Request.ContentFields.Values['delete'];
1008     if s = 'all' then
1009       with DataModule1.FDTable4 do
1010         while (Bof = false) or (Eof = false) do
1011           Delete
1012     else
1013     begin
1014       DataModule1.FDTable4.First;
1015       while DataModule1.FDTable4.Eof = false do
1016       begin
1017         i := DataModule1.FDTable4.FieldByName('dbname').AsInteger;
1018         if DataModule1.FDTable1.Locate('dbnum', i) = true then
1019         begin
1020           i := DataModule1.FDTable4.FieldByName('posnum').AsInteger;
1021           if DataModule1.FDTable2.Locate('number', i) = false then
1022             DataModule1.FDTable4.Delete
1023           else
1024             DataModule1.FDTable4.Next;
1025         end
1026         else
1027           DataModule1.FDTable4.Delete;
1028       end;
1029     end;
1030   end;
1031   Response.ContentType := 'text/html;charset=utf-8';
1032   Response.Content := master.Content;
1033 end;
1034
1035 procedure TWebModule1.WebModule1registAction(Sender: TObject;
1036   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
1037 var
1038   number, i: Integer;
1039   title, na, raw, pass, kotoba, error: string;
1040   s: string;
1041   comment: TStringList;
1042   function scan(Text: string): string;
1043   var
1044     reg: TRegEx;
1045     coll: TMatchCollection;
1046     j: Integer;
1047     s, t: string;
1048   begin
1049     Text := TNetEncoding.HTML.Encode(Text);
1050     s := TNetEncoding.HTML.Encode('>>');
1051     reg := TRegEx.Create(s + '(\d+)');
1052     coll := reg.Matches(Text);
1053     for j := coll.count - 1 downto 0 do
1054     begin
1055       Delete(Text, coll[j].index, coll[j].Length);
1056       t := Copy(coll[j].Value, Length(s) + 1, coll[j].Length);
1057       result := Format
1058         ('<a class=minpreview data-preview-url=/link?num=%s href=/jump?num=%s>>>%s</a>',
1059         [t, t, t]);
1060       Insert(result, Text, coll[j].index);
1061     end;
1062     result := Text;
1063   end;
1064
1065 begin
1066   error := '';
1067   kotoba := Request.ContentFields.Values['aikotoba'];
1068   if kotoba <> '\82°\82ñ\82«' then
1069     error := '<section style=color:red><p>\8d\87\8c¾\97t\82ª\82¿\82ª\82¢\82Ü\82·.';
1070   with DataModule1.FDTable2 do
1071   begin
1072     if isInfo = true then
1073       First
1074     else
1075       Last;
1076     number := FieldByName('number').AsInteger + 1;
1077   end;
1078   with Request.ContentFields do
1079   begin
1080     title := Values['title'];
1081     na := Values['name'];
1082     raw := Values['comment'];
1083     pass := hash(Values['password']);
1084   end;
1085   if title = '' then
1086     title := '\83^\83C\83g\83\8b\82È\82µ.';
1087   with Response.Cookies.Add do
1088   begin
1089     Name := 'name';
1090     if na = '' then
1091       Value := '\92N\82©\82³\82ñ.'
1092     else
1093       Value := na;
1094     Expires := Now + 14;
1095   end;
1096   if error = '' then
1097     with Response.Cookies.Add do
1098     begin
1099       Name := 'aikotoba';
1100       Value := kotoba;
1101       Expires := Now + 14;
1102     end;
1103   comment := TStringList.Create;
1104   try
1105     comment.Text := raw;
1106     strsCheck(error, comment);
1107     Request.ContentFields.Values['show'] := 'false';
1108     Request.ContentFields.Values['raw'] := raw;
1109     if error <> '' then
1110       Request.ContentFields.Values['preview'] := error + '</section>'
1111     else if Request.ContentFields.Values['show'] = 'true' then
1112     begin
1113       error := '<p style=font-size:2.3em;color:blue>\81«\81«\83v\83\8c\83r\83\85\81[\81«\81«<p>' +
1114         comment.Text;
1115       Request.ContentFields.Values['preview'] := error;
1116     end
1117     else
1118     begin
1119       s := DataModule1.FDTable2.IndexFieldNames;
1120       if s[Length(s)] = 'N' then
1121       begin
1122         s := Copy(s, 1, Length(s) - 3);
1123         DataModule1.FDTable2.IndexFieldNames := s;
1124       end;
1125       i := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
1126       DataModule1.FDTable2.AppendRecord([i, number, title, na, comment.Text,
1127         raw, Now, pass]);
1128       if isInfo = true then
1129         s := s + ':DN'
1130       else
1131         s := s + ':AN';
1132       DataModule1.FDTable2.IndexFieldNames := s;
1133       Response.SendRedirect('index?db=' + i.ToString + '#article');
1134       Exit;
1135     end;
1136   finally
1137     comment.Free;
1138   end;
1139   WebModule1indexpageAction(nil, Request, Response, Handled);
1140 end;
1141
1142 procedure TWebModule1.WebModule1searchAction(Sender: TObject;
1143   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
1144 begin
1145   Response.ContentType := 'text/html;charset=utf-8';
1146   Response.Content := search.Content;
1147 end;
1148
1149 procedure TWebModule1.WebModule1titleAction(Sender: TObject;
1150   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
1151 begin
1152   Response.ContentType := 'text/html;charset=utf-8';
1153   Response.Content := title.Content;
1154 end;
1155
1156 procedure TWebModule1.WebModule1topAction(Sender: TObject; Request: TWebRequest;
1157   Response: TWebResponse; var Handled: Boolean);
1158 begin
1159   Response.ContentType := 'text/html;charset=utf-8';
1160   DataModule1.FDTable1.First;
1161   if mente = false then
1162     Response.Content := top.ContentFromString(top.Content);
1163 end;
1164
1165 procedure TWebModule1.WebModuleCreate(Sender: TObject);
1166 var
1167   i: Integer;
1168   a: Variant;
1169   s: string;
1170 begin
1171   with DataModule1 do
1172   begin
1173     if FDTable1.Exists = false then
1174       FDTable1.CreateTable;
1175     if FDTable2.Exists = false then
1176       FDTable2.CreateTable;
1177     if FDTable3.Exists = false then
1178       FDTable3.CreateTable;
1179     if FDTable4.Exists = false then
1180       FDTable4.CreateTable;
1181     if FDTable5.Exists = false then
1182       FDTable5.CreateTable;
1183     FDTable1.Open;
1184     FDTable2.Open;
1185     FDTable3.Open;
1186     FDTable4.Open;
1187     FDTable5.Open;
1188     FDTable1.Refresh;
1189     FDTable3.Refresh;
1190     FDTable5.Refresh;
1191   end;
1192   if DataModule1.FDTable1.Bof and DataModule1.FDTable1.Eof then
1193   begin
1194     DataModule1.FDTable1.AppendRecord([0, 'info']);
1195     for i := 1 to 10 do
1196       DataModule1.FDTable1.AppendRecord([i, '\8cf\8e¦\94Â' + i.ToString]);
1197   end;
1198   if DataModule1.FDTable3.Bof and DataModule1.FDTable3.Eof then
1199   begin
1200     a := DataModule1.FDTable1.Lookup('database', 'info', 'dbnum');
1201     s := '\88¢\95Û,\94n\8e,\8e\80\82Ë';
1202     DataModule1.FDTable3.AppendRecord
1203       (['\82Æ\82é\82Ë\81`\82Ç\8d\86',
1204       '<h1 style=color:maron;text-align:center;font-style:italic>\82Æ\82é\82Ë\81`\82Ç\8d\86</h1>',
1205       false, a, 30, hash(hash('admin')), s]);
1206   end;
1207 end;
1208
1209 end.