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