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