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