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