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: string;
 624   i: Integer;
 625 begin
 626   if hash(Request.CookieFields.Values['user']) <>
 627     DataModule1.FDTable3.FieldByName('password').AsString then
 628   begin
 629     Response.SendRedirect('/login');
 630     Exit;
 631   end;
 632   admin.MaxRows := DataModule1.FDTable3.FieldByName('count').AsInteger;
 633   s := Request.QueryFields.Values['db'];
 634   if s <> '' then
 635     DataModule1.FDTable1.Locate('dbnum', s, []);
 636   s := Request.QueryFields.Values['num'];
 637   i := StrToIntDef(s, -1);
 638   pages(DataModule1.FDTable2.RecordCount, i);
 639   index.Tag := i;
 640   tagstr := '/admin';
 641   Self.Tag := Integer(@tagstr);
 642   admin.header.Text := adhead.Content;
 643   admin.Footer.Clear;
 644   admin.Footer.Add('<input type=submit value=\8dí\8f\9c\82·\82é><input type=reset value=\83\8a\83Z\83b\83g></form>');
 645   admin.Footer.Add(footer.Content);
 646   admin.Footer.Add('<p style=text-align:center><a href="/index?db=<#dbnum>">\96ß\82é</a>');
 647   admin.Tag := DataModule1.FDTable2.RecNo;
 648   Response.ContentType := 'text/html;charset=utf-8';
 649   Response.Content := admin.Content;
 650 end;
 651
 652 procedure TWebModule1.WebModule1adminsetAction(Sender: TObject;
 653   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 654 var
 655   s: string;
 656 begin
 657   s := hash(Request.ContentFields.Values['pass']);
 658   with DataModule1.FDTable3 do
 659   begin
 660     Edit;
 661     FieldByName('mente').AsBoolean := Request.ContentFields.Values
 662       ['mente'] = 'on';
 663     FieldByName('password').AsString := hash(s);
 664     Post;
 665   end;
 666   with Response.Cookies.Add do
 667   begin
 668     Name := 'user';
 669     Value := s;
 670     Expires := Now + 14;
 671     Secure := true;
 672   end;
 673   Request.CookieFields.Values['user'] := s;
 674   WebModule1adminAction(nil, Request, Response, Handled);
 675 end;
 676
 677 procedure TWebModule1.WebModule1alertAction(Sender: TObject;
 678   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 679 var
 680   num1, num2, i, dbnum: Integer;
 681 begin
 682   dbnum := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
 683   num1 := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
 684   num2 := Request.QueryFields.Values['num'].ToInteger;
 685   if Request.MethodType = mtGet then
 686   begin
 687     DataModule1.FDTable2.Locate('number', num2, []);
 688     Response.ContentType := 'text/html;charset=utf-8';
 689     Response.Content := mail.Content;
 690   end
 691   else
 692     with DataModule1.FDTable4 do
 693     begin
 694       Last;
 695       i := FieldByName('id').AsInteger + 1;
 696       AppendRecord([i, num1, num2, Now, Request.ContentFields.Values
 697         ['request']]);
 698       pages(DataModule1.FDTable2.RecNo, i);
 699       Response.SendRedirect(Format('/index?db=%d&num=%d#%d', [dbnum, i, num2]));
 700     end;
 701 end;
 702
 703 procedure TWebModule1.WebModule1deleteAction(Sender: TObject;
 704   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 705 var
 706   num: Integer;
 707   s: string;
 708 begin
 709   s := Request.ContentFields.Values['num'];
 710   if s = '' then
 711     Exit;
 712   num := s.ToInteger;
 713   s := hash(Request.ContentFields.Values['password']);
 714   with DataModule1.FDTable2 do
 715     if Locate('number;pass', VarArrayOf([num, s])) = true then
 716     begin
 717       Edit;
 718       FieldByName('title').AsString := '';
 719       FieldByName('name').AsString := ' - - - ';
 720       FieldByName('comment').AsString := '<em>\93\8a\8de\8eÒ\82É\82æ\82è\8dí\8f\9c\82³\82ê\82Ü\82µ\82½.</em>';
 721       FieldByName('raw').AsString := '';
 722       FieldByName('date').AsDateTime := Now;
 723       Post;
 724       WebModule1jumpAction(nil, Request, Response, Handled);
 725     end
 726     else
 727       WebModule1indexpageAction(nil, Request, Response, Handled);
 728 end;
 729
 730 procedure TWebModule1.WebModule1fileAction(Sender: TObject;
 731   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 732 var
 733   s: string;
 734 begin
 735   s := Request.QueryFields.Values['type'];
 736   if s = 'js' then
 737     Response.ContentType := 'text/javascript'
 738   else if s = 'css' then
 739     Response.ContentType := 'text/css';
 740   Response.Content := detail(s, Request.QueryFields.Values['id']);
 741 end;
 742
 743 procedure TWebModule1.WebModule1helpAction(Sender: TObject;
 744   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 745 var
 746   i, j: Integer;
 747   s: string;
 748 begin
 749   Response.ContentType := 'text/html;charset=utf-8';
 750   if Request.MethodType = mtPost then
 751   begin
 752     i := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;;
 753     j := DataModule1.FDTable2.FieldByName('number').AsInteger;
 754     s := Request.ContentFields.Values['help'];
 755     DataModule1.FDTable4.AppendRecord([i, j, s]);
 756   end;
 757   Response.Content := help.Content;
 758 end;
 759
 760 procedure TWebModule1.WebModule1imgAction(Sender: TObject; Request: TWebRequest;
 761   Response: TWebResponse; var Handled: Boolean);
 762 var
 763   s: string;
 764   res: TResourceStream;
 765 begin
 766   with DataModule1.FDTable5 do
 767   begin
 768     s := Request.ContentFields.Values['name'];
 769     Response.ContentType := 'image/jpeg';
 770     if Locate('name', s) = true then
 771       Response.ContentStream := CreateBlobStream(FieldByName('source'), bmRead)
 772     else if s = 'sprites.png' then
 773     begin
 774       Response.ContentType := 'image/png';
 775       res := TResourceStream.Create(HInstance, 'PngImage_1', RT_RCDATA);
 776       Response.ContentStream := res;
 777     end
 778     else
 779       Response.ContentStream := nil;
 780   end;
 781 end;
 782
 783 procedure TWebModule1.WebModule1indexpageAction(Sender: TObject;
 784   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 785 var
 786   int: Integer;
 787   s: string;
 788 begin
 789   s := Request.QueryFields.Values['db'];
 790   if s <> '' then
 791     DataModule1.FDTable1.Locate('dbnum', s, []);
 792   int := StrToIntDef(Request.QueryFields.Values['num'], -1);
 793   pages(DataModule1.FDTable2.RecordCount, int);
 794   index.Tag := int;
 795   tagstr := '/index';
 796   Self.Tag := Integer(@tagstr);
 797   Response.ContentType := 'text/html; charset="utf-8"';
 798   if mente = false then
 799     Response.Content := index.Content;
 800 end;
 801
 802 procedure TWebModule1.WebModule1jumpAction(Sender: TObject;
 803   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 804 var
 805   DB, s: string;
 806   page: Integer;
 807 begin
 808   DB := Request.QueryFields.Values['db'];
 809   s := Request.ContentFields.Values['num'];
 810   if DB <> '' then
 811     DataModule1.FDTable1.Locate('dbnum', DB.ToInteger, []);
 812   DataModule1.FDTable2.Locate('number', s.ToInteger, []);
 813   page := 10;
 814   pages(DataModule1.FDTable2.RecNo, page);
 815   Response.SendRedirect(Format('/index?db=%s&num=%d#%s', [DB, page, s]));
 816 end;
 817
 818 procedure TWebModule1.WebModule1linkAction(Sender: TObject;
 819   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 820 var
 821   num: Integer;
 822   s: string;
 823 begin
 824   s := Request.QueryFields.Values['num'];
 825   if s = '' then
 826     Exit;
 827   num := s.ToInteger;
 828   if DataModule1.FDTable2.Locate('number', num, []) = true then
 829   begin
 830     Response.ContentType := 'text/html;charset=utf-8';
 831     Response.Content := articles.Content;
 832   end;
 833 end;
 834
 835 procedure TWebModule1.WebModule1loginAction(Sender: TObject;
 836   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 837 var
 838   i: Integer;
 839   s: string;
 840 begin
 841   if Request.MethodType = mtGet then
 842   begin
 843     Response.ContentType := 'text/html;charset=utf-8';
 844     Response.Content := login.Content;
 845     Exit;
 846   end;
 847   with Response.Cookies.Add do
 848   begin
 849     Name := 'user';
 850     Value := hash(Request.ContentFields.Values['password']);
 851     Expires := Now + 14;
 852     // Secure := true;
 853   end;
 854   s := Request.ContentFields.Values['record'];
 855   if s = 'master' then
 856     Response.SendRedirect('master')
 857   else
 858   begin
 859     i := DataModule1.FDTable1.Lookup('database', s, 'dbnum');
 860     Response.SendRedirect('/admin?db=' + i.ToString);
 861   end;
 862 end;
 863
 864 procedure TWebModule1.WebModule1logoutAction(Sender: TObject;
 865   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 866 var
 867   s: string;
 868 begin
 869   with Response.Cookies.Add do
 870   begin
 871     Name := 'user';
 872     Expires := Now - 1;
 873   end;
 874   s := Request.QueryFields.Values['db'];
 875   if s = 'master' then
 876     Response.SendRedirect('/')
 877   else
 878     Response.SendRedirect('/index?db=' + s);
 879 end;
 880
 881 procedure TWebModule1.WebModule1masterAction(Sender: TObject;
 882   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 883 var
 884   s: string;
 885   i: Integer;
 886 begin
 887   if hash(Request.CookieFields.Values['user']) <>
 888     DataModule1.FDTable3.FieldByName('password').AsString then
 889   begin
 890     with DataModule1.FDTable1 do
 891       if Locate('database', 'master') = false then
 892         AppendRecord([RecordCount, 'master']);
 893     WebModule1loginAction(nil, Request, Response, Handled);
 894     Exit;
 895   end;
 896   if Request.MethodType = mtPost then
 897   begin
 898     s := Request.ContentFields.Values['delete'];
 899     if s = 'all' then
 900       with DataModule1.FDTable4 do
 901         while (Bof = false) or (Eof = false) do
 902           Delete
 903     else
 904     begin
 905       DataModule1.FDTable4.First;
 906       while DataModule1.FDTable4.Eof = false do
 907       begin
 908         i := DataModule1.FDTable4.FieldByName('dbname').AsInteger;
 909         if DataModule1.FDTable1.Locate('dbnum', i) = true then
 910         begin
 911           i := DataModule1.FDTable4.FieldByName('posnum').AsInteger;
 912           if DataModule1.FDTable2.Locate('number', i) = false then
 913           begin
 914             DataModule1.FDTable4.Delete;
 915             continue;
 916           end;
 917         end;
 918         DataModule1.FDTable4.Next;
 919       end;
 920     end;
 921   end;
 922   Response.ContentType := 'text/html;charset=utf-8';
 923   Response.Content := master.Content;
 924 end;
 925
 926 procedure TWebModule1.WebModule1registAction(Sender: TObject;
 927   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 928 var
 929   number, i: Integer;
 930   title, na, raw, pass, kotoba, error: string;
 931   comment: TStringList;
 932   x: Boolean;
 933   function scan(Text: string): string;
 934   var
 935     reg: TRegEx;
 936     coll: TMatchCollection;
 937     j: Integer;
 938     s, t: string;
 939   begin
 940     Text := TNetEncoding.HTML.Encode(Text);
 941     s := TNetEncoding.HTML.Encode('>>');
 942     reg := TRegEx.Create(s + '(\d+)');
 943     coll := reg.Matches(Text);
 944     for j := coll.count - 1 downto 0 do
 945     begin
 946       Delete(Text, coll[j].index, coll[j].Length);
 947       t := Copy(coll[j].Value, Length(s) + 1, coll[j].Length);
 948       result := Format
 949         ('<a class=minpreview data-preview-url=/link?num=%s href=/jump?num=%s>>>%s</a>',
 950         [t, t, t]);
 951       Insert(result, Text, coll[j].index);
 952     end;
 953     result := Text;
 954   end;
 955
 956 begin
 957   error := '';
 958   kotoba := Request.ContentFields.Values['aikotoba'];
 959   if kotoba <> '\82°\82ñ\82«' then
 960     error := '<section style=color:red><p>\8d\87\8c¾\97t\82ª\82¿\82ª\82¢\82Ü\82·.';
 961   with DataModule1.FDTable2 do
 962   begin
 963     Last;
 964     number := FieldByName('number').AsInteger + 1;
 965   end;
 966   with Request.ContentFields do
 967   begin
 968     title := Values['title'];
 969     na := Values['name'];
 970     raw := Values['comment'];
 971     pass := hash(Values['password']);
 972   end;
 973   if title = '' then
 974     title := '\83^\83C\83g\83\8b\82È\82µ.';
 975   with Response.Cookies.Add do
 976   begin
 977     Name := 'name';
 978     if na = '' then
 979       Value := '\92N\82©\82³\82ñ.'
 980     else
 981       Value := na;
 982     Expires := Now + 14;
 983   end;
 984   if error = '' then
 985     with Response.Cookies.Add do
 986     begin
 987       Name := 'aikotoba';
 988       Value := kotoba;
 989       Expires := Now + 14;
 990     end;
 991   comment := TStringList.Create;
 992   try
 993     comment.Text := raw;
 994     for i := 0 to comment.count - 1 do
 995     begin
 996       if Pos('ng', comment[i]) > 0 then
 997       begin
 998         error := error + '<p>\8bÖ\8e~\8cê\8bå\82ª\8aÜ\82Ü\82ê\82Ä\82¢\82Ü\82·.';
 999         break;
1000       end;
1001       comment[i] := '<p>' + scan(comment[i]);
1002     end;
1003     x := Request.ContentFields.Values['show'] = 'true';
1004     if error <> '' then
1005       error := error + '</section>'
1006     else if x = true then
1007     begin
1008       error := '<p style=font-size:2.3em;color:blue>\81«\81«\83v\83\8c\83r\83\85\81[\81«\81«<p>' +
1009         comment.Text;
1010       Request.ContentFields.Values['show'] := 'false';
1011       Request.ContentFields.Values['preview'] := error;
1012       Request.ContentFields.Values['raw'] := raw;
1013     end
1014     else
1015     begin
1016       i := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
1017       DataModule1.FDTable2.AppendRecord([i, number, title, na, comment.Text,
1018         raw, Now, pass]);
1019       Response.SendRedirect('index?db=' + i.ToString + '#article');
1020       Exit;
1021     end;
1022   finally
1023     comment.Free;
1024   end;
1025   WebModule1indexpageAction(nil, Request, Response, Handled);
1026 end;
1027
1028 procedure TWebModule1.WebModule1searchAction(Sender: TObject;
1029   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
1030 begin
1031   Response.ContentType := 'text/html;charset=utf-8';
1032   Response.Content := search.Content;
1033 end;
1034
1035 procedure TWebModule1.WebModule1titleAction(Sender: TObject;
1036   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
1037 begin
1038   Response.ContentType := 'text/html;charset=utf-8';
1039   Response.Content := title.Content;
1040 end;
1041
1042 procedure TWebModule1.WebModule1topAction(Sender: TObject; Request: TWebRequest;
1043   Response: TWebResponse; var Handled: Boolean);
1044 begin
1045   Response.ContentType := 'text/html;charset=utf-8';
1046   DataModule1.FDTable1.First;
1047   if mente = false then
1048     Response.Content := top.ContentFromString(top.Content);
1049 end;
1050
1051 procedure TWebModule1.WebModuleCreate(Sender: TObject);
1052 var
1053   i: Integer;
1054   a: Variant;
1055 begin
1056   with DataModule1 do
1057   begin
1058     if FDTable1.Exists = false then
1059       FDTable1.CreateTable;
1060     if FDTable2.Exists = false then
1061       FDTable2.CreateTable;
1062     if FDTable3.Exists = false then
1063       FDTable3.CreateTable;
1064     if FDTable4.Exists = false then
1065       FDTable4.CreateTable;
1066     if FDTable5.Exists = false then
1067       FDTable5.CreateTable;
1068     FDTable1.Open;
1069     FDTable2.Open;
1070     FDTable3.Open;
1071     FDTable4.Open;
1072     FDTable5.Open;
1073     FDTable1.Refresh;
1074     FDTable3.Refresh;
1075     FDTable5.Refresh;
1076   end;
1077   if DataModule1.FDTable1.Bof and DataModule1.FDTable1.Eof then
1078   begin
1079     DataModule1.FDTable1.AppendRecord([0, 'info']);
1080     for i := 1 to 10 do
1081       DataModule1.FDTable1.AppendRecord([i, '\8cf\8e¦\94Â' + i.ToString]);
1082   end;
1083   if DataModule1.FDTable3.Bof and DataModule1.FDTable3.Eof then
1084   begin
1085     a := DataModule1.FDTable1.Lookup('database', 'info', 'dbnum');
1086     DataModule1.FDTable3.AppendRecord
1087       (['\82Æ\82é\82Ë\81`\82Ç\8d\86',
1088       '<h1 style=color:maron;text-align:center;font-style:italic>\82Æ\82é\82Ë\81`\82Ç\8d\86</h1>',
1089       false, a, 30, hash(hash('admin'))]);
1090   end;
1091 end;
1092
1093 end.