1# $Id$ 2 3namespace eval highlight { 4 5 custom::defgroup Highlight [::msgcat::mc "Groupchat message highlighting plugin options."] \ 6 -group Chat \ 7 -group {Rich Text} 8 9 custom::defvar options(enable_highlighting) 1 \ 10 [::msgcat::mc "Enable highlighting plugin."] \ 11 -type boolean -group Highlight \ 12 -command [namespace current]::on_state_changed 13 14 custom::defvar options(highlight_nick) 1 \ 15 [::msgcat::mc "Highlight current nickname in messages."] \ 16 -type boolean -group Highlight 17 18 custom::defvar options(highlight_substrings) {} \ 19 [::msgcat::mc "Substrings to highlight in messages."] \ 20 -type string -group Highlight 21 22 custom::defvar options(highlight_whole_words) 1 \ 23 [::msgcat::mc "Highlight only whole words in messages."] \ 24 -type boolean -group Highlight 25} 26 27proc highlight::configure_richtext_widget {w} { 28 # TODO some defaults may be? 29 30 $w tag configure highlight 31} 32 33proc highlight::process_highlights {atLevel accVar} { 34 upvar #$atLevel $accVar chunks 35 36 variable options 37 38 set subs [split $options(highlight_substrings) " "] 39 if {$options(highlight_nick) && [::richtext::property_exists mynick]} { 40 lappend subs [::richtext::property_get mynick] 41 } 42 43 set out {} 44 45 foreach {s type tags} $chunks { 46 if {$type != "text"} { 47 # pass through 48 lappend out $s $type $tags 49 continue 50 } 51 52 set ts 0 53 54 foreach {ms me} [spot_highlights $s $subs] { 55 # Write out text before current highlight, if any: 56 if {$ts < $ms} { 57 lappend out [string range $s $ts [expr {$ms - 1}]] $type $tags 58 } 59 # Write out current highlight: 60 lappend out [string range $s $ms $me] highlight $tags 61 62 set ts [expr {$me + 1}] 63 } 64 65 # Write out text after the last highlight, if any: 66 if {[string length $s] - $ts > 0} { 67 lappend out [string range $s $ts end] $type $tags 68 } 69 } 70 71 set chunks $out 72} 73 74proc highlight::spot_highlights {s subs} { 75 variable options 76 77 set words [textutil::splitx $s {([\t \r\n]+)}] 78 79 set ind_end 0 80 set stop_ind [string length $s] 81 set ranges {} 82 set found 1 83 while {$found && $ind_end < $stop_ind} { 84 set found 0 85 set ind $ind_end 86 foreach str $subs { 87 set len [string length $str] 88 if {$len > 0 && [set match [string first $str $s $ind]] >= 0} { 89 if {!$options(highlight_whole_words) || \ 90 (![string is wordchar -strict [string index $s [expr {$match - 1}]]] && \ 91 ![string is wordchar -strict [string index $s [expr {$match + $len}]]])} { 92 if {!$found} { 93 set found 1 94 set ind_start $match 95 set ind_end [expr {$match + $len}] 96 } elseif {$match < $ind_start} { 97 set ind_start $match 98 set ind_end [expr {$match + $len}] 99 } 100 } 101 } 102 } 103 if {$found} { 104 lappend ranges $ind_start [expr {$ind_end - 1}] 105 } 106 } 107 108 return $ranges 109} 110 111proc highlight::render_highlight {w type piece tags} { 112 $w insert end $piece [lfuse $type $tags] 113} 114 115# The following procedure reports highlighting inside URLs too 116proc highlight::check_highlighted_message {vpersonal nick body} { 117 variable options 118 upvar 2 $vpersonal personal 119 120 set subs [split $options(highlight_substrings) " "] 121 if {$options(highlight_nick)} { 122 lappend subs $nick 123 } 124 if {![lempty [spot_highlights $body $subs]]} { 125 set personal 1 126 } 127} 128 129hook::add check_personal_message_hook \ 130 [namespace current]::highlight::check_highlighted_message 131 132proc highlight::on_state_changed {args} { 133 variable options 134 135 ::richtext::entity_state highlight $options(enable_highlighting) 136} 137 138namespace eval highlight { 139 ::richtext::register_entity highlight \ 140 -configurator [namespace current]::configure_richtext_widget \ 141 -parser [namespace current]::process_highlights \ 142 -renderer [namespace current]::render_highlight \ 143 -parser-priority 60 144 145 on_state_changed 146} 147 148# vim:ts=8:sw=4:sts=4:noet 149