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