]> git.8kb.co.uk Git - dataflex/df32func/blob - src/df32/data.inc
5f80d00feec2e116954bdb4c0b1c11eca4ae993c
[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-2015, 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 //    [obsolete] matrix_sort        - Y pos to sort on, ASC OR DESC\r
794 //    sort_items                    - Y pos to sort on, ASC OR DESC (auto detects)\r
795 //    sort_items_ascii              - Y pos to sort on, ASC OR DESC (ascii)\r
796 //    sort_items_num                - Y pos to sort on, ASC OR DESC (numeric)\r
797 //    matrix_delete                 - X and Y pos to delete \r
798 //    delete_item                   - X position to delete (this reshuffles the matrix; avoid using)\r
799 //    hash_on_column_algorithm      - Hash algorithm to use\r
800 //    hash_on_column                - Y pos of column to hash\r
801 //    remove_hash_on_column         - Remove the hash from the column\r
802 //    hash_is_unique                - Add a unique constraint on the hash\r
803 //    remove_hash_is_unique         - Remove a unique constraint from the hash\r
804 //    matrix_index_lookup_clear     - Clear the lookup buffer\r
805 //    matrix_append_csv             - Append some data in CSV format to the array E.g. ('My Name,"My,\"address\""')\r
806 //    matrix_copy_csv_in            - Copy csv data from specified file into matrix\r
807 //    matrix_copy_csv_in_header     - Copy csv data with header from specified file into matrix\r
808 //    matrix_copy_csv_out           - Copy csv data from matrix into specified file\r
809 //\r
810 // Set methods:\r
811 //    matrix_value                  - Set a value at X, Y\r
812 //    matrix_string    \r
813 //\r
814 // Get methods:\r
815 //    matrix_value                  - Get a value at X, Y\r
816 //    matrix_string                 - Get an string value at X, Y\r
817 //    matrix_integer                - Get an integer value at X, Y\r
818 //    matrix_numeric                - Get an numeric value at X, Y\r
819 //    matrix_real                   - Get an real value at X, Y\r
820 //    matrix_hash_from_value        - Get the hash index value used for an indexed column value\r
821 //    matrix_indextable_from_value  - Get list of matrix x pos indexes for a particular hashed value\r
822 //    matrix_index_lookup_clear     - Clear the buffer for an indexed lookup\r
823 //    matrix_index_count_from_value - Get a count of rows with a particular value\r
824 //    matrix_index_from_value       - Get the next X pos (row) with indexed value. Returns -1 when nothing left to find.\r
825 //    item_count                    - Get count of rows in matrix\r
826 //    item_width                    - Get count of columns in matrix\r
827 //    \r
828 // Example usage:\r
829 //\r
830 //    object test is a matrix\r
831 //    end_object\r
832 //\r
833 //    set matrix_value of (test(current_object)) item 0 item 1 to "1"    - x then y pos to Value\r
834 //    get matrix_value of (test(current_object)) item 0 item 1 to tmpStr - x then y pos to Value\r
835 //    send matrix_append_csv to test ('My Name,"My,\"address\""')        - Append CSV data to the end of the matrix\r
836 //    send matrix_copy_csv_in to (test(current_object)) "f:\data.csv"       - Copy data from csv file into matrix\r
837 //    [obsolete] send matrix_sort to (test(current_object)) 1 ASC        - y pos to sort by, ASCENDING/DESCENDING\r
838 //    send sort_items to (test(current_object)) 1                        - y pos to sort by, ASCENDING/DESCENDING (auto)\r
839 //    send sort_items_ascii to (test(current_object)) 1                  - y pos to sort by, ASCENDING/DESCENDING (ascii)\r
840 //    send sort_items_num to (test(current_object)) 1                    - y pos to sort by, ASCENDING/DESCENDING (numeric)\r
841 //    send matrix_delete to (test(current_object)) 1 1           - x then y pos to delete \r
842 //    send matrix_delete_row to (test(current_object)) 1             - x essentially blanks record out, no reshuffle\r
843 //    send delete_item to (test(current_object)) 1              - x pos (not v efficient), reshuffles\r
844 //\r
845 // Hash indexed columns usage:\r
846 //\r
847 //    send hash_on_column_algorithm to (test(current_object)) "hash_reduced_lazy"\r
848 //    send hash_on_column to (test(current_object)) 0\r
849 //    send remove_hash_on_column to (test(current_object)) \r
850 //    send hash_is_unique to (test(current_object)) \r
851 //    \r
852 //    send matrix_index_lookup_clear to (test(current_object)) \r
853 //    get matrix_index_count_from_value of (test(current_object)) item "1" to count\r
854 //    get matrix_index_from_value of (test(current_object)) item "1" to x_pos   \r
855 //    get matrix_indextable_from_value of (test(current_object)) item "1" to tmpStr \r
856 //    get matrix_hash_from_value of (test(current_object)) item "1" to tmpInt   \r
857 //    get item_count of (test(current_object) to tmpInt\r
858 //    get item_width of (test(current_object) to tmpInt\r
859 \r
860 class matrix is an array\r
861     procedure construct_object integer argc\r
862         object mTokens is a StringTokenizer\r
863         end_object\r
864         object mTokens2 is a StringTokenizer\r
865         end_object\r
866         \r
867         forward send construct_object\r
868         property integer c_iWidth public argc\r
869         property integer c_iHashOn\r
870         property integer c_iLastIndexTableHash\r
871         property integer c_iLastIndexTablePos\r
872         property integer c_iEnforceUnique\r
873         property string c_sHashAlgorithm\r
874         \r
875         set c_sHashAlgorithm to ""\r
876         set c_iHashOn to -1\r
877         set c_iLastIndexTableHash to -1\r
878         set c_iLastIndexTablePos to -1\r
879         set c_iEnforceUnique to 0\r
880     end_procedure    \r
881     \r
882     // Pull the value of a column from the string representation\r
883     function column_value integer itemy string row\r
884         local string l_sResult\r
885         local integer l_i\r
886         \r
887         move row to l_sResult\r
888         \r
889         for l_i from 0 to (itemy-1)\r
890             move (right(l_sResult,length(l_sResult)-pos(character(1),l_sResult))) to l_sResult\r
891         loop\r
892         move (left(l_sResult,pos(character(1),l_sResult)-1)) to l_sResult\r
893         \r
894         function_return l_sResult\r
895     end_function    \r
896     \r
897     procedure hash_on_column_algorithm string hashalg\r
898         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
899             set c_sHashAlgorithm to hashalg\r
900         end     \r
901     end_procedure\r
902     \r
903     procedure hash_is_unique\r
904         set c_iEnforceUnique to 1\r
905     end_procedure   \r
906     \r
907     procedure remove_hash_is_unique\r
908         set c_iEnforceUnique to 0\r
909     end_procedure   \r
910     \r
911     procedure hash_on_column integer l_iColumn\r
912         local integer l_iMax l_iHashOn l_i l_iHash l_iEnforceUnique l_iHashError\r
913         local string l_sBuf l_sTmp l_sHashAlgorithm \r
914         \r
915         forward get item_count to l_iMax\r
916         get c_iHashOn to l_iHashOn\r
917         \r
918         // Allow adding hash only when no hash already set\r
919         if ((l_iHashOn = -1) and (l_iColumn >= 0)) begin\r
920                             \r
921             object mHash_array is an array\r
922             end_object              \r
923                 \r
924             object mHash_table is a hashTable\r
925             end_object\r
926                 \r
927             get c_sHashAlgorithm to l_sHashAlgorithm\r
928             get c_iEnforceUnique to l_iEnforceUnique\r
929             \r
930             if (l_sHashAlgorithm <> "") begin\r
931                 send hash_algorithm to (mHash_table(current_object)) l_sHashAlgorithm\r
932             end\r
933             \r
934             if (l_iMax <> 0) begin\r
935                 // Hash the current matrix if not empty\r
936                 move (l_iMax-1) to l_iMax       \r
937                 \r
938                 for l_i from 0 to l_iMax\r
939                     forward get array_value item l_i to l_sBuf\r
940 \r
941                     get column_value item l_iColumn item l_sBuf to l_sTmp\r
942                     \r
943                     get insert_hash of (mHash_table(current_object)) item l_sTmp to l_iHash\r
944                     get string_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
945                         \r
946                     if ((l_iEnforceUnique = 1) and (length(replace("|",l_sTmp,"")) <> 0)) begin\r
947                         custom_error ERROR_CODE_DUPLICATE_HASH_KEY$ ERROR_MSG_DUPLICATE_HASH_KEY ERROR_DETAIL_DUPLICATE_HASH_KEY l_iColumn\r
948                         move 1 to l_iHashError\r
949                         break\r
950                     end\r
951                     else if not (l_sTmp contains ("|"+string(l_i)+"|")) begin\r
952                         if (length(l_sTmp) = 0) move "|" to l_sTmp\r
953                         append l_sTmp (string(l_i)+"|")\r
954                         set array_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
955                     end\r
956                 loop\r
957             end\r
958                 \r
959             if (l_iHashError = 0) begin\r
960                 set c_iHashOn to l_iColumn\r
961             end\r
962             else begin\r
963                 send destroy_object to (mHash_array(current_object))\r
964                 send destroy_object to (mHash_table(current_object))                    \r
965             end\r
966         end\r
967     end_procedure\r
968         \r
969     procedure remove_hash_on_column\r
970         local integer l_iHashOn\r
971         \r
972         get c_iHashOn to l_iHashOn\r
973         \r
974         if (l_iHashOn <> -1) begin          \r
975             set c_iHashOn to -1\r
976             set c_iLastIndexTableHash to -1\r
977             set c_iLastIndexTablePos to -1\r
978             send destroy_object to (mHash_array(current_object))\r
979             send destroy_object to (mHash_table(current_object))\r
980         end\r
981     end_procedure\r
982         \r
983     procedure set matrix_value integer itemx integer itemy string val\r
984         local string l_sBuf l_sTmp l_sOldVal \r
985         local integer l_i l_iWidth l_iHashOn l_iHash l_iEnforceUnique l_iHashError\r
986 \r
987         move 0 to l_iHashError\r
988         get c_iWidth to l_iWidth\r
989         get c_iHashOn to l_iHashOn\r
990         \r
991         forward get array_value item itemx to l_sBuf\r
992                         \r
993         if (itemy > l_iWidth) begin\r
994                 set c_iWidth to itemy\r
995                 move itemy to l_iWidth\r
996         end\r
997 \r
998         // Delimiter is ascii char 1 (start of heading/console interrupt)\r
999         // so any values containing ascii 1 will, of course break the matrix\r
1000         send delete_data to (mTokens(current_object))\r
1001         send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1002         \r
1003         if (l_iHashOn = itemy) begin\r
1004             get token_value of (mTokens(current_object)) item itemy to l_sOldVal\r
1005         end\r
1006         if (val = "") set token_value of (mTokens(current_object)) item itemy to (character(3))\r
1007         else set token_value of (mTokens(current_object)) item itemy to (replaces(character(1),(replaces(character(3),val,"")),""))\r
1008     \r
1009         move "" to l_sBuf\r
1010         for l_i from 0 to l_iWidth                        \r
1011             get token_value of (mTokens(current_object)) item l_i to l_sTmp                        \r
1012             if (length(l_sTmp) = 0) move (character(3)) to l_sTmp        \r
1013             if (length(l_sBuf) <> 0) append l_sBuf (character(1))\r
1014             append l_sBuf l_sTmp\r
1015         loop\r
1016                 \r
1017         move (replaces(character(3),l_sBuf,"")) to l_sBuf\r
1018                     \r
1019         // Insert/update in the value to the hash\r
1020         if ((l_iHashOn = itemy) and (l_sOldVal <> val)) begin       \r
1021             get c_iEnforceUnique to l_iEnforceUnique\r
1022             get insert_hash of (mHash_table(current_object)) item val to l_iHash\r
1023             get string_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1024             \r
1025             if ((l_iEnforceUnique = 1) and (length(replace("|",l_sTmp,"")) <> 0)) begin\r
1026                 custom_error ERROR_CODE_DUPLICATE_HASH_KEY$ ERROR_MSG_DUPLICATE_HASH_KEY ERROR_DETAIL_DUPLICATE_HASH_KEY itemy\r
1027                 move 1 to l_iHashError\r
1028             end\r
1029             else if not (l_sTmp contains ("|"+string(itemx)+"|")) begin\r
1030                 if (length(l_sTmp) = 0) move "|" to l_sTmp\r
1031                 append l_sTmp (string(itemx)+"|")\r
1032                 set array_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1033             end\r
1034  \r
1035             // Remove old hash (if any) when insert succeeds\r
1036             if (l_iHashError = 0) begin\r
1037                 get find_hash of (mHash_table(current_object)) item l_sOldVal to l_iHash\r
1038                 if (l_iHash <> 0) begin\r
1039                     get string_value of (mHash_array(current_object)) item l_iHash to l_sTmp                \r
1040                     if (l_sTmp contains ("|"+string(itemx)+"|")) begin\r
1041                         move (replace(("|"+string(itemx)+"|"),l_sTmp,"")) to l_sTmp\r
1042                         if (l_sTmp = "") begin\r
1043                             send remove_hash to (mHash_table(current_object)) l_iHash\r
1044                         end\r
1045                         else begin\r
1046                             if (left(l_sTmp,1) <> "|") move ("|"+l_sTmp) to l_sTmp\r
1047                             else append l_sTmp "|"\r
1048                         end\r
1049                         set array_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1050                     end\r
1051                 end\r
1052             end\r
1053         end\r
1054                 \r
1055         if (l_iHashError = 0) begin\r
1056             forward set array_value item itemx to l_sBuf\r
1057         end\r
1058     end_procedure\r
1059     \r
1060     procedure matrix_append_csv string row        \r
1061         local integer l_iMax l_iValues l_i l_iHashOn l_iWidth l_iCount\r
1062         local string l_sBuf\r
1063             \r
1064         get c_iHashOn to l_iHashOn\r
1065         forward get item_count to l_iMax\r
1066         \r
1067         if ((l_iHashOn <> -1) or (row contains '"')) begin \r
1068             send delete_data to (mTokens2(current_object))\r
1069             send set_string_csv to (mTokens2(current_object)) row\r
1070             get token_count of (mTokens2(current_object)) to l_iValues\r
1071         \r
1072             for l_i from 0 to l_iValues                 \r
1073                 get token_value of (mTokens2(current_object)) item l_i to l_sBuf\r
1074                 indicate err false\r
1075                 set matrix_value item l_iMax item l_i to l_sBuf         \r
1076                 if (err) forward send delete_item l_iMax\r
1077                 if (err) break\r
1078             loop\r
1079         end\r
1080         else begin\r
1081             get c_iWidth to l_iWidth \r
1082             move 0 to l_iCount\r
1083             forward set array_value item l_iMax to (replaces(',', row, character(1)))\r
1084             for l_i from (pos(',', row)) to (length(row))\r
1085                 if (mid(row,1,l_i) = ',') increment l_iCount\r
1086             loop            \r
1087             if (l_iCount > l_iWidth) set c_iWidth to l_iCount\r
1088         end\r
1089 \r
1090     end_procedure\r
1091 \r
1092     procedure matrix_copy_csv_worker string fname integer offset\r
1093         local string l_sBuf \r
1094         local integer l_i\r
1095         \r
1096         move 0 to l_i\r
1097         if (does_exist(fname)) begin\r
1098             direct_input channel DEFAULT_FILE_CHANNEL fname\r
1099                 while not (seqeof)\r
1100                     readln channel DEFAULT_FILE_CHANNEL l_sBuf\r
1101                     increment l_i\r
1102                     if (l_i <= offset) break begin\r
1103                     if (seqeof) break\r
1104                     if (trim(l_sBuf) <> "") begin\r
1105                         send matrix_append_csv l_sBuf\r
1106                     end\r
1107                 loop\r
1108             close_input channel DEFAULT_FILE_CHANNEL\r
1109         end\r
1110         else;\r
1111             custom_error ERROR_CODE_FILE_NOT_FOUND$ ERROR_MSG_FILE_NOT_FOUND ERROR_DETAIL_FILE_NOT_FOUND fname\r
1112                     \r
1113     end_procedure \r
1114     \r
1115     procedure matrix_copy_csv_in string fname\r
1116         send matrix_copy_csv_worker fname 0\r
1117     end_procedure \r
1118 \r
1119     procedure matrix_copy_csv_in_header string fname\r
1120         send matrix_copy_csv_worker fname 1\r
1121     end_procedure \r
1122         \r
1123     procedure matrix_copy_csv_out string fname \r
1124         local integer l_iMax l_i l_j l_iValues\r
1125         local string l_sBuf\r
1126         \r
1127         forward get item_count to l_iMax\r
1128         \r
1129         direct_output channel DEFAULT_FILE_CHANNEL fname\r
1130             for l_i from 0 to l_iMax\r
1131                 forward get string_value item l_i to l_sBuf\r
1132                 if (l_sBuf <> "") begin\r
1133                     if ((l_sBuf contains '"') or (l_sBuf contains ',')) begin\r
1134                         send delete_data to (mTokens2(current_object))\r
1135                         send set_string to (mTokens2(current_object)) l_sBuf (character(1))\r
1136                         get token_count of (mTokens2(current_object)) to l_iValues\r
1137         \r
1138                         for l_j from 0 to l_iValues                 \r
1139                             get token_value of (mTokens2(current_object)) item l_j to l_sBuf\r
1140                             if (l_j <> 0);\r
1141                                 write channel DEFAULT_FILE_CHANNEL ','\r
1142                             if (l_sBuf contains '"');\r
1143                                 write channel DEFAULT_FILE_CHANNEL ('"'+(replaces('"', l_sBuf, '\"'))+'"')\r
1144                             else;\r
1145                                 write channel DEFAULT_FILE_CHANNEL l_sBuf\r
1146                         loop\r
1147                         writeln channel DEFAULT_FILE_CHANNEL ""\r
1148                     end\r
1149                     else;\r
1150                         writeln channel DEFAULT_FILE_CHANNEL (replaces(character(1), l_sBuf, ','))\r
1151                 end\r
1152             loop\r
1153         close_output channel DEFAULT_FILE_CHANNEL\r
1154     end_procedure \r
1155     \r
1156     \r
1157     function matrix_value integer itemx integer itemy returns string\r
1158         local string l_sBuf l_sTmp\r
1159 \r
1160         forward get array_value item itemx to l_sBuf\r
1161         get column_value item itemy item l_sBuf to l_sTmp\r
1162         \r
1163         function_return l_sTmp\r
1164     end_function        \r
1165     \r
1166     function matrix_string integer itemx integer itemy returns string\r
1167         local string l_sTmp\r
1168 \r
1169         get matrix_value item itemx item itemy to l_sTmp\r
1170         \r
1171         function_return l_sTmp\r
1172     end_function        \r
1173     \r
1174     function matrix_integer integer itemx integer itemy returns integer\r
1175         local integer l_iTmp\r
1176         \r
1177         get matrix_value item itemx item itemy to l_iTmp\r
1178         \r
1179         function_return l_iTmp\r
1180     end_function\r
1181     \r
1182     function matrix_number integer itemx integer itemy returns number\r
1183         local number l_nTmp\r
1184         \r
1185         get matrix_value item itemx item itemy to l_nTmp\r
1186         \r
1187         function_return l_nTmp\r
1188     end_function\r
1189     \r
1190     function matrix_real integer itemx integer itemy returns real\r
1191         local real l_rTmp\r
1192         \r
1193         get matrix_value item itemx item itemy to l_rTmp\r
1194         \r
1195         function_return l_rTmp\r
1196     end_function\r
1197     \r
1198     function matrix_hash_from_value string val returns integer\r
1199         local integer l_iHash l_iHashOn\r
1200         \r
1201         get c_iHashOn to l_iHashOn\r
1202                 \r
1203         if (l_iHashOn <> -1) begin\r
1204             get find_hash of (mHash_table(current_object)) item val to l_iHash\r
1205         end\r
1206 \r
1207         function_return l_iHash\r
1208     end_function\r
1209     \r
1210     function matrix_indextable_from_value string val returns string\r
1211         local integer l_iHashOn l_iHash\r
1212         local string l_sIndexTable\r
1213 \r
1214         get c_iHashOn to l_iHashOn\r
1215                 \r
1216         if (l_iHashOn <> -1) begin\r
1217             get find_hash of (mHash_table(current_object)) item val to l_iHash\r
1218             get string_value of (mHash_array(current_object)) item l_iHash to l_sIndexTable\r
1219         end\r
1220 \r
1221         function_return l_sIndexTable\r
1222     end_function\r
1223         \r
1224     procedure matrix_index_lookup_clear \r
1225         local integer l_iHashOn\r
1226         \r
1227         get c_iHashOn to l_iHashOn\r
1228     \r
1229         if (l_iHashOn <> -1) begin\r
1230             set c_iLastIndexTableHash to -1\r
1231             set c_iLastIndexTablePos to -1\r
1232         end\r
1233     end_procedure\r
1234         \r
1235     function matrix_index_from_value string val returns integer\r
1236         local integer l_iHashOn l_iHash l_iLastIndexTableHash l_iLastIndexTablePos l_iIndex l_iIndexValues\r
1237         local string l_sIndexTable\r
1238 \r
1239         get c_iHashOn to l_iHashOn\r
1240         move -1 to l_iIndex\r
1241         move 0 to l_iLastIndexTablePos\r
1242             \r
1243         if (l_iHashOn <> -1) begin\r
1244             get find_hash of (mHash_table(current_object)) item val to l_iHash\r
1245             get string_value of (mHash_array(current_object)) item l_iHash to l_sIndexTable\r
1246 \r
1247             get c_iLastIndexTableHash to l_iLastIndexTableHash          \r
1248             \r
1249             if (l_iHash = l_iLastIndexTableHash) begin\r
1250                 get c_iLastIndexTablePos to l_iLastIndexTablePos\r
1251             end\r
1252             increment l_iLastIndexTablePos\r
1253             \r
1254             send delete_data to (mTokens(current_object))\r
1255             send set_string to (mTokens(current_object)) l_sIndexTable "|"\r
1256             get token_count of (mTokens(current_object)) to l_iIndexValues\r
1257             if (l_iLastIndexTablePos <= l_iIndexValues) begin\r
1258                 get token_value of (mTokens(current_object)) item l_iLastIndexTablePos to l_iIndex\r
1259                 set c_iLastIndexTableHash to l_iHash\r
1260                 set c_iLastIndexTablePos to l_iLastIndexTablePos\r
1261             end\r
1262             else begin\r
1263                 move -1 to l_iIndex\r
1264                 set c_iLastIndexTableHash to -1\r
1265                 set c_iLastIndexTablePos to -1\r
1266             end\r
1267         end\r
1268 \r
1269         function_return l_iIndex\r
1270     end_function\r
1271     \r
1272     function matrix_index_count_from_value string val returns integer\r
1273         local integer l_iHashOn l_iHash l_iIndexValues l_i\r
1274         local string l_sIndexTable\r
1275     \r
1276         get c_iHashOn to l_iHashOn\r
1277     \r
1278         if (l_iHashOn <> -1) begin\r
1279             get find_hash of (mHash_table(current_object)) item val to l_iHash\r
1280             get string_value of (mHash_array(current_object)) item l_iHash to l_sIndexTable\r
1281     \r
1282             move 0 to l_iIndexValues\r
1283             for l_i from 1 to (length(l_sIndexTable))\r
1284                 if (mid(l_sIndexTable,1,l_i) = '|');\r
1285                     increment l_iIndexValues\r
1286             loop\r
1287         end\r
1288     \r
1289         function_return (l_iIndexValues-1)\r
1290     end_function\r
1291         \r
1292     procedure set item_count integer newVal\r
1293         forward set item_count to newVal\r
1294     end_procedure\r
1295     \r
1296     function item_width returns integer\r
1297         local integer l_iWidth\r
1298         get c_iWidth to l_iWidth\r
1299         function_return l_iWidth\r
1300     end_function\r
1301         \r
1302     procedure matrix_delete integer itemx integer itemy\r
1303         local string l_sBuf l_sTmp l_sOldVal\r
1304         local integer l_i l_iWidth l_iHashOn l_iHash\r
1305 \r
1306         get c_iWidth to l_iWidth\r
1307         get c_iHashOn to l_iHashOn\r
1308     \r
1309         forward get array_value item itemx to l_sBuf\r
1310             \r
1311         send delete_data to (mTokens(current_object))\r
1312         send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1313         \r
1314         if (l_iHashOn = itemy) begin                \r
1315             get token_value of (mTokens(current_object)) item itemy to l_sOldVal\r
1316         end\r
1317         set token_value of (mTokens(current_object)) item itemy to (character(3))\r
1318 \r
1319         move "" to l_sBuf\r
1320         for l_i from 0 to l_iWidth\r
1321             get token_value of (mTokens(current_object)) item l_i to l_sTmp\r
1322             if (length(l_sTmp) = 0) move (character(3)) to l_sTmp\r
1323             if (length(l_sBuf) <> 0) append l_sBuf (character(1))\r
1324             append l_sBuf l_sTmp\r
1325         loop\r
1326         move (replaces(character(3),l_sBuf,"")) to l_sBuf\r
1327 \r
1328         forward set array_value item itemx to l_sBuf\r
1329         \r
1330         // Delete in the value to the hash\r
1331         if (l_iHashOn = itemy) begin                \r
1332             get find_hash of (mHash_table(current_object)) item l_sOldVal to l_iHash\r
1333             if (l_iHash <> 0) begin                     \r
1334         get string_value of (mHash_array(current_object)) item l_iHash to l_sTmp                    \r
1335         if (l_sTmp contains ("|"+string(itemx)+"|")) begin\r
1336             move (replace(("|"+string(itemx)+"|"),l_sTmp,"")) to l_sTmp\r
1337             if (l_sTmp = "") begin\r
1338                 send remove_hash to (mHash_table(current_object)) l_iHash\r
1339             end\r
1340             else begin\r
1341                 if (left(l_sTmp,1) <> "|") move ("|"+l_sTmp) to l_sTmp\r
1342                 else append l_sTmp "|"\r
1343             end\r
1344             set array_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1345         end                             \r
1346             end\r
1347         end\r
1348     end_procedure\r
1349         \r
1350     // Inefficient.\r
1351     procedure delete_item integer itemx                \r
1352         local string l_sBuf l_sOldVal l_sTmp l_sIndexTable\r
1353         local integer l_iHashOn l_iHash l_i l_j l_iItems l_iIndexValues l_iIndex\r
1354         \r
1355         get c_iHashOn to l_iHashOn\r
1356         // Delete in the value to the hash\r
1357         if (l_iHashOn <> -1) begin\r
1358             forward get array_value item itemx to l_sBuf\r
1359             send delete_data to (mTokens(current_object))\r
1360             send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1361             get token_value of (mTokens(current_object)) item l_iHashOn to l_sOldVal\r
1362             get find_hash of (mHash_table(current_object)) item l_sOldVal to l_iHash\r
1363             if (l_iHash <> 0) begin                     \r
1364                 get string_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1365                 if (l_sTmp contains ("|"+string(itemx)+"|")) begin\r
1366                     move (replace(("|"+string(itemx)+"|"),l_sTmp,"")) to l_sTmp\r
1367                     if (l_sTmp = "") begin\r
1368                         send remove_hash to (mHash_table(current_object)) l_iHash\r
1369                     end\r
1370                     else begin\r
1371                         if (left(l_sTmp,1) <> "|") move ("|"+l_sTmp) to l_sTmp\r
1372                         else append l_sTmp "|"\r
1373                     end\r
1374                     set array_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1375                 end                     \r
1376             end\r
1377                 \r
1378             forward get item_count to l_iItems\r
1379         \r
1380             for l_i from (itemx+1) to l_iItems\r
1381         \r
1382                 forward get array_value item l_i to l_sBuf\r
1383                 send delete_data to (mTokens(current_object))\r
1384                 send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1385                 get token_value of (mTokens(current_object)) item l_iHashOn to l_sOldVal\r
1386                 get find_hash of (mHash_table(current_object)) item l_sOldVal to l_iHash\r
1387                 \r
1388                 if (l_iHash <> 0) begin\r
1389                     get string_value of (mHash_array(current_object)) item l_iHash to l_sIndexTable\r
1390                     \r
1391                     send delete_data to (mTokens(current_object))\r
1392                     send set_string to (mTokens(current_object)) l_sIndexTable "|"\r
1393                     get token_count of (mTokens(current_object)) to l_iIndexValues\r
1394                     move "|" to l_sIndexTable\r
1395                     for l_j from 1 to l_iIndexValues\r
1396                         get token_value of (mTokens(current_object)) item l_j to l_iIndex\r
1397                         if (l_iIndex = l_i) calc (l_iIndex-1) to l_iIndex\r
1398                         append l_sIndexTable (string(l_iIndex)+"|")\r
1399                     loop\r
1400                     \r
1401                     set array_value of (mHash_array(current_object)) item l_iHash to l_sIndexTable\r
1402                 end\r
1403             loop\r
1404             \r
1405         end\r
1406             \r
1407         forward send delete_item to current_object itemx\r
1408     end_procedure\r
1409 \r
1410     // The routine below relies on the internal dataflex sort, doing\r
1411     // what is essentially a nested loop join on the result and rebuilding\r
1412     // the original matrix.  It's pretty awful and is only left here for\r
1413     // reference.  Behaviour isn't quite quadratic, a feeble guess is\r
1414     // something like O( (2N + Nlog(n) + N^1.8) :-(\r
1415     procedure matrix_sort integer itemy string order\r
1416         local string l_sBuf l_sTmp l_sTmp2 l_sHash\r
1417         local integer l_iX l_i l_j l_iMax l_iPoolMax l_iWidth l_iThrow l_iNumCount l_iHashOn l_iHash\r
1418         \r
1419         move (trim(uppercase(order))) to order\r
1420         if ((left(order,3) <> "ASC") and (left(order,4) <> "DESC")) move "ASCENDING" to order\r
1421         \r
1422         object mSort_array is an array\r
1423         end_object\r
1424         object mClone_array is an array\r
1425         end_object\r
1426         \r
1427         get c_iHashOn to l_iHashOn\r
1428         get c_iWidth to l_iWidth\r
1429         forward get item_count to l_iMax\r
1430         \r
1431         send delete_data to (mSort_array(current_object))\r
1432         send delete_data to (mClone_array(current_object))\r
1433         \r
1434         if (l_iHashOn <> -1) begin\r
1435             //Zero the hash\r
1436             send delete_data to (mHash_array(current_object))\r
1437         end\r
1438         \r
1439         move (l_iMax-1) to l_iMax       \r
1440         \r
1441         for l_i from 0 to l_iMax\r
1442             forward get array_value item l_i to l_sBuf\r
1443             \r
1444             send delete_data to (mTokens(current_object))\r
1445             send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1446             get token_value of (mTokens(current_object)) item itemy to l_sTmp\r
1447         \r
1448             move 0 to l_iNumCount \r
1449             for l_j from 1 to (length(l_sTmp))\r
1450                 if not (((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)) break\r
1451                 increment l_iNumCount\r
1452             loop\r
1453             if ((length(l_sTmp) > 0) and (length(l_sTmp) = l_iNumCount)) begin\r
1454                 set array_value of (mSort_array(current_object)) item l_i to (number(l_sTmp))\r
1455             end\r
1456             else begin\r
1457                 if (length(l_sTmp) = 0) move (character(2)) to l_sTmp\r
1458                 set array_value of (mSort_array(current_object)) item l_i to l_sTmp\r
1459             end\r
1460         loop\r
1461         \r
1462         //Rely on dataflex sort\r
1463         if (left(order,3) = "ASC") send sort_items to (mSort_array(current_object)) ascending\r
1464         if (left(order,4) = "DESC") send sort_items to (mSort_array(current_object)) descending\r
1465 \r
1466         move l_iMax to l_iPoolMax\r
1467 \r
1468         // Nested loop join, sort of. Not good :-(\r
1469         for l_i from 0 to l_iMax\r
1470             get array_value of (mSort_array(current_object)) item l_i to l_sTmp\r
1471             if (l_sTmp = character(2)) move "" to l_sTmp\r
1472             \r
1473             for l_j from 0 to l_iPoolMax\r
1474                 // Ideally we'd change the next 3 lines for a lookup table instead\r
1475                 forward get array_value item l_j to l_sBuf\r
1476                 \r
1477                 send delete_data to (mTokens(current_object))\r
1478                 send set_string to (mTokens(current_object)) l_sBuf (character(1))\r
1479                 get token_value of (mTokens(current_object)) item itemy to l_sTmp2\r
1480                 \r
1481                 if (l_sTmp = l_sTmp2) begin\r
1482                     set array_value of (mClone_array(current_object)) item l_i to l_sBuf                    \r
1483                     \r
1484                     // On successful find shrink the sort pool here by moving max to l_j and decrementing max                 \r
1485                     forward get array_value item l_iPoolMax to l_sBuf\r
1486                     forward set array_value item l_j to l_sBuf\r
1487                     forward send delete_item to current_object l_iPoolMax\r
1488                     decrement l_iPoolMax                    \r
1489                         \r
1490                     // Rebuild hash\r
1491                     if (l_iHashOn <> -1) begin                  \r
1492                         get token_value of (mTokens(current_object)) item l_iHashOn to l_sHash\r
1493                         get find_hash of (mHash_table(current_object)) item l_sHash to l_iHash\r
1494                         get string_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1495                         if not (l_sTmp contains ("|"+string(l_i)+"|")) begin\r
1496                             if (length(l_sTmp) = 0) move "|" to l_sTmp\r
1497                             append l_sTmp (string(l_i)+"|")\r
1498                             set array_value of (mHash_array(current_object)) item l_iHash to l_sTmp\r
1499                         end\r
1500                     end                    \r
1501                     goto dirty_speedup_jump\r
1502                 end\r
1503             loop\r
1504             dirty_speedup_jump:\r
1505         loop\r
1506         send delete_data to (mSort_array(current_object))\r
1507                 \r
1508         for l_i from 0 to l_iMax\r
1509             get array_value of (mClone_array(current_object)) item l_i to l_sBuf\r
1510             forward set array_value item l_i to l_sBuf                      \r
1511         loop\r
1512         \r
1513         send destroy_object to (mSort_array(current_object))  // Use "send request_destroy_object" to destroy object and all children.\r
1514         send destroy_object to (mClone_array(current_object))\r
1515     end_procedure\r
1516 \r
1517     \r
1518     // Recursive partition for quicksort.\r
1519     // Dataflex arrays track the type of each row and perform a sort acordingly\r
1520     // but we have no easy way of knowing.  So perform compare based on what a\r
1521     // value looks "like" unless told otherwise.    \r
1522     // Index from (lo_in), index to (hi_in), numeric/string mode (1=integer, 0=string), invert (1=descending, 0=ascending)\r
1523     procedure partition integer lo_in integer hi_in integer mode integer itemy integer invert\r
1524         local integer pivot lo_idx hi_idx t\r
1525         local string pivot_val lo_row hi_row lo_val hi_val      \r
1526         \r
1527         if ((hi_in-lo_in) > 0) begin\r
1528             move lo_in to lo_idx\r
1529             move hi_in to hi_idx       \r
1530             move ((lo_in+hi_in)/2) to pivot\r
1531                         \r
1532             while ((lo_idx <= pivot) AND (hi_idx >= pivot))\r
1533                         \r
1534                 forward get array_value item pivot to pivot_val\r
1535                 get column_value item itemy item pivot_val to pivot_val\r
1536                 \r
1537                 forward get array_value item lo_idx to lo_row\r
1538                 get column_value item itemy item lo_row to lo_val\r
1539 \r
1540                 forward get array_value item hi_idx to hi_row\r
1541                 get column_value item itemy item hi_row to hi_val\r
1542 \r
1543                 \r
1544                 if (invert) begin\r
1545                     while ( ( ((mode) and (number(lo_val) > number(pivot_val))) or (not (mode) and (lo_val > pivot_val))) and (lo_idx <= pivot))\r
1546                         increment lo_idx\r
1547                         forward get array_value item lo_idx to lo_row\r
1548                         get column_value item itemy item lo_row to lo_val\r
1549                     loop\r
1550                     while ( ( ((mode) and (number(hi_val) < number(pivot_val))) or (not (mode) and (hi_val < pivot_val))) and (hi_idx >= pivot))\r
1551                         decrement hi_idx\r
1552                         forward get array_value item hi_idx to hi_row\r
1553                         get column_value item itemy item hi_row to hi_val\r
1554                     loop\r
1555                 end\r
1556                 else begin\r
1557                     while ( ( ((mode) and (number(lo_val) < number(pivot_val))) or (not (mode) and (lo_val < pivot_val))) and (lo_idx <= pivot))\r
1558                         increment lo_idx\r
1559                         forward get array_value item lo_idx to lo_row\r
1560                         get column_value item itemy item lo_row to lo_val\r
1561                     loop\r
1562                     while ( ( ((mode) and (number(hi_val) > number(pivot_val))) or (not (mode) and (hi_val > pivot_val))) and (hi_idx >= pivot))\r
1563                         decrement hi_idx\r
1564                         forward get array_value item hi_idx to hi_row\r
1565                         get column_value item itemy item hi_row to hi_val\r
1566                     loop\r
1567                 end\r
1568                 \r
1569                 forward set array_value item lo_idx to hi_row\r
1570                 forward set array_value item hi_idx to lo_row\r
1571                 \r
1572                 increment lo_idx\r
1573                 decrement hi_idx\r
1574                 \r
1575                 if ((lo_idx-1) = pivot) begin\r
1576                     increment hi_idx\r
1577                     move hi_idx to pivot\r
1578                 end\r
1579                 else if ((hi_idx+1) = pivot) begin\r
1580                     decrement lo_idx\r
1581                     move lo_idx to pivot\r
1582                 end\r
1583                 \r
1584             loop\r
1585     \r
1586             if ((pivot-lo_in) > 1);\r
1587                 send partition lo_in (pivot-1) mode itemy invert\r
1588             if ((hi_in-pivot) > 1);\r
1589                 send partition (pivot+1) hi_in mode itemy invert\r
1590         end        \r
1591     end_procedure   \r
1592     \r
1593     // Perform a quick sort on a perticular column (y) in the martix\r
1594     // This is done in native dataflex, so no match for compiled C\r
1595     procedure quick_sort integer itemy string order integer mode\r
1596         local integer l_i l_j l_iHashOn l_iMax l_iInvert\r
1597         local string l_sBuf\r
1598         \r
1599         if (uppercase(left(trim(order),4)) = "DESC") move 1 to l_iInvert\r
1600         else move 0 to l_iInvert    \r
1601         \r
1602         get item_count to l_iMax\r
1603         \r
1604         // If we've not been told string/numeric, try and work out here.\r
1605         if (mode = -1) begin\r
1606             for l_i from 0 to (l_iMax-1)\r
1607                 forward get array_value item l_i to l_sBuf\r
1608                 get column_value item itemy item l_sBuf to l_sBuf\r
1609                 move (is_number(l_sBuf)) to mode\r
1610                 if (mode = 0) break\r
1611             loop\r
1612         end\r
1613         \r
1614         // Remove the current hash index if there is one        \r
1615         get c_iHashOn to l_iHashOn\r
1616         if (l_iHashOn <> -1);\r
1617             send remove_hash_on_column  \r
1618         \r
1619         // Do the quick-sort\r
1620         send partition 0 (l_iMax-1) mode itemy l_iInvert\r
1621         \r
1622         // Recreate any the hash if there was one\r
1623         if (l_iHashOn <> -1);\r
1624             send hash_on_column l_iHashOn\r
1625 \r
1626     end_procedure\r
1627     \r
1628     //Wrapper for sort_items\r
1629     procedure sort_items integer itemy string order\r
1630         send quick_sort itemy order -1\r
1631     end_procedure\r
1632     \r
1633     //Wrapper for sort_items\r
1634     procedure sort_items_ascii integer itemy string order\r
1635         send quick_sort itemy order 0\r
1636     end_procedure    \r
1637     \r
1638     //Wrapper for sort_items\r
1639     procedure sort_items_num integer itemy string order\r
1640         send quick_sort itemy order 1\r
1641     end_procedure        \r
1642     \r
1643 end_class\r
1644 \r
1645 // Rss 2.0 data class - RFC-822 dates used\r
1646 //\r
1647 // Send message methods:\r
1648 //     init_rss                  - Initialise a new rss20 instance\r
1649 //     init_img                  - Initialise the image to be used in the feed\r
1650 //     add_item                  - Add an item to the feed\r
1651 //     write_rss                 - Write the feed out to disk\r
1652 //\r
1653 // Set methods:\r
1654 //    set_ttl                    - Set the TTL/refresh rate of the feed\r
1655 //    set_contacts               - Set admin contacts\r
1656 //    \r
1657 // Get methods:\r
1658 //\r
1659 // Example usage:\r
1660 //\r
1661 //    object test is an rss20\r
1662 //    end_object\r
1663 //\r
1664 //    move "" to link\r
1665 //    move "" to url\r
1666 //\r
1667 //    move "Google Maps" to title\r
1668 //    move ("http:/"+"/www.google.com/maps") to link\r
1669 //    move "Try out google maps" to desc\r
1670 //    send init_rss to (test(current_object)) title link desc\r
1671 //\r
1672 //    move ("http:/"+"/www.google.com/images/srpr/logo11w.png") to url\r
1673 //    move 19 to x\r
1674 //    move 41 to y\r
1675 //    send init_img to (test(current_object)) url x y\r
1676 //\r
1677 //    send set_ttl to (test(current_object)) 30\r
1678 //    send set_contacts to (test(current_object)) "maps@google.com" "search@google.com"\r
1679 //\r
1680 //    for i from 1 to 15\r
1681 //        move "Test item " to title\r
1682 //        append title i\r
1683 //        move ("http:/"+"/www.google.com") to link\r
1684 //        move "Test description " to desc\r
1685 //        append desc i\r
1686 //        move "NONE" to cat\r
1687 //\r
1688 //        send add_item to (test(current_object)) title link desc cat (rssdate((now("date")),(now("longtime"))))\r
1689 //    loop\r
1690 //    send write_rss to (test(current_object)) "c:\google_maps.rss"\r
1691 \r
1692 class rss20 is a matrix\r
1693     procedure construct_object string argc \r
1694         forward send construct_object argc\r
1695         property string c_rssTitle\r
1696         property string c_rssLink\r
1697         property string c_rssDesc\r
1698         \r
1699         property string c_imgTitle\r
1700         property string c_imgUrl\r
1701         property string c_imgLink\r
1702         property string c_imgDesc\r
1703         \r
1704         property string c_webMaster\r
1705         property string c_manEditor\r
1706         \r
1707         property integer c_imgx\r
1708         property integer c_imgy\r
1709         property integer c_ttl\r
1710         \r
1711         property integer c_itemCount\r
1712     end_procedure\r
1713     \r
1714     procedure init_rss string rssTitle string rssLink string rssDesc\r
1715         set c_rssTitle to rssTitle\r
1716         set c_rssLink to rssLink\r
1717         set c_rssDesc to rssDesc\r
1718         set c_itemCount to 0\r
1719     end_procedure\r
1720     \r
1721     procedure init_img string imgUrl integer imgx integer imgy\r
1722         local string imgTitle imgLink imgDesc\r
1723         get c_rssTitle to imgTitle\r
1724     get c_rssLink to imgLink\r
1725     get c_rssDesc to imgDesc\r
1726     \r
1727         set c_imgTitle to imgTitle\r
1728         set c_imgUrl to imgUrl\r
1729         set c_imgLink to imgLink\r
1730         set c_imgDesc to imgDesc\r
1731         set c_imgx to imgx\r
1732         set c_imgy to imgy\r
1733     end_procedure\r
1734     \r
1735     procedure set_ttl integer ttl\r
1736         if (ttl > 0) set c_ttl to ttl\r
1737     end_procedure\r
1738     \r
1739     procedure set_contacts string webMaster string manEditor\r
1740         if (webMaster <> "") set c_webMaster to webMaster\r
1741         if (manEditor <> "") set c_manEditor to manEditor\r
1742     end_procedure\r
1743     \r
1744     procedure add_item string itemTitle string itemLink string itemDesc string itemCat string pubDate string itemGuID\r
1745         local integer l_itemCount\r
1746         get c_itemCount to l_itemCount\r
1747     \r
1748         // The standard says we should not have more than 15 items, but ignore this.\r
1749         //if ((l_itemCount < 15) and (itemTitle <> "")) begin \r
1750         if (itemTitle <> "") begin\r
1751             increment l_itemCount\r
1752             set c_itemCount to l_itemCount\r
1753             \r
1754             forward set matrix_value item l_itemCount item 0 to itemTitle\r
1755             forward set matrix_value item l_itemCount item 1 to itemLink\r
1756             forward set matrix_value item l_itemCount item 2 to itemDesc\r
1757             forward set matrix_value item l_itemCount item 3 to itemCat\r
1758             forward set matrix_value item l_itemCount item 4 to itemGuID\r
1759             if ((pubDate <> "") and (pubDate <> "NOW")) forward set matrix_value item l_itemCount item 6 to pubDate\r
1760         end\r
1761     end_procedure\r
1762     \r
1763     procedure write_rss string rssFileName\r
1764         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
1765         local integer l_imgx l_imgy l_itemcount l_i l_j l_iConflict l_iTtl\r
1766         \r
1767         get c_rssTitle to l_rssTitle\r
1768         get c_rssLink to l_rssLink\r
1769         get c_rssDesc to l_rssDesc\r
1770     \r
1771         get c_imgTitle to l_imgTitle\r
1772         get c_imgUrl to l_imgUrl\r
1773         get c_imgLink to l_imgLink\r
1774         get c_manEditor to l_manEditor\r
1775         get c_webMaster to l_webMaster\r
1776         \r
1777         get c_imgx to l_imgx\r
1778         get c_imgy to l_imgy\r
1779         get c_itemCount to l_itemCount\r
1780         get c_ttl to l_iTtl\r
1781     \r
1782         direct_output channel DEFAULT_FILE_CHANNEL rssFileName\r
1783             writeln channel DEFAULT_FILE_CHANNEL '<?xml version="1.0" ?>'\r
1784             writeln channel DEFAULT_FILE_CHANNEL '<?xml-stylesheet type="text/xsl" href="rss.xsl" media="screen"?>'\r
1785             write channel DEFAULT_FILE_CHANNEL '<rss version="2.0" xmlns:dc="http:/' '/purl.org/dc/elements/1.1/" xmlns:sy="http:/'\r
1786             write channel DEFAULT_FILE_CHANNEL '/purl.org/rss/1.0/modules/syndication/" xmlns:admin="http:/' '/webns.net/mvcb/" xmlns:rdf="http:/'\r
1787             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
1788             \r
1789             // skipHours skipDays cloud - all currently not used\r
1790             // Write out Channel\r
1791             writeln channel DEFAULT_FILE_CHANNEL '       <channel>'\r
1792             writeln channel DEFAULT_FILE_CHANNEL '               <title>' (trim(l_rssTitle)) '</title>'\r
1793             writeln channel DEFAULT_FILE_CHANNEL '               <link>' (trim(l_rssLink)) '</link>'\r
1794             writeln channel DEFAULT_FILE_CHANNEL '               <description>' (trim(l_rssDesc)) '</description>'\r
1795             writeln channel DEFAULT_FILE_CHANNEL '               <language>en-gb</language>'\r
1796             writeln channel DEFAULT_FILE_CHANNEL '               <generator>Df32func RSS Object Generator</generator>'\r
1797             writeln channel DEFAULT_FILE_CHANNEL '               <copyright>Copyright ' (trim(l_rssTitle)) ' (C) ' (now("date")) '</copyright>'\r
1798             writeln channel DEFAULT_FILE_CHANNEL '               <lastBuildDate>' (rssdate((now("date")),(now("longtime")))) '</lastBuildDate>'\r
1799             writeln channel DEFAULT_FILE_CHANNEL '               <pubDate>' (rssdate((now("date")),(now("longtime")))) '</pubDate>'\r
1800             \r
1801             if (l_manEditor <> "") writeln channel DEFAULT_FILE_CHANNEL '               <managingEditor>' l_manEditor '</managingEditor>'\r
1802             if (l_webMaster <> "") writeln channel DEFAULT_FILE_CHANNEL '               <webMaster>' l_webMaster '</webMaster>'\r
1803             if (l_iTtl <> 0) writeln channel DEFAULT_FILE_CHANNEL '               <ttl>' l_iTtl '</ttl>'           \r
1804             \r
1805             // Write out image\r
1806             if ((l_imgUrl <> "") and (l_imgx > 0) and (l_imgy > 0)) begin\r
1807                 writeln channel DEFAULT_FILE_CHANNEL '               <image>'\r
1808                 writeln channel DEFAULT_FILE_CHANNEL '                       <title>' (trim(l_imgTitle)) '</title>'\r
1809                 writeln channel DEFAULT_FILE_CHANNEL '                       <url>' (trim(l_imgUrl)) '</url>'\r
1810                 writeln channel DEFAULT_FILE_CHANNEL '                       <link>' (trim(l_imgLink)) '</link>'\r
1811                 writeln channel DEFAULT_FILE_CHANNEL '                       <height>' l_imgx '</height>'\r
1812                 writeln channel DEFAULT_FILE_CHANNEL '                       <width>' l_imgy '</width>'\r
1813                 writeln channel DEFAULT_FILE_CHANNEL '                       <description>' (trim(l_rssDesc)) '</description>'\r
1814                 writeln channel DEFAULT_FILE_CHANNEL '               </image>'\r
1815             end\r
1816             \r
1817             // Write out items\r
1818             for l_i from 1 to l_itemCount\r
1819                 forward get matrix_value item l_i item 0 to l_itemTitle\r
1820                 forward get matrix_value item l_i item 1 to l_itemLink\r
1821                 forward get matrix_value item l_i item 2 to l_itemDesc\r
1822                 forward get matrix_value item l_i item 3 to l_itemCat\r
1823                 forward get matrix_value item l_i item 4 to l_itemGuID\r
1824                 forward get matrix_value item l_i item 5 to l_itemCc\r
1825                 forward get matrix_value item l_i item 6 to l_pubDate\r
1826                     \r
1827 \r
1828                 // Escape html in the description\r
1829                 move (replaces('"',l_itemDesc,"&quot;")) to l_itemDesc\r
1830                 move (replaces('<',l_itemDesc,"&lt;")) to l_itemDesc\r
1831                 move (replaces('>',l_itemDesc,"&gt;")) to l_itemDesc\r
1832                 \r
1833                 writeln channel DEFAULT_FILE_CHANNEL '               <item>'\r
1834                 writeln channel DEFAULT_FILE_CHANNEL '                      <title>' l_itemTitle '</title>'\r
1835                 writeln channel DEFAULT_FILE_CHANNEL '                      <link>' l_itemLink '</link>'\r
1836                 writeln channel DEFAULT_FILE_CHANNEL '                      <description>' l_itemDesc '</description>'\r
1837                 \r
1838                 if (l_itemGuID = "") begin\r
1839                 move 0 to l_iConflict\r
1840                 for l_j from 1 to (l_i-1)\r
1841                     forward get matrix_value item l_j item 1 to l_sConflict\r
1842                     if (l_sConflict = l_itemLink) increment l_iConflict\r
1843                 end\r
1844                     if (l_iConflict > 0) append l_iTemLink "#" l_iConflict\r
1845                 end\r
1846                 if (l_itemGuID <> "") append l_itemLink "#" l_itemGuID\r
1847                 \r
1848                 writeln channel DEFAULT_FILE_CHANNEL '                      <guid isPermaLink="false">' l_itemLink '</guid>'\r
1849                 if ((l_pubDate = "") or (l_pubDate = "NOW")) writeln channel DEFAULT_FILE_CHANNEL '                      <pubDate>' (rssdate((now("date")),(now("longtime")))) '</pubDate>'\r
1850                 else writeln channel DEFAULT_FILE_CHANNEL '                      <pubDate>' l_pubDate '</pubDate>'\r
1851                 writeln channel DEFAULT_FILE_CHANNEL '                      <category>' l_itemCat '</category>'\r
1852                 writeln channel DEFAULT_FILE_CHANNEL '               </item>'          \r
1853             loop\r
1854             \r
1855             // Write out file/channel close\r
1856             writeln channel DEFAULT_FILE_CHANNEL '       </channel>'\r
1857             writeln channel DEFAULT_FILE_CHANNEL '</rss>'  \r
1858         close_output channel DEFAULT_FILE_CHANNEL\r
1859         \r
1860     end_procedure        \r
1861     \r
1862 end_class\r
1863 \r
1864 \r
1865 // File list - Returns the contents of the DataFlex filelist\r
1866 //\r
1867 // In order to retrieve file attributes including the file number the file needs to be opened.\r
1868 //\r
1869 // Send message methods:\r
1870 //    init                  - Initialize the matrix by reading the filelist\r
1871 //\r
1872 // Set methods:\r
1873 //    <na>\r
1874 //\r
1875 // Get methods:\r
1876 //    item_count            - Return the count of filelist items\r
1877 //    root_name             - Get the root name of the file\r
1878 //    display_name          - Get the user friendly name of the file\r
1879 //    system_name           - Get the DataFlex friendly name of the table / file\r
1880 //    valid                 - Non-zero if the DataFlex FD file exists\r
1881 //\r
1882 // Example usage:\r
1883 //\r
1884 //    object test is a filelist\r
1885 //    end_object\r
1886 \r
1887 //    integer x i \r
1888 //    string buf1 buf2 buf3 buf4\r
1889 //    send init to (test(current_object)) "c:\df32" "filelist.cfg"\r
1890 //    get item_count of test to x\r
1891 //    \r
1892 //    for i from 0 to x\r
1893 //        get root_name of (test(current_object)) item i to buf1\r
1894 //        get display_name of (test(current_object)) item i to buf2\r
1895 //        get system_name of (test(current_object)) item i to buf3\r
1896 //        get valid of (test(current_object)) item i to buf4\r
1897 //        showln buf1 " " buf2 " " buf3 " " buf4\r
1898 //    loop\r
1899 //\r
1900 \r
1901 class filelist is a matrix\r
1902     procedure construct_object string argc \r
1903             forward send construct_object argc\r
1904             property string c_filelistDirectory\r
1905             property string c_filelistName\r
1906             property integer c_itemCount\r
1907     end_procedure\r
1908     \r
1909     function item_count returns integer\r
1910         local integer l_iItems\r
1911         get c_itemCount to l_iItems\r
1912         function_return l_iItems\r
1913     end_function\r
1914     \r
1915     procedure init string filelistDirectory string filelistName\r
1916         local integer l_iFileNumber\r
1917         local string l_sRootName l_sUserDisplayName l_sFileName l_sHead l_sUrn\r
1918         \r
1919         move 0 to l_iFileNumber\r
1920         if (filelistName = "") begin\r
1921             move "filelist.cfg" to filelistName\r
1922         end\r
1923         \r
1924         set c_filelistDirectory to filelistDirectory\r
1925         set c_filelistName to filelistName\r
1926         \r
1927         direct_input channel DEFAULT_FILE_CHANNEL (filelistDirectory+filelistName)\r
1928             read_block l_sHead 256          \r
1929             while not (seqeof)          \r
1930                 //Block of 128 split 41\33\54\r
1931                 read_block channel DEFAULT_FILE_CHANNEL l_sRootName 41\r
1932                 read_block channel DEFAULT_FILE_CHANNEL l_sUserDisplayName 33\r
1933                 read_block channel DEFAULT_FILE_CHANNEL l_sFileName 54\r
1934 \r
1935                 move filelistDirectory to l_sUrn\r
1936                 append l_sUrn (trim(cstring(l_sFileName))) ".FD"\r
1937 \r
1938                 if ((trim(cstring(l_sFileName))) <> "") begin\r
1939                     forward set matrix_value item l_iFileNumber item 0 to (trim(cstring(l_sRootName)))\r
1940                     forward set matrix_value item l_iFileNumber item 1 to (trim(cstring(l_sUserDisplayName)))\r
1941                     forward set matrix_value item l_iFileNumber item 2 to (trim(cstring(l_sFileName)))\r
1942                     if (does_exist(l_sUrn) = 1) begin\r
1943                         forward set matrix_value item l_iFileNumber item 3 to 1\r
1944                     end\r
1945                     else begin\r
1946                         forward set matrix_value item l_iFileNumber item 3 to 0\r
1947                     end\r
1948                     increment l_iFileNumber\r
1949                 end\r
1950             loop        \r
1951         close_input channel DEFAULT_FILE_CHANNEL\r
1952     \r
1953         set c_itemCount to l_iFileNumber\r
1954     end_procedure\r
1955     \r
1956     function root_name integer itemx returns integer\r
1957         local string l_sBuf\r
1958         forward get matrix_value item itemx item 0 to l_sBuf\r
1959         function_return l_sBuf\r
1960     end_function\r
1961         \r
1962     function display_name integer itemx returns integer\r
1963         local string l_sBuf\r
1964         forward get matrix_value item itemx item 1 to l_sBuf\r
1965         function_return l_sBuf\r
1966     end_function\r
1967 \r
1968     function system_name integer itemx returns integer\r
1969         local string l_sBuf\r
1970         forward get matrix_value item itemx item 2 to l_sBuf\r
1971         function_return l_sBuf\r
1972     end_function\r
1973     \r
1974     function valid integer itemx returns integer\r
1975         local integer l_iTmp\r
1976         forward get matrix_value item itemx item 3 to l_iTmp\r
1977         function_return l_iTmp\r
1978     end_function\r
1979 end_class\r
1980 \r
1981 \r
1982 //Class for reading unicode files when we know they have low ASCII only\r
1983 //\r
1984 // Example Usage:\r
1985 //\r
1986 //    object test is a UnicodeReader\r
1987 //    end_object\r
1988 //\r
1989 //    local string asciiline\r
1990 //    local integer error i count channelx\r
1991 //\r
1992 //    send open_file to (test(current_object)) 1 "c:\test_unicode.txt"\r
1993 //    while not (seqeof)\r
1994 //        get readline of (test(current_object)) 1 to asciiline\r
1995 //        showln asciiline\r
1996 //    loop\r
1997 //    send close_file to (test(current_object)) 1\r
1998 \r
1999 class UnicodeReader is an array\r
2000     procedure construct_object integer argc\r
2001         forward send construct_object\r
2002         property integer c_iSizeBytes public argc\r
2003         property integer c_iBytesOn                \r
2004         property integer c_iOpen\r
2005         property string c_sPeek\r
2006         set c_iOpen to 0\r
2007     end_procedure\r
2008         \r
2009     procedure open_file integer l_iChan string l_sFile\r
2010         local integer l_iSizeBytes l_iOpen\r
2011         local string l_sTmp l_sBom\r
2012         get c_iOpen to l_iOpen\r
2013             \r
2014         move (trim(l_sFile)) to l_sFile\r
2015         if ((l_sFile <> "") and (l_iOpen = 0)) begin    \r
2016             move (file_size_bytes(l_sFile)-2) to l_iSizeBytes\r
2017             direct_input channel l_iChan l_sFile\r
2018                 read_block channel l_iChan l_sTmp 1\r
2019                 if (ascii(l_sTmp) < 254) begin\r
2020                     set_channel_position l_iChan to 0\r
2021                 end\r
2022                 else begin\r
2023                     read_block channel l_iChan l_sTmp 1\r
2024                 end\r
2025             \r
2026                 set c_iSizeBytes to l_iSizeBytes\r
2027                 set c_iBytesOn to 0\r
2028                 set c_iOpen to 1\r
2029         end\r
2030     end_procedure\r
2031         \r
2032     procedure close_file integer l_iChan\r
2033         local integer l_iOpen\r
2034         \r
2035         get c_iOpen to l_iOpen\r
2036         if (l_iOpen = 0) begin  \r
2037             close_input channel l_iChan\r
2038         end\r
2039         set c_iOpen to 0\r
2040     end_procedure\r
2041     \r
2042     function readline global integer l_iChan returns string\r
2043         local string l_sReturn l_sTmp\r
2044         local integer l_iBytesOn l_iSizeBytes\r
2045         \r
2046         move "" to l_sTmp\r
2047         move "" to l_sReturn\r
2048         get c_iSizeBytes to l_iSizeBytes\r
2049         get c_iBytesOn to l_iBytesOn\r
2050         \r
2051         while ((l_sTmp <> character(13)) and (l_iBytesOn < l_iSizeBytes))\r
2052             read_block channel l_iChan l_sTmp 1\r
2053             increment l_iBytesOn\r
2054             if ((l_sTmp <> character(13)) and (l_sTmp <> character(10)) and (l_sTmp <> character(0))) begin\r
2055                 move (l_sReturn+l_sTmp) to l_sReturn\r
2056             end\r
2057         loop\r
2058     \r
2059         function_return l_sReturn\r
2060     end_function\r
2061     \r
2062 end_class\r
2063 \r
2064 // ListDirectory class - provides a directory listing\r
2065 //\r
2066 // Send message methods:\r
2067 //    delete_data           - Clear the listing\r
2068 //    list_files            - Read the directory listing into the object\r
2069 //    sort_files            - Sort the file list on a particular property\r
2070 //\r
2071 // Set methods:\r
2072 //    <na>\r
2073 //\r
2074 // Get methods:\r
2075 //    file_count            - Return the count of files in the list\r
2076 //    filename              - Get the base name of a file in the list\r
2077 //    filesize              - Get the size of a file in the list\r
2078 //    file_created          - Get the created timestamp of the file\r
2079 //    file_modified         - Get the modification timestamp of the file\r
2080 //    file_accessed         - Get the last access timestamp of the file\r
2081 //\r
2082 // Example usage:\r
2083 //\r
2084 //    object test is a ListDirectory\r
2085 //    end_object\r
2086 //    \r
2087 //    integer i x\r
2088 //    string buf tmp\r
2089 //    \r
2090 //    send delete_data to test\r
2091 //    send list_files to (test(current_object)) "c:\*"\r
2092 //    get file_count of (test(current_object)) to x\r
2093 //    send sort_files to test "file_accesed" "ASCENDING"\r
2094 //    \r
2095 //    for i from 0 to x\r
2096 //        get filename of (test(current_object)) item i to tmp\r
2097 //        get filesize of (test(current_object)) item i to buf\r
2098 //        append tmp "," buf\r
2099 //        move (pad(tmp,35)) to tmp\r
2100 //        get file_created of (test(current_object)) item i to buf\r
2101 //        append tmp "," buf\r
2102 //        get file_modified of (test(current_object)) item i to buf\r
2103 //        append tmp "," buf\r
2104 //        get file_accessed of (test(current_object)) item i to buf\r
2105 //        append tmp "," buf\r
2106 //        showln tmp\r
2107 //    loop    \r
2108 \r
2109 class ListDirectory is a matrix\r
2110     procedure construct_object integer argc\r
2111         forward send construct_object argc\r
2112         property integer c_iFiles public argc\r
2113     end_procedure\r
2114     \r
2115     procedure delete_data\r
2116         set c_iFiles to 0\r
2117         forward send delete_data\r
2118     end_procedure\r
2119     \r
2120     procedure list_files string sPathName\r
2121         local string sWin32FindData sLine sLast sComment sFileName sModifiedDate sAccessDate sCreationDate k sLastFile\r
2122         local integer l_01iResult iFileSize l_iFiles\r
2123         local pointer pT5 pT6\r
2124         local handle hFile\r
2125         local dword dwFileSizeHigh dwFileSizeLow dwHighDateTime dwLowDateTime\r
2126 \r
2127         forward send delete_data\r
2128         \r
2129         zerotype _WIN32_FIND_DATA to sWin32FindData\r
2130         getaddress of sWin32FindData to pT5\r
2131         move (trim(sPathName)) to sPathName\r
2132         getaddress of sPathName to pT6\r
2133         move (FindFirstFile(pT6, pT5)) to hFile\r
2134         //if (hFile = -1) showln "Invalid file handle!"\r
2135 \r
2136         move -1 to l_iFiles\r
2137         repeat \r
2138             // FileName\r
2139             getbuff_String from sWin32FindData at WIN32_FIND_DATA.cFileName to sFileName\r
2140             if ((sFileName <> ".") and (sFileName <> "..") and (sFileName <> "")) begin\r
2141                 increment l_iFiles\r
2142 \r
2143                 // FileSize\r
2144                 getbuff from sWin32FindData at WIN32_FIND_DATA.nFileSizeHigh to dwFileSizeHigh\r
2145                 getbuff from sWin32FindData at WIN32_FIND_DATA.nFileSizeLow to dwFileSizeLow\r
2146                 moveint ((dwFileSizeHigh*MaxDword)+dwFileSizeLow) to iFileSize\r
2147 \r
2148                 // File Modified Time\r
2149                 getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastWriteLowDateTime to dwLowDateTime\r
2150                 getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastWriteHighDateTime to dwHighDateTime\r
2151                 move (convert_date_format(dwLowDateTime, dwHighDateTime)) to sModifiedDate\r
2152 \r
2153                 // File Accessed Time\r
2154                 getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastAccessLowDateTime to dwLowDateTime\r
2155                 getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastAccessHighDateTime to dwHighDateTime\r
2156                 move (convert_date_format(dwLowDateTime, dwHighDateTime)) to sAccessDate\r
2157 \r
2158                 // File Creation Time\r
2159                 getbuff from sWin32FindData at WIN32_FIND_DATA.ftCreationLowDateTime to dwLowDateTime\r
2160                 getbuff from sWin32FindData at WIN32_FIND_DATA.ftCreationHighDateTime to dwHighDateTime\r
2161                 move (convert_date_format(dwLowDateTime, dwHighDateTime)) to sCreationDate\r
2162 \r
2163                 move (cstring(sFileName)) to sFileName\r
2164                 forward set matrix_value item l_iFiles item 1 to sFileName\r
2165                 forward set matrix_value item l_iFiles item 2 to iFileSize\r
2166                 forward set matrix_value item l_iFiles item 3 to (integer(date(sModifiedDate)))\r
2167                 forward set matrix_value item l_iFiles item 4 to (integer(date(sAccessDate)))\r
2168                 forward set matrix_value item l_iFiles item 5 to (integer(date(sCreationDate)))\r
2169             end\r
2170             zerotype _WIN32_FIND_DATA to sWin32FindData\r
2171             move (FindNextFile(hFile, pT5)) to l_01iResult\r
2172         until (l_01iResult = 0)\r
2173         move (FindClose(hFile)) to l_01iResult\r
2174 \r
2175         set c_iFiles to l_iFiles\r
2176     end_procedure\r
2177 \r
2178     function filename integer itemx returns string\r
2179         local string l_sBuf\r
2180         move "" to l_sBuf\r
2181         forward get matrix_value item itemx item 1 to l_sBuf\r
2182         function_return l_sBuf\r
2183     end_function \r
2184     \r
2185     function filesize integer itemx returns integer\r
2186             local integer l_iBuf                \r
2187             forward get matrix_value item itemx item 2 to l_iBuf\r
2188             function_return l_iBuf\r
2189     end_function\r
2190     \r
2191     function file_modified integer itemx returns date\r
2192         local integer l_iBuf                \r
2193         forward get matrix_value item itemx item 3 to l_iBuf\r
2194         function_return (date(l_iBuf))\r
2195     end_function\r
2196     \r
2197     function file_accessed integer itemx returns date\r
2198         local integer l_iBuf                \r
2199         forward get matrix_value item itemx item 4 to l_iBuf\r
2200         function_return (date(l_iBuf))\r
2201     end_function \r
2202     \r
2203     function file_created integer itemx returns date\r
2204         local integer l_iBuf                \r
2205         forward get matrix_value item itemx item 5 to l_iBuf\r
2206         function_return (date(l_iBuf))\r
2207     end_function\r
2208     \r
2209     procedure sort_files string sField string sOrder\r
2210         local integer l_iSort\r
2211         if ((sOrder <> "ASCENDING") and (sOrder <> "DESCENDING")) move "ASCENDING" to sOrder\r
2212         move 1 to l_iSort\r
2213         if (sField = "filename") move 1 to l_iSort\r
2214         if (sField = "filesize") move 2 to l_iSort\r
2215         if (sField = "file_modified") move 3 to l_iSort\r
2216         if (sField = "file_accessed") move 4 to l_iSort\r
2217         if (sField = "file_created") move 5 to l_iSort\r
2218         forward send matrix_sort l_iSort sOrder\r
2219     end_procedure\r
2220     \r
2221     function file_count returns integer\r
2222         local integer l_iFiles\r
2223         get c_iFiles to l_iFiles\r
2224         function_return l_iFiles\r
2225     end_function\r
2226 end_class\r
2227 \r
2228 // ProcessList class - provides a listing of running processes\r
2229 //\r
2230 // Experimental; all aspects reading process info appear to fail, it can\r
2231 // be useful however to check if a particular process pid is still running.\r
2232 //\r
2233 // Send message methods:\r
2234 //    delete_data           - Clear the listing\r
2235 //    init_processes        - Read the process list table\r
2236 //\r
2237 // Set methods:\r
2238 //    <na>\r
2239 //\r
2240 // Get methods:\r
2241 //    get_process_id        - Return the PID of a particular process\r
2242 //    process_count         - Return count of processes in the list\r
2243 //    process_handle        - BROKEN\r
2244 //\r
2245 // Example usage:\r
2246 //\r
2247 //    object test is an ProcessList\r
2248 //    end_object\r
2249 //    \r
2250 //    integer i x id hx\r
2251 //    \r
2252 //    send init_processes to test\r
2253 //    get process_count of (test(current_object)) to x\r
2254 //    showln "Processes in list = "  x\r
2255 //    \r
2256 //    for i from 0 to x\r
2257 //        get process_id of (test(current_object)) item i to id\r
2258 //    loop\r
2259 //\r
2260 class ProcessList is an array\r
2261     procedure construct_object integer argc\r
2262             forward send construct_object\r
2263             property integer c_iProcesses public argc\r
2264     end_procedure\r
2265     \r
2266     procedure delete_data\r
2267         set c_iProcesses to 0\r
2268         forward send delete_data\r
2269     end_procedure\r
2270     \r
2271     procedure init_processes\r
2272     local string l_sProcesses l_sStructBytesBack l_sBuf l_sModules\r
2273     local integer l_iThrow l_iBytes l_iBytes2 l_iBytesBack l_iBytesBack2 l_i l_j l_iPid l_iMid l_iProcesses\r
2274     local pointer l_pProcesses l_pBytesBack l_pBytesBack2 l_pModules\r
2275     local handle l_hProcess\r
2276 \r
2277     move (1024*10) to l_iBytes  \r
2278     zerostring l_iBytes to l_sProcesses\r
2279     move 0 to l_iBytesBack\r
2280     move 0 to l_iProcesses\r
2281     forward send delete_data\r
2282 \r
2283     getAddress of l_sProcesses to l_pProcesses  \r
2284     zerotype _STRUCTBYTESBACK to l_sStructBytesBack\r
2285     getaddress of l_sStructBytesBack to l_pBytesBack\r
2286 \r
2287     move (EnumProcesses(l_pProcesses,l_iBytes,l_pBytesBack)) to l_iThrow\r
2288 \r
2289     getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack\r
2290 \r
2291     if (mod(l_iBytesBack,4) = 0) begin\r
2292         for l_i from 1 to (l_iBytesBack/4)\r
2293             move (left(l_sProcesses,4)) to l_sBuf\r
2294             move (mid(l_sProcesses,(length(l_sProcesses)-4),5)) to l_sProcesses\r
2295             getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iPid     \r
2296             move (OpenProcess(PROCESS_QUERY_INFORMATION, 0,l_iPid)) to l_hProcess\r
2297             \r
2298             // Fails to open the process for more info here unfortunately\r
2299             //showln "LERR=" (get_last_error_detail(GetLastError())) " " l_ipid\r
2300 \r
2301             move 1024 to l_iBytes2\r
2302             zerostring l_iBytes2 to l_sModules\r
2303             getAddress of l_sModules to l_pModules\r
2304             zerotype _STRUCTBYTESBACK to l_sStructBytesBack\r
2305             getaddress of l_sStructBytesBack to l_pBytesBack2\r
2306 \r
2307             move (EnumProcessModules(l_hProcess,l_pModules,l_iBytes2,l_pBytesBack2)) to l_iThrow\r
2308             getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack2\r
2309             \r
2310             increment l_iProcesses              \r
2311             forward set array_value item (l_i-1) to (string(l_iPid)+"|"+string(l_hProcess))\r
2312 \r
2313             if (mod(l_iBytesBack2,4) = 0) begin\r
2314                 for l_j from 1 to (l_iBytesBack2/4)\r
2315                     move (left(l_sModules,4)) to l_sBuf\r
2316                     move (mid(l_sModules,(length(l_sModules)-4),5)) to l_sModules\r
2317                     getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iMid\r
2318                 loop\r
2319             end\r
2320             move (CloseHandle(l_hProcess)) to l_iThrow\r
2321         loop\r
2322         \r
2323         set c_iTokenOn to 0\r
2324         set c_iProcesses to l_iProcesses\r
2325     end\r
2326     end_procedure\r
2327 \r
2328     function process_id integer itemx returns integer\r
2329         local string l_sBuf                \r
2330         forward get array_value item itemx to l_sBuf\r
2331         function_return (integer(left(l_sBuf,pos("|",l_sBuf)-1)))\r
2332     end_function \r
2333 \r
2334     // There's not much point to this as we couldn't get the handle because OpenProcess failed.\r
2335     function process_handle integer itemx returns integer\r
2336         local string l_sBuf                \r
2337         forward get array_value item itemx to l_sBuf\r
2338         function_return (integer(right(l_sBuf,length(l_sBuf)-pos("|",l_sBuf))))\r
2339     end_function \r
2340     \r
2341     function process_count returns integer\r
2342         local integer l_iProcesses\r
2343         get c_iProcesses to l_iProcesses\r
2344         function_return l_iProcesses\r
2345     end_function\r
2346 end_class\r