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
   8 type
   9   TTWebModule1 = class(TWebModule)
  10     articles: TDataSetPageProducer;
  11     index: TDataSetPageProducer;
  12     admin: TDataSetTableProducer;
  13     search: TPageProducer;
  14     items: TDataSetPageProducer;
  15     help: TPageProducer;
  16     top: TPageProducer;
  17     master: TPageProducer;
  18     alert: TDataSetPageProducer;
  19     footer: TDataSetPageProducer;
  20     mail: TPageProducer;
  21     css1: TPageProducer;
  22     css2: TPageProducer;
  23     css3: TPageProducer;
  24     css4: TPageProducer;
  25     header: TDataSetPageProducer;
  26     login: TDataSetPageProducer;
  27     js1: TPageProducer;
  28     js2: TPageProducer;
  29     js3: TPageProducer;
  30     js4: TPageProducer;
  31     js5: TPageProducer;
  32     js6: TPageProducer;
  33     procedure indexHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  34       TagParams: TStrings; var ReplaceText: string);
  35     procedure TWebModule1indexpageAction(Sender: TObject; Request: TWebRequest;
  36       Response: TWebResponse; var Handled: Boolean);
  37     procedure TWebModule1registAction(Sender: TObject; Request: TWebRequest;
  38       Response: TWebResponse; var Handled: Boolean);
  39     procedure WebModuleCreate(Sender: TObject);
  40     procedure TWebModule1adminAction(Sender: TObject; Request: TWebRequest;
  41       Response: TWebResponse; var Handled: Boolean);
  42     procedure TWebModule1topAction(Sender: TObject; Request: TWebRequest;
  43       Response: TWebResponse; var Handled: Boolean);
  44     procedure itemsHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  45       TagParams: TStrings; var ReplaceText: string);
  46     procedure topHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  47       TagParams: TStrings; var ReplaceText: string);
  48     procedure TWebModule1searchAction(Sender: TObject; Request: TWebRequest;
  49       Response: TWebResponse; var Handled: Boolean);
  50     procedure TWebModule1helpAction(Sender: TObject; Request: TWebRequest;
  51       Response: TWebResponse; var Handled: Boolean);
  52     procedure searchHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  53       TagParams: TStrings; var ReplaceText: string);
  54     procedure masterHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  55       TagParams: TStrings; var ReplaceText: string);
  56     procedure articlesHTMLTag(Sender: TObject; Tag: TTag;
  57       const TagString: string; TagParams: TStrings; var ReplaceText: string);
  58     procedure footerHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  59       TagParams: TStrings; var ReplaceText: string);
  60     procedure TWebModule1alertAction(Sender: TObject; Request: TWebRequest;
  61       Response: TWebResponse; var Handled: Boolean);
  62     procedure TWebModule1masterAction(Sender: TObject; Request: TWebRequest;
  63       Response: TWebResponse; var Handled: Boolean);
  64     procedure mailHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  65       TagParams: TStrings; var ReplaceText: string);
  66     procedure alertHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  67       TagParams: TStrings; var ReplaceText: string);
  68     procedure TWebModule1deleteAction(Sender: TObject; Request: TWebRequest;
  69       Response: TWebResponse; var Handled: Boolean);
  70     procedure TWebModule1jumpAction(Sender: TObject; Request: TWebRequest;
  71       Response: TWebResponse; var Handled: Boolean);
  72     procedure TWebModule1linkAction(Sender: TObject; Request: TWebRequest;
  73       Response: TWebResponse; var Handled: Boolean);
  74     procedure headerHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
  75       TagParams: TStrings; var ReplaceText: string);
  76     procedure adminFormatCell(Sender: TObject; CellRow, CellColumn: Integer;
  77       var BgColor: THTMLBgColor; var Align: THTMLAlign; var VAlign: THTMLVAlign;
  78       var CustomAttrs, CellData: string);
  79     procedure TWebModule1admdelAction(Sender: TObject; Request: TWebRequest;
  80       Response: TWebResponse; var Handled: Boolean);
  81     procedure TWebModule1loginAction(Sender: TObject; Request: TWebRequest;
  82       Response: TWebResponse; var Handled: Boolean);
  83   private
  84     { private \90é\8c¾ }
  85     ss: TStringList;
  86     checkbox: Boolean;
  87     procedure pages(count: Integer; var page: Integer);
  88     function getdbname: string;
  89   public
  90     { public \90é\8c¾ }
  91   end;
  92
  93 var
  94   WebModuleClass: TComponentClass = TTWebModule1;
  95
  96 implementation
  97
  98 { %CLASSGROUP 'Vcl.Controls.TControl' }
  99
 100 uses Unit1;
 101
 102 {$R *.dfm}
 103
 104 procedure TTWebModule1.adminFormatCell(Sender: TObject;
 105   CellRow, CellColumn: Integer; var BgColor: THTMLBgColor;
 106   var Align: THTMLAlign; var VAlign: THTMLVAlign;
 107   var CustomAttrs, CellData: string);
 108 begin
 109   if (CellColumn = 0) and (CellRow > 0) then
 110     CellData := Format('<input name=check%d type=checkbox>', [CellRow]);
 111 end;
 112
 113 procedure TTWebModule1.alertHTMLTag(Sender: TObject; Tag: TTag;
 114   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 115 var
 116   s: TStringList;
 117   i: Integer;
 118 begin
 119   if TagString = 'article' then
 120   begin
 121     with DataModule1 do
 122     begin
 123       FDTable1.Locate('dbnum', FDTable4.FieldByName('dbname').AsInteger);
 124       FDTable2.Locate('number', FDTable4.FieldByName('posnum').AsInteger);
 125     end;
 126     s := TStringList.Create;
 127     try
 128       s.Text := articles.Content;
 129       for i := s.count - 1 downto 0 do
 130         if Copy(s[i], 1, 18) = '<section id=master' then
 131         begin
 132           s.Delete(i);
 133           break;
 134         end;
 135       ReplaceText := s.Text;
 136     finally
 137       s.Free;
 138     end;
 139   end
 140   else if TagString = 'request' then
 141     ReplaceText := DataModule1.FDTable4.FieldByName('request').AsString;
 142 end;
 143
 144 procedure TTWebModule1.articlesHTMLTag(Sender: TObject; Tag: TTag;
 145   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 146 begin
 147   if TagString = 'database' then
 148     ReplaceText := Request.QueryFields.Values['db']
 149   else if TagString = 'comment' then
 150     ReplaceText := DataModule1.FDTable2.FieldByName('comment').AsString;
 151 end;
 152
 153 procedure TTWebModule1.footerHTMLTag(Sender: TObject; Tag: TTag;
 154   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 155 var
 156   i: Integer;
 157 begin
 158   if TagString = 'link' then
 159   begin
 160     for i := 1 to 10 do
 161       if i = index.Tag then
 162         ReplaceText := ReplaceText + ' ' + i.ToString + ' '
 163       else
 164         ReplaceText := ReplaceText +
 165           Format(' <a style=text-decoration-line:none href=%s?db=%s&num=%d>%d</a> ',
 166           [PString(Self.Tag)^, DataModule1.FDTable1.FieldByName('database')
 167           .AsString, i, i]);
 168   end
 169   else if TagString = 'recent' then
 170     if index.Tag = -1 then
 171       ReplaceText := TagString
 172     else
 173       ReplaceText := '<a style=text-decoration-line:none href=' +
 174         PString(Self.Tag)^ + '?db=' + DataModule1.FDTable1.FieldByName
 175         ('database').AsString + '>recent</a>';
 176 end;
 177
 178 function TTWebModule1.getdbname: string;
 179 begin
 180   result := Request.ContentFields.Values['db'];
 181   if result = '' then
 182     result := TNetEncoding.URL.Encode
 183       (DataModule1.FDTable1.FieldByName('database').AsString)
 184   else if DataModule1.FDTable1.Locate('database', result, []) = false then
 185     result := '';
 186 end;
 187
 188 procedure TTWebModule1.headerHTMLTag(Sender: TObject; Tag: TTag;
 189   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 190 var
 191   s: string;
 192 begin
 193   if TagString = 'cookie' then
 194   begin
 195     s := TagParams.Values['param'];
 196     ReplaceText := TNetEncoding.URL.Decode(Request.CookieFields.Values[s]);
 197   end
 198   else if (TagString = 'check') and (checkbox = true) then
 199     ReplaceText := 'checked'
 200   else if TagString = 'preview' then
 201     ReplaceText := Request.ContentFields.Values['preview']
 202   else if TagString = 'raw' then
 203     ReplaceText := Request.ContentFields.Values['raw'];
 204 end;
 205
 206 procedure TTWebModule1.indexHTMLTag(Sender: TObject; Tag: TTag;
 207   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 208 var
 209   i: Integer;
 210   x: Boolean;
 211   function detail: string;
 212   var
 213     s: string;
 214     j: Integer;
 215   begin
 216     s := TagParams.Values['id'];
 217     for j := 0 to ComponentCount - 1 do
 218       if Components[j].Name = TagString + s then
 219         result := (Components[j] as TPageProducer).Content;
 220   end;
 221
 222 begin
 223   if TagString = 'article' then
 224   begin
 225     x := DataModule1.FDTable1.FieldByName('dbnum')
 226       .AsInteger = DataModule1.FDTable3.FieldByName('info').AsInteger;
 227     for i := 1 to DataModule1.FDTable3.FieldByName('count').AsInteger do
 228     begin
 229       if DataModule1.FDTable2.Eof = true then
 230         break;
 231       if x = false then
 232         ReplaceText := ReplaceText + articles.Content
 233       else
 234         ReplaceText := articles.Content + ReplaceText;
 235       if DataModule1.FDTable2.Eof = false then
 236         DataModule1.FDTable2.Next;
 237     end;
 238   end
 239   else if TagString = 'footer' then
 240     ReplaceText := footer.Content
 241   else if TagString = 'header' then
 242   begin
 243     i := DataModule1.FDTable3.FieldByName('count').AsInteger;
 244     if 10 * i < DataModule1.FDTable2.RecordCount then
 245       ReplaceText := '\82±\82ê\88È\8fã\93\8a\8de\82Å\82«\82Ü\82¹\82ñ.'
 246     else
 247       ReplaceText := header.Content;
 248   end
 249   else if (TagString = 'css') or (TagString = 'js') then
 250     ReplaceText := detail;
 251 end;
 252
 253 procedure TTWebModule1.itemsHTMLTag(Sender: TObject; Tag: TTag;
 254   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 255 var
 256   s: TStringList;
 257   t, str: string;
 258   i, j: Integer;
 259 begin
 260   if TagString = 'item' then
 261   begin
 262     s := TStringList.Create;
 263     try
 264       s.Text := DataModule1.FDTable2.FieldByName('raw').AsString;
 265       for i := 0 to s.count - 1 do
 266         for j := 0 to ss.count - 1 do
 267           if Pos(ss[j], s[i]) > 0 then
 268             if Self.Tag = 0 then
 269               s[i] := '<p style=background-color:aqua>' + s[i]
 270             else
 271               s[i] := '<p style=background-color:yellow>' + s[i];
 272       with DataModule1.FDTable2 do
 273       begin
 274         i := FieldByName('dbnum').AsInteger;
 275         j := FieldByName('number').AsInteger;
 276         str := Request.QueryFields.Values['db'];
 277         if str = '' then
 278           t := Format('<a href=/index?db=%s&num=%d>[ %d-%d ]</a>',
 279             [str, j, i, j])
 280         else
 281           t := Format('<a href=/index?db=%s&num=%d>[ %d ]</a>', [str, j, j]);
 282       end;
 283       ReplaceText := t + s.Text;
 284     finally
 285       s.Free;
 286     end;
 287   end;
 288 end;
 289
 290 procedure TTWebModule1.masterHTMLTag(Sender: TObject; Tag: TTag;
 291   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 292 var
 293   i, j: Integer;
 294   s: string;
 295 begin
 296   if TagString = 'request' then
 297     with DataModule1.FDTable4 do
 298     begin
 299       First;
 300       ReplaceText := '<table border=1>';
 301       while Eof = false do
 302       begin
 303         ReplaceText := ReplaceText + alert.Content;
 304         Next;
 305       end;
 306       ReplaceText := ReplaceText + '</table>';
 307     end;
 308 end;
 309
 310 procedure TTWebModule1.pages(count: Integer; var page: Integer);
 311 var
 312   max: Integer;
 313 begin
 314   max := DataModule1.FDTable3.FieldByName('count').AsInteger;
 315   if (page > -1) and (count < max * (page - 1)) then
 316     page := (count div max) + 1;
 317   case page of
 318     - 1:
 319       begin
 320         DataModule1.FDTable2.Last;
 321         DataModule1.FDTable2.MoveBy(1 - max);
 322       end;
 323   else
 324     DataModule1.FDTable2.First;
 325     DataModule1.FDTable2.MoveBy(max * (page - 1));
 326   end;
 327 end;
 328
 329 procedure TTWebModule1.mailHTMLTag(Sender: TObject; Tag: TTag;
 330   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 331 begin
 332   if TagString = 'content' then
 333     ReplaceText := articles.Content
 334   else if TagString = 'query' then
 335     ReplaceText := '?' + Request.Query + '#' + Request.QueryFields.Values['num']
 336   else if TagString = 'number' then
 337     ReplaceText := Request.QueryFields.Values['num'];
 338 end;
 339
 340 procedure TTWebModule1.searchHTMLTag(Sender: TObject; Tag: TTag;
 341   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 342 var
 343   s: TStringList;
 344   procedure sub;
 345   var
 346     i: Integer;
 347     j: Integer;
 348   label jump;
 349   begin
 350     DataModule1.FDTable2.First;
 351     while DataModule1.FDTable2.Eof = false do
 352     begin
 353       s.Text := DataModule1.FDTable2.FieldByName('raw').AsString;
 354       ss.DelimitedText := Request.ContentFields.Values['word1'];
 355       for j := 0 to ss.count - 1 do
 356         for i := 0 to s.count - 1 do
 357           if Pos(ss[j], s[i]) > 0 then
 358             if Self.Tag = 0 then
 359             begin
 360               ReplaceText := ReplaceText + items.Content;
 361               goto jump;
 362             end
 363             else
 364             begin
 365               if j = ss.count - 1 then
 366               begin
 367                 ReplaceText := ReplaceText + items.Content;
 368                 goto jump;
 369               end
 370               else
 371                 break;
 372             end
 373           else if i = s.count - 1 then
 374             goto jump;
 375     jump:
 376       DataModule1.FDTable2.Next;
 377     end;
 378   end;
 379
 380 begin
 381   if (Request.MethodType = mtPost) and (TagString = 'items') then
 382   begin
 383     if Request.ContentFields.Values['type'] = 'OR' then
 384       Self.Tag := 0
 385     else
 386       Self.Tag := 1;
 387     s := TStringList.Create;
 388     ss := TStringList.Create;
 389     try
 390       ss.Delimiter := ' ';
 391       ss.StrictDelimiter := false;
 392       if Request.QueryFields.Values['db'] = '' then
 393       begin
 394         DataModule1.FDTable1.First;
 395         while DataModule1.FDTable1.Eof = false do
 396         begin
 397           sub;
 398           DataModule1.FDTable1.Next;
 399         end;
 400       end
 401       else
 402         sub;
 403     finally
 404       s.Free;
 405       ss.Free;
 406     end;
 407   end
 408   else if TagString = 'query' then
 409   begin
 410     ReplaceText := Request.Query;
 411     if ReplaceText <> '' then
 412       ReplaceText := '?' + ReplaceText;
 413   end
 414   else if TagString = 'css' then
 415     ReplaceText := css2.Content;
 416 end;
 417
 418 procedure TTWebModule1.topHTMLTag(Sender: TObject; Tag: TTag;
 419   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 420 var
 421   s, t: string;
 422   i: Integer;
 423 begin
 424   if TagString = 'list' then
 425   begin
 426     DataModule1.FDTable1.First;
 427     i := DataModule1.FDTable3.FieldByName('info').AsInteger;
 428     while DataModule1.FDTable1.Eof = false do
 429     begin
 430       t := '';
 431       if i = DataModule1.FDTable1.FieldByName('dbnum').AsInteger then
 432       begin
 433         DataModule1.FDTable1.Next;
 434         continue;
 435       end;
 436       s := DataModule1.FDTable1.FieldByName('database').AsString;
 437       DataModule1.FDTable2.Last;
 438       if Now - DataModule1.FDTable2.FieldByName('date').AsDateTime < 1 then
 439         t := 'background-color:aqua;';
 440       if DataModule1.FDTable2.RecordCount >= 10 *
 441         DataModule1.FDTable3.FieldByName('count').AsInteger then
 442         t := t + 'color:red;';
 443       if t <> '' then
 444         t := ' style=' + t;
 445       ReplaceText := ReplaceText +
 446         Format('<p%s><a target=_blank href=%s>%s</a><br></p>',
 447         [t, '/index?db=' + s, s]);
 448       DataModule1.FDTable1.Next;
 449     end;
 450   end
 451   else if TagString = 'info' then
 452     ReplaceText := DataModule1.FDTable1.Lookup('dbnum',
 453       DataModule1.FDTable3.FieldByName('info').AsInteger, 'database')
 454   else if TagString = 'css' then
 455     case TagParams.Values['id'].ToInteger of
 456       1:
 457         ReplaceText := css1.Content;
 458       3:
 459         ReplaceText := css3.Content;
 460     end;
 461 end;
 462
 463 procedure TTWebModule1.TWebModule1admdelAction(Sender: TObject;
 464   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 465 var
 466   i, j, k, m: Integer;
 467   reg: TRegEx;
 468   match: TMatch;
 469 begin
 470   j := 0;
 471   DataModule1.FDTable2.RecNo := admin.Tag;
 472   for i := 0 to Request.ContentFields.count - 1 do
 473   begin
 474     reg := TRegEx.Create('\d+');
 475     match := reg.match(Request.ContentFields[i]);
 476     if match.Success = true then
 477     begin
 478       k := match.Value.ToInteger - j - 1;
 479       j := match.Value.ToInteger;
 480       for m := 1 to k do
 481         DataModule1.FDTable2.Next;
 482       DataModule1.FDTable2.Delete;
 483     end;
 484   end;
 485   Response.SendRedirect('/admin?db=' + getdbname);
 486 end;
 487
 488 procedure TTWebModule1.TWebModule1adminAction(Sender: TObject;
 489   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 490 var
 491   s: string;
 492   i: Integer;
 493 begin
 494   if Request.CookieFields.Values['user'] <> 'admin' then
 495   begin
 496     Response.SendRedirect('/login');
 497     Exit;
 498   end;
 499   admin.MaxRows := DataModule1.FDTable3.FieldByName('count').AsInteger;
 500   s := TNetEncoding.URL.Decode(Request.QueryFields.Values['db']);
 501   DataModule1.FDTable1.Locate('database', s, []);
 502   s := Request.QueryFields.Values['num'];
 503   i := StrToIntDef(s, -1);
 504   pages(DataModule1.FDTable2.RecordCount, i);
 505   index.Tag := i;
 506   s := '/admin';
 507   Self.Tag := Integer(@s);
 508   i := footer.HTMLDoc.Add
 509     ('<p style=text-align:center><a href=/index?db=<#database>>\96ß\82é</a>');
 510   if admin.Tag = 0 then
 511     admin.footer.Insert(3, footer.Content)
 512   else
 513   begin
 514     admin.footer.Delete(3);
 515     admin.footer.Insert(3, footer.Content);
 516   end;
 517   admin.Tag := DataModule1.FDTable2.RecNo;
 518   footer.HTMLDoc.Delete(i);
 519   Response.ContentType := 'text/html;charset=utf-8';
 520   Response.Content := admin.Content;
 521 end;
 522
 523 procedure TTWebModule1.TWebModule1alertAction(Sender: TObject;
 524   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 525 var
 526   num1, num2, i: Integer;
 527   s: string;
 528 begin
 529   s := getdbname;
 530   num1 := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
 531   num2 := Request.QueryFields.Values['num'].ToInteger;
 532   if Request.MethodType = mtGet then
 533   begin
 534     DataModule1.FDTable2.Locate('number', num2, []);
 535     Response.ContentType := 'text/html;charset=utf-8';
 536     Response.Content := mail.Content;
 537   end
 538   else
 539     with DataModule1.FDTable4 do
 540     begin
 541       Last;
 542       i := FieldByName('id').AsInteger + 1;
 543       AppendRecord([i, num1, num2, Now, Request.ContentFields.Values
 544         ['request']]);
 545       pages(DataModule1.FDTable2.RecNo, i);
 546       Response.SendRedirect(Format('/index?db=%s&num=%d#%d', [s, i, num2]));
 547     end;
 548 end;
 549
 550 procedure TTWebModule1.TWebModule1deleteAction(Sender: TObject;
 551   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 552 var
 553   num: Integer;
 554   s: string;
 555 begin
 556   s := Request.ContentFields.Values['number'];
 557   if s = '' then
 558     Exit;
 559   num := s.ToInteger;
 560   s := Request.ContentFields.Values['password'];
 561   with DataModule1.FDTable2 do
 562     if Locate('number;pass', VarArrayOf([num, s])) = true then
 563     begin
 564       Edit;
 565       FieldByName('title').AsString := '';
 566       FieldByName('name').AsString := '---';
 567       FieldByName('comment').AsString := '<em>\93\8a\8de\8eÒ\82É\82æ\82è\8dí\8f\9c\82³\82ê\82Ü\82µ\82½.</em>';
 568       FieldByName('raw').AsString := '';
 569       FieldByName('date').AsDateTime := Now;
 570       Post;
 571     end;
 572   Response.SendRedirect('/index?db=' + getdbname);
 573 end;
 574
 575 procedure TTWebModule1.TWebModule1helpAction(Sender: TObject;
 576   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 577 var
 578   i, j: Integer;
 579   s: string;
 580 begin
 581   Response.ContentType := 'text/html;charset=utf-8';
 582   if Request.MethodType = mtPost then
 583   begin
 584     i := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;;
 585     j := DataModule1.FDTable2.FieldByName('number').AsInteger;
 586     s := Request.ContentFields.Values['help'];
 587     DataModule1.FDTable4.AppendRecord([i, j, s]);
 588   end;
 589   Response.Content := help.Content;
 590 end;
 591
 592 procedure TTWebModule1.TWebModule1indexpageAction(Sender: TObject;
 593   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 594 var
 595   int: Integer;
 596   s: string;
 597 begin
 598   DataModule1.FDTable1.Locate('database', Request.QueryFields.Values['db'], []);
 599   int := StrToIntDef(Request.QueryFields.Values['num'], -1);
 600   pages(DataModule1.FDTable2.RecordCount, int);
 601   index.Tag := int;
 602   s := '/index';
 603   Self.Tag := Integer(@s);
 604   Response.ContentType := 'text/html; charset="utf-8"';
 605   if DataModule1.FDTable3.FieldByName('mente').AsBoolean = true then
 606     Response.Content := '\82½\82¾\82¢\82Ü\83\81\83\93\83e\83i\83\93\83X\92\86\82Å\82·^_^'
 607   else
 608     Response.Content := index.Content;
 609 end;
 610
 611 procedure TTWebModule1.TWebModule1jumpAction(Sender: TObject;
 612   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 613 var
 614   db, s: string;
 615   page: Integer;
 616 begin
 617   db := DataModule1.FDTable1.FieldByName('database').AsString;
 618   s := Request.ContentFields.Values['num'];
 619   if s = '' then
 620   begin
 621     Response.ContentType := 'text/html;charset=utf-8';
 622     Response.Content := '<a href=/index?db=' + db + '>\96ß\82é</a>';
 623     Exit;
 624   end;
 625   DataModule1.FDTable2.Locate('number', s.ToInteger, []);
 626   page := 10;
 627   pages(DataModule1.FDTable2.RecNo, page);
 628   Response.SendRedirect(Format('/index?db=%s&num=%d#%s', [getdbname, page, s]));
 629 end;
 630
 631 procedure TTWebModule1.TWebModule1linkAction(Sender: TObject;
 632   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 633 var
 634   num: Integer;
 635   s: string;
 636 begin
 637   s := Request.QueryFields.Values['num'];
 638   if s = '' then
 639     Exit;
 640   num := s.ToInteger;
 641   if DataModule1.FDTable2.Locate('number', num, []) = true then
 642   begin
 643     Response.ContentType := 'text/html;charset=utf-8';
 644     Response.Content := articles.Content;
 645   end;
 646 end;
 647
 648 procedure TTWebModule1.TWebModule1loginAction(Sender: TObject;
 649   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 650 var
 651   s: string;
 652 begin
 653   if Request.MethodType = mtGet then
 654   begin
 655     Response.ContentType := 'text/html;charset=utf-8';
 656     Response.Content := login.Content;
 657     Exit;
 658   end;
 659   with Response.Cookies.Add do
 660   begin
 661     Name := 'user';
 662     Value := 'admin';
 663     Expires := Now + 14;
 664   end;
 665   s := Request.ContentFields.Values['record'];
 666   Response.SendRedirect('/admin?db=' + TNetEncoding.URL.Encode(s));
 667 end;
 668
 669 procedure TTWebModule1.TWebModule1masterAction(Sender: TObject;
 670   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 671 begin
 672   Response.ContentType := 'text/html;charset=utf-8';
 673   Response.Content := master.Content;
 674 end;
 675
 676 procedure TTWebModule1.TWebModule1registAction(Sender: TObject;
 677   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 678 var
 679   number: Integer;
 680   title, na, raw, pass, kotoba, error: string;
 681   p: PString;
 682   comment: TStringList;
 683   i: Integer;
 684   function scan(Text: string): string;
 685   var
 686     reg: TRegEx;
 687     coll: TMatchCollection;
 688     j: Integer;
 689     s, t: string;
 690   begin
 691     Text := TNetEncoding.HTML.Encode(Text);
 692     s := TNetEncoding.HTML.Encode('>>');
 693     reg := TRegEx.Create(s + '(\d+)');
 694     coll := reg.Matches(Text);
 695     for j := coll.count - 1 downto 0 do
 696     begin
 697       Delete(Text, coll[j].index, coll[j].Length);
 698       t := Copy(coll[j].Value, Length(s) + 1, coll[j].Length);
 699       result := Format
 700         ('<a class=minpreview data-preview-url=/link?num=%s href=/jump?num=%s>>>%s</a>',
 701         [t, t, t]);
 702       Insert(result, Text, coll[j].index);
 703     end;
 704     result := Text;
 705   end;
 706
 707 begin
 708   error := '';
 709   kotoba := Request.ContentFields.Values['aikotoba'];
 710   if kotoba <> '\82°\82ñ\82«' then
 711     error := '<section style=color:red><p>\8d\87\8c¾\97t\82ª\82¿\82ª\82¢\82Ü\82·.';
 712   with DataModule1.FDTable2 do
 713   begin
 714     Last;
 715     number := FieldByName('number').AsInteger + 1;
 716   end;
 717   with Request.ContentFields do
 718   begin
 719     title := Values['title'];
 720     na := Values['name'];
 721     raw := Values['comment'];
 722     pass := Values['password'];
 723   end;
 724   if title = '' then
 725     title:='\83^\83C\83g\83\8b\82È\82µ.';
 726   with Response.Cookies.Add do
 727   begin
 728     Name := 'name';
 729     if na = '' then
 730       Value := '\92N\82©\82³\82ñ.'
 731     else
 732       Value := na;
 733     Expires := Now + 14;
 734   end;
 735   if error = '' then
 736     with Response.Cookies.Add do
 737     begin
 738       Name := 'aikotoba';
 739       Value := kotoba;
 740       Expires := Now + 14;
 741     end;
 742   comment := TStringList.Create;
 743   try
 744     comment.Text := raw;
 745     for i := 0 to comment.count - 1 do
 746     begin
 747       if Pos('ng', comment[i]) > 0 then
 748       begin
 749         error := error + '<p>\8bÖ\8e~\8cê\8bå\82ª\8aÜ\82Ü\82ê\82Ä\82¢\82Ü\82·.';
 750         break;
 751       end;
 752       comment[i] := '<p>' + scan(comment[i]);
 753     end;
 754     if error <> '' then
 755       error := error + '</section>'
 756     else if Request.ContentFields.Values['show'] = 'true' then
 757     begin
 758       error := '<p style=font-size:2.3em;color:blue>\81«\81«\83v\83\8c\83r\83\85\81[\81«\81«<p>' +
 759         comment.Text;
 760       checkbox := false;
 761       Request.ContentFields.Add('preview='+error);
 762       Request.ContentFields.Add('raw='+raw);
 763     end
 764     else
 765     begin
 766       i := DataModule1.FDTable1.FieldByName('dbnum').AsInteger;
 767       DataModule1.FDTable2.AppendRecord([i, number, title, na, comment.Text,
 768         raw, Now, pass]);
 769       checkbox := true;
 770       Response.SendRedirect('index?db=' + getdbname + '#article');
 771       Exit;
 772     end;
 773   finally
 774     comment.Free;
 775   end;
 776   TWebModule1indexpageAction(nil,Request,Response,Handled);
 777 end;
 778
 779 procedure TTWebModule1.TWebModule1searchAction(Sender: TObject;
 780   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 781 begin
 782   Response.ContentType := 'text/html;charset=utf-8';
 783   Response.Content := search.Content;
 784 end;
 785
 786 procedure TTWebModule1.TWebModule1topAction(Sender: TObject;
 787   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 788 begin
 789   Response.ContentType := 'text/html;charset=utf-8';
 790   Response.Content := top.Content;
 791 end;
 792
 793 procedure TTWebModule1.WebModuleCreate(Sender: TObject);
 794 var
 795   a: Variant;
 796   i: Integer;
 797 begin
 798   if DataModule1.FDTable1.Bof and DataModule1.FDTable1.Eof then
 799   begin
 800     DataModule1.FDTable1.AppendRecord([0, 'info']);
 801     for i := 1 to 10 do
 802       DataModule1.FDTable1.AppendRecord([i, '\8cf\8e¦\94Â' + i.ToString]);
 803   end;
 804   if DataModule1.FDTable3.Bof and DataModule1.FDTable3.Eof then
 805   begin
 806     a := DataModule1.FDTable1.Lookup('database', 'info', 'dbnum');
 807     DataModule1.FDTable3.AppendRecord
 808       (['\82Æ\82é\82Ë\81`\82Ç\8d\86', '<p style=font-color:gray>\82Æ\82é\82Ë\81`\82Ç\8d\86</p>', false, a, 30]);
 809   end;
 810   checkbox := true;
 811 end;
 812
 813 end.