visual_regexp.tcl

tcl/tk正则表达式工具的源代码

			set idx [lindex $stack 0]
			if {$idx == ""} {
				continue
			}
			set stack [lrange $stack 1 end]
			set indices [lreplace $indices $idx $idx $i]
		}
	}

	# remove old colors
	foreach level $data(v:levels) {
		$data(w:regexp) tag remove $level 1.0 end
	}
	$data(w:regexp) tag remove "lookahead" 1.0 end
	$data(w:regexp) tag remove "noreport" 1.0 end
	# colorize the regexp
	set i 0
	foreach {type min max} $indices {
		if {$type != "report"} {
			continue
		}
		$data(w:regexp) tag add [lindex $data(v:levels) $i] \
				[$data(w:regexp) index "1.0+${min}chars"] \
				[$data(w:regexp) index "1.0+[expr $max+1]chars"]
		incr i
	}
	# apply special item
	foreach {type min max} $indices {
		if {$type == "report"} {
			continue
		}
		$data(w:regexp) tag add $type \
				[$data(w:regexp) index "1.0+${min}chars"] \
				[$data(w:regexp) index "1.0+[expr $max+1]chars"]
	}
}

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

proc regexp::regexp:load {} {
variable data

	# get filename
	set types [list [list "All" *]]
	set file [tk_getOpenFile -filetypes $types -parent .]
	if {$file == ""} {
		return
	}
	# do it
	set in [open $file "r"]
	regexp:set [read $in [file size $file]]
	close $in
}

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

proc regexp::regexp:insert {what} {
variable data

	set w $data(w:regexp)
	# prepare undo/redo
	set data(v:undo:r$data(v:undo:index)) [list [$w index insert] [$w get 1.0 end-1char]]
	set data(v:undo:index) [expr ($data(v:undo:index)+1) % 100]
	# do it
	$w insert insert $what
	# prepare undo/redo
	set data(v:undo:r$data(v:undo:index)) [list [$w index insert] [$w get 1.0 end-1char]]
}

#----------------------------------------------------------------------------------------------
# History window to memorize already typed regexp

proc regexp::history:init {} {
variable data
global font

	set w [toplevel .history]
	wm title $w "Visual REGEXP $::version -- REGEXP History"
	wm geometry $w 640x480
	wm protocol $w WM_DELETE_WINDOW "set regexp::data(v:history) 0; wm withdraw $w"

	# text zone	
	set tf [frame $w.t]
	pack $tf -side top -expand true -fill both
	set t [text $tf.t -xscrollcommand "$tf.x set" -yscrollcommand "$tf.y set" \
					-bg white -font $::font_regexp -width 5 -height 1 \
					-selectbackground lightblue -selectborderwidth 0]
	set data(w:history) $t
	$t tag configure spacing -font {Helvetica 6}
	set tx [scrollbar $tf.x -bd 1 -orient horizontal -command "$t xview"]
	set ty [scrollbar $tf.y -bd 1 -orient vertical -command "$t yview"]
	bindtags $t "$t all"
	grid $t  $ty -sticky news
	grid $tx x   -sticky news
	grid columnconfigure $tf {0} -weight 1
	grid columnconfigure $tf {1} -weight 0
	grid rowconfigure $tf {0} -weight 1
	grid rowconfigure $tf {1} -weight 0

	# buttons
	set bf [frame $w.f]
	pack $bf -side bottom -padx 5 -pady 5

	set b1 [button $bf.1 -bd 1 -text "Hide" -command "wm withdraw $w; set ::regexp::data(v:history) 0"]
	set b2 [button $bf.2 -bd 1 -text "Save ..." -command "regexp::history:save"]
	pack $b2 $b1 -side left -anchor c

	wm withdraw $w
}

set last ""
set counter 0

proc regexp::history:add {} {
variable data

	if {$::inReplay} {
		# avoid to put the same expression again when replaying it
		set ::inReplay 0
		return
	}

	set exp [$data(w:regexp) get 1.0 end-1char]
	if {$exp != "" && $exp != $::last} {
		# memorize position
		set start [$data(w:history) index insert]
		# add text
		$data(w:history) insert end "$exp\n"
		set end [$data(w:history) index insert]
		$data(w:history) insert end "\n" {spacing}
		set ::last $exp
		$data(w:history) yview moveto 1.0
		# do the binding
		set tag "t$::counter"
		incr ::counter
	    $data(w:history) tag bind $tag <Any-Enter> "$data(w:history) tag configure $tag -background lightblue"
	    $data(w:history) tag bind $tag <Any-Leave> "$data(w:history) tag configure $tag -background {}"
		$data(w:history) tag bind $tag <1> "regexp::history:replay [list $exp]"
		$data(w:history) tag add $tag $start $end

		# colorize the expression in history
		scan $start "%d.%d" sl sc
		incr sl -1
		foreach tag {e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 lookahead noreport} {
			foreach {start end} [$data(w:regexp) tag ranges $tag] {
				set start [$data(w:history) index "$start + $sc chars + $sl lines"]
				set end [$data(w:history) index "$end + $sc chars + $sl lines"]
				$data(w:history) tag add $tag $start $end
			}
		}
	}
}

set inReplay 0

proc regexp::history:replay {text} {
variable data

	set ::inReplay 1
	regexp:set $text
	go
}

