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