visual_regexp.tcl

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

		bind $data(w:replace) <Control-$key> "$data(w:replace) insert insert {\\$key}; break;"
	}

	bind Text <Control-v> {}

	# font selection popup
	foreach w {regexp replace sample} {
		set m [menu .fonts_$w -tearoff 0]
		foreach f $::fonts {
			if {$f == "----"} {
				$m add separator
			} else {
				$m add command -label $f -command "$data(w:$w) configure -font [list $f]"
			}
		}
		bind $data(w:$w) <3> "tk_popup $m %X %Y"
	}

	# some init
	set data(v:nocase) "-nocase"
	set data(v:all) "-all"
	set data(v:wrap) "char"
	set regexp::data(v:mode) $::mode
	replace:toggle		;# set bindings
	regexp:help:toggle
}

proc regexp::pattern:load {{file ""}} {
variable data

	# get filename
	if {$file == ""} {
		set types [list [list "All" *]]
		set file [tk_getOpenFile -filetypes $types -parent .]
	    if {$file == ""} {
			return
		}
	}
	# do it
	set in [open $file "r"]
	$data(w:menu) delete [expr 4+[llength $::regexp_db]/2] end
	while {![eof $in]} {
		set name [gets $in]
		while {$name == ""} {
			set name [gets $in]
		}
		set pattern [gets $in]
		while {$pattern == ""} {
			set pattern [gets $in]
		}
		$data(w:menu) add command -label $name -command "regexp::regexp:insert [list $pattern]"
	}
	close $in
}


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

proc regexp::go {} {
variable data

	set exp [$data(w:regexp) get 1.0 end-1char]
	# check if regexp is OK
	if {[catch { regexp -- $exp dummy } errMsg]} {
		tk_messageBox -type ok -icon error -message "Malformed regexp: $errMsg"
		return
	}
	regexp::regexp:colorize
	regexp::sample:colorize
	regexp::history:add
}

proc regexp::clear {} {
variable data

	regexp::history:add
	$data(w:regexp) delete 1.0 end
	regexp::go
}

proc regexp::dump {} {
variable data

	# update display
	go
	# built list of options
	set dump "regexp"
	foreach option {nocase all   line lineanchor linestop   inline} {
		if {$data(v:$option) != ""} {
			append dump " $data(v:$option)"
		}
	}
	# build expression
	set exp [$data(w:regexp) get 1.0 end-1char]
	append dump " -- {$exp} string"
	# add variables if needed
	if {$data(v:inline) == ""} {
		append dump " match"
		for {set i 1} {$i < $data(v:nblevels)} {incr i} {
			append dump " v$i"
		}
	}
	# put dump into the clipboard (by creating a hidden entry ... anyone has a better solution?)
	destroy .e
	entry .e
	.e insert 0 $dump
	.e selection range 0 end
	puts "$dump"
}

proc regexp::select {level} {
variable data

	# update
	go
	if {[llength $data(v:result)] == 0} {
		bell
		return
	}
	# puts regexp
	dump
	# extract matching parts in sample
	set i 0
	set newsample ""
	foreach match $data(v:result) {
		if {($i % $data(v:nblevels)) == $level} {
			set text [$data(w:sample) get \
							[$data(w:sample) index "1.0+[lindex $match 0]chars"] \
							[$data(w:sample) index "1.0+[expr [lindex $match 1]+1]chars"]]
			append newsample $text
			if {$data(v:mode) == "nl"} {
				append newsample "\n"
			}
		}
		incr i
	}
	$data(w:sample) delete 1.0 end
	$data(w:sample) insert 1.0 $newsample
	# update with regexp
	go
}

proc regexp::help {} {
global tcl_platform

	toplevel .help
	wm title .help "Help"
	# logo
	label .help.l -image logo
	pack .help.l -side top -padx 10 -pady 10
	# help text
	if {$tcl_platform(platform) == "windows"} {
		text .help.t -bd 2 -relief groove -font {Courier 10}
	} else {
		text .help.t -bd 2 -relief groove
	}
	pack .help.t -side top -padx 20
	.help.t tag configure bold -font "[.help.t cget -font] bold"
	.help.t insert 1.0 "Version:" bold " $::version

" normal "Usage:" bold " tkregexp <sampleFile>

" normal "Key bindings:" bold " Alt-q               exit
              Alt-a               toggle 'all' flag
              Alt-n               toggle 'nocase' flag
              Alt-l               toggle 'line' flag
              Alt-k               toggle 'lineanchor' flag
              Alt-m               toggle 'linestop' flag
              Alt-i               toggle 'inline' flag
              Alt-g               do the highlighting
              Return (in regexp)  do the highlighting

" normal "To clipboard:" bold " Put the 'regexp' command with its arguments to the clipboard

" normal "Tips:" bold " 1) To set the sample, either put a filename on the command line,
         or just copy & paste it in the sample text window.
      2) You can change the default colors or windows size by editing the
         first lines of the program file.
      3) when typing your regexp you can use Control-Z/Control-R
         to undo/redo the last typing.
      4) When using the replace function, using Control-Z restore the value
         of the sample before the replacement : you try, retry, reretry, ..."
	# ok button
	button .help.ok -text "Ok" -width 10 -default active -command "destroy .help"
	pack .help.ok -side bottom -pady 10
}