proc regexp::history:save {} {
variable data

	set file [tk_getSaveFile -defaultextension .txt]
	if {$file != ""} {
		set out [open $file "w"]
		puts -nonewline $out [$data(w:history) get 1.0 end]
		close $out
	}
}


#----------------------------------------------------------------------------------------------
#	Manage SAMPLE
#----------------------------------------------------------------------------------------------

proc regexp::sample:set {text} {
variable data

	$data(w:sample) delete 1.0 end
	$data(w:sample) insert 1.0 $text
	set data(v:undo:sample) $text
}

proc regexp::sample:colorize {} {
variable data

	# remove old tags
	foreach level $data(v:levels) {
		$data(w:sample) tag remove $level 1.0 end
	}
	set data(v:position) 0
	set data(v:positions) [list ]

	# set new tags
	set exp [$data(w:regexp) get 1.0 end-1char]
	if {$exp == ""} {
		set data(v:result) {}
		return
	}
	set result [eval regexp -inline -indices $data(v:all) \
						$data(v:line) $data(v:lineanchor) $data(v:linestop) \
						$data(v:nocase) -- \
						[list $exp] [list [$data(w:sample) get 1.0 end]]]
	set data(v:result) $result
	set i 0
	foreach match $result {
		set start [$data(w:sample) index "1.0+[lindex $match 0]chars"]
		$data(w:sample) tag add e[expr $i % $data(v:nblevels)] \
				$start [$data(w:sample) index "1.0+[expr [lindex $match 1]+1]chars"]
		lappend data(v:positions) $start
		if {$i == 0} {
			$data(w:sample) see $start
		}
		incr i
	}
	# set nb of matches
	if {$data(v:nblevels)} {
		set nb 0
		foreach item $result {
			if {[lindex $item 0] <= [lindex $item 1]} {
				incr nb
			}
		}
		set regexp::data(v:nbmatches) "[expr $nb/$data(v:nblevels)] matches"
	} else {
		set regexp::data(v:nbmatches) "? matches"
	}
}

proc regexp::sample:background {} {
variable data

	foreach level $data(v:levels) color $::colors bgcolor $::bgcolors {
		if {$data(v:background)} {
			$data(w:sample) tag configure $level -foreground $color -background $bgcolor
		} else {
			$data(w:sample) tag configure $level -foreground $color -background {}
		}
	}
}

proc regexp::sample:move {amount} {
variable data

	if {$amount == -1} {
		if {$data(v:position) > 0} {
			incr data(v:position) -1
		}
	} else {
		if {$data(v:position) < [llength $data(v:positions)]-1} {
			incr data(v:position) +1
		}
	}
	set where [lindex $data(v:positions) $data(v:position)]
	if {$where != ""} {
		$data(w:sample) see $where
		$data(w:sample) mark set insert $where
		focus $data(w:sample)
	}
}

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

proc regexp::sample:load {} {
variable data

	# get filename
	set types [list [list "All" *]]
	set file [tk_getOpenFile -initialdir $data(v:dir) -filetypes $types -parent .]
    if {$file == ""} {
		return
	}
	# memorize location
	set data(v:dir) [file dirname $file]
	set data(v:file) [file tail $file]
	# do it
	set in [open $file "r"]
	sample:set [read $in [file size $file]]
	close $in
}

proc regexp::sample:save {mode} {
variable data

	# get filename
	set types [list [list "All" *]]
	set file [tk_getSaveFile -initialdir $data(v:dir) -initialfile $data(v:file) \
							 -filetypes $types -parent .]
    if {$file == ""} {
		return
	}
	# memorize location
	set data(v:dir) [file dirname $file]
	set data(v:file) [file tail $file]
	# do it
	set out [open $file "w"]
	fconfigure $out -translation $mode
	puts $out [$data(w:sample) get 1.0 end]
	close $out
}


#----------------------------------------------------------------------------------------------
#	Main toplevel commands
#----------------------------------------------------------------------------------------------

proc regexp::make-regexp {} {
variable data

	# new dialog
	catch { destroy .mkregexp }
	set w [toplevel .mkregexp]
	wm title $w "Make regexp"
	wm geometry $w 640x480
	# widgets
	set f [frame $w.top]
		# area to input words
		label $f.l1 -text "Words list:"
		set list [text $f.list -wrap char -bg white -font $::font_regexp \
							-selectbackground lightblue -selectborderwidth 0 \
							-width 1 -height 10 -bd 1 -yscrollcommand "$f.sy1 set"]
		scrollbar $f.sy1 -command "$list yview" -orient vertical -bd 1
		# button to compute the regexp
		set doit [button $f.doit -text "Compute" -width 15 -bd 1 -command "regexp::make-regexp:compute"]
		# display result
		label $f.l2 -text "Regexp:"
		set output [text $f.output -wrap char -bg white -font $::font_regexp \
							-selectbackground lightblue -selectborderwidth 0 \
							-width 1 -height 4 -bd 1 -yscrollcommand "$f.sy2 set"]
		bindtags $output "$output all"
		scrollbar $f.sy2 -command "$output yview" -orient vertical -bd 1
		# layout
		grid $f.l1	$list		$f.sy1		-sticky news
		grid $doit	-			-			-sticky ns -pady 2
		grid $f.l2	$output	$f.sy2		-sticky news
		grid columnconfigure $f {1} -weight 1
		grid rowconfigure $f {0 2} -weight 1
		# init