Artifact c045a209b62c207a6630e4e1792b871055364d26:

Attachment "th1x.tcl" to wiki page [search function] added by mario 2014-02-16 21:57:58.

---

#   -------------------------------------------------------------------


#-- Pre-increment
#
#  [++ varname]
#
proc ++ {varname} {
  upvar 1 $varname i
  return [uplevel 1 "set {$varname} [expr 1+$i]"]
}  


#-- while loop
proc while {condition code} {
   return [uplevel 1 "for {} {$condition} {} {$code}"]
}


#-- info exists shorthand
proc isset {varname} {
  return [uplevel 1 "info exists {$varname}"]
}


#-- foreach list
#
# foreach VAR "abc xyz 123" { puts "($VAR) " }
#
proc foreach {varname list code} {
  upvar 1 $varname val
  for {set i 0}  {[expr $i<[llength $list]]}  {++ i} {
     set val [lindex $list $i]
     uplevel 1 "$code"
  }
}


#-- A switch statement.
#
# switch "val" {
#   "cmp1" {code1}
#   "cmp2" {code2}
#   "cmp3" {code3}
#   {{default}} {codeN}
# }
#
proc switch {compare_value val_code_pairs} {
  set len [llength $val_code_pairs]
  for  {set n 0}  {[expr $n<$len]}  {++ n} {
     set cmp [lindex $val_code_pairs $n];
     if {[expr {[expr "{$cmp} eq {$compare_value}"] || [expr "{$cmp} eq {{default}}"]} ]} {
        return [uplevel 1 [lindex $val_code_pairs [++ n]]];
     }
  }
}



#   -------------------------------------------------------------------



   
#-- returns true if string contained in another string
proc str::contains {needle haystack} {
  return [expr {-1 != [string first $needle $haystack]}]
}


#-- wrapper for [string first ...] to support startindex
proc str::next {search content start} {
   # cut out $content at $start before searching
   set p [string first $search [string range $content $start [string length $content]]]
   if [expr $p>=0] {
      set p [expr $start+$p]
   }
   return $p
}


#-- return only string characters that match (up to) a certain set
proc str::spn {str allowed} {
   set r ""
   set n [string length $str]
   for {set i 0} {[expr $i<$n]} {++ i} {
      set c [string range $str $i $i]
      if [str::contains $c $allowed] {
         set r "$r$c"
      } else { break }
   }
   return $r
}


#-- enclose string in e.g. html tags
proc str::wrap {content search before after} {
   set len [string length $search]
   set p 0
   while {[expr [set p [str::next $search $content $p]]>=0]} {
      set content "[string range $content 0 [expr $p-1]]$before$search$after[string range $content [expr $p+$len] 2000]";
      set p [expr $p+[string length "$before+$search+$after"]]; # skip a little further
   }
   return $content
}


#-- Split string into list on delimiter character
# (basically just turns delimiter into space)
#
proc str::explode {delim str} {
   set r ""
   set len [string length $str]
   while {[expr { -1 != [set p [string first $delim $str]] }]} {
      set r "$r [string range $str 0 [expr $p-1]]"
      set str [string range $str [++ p] $len]
   }
   return [list [string trim "$r $str"]]
}   




#   -------------------------------------------------------------------



#-- Whitelist permissible characters for SQL context
# 
# * A workaround for the lack of SQL escaping here (or the new query API branch)
# * Used in LIKE context, so ? and # are not allowed
#
proc sql::allowed {str} {
   return [regexp {^[a-zA-Z0-9 !$&/(){}=<>,.;:-_+#*@]+$} $str]
}


#-- Search function
#
# * Requires fossil-search.php to build the according table
#   (reading from the raw blobs is impossible) as cronjob
# * Is engaged on non-existant wiki pages (hopefully), so
#   we can get $<title> as search terms (no way to access
#   query string parameters otherwise)
# * 
#
proc ui::search {terms baseurl} {

   # cleanup $terms
   if [sql::allowed $terms] {
   
      # prepare search query
      set WHERE ""
      foreach search $terms {
         if [string length $WHERE] { set WHERE "$WHERE AND " }
         set WHERE "$WHERE content LIKE '%$search%'"
      }

      # perform search
      query "SELECT path, type, name, content FROM search WHERE $WHERE" {
      
         set p [string first $terms $content]
         set excerpt [string range $content [expr $p-50] [expr $p+450]]
         foreach search $terms {
            set excerpt [str::wrap "$excerpt" $search <ins> </ins>]
         }
      
         html "\n<div class=search-result>\n";
         html "<b>[htmlize $type]</b>\n";
         html "<a href=[htmlize $path]>[htmlize $name]</a> <br>\n";
         html "<span class=search-link><a href=[htmlize $path]>$baseurl/[htmlize $path]</a></span> <br>\n";
         html "<small class=search-excerpt>$excerpt</small\n>";
         html "</div>\n";
      }
   }
}


#-- Check for existence of wiki page
proc ui::page_exists {name} {
   if [sql::allowed $name] {
      query "SELECT 1 FROM tag WHERE tagname = 'wiki-$name'" {
         return 1
      }
   }
   return 0
}


#-- Check if search can be run
proc ui::search_on_wiki {} {
   upvar 1  title title  baseurl baseurl  current_page current_page
   if [expr {[regexp {^wiki[?]name=} $current_page] && ! [ui::page_exists $title]}] {
      html "<h2 class=search-headline>Search</h2>";
      ui::search $title $baseurl
      html "<br><br><br><br>"
   }
}