scripts/uri.itcl

   1 # vim: foldmarker=<<<,>>>
   2
   3 # tlc::Uri singleton handles a registry of uri types and handlers,
   4 # and invokes the appropriate handlers on a dispatch() method call
   5
   6 itcl::class tlc::Uri {
   7         constructor {args} {}
   8
   9         public {
  10                 method register_handler {type handler}
  11                 method unregister_handler {type handler}
  12                 method dispatch {uri}
  13                 method construct_uri {pref rest arglist}
  14         }
  15
  16         private {
  17                 variable handlers
  18         }
  19 }
  20
  21
  22 itcl::body tlc::Uri::constructor {args} { #<<<1
  23         array set handlers      {}
  24
  25         eval configure $args
  26 }
  27
  28
  29 # Register a handler for <type>://rest as <handler>
  30 itcl::body tlc::Uri::register_handler {type handler} { #<<<1
  31         if {[info exists handlers($type)]} return               ;# Disallow multi handlers
  32         if {![info exists handlers($type)] || [lsearch $handlers($type) $handler] == -1} {
  33                 lappend handlers($type) $handler
  34         }
  35 }
  36
  37
  38 # Unregister the <handler> for <type>.  Silently returns if not registered
  39 itcl::body tlc::Uri::unregister_handler {type handler} { #<<<1
  40         if {![info exists handlers($type)]} return
  41         set idx         [lsearch $handlers($type) $handler]
  42         set handlers($type)             [lreplace $handlers($type) $idx $idx]
  43 }
  44
  45
  46 # Invoke all registered handlers for <type>, passing the remainder after the
  47 # '://' as the only parameter
  48 # Returns 1 on success (if at least one handler was invoked), 0 otherwise
  49 itcl::body tlc::Uri::dispatch {uri} { #<<<1
  50         set idx         [string first "://" $uri]
  51         set aidx        [string first "?" $uri]
  52         if {$aidx == -1} {set aidx      "end"} else {incr aidx -1}
  53         if {$idx == -1} {return 0}
  54         incr idx        -1
  55         set type        [string range $uri 0 $idx]
  56         incr idx        4
  57         set rest        [string range $uri $idx $aidx]
  58         if {$aidx != "end"} {
  59                 incr aidx       2
  60                 set argsl       [split [string range $uri $aidx end] &]
  61         } else {
  62                 set argsl       {}
  63         }
  64
  65         array set build {}
  66         foreach a $argsl {
  67                 set al  [split $a =]
  68                 set build([lindex $al 0])       [lindex $al 1]
  69         }
  70         set argsmap     [array get build]
  71
  72         if {![info exists handlers($type)]} {
  73                 puts "tlc::Uri::dispatch: warning: no handler registered for type ($type)"
  74                 parray handlers
  75                 return 0
  76         }
  77
  78         set ok  0
  79         foreach handler $handlers($type) {
  80                 puts "Uri::dispatch uplevel #0 $handlers($type) [list $rest] $argsmap"
  81                 uplevel #0 $handlers($type) [list $rest] $argsmap
  82                 set ok  1
  83         }
  84
  85         return $ok
  86 }
  87
  88
  89 itcl::body tlc::Uri::construct_uri {pref rest arglist} { #<<<1
  90         set uri         "$pref://$rest"
  91         if {[llength $arglist] > 0} {
  92                 foreach {key val} $arglist {
  93                         lappend qargs   [join [list $key $val] =]
  94                 }
  95                 append uri      "?" [join $qargs "&"]
  96         }
  97
  98         return $uri
  99 }
 100
 101