pngファイルはリソースで読む

[newbbs/newbbs.git] / WebModuleUnit1.pas

diff --git a/WebModuleUnit1.pas b/WebModuleUnit1.pas
index 96e867a..7625c79 100644 (file)
--- a/WebModuleUnit1.pas
+++ b/WebModuleUnit1.pas
@@ -4,7 +4,7 @@ interface
 
 uses System.SysUtils, System.Classes, Web.HTTPApp, Web.DSProd, Web.HTTPProd,
   Web.DBWeb, System.Variants, System.NetEncoding, System.RegularExpressions,
-  Data.DB;
+  Data.DB, Web.DBXpressWeb, System.Types;
 
 type
   TTWebModule1 = class(TWebModule)
@@ -30,6 +30,9 @@ type
     js3: TPageProducer;
     js4: TPageProducer;
     adhead: TPageProducer;
+    js5: TPageProducer;
+    title: TPageProducer;
+    ti: TDataSetPageProducer;
     procedure indexHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
       TagParams: TStrings; var ReplaceText: string);
     procedure TWebModule1indexpageAction(Sender: TObject; Request: TWebRequest;
@@ -90,6 +93,16 @@ type
       Response: TWebResponse; var Handled: Boolean);
     procedure TWebModule1fileAction(Sender: TObject; Request: TWebRequest;
       Response: TWebResponse; var Handled: Boolean);
+    procedure titleHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
+      TagParams: TStrings; var ReplaceText: string);
+    procedure TWebModule1titleAction(Sender: TObject; Request: TWebRequest;
+      Response: TWebResponse; var Handled: Boolean);
+    procedure tiHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
+      TagParams: TStrings; var ReplaceText: string);
+    procedure helpHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
+      TagParams: TStrings; var ReplaceText: string);
+    procedure loginHTMLTag(Sender: TObject; Tag: TTag; const TagString: string;
+      TagParams: TStrings; var ReplaceText: string);
   private
     { private \90é\8c¾ }
     ss: TStringList;
@@ -112,11 +125,17 @@ uses Unit1, IdHashSHA, IdGlobal, IdHash, IdHashMessageDigest;
 
 {$R *.dfm}
 
+const
+  promotion = '\8dL\8d\90:';
+  tcnt = 7;
+
 procedure TTWebModule1.adheadHTMLTag(Sender: TObject; Tag: TTag;
   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 begin
-  if (TagString = 'mente') and (DataModule1.FDTable3.FieldByName('mente')
-    .AsBoolean = true) then
+  if TagString = 'pr' then
+    ReplaceText := promotion
+  else if (TagString = 'mente') and
+    (DataModule1.FDTable3.FieldByName('mente').AsBoolean = true) then
     ReplaceText := 'checked'
   else if TagString = 'password' then
     ReplaceText := Request.CookieFields.Values['user'];
@@ -240,13 +259,22 @@ begin
     ReplaceText := Request.ContentFields.Values['title'];
 end;
 
+procedure TTWebModule1.helpHTMLTag(Sender: TObject; Tag: TTag;
+  const TagString: string; TagParams: TStrings; var ReplaceText: string);
+begin
+  if TagString = 'pr' then
+    ReplaceText := promotion;
+end;
+
 procedure TTWebModule1.indexHTMLTag(Sender: TObject; Tag: TTag;
   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 var
   i: Integer;
   x: Boolean;
 begin
-  if TagString = 'article' then
+  if TagString = 'pr' then
+    ReplaceText := promotion
+  else if TagString = 'article' then
   begin
     x := DataModule1.FDTable1.FieldByName('dbnum')
       .AsInteger = DataModule1.FDTable3.FieldByName('info').AsInteger;
@@ -267,8 +295,8 @@ begin
   else if TagString = 'header' then
   begin
     i := DataModule1.FDTable3.FieldByName('count').AsInteger;
-    if 10 * i < DataModule1.FDTable2.RecordCount then
-      ReplaceText := '\82±\82ê\88È\8fã\93\8a\8de\82Å\82«\82Ü\82¹\82ñ.'
+    if 10 * i <= DataModule1.FDTable2.RecordCount then
+      ReplaceText := '<h1>\82±\82ê\88È\8fã\93\8a\8de\82Å\82«\82Ü\82¹\82ñ.</h1>'
     else
       ReplaceText := header.Content;
   end
@@ -317,10 +345,19 @@ begin
   end;
 end;
 
+procedure TTWebModule1.loginHTMLTag(Sender: TObject; Tag: TTag;
+  const TagString: string; TagParams: TStrings; var ReplaceText: string);
+begin
+  if TagString = 'pr' then
+    ReplaceText := promotion;
+end;
+
 procedure TTWebModule1.masterHTMLTag(Sender: TObject; Tag: TTag;
   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 begin
-  if TagString = 'request' then
+  if TagString = 'pr' then
+    ReplaceText := promotion
+  else if TagString = 'request' then
     with DataModule1.FDTable4 do
     begin
       First;
@@ -373,7 +410,9 @@ end;
 procedure TTWebModule1.mailHTMLTag(Sender: TObject; Tag: TTag;
   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 begin
-  if TagString = 'content' then
+  if TagString = 'pr' then
+    ReplaceText := promotion
+  else if TagString = 'content' then
     ReplaceText := articles.Content
   else if TagString = 'query' then
     ReplaceText := '?' + Request.Query
@@ -422,7 +461,9 @@ var
   end;
 
 begin
-  if (Request.MethodType = mtPost) and (TagString = 'items') then
+  if TagString = 'pr' then
+    ReplaceText := promotion
+  else if (Request.MethodType = mtPost) and (TagString = 'items') then
   begin
     if Request.ContentFields.Values['type'] = 'OR' then
       Self.Tag := 0
@@ -459,16 +500,52 @@ begin
     ReplaceText := css2.Content;
 end;
 
+procedure TTWebModule1.tiHTMLTag(Sender: TObject; Tag: TTag;
+  const TagString: string; TagParams: TStrings; var ReplaceText: string);
+begin
+  if TagString = 'count' then
+  begin
+    DataModule1.FDTable1.Locate('dbnum',
+      DataModule1.FDQuery1.FieldByName('dbnum').AsInteger);
+    ReplaceText := DataModule1.FDTable2.RecordCount.ToString;
+  end
+  else if TagString = 'database' then
+    ReplaceText := DataModule1.FDTable1.Lookup('dbnum',
+      DataModule1.FDQuery1.FieldByName('dbnum').AsInteger, 'database');
+end;
+
+procedure TTWebModule1.titleHTMLTag(Sender: TObject; Tag: TTag;
+  const TagString: string; TagParams: TStrings; var ReplaceText: string);
+begin
+  if TagString = 'pr' then
+    ReplaceText := promotion
+  else if TagString = 'js' then
+    ReplaceText := detail(TagString, TagParams.Values['id'])
+  else if TagString = 'main' then
+    with DataModule1.FDQuery1 do
+    begin
+      Open;
+      while Eof = false do
+      begin
+        ReplaceText := ReplaceText + ti.Content;
+        Next;
+      end;
+      Close;
+    end;
+end;
+
 procedure TTWebModule1.topHTMLTag(Sender: TObject; Tag: TTag;
   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 var
   s, t: string;
   i, j, k: Integer;
 begin
-  if TagString = 'list' then
+  if TagString = 'pr' then
+    ReplaceText := promotion
+  else if TagString = 'list' then
   begin
     i := DataModule1.FDTable3.FieldByName('info').AsInteger;
-    for k := 0 to DataModule1.FDTable3.FieldByName('tcnt').AsInteger do
+    for k := 0 to tcnt do
     begin
       if DataModule1.FDTable1.Eof = true then
         break;
@@ -503,8 +580,7 @@ begin
     ReplaceText := detail(TagString, TagParams.Values['id'])
   else if TagString = 'slide' then
   begin
-    j := DataModule1.FDTable3.FieldByName('tcnt').AsInteger;
-    for i := 1 to (DataModule1.FDTable1.RecordCount div j) + 1 do
+    for i := 1 to (DataModule1.FDTable1.RecordCount div tcnt) + 1 do
       ReplaceText := ReplaceText +
         '<div class="slide"><img src="/src?name=slide' + i.ToString +
         '.jpg" style=float:right;height:465px><#list></div>';
@@ -593,6 +669,7 @@ begin
     Name := 'user';
     Value := s;
     Expires := Now + 14;
+    Secure := true;
   end;
   Request.CookieFields.Values['user'] := s;
   TWebModule1adminAction(nil, Request, Response, Handled);
@@ -658,7 +735,7 @@ var
 begin
   s := Request.QueryFields.Values['type'];
   if s = 'js' then
-    Response.ContentType := 'text/javascript;charset=utf-8'
+    Response.ContentType := 'text/javascript'
   else if s = 'css' then
     Response.ContentType := 'text/css';
   Response.Content := detail(s, Request.QueryFields.Values['id']);
@@ -683,12 +760,28 @@ end;
 
 procedure TTWebModule1.TWebModule1imgAction(Sender: TObject;
   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
+var
+  s: string;
+  res: TResourceStream;
 begin
   with DataModule1.FDTable5 do
   begin
-    Locate('name', Request.ContentFields.Values['name'], []);
+    s:= Request.ContentFields.Values['name'];
     Response.ContentType := 'image/jpeg';
-    Response.ContentStream := CreateBlobStream(FieldByName('source'), bmRead);
+    if Locate('name', s) = true then
+      Response.ContentStream := CreateBlobStream(FieldByName('source'), bmRead)
+    else
+      if s = 'sprites.png' then
+      begin
+        res:=TResourceStream.Create(HInstance,'PngImage_1',RT_RCDATA);
+        try
+          Response.ContentStream:=res;
+        finally
+          res.Free;
+        end;
+      end
+      else
+        Response.ContentStream:=nil;
   end;
 end;
 
@@ -760,6 +853,7 @@ begin
     Name := 'user';
     Value := Request.ContentFields.Values['password'];
     Expires := Now + 14;
+    Secure := true;
   end;
   i := DataModule1.FDTable1.Lookup('database',
     Request.ContentFields.Values['record'], 'dbnum');
@@ -922,6 +1016,13 @@ begin
   Response.Content := search.Content;
 end;
 
+procedure TTWebModule1.TWebModule1titleAction(Sender: TObject;
+  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
+begin
+  Response.ContentType := 'text/html;charset=utf-8';
+  Response.Content := title.Content;
+end;
+
 procedure TTWebModule1.TWebModule1topAction(Sender: TObject;
   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 begin
@@ -936,6 +1037,27 @@ var
   i: Integer;
   a: Variant;
 begin
+  with DataModule1 do
+  begin
+    if FDTable1.Exists = false then
+      FDTable1.CreateTable;
+    if FDTable2.Exists = false then
+      FDTable2.CreateTable;
+    if FDTable3.Exists = false then
+      FDTable3.CreateTable;
+    if FDTable4.Exists = false then
+      FDTable4.CreateTable;
+    if FDTable5.Exists = false then
+      FDTable5.CreateTable;
+    FDTable1.Open;
+    FDTable2.Open;
+    FDTable3.Open;
+    FDTable4.Open;
+    FDTable5.Open;
+    FDTable1.Refresh;
+    FDTable3.Refresh;
+    FDTable5.Refresh;
+  end;
   if DataModule1.FDTable1.Bof and DataModule1.FDTable1.Eof then
   begin
     DataModule1.FDTable1.AppendRecord([0, 'info']);
@@ -948,7 +1070,7 @@ begin
     DataModule1.FDTable3.AppendRecord
       (['\82Æ\82é\82Ë\81`\82Ç\8d\86',
       '<h1 style=color:maron;text-align:center;font-style:italic>\82Æ\82é\82Ë\81`\82Ç\8d\86</h1>',
-      false, a, 30, hash('admin'), 7]);
+      false, a, 30, hash('admin')]);
   end;
 end;