Merge branch 'jamespic-master'

README.md

@@ -422,6 +422,48 @@ it "should add X-Common-Name-SSL with Common Name from client SSL certificate if
 }
 ```
 
+### Classes Example
+
+TesTcl has partial support for the `class` command. For example, we could test the following rule:
+
+```tcl
+rule classes {
+  when HTTP_REQUEST {
+    if { [class match [IP::remote_addr] equals blacklist] } {
+      drop
+    } else {
+      pool main-pool
+    }
+  }
+}
+```
+
+with code that looks like this
+
+```tcl
+package require -exact testcl 1.0.7
+namespace import testcl::*
+
+before {
+  event HTTP_REQUEST
+  class configure blacklist {
+    "blacklisted" "192.168.6.66"
+  }
+}
+
+it "should drop blacklisted addresses" {
+  on IP::remote_addr return "192.168.6.66"
+  endstate drop
+  run irules/classes.tcl classes
+}
+
+it "should drop blacklisted addresses" {
+  on IP::remote_addr return "192.168.0.1"
+  endstate pool main-pool
+  run irules/classes.tcl classes
+}
+```
+
 ## How stable is this code?
 This work is quite stable, but you can expect minor breaking changes.
 

src/classes.tcl

@@ -0,0 +1,151 @@
+package provide testcl 1.0.7
+package require log
+package require cmdline
+
+namespace eval ::testcl {
+  namespace export class
+  variable classes
+}
+
+# testcl::class --
+# 
+# stub for class command
+#
+# See https://devcentral.f5.com/wiki/irules.class.ashx
+# 
+# class match [<options>] <item> <operator> <class>
+# class search [<options>] <class> <operator> <item>
+# class lookup <item> <class>
+# class element [<options>] <index> <class>
+# class type <class>
+# class exists <class>
+# class size <class>
+# class names [-nocase] <class> [<pattern>]
+# class get [-nocase] <class> [<pattern>]
+# class startsearch <class>
+# class nextelement [<options>] <class> <search_id>
+# class anymore <class> <search_id>
+# class donesearch <class> <search_id>
+# 
+# For convenience, we also add an extra helper subcommand:
+# class configure <class_data>
+#
+# Example:
+# class configure servers {
+#   "server1" "192.168.0.1"
+#   "server2" "192.168.0.2"
+# }
+#
+# This format bears no resemblance to the formats used in F5
+# load balancers, and is simply the easiest to implement
+
+proc ::testcl::class {cmd args} {
+  variable classes
+  log::log debug "class $cmd $args invoked"
+
+  set cmdargs [concat class $cmd $args]
+  set rc [catch { return [eval testcl::expected $cmdargs] } res]
+  if {$rc != 1500} {
+    log::log debug "skipping class method evaluation - expectation found for $cmdargs"
+    if {$rc < 1000} {
+      return $res
+    }
+    return -code $rc $res
+  }
+
+  set options {
+      {index    "Changes the return value to be the index of the matching class element."}
+      {name     "Changes the return value to be the name of the matching class element."}
+      {value    "Changes the return value to be the value of the matching class element."}
+      {element  "Changes the return value to be a list of the name and value of the matching class element."}
+  }
+
+  set return_command {
+    if {$params(index)} {return $i}
+    if {$params(name)} {return $element_name}
+    if {$params(value)} {return $element_value}
+    if {$params(element)} {return [list $element_name $element_value]}
+    return 1
+  }
+
+  set return_failure_block {
+    if {$params(index)} {return -1}
+    if {$params(name)} {return ""}
+    if {$params(value)} {return ""}
+    if {$params(element)} {return ""}
+    return 0
+  }
+
+  array set params [::cmdline::getoptions args $options]
+  switch -- $cmd {
+    configure {
+      set name [lindex $args 0]
+      set value [lindex $args 1]
+      set classes($name) $value
+    }
+    search {
+      set classname [lindex $args 0]
+      set operator [lindex $args 1]
+      set item [lindex $args 2]
+      if {[expr ! [info exists classes($classname)]]} $return_failure_block
+      set clazz $classes($classname)
+      for {set i 0} {$i < [llength $clazz] / 2} {incr i} {
+        set element_name [lindex $clazz [expr 2 * $i]]
+        set element_value [lindex $clazz [expr 2 * $i + 1]]
+        if "\$element_value $operator \$item" $return_command
+      }
+      eval $return_failure_block
+    }
+    match {
+      set item [lindex $args 0]
+      set operator [lindex $args 1]
+      set classname [lindex $args 2]
+      if {[expr ! [info exists classes($classname)]]} $return_failure_block
+      set clazz $classes($classname)
+      for {set i 0} {$i < [llength $clazz] / 2} {incr i} {
+        set element_name [lindex $clazz [expr 2 * $i]]
+        set element_value [lindex $clazz [expr 2 * $i + 1]]
+        if "\$item $operator \$element_value" $return_command
+      }
+      eval $return_failure_block
+    }
+    lookup {
+      set item [lindex $args 0]
+      set classname [lindex $args 1]
+      return [::testcl::class match -value $item equals $classname]
+    }
+    element {
+      set index [lindex $args 0]
+      set classname [lindex $args 1]
+      set name [lindex $classes($classname) [expr 2 * $index]]
+      set value [lindex $classes($classname) [expr 2 * $index + 1]]
+      if {$params(name)} {
+        return $name
+      }
+      if {$params(value)} {
+        return $value
+      }
+      return [list $name $value]
+    }
+    exists {
+      set classname [lindex $args 0]
+      return [info exists classes($classname)]
+    }
+    size {
+      set classname [lindex $args 0]
+      if {[expr ! [info exists classes($classname)]]} {
+        return 0
+      } else {
+        return [expr [llength $classes($classname)] / 2]
+      }
+    }
+    type -
+    names -
+    get -
+    startsearch -
+    nextelement - 
+    anymore -
+    donesearch {error "Not implemented yet"}
+  }
+
+}

test/test_class.tcl

@@ -0,0 +1,38 @@
+source src/on.tcl
+source src/assert.tcl
+source src/classes.tcl
+namespace import ::testcl::*
+
+# Comment out to suppress logging
+#log::lvSuppressLE info 0
+
+class configure server {
+  "server1" "192.168.0.1"
+  "server2" "192.168.0.2"
+}
+
+class configure protocols {
+  "http" "http://"
+  "mailto" "mailto:"
+  "ftp" "ftp://"
+}
+
+if { $::tcl_platform(platform) eq "java" } {
+  assertStringEquals [class search -value server ends_with "0.1"] "192.168.0.1"
+  assertStringEquals [class search -name server ends_with "0.2"] "server2"
+  assertStringEquals [class match -element "http://localhost" starts_with protocols] [list "http" "http://"]
+  assertNumberEquals [class match -index "ftp://locahost" starts_with protocols] 2	
+}
+assertNumberEquals [class search server eq "192.168.0.1"] 1
+assertNumberEquals [class search server eq "doesn't exist"] 0
+assertNumberEquals [class search doesnt_exist eq "192.168.0.1"] 0
+assertStringEquals [class -value search server eq "doesn't exist"] ""
+assertStringEquals [class -name search doesnt_exist eq "192.168.0.1"] ""
+assertNumberEquals [class size protocols] 3
+assertNumberEquals [class size doesnt_exist] 0
+assertStringEquals [class element 2 protocols] [list "ftp" "ftp://"]
+assertStringEquals [class element -name 1 protocols] "mailto"
+assertStringEquals [class element -value 0 protocols] "http://"
+assertNumberEquals [class exists server] 1
+assertNumberEquals [class exists doesnt_exist] 0
+