scripts/datasource_filter.itcl

   1 # vim: foldmethod=marker foldmarker=<<<,>>> ft=tcl ts=4 shiftwidth=4
   2
   3 # Datasource_filter is a datasource stacked on top of another datasource.
   4 #       Items can be filtered to a subset of the source datasource by means of
   5 #       filter expressions that each row must pass to be included in our filtered
   6 #       set.
   7 #       Items may also be translated (and have the header list changed) by
   8 #       a translator that given an input row, produces the output row.
   9
  10 # Events fired
  11 #       init()
  12 #       onchange()
  13 #       id_column_changed(new_id_column)
  14 #       headers_changed(new_headerlist)
  15 #       new_item(pool, id, newitem)
  16 #       change_item(pool, id, olditem, newitem)
  17 #       remove_item(pool, id, olditem)
  18 #       new_pool(pool)
  19 #       remove_pool(pool)
  20
  21 class tlc::Datasource_filter {
  22         inherit tlc::Datasource tlc::Baselog
  23
  24         constructor {args} {}
  25         destructor {}
  26
  27         public {
  28                 variable ds                                     ""              need_refilter
  29                 variable override_headers       {}              need_refilter
  30                 variable filter                         {true}  need_refilter
  31                 variable translator                     {}              need_refilter
  32                 variable id_column                      ""      ;# column to use as the ID column
  33                 variable cache          0       ;# 1 = Cache the filtered items, 0 = do jit
  34                 variable debug          0
  35
  36                 method get_list {criteria {headersvar {}}}
  37                 method get_list_extended {criteria {headersvar {}}}
  38                 method get_headers {}
  39                 method pool_meta {pool}
  40         }
  41
  42         private {
  43                 variable link_id_column         1
  44                 variable damp_onchange          1
  45                 variable dominos
  46
  47                 method need_refilter {}
  48                 method refilter {}
  49                 method init {}
  50                 method onchange {}
  51                 method id_column_changed {new_id_column}
  52                 method headers_changed {new_headerlist}
  53                 method new_item {pool id newitem}
  54                 method change_item {pool id olditem newitem}
  55                 method remove_item {pool id olditem}
  56                 method new_pool {pool}
  57                 method remove_pool {pool}
  58         }
  59 }
  60
  61
  62 configbody tlc::Datasource_filter::id_column { #<<<1
  63         if {$id_column == ""} {
  64                 set link_id_column      1
  65                 if {[info exists ds] && [itcl::is object $ds] && [$ds isa tlc::Datasource]} {
  66                         set id_column           [$ds cget -id_column]
  67                 }
  68         } else {
  69                 set link_id_column      0
  70         }
  71 }
  72
  73
  74 configbody tlc::Datasource_filter::ds { #<<<1
  75         if {![itcl::is object $ds] || !([$ds isa tlc::DSchan] || [$ds isa tlc::Datasource_filter])} {
  76                 if {![itcl::is object $ds]} {
  77                         log error "-ds ($ds) is not an object"
  78                 } elseif {!([$ds isa tlc::DSchan] || [$ds isa tlc::Datasource_filter])} {
  79                         log error "-ds ($ds) is not a tlc::DSchan or tlc::Datasource_filter: ([$ds info heritage]))"
  80                 } else {
  81                         log error "non-specific -ds ($ds) problem"
  82                 }
  83                 error "Only tlc::DSchan and its subclasses are allowed for -ds" "" \
  84                                 [list invalid_ds]
  85         }
  86
  87         if {$link_id_column} {
  88                 set id_column   [$ds cget -id_column]
  89         }
  90 }
  91
  92
  93 configbody tlc::Datasource_filter::cache { #<<<1
  94         if {$cache} {
  95                 error "Caching not implemented yet" "" [list caching_not_supported]
  96         }
  97 }
  98
  99
 100 configbody tlc::Datasource_filter::filter { #<<<1
 101         if {[string trim $filter] == ""} {
 102                 error "-filter cannot be blank" "" [list invalid_filter $filter]
 103         }
 104         $dominos(need_refilter) tip
 105 }
 106
 107
 108 body tlc::Datasource_filter::constructor {args} { #<<<1
 109         log debug $this
 110         array set dominos       {}
 111
 112         tlc::Domino #auto dominos(need_refilter) -name "$this need_refilter"
 113
 114         eval configure $args
 115
 116         foreach reqf {ds} {
 117                 if {![info exists $reqf]} {
 118                         error "Must set -$reqf" "" [list missing_field $reqf]
 119                 }
 120         }
 121
 122         if {$ds == ""} {
 123                 error "Must set -ds" "" [list missing_field ds]
 124         }
 125
 126         $dominos(need_refilter) attach_output [code $this refilter]
 127
 128         $ds register_handler init [code $this init]
 129         $ds register_handler onchange [code $this onchange]
 130         $ds register_handler id_column_changed [code $this id_column_changed]
 131         $ds register_handler headers_changed [code $this headers_changed]
 132         $ds register_handler new_item [code $this new_item]
 133         $ds register_handler change_item [code $this change_item]
 134         $ds register_handler remove_item [code $this remove_item]
 135         $ds register_handler new_pool [code $this new_pool]
 136         $ds register_handler remove_pool [code $this remove_pool]
 137 }
 138
 139
 140 body tlc::Datasource_filter::destructor {} { #<<<1
 141         log debug $this
 142
 143         $dominos(need_refilter) detach_output [code $this refilter]
 144
 145         $ds deregister_handler init [code $this init]
 146         $ds deregister_handler onchange [code $this onchange]
 147         $ds deregister_handler id_column_changed [code $this id_column_changed]
 148         $ds deregister_handler headers_changed [code $this headers_changed]
 149         $ds deregister_handler new_item [code $this new_item]
 150         $ds deregister_handler change_item [code $this change_item]
 151         $ds deregister_handler remove_item [code $this remove_item]
 152         $ds deregister_handler new_pool [code $this new_pool]
 153         $ds deregister_handler remove_pool [code $this remove_pool]
 154 }
 155
 156
 157 body tlc::Datasource_filter::get_list {criteria {headersvar {}}} { #<<<1
 158         log debug $this
 159         if {$headersvar != {}} {
 160                 upvar $headersvar hdrs
 161         } else {
 162                 set hdrs        {}
 163         }
 164
 165         set pool_data   [lindex [get_list_extended $criteria hdrs] 1]
 166         #log debug "got pool_data: ($pool_data)"
 167
 168         set list        {}
 169         foreach {pool data} $pool_data {
 170                 #log debug "Appending data from pool ($pool): ($data)"
 171                 lappend list    $data
 172         }
 173
 174         set flatlist    [eval concat $list]
 175         log debug "returning [llength $flatlist] items, sorted by id column $id_column"
 176         return [lsort -unique -index $id_column $flatlist]
 177 }
 178
 179
 180 body tlc::Datasource_filter::get_list_extended {criteria {headersvar {}}} { #<<<1
 181         log debug $this
 182         if {$headersvar != {}} {
 183                 upvar $headersvar hdrs
 184         }
 185
 186         set raw                         [$ds get_list_extended $criteria hdrs]
 187         set pool_meta_arr       [lindex $raw 0]
 188         set pool_data           [lindex $raw 1]
 189
 190         tlc::try {
 191                 array set pool_meta     $pool_meta_arr
 192         } onerr {
 193                 default {
 194                         error "Cannot parse pool_meta: ($pool_meta_arr): $errmsg" "" \
 195                                         [list pool_meta_syntax_error $errmsg]
 196                 }
 197         }
 198
 199         set use_trans   [expr {$translator != {}}]
 200         set build               {}
 201         if {$override_headers != {}} {
 202                 set outhdrs             $override_headers
 203                 set use_trans   1
 204         } else {
 205                 set outhdrs             $hdrs
 206         }
 207         foreach {pool data} $pool_data {
 208                 array unset meta
 209                 array set meta  $pool_meta($pool)
 210
 211                 set new_pool_data       {}
 212                 foreach r $data {
 213                         array unset row
 214                         foreach f $r h $hdrs {
 215                                 set row($h)     $f
 216                         }
 217
 218                         tlc::try {
 219                                 if {$debug} {
 220                                         if {![expr $filter]} {
 221                                                 log debug "Row ([array get row]) fails filter ($filter)"
 222                                                 continue
 223                                         } else {
 224                                                 log debug "Row ([array get row]) passes filter ($filter)"
 225                                         }
 226                                 } else {
 227                                         if {![expr $filter]} continue
 228                                 }
 229                         } onerr {
 230                                 default {
 231                                         error "Error applying filter ($filter): $errmsg" "" \
 232                                                         [list filter_error $errmsg]
 233                                 }
 234                         }
 235
 236                         if {$use_trans} $translator
 237
 238                         if {$use_trans} {
 239                                 set outrow      {}
 240                                 foreach h $outhdrs {
 241                                         if {$debug} {
 242                                                 log debug "Assembling output row field ($h): ($row($h))"
 243                                         }
 244                                         lappend outrow  $row($h)
 245                                 }
 246                                 lappend new_pool_data   $outrow
 247                         } else {
 248                                 lappend new_pool_data   $r
 249                         }
 250                 }
 251
 252                 lappend build   $pool $new_pool_data
 253         }
 254         if {$override_headers != {}} {
 255                 set hdrs        $override_headers
 256         }
 257         set last_headers        $hdrs
 258
 259         if {$debug} {
 260                 log debug "Returning pool_meta_arr: ($pool_meta_arr), data: ([llength $build] items)"
 261         }
 262         return [list $pool_meta_arr $build]
 263 }
 264
 265
 266 body tlc::Datasource_filter::need_refilter {} { #<<<1
 267         $dominos(need_refilter) tip
 268 }
 269
 270
 271 body tlc::Datasource_filter::refilter {} { #<<<1
 272         #invoke_handlers init
 273         invoke_handlers onchange
 274 }
 275
 276
 277 body tlc::Datasource_filter::init {} { #<<<1
 278         invoke_handlers onchange
 279         invoke_handlers init
 280 }
 281
 282
 283 body tlc::Datasource_filter::onchange {} { #<<<1
 284         if {!($damp_onchange)} {
 285                 invoke_handlers onchange
 286                 set damp_onchange       1
 287         }
 288 }
 289
 290
 291 body tlc::Datasource_filter::id_column_changed {new_id_column} { #<<<1
 292         if {$link_id_column} {
 293                 set id_column   $new_id_column
 294                 set damp_onchange       0
 295                 invoke_handlers id_column_changed $id_column
 296         }
 297 }
 298
 299
 300 body tlc::Datasource_filter::headers_changed {new_headerlist} { #<<<1
 301         if {$override_headers == {}} {
 302                 set last_headers        $new_headerlist
 303                 set damp_onchange       0
 304                 invoke_handlers headers_changed $new_headerlist
 305         }
 306 }
 307
 308
 309 body tlc::Datasource_filter::new_item {pool id newitem} { #<<<1
 310         set hdrs                [$ds get_headers]
 311         array set meta  [$ds pool_meta $pool]
 312
 313         foreach f $newitem h $hdrs {
 314                 set row($h)     $f
 315         }
 316         #log debug "new row:"
 317         #parray row
 318
 319         #log debug "testing against filter: ($filter)"
 320         tlc::try {
 321                 if {![expr $filter]} return
 322         } onerr {
 323                 default {
 324                         error "Error applying filter ($filter): $errmsg" "" \
 325                                         [list filter_error $errmsg]
 326                 }
 327         }
 328         #log debug "survives filter"
 329
 330         set use_trans   [expr {$translator != {}}]
 331
 332         if {$use_trans} $translator
 333         #log debug "after translator:"
 334         #parray row
 335
 336         if {$use_trans} {
 337                 set outrow      {}
 338                 foreach h $last_headers {
 339                         lappend outrow  $row($h)
 340                 }
 341                 set id          [lindex $outrow $id_column]
 342         } else {
 343                 set outrow      $newitem
 344         }
 345         #log debug "id: ($id) outrow: ($outrow)"
 346
 347         set damp_onchange       0
 348         invoke_handlers new_item $pool $id $outrow
 349 }
 350
 351
 352 body tlc::Datasource_filter::change_item {pool id olditem newitem} { #<<<1
 353         set hdrs                [$ds get_headers]
 354         array set meta  [$ds pool_meta $pool]
 355
 356         # Process olditem <<<
 357         array unset row
 358         foreach f $olditem h $hdrs {
 359                 set row($h)     $f
 360         }
 361
 362         set use_trans   [expr {$translator != {}}]
 363
 364         set old_visible         [expr $filter]
 365
 366         if {$old_visible} {
 367                 if {$use_trans} $translator
 368
 369                 if {$use_trans} {
 370                         set old_outrow  {}
 371                         foreach h $last_headers {
 372                                 lappend old_outrow      $row($h)
 373                         }
 374                 } else {
 375                         set old_outrow  $olditem
 376                 }
 377                 set old_id              [lindex $old_outrow $id_column]
 378         }
 379         # Process olditem >>>
 380         # Process newitem <<<
 381         array unset row
 382         foreach f $newitem h $hdrs {
 383                 set row($h)     $f
 384         }
 385
 386         set new_visible         [expr $filter]
 387
 388         if {$new_visible} {
 389                 if {$use_trans} $translator
 390
 391                 if {$use_trans} {
 392                         set new_outrow  {}
 393                         foreach h $last_headers {
 394                                 lappend new_outrow      $row($h)
 395                         }
 396                 } else {
 397                         set new_outrow  $newitem
 398                 }
 399                 set new_id              [lindex $new_outrow $id_column]
 400         }
 401         # Process newitem >>>
 402
 403         set damp_onchange       0
 404         switch -- $old_visible,$new_visible {
 405                 0,0 {set damp_onchange  1}
 406                 1,0 {invoke_handlers remove_item $pool $old_id $old_outrow}
 407                 0,1 {invoke_handlers new_item $pool $new_id $new_outrow}
 408                 1,1 {invoke_handlers change_item $pool $old_id $old_outrow $new_outrow}
 409         }
 410 }
 411
 412
 413 body tlc::Datasource_filter::remove_item {pool id olditem} { #<<<1
 414         set hdrs                [$ds get_headers]
 415         array set meta  [$ds pool_meta $pool]
 416
 417         array unset row
 418         foreach f $olditem h $hdrs {
 419                 set row($h)     $f
 420         }
 421
 422         tlc::try {
 423                 if {![expr $filter]} return
 424         } onerr {
 425                 default {
 426                         error "Error applying filter ($filter): $errmsg" "" \
 427                                         [list filter_error $errmsg]
 428                 }
 429         }
 430
 431         set use_trans   [expr {$translator != {}}]
 432
 433         if {$use_trans} $translator
 434
 435         if {$use_trans} {
 436                 set old_outrow  {}
 437                 foreach h $last_headers {
 438                         lappend old_outrow      $row($h)
 439                 }
 440         } else {
 441                 set old_outrow  $olditem
 442         }
 443         set old_id              [lindex $old_outrow $id_column]
 444
 445         set damp_onchange       0
 446         invoke_handlers remove_item $pool $old_id $old_outrow
 447 }
 448
 449
 450 body tlc::Datasource_filter::new_pool {pool} { #<<<1
 451         $dominos(need_refilter) tip
 452         set damp_onchange       0
 453         invoke_handlers new_pool $pool
 454 }
 455
 456
 457 body tlc::Datasource_filter::remove_pool {pool} { #<<<1
 458         $dominos(need_refilter) tip
 459         set damp_onchange       0
 460         invoke_handlers remove_pool $pool
 461 }
 462
 463
 464 body tlc::Datasource_filter::get_headers {} { #<<<1
 465         if {$override_headers != {}} {
 466                 set outhdrs             $override_headers
 467         } else {
 468                 set outhdrs             [$ds get_headers]
 469         }
 470         return $outhdrs
 471 }
 472
 473
 474 body tlc::Datasource_filter::pool_meta {pool} { #<<<1
 475         return [$ds pool_meta $pool]
 476 }
 477
 478