proc regexp::regexp:help:toggle {} {
variable data

	if {$data(v:help) == 0} {
		pack forget $data(w:help)
	} else {
		pack $data(w:help) -before $data(w:regexp) -fill x -padx 5
	}
}

#----------------------------------------------------------------------------------------------
#	Undo/redo (quick and dirty UNDO/REDO support)
#----------------------------------------------------------------------------------------------

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

	# display result
	$data(w:sample) delete 1.0 end
	$data(w:sample) insert 1.0 $data(v:undo:sample)
	# colorize
	go
}

proc regexp::unredo:regexp {dir} {
variable data

	set index [expr ($data(v:undo:index)+$dir) % 100]
	if {![info exists data(v:undo:r$index)]} {
		return
	}
	set data(v:undo:index) $index

	set t $data(w:regexp)
	$t delete 1.0 end
	$t insert 1.0 [lindex $data(v:undo:r$index) 1]
	$t mark set insert [lindex $data(v:undo:r$index) 0]
}

proc regexp::undo:regexp:compute {w k a} {
variable data

	if {[string match -nocase "*control*" $k]
			|| [string match -nocase "*shift*" $k]
			|| [string match -nocase "*alt*" $k]} {
		return
	}

	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]
}

#----------------------------------------------------------------------------------------------
#	Replace
#----------------------------------------------------------------------------------------------

proc regexp::replace {} {
variable data

	set exp [$data(w:regexp) get 1.0 end-1char]
	set subst [$data(w:replace) get 1.0 end-1char]
	if {$exp == ""} {
		set regexp::data(v:nbreplace) "empty regexp"
		return
	}

	# get sample & store it for undo
	set sample [$data(w:sample) get 1.0 end]
	set data(v:undo:sample) $sample
	set result [eval regsub $data(v:all) \
						$data(v:line) $data(v:lineanchor) $data(v:linestop) \
						$data(v:nocase) -- \
						[list $exp] [list $sample] [list [subst -nocommands -novariables $subst]] sample]
	set regexp::data(v:nbreplace) "$result replaced"
	# display result
	$data(w:sample) delete 1.0 end
	$data(w:sample) insert 1.0 $sample
}

proc regexp::replace:toggle {} {
variable data

	if {$regexp::data(v:mode) == "replace"} {
		bind $data(w:regexp) <Tab> "focus $data(w:replace); break;"
		bind $data(w:regexp) <Shift-Tab> "focus $data(w:sample); break;"
		catch { bind $data(w:regexp) <ISO_Left_Tab> "focus $data(w:sample); break;" }

		bind $data(w:replace) <Tab> "focus $data(w:sample); break;"
		bind $data(w:replace) <Shift-Tab> "focus $data(w:regexp); break;"
		catch { bind $data(w:replace) <ISO_Left_Tab> "focus $data(w:regexp); break;" }

		bind $data(w:sample) <Tab> "focus $data(w:regexp); break;"
		bind $data(w:sample) <Shift-Tab> "focus $data(w:replace); break;"
		catch { bind $data(w:sample) <ISO_Left_Tab> "focus $data(w:replace); break;" }

		pack $data(w:allreplace) -side top -fill both

	} else {
		bind $data(w:regexp) <Tab> "focus $data(w:sample); break;"
		catch { bind $data(w:regexp) <ISO_Left_Tab> "focus $data(w:sample); break;" }

		bind $data(w:sample) <Tab> "focus $data(w:regexp); break;"
		catch { bind $data(w:sample) <ISO_Left_Tab> "focus $data(w:regexp); break;" }

		pack forget $data(w:allreplace)
	}
}

#----------------------------------------------------------------------------------------------
#	Manage REGEXP
#----------------------------------------------------------------------------------------------

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

	$data(w:regexp) delete 1.0 end
	$data(w:regexp) insert 1.0 $text
}

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

	set exp [$data(w:regexp) get 1.0 end-1char]
	set max [string length $exp]
	set stack {}
	# list format : min max min max ...
	set indices [list "report" 0 [string length $exp]]
	# search the groups in the regexp
	set data(v:nblevels) 1
	for {set i 0} {$i < $max} {incr i} {
		set c [string index $exp $i]
		if {$c == "\\"} {
			incr i
			continue
		} elseif {$c == "("} {
			set c [string index $exp [expr $i+1]]
			set what [string index $exp [expr $i+2]]
			# test for escape with (?...)
			if {$c == "?"} {
				if {$what != ":"} {
					lappend indices "lookahead"
				} else {
					lappend indices "noreport"
				}
			} else {
				lappend indices "report"
				incr data(v:nblevels)
			}
			lappend indices $i
			set stack "[llength $indices] $stack"
			lappend indices 0

		} elseif {$c == ")"} {