Tcl/Tk client for dictd server

 #!/bin/sh
 # Tcl/Tk client to http://dict.org/ server
 #
 # (C) 2006 Fedor Zhigaltsov([email protected]), 
 # may be freely distributed under terms and conditions of GNU GPL.
 # 
 # -*- mode: tcl -*-
 # next line is a comment for Tcl, but not for bash: \
 exec wish "$0" -- "$@"
 
 set dictHost localhost
 set dictPort 2628
 set dictClientName tkdict
 set dictsWithTranscription {mueller7}
 
 option add *text.relief      sunken startupFile
 option add *text.borderWidth 2      startupFile
 option add *text.height      25     startupFile
 option add *text.width       70     startupFile
 # <tags>
 option add *text.searchwordForeground blue startupFile
 option add *text.matchwordForeground blue startupFile
 option add *text.transcriptionForeground \#ce5555 startupFile
 option add *text.transcriptionFont -*-sildoulosipa-*-*-*-*-*-*-*-*-*-*-iso8859-1 startupFile
 # </tags>
 option add *exitKeySequences {Control-q Alt-q Meta-q} startupFile
 
 
 proc showWordDef {entry text} {
     set word [$entry get]
     $text configure -state normal
     $text delete 0.0 end
     
     #$text insert 0.0 [exec dictl $word]
     if {[dictDefineWord $word $text] < 1} {
         if {[dictMatchWord $word $text] <1} {
             $text insert end "No definitions found for \"$word\""
         }
     }
 
     $text mark set insert 0.0
 
     #textSearch $text $word
 
     updateWmTitle $word
     $text configure -state disabled
 
     # select input text for easy deletion
     #$entry selection range 0 end
     
     recordWordInHistory $word
 }
 
 proc dictDefineWord {word text} {
     global dictHost dictPort dictClientName
     set sk [ socket $dictHost $dictPort ]
     fconfigure $sk -translation crlf -buffering none -encoding utf-8
     puts $sk "client \"$dictClientName\""
     puts $sk "define * \"$word\""
     puts $sk {quit}
     
     set STATE_START 0
     set STATE_WAIT_DEFINITION 1
     set STATE_IN_DEFINITION 2
     
     set state $STATE_START
     configure_text_tag $text transcription transcription Transcription
     configure_text_tag $text searchword searchword Searchword
 
     set found 0
 
     while { ![ eof $sk ] } {
         gets $sk line
         #$rawtext insert end "$line\n"
         if {$state == $STATE_START} {
             if [string match {150 *} $line] {
                 # 150 7 definitions retrieved
                 $text insert end [regsub "retrieved" \
                                       [string range $line 4 end] "found"]
                 $text insert end "\n"
                 set state $STATE_WAIT_DEFINITION
                 continue
             }
         } elseif {$state == $STATE_WAIT_DEFINITION} {
             if [string match {151 *} $line] {
                 incr found
                 # 151 "one" mueller7 "Mueller English-Russian Dictionary"
                 # cut "151 "
                 set line [string range $line 4 end] 
                 set next [string first " " $line]
                 set word [string range $line 0 $next ]
                 set word [string trim $word " \""]
 
                 # cut word
                 incr next
                 set line [string range $line $next end]
                 set next [string first " " $line]
                 set dictName [string range $line 0 $next]
                 set dictName [string trim $dictName  " \""]
 
                 # cut dict name
                 incr next
                 set line [string range $line $next end]
                 set dictDesc [string trim $line " \""]
 
                 $text insert end "\n"
                 $text insert end "From $dictDesc \[$dictName\]:\n"
                 $text insert end "\n"
 
                 global dictsWithTranscription
                 set useTranscriptionTag \
                     [expr  \
                          [lsearch -exact \
                               $dictsWithTranscription \
                               $dictName] !=-1 ]
                 set state $STATE_IN_DEFINITION
                 continue
             }
         } elseif {$state == $STATE_IN_DEFINITION} {
             if {$line == "."} {
                 # The textual body of each definition is 
                 # terminated with a CRLF period  CRLF sequence.
                 set state $STATE_WAIT_DEFINITION
                 continue
             }
 
             $text insert end $line
 
             # mark search word 
             set cur {insert linestart}
             while { [set cur \
                          [$text search -nocase \
                               -count length -- $word $cur end]] != "" } {
                 set next [ $text index "$cur + $length char" ]
                 $text tag add searchword $cur $next
                 set cur $next
             }
 
             # mark transcription 
             if {$useTranscriptionTag} {
                 set cur {insert linestart}
                 while { [set cur \
                              [$text search -nocase\
                                   -count length\
                                   -regexp {\[[^\]]*\]} $cur end]] != "" } {
                     set next [ $text index "$cur + $length char" ]
                     $text tag add transcription $cur $next
                     set cur $next
                 }        
             }
 
             $text insert end "\n"
         }
     }
     close $sk
     return $found
 }
 
 
 proc dictMatchWord {word text} {
     global dictHost dictPort dictClientName
     set sk [ socket $dictHost $dictPort ]
     fconfigure $sk -translation crlf
     fconfigure $sk -buffering none
     fconfigure $sk -encoding utf-8
     puts $sk {client "$dictClientName"}
     puts $sk "match * . \"$word\""
     puts $sk {quit}
 
     set STATE_START 0
     set STATE_MATCH 1
     set STATE_FINISH 2
     set matchesFound 0
     set state $STATE_START
 
     configure_text_tag $text matchword matchword Matchword
 
     while { ![ eof $sk ] } {
         gets $sk line
         #$rawtext insert end "$line\n"
         if {$state == $STATE_START} {
             if [string match {152 *} $line] {
                 # 150 94 matches found
                 #$text insert end [string range $line 4 end]
                 #$text insert end "\n"
                 $text insert end "No definitions found for \"$word\", perhaps you mean:"
                 set state $STATE_MATCH
                 continue
             }
         } elseif {$state == $STATE_MATCH} {
             if {$line == "."} {
                 $text insert end "\n"
                 set state $STATE_FINISH
                 continue
             }
             incr matchesFound
             # mueller7 "k"
             set spaceIdx [string first " " $line]
             if {$spaceIdx == -1} {
                 continue
             }
             set curDict [string trim [string range $line 0 $spaceIdx] " "]
             set curWord [string trim [string range $line $spaceIdx end ] " \""]
             
             if { ! [info exists prevDict] || $prevDict != $curDict } {
                 $text insert end "\n"
                 $text insert end "$curDict:"
                 set prevDict $curDict
             } 
             $text insert end "  "
             $text insert end $curWord matchword
 
         }
     }
     close $sk
     return $matchesFound
 }
 
 set history {}
 set historyIdx 0
 
 proc recordWordInHistory {word} {
     global history
     global historyIdx
     # don't put duplicate words into history
     if { [lsearch $history $word] == -1 } {
         lappend history $word
         set historyIdx [llength $history]
         incr historyIdx -1
     }
 }
 
 proc historyUp {entry} {
     global history
     global historyIdx
     if { ! [ llength $history ] } {
         return
     }
     if { $historyIdx > 0 } {
         incr historyIdx -1
     }
     setInputValue $entry [lindex $history $historyIdx]
 }
 
 proc historyDown {entry} {
     global history
     global historyIdx
     if { ! [ llength $history ] } {
         return
     }
     if { $historyIdx < [ llength $history ] - 1 } {
         incr historyIdx
     }
     setInputValue $entry [lindex $history $historyIdx]
 }
 
 # get X selection and insert into entry
 proc setInputValueFromXSelection {entry} {
     if { [catch {setInputValue $entry [selection get] } ] } {
         # error
         return 0
     }
     return 1
 }
 
 proc setInputValue {entry value} {
     $entry delete 0 end
     $entry insert 0 $value
 }
 
 proc deleteWordBackward {entry} {
     set insertIndex [$entry index insert]
     set leftPart [string range [$entry get] 0 $insertIndex]
     set spaceIndex [string last " " $leftPart]
     if { $spaceIndex < 0 } {
         set spaceIndex 0
     } else {
         incr spaceIndex
     }
     $entry delete $spaceIndex $insertIndex
 }
 
 proc updateWmTitle {{searchWord ""}} {
     set s "TkDict"
     if {$searchWord != ""} {
         append s ": $searchWord"
     }
     wm title . $s
 }
 
 proc configure_text_tag { wt tag rpfx cpfx } {
     foreach { o s } {
         -background  Background
         -borderwidth BorderWidth
         -font        Font
         -foreground  Foreground
         -overstrike  Overstrike
         -relief      Relief
         -underline   Underline
     } {
         if { [ set v [ option get $wt $rpfx$s $cpfx$s ] ] != "" } {
             $wt tag configure $tag $o $v
         }
     }
 }
 
 proc usage {} {
     puts {Usage: tkdict [-h host] [-p port] [-s] [word]}
     puts "\t-h host - dictd server host"
     puts "\t-p port - dictd server port"
     puts "\t-x - get word from x selection"
     exit 0
 }
 
 proc parseArguments {argv} {
     global dictHost dictPort
     set args $argv
     while { [ llength $args ] } {
         set cur  [ lindex $args 0 ]
         set args [ lrange $args 1 end ]
         if { ! [ string match "-*" $cur ] } {
             lappend nonOptions $cur
             continue
         }
         switch -exact -- $cur {
             "-h" { set varn dictHost }
             "-p" { set varn dictPort }
             "-s" { set xsel t }
             "--help" { usage ; exit 0 }
             "--" {
                 set nonOptions [ concat $nonOptions $args ]
                 set args {}
             }
             default { puts "unrecognized option `$cur'"; usage }
         }
         if { [ info exists varn ] } {
             if { ! [ llength $args ] } {
                 puts "option requires an argument -- `$cur'"
                 usage
             }
             set $varn [ lindex $args 0 ]
             unset varn
             set args [ lrange $args 1 end ]
         }
     }
 
     if [ info exist nonOptions ] {
         setInputValue .input $nonOptions
         showWordDef .input .text
     } elseif [info exist xsel] {
         if [setInputValueFromXSelection .input] {
             showWordDef .input .text
         }
     }
 }
 
 text .text -yscrollcommand {.scroll set} -setgrid 1 \
     -undo 1 -autosep 1 -state disabled
 
 entry .input
 
 scrollbar .scroll -command {.text yview}
 
 grid .input -sticky we -columnspan 2
 grid .text .scroll -sticky news
 grid rowconfigure . 1 -weight 1
 grid columnconfigure . 0 -weight 1
 
 bind . <Up> {historyUp .input}
 bind . <Control-p> {historyUp .input}
 bind . <Down> {historyDown .input}
 bind . <Control-n> {historyDown .input}
 bind . <F1> {
     if [setInputValueFromXSelection .input] {
         showWordDef .input .text
     }
 }
 
 bind .input <Return> {showWordDef .input .text}
 bind .input <Mod1-BackSpace> {deleteWordBackward .input}
 
 bind .input <Prior> {.text yview scroll -1 page}
 bind .input <Mod1-v> {.text yview scroll -1 page}
 
 bind .input <Next> {.text yview scroll 1 page}
 bind .input <Control-v> {.text yview scroll 1 page}
 
 # configure exit key sequences
 foreach seq [option get . "exitKeySequences" {}] {
     bind . <$seq> {destroy .}
 }
 
 updateWmTitle
 
 parseArguments $argv
 
 focus .input

Example .Xresources:

 Tkdict.exitKeySequences: Escape
 !Tkdict.text.markedBackground: Red
 !Tkdict.text.markedForeground: Yellow
 Tkdict.input.font: -cronyx-fixed-medium-*-*-*-15-*-*-*-*-*-koi8-r
 Tkdict.text.font: -cronyx-fixed-medium-*-*-*-15-*-*-*-*-*-koi8-r
 !Tkdict.text.background: Black
 !Tkdict.text.foreground: Yellow

Arts and crafts of Tcl-Tk programming

Category Application

Category Human Language