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