1 PROGRAM LinkLib;
2 
3 uses exec, triton, tritonmacros, linklist,
4            amigautils,strings, easyasl, utility;
5 
6 {
7    A demo in FPC Pascal using triton.library
8 
9    Updated for fpc 1.0.7
10    09 Jan 2003.
11 
12    nils.sjoholm@mailbox.swipnet.se
13 }
14 
15 
16 
17 VAR
18      Project  : pTR_Project;
19      mylist   : pList;
20      llist    : pList;
21      pdummy   : ARRAY [0..108] OF Char;
22      path     : PChar;
23      Triton_App : pTR_App;
24 
25 const
26 
27     LibListGadID   = 1;
28     AddGadID       = 2;
29     RemoveGadID    = 3;
30     RemAllGadID    = 4;
31     UpGadID        = 5;
32     DownGadID      = 6;
33     OkButton       = 7;
34     CancelButton   = 8;
35 
36 
37 PROCEDURE CleanExit(errstring : STRING; rc : Longint);
38 BEGIN
39     IF assigned(Project) THEN TR_CloseProject(Project);
40     IF Assigned(mylist) THEN DestroyList(mylist);
41     IF Assigned(llist) THEN DestroyList(llist);
42     IF errstring <> '' THEN WriteLn(errstring);
43     Halt(rc)
44 END;
45 
46 PROCEDURE disablegads;
47 VAR
48    dummy : Longint;
49 BEGIN
50    IF NodesInList(mylist) > 0 THEN dummy := 0
51       ELSE dummy := 1;
52 
53    TR_SetAttribute(Project,RemoveGadID,TRAT_Disabled,dummy);
54    TR_SetAttribute(Project,RemAllGadID,TRAT_Disabled,dummy);
55    TR_SetAttribute(Project,UpGadID,TRAT_Disabled,dummy);
56    TR_SetAttribute(Project,DownGadID,TRAT_Disabled,dummy);
57 END;
58 
59 PROCEDURE readinlist;
60 VAR
61    dummy : BOOLEAN;
62    temp : pFPCNode;
63 BEGIN
64    dummy := FileToList('ram:fpclistoffiles',mylist);
65    IF dummy THEN BEGIN
66       temp := GetFirstNode(mylist);
67       IF temp <> NIL THEN StrCopy(path,PathOf(GetNodeData(temp)));
68       temp := GetLastNode(mylist);
69       IF StrLen(GetNodeData(temp)) = 0 THEN RemoveLastNode(mylist);
70    END;
71 END;
72 
73 PROCEDURE addfiles;
74 
75 VAR
76   dummy    : BOOLEAN;
77   mynode,tempnode   : pFPCNode;
78   temp  : Longint;
79 
80 BEGIN
81   dummy := GetMultiAsl('Pick a file or two :)',path,llist,NIL,NIL);
82   IF dummy THEN BEGIN
83      mynode := GetFirstNode(llist);
84      FOR temp := 1 TO NodesInList(llist) DO BEGIN
85         tempnode := AddNewNode(mylist,(PathAndFile(path,GetNodeData(mynode))));
86         mynode := GetNextNode(mynode);
87      END;
88      TR_UpdateListView(Project,LibListGadID,mylist);
89      TR_SetValue(Project,LibListGadID,0);
90      disablegads;
91      ClearList(llist);
92   END;
93 END;
94 
95 PROCEDURE removelib;
96 VAR
97    num : Longint;
98    mynode : pFPCNode;
99    strbuf : ARRAY [0..255] OF Char;
100    buffer : PChar;
101    dummy : Longint;
102 BEGIN
103    buffer := @strbuf;
104    num := TR_GetValue(Project,LibListGadID);
105    mynode := GetNodeNumber(mylist,num);
106 
107    dummy := TR_EasyRequestTags(Triton_App,'Sure you want to delete'+#10+
108                             strpas(GetNodeData(mynode)),'_Remove|_Cancel',[
109                             TREZ_LockProject, AsTag(Project),
110                             TREZ_Title, AsTag('Delete this file?'),
111                             TREZ_Activate,1,
112                             TAG_END]);
113    IF dummy = 1 THEN BEGIN
114       DeleteNode(mynode);
115       TR_UpdateListView(Project,LibListGadID,mylist);
116       TR_SetValue(Project,LibListGadID,0);
117       disablegads;
118    END;
119 END;
120 
121 PROCEDURE removeall;
122 VAR
123    dummy : Longint;
124 BEGIN
125    dummy := TR_EasyRequestTags(Triton_App,'Sure you want to remove all files?',
126                                       '_Remove|_Cancel',[
127                                       TREZ_LockProject, AsTag(Project),
128                                       TREZ_Title, AsTag('Delete all?'),
129                                       TREZ_Activate,1,
130                                       TAG_END]);
131    IF dummy = 1 THEN BEGIN
132       ClearList(mylist);
133       TR_UpdateListView(Project,LibListGadID,mylist);
134       disablegads;
135    END;
136 END;
137 
138 PROCEDURE savethelist;
139 VAR
140    dummy : BOOLEAN;
141 BEGIN
142    dummy := ListToFile('Ram:fpclistoffiles',mylist);
143 END;
144 
145 PROCEDURE movedown;
146 VAR
147    num : INTEGER;
148    mynode : pFPCNode;
149 BEGIN
150    num := TR_GetValue(project,LibListGadID);
151    IF num < (NodesInList(mylist)-1) THEN BEGIN
152       mynode := GetNodeNumber(mylist,num);
153       IF mynode <> NIL THEN BEGIN
154           MoveNodeDown(mylist,mynode);
155           TR_UpdateListView(Project,LibListGadID,mylist);
156           TR_SetValue(Project,LibListGadID,num + 1);
157       END;
158    END;
159 END;
160 
161 PROCEDURE moveup;
162 VAR
163    num : Longint;
164    mynode : pFPCNode;
165 BEGIN
166    num := TR_GetValue(project,LibListGadID);
167    IF num > 0 THEN BEGIN
168       mynode := GetNodeNumber(mylist,num);
169       IF mynode <> NIL THEN BEGIN
170           MoveNodeUp(mylist,mynode);
171           TR_UpdateListView(Project,LibListGadID,mylist);
172           TR_SetValue(Project,LibListGadID,num-1);
173       END;
174    END;
175 END;
176 
177 PROCEDURE do_demo;
178 VAR
179     close_me : BOOLEAN;
180     trmsg : pTR_Message;
181     dummy : Longint;
182 
183 BEGIN
184     ProjectStart;
185                WindowID(1);
186                WindowPosition(TRWP_CENTERDISPLAY);
187                WindowTitle('TritonListViewDemo in FPC Pascal');
188                   HorizGroupAC;
189                      Space;
190                      VertGroupAC;
191                      Space;
192                      NamedSeparator('List of files');
193                         Space;
194                         ListSSM(mylist,LibListGadID,0,0,25);
195                         Space;
196                      EndGroup;
197                      Space;
198                      VertSeparator;
199                      Space;
200                      SetTRTag(TRGR_Vert, TRGR_ALIGN OR TRGR_FIXHORIZ);
201                         Space;
202                         Button('_Add...',AddGadID);
203                         SpaceS;
204                         Button('_Remove...',RemoveGadID);
205                         SpaceS;
206                         Button('Re_move All...',RemAllGadID);
207                         SpaceS;
208                         Button('_Up',UpGadID);
209                         SpaceS;
210                         Button('_Down',DownGadID);
211                         VertGroupS;Space;EndGroup;
212                         Button('_Ok',OkButton);
213                         SpaceS;
214                         Button('_Cancel',CancelButton);
215                         Space;
216                      EndGroup;
217                      Space;
218                   EndGroup;
219                EndProject;
220 
221     Project := TR_OpenProject(Triton_App,@tritontags);
222     IF Project <> NIL THEN BEGIN
223       disablegads;
224       close_me := FALSE;
225       WHILE NOT close_me DO BEGIN
226         dummy := TR_Wait(Triton_App,0);
227         REPEAT
228           trmsg := TR_GetMsg(Triton_App);
229           IF trmsg <> NIL THEN BEGIN
230             IF (trmsg^.trm_Project = Project) THEN BEGIN
231                CASE trmsg^.trm_Class OF
232                  TRMS_CLOSEWINDOW : close_me := True;
233                  TRMS_ERROR:        WriteLN(TR_GetErrorString(trmsg^.trm_Data));
234                  TRMS_ACTION :
235                  BEGIN
236                  CASE trmsg^.trm_ID OF
237                    AddGadID : addfiles;
238                    UpGadID : moveup;
239                    DownGadID : movedown;
240                    RemoveGadID : removelib;
241                    RemAllGadID : removeall;
242                    OkButton : BEGIN savethelist; close_me := True; END;
243                    CancelButton : close_me := True;
244                  END;
245                END;
246                ELSE
247                END;
248             END;
249             TR_ReplyMsg(trmsg);
250           END
251         UNTIL close_me OR (trmsg = NIL);
252       END;
253     END ELSE WriteLN(TR_GetErrorString(TR_GetLastError(Triton_App)));
254 END;
255 
256 
257 BEGIN  { Main }
258   if not Assigned(TritonBase) then
259   begin
260     writeln('cannot open ' + TRITONNAME);
261     Halt(5);
262   end;
263         Triton_App := TR_CreateAppTags([
264                        TRCA_Name, AsTag('Triton ListView Demo'),
265                        TRCA_LongName, AsTag('Demo of ListView in Triton, made in FPC Pascal'),
266                        TRCA_Version, AsTag('0.01'),
267                        TRCA_Info, AsTag('Uses tritonsupport'),
268                        TRCA_Release, AsTag('11'),
269                        TRCA_Date, AsTag('03-02-1998'),
270                        TAG_END]);
271         if Triton_App <> nil then begin
272         path := @pdummy;
273         StrpCopy(path,'sys:');
274         CreateList(mylist);
275         CreateList(llist);
276         readinlist;
277         do_demo;
278         CleanExit('',0);
279      END
280      ELSE CleanExit('Can''t create application',20);
281 END.
282