]> git.8kb.co.uk Git - dataflex/df32func/blob - src/df32/data.inc
Initial import
[dataflex/df32func] / src / df32 / data.inc
1 //-------------------------------------------------------------------------\r
2 // data.inc\r
3 //      This file contains some DataFlex 3.2 Console Mode classes\r
4 //      to provide some useful data structures.\r
5 //\r
6 // This file is to be included in df32func.mk\r
7 //\r
8 // Copyright (c) 2006-2009, glyn@8kb.co.uk\r
9 // \r
10 // df32func/data.inc\r
11 //-------------------------------------------------------------------------\r
12 \r
13 //-------------------------------------------------------------------------\r
14 // Classes\r
15 //-------------------------------------------------------------------------\r
16 \r
17 // Linked list class - impliments a linked list type structure in an array, unlike\r
18 // traditional linked lists the data is actually the prev/next links (array indexes)\r
19 //\r
20 // Prev and next addresses are stored as a string "prev,next" rather than using XORing;\r
21 // this is so we can start traversal in either direction from a particular address\r
22 // without having to also know the prev or next address.\r
23 //\r
24 // Get methods:\r
25 //    probe_state                   - Returns a summary of the linked list state\r
26 //    first_link                    - Returns the first link in the list\r
27 //    last_link                     - Returns the last link in the list\r
28 //    link_count                    - Returns the total number of links\r
29 //    next_link <current_link>      - Returns the next link after the link id passed in\r
30 //    prev_link <current_link>      - Returns the previous link after the link id passed in\r
31 //\r
32 // Set methods: (All of the following methods are intended to be private)\r
33 //    next_link <current_link>      - Sets the next link after the link id passed in\r
34 //    prev_link <current_link>      - Sets the previous link after the link id passed in\r
35 //    seek_link                     - Seeks out the position in the list for a new link    \r
36 //\r
37 // Send message methods:\r
38 //    insert_link                   - Insert a new item into the linked list\r
39 //    remove_link                   - Remove an item from the linked list\r
40 //\r
41 //\r
42 // Example usage:\r
43 //    \r
44 //    string buf\r
45 //    integer max min count i\r
46 //    \r
47 //    object test is a linkedlist\r
48 //    end_object\r
49 //    \r
50 //    // Create some links\r
51 //    for i from 10 to 15\r
52 //        send insert_link to test (i*100)\r
53 //    loop\r
54 //    for i from 1 to 5\r
55 //        send insert_link to test (i*100)\r
56 //    loop\r
57 //    \r
58 //    send insert_link to test 750\r
59 //\r
60 //    // Remove a link\r
61 //    send remove_link to test 300\r
62 //    \r
63 //    // Access the list\r
64 //    get probe_state of test to buf\r
65 //    get first_link of test to min\r
66 //    get last_link of test to max\r
67 //    get link_count of test to count\r
68 //    \r
69 //    showln "There are " count " items in the linked list"\r
70 //    showln buf\r
71 //    \r
72 //    show "Traverse forwards: "\r
73 //    move min to i\r
74 //    while (i <> -1) \r
75 //        show i "->"   \r
76 //        get next_link of test item i to i\r
77 //    loop\r
78 //    showln "END"\r
79 //    \r
80 //    show "Traverse backwards: "\r
81 //    move max to i\r
82 //    while (i <> -1) \r
83 //        show i "->"   \r
84 //        get prev_link of test item i to i\r
85 //    loop\r
86 //    showln "END"\r
87 \r
88 class linkedlist is an array\r
89     procedure construct_object integer argc\r
90         object mTokens is a StringTokenizer\r
91         end_object\r
92     \r
93         forward send construct_object\r
94         \r
95         property integer c_iMinAddr\r
96         property integer c_iMaxAddr\r
97         property integer c_iCount\r
98         property number c_nDist\r
99         \r
100         set c_iMinAddr to -1\r
101         set c_iMaxAddr to -1\r
102         set c_iCount to 0\r
103         set c_nDist to 1\r
104     end_procedure\r
105     \r
106     procedure delete_data\r
107         set c_iMinAddr to -1\r
108         set c_iMaxAddr to -1\r
109         set c_iCount to 0\r
110         set c_nDist to 1\r
111         forward send delete_data\r
112     end_procedure    \r
113     \r
114     function probe_state returns string\r
115         local integer l_iMinAddr l_iMaxAddr l_iCount \r
116         local number l_nDist\r
117         \r
118         get c_iMaxAddr to l_iMaxAddr\r
119         get c_iMinAddr to l_iMinAddr\r
120         get c_iCount to l_iCount\r
121         get c_nDist to l_nDist\r
122         \r
123         function_return ("Address range: "+string(l_iMinAddr)+"<->"+string(l_iMaxAddr)+" Items: "+string(l_iCount)+" Dist: "+string(l_nDist))\r
124     end_function\r
125     \r
126     function last_link returns integer\r
127         local integer l_iMaxAddr\r
128         \r
129         get c_iMaxAddr to l_iMaxAddr\r
130         \r
131         function_return l_iMaxAddr\r
132     end_function\r
133     \r
134     function first_link returns integer\r
135         local integer l_iMinAddr\r
136         \r
137         get c_iMinAddr to l_iMinAddr\r
138         \r
139         function_return l_iMinAddr\r
140     end_function    \r
141     \r
142     function link_count returns integer\r
143         local integer l_iCount\r
144         \r
145         get c_iCount to l_iCount\r
146         \r
147         function_return l_iCount\r
148     end_function      \r
149     \r
150     function next_link integer l_iAddr returns integer\r
151         local string l_sBuf\r
152         local integer l_iNext\r
153         \r
154         forward get string_value item l_iAddr to l_sBuf\r
155         if (l_sBuf = "") custom_error ERROR_CODE_INVALID_ADDRESS$ ERROR_MSG_INVALID_ADDRESS l_iAddr\r
156         move (integer(right(l_sBuf,(length(l_sBuf)-pos(",",l_sBuf))))) to l_iNext\r
157         \r
158         function_return l_iNext\r
159     end_function\r
160     \r
161     function prev_link integer l_iAddr returns integer\r
162         local string l_sBuf\r
163         local integer l_iPrev\r
164         \r
165         forward get string_value item l_iAddr to l_sBuf\r
166         if (l_sBuf = "") custom_error ERROR_CODE_INVALID_ADDRESS$ ERROR_MSG_INVALID_ADDRESS l_iAddr\r
167         move (integer(left(l_sBuf,pos(",",l_sBuf)-1))) to l_iPrev        \r
168         \r
169         function_return l_iPrev\r
170     end_function \r
171     \r
172     procedure set next_link integer l_iAddr integer l_iNext\r
173         local string l_sBuf\r
174         local integer l_iPrev\r
175         \r
176         forward get string_value item l_iAddr to l_sBuf\r
177         move (integer(left(l_sBuf,pos(",",l_sBuf)-1))) to l_iPrev\r
178         forward set array_value item l_iAddr to (string(l_iPrev)+","+string(l_iNext))\r
179         \r
180     end_procedure\r
181 \r
182     procedure set prev_link integer l_iAddr integer l_iPrev\r
183         local string l_sBuf\r
184         local integer l_iNext\r
185         \r
186         forward get string_value item l_iAddr to l_sBuf\r
187         move (integer(right(l_sBuf,(length(l_sBuf)-pos(",",l_sBuf))))) to l_iNext\r
188         forward set array_value item l_iAddr to (string(l_iPrev)+","+string(l_iNext))\r
189         \r
190     end_procedure    \r
191     \r
192     function seek_link integer l_iAddr returns string\r
193         local integer l_iOn l_iNext l_iPrev l_iMinAddr l_iMaxAddr\r
194         local string l_sBuf\r
195         local number l_nDist\r
196         \r
197         get c_iMaxAddr to l_iMaxAddr\r
198         get c_iMinAddr to l_iMinAddr\r
199         get c_nDist to l_nDist\r
200 \r
201 \r
202         if (show_debug_lines) begin        \r
203             showln "DEBUG: Addr " l_iAddr\r
204             showln "DEBUG: Range " l_iMinAddr " <-> " l_iMaxAddr\r
205             showln "DEBUG: Dist " l_nDist\r
206         end\r
207         \r
208         move l_iMinAddr to l_iPrev\r
209         move l_iMaxAddr to l_iNext \r
210         \r
211         if (l_iAddr > l_iMaxAddr) move l_iMaxAddr to l_iOn\r
212         else move l_iMinAddr to l_iOn\r
213         \r
214         if (l_iOn > -1) begin\r
215             while (l_iOn < l_iAddr)\r
216                 forward get string_value item l_iOn to l_sBuf\r
217             if (l_sBuf = "") break\r
218                 else begin\r
219                     move (integer(left(l_sBuf,pos(",",l_sBuf)-1))) to l_iPrev\r
220                     move (integer(right(l_sBuf,(length(l_sBuf)-pos(",",l_sBuf))))) to l_iNext\r
221                 end    \r
222                 if ((l_iNext = -1) or (l_iNext > l_iAddr)) break             \r
223                 move l_iNext to l_iOn\r
224             loop\r
225         end\r
226         \r
227         if (l_iPrev > l_iAddr) begin \r
228                 move l_iPrev to l_iNext\r
229                 move -1 to l_iOn\r
230             move -1 to l_iPrev\r
231         end            \r
232         \r
233         function_return (string(l_iPrev)+","+string(l_iOn)+","+string(l_iNext))\r
234     end_function\r
235     \r
236     procedure insert_link integer l_iAddr\r
237         local integer l_iMinAddr l_iMaxAddr l_iPrev l_iNext l_iOn l_iCount\r
238         local string l_sBuf\r
239         local number l_nDist\r
240         \r
241         if (l_iAddr < 0) custom_error ERROR_CODE_INVALID_ADDRESS$ ERROR_MSG_INVALID_ADDRESS l_iAddr\r
242         else begin\r
243             forward get string_value item l_iAddr to l_sBuf\r
244             if (l_sBuf <> "") custom_error ERROR_CODE_ADDRESS_TAKEN$ ERROR_MSG_ADDRESS_TAKEN l_iAddr\r
245             else begin\r
246                 get c_iMaxAddr to l_iMaxAddr\r
247             get c_iMinAddr to l_iMinAddr\r
248             get seek_link item l_iAddr to l_sBuf\r
249 \r
250                 send delete_data to (mTokens(current_object))\r
251                 send set_string to (mTokens(current_object)) l_sBuf ","\r
252                 get integer_value of (mTokens(current_object)) item 0 to l_iPrev\r
253                 get integer_value of (mTokens(current_object)) item 1 to l_iOn\r
254                 get integer_value of (mTokens(current_object)) item 2 to l_iNext\r
255                 \r
256                 if (show_debug_lines) begin\r
257                     showln "DEBUG: Insert address: " l_iAddr " Seek data '" l_sBuf "'"\r
258                 end\r
259                 \r
260                 if (l_iOn <> -1) set next_link item l_iOn to l_iAddr  \r
261                 forward set array_value item l_iAddr to (string(l_iOn)+","+string(l_iNext))\r
262                 if (l_iNext <> -1) set prev_link item l_iNext to l_iAddr\r
263                 \r
264                 if (l_iAddr > l_iMaxAddr) begin \r
265                     move l_iAddr to l_iMaxAddr\r
266                     set c_iMaxAddr to l_iMaxAddr\r
267                 end\r
268             if ((l_iAddr < l_iMinAddr) or (l_iMinAddr = -1)) begin\r
269                 move l_iAddr to l_iMinAddr\r
270                 set c_iMinAddr to l_iMinAddr\r
271             end\r
272             get c_iCount to l_iCount\r
273             get c_nDist to l_nDist\r
274             increment l_iCount\r
275             set c_iCount to l_iCount\r
276             set c_nDist to (number(l_iCount)/(l_iMaxAddr-l_iMinAddr))\r
277             end\r
278         end\r
279     end_procedure\r
280     \r
281     procedure remove_link integer l_iAddr\r
282         local integer l_iMinAddr l_iMaxAddr l_iPrev l_iNext l_iOn l_iCount\r
283         local string l_sBuf\r
284         local number l_nDist\r
285         \r
286         if (l_iAddr < 0) custom_error ERROR_CODE_INVALID_ADDRESS$ ERROR_MSG_INVALID_ADDRESS l_iAddr\r
287         else begin\r
288             get c_iMaxAddr to l_iMaxAddr\r
289             get c_iMinAddr to l_iMinAddr\r
290             forward get string_value item l_iAddr to l_sBuf\r
291             \r
292             move (integer(left(l_sBuf,pos(",",l_sBuf)-1))) to l_iPrev\r
293             move (integer(right(l_sBuf,(length(l_sBuf)-pos(",",l_sBuf))))) to l_iNext\r
294             \r
295             if (show_debug_lines) begin\r
296                 showln "DEBUG: Remove address: " l_iAddr " Link data '" l_sBuf "'"\r
297             end\r
298             \r
299             if (l_iPrev <> -1) set next_link item l_iPrev to l_iNext\r
300             if (l_iNext <> -1) set prev_link item l_iNext to l_iPrev\r
301             forward set array_value item l_iAddr to ""\r
302             \r
303             if (l_iMaxAddr = l_iAddr) set c_iMaxAddr to l_iPrev            \r
304             if (l_iMinAddr = l_iAddr) set c_iMinAddr to l_iNext            \r
305             \r
306             get c_iCount to l_iCount\r
307             get c_nDist to l_nDist\r
308             decrement l_iCount\r
309             set c_iCount to l_iCount\r
310             set c_nDist to (number(l_iCount)/(l_iMaxAddr-l_iMinAddr))                        \r
311         end        \r
312     end_procedure\r
313 \r
314 end_class\r
315 \r
316 // Hashtable class - unlike other similar "hash" data structures which usually\r
317 // store key/value pairs; the hashtable class was only initially intended to \r
318 // store a key and return a hash index.  Typical use would usually have been \r
319 // to then store the value in an array at the hash index.  (See the "hash" class\r
320 // below for a key/value orientated class)\r
321 // It is however possible to use insert_at_hash and find_at_hash to store a different\r
322 // value at a particular key hash, this is however an afterthought and colisions are \r
323 // possible.\r
324 //\r
325 // Send message methods:\r
326 //    delete_data       - Clear the hashtable\r
327 //    hash_algorithm    - Set the hash algorithm, any of ("hash_for_df_arrays", \r
328 //                        "hash_reduced_djb2", "hash_reduced_lazy", "hash_reduced_sdbm")\r
329 //                        with "hash_for_df_arrays" being the default.\r
330 //    remove_hash       - Removes an item from the hashtable.\r
331 //\r
332 // Set methods:\r
333 //    item_ptr          - Set the index of the current item_ptr (next_hash will return the next item from this)\r
334 //\r
335 // Get methods:\r
336 //    item_count\r
337 //    insert_hash       - Insert a value (where the key is equal to the value) and return hash index\r
338 //    insert_at_hash    - Insert a value at the hash index of a key and return hash index\r
339 //    find_hash         - Check if a value is stored in the hash (where the key is equal to the value) and return it's hash index\r
340 //    find_at_hash      - Check if a value is stored in the hash at the hash index of a key and return it's hash index\r
341 //    value_at_index    - Return the value stored at a particular hash index\r
342 //    string_at_index   - Same as above, but specifically retun in string context\r
343 //    next_hash         - Get the next value stored in the hash\r
344 //    item_ptr          - Get the index of the last value returned by next_hash\r
345 //\r
346 // Example usage:\r
347 //\r
348 //    object myHashtable is a hashTable\r
349 //    end_object\r
350 //\r
351 //    integer i ix\r
352 //    string k\r
353 //\r
354 //    clearscreen\r
355 //    get insert_hash of (myHashtable(current_object)) item "ABC" to i\r
356 //    get insert_hash of (myHashtable(current_object)) item "HELLO" to ix\r
357 //    get insert_hash of (myHashtable(current_object)) item "ZZZ" to i\r
358 //    send remove_hash to (myHashtable(current_object)) ix\r
359 //    get item_count of (myHashtable(current_object)) to i  \r
360 //\r
361 //    get find_hash of (myHashtable(current_object)) item "HELLO" to i\r
362 //    showln i\r
363 //\r
364 //    set item_ptr of (myHashTable(current_object)) to 0\r
365 //    move 0 to i\r
366 //    while (i  <> -1)\r
367 //        get next_hash of (myHashtable(current_object)) to k\r
368 //        get item_ptr of (myHashtable(current_object)) to i  \r
369 //\r
370 //        showln "*** " i " " k\r
371 //        inkey k\r
372 //    loop\r
373 //\r
374 class hashtable is an array\r
375     procedure construct_object integer argc\r
376         forward send construct_object\r
377         property integer c_iMaxHash public argc\r
378         property integer c_iMinHash\r
379         property integer c_iItems\r
380         property integer c_iItemP\r
381         property string c_sHashAlgorithm\r
382         set c_sHashAlgorithm to "hash_for_df_arrays"\r
383         set c_iMinHash to 99999999\r
384     end_procedure\r
385         \r
386     procedure delete_data\r
387         set c_iMinHash to 0\r
388         set c_iMaxHash to 0\r
389         set c_iItems to 0\r
390         set c_iItemP to 0\r
391         forward send delete_data\r
392     end_procedure\r
393         \r
394     procedure hash_algorithm string l_sType\r
395         local integer l_iItems\r
396         \r
397         get c_iItems to l_iItems\r
398         \r
399         // Allow algorithm change only when empty.\r
400         if (l_iItems = 0) begin\r
401             if (trim(lowercase(l_sType)) = "hash_for_df_arrays") set c_sHashAlgorithm to "hash_for_df_arrays"\r
402             if (trim(lowercase(l_sType)) = "hash_reduced_djb2") set c_sHashAlgorithm to "hash_reduced_djb2"\r
403             if (trim(lowercase(l_sType)) = "hash_reduced_sdbm") set c_sHashAlgorithm to "hash_reduced_sdbm"\r
404             if (trim(lowercase(l_sType)) = "hash_reduced_lazy") set c_sHashAlgorithm to "hash_reduced_lazy"\r
405         end\r
406     end_procedure\r
407         \r
408     procedure set item_ptr integer l_iItemP\r
409         set c_iItemP to l_iItemp\r
410     end_procedure\r
411         \r
412     function item_ptr returns integer\r
413         local integer l_iItemP\r
414         get c_iItemP to l_iItemP\r
415         function_return l_iItemP\r
416     end_function\r
417         \r
418     procedure remove_hash integer l_iHash\r
419         local string l_sNext\r
420         local integer l_iItems\r
421         \r
422         get c_iItems to l_iItems\r
423         if (l_iItems > 0) begin\r
424             forward get array_value item (l_iHash+1) to l_sNext\r
425             if (trim(l_sNext) <> "") forward set array_value item l_iHash to "<!!#ITEM REMOVED#!!>"\r
426             if (trim(l_sNext) = "") forward set array_value item l_iHash to ""\r
427             set c_iItems to (l_iItems-1)\r
428         end\r
429     end_procedure\r
430         \r
431     function item_count returns integer\r
432             local integer l_iItems\r
433             get c_iItems to l_iItems\r
434             function_return l_iItems\r
435     end_procedure\r
436         \r
437     function write_hash string l_sHash string l_sValue returns integer\r
438         local integer l_iHash l_iMinHash l_iMaxHash l_iItems l_iReuse\r
439         local string l_sTmp l_sHashAlgorithm l_sStorage\r
440 \r
441         if (l_sValue = "") begin\r
442             move l_sHash to l_sStorage\r
443         end\r
444         else begin\r
445             move l_sValue to l_sStorage\r
446         end\r
447 \r
448         // Get our object properties\r
449         get c_iMaxHash to l_iMaxHash\r
450         get c_iMinHash to l_iMinHash\r
451         get c_iItems to l_iItems\r
452         get c_sHashAlgorithm to l_sHashAlgorithm\r
453         \r
454         // Generate an initial hash\r
455         move 0 to l_iHash\r
456         \r
457         case begin\r
458             case (l_sHashAlgorithm = "hash_reduced_djb2") move (reduce_hash(hash_djb2(l_sHash))) to l_iHash\r
459             case break\r
460             case (l_sHashAlgorithm = "hash_reduced_sdbm") move (reduce_hash(hash_sdbm(l_sHash))) to l_iHash\r
461             case break\r
462             case (l_sHashAlgorithm = "hash_reduced_lazy") move (reduce_hash(hash_lazy(l_sHash))) to l_iHash\r
463             case break\r
464             case else move (hash_for_df_arrays(l_sHash)) to l_iHash\r
465             case break\r
466         case end\r
467         \r
468         // Then we check in the array to see if out hash is available or equal\r
469         // if not we bucket the value by moveing along into the next available slot\r
470         move 0 to l_iReuse\r
471         next_bucket01:\r
472         forward get string_value item l_iHash to l_sTmp\r
473         if ((l_sTmp <> "") and (l_sTmp <> l_sStorage)) begin\r
474             // If we come across a removed item we may want to reuse the hash space\r
475             if ((l_sTmp = "<!!#ITEM REMOVED#!!>") and (l_iReuse = 0)) move l_iHash to l_iReuse \r
476             calc (l_iHash+1) to l_iHash\r
477             goto next_bucket01\r
478         end\r
479             \r
480         // If this is a new object and we have a slot to reuse then do so here\r
481         if ((l_iReuse <> 0) and (l_sTmp = "")) move l_iReuse to l_iHash \r
482         if (l_iHash > l_iMaxHash) move l_iHash to l_iMaxHash\r
483         if (l_iHash < l_iMinHash) move l_iHash to l_iMinHash\r
484         forward set array_value item l_iHash to l_sStorage\r
485         \r
486         set c_iMaxHash to l_iMaxHash\r
487         set c_iMinHash to l_iMinHash\r
488         set c_iItems to (l_iItems+1)\r
489         \r
490         function_return l_iHash\r
491     end_function\r
492 \r
493     function insert_hash string l_sHash returns integer\r
494         local integer l_iHash\r
495         get write_hash item l_sHash item "" to l_iHash\r
496         function_return l_iHash\r
497     end_procedure\r
498         \r
499     function insert_at_hash string l_sHash string l_sValue returns integer\r
500         local integer l_iHash\r
501         get write_hash item l_sHash item l_sValue to l_iHash\r
502         function_return l_iHash\r
503     end_procedure\r
504         \r
505     function read_hash string l_sHash string l_sValue returns integer\r
506         local integer l_iHash l_iMinHash l_iMaxHash l_iItems\r
507         local string l_sTmp l_sHashAlgorithm l_sStorage\r
508 \r
509         if (l_sValue = "") begin\r
510             move l_sHash to l_sStorage\r
511         end\r
512         else begin\r
513             move l_sValue to l_sStorage\r
514         end\r
515 \r
516         // Get our object properties\r
517         get c_iMaxHash to l_iMaxHash\r
518         get c_iMinHash to l_iMinHash\r
519         get c_iItems to l_iItems\r
520         get c_sHashAlgorithm to l_sHashAlgorithm\r
521         \r
522         // Generate an initial hash\r
523         move 0 to l_iHash\r
524         \r
525         case begin\r
526             case (l_sHashAlgorithm = "hash_reduced_djb2") move (reduce_hash(hash_djb2(l_sHash))) to l_iHash\r
527             case break\r
528             case (l_sHashAlgorithm = "hash_reduced_sdbm") move (reduce_hash(hash_sdbm(l_sHash))) to l_iHash\r
529             case break\r
530             case (l_sHashAlgorithm = "hash_reduced_lazy") move (reduce_hash(hash_lazy(l_sHash))) to l_iHash\r
531             case break\r
532             case else move (hash_for_df_arrays(l_sHash)) to l_iHash\r
533             case break\r
534         case end\r
535 \r
536         // Then we check in the array to see if our hash is available or equal\r
537         // if not we bucket the value by moveing along into the next available slot\r
538         next_bucket02:\r
539         forward get string_value item l_iHash to l_sTmp\r
540         \r
541         if ((l_sTmp <> "") and (l_sTmp <> l_sStorage)) begin\r
542                 calc (l_iHash+1) to l_iHash\r
543                 goto next_bucket02\r
544         end\r
545         if (l_sTmp <> l_sStorage) move -1 to l_iHash\r
546         \r
547         function_return l_iHash\r
548     end_function\r
549     \r
550     function find_hash string l_sHash returns integer\r
551         local integer l_iHash\r
552         get read_hash item l_sHash item "" to l_iHash\r
553         function_return l_iHash\r
554     end_function\r
555     \r
556     function find_at_hash string l_sHash string l_sValue returns integer\r
557         local integer l_iHash\r
558         get read_hash item l_sHash item l_sValue to l_iHash\r
559         function_return l_iHash\r
560     end_function\r
561 \r
562     function value_at_index integer l_iHash returns string\r
563         local string l_sBuf\r
564 \r
565         forward get array_value item l_iHash to l_sBuf\r
566         \r
567         function_return l_sBuf\r
568     end_function\r
569     \r
570     function string_at_index integer l_iHash returns string\r
571         local string l_sBuf\r
572 \r
573         forward get string_value item l_iHash to l_sBuf\r
574         \r
575         function_return l_sBuf\r
576     end_function    \r
577     \r
578     function next_hash returns string\r
579         local string l_sBuf\r
580         local integer l_iItemP l_iMaxHash l_iMinHash\r
581         \r
582         get c_iItemP to l_iItemP\r
583         get c_iMaxHash to l_iMaxHash\r
584         get c_iMinHash to l_iMinHash\r
585         \r
586         if (l_iMinHash > l_iItemP) move (l_iMinHash-1) to l_iItemP\r
587         \r
588         move "" to l_sBuf\r
589         while ((l_sBuf = "") and (l_iItemP <= l_iMaxHash))\r
590             increment l_iItemP \r
591             forward get array_value item l_iItemP to l_sBuf\r
592             if (trim(l_sBuf) = "<!!#ITEM REMOVED#!!>") move "" to l_sBuf            \r
593         loop\r
594         \r
595         if (l_iItemP > l_iMaxHash) move -1 to l_iItemP\r
596         set c_iItemP to l_iItemP\r
597     \r
598         function_return l_sBuf\r
599     end_function \r
600     \r
601 end_class\r
602 \r
603 // Hash class - more akin to similar "hash" data structures in other languages\r
604 // which stores key/value pairs.\r
605 // This is a quick 5 minute implementation, it depends on the hashtable object \r
606 // above for it's hashing.\r
607 //\r
608 // Send message methods:\r
609 //\r
610 //    truncate          - Clear the hash\r
611 //    remove_key        - Removes a key/value pair from the hash\r
612 //\r
613 // Set methods:\r
614 //    value_at_key      - Gets the value stored for a particular key\r
615 //\r
616 // Get methods:\r
617 //    insert_key        - Inserts a key/value pair into the hash\r
618 //    value_at_key      - Retrieves the value stored for a particular key\r
619 //    item_count        - Retrieves the count of items in the hash\r
620 //\r
621 //    Example usage:\r
622 //    \r
623 //    \r
624 //    string key iv buf\r
625 //    integer i\r
626 //    \r
627 //    object test is a hash\r
628 //    end_object\r
629 //    \r
630 //    send insert_key to test "INDEX 1" "VALUE 1"\r
631 //    send insert_key to test "INDEX 2" "VALUE 2"\r
632 //    send insert_key to test "INDEX 3" "VALUE 3"\r
633 //    \r
634 //    get first_key of test to key\r
635 //    showln "KEY " key\r
636 //    get value_at_key of test item key to buf\r
637 //    showln "VALUE " buf\r
638 //    \r
639 //    while (key <> "") \r
640 //        get next_key of test key to key\r
641 //        if (key <> "") begin\r
642 //            showln "KEY " key\r
643 //            get value_at_key of test item key to buf\r
644 //            showln "VALUE " buf\r
645 //        end\r
646 //    loop\r
647 //    \r
648 //    set value_at_key of test item "INDEX 2" item "VALUE TWO"\r
649 //    showln "SET VALUE AT 'INDEX 2'"\r
650 //    \r
651 //    get value_at_key of test item "INDEX 1" to buf\r
652 //    showln "LOOKUP 'INDEX 1' = " buf\r
653 //    get value_at_key of test item "INDEX 2" to buf\r
654 //    showln "LOOKUP 'INDEX 2' = " buf\r
655 //    \r
656 //    get item_count of test to i\r
657 //    showln "ITEM COUNT " i\r
658 //    \r
659 //    send remove_key to test "INDEX 3"\r
660 //    showln "REMOVE AT KEY: 'INDEX 3'"\r
661 //    \r
662 //    get item_count of test to i\r
663 //    showln "ITEM COUNT " i\r
664 //    \r
665 //    get value_at_key of test item "INDEX 3" to buf\r
666 //    showln "LOOKUP 'INDEX 3' =" buf\r
667 //    \r
668 //    send truncate to test\r
669 //    showln "TRUNCATED"\r
670 //    \r
671 //    get value_at_key of test item "INDEX 1" to buf\r
672 //    showln "LOOKUP 'INDEX 1' = " buf\r
673 //    \r
674 //    get item_count of test to i\r
675 //    showln "EMPTY COUNT " i\r
676 //\r
677 class hash is an array\r
678     procedure construct_object integer argc\r
679         object keystore is a hashtable\r
680         end_object\r
681         \r
682         object linkstore is a linkedlist\r
683         end_object\r
684         \r
685         forward send construct_object\r
686     end_procedure\r
687 \r
688     procedure truncate\r
689         send delete_data to (keystore(current_object))\r
690         send delete_data to (linkstore(current_object))\r
691         \r
692         forward send delete_data\r
693     end_procedure    \r
694     \r
695     procedure remove_key string l_sKey\r
696         local integer l_iIndex\r
697         get find_hash of (keystore(current_object)) item l_sKey to l_iIndex\r
698         if (l_iIndex <> -1) begin\r
699             send remove_hash to (keystore(current_object)) l_iIndex\r
700             send remove_link to (linkstore(current_object)) l_iIndex\r
701             forward set array_value item l_iIndex to ""\r
702         end\r
703     end_procedure\r
704     \r
705     procedure set value_at_key string l_sKey string l_sValue\r
706         local integer l_iIndex\r
707         \r
708         get find_hash of (keystore(current_object)) item l_sKey to l_iIndex\r
709         forward set array_value item l_iIndex to l_sValue\r
710         \r
711     end_procedure\r
712     \r
713     procedure insert_key string l_sKey string l_sValue\r
714         local integer l_iIndex\r
715         \r
716         get insert_hash of (keystore(current_object)) item l_sKey to l_iIndex\r
717         send insert_link to (linkstore(current_object)) l_iIndex\r
718         forward set array_value item l_iIndex to l_sValue\r
719         \r
720     end_procedure\r
721     \r
722     function value_at_key string l_sKey returns string\r
723         local integer l_iIndex\r
724         local string l_sValue\r
725         \r
726         get find_hash of (keystore(current_object)) item l_sKey to l_iIndex\r
727         forward get string_value item l_iIndex to l_sValue\r
728         \r
729         function_return l_sValue\r
730     end_function\r
731     \r
732     function first_key returns string\r
733         local integer l_iIndex\r
734         local string l_sKey\r
735         \r
736         get first_link of (linkstore(current_object)) to l_iIndex\r
737         get string_at_index of (keystore(current_object)) item l_iIndex to l_sKey\r
738 \r
739         function_return l_sKey\r
740     end_function    \r
741     \r
742     function next_key string l_sKey returns string\r
743         local integer l_iIndex\r
744         \r
745         get find_hash of (keystore(current_object)) item l_sKey to l_iIndex\r
746         get next_link of (linkstore(current_object)) item l_iIndex to l_iIndex\r
747         get string_at_index of (keystore(current_object)) item l_iIndex to l_sKey\r
748 \r
749         function_return l_sKey\r
750     end_function\r
751     \r
752     function item_count returns integer\r
753         local integer l_iResult\r
754         get item_count of (keystore(current_object)) to l_iResult\r
755         \r
756         function_return l_iResult\r
757     end_function\r
758 end_class\r
759 \r
760 // Matrix class - Provides an indexed two-dimensional array / matrix class\r
761 //\r
762 // This class is sensitive to ascii char 1, which is used for delimiting values \r
763 // within the second dimension.  The implimentation is rather unrefined and \r
764 // stores delimited values within an array, thus the wider the matrix the \r
765 // slower any adding removing or sorting will be. \r
766 //\r
767 // This is designed purely as a convenience to provide something matrix like within \r
768 // the limitations of DataFlex 3.2 Console Mode; be sure to keep this in mind before \r
769 // using.\r
770 //\r
771 // To allow quick lookup of linked data, a hash index may be created on one column \r
772 // of a matrix at a time.\r
773 // A hash index may be added both before and after populating the matrix with your \r
774 // data.\r
775 //\r
776 // As with a hash table the hasing algorithm may be set for the matrix, but to take\r
777 // affect this must be called before the hash_on_column message. (see hash.inc \r
778 // function for available algorithms)\r
779 //        \r
780 // The hash_is_unique and remove_hash_is_unique messages allow enforcement of unique\r
781 // values in the hashed column.  If the hash_is_unique message is sent after the \r
782 // creation of a hash index on a matrix already populated with data the constraint will \r
783 // only apply to new data.\r
784 //    \r
785 // The hash may also be removed from the column (freeing up any memory used, which can\r
786 // be fairly large) at any time, this allows for removing the hash from one column and \r
787 // re-assigning it to another or changing hash algorithm on the same data.\r
788 //  \r
789 // Lookups on the hash index are performed with the matrix_index_from_value, matrix_index_count_from_value\r
790 //\r
791 // Send message methods:\r
792 //    delete_data                   - Clear the matrix\r
793 //    matrix_sort                   - Y pos to sort on\r
794 //    matrix_delete                 - X and Y pos to delete \r
795 //    delete_item                   - X position to delete (this reshuffles the matrix; avoid using)\r
796 //    hash_on_column_algorithm      - Hash algorithm to use\r
797 //    hash_on_column                - Y pos of column to hash\r
798 //    remove_hash_on_column         - Remove the hash from the column\r
799 //    hash_is_unique                - Add a unique constraint on the hash\r
800 //    remove_hash_is_unique         - Remove a unique constraint from the hash\r
801 //    matrix_index_lookup_clear     - Clear the lookup buffer\r
802 //\r
803 // Set methods:\r
804 //    matrix_value                  - Set a value at X, Y\r
805 //    matrix_string    \r
806 //\r
807 // Get methods:\r
808 //    matrix_value                  - Get a value at X, Y\r
809 //    matrix_string                 - Get an string value at X, Y\r
810 //    matrix_integer                - Get an integer value at X, Y\r
811 //    matrix_numeric                - Get an numeric value at X, Y\r
812 //    matrix_real                   - Get an real value at X, Y\r
813 //    matrix_hash_from_value        - Get the hash index value used for an indexed column value\r
814 //    matrix_indextable_from_value  - Get list of matrix x pos indexes for a particular hashed value\r
815 //    matrix_index_lookup_clear     - Clear the buffer for an indexed lookup\r
816 //    matrix_index_count_from_value - Get a count of rows with a particular value\r
817 //    matrix_index_from_value       - Get the next X pos (row) with indexed value. Returns -1 when nothing left to find.\r
818 //    \r
819 // Example usage:\r
820 //\r
821 //\r
822 //    object test is a matrix\r
823 //    end_object\r
824 //\r
825 //    set matrix_value of (test(current_object)) item 0 item 1 to "1"    - x then y pos to Value\r
826 //    get matrix_value of (test(current_object)) item 0 item 1 to tmpStr - x then y pos to Value\r
827 //    send matrix_sort to (test(current_object)) 1               - x then y pos to sort by\r
828 //    send matrix_delete to (test(current_object)) 1 1           - x then y pos to delete \r
829 //    send matrix_delete_row to (test(current_object)) 1             - x essentially blanks record out, no reshuffle\r
830 //    send delete_item to (test1(current_object)) 1              - x pos (not v efficient), reshuffles\r
831 //\r
832 // Hash indexed columns usage:\r
833 //\r
834 //    send hash_on_column_algorithm to (test(current_object)) "hash_reduced_lazy"\r
835 //    send hash_on_column to (test(current_object)) 0\r
836 //    send remove_hash_on_column to (test(current_object)) \r
837 //    send hash_is_unique to (test(current_object)) \r
838 //    \r
839 //    send matrix_index_lookup_clear to (test(current_object)) \r
840 //    get matrix_index_count_from_value of (test(current_object)) item "1" to count\r
841 //    get matrix_index_from_value of (test(current_object)) item "1" to x_pos   \r
842 //    get matrix_indextable_from_value of (test(current_object)) item "1" to tmpStr \r
843 //    get matrix_hash_from_value of (test(current_object)) item "1" to tmpInt   \r
844 \r
845 class matrix is an array\r
846     procedure construct_object integer argc\r
847         object mTokens is a StringTokenizer\r
848         end_object\r
849     \r
850         forward send construct_object\r
851         property integer c_iWidth public argc\r
852         property integer c_iHashOn\r
853         property integer c_iLastIndexTableHash\r
854         property integer c_iLastIndexTablePos\r
855         property integer c_iEnforceUnique\r
856         property string c_sHashAlgorithm\r
857         \r
858         set c_sHashAlgorithm to ""\r
859         set c_iHashOn to -1\r
860         set c_iLastIndexTableHash to -1\r
861         set c_iLastIndexTablePos to -1\r
862         set c_iEnforceUnique to 0\r
863     end_procedure\r
864     \r
865     procedure hash_on_column_algorithm string hashalg\r
866         if ((hashalg = "hash_reduced_djb2") or (hashalg = "hash_reduced_sdbm") or (hashalg = "hash_reduced_lazy") or (hashalg = "hash_for_df_arrays") or (hashalg = "")) begin\r
867             set c_sHashAlgorithm to hashalg\r
868         end     \r
869     end_procedure\r
870     \r
871     procedure hash_is_unique\r
872         set c_iEnforceUnique to 1\r
873     end_procedure   \r
874     \r
875     procedure remove_hash_is_unique\r
876         set c_iEnforceUnique to 0\r
877     end_procedure   \r
878     \r
879     procedure hash_on_column integer l_iColumn\r
880         local integer l_iMax l_iHashOn l_i l_iHash l_iEnforceUnique l_iHashError\r
881         local string l_sBuf l_sTmp l_sHashAlgorithm \r
882         \r
883         forward get item_count to l_iMax\r
884         get c_iHashOn to l_iHashOn\r
885         \r
886         // Allow adding hash only when no hash already set\r
887         if ((l_iHashOn = -1) and (l_iColumn >= 0)) begin\r
888                             \r
889             object mHash_array is an array\r
890             end_object              \r
891                 \r
892             object mHash_table is a hashTable\r
893             end_object\r
894                 \r
895             get c_sHashAlgorithm to l_sHashAlgorithm\r
896             get c_iEnforceUnique to l_iEnforceUnique\r
897             \r
898             if (l_sHashAlgorithm <> "") begin\r
899                 send hash_algorithm to (mHash_table(current_object)) l_sHashAlgorithm\r
900             end\r
901             \r
902             if (l_iMax <> 0) begin\r
903                 // Hash the current matrix if not empty\r
904                 move (l_iMax-1) to l_iMax       \r
905                 \r
906                 for l_i from 0 to l_iMax\r
907                     forward get array_value item l_i to l_sBuf\r
908                 \r
909                     send delete_data to (mTokens(current_object))\r
910                     send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
911                     get token_value of (mTokens(current_object)) item l_iColumn to l_sTmp                                       \r
912                     get insert_hash of (mHash_table(current_object)) item l_sTmp to l_iHash\r
913                     get string_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
914                         \r
915                     if ((l_iEnforceUnique = 1) and (length(replace("|",l_sTmp,"")) <> 0)) begin\r
916                         custom_error ERROR_CODE_DUPLICATE_HASH_KEY$ ERROR_MSG_DUPLICATE_HASH_KEY ERROR_DETAIL_DUPLICATE_HASH_KEY l_iColumn\r
917                         move 1 to l_iHashError\r
918                         break\r
919                     end\r
920                     else if not (l_sTmp contains ("|"+string(l_i)+"|")) begin\r
921                         if (length(l_sTmp) = 0) move "|" to l_sTmp\r
922                         append l_sTmp (string(l_i)+"|")\r
923                         set array_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
924                     end\r
925                 loop\r
926             end\r
927                 \r
928             if (l_iHashError = 0) begin\r
929                 set c_iHashOn to l_iColumn\r
930             end\r
931             else begin\r
932                 send destroy_object to (mHash_array(current_object))\r
933                 send destroy_object to (mHash_table(current_object))                    \r
934             end\r
935         end\r
936     end_procedure\r
937         \r
938     procedure remove_hash_on_column\r
939         local integer l_iHashOn\r
940         \r
941         get c_iHashOn to l_iHashOn\r
942         \r
943         if (l_iHashOn <> -1) begin          \r
944             set c_iHashOn to -1\r
945             send destroy_object to (mHash_array(current_object))\r
946             send destroy_object to (mHash_table(current_object))\r
947         end\r
948     end_procedure\r
949         \r
950     procedure set matrix_value integer itemx integer itemy string val\r
951         local string l_sBuf l_sTmp l_sOldVal \r
952         local integer l_i l_iWidth l_iHashOn l_iHash l_iEnforceUnique l_iHashError\r
953 \r
954         move 0 to l_iHashError\r
955         get c_iWidth to l_iWidth\r
956         get c_iHashOn to l_iHashOn\r
957         \r
958         forward get array_value item itemx to l_sBuf\r
959                         \r
960         if (itemy > l_iWidth) begin\r
961                 set c_iWidth to itemy\r
962                 move itemy to l_iWidth\r
963         end\r
964 \r
965         // Delimiter is ascii char 1 (start of heading/console interrupt)\r
966         // so any values containing ascii 1 will, of course break the matrix\r
967         send delete_data to (mTokens(current_object))\r
968         send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
969         \r
970         if (l_iHashOn = itemy) begin\r
971             get token_value of (mTokens(current_object)) item itemy to l_sOldVal\r
972         end\r
973         if (val = "") set token_value of (mTokens(current_object)) item itemy to (character(3))\r
974         else set token_value of (mTokens(current_object)) item itemy to (replaces(character(1),(replaces(character(3),val,"")),""))\r
975     \r
976         move "" to l_sBuf\r
977         for l_i from 0 to l_iWidth                        \r
978             get token_value of (mTokens(current_object)) item l_i to l_sTmp                        \r
979             if (length(l_sTmp) = 0) move (character(3)) to l_sTmp        \r
980             if (length(l_sBuf) <> 0) append l_sBuf (character(1))\r
981             append l_sBuf l_sTmp\r
982         loop\r
983                 \r
984         move (replaces(character(3),l_sBuf,"")) to l_sBuf\r
985                     \r
986         // Insert/update in the value to the hash\r
987         if ((l_iHashOn = itemy) and (l_sOldVal <> val)) begin       \r
988             get c_iEnforceUnique to l_iEnforceUnique\r
989             get insert_hash of (mHash_table(current_object)) item val to l_iHash\r
990             get string_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
991             \r
992             if ((l_iEnforceUnique = 1) and (length(replace("|",l_sTmp,"")) <> 0)) begin\r
993                 custom_error ERROR_CODE_DUPLICATE_HASH_KEY$ ERROR_MSG_DUPLICATE_HASH_KEY ERROR_DETAIL_DUPLICATE_HASH_KEY itemy\r
994                 move 1 to l_iHashError\r
995             end\r
996             else if not (l_sTmp contains ("|"+string(itemx)+"|")) begin\r
997                 if (length(l_sTmp) = 0) move "|" to l_sTmp\r
998                 append l_sTmp (string(itemx)+"|")\r
999                 set array_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1000             end\r
1001  \r
1002             // Remove old hash (if any) when insert succeeds\r
1003             if (l_iHashError = 0) begin\r
1004                 get find_hash of (mHash_table(current_object)) item l_sOldVal to l_iHash\r
1005                 if (l_iHash <> 0) begin\r
1006                     get string_value of (mHash_array(current_object)) item l_iHash to l_sTmp                \r
1007                     if (l_sTmp contains ("|"+string(itemx)+"|")) begin\r
1008                         move (replace(("|"+string(itemx)+"|"),l_sTmp,"")) to l_sTmp\r
1009                         if (l_sTmp = "") begin\r
1010                             send remove_hash to (mHash_table(current_object)) l_iHash\r
1011                         end\r
1012                         else begin\r
1013                             if (left(l_sTmp,1) <> "|") move ("|"+l_sTmp) to l_sTmp\r
1014                             else append l_sTmp "|"\r
1015                         end\r
1016                         set array_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1017                     end\r
1018                 end\r
1019             end\r
1020         end\r
1021                 \r
1022         if (l_iHashError = 0) begin\r
1023             forward set array_value item itemx to l_sBuf\r
1024         end\r
1025     end_procedure\r
1026     \r
1027     function matrix_string integer itemx integer itemy returns string\r
1028         local string l_sBuf l_sTmp\r
1029 \r
1030         forward get array_value item itemx to l_sBuf\r
1031         \r
1032         send delete_data to (mTokens(current_object))\r
1033         send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1034         get token_value of (mTokens(current_object)) item itemy to l_sTmp\r
1035         \r
1036         function_return l_sTmp\r
1037     end_function        \r
1038     \r
1039     function matrix_value integer itemx integer itemy returns string\r
1040         local string l_sBuf l_sTmp\r
1041 \r
1042         forward get array_value item itemx to l_sBuf\r
1043         \r
1044         send delete_data to (mTokens(current_object))\r
1045         send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1046         get token_value of (mTokens(current_object)) item itemy to l_sTmp\r
1047         \r
1048         function_return l_sTmp\r
1049     end_function        \r
1050     \r
1051     function matrix_integer integer itemx integer itemy returns integer\r
1052         local string l_sBuf\r
1053         local integer l_iTmp\r
1054 \r
1055         forward get array_value item itemx to l_sBuf\r
1056         \r
1057         send delete_data to (mTokens(current_object))\r
1058         send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1059         get token_value of (mTokens(current_object)) item itemy to l_iTmp\r
1060         \r
1061         function_return l_iTmp\r
1062     end_function\r
1063     \r
1064     function matrix_number integer itemx integer itemy returns number\r
1065         local string l_sBuf\r
1066         local number l_nTmp\r
1067         \r
1068         forward get array_value item itemx to l_sBuf\r
1069         \r
1070         send delete_data to (mTokens(current_object))\r
1071         send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1072         get token_value of (mTokens(current_object)) item itemy to l_nTmp\r
1073         \r
1074         function_return l_nTmp\r
1075     end_function\r
1076     \r
1077     function matrix_real integer itemx integer itemy returns real\r
1078         local string l_sBuf\r
1079         local real l_rTmp\r
1080         \r
1081         forward get array_value item itemx to l_sBuf\r
1082         \r
1083         send delete_data to (mTokens(current_object))\r
1084         send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1085         get token_value of (mTokens(current_object)) item itemy to l_rTmp\r
1086         \r
1087         function_return l_rTmp\r
1088     end_function\r
1089     \r
1090     function matrix_hash_from_value string val returns integer\r
1091         local integer l_iHash l_iHashOn\r
1092         \r
1093         get c_iHashOn to l_iHashOn\r
1094                 \r
1095         if (l_iHashOn <> -1) begin\r
1096             get find_hash of (mHash_table(current_object)) item val to l_iHash\r
1097         end\r
1098 \r
1099         function_return l_iHash\r
1100     end_function\r
1101     \r
1102     function matrix_indextable_from_value string val returns string\r
1103         local integer l_iHashOn l_iHash\r
1104         local string l_sIndexTable\r
1105 \r
1106         get c_iHashOn to l_iHashOn\r
1107                 \r
1108         if (l_iHashOn <> -1) begin\r
1109             get find_hash of (mHash_table(current_object)) item val to l_iHash\r
1110             get string_value of (mHash_array(current_object)) item l_iHash to l_sIndexTable\r
1111         end\r
1112 \r
1113         function_return l_sIndexTable\r
1114     end_function\r
1115         \r
1116     procedure matrix_index_lookup_clear \r
1117         local integer l_iHashOn\r
1118         \r
1119         get c_iHashOn to l_iHashOn\r
1120     \r
1121         if (l_iHashOn <> -1) begin\r
1122             set c_iLastIndexTableHash to -1\r
1123             set c_iLastIndexTablePos to -1\r
1124         end\r
1125     end_procedure\r
1126         \r
1127     function matrix_index_from_value string val returns integer\r
1128         local integer l_iHashOn l_iHash l_iLastIndexTableHash l_iLastIndexTablePos l_iIndex l_iIndexValues\r
1129         local string l_sIndexTable\r
1130 \r
1131         get c_iHashOn to l_iHashOn\r
1132         move -1 to l_iIndex\r
1133             \r
1134         if (l_iHashOn <> -1) begin\r
1135             get find_hash of (mHash_table(current_object)) item val to l_iHash\r
1136             get string_value of (mHash_array(current_object)) item l_iHash to l_sIndexTable\r
1137 \r
1138             get c_iLastIndexTableHash to l_iLastIndexTableHash          \r
1139             \r
1140             if (l_iHash = l_iLastIndexTableHash) begin\r
1141                 get c_iLastIndexTablePos to l_iLastIndexTablePos\r
1142             end\r
1143             increment l_iLastIndexTablePos\r
1144             \r
1145             send delete_data to (mTokens(current_object))\r
1146             send set_string to (mTokens(current_object)) l_sIndexTable "|"\r
1147             get token_count of (mTokens(current_object)) to l_iIndexValues\r
1148             if (l_iLastIndexTablePos <= l_iIndexValues) begin\r
1149                 get token_value of (mTokens(current_object)) item l_iLastIndexTablePos to l_iIndex\r
1150                 set c_iLastIndexTableHash to l_iHash\r
1151                 set c_iLastIndexTablePos to l_iLastIndexTablePos\r
1152             end\r
1153             else begin\r
1154                 move -1 to l_iIndex\r
1155                 set c_iLastIndexTableHash to -1\r
1156                 set c_iLastIndexTablePos to -1\r
1157             end\r
1158         end\r
1159 \r
1160         function_return l_iIndex\r
1161     end_function\r
1162     \r
1163     function matrix_index_count_from_value string val returns integer\r
1164         local integer l_iHashOn l_iHash l_iIndexValues\r
1165         local string l_sIndexTable\r
1166     \r
1167         get c_iHashOn to l_iHashOn\r
1168     \r
1169         if (l_iHashOn <> -1) begin\r
1170             get find_hash of (mHash_table(current_object)) item val to l_iHash\r
1171             get string_value of (mHash_array(current_object)) item l_iHash to l_sIndexTable\r
1172     \r
1173             send delete_data to (mTokens(current_object))\r
1174             send set_string to (mTokens(current_object)) l_sIndexTable "|"\r
1175             get token_count of (mTokens(current_object)) to l_iIndexValues\r
1176         end\r
1177     \r
1178         function_return l_iIndexValues\r
1179     end_function\r
1180         \r
1181     procedure set item_count integer newVal\r
1182         forward set item_count to newVal\r
1183     end_procedure\r
1184         \r
1185     procedure matrix_delete integer itemx integer itemy\r
1186         local string l_sBuf l_sTmp l_sOldVal\r
1187         local integer l_i l_iWidth l_iHashOn l_iHash\r
1188 \r
1189         get c_iWidth to l_iWidth\r
1190         get c_iHashOn to l_iHashOn\r
1191     \r
1192         forward get array_value item itemx to l_sBuf\r
1193             \r
1194         send delete_data to (mTokens(current_object))\r
1195         send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1196         \r
1197         if (l_iHashOn = itemy) begin                \r
1198             get token_value of (mTokens(current_object)) item itemy to l_sOldVal\r
1199         end\r
1200         set token_value of (mTokens(current_object)) item itemy to (character(3))\r
1201 \r
1202         move "" to l_sBuf\r
1203         for l_i from 0 to l_iWidth\r
1204             get token_value of (mTokens(current_object)) item l_i to l_sTmp\r
1205             if (length(l_sTmp) = 0) move (character(3)) to l_sTmp\r
1206             if (length(l_sBuf) <> 0) append l_sBuf (character(1))\r
1207             append l_sBuf l_sTmp\r
1208         loop\r
1209         move (replaces(character(3),l_sBuf,"")) to l_sBuf\r
1210 \r
1211         forward set array_value item itemx to l_sBuf\r
1212         \r
1213         // Delete in the value to the hash\r
1214         if (l_iHashOn = itemy) begin                \r
1215             get find_hash of (mHash_table(current_object)) item l_sOldVal to l_iHash\r
1216             if (l_iHash <> 0) begin                     \r
1217         get string_value of (mHash_array(current_object)) item l_iHash to l_sTmp                    \r
1218         if (l_sTmp contains ("|"+string(itemx)+"|")) begin\r
1219             move (replace(("|"+string(itemx)+"|"),l_sTmp,"")) to l_sTmp\r
1220             if (l_sTmp = "") begin\r
1221                 send remove_hash to (mHash_table(current_object)) l_iHash\r
1222             end\r
1223             else begin\r
1224                 if (left(l_sTmp,1) <> "|") move ("|"+l_sTmp) to l_sTmp\r
1225                 else append l_sTmp "|"\r
1226             end\r
1227             set array_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1228         end                             \r
1229             end\r
1230         end\r
1231     end_procedure\r
1232         \r
1233     // Inefficient.\r
1234     procedure delete_item integer itemx                \r
1235         local string l_sBuf l_sOldVal l_sTmp l_sIndexTable\r
1236         local integer l_iHashOn l_iHash l_i l_j l_iItems l_iIndexValues l_iIndex\r
1237         \r
1238         get c_iHashOn to l_iHashOn\r
1239         // Delete in the value to the hash\r
1240         if (l_iHashOn <> -1) begin\r
1241             forward get array_value item itemx to l_sBuf\r
1242             send delete_data to (mTokens(current_object))\r
1243             send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1244             get token_value of (mTokens(current_object)) item l_iHashOn to l_sOldVal\r
1245             get find_hash of (mHash_table(current_object)) item l_sOldVal to l_iHash\r
1246             if (l_iHash <> 0) begin                     \r
1247                 get string_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1248                 if (l_sTmp contains ("|"+string(itemx)+"|")) begin\r
1249                     move (replace(("|"+string(itemx)+"|"),l_sTmp,"")) to l_sTmp\r
1250                     if (l_sTmp = "") begin\r
1251                         send remove_hash to (mHash_table(current_object)) l_iHash\r
1252                     end\r
1253                     else begin\r
1254                         if (left(l_sTmp,1) <> "|") move ("|"+l_sTmp) to l_sTmp\r
1255                         else append l_sTmp "|"\r
1256                     end\r
1257                     set array_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1258                 end                     \r
1259             end\r
1260                 \r
1261             forward get item_count to l_iItems\r
1262         \r
1263             for l_i from (itemx+1) to l_iItems\r
1264         \r
1265                 forward get array_value item l_i to l_sBuf\r
1266                 send delete_data to (mTokens(current_object))\r
1267                 send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1268                 get token_value of (mTokens(current_object)) item l_iHashOn to l_sOldVal\r
1269                 get find_hash of (mHash_table(current_object)) item l_sOldVal to l_iHash\r
1270                 \r
1271                 if (l_iHash <> 0) begin\r
1272                     get string_value of (mHash_array(current_object)) item l_iHash to l_sIndexTable\r
1273                     \r
1274                     send delete_data to (mTokens(current_object))\r
1275                     send set_string to (mTokens(current_object)) l_sIndexTable "|"\r
1276                     get token_count of (mTokens(current_object)) to l_iIndexValues\r
1277                     move "|" to l_sIndexTable\r
1278                     for l_j from 1 to l_iIndexValues\r
1279                         get token_value of (mTokens(current_object)) item l_j to l_iIndex\r
1280                         if (l_iIndex = l_i) calc (l_iIndex-1) to l_iIndex\r
1281                         append l_sIndexTable (string(l_iIndex)+"|")\r
1282                     loop\r
1283                     \r
1284                     set array_value of (mHash_array(current_object)) item l_iHash to l_sIndexTable\r
1285                 end\r
1286             loop\r
1287             \r
1288         end\r
1289             \r
1290         forward send delete_item to current_object itemx\r
1291     end_procedure\r
1292 \r
1293     procedure matrix_sort integer itemy string order \r
1294         local string l_sBuf l_sTmp l_sTmp2 l_sHash\r
1295         local integer l_iX l_i l_j l_iMax l_iPoolMax l_iWidth l_iThrow l_iNumCount l_iHashOn l_iHash\r
1296         \r
1297         move (trim(uppercase(order))) to order\r
1298         if ((order <> "ASCENDING") and (order <> "DESCENDING")) move "ASCENDING" to order\r
1299         \r
1300         object mSort_array is an array\r
1301         end_object\r
1302         object mClone_array is an array\r
1303         end_object\r
1304         \r
1305         get c_iHashOn to l_iHashOn\r
1306         get c_iWidth to l_iWidth\r
1307         forward get item_count to l_iMax\r
1308         \r
1309         send delete_data to (mSort_array(current_object))\r
1310         send delete_data to (mClone_array(current_object))\r
1311         \r
1312         if (l_iHashOn <> -1) begin\r
1313             send delete_data to (mHash_array(current_object))\r
1314         end\r
1315         \r
1316         move (l_iMax-1) to l_iMax       \r
1317         \r
1318         for l_i from 0 to l_iMax\r
1319             forward get array_value item l_i to l_sBuf\r
1320             \r
1321             send delete_data to (mTokens(current_object))\r
1322             send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1323             get token_value of (mTokens(current_object)) item itemy to l_sTmp\r
1324         \r
1325             move 0 to l_iNumCount \r
1326             for l_j from 1 to (length(l_sTmp))\r
1327                 if (((ascii(mid(l_sTmp,1,l_j))) >= 48) and ((ascii(mid(l_sTmp,1,l_j))) <= 57) or ((ascii(mid(l_sTmp,1,l_j))) = 46)) begin\r
1328                     increment l_iNumCount\r
1329                 end\r
1330             loop\r
1331             if ((length(l_sTmp) > 0) and (length(l_sTmp) = l_iNumCount)) begin\r
1332                 set array_value of (mSort_array(current_object)) item l_i to (number(l_sTmp))\r
1333             end\r
1334             else begin\r
1335                 if (length(l_sTmp) = 0) move (character(2)) to l_sTmp\r
1336                 set array_value of (mSort_array(current_object)) item l_i to l_sTmp\r
1337             end\r
1338         loop\r
1339         \r
1340         if (order = "ASCENDING") send sort_items to (mSort_array(current_object)) ascending\r
1341         if (order = "DESCENDING") send sort_items to (mSort_array(current_object)) descending\r
1342 \r
1343         move l_iMax to l_iPoolMax\r
1344 \r
1345         for l_i from 0 to l_iMax\r
1346             get array_value of (mSort_array(current_object)) item l_i to l_sTmp\r
1347             if (l_sTmp = character(2)) move "" to l_sTmp\r
1348             \r
1349             for l_j from 0 to l_iPoolMax\r
1350                 // Ideally we'd change the next 3 lines for a lookup table instead\r
1351                 forward get array_value item l_j to l_sBuf\r
1352                 \r
1353                 send delete_data to (mTokens(current_object))\r
1354                 send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1355                 get token_value of (mTokens(current_object)) item itemy to l_sTmp2\r
1356                 \r
1357                 if (l_sTmp = l_sTmp2) begin\r
1358                     set array_value of (mClone_array(current_object)) item l_i to l_sBuf                    \r
1359                     \r
1360                     // On successful find shrink the sort pool here by moving max to l_j and decrementing max                 \r
1361                     forward get array_value item l_iPoolMax to l_sBuf\r
1362                     forward set array_value item l_j to l_sBuf\r
1363                     forward send delete_item to current_object l_iPoolMax\r
1364                     decrement l_iPoolMax                    \r
1365                         \r
1366                     // Remap hash\r
1367                     if (l_iHashOn <> -1) begin                  \r
1368                         get token_value of (mTokens(current_object)) item l_iHashOn to l_sHash\r
1369                         get find_hash of (mHash_table(current_object)) item l_sHash to l_iHash\r
1370                         get string_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1371                         if not (l_sTmp contains ("|"+string(l_i)+"|")) begin\r
1372                             if (length(l_sTmp) = 0) move "|" to l_sTmp\r
1373                             append l_sTmp (string(l_i)+"|")\r
1374                             set array_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1375                         end\r
1376                     end                    \r
1377                     goto dirty_speedup_jump\r
1378                 end\r
1379             loop\r
1380             dirty_speedup_jump:\r
1381         loop\r
1382         send delete_data to (mSort_array(current_object))\r
1383                 \r
1384         for l_i from 0 to l_iMax\r
1385             get array_value of (mClone_array(current_object)) item l_i to l_sBuf\r
1386             forward set array_value item l_i to l_sBuf                      \r
1387         loop\r
1388         \r
1389         send destroy_object to (mSort_array(current_object))  // Use "send request_destroy_object" to destroy object and all children.\r
1390         send destroy_object to (mClone_array(current_object))\r
1391     end_procedure\r
1392     \r
1393 end_class\r
1394 \r
1395 // Rss 2.0 data class - RFC-822 dates used\r
1396 //\r
1397 // Send message methods:\r
1398 //     init_rss                  - Initialise a new rss20 instance\r
1399 //     init_img                  - Initialise the image to be used in the feed\r
1400 //     add_item                  - Add an item to the feed\r
1401 //     write_rss                 - Write the feed out to disk\r
1402 //\r
1403 // Set methods:\r
1404 //    set_ttl                    - Set the TTL/refresh rate of the feed\r
1405 //    set_contacts               - Set admin contacts\r
1406 //    \r
1407 // Get methods:\r
1408 //\r
1409 // Example usage:\r
1410 //\r
1411 //    object test is an rss20\r
1412 //    end_object\r
1413 //\r
1414 //    move "" to link\r
1415 //    move "" to url\r
1416 //\r
1417 //    move "Google Maps" to title\r
1418 //    move ("http:/"+"/www.google.com/maps") to link\r
1419 //    move "Try out google maps" to desc\r
1420 //    send init_rss to (test(current_object)) title link desc\r
1421 //\r
1422 //    move ("http:/"+"/www.google.com/images/srpr/logo11w.png") to url\r
1423 //    move 19 to x\r
1424 //    move 41 to y\r
1425 //    send init_img to (test(current_object)) url x y\r
1426 //\r
1427 //    send set_ttl to (test(current_object)) 30\r
1428 //    send set_contacts to (test(current_object)) "maps@google.com" "search@google.com"\r
1429 //\r
1430 //    for i from 1 to 15\r
1431 //        move "Test item " to title\r
1432 //        append title i\r
1433 //        move ("http:/"+"/www.google.com") to link\r
1434 //        move "Test description " to desc\r
1435 //        append desc i\r
1436 //        move "NONE" to cat\r
1437 //\r
1438 //        send add_item to (test(current_object)) title link desc cat (rssdate((now("date")),(now("longtime"))))\r
1439 //    loop\r
1440 //    send write_rss to (test(current_object)) "c:\google_maps.rss"\r
1441 \r
1442 class rss20 is a matrix\r
1443     procedure construct_object string argc \r
1444         forward send construct_object argc\r
1445         property string c_rssTitle\r
1446         property string c_rssLink\r
1447         property string c_rssDesc\r
1448         \r
1449         property string c_imgTitle\r
1450         property string c_imgUrl\r
1451         property string c_imgLink\r
1452         property string c_imgDesc\r
1453         \r
1454         property string c_webMaster\r
1455         property string c_manEditor\r
1456         \r
1457         property integer c_imgx\r
1458         property integer c_imgy\r
1459         property integer c_ttl\r
1460         \r
1461         property integer c_itemCount\r
1462     end_procedure\r
1463     \r
1464     procedure init_rss string rssTitle string rssLink string rssDesc\r
1465         set c_rssTitle to rssTitle\r
1466         set c_rssLink to rssLink\r
1467         set c_rssDesc to rssDesc\r
1468         set c_itemCount to 0\r
1469     end_procedure\r
1470     \r
1471     procedure init_img string imgUrl integer imgx integer imgy\r
1472         local string imgTitle imgLink imgDesc\r
1473         get c_rssTitle to imgTitle\r
1474     get c_rssLink to imgLink\r
1475     get c_rssDesc to imgDesc\r
1476     \r
1477         set c_imgTitle to imgTitle\r
1478         set c_imgUrl to imgUrl\r
1479         set c_imgLink to imgLink\r
1480         set c_imgDesc to imgDesc\r
1481         set c_imgx to imgx\r
1482         set c_imgy to imgy\r
1483     end_procedure\r
1484     \r
1485     procedure set_ttl integer ttl\r
1486         if (ttl > 0) set c_ttl to ttl\r
1487     end_procedure\r
1488     \r
1489     procedure set_contacts string webMaster string manEditor\r
1490         if (webMaster <> "") set c_webMaster to webMaster\r
1491         if (manEditor <> "") set c_manEditor to manEditor\r
1492     end_procedure\r
1493     \r
1494     procedure add_item string itemTitle string itemLink string itemDesc string itemCat string pubDate string itemGuID\r
1495         local integer l_itemCount\r
1496         get c_itemCount to l_itemCount\r
1497     \r
1498         // The standard says we should not have more than 15 items, but ignore this.\r
1499         //if ((l_itemCount < 15) and (itemTitle <> "")) begin \r
1500         if (itemTitle <> "") begin\r
1501             increment l_itemCount\r
1502             set c_itemCount to l_itemCount\r
1503             \r
1504             forward set matrix_value item l_itemCount item 0 to itemTitle\r
1505             forward set matrix_value item l_itemCount item 1 to itemLink\r
1506             forward set matrix_value item l_itemCount item 2 to itemDesc\r
1507             forward set matrix_value item l_itemCount item 3 to itemCat\r
1508             forward set matrix_value item l_itemCount item 4 to itemGuID\r
1509             if ((pubDate <> "") and (pubDate <> "NOW")) forward set matrix_value item l_itemCount item 6 to pubDate\r
1510         end\r
1511     end_procedure\r
1512     \r
1513     procedure write_rss string rssFileName\r
1514         local string l_rssTitle l_rssLink l_rssDesc l_imgTitle l_imgUrl l_imgLink l_itemTitle l_itemLink l_itemDesc l_itemCat l_sConflict l_property l_manEditor l_webMaster l_pubDate l_itemGuID l_itemCc\r
1515         local integer l_imgx l_imgy l_itemcount l_i l_j l_iConflict l_iTtl\r
1516         \r
1517         get c_rssTitle to l_rssTitle\r
1518         get c_rssLink to l_rssLink\r
1519         get c_rssDesc to l_rssDesc\r
1520     \r
1521         get c_imgTitle to l_imgTitle\r
1522         get c_imgUrl to l_imgUrl\r
1523         get c_imgLink to l_imgLink\r
1524         get c_manEditor to l_manEditor\r
1525         get c_webMaster to l_webMaster\r
1526         \r
1527         get c_imgx to l_imgx\r
1528         get c_imgy to l_imgy\r
1529         get c_itemCount to l_itemCount\r
1530         get c_ttl to l_iTtl\r
1531     \r
1532         direct_output channel default_file_channel rssFileName\r
1533             writeln channel default_file_channel '<?xml version="1.0" ?>'\r
1534             writeln channel default_file_channel '<?xml-stylesheet type="text/xsl" href="rss.xsl" media="screen"?>'\r
1535             write channel default_file_channel '<rss version="2.0" xmlns:dc="http:/' '/purl.org/dc/elements/1.1/" xmlns:sy="http:/'\r
1536             write channel default_file_channel '/purl.org/rss/1.0/modules/syndication/" xmlns:admin="http:/' '/webns.net/mvcb/" xmlns:rdf="http:/'\r
1537             writeln channel default_file_channel '/www.w3.org/1999/02/22-rdf-syntax-ns#" xmlns:content="http:/' '/purl.org/rss/1.0/modules/content/">'\r
1538             \r
1539             // skipHours skipDays cloud - all currently not used\r
1540             // Write out Channel\r
1541             writeln channel default_file_channel '       <channel>'\r
1542             writeln channel default_file_channel '               <title>' (trim(l_rssTitle)) '</title>'\r
1543             writeln channel default_file_channel '               <link>' (trim(l_rssLink)) '</link>'\r
1544             writeln channel default_file_channel '               <description>' (trim(l_rssDesc)) '</description>'\r
1545             writeln channel default_file_channel '               <language>en-gb</language>'\r
1546             writeln channel default_file_channel '               <generator>Df32func RSS Object Generator</generator>'\r
1547             writeln channel default_file_channel '               <copyright>Copyright ' (trim(l_rssTitle)) ' (C) ' (now("date")) '</copyright>'\r
1548             writeln channel default_file_channel '               <lastBuildDate>' (rssdate((now("date")),(now("longtime")))) '</lastBuildDate>'\r
1549             writeln channel default_file_channel '               <pubDate>' (rssdate((now("date")),(now("longtime")))) '</pubDate>'\r
1550             \r
1551             if (l_manEditor <> "") writeln channel default_file_channel '               <managingEditor>' l_manEditor '</managingEditor>'\r
1552             if (l_webMaster <> "") writeln channel default_file_channel '               <webMaster>' l_webMaster '</webMaster>'\r
1553             if (l_iTtl <> 0) writeln channel default_file_channel '               <ttl>' l_iTtl '</ttl>'           \r
1554             \r
1555             // Write out image\r
1556             if ((l_imgUrl <> "") and (l_imgx > 0) and (l_imgy > 0)) begin\r
1557                 writeln channel default_file_channel '               <image>'\r
1558                 writeln channel default_file_channel '                       <title>' (trim(l_imgTitle)) '</title>'\r
1559                 writeln channel default_file_channel '                       <url>' (trim(l_imgUrl)) '</url>'\r
1560                 writeln channel default_file_channel '                       <link>' (trim(l_imgLink)) '</link>'\r
1561                 writeln channel default_file_channel '                       <height>' l_imgx '</height>'\r
1562                 writeln channel default_file_channel '                       <width>' l_imgy '</width>'\r
1563                 writeln channel default_file_channel '                       <description>' (trim(l_rssDesc)) '</description>'\r
1564                 writeln channel default_file_channel '               </image>'\r
1565             end\r
1566             \r
1567             // Write out items\r
1568             for l_i from 1 to l_itemCount\r
1569                 forward get matrix_value item l_i item 0 to l_itemTitle\r
1570                 forward get matrix_value item l_i item 1 to l_itemLink\r
1571                 forward get matrix_value item l_i item 2 to l_itemDesc\r
1572                 forward get matrix_value item l_i item 3 to l_itemCat\r
1573                 forward get matrix_value item l_i item 4 to l_itemGuID\r
1574                 forward get matrix_value item l_i item 5 to l_itemCc\r
1575                 forward get matrix_value item l_i item 6 to l_pubDate\r
1576                     \r
1577 \r
1578                 // Escape html in the description\r
1579                 move (replaces('"',l_itemDesc,"&quot;")) to l_itemDesc\r
1580                 move (replaces('<',l_itemDesc,"&lt;")) to l_itemDesc\r
1581                 move (replaces('>',l_itemDesc,"&gt;")) to l_itemDesc\r
1582                 \r
1583                 writeln channel default_file_channel '               <item>'\r
1584                 writeln channel default_file_channel '                      <title>' l_itemTitle '</title>'\r
1585                 writeln channel default_file_channel '                      <link>' l_itemLink '</link>'\r
1586                 writeln channel default_file_channel '                      <description>' l_itemDesc '</description>'\r
1587                 \r
1588                 if (l_itemGuID = "") begin\r
1589                 move 0 to l_iConflict\r
1590                 for l_j from 1 to (l_i-1)\r
1591                     forward get matrix_value item l_j item 1 to l_sConflict\r
1592                     if (l_sConflict = l_itemLink) increment l_iConflict\r
1593                 end\r
1594                     if (l_iConflict > 0) append l_iTemLink "#" l_iConflict\r
1595                 end\r
1596                 if (l_itemGuID <> "") append l_itemLink "#" l_itemGuID\r
1597                 \r
1598                 writeln channel default_file_channel '                      <guid isPermaLink="false">' l_itemLink '</guid>'\r
1599                 if ((l_pubDate = "") or (l_pubDate = "NOW")) writeln channel default_file_channel '                      <pubDate>' (rssdate((now("date")),(now("longtime")))) '</pubDate>'\r
1600                 else writeln channel default_file_channel '                      <pubDate>' l_pubDate '</pubDate>'\r
1601                 writeln channel default_file_channel '                      <category>' l_itemCat '</category>'\r
1602                 writeln channel default_file_channel '               </item>'          \r
1603             loop\r
1604             \r
1605             // Write out file/channel close\r
1606             writeln channel default_file_channel '       </channel>'\r
1607             writeln channel default_file_channel '</rss>'  \r
1608         close_output channel default_file_channel\r
1609         \r
1610     end_procedure        \r
1611     \r
1612 end_class\r
1613 \r
1614 \r
1615 // File list - Returns the contents of the DataFlex filelist\r
1616 //\r
1617 // In order to retrieve file attributes including the file number the file needs to be opened.\r
1618 //\r
1619 // Send message methods:\r
1620 //    init                  - Initialize the matrix by reading the filelist\r
1621 //\r
1622 // Set methods:\r
1623 //    <na>\r
1624 //\r
1625 // Get methods:\r
1626 //    item_count            - Return the count of filelist items\r
1627 //    root_name             - Get the root name of the file\r
1628 //    display_name          - Get the user friendly name of the file\r
1629 //    system_name           - Get the DataFlex friendly name of the table / file\r
1630 //    valid                 - Non-zero if the DataFlex FD file exists\r
1631 //\r
1632 // Example usage:\r
1633 //\r
1634 //    object test is a filelist\r
1635 //    end_object\r
1636 \r
1637 //    integer x i \r
1638 //    string buf1 buf2 buf3 buf4\r
1639 //    send init to (test(current_object)) "c:\df32" "filelist.cfg"\r
1640 //    get item_count of test to x\r
1641 //    \r
1642 //    for i from 0 to x\r
1643 //        get root_name of (test(current_object)) item i to buf1\r
1644 //        get display_name of (test(current_object)) item i to buf2\r
1645 //        get system_name of (test(current_object)) item i to buf3\r
1646 //        get valid of (test(current_object)) item i to buf4\r
1647 //        showln buf1 " " buf2 " " buf3 " " buf4\r
1648 //    loop\r
1649 //\r
1650 \r
1651 class filelist is a matrix\r
1652     procedure construct_object string argc \r
1653             forward send construct_object argc\r
1654             property string c_filelistDirectory\r
1655             property string c_filelistName\r
1656             property integer c_itemCount\r
1657     end_procedure\r
1658     \r
1659     function item_count returns integer\r
1660         local integer l_iItems\r
1661         get c_itemCount to l_iItems\r
1662         function_return l_iItems\r
1663     end_function\r
1664     \r
1665     procedure init string filelistDirectory string filelistName\r
1666         local integer l_iFileNumber\r
1667         local string l_sRootName l_sUserDisplayName l_sFileName l_sHead l_sUrn\r
1668         \r
1669         move 0 to l_iFileNumber\r
1670         if (filelistName = "") begin\r
1671             move "filelist.cfg" to filelistName\r
1672         end\r
1673         \r
1674         set c_filelistDirectory to filelistDirectory\r
1675         set c_filelistName to filelistName\r
1676         \r
1677         direct_input channel default_file_channel (filelistDirectory+filelistName)\r
1678             read_block l_sHead 256          \r
1679             while not (seqeof)          \r
1680                 //Block of 128 split 41\33\54\r
1681                 read_block channel default_file_channel l_sRootName 41\r
1682                 read_block channel default_file_channel l_sUserDisplayName 33\r
1683                 read_block channel default_file_channel l_sFileName 54\r
1684 \r
1685                 move filelistDirectory to l_sUrn\r
1686                 append l_sUrn (trim(cstring(l_sFileName))) ".FD"\r
1687 \r
1688                 if ((trim(cstring(l_sFileName))) <> "") begin\r
1689                     forward set matrix_value item l_iFileNumber item 0 to (trim(cstring(l_sRootName)))\r
1690                     forward set matrix_value item l_iFileNumber item 1 to (trim(cstring(l_sUserDisplayName)))\r
1691                     forward set matrix_value item l_iFileNumber item 2 to (trim(cstring(l_sFileName)))\r
1692                     if (does_exist(l_sUrn) = 1) begin\r
1693                         forward set matrix_value item l_iFileNumber item 3 to 1\r
1694                     end\r
1695                     else begin\r
1696                         forward set matrix_value item l_iFileNumber item 3 to 0\r
1697                     end\r
1698                     increment l_iFileNumber\r
1699                 end\r
1700             loop        \r
1701         close_input channel default_file_channel\r
1702     \r
1703         set c_itemCount to l_iFileNumber\r
1704     end_procedure\r
1705     \r
1706     function root_name integer itemx returns integer\r
1707         local string l_sBuf\r
1708         forward get matrix_value item itemx item 0 to l_sBuf\r
1709         function_return l_sBuf\r
1710     end_function\r
1711         \r
1712     function display_name integer itemx returns integer\r
1713         local string l_sBuf\r
1714         forward get matrix_value item itemx item 1 to l_sBuf\r
1715         function_return l_sBuf\r
1716     end_function\r
1717 \r
1718     function system_name integer itemx returns integer\r
1719         local string l_sBuf\r
1720         forward get matrix_value item itemx item 2 to l_sBuf\r
1721         function_return l_sBuf\r
1722     end_function\r
1723     \r
1724     function valid integer itemx returns integer\r
1725         local integer l_iTmp\r
1726         forward get matrix_value item itemx item 3 to l_iTmp\r
1727         function_return l_iTmp\r
1728     end_function\r
1729 end_class\r
1730 \r
1731 \r
1732 //Class for reading unicode files when we know they have low ASCII only\r
1733 //\r
1734 // Example Usage:\r
1735 //\r
1736 //    object test is a UnicodeReader\r
1737 //    end_object\r
1738 //\r
1739 //    local string asciiline\r
1740 //    local integer error i count channelx\r
1741 //\r
1742 //    send open_file to (test(current_object)) 1 "c:\test_unicode.txt"\r
1743 //    while not (seqeof)\r
1744 //        get readline of (test(current_object)) 1 to asciiline\r
1745 //        showln asciiline\r
1746 //    loop\r
1747 //    send close_file to (test(current_object)) 1\r
1748 \r
1749 class UnicodeReader is an array\r
1750     procedure construct_object integer argc\r
1751         forward send construct_object\r
1752         property integer c_iSizeBytes public argc\r
1753         property integer c_iBytesOn                \r
1754         property integer c_iOpen\r
1755         property string c_sPeek\r
1756         set c_iOpen to 0\r
1757     end_procedure\r
1758         \r
1759     procedure open_file integer l_iChan string l_sFile\r
1760         local integer l_iSizeBytes l_iOpen\r
1761         local string l_sTmp l_sBom\r
1762         get c_iOpen to l_iOpen\r
1763             \r
1764         move (trim(l_sFile)) to l_sFile\r
1765         if ((l_sFile <> "") and (l_iOpen = 0)) begin    \r
1766             move (file_size_bytes(l_sFile)-2) to l_iSizeBytes\r
1767             direct_input channel l_iChan l_sFile\r
1768                 read_block channel l_iChan l_sTmp 1\r
1769                 if (ascii(l_sTmp) < 254) begin\r
1770                     set_channel_position l_iChan to 0\r
1771                 end\r
1772                 else begin\r
1773                     read_block channel l_iChan l_sTmp 1\r
1774                 end\r
1775             \r
1776                 set c_iSizeBytes to l_iSizeBytes\r
1777                 set c_iBytesOn to 0\r
1778                 set c_iOpen to 1\r
1779         end\r
1780     end_procedure\r
1781         \r
1782     procedure close_file integer l_iChan\r
1783         local integer l_iOpen\r
1784         \r
1785         get c_iOpen to l_iOpen\r
1786         if (l_iOpen = 0) begin  \r
1787             close_input channel l_iChan\r
1788         end\r
1789         set c_iOpen to 0\r
1790     end_procedure\r
1791     \r
1792     function readline global integer l_iChan returns string\r
1793         local string l_sReturn l_sTmp\r
1794         local integer l_iBytesOn l_iSizeBytes\r
1795         \r
1796         move "" to l_sTmp\r
1797         move "" to l_sReturn\r
1798         get c_iSizeBytes to l_iSizeBytes\r
1799         get c_iBytesOn to l_iBytesOn\r
1800         \r
1801         while ((l_sTmp <> character(13)) and (l_iBytesOn < l_iSizeBytes))\r
1802             read_block channel l_iChan l_sTmp 1\r
1803             increment l_iBytesOn\r
1804             if ((l_sTmp <> character(13)) and (l_sTmp <> character(10)) and (l_sTmp <> character(0))) begin\r
1805                 move (l_sReturn+l_sTmp) to l_sReturn\r
1806             end\r
1807         loop\r
1808     \r
1809         function_return l_sReturn\r
1810     end_function\r
1811     \r
1812 end_class\r
1813 \r
1814 // ListDirectory class - provides a directory listing\r
1815 //\r
1816 // Send message methods:\r
1817 //    delete_data           - Clear the listing\r
1818 //    list_files            - Read the directory listing into the object\r
1819 //    sort_files            - Sort the file list on a particular property\r
1820 //\r
1821 // Set methods:\r
1822 //    <na>\r
1823 //\r
1824 // Get methods:\r
1825 //    file_count            - Return the count of files in the list\r
1826 //    filename              - Get the base name of a file in the list\r
1827 //    filesize              - Get the size of a file in the list\r
1828 //    file_created          - Get the created timestamp of the file\r
1829 //    file_modified         - Get the modification timestamp of the file\r
1830 //    file_accessed         - Get the last access timestamp of the file\r
1831 //\r
1832 // Example usage:\r
1833 //\r
1834 //    object test is a ListDirectory\r
1835 //    end_object\r
1836 //    \r
1837 //    integer i x\r
1838 //    string buf tmp\r
1839 //    \r
1840 //    send delete_data to test\r
1841 //    send list_files to (test(current_object)) "c:\*"\r
1842 //    get file_count of (test(current_object)) to x\r
1843 //    send sort_files to test "file_accesed" "ASCENDING"\r
1844 //    \r
1845 //    for i from 0 to x\r
1846 //        get filename of (test(current_object)) item i to tmp\r
1847 //        get filesize of (test(current_object)) item i to buf\r
1848 //        append tmp "," buf\r
1849 //        move (pad(tmp,35)) to tmp\r
1850 //        get file_created of (test(current_object)) item i to buf\r
1851 //        append tmp "," buf\r
1852 //        get file_modified of (test(current_object)) item i to buf\r
1853 //        append tmp "," buf\r
1854 //        get file_accessed of (test(current_object)) item i to buf\r
1855 //        append tmp "," buf\r
1856 //        showln tmp\r
1857 //    loop    \r
1858 \r
1859 class ListDirectory is a matrix\r
1860     procedure construct_object integer argc\r
1861         forward send construct_object argc\r
1862         property integer c_iFiles public argc\r
1863     end_procedure\r
1864     \r
1865     procedure delete_data\r
1866         set c_iFiles to 0\r
1867         forward send delete_data\r
1868     end_procedure\r
1869     \r
1870     procedure list_files string sPathName\r
1871         local string sWin32FindData sLine sLast sComment sFileName sModifiedDate sAccessDate sCreationDate k sLastFile\r
1872         local integer l_01iResult iFileSize l_iFiles\r
1873         local pointer pT5 pT6\r
1874         local handle hFile\r
1875         local dword dwFileSizeHigh dwFileSizeLow dwHighDateTime dwLowDateTime\r
1876 \r
1877         forward send delete_data\r
1878         \r
1879         zerotype _WIN32_FIND_DATA to sWin32FindData\r
1880         getaddress of sWin32FindData to pT5\r
1881         move (trim(sPathName)) to sPathName\r
1882         getaddress of sPathName to pT6\r
1883         move (FindFirstFile(pT6, pT5)) to hFile\r
1884         //if (hFile = -1) showln "Invalid file handle!"\r
1885 \r
1886         move -1 to l_iFiles\r
1887         repeat \r
1888             // FileName\r
1889             getbuff_String from sWin32FindData at WIN32_FIND_DATA.cFileName to sFileName\r
1890             if ((sFileName <> ".") and (sFileName <> "..") and (sFileName <> "")) begin\r
1891                 increment l_iFiles\r
1892 \r
1893                 // FileSize\r
1894                 getbuff from sWin32FindData at WIN32_FIND_DATA.nFileSizeHigh to dwFileSizeHigh\r
1895                 getbuff from sWin32FindData at WIN32_FIND_DATA.nFileSizeLow to dwFileSizeLow\r
1896                 moveint ((dwFileSizeHigh*MaxDword)+dwFileSizeLow) to iFileSize\r
1897 \r
1898                 // File Modified Time\r
1899                 getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastWriteLowDateTime to dwLowDateTime\r
1900                 getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastWriteHighDateTime to dwHighDateTime\r
1901                 move (convert_date_format(dwLowDateTime, dwHighDateTime)) to sModifiedDate\r
1902 \r
1903                 // File Accessed Time\r
1904                 getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastAccessLowDateTime to dwLowDateTime\r
1905                 getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastAccessHighDateTime to dwHighDateTime\r
1906                 move (convert_date_format(dwLowDateTime, dwHighDateTime)) to sAccessDate\r
1907 \r
1908                 // File Creation Time\r
1909                 getbuff from sWin32FindData at WIN32_FIND_DATA.ftCreationLowDateTime to dwLowDateTime\r
1910                 getbuff from sWin32FindData at WIN32_FIND_DATA.ftCreationHighDateTime to dwHighDateTime\r
1911                 move (convert_date_format(dwLowDateTime, dwHighDateTime)) to sCreationDate\r
1912 \r
1913                 move (cstring(sFileName)) to sFileName\r
1914                 forward set matrix_value item l_iFiles item 1 to sFileName\r
1915                 forward set matrix_value item l_iFiles item 2 to iFileSize\r
1916                 forward set matrix_value item l_iFiles item 3 to (integer(date(sModifiedDate)))\r
1917                 forward set matrix_value item l_iFiles item 4 to (integer(date(sAccessDate)))\r
1918                 forward set matrix_value item l_iFiles item 5 to (integer(date(sCreationDate)))\r
1919             end\r
1920             zerotype _WIN32_FIND_DATA to sWin32FindData\r
1921             move (FindNextFile(hFile, pT5)) to l_01iResult\r
1922         until (l_01iResult = 0)\r
1923         move (FindClose(hFile)) to l_01iResult\r
1924 \r
1925         set c_iFiles to l_iFiles\r
1926     end_procedure\r
1927 \r
1928     function filename integer itemx returns string\r
1929         local string l_sBuf\r
1930         move "" to l_sBuf\r
1931         forward get matrix_value item itemx item 1 to l_sBuf\r
1932         function_return l_sBuf\r
1933     end_function \r
1934     \r
1935     function filesize integer itemx returns integer\r
1936             local integer l_iBuf                \r
1937             forward get matrix_value item itemx item 2 to l_iBuf\r
1938             function_return l_iBuf\r
1939     end_function\r
1940     \r
1941     function file_modified integer itemx returns date\r
1942         local integer l_iBuf                \r
1943         forward get matrix_value item itemx item 3 to l_iBuf\r
1944         function_return (date(l_iBuf))\r
1945     end_function\r
1946     \r
1947     function file_accessed integer itemx returns date\r
1948         local integer l_iBuf                \r
1949         forward get matrix_value item itemx item 4 to l_iBuf\r
1950         function_return (date(l_iBuf))\r
1951     end_function \r
1952     \r
1953     function file_created integer itemx returns date\r
1954         local integer l_iBuf                \r
1955         forward get matrix_value item itemx item 5 to l_iBuf\r
1956         function_return (date(l_iBuf))\r
1957     end_function\r
1958     \r
1959     procedure sort_files string sField string sOrder\r
1960         local integer l_iSort\r
1961         if ((sOrder <> "ASCENDING") and (sOrder <> "DESCENDING")) move "ASCENDING" to sOrder\r
1962         move 1 to l_iSort\r
1963         if (sField = "filename") move 1 to l_iSort\r
1964         if (sField = "filesize") move 2 to l_iSort\r
1965         if (sField = "file_modified") move 3 to l_iSort\r
1966         if (sField = "file_accessed") move 4 to l_iSort\r
1967         if (sField = "file_created") move 5 to l_iSort\r
1968         forward send matrix_sort l_iSort sOrder\r
1969     end_procedure\r
1970     \r
1971     function file_count returns integer\r
1972         local integer l_iFiles\r
1973         get c_iFiles to l_iFiles\r
1974         function_return l_iFiles\r
1975     end_function\r
1976 end_class\r
1977 \r
1978 // ProcessList class - provides a listing of running processes\r
1979 //\r
1980 // Experimental; all aspects reading process info appear to fail, it can\r
1981 // be useful however to check if a particular process pid is still running.\r
1982 //\r
1983 // Send message methods:\r
1984 //    delete_data           - Clear the listing\r
1985 //    init_processes        - Read the process list table\r
1986 //\r
1987 // Set methods:\r
1988 //    <na>\r
1989 //\r
1990 // Get methods:\r
1991 //    get_process_id        - Return the PID of a particular process\r
1992 //    process_count         - Return count of processes in the list\r
1993 //    process_handle        - BROKEN\r
1994 //\r
1995 // Example usage:\r
1996 //\r
1997 //    object test is an ProcessList\r
1998 //    end_object\r
1999 //    \r
2000 //    integer i x id hx\r
2001 //    \r
2002 //    send init_processes to test\r
2003 //    get process_count of (test(current_object)) to x\r
2004 //    showln "Processes in list = "  x\r
2005 //    \r
2006 //    for i from 0 to x\r
2007 //        get process_id of (test(current_object)) item i to id\r
2008 //    loop\r
2009 //\r
2010 class ProcessList is an array\r
2011     procedure construct_object integer argc\r
2012             forward send construct_object\r
2013             property integer c_iProcesses public argc\r
2014     end_procedure\r
2015     \r
2016     procedure delete_data\r
2017         set c_iProcesses to 0\r
2018         forward send delete_data\r
2019     end_procedure\r
2020     \r
2021     procedure init_processes\r
2022     local string l_sProcesses l_sStructBytesBack l_sBuf l_sModules\r
2023     local integer l_iThrow l_iBytes l_iBytes2 l_iBytesBack l_iBytesBack2 l_i l_j l_iPid l_iMid l_iProcesses\r
2024     local pointer l_pProcesses l_pBytesBack l_pBytesBack2 l_pModules\r
2025     local handle l_hProcess\r
2026 \r
2027     move (1024*10) to l_iBytes  \r
2028     zerostring l_iBytes to l_sProcesses\r
2029     move 0 to l_iBytesBack\r
2030     move 0 to l_iProcesses\r
2031     forward send delete_data\r
2032 \r
2033     getAddress of l_sProcesses to l_pProcesses  \r
2034     zerotype _STRUCTBYTESBACK to l_sStructBytesBack\r
2035     getaddress of l_sStructBytesBack to l_pBytesBack\r
2036 \r
2037     move (EnumProcesses(l_pProcesses,l_iBytes,l_pBytesBack)) to l_iThrow\r
2038 \r
2039     getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack\r
2040 \r
2041     if (mod(l_iBytesBack,4) = 0) begin\r
2042         for l_i from 1 to (l_iBytesBack/4)\r
2043             move (left(l_sProcesses,4)) to l_sBuf\r
2044             move (mid(l_sProcesses,(length(l_sProcesses)-4),5)) to l_sProcesses\r
2045             getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iPid     \r
2046             move (OpenProcess(PROCESS_QUERY_INFORMATION, 0,l_iPid)) to l_hProcess\r
2047             \r
2048             // Fails to open the process for more info here unfortunately\r
2049             //showln "LERR=" (get_last_error_detail(GetLastError())) " " l_ipid\r
2050 \r
2051             move 1024 to l_iBytes2\r
2052             zerostring l_iBytes2 to l_sModules\r
2053             getAddress of l_sModules to l_pModules\r
2054             zerotype _STRUCTBYTESBACK to l_sStructBytesBack\r
2055             getaddress of l_sStructBytesBack to l_pBytesBack2\r
2056 \r
2057             move (EnumProcessModules(l_hProcess,l_pModules,l_iBytes2,l_pBytesBack2)) to l_iThrow\r
2058             getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack2\r
2059             \r
2060             increment l_iProcesses              \r
2061             forward set array_value item (l_i-1) to (string(l_iPid)+"|"+string(l_hProcess))\r
2062 \r
2063             if (mod(l_iBytesBack2,4) = 0) begin\r
2064                 for l_j from 1 to (l_iBytesBack2/4)\r
2065                     move (left(l_sModules,4)) to l_sBuf\r
2066                     move (mid(l_sModules,(length(l_sModules)-4),5)) to l_sModules\r
2067                     getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iMid\r
2068                 loop\r
2069             end\r
2070             move (CloseHandle(l_hProcess)) to l_iThrow\r
2071         loop\r
2072         \r
2073         set c_iTokenOn to 0\r
2074         set c_iProcesses to l_iProcesses\r
2075     end\r
2076     end_procedure\r
2077 \r
2078     function process_id integer itemx returns integer\r
2079         local string l_sBuf                \r
2080         forward get array_value item itemx to l_sBuf\r
2081         function_return (integer(left(l_sBuf,pos("|",l_sBuf)-1)))\r
2082     end_function \r
2083 \r
2084     // There's not much point to this as we couldn't get the handle because OpenProcess failed.\r
2085     function process_handle integer itemx returns integer\r
2086         local string l_sBuf                \r
2087         forward get array_value item itemx to l_sBuf\r
2088         function_return (integer(right(l_sBuf,length(l_sBuf)-pos("|",l_sBuf))))\r
2089     end_function \r
2090     \r
2091     function process_count returns integer\r
2092         local integer l_iProcesses\r
2093         get c_iProcesses to l_iProcesses\r
2094         function_return l_iProcesses\r
2095     end_function\r
2096 end_class\r