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