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