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