mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-22 05:59:28 +02:00
fpweb: added demos from Michael Van Canneyt
git-svn-id: trunk@12880 -
This commit is contained in:
mattias
parent
c2631e46f5
commit
65da460e39
16
.gitattributes
vendored
16
.gitattributes
vendored
@ -268,6 +268,22 @@ components/fpcunit/ide/testcaseopts.pas svneol=native#text/pascal
|
||||
components/fpcunit/lib/README.txt svneol=native#text/plain
|
||||
components/fpweb/README.txt svneol=native#text/plain
|
||||
components/fpweb/cgiapp.pp svneol=native#text/plain
|
||||
components/fpweb/demo/README.txt svneol=native#text/plain
|
||||
components/fpweb/demo/echo/echo.lpi svneol=native#text/plain
|
||||
components/fpweb/demo/echo/echo.lpr svneol=native#text/plain
|
||||
components/fpweb/demo/echo/wmecho.lfm svneol=native#text/plain
|
||||
components/fpweb/demo/echo/wmecho.lrs svneol=native#text/plain
|
||||
components/fpweb/demo/echo/wmecho.pp svneol=native#text/plain
|
||||
components/fpweb/demo/image/imagedemo.lpi svneol=native#text/plain
|
||||
components/fpweb/demo/image/imagedemo.lpr svneol=native#text/plain
|
||||
components/fpweb/demo/image/wmimage.lfm svneol=native#text/plain
|
||||
components/fpweb/demo/image/wmimage.lrs svneol=native#text/plain
|
||||
components/fpweb/demo/image/wmimage.pp svneol=native#text/plain
|
||||
components/fpweb/demo/session/sessiondemo.lpi svneol=native#text/plain
|
||||
components/fpweb/demo/session/sessiondemo.lpr svneol=native#text/plain
|
||||
components/fpweb/demo/session/wmsession.lfm svneol=native#text/plain
|
||||
components/fpweb/demo/session/wmsession.lrs svneol=native#text/plain
|
||||
components/fpweb/demo/session/wmsession.pp svneol=native#text/plain
|
||||
components/fpweb/lazweb.pp svneol=native#text/plain
|
||||
components/fpweb/weblaz.lpk svneol=native#text/plain
|
||||
components/fpweb/weblaz.pas svneol=native#text/plain
|
||||
|
||||
57
components/fpweb/demo/README.txt
Normal file
57
components/fpweb/demo/README.txt
Normal file
@ -0,0 +1,57 @@
|
||||
This directory contains demo applications for the FP/Lazarus web
|
||||
package lazweb
|
||||
|
||||
echo demo:
|
||||
==========
|
||||
|
||||
This is a very simple demo, it just echoes the request back to the
|
||||
webbrowser. The standard webutil unit contains a 'dumprequest'
|
||||
routine which can be used to dump the request.
|
||||
|
||||
session demo:
|
||||
=============
|
||||
|
||||
The session directory contains a session demonstration CGI app.
|
||||
The DemoSession action variable controls what will happen:
|
||||
DemoSession=NewSession - a new session is started
|
||||
DemoSession=InSession (the default): the session variable is displayed
|
||||
DemoSession=EndSession - the sesson is destroyed.
|
||||
|
||||
Sample URLs:
|
||||
|
||||
end session:
|
||||
http://localhost/~michael/sessiondemo.cgi?DemoSession=EndSession
|
||||
|
||||
set session variable 'var':
|
||||
http://localhost/~michael/sessiondemo.cgi?Var=SomeValue
|
||||
|
||||
start session:
|
||||
http://localhost/~michael/sessiondemo.cgi?DemoSession=NewSession
|
||||
|
||||
image demo:
|
||||
===========
|
||||
|
||||
You need to set some constants in this application, you must configure some
|
||||
font/image paths and set a font name.
|
||||
|
||||
This demo shows how to send images. It has 2 actions:
|
||||
|
||||
Pie: creates a pie diagram on the fly. It uses the fpimage routines
|
||||
for this. The text is shown using a font, for which the FreeType
|
||||
font library is used.
|
||||
|
||||
A sample URL is:
|
||||
http://localhost/~michael/imagedemo.cgi?action=pie
|
||||
|
||||
It can be configured with the Runs/Failed/Skipped/FontName query
|
||||
variables. See the sources for more information.
|
||||
|
||||
The second action is image:
|
||||
In this mode, the image is searched on disk through the 'FileName' query
|
||||
variable. The directory is hardcoded in the program, see the constants in
|
||||
the source. Only PNG images are sent.
|
||||
|
||||
Sample URL:
|
||||
http://localhost/~michael/imagedemo.cgi?action=file&filename=menu_run
|
||||
|
||||
This will send the 'menu_run.png' file from the configured directory.
|
||||
95
components/fpweb/demo/echo/echo.lpi
Normal file
95
components/fpweb/demo/echo/echo.lpi
Normal file
@ -0,0 +1,95 @@
|
||||
<?xml version="1.0"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<PathDelim Value="/"/>
|
||||
<Version Value="6"/>
|
||||
<General>
|
||||
<MainUnit Value="0"/>
|
||||
<IconPath Value="./"/>
|
||||
<TargetFileExt Value=""/>
|
||||
<ActiveEditorIndexAtStart Value="1"/>
|
||||
</General>
|
||||
<VersionInfo>
|
||||
<ProjectVersion Value=""/>
|
||||
<Language Value=""/>
|
||||
<CharSet Value=""/>
|
||||
</VersionInfo>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<IgnoreBinaries Value="False"/>
|
||||
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
|
||||
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="1">
|
||||
<Item1>
|
||||
<PackageName Value="WebLaz"/>
|
||||
</Item1>
|
||||
</RequiredPackages>
|
||||
<Units Count="4">
|
||||
<Unit0>
|
||||
<Filename Value="echo.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="echo"/>
|
||||
<CursorPos X="19" Y="14"/>
|
||||
<TopLine Value="1"/>
|
||||
<EditorIndex Value="1"/>
|
||||
<UsageCount Value="20"/>
|
||||
<Loaded Value="True"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="wmecho.pp"/>
|
||||
<ComponentName Value="EchoModule"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ResourceFilename Value="wmecho.lrs"/>
|
||||
<UnitName Value="wmecho"/>
|
||||
<CursorPos X="19" Y="47"/>
|
||||
<TopLine Value="5"/>
|
||||
<EditorIndex Value="0"/>
|
||||
<UsageCount Value="20"/>
|
||||
<Loaded Value="True"/>
|
||||
</Unit1>
|
||||
<Unit2>
|
||||
<Filename Value="../../../../../../fpc/fcl/net/httpdefs.pp"/>
|
||||
<UnitName Value="HTTPDefs"/>
|
||||
<CursorPos X="9" Y="167"/>
|
||||
<TopLine Value="157"/>
|
||||
<UsageCount Value="10"/>
|
||||
</Unit2>
|
||||
<Unit3>
|
||||
<Filename Value="../../../../../../source/articles/web2/session/wmsession.pas"/>
|
||||
<ComponentName Value="SessionModule"/>
|
||||
<HasResources Value="True"/>
|
||||
<UnitName Value="wmsession"/>
|
||||
<CursorPos X="44" Y="1"/>
|
||||
<TopLine Value="1"/>
|
||||
<UsageCount Value="10"/>
|
||||
</Unit3>
|
||||
</Units>
|
||||
<JumpHistory Count="0" HistoryIndex="-1"/>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="5"/>
|
||||
<CodeGeneration>
|
||||
<Generate Value="Faster"/>
|
||||
</CodeGeneration>
|
||||
<Other>
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="2">
|
||||
<Item1>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item2>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
13
components/fpweb/demo/echo/echo.lpr
Normal file
13
components/fpweb/demo/echo/echo.lpr
Normal file
@ -0,0 +1,13 @@
|
||||
program echo;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
fpWeb,fpCGI, wmecho;
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TEchoModule, EchoModule);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
10
components/fpweb/demo/echo/wmecho.lfm
Normal file
10
components/fpweb/demo/echo/wmecho.lfm
Normal file
@ -0,0 +1,10 @@
|
||||
object EchoModule: TEchoModule
|
||||
Actions = <>
|
||||
OnRequest = EchoModuleRequest
|
||||
left = 302
|
||||
top = 190
|
||||
Height = 0
|
||||
HorizontalOffset = 0
|
||||
VerticalOffset = 0
|
||||
Width = 0
|
||||
end
|
||||
7
components/fpweb/demo/echo/wmecho.lrs
Normal file
7
components/fpweb/demo/echo/wmecho.lrs
Normal file
@ -0,0 +1,7 @@
|
||||
{ This is an automatically generated lazarus resource file }
|
||||
|
||||
LazarusResources.Add('TEchoModule','FORMDATA',[
|
||||
'TPF0'#11'TEchoModule'#10'EchoModule'#7'Actions'#14#0#9'OnRequest'#7#17'EchoM'
|
||||
+'oduleRequest'#4'left'#3'.'#1#3'top'#3#190#0#6'Height'#2#0#16'HorizontalOffs'
|
||||
+'et'#2#0#14'VerticalOffset'#2#0#5'Width'#2#0#0#0
|
||||
]);
|
||||
58
components/fpweb/demo/echo/wmecho.pp
Normal file
58
components/fpweb/demo/echo/wmecho.pp
Normal file
@ -0,0 +1,58 @@
|
||||
unit wmecho;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, HTTPDefs, websession, fpHTTP,
|
||||
fpWeb;
|
||||
|
||||
type
|
||||
|
||||
{ TEchoModule }
|
||||
|
||||
TEchoModule = class(TFPWebModule)
|
||||
procedure EchoModuleRequest(Sender: TObject; ARequest: TRequest;
|
||||
AResponse: TResponse; var Handled: Boolean);
|
||||
private
|
||||
{ private declarations }
|
||||
public
|
||||
{ public declarations }
|
||||
end;
|
||||
|
||||
var
|
||||
EchoModule: TEchoModule;
|
||||
|
||||
implementation
|
||||
|
||||
uses webutil;
|
||||
|
||||
{ TEchoModule }
|
||||
|
||||
procedure TEchoModule.EchoModuleRequest(Sender: TObject; ARequest: TRequest;
|
||||
AResponse: TResponse; var Handled: Boolean);
|
||||
|
||||
Var
|
||||
S : TStrings;
|
||||
|
||||
begin
|
||||
S:=TStringList.Create;
|
||||
try
|
||||
// Analyze request.
|
||||
DumpRequest(ARequest,S);
|
||||
// Optional, because default.
|
||||
AResponse.ContentType:='text/html';
|
||||
AResponse.Contents:=S;
|
||||
Handled:=True;
|
||||
finally
|
||||
S.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
{$I wmecho.lrs}
|
||||
|
||||
RegisterHTTPModule('echo', TEchoModule);
|
||||
end.
|
||||
|
||||
144
components/fpweb/demo/image/imagedemo.lpi
Normal file
144
components/fpweb/demo/image/imagedemo.lpi
Normal file
@ -0,0 +1,144 @@
|
||||
<?xml version="1.0"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<PathDelim Value="/"/>
|
||||
<Version Value="6"/>
|
||||
<General>
|
||||
<MainUnit Value="0"/>
|
||||
<TargetFileExt Value=""/>
|
||||
<ActiveEditorIndexAtStart Value="0"/>
|
||||
</General>
|
||||
<VersionInfo>
|
||||
<ProjectVersion Value=""/>
|
||||
<Language Value=""/>
|
||||
<CharSet Value=""/>
|
||||
</VersionInfo>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<IgnoreBinaries Value="False"/>
|
||||
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
|
||||
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="1">
|
||||
<Item1>
|
||||
<PackageName Value="WebLaz"/>
|
||||
</Item1>
|
||||
</RequiredPackages>
|
||||
<Units Count="3">
|
||||
<Unit0>
|
||||
<Filename Value="imagedemo.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="imagedemo"/>
|
||||
<UsageCount Value="20"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<ComponentName Value="FPWebModule1"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ResourceFilename Value="wmimage.lrs"/>
|
||||
<UnitName Value="wmimage"/>
|
||||
<CursorPos X="28" Y="49"/>
|
||||
<TopLine Value="38"/>
|
||||
<EditorIndex Value="0"/>
|
||||
<UsageCount Value="20"/>
|
||||
<Loaded Value="True"/>
|
||||
</Unit1>
|
||||
<Unit2>
|
||||
<Filename Value="../../../../../../fpc/packages/fcl-web/src/httpdefs.pp"/>
|
||||
<UnitName Value="HTTPDefs"/>
|
||||
<CursorPos X="1" Y="255"/>
|
||||
<TopLine Value="203"/>
|
||||
<EditorIndex Value="1"/>
|
||||
<UsageCount Value="10"/>
|
||||
<Loaded Value="True"/>
|
||||
</Unit2>
|
||||
</Units>
|
||||
<JumpHistory Count="15" HistoryIndex="14">
|
||||
<Position1>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="160" Column="18" TopLine="108"/>
|
||||
</Position1>
|
||||
<Position2>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="3" Column="1" TopLine="1"/>
|
||||
</Position2>
|
||||
<Position3>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="8" Column="77" TopLine="1"/>
|
||||
</Position3>
|
||||
<Position4>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="50" Column="32" TopLine="25"/>
|
||||
</Position4>
|
||||
<Position5>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="8" Column="34" TopLine="1"/>
|
||||
</Position5>
|
||||
<Position6>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="68" Column="8" TopLine="36"/>
|
||||
</Position6>
|
||||
<Position7>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="52" Column="32" TopLine="26"/>
|
||||
</Position7>
|
||||
<Position8>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="8" Column="40" TopLine="1"/>
|
||||
</Position8>
|
||||
<Position9>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="88" Column="1" TopLine="37"/>
|
||||
</Position9>
|
||||
<Position10>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="65" Column="17" TopLine="39"/>
|
||||
</Position10>
|
||||
<Position11>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="67" Column="24" TopLine="41"/>
|
||||
</Position11>
|
||||
<Position12>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="82" Column="1" TopLine="67"/>
|
||||
</Position12>
|
||||
<Position13>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="16" Column="51" TopLine="14"/>
|
||||
</Position13>
|
||||
<Position14>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="127" Column="12" TopLine="88"/>
|
||||
</Position14>
|
||||
<Position15>
|
||||
<Filename Value="wmimage.pp"/>
|
||||
<Caret Line="48" Column="1" TopLine="13"/>
|
||||
</Position15>
|
||||
</JumpHistory>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="5"/>
|
||||
<CodeGeneration>
|
||||
<Generate Value="Faster"/>
|
||||
</CodeGeneration>
|
||||
<Other>
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="2">
|
||||
<Item1>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item2>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
14
components/fpweb/demo/image/imagedemo.lpr
Normal file
14
components/fpweb/demo/image/imagedemo.lpr
Normal file
@ -0,0 +1,14 @@
|
||||
program imagedemo;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
fpWeb,fpCGI, wmimage;
|
||||
|
||||
begin
|
||||
Application.Title:='cgiproject1';
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TFPWebModule1, FPWebModule1);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
19
components/fpweb/demo/image/wmimage.lfm
Normal file
19
components/fpweb/demo/image/wmimage.lfm
Normal file
@ -0,0 +1,19 @@
|
||||
object FPWebModule1: TFPWebModule1
|
||||
Actions = <
|
||||
item
|
||||
Name = 'Pie'
|
||||
Default = True
|
||||
OnRequest = PieRequest
|
||||
end
|
||||
item
|
||||
Name = 'File'
|
||||
OnRequest = FileRequest
|
||||
end>
|
||||
ActionVar = 'Action'
|
||||
left = 272
|
||||
top = 230
|
||||
Height = 0
|
||||
HorizontalOffset = 0
|
||||
VerticalOffset = 0
|
||||
Width = 0
|
||||
end
|
||||
9
components/fpweb/demo/image/wmimage.lrs
Normal file
9
components/fpweb/demo/image/wmimage.lrs
Normal file
@ -0,0 +1,9 @@
|
||||
{ This is an automatically generated lazarus resource file }
|
||||
|
||||
LazarusResources.Add('TFPWebModule1','FORMDATA',[
|
||||
'TPF0'#13'TFPWebModule1'#12'FPWebModule1'#7'Actions'#14#1#4'Name'#6#3'Pie'#7
|
||||
+'Default'#9#9'OnRequest'#7#10'PieRequest'#0#1#4'Name'#6#4'File'#9'OnRequest'
|
||||
+#7#11'FileRequest'#0#0#9'ActionVar'#6#6'Action'#4'left'#3#16#1#3'top'#3#230#0
|
||||
+#6'Height'#2#0#16'HorizontalOffset'#2#0#14'VerticalOffset'#2#0#5'Width'#2#0#0
|
||||
+#0
|
||||
]);
|
||||
242
components/fpweb/demo/image/wmimage.pp
Normal file
242
components/fpweb/demo/image/wmimage.pp
Normal file
@ -0,0 +1,242 @@
|
||||
unit wmimage;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, HTTPDefs, websession, fpHTTP, fpWeb,fpimage;
|
||||
|
||||
type
|
||||
|
||||
{ TFPWebModule1 }
|
||||
|
||||
TFPWebModule1 = class(TFPWebModule)
|
||||
procedure FileRequest(Sender: TObject; ARequest: TRequest;
|
||||
AResponse: TResponse; var Handled: Boolean);
|
||||
procedure PieRequest(Sender: TObject; ARequest: TRequest;
|
||||
AResponse: TResponse; var Handled: Boolean);
|
||||
procedure DoDrawPie(Img: TFPCustomImage;AFontName : String; Skipped, Failed, Total: Integer);
|
||||
private
|
||||
{ private declarations }
|
||||
public
|
||||
{ public declarations }
|
||||
end;
|
||||
|
||||
var
|
||||
FPWebModule1: TFPWebModule1;
|
||||
|
||||
implementation
|
||||
|
||||
// Units needed to draw a pie. Requires freetype font rendering lib
|
||||
// Make sure the font path is set correctly.
|
||||
|
||||
uses ftFont,fpimgcanv,fpWritePng,fpcanvas;
|
||||
|
||||
{ Configure this so it makes sense for your system }
|
||||
|
||||
Const
|
||||
|
||||
// Directory to send images from.
|
||||
ImageDir = '/home/michael/lazarus/images/menu';
|
||||
// Directories with TTF files for fonts.
|
||||
{$ifdef win32}
|
||||
FontDirs = 'c:\windows;c:\windows\system32';
|
||||
{$else}
|
||||
FontDirs = '/usr/share/fonts/truetype';
|
||||
{$endif}
|
||||
// Font to be used by default. Must exist in fontdir.
|
||||
DefFontName = 'FreeSans';
|
||||
|
||||
{ TFPWebModule1 }
|
||||
|
||||
{
|
||||
When action is pie, a pie diagram simulating a testrun of the FPC
|
||||
test suite is generated and sent to the client.
|
||||
The pie can be customized with the following request variables
|
||||
Runs : Total number of runs (integer)
|
||||
Failed : Number of failed runs (integer, less than runs)
|
||||
Skipped : Number of skipped runs (integer, less than runs)
|
||||
FontName : Name of font to be used for legend. (string)
|
||||
}
|
||||
|
||||
|
||||
procedure TFPWebModule1.PieRequest(Sender: TObject; ARequest: TRequest;
|
||||
AResponse: TResponse; var Handled: Boolean);
|
||||
|
||||
Var
|
||||
I : TFPMemoryImage;
|
||||
M : TMemoryStream;
|
||||
Skipped,Failed,Runs : Integer;
|
||||
FontName : String;
|
||||
|
||||
|
||||
begin
|
||||
ftFont.InitEngine;
|
||||
FontMgr.SearchPath:=FontDirs;
|
||||
I:=TFPMemoryImage.Create(320,320);
|
||||
try
|
||||
// Simulate a testrun. Take values from request variables,
|
||||
// Generate default values if needed.
|
||||
Runs:=StrToIntDef(ARequest.QueryFields.Values['Runs'],100+Random(100));
|
||||
Failed:=StrToIntDef(ARequest.QueryFields.Values['Failed'],Random(Runs div 2));
|
||||
Skipped:=StrToIntDef(ARequest.QueryFields.Values['Skipped'],Random(Runs div 10));
|
||||
FontName:=ARequest.QueryFields.Values['FontName'];
|
||||
If (FontName='') then
|
||||
FontName:=DefFontName; // Default. Make sure this exists.
|
||||
DoDrawPie(I,FontName,Skipped,Failed,Runs);
|
||||
M:=TMemoryStream.Create;
|
||||
Try
|
||||
With TFPWriterPNG.Create do
|
||||
try
|
||||
UseAlpha:=True;
|
||||
ImageWrite(M,I);
|
||||
Finally
|
||||
Free;
|
||||
end;
|
||||
AResponse.ContentType:='image/png';
|
||||
M.Position:=0;
|
||||
AResponse.ContentStream:=M;
|
||||
AResponse.SendContent;
|
||||
Finally
|
||||
M.Free;
|
||||
end;
|
||||
Finally
|
||||
I.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{
|
||||
When action is file, a png image file is sent to the client.
|
||||
The filename is determined from the 'filename' request variable
|
||||
and the configured directory. (see above for the config constants)
|
||||
|
||||
}
|
||||
|
||||
procedure TFPWebModule1.FileRequest(Sender: TObject; ARequest: TRequest;
|
||||
AResponse: TResponse; var Handled: Boolean);
|
||||
|
||||
Var
|
||||
OFN, FN : String;
|
||||
F : TFileStream;
|
||||
|
||||
begin
|
||||
OFN:=ARequest.QueryFields.Values['FileName'];
|
||||
FN:=OFN;
|
||||
If (FN='') then
|
||||
Raise Exception.Create('This script requires a file name argument');
|
||||
// Strip any directory path.
|
||||
FN:=ExtractFileName(FN);
|
||||
// Make sure it is a PNG file.
|
||||
FN:=ChangeFileExt(FN,'.png');
|
||||
FN:=IncludeTrailingPathDelimiter(ImageDir)+FN;
|
||||
If Not FileExists(FN) then
|
||||
Raise Exception.Create('The requested file "'+OFN+'" does not exist in the image directory');
|
||||
AResponse.ContentType:='image/png';
|
||||
F:=TFileStream.Create(FN,fmOpenRead);
|
||||
Try
|
||||
AResponse.ContentStream:=F;
|
||||
AResponse.SendContent;
|
||||
Handled:=True;
|
||||
Finally
|
||||
F.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{
|
||||
This routine is not essential to the webmodule, but demonstrates nicely
|
||||
how to draw an image using fpimage.
|
||||
}
|
||||
|
||||
Procedure TFPWebModule1.DoDrawPie(Img : TFPCustomImage; AFontName : String; Skipped,Failed,Total : Integer);
|
||||
|
||||
Var
|
||||
Cnv : TFPImageCanvas;
|
||||
W,H,FH,CR,ra : Integer;
|
||||
A1,A2,FR,SR,PR : Double;
|
||||
R : TRect;
|
||||
F : TFreeTypeFont;
|
||||
|
||||
Procedure AddPie(X,Y,R : Integer; AStart,AStop : Double; Col : TFPColor);
|
||||
|
||||
Var
|
||||
DX,Dy : Integer;
|
||||
|
||||
begin
|
||||
DX:=Round(R*Cos(A1));
|
||||
DY:=Round(R*Sin(A1));
|
||||
Cnv.Line(X,Y,X+DX,Y-DY);
|
||||
DX:=Round(Ra*Cos(A2));
|
||||
DY:=Round(Ra*Sin(A2));
|
||||
Cnv.Line(X,Y,X+DX,Y-Dy);
|
||||
DX:=Round(R/2*Cos((A1+A2)/2));
|
||||
DY:=Round(R/2*Sin((A1+A2)/2));
|
||||
Cnv.Brush.FpColor:=Col;
|
||||
Cnv.FloodFill(X+DX,Y-DY);
|
||||
end;
|
||||
|
||||
Function FractionAngle(F,T : Integer): Double;
|
||||
|
||||
begin
|
||||
Result:=(2*Pi*(F/T))
|
||||
end;
|
||||
|
||||
begin
|
||||
F:=TFreeTypeFont.Create;
|
||||
With F do
|
||||
begin
|
||||
Name:=AFontName;
|
||||
FontIndex:=0;
|
||||
Size:=12;
|
||||
FPColor:=colred;
|
||||
AntiAliased:=False;
|
||||
Resolution:=96;
|
||||
end;
|
||||
Cnv:=TFPImageCanvas.Create(Img);
|
||||
W:=Img.Width;
|
||||
H:=Img.Height;
|
||||
cnv.Brush.Style:=bsSolid;
|
||||
cnv.Brush.FPColor:=colTransparent;
|
||||
cnv.Pen.FPColor:=colWhite;
|
||||
Cnv.Rectangle(0,0,W,H);
|
||||
Cnv.Font:=F;
|
||||
FH:=CNV.GetTextHeight('A');
|
||||
If FH=0 then
|
||||
FH:=14; // 3 * 14;
|
||||
Inc(FH,3);
|
||||
R.Top:=FH*4;
|
||||
R.Left:=0;
|
||||
R.Bottom:=H;
|
||||
CR:=H-(FH*4);
|
||||
If W>CR then
|
||||
R.Right:=CR
|
||||
else
|
||||
R.Right:=W;
|
||||
Ra:=CR div 2;
|
||||
Cnv.Pen.FPColor:=colBlack;
|
||||
cnv.brush.FPColor:=colRed;
|
||||
Cnv.Ellipse(R);
|
||||
cnv.font.FPColor:=colred;
|
||||
Inc(FH,4);
|
||||
FR:=Failed/Total;
|
||||
SR:=Skipped/Total;
|
||||
PR:=1-(FR+SR);
|
||||
Cnv.Textout(1,FH,Format('%d Failed (%3.1f%%)',[Failed,Fr*100]));
|
||||
cnv.font.FPColor:=colYellow;
|
||||
Cnv.Textout(1,FH*2,Format('%d Skipped (%3.1f%%)',[Skipped,SR*100]));
|
||||
A1:=(Pi*2*(failed/total));
|
||||
A2:=A1+(Pi*2*(Skipped/Total));
|
||||
AddPie(Ra,R.Top+Ra,Ra,A1,A2,ColYellow);
|
||||
cnv.font.FPColor:=colGreen;
|
||||
A1:=A2;
|
||||
A2:=A1+(Pi*2*((Total-(Skipped+Failed))/Total));
|
||||
Cnv.Textout(1,FH*3,Format('%d Passed (%3.1f%%',[Total-Skipped-Failed,PR*100]));
|
||||
AddPie(Ra,R.Top+Ra,Ra,A1,A2,ColGreen);
|
||||
end;
|
||||
|
||||
initialization
|
||||
{$I wmimage.lrs}
|
||||
|
||||
RegisterHTTPModule('TFPWebModule1', TFPWebModule1);
|
||||
end.
|
||||
|
||||
56
components/fpweb/demo/session/sessiondemo.lpi
Normal file
56
components/fpweb/demo/session/sessiondemo.lpi
Normal file
@ -0,0 +1,56 @@
|
||||
<?xml version="1.0"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<PathDelim Value="/"/>
|
||||
<Version Value="6"/>
|
||||
<General>
|
||||
<SessionStorage Value="InIDEConfig"/>
|
||||
<MainUnit Value="0"/>
|
||||
<IconPath Value="./"/>
|
||||
<TargetFileExt Value=""/>
|
||||
</General>
|
||||
<VersionInfo>
|
||||
<ProjectVersion Value=""/>
|
||||
</VersionInfo>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<IgnoreBinaries Value="False"/>
|
||||
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
|
||||
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="1">
|
||||
<Item1>
|
||||
<PackageName Value="WebLaz"/>
|
||||
</Item1>
|
||||
</RequiredPackages>
|
||||
<Units Count="2">
|
||||
<Unit0>
|
||||
<Filename Value="sessiondemo.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="sessiondemo"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="../../../../../../lazarus/components/fpweb/demo/session/wmsession.pp"/>
|
||||
<ComponentName Value="SessionModule"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ResourceFilename Value="../../../../../../lazarus/components/fpweb/demo/session/wmsession.lrs"/>
|
||||
<UnitName Value="wmsession"/>
|
||||
</Unit1>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="5"/>
|
||||
<CodeGeneration>
|
||||
<Generate Value="Faster"/>
|
||||
</CodeGeneration>
|
||||
<Other>
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
</CONFIG>
|
||||
13
components/fpweb/demo/session/sessiondemo.lpr
Normal file
13
components/fpweb/demo/session/sessiondemo.lpr
Normal file
@ -0,0 +1,13 @@
|
||||
program sessiondemo;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
fpWeb,fpCGI, wmsession;
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TSessionModule, SessionModule);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
25
components/fpweb/demo/session/wmsession.lfm
Normal file
25
components/fpweb/demo/session/wmsession.lfm
Normal file
@ -0,0 +1,25 @@
|
||||
object SessionModule: TSessionModule
|
||||
Actions = <
|
||||
item
|
||||
Name = 'NewSession'
|
||||
OnRequest = NewSessionRequest
|
||||
end
|
||||
item
|
||||
Name = 'InSession'
|
||||
Default = True
|
||||
OnRequest = InSessionRequest
|
||||
end
|
||||
item
|
||||
Name = 'EndSession'
|
||||
OnRequest = EndSessionRequest
|
||||
end>
|
||||
ActionVar = 'DemoSession'
|
||||
CreateSession = True
|
||||
OnNewSession = SessionModuleNewSession
|
||||
left = 302
|
||||
top = 190
|
||||
Height = 0
|
||||
HorizontalOffset = 0
|
||||
VerticalOffset = 0
|
||||
Width = 0
|
||||
end
|
||||
11
components/fpweb/demo/session/wmsession.lrs
Normal file
11
components/fpweb/demo/session/wmsession.lrs
Normal file
@ -0,0 +1,11 @@
|
||||
{ This is an automatically generated lazarus resource file }
|
||||
|
||||
LazarusResources.Add('TSessionModule','FORMDATA',[
|
||||
'TPF0'#14'TSessionModule'#13'SessionModule'#7'Actions'#14#1#4'Name'#6#10'NewS'
|
||||
+'ession'#9'OnRequest'#7#17'NewSessionRequest'#0#1#4'Name'#6#9'InSession'#7'D'
|
||||
+'efault'#9#9'OnRequest'#7#16'InSessionRequest'#0#1#4'Name'#6#10'EndSession'#9
|
||||
+'OnRequest'#7#17'EndSessionRequest'#0#0#9'ActionVar'#6#11'DemoSession'#13'Cr'
|
||||
+'eateSession'#9#12'OnNewSession'#7#23'SessionModuleNewSession'#4'left'#3'.'#1
|
||||
+#3'top'#3#190#0#6'Height'#2#0#16'HorizontalOffset'#2#0#14'VerticalOffset'#2#0
|
||||
+#5'Width'#2#0#0#0
|
||||
]);
|
||||
167
components/fpweb/demo/session/wmsession.pp
Normal file
167
components/fpweb/demo/session/wmsession.pp
Normal file
@ -0,0 +1,167 @@
|
||||
unit wmsession;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, HTTPDefs, websession, fpHTTP,
|
||||
fpWeb;
|
||||
|
||||
type
|
||||
|
||||
{ TSessionModule }
|
||||
|
||||
TSessionModule = class(TFPWebModule)
|
||||
procedure EndSessionRequest(Sender: TObject; ARequest: TRequest;
|
||||
AResponse: TResponse; var Handled: Boolean);
|
||||
procedure InSessionRequest(Sender: TObject; ARequest: TRequest;
|
||||
AResponse: TResponse; var Handled: Boolean);
|
||||
procedure NewSessionRequest(Sender: TObject; ARequest: TRequest;
|
||||
AResponse: TResponse; var Handled: Boolean);
|
||||
procedure SessionModuleNewSession(Sender: TObject);
|
||||
private
|
||||
{ private declarations }
|
||||
public
|
||||
{ public declarations }
|
||||
end;
|
||||
|
||||
var
|
||||
SessionModule: TSessionModule;
|
||||
|
||||
implementation
|
||||
|
||||
{ TSessionModule }
|
||||
|
||||
{
|
||||
The default action is the 'InSession' action. When a new session
|
||||
is started, the newsession event handler is called, and
|
||||
we set the 'NewSession' action as default.
|
||||
}
|
||||
|
||||
procedure TSessionModule.SessionModuleNewSession(Sender: TObject);
|
||||
begin
|
||||
Actions.ActionByName('NewSession').Default:=True;
|
||||
Actions.ActionByName('InSession').Default:=False;
|
||||
end;
|
||||
|
||||
{
|
||||
When a new session is detected
|
||||
|
||||
- either because there was no session,in which case NewSession is the default
|
||||
|
||||
- The URL contained the newsession action in the 'DemoSession' action variable,
|
||||
something like:
|
||||
|
||||
http://localhost/cgi-bin/sessiondemo.cgi?DemoSession=NewSession
|
||||
|
||||
in either case, the NewSession action is called, and this event is triggered:
|
||||
}
|
||||
|
||||
procedure TSessionModule.NewSessionRequest(Sender: TObject; ARequest: TRequest;
|
||||
AResponse: TResponse; var Handled: Boolean);
|
||||
|
||||
Var
|
||||
C : TCookie;
|
||||
|
||||
begin
|
||||
With AResponse.Contents do
|
||||
begin
|
||||
Add('<HTML><TITLE>Demo session was started</TITLE><BODY>');
|
||||
Add('<H1>New session started</H1>');
|
||||
Add('A new session was started<P>.');
|
||||
If Session is TFPWebSession then
|
||||
begin
|
||||
C:=AResponse.Cookies.FindCookie((Session as TFPWebSession).SessionCookie);
|
||||
If Assigned(C) then
|
||||
begin
|
||||
Add('The issued session cookie is called <B>'+C.Name+'</B><BR> ');
|
||||
Add('The issued session cookie has value <B>'+C.Value+'</B><BR>.');
|
||||
end
|
||||
else
|
||||
Add('No session cookie was found.');
|
||||
end;
|
||||
Add('</BODY></HTML>');
|
||||
end;
|
||||
Handled:=True; // Content will be sent.
|
||||
end;
|
||||
|
||||
{
|
||||
The default action is the 'InSession' action.
|
||||
We display the session cookie, and the value (name 'Var')
|
||||
that is currently stored in the session object.
|
||||
|
||||
If the user supplied a new value for 'var', we store it in the session.
|
||||
to supply the value, append
|
||||
?var=value
|
||||
to the URL.
|
||||
}
|
||||
|
||||
procedure TSessionModule.InSessionRequest(Sender: TObject; ARequest: TRequest;
|
||||
AResponse: TResponse; var Handled: Boolean);
|
||||
|
||||
Var
|
||||
V : string;
|
||||
C : TCookie;
|
||||
|
||||
begin
|
||||
With AResponse.Contents do
|
||||
begin
|
||||
Add('<HTML><TITLE>Demo session active</TITLE><BODY>');
|
||||
Add('<H1>Demo session active</H1>');
|
||||
Add('The demo session is still active<P>');
|
||||
If Session is TFPWebSession then
|
||||
begin
|
||||
C:=AResponse.Cookies.FindCookie((Session as TFPWebSession).SessionCookie);
|
||||
If Assigned(C) then
|
||||
begin
|
||||
Add('Current session Cookie is called <B>'+C.Name+'</B><BR>');
|
||||
Add('and has value <B>'+C.Value+'</B>.');
|
||||
end;
|
||||
V:=Session.Variables['Var'];
|
||||
If (V<>'') then
|
||||
Add('<P>Stored session value: <B>'+V+'</B>.')
|
||||
else
|
||||
Add('<P>No values stored in session.');
|
||||
V:=ARequest.QueryFields.Values['Var'];
|
||||
If V<>'' then
|
||||
begin
|
||||
Add('<P>Storing new session value: <B>'+V+'</B>.');
|
||||
Session.Variables['Var']:=V;
|
||||
end;
|
||||
end;
|
||||
Add('</BODY></HTML>');
|
||||
AResponse.SendContent; // Handles the response.
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{
|
||||
When the 'EndSession' action is called, the session is ended. The
|
||||
endsession action can be called by providing the 'EndSession' value for
|
||||
the 'DemoSession' action variable, something like:
|
||||
|
||||
http://localhost/cgi-bin/sessiondemo.cgi?DemoSession=EndSession
|
||||
}
|
||||
procedure TSessionModule.EndSessionRequest(Sender: TObject; ARequest: TRequest;
|
||||
AResponse: TResponse; var Handled: Boolean);
|
||||
begin
|
||||
// Stop the session
|
||||
Session.Terminate;
|
||||
With AResponse.Contents do
|
||||
begin
|
||||
Add('<HTML><TITLE>Demo Session Is Terminated</TITLE><BODY>');
|
||||
Add('<H1>Demo session Terminated</H1>');
|
||||
Add('The session was terminated, the cookie is cleared and the');
|
||||
Add('stored value is lost');
|
||||
Add('</BODY></HTML>');
|
||||
end;
|
||||
AResponse.SendContent;
|
||||
end;
|
||||
|
||||
initialization
|
||||
{$I wmsession.lrs}
|
||||
|
||||
RegisterHTTPModule('session', TSessionModule);
|
||||
end.
|
||||
|
||||
@ -289,7 +289,7 @@ end;
|
||||
function TFileDescWebDataModule.GetInterfaceUsesSection: string;
|
||||
begin
|
||||
Result:=inherited GetInterfaceUsesSection;
|
||||
Result:=Result+',LResources,HTTPDefs, websession, fpHTTP,fpWeb';
|
||||
Result:=Result+',HTTPDefs, websession, fpHTTP,fpWeb';
|
||||
end;
|
||||
|
||||
function TFileDescWebDataModule.GetLocalizedName: string;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user