├── .gitignore
├── LICENSE
├── ProjectGroup1.groupproj
├── README-en.md
├── README.md
├── Router4Delphi.dpk
├── Router4Delphi.dproj
├── Samples
├── FMX
│ ├── Demo
│ │ ├── Router4DelphiDemo.View.Principal.fmx
│ │ ├── Router4DelphiDemo.View.Principal.pas
│ │ ├── Router4DelphiDemo.dpr
│ │ ├── Router4DelphiDemo.dproj
│ │ ├── Router4DelphiDemo.res
│ │ └── Views
│ │ │ ├── Components
│ │ │ ├── Router4DelphiDemo.View.Components.Sidebar.fmx
│ │ │ └── Router4DelphiDemo.View.Components.Sidebar.pas
│ │ │ ├── Layouts
│ │ │ ├── Router4DelphiDemo.Views.Layouts.Main.fmx
│ │ │ └── Router4DelphiDemo.Views.Layouts.Main.pas
│ │ │ ├── Pages
│ │ │ ├── Router4DelphiDemo.View.Pages.Cadastros.fmx
│ │ │ ├── Router4DelphiDemo.View.Pages.Cadastros.pas
│ │ │ ├── Router4DelphiDemo.View.Pages.Index.fmx
│ │ │ └── Router4DelphiDemo.View.Pages.Index.pas
│ │ │ ├── Router4DelphiDemo.View.Principal.fmx
│ │ │ ├── Router4DelphiDemo.View.Principal.pas
│ │ │ └── Routers
│ │ │ └── Router4DelphiDemo.View.Router.pas
│ └── SimpleDemo
│ │ ├── SimpleDemo.View.Components.Button01.fmx
│ │ ├── SimpleDemo.View.Components.Button01.pas
│ │ ├── SimpleDemo.View.Page.Cadastros.Sub.fmx
│ │ ├── SimpleDemo.View.Page.Cadastros.Sub.pas
│ │ ├── SimpleDemo.View.Page.Cadastros.fmx
│ │ ├── SimpleDemo.View.Page.Cadastros.pas
│ │ ├── SimpleDemo.View.Page.Principal.fmx
│ │ ├── SimpleDemo.View.Page.Principal.pas
│ │ ├── SimpleDemo.View.Principal.fmx
│ │ ├── SimpleDemo.View.Principal.pas
│ │ ├── SimpleDemo.dpr
│ │ ├── SimpleDemo.dproj
│ │ └── SimpleDemo.res
└── VCL
│ ├── Main.dfm
│ ├── Main.pas
│ ├── Router.dpr
│ ├── Router.dproj
│ └── pages
│ ├── View.Page.Customer.dfm
│ ├── View.Page.Customer.pas
│ ├── View.Page.Main.Cadastro.dfm
│ ├── View.Page.Main.Cadastro.pas
│ ├── View.Page.Product.dfm
│ ├── View.Page.Product.pas
│ ├── View.Page.Template.dfm
│ └── View.Page.Template.pas
├── assets
└── logo.fw.png
├── boss-lock.json
├── boss.json
└── src
├── DuckListU.pas
├── EventBus.Core.pas
├── EventBus.Subscribers.pas
├── ObjectsMappers.pas
├── RTTIUtilsU.pas
├── Router4D.Helper.pas
├── Router4D.History.pas
├── Router4D.Interfaces.pas
├── Router4D.Link.pas
├── Router4D.Props.pas
├── Router4D.Render.pas
├── Router4D.Sidebar.pas
├── Router4D.Switch.pas
├── Router4D.Utils.pas
├── Router4D.inc
└── Router4D.pas
/.gitignore:
--------------------------------------------------------------------------------
1 | # Uncomment these types if you want even more clean repository. But be careful.
2 | # It can make harm to an existing project source. Read explanations below.
3 |
4 | # Resource files are binaries containing manifest, project icon and version info.
5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files.
6 | *.res
7 |
8 | # Type library file (binary). In old Delphi versions it should be stored.
9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored.
10 | #*.tlb
11 | #
12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7.
13 | # Uncomment this if you are not using diagrams or use newer Delphi version.
14 | #*.ddp
15 | #
16 | # Visual LiveBindings file. Added in Delphi XE2.
17 | # Uncomment this if you are not using LiveBindings Designer.
18 | #*.vlb
19 | #
20 | # Deployment Manager configuration file for your project. Added in Delphi XE2.
21 | # Uncomment this if it is not mobile development and you do not use remote debug feature.
22 | #*.deployproj
23 | #
24 | # C++ object files produced when C/C++ Output file generation is configured.
25 | # Uncomment this if you are not using external objects (zlib library for example).
26 | #*.obj
27 | #
28 |
29 | # Delphi compiler-generated binaries (safe to delete)
30 | *.exe
31 | *.dll
32 | *.bpl
33 | *.bpi
34 | *.dcp
35 | *.so
36 | *.apk
37 | *.drc
38 | *.map
39 | *.dres
40 | *.rsm
41 | *.tds
42 | *.dcu
43 | *.lib
44 | *.a
45 | *.o
46 | *.ocx
47 |
48 | # Delphi autogenerated files (duplicated info)
49 | *.cfg
50 | *.hpp
51 | *Resource.rc
52 |
53 | # Delphi local files (user-specific info)
54 | *.local
55 | *.identcache
56 | *.projdata
57 | *.tvsconfig
58 | *.dsk
59 |
60 | # Delphi history and backups
61 | __history/
62 | __recovery/
63 | *.~*
64 |
65 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi)
66 | *.stat
67 |
68 | # Boss dependency manager vendor folder https://github.com/HashLoad/boss
69 | modules/
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | MIT License
2 |
3 | Copyright (c) 2020 Thulio Bittencourt
4 |
5 | Permission is hereby granted, free of charge, to any person obtaining a copy
6 | of this software and associated documentation files (the "Software"), to deal
7 | in the Software without restriction, including without limitation the rights
8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 |
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 |
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
22 |
--------------------------------------------------------------------------------
/ProjectGroup1.groupproj:
--------------------------------------------------------------------------------
1 |
2 |
3 | {9C8C8331-996E-4D6D-AEBB-F1D465788ABF}
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 | Default.Personality.12
18 |
19 |
20 |
21 |
22 |
23 |
24 |
25 |
26 |
27 |
28 |
29 |
30 |
31 |
32 |
33 |
34 |
35 |
36 |
37 |
38 |
39 |
40 |
41 |
42 |
43 |
44 |
45 |
46 |
47 |
48 |
49 |
50 |
51 |
52 |
53 |
54 |
55 |
56 |
57 |
58 |
59 |
60 |
61 |
--------------------------------------------------------------------------------
/README-en.md:
--------------------------------------------------------------------------------
1 |
2 |
3 | 
4 |
5 |
6 |
7 |
8 | 
9 | 
10 | 
11 | 
12 | 
13 | 
14 | 
15 |
16 |
17 | # Router4Delphi
18 | Framework for Creating Screen Routes for FMX and VCL
19 |
20 | Router4Delphi aims to facilitate the calling of screens and embed Layouts in FMX applications, and Panels in VCL applications, reducing the coupling of screens and providing more dynamism and practicality in the construction of rich Delphi interfaces.
21 |
22 | ## Instalation
23 |
24 | Simply register the path to the library's SRC folder in the Library Path of your Delphi, or if you prefer, you can use [**Boss**](https://github.com/HashLoad/boss) (dependency manager for Delphi) To perform the installation:
25 | ```
26 | boss install https://github.com/academiadocodigo/Router4Delphi
27 | ```
28 |
29 | ## First Steps - Tutorial
30 |
31 | To use Router4Delphi to create your routes, you must use Router4D.
32 |
33 | #### Observation
34 |
35 | Inside the src folder contains Router4D.inc, this file has the compilation directive for Firemonkey, with this directive commented out the Framework will have VCL support, and when uncommenting it you will have FMX support.
36 |
37 | ## Creating a Screen for Routing
38 |
39 | For the Route system to work you must create a new FMX or VCL form and Implement the iRouter4DComponent Interface, it belongs to the Router4D.Interfaces unit so it must be included in your Units.
40 |
41 | All route-based screen construction uses TLayouts and TPanels to embed the screen calls, so your new screen must have a TLayout or a main TPanel and all other components must be included within this layout or panel.
42 |
43 | The iRouter4DComponent Interface Implementation requires the declaration of two methods (Render and UnRender), Render is called whenever a route activates the screen, and UnRender whenever it leaves the display.
44 |
45 | Below is the code for a simple screen implementing the iRouter4DComponent interface and ready to be used.
46 |
47 | #### FMX Sample
48 |
49 | Create a New Form in your Application, include an AlClient aligned Layout in it and implement the methods as below.
50 |
51 | ```delphi
52 |
53 | unit PrimeiraTela;
54 |
55 | interface
56 |
57 | uses
58 | System.SysUtils,
59 | System.Types,
60 | System.UITypes,
61 | System.Classes,
62 | System.Variants,
63 | FMX.Types,
64 | FMX.Controls,
65 | FMX.Forms,
66 | FMX.Graphics,
67 | FMX.Dialogs,
68 | Router4D.Interfaces;
69 |
70 | type
71 | TFirstScreen = class(TForm, iRouter4DComponent)
72 | Layout1: TLayout;
73 | private
74 | { Private declarations }
75 | public
76 | { Public declarations }
77 | function Render : TFMXObject;
78 | procedure UnRender;
79 | end;
80 |
81 | var
82 | FirstScreen: TFirstScreen;
83 |
84 | implementation
85 |
86 | {$R *.fmx}
87 |
88 | { TForm3 }
89 |
90 | function TFirstScreen.Render: TFMXObject;
91 | begin
92 | Result := Layout1;
93 | end;
94 |
95 | procedure TFirstScreen.UnRender;
96 | begin
97 |
98 | end;
99 |
100 | end.
101 | ```
102 |
103 | Note that in the Render method we define Layout1 as Result, this is necessary because this layout will be embedded whenever the route is activated.
104 |
105 | ## Registering the Route to the Screen
106 |
107 | Now that we have a screen ready to be registered, let's move on to the process that will make our screen ready to be activated at any time.
108 |
109 | To register a route it is necessary to declare Uses Router4D, it provides access to all library methods and in many cases it will be the only coupling necessary in your Views.
110 |
111 | Once declared, simply activate the method below to declare the form we created previously as a route.
112 |
113 | In the Main form of your Application, within the onCreate method, execute the method below to register the Route for the Form TFirstScreen
114 |
115 | ```delphi
116 |
117 | procedure TMainForm.FormCreate(Sender: TObject);
118 | begin
119 | TRouter4D.Switch.Router('Inicio', TFirstScreen);
120 | end;
121 | ```
122 |
123 | We now have a Route created, so our forms no longer need to know the uses of our screen, just activate our route system and ask for the creation of the "Start" route and it will be displayed in the application's LayoutMain.
124 |
125 | You can create a separate Unit just to Register the Routes or call a method in the onCreate of your main form for this.
126 |
127 | ## Defining the Main Render
128 |
129 | We already have a screen and a route to use, now we just need to define where this route will render the layout, that is, what will be our Object that will receive the embedded screens.
130 |
131 | To do this, in the formPrincipal of your application, declare uses Router4D and in its onCreate make the following call.
132 |
133 | Remembering that in the previous step we had already used the onCreate formPrincipal to Register the Route.
134 |
135 | ```delphi
136 |
137 | procedure TMainForm.FormCreate(Sender: TObject);
138 | begin
139 | TRouter4D.Switch.Router('Inicio', TFirstScreen);
140 |
141 | TRouter4D.Render.SetElement(Layout1, Layout1);
142 | end;
143 |
144 | ```
145 |
146 | The Render method is responsible for defining the Application's LayoutsMain and Index in the library.
147 |
148 | The Render receives the name of the Class from our home screen as a generic, it will be rendered when the application opens within the Layout that was informed as the first parameter of the SetElement
149 |
150 | The first parameter of the SetElement is defining in which Layout the library will render a new screen whenever a Route Link is called.
151 |
152 | The second parameter of the SetElement is defining the Index layout of the application, so when an IndexLink is called it will be rendered in that layout, later I will explain about the IndexLink.
153 |
154 | Okay, now when you open your application you will already have the TPrimeiraTela Form Layout being rendered within Layout1 of your application's Main form.
155 |
156 | ## Creating a Second Screen
157 |
158 | So that we can actually see the component in action and all its benefits, create a new screen similar to the one we did at the beginning, adding an alClient Layout to it and implementing the Render and UnRender methods.
159 |
160 | Place a Label inside the Layout, for example, written on the second screen, just to make sure everything worked correctly.
161 |
162 | ```delphi
163 |
164 | unit SecondScreen;
165 |
166 | interface
167 |
168 | uses
169 | System.SysUtils,
170 | System.Types,
171 | System.UITypes,
172 | System.Classes,
173 | System.Variants,
174 | FMX.Types,
175 | FMX.Controls,
176 | FMX.Forms,
177 | FMX.Graphics,
178 | FMX.Dialogs,
179 | Router4D.Interfaces;
180 |
181 | type
182 | TSecondScreen = class(TForm, iRouter4DComponent)
183 | Layout1: TLayout;
184 | private
185 | { Private declarations }
186 | public
187 | { Public declarations }
188 | function Render : TFMXObject;
189 | procedure UnRender;
190 | end;
191 |
192 | var
193 | SecondScreen: TSecondScreen;
194 |
195 | implementation
196 |
197 | {$R *.fmx}
198 |
199 | { TSecondScreen }
200 |
201 | function TSecondScreen.Render: TFMXObject;
202 | begin
203 | Result := Layout1;
204 | end;
205 |
206 | procedure TSecondScreen.UnRender;
207 | begin
208 |
209 | end;
210 |
211 | end.
212 | ```
213 | ## Registering the Second Screen on the Route
214 |
215 | Now that we have created a new screen we need to register it in the Routes system, so let's go back to onCreate and make this registration, let's call this screen Screen2.
216 |
217 | ```delphi
218 |
219 | procedure TMainForm.FormCreate(Sender: TObject);
220 | begin
221 | TRouter4D.Switch.Router('Inicio', TFirstScreen);
222 |
223 | TRouter4D.Switch.Router('Tela2', TSecondScreen);
224 |
225 | TRouter4D.Render.SetElement(Layout1, Layout1);
226 | end;
227 |
228 | ```
229 |
230 |
231 | ## Activating the new screen through the Route using the Link
232 |
233 | Now that the magic comes, go back to the TFirstScreen and place a button there and we will use the Router4D Links system to call the TSegundaScreen without having to use it.
234 |
235 | Just call the method below in the Button Click Event.
236 |
237 | ```delphi
238 | procedure TFirstScreen.Button1Click(Sender: TObject);
239 | begin
240 | TRouter4D.Link.&To('Tela2');
241 | end;
242 | ```
243 |
244 | Note that TFirstScreen does not know TSecondScren because its uses were only given in the formPrincipal where it is necessary for Route Registration.
245 |
246 | If you want to make this more organized, I even suggest that you create a separate Unit just to register the Routes with a class procedure and call this method in the MainForm's onCreate.
247 |
248 | This way we put an end to a lot of cross-references and coupling between screens.
249 |
250 |
251 | ## Resources - Render
252 |
253 | ```delphi
254 | TRouter4D.Render.SetElement(MainContainer, IndexContainer);
255 | ```
256 |
257 | Render is the first action to be done to work with Router4D, as in it you will configure the main and index containers.
258 |
259 | MainContainer = The container where the forms will be embedded
260 |
261 | IndexContainer = The main container of the application (useful when you have more than one type of layout in the application)
262 |
263 | ## SWITCH
264 |
265 | ```delphi
266 | TRouter4D.Switch.Router(aPath : String; aRouter : TPersistentClass);
267 | ```
268 | On the Switch you register your routes, passing the name of the route and the object that is opened when this route is activated.
269 |
270 | ```delphi
271 | TRouter4D.Switch.Router(aPath : String; aRouter : TPersistentClass; aSidebarKey : String = 'SBIndex'; isVisible : Boolean = True);
272 | ```
273 |
274 | In Swith there are some additional parameters that already have default values
275 |
276 | aSidebarKey: This parameter allows you to separate routes by category for creating dynamic menus with the SideBar class, I will explain more about it below.
277 |
278 | isVisible: Allows you to hide the route when dynamically generating menus with SideBar.
279 |
280 | ## LINK
281 |
282 | ```delphi
283 |
284 | TRouter4D.Link.&To ( aPatch : String; aComponent : TFMXObject );
285 |
286 | TRouter4D.Link.&To ( aPatch : String);
287 |
288 | TRouter4D.Link.&To ( aPatch : String; aProps : TProps; aKey : String = '');
289 |
290 | ```
291 |
292 | Links are the actions to trigger the routes you registered on the Switch
293 |
294 | There are 3 ways to call the links:
295 |
296 | ```delphi
297 | TRouter4D.Link.&To ( aPatch : String);
298 | ```
299 | Passing only the Route Path, this way the form associated with the route will be embedded within the MainContainer that you defined in Render
300 |
301 | ```delphi
302 | TRouter4D.Link.&To ( aPatch : String; aComponent : TFMXObject );
303 | ```
304 |
305 | Passing the Path and the Component, it will embed the form registered in the path within the component that you are passing in the parameter.
306 |
307 | ```delphi
308 | TRouter4D.Link.&To ( aPatch : String; aProps : TProps; aKey : String = '');
309 | ```
310 |
311 | You can trigger a route by passing Props, which are values that your form will receive at the time of Render, I will explain below how this works in detail, but this is useful for example when you want to send an ID to a screen to perform a query in the database and be loaded with the data.
312 |
313 | ## PROPS
314 |
315 | ```delphi
316 | TRouter4D.Link.&To ( aPatch : String; aProps : TProps; aKey : String = '');
317 | ```
318 |
319 | The Router4D Library incorporates the Delphi Event Bus to perform Pub and Sub actions, so you can register your forms to receive events when calling links.
320 |
321 | To receive a Props you need to add uses Router4D.Props to your form and implement the following method with the [Subscribe] attribute
322 |
323 | ```delphi
324 | [Subscribe]
325 | procedure Props ( aValue : TProps);
326 | ```
327 |
328 | and implement it
329 |
330 | ```delphi
331 | procedure TPageCadastros.Props(aValue: TProps);
332 | begin
333 | if aValue.Key = 'telacadastro' then
334 | Label1.Text := aValue.PropString;
335 | aValue.Free;
336 | end;
337 | ```
338 | This way, your form is prepared, for example, to receive a string passed in the link call.
339 |
340 | To call a link by passing a Props you use the following code:
341 |
342 | ```delphi
343 | TRouter4D.Link.&To('Cadastros', TProps.Create.PropString('Olá').Key('telacadastro'));
344 | ```
345 | Passing the TProps object with a PropString and a Key to the Link so that the receiving screen can be sure that that prop was sent to it.
346 |
347 | ## SideBar
348 |
349 | With registered routes you can create an automatic menu of registered routes dynamically, simply register a new route and it will be available in all your menus.
350 |
351 | ```delphi
352 | TRouter4D
353 | .SideBar
354 | .MainContainer(Layout5)
355 | .LinkContainer(Layout4)
356 | .FontSize(15)
357 | .FontColor(4294967295)
358 | .ItemHeigth(60)
359 | .RenderToListBox;
360 | ```
361 |
362 | In the example above we are generating a menu in listbox format within Layout5 and all links clicked on this menu will be rendered in Layout4, if you do not pass the LinkContainer it will be rendered in the MainContainer informed in the Router4D Render.
363 |
364 | You can also create menus based on categorized routes, just enter the category in which the route belongs when registering the route.
365 |
366 | ```delphi
367 | TRouter4D.Switch.Router('Clientes', TPagePrincipal, 'cadastros');
368 | TRouter4D.Switch.Router('Fornecedores', TSubCadastros, 'cadastros');
369 | TRouter4D.Switch.Router('Produtos', TSubCadastros, 'cadastros');
370 | ```
371 |
372 | This way we created 3 routes in the registration category. To generate a menu with just these links, simply inform this when building the SideBar.
373 |
374 | ```delphi
375 | TRouter4D
376 | .SideBar
377 | .Name('cadastros')
378 | .MainContainer(Layout5)
379 | .LinkContainer(Layout4)
380 | .FontSize(15)
381 | .FontColor(4294967295)
382 | .ItemHeigth(60)
383 | .RenderToListBox;
384 | ```
385 | ## Documentação
386 | [English (en)](https://github.com/academiadocodigo/Router4Delphi/blob/master/README-en.md)
387 | [Português (ptBR)](https://github.com/academiadocodigo/Router4Delphi/blob/master/README.md)
388 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 |
2 |
3 | 
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 | # Router4Delphi
18 | Framework para Criação de Rotas de Telas para FMX e VCL
19 |
20 | O Router4Delphi tem o objetivo de facilitar a chamada de telas e embed de Layouts em aplicações FMX, e Panels em aplicações VCL, reduzindo o acoplamento das telas de dando mais dinâmismo e práticidade na construção de interfaces ricas em Delphi
21 |
22 | ## Instalação
23 |
24 | Basta registrar no Library Path do seu Delphi o caminho da pasta SRC da biblioteca, ou se preferir, pode utilizar o [**Boss**](https://github.com/HashLoad/boss) (gerenciador de dependências para Delphi) para realizar a instalação:
25 | ```
26 | boss install https://github.com/bittencourtthulio/Router4Delphi
27 | ```
28 |
29 | ## Primeiros Passos - Tutorial
30 |
31 | Para utilizar o Router4Delphi para criar suas rotas, você deve realizar a uses do Router4D.
32 |
33 | #### Observação
34 |
35 | Dentro da pasta src contém o Router4D.inc, esse arquivo possui a diretiva de compilação para o Firemonkey, com essa diretiva comentada o Framework terá suporte a VCL, e ao descomentar você terá suporte ao FMX.
36 |
37 | ## Criação de uma Tela para Roteamento
38 |
39 | Para que o sistema de Rotas funcione você deve criar um novo formulário FMX ou VCL e Implementar a Interface iRouter4DComponent ela pertence a unit Router4D.Interfaces portanto a mesma deve ser incluida nas suas Units.
40 |
41 | Toda a construção das telas baseadas em rotas utilizar TLayouts e TPanels para embedar as chamadas das telas, dessa forma é preciso que sua nova tela tenha um TLayout ou um TPanel principal e todos os demais componentes devem ser incluídos dentro desse layout ou panel.
42 |
43 | A Implementação da Interface iRouter4DComponent requer a declaração de dois métodos ( Render e UnRender ), o Render é chamado sempre que uma rota aciona a tela, e o UnRender sempre que ela saí de exibição.
44 |
45 | Abaixo o Código de uma tela simples implementando a interface iRouter4DComponent e pronta para ser utilizada.
46 |
47 | #### Exemplo em FMX
48 |
49 | Crie um Novo Formulario na sua Aplicação, inclua nele um Layout alinhado AlClient e implemente os métodos como abaixo.
50 |
51 | ```delphi
52 |
53 | unit PrimeiraTela;
54 |
55 | interface
56 |
57 | uses
58 | System.SysUtils,
59 | System.Types,
60 | System.UITypes,
61 | System.Classes,
62 | System.Variants,
63 | FMX.Types,
64 | FMX.Controls,
65 | FMX.Forms,
66 | FMX.Graphics,
67 | FMX.Dialogs,
68 | Router4D.Interfaces;
69 |
70 | type
71 | TPrimeiraTela = class(TForm, iRouter4DComponent)
72 | Layout1: TLayout;
73 | private
74 | { Private declarations }
75 | public
76 | { Public declarations }
77 | function Render : TFMXObject;
78 | procedure UnRender;
79 | end;
80 |
81 | var
82 | PrimeiraTela: TPrimeiraTela;
83 |
84 | implementation
85 |
86 | {$R *.fmx}
87 |
88 | { TForm3 }
89 |
90 | function TPrimeiraTela.Render: TFMXObject;
91 | begin
92 | Result := Layout1;
93 | end;
94 |
95 | procedure TPrimeiraTela.UnRender;
96 | begin
97 |
98 | end;
99 |
100 | end.
101 | ```
102 |
103 | Perceba que no método Render nós definimos como Result o Layout1, isso é necessário pois esse layout será embedado sempre que a rota for acionada.
104 |
105 | ## Registrando a Rota para a Tela
106 |
107 | Agora que já temos uma tela pronta para ser registrada vamos ao processo que deixará a nossa tela pronta para ser acionada a qualquer momento.
108 |
109 | Para registrar uma rota é necessário declarar a Uses Router4D ela fornece acesso a todos os métodos da biblioteca e em muito dos casos será o único acoplamento necessário nas suas Views.
110 |
111 | Uma vez declarada basta acionar o método abaixo para declarar o form que criamos anteriormente como uma rota.
112 |
113 | No formPrincipal da sua Aplicação, dentro do método onCreate execute o método abaixo para registrar a Rota para o Form TPrimeiraTela
114 |
115 | ```delphi
116 |
117 | procedure TformPrincipal.FormCreate(Sender: TObject);
118 | begin
119 | TRouter4D.Switch.Router('Inicio', TPrimeiraTela);
120 | end;
121 | ```
122 |
123 | Pronto já temos uma Rota criada, dessa forma os nossos forms não precisam mais conhecer a uses da nossa tela, basta acionar nosso sistema de rotas e pedir a criação da rota "Inicio" que a mesma será exibida no LayoutMain da aplicação.
124 |
125 | Você pode criar uma Unit Separada somente para Registrar as Rotas ou então chamar um metodo no onCreate do seu formulario principal para isso.
126 |
127 | ## Definindo o Render Principal
128 |
129 | Já temos uma tela e uma rota para utilizarmos, agora precisamos definir apenas onde está rota renderizará o layout, ou seja, qual será o nosso Objeto que vai receber as telas embedadas.
130 |
131 | Para isso no formPrincipal da sua aplicação, declare a uses Router4D e no onCreate do mesmo faça a seguinte chamada.
132 |
133 | Lembrando que no passo anterios nós já tinhamos usado o onCreate do formPrincipal para Registrar a Rota.
134 |
135 | ```delphi
136 |
137 | procedure TformPrincipal.FormCreate(Sender: TObject);
138 | begin
139 | TRouter4D.Switch.Router('Inicio', TPrimeiraTela);
140 |
141 | TRouter4D.Render.SetElement(Layout1, Layout1);
142 | end;
143 |
144 | ```
145 |
146 | O método Render é responsável por definir na biblioteca quais serão os LayoutsMain e Index da Aplicação.
147 |
148 | O Render recebe como genéric o nome da Classe da nossa tela inicial, ela será renderizada quando a aplicação abrir dentro do Layout que foi informado como primeiro parametro do SetElement
149 |
150 | O primeiro parametro do SetElement está definindo em qual Layout a biblioteca irá renderizar uma nova tela sempre que um Link da rota for chamado.
151 |
152 | O Segundo parametro do SetElement está definindo qual é o layout Index da aplicação, assim quando um IndexLink for chamado ele será renderizado nesse layout, mais para frente explicarei sobre o IndexLink.
153 |
154 | Pronto, agora ao abrir a sua aplicação você já terá o Layout do Formulario TPrimeiraTela sendo renderizado dentro do Layout1 do formPrincipal da sua aplicação.
155 |
156 | ## Criando uma Segunda Tela
157 |
158 | Para que possamos ver o componente em ação de fato e todos os seus benefícios, crie uma nova tela semelhante a que fizemos no inicio, adicionando um Layout alClient nela e implementando os métodos Render e UnRender.
159 |
160 | Coloque dentro do Layout um Label por exemplo, escrito segunda tela apenas para termos a certeza que tudo funcionou corretamente.
161 |
162 | ```delphi
163 |
164 | unit SegundaTela;
165 |
166 | interface
167 |
168 | uses
169 | System.SysUtils,
170 | System.Types,
171 | System.UITypes,
172 | System.Classes,
173 | System.Variants,
174 | FMX.Types,
175 | FMX.Controls,
176 | FMX.Forms,
177 | FMX.Graphics,
178 | FMX.Dialogs,
179 | Router4D.Interfaces;
180 |
181 | type
182 | TSegundaTela = class(TForm, iRouter4DComponent)
183 | Layout1: TLayout;
184 | private
185 | { Private declarations }
186 | public
187 | { Public declarations }
188 | function Render : TFMXObject;
189 | procedure UnRender;
190 | end;
191 |
192 | var
193 | SegundaTela: TSegundaTela;
194 |
195 | implementation
196 |
197 | {$R *.fmx}
198 |
199 | { TSegundaTela }
200 |
201 | function TSegundaTela.Render: TFMXObject;
202 | begin
203 | Result := Layout1;
204 | end;
205 |
206 | procedure TSegundaTela.UnRender;
207 | begin
208 |
209 | end;
210 |
211 | end.
212 | ```
213 | ## Registrando a Segunda tela na Rota
214 |
215 | Agora que criamos uma nova tela precisamos registrar ela no sistema de Rotas, então vamos voltar ao onCreate e fazer esse registros, vamos chamar essa tela de Tela2.
216 |
217 | ```delphi
218 |
219 | procedure TformPrincipal.FormCreate(Sender: TObject);
220 | begin
221 | TRouter4D.Switch.Router('Inicio', TPrimeiraTela);
222 |
223 | TRouter4D.Switch.Router('Tela2', TSegundaTela);
224 |
225 | TRouter4D.Render.SetElement(Layout1, Layout1);
226 | end;
227 |
228 | ```
229 |
230 |
231 | ## Acionando a nova tela atráves da Rota utilizando o Link
232 |
233 | Agora que vem a mágica, volte na TPrimeiraTela e coloque um botão lá e vamos usar o sistema de Links do Router4D para chamar a TSegundaTela sem precisar dar uses nela.
234 |
235 | Basta chamar o método abaixo no Evento de Clique do Botão.
236 |
237 | ```delphi
238 | procedure TPrimeiraTela.Button1Click(Sender: TObject);
239 | begin
240 | TRouter4D.Link.&To('Tela2');
241 | end;
242 | ```
243 |
244 | Perceba que a TPrimeiraTela não conhece a TSegundaTela pois o uses da mesma foi dado apenas no formPrincipal onde é necessário para o Registro das Rotas.
245 |
246 | Se você deseja deixar isso mais organizado, eu sugiro inclusive que você crie uma Unit separada apenas para registro das Rotas com um class procedure e faça a chamada desse método no onCreate do formPrincipal.
247 |
248 | Dessa forma damos fim a um monte de referencias cruzadas e acoplamento entre as telas.
249 |
250 |
251 | ## RECURSOS - RENDER
252 |
253 | ```delphi
254 | TRouter4D.Render.SetElement(MainContainer, IndexContainer);
255 | ```
256 |
257 | O Render é a primeira ação a ser feita para trabalhar com o Router4D, pois nele você irá configurar os container main e index.
258 |
259 | MainContainer = O container onde os formularios serão embedados
260 |
261 | IndexContainer = O container principal da aplicação (util quando você tem mais de um tipo de layout na aplicação)
262 |
263 | ## SWITCH
264 |
265 | ```delphi
266 | TRouter4D.Switch.Router(aPath : String; aRouter : TPersistentClass);
267 | ```
268 | No Switch você registra suas rotas, passando o nome da rota e o objeto que seja aberto quando essa rota for acionada.
269 |
270 | ```delphi
271 | TRouter4D.Switch.Router(aPath : String; aRouter : TPersistentClass; aSidebarKey : String = 'SBIndex'; isVisible : Boolean = True);
272 | ```
273 |
274 | No Swith existem alguns parametros a mais que já possuem valores default
275 |
276 | aSidebarKey: Este parametro permite você separar as rotas por categoria para a criação de menus dinâmicos com a classe SideBar, vou explicar mais abaixo sobre ela.
277 |
278 | isVisible: Permite você ocultar a rota na geração dinamica dos menus com a SideBar.
279 |
280 | ## LINK
281 |
282 | ```delphi
283 |
284 | TRouter4D.Link.&To ( aPatch : String; aComponent : TFMXObject );
285 |
286 | TRouter4D.Link.&To ( aPatch : String);
287 |
288 | TRouter4D.Link.&To ( aPatch : String; aProps : TProps; aKey : String = '');
289 |
290 | ```
291 |
292 | Os links são as ações para acionar as rotas que você registrou no Switch
293 |
294 | Existem 3 formas de chamar os links:
295 |
296 | ```delphi
297 | TRouter4D.Link.&To ( aPatch : String);
298 | ```
299 | Passando apenas o Path da Rota, dessa forma o formulario associado a rota será embedado dentro do MainContainer que você definiu no Render
300 |
301 | ```delphi
302 | TRouter4D.Link.&To ( aPatch : String; aComponent : TFMXObject );
303 | ```
304 |
305 | Passando o Path e o Component, ele irá embedar o formulario registrado no path dentro do componente que você está passando no parametro.
306 |
307 | ```delphi
308 | TRouter4D.Link.&To ( aPatch : String; aProps : TProps; aKey : String = '');
309 | ```
310 |
311 | Você pode acionar uma rota passando Props, que são valores que o seu formulário irá receber no momento do Render, vou explicar mais abaixo como isso funciona em detalhes, mas isso é util por exemplo quando você deseja enviar um ID para uma tela realizar uma consulta no banco e ser carregada com os dados.
312 |
313 | ## PROPS
314 |
315 | ```delphi
316 | TRouter4D.Link.&To ( aPatch : String; aProps : TProps; aKey : String = '');
317 | ```
318 |
319 | A Biblioteca Router4D incopora o Delphi Event Bus para realizar ações de Pub e Sub, com isso você pode registrar seus formularios para receber eventos na chamada dos links.
320 |
321 | Para receber uma Props você precisa adicionar a uses Router4D.Props no seu formulario e implementar o seguinte método com o atributo [Subscribe]
322 |
323 | ```delphi
324 | [Subscribe]
325 | procedure Props ( aValue : TProps);
326 | ```
327 |
328 | e implementa-lo
329 |
330 | ```delphi
331 | procedure TPageCadastros.Props(aValue: TProps);
332 | begin
333 | if aValue.Key = 'telacadastro' then
334 | Label1.Text := aValue.PropString;
335 | aValue.Free;
336 | end;
337 | ```
338 | Dessa forma seu formulario está preparado por exemplo para receber uma string passada na chamada do link.
339 |
340 | Para chamar um link passando um Props você utiliza o seguinte código:
341 |
342 | ```delphi
343 | TRouter4D.Link.&To('Cadastros', TProps.Create.PropString('Olá').Key('telacadastro'));
344 | ```
345 | Passando no Link o objeto TProps com uma PropString e uma Chave para que a tela que vai receber tenha certeza que aquela props foi enviada para ela.
346 |
347 | ## SideBar
348 |
349 | Com as rotas registradas você pode criar um menu automático das rotas registradas de forma dinâmica, basta registrar uma nova rota que a mesma estará disponível em todos os seus menus.
350 |
351 | ```delphi
352 | TRouter4D
353 | .SideBar
354 | .MainContainer(Layout5)
355 | .LinkContainer(Layout4)
356 | .FontSize(15)
357 | .FontColor(4294967295)
358 | .ItemHeigth(60)
359 | .RenderToListBox;
360 | ```
361 |
362 | No exemplo acima estamos gerando um menu em formato de listbox dentro do Layout5 e todos os links clicados nesse menu serão renderizados no Layout4, se você não passar o LinkContainer o mesmo será renderizado no MainContainer informado no Render do Router4D.
363 |
364 | Você ainda pode criar menus baseados em rotas categorizadas, basta no registro da rota você informar a categoria que a rota pertence
365 |
366 | ```delphi
367 | TRouter4D.Switch.Router('Clientes', TPagePrincipal, 'cadastros');
368 | TRouter4D.Switch.Router('Fornecedores', TSubCadastros, 'cadastros');
369 | TRouter4D.Switch.Router('Produtos', TSubCadastros, 'cadastros');
370 | ```
371 |
372 | Dessa forma criamos 3 rotas da categoria cadastro, para gerar um menu apenas com esses link basta informar isso na construção da SideBar.
373 |
374 | ```delphi
375 | TRouter4D
376 | .SideBar
377 | .Name('cadastros')
378 | .MainContainer(Layout5)
379 | .LinkContainer(Layout4)
380 | .FontSize(15)
381 | .FontColor(4294967295)
382 | .ItemHeigth(60)
383 | .RenderToListBox;
384 | ```
385 | ## Documentação
386 | [English (en)](https://github.com/academiadocodigo/Router4Delphi/blob/master/README-en.md)
387 | [Português (ptBR)](https://github.com/academiadocodigo/Router4Delphi/blob/master/README.md)
388 |
--------------------------------------------------------------------------------
/Router4Delphi.dpk:
--------------------------------------------------------------------------------
1 | package Router4Delphi;
2 |
3 | {$R *.res}
4 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users}
5 | {$ALIGN 8}
6 | {$ASSERTIONS ON}
7 | {$BOOLEVAL OFF}
8 | {$DEBUGINFO OFF}
9 | {$EXTENDEDSYNTAX ON}
10 | {$IMPORTEDDATA ON}
11 | {$IOCHECKS ON}
12 | {$LOCALSYMBOLS ON}
13 | {$LONGSTRINGS ON}
14 | {$OPENSTRINGS ON}
15 | {$OPTIMIZATION OFF}
16 | {$OVERFLOWCHECKS OFF}
17 | {$RANGECHECKS OFF}
18 | {$REFERENCEINFO ON}
19 | {$SAFEDIVIDE OFF}
20 | {$STACKFRAMES ON}
21 | {$TYPEDADDRESS OFF}
22 | {$VARSTRINGCHECKS ON}
23 | {$WRITEABLECONST OFF}
24 | {$MINENUMSIZE 1}
25 | {$IMAGEBASE $400000}
26 | {$DEFINE DEBUG}
27 | {$ENDIF IMPLICITBUILDING}
28 | {$IMPLICITBUILD ON}
29 |
30 | requires
31 | rtl,
32 | xmlrtl,
33 | fmx,
34 | soaprtl,
35 | dbrtl,
36 | DbxCommonDriver,
37 | FireDAC,
38 | FireDACCommonDriver,
39 | FireDACCommon,
40 | vcl;
41 |
42 | contains
43 | DuckListU in 'src\DuckListU.pas',
44 | EventBus.Core in 'src\EventBus.Core.pas',
45 | EventBus.Subscribers in 'src\EventBus.Subscribers.pas',
46 | ObjectsMappers in 'src\ObjectsMappers.pas',
47 | Router4D.History in 'src\Router4D.History.pas',
48 | Router4D.Interfaces in 'src\Router4D.Interfaces.pas',
49 | Router4D.Link in 'src\Router4D.Link.pas',
50 | Router4D in 'src\Router4D.pas',
51 | Router4D.Props in 'src\Router4D.Props.pas',
52 | Router4D.Render in 'src\Router4D.Render.pas',
53 | Router4D.Switch in 'src\Router4D.Switch.pas',
54 | Router4D.Utils in 'src\Router4D.Utils.pas',
55 | RTTIUtilsU in 'src\RTTIUtilsU.pas',
56 | Router4D.Helper in 'src\Router4D.Helper.pas',
57 | Router4D.Sidebar in 'src\Router4D.Sidebar.pas';
58 |
59 | end.
60 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Router4DelphiDemo.View.Principal.fmx:
--------------------------------------------------------------------------------
1 | object Form2: TForm2
2 | Left = 0
3 | Top = 0
4 | Caption = 'Form2'
5 | ClientHeight = 537
6 | ClientWidth = 921
7 | FormFactor.Width = 320
8 | FormFactor.Height = 480
9 | FormFactor.Devices = [Desktop]
10 | DesignerMasterStyle = 0
11 | end
12 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Router4DelphiDemo.View.Principal.pas:
--------------------------------------------------------------------------------
1 | unit Router4DelphiDemo.View.Principal;
2 |
3 | interface
4 |
5 | uses
6 | System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
7 | FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs;
8 |
9 | type
10 | TForm2 = class(TForm)
11 | private
12 | { Private declarations }
13 | public
14 | { Public declarations }
15 | end;
16 |
17 | var
18 | Form2: TForm2;
19 |
20 | implementation
21 |
22 | {$R *.fmx}
23 |
24 | end.
25 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Router4DelphiDemo.dpr:
--------------------------------------------------------------------------------
1 | program Router4DelphiDemo;
2 |
3 | uses
4 | System.StartUpCopy,
5 | FMX.Forms,
6 | Router4DelphiDemo.View.Principal in 'Views\Router4DelphiDemo.View.Principal.pas' {ViewPrincipal},
7 | Router4DelphiDemo.Views.Layouts.Main in 'Views\Layouts\Router4DelphiDemo.Views.Layouts.Main.pas' {MainLayout},
8 | Router4DelphiDemo.View.Components.Sidebar in 'Views\Components\Router4DelphiDemo.View.Components.Sidebar.pas' {ComponentSideBar},
9 | Router4DelphiDemo.View.Router in 'Views\Routers\Router4DelphiDemo.View.Router.pas',
10 | Router4DelphiDemo.View.Pages.Index in 'Views\Pages\Router4DelphiDemo.View.Pages.Index.pas' {PageIndex},
11 | Router4DelphiDemo.View.Pages.Cadastros in 'Views\Pages\Router4DelphiDemo.View.Pages.Cadastros.pas' {PageCadastros};
12 |
13 | {$R *.res}
14 |
15 | begin
16 | Application.Initialize;
17 | Application.CreateForm(TViewPrincipal, ViewPrincipal);
18 | Application.Run;
19 | end.
20 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Router4DelphiDemo.res:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/academiadocodigo/Router4Delphi/eedd012e4b68cbda69067f9baf3f9ccfb628abc6/Samples/FMX/Demo/Router4DelphiDemo.res
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Views/Components/Router4DelphiDemo.View.Components.Sidebar.fmx:
--------------------------------------------------------------------------------
1 | object ComponentSideBar: TComponentSideBar
2 | Left = 0
3 | Top = 0
4 | Caption = 'Form4'
5 | ClientHeight = 480
6 | ClientWidth = 640
7 | FormFactor.Width = 320
8 | FormFactor.Height = 480
9 | FormFactor.Devices = [Desktop]
10 | DesignerMasterStyle = 0
11 | object Layout1: TLayout
12 | Align = Client
13 | Size.Width = 640.000000000000000000
14 | Size.Height = 480.000000000000000000
15 | Size.PlatformDefault = False
16 | object Rectangle1: TRectangle
17 | Align = Contents
18 | Fill.Color = xFF36414A
19 | Size.Width = 640.000000000000000000
20 | Size.Height = 480.000000000000000000
21 | Size.PlatformDefault = False
22 | Stroke.Kind = None
23 | end
24 | object ListBox1: TListBox
25 | Align = Client
26 | Size.Width = 640.000000000000000000
27 | Size.Height = 480.000000000000000000
28 | Size.PlatformDefault = False
29 | StyleLookup = 'transparentlistboxstyle'
30 | OnClick = ListBox1Click
31 | DisableFocusEffect = True
32 | ItemHeight = 60.000000000000000000
33 | DefaultItemStyles.ItemStyle = ''
34 | DefaultItemStyles.GroupHeaderStyle = ''
35 | DefaultItemStyles.GroupFooterStyle = ''
36 | Viewport.Width = 640.000000000000000000
37 | Viewport.Height = 480.000000000000000000
38 | object ListBoxItem1: TListBoxItem
39 | TextSettings.Font.Size = 15.000000000000000000
40 | TextSettings.FontColor = claWhite
41 | StyledSettings = [Family, Style, Other]
42 | Padding.Left = 15.000000000000000000
43 | Size.Width = 640.000000000000000000
44 | Size.Height = 60.000000000000000000
45 | Size.PlatformDefault = False
46 | Text = 'Home'
47 | end
48 | object ListBoxItem2: TListBoxItem
49 | TextSettings.Font.Size = 15.000000000000000000
50 | TextSettings.FontColor = claWhite
51 | StyledSettings = [Family, Style, Other]
52 | Position.Y = 60.000000000000000000
53 | Size.Width = 640.000000000000000000
54 | Size.Height = 60.000000000000000000
55 | Size.PlatformDefault = False
56 | Text = 'Cadastros'
57 | end
58 | end
59 | end
60 | end
61 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Views/Components/Router4DelphiDemo.View.Components.Sidebar.pas:
--------------------------------------------------------------------------------
1 | unit Router4DelphiDemo.View.Components.Sidebar;
2 |
3 | interface
4 |
5 | uses
6 | System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
7 | FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Layouts,
8 | FMX.ListBox, FMX.Controls.Presentation, FMX.StdCtrls, FMX.Objects;
9 |
10 | type
11 | TComponentSideBar = class(TForm)
12 | Layout1: TLayout;
13 | ListBox1: TListBox;
14 | ListBoxItem1: TListBoxItem;
15 | ListBoxItem2: TListBoxItem;
16 | Rectangle1: TRectangle;
17 | procedure ListBox1Click(Sender: TObject);
18 | private
19 | { Private declarations }
20 | public
21 | { Public declarations }
22 | end;
23 |
24 | var
25 | ComponentSideBar: TComponentSideBar;
26 |
27 | implementation
28 |
29 | uses
30 | Router4D;
31 |
32 | {$R *.fmx}
33 |
34 | procedure TComponentSideBar.ListBox1Click(Sender: TObject);
35 | begin
36 | TRouter4D.Link.&To(ListBox1.Items[ListBox1.ItemIndex])
37 | end;
38 |
39 | end.
40 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Views/Layouts/Router4DelphiDemo.Views.Layouts.Main.fmx:
--------------------------------------------------------------------------------
1 | object MainLayout: TMainLayout
2 | Left = 0
3 | Top = 0
4 | Caption = 'Form3'
5 | ClientHeight = 577
6 | ClientWidth = 860
7 | FormFactor.Width = 320
8 | FormFactor.Height = 480
9 | FormFactor.Devices = [Desktop]
10 | DesignerMasterStyle = 0
11 | object LayoutIndex: TLayout
12 | Align = Contents
13 | Size.Width = 860.000000000000000000
14 | Size.Height = 577.000000000000000000
15 | Size.PlatformDefault = False
16 | object Layout1: TLayout
17 | Align = Top
18 | Size.Width = 860.000000000000000000
19 | Size.Height = 65.000000000000000000
20 | Size.PlatformDefault = False
21 | object Rectangle1: TRectangle
22 | Align = Contents
23 | Fill.Color = xFF2D2F32
24 | Size.Width = 860.000000000000000000
25 | Size.Height = 65.000000000000000000
26 | Size.PlatformDefault = False
27 | Stroke.Kind = None
28 | end
29 | object Label1: TLabel
30 | Align = Left
31 | StyledSettings = [Family, Style]
32 | Margins.Left = 15.000000000000000000
33 | Position.X = 15.000000000000000000
34 | Size.Width = 554.000000000000000000
35 | Size.Height = 65.000000000000000000
36 | Size.PlatformDefault = False
37 | TextSettings.Font.Size = 25.000000000000000000
38 | TextSettings.FontColor = claWhite
39 | Text = 'Layout Principal'
40 | end
41 | end
42 | object Layout2: TLayout
43 | Align = Left
44 | Position.Y = 65.000000000000000000
45 | Size.Width = 225.000000000000000000
46 | Size.Height = 512.000000000000000000
47 | Size.PlatformDefault = False
48 | end
49 | object Layout3: TLayout
50 | Align = Client
51 | Size.Width = 635.000000000000000000
52 | Size.Height = 512.000000000000000000
53 | Size.PlatformDefault = False
54 | end
55 | end
56 | end
57 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Views/Layouts/Router4DelphiDemo.Views.Layouts.Main.pas:
--------------------------------------------------------------------------------
1 | unit Router4DelphiDemo.Views.Layouts.Main;
2 |
3 | interface
4 |
5 | uses
6 | System.SysUtils,
7 | System.Types,
8 | System.UITypes,
9 | System.Classes,
10 | System.Variants,
11 | FMX.Types,
12 | FMX.Controls,
13 | FMX.Forms,
14 | FMX.Graphics,
15 | FMX.Dialogs,
16 | FMX.Layouts,
17 | FMX.Controls.Presentation,
18 | FMX.StdCtrls,
19 | Router4D.Interfaces, FMX.Objects;
20 |
21 | type
22 | TMainLayout = class(TForm, iRouter4DComponent)
23 | Layout1: TLayout;
24 | Layout2: TLayout;
25 | Layout3: TLayout;
26 | Label1: TLabel;
27 | LayoutIndex: TLayout;
28 | Rectangle1: TRectangle;
29 | private
30 | { Private declarations }
31 | public
32 | { Public declarations }
33 | function Render : TFMXObject;
34 | procedure UnRender;
35 | end;
36 |
37 | var
38 | MainLayout: TMainLayout;
39 |
40 | implementation
41 |
42 | uses
43 | Router4DelphiDemo.View.Pages.Index,
44 | Router4D,
45 | Router4DelphiDemo.View.Components.Sidebar;
46 |
47 | {$R *.fmx}
48 |
49 | { TMainLayout }
50 |
51 | function TMainLayout.Render: TFMXObject;
52 | begin
53 | Result := LayoutIndex;
54 | TRouter4D.Render.SetElement(Layout3);
55 |
56 | Layout2.RemoveObject(0);
57 | Layout2.AddObject(
58 | TComponentSideBar.Create(Self).Layout1
59 | )
60 | end;
61 |
62 | procedure TMainLayout.UnRender;
63 | begin
64 |
65 | end;
66 |
67 | end.
68 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Views/Pages/Router4DelphiDemo.View.Pages.Cadastros.fmx:
--------------------------------------------------------------------------------
1 | object PageCadastros: TPageCadastros
2 | Left = 0
3 | Top = 0
4 | Caption = 'Form2'
5 | ClientHeight = 480
6 | ClientWidth = 640
7 | FormFactor.Width = 320
8 | FormFactor.Height = 480
9 | FormFactor.Devices = [Desktop]
10 | DesignerMasterStyle = 0
11 | object Layout1: TLayout
12 | Align = Client
13 | Size.Width = 640.000000000000000000
14 | Size.Height = 480.000000000000000000
15 | Size.PlatformDefault = False
16 | object Label1: TLabel
17 | Align = Client
18 | StyledSettings = [Family, Style, FontColor]
19 | Size.Width = 640.000000000000000000
20 | Size.Height = 480.000000000000000000
21 | Size.PlatformDefault = False
22 | TextSettings.Font.Size = 30.000000000000000000
23 | TextSettings.HorzAlign = Center
24 | Text = 'Cadastros'
25 | end
26 | end
27 | end
28 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Views/Pages/Router4DelphiDemo.View.Pages.Cadastros.pas:
--------------------------------------------------------------------------------
1 | unit Router4DelphiDemo.View.Pages.Cadastros;
2 |
3 | interface
4 |
5 | uses
6 | System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
7 | FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
8 | FMX.Controls.Presentation, FMX.StdCtrls, FMX.Layouts,
9 | Router4D.Interfaces;
10 |
11 | type
12 | TPageCadastros = class(TForm, iRouter4DComponent)
13 | Layout1: TLayout;
14 | Label1: TLabel;
15 | private
16 | { Private declarations }
17 | public
18 | { Public declarations }
19 | function Render : TFMXObject;
20 | procedure UnRender;
21 | end;
22 |
23 | var
24 | PageCadastros: TPageCadastros;
25 |
26 | implementation
27 |
28 | {$R *.fmx}
29 |
30 | { TForm2 }
31 |
32 | function TPageCadastros.Render: TFMXObject;
33 | begin
34 | Result := Layout1;
35 | end;
36 |
37 | procedure TPageCadastros.UnRender;
38 | begin
39 |
40 | end;
41 |
42 | end.
43 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Views/Pages/Router4DelphiDemo.View.Pages.Index.fmx:
--------------------------------------------------------------------------------
1 | object PageIndex: TPageIndex
2 | Left = 0
3 | Top = 0
4 | Caption = 'Form5'
5 | ClientHeight = 609
6 | ClientWidth = 940
7 | FormFactor.Width = 320
8 | FormFactor.Height = 480
9 | FormFactor.Devices = [Desktop]
10 | DesignerMasterStyle = 0
11 | object Layout1: TLayout
12 | Align = Contents
13 | Size.Width = 940.000000000000000000
14 | Size.Height = 609.000000000000000000
15 | Size.PlatformDefault = False
16 | object Label1: TLabel
17 | Align = Client
18 | StyledSettings = [Family, Style, FontColor]
19 | Size.Width = 940.000000000000000000
20 | Size.Height = 609.000000000000000000
21 | Size.PlatformDefault = False
22 | TextSettings.Font.Size = 30.000000000000000000
23 | TextSettings.HorzAlign = Center
24 | Text = 'Home'
25 | end
26 | object Button1: TButton
27 | Position.X = 424.000000000000000000
28 | Position.Y = 408.000000000000000000
29 | TabOrder = 0
30 | Text = 'Button1'
31 | end
32 | end
33 | end
34 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Views/Pages/Router4DelphiDemo.View.Pages.Index.pas:
--------------------------------------------------------------------------------
1 | unit Router4DelphiDemo.View.Pages.Index;
2 |
3 | interface
4 |
5 | uses
6 | System.SysUtils,
7 | System.Types,
8 | System.UITypes,
9 | System.Classes,
10 | System.Variants,
11 | FMX.Types,
12 | FMX.Controls,
13 | FMX.Forms,
14 | FMX.Graphics,
15 | FMX.Dialogs,
16 | FMX.Layouts,
17 | Router4D.Interfaces, FMX.Controls.Presentation, FMX.StdCtrls;
18 |
19 | type
20 | TPageIndex = class(TForm, iRouter4DComponent)
21 | Layout1: TLayout;
22 | Label1: TLabel;
23 | Button1: TButton;
24 | private
25 | { Private declarations }
26 | public
27 | { Public declarations }
28 | function Render : TFMXObject;
29 | procedure UnRender;
30 | end;
31 |
32 | var
33 | PageIndex: TPageIndex;
34 |
35 | implementation
36 |
37 | uses
38 | Router4D,
39 | Router4D.History,
40 | Router4DelphiDemo.Views.Layouts.Main;
41 |
42 | {$R *.fmx}
43 |
44 | function TPageIndex.Render: TFMXObject;
45 | begin
46 | Result := Layout1;
47 | //TRouter4D.Render.GetElement(Layout1);
48 | end;
49 |
50 | procedure TPageIndex.UnRender;
51 | begin
52 |
53 | end;
54 |
55 | end.
56 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Views/Router4DelphiDemo.View.Principal.fmx:
--------------------------------------------------------------------------------
1 | object ViewPrincipal: TViewPrincipal
2 | Left = 0
3 | Top = 0
4 | Caption = 'Form2'
5 | ClientHeight = 612
6 | ClientWidth = 925
7 | FormFactor.Width = 320
8 | FormFactor.Height = 480
9 | FormFactor.Devices = [Desktop]
10 | OnCreate = FormCreate
11 | DesignerMasterStyle = 0
12 | object Layout1: TLayout
13 | Align = Contents
14 | Size.Width = 925.000000000000000000
15 | Size.Height = 612.000000000000000000
16 | Size.PlatformDefault = False
17 | end
18 | end
19 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Views/Router4DelphiDemo.View.Principal.pas:
--------------------------------------------------------------------------------
1 | unit Router4DelphiDemo.View.Principal;
2 |
3 | interface
4 |
5 | uses
6 | System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
7 | FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Layouts;
8 |
9 | type
10 | TViewPrincipal = class(TForm)
11 | Layout1: TLayout;
12 | procedure FormCreate(Sender: TObject);
13 | private
14 | { Private declarations }
15 | public
16 | { Public declarations }
17 | procedure Animation( aLayout : TFMXObject );
18 | end;
19 |
20 | var
21 | ViewPrincipal: TViewPrincipal;
22 |
23 | implementation
24 |
25 | uses
26 | Router4D,
27 | Router4DelphiDemo.Views.Layouts.Main,
28 | Router4DelphiDemo.View.Router;
29 |
30 | {$R *.fmx}
31 |
32 | procedure TViewPrincipal.Animation(aLayout: TFMXObject);
33 | begin
34 | TLayout(aLayout).Opacity := 0;
35 | TLayout(aLayout).AnimateFloat('Opacity', 1, 0.9);
36 | end;
37 |
38 | procedure TViewPrincipal.FormCreate(Sender: TObject);
39 | begin
40 | TRouter4D.Render.SetElement(Layout1, Layout1);
41 | TRouter4D.Link.Animation(Animation);
42 | end;
43 |
44 | end.
45 |
--------------------------------------------------------------------------------
/Samples/FMX/Demo/Views/Routers/Router4DelphiDemo.View.Router.pas:
--------------------------------------------------------------------------------
1 | unit Router4DelphiDemo.View.Router;
2 |
3 | interface
4 |
5 | type
6 | TRouters = class
7 | private
8 | public
9 | constructor Create;
10 | destructor Destroy; override;
11 | end;
12 |
13 | var
14 | Routers : TRouters;
15 |
16 | implementation
17 |
18 | uses
19 | Router4D,
20 | Router4DelphiDemo.View.Pages.Index,
21 | Router4DelphiDemo.Views.Layouts.Main,
22 | Router4DelphiDemo.View.Pages.Cadastros;
23 |
24 | { TRouters }
25 |
26 | constructor TRouters.Create;
27 | begin
28 | TRouter4D.Switch.Router('Home', TPageIndex);
29 | TRouter4D.Switch.Router('Cadastros', TPageCadastros);
30 | TRouter4D.Switch.Router('main', TMainLayout);
31 | end;
32 |
33 | destructor TRouters.Destroy;
34 | begin
35 |
36 | inherited;
37 | end;
38 |
39 | initialization
40 | Routers := TRouters.Create;
41 |
42 | finalization
43 | Routers.Free;
44 |
45 | end.
46 |
--------------------------------------------------------------------------------
/Samples/FMX/SimpleDemo/SimpleDemo.View.Components.Button01.fmx:
--------------------------------------------------------------------------------
1 | object ComponentButton01: TComponentButton01
2 | Left = 0
3 | Top = 0
4 | Caption = 'Form1'
5 | ClientHeight = 480
6 | ClientWidth = 640
7 | FormFactor.Width = 320
8 | FormFactor.Height = 480
9 | FormFactor.Devices = [Desktop]
10 | OnCreate = FormCreate
11 | DesignerMasterStyle = 0
12 | object Layout1: TLayout
13 | Position.X = 232.000000000000000000
14 | Position.Y = 120.000000000000000000
15 | Size.Width = 121.000000000000000000
16 | Size.Height = 81.000000000000000000
17 | Size.PlatformDefault = False
18 | object Line1: TLine
19 | Align = Bottom
20 | LineType = Bottom
21 | Position.Y = 80.000000000000000000
22 | Size.Width = 121.000000000000000000
23 | Size.Height = 1.000000000000000000
24 | Size.PlatformDefault = False
25 | Stroke.Thickness = 5.000000000000000000
26 | end
27 | object Label1: TLabel
28 | Align = Contents
29 | StyledSettings = [Family, Style, FontColor]
30 | Size.Width = 121.000000000000000000
31 | Size.Height = 81.000000000000000000
32 | Size.PlatformDefault = False
33 | TextSettings.Font.Size = 20.000000000000000000
34 | TextSettings.HorzAlign = Center
35 | Text = 'Button'
36 | end
37 | object SpeedButton1: TSpeedButton
38 | Align = Contents
39 | Opacity = 0.000000000000000000
40 | Size.Width = 121.000000000000000000
41 | Size.Height = 81.000000000000000000
42 | Size.PlatformDefault = False
43 | Text = 'SpeedButton1'
44 | OnClick = SpeedButton1Click
45 | end
46 | end
47 | end
48 |
--------------------------------------------------------------------------------
/Samples/FMX/SimpleDemo/SimpleDemo.View.Components.Button01.pas:
--------------------------------------------------------------------------------
1 | unit SimpleDemo.View.Components.Button01;
2 |
3 | interface
4 |
5 | uses
6 | System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
7 | FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
8 | FMX.Controls.Presentation, FMX.StdCtrls, FMX.Objects, FMX.Layouts,
9 | Router4D.Interfaces,
10 | Router4D.Props;
11 |
12 | type
13 | TComponentButton01 = class(TForm, iRouter4DComponent)
14 | Layout1: TLayout;
15 | Line1: TLine;
16 | Label1: TLabel;
17 | SpeedButton1: TSpeedButton;
18 | procedure FormCreate(Sender: TObject);
19 | procedure SpeedButton1Click(Sender: TObject);
20 | private
21 | { Private declarations }
22 | public
23 | { Public declarations }
24 | function Render : TFMXObject;
25 | procedure UnRender;
26 | [Subscribe]
27 | procedure Props ( aValue : TProps);
28 | function createButton(aLabel : String) : TFMXObject;
29 | end;
30 |
31 | var
32 | ComponentButton01: TComponentButton01;
33 |
34 | implementation
35 |
36 | {$R *.fmx}
37 |
38 | { TComponentButton01 }
39 |
40 | function TComponentButton01.createButton(aLabel: String): TFMXObject;
41 | begin
42 | Result := Layout1;
43 | Label1.Text := aLabel;
44 | Layout1.Align := TAlignLayout.Left;
45 | Line1.Visible := False;
46 | Self.TagString := aLabel;
47 | end;
48 |
49 | procedure TComponentButton01.FormCreate(Sender: TObject);
50 | begin
51 | GlobalEventBus.RegisterSubscriber(Self);
52 | end;
53 |
54 | procedure TComponentButton01.Props(aValue: TProps);
55 | begin
56 | Line1.Visible := False;
57 |
58 | if (aValue.PropString = Label1.Text) and
59 | (aValue.Key = 'Button01') then
60 | Line1.Visible := True;
61 |
62 | aValue.Free;
63 | end;
64 |
65 | function TComponentButton01.Render: TFMXObject;
66 | begin
67 | Result := Layout1;
68 | end;
69 |
70 | procedure TComponentButton01.SpeedButton1Click(Sender: TObject);
71 | begin
72 | Line1.Visible := True;
73 | GlobalEventBus.Post(
74 | TProps.Create
75 | .PropString(Label1.Text)
76 | .Key('Button01')
77 | );
78 | end;
79 |
80 | procedure TComponentButton01.UnRender;
81 | begin
82 | //
83 | end;
84 |
85 | end.
86 |
--------------------------------------------------------------------------------
/Samples/FMX/SimpleDemo/SimpleDemo.View.Page.Cadastros.Sub.fmx:
--------------------------------------------------------------------------------
1 | object SubCadastros: TSubCadastros
2 | Left = 0
3 | Top = 0
4 | Caption = 'Form1'
5 | ClientHeight = 480
6 | ClientWidth = 640
7 | FormFactor.Width = 320
8 | FormFactor.Height = 480
9 | FormFactor.Devices = [Desktop]
10 | DesignerMasterStyle = 0
11 | object Layout1: TLayout
12 | Align = Client
13 | Size.Width = 640.000000000000000000
14 | Size.Height = 480.000000000000000000
15 | Size.PlatformDefault = False
16 | object Label1: TLabel
17 | Align = Contents
18 | StyledSettings = [Family, Style, FontColor]
19 | Size.Width = 640.000000000000000000
20 | Size.Height = 480.000000000000000000
21 | Size.PlatformDefault = False
22 | TextSettings.Font.Size = 30.000000000000000000
23 | TextSettings.HorzAlign = Center
24 | Text = 'Sub-Cadastros'
25 | end
26 | end
27 | end
28 |
--------------------------------------------------------------------------------
/Samples/FMX/SimpleDemo/SimpleDemo.View.Page.Cadastros.Sub.pas:
--------------------------------------------------------------------------------
1 | unit SimpleDemo.View.Page.Cadastros.Sub;
2 |
3 | interface
4 |
5 | uses
6 | System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
7 | FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
8 | FMX.Controls.Presentation, FMX.StdCtrls, FMX.Layouts,
9 | Router4D.Interfaces;
10 |
11 | type
12 | TSubCadastros = class(TForm, iRouter4DComponent)
13 | Layout1: TLayout;
14 | Label1: TLabel;
15 | private
16 | { Private declarations }
17 | public
18 | { Public declarations }
19 | function Render : TFMXObject;
20 | procedure UnRender;
21 | end;
22 |
23 | var
24 | SubCadastros: TSubCadastros;
25 |
26 | implementation
27 |
28 | uses
29 | Router4D.History;
30 |
31 | {$R *.fmx}
32 |
33 | { TSubCadastros }
34 |
35 | function TSubCadastros.Render: TFMXObject;
36 | begin
37 | Result := Layout1;
38 | end;
39 |
40 | procedure TSubCadastros.UnRender;
41 | begin
42 | //
43 | end;
44 |
45 | end.
46 |
--------------------------------------------------------------------------------
/Samples/FMX/SimpleDemo/SimpleDemo.View.Page.Cadastros.fmx:
--------------------------------------------------------------------------------
1 | object PageCadastros: TPageCadastros
2 | Left = 0
3 | Top = 0
4 | Caption = 'Form3'
5 | ClientHeight = 480
6 | ClientWidth = 640
7 | FormFactor.Width = 320
8 | FormFactor.Height = 480
9 | FormFactor.Devices = [Desktop]
10 | OnCreate = FormCreate
11 | DesignerMasterStyle = 0
12 | object Layout1: TLayout
13 | Align = Client
14 | Size.Width = 640.000000000000000000
15 | Size.Height = 480.000000000000000000
16 | Size.PlatformDefault = False
17 | object Layout2: TLayout
18 | Align = Left
19 | Size.Width = 177.000000000000000000
20 | Size.Height = 480.000000000000000000
21 | Size.PlatformDefault = False
22 | Visible = False
23 | object Rectangle1: TRectangle
24 | Align = Contents
25 | Fill.Color = xFF36414A
26 | Size.Width = 177.000000000000000000
27 | Size.Height = 480.000000000000000000
28 | Size.PlatformDefault = False
29 | Stroke.Kind = None
30 | end
31 | end
32 | object Layout3: TLayout
33 | Align = Client
34 | Size.Width = 640.000000000000000000
35 | Size.Height = 399.000000000000000000
36 | Size.PlatformDefault = False
37 | object Label1: TLabel
38 | Align = Contents
39 | StyledSettings = [Family, Style, FontColor]
40 | Size.Width = 640.000000000000000000
41 | Size.Height = 399.000000000000000000
42 | Size.PlatformDefault = False
43 | TextSettings.Font.Size = 30.000000000000000000
44 | TextSettings.HorzAlign = Center
45 | Text = 'Cadastros'
46 | end
47 | object Button1: TButton
48 | Anchors = []
49 | Position.X = 243.682922363281300000
50 | Position.Y = 215.990631103515600000
51 | Size.Width = 145.000000000000000000
52 | Size.Height = 41.000000000000000000
53 | Size.PlatformDefault = False
54 | Text = 'Voltar para Home'
55 | OnClick = Button1Click
56 | end
57 | object Edit1: TEdit
58 | Touch.InteractiveGestures = [LongTap, DoubleTap]
59 | Anchors = []
60 | Position.X = 243.682922363281300000
61 | Position.Y = 257.240631103515600000
62 | Size.Width = 145.000000000000000000
63 | Size.Height = 25.000000000000000000
64 | Size.PlatformDefault = False
65 | end
66 | end
67 | object Layout4: TLayout
68 | Align = Top
69 | Size.Width = 640.000000000000000000
70 | Size.Height = 81.000000000000000000
71 | Size.PlatformDefault = False
72 | end
73 | end
74 | end
75 |
--------------------------------------------------------------------------------
/Samples/FMX/SimpleDemo/SimpleDemo.View.Page.Cadastros.pas:
--------------------------------------------------------------------------------
1 | unit SimpleDemo.View.Page.Cadastros;
2 |
3 | interface
4 |
5 | uses
6 | System.SysUtils,
7 | System.Types,
8 | System.UITypes,
9 | System.Classes,
10 | System.Variants,
11 | FMX.Types,
12 | FMX.Controls,
13 | FMX.Forms,
14 | FMX.Graphics,
15 | FMX.Dialogs,
16 | FMX.Controls.Presentation,
17 | FMX.StdCtrls,
18 | FMX.Layouts,
19 | Router4D.Interfaces,
20 | Router4D.Props, FMX.Edit, FMX.Objects;
21 |
22 | type
23 | TPageCadastros = class(TForm, iRouter4DComponent)
24 | Layout1: TLayout;
25 | Label1: TLabel;
26 | Button1: TButton;
27 | Edit1: TEdit;
28 | Layout2: TLayout;
29 | Layout3: TLayout;
30 | Rectangle1: TRectangle;
31 | Layout4: TLayout;
32 | procedure Button1Click(Sender: TObject);
33 | procedure FormCreate(Sender: TObject);
34 | private
35 | procedure CreateMenuSuperior;
36 | procedure CreateRouters;
37 | { Private declarations }
38 | public
39 | { Public declarations }
40 | function Render : TFMXObject;
41 | procedure UnRender;
42 | [Subscribe]
43 | procedure Props ( aValue : TProps);
44 | end;
45 |
46 | var
47 | PageCadastros: TPageCadastros;
48 |
49 | implementation
50 |
51 | uses
52 | Router4D, SimpleDemo.View.Page.Cadastros.Sub, SimpleDemo.View.Page.Principal,
53 | SimpleDemo.View.Components.Button01;
54 |
55 | {$R *.fmx}
56 |
57 | { TPageCadastros }
58 |
59 | procedure TPageCadastros.Button1Click(Sender: TObject);
60 | begin
61 | TRouter4D.Link.&To('Inicio');
62 | end;
63 |
64 | procedure TPageCadastros.FormCreate(Sender: TObject);
65 | begin
66 | CreateRouters;
67 | CreateMenuSuperior;
68 | end;
69 |
70 | procedure TPageCadastros.Props(aValue: TProps);
71 | begin
72 | if (aValue.PropString <> '') and (aValue.Key = 'TelaCadastro') then
73 | Label1.Text := aValue.PropString;
74 |
75 | aValue.Free;
76 | end;
77 |
78 | procedure TPageCadastros.CreateRouters;
79 | begin
80 | TRouter4D.Switch.Router('Clientes', TPagePrincipal, 'cadastros');
81 | TRouter4D.Switch.Router('Fornecedores', TSubCadastros, 'cadastros');
82 | TRouter4D.Switch.Router('Produtos', TSubCadastros, 'cadastros');
83 | end;
84 |
85 | procedure TPageCadastros.CreateMenuSuperior;
86 | begin
87 | Layout4.AddObject(
88 | TComponentButton01.Create(Self)
89 | .createButton('Clientes')
90 | );
91 |
92 | Layout4.AddObject(
93 | TComponentButton01.Create(Self)
94 | .createButton('Produtos')
95 | );
96 |
97 | Layout4.AddObject(
98 | TComponentButton01.Create(Self)
99 | .createButton('Fornecedores')
100 | );
101 | end;
102 |
103 | function TPageCadastros.Render: TFMXObject;
104 | begin
105 | Label1.Text := 'Cadastros';
106 | Result := Layout1;
107 | end;
108 |
109 | procedure TPageCadastros.UnRender;
110 | begin
111 | //
112 | end;
113 |
114 | end.
115 |
--------------------------------------------------------------------------------
/Samples/FMX/SimpleDemo/SimpleDemo.View.Page.Principal.fmx:
--------------------------------------------------------------------------------
1 | object PagePrincipal: TPagePrincipal
2 | Left = 0
3 | Top = 0
4 | Caption = 'Form3'
5 | ClientHeight = 480
6 | ClientWidth = 640
7 | FormFactor.Width = 320
8 | FormFactor.Height = 480
9 | FormFactor.Devices = [Desktop]
10 | DesignerMasterStyle = 0
11 | object Layout1: TLayout
12 | Align = Client
13 | Size.Width = 640.000000000000000000
14 | Size.Height = 480.000000000000000000
15 | Size.PlatformDefault = False
16 | object Label1: TLabel
17 | Align = Client
18 | StyledSettings = [Family, Style, FontColor]
19 | Size.Width = 640.000000000000000000
20 | Size.Height = 480.000000000000000000
21 | Size.PlatformDefault = False
22 | TextSettings.Font.Size = 30.000000000000000000
23 | TextSettings.HorzAlign = Center
24 | Text = 'Home'
25 | end
26 | object Button1: TButton
27 | Anchors = []
28 | Position.X = 240.000000000000000000
29 | Position.Y = 264.000000000000000000
30 | Size.Width = 169.000000000000000000
31 | Size.Height = 33.000000000000000000
32 | Size.PlatformDefault = False
33 | Text = 'Cadastros Simples'
34 | OnClick = Button1Click
35 | end
36 | object Button2: TButton
37 | Anchors = []
38 | Position.X = 240.000000000000000000
39 | Position.Y = 304.000000000000000000
40 | Size.Width = 169.000000000000000000
41 | Size.Height = 33.000000000000000000
42 | Size.PlatformDefault = False
43 | Text = 'Cadastros com Props'
44 | OnClick = Button2Click
45 | end
46 | end
47 | end
48 |
--------------------------------------------------------------------------------
/Samples/FMX/SimpleDemo/SimpleDemo.View.Page.Principal.pas:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/academiadocodigo/Router4Delphi/eedd012e4b68cbda69067f9baf3f9ccfb628abc6/Samples/FMX/SimpleDemo/SimpleDemo.View.Page.Principal.pas
--------------------------------------------------------------------------------
/Samples/FMX/SimpleDemo/SimpleDemo.View.Principal.fmx:
--------------------------------------------------------------------------------
1 | object Form2: TForm2
2 | Left = 0
3 | Top = 0
4 | Caption = 'Form2'
5 | ClientHeight = 586
6 | ClientWidth = 875
7 | FormFactor.Width = 320
8 | FormFactor.Height = 480
9 | FormFactor.Devices = [Desktop]
10 | OnShow = FormShow
11 | DesignerMasterStyle = 0
12 | object Layout1: TLayout
13 | Align = Client
14 | Size.Width = 875.000000000000000000
15 | Size.Height = 586.000000000000000000
16 | Size.PlatformDefault = False
17 | object Layout2: TLayout
18 | Align = Top
19 | Size.Width = 875.000000000000000000
20 | Size.Height = 50.000000000000000000
21 | Size.PlatformDefault = False
22 | object Rectangle1: TRectangle
23 | Align = Contents
24 | Fill.Color = xFF36414A
25 | Size.Width = 875.000000000000000000
26 | Size.Height = 50.000000000000000000
27 | Size.PlatformDefault = False
28 | Stroke.Kind = None
29 | end
30 | object Label1: TLabel
31 | Align = Contents
32 | StyledSettings = [Family, Style]
33 | Margins.Right = 10.000000000000000000
34 | Size.Width = 865.000000000000000000
35 | Size.Height = 50.000000000000000000
36 | Size.PlatformDefault = False
37 | TextSettings.Font.Size = 15.000000000000000000
38 | TextSettings.FontColor = claWhite
39 | TextSettings.HorzAlign = Trailing
40 | Text = 'Router4D - SimpleDemo'
41 | end
42 | end
43 | object Layout4: TLayout
44 | Align = Client
45 | Size.Width = 705.000000000000000000
46 | Size.Height = 536.000000000000000000
47 | Size.PlatformDefault = False
48 | end
49 | object Layout3: TLayout
50 | Align = Left
51 | Position.Y = 50.000000000000000000
52 | Size.Width = 170.000000000000000000
53 | Size.Height = 536.000000000000000000
54 | Size.PlatformDefault = False
55 | object Rectangle2: TRectangle
56 | Align = Contents
57 | Fill.Color = xFF2D2F32
58 | Size.Width = 170.000000000000000000
59 | Size.Height = 536.000000000000000000
60 | Size.PlatformDefault = False
61 | Stroke.Kind = None
62 | end
63 | object Layout5: TLayout
64 | Align = Client
65 | Size.Width = 170.000000000000000000
66 | Size.Height = 536.000000000000000000
67 | Size.PlatformDefault = False
68 | end
69 | end
70 | end
71 | end
72 |
--------------------------------------------------------------------------------
/Samples/FMX/SimpleDemo/SimpleDemo.View.Principal.pas:
--------------------------------------------------------------------------------
1 | unit SimpleDemo.View.Principal;
2 |
3 | interface
4 |
5 | uses
6 | System.SysUtils,
7 | System.Types,
8 | System.UITypes,
9 | System.Classes,
10 | System.Variants,
11 | FMX.Types,
12 | FMX.Controls,
13 | FMX.Forms,
14 | FMX.Graphics,
15 | FMX.Dialogs,
16 | FMX.Controls.Presentation,
17 | FMX.StdCtrls,
18 | FMX.ListBox,
19 | FMX.Layouts,
20 | FMX.Objects, FMX.Edit, FMX.SearchBox, FMX.MultiView;
21 |
22 | type
23 | TForm2 = class(TForm)
24 | Layout1: TLayout;
25 | Layout2: TLayout;
26 | Layout3: TLayout;
27 | Layout4: TLayout;
28 | Rectangle1: TRectangle;
29 | Rectangle2: TRectangle;
30 | Label1: TLabel;
31 | Layout5: TLayout;
32 | procedure FormShow(Sender: TObject);
33 | private
34 | procedure RegisterRouters;
35 | procedure createSideBar;
36 | { Private declarations }
37 | public
38 | { Public declarations }
39 | end;
40 |
41 | var
42 | Form2: TForm2;
43 |
44 | implementation
45 |
46 | uses
47 | Router4D,
48 | SimpleDemo.View.Page.Cadastros,
49 | SimpleDemo.View.Page.Principal;
50 |
51 | {$R *.fmx}
52 |
53 | procedure TForm2.FormShow(Sender: TObject);
54 | begin
55 | RegisterRouters;
56 | TRouter4D.Render.SetElement(Layout4, Layout1);
57 | end;
58 |
59 | procedure TForm2.RegisterRouters;
60 | begin
61 | TRouter4D.Switch.Router('Inicio', TPagePrincipal);
62 | TRouter4D.Switch.Router('Cadastros', TPageCadastros);
63 | TRouter4D.Switch.Router('Configuracoes', TPageCadastros);
64 | createSideBar;
65 | end;
66 |
67 | procedure TForm2.createSideBar;
68 | begin
69 | TRouter4D
70 | .SideBar
71 | .MainContainer(Layout5)
72 | .LinkContainer(Layout4)
73 | .FontSize(15)
74 | .FontColor(4294967295)
75 | .ItemHeigth(60)
76 | .RenderToListBox;
77 | end;
78 |
79 | end.
80 |
--------------------------------------------------------------------------------
/Samples/FMX/SimpleDemo/SimpleDemo.dpr:
--------------------------------------------------------------------------------
1 | program SimpleDemo;
2 |
3 | uses
4 | System.StartUpCopy,
5 | FMX.Forms,
6 | SimpleDemo.View.Principal in 'SimpleDemo.View.Principal.pas' {Form2},
7 | SimpleDemo.View.Page.Principal in 'SimpleDemo.View.Page.Principal.pas' {PagePrincipal},
8 | SimpleDemo.View.Page.Cadastros in 'SimpleDemo.View.Page.Cadastros.pas' {PageCadastros},
9 | SimpleDemo.View.Page.Cadastros.Sub in 'SimpleDemo.View.Page.Cadastros.Sub.pas' {SubCadastros},
10 | SimpleDemo.View.Components.Button01 in 'SimpleDemo.View.Components.Button01.pas' {ComponentButton01};
11 |
12 | {$R *.res}
13 |
14 | begin
15 | ReportMemoryLeaksOnShutdown := True;
16 | Application.Initialize;
17 | Application.CreateForm(TForm2, Form2);
18 | Application.Run;
19 | end.
20 |
--------------------------------------------------------------------------------
/Samples/FMX/SimpleDemo/SimpleDemo.res:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/academiadocodigo/Router4Delphi/eedd012e4b68cbda69067f9baf3f9ccfb628abc6/Samples/FMX/SimpleDemo/SimpleDemo.res
--------------------------------------------------------------------------------
/Samples/VCL/Main.dfm:
--------------------------------------------------------------------------------
1 | object fMain: TfMain
2 | Left = 0
3 | Top = 0
4 | Caption = 'fMain'
5 | ClientHeight = 678
6 | ClientWidth = 1178
7 | Color = clBtnFace
8 | Font.Charset = DEFAULT_CHARSET
9 | Font.Color = clWindowText
10 | Font.Height = -11
11 | Font.Name = 'Tahoma'
12 | Font.Style = []
13 | OldCreateOrder = False
14 | OnCreate = FormCreate
15 | PixelsPerInch = 96
16 | TextHeight = 13
17 | object pnlBackground: TPanel
18 | Left = 0
19 | Top = 0
20 | Width = 1178
21 | Height = 678
22 | Align = alClient
23 | TabOrder = 0
24 | object pnlMain: TPanel
25 | Left = 1
26 | Top = 1
27 | Width = 192
28 | Height = 676
29 | Align = alLeft
30 | TabOrder = 0
31 | end
32 | object pnlEmbed: TPanel
33 | Left = 193
34 | Top = 1
35 | Width = 984
36 | Height = 676
37 | Align = alClient
38 | TabOrder = 1
39 | end
40 | end
41 | end
42 |
--------------------------------------------------------------------------------
/Samples/VCL/Main.pas:
--------------------------------------------------------------------------------
1 | unit Main;
2 |
3 | interface
4 |
5 | uses
6 | Winapi.Windows,
7 | Winapi.Messages,
8 | System.SysUtils,
9 | System.Variants,
10 | System.Classes,
11 | Vcl.Graphics,
12 | Vcl.Controls,
13 | Vcl.Forms,
14 | Vcl.Dialogs,
15 | Vcl.ExtCtrls,
16 | Router4D,
17 | View.Page.Main.Cadastro,
18 | Vcl.StdCtrls;
19 |
20 | type
21 | TfMain = class(TForm)
22 | pnlBackground: TPanel;
23 | pnlMain: TPanel;
24 | pnlEmbed: TPanel;
25 | procedure FormCreate(Sender: TObject);
26 | private
27 | procedure RegisterRouters;
28 | public
29 | { Public declarations }
30 | end;
31 |
32 | var
33 | fMain: TfMain;
34 |
35 | implementation
36 |
37 | {$R *.dfm}
38 |
39 | uses
40 | View.Page.Customer,
41 | View.Page.Product;
42 |
43 | procedure TfMain.FormCreate(Sender: TObject);
44 | begin
45 | RegisterRouters;
46 | TRouter4D.Render.SetElement(pnlEmbed, pnlBackground);
47 | end;
48 |
49 | procedure TfMain.RegisterRouters;
50 | begin
51 | TRouter4D.Switch.Router('Start', TfViewPageMainCadastro);
52 | TRouter4D.Switch.Router('Product', TfViewPageProduct);
53 | TRouter4D.Switch.Router('Customer', TfViewPageCustomer);
54 | end;
55 |
56 | end.
57 |
58 |
--------------------------------------------------------------------------------
/Samples/VCL/Router.dpr:
--------------------------------------------------------------------------------
1 | program Router;
2 |
3 | uses
4 | Vcl.Forms,
5 | Main in 'Main.pas' {fMain},
6 | View.Page.Main.Cadastro in 'pages\View.Page.Main.Cadastro.pas' {fViewPageMainCadastro},
7 | View.Page.Template in 'pages\View.Page.Template.pas' {fViewPageTemplate},
8 | View.Page.Product in 'pages\View.Page.Product.pas' {fViewPageProduct},
9 | View.Page.Customer in 'pages\View.Page.Customer.pas' {fViewPageCustomer};
10 |
11 | {$R *.res}
12 |
13 | begin
14 | ReportMemoryLeaksOnShutdown := True;
15 | Application.Initialize;
16 | Application.MainFormOnTaskbar := True;
17 | Application.CreateForm(TfMain, fMain);
18 | Application.Run;
19 | end.
20 |
--------------------------------------------------------------------------------
/Samples/VCL/pages/View.Page.Customer.dfm:
--------------------------------------------------------------------------------
1 | inherited fViewPageCustomer: TfViewPageCustomer
2 | Caption = 'fViewPageCustomer'
3 | PixelsPerInch = 96
4 | TextHeight = 13
5 | inherited pnlBackground: TPanel
6 | ExplicitWidth = 715
7 | ExplicitHeight = 463
8 | inherited lblTitle: TLabel
9 | Width = 242
10 | Caption = 'Cadastro de Clientes'
11 | ExplicitWidth = 242
12 | end
13 | inherited btnBack: TButton
14 | TabOrder = 1
15 | ExplicitTop = 415
16 | end
17 | object edt1: TEdit
18 | Left = 16
19 | Top = 120
20 | Width = 121
21 | Height = 21
22 | TabOrder = 0
23 | Text = 'edt1'
24 | end
25 | end
26 | end
27 |
--------------------------------------------------------------------------------
/Samples/VCL/pages/View.Page.Customer.pas:
--------------------------------------------------------------------------------
1 | unit View.Page.Customer;
2 |
3 | interface
4 |
5 | uses
6 | Winapi.Windows,
7 | Winapi.Messages,
8 | System.SysUtils,
9 | System.Variants,
10 | System.Classes,
11 | Vcl.Graphics,
12 | Vcl.Controls,
13 | Vcl.Forms,
14 | Vcl.Dialogs,
15 | View.Page.Template,
16 | Vcl.ExtCtrls,
17 | Vcl.StdCtrls;
18 |
19 | type
20 | TfViewPageCustomer = class(TfViewPageTemplate)
21 | edt1: TEdit;
22 | private
23 | { Private declarations }
24 | public
25 | { Public declarations }
26 | end;
27 |
28 | var
29 | fViewPageCustomer: TfViewPageCustomer;
30 |
31 | implementation
32 |
33 | {$R *.dfm}
34 |
35 | end.
36 |
37 |
--------------------------------------------------------------------------------
/Samples/VCL/pages/View.Page.Main.Cadastro.dfm:
--------------------------------------------------------------------------------
1 | object fViewPageMainCadastro: TfViewPageMainCadastro
2 | Left = 0
3 | Top = 0
4 | Align = alClient
5 | BorderStyle = bsNone
6 | Caption = 'fViewPageMainCadastro'
7 | ClientHeight = 484
8 | ClientWidth = 799
9 | Color = clBtnFace
10 | Font.Charset = DEFAULT_CHARSET
11 | Font.Color = clWindowText
12 | Font.Height = -11
13 | Font.Name = 'Tahoma'
14 | Font.Style = []
15 | OldCreateOrder = False
16 | PixelsPerInch = 96
17 | TextHeight = 13
18 | object pnlAll: TPanel
19 | Left = 0
20 | Top = 0
21 | Width = 799
22 | Height = 484
23 | Align = alClient
24 | TabOrder = 0
25 | object btnProduct: TButton
26 | Left = 24
27 | Top = 32
28 | Width = 153
29 | Height = 25
30 | Caption = 'Product'
31 | TabOrder = 0
32 | OnClick = btnProductClick
33 | end
34 | object btnProductProp: TButton
35 | Left = 24
36 | Top = 63
37 | Width = 153
38 | Height = 25
39 | Caption = 'Product With Prop'
40 | TabOrder = 1
41 | OnClick = btnProductPropClick
42 | end
43 | object btnCustomer: TButton
44 | Left = 24
45 | Top = 104
46 | Width = 153
47 | Height = 25
48 | Caption = 'Customer'
49 | TabOrder = 2
50 | OnClick = btnCustomerClick
51 | end
52 | object btnCustomerWithProps: TButton
53 | Left = 24
54 | Top = 135
55 | Width = 153
56 | Height = 25
57 | Caption = 'Customer With Prop'
58 | TabOrder = 3
59 | OnClick = btnCustomerWithPropsClick
60 | end
61 | end
62 | end
63 |
--------------------------------------------------------------------------------
/Samples/VCL/pages/View.Page.Main.Cadastro.pas:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/academiadocodigo/Router4Delphi/eedd012e4b68cbda69067f9baf3f9ccfb628abc6/Samples/VCL/pages/View.Page.Main.Cadastro.pas
--------------------------------------------------------------------------------
/Samples/VCL/pages/View.Page.Product.dfm:
--------------------------------------------------------------------------------
1 | inherited fViewPageProduct: TfViewPageProduct
2 | Caption = 'fViewPageProduct'
3 | PixelsPerInch = 96
4 | TextHeight = 13
5 | inherited pnlBackground: TPanel
6 | ExplicitWidth = 715
7 | ExplicitHeight = 463
8 | inherited btnBack: TButton
9 | ExplicitTop = 415
10 | end
11 | end
12 | end
13 |
--------------------------------------------------------------------------------
/Samples/VCL/pages/View.Page.Product.pas:
--------------------------------------------------------------------------------
1 | unit View.Page.Product;
2 |
3 | interface
4 |
5 | uses
6 | Winapi.Windows,
7 | Winapi.Messages,
8 | System.SysUtils,
9 | System.Variants,
10 | System.Classes,
11 | Vcl.Graphics,
12 | Vcl.Controls,
13 | Vcl.Forms,
14 | Vcl.Dialogs,
15 | View.Page.Template,
16 | Vcl.ExtCtrls,
17 | Vcl.StdCtrls;
18 |
19 | type
20 | TfViewPageProduct = class(TfViewPageTemplate)
21 | private
22 | { Private declarations }
23 | public
24 | { Public declarations }
25 | end;
26 |
27 | var
28 | fViewPageProduct: TfViewPageProduct;
29 |
30 | implementation
31 |
32 | {$R *.dfm}
33 |
34 | end.
35 |
36 |
--------------------------------------------------------------------------------
/Samples/VCL/pages/View.Page.Template.dfm:
--------------------------------------------------------------------------------
1 | object fViewPageTemplate: TfViewPageTemplate
2 | Left = 0
3 | Top = 0
4 | Align = alClient
5 | BorderStyle = bsNone
6 | Caption = 'fViewPageTemplate'
7 | ClientHeight = 463
8 | ClientWidth = 715
9 | Color = clBtnFace
10 | Font.Charset = DEFAULT_CHARSET
11 | Font.Color = clWindowText
12 | Font.Height = -11
13 | Font.Name = 'Tahoma'
14 | Font.Style = []
15 | OldCreateOrder = False
16 | PixelsPerInch = 96
17 | TextHeight = 13
18 | object pnlBackground: TPanel
19 | Left = 0
20 | Top = 0
21 | Width = 715
22 | Height = 463
23 | Align = alClient
24 | TabOrder = 0
25 | DesignSize = (
26 | 715
27 | 463)
28 | object lblTitle: TLabel
29 | Left = 16
30 | Top = 24
31 | Width = 142
32 | Height = 33
33 | Caption = 'Cadastro de'
34 | Font.Charset = DEFAULT_CHARSET
35 | Font.Color = clWindowText
36 | Font.Height = -27
37 | Font.Name = 'Tahoma'
38 | Font.Style = []
39 | ParentFont = False
40 | end
41 | object lblSubtitle: TLabel
42 | Left = 16
43 | Top = 67
44 | Width = 70
45 | Height = 19
46 | Caption = 'lblSubtitle'
47 | Font.Charset = DEFAULT_CHARSET
48 | Font.Color = clWindowText
49 | Font.Height = -16
50 | Font.Name = 'Tahoma'
51 | Font.Style = []
52 | ParentFont = False
53 | end
54 | object btnBack: TButton
55 | Left = 16
56 | Top = 415
57 | Width = 75
58 | Height = 25
59 | Anchors = [akLeft, akBottom]
60 | Caption = 'Voltar'
61 | TabOrder = 0
62 | OnClick = btnBackClick
63 | end
64 | end
65 | end
66 |
--------------------------------------------------------------------------------
/Samples/VCL/pages/View.Page.Template.pas:
--------------------------------------------------------------------------------
1 | unit View.Page.Template;
2 |
3 | interface
4 |
5 | uses
6 | Winapi.Windows,
7 | Winapi.Messages,
8 | System.SysUtils,
9 | System.Variants,
10 | System.Classes,
11 | Vcl.Graphics,
12 | Vcl.Controls,
13 | Vcl.Forms,
14 | Vcl.Dialogs,
15 | Router4D.Interfaces,
16 | Vcl.ExtCtrls,
17 | Vcl.StdCtrls,
18 | Router4D.Props,
19 | Router4D;
20 |
21 | type
22 | TfViewPageTemplate = class(TForm, IRouter4DComponent)
23 | pnlBackground: TPanel;
24 | btnBack: TButton;
25 | lblTitle: TLabel;
26 | lblSubtitle: TLabel;
27 | procedure btnBackClick(Sender: TObject);
28 | private
29 | function Render: TForm;
30 | procedure UnRender;
31 | public
32 | [Subscribe]
33 | procedure Props(AValue: TProps);
34 | end;
35 |
36 | var
37 | fViewPageTemplate: TfViewPageTemplate;
38 |
39 | implementation
40 |
41 | {$R *.dfm}
42 |
43 | { TfViewPageTemplate }
44 |
45 | procedure TfViewPageTemplate.btnBackClick(Sender: TObject);
46 | begin
47 | TRouter4D.Link.&To('Start');
48 | end;
49 |
50 | procedure TfViewPageTemplate.Props(AValue: TProps);
51 | begin
52 | lblSubtitle.Caption := AValue.PropString;
53 |
54 | AValue.Free;
55 | end;
56 |
57 | function TfViewPageTemplate.Render: TForm;
58 | begin
59 | Result := Self;
60 | end;
61 |
62 | procedure TfViewPageTemplate.UnRender;
63 | begin
64 |
65 | end;
66 |
67 | end.
68 |
69 |
--------------------------------------------------------------------------------
/assets/logo.fw.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/academiadocodigo/Router4Delphi/eedd012e4b68cbda69067f9baf3f9ccfb628abc6/assets/logo.fw.png
--------------------------------------------------------------------------------
/boss-lock.json:
--------------------------------------------------------------------------------
1 | {
2 | "hash": "d41d8cd98f00b204e9800998ecf8427e",
3 | "updated": "2021-04-29T17:11:41.0855564-03:00",
4 | "installedModules": {}
5 | }
--------------------------------------------------------------------------------
/boss.json:
--------------------------------------------------------------------------------
1 | {
2 | "name": "Router4Delphi",
3 | "description": "",
4 | "version": "1.0.0",
5 | "homepage": "",
6 | "mainsrc": "src",
7 | "projects": [],
8 | "dependencies": {}
9 | }
--------------------------------------------------------------------------------
/src/DuckListU.pas:
--------------------------------------------------------------------------------
1 | // ***************************************************************************
2 | //
3 | // Delphi MVC Framework
4 | //
5 | // Copyright (c) 2010-2016 Daniele Teti and the DMVCFramework Team
6 | //
7 | // https://github.com/danieleteti/delphimvcframework
8 | //
9 | // ***************************************************************************
10 | //
11 | // Licensed under the Apache License, Version 2.0 (the "License");
12 | // you may not use this file except in compliance with the License.
13 | // You may obtain a copy of the License at
14 | //
15 | // http://www.apache.org/licenses/LICENSE-2.0
16 | //
17 | // Unless required by applicable law or agreed to in writing, software
18 | // distributed under the License is distributed on an "AS IS" BASIS,
19 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
20 | // See the License for the specific language governing permissions and
21 | // limitations under the License.
22 | //
23 | // ***************************************************************************
24 |
25 | unit DuckListU;
26 |
27 | interface
28 |
29 | uses
30 | RTTI,
31 | Classes,
32 | // superobject,
33 | Generics.Collections,
34 | SysUtils,
35 | TypInfo;
36 |
37 | type
38 | TDuckTypedList=class;
39 |
40 | TdormObjectStatus=(osDirty=0, osClean, osUnknown, osDeleted);
41 |
42 | EdormException=class(Exception)
43 |
44 | end;
45 |
46 | EdormValidationException=class(EdormException)
47 |
48 | end;
49 |
50 | TdormEnvironment=(deDevelopment, deTest, deRelease);
51 | TdormObjectOwner=(ooItself, ooParent);
52 | TdormSaveType=(stAllGraph, stSingleObject);
53 | TdormRelations=set of (drBelongsTo, drHasMany, drHasOne);
54 | TdormFillOptions=set of (CallAfterLoadEvent);
55 |
56 | IList=interface
57 | ['{2A1BCB3C-17A2-4F8D-B6FB-32B2A1BFE840}']
58 | function Add(const Value: TObject): Integer;
59 | procedure Clear;
60 | function Count: Integer;
61 | function GetItem(index: Integer): TObject;
62 | end;
63 |
64 | TdormListEnumerator=class(TEnumerator)
65 | protected
66 | FPosition: Int64;
67 | FDuckTypedList: TDuckTypedList;
68 |
69 | protected
70 | function DoGetCurrent: TObject; override;
71 | function DoMoveNext: boolean; override;
72 |
73 | public
74 | constructor Create(ADuckTypedList: TDuckTypedList);
75 | end;
76 |
77 | TSortingType=(soAscending, soDescending);
78 |
79 | IWrappedList=interface
80 | ['{B60AF5A6-7C31-4EAA-8DFB-D8BD3E112EE7}']
81 | function Count: Integer;
82 | function GetItem(const index: Integer): TObject;
83 | procedure Add(const AObject: TObject);
84 | procedure Clear;
85 | function GetEnumerator: TdormListEnumerator;
86 | function WrappedObject: TObject;
87 | procedure Sort(const PropertyName: string; Order: TSortingType=soAscending);
88 | function GetOwnsObjects: boolean;
89 | procedure SetOwnsObjects(const Value: boolean);
90 | property OwnsObjects: boolean read GetOwnsObjects write SetOwnsObjects;
91 | end;
92 |
93 | TDuckTypedList=class(TInterfacedObject, IWrappedList)
94 | protected
95 | FCTX: TRTTIContext;
96 | FObjectAsDuck: TObject;
97 | FAddMethod: TRttiMethod;
98 | FClearMethod: TRttiMethod;
99 | FCountProperty: TRttiProperty;
100 | FGetItemMethod: TRttiMethod;
101 | FGetCountMethod: TRttiMethod;
102 | function Count: Integer;
103 | function GetItem(const index: Integer): TObject;
104 | procedure Add(const AObject: TObject);
105 | procedure Clear;
106 | function WrappedObject: TObject;
107 | procedure QuickSort(List: IWrappedList; L, R: Integer; SCompare: TFunc); overload;
108 |
109 | procedure QuickSort(List: IWrappedList; SCompare: TFunc); overload;
110 | procedure Sort(const PropertyName: string; Order: TSortingType=soAscending);
111 |
112 | public
113 | constructor Create(AObjectAsDuck: TObject);
114 | destructor Destroy; override;
115 | function GetEnumerator: TdormListEnumerator;
116 | function GetOwnsObjects: boolean;
117 | procedure SetOwnsObjects(const Value: boolean);
118 | property OwnsObjects: boolean read GetOwnsObjects write SetOwnsObjects;
119 | class function CanBeWrappedAsList(const AObjectAsDuck: TObject): boolean;
120 | end;
121 |
122 | function WrapAsList(const AObject: TObject): IWrappedList;
123 |
124 | implementation
125 |
126 | uses System.Math,
127 | RTTIUtilsU;
128 |
129 | constructor TdormListEnumerator.Create(ADuckTypedList: TDuckTypedList);
130 | begin
131 | inherited Create;
132 | FDuckTypedList := ADuckTypedList;
133 | FPosition := -1;
134 | end;
135 |
136 | function TdormListEnumerator.DoGetCurrent: TObject;
137 | begin
138 | if FPosition>-1 then
139 | Result := FDuckTypedList.GetItem(FPosition)
140 | else
141 | raise Exception.Create('Enumerator error: Call MoveNext first');
142 | end;
143 |
144 | function TdormListEnumerator.DoMoveNext: boolean;
145 | begin
146 | if FPositionnil)and(FCTX.GetType(AObjectAsDuck.ClassInfo).GetMethod('Clear')<>nil)
170 |
171 | {$IF CompilerVersion >= 23}
172 | and(FCTX.GetType(AObjectAsDuck.ClassInfo).GetIndexedProperty('Items').ReadMethod<>nil)
173 |
174 | {$IFEND}
175 | and((FCTX.GetType(AObjectAsDuck.ClassInfo).GetMethod('GetItem')<>nil)or(FCTX.GetType(AObjectAsDuck.ClassInfo).GetMethod('GetElement')<>
176 | nil))and(FCTX.GetType(AObjectAsDuck.ClassInfo).GetProperty('Count')<>nil)
177 |
178 | end;
179 |
180 | procedure TDuckTypedList.Clear;
181 | begin
182 | FClearMethod.Invoke(FObjectAsDuck, []);
183 | end;
184 |
185 | function TDuckTypedList.Count: Integer;
186 | begin
187 | if Assigned(FCountProperty) then
188 | Result := FCountProperty.GetValue(FObjectAsDuck).AsInteger
189 | else
190 | Result := FGetCountMethod.Invoke(FObjectAsDuck, []).AsInteger;
191 |
192 | end;
193 |
194 | constructor TDuckTypedList.Create(AObjectAsDuck: TObject);
195 | begin
196 | inherited Create;
197 | FObjectAsDuck := AObjectAsDuck;
198 | FAddMethod := FCTX.GetType(AObjectAsDuck.ClassInfo).GetMethod('Add');
199 | if not Assigned(FAddMethod) then
200 | raise EdormException.Create('Cannot find method "Add" in the duck object');
201 | FClearMethod := FCTX.GetType(AObjectAsDuck.ClassInfo).GetMethod('Clear');
202 | if not Assigned(FClearMethod) then
203 | raise EdormException.Create('Cannot find method "Clear" in the duck object');
204 | FGetItemMethod := nil;
205 |
206 | {$IF CompilerVersion >= 23}
207 | FGetItemMethod := FCTX.GetType(AObjectAsDuck.ClassInfo).GetIndexedProperty('Items').ReadMethod;
208 |
209 | {$IFEND}
210 | if not Assigned(FGetItemMethod) then
211 | FGetItemMethod := FCTX.GetType(AObjectAsDuck.ClassInfo).GetMethod('GetItem');
212 | if not Assigned(FGetItemMethod) then
213 | FGetItemMethod := FCTX.GetType(AObjectAsDuck.ClassInfo).GetMethod('GetElement');
214 | if not Assigned(FGetItemMethod) then
215 | raise EdormException.Create
216 | ('Cannot find method Indexed property "Items" or method "GetItem" or method "GetElement" in the duck object');
217 | FCountProperty := FCTX.GetType(AObjectAsDuck.ClassInfo).GetProperty('Count');
218 | if not Assigned(FCountProperty) then
219 | begin
220 | FGetCountMethod := FCTX.GetType(AObjectAsDuck.ClassInfo).GetMethod('Count');
221 | if not Assigned(FGetCountMethod) then
222 |
223 | raise EdormException.Create('Cannot find property/method "Count" in the duck object');
224 | end;
225 | end;
226 |
227 | destructor TDuckTypedList.Destroy;
228 | begin
229 |
230 | inherited;
231 | end;
232 |
233 | function TDuckTypedList.GetItem(const index: Integer): TObject;
234 | begin
235 | Result := FGetItemMethod.Invoke(FObjectAsDuck, [index]).AsObject;
236 | end;
237 |
238 | function TDuckTypedList.GetOwnsObjects: boolean;
239 | begin
240 | Result := TRTTIUtils.GetProperty(FObjectAsDuck, 'OwnsObjects').AsBoolean
241 | end;
242 |
243 | function TDuckTypedList.WrappedObject: TObject;
244 | begin
245 | Result := FObjectAsDuck;
246 | end;
247 |
248 | function WrapAsList(const AObject: TObject): IWrappedList;
249 | begin
250 | try
251 | Result := TDuckTypedList.Create(AObject);
252 | except
253 | Result := nil;
254 | end;
255 | end;
256 |
257 | procedure TDuckTypedList.QuickSort(List: IWrappedList; L, R: Integer; SCompare: TFunc);
258 | var
259 | I, J: Integer;
260 | p: TObject;
261 | begin
262 | { 07/08/2013: This method is based on QuickSort procedure from
263 | Classes.pas, (c) Borland Software Corp.
264 | but modified to be part of TDuckListU unit. It implements the
265 | standard quicksort algorithm,
266 | delegating comparison operation to an anonimous.
267 | The Borland version delegates to a pure function
268 | pointer, which is problematic in some cases. }
269 | repeat
270 | I := L;
271 | J := R;
272 | p := List.GetItem((L+R) shr 1);
273 | repeat
274 | while SCompare(TObject(List.GetItem(I)), p)<0 do
275 | Inc(I);
276 | while SCompare(TObject(List.GetItem(J)), p)>0 do
277 | Dec(J);
278 | if I<=J then
279 | begin
280 | TRTTIUtils.MethodCall(List.WrappedObject, 'Exchange', [I, J]);
281 | Inc(I);
282 | Dec(J);
283 | end;
284 | until I>J;
285 | if L=R;
289 | end;
290 |
291 | procedure TDuckTypedList.QuickSort(List: IWrappedList; SCompare: TFunc);
292 | begin
293 | QuickSort(List, 0, List.Count-1, SCompare);
294 | end;
295 |
296 | function CompareValue(const Left, Right: TValue): Integer;
297 | begin
298 | if Left.IsOrdinal then
299 | begin
300 | Result := System.Math.CompareValue(Left.AsOrdinal, Right.AsOrdinal);
301 | end
302 | else if Left.Kind=tkFloat then
303 | begin
304 | Result := System.Math.CompareValue(Left.AsExtended, Right.AsExtended);
305 | end
306 | else if Left.Kind in [tkString, tkUString, tkWString, tkLString] then
307 | begin
308 | Result := CompareText(Left.AsString, Right.AsString);
309 | end
310 | else
311 | begin
312 | Result := 0;
313 | end;
314 | end;
315 |
316 | procedure TDuckTypedList.SetOwnsObjects(const Value: boolean);
317 | begin
318 | TRTTIUtils.SetProperty(FObjectAsDuck, 'OwnsObjects', Value);
319 | end;
320 |
321 | procedure TDuckTypedList.Sort(const PropertyName: string; Order: TSortingType);
322 | begin
323 | if Order=soAscending then
324 | QuickSort(self,
325 | function(Left, Right: TObject): Integer
326 | begin
327 | Result := CompareValue(TRTTIUtils.GetProperty(Left, PropertyName), TRTTIUtils.GetProperty(Right, PropertyName));
328 | end)
329 | else
330 | QuickSort(self,
331 | function(Left, Right: TObject): Integer
332 | begin
333 | Result := -1*CompareValue(TRTTIUtils.GetProperty(Left, PropertyName), TRTTIUtils.GetProperty(Right, PropertyName));
334 | end);
335 | end;
336 |
337 | end.
338 |
--------------------------------------------------------------------------------
/src/EventBus.Core.pas:
--------------------------------------------------------------------------------
1 | { *******************************************************************************
2 | Copyright 2016-2019 Daniele Spinetti
3 |
4 | Licensed under the Apache License, Version 2.0 (the "License");
5 | you may not use this file except in compliance with the License.
6 | You may obtain a copy of the License at
7 |
8 | http://www.apache.org/licenses/LICENSE-2.0
9 |
10 | Unless required by applicable law or agreed to in writing, software
11 | distributed under the License is distributed on an "AS IS" BASIS,
12 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 | See the License for the specific language governing permissions and
14 | limitations under the License.
15 | ******************************************************************************** }
16 |
17 | unit EventBus.Core;
18 |
19 | interface
20 |
21 | uses
22 | System.SyncObjs, EventBus.Subscribers, Generics.Collections,
23 | System.SysUtils, System.Classes, Router4D.Props;
24 |
25 | type
26 |
27 | TEventBus = class(TInterfacedObject, IEventBus)
28 | var
29 | FTypesOfGivenSubscriber: TObjectDictionary>;
30 | FSubscriptionsOfGivenEventType
31 | : TObjectDictionary>;
32 | FCustomClonerDict: TDictionary;
33 | FOnCloneEvent: TCloneEventCallback;
34 | procedure Subscribe(ASubscriber: TObject;
35 | ASubscriberMethod: TSubscriberMethod);
36 | procedure UnsubscribeByEventType(ASubscriber: TObject; AEventType: TClass);
37 | procedure InvokeSubscriber(ASubscription: TSubscription; AEvent: TObject);
38 | function GenerateTProc(ASubscription: TSubscription;
39 | AEvent: TObject): TProc;
40 | function GenerateThreadProc(ASubscription: TSubscription; AEvent: TObject)
41 | : TThreadProcedure;
42 | protected
43 | procedure SetOnCloneEvent(const aCloneEvent: TCloneEventCallback);
44 | function CloneEvent(AEvent: TObject): TObject; virtual;
45 | procedure PostToSubscription(ASubscription: TSubscription; AEvent: TObject;
46 | AIsMainThread: Boolean); virtual;
47 | public
48 | constructor Create; virtual;
49 | destructor Destroy; override;
50 | procedure RegisterSubscriber(ASubscriber: TObject); virtual;
51 | function IsRegistered(ASubscriber: TObject): Boolean;
52 | procedure Unregister(ASubscriber: TObject); virtual;
53 | procedure Post(AEvent: TObject; const AContext: String = '';
54 | AEventOwner: Boolean = true); virtual;
55 | property TypesOfGivenSubscriber: TObjectDictionary < TObject,
56 | TList < TClass >> read FTypesOfGivenSubscriber;
57 | property SubscriptionsOfGivenEventType: TObjectDictionary < TClass,
58 | TObjectList < TSubscription >> read FSubscriptionsOfGivenEventType;
59 | property OnCloneEvent: TCloneEventCallback write SetOnCloneEvent;
60 | procedure AddCustomClassCloning(const AQualifiedClassName: String;
61 | const aCloneEvent: TCloneEventMethod);
62 | procedure RemoveCustomClassCloning(const AQualifiedClassName: String);
63 | end;
64 |
65 | implementation
66 |
67 | uses
68 | System.Rtti,
69 | {$IF CompilerVersion >= 28.0}
70 | System.Threading,
71 | {$ENDIF}
72 | RTTIUtilsU;
73 |
74 | var
75 | FMREWSync: TMultiReadExclusiveWriteSynchronizer;
76 |
77 | { TEventBus }
78 |
79 | constructor TEventBus.Create;
80 | begin
81 | inherited Create;
82 | FSubscriptionsOfGivenEventType := TObjectDictionary < TClass,
83 | TObjectList < TSubscription >>.Create([doOwnsValues]);
84 | FTypesOfGivenSubscriber := TObjectDictionary < TObject,
85 | TList < TClass >>.Create([doOwnsValues]);
86 | FCustomClonerDict := TDictionary.Create;
87 | end;
88 |
89 | destructor TEventBus.Destroy;
90 | begin
91 | FreeAndNil(FSubscriptionsOfGivenEventType);
92 | FreeAndNil(FTypesOfGivenSubscriber);
93 | FreeAndNil(FCustomClonerDict);
94 | inherited;
95 | end;
96 |
97 | procedure TEventBus.AddCustomClassCloning(const AQualifiedClassName: String;
98 | const aCloneEvent: TCloneEventMethod);
99 | begin
100 | FCustomClonerDict.Add(AQualifiedClassName, aCloneEvent);
101 | end;
102 |
103 | function TEventBus.CloneEvent(AEvent: TObject): TObject;
104 | var
105 | LCloneEvent: TCloneEventMethod;
106 | begin
107 | if FCustomClonerDict.TryGetValue(AEvent.QualifiedClassName, LCloneEvent) then
108 | Result := LCloneEvent(AEvent)
109 | else if Assigned(FOnCloneEvent) then
110 | Result := FOnCloneEvent(AEvent)
111 | else
112 | Result := TRTTIUtils.Clone(AEvent);
113 | end;
114 |
115 | function TEventBus.GenerateThreadProc(ASubscription: TSubscription;
116 | AEvent: TObject): TThreadProcedure;
117 | begin
118 | Result := procedure
119 | begin
120 | if ASubscription.Active then
121 | begin
122 | ASubscription.SubscriberMethod.Method.Invoke(ASubscription.Subscriber,
123 | [AEvent]);
124 | end;
125 | end;
126 | end;
127 |
128 | function TEventBus.GenerateTProc(ASubscription: TSubscription;
129 | AEvent: TObject): TProc;
130 | begin
131 | Result := procedure
132 | begin
133 | if ASubscription.Active then
134 | begin
135 | ASubscription.SubscriberMethod.Method.Invoke(ASubscription.Subscriber,
136 | [AEvent]);
137 | end;
138 | end;
139 | end;
140 |
141 | procedure TEventBus.InvokeSubscriber(ASubscription: TSubscription;
142 | AEvent: TObject);
143 | begin
144 | try
145 | ASubscription.SubscriberMethod.Method.Invoke(ASubscription.Subscriber,
146 | [AEvent]);
147 | except
148 | on E: Exception do
149 | begin
150 | raise Exception.CreateFmt
151 | ('Error invoking subscriber method. Subscriber class: %s. Event type: %s. Original exception: %s: %s',
152 | [ASubscription.Subscriber.ClassName,
153 | ASubscription.SubscriberMethod.EventType.ClassName, E.ClassName,
154 | E.Message]);
155 | end;
156 | end;
157 | end;
158 |
159 | function TEventBus.IsRegistered(ASubscriber: TObject): Boolean;
160 | begin
161 | FMREWSync.BeginRead;
162 | try
163 | Result := FTypesOfGivenSubscriber.ContainsKey(ASubscriber);
164 | finally
165 | FMREWSync.EndRead;
166 | end;
167 | end;
168 |
169 | procedure TEventBus.Post(AEvent: TObject; const AContext: String = '';
170 | AEventOwner: Boolean = true);
171 | var
172 | LSubscriptions: TObjectList;
173 | LSubscription: TSubscription;
174 | LEvent: TObject;
175 | LIsMainThread: Boolean;
176 | begin
177 | FMREWSync.BeginRead;
178 | try
179 | try
180 | LIsMainThread := MainThreadID = TThread.CurrentThread.ThreadID;
181 |
182 | FSubscriptionsOfGivenEventType.TryGetValue(AEvent.ClassType,
183 | LSubscriptions);
184 |
185 | if (not Assigned(LSubscriptions)) then
186 | Exit;
187 |
188 | for LSubscription in LSubscriptions do
189 | begin
190 |
191 | if not LSubscription.Active then
192 | continue;
193 |
194 | if ((not AContext.IsEmpty) and (LSubscription.Context <> AContext)) then
195 | continue;
196 |
197 | LEvent := CloneEvent(AEvent);
198 | PostToSubscription(LSubscription, LEvent, LIsMainThread);
199 | end;
200 | finally
201 | if (AEventOwner and Assigned(AEvent)) then
202 | AEvent.Free;
203 | end;
204 | finally
205 | FMREWSync.EndRead;
206 | end;
207 | end;
208 |
209 | procedure TEventBus.PostToSubscription(ASubscription: TSubscription;
210 | AEvent: TObject; AIsMainThread: Boolean);
211 | begin
212 |
213 | if not Assigned(ASubscription.Subscriber) then
214 | Exit;
215 |
216 | case ASubscription.SubscriberMethod.ThreadMode of
217 | Posting:
218 | InvokeSubscriber(ASubscription, AEvent);
219 | Main:
220 | if (AIsMainThread) then
221 | InvokeSubscriber(ASubscription, AEvent)
222 | else
223 | TThread.Queue(nil, GenerateThreadProc(ASubscription, AEvent));
224 | Background:
225 | if (AIsMainThread) then
226 | {$IF CompilerVersion >= 28.0}
227 | TTask.Run(GenerateTProc(ASubscription, AEvent))
228 | {$ELSE}
229 | TThread.CreateAnonymousThread(GenerateTProc(ASubscription,
230 | AEvent)).Start
231 | {$ENDIF}
232 | else
233 | InvokeSubscriber(ASubscription, AEvent);
234 | Async:
235 | {$IF CompilerVersion >= 28.0}
236 | TTask.Run(GenerateTProc(ASubscription, AEvent));
237 | {$ELSE}
238 | TThread.CreateAnonymousThread(GenerateTProc(ASubscription, AEvent)).Start;
239 | {$ENDIF}
240 | else
241 | raise Exception.Create('Unknown thread mode');
242 | end;
243 |
244 | end;
245 |
246 | procedure TEventBus.RegisterSubscriber(ASubscriber: TObject);
247 | var
248 | LSubscriberClass: TClass;
249 | LSubscriberMethods: TArray;
250 | LSubscriberMethod: TSubscriberMethod;
251 | begin
252 | FMREWSync.BeginWrite;
253 | try
254 | LSubscriberClass := ASubscriber.ClassType;
255 | LSubscriberMethods := TSubscribersFinder.FindSubscriberMethods
256 | (LSubscriberClass, true);
257 | for LSubscriberMethod in LSubscriberMethods do
258 | Subscribe(ASubscriber, LSubscriberMethod);
259 | finally
260 | FMREWSync.EndWrite;
261 | end;
262 | end;
263 |
264 | procedure TEventBus.RemoveCustomClassCloning(const AQualifiedClassName: String);
265 | begin
266 | // No exception is thrown if the key is not in the dictionary
267 | FCustomClonerDict.Remove(AQualifiedClassName);
268 | end;
269 |
270 | procedure TEventBus.SetOnCloneEvent(const aCloneEvent: TCloneEventCallback);
271 | begin
272 | FOnCloneEvent := aCloneEvent;
273 | end;
274 |
275 | procedure TEventBus.Subscribe(ASubscriber: TObject;
276 | ASubscriberMethod: TSubscriberMethod);
277 | var
278 | LEventType: TClass;
279 | LNewSubscription: TSubscription;
280 | LSubscriptions: TObjectList;
281 | LSubscribedEvents: TList;
282 | begin
283 | LEventType := ASubscriberMethod.EventType;
284 | LNewSubscription := TSubscription.Create(ASubscriber, ASubscriberMethod);
285 | if (not FSubscriptionsOfGivenEventType.ContainsKey(LEventType)) then
286 | begin
287 | LSubscriptions := TObjectList.Create();
288 | FSubscriptionsOfGivenEventType.Add(LEventType, LSubscriptions);
289 | end
290 | else
291 | begin
292 | LSubscriptions := FSubscriptionsOfGivenEventType.Items[LEventType];
293 | if (LSubscriptions.Contains(LNewSubscription)) then
294 | raise Exception.CreateFmt('Subscriber %s already registered to event %s ',
295 | [ASubscriber.ClassName, LEventType.ClassName]);
296 | end;
297 |
298 | LSubscriptions.Add(LNewSubscription);
299 |
300 | if (not FTypesOfGivenSubscriber.TryGetValue(ASubscriber, LSubscribedEvents))
301 | then
302 | begin
303 | LSubscribedEvents := TList.Create;
304 | FTypesOfGivenSubscriber.Add(ASubscriber, LSubscribedEvents);
305 | end;
306 | LSubscribedEvents.Add(LEventType);
307 | end;
308 |
309 | procedure TEventBus.Unregister(ASubscriber: TObject);
310 | var
311 | LSubscribedTypes: TList;
312 | LEventType: TClass;
313 | begin
314 | FMREWSync.BeginWrite;
315 | try
316 | if FTypesOfGivenSubscriber.TryGetValue(ASubscriber, LSubscribedTypes) then
317 | begin
318 | for LEventType in LSubscribedTypes do
319 | UnsubscribeByEventType(ASubscriber, LEventType);
320 | FTypesOfGivenSubscriber.Remove(ASubscriber);
321 | end;
322 | // else {
323 | // Log.w(TAG, "Subscriber to unregister was not registered before: " + subscriber.getClass());
324 | // }
325 | finally
326 | FMREWSync.EndWrite;
327 | end;
328 | end;
329 |
330 | procedure TEventBus.UnsubscribeByEventType(ASubscriber: TObject;
331 | AEventType: TClass);
332 | var
333 | LSubscriptions: TObjectList;
334 | LSize, I: Integer;
335 | LSubscription: TSubscription;
336 | begin
337 | LSubscriptions := FSubscriptionsOfGivenEventType.Items[AEventType];
338 | if (not Assigned(LSubscriptions)) or (LSubscriptions.Count < 1) then
339 | Exit;
340 | LSize := LSubscriptions.Count;
341 | for I := LSize - 1 downto 0 do
342 | begin
343 | LSubscription := LSubscriptions[I];
344 | // Notes: In case the subscriber has been freed but it didn't unregister itself, calling
345 | // LSubscription.Subscriber.Equals() will cause Access Violation, so we use '=' instead.
346 | if LSubscription.Subscriber = ASubscriber then
347 | begin
348 | LSubscription.Active := false;
349 | LSubscriptions.Delete(I);
350 | end;
351 | end;
352 | end;
353 |
354 | initialization
355 |
356 | FMREWSync := TMultiReadExclusiveWriteSynchronizer.Create;
357 |
358 | finalization
359 |
360 | FMREWSync.Free;
361 |
362 | end.
363 |
--------------------------------------------------------------------------------
/src/EventBus.Subscribers.pas:
--------------------------------------------------------------------------------
1 | { *******************************************************************************
2 | Copyright 2016-2019 Daniele Spinetti
3 |
4 | Licensed under the Apache License, Version 2.0 (the "License");
5 | you may not use this file except in compliance with the License.
6 | You may obtain a copy of the License at
7 |
8 | http://www.apache.org/licenses/LICENSE-2.0
9 |
10 | Unless required by applicable law or agreed to in writing, software
11 | distributed under the License is distributed on an "AS IS" BASIS,
12 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 | See the License for the specific language governing permissions and
14 | limitations under the License.
15 | ******************************************************************************** }
16 |
17 | unit EventBus.Subscribers;
18 |
19 | interface
20 |
21 | uses
22 | System.RTTI, Router4D.Props;
23 |
24 | type
25 |
26 | TSubscriberMethod = class(TObject)
27 | private
28 | FEventType: TClass;
29 | FThreadMode: TThreadMode;
30 | FMethod: TRttiMethod;
31 | FContext: string;
32 | procedure SetEventType(const Value: TClass);
33 | procedure SetMethod(const Value: TRttiMethod);
34 | procedure SetThreadMode(const Value: TThreadMode);
35 | procedure SetContext(const Value: String);
36 | public
37 | constructor Create(ARttiMethod: TRttiMethod; AEventType: TClass;
38 | AThreadMode: TThreadMode; const AContext: String = '';
39 | APriority: Integer = 1);
40 | destructor Destroy; override;
41 | property EventType: TClass read FEventType write SetEventType;
42 | property Method: TRttiMethod read FMethod write SetMethod;
43 | property ThreadMode: TThreadMode read FThreadMode write SetThreadMode;
44 | property Context: String read FContext write SetContext;
45 | function Equals(Obj: TObject): Boolean; override;
46 | end;
47 |
48 | TSubscription = class(TObject)
49 | private
50 | FSubscriberMethod: TSubscriberMethod;
51 | FSubscriber: TObject;
52 | FActive: Boolean;
53 | procedure SetActive(const Value: Boolean);
54 | function GetActive: Boolean;
55 | procedure SetSubscriberMethod(const Value: TSubscriberMethod);
56 | procedure SetSubscriber(const Value: TObject);
57 | function GetContext: String;
58 | public
59 | constructor Create(ASubscriber: TObject;
60 | ASubscriberMethod: TSubscriberMethod);
61 | destructor Destroy; override;
62 | property Active: Boolean read GetActive write SetActive;
63 | property Subscriber: TObject read FSubscriber write SetSubscriber;
64 | property SubscriberMethod: TSubscriberMethod read FSubscriberMethod
65 | write SetSubscriberMethod;
66 | property Context: String read GetContext;
67 | function Equals(Obj: TObject): Boolean; override;
68 |
69 | end;
70 |
71 | TSubscribersFinder = class(TObject)
72 | class function FindSubscriberMethods(ASubscriberClass: TClass;
73 | ARaiseExcIfEmpty: Boolean = false): TArray;
74 | end;
75 |
76 | implementation
77 |
78 | uses
79 | RTTIUtilsU, System.SysUtils, System.TypInfo;
80 |
81 | { TSubscriberMethod }
82 |
83 | constructor TSubscriberMethod.Create(ARttiMethod: TRttiMethod;
84 | AEventType: TClass; AThreadMode: TThreadMode; const AContext: String = '';
85 | APriority: Integer = 1);
86 | begin
87 | FMethod := ARttiMethod;
88 | FEventType := AEventType;
89 | FThreadMode := AThreadMode;
90 | FContext := AContext;
91 | end;
92 |
93 | destructor TSubscriberMethod.Destroy;
94 | begin
95 | inherited;
96 | end;
97 |
98 | function TSubscriberMethod.Equals(Obj: TObject): Boolean;
99 | var
100 | OtherSubscriberMethod: TSubscriberMethod;
101 | begin
102 | if (inherited Equals(Obj)) then
103 | exit(true)
104 | else if (Obj is TSubscriberMethod) then
105 | begin
106 | OtherSubscriberMethod := TSubscriberMethod(Obj);
107 | exit(OtherSubscriberMethod.Method.ToString = Method.ToString);
108 | end
109 | else
110 | exit(false);
111 | end;
112 |
113 | procedure TSubscriberMethod.SetContext(const Value: String);
114 | begin
115 | FContext := Value;
116 | end;
117 |
118 | procedure TSubscriberMethod.SetEventType(const Value: TClass);
119 | begin
120 | FEventType := Value;
121 | end;
122 |
123 | procedure TSubscriberMethod.SetMethod(const Value: TRttiMethod);
124 | begin
125 | FMethod := Value;
126 | end;
127 |
128 | procedure TSubscriberMethod.SetThreadMode(const Value: TThreadMode);
129 | begin
130 | FThreadMode := Value;
131 | end;
132 |
133 | { TSubscribersFinder }
134 |
135 | class function TSubscribersFinder.FindSubscriberMethods(ASubscriberClass
136 | : TClass; ARaiseExcIfEmpty: Boolean = false): TArray;
137 | var
138 | LRttiType: TRttiType;
139 | LSubscribeAttribute: SubscribeAttribute;
140 | LRttiMethods: TArray;
141 | LMethod: TRttiMethod;
142 | LParamsLength: Integer;
143 | LEventType: TClass;
144 | LSubMethod: TSubscriberMethod;
145 | begin
146 | LRttiType := TRTTIUtils.ctx.GetType(ASubscriberClass);
147 | LRttiMethods := LRttiType.GetMethods;
148 | for LMethod in LRttiMethods do
149 | if TRTTIUtils.HasAttribute(LMethod, LSubscribeAttribute)
150 | then
151 | begin
152 | LParamsLength := Length(LMethod.GetParameters);
153 | if (LParamsLength <> 1) then
154 | raise Exception.CreateFmt
155 | ('Method %s has Subscribe attribute but requires %d arguments. Methods must require a single argument.',
156 | [LMethod.Name, LParamsLength]);
157 | LEventType := LMethod.GetParameters[0].ParamType.Handle.TypeData.
158 | ClassType;
159 | LSubMethod := TSubscriberMethod.Create(LMethod, LEventType,
160 | LSubscribeAttribute.ThreadMode, LSubscribeAttribute.Context);
161 | {$IF CompilerVersion >= 28.0}
162 | Result := Result + [LSubMethod];
163 | {$ELSE}
164 | SetLength(Result, Length(Result) + 1);
165 | Result[High(Result)] := LSubMethod;
166 | {$ENDIF}
167 | end;
168 | //if (Length(Result) < 1) and ARaiseExcIfEmpty then
169 | // raise Exception.CreateFmt
170 | // ('The class %s and its super classes have no public methods with the Subscribe attributes',
171 | // [ASubscriberClass.QualifiedClassName]);
172 | end;
173 |
174 | { TSubscription }
175 |
176 | constructor TSubscription.Create(ASubscriber: TObject;
177 | ASubscriberMethod: TSubscriberMethod);
178 | begin
179 | inherited Create;
180 | FSubscriber := ASubscriber;
181 | FSubscriberMethod := ASubscriberMethod;
182 | FActive := true;
183 | end;
184 |
185 | destructor TSubscription.Destroy;
186 | begin
187 | if Assigned(FSubscriberMethod) then
188 | FreeAndNil(FSubscriberMethod);
189 | inherited;
190 | end;
191 |
192 | function TSubscription.Equals(Obj: TObject): Boolean;
193 | var
194 | LOtherSubscription: TSubscription;
195 | begin
196 | if (Obj is TSubscription) then
197 | begin
198 | LOtherSubscription := TSubscription(Obj);
199 | exit((Subscriber = LOtherSubscription.Subscriber) and
200 | (SubscriberMethod.Equals(LOtherSubscription.SubscriberMethod)));
201 | end
202 | else
203 | exit(false);
204 | end;
205 |
206 | function TSubscription.GetActive: Boolean;
207 | begin
208 | TMonitor.Enter(self);
209 | try
210 | Result := FActive;
211 | finally
212 | TMonitor.exit(self);
213 | end;
214 | end;
215 |
216 | function TSubscription.GetContext: String;
217 | begin
218 | Result := SubscriberMethod.Context;
219 | end;
220 |
221 | procedure TSubscription.SetActive(const Value: Boolean);
222 | begin
223 | TMonitor.Enter(self);
224 | try
225 | FActive := Value;
226 | finally
227 | TMonitor.exit(self);
228 | end;
229 | end;
230 |
231 | procedure TSubscription.SetSubscriberMethod(const Value: TSubscriberMethod);
232 | begin
233 | FSubscriberMethod := Value;
234 | end;
235 |
236 | procedure TSubscription.SetSubscriber(const Value: TObject);
237 | begin
238 | FSubscriber := Value;
239 | end;
240 |
241 | end.
242 |
--------------------------------------------------------------------------------
/src/RTTIUtilsU.pas:
--------------------------------------------------------------------------------
1 | // ***************************************************************************
2 | //
3 | // Delphi MVC Framework
4 | //
5 | // Copyright (c) 2010-2016 Daniele Teti and the DMVCFramework Team
6 | //
7 | // https://github.com/danieleteti/delphimvcframework
8 | //
9 | // ***************************************************************************
10 | //
11 | // Licensed under the Apache License, Version 2.0 (the "License");
12 | // you may not use this file except in compliance with the License.
13 | // You may obtain a copy of the License at
14 | //
15 | // http://www.apache.org/licenses/LICENSE-2.0
16 | //
17 | // Unless required by applicable law or agreed to in writing, software
18 | // distributed under the License is distributed on an "AS IS" BASIS,
19 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
20 | // See the License for the specific language governing permissions and
21 | // limitations under the License.
22 | //
23 | // ***************************************************************************
24 |
25 | unit RTTIUtilsU;
26 |
27 | interface
28 |
29 | uses
30 | RTTI,
31 | DB,
32 | Generics.Collections,
33 | System.SysUtils;
34 |
35 | type
36 | TRTTIUtils = class sealed
37 | public
38 | class var ctx: TRttiContext;
39 | class var TValueToStringFormatSettings: TFormatSettings;
40 |
41 | public
42 | class function MethodCall(AObject: TObject; AMethodName: string; AParameters: array of TValue;
43 | RaiseExceptionIfNotFound: boolean = true): TValue;
44 | class function GetMethod(AObject: TObject; AMethodName: string): TRttiMethod;
45 | class procedure SetProperty(Obj: TObject; const PropertyName: string; const Value: TValue); overload; static;
46 | class function GetFieldType(AProp: TRttiProperty): string;
47 | class function GetPropertyType(AObject: TObject; APropertyName: string): string;
48 | class procedure ObjectToDataSet(Obj: TObject; Field: TField; var Value: Variant);
49 | class function ExistsProperty(AObject: TObject; const APropertyName: string; out AProperty: TRttiProperty): boolean;
50 | class procedure DatasetToObject(Dataset: TDataset; Obj: TObject);
51 | class function GetProperty(Obj: TObject; const PropertyName: string): TValue;
52 | class function GetPropertyAsString(Obj: TObject; const PropertyName: string): string; overload;
53 |
54 | class function GetPropertyAsString(Obj: TObject; AProperty: TRttiProperty): string; overload;
55 | class function GetField(Obj: TObject; const PropertyName: string): TValue; overload;
56 | class procedure SetField(Obj: TObject; const PropertyName: string; const Value: TValue); overload;
57 | class function Clone(Obj: TObject): TObject; static;
58 | class procedure CopyObject(SourceObj, TargetObj: TObject); static;
59 | {$IF CompilerVersion >= 24.0} // not supported in xe3
60 | class procedure CopyObjectAS(SourceObj, TargetObj: TObject); static;
61 | {$IFEND}
62 | class function CreateObject(ARttiType: TRttiType): TObject; overload; static;
63 | class function CreateObject(AQualifiedClassName: string): TObject; overload; static;
64 | class function GetAttribute(const Obj: TRttiObject): T; overload;
65 | class function GetAttribute(const Obj: TRttiType): T; overload;
66 |
67 | class function HasAttribute(const Obj: TRttiObject): boolean; overload;
68 | class function HasAttribute(const Obj: TRttiObject; out AAttribute: T): boolean; overload;
69 | class function HasAttribute(aObj: TObject; out AAttribute: T): boolean; overload;
70 | class function HasAttribute(ARTTIMember: TRttiMember; out AAttribute: T): boolean; overload;
71 | class function HasAttribute(ARTTIMember: TRttiType; out AAttribute: T): boolean; overload;
72 |
73 | class function TValueAsString(const Value: TValue; const PropertyType, CustomFormat: string): string;
74 | class function EqualValues(source, destination: TValue): boolean;
75 | class function FindByProperty(List: TObjectList; PropertyName: string; PropertyValue: TValue): T;
76 | class procedure ForEachProperty(Clazz: TClass; Proc: TProc);
77 | class function HasStringValueAttribute(ARTTIMember: TRttiMember; out Value: string): boolean;
78 | class function BuildClass(AQualifiedName: string; Params: array of TValue): TObject;
79 | class function FindType(QualifiedName: string): TRttiType;
80 | class function GetGUID: TGUID;
81 |
82 | end;
83 |
84 | function FieldFor(const PropertyName: string): string; inline;
85 |
86 | implementation
87 |
88 | uses
89 | Classes,
90 | TypInfo,
91 | ObjectsMappers,
92 | DuckListU;
93 |
94 | class function TRTTIUtils.MethodCall(AObject: TObject; AMethodName: string; AParameters: array of TValue;
95 | RaiseExceptionIfNotFound: boolean): TValue;
96 | var
97 | m: TRttiMethod;
98 | T: TRttiType;
99 | Found: boolean;
100 | ParLen: Integer;
101 | MethodParamsLen: Integer;
102 | begin
103 | Found := False;
104 | T := ctx.GetType(AObject.ClassInfo);
105 | ParLen := Length(AParameters);
106 | m := nil;
107 | for m in T.GetMethods do
108 | begin
109 | MethodParamsLen := Length(m.GetParameters);
110 | if m.Name.Equals(AMethodName) and (MethodParamsLen = ParLen) then
111 | begin
112 | Found := true;
113 | Break;
114 | end;
115 | end;
116 |
117 | if Found then
118 | Result := m.Invoke(AObject, AParameters)
119 | else if RaiseExceptionIfNotFound then
120 | raise Exception.CreateFmt('Cannot find compatible method "%s" in the object', [AMethodName]);
121 | end;
122 |
123 | function FieldFor(const PropertyName: string): string; inline;
124 | begin
125 | Result := 'F' + PropertyName;
126 | end;
127 |
128 | class function TRTTIUtils.GetAttribute(const Obj: TRttiObject): T;
129 | var
130 | Attr: TCustomAttribute;
131 | begin
132 | Result := nil;
133 | for Attr in Obj.GetAttributes do
134 | begin
135 | if Attr.ClassType.InheritsFrom(T) then
136 | Exit(T(Attr));
137 | end;
138 | end;
139 |
140 | class function TRTTIUtils.GetAttribute(const Obj: TRttiType): T;
141 | var
142 | Attr: TCustomAttribute;
143 | begin
144 | Result := nil;
145 | for Attr in Obj.GetAttributes do
146 | begin
147 | if Attr.ClassType.InheritsFrom(T) then
148 | Exit(T(Attr));
149 | end;
150 | end;
151 |
152 | class function TRTTIUtils.GetField(Obj: TObject; const PropertyName: string): TValue;
153 | var
154 | Field: TRttiField;
155 | Prop: TRttiProperty;
156 | ARttiType: TRttiType;
157 | begin
158 | ARttiType := ctx.GetType(Obj.ClassType);
159 | if not Assigned(ARttiType) then
160 | raise Exception.CreateFmt('Cannot get RTTI for type [%s]', [ARttiType.ToString]);
161 | Field := ARttiType.GetField(FieldFor(PropertyName));
162 | if Assigned(Field) then
163 | Result := Field.GetValue(Obj)
164 | else
165 | begin
166 | Prop := ARttiType.GetProperty(PropertyName);
167 | if not Assigned(Prop) then
168 | raise Exception.CreateFmt('Cannot get RTTI for property [%s.%s]', [ARttiType.ToString, PropertyName]);
169 | Result := Prop.GetValue(Obj);
170 | end;
171 | end;
172 |
173 | class function TRTTIUtils.GetProperty(Obj: TObject; const PropertyName: string): TValue;
174 | var
175 | Prop: TRttiProperty;
176 | ARttiType: TRttiType;
177 | begin
178 | ARttiType := ctx.GetType(Obj.ClassType);
179 | if not Assigned(ARttiType) then
180 | raise Exception.CreateFmt('Cannot get RTTI for type [%s]', [ARttiType.ToString]);
181 | Prop := ARttiType.GetProperty(PropertyName);
182 | if not Assigned(Prop) then
183 | raise Exception.CreateFmt('Cannot get RTTI for property [%s.%s]', [ARttiType.ToString, PropertyName]);
184 | if Prop.IsReadable then
185 | Result := Prop.GetValue(Obj)
186 | else
187 | raise Exception.CreateFmt('Property is not readable [%s.%s]', [ARttiType.ToString, PropertyName]);
188 | end;
189 |
190 | class function TRTTIUtils.GetPropertyAsString(Obj: TObject; AProperty: TRttiProperty): string;
191 | var
192 | P: TValue;
193 | FT: string;
194 | CustomFormat: string;
195 | begin
196 | if AProperty.IsReadable then
197 | begin
198 | P := AProperty.GetValue(Obj);
199 | FT := GetFieldType(AProperty);
200 | HasStringValueAttribute(AProperty, CustomFormat);
201 | Result := TValueAsString(P, FT, CustomFormat);
202 | end
203 | else
204 | Result := '';
205 | end;
206 |
207 | class function TRTTIUtils.GetPropertyAsString(Obj: TObject; const PropertyName: string): string;
208 | var
209 | Prop: TRttiProperty;
210 | begin
211 | Prop := ctx.GetType(Obj.ClassType).GetProperty(PropertyName);
212 | if Assigned(Prop) then
213 | Result := GetPropertyAsString(Obj, Prop)
214 | else
215 | Result := '';
216 | end;
217 |
218 | class function TRTTIUtils.GetPropertyType(AObject: TObject; APropertyName: string): string;
219 | begin
220 | Result := GetFieldType(ctx.GetType(AObject.ClassInfo).GetProperty(APropertyName));
221 | end;
222 |
223 | class function TRTTIUtils.HasAttribute(const Obj: TRttiObject): boolean;
224 | begin
225 | Result := Assigned(GetAttribute(Obj));
226 | end;
227 |
228 | class function TRTTIUtils.HasAttribute(ARTTIMember: TRttiMember; out AAttribute: T): boolean;
229 | var
230 | attrs: TArray;
231 | Attr: TCustomAttribute;
232 | begin
233 | AAttribute := nil;
234 | Result := False;
235 | attrs := ARTTIMember.GetAttributes;
236 | for Attr in attrs do
237 | if Attr is T then
238 | begin
239 | AAttribute := T(Attr);
240 | Exit(true);
241 | end;
242 | end;
243 |
244 | class function TRTTIUtils.HasAttribute(ARTTIMember: TRttiType; out AAttribute: T): boolean;
245 | var
246 | attrs: TArray;
247 | Attr: TCustomAttribute;
248 | begin
249 | AAttribute := nil;
250 | Result := False;
251 | attrs := ARTTIMember.GetAttributes;
252 | for Attr in attrs do
253 | if Attr is T then
254 | begin
255 | AAttribute := T(Attr);
256 | Exit(true);
257 | end;
258 |
259 | end;
260 |
261 | class function TRTTIUtils.HasAttribute(const Obj: TRttiObject; out AAttribute: T): boolean;
262 | begin
263 | AAttribute := GetAttribute(Obj);
264 | Result := Assigned(AAttribute);
265 | end;
266 |
267 | class function TRTTIUtils.HasStringValueAttribute(ARTTIMember: TRttiMember; out Value: string): boolean;
268 | var
269 | Attr: T; // StringValueAttribute;
270 | begin
271 | Result := HasAttribute(ARTTIMember, Attr);
272 | if Result then
273 | Value := StringValueAttribute(Attr).Value
274 | else
275 | Value := '';
276 | end;
277 |
278 | class procedure TRTTIUtils.SetField(Obj: TObject; const PropertyName: string; const Value: TValue);
279 | var
280 | Field: TRttiField;
281 | Prop: TRttiProperty;
282 | ARttiType: TRttiType;
283 | begin
284 | ARttiType := ctx.GetType(Obj.ClassType);
285 | if not Assigned(ARttiType) then
286 | raise Exception.CreateFmt('Cannot get RTTI for type [%s]', [ARttiType.ToString]);
287 | Field := ARttiType.GetField(FieldFor(PropertyName));
288 | if Assigned(Field) then
289 | Field.SetValue(Obj, Value)
290 | else
291 | begin
292 | Prop := ARttiType.GetProperty(PropertyName);
293 | if Assigned(Prop) then
294 | begin
295 | if Prop.IsWritable then
296 | Prop.SetValue(Obj, Value)
297 | end
298 | else
299 | raise Exception.CreateFmt('Cannot get RTTI for field or property [%s.%s]', [ARttiType.ToString, PropertyName]);
300 | end;
301 | end;
302 |
303 | class procedure TRTTIUtils.SetProperty(Obj: TObject; const PropertyName: string; const Value: TValue);
304 | var
305 | Prop: TRttiProperty;
306 | ARttiType: TRttiType;
307 | begin
308 | ARttiType := ctx.GetType(Obj.ClassType);
309 | if not Assigned(ARttiType) then
310 | raise Exception.CreateFmt('Cannot get RTTI for type [%s]', [ARttiType.ToString]);
311 | Prop := ARttiType.GetProperty(PropertyName);
312 | if not Assigned(Prop) then
313 | raise Exception.CreateFmt('Cannot get RTTI for property [%s.%s]', [ARttiType.ToString, PropertyName]);
314 | if Prop.IsWritable then
315 | Prop.SetValue(Obj, Value)
316 | else
317 | raise Exception.CreateFmt('Property is not writeable [%s.%s]', [ARttiType.ToString, PropertyName]);
318 | end;
319 |
320 | class function TRTTIUtils.TValueAsString(const Value: TValue; const PropertyType, CustomFormat: string): string;
321 | begin
322 | case Value.Kind of
323 | tkUnknown:
324 | Result := '';
325 | tkInteger:
326 | Result := IntToStr(Value.AsInteger);
327 | tkChar:
328 | Result := Value.AsString;
329 | tkEnumeration:
330 | if PropertyType = 'boolean' then
331 | Result := BoolToStr(Value.AsBoolean, true)
332 | else
333 | Result := '(enumeration)';
334 | tkFloat:
335 | begin
336 | if PropertyType = 'datetime' then
337 | begin
338 | if CustomFormat = '' then
339 | Exit(DateTimeToStr(Value.AsExtended))
340 | else
341 | Exit(FormatDateTime(CustomFormat, Value.AsExtended))
342 | end
343 | else if PropertyType = 'date' then
344 | begin
345 | if CustomFormat = '' then
346 | Exit(DateToStr(Value.AsExtended))
347 | else
348 | Exit(FormatDateTime(CustomFormat, Trunc(Value.AsExtended)))
349 | end
350 | else if PropertyType = 'time' then
351 | begin
352 | if CustomFormat = '' then
353 | Exit(TimeToStr(Value.AsExtended))
354 | else
355 | Exit(FormatDateTime(CustomFormat, Frac(Value.AsExtended)))
356 | end;
357 | if CustomFormat.IsEmpty then
358 | Result := FloatToStr(Value.AsExtended)
359 | else
360 | Result := FormatFloat(CustomFormat, Value.AsExtended);
361 | end;
362 | tkString:
363 | Result := Value.AsString;
364 | tkSet:
365 | ;
366 | tkClass:
367 | Result := Value.AsObject.QualifiedClassName;
368 | tkMethod:
369 | ;
370 | tkWChar:
371 | Result := Value.AsString;
372 |
373 | tkLString:
374 | Result := Value.AsString;
375 |
376 | tkWString:
377 | Result := Value.AsString;
378 |
379 | tkVariant:
380 | Result := string(Value.AsVariant);
381 |
382 | tkArray:
383 | Result := '(array)';
384 | tkRecord:
385 | Result := '(record)';
386 | tkInterface:
387 | Result := '(interface)';
388 |
389 | tkInt64:
390 | Result := IntToStr(Value.AsInt64);
391 |
392 | tkDynArray:
393 | Result := '(array)';
394 |
395 | tkUString:
396 | Result := Value.AsString;
397 | tkClassRef:
398 | Result := '(classref)';
399 |
400 | tkPointer:
401 | Result := '(pointer)';
402 |
403 | tkProcedure:
404 | Result := '(procedure)';
405 | end;
406 | end;
407 |
408 | class function TRTTIUtils.GetFieldType(AProp: TRttiProperty): string;
409 | var
410 | _PropInfo: PTypeInfo;
411 | begin
412 | _PropInfo := AProp.PropertyType.Handle;
413 | if _PropInfo.Kind in [tkString, tkWString, tkChar, tkWChar, tkLString, tkUString] then
414 | Result := 'string'
415 | else if _PropInfo.Kind in [tkInteger, tkInt64] then
416 | Result := 'integer'
417 | else if _PropInfo = TypeInfo(TDate) then
418 | Result := 'date'
419 | else if _PropInfo = TypeInfo(TDateTime) then
420 | Result := 'datetime'
421 | else if _PropInfo = TypeInfo(Currency) then
422 | Result := 'decimal'
423 | else if _PropInfo = TypeInfo(TTime) then
424 | begin
425 | Result := 'time'
426 | end
427 | else if _PropInfo.Kind = tkFloat then
428 | begin
429 | Result := 'float'
430 | end
431 | else if (_PropInfo.Kind = tkEnumeration) { and (_PropInfo.Name = 'Boolean') } then
432 | Result := 'boolean'
433 | else if AProp.PropertyType.IsInstance and AProp.PropertyType.AsInstance.MetaclassType.InheritsFrom(TStream) then
434 | Result := 'blob'
435 | else
436 | Result := EmptyStr;
437 | end;
438 |
439 | class function TRTTIUtils.GetGUID: TGUID;
440 | var
441 | Tp: TRttiType;
442 | begin
443 | Tp := ctx.GetType(TypeInfo(T));
444 | if not (Tp.TypeKind = tkInterface) then
445 | raise Exception.Create('Type is no interface');
446 | Result := TRttiInterfaceType(Tp).GUID;
447 | end;
448 |
449 | class function TRTTIUtils.GetMethod(AObject: TObject; AMethodName: string): TRttiMethod;
450 | var
451 | T: TRttiType;
452 | begin
453 | T := ctx.GetType(AObject.ClassInfo);
454 | Result := T.GetMethod(AMethodName);
455 | end;
456 |
457 | class procedure TRTTIUtils.ObjectToDataSet(Obj: TObject; Field: TField; var Value: Variant);
458 | begin
459 | Value := GetProperty(Obj, Field.FieldName).AsVariant;
460 | end;
461 |
462 | class procedure TRTTIUtils.DatasetToObject(Dataset: TDataset; Obj: TObject);
463 | var
464 | ARttiType: TRttiType;
465 | props: TArray;
466 | Prop: TRttiProperty;
467 | f: TField;
468 | begin
469 | ARttiType := ctx.GetType(Obj.ClassType);
470 | props := ARttiType.GetProperties;
471 | for Prop in props do
472 | if not SameText(Prop.Name, 'ID') then
473 | begin
474 | f := Dataset.FindField(Prop.Name);
475 | if Assigned(f) and not f.ReadOnly then
476 | begin
477 | if f is TIntegerField then
478 | SetProperty(Obj, Prop.Name, TIntegerField(f).Value)
479 | else
480 | SetProperty(Obj, Prop.Name, TValue.From(f.Value))
481 | end;
482 | end;
483 | end;
484 |
485 | class function TRTTIUtils.EqualValues(source, destination: TValue): boolean;
486 | begin
487 | // Really UniCodeCompareStr (Annoying VCL Name for backwards compatablity)
488 | Result := AnsiCompareStr(source.ToString, destination.ToString) = 0;
489 | end;
490 |
491 | class function TRTTIUtils.ExistsProperty(AObject: TObject; const APropertyName: string; out AProperty: TRttiProperty): boolean;
492 | begin
493 | AProperty := ctx.GetType(AObject.ClassInfo).GetProperty(APropertyName);
494 | Result := Assigned(AProperty);
495 | end;
496 |
497 | class function TRTTIUtils.FindByProperty(List: TObjectList; PropertyName: string; PropertyValue: TValue): T;
498 | var
499 | elem: T;
500 | V: TValue;
501 | Found: boolean;
502 | begin
503 | Found := False;
504 | for elem in List do
505 | begin
506 | V := GetProperty(elem, PropertyName);
507 | case V.Kind of
508 | tkInteger:
509 | Found := V.AsInteger = PropertyValue.AsInteger;
510 | tkFloat:
511 | Found := abs(V.AsExtended - PropertyValue.AsExtended) < 0.001;
512 | tkString, tkLString, tkWString, tkUString:
513 | Found := V.AsString = PropertyValue.AsString;
514 | tkInt64:
515 | Found := V.AsInt64 = PropertyValue.AsInt64;
516 | else
517 | raise Exception.Create('Property type not supported');
518 | end;
519 | if Found then
520 | Exit(elem);
521 | end;
522 | Result := nil;
523 | end;
524 |
525 | class function TRTTIUtils.FindType(QualifiedName: string): TRttiType;
526 | begin
527 | Result := ctx.FindType(QualifiedName);
528 | end;
529 |
530 | class procedure TRTTIUtils.ForEachProperty(Clazz: TClass; Proc: TProc);
531 | var
532 | _rtti: TRttiType;
533 | P: TRttiProperty;
534 | begin
535 | _rtti := ctx.GetType(Clazz);
536 | if Assigned(_rtti) then
537 | begin
538 | for P in _rtti.GetProperties do
539 | Proc(P);
540 | end;
541 | end;
542 |
543 | class procedure TRTTIUtils.CopyObject(SourceObj, TargetObj: TObject);
544 | var
545 | _ARttiType: TRttiType;
546 | Field: TRttiField;
547 | master, cloned: TObject;
548 | Src: TObject;
549 | sourceStream: TStream;
550 | SavedPosition: Int64;
551 | targetStream: TStream;
552 | targetCollection: IWrappedList;
553 | sourceCollection: IWrappedList;
554 | I: Integer;
555 | sourceObject: TObject;
556 | targetObject: TObject;
557 | Tar: TObject;
558 | begin
559 | if not Assigned(TargetObj) then
560 | Exit;
561 |
562 | _ARttiType := ctx.GetType(SourceObj.ClassType);
563 | cloned := TargetObj;
564 | master := SourceObj;
565 | for Field in _ARttiType.GetFields do
566 | begin
567 | if not Field.FieldType.IsInstance then
568 | Field.SetValue(cloned, Field.GetValue(master))
569 | else
570 | begin
571 | Src := Field.GetValue(SourceObj).AsObject;
572 | if Src is TStream then
573 | begin
574 | sourceStream := TStream(Src);
575 | SavedPosition := sourceStream.Position;
576 | sourceStream.Position := 0;
577 | if Field.GetValue(cloned).IsEmpty then
578 | begin
579 | targetStream := TMemoryStream.Create;
580 | Field.SetValue(cloned, targetStream);
581 | end
582 | else
583 | targetStream := Field.GetValue(cloned).AsObject as TStream;
584 | targetStream.Position := 0;
585 | targetStream.CopyFrom(sourceStream, sourceStream.Size);
586 | targetStream.Position := SavedPosition;
587 | sourceStream.Position := SavedPosition;
588 | end
589 | else if TDuckTypedList.CanBeWrappedAsList(Src) then
590 | begin
591 | sourceCollection := WrapAsList(Src);
592 | Tar := Field.GetValue(cloned).AsObject;
593 | if Assigned(Tar) then
594 | begin
595 | targetCollection := WrapAsList(Tar);
596 | targetCollection.Clear;
597 | for I := 0 to sourceCollection.Count - 1 do
598 | targetCollection.Add(TRTTIUtils.Clone(sourceCollection.GetItem(I)));
599 | end;
600 | end
601 | else
602 | begin
603 | sourceObject := Src;
604 |
605 | if Field.GetValue(cloned).IsEmpty then
606 | begin
607 | targetObject := TRTTIUtils.Clone(sourceObject);
608 | Field.SetValue(cloned, targetObject);
609 | end
610 | else
611 | begin
612 | targetObject := Field.GetValue(cloned).AsObject;
613 | TRTTIUtils.CopyObject(sourceObject, targetObject);
614 | end;
615 | end;
616 | end;
617 | end;
618 | end;
619 |
620 | {$IF CompilerVersion >= 24.0}
621 |
622 | class procedure TRTTIUtils.CopyObjectAS(SourceObj, TargetObj: TObject);
623 | var
624 | _ARttiType: TRttiType;
625 | _ARttiTypeTarget: TRttiType;
626 | Field, FieldDest: TRttiField;
627 | master, cloned: TObject;
628 | Src: TObject;
629 | sourceStream: TStream;
630 | SavedPosition: Int64;
631 | targetStream: TStream;
632 | targetCollection: IWrappedList;
633 | sourceCollection: IWrappedList;
634 | I: Integer;
635 | sourceObject: TObject;
636 | targetObject: TObject;
637 | Tar: TObject;
638 | begin
639 | if not Assigned(TargetObj) then
640 | Exit;
641 |
642 | _ARttiType := ctx.GetType(SourceObj.ClassType);
643 | _ARttiTypeTarget := ctx.GetType(TargetObj.ClassType);
644 |
645 | cloned := TargetObj;
646 | master := SourceObj;
647 | for Field in _ARttiType.GetFields do
648 | begin
649 | FieldDest := _ARttiTypeTarget.GetField(Field.Name);
650 | if not Assigned(FieldDest) then
651 | continue;
652 | if not Field.FieldType.IsInstance then
653 | begin
654 | FieldDest.SetValue(cloned, Field.GetValue(master));
655 | end
656 | else
657 | begin
658 | Src := Field.GetValue(SourceObj).AsObject;
659 | if not Assigned(Src) then
660 | begin
661 | FieldDest.SetValue(cloned, Src);
662 |
663 | end
664 | else if Src is TStream then
665 | begin
666 | sourceStream := TStream(Src);
667 | SavedPosition := sourceStream.Position;
668 | sourceStream.Position := 0;
669 | if FieldDest.GetValue(cloned).IsEmpty then
670 | begin
671 | targetStream := TMemoryStream.Create;
672 | FieldDest.SetValue(cloned, targetStream);
673 | end
674 | else
675 | targetStream := FieldDest.GetValue(cloned).AsObject as TStream;
676 | targetStream.Position := 0;
677 | targetStream.CopyFrom(sourceStream, sourceStream.Size);
678 | targetStream.Position := SavedPosition;
679 | sourceStream.Position := SavedPosition;
680 | end
681 | else if TDuckTypedList.CanBeWrappedAsList(Src) then
682 | begin
683 | sourceCollection := WrapAsList(Src);
684 | Tar := FieldDest.GetValue(cloned).AsObject;
685 | if Assigned(Tar) then
686 | begin
687 | targetCollection := WrapAsList(Tar);
688 | targetCollection.Clear;
689 | for I := 0 to sourceCollection.Count - 1 do
690 | targetCollection.Add(TRTTIUtils.Clone(sourceCollection.GetItem(I)));
691 | end;
692 | end
693 | else
694 | begin
695 | sourceObject := Src;
696 |
697 | if FieldDest.GetValue(cloned).IsEmpty then
698 | begin
699 | targetObject := TRTTIUtils.Clone(sourceObject);
700 | FieldDest.SetValue(cloned, targetObject);
701 | end
702 | else
703 | begin
704 | targetObject := FieldDest.GetValue(cloned).AsObject;
705 | TRTTIUtils.CopyObject(sourceObject, targetObject);
706 | end;
707 | end;
708 | end;
709 | end;
710 | end;
711 | {$IFEND}
712 |
713 | class function TRTTIUtils.CreateObject(AQualifiedClassName: string): TObject;
714 | var
715 | rttitype: TRttiType;
716 | begin
717 | rttitype := ctx.FindType(AQualifiedClassName);
718 | if Assigned(rttitype) then
719 | Result := CreateObject(rttitype)
720 | else
721 | raise Exception.Create('Cannot find RTTI for ' + AQualifiedClassName + '. Hint: Is the specified classtype linked in the module?');
722 | end;
723 |
724 | class function TRTTIUtils.CreateObject(ARttiType: TRttiType): TObject;
725 | var
726 | Method: TRttiMethod;
727 | metaClass: TClass;
728 | begin
729 | { First solution, clear and slow }
730 | metaClass := nil;
731 | Method := nil;
732 | for Method in ARttiType.GetMethods do
733 | if Method.HasExtendedInfo and Method.IsConstructor then
734 | if Length(Method.GetParameters) = 0 then
735 | begin
736 | metaClass := ARttiType.AsInstance.MetaclassType;
737 | Break;
738 | end;
739 | if Assigned(metaClass) then
740 | Result := Method.Invoke(metaClass, []).AsObject
741 | else
742 | raise Exception.Create('Cannot find a propert constructor for ' + ARttiType.ToString);
743 |
744 | { Second solution, dirty and fast }
745 | // Result := TObject(ARttiType.GetMethod('Create')
746 | // .Invoke(ARttiType.AsInstance.MetaclassType, []).AsObject);
747 | end;
748 |
749 | class function TRTTIUtils.BuildClass(AQualifiedName: string; Params: array of TValue): TObject;
750 | var
751 | T: TRttiType;
752 | V: TValue;
753 | begin
754 |
755 | T := FindType(AQualifiedName);
756 | V := T.GetMethod('Create').Invoke(T.AsInstance.MetaclassType, Params);
757 | Result := V.AsObject;
758 | end;
759 |
760 | class function TRTTIUtils.Clone(Obj: TObject): TObject;
761 | var
762 | _ARttiType: TRttiType;
763 | Field: TRttiField;
764 | master, cloned: TObject;
765 | Src: TObject;
766 | sourceStream: TStream;
767 | SavedPosition: Int64;
768 | targetStream: TStream;
769 | targetCollection: TObjectList;
770 | sourceCollection: TObjectList;
771 | I: Integer;
772 | sourceObject: TObject;
773 | targetObject: TObject;
774 | begin
775 | Result := nil;
776 | if not Assigned(Obj) then
777 | Exit;
778 |
779 | _ARttiType := ctx.GetType(Obj.ClassType);
780 | cloned := CreateObject(_ARttiType);
781 | master := Obj;
782 | for Field in _ARttiType.GetFields do
783 | begin
784 | if not Field.FieldType.IsInstance then
785 | Field.SetValue(cloned, Field.GetValue(master))
786 | else
787 | begin
788 | Src := Field.GetValue(Obj).AsObject;
789 | if Src is TStream then
790 | begin
791 | sourceStream := TStream(Src);
792 | SavedPosition := sourceStream.Position;
793 | sourceStream.Position := 0;
794 | if Field.GetValue(cloned).IsEmpty then
795 | begin
796 | targetStream := TMemoryStream.Create;
797 | Field.SetValue(cloned, targetStream);
798 | end
799 | else
800 | targetStream := Field.GetValue(cloned).AsObject as TStream;
801 | targetStream.Position := 0;
802 | targetStream.CopyFrom(sourceStream, sourceStream.Size);
803 | targetStream.Position := SavedPosition;
804 | sourceStream.Position := SavedPosition;
805 | end
806 | else if Src is TObjectList then
807 | begin
808 | sourceCollection := TObjectList(Src);
809 | if Field.GetValue(cloned).IsEmpty then
810 | begin
811 | targetCollection := TObjectList.Create;
812 | Field.SetValue(cloned, targetCollection);
813 | end
814 | else
815 | targetCollection := Field.GetValue(cloned).AsObject as TObjectList;
816 | for I := 0 to sourceCollection.Count - 1 do
817 | begin
818 | targetCollection.Add(TRTTIUtils.Clone(sourceCollection[I]));
819 | end;
820 | end
821 | else
822 | begin
823 | sourceObject := Src;
824 |
825 | if Field.GetValue(cloned).IsEmpty then
826 | begin
827 | targetObject := TRTTIUtils.Clone(sourceObject);
828 | Field.SetValue(cloned, targetObject);
829 | end
830 | else
831 | begin
832 | targetObject := Field.GetValue(cloned).AsObject;
833 | TRTTIUtils.CopyObject(sourceObject, targetObject);
834 | end;
835 | Field.SetValue(cloned, targetObject);
836 | end;
837 | end;
838 |
839 | end;
840 | Result := cloned;
841 | end;
842 |
843 | { TListDuckTyping }
844 |
845 | class function TRTTIUtils.HasAttribute(aObj: TObject; out AAttribute: T): boolean;
846 | begin
847 | Result := HasAttribute(ctx.GetType(aObj.ClassType), AAttribute)
848 | end;
849 |
850 | end.
851 |
--------------------------------------------------------------------------------
/src/Router4D.Helper.pas:
--------------------------------------------------------------------------------
1 | unit Router4D.Helper;
2 |
3 | interface
4 |
5 | uses
6 | System.Classes,
7 | Vcl.ExtCtrls,
8 | Vcl.Forms,
9 | Vcl.Controls;
10 |
11 | type
12 | TRouter4DHelper = class helper for TPanel
13 | public
14 | procedure RemoveObject; overload;
15 | procedure AddObject(AValue: TForm);
16 | end;
17 |
18 | implementation
19 |
20 | procedure TRouter4DHelper.AddObject(AValue: TForm);
21 | begin
22 | AValue.Parent := Self;
23 | AValue.Show;
24 | end;
25 |
26 | procedure TRouter4DHelper.RemoveObject;
27 | var
28 | lIndex: Integer;
29 | begin
30 | for lIndex := Self.ControlCount - 1 downto 0 do
31 | begin
32 | if (Self.Controls[lIndex] is TForm) then
33 | begin
34 | (Self.Controls[lIndex] as TForm).Close;
35 | (Self.Controls[lIndex] as TForm).parent := nil;
36 | end;
37 | end;
38 | end;
39 |
40 | end.
41 |
--------------------------------------------------------------------------------
/src/Router4D.History.pas:
--------------------------------------------------------------------------------
1 | unit Router4D.History;
2 |
3 | {$I Router4D.inc}
4 |
5 | interface
6 |
7 | uses
8 | Classes,
9 | SysUtils,
10 | {$IFDEF HAS_FMX}
11 | FMX.Forms,
12 | FMX.Types,
13 | {$ELSE}
14 | Vcl.Forms,
15 | Vcl.ExtCtrls,
16 | {$ENDIF}
17 | System.Generics.Collections,
18 | Router4D.Interfaces,
19 | Router4D.Props;
20 |
21 | type
22 | TCachePersistent = record
23 | FPatch : String;
24 | FisVisible : Boolean;
25 | FSBKey : String;
26 | FPersistentClass : TPersistentClass;
27 | end;
28 |
29 | TRouter4DHistory = class
30 | private
31 | FListCache : TObjectDictionary;
32 | {$IFDEF HAS_FMX}
33 | FListCacheContainer : TObjectDictionary;
34 | FMainRouter : TFMXObject;
35 | FIndexRouter : TFMXObject;
36 | {$ELSE}
37 | FListCacheContainer : TObjectDictionary;
38 | FMainRouter : TPanel;
39 | FIndexRouter : TPanel;
40 | {$ENDIF}
41 | FListCache2 : TDictionary;
42 | FInstanteObject : iRouter4DComponent;
43 | FListCacheOrder : TList;
44 | FIndexCache : Integer;
45 | FMaxCacheHistory : Integer;
46 | const MAX_FRAME_COUNT = 25;
47 | procedure CreateInstancePersistent( aPath : String);
48 | //procedure CacheKeyNotify(Sender: TObject; const Key: string; Action: TCollectionNotification);
49 | public
50 | constructor Create;
51 | destructor Destroy; override;
52 | {$IFDEF HAS_FMX}
53 | function MainRouter ( aValue : TFMXObject ) : TRouter4DHistory; overload;
54 | function MainRouter : TFMXObject; overload;
55 | function IndexRouter ( aValue : TFMXObject ) : TRouter4DHistory; overload;
56 | function IndexRouter : TFMXObject; overload;
57 | function AddHistoryConteiner ( aKey : String; aObject : TFMXObject) : TRouter4DHistory; overload;
58 | function GetHistoryContainer ( aKey : String ) : TFMXObject;
59 | function GetRouter : String;
60 | function PreviousRouter : String;
61 | {$ELSE}
62 | function MainRouter ( aValue : TPanel ) : TRouter4DHistory; overload;
63 | function MainRouter : TPanel; overload;
64 | function IndexRouter ( aValue : TPanel ) : TRouter4DHistory; overload;
65 | function IndexRouter : TPanel; overload;
66 | function AddHistoryConteiner ( aKey : String; aObject : TPanel) : TRouter4DHistory; overload;
67 | function GetHistoryContainer ( aKey : String ) : TPanel;
68 | {$ENDIF}
69 | function AddHistory ( aKey : String; aObject : TObject ) : iRouter4DComponent; overload;
70 | function AddHistory ( aKey : String; aObject : TPersistentClass ) : iRouter4DComponent; overload;
71 | function AddHistory ( aKey : String; aObject : TPersistentClass; aSBKey : String; isVisible : Boolean ) : iRouter4DComponent; overload;
72 | function RemoveHistory ( aKey : String ) : TRouter4DHistory;
73 | function GetHistory ( aKey : String ) : iRouter4DComponent;
74 | function RoutersList : TDictionary;
75 | function RoutersListPersistent : TDictionary;
76 | function InstanteObject : iRouter4DComponent;
77 | function GoBack : String;
78 | function BreadCrumb(aDelimiter: char = '/') : String;
79 | function addCacheHistory(aKey : String) : TRouter4DHistory;
80 | function IndexCache : Integer;
81 | end;
82 |
83 | var
84 | Router4DHistory : TRouter4DHistory;
85 |
86 | implementation
87 |
88 | { TRouter4DHistory }
89 |
90 | {$IFDEF HAS_FMX}
91 | function TRouter4DHistory.MainRouter(aValue: TFMXObject): TRouter4DHistory;
92 | begin
93 | Result := Self;
94 | FMainRouter := aValue;
95 | end;
96 |
97 | function TRouter4DHistory.MainRouter: TFMXObject;
98 | begin
99 | Result := FMainRouter;
100 | end;
101 |
102 | function TRouter4DHistory.IndexRouter(aValue: TFMXObject): TRouter4DHistory;
103 | begin
104 | Result := Self;
105 | FIndexRouter := aValue;
106 | end;
107 |
108 | function TRouter4DHistory.IndexRouter: TFMXObject;
109 | begin
110 | Result := FIndexRouter;
111 | end;
112 |
113 | function TRouter4DHistory.AddHistoryConteiner( aKey : String; aObject : TFMXObject) : TRouter4DHistory;
114 | var
115 | auxObject : TFMXObject;
116 | begin
117 | Result := Self;
118 | if not FListCacheContainer.TryGetValue(aKey, auxObject) then
119 | FListCacheContainer.Add(aKey, aObject);
120 | end;
121 |
122 | function TRouter4DHistory.GetHistoryContainer(aKey: String): TFMXObject;
123 | begin
124 | FListCacheContainer.TryGetValue(aKey, Result);
125 | end;
126 |
127 | function TRouter4DHistory.PreviousRouter: String;
128 | begin
129 | Result := Self.FListCacheOrder[Self.FIndexCache - 1];
130 | end;
131 |
132 | function TRouter4DHistory.GetRouter: String;
133 | begin
134 | Result := Self.FListCacheOrder[Self.FIndexCache];
135 | end;
136 | {$ELSE}
137 | function TRouter4DHistory.MainRouter(aValue: TPanel): TRouter4DHistory;
138 | begin
139 | Result := Self;
140 | FMainRouter := aValue;
141 | end;
142 |
143 | function TRouter4DHistory.MainRouter: TPanel;
144 | begin
145 | Result := FMainRouter;
146 | end;
147 |
148 | function TRouter4DHistory.IndexRouter(aValue: TPanel): TRouter4DHistory;
149 | begin
150 | Result := Self;
151 | FIndexRouter := aValue;
152 | end;
153 |
154 | function TRouter4DHistory.IndexRouter: TPanel;
155 | begin
156 | Result := FIndexRouter;
157 | end;
158 |
159 | function TRouter4DHistory.AddHistoryConteiner( aKey : String; aObject : TPanel) : TRouter4DHistory;
160 | var
161 | auxObject : TPanel;
162 | begin
163 | Result := Self;
164 | if not FListCacheContainer.TryGetValue(aKey, auxObject) then
165 | FListCacheContainer.Add(aKey, aObject);
166 | end;
167 |
168 | function TRouter4DHistory.GetHistoryContainer(aKey: String): TPanel;
169 | begin
170 | FListCacheContainer.TryGetValue(aKey, Result);
171 | end;
172 |
173 | {$ENDIF}
174 |
175 | function TRouter4DHistory.IndexCache: Integer;
176 | begin
177 | Result := Self.FIndexCache;
178 | end;
179 |
180 | function TRouter4DHistory.BreadCrumb(aDelimiter: char): String;
181 | var
182 | i : integer;
183 | begin
184 | Result := '';
185 |
186 | if Self.FIndexCache = -1 then
187 | Exit;
188 |
189 | Result := Self.FListCacheOrder[Self.FIndexCache];
190 |
191 | for i := Self.FIndexCache-1 downto 0 do
192 | begin
193 | Result := Self.FListCacheOrder[i] + ADelimiter + Result;
194 | end;
195 | end;
196 |
197 | function TRouter4DHistory.GoBack: String;
198 | begin
199 | if Self.FIndexCache > 0 then
200 | Dec(Self.FIndexCache);
201 |
202 | Result := Self.FListCacheOrder[Self.FIndexCache];
203 | end;
204 |
205 | function TRouter4DHistory.AddHistory( aKey : String; aObject : TObject ) : iRouter4DComponent;
206 | var
207 | mKey : String;
208 | vObject : TObject;
209 | begin
210 | if not Supports(aObject, iRouter4DComponent, Result) then
211 | raise Exception.Create('Form not Implement iRouter4DelphiComponent Interface');
212 |
213 | try GlobalEventBus.RegisterSubscriber(aObject); except end;
214 |
215 | if FListCache.Count > MAX_FRAME_COUNT then
216 | for mKey in FListCache.Keys do
217 | begin
218 | FListCache.Remove(mKey);
219 | Break;
220 | end;
221 |
222 |
223 | if not FListCache.TryGetValue(aKey, vObject) then
224 | FListCache.Add(aKey, aObject);
225 |
226 | end;
227 |
228 | function TRouter4DHistory.AddHistory(aKey: String;
229 | aObject: TPersistentClass): iRouter4DComponent;
230 | var
231 | CachePersistent : TCachePersistent;
232 | vPesersistentClass : TCachePersistent;
233 | begin
234 | CachePersistent.FPatch := aKey;
235 | CachePersistent.FisVisible := True;
236 | CachePersistent.FPersistentClass := aObject;
237 | CachePersistent.FSBKey := 'SBIndex';
238 |
239 | if not FListCache2.TryGetValue(aKey, vPesersistentClass) then
240 | FListCache2.Add(aKey, CachePersistent);
241 | end;
242 |
243 | function TRouter4DHistory.addCacheHistory(aKey: String): TRouter4DHistory;
244 | var
245 | I: Integer;
246 | begin
247 | Result := Self;
248 | for I := Pred(FListCacheOrder.Count) downto Succ(FIndexCache) do
249 | FListCacheOrder.Delete(I);
250 |
251 | if FListCacheOrder.Count > FMaxCacheHistory then
252 | FListCacheOrder.Delete(0);
253 |
254 | FListCacheOrder.Add(aKey);
255 | FIndexCache := Pred(FListCacheOrder.Count);
256 | end;
257 |
258 | function TRouter4DHistory.AddHistory(aKey: String; aObject: TPersistentClass;
259 | aSBKey : String; isVisible: Boolean): iRouter4DComponent;
260 | var
261 | CachePersistent : TCachePersistent;
262 | vPesersistentClass : TCachePersistent;
263 | begin
264 | CachePersistent.FPatch := aKey;
265 | CachePersistent.FisVisible := isVisible;
266 | CachePersistent.FPersistentClass := aObject;
267 | CachePersistent.FSBKey := aSBKey;
268 |
269 | if not FListCache2.TryGetValue(aKey, vPesersistentClass) then
270 | FListCache2.Add(aKey, CachePersistent);
271 | end;
272 |
273 | constructor TRouter4DHistory.Create;
274 | begin
275 | FListCache := TObjectDictionary.Create;
276 | FListCache2 := TDictionary.Create;
277 | FListCacheOrder := TList.Create;
278 | FMaxCacheHistory := 10;
279 | {$IFDEF HAS_FMX}
280 | FListCacheContainer := TObjectDictionary.Create;
281 | {$ELSE}
282 | FListCacheContainer := TObjectDictionary.Create;
283 | {$ENDIF}
284 | end;
285 |
286 | procedure TRouter4DHistory.CreateInstancePersistent( aPath : String);
287 | var
288 | aPersistentClass : TCachePersistent;
289 | begin
290 | if not FListCache2.TryGetValue(aPath, aPersistentClass) then
291 | raise Exception.Create('Not Register Router ' + aPath);
292 |
293 | Self.AddHistory(
294 | aPath,
295 | TComponentClass(
296 | FindClass(
297 | aPersistentClass
298 | .FPersistentClass
299 | .ClassName
300 | )
301 | ).Create(Application)
302 | );
303 | end;
304 |
305 | destructor TRouter4DHistory.Destroy;
306 | begin
307 | FListCache.Free;
308 | FListCache2.Free;
309 | FListCacheContainer.Free;
310 | FListCacheOrder.Free;
311 | inherited;
312 | end;
313 |
314 | function TRouter4DHistory.GetHistory(aKey: String): iRouter4DComponent;
315 | var
316 | aObject : TObject;
317 | begin
318 |
319 | if not FListCache.TryGetValue(aKey, aObject) then
320 | Self.CreateInstancePersistent(aKey);
321 |
322 | if not Supports(FListCache.Items[aKey], iRouter4DComponent, Result) then
323 | raise Exception.Create('Object not Implements Interface Component');
324 |
325 | FInstanteObject := Result;
326 | end;
327 |
328 | function TRouter4DHistory.InstanteObject: iRouter4DComponent;
329 | begin
330 | Result := FInstanteObject;
331 | end;
332 |
333 | function TRouter4DHistory.RemoveHistory(aKey: String): TRouter4DHistory;
334 | begin
335 | Result := Self;
336 | FListCache.Remove(aKey);
337 | end;
338 |
339 | function TRouter4DHistory.RoutersList: TDictionary;
340 | begin
341 | Result := FListCache;
342 | end;
343 |
344 | function TRouter4DHistory.RoutersListPersistent: TDictionary;
345 | begin
346 | Result := FListCache2;
347 | end;
348 |
349 | initialization
350 | Router4DHistory := TRouter4DHistory.Create;
351 |
352 | finalization
353 | Router4DHistory.Free;
354 | end.
355 |
--------------------------------------------------------------------------------
/src/Router4D.Interfaces.pas:
--------------------------------------------------------------------------------
1 | unit Router4D.Interfaces;
2 |
3 | {$I Router4D.inc}
4 |
5 | interface
6 |
7 | uses
8 | System.Classes,
9 | System.Generics.Collections,
10 | System.UITypes,
11 | SysUtils,
12 | {$IFDEF HAS_FMX}
13 | FMX.Types,
14 | {$ELSE}
15 | Vcl.ExtCtrls,
16 | Vcl.Forms,
17 | {$ENDIF}
18 | Router4D.Props;
19 |
20 | type
21 |
22 | iRouter4D = interface
23 | ['{56BF88E9-25AB-49C7-8CB2-F89C95F34816}']
24 | end;
25 |
26 | iRouter4DComponent = interface
27 | ['{C605AEFB-36DC-4952-A3D9-BA372B998BC3}']
28 | {$IFDEF HAS_FMX}
29 | function Render : TFMXObject;
30 | {$ElSE}
31 | function Render : TForm;
32 | {$ENDIF}
33 | procedure UnRender;
34 | end;
35 |
36 | iRouter4DComponentProps = interface
37 | ['{FAF5DD55-924F-4A8B-A436-208891FFE30A}']
38 | procedure Props ( aProps : TProps );
39 | end;
40 |
41 | iRouter4DLink = interface
42 | ['{3C80F86A-D6B8-470C-A30E-A82E620F6F1D}']
43 | {$IFDEF HAS_FMX}
44 | function &To ( aPatch : String; aComponent : TFMXObject ) : iRouter4DLink; overload;
45 | function &To ( aPatch : String; aProps : TProps; aComponent : TFMXObject ) : iRouter4DLink; overload;
46 | function Animation ( aAnimation : TProc ) : iRouter4DLink;
47 | {$ELSE}
48 | function &To ( aPatch : String; aComponent : TPanel ) : iRouter4DLink; overload;
49 | function &To ( aPatch : String; aProps : TProps; aComponent : TPanel ) : iRouter4DLink; overload;
50 | function Animation ( aAnimation : TProc ) : iRouter4DLink;
51 | {$ENDIF}
52 | function &To ( aPatch : String) : iRouter4DLink; overload;
53 | function &To ( aPatch : String; aProps : TProps; aKey : String = '') : iRouter4DLink; overload;
54 | function &To ( aPatch : String; aNameContainer : String) : iRouter4DLink; overload;
55 | function IndexLink ( aPatch : String ) : iRouter4DLink;
56 | function GoBack : iRouter4DLink;
57 | end;
58 |
59 | iRouter4DRender = interface
60 | ['{2BD026ED-3A92-44E9-8CD4-38E80CB2F000}']
61 | {$IFDEF HAS_FMX}
62 | function SetElement ( aComponent : TFMXObject; aIndexComponent : TFMXObject = nil ) : iRouter4DRender;
63 | {$ELSE}
64 | function SetElement ( aComponent : TPanel; aIndexComponent : TPanel = nil ) : iRouter4DRender;
65 | {$ENDIF}
66 | end;
67 |
68 | iRouter4DSwitch = interface
69 | ['{0E49AFE7-9329-4F0C-B289-A713FA3DFE45}']
70 | function Router(aPath : String; aRouter : TPersistentClass; aSidebarKey : String = 'SBIndex'; isVisible : Boolean = True) : iRouter4DSwitch;
71 | function UnRouter(aPath : String) : iRouter4DSwitch;
72 | end;
73 |
74 | iRouter4DSidebar = interface
75 | ['{B4E8C229-A801-4FCA-AF7B-DEF8D0EE5DFE}']
76 | function Name ( aValue : String ) : iRouter4DSidebar; overload;
77 | {$IFDEF HAS_FMX}
78 | function MainContainer ( aValue : TFMXObject ) : iRouter4DSidebar; overload;
79 | function MainContainer : TFMXObject; overload;
80 | function LinkContainer ( aValue : TFMXObject ) : iRouter4DSidebar;
81 | function Animation ( aAnimation : TProc ) : iRouter4DSidebar;
82 | function RenderToListBox : iRouter4DSidebar;
83 | {$ELSE}
84 | function MainContainer ( aValue : TPanel ) : iRouter4DSidebar; overload;
85 | function MainContainer : TPanel; overload;
86 | function LinkContainer ( aValue : TPanel ) : iRouter4DSidebar;
87 | function Animation ( aAnimation : TProc ) : iRouter4DSidebar;
88 | {$ENDIF}
89 | function Name : String; overload;
90 | function FontSize ( aValue : Integer ) : iRouter4DSidebar;
91 | function FontColor ( aValue : TAlphaColor ) : iRouter4DSidebar;
92 | function ItemHeigth ( aValue : Integer ) : iRouter4DSidebar;
93 |
94 | end;
95 |
96 | implementation
97 |
98 | end.
99 |
--------------------------------------------------------------------------------
/src/Router4D.Link.pas:
--------------------------------------------------------------------------------
1 | unit Router4D.Link;
2 |
3 | {$I Router4D.inc}
4 |
5 | interface
6 |
7 | uses
8 | {$IFDEF HAS_FMX}
9 | FMX.Types,
10 | FMX.Layouts,
11 | {$ELSE}
12 | Vcl.ExtCtrls,
13 | Router4D.Helper,
14 | {$ENDIF}
15 | SysUtils,
16 | Router4D.Interfaces,
17 | Router4D.Props;
18 |
19 | type
20 | TRouter4DLink = class(TInterfacedObject, iRouter4DLink)
21 | private
22 | {$IFDEF HAS_FMX}
23 | FAnimation : TProc;
24 | {$ELSE}
25 | FAnimation : TProc;
26 | {$ENDIF}
27 | public
28 | constructor Create;
29 | destructor Destroy; override;
30 | class function New : iRouter4DLink;
31 | {$IFDEF HAS_FMX}
32 | function Animation ( aAnimation : TProc ) : iRouter4DLink;
33 | function &To ( aPatch : String; aComponent : TFMXObject ) : iRouter4DLink; overload;
34 | function &To ( aPatch : String; aProps: TProps; aComponent : TFMXObject ) : iRouter4DLink; overload;
35 | {$ELSE}
36 | function Animation ( aAnimation : TProc ) : iRouter4DLink;
37 | function &To ( aPatch : String; aComponent : TPanel ) : iRouter4DLink; overload;
38 | function &To ( aPatch : String; aProps : TProps; aComponent : TPanel ) : iRouter4DLink; overload;
39 | {$ENDIF}
40 | function &To ( aPatch : String) : iRouter4DLink; overload;
41 | function &To ( aPatch : String; aProps : TProps; aKey : String = '') : iRouter4DLink; overload;
42 | function &To ( aPatch : String; aNameContainer : String) : iRouter4DLink; overload;
43 | function GoBack : iRouter4DLink;
44 | function IndexLink ( aPatch : String ) : iRouter4DLink;
45 | end;
46 |
47 | var
48 | Router4DLink : iRouter4DLink;
49 |
50 | implementation
51 |
52 | { TRouter4DLink }
53 |
54 |
55 | uses Router4D.History;
56 |
57 | {$IFDEF HAS_FMX}
58 | function TRouter4DLink.Animation(aAnimation: TProc): iRouter4DLink;
59 | begin
60 | Result := Self;
61 | FAnimation := aAnimation;
62 | end;
63 |
64 | function TRouter4DLink.&To( aPatch : String; aComponent : TFMXObject ) : iRouter4DLink;
65 | begin
66 | Result := Self;
67 | aComponent.RemoveObject(0);
68 | Router4DHistory.InstanteObject.UnRender;
69 | aComponent
70 | .AddObject(
71 | Router4DHistory
72 | .addCacheHistory(aPatch)
73 | .GetHistory(aPatch)
74 | .Render
75 | );
76 | end;
77 |
78 | function TRouter4DLink.&To( aPatch : String; aProps: TProps; aComponent : TFMXObject ) : iRouter4DLink;
79 | begin
80 | Result := Self;
81 | aComponent.RemoveObject(0);
82 | Router4DHistory.InstanteObject.UnRender;
83 | aComponent
84 | .AddObject(
85 | Router4DHistory
86 | .addCacheHistory(aPatch)
87 | .GetHistory(aPatch)
88 | .Render
89 | );
90 |
91 | GlobalEventBus.Post(aProps);
92 | end;
93 | {$ELSE}
94 | function TRouter4DLink.Animation(aAnimation: TProc): iRouter4DLink;
95 | begin
96 | Result := Self;
97 | FAnimation := aAnimation;
98 | end;
99 |
100 | function TRouter4DLink.&To( aPatch : String; aComponent : TPanel ) : iRouter4DLink;
101 | begin
102 | Result := Self;
103 | aComponent.RemoveObject;
104 | Router4DHistory.InstanteObject.UnRender;
105 | aComponent
106 | .AddObject(
107 | Router4DHistory
108 | .addCacheHistory(aPatch)
109 | .GetHistory(aPatch)
110 | .Render
111 | );
112 | end;
113 |
114 | function TRouter4DLink.&To( aPatch : String; aProps: TProps; aComponent : TPanel ) : iRouter4DLink;
115 | begin
116 | Result := Self;
117 | aComponent.RemoveObject;
118 | Router4DHistory.InstanteObject.UnRender;
119 | aComponent
120 | .AddObject(
121 | Router4DHistory
122 | .addCacheHistory(aPatch)
123 | .GetHistory(aPatch)
124 | .Render
125 | );
126 |
127 | GlobalEventBus.Post(aProps);
128 | end;
129 | {$ENDIF}
130 |
131 | function TRouter4DLink.&To(aPatch, aNameContainer: String): iRouter4DLink;
132 | var
133 | {$IFDEF HAS_FMX}
134 | aContainer : TFMXObject;
135 | {$ELSE}
136 | aContainer : TPanel;
137 | {$ENDIF}
138 | begin
139 | Result := Self;
140 | Router4DHistory.InstanteObject.UnRender;
141 | aContainer := Router4DHistory.GetHistoryContainer(aNameContainer);
142 | {$IFDEF HAS_FMX}
143 | aContainer.RemoveObject(0);
144 | {$ELSE}
145 | aContainer.RemoveObject;
146 | {$ENDIF}
147 |
148 | aContainer
149 | .AddObject(
150 | Router4DHistory
151 | .addCacheHistory(aPatch)
152 | .GetHistory(aPatch)
153 | .Render
154 | );
155 |
156 | if Assigned(FAnimation) then
157 | FAnimation(aContainer);
158 |
159 | end;
160 |
161 | constructor TRouter4DLink.Create;
162 | begin
163 |
164 | end;
165 |
166 | destructor TRouter4DLink.Destroy;
167 | begin
168 |
169 | inherited;
170 | end;
171 |
172 | function TRouter4DLink.GoBack : iRouter4DLink;
173 | begin
174 | Result := Self;
175 | {$IFDEF HAS_FMX}
176 | Router4DHistory.MainRouter.RemoveObject(0);
177 | {$ELSE}
178 | Router4DHistory.MainRouter.RemoveObject;
179 | {$ENDIF}
180 | Router4DHistory.InstanteObject.UnRender;
181 | Router4DHistory
182 | .MainRouter
183 | .AddObject(
184 | Router4DHistory
185 | .GetHistory(Router4DHistory.GoBack)
186 | .Render
187 | );
188 |
189 | if Assigned(FAnimation) then
190 | FAnimation(Router4DHistory.MainRouter);
191 | end;
192 | function TRouter4DLink.IndexLink(aPatch: String): iRouter4DLink;
193 | begin
194 | Result := Self;
195 | {$IFDEF HAS_FMX}
196 | Router4DHistory.IndexRouter.RemoveObject(0);
197 | {$ELSE}
198 | Router4DHistory.IndexRouter.RemoveObject;
199 | {$ENDIF}
200 | Router4DHistory.InstanteObject.UnRender;
201 | Router4DHistory
202 | .IndexRouter
203 | .AddObject(
204 | Router4DHistory
205 | .GetHistory(aPatch)
206 | .Render
207 | );
208 |
209 | if Assigned(FAnimation) then
210 | FAnimation(Router4DHistory.IndexRouter);
211 |
212 | end;
213 |
214 | function TRouter4DLink.&To(aPatch: String) : iRouter4DLink;
215 | begin
216 | Result := Self;
217 | {$IFDEF HAS_FMX}
218 | Router4DHistory.MainRouter.RemoveObject(0);
219 | {$ELSE}
220 | Router4DHistory.MainRouter.RemoveObject;
221 | {$ENDIF}
222 | Router4DHistory.InstanteObject.UnRender;
223 | Router4DHistory
224 | .MainRouter
225 | .AddObject(
226 | Router4DHistory
227 | .addCacheHistory(aPatch)
228 | .GetHistory(aPatch)
229 | .Render
230 | );
231 |
232 | if Assigned(FAnimation) then
233 | FAnimation(Router4DHistory.MainRouter);
234 |
235 | end;
236 |
237 | function TRouter4DLink.&To(aPatch: String; aProps: TProps; aKey : String = '') : iRouter4DLink;
238 | begin
239 | Result := Self;
240 | {$IFDEF HAS_FMX}
241 | Router4DHistory.MainRouter.RemoveObject(0);
242 | {$ELSE}
243 | Router4DHistory.MainRouter.RemoveObject;
244 | {$ENDIF}
245 | Router4DHistory.InstanteObject.UnRender;
246 | Router4DHistory
247 | .MainRouter
248 | .AddObject(
249 | Router4DHistory
250 | .addCacheHistory(aPatch)
251 | .GetHistory(aPatch)
252 | .Render
253 | );
254 |
255 | if Assigned(FAnimation) then
256 | FAnimation(Router4DHistory.MainRouter);
257 |
258 | if aKey <> '' then aProps.Key(aKey);
259 |
260 | GlobalEventBus.Post(aProps);
261 | end;
262 |
263 | class function TRouter4DLink.New: iRouter4DLink;
264 | begin
265 | if not Assigned(Router4DLink) then
266 | Router4DLink := Self.Create;
267 |
268 | Result := Router4DLink;
269 | end;
270 |
271 | initialization
272 | Router4DLink := TRouter4DLink.New;
273 |
274 | end.
275 |
--------------------------------------------------------------------------------
/src/Router4D.Props.pas:
--------------------------------------------------------------------------------
1 | { *******************************************************************************
2 | Copyright 2016-2019 Daniele Spinetti
3 |
4 | Licensed under the Apache License, Version 2.0 (the "License");
5 | you may not use this file except in compliance with the License.
6 | You may obtain a copy of the License at
7 |
8 | http://www.apache.org/licenses/LICENSE-2.0
9 |
10 | Unless required by applicable law or agreed to in writing, software
11 | distributed under the License is distributed on an "AS IS" BASIS,
12 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 | See the License for the specific language governing permissions and
14 | limitations under the License.
15 | ******************************************************************************** }
16 |
17 | unit Router4D.Props;
18 |
19 | {$I Router4D.inc}
20 |
21 | interface
22 |
23 | uses
24 | System.Classes,
25 | System.SysUtils,
26 | System.Rtti;
27 |
28 | type
29 |
30 | TThreadMode = (Posting, Main, Async, Background);
31 |
32 | TCloneEventCallback = function(const AObject: TObject): TObject of object;
33 | TCloneEventMethod = TFunc;
34 |
35 | IEventBus = Interface
36 | ['{7BDF4536-F2BA-4FBA-B186-09E1EE6C7E35}']
37 | procedure RegisterSubscriber(ASubscriber: TObject);
38 | function IsRegistered(ASubscriber: TObject): Boolean;
39 | procedure Unregister(ASubscriber: TObject);
40 | procedure Post(AEvent: TObject; const AContext: String = '';
41 | AEventOwner: Boolean = true);
42 |
43 | procedure SetOnCloneEvent(const aCloneEvent: TCloneEventCallback);
44 | procedure AddCustomClassCloning(const AQualifiedClassName: String;
45 | const aCloneEvent: TCloneEventMethod);
46 | procedure RemoveCustomClassCloning(const AQualifiedClassName: String);
47 |
48 | property OnCloneEvent: TCloneEventCallback write SetOnCloneEvent;
49 | end;
50 |
51 | SubscribeAttribute = class(TCustomAttribute)
52 | private
53 | FContext: String;
54 | FThreadMode: TThreadMode;
55 | public
56 | constructor Create(AThreadMode: TThreadMode = TThreadMode.Posting;
57 | const AContext: String = '');
58 | property ThreadMode: TThreadMode read FThreadMode;
59 | property Context: String read FContext;
60 | end;
61 |
62 | TDEBEvent = class(TObject)
63 | private
64 | FDataOwner: Boolean;
65 | FData: T;
66 | procedure SetData(const Value: T);
67 | procedure SetDataOwner(const Value: Boolean);
68 | public
69 | constructor Create; overload;
70 | constructor Create(AData: T); overload;
71 | destructor Destroy; override;
72 | property DataOwner: Boolean read FDataOwner write SetDataOwner;
73 | property Data: T read FData write SetData;
74 | end;
75 |
76 |
77 | TProps = class
78 | private
79 | FPropString: String;
80 | FPropInteger: Integer;
81 | FPropCurrency : Currency;
82 | FPropDouble : Double;
83 | FPropValue : TValue;
84 | FPropObject : TObject;
85 | FPropDateTime : TDateTime;
86 | FKey : String;
87 | public
88 | constructor Create;
89 | destructor Destroy; override;
90 | function PropString ( aProp : String ) : TProps; overload;
91 | function PropString : String; overload;
92 | function PropInteger ( aProp : Integer ) : TProps; overload;
93 | function PropInteger : Integer; overload;
94 | function PropCurrency ( aProp : Currency ) : TProps; overload;
95 | function PropCurrency : Currency; overload;
96 | function PropDouble ( aProp : Double ) : TProps; overload;
97 | function PropDouble : Double; overload;
98 | function PropValue ( aProp : TValue ) : TProps; overload;
99 | function PropValue : TValue; overload;
100 | function PropObject ( aProp : TObject ) : TProps; overload;
101 | function PropObject : TObject; overload;
102 | function PropDateTime ( aProp : TDateTime ) : TProps; overload;
103 | function PropDateTime : TDateTime; overload;
104 | function Key ( aKey : String ) : TProps; overload;
105 | function Key : String; overload;
106 | end;
107 |
108 | function GlobalEventBus: IEventBus;
109 |
110 | implementation
111 |
112 | uses
113 | EventBus.Core, RTTIUtilsU;
114 |
115 | var
116 | FGlobalEventBus: IEventBus;
117 |
118 | { SubscribeAttribute }
119 |
120 | constructor SubscribeAttribute.Create(AThreadMode
121 | : TThreadMode = TThreadMode.Posting; const AContext: String = '');
122 | begin
123 | inherited Create;
124 | FContext := AContext;
125 | FThreadMode := AThreadMode;
126 | end;
127 |
128 | { TDEBSimpleEvent }
129 |
130 | constructor TDEBEvent.Create(AData: T);
131 | begin
132 | inherited Create;
133 | DataOwner := true;
134 | Data := AData;
135 | end;
136 |
137 | constructor TDEBEvent.Create;
138 | begin
139 | inherited Create;
140 | end;
141 |
142 | destructor TDEBEvent.Destroy;
143 | var
144 | LValue: TValue;
145 | begin
146 | LValue := TValue.From(Data);
147 | if (LValue.IsObject) and DataOwner then
148 | LValue.AsObject.Free;
149 | inherited;
150 | end;
151 |
152 | procedure TDEBEvent.SetData(const Value: T);
153 | begin
154 | FData := Value;
155 | end;
156 |
157 | procedure TDEBEvent.SetDataOwner(const Value: Boolean);
158 | begin
159 | FDataOwner := Value;
160 | end;
161 |
162 | function GlobalEventBus: IEventBus;
163 | begin
164 | if not Assigned(FGlobalEventBus) then
165 | FGlobalEventBus := TEventBus.Create;
166 | Result := FGlobalEventBus;
167 | end;
168 |
169 | { TProps }
170 |
171 | constructor TProps.Create;
172 | begin
173 |
174 | end;
175 |
176 | destructor TProps.Destroy;
177 | begin
178 |
179 | inherited;
180 | end;
181 |
182 | function TProps.Key(aKey: String): TProps;
183 | begin
184 | Result := Self;
185 | FKey := aKey;
186 | end;
187 |
188 | function TProps.Key: String;
189 | begin
190 | Result := FKey;
191 | end;
192 |
193 | function TProps.PropCurrency: Currency;
194 | begin
195 | Result := FPropCurrency;
196 | end;
197 |
198 | function TProps.PropDateTime: TDateTime;
199 | begin
200 | Result := FPropDateTime;
201 | end;
202 |
203 | function TProps.PropDateTime(aProp: TDateTime): TProps;
204 | begin
205 | Result := Self;
206 | FPropDateTime := aProp;
207 | end;
208 |
209 | function TProps.PropDouble: Double;
210 | begin
211 | Result := FPropDouble;
212 | end;
213 |
214 | function TProps.PropDouble(aProp: Double): TProps;
215 | begin
216 | Result := Self;
217 | FPropDouble := aProp;
218 | end;
219 |
220 | function TProps.PropCurrency(aProp: Currency): TProps;
221 | begin
222 | Result := Self;
223 | FPropCurrency := aProp;
224 | end;
225 |
226 | function TProps.PropInteger: Integer;
227 | begin
228 | Result := FPropInteger;
229 | end;
230 |
231 | function TProps.PropObject: TObject;
232 | begin
233 | Result := FPropObject;
234 | end;
235 |
236 | function TProps.PropObject(aProp: TObject): TProps;
237 | begin
238 | Result := Self;
239 | FPropObject := aProp;
240 | end;
241 |
242 | function TProps.PropInteger(aProp: Integer): TProps;
243 | begin
244 | Result := Self;
245 | FPropInteger := aProp;
246 | end;
247 |
248 | function TProps.PropString(aProp: String): TProps;
249 | begin
250 | Result := Self;
251 | FPropString := aProp;
252 | end;
253 |
254 | function TProps.PropString: String;
255 | begin
256 | Result := FPropString;
257 | end;
258 |
259 | function TProps.PropValue: TValue;
260 | begin
261 | Result := FPropValue;
262 | end;
263 |
264 | function TProps.PropValue(aProp: TValue): TProps;
265 | begin
266 | Result := Self;
267 | FPropValue := aProp;
268 | end;
269 |
270 | initialization
271 | GlobalEventBus;
272 |
273 | finalization
274 |
275 | end.
276 |
--------------------------------------------------------------------------------
/src/Router4D.Render.pas:
--------------------------------------------------------------------------------
1 | unit Router4D.Render;
2 |
3 | {$I Router4D.inc}
4 |
5 | interface
6 |
7 | uses
8 | {$IFDEF HAS_FMX}
9 | FMX.Types,
10 | {$ELSE}
11 | Vcl.ExtCtrls,
12 | Router4D.Helper,
13 | {$ENDIF}
14 | Router4D.Interfaces;
15 |
16 | type
17 | TRouter4DRender = class(TInterfacedObject, iRouter4DRender)
18 | private
19 | [weak]
20 | FParent : iRouter4DComponent;
21 | public
22 | constructor Create(Parent : iRouter4DComponent);
23 | destructor Destroy; override;
24 | class function New(Parent : iRouter4DComponent) : iRouter4DRender;
25 | {$IFDEF HAS_FMX}
26 | function SetElement ( aComponent : TFMXObject; aIndexComponent : TFMXObject = nil ) : iRouter4DRender;
27 | {$ELSE}
28 | function SetElement ( aComponent : TPanel; aIndexComponent : TPanel = nil ) : iRouter4DRender;
29 | {$ENDIF}
30 | end;
31 |
32 | implementation
33 |
34 | uses
35 | Router4D.History;
36 |
37 | { TRouter4DelphiRender }
38 |
39 | constructor TRouter4DRender.Create(Parent: iRouter4DComponent);
40 | begin
41 | FParent := Parent;
42 | end;
43 |
44 | destructor TRouter4DRender.Destroy;
45 | begin
46 |
47 | inherited;
48 | end;
49 |
50 | {$IFDEF HAS_FMX}
51 | function TRouter4DRender.SetElement( aComponent : TFMXObject; aIndexComponent : TFMXObject = nil ) : iRouter4DRender;
52 | begin
53 | Result := Self;
54 | Router4DHistory.MainRouter(aComponent);
55 |
56 | if aIndexComponent <> nil then
57 | Router4DHistory.IndexRouter(aIndexComponent);
58 |
59 | if Assigned(FParent) then
60 | begin
61 | aComponent.RemoveObject(0);
62 | aComponent.AddObject(FParent.Render);
63 | end;
64 | end;
65 | {$ELSE}
66 | function TRouter4DRender.SetElement( aComponent : TPanel; aIndexComponent : TPanel = nil ) : iRouter4DRender;
67 | begin
68 | Result := Self;
69 | Router4DHistory.MainRouter(aComponent);
70 |
71 | if aIndexComponent <> nil then
72 | Router4DHistory.IndexRouter(aIndexComponent);
73 |
74 | if Assigned(FParent) then
75 | begin
76 | aComponent.RemoveObject;
77 | aComponent.AddObject(FParent.Render);
78 | end;
79 | end;
80 | {$ENDIF}
81 |
82 | class function TRouter4DRender.New(
83 | Parent: iRouter4DComponent): iRouter4DRender;
84 | begin
85 | Result := Self.Create(Parent);
86 | end;
87 |
88 | end.
89 |
--------------------------------------------------------------------------------
/src/Router4D.Sidebar.pas:
--------------------------------------------------------------------------------
1 | unit Router4D.Sidebar;
2 |
3 | {$I Router4D.inc}
4 |
5 | interface
6 |
7 | {$IFDEF HAS_FMX}
8 | uses
9 | Classes,
10 | SysUtils,
11 | FMX.Types,
12 | FMX.ListBox,
13 | FMX.SearchBox,
14 | FMX.Layouts,
15 | Router4D.Interfaces,
16 | System.UITypes;
17 |
18 | type
19 | TRouter4DSidebar = class(TInterfacedObject, iRouter4DSidebar)
20 | private
21 | FName : String;
22 | FMainContainer : TFMXObject;
23 | FLinkContainer : TFMXObject;
24 | FAnimation : TProc;
25 | FFontSize : Integer;
26 | FFontColor : TAlphaColor;
27 | FItemHeigth : Integer;
28 | public
29 | constructor Create;
30 | destructor Destroy; override;
31 | class function New : iRouter4DSidebar;
32 | function Animation ( aAnimation : TProc ) : iRouter4DSidebar;
33 | function MainContainer ( aValue : TFMXObject ) : iRouter4DSidebar; overload;
34 | function MainContainer : TFMXObject; overload;
35 | function LinkContainer ( aValue : TFMXObject ) : iRouter4DSidebar;
36 | function RenderToListBox : iRouter4DSidebar;
37 | function Name ( aValue : String ) : iRouter4DSidebar; overload;
38 | function Name : String; overload;
39 | function FontSize ( aValue : Integer ) : iRouter4DSidebar;
40 | function FontColor ( aValue : TAlphaColor ) : iRouter4DSidebar;
41 | function ItemHeigth ( aValue : Integer ) : iRouter4DSidebar;
42 | end;
43 |
44 | implementation
45 |
46 | uses
47 | Router4D,
48 | Router4D.History,
49 | Router4D.Utils;
50 |
51 | { TRouter4DSidebar }
52 |
53 | function TRouter4DSidebar.Animation(
54 | aAnimation: TProc): iRouter4DSidebar;
55 | begin
56 | Result := Self;
57 | FAnimation := aAnimation;
58 | end;
59 |
60 | function TRouter4DSidebar.LinkContainer(aValue: TFMXObject): iRouter4DSidebar;
61 | begin
62 | Result := Self;
63 | FLinkContainer := aValue;
64 | end;
65 |
66 | function TRouter4DSidebar.MainContainer(aValue: TFMXObject): iRouter4DSidebar;
67 | begin
68 | Result := Self;
69 | FMainContainer := aValue;
70 | end;
71 |
72 | function TRouter4DSidebar.MainContainer: TFMXObject;
73 | begin
74 | Result := FMainContainer;
75 | end;
76 |
77 | function TRouter4DSidebar.RenderToListBox: iRouter4DSidebar;
78 | var
79 | aListBox : TListBox;
80 | aListBoxItem : TListBoxItem;
81 | AListBoxSearch : TSearchBox;
82 | aItem : TCachePersistent;
83 | begin
84 | aListBox := TListBox.Create(FMainContainer);
85 | aListBox.Align := TAlignLayout.Client;
86 |
87 | aListBox.StyleLookup := 'transparentlistboxstyle';
88 |
89 | aListBox.BeginUpdate;
90 |
91 | AListBoxSearch := TSearchBox.Create(aListBox);
92 | AListBoxSearch.Height := FItemHeigth - 25;
93 | aListBox.ItemHeight := FItemHeigth;
94 |
95 | aListBox.AddObject(AListBoxSearch);
96 |
97 | for aItem in Router4DHistory.RoutersListPersistent.Values do
98 | begin
99 | if AItem.FisVisible and (AItem.FSBKey = FName) then
100 | begin
101 | aListBoxItem := TListBoxItem.Create(aListBox);
102 | aListBoxItem.Parent := aListBox;
103 | aListBoxItem.StyledSettings:=[TStyledSetting.Other];
104 | aListBoxItem.TextSettings.Font.Size := FFontSize;
105 | aListBoxItem.FontColor := FFontColor;
106 | aListBoxItem.Text := aItem.FPatch;
107 | aListBox.AddObject(aListBoxItem);
108 | end;
109 | end;
110 | aListBox.EndUpdate;
111 |
112 |
113 | Router4DHistory.AddHistoryConteiner(FName, FLinkContainer);
114 |
115 | aListBox.OnClick :=
116 |
117 | TNotifyEventWrapper
118 | .AnonProc2NotifyEvent(
119 | aListBox,
120 | procedure(Sender: TObject; Aux : String)
121 | begin
122 | TRouter4D
123 | .Link
124 | .Animation(
125 | procedure ( aObject : TFMXObject )
126 | begin
127 | TLayout(aObject).Opacity := 0;
128 | TLayout(aObject).AnimateFloat('Opacity', 1, 0.2);
129 | end)
130 | .&To(
131 | (Sender as TListBox).Items[(Sender as TListBox).ItemIndex],
132 | Aux
133 | )
134 | end,
135 | FName
136 | );
137 |
138 | FMainContainer.AddObject(aListBox);
139 | end;
140 |
141 | constructor TRouter4DSidebar.Create;
142 | begin
143 | FName := 'SBIndex';
144 | FLinkContainer := Router4DHistory.MainRouter;
145 | end;
146 |
147 | destructor TRouter4DSidebar.Destroy;
148 | begin
149 |
150 | inherited;
151 | end;
152 |
153 | function TRouter4DSidebar.FontColor(aValue: TAlphaColor): iRouter4DSidebar;
154 | begin
155 | Result := Self;
156 | FFontColor := aValue;
157 | end;
158 |
159 | function TRouter4DSidebar.FontSize(aValue: Integer): iRouter4DSidebar;
160 | begin
161 | Result := Self;
162 | FFontSize := aValue;
163 | end;
164 |
165 | function TRouter4DSidebar.ItemHeigth(aValue: Integer): iRouter4DSidebar;
166 | begin
167 | Result := Self;
168 | FItemHeigth := aValue;
169 | end;
170 |
171 | function TRouter4DSidebar.Name(aValue: String): iRouter4DSidebar;
172 | begin
173 | Result := Self;
174 | FName := aValue;
175 | end;
176 |
177 | function TRouter4DSidebar.Name: String;
178 | begin
179 | Result := FName;
180 | end;
181 |
182 | class function TRouter4DSidebar.New: iRouter4DSidebar;
183 | begin
184 | Result := Self.Create;
185 | end;
186 | {$ELSE}
187 | implementation
188 | {$ENDIF}
189 |
190 | end.
191 |
--------------------------------------------------------------------------------
/src/Router4D.Switch.pas:
--------------------------------------------------------------------------------
1 | unit Router4D.Switch;
2 |
3 | {$I Router4D.inc}
4 |
5 | interface
6 |
7 | uses
8 | Classes,
9 | System.Generics.Collections,
10 | Router4D.Interfaces,
11 | Router4D.History;
12 |
13 | type
14 | TRouter4DSwitch = class(TInterfacedObject, iRouter4DSwitch)
15 | private
16 | FSideBarList : TDictionary;
17 | public
18 | constructor Create;
19 | destructor Destroy; override;
20 | class function New : iRouter4DSwitch;
21 | function Router(aPath : String; aRouter : TPersistentClass; aSidebarKey : String = 'SBIndex'; isVisible : Boolean = True) : iRouter4DSwitch;
22 | function UnRouter(aPath : String) : iRouter4DSwitch;
23 | function SidebarAdd ( aPatch : String; aSideBar : iRouter4DSidebar) : iRouter4DSwitch;
24 | function SideBarList : TDictionary;
25 | end;
26 |
27 | implementation
28 |
29 | { TRouter4DSwitch }
30 |
31 | uses
32 | Router4D.Utils;
33 |
34 | constructor TRouter4DSwitch.Create;
35 | begin
36 | FSideBarList := TDictionary.Create;
37 | end;
38 |
39 | destructor TRouter4DSwitch.Destroy;
40 | begin
41 | FSideBarList.Free;
42 | inherited;
43 | end;
44 |
45 | class function TRouter4DSwitch.New: iRouter4DSwitch;
46 | begin
47 | Result := Self.Create;
48 | end;
49 |
50 | function TRouter4DSwitch.Router(aPath : String; aRouter : TPersistentClass; aSidebarKey : String = 'SBIndex'; isVisible : Boolean = True) : iRouter4DSwitch;
51 | begin
52 | Result := Self;
53 | RegisterClass(aRouter);
54 | Router4DHistory.AddHistory(aPath, aRouter, aSidebarKey, isVisible);
55 | end;
56 |
57 | function TRouter4DSwitch.SidebarAdd(aPatch: String;
58 | aSideBar: iRouter4DSidebar): iRouter4DSwitch;
59 | begin
60 | Result := Self;
61 | FSideBarList.Add(aPatch, aSideBar);
62 | end;
63 |
64 | function TRouter4DSwitch.SideBarList: TDictionary;
65 | begin
66 | Result := FSideBarList;
67 | end;
68 |
69 | function TRouter4DSwitch.UnRouter(aPath: String) : iRouter4DSwitch;
70 | begin
71 | Result := Self;
72 | Router4DHistory.RemoveHistory(aPath);
73 | end;
74 |
75 | end.
76 |
--------------------------------------------------------------------------------
/src/Router4D.Utils.pas:
--------------------------------------------------------------------------------
1 | unit Router4D.Utils;
2 |
3 | {$I Router4D.inc}
4 |
5 | interface
6 |
7 | uses
8 | System.Rtti,
9 | Router4D.Props,
10 | SysUtils,
11 | Classes;
12 |
13 | type
14 | TRouter4DUtils = class
15 | private
16 | public
17 | class function CreateInstance : T;
18 | end;
19 |
20 | TNotifyEventWrapper = class(TComponent)
21 | private
22 | FProc: TProc;
23 | FAux : String;
24 | public
25 | constructor Create(Owner: TComponent; Proc: TProc; Aux : String = ''); reintroduce;
26 | class function AnonProc2NotifyEvent(Owner: TComponent; Proc: TProc; Aux : String = ''): TNotifyEvent;
27 | published
28 | procedure Event(Sender: TObject);
29 | end;
30 |
31 | implementation
32 |
33 | { TRouter4DUtils }
34 |
35 | class function TRouter4DUtils.CreateInstance: T;
36 | var
37 | AValue: TValue;
38 | ctx: TRttiContext;
39 | rType: TRttiType;
40 | AMethCreate: TRttiMethod;
41 | instanceType: TRttiInstanceType;
42 | begin
43 | ctx := TRttiContext.Create;
44 | rType := ctx.GetType(TypeInfo(T));
45 | for AMethCreate in rType.GetMethods do
46 | begin
47 | if (AMethCreate.IsConstructor) and (Length(AMethCreate.GetParameters) = 1) then
48 | begin
49 | instanceType := rType.AsInstance;
50 | AValue := AMethCreate.Invoke(instanceType.MetaclassType, [nil]);
51 | Result := AValue.AsType;
52 |
53 | try
54 | GlobalEventBus.RegisterSubscriber(AValue.AsType);
55 | except
56 |
57 | end;
58 |
59 | Exit;
60 | end;
61 | end;
62 |
63 | end;
64 |
65 | { TNotifyEventWrapper }
66 |
67 | class function TNotifyEventWrapper.AnonProc2NotifyEvent(Owner: TComponent; Proc: TProc; Aux : String = ''): TNotifyEvent;
68 | begin
69 | Result := Self.Create(Owner, Proc, Aux).Event;
70 | end;
71 |
72 | constructor TNotifyEventWrapper.Create(Owner: TComponent; Proc: TProc; Aux : String = '');
73 | begin
74 | inherited Create(Owner);
75 | FProc := Proc;
76 | FAux := Aux;
77 | end;
78 |
79 | procedure TNotifyEventWrapper.Event(Sender: TObject);
80 | begin
81 | FProc(Sender, FAux);
82 | end;
83 |
84 | end.
85 |
--------------------------------------------------------------------------------
/src/Router4D.inc:
--------------------------------------------------------------------------------
1 | //{$DEFINE HAS_FMX}
--------------------------------------------------------------------------------
/src/Router4D.pas:
--------------------------------------------------------------------------------
1 | unit Router4D;
2 |
3 | {$I Router4D.inc}
4 |
5 | interface
6 |
7 | uses
8 | System.Generics.Collections,
9 | System.Classes,
10 | System.Rtti,
11 | System.TypInfo,
12 | SysUtils,
13 | {$IFDEF HAS_FMX}
14 | FMX.Types,
15 | {$ELSE}
16 | Vcl.ExtCtrls,
17 | {$ENDIF}
18 | Router4D.Interfaces,
19 | Router4D.History,
20 | Router4D.Render,
21 | Router4D.Link;
22 |
23 | type
24 | TRouter4D = class(TInterfacedObject, iRouter4D)
25 | private
26 | public
27 | constructor Create;
28 | destructor Destroy; override;
29 | class function New : iRouter4D;
30 | class function Render : iRouter4DRender; overload;
31 | class function Render(initialRoute:string) : iRouter4DRender; overload;
32 | class function Link : iRouter4DLink;
33 | class function Switch : iRouter4DSwitch;
34 | {$IFDEF HAS_FMX}
35 | class function SideBar : iRouter4DSidebar;
36 | {$ENDIF}
37 | end;
38 |
39 | implementation
40 |
41 | { TRouter4Delphi }
42 |
43 | uses
44 | Router4D.Utils,
45 | Router4D.Switch,
46 | Router4D.Sidebar;
47 |
48 | constructor TRouter4D.Create;
49 | begin
50 |
51 | end;
52 |
53 | destructor TRouter4D.Destroy;
54 | begin
55 |
56 | inherited;
57 | end;
58 |
59 | class function TRouter4D.Link: iRouter4DLink;
60 | begin
61 | Result := TRouter4DLink.New;
62 | end;
63 |
64 | class function TRouter4D.New: iRouter4D;
65 | begin
66 | Result := Self.Create;
67 | end;
68 |
69 | class function TRouter4D.Render(initialRoute:string): iRouter4DRender;
70 | begin
71 | Router4DHistory
72 | .AddHistory(
73 | TPersistentClass(T).ClassName,
74 | TPersistentClass(T)
75 | );
76 |
77 |
78 | Result :=
79 | TRouter4DRender
80 | .New(
81 | Router4DHistory
82 | .addCacheHistory(initialRoute)
83 | .GetHistory(
84 | TPersistentClass(T)
85 | .ClassName
86 | )
87 | );
88 | end;
89 |
90 | class function TRouter4D.Render: iRouter4DRender;
91 | begin
92 | Router4DHistory
93 | .AddHistory(
94 | TPersistentClass(T).ClassName,
95 | TPersistentClass(T)
96 | );
97 |
98 |
99 | Result :=
100 | TRouter4DRender
101 | .New(
102 | Router4DHistory
103 | .GetHistory(
104 | TPersistentClass(T)
105 | .ClassName
106 | )
107 | );
108 | end;
109 | {$IFDEF HAS_FMX}
110 | class function TRouter4D.SideBar: iRouter4DSidebar;
111 | begin
112 | Result := TRouter4DSidebar.New;
113 | end;
114 | {$ENDIF}
115 | class function TRouter4D.Switch: iRouter4DSwitch;
116 | begin
117 | Result := TRouter4DSwitch.New;
118 | end;
119 |
120 | end.
121 |
--------------------------------------------------------------------------------