ADDED modules/ctext/ChangeLog Index: modules/ctext/ChangeLog ================================================================== --- /dev/null +++ modules/ctext/ChangeLog @@ -0,0 +1,601 @@ +3.1.3 - Thu Jan 22 14:51:08 GMT 2004 + + I changed the bindtags so that binding to + the parent frame will cause the child $win.t + to invoke those bindings. This means that + you can create menus that popup on + ButtonPress-3 without having to use bind.tree + or a similar mechanism. Thank Jeff Hobbs + for pointing this out. + + I fixed the destroy event handling, so that + it will now not cleanup the widget when a + temporary child of the widget is destroyed. + +3.1.2 - Fri May 23 17:33:17 GMT 2003 + + I fixed ctext::deleteHighlighClass so + that it will now delete regexp classes. + I had to modify ctext::getHighlightClasses + and ctext::addHighlightClassForRegexp to + fix it. I've decided to keep the package + provide at 3.1. + +3.1.1 - Fri May 23 00:53:39 GMT 2003 + + I made some minor changes to configure + instance handling, so that .t config + will return the proper values. Alas I + decided to add a TODO, because the values + aren't quite like standard Tk; with the + resource classes and all. + +3.1 - Thu May 22 01:30:41 GMT 2003 + + I fixed some bugs on the configure instance + handling. I added ctext::buildArgParseTable, + which improves performance, because now the + table is only generated once per widget. + + I improved cget to accept glob expressions, + which also fixed a bug with strings like: + cget -yscroll which didn't match an array + element, but do match when passed to the + real text widget. + + You can now pass strings like: + .t config -flag + + and the value for -flag will be returned + even if the flag is special to ctext. + This took some engineering to get right. + + I fixed a bug in the test files that occured + due to some fixes. Basically I'm using list + now to construct the tagInfo for each highlight + class. This caused problems, because I was + previously using strings. The test files were + using escapes to work around the quoting + problem. They have been changed and now + everything should work properly. You will + need to lookout for this problem if you + upgrade. + + I updated REGRESSION. + + The end result is a good release based on + my testing. + +3.1-alpha-5 - Thu May 15 00:39:10 GMT 2003 + + I fixed a minor bug in argument handling + in the configure instance handler. + +3.1-alpha-4 - Wed May 14 17:09:32 GMT 2003 + + I improved install.tcl by adding more + information about auto_path. + + I fixed a bug with listbox selection in + install.tcl (curselection wasn't used). + + I renamed ctext::getClasses to + ctext::getHighlightClasses. + + I made some uplevel calls list based, so + that if $win has a space in its path ctext + will work correctly. + + I made the class creation procs all use + list for storing items in the arrays. + + I modified ctext::getHighlightClasses to + return a list in the format of: + class [list items ...] + + I fixed a bug with + ctext::addHighlightClassForRegexp. It + wasn't storing the $re in the class array. + This was new to the 3.x series. + +3.1-alpha-2-3 - Tue May 13 19:30:51 GMT 2003 + + I have redone the configure instance + handling. I added -linemap_select_fg + and -linemap_select_bg. I have updated + the README to reflect the new commands + and options introduced in the 3.x series. + I have removed the TODO file, because all + tasks within it have been completed. + + I added an install.tcl script. It's + very easy to use and passes all of my + tests. + + I need to test with Malephiso, + because there may be minor issues I + haven't noticed. + +3.1-alpha-1 - Mon May 12 23:12:18 GMT 2003 + + I've made many changes that have cleaned + up the code. I have added -linemap_markable. + I changed ctext::getAr to accept a suffix. + I'm now using global variables with a + __ctext prefix, because it is easier than + using namespace variables. + + The _blink tag was renamed to __ctext_blink. + + I added ctext::deleteHighlightClass, which + works with any of the 4 class creators. It + needs more testing, but so far it passes + all of my tests. + + I want to wait about a week or so and go + over each line of code slowly. I've tried + to engineer this well, but typos happen, so... + + I need to merge more of Andreas Sievers' + changes and features. + +[At this point Andreas Sievers working on ASED +submitted his 3.0 to me and I decided to create +3.1 which merges 2.7-alpha with his work.] + +2.7-alpha - Fri May 2 13:08:48 GMT 2003 + + I have added -linemap_mark_command with + an example in ctext_test_interactive.tcl + + I addec ctext::getAr which I'm using to + store more state information about the + widget for cget and configure. I modified + cget and configure to use it, and they + are now more useful. + + This is an alpha release because I haven't + tested it much. I still need to spend + some time and review the diffs. I'll + probably get to that next week, and I'll + test it with Malephiso (my editor). I + should also update the README with + information about -linemap_mark_command. + +2.6.10 - Tue Apr 29 20:47:29 GMT 2003 + + I fixed a bug with -font handling in the + instance command. + You can now do: + .t config -font + and it will change the linemap font as + well as the main text widget. + + I cleaned up argument handling in the + constructor and instance commands. They + now use concat and are simpler. + + I added ctext::event:Destroy which now + takes care of removing an interp alias + which was missing in previous releases. + + interp alias is now used rather than + eval with a dummy proc for creating an + instance command. + + $win now has a binding that + should fix a problem some of you may + experience. + You can now do: + focus $win + and it will act like: + focus $win.t + + I removed uplevel n eval calls, which + were pointless. I didn't realize + when I wrote them that uplevel acts like + eval. + +2.6.9 - Mon Apr 28 16:17:13 GMT 2003 + + I fixed a minor focus issue by adding + -takefocus 0 to the linemap creator. + + I also removed an uplevel #0 for interp + alias, which wasn't needed. + + I removed the government clause in the + LICENSE. + + I'm pondering a rewrite of Ctext (yet again) + which will use SDynObject, and provide more + features, but the thought "Why fix it if it + isn't broken?" comes to mind. + +2.6.8 - Mon Dec 2 18:24:49 GMT 2002 + + I fixed two bugs pointed out by Neil Madden. + + The initial creation of the widget failed + when -linemap 0 was used. + + The virtual event <> was not occuring. + ---- + I cleaned up several rough areas in the code. + + I cleaned up the code in the creation of the + widget for -yscrollcommand and the linemap. + + I cleaned up the code in the configure instance + command handler. + + ---- + This release passes all of my tests with + Tcl/Tk 8.3 and 8.4. To make debugging easier + I have added ctext_test_interactive.tcl + +2.6.7 - Fri Nov 22 16:39:41 GMT 2002 + + I fixed a bug with C comment highlighting. It + wasn't updating the highlighting when the + insertion was just one character. The problem + was that the RE didn't match, because the + previous char and next char were not used to + decipher the match. + + This release was tested with Tcl/Tk 8.4 + +2.6.6 - Thu Aug 22 23:46:14 GMT 2002 + + I fixed a serious bug with ctext::matchPair + and ctext::matchQuote. The problem was that + in some cases the pattern )|}|] was causing + an infinite loop when no other patterns matched. + It was finding the same character over and over + again. This is fixed now. I'm sorry to anyone + that was bothered by this. I found it today with + Malephiso while editing a test file. It basically + locked up my editor. The long scripts and C code + I've been editing in the past haven't had this + problem, due to multiple characters matching. + + Please report BUGS. I need your help. + +2.6.5 - Tue Aug 20 23:27:23 GMT 2002 + + I fixed a minor issue with handling. + A catch was needed to prevent an error + message, due to several events + occuring in some cases. + + +2.6.4 - Tue Jul 23 19:29:49 MDT 2002 + + I fixed a minor bug with the linemap updating. + I didn't notice that with a small number of + lines it wasn't displaying the line numbers + properly. + + I fixed a major flaw with 8.4 handling. The + 8.4 text widget has some new features, and + the edit instance command wasn't dealing with + the requests properly. Now it should, but + I haven't tested it a lot. + + +2.6.3 - Fri Jul 5 11:32:42 MDT 2002 + + I made improvements to ctext::matchPair that + should improve the speed. I also fixed a + bug that occured with the pattern { \}. + + I added an edit modified instance command. + I'm not sure if it works like the Tk 8.4 + version, but it should work well enough. + + I added edit modified tests to ctext_test.tcl + + I added -class Ctext to the parent frame. + Those of you using .Xdefaults may want this. + + I updated the README for edit modified. + + It's about time for another study session of + the code to fix any bugs or potential bugs. + +2.6.2 - Mon Jul 1 09:31:39 MDT 2002 + + I fixed a bug with handling. + + I removed all calls to variable, and now use + the fully qualified namespace name for variables. + This makes the code more concise and cleaner. + + I improved the speed of + ctext::addHighlightClassForSpecialChars by + using foreach with [split $str ""]. + + I added a Destroy button to ctext_test.tcl. + + I removed the -font flags in the test files, + so it will use what's in the X resources, or + the default for Tk. + + I improved ctext::matchQuote:blink by doing + if {$count & 1} rather than if {[expr {$count & 1}]} + I need to remember that if is like expr. + + I fixed a Doh! in ctext::matchQuote. I was + not thinking that the end pos is already known + due to the switch in the instanceCmd. + + ctext::matchPair now works. Try typing a pattern + of ( ) or [ ] or { } or ( ( ) ) and so on. It's really + cool. Big thanks to Mac Cody for inspiring this. I + didn't use any of his code for MatchPair but I looked + at it to get a general idea. + +2.6.1 - Thu Jun 27 10:55:54 MDT 2002 + + I added ctext::disableComments and + ctext::enableComments. C comment highlighting + is disabled by default now. I started merging + the changes by Mac Cody into this release. I + used some of his code for making quotes blink. + I rewrote some of it to fit more with my ideals. + I'll be merging more of his great ideas into + Ctext in the future. + + I fixed a bug with the C comment highlighting. + I found that \\ was causing problems, so the + \\\\ RE addition and \\\\ check solves that. + + I replaced func_finder.tcl with a newer file that + should work better. What I should probably do is + write a minimal C parser for dealing with finding + functions, or do another trick with the C + preprocessor. + + I updated the README and ctext_test_c.tcl + +2.6 - Mon Jun 24 09:39:24 MDT 2002 + + I radically modified ctext::comments to fix bugs + with comments in quotes being highlighted and + to improve speed. It is now much faster and + simpler. I added -linemapfg and -linemapbg options. + + +2.5.2 - Sun May 19 09:36:16 MDT 2002 + + I made major changes to how the C commenting works. + I made a serious mistake with the way that C + comments were highlighted. I was invoking + ctext::comments and there could be several + after idle timers going that call it that were + relying on a global array. Basically my + state variables were getting clobbered. It + took me a while to figure this out. Now I + pass a [clock clicks] argument for each call + and it creates the array if necessary and + passes the clock clicks value in subsequent + calls. The end result is that now several + ctext::comments loops can be running at + once and they don't clobber each other. + +2.5.1 - Fri Mar 15 17:15:30 MST 2002 + + I have added ctext::update which allows you + to update a cursor or progress dialog while + Ctext highlights text. It works quite nicely + in Malephiso. I updated the README to + show the new change, and how to use it. I + also fixed a minor error in the README. + +2.5 - Sat Mar 2 23:59:07 MST 2002 + + I've fixed several critical bugs with deletion + of text. I've improved the clarity of the + code by adding ctext::instanceCmd. This also + makes it so that theoretically you could + overload ctext. The performance of deletion + and insertion may be better due to my use of + a timer for highlighting. + +2.4.1 - Sat Feb 23 23:12:49 MST 2002 + + I fixed a bug with tag removal that occured + when text was appended to an existing tag. + The fix was to use the insert position minus + one char in the call to ctext::findPreviousSpace. + + +2.4 - Tue Feb 5 16:27:46 MST 2002 + + The linemap will now update even if scrolling + hasn't occured. I tried to get this working + in previous releases, but had problems with + display updates. Now I use "after 1" with it, + so it works without blocking the GUI. + + The widget should now completely clean up after + itself I hope. I made changes to the + callback. Please let me know if it doesn't + cleanup for you. + + +2.3.5 - Wed Jan 23 23:55:51 MST 2002 + + I fixed a minor bug that caused some text tags + to be removed when they shouldn't be when deleting + the first character of a line. + + if {[$self._t compare $start < $lineStart]} { + set start $lineStart + } + +2.3.4 - Mon Jan 21 22:05:23 MST 2002 + + I added | and , to the not chars. This helps with C + syntax highlighting. + +2.3.3 - Mon Jan 14 23:06:39 MST 2002 + + I fixed a bug with C comment highlighting that occured when + the state of the comment handler was not reset when it reached + the end of the text widget. I also fixed a minor bug with + tag removal in the delete handler. + +2.3.2 - Thu Jan 10 19:48:20 MST 2002 + + I added " and ' to the not chars in the main highlighting + engine. This makes it so that char start strings like + $blah end at a " or '. So, for example with $blah" every + thing would be highlighted like the variable. Now, it only + highlights the $blah. + +2.3.1 - Fri Jan 4 22:35:19 MST 2002 + + I fixed a minor bug with the C comment handling. I now + have it working very fast for a while, and then it stops + until being restarted when / or * is found/entered in the + insert or delete widget instance commands. There is one + bug I'm trying to track down where the highlighting stops + for apparently no reason. It's probably good enough to + use for production use in Malephiso, but as usual no warranty + to you folks. + +2.3 - Mon Dec 31 15:18:05 MST 2001 + + I have added C comment highlighting. It works properly + but it flashes; which can be annoying. I'm going to work + on this more later on. + +2.2.8 - Mon Dec 31 04:18:57 MST 2001 + + I fixed some bugs with the delete instance command. + + +2.2.7 - Sun Dec 30 18:15:10 MST 2001 + + I made changes to ctext::highlight that have improved + the speed. They should help a lot with very large files. + +2.2.6 - Sun Dec 30 16:28:26 MST 2001 + + I improved the search expressions by adding -- to + deal with - in any of the search strings. Using + ctext in Malephiso has caused me to find so many bugs + that I had no idea about over the past week or so. + +2.2.5 - Sun Dec 30 11:10:38 MST 2001 + + I fixed a bug with findPreviousSpace and findNextSpace + which should improve the speed of tag removal, because + it will no longer remove char tags that it doesn't + have to. + +2.2.4 - Sun Dec 30 10:57:57 MST 2001 + + I fixed a bug with the highlighting that occured when + the whitespace is entered between a highlighted word. + + I also fixed a bug with the linemap that occured when + an empty line was pressed. + +2.2.3 - Mon Dec 24 12:53:49 MST 2001 + + I added ; to the RE for not chars in the ctext::highlight + proc. + +2.2.2 - Sun Dec 23 14:37:26 MST 2001 + + I made a minor change to the highlighting RE, so that + it handles things like [.widget cget -flag] Before this + the -flag part wouldn't have been highlighted. + + I added ctext::clearHighlightClasses which takes only + one argument; $win. + +2.2.1 - Wed Dec 19 10:18:42 MST 2001 + + I fixed a bug that occured with some text widget commands, + for example searching with -count. I had to use uplevel + in the call to the master text widget. + + +2.2 - Wed Dec 19 06:18:08 MST 2001 + + I've fixed some bugs that occured if C functions were being + highlighted. I changed addHighlightClassForSpecialChars + so that it accepts a string of characters to match. + All addHighlightClass commands now must have a window argument. + The window argument makes it so that you can now have multiple + languages highlighted in separate windows. I added + ctext::addHighlightClassForRegexp (see the test files for + examples). + + I'm going to write a script for finding all Tcl and Tk + flags via an automated search through the man pages. This + should hopefully help others with their custom editors + that use ctext. + +2.1.4 + I fixed a few bugs. Widget destruction should now work + properly. + +2.1.3: +Well, the diff between 2.1.2 and 2.1.3 is huge. To summarize I've +replaced the list that stored selected linemap lines with an array, +which has improved the performance. I've added error checking and +done a bunch of cleanup. I've changed the indentation style. + +2.1.2: +LICENSE file added and licensing changed to BSD style. + +2.1.1: +replaced addHighlightClass array setting with a list (quoting hell fix) + +2.1: +added \r to the tests for the Mac +added \r to the default regexp end of line for the Mac +removed global and replaced with upvar #0 +added ctext to the prefix of ToggledList +new ctext_test2.tcl with two ctext widgets +fixed the dos2unix script, so that {lf lf} -translation is used + +2.0.2: +fixed a bug with insert calling highlight improperly when pasting/inserting multiple lines +wrote dos2unix to convert from NT's \r\n to \n so that Unix people aren't annoyed. +update idletasks added to delete and insert instance commands + +2.0.1: +ctext_test.tcl removed extra ctext test window + +2.0-a6: +instance cget -linemap works +added more documentation to Readme.txt + +2.0-a5: +removed hardcoded comment highlighting +removed debug output and console show + +2.0-a4: +> 50% speedup during ctext::highlight due to a simpler regexp +that uses not ([^ chars]+) instead. + +2.0-a3: +fixed bug with cut instance command +added fastdelete and fastinsert instance commands +instance config -linemap and -yscrollcommand work +added highlight instance command +added copy, cut, paste, and append selection instance commands + +2.0-a2: +proc ctext::addHighlightClassForSpecialChars +proc ctext::addHighlightClassWithOnlyCharStart +highlight function works +merged delete from 1.1.1 and fixed a bug +insert bug fix + + ADDED modules/ctext/LICENSE Index: modules/ctext/LICENSE ================================================================== --- /dev/null +++ modules/ctext/LICENSE @@ -0,0 +1,26 @@ +This software is copyrighted by George Peter Staplin. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. ADDED modules/ctext/README Index: modules/ctext/README ================================================================== --- /dev/null +++ modules/ctext/README @@ -0,0 +1,152 @@ + + o Author + + George Peter Staplin + + See also: Thanks (below) + + + o Licensing + + BSD style see the LICENSE file + + + o Installation + + Ctext requires only one file named ctext.tcl. You + can source this file or if you prefer to use + "package require ctext" you can use the install.tcl + script. The install script can be run like so: + wish8.4 install.tcl + + If you are a developer I highly recommend that you + study the Usage section below. If you need an + example then see the test files (especialy + ctext_test_interactive.tcl). + + + o How it Works + + Ctext overloads the text widget and provides + new commands, named highlight, copy, paste, cut, + append, and edit. It also provides several + commands that allow you to define classes. + Each class corresponds to a tag in the widget. + + + o Usage + + Ctext can be used like so: + pack [ctext .t] + .t fastinsert end $data + .t highlight 1.0 end + + The copy, paste, and cut widget commands are frontends + for tk_text*, but they don't require giving an argument + for the text widget window. I have also addded an + append command, which appends the current selection + to the existing clipboard text. + + An edit modified command is available that keeps + track of whether or not data in the widget has been + modified. .t edit modified would return 0 if the + data hasn't been modified. To set the value after + inserting text you can use .t edit modified 0. It + will automatically be set to 1 during + insertion/deletion cut/paste etc. + + During insertion and deletion of text in the widget + the tags and highlighting will be automatically + updated, unless you specify -highlight 0 during + creation or instance configuration of the widget. + + All of the flags that the text widget supports work. + It also supports new flags. These new flags are: + + -linemap creates a line number list on the left of + the widget. + + -linemapfg changes the foreground of the linemap. + The default is the same color as the main text + widget. + + -linemapbg changes the background of the linemap. + The default is the same color as the main text + widget. + + -linemap_select_fg changes the selected + line foreground. The default is black. + + -linemap_select_bg changes the selected line + background. The default is yellow. + + -linemap_mark_command calls a procedure or command + with the path of the ctext window, the type which is + either marked or unmarked, and finally the line + number selected. The proc prototype is: + proc linemark_cmd {win type line}. See also + ctext_test_interactive.tcl + + -highlight takes a boolean value which defines + whether or not to highlight text which is inserted + or deleted. The default is 1. + + -linemap_markable takes a boolean value which + specifies whether or not lines in the linemap + are markable with the mouse. The default is 1. + + Four highlighting procedures are available for adding + keywords. Each proc takes a class, color, keyword, + and window argument. The highlight widget command will + automatically use each class that you add with any of + the three functions. If you want to change the font + of a class or another attribute you can run a + command like this: + .t tag configure $className -font {Helvetica 16} + + Note that the tag is created when you add a class. + + Normal keywords: + ctext::addHighlightClass .t class color [list string1 string2 ...] + + Strings that start with chars like $, for $var: + ctext::addHighlightClassWithOnlyCharStart .t class color "\$" + + A series of characters in a string + ctext:addHighlightClassForSpecialChars .t class color {[]{}} + + Comments, and other things that need regexp: + ctext::addHighlightClassForRegexp .t class color {#\[^\n\]*} + + ctext::clearHighlightClasses clears all of the + highlight classes from the widget specified. + Example: ctext::clearHighlightClasses .t + + To get a list of classes defined for a widget do + something like: ctext::getHighlightClasses .t + + To delete a highlight class do something like: + ctext::deleteHighlightClass .t classNameToDelete + + You can update a cursor while ctext highlights a large file + by overriding ctext::update. Simply source ctext.tcl then + create your ctext::update proc, and it will be called by + ctext. This allows you to have a progress dialog, or animated + cursor. + + If you are using C and want C comments highlighted you can + use ctext::enableComments. You can modify the colors of + C comments by configuring the tag _cComment after enabling with + the afformentioned command. The C comment highlighting is + disabled by default. + + + I have personally tested it with Tcl/Tk 8.4.4 in NetBSD. + It should work with all Tcl platforms. + + Please send comments and bugs to GeorgePS@XMission.com + + o Thanks + + Kevin Kenny, Neil Madden, Jeffrey Hobbs, Richard Suchenwirth, + Johan Bengtsson, Mac Cody, Günther, and Andreas Sievers. ADDED modules/ctext/REGRESSION Index: modules/ctext/REGRESSION ================================================================== --- /dev/null +++ modules/ctext/REGRESSION @@ -0,0 +1,4 @@ + +Due to changes between the 2.7 and 3.1 release you may need to remove escapes in your class patterns. This is due to my former inproper use of quotes, which I have now replaced with lists. The escaping is no longer necessary. + +Some fonts don't display a bitmap properly. The size of the bitmap seems to be the issue. This seems to be a bug with the text widget. ADDED modules/ctext/TODO Index: modules/ctext/TODO ================================================================== --- /dev/null +++ modules/ctext/TODO @@ -0,0 +1,1 @@ +Make the flags that ctext adds have Class and resource names. Also make .t config return those resource/class names. I suspect that I could do this by making each value for a flag a list, but this needs proper planning before I go coding in the unknown. ADDED modules/ctext/ctext.tcl Index: modules/ctext/ctext.tcl ================================================================== --- /dev/null +++ modules/ctext/ctext.tcl @@ -0,0 +1,1000 @@ +# By George Peter Staplin +# See also the README for a list of contributors +# RCS: @(#) $Id: ctext.tcl,v 1.1.1.1 2004/01/23 00:32:16 georgeps Exp $ + +package require Tk +package provide ctext 3.1 + +namespace eval ctext {} + +#win is used as a unique token to create arrays for each ctext instance +proc ctext::getAr {win suffix name} { + set arName __ctext[set win][set suffix] + uplevel [list upvar #0 $arName $name] + return $arName +} + +proc ctext {win args} { + if {[llength $args] & 1} { + return -code error "invalid number of arguments given to ctext (uneven number after window) : $args" + } + + frame $win -class Ctext + + set tmp [text .__ctextTemp] + + ctext::getAr $win config ar + + set ar(-fg) [$tmp cget -foreground] + set ar(-bg) [$tmp cget -background] + set ar(-font) [$tmp cget -font] + set ar(-relief) [$tmp cget -relief] + destroy $tmp + set ar(-yscrollcommand) "" + set ar(-linemap) 1 + set ar(-linemapfg) $ar(-fg) + set ar(-linemapbg) $ar(-bg) + set ar(-linemap_mark_command) {} + set ar(-linemap_markable) 1 + set ar(-linemap_select_fg) black + set ar(-linemap_select_bg) yellow + set ar(-highlight) 1 + set ar(win) $win + set ar(modified) 0 + + set ar(ctextFlags) [list -yscrollcommand -linemap -linemapfg -linemapbg \ +-font -linemap_mark_command -highlight -linemap_markable -linemap_select_fg \ +-linemap_select_bg] + + array set ar $args + + foreach flag {foreground background} short {fg bg} { + if {[info exists ar(-$flag)] == 1} { + set ar(-$short) $ar(-$flag) + unset ar(-$flag) + } + } + + #Now remove flags that will confuse text and those that need modification: + foreach arg $ar(ctextFlags) { + set loc [lsearch $args $arg] + if {$loc >= 0} { + set args [lreplace $args $loc [expr {$loc + 1}]] + } + } + + text $win.l -font $ar(-font) -width 1 -height 1 \ + -relief $ar(-relief) -fg $ar(-linemapfg) -bg $ar(-linemapbg) -takefocus 0 + + set topWin [winfo toplevel $win] + bindtags $win.l [list $win.l $topWin all] + + if {$ar(-linemap) == 1} { + pack $win.l -side left -fill y + } + + set args [concat $args [list -yscrollcommand [list ctext::event:yscroll $win $ar(-yscrollcommand)]]] + + #escape $win, because it could have a space + pack [eval text \$win.t $args -font \$ar(-font)] -side right -fill both -expand 1 + + bind $win.t [list ctext::linemapUpdate $win] + bind $win.l [list ctext::linemapToggleMark $win %y] + bind $win.t [list ctext::linemapUpdate $win] + rename $win __ctextJunk$win + rename $win.t $win._t + + bind $win [list ctext::event:Destroy $win %W] + bindtags $win.t [linsert [bindtags $win.t] 0 $win] + + interp alias {} $win {} ctext::instanceCmd $win + interp alias {} $win.t {} $win + + #If the user wants C comments they should call ctext::enableComments + ctext::disableComments $win + ctext::modified $win 0 + ctext::buildArgParseTable $win + + return $win +} + +proc ctext::event:yscroll {win clientData args} { + ctext::linemapUpdate $win + + if {$clientData == ""} { + return + } + uplevel #0 $clientData $args +} + +proc ctext::event:Destroy {win dWin} { + if {![string equal $win $dWin]} { + return + } + catch {rename $win {}} + interp alias {} $win.t {} + ctext::clearHighlightClasses $win + array unset [ctext::getAr $win config ar] +} + +#This stores the arg table within the config array for each instance. +#It's used by the configure instance command. +proc ctext::buildArgParseTable win { + set argTable [list] + + lappend argTable any -linemap_mark_command { + set configAr(-linemap_mark_command) $value + break + } + + lappend argTable {1 true yes} -linemap { + pack $self.l -side left -fill y + set configAr(-linemap) 1 + break + } + + lappend argTable {0 false no} -linemap { + pack forget $self.l + set configAr(-linemap) 0 + break + } + + lappend argTable any -yscrollcommand { + set cmd [list $self._t config -yscrollcommand [list ctext::event:yscroll $self $value]] + + if {[catch $cmd res]} { + return $res + } + set configAr(-yscrollcommand) $value + break + } + + lappend argTable any -linemapfg { + if {[catch {winfo rgb $self $value} res]} { + return -code error $res + } + $self.l config -fg $value + set configAr(-linemapfg) $value + break + } + + lappend argTable any -linemapbg { + if {[catch {winfo rgb $self $value} res]} { + return -code error $res + } + $self.l config -bg $value + set configAr(-linemapbg) $value + break + } + + lappend argTable any -font { + if {[catch {$self.l config -font $value} res]} { + return -code error $res + } + $self._t config -font $value + set configAr(-font) $value + break + } + + lappend argTable {0 false no} -highlight { + set configAr(-highlight) 0 + break + } + + lappend argTable {1 true yes} -highlight { + set configAr(-highlight) 1 + break + } + + lappend argTable {0 false no} -linemap_markable { + set configAr(-linemap_markable) 0 + break + } + + lappend argTable {1 true yes} -linemap_markable { + set configAr(-linemap_markable) 1 + break + } + + lappend argTable any -linemap_select_fg { + if {[catch {winfo rgb $self $value} res]} { + return -code error $res + } + set configAr(-linemap_select_fg) $value + $self.l tag configure lmark -foreground $value + break + } + + lappend argTable any -linemap_select_bg { + if {[catch {winfo rgb $self $value} res]} { + return -code error $res + } + set configAr(-linemap_select_bg) $value + $self.l tag configure lmark -background $value + break + } + + ctext::getAr $win config ar + set ar(argTable) $argTable +} + +proc ctext::instanceCmd {self cmd args} { + #slightly different than the RE used in ctext::comments + set commentRE {\"|\\|'|/|\*} + + switch -glob -- $cmd { + append { + if {[catch {$self._t get sel.first sel.last} data] == 0} { + clipboard append -displayof $self $data + } + } + + cget { + set arg [lindex $args 0] + ctext::getAr $self config configAr + + foreach flag $configAr(ctextFlags) { + if {[string match ${arg}* $flag]} { + return [set configAr($flag)] + } + } + return [$self._t cget $arg] + } + + conf* { + ctext::getAr $self config configAr + + if {0 == [llength $args]} { + set res [$self._t configure] + set del [lsearch -glob $res -yscrollcommand*] + set res [lreplace $res $del $del] + + foreach flag $configAr(ctextFlags) { + lappend res [list $flag [set configAr($flag)]] + } + return $res + } + + array set flags {} + foreach flag $configAr(ctextFlags) { + set loc [lsearch $args $flag] + if {$loc < 0} { + continue + } + + if {[llength $args] <= ($loc + 1)} { + #.t config -flag + return [set configAr($flag)] + } + + set flagArg [lindex $args [expr {$loc + 1}]] + set args [lreplace $args $loc [expr {$loc + 1}]] + set flags($flag) $flagArg + } + + foreach {valueList flag cmd} $configAr(argTable) { + if {[info exists flags($flag)]} { + foreach valueToCheckFor $valueList { + set value [set flags($flag)] + if {[string equal "any" $valueToCheckFor]} $cmd \ + elseif {[string equal $valueToCheckFor [set flags($flag)]]} $cmd + } + } + } + + if {[llength $args]} { + #we take care of configure without args at the top of this branch + uplevel 1 [linsert $args 0 $self._t configure] + } + } + + copy { + tk_textCopy $self + } + + cut { + if {[catch {$self.t get sel.first sel.last} data] == 0} { + clipboard clear -displayof $self.t + clipboard append -displayof $self.t $data + $self delete [$self.t index sel.first] [$self.t index sel.last] + ctext::modified $self 1 + } + } + + delete { + #delete n.n ?n.n + + #first deal with delete n.n + set argsLength [llength $args] + + if {$argsLength == 1} { + set deletePos [lindex $args 0] + set prevChar [$self._t get $deletePos] + + $self._t delete $deletePos + set char [$self._t get $deletePos] + + set prevSpace [ctext::findPreviousSpace $self._t $deletePos] + set nextSpace [ctext::findNextSpace $self._t $deletePos] + + set lineStart [$self._t index "$deletePos linestart"] + set lineEnd [$self._t index "$deletePos + 1 chars lineend"] + + if {[string equal $prevChar "#"] || [string equal $char "#"]} { + set removeStart $lineStart + set removeEnd $lineEnd + } else { + set removeStart $prevSpace + set removeEnd $nextSpace + } + + foreach tag [$self._t tag names] { + if {[string equal $tag "_cComment"] != 1} { + $self._t tag remove $tag $removeStart $removeEnd + } + } + + set checkStr "$prevChar[set char]" + + if {[regexp $commentRE $checkStr]} { + after idle [list ctext::comments $self] + } + ctext::highlight $self $lineStart $lineEnd + ctext::linemapUpdate $self + } elseif {$argsLength == 2} { + #now deal with delete n.n ?n.n? + set deleteStartPos [lindex $args 0] + set deleteEndPos [lindex $args 1] + + set data [$self._t get $deleteStartPos $deleteEndPos] + + set lineStart [$self._t index "$deleteStartPos linestart"] + set lineEnd [$self._t index "$deleteEndPos + 1 chars lineend"] + eval \$self._t delete $args + + foreach tag [$self._t tag names] { + if {[string equal $tag "_cComment"] != 1} { + $self._t tag remove $tag $lineStart $lineEnd + } + } + + if {[regexp $commentRE $data]} { + after idle [list ctext::comments $self] + } + + ctext::highlight $self $lineStart $lineEnd + if {[string first "\n" $data] >= 0} { + ctext::linemapUpdate $self + } + } else { + return -code error "invalid argument(s) sent to $self delete: $args" + } + ctext::modified $self 1 + } + + fastdelete { + eval \$self._t delete $args + ctext::modified $self 1 + ctext::linemapUpdate $self + } + + fastinsert { + eval \$self._t insert $args + ctext::modified $self 1 + ctext::linemapUpdate $self + } + + highlight { + ctext::highlight $self [lindex $args 0] [lindex $args 1] + ctext::comments $self + } + + insert { + if {[llength $args] < 2} { + return -code error "please use at least 2 arguments to $self insert" + } + set insertPos [lindex $args 0] + set prevChar [$self._t get "$insertPos - 1 chars"] + set nextChar [$self._t get $insertPos] + set lineStart [$self._t index "$insertPos linestart"] + set prevSpace [ctext::findPreviousSpace $self._t ${insertPos}-1c] + set data [lindex $args 1] + eval \$self._t insert $args + + set nextSpace [ctext::findNextSpace $self._t insert] + set lineEnd [$self._t index "insert lineend"] + + if {[$self._t compare $prevSpace < $lineStart]} { + set prevSpace $lineStart + } + + if {[$self._t compare $nextSpace > $lineEnd]} { + set nextSpace $lineEnd + } + + foreach tag [$self._t tag names] { + if {[string equal $tag "_cComment"] != 1} { + $self._t tag remove $tag $prevSpace $nextSpace + } + } + + set REData $prevChar + append REData $data + append REData $nextChar + if {[regexp $commentRE $REData]} { + after idle [list ctext::comments $self] + } + + after idle [list ctext::highlight $self $lineStart $lineEnd] + switch -- $data { + "\}" { + ctext::matchPair $self "\\\{" "\\\}" "\\" + } + "\]" { + ctext::matchPair $self "\\\[" "\\\]" "\\" + } + "\)" { + ctext::matchPair $self "\\(" "\\)" "" + } + "\"" { + ctext::matchQuote $self + } + } + ctext::modified $self 1 + ctext::linemapUpdate $self + } + + paste { + tk_textPaste $self + ctext::modified $self 1 + } + + edit { + set subCmd [lindex $args 0] + set argsLength [llength $args] + + ctext::getAr $self config ar + + if {"modified" == $subCmd} { + if {$argsLength == 1} { + return $ar(modified) + } elseif {$argsLength == 2} { + set value [lindex $args 1] + set ar(modified) $value + } else { + return -code error "invalid arg(s) to $self edit modified: $args" + } + } else { + #Tk 8.4 has other edit subcommands that I don't want to emulate. + return [uplevel 1 [linsert $args 0 $self._t $cmd]] + } + } + + default { + return [uplevel 1 [linsert $args 0 $self._t $cmd]] + } + } +} + +proc ctext::tag:blink {win count} { + if {$count & 1} { + $win tag configure __ctext_blink -foreground [$win cget -bg] -background [$win cget -fg] + } else { + $win tag configure __ctext_blink -foreground [$win cget -fg] -background [$win cget -bg] + } + + if {$count == 4} { + $win tag delete __ctext_blink 1.0 end + return + } + incr count + after 50 [list ctext::tag:blink $win $count] +} + +proc ctext::matchPair {win str1 str2 escape} { + set prevChar [$win get "insert - 2 chars"] + + if {[string equal $prevChar $escape]} { + #The char that we thought might be the end is actually escaped. + return + } + + set searchRE "[set str1]|[set str2]" + set count 1 + + set pos [$win index "insert - 1 chars"] + set endPair $pos + set lastFound "" + while 1 { + set found [$win search -backwards -regexp $searchRE $pos] + + if {$found == "" || [$win compare $found > $pos]} { + return + } + + if {$lastFound != "" && [$win compare $found == $lastFound]} { + #The search wrapped and found the previous search + return + } + + set lastFound $found + set char [$win get $found] + set prevChar [$win get "$found - 1 chars"] + set pos $found + + if {[string equal $prevChar $escape]} { + continue + } elseif {[string equal $char [subst $str2]]} { + incr count + } elseif {[string equal $char [subst $str1]]} { + incr count -1 + if {$count == 0} { + set startPair $found + break + } + } else { + #This shouldn't happen. I may in the future make it return -code error + puts stderr "ctext seems to have encountered a bug in ctext::matchPair" + return + } + } + + $win tag add __ctext_blink $startPair + $win tag add __ctext_blink $endPair + ctext::tag:blink $win 0 +} + +proc ctext::matchQuote {win} { + set endQuote [$win index insert] + set start [$win index "insert - 1 chars"] + + if {[$win get "$start - 1 chars"] == "\\"} { + #the quote really isn't the end + return + } + set lastFound "" + while 1 { + set startQuote [$win search -backwards \" $start] + if {$startQuote == "" || [$win compare $startQuote > $start]} { + #The search found nothing or it wrapped. + return + } + + if {$lastFound != "" && [$win compare $lastFound == $startQuote]} { + #We found the character we found before, so it wrapped. + return + } + set lastFound $startQuote + set start [$win index "$startQuote - 1 chars"] + set prevChar [$win get $start] + + if {$prevChar == "\\"} { + continue + } + break + } + + if {[$win compare $endQuote == $startQuote]} { + #probably just \" + return + } + + $win tag add __ctext_blink $startQuote $endQuote + ctext::tag:blink $win 0 +} + +proc ctext::enableComments {win} { + $win tag configure _cComment -foreground khaki +} +proc ctext::disableComments {win} { + catch {$win tag delete _cComment} +} + +proc ctext::comments {win} { + if {[catch {$win tag cget _cComment -foreground}]} { + #C comments are disabled + return + } + + set startIndex 1.0 + set commentRE {\\\\|\"|\\\"|\\'|'|/\*|\*/} + set commentStart 0 + set isQuote 0 + set isSingleQuote 0 + set isComment 0 + $win tag remove _cComment 1.0 end + while 1 { + set index [$win search -count length -regexp $commentRE $startIndex end] + + if {$index == ""} { + break + } + + set endIndex [$win index "$index + $length chars"] + set str [$win get $index $endIndex] + set startIndex $endIndex + + if {$str == "\\\\"} { + continue + } elseif {$str == "\\\""} { + continue + } elseif {$str == "\\'"} { + continue + } elseif {$str == "\"" && $isComment == 0 && $isSingleQuote == 0} { + if {$isQuote} { + set isQuote 0 + } else { + set isQuote 1 + } + } elseif {$str == "'" && $isComment == 0 && $isQuote == 0} { + if {$isSingleQuote} { + set isSingleQuote 0 + } else { + set isSingleQuote 1 + } + } elseif {$str == "/*" && $isQuote == 0 && $isSingleQuote == 0} { + if {$isComment} { + #comment in comment + break + } else { + set isComment 1 + set commentStart $index + } + } elseif {$str == "*/" && $isQuote == 0 && $isSingleQuote == 0} { + if {$isComment} { + set isComment 0 + $win tag add _cComment $commentStart $endIndex + $win tag raise _cComment + } else { + #comment end without beginning + break + } + } + } +} + +proc ctext::addHighlightClass {win class color keywords} { + set ref [ctext::getAr $win highlight ar] + foreach word $keywords { + set ar($word) [list $class $color] + } + $win tag configure $class + + ctext::getAr $win classes classesAr + set classesAr($class) [list $ref $keywords] +} + +#For [ ] { } # etc. +proc ctext::addHighlightClassForSpecialChars {win class color chars} { + set charList [split $chars ""] + + set ref [ctext::getAr $win highlightSpecialChars ar] + foreach char $charList { + set ar($char) [list $class $color] + } + $win tag configure $class + + ctext::getAr $win classes classesAr + set classesAr($class) [list $ref $charList] +} + +proc ctext::addHighlightClassForRegexp {win class color re} { + set ref [ctext::getAr $win highlightRegexp ar] + + set ar($class) [list $re $color] + $win tag configure $class + + ctext::getAr $win classes classesAr + set classesAr($class) [list $ref $class] +} + +#For things like $blah +proc ctext::addHighlightClassWithOnlyCharStart {win class color char} { + set ref [ctext::getAr $win highlightCharStart ar] + + set ar($char) [list $class $color] + $win tag configure $class + + ctext::getAr $win classes classesAr + set classesAr($class) [list $ref $char] +} + +proc ctext::deleteHighlightClass {win classToDelete} { + ctext::getAr $win classes classesAr + + if {![info exists classesAr($classToDelete)]} { + return -code error "$classToDelete doesn't exist" + } + + foreach {ref keyList} [set classesAr($classToDelete)] { + upvar #0 $ref refAr + foreach key $keyList { + if {![info exists refAr($key)]} { + continue + } + unset refAr($key) + } + } + unset classesAr($classToDelete) +} + +proc ctext::getHighlightClasses win { + ctext::getAr $win classes classesAr + + set res [list] + + foreach {class info} [array get classesAr] { + lappend res $class + } + return $res +} + +proc ctext::findNextChar {win index char} { + set i [$win index "$index + 1 chars"] + set lineend [$win index "$i lineend"] + while 1 { + set ch [$win get $i] + if {[$win compare $i >= $lineend]} { + return "" + } + if {$ch == $char} { + return $i + } + set i [$win index "$i + 1 chars"] + } +} + +proc ctext::findNextSpace {win index} { + set i [$win index $index] + set lineStart [$win index "$i linestart"] + set lineEnd [$win index "$i lineend"] + #Sometimes the lineend fails (I don't know why), so add 1 and try again. + if {[$win compare $lineEnd == $lineStart]} { + set lineEnd [$win index "$i + 1 chars lineend"] + } + + while {1} { + set ch [$win get $i] + + if {[$win compare $i >= $lineEnd]} { + set i $lineEnd + break + } + + if {[string is space $ch]} { + break + } + set i [$win index "$i + 1 chars"] + } + return $i +} + +proc ctext::findPreviousSpace {win index} { + set i [$win index $index] + set lineStart [$win index "$i linestart"] + while {1} { + set ch [$win get $i] + + if {[$win compare $i <= $lineStart]} { + set i $lineStart + break + } + + if {[string is space $ch]} { + break + } + + set i [$win index "$i - 1 chars"] + } + return $i +} + +proc ctext::clearHighlightClasses {win} { + #no need to catch, because array unset doesn't complain + #puts [array exists ::ctext::highlight$win] + + ctext::getAr $win highlight ar + array unset ar + + ctext::getAr $win highlightSpecialChars ar + array unset ar + + ctext::getAr $win highlightRegexp ar + array unset ar + + ctext::getAr $win highlightCharStart ar + array unset ar + + ctext::getAr $win classes ar + array unset ar +} + +#This is a proc designed to be overwritten by the user. +#It can be used to update a cursor or animation while +#the text is being highlighted. +proc ctext::update {} { + +} + +proc ctext::highlight {win start end} { + ctext::getAr $win config configAr + + if {!$configAr(-highlight)} { + return + } + + set si $start + set twin "$win._t" + + #The number of times the loop has run. + set numTimesLooped 0 + set numUntilUpdate 600 + + ctext::getAr $win highlight highlightAr + ctext::getAr $win highlightSpecialChars highlightSpecialCharsAr + ctext::getAr $win highlightRegexp highlightRegexpAr + ctext::getAr $win highlightCharStart highlightCharStartAr + + while 1 { + set res [$twin search -count length -regexp -- {([^\s\(\{\[\}\]\)\.\t\n\r;\"'\|,]+)} $si $end] + if {$res == ""} { + break + } + + set wordEnd [$twin index "$res + $length chars"] + set word [$twin get $res $wordEnd] + set firstOfWord [string index $word 0] + + if {[info exists highlightAr($word)] == 1} { + set wordAttributes [set highlightAr($word)] + foreach {tagClass color} $wordAttributes break + + $twin tag add $tagClass $res $wordEnd + $twin tag configure $tagClass -foreground $color + + } elseif {[info exists highlightCharStartAr($firstOfWord)] == 1} { + set wordAttributes [set highlightCharStartAr($firstOfWord)] + foreach {tagClass color} $wordAttributes break + + $twin tag add $tagClass $res $wordEnd + $twin tag configure $tagClass -foreground $color + } + set si $wordEnd + + incr numTimesLooped + if {$numTimesLooped >= $numUntilUpdate} { + ctext::update + set numTimesLooped 0 + } + } + + foreach {ichar tagInfo} [array get highlightSpecialCharsAr] { + set si $start + foreach {tagClass color} $tagInfo break + + while 1 { + set res [$twin search -- $ichar $si $end] + if {"" == $res} { + break + } + set wordEnd [$twin index "$res + 1 chars"] + + $twin tag add $tagClass $res $wordEnd + $twin tag configure $tagClass -foreground $color + set si $wordEnd + + incr numTimesLooped + if {$numTimesLooped >= $numUntilUpdate} { + ctext::update + set numTimesLooped 0 + } + } + } + + foreach {tagClass tagInfo} [array get highlightRegexpAr] { + set si $start + foreach {re color} $tagInfo break + while 1 { + set res [$twin search -count length -regexp -- $re $si $end] + if {"" == $res} { + break + } + + set wordEnd [$twin index "$res + $length chars"] + $twin tag add $tagClass $res $wordEnd + $twin tag configure $tagClass -foreground $color + set si $wordEnd + + incr numTimesLooped + if {$numTimesLooped >= $numUntilUpdate} { + ctext::update + set numTimesLooped 0 + } + } + } +} + +proc ctext::linemapToggleMark {win y} { + ctext::getAr $win config configAr + + if {!$configAr(-linemap_markable)} { + return + } + + set markChar [$win.l index @0,$y] + set lineSelected [lindex [split $markChar .] 0] + set line [$win.l get $lineSelected.0 $lineSelected.end] + + if {$line == ""} { + return + } + + ctext::getAr $win linemap linemapAr + + if {[info exists linemapAr($line)] == 1} { + #It's already marked, so unmark it. + array unset linemapAr $line + ctext::linemapUpdate $win + set type unmarked + } else { + #This means that the line isn't toggled, so toggle it. + array set linemapAr [list $line {}] + $win.l tag add lmark $markChar [$win.l index "$markChar lineend"] + $win.l tag configure lmark -foreground $configAr(-linemap_select_fg) \ +-background $configAr(-linemap_select_bg) + set type marked + } + + if {[string length $configAr(-linemap_mark_command)]} { + uplevel #0 [linsert $configAr(-linemap_mark_command) end $win $type $line] + } +} + +#args is here because -yscrollcommand may call it +proc ctext::linemapUpdate {win args} { + if {[winfo exists $win.l] != 1} { + return + } + + set pixel 0 + set lastLine {} + set lineList [list] + set fontMetrics [font metrics [$win._t cget -font]] + set incrBy [expr {1 + ([lindex $fontMetrics 5] / 2)}] + + while {$pixel < [winfo height $win.l]} { + set idx [$win._t index @0,$pixel] + + if {$idx != $lastLine} { + set line [lindex [split $idx .] 0] + set lastLine $idx + $win.l config -width [string length $line] + lappend lineList $line + } + incr pixel $incrBy + } + + ctext::getAr $win linemap linemapAr + + $win.l delete 1.0 end + set lastLine {} + foreach line $lineList { + if {$line == $lastLine} { + $win.l insert end "\n" + } else { + if {[info exists linemapAr($line)]} { + $win.l insert end "$line\n" lmark + } else { + $win.l insert end "$line\n" + } + } + set lastLine $line + } +} + +proc ctext::modified {win value} { + ctext::getAr $win config ar + set ar(modified) $value + event generate $win <> + return $value +} ADDED modules/ctext/ctext_scroll_test.tcl Index: modules/ctext/ctext_scroll_test.tcl ================================================================== --- /dev/null +++ modules/ctext/ctext_scroll_test.tcl @@ -0,0 +1,11 @@ + +source ./ctext.tcl + +scrollbar .y -orient vertical -command {.t yview} +ctext .t -xscrollcommand {.x set} -yscrollcommand {.y set} -wrap none +scrollbar .x -orient horizontal -command {.t xview} + + +grid .y -sticky ns +grid .t -row 0 -column 1 +grid .x -column 1 -sticky we ADDED modules/ctext/ctext_test.tcl Index: modules/ctext/ctext_test.tcl ================================================================== --- /dev/null +++ modules/ctext/ctext_test.tcl @@ -0,0 +1,82 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" ${1+"$@"} + +#set tcl_traceExec 1 + +proc main {} { + source ./ctext.tcl + + pack [frame .f] -fill both -expand 1 + #Of course this could be cscrollbar instead, but it's not as common. + pack [scrollbar .f.s -command {.f.t yview}] -side right -fill y + + #Dark colors + pack [ctext .f.t -linemap 1 -bg black -fg white -insertbackground yellow \ + -yscrollcommand {.f.s set}] -fill both -expand 1 + + ctext::addHighlightClass .f.t widgets purple [list obutton button label text frame toplevel \ + cscrollbar scrollbar checkbutton canvas listbox menu menubar menubutton \ + radiobutton scale entry message tk_chooseDir tk_getSaveFile \ + tk_getOpenFile tk_chooseColor tk_optionMenu] + + ctext::addHighlightClass .f.t flags orange [list -text -command -yscrollcommand \ + -xscrollcommand -background -foreground -fg -bg \ + -highlightbackground -y -x -highlightcolor -relief -width \ + -height -wrap -font -fill -side -outline -style -insertwidth \ + -textvariable -activebackground -activeforeground -insertbackground \ + -anchor -orient -troughcolor -nonewline -expand -type -message \ + -title -offset -in -after -yscroll -xscroll -forward -regexp -count \ + -exact -padx -ipadx -filetypes -all -from -to -label -value -variable \ + -regexp -backwards -forwards -bd -pady -ipady -state -row -column \ + -cursor -highlightcolors -linemap -menu -tearoff -displayof -cursor \ + -underline -tags -tag] + + ctext::addHighlightClass .f.t stackControl red {proc uplevel namespace while for foreach if else} + ctext::addHighlightClassWithOnlyCharStart .f.t vars mediumspringgreen "\$" + ctext::addHighlightClass .f.t htmlText yellow " " + ctext::addHighlightClass .f.t variable_funcs gold {set global variable unset} + ctext::addHighlightClassForSpecialChars .f.t brackets green {[]{}} + ctext::addHighlightClassForRegexp .f.t paths lightblue {\.[a-zA-Z0-9\_\-]+} + ctext::addHighlightClassForRegexp .f.t comments khaki {#[^\n\r]*} + #After overloading, insertion is a little slower with the + #regular insert, so use fastinsert. + #set fi [open Ctext_Bug_Crasher.tcl r] + set fi [open long_test_script r] + .f.t fastinsert end [read $fi] + close $fi + + pack [frame .f1] -fill x + + pack [button .f1.append -text Append -command {.f.t append}] -side left + pack [button .f1.cut -text Cut -command {.f.t cut}] -side left + pack [button .f1.copy -text Copy -command {.f.t copy}] -side left + pack [button .f1.paste -text Paste -command {.f.t paste}] -side left + .f.t highlight 1.0 end + pack [button .f1.test -text {Remove all Tags and Highlight} \ + -command {puts [time { + foreach tag [.f.t tag names] { + .f.t tag remove $tag 1.0 end + } + update idletasks + .f.t highlight 1.0 end + }] + } + ] -side left + pack [button .f1.fastdel -text {Fast Delete} -command {.f.t fastdelete 1.0 end}] -side left + + pack [frame .f2] -fill x + pack [button .f2.test2 -text {Scrollbar Command {}} -command {.f.t config -yscrollcommand {}}] -side left + pack [button .f2.cl -text {Clear Classes} -command {ctext::clearHighlightClasses .f.t}] -side left + pack [button .f2.des -text Destroy -command {destroy .f.t}] -side left + pack [button .f2.editModSet0 -text "Set Modified 0" -command {puts [.f.t edit modified 0]}] -side left + pack [button .f2.editModGet -text "Print Modified" -command {puts [.f.t edit modified]}] -side left + + pack [button .f2.exit -text Exit -command exit] -side left + + puts [.f.t cget -linemap] + puts [.f.t cget -linemapfg] + puts [.f.t cget -linemapbg] + puts [.f.t cget -bg] +} +main ADDED modules/ctext/ctext_test_c.tcl Index: modules/ctext/ctext_test_c.tcl ================================================================== --- /dev/null +++ modules/ctext/ctext_test_c.tcl @@ -0,0 +1,70 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" ${1+"$@"} + +#use :: so I don't forget it's global +#set ::tcl_traceExec 1 + +proc highlight:addClasses {win} { + ctext::addHighlightClassForSpecialChars $win brackets green {[]} + ctext::addHighlightClassForSpecialChars $win braces lawngreen {{}} + ctext::addHighlightClassForSpecialChars $win parentheses palegreen {()} + ctext::addHighlightClassForSpecialChars $win quotes "#c65e3c" {"'} + + ctext::addHighlightClass $win control red [list namespace while for if else do switch case] + + ctext::addHighlightClass $win types purple [list \ + int char u_char u_int long double float typedef unsigned signed] + + ctext::addHighlightClass $win macros mediumslateblue [list \ + #define #undef #if #ifdef #ifndef #endif #elseif #include #import #exclude] + + ctext::addHighlightClassForSpecialChars $win math cyan {+=*-/&^%!|<>} +} + +proc main {} { + source ./ctext.tcl + + pack [frame .f] -fill both -expand 1 + #Of course this could be cscrollbar instead, but it's not as common. + pack [scrollbar .f.s -command ".f.t yview"] -side right -fill y + + #Dark colors + pack [ctext .f.t -linemap 1 \ + -bg black -fg white -insertbackground yellow \ + -yscrollcommand ".f.s set"] -fill both -expand 1 + + highlight:addClasses .f.t + ctext::enableComments .f.t + + set fi [open test.c r] + .f.t fastinsert end [read $fi] + close $fi + + pack [button .append -text Append -command {.f.t append}] -side left + pack [button .cut -text Cut -command {.f.t cut}] -side left + pack [button .copy -text Copy -command {.f.t copy}] -side left + pack [button .paste -text Paste -command {.f.t paste}] -side left + .f.t highlight 1.0 end + pack [button .test -text {Remove all Tags and Highlight} \ + -command {puts [time { + foreach tag [.f.t tag names] { + .f.t tag remove $tag 1.0 end + } + update idletasks + .f.t highlight 1.0 end + }] + } + ] -side left + pack [button .test2 -text {Scrollbar Command {}} -command {.f.t config -yscrollcommand {}}] -side left + pack [button .cl -text {Clear Classes} \ + -command {ctext::clearHighlightClasses .f.t}] -side left + pack [button .exit -text Exit -command exit] -side left + #pack [ctext .ct2 -linemap 1] -side bottom + + #update + #console show + #puts [.f.t cget -linemap] + #puts [.f.t cget -bg] +} +main ADDED modules/ctext/ctext_test_interactive.tcl Index: modules/ctext/ctext_test_interactive.tcl ================================================================== --- /dev/null +++ modules/ctext/ctext_test_interactive.tcl @@ -0,0 +1,89 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" ${1+"$@"} + +#set tcl_traceExec 1 +proc linemap_mark_cmd {win type line} { + puts "line $line was $type in $win" +} + +proc main {} { + source ./ctext.tcl + + pack [frame .f] -fill both -expand 1 + #Of course this could be cscrollbar instead, but it's not as common. + pack [scrollbar .f.s -command {.f.t yview}] -side right -fill y + + #Dark colors + pack [ctext .f.t -bg black -fg white -insertbackground yellow \ + -yscrollcommand {.f.s set} -linemap_mark_command linemap_mark_cmd] -fill both -expand 1 + + ctext::addHighlightClass .f.t widgets purple [list obutton button label text frame toplevel \ + cscrollbar scrollbar checkbutton canvas listbox menu menubar menubutton \ + radiobutton scale entry message tk_chooseDir tk_getSaveFile \ + tk_getOpenFile tk_chooseColor tk_optionMenu] + + ctext::addHighlightClass .f.t flags orange [list -text -command -yscrollcommand \ + -xscrollcommand -background -foreground -fg -bg \ + -highlightbackground -y -x -highlightcolor -relief -width \ + -height -wrap -font -fill -side -outline -style -insertwidth \ + -textvariable -activebackground -activeforeground -insertbackground \ + -anchor -orient -troughcolor -nonewline -expand -type -message \ + -title -offset -in -after -yscroll -xscroll -forward -regexp -count \ + -exact -padx -ipadx -filetypes -all -from -to -label -value -variable \ + -regexp -backwards -forwards -bd -pady -ipady -state -row -column \ + -cursor -highlightcolors -linemap -menu -tearoff -displayof -cursor \ + -underline -tags -tag] + + ctext::addHighlightClass .f.t stackControl red {proc uplevel namespace while for foreach if else} + ctext::addHighlightClassWithOnlyCharStart .f.t vars mediumspringgreen "\$" + ctext::addHighlightClass .f.t htmlText yellow " " + ctext::addHighlightClass .f.t variable_funcs gold {set global variable unset} + ctext::addHighlightClassForSpecialChars .f.t brackets green {[]{}} + ctext::addHighlightClassForRegexp .f.t paths lightblue {\.[a-zA-Z0-9\_\-]+} + ctext::addHighlightClassForRegexp .f.t comments khaki {#[^\n\r]*} + #After overloading, insertion is a little slower with the + #regular insert, so use fastinsert. + #set fi [open Ctext_Bug_Crasher.tcl r] + set fi [open long_test_script r] + .f.t fastinsert end [read $fi] + close $fi + + pack [frame .f1] -fill x + + pack [button .f1.append -text Append -command {.f.t append}] -side left + pack [button .f1.cut -text Cut -command {.f.t cut}] -side left + pack [button .f1.copy -text Copy -command {.f.t copy}] -side left + pack [button .f1.paste -text Paste -command {.f.t paste}] -side left + .f.t highlight 1.0 end + pack [button .f1.test -text {Remove all Tags and Highlight} \ + -command {puts [time { + foreach tag [.f.t tag names] { + .f.t tag remove $tag 1.0 end + } + update idletasks + .f.t highlight 1.0 end + }] + } + ] -side left + pack [button .f1.fastdel -text {Fast Delete} -command {.f.t fastdelete 1.0 end}] -side left + + pack [frame .f2] -fill x + pack [button .f2.test2 -text {Scrollbar Command {}} -command {.f.t config -yscrollcommand {}}] -side left + pack [button .f2.cl -text {Clear Classes} -command {ctext::clearHighlightClasses .f.t}] -side left + pack [button .f2.des -text Destroy -command {destroy .f.t}] -side left + pack [button .f2.editModSet0 -text "Set Modified 0" -command {puts [.f.t edit modified 0]}] -side left + pack [button .f2.editModGet -text "Print Modified" -command {puts [.f.t edit modified]}] -side left + + pack [button .f2.exit -text Exit -command exit] -side left + + pack [entry .e] -side bottom -fill x + .e insert end "ctext::deleteHighlightClass .f.t " + bind .e {puts [eval [.e get]]} + + puts [.f.t cget -linemap] + puts [.f.t cget -linemapfg] + puts [.f.t cget -linemapbg] + puts [.f.t cget -bg] +} +main ADDED modules/ctext/ctext_test_ws.tcl Index: modules/ctext/ctext_test_ws.tcl ================================================================== --- /dev/null +++ modules/ctext/ctext_test_ws.tcl @@ -0,0 +1,9 @@ + +source ./ctext.tcl +pack [ctext {.t blah}] + +ctext::addHighlightClass {.t blah} c blue [list bat ball boot cat hat] +ctext::addHighlightClass {.t blah} c2 red [list bozo bull bongo] +{.t blah} highlight 1.0 end + + ADDED modules/ctext/function_finder.tcl Index: modules/ctext/function_finder.tcl ================================================================== --- /dev/null +++ modules/ctext/function_finder.tcl @@ -0,0 +1,45 @@ +#!/bin/tclsh8.3 + +proc main {argc argv} { + + array set functions "" + + foreach f $argv { + puts stderr "PROCESSING FILE $f" + + catch {exec cc -DNeedFunctionPrototypes -E $f} data + #set functionList [regexp -all -inline {[a-zA-Z0-9_-]+[ \t\n\r]+([a-zA-Z0-9_-]+)[ \t\n\r]+\([ \t\n\r]*([^\)]+)[ \t\n\r]*\)[ \t\n\r]*;} $data] + set functionList [regexp -all -inline {[a-zA-Z0-9_\-\*]+[ \t\n\r\*]+([a-zA-Z0-9_\-\*]+)[ \t\n\r]*\(([^\)]*)\)[ \t\n\r]*;} $data] + set functionList [concat $functionList \ + [regexp -all -inline {[a-zA-Z0-9_\-\*]+[ \t\n\r\*]+([a-zA-Z0-9_\-\*]+)[ \t\n\r]*_ANSI_ARGS_\(\(([^\)]*)\)\)[ \t\n\r]*;} $data]] + #puts "FL $functionList" + foreach {junk function args} $functionList { + #puts "FUNC $function ARGS $args" + set args [string map {"\n" "" "\r" "" "\t" " " "," ", "} $args] + regsub -all {\s{2,}} $args " " args + set functions($function) $args + } + } + + puts "array set ::functions \{" + foreach function [lsort -dictionary [array names functions]] { + if {"_" == [string index $function 0] || "_" == [string index $function end]} { + continue + } + puts "\t$function [list [set functions($function)]]" + } + puts "\}" +} + +proc sglob {pattern} { + return [glob -nocomplain $pattern] +} + +#main $argc /usr/local/include/tclDecls.h +#return + +main $argc [concat [sglob /usr/include/*.h] [sglob /usr/include/*/*.h] \ +[sglob /usr/local/include/*.h] [sglob /usr/local/include/*/*.h] \ +[sglob /usr/X11R6/include/*.h] [sglob /usr/X11R6/include/*/*.h] \ +[sglob /usr/X11R6/include/*/*/*.h] [sglob /usr/local/include/X11/*.h] \ +[sglob /usr/local/include/X11/*/*.h]] ADDED modules/ctext/install.tcl Index: modules/ctext/install.tcl ================================================================== --- /dev/null +++ modules/ctext/install.tcl @@ -0,0 +1,57 @@ +#Run this with the wish (Tk shell) that you want to install for. +#For example: $ wish8.4 install.tcl + +proc event.select.install.path win { + set i [$win curselection] + set ::installPath [$win get $i] +} + +proc install {} { + set idir [file join $::installPath ctext] + file mkdir $idir + file copy -force pkgIndex.tcl $idir + file copy -force ctext.tcl $idir + tk_messageBox -icon info -message "Successfully installed into $idir" \ +-title {Install Successful} -type ok + + exit +} + +proc main {} { + option add *foreground black + option add *background gray65 + . config -bg gray65 + + wm title . {Ctext Installer} + label .title -text {Welcome to the Ctext installer} -font {Helvetica 14} + + message .msgauto -aspect 300 -text {The auto_path directories are automatically searched by Tcl/Tk for packages. You may select a directory to install Ctext into, or type in a new directory. Your auto_path directories are:} + + set autoLen [llength $::auto_path] + listbox .listauto -height $autoLen + + for {set i 0} {$i < $autoLen} {incr i} { + .listauto insert end [lindex $::auto_path $i] + } + + bind .listauto <> [list event.select.install.path %W] + + label .lipath -text {Install Path:} + set ::installPath [lindex $::auto_path end] + entry .installPath -textvariable ::installPath + + frame .fcontrol + frame .fcontrol.finst -relief sunken -bd 1 + pack [button .fcontrol.finst.install -text Install -command install] -padx 4 -pady 4 + button .fcontrol.cancel -text Cancel -command exit + pack .fcontrol.finst -side left -padx 5 + pack .fcontrol.cancel -side right -padx 5 + + pack .title -fill x + pack .msgauto -anchor w + pack .listauto -fill both -expand 1 + pack .lipath -anchor w + pack .installPath -fill x + pack .fcontrol -pady 10 +} +main ADDED modules/ctext/long_test_script Index: modules/ctext/long_test_script ================================================================== --- /dev/null +++ modules/ctext/long_test_script @@ -0,0 +1,672 @@ +#By George Peter Staplin + +namespace eval cscrollbar { + variable buttonPressed 0 + variable lastX 0 + variable lastY 0 + +variable up_xbm { +#define up_width 18 +#define up_height 12 +static unsigned char up_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x03, 0x00, 0x80, 0x07, 0x00, + 0xc0, 0x0f, 0x00, 0xe0, 0x1f, 0x00, 0xf0, 0x3f, 0x00, 0xf8, 0x7f, 0x00, + 0xfc, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; +} + +variable down_xbm { +#define down_width 18 +#define down_height 12 +static char down_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0xff, 0x00, + 0xf8, 0x7f, 0x00, 0xf0, 0x3f, 0x00, 0xe0, 0x1f, 0x00, 0xc0, 0x0f, 0x00, + 0x80, 0x07, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 }; +} + +variable left_xbm { +#define left_width 12 +#define left_height 18 +static char left_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x80, 0x01, 0xc0, 0x01, 0xe0, 0x01, + 0xf0, 0x01, 0xf8, 0x01, 0xfc, 0x01, 0xfc, 0x01, 0xf8, 0x01, 0xf0, 0x01, + 0xe0, 0x01, 0xc0, 0x01, 0x80, 0x01, 0x00, 0x01, 0x00, 0x00, 0x00, 0x00 }; +} + +variable right_xbm { +#define right_width 12 +#define right_height 18 +static char right_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, + 0xf8, 0x00, 0xf8, 0x01, 0xf8, 0x03, 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, + 0x78, 0x00, 0x38, 0x00, 0x18, 0x00, 0x08, 0x00, 0x00, 0x00, 0x00, 0x00 }; +} +} + +#This creates the scrollbar and an instance command for it. +#cmdArgs represents the initial arguments. cmdArgs becomes smaller +#gradually as options/flags are processed, and if it contains +#anything else afterward an error is reported. + +proc cscrollbar {win args} { + + if {[expr {[llength $args] & 1}] != 0} { + return -code error "Invalid number of arguments given to cscrollbar\ +(uneven number): $args" + } + + frame $win -class Cscrollbar + upvar #0 _cscrollbar$win ar + button .__temp + set cmdArgs(-orient) vertical + + set cmdArgs(-bg) [option get $win background Color1] + if {$cmdArgs(-bg) == ""} { + set cmdArgs(-bg) [.__temp cget -bg] + } + + set cmdArgs(-fg) [option get $win foreground Color1] + if {$cmdArgs(-fg) == ""} { + set cmdArgs(-fg) [.__temp cget -fg] + } + + set cmdArgs(-slidercolor) [option get $win sliderColor Color1] + if {$cmdArgs(-slidercolor) == ""} { + set cmdArgs(-slidercolor) blue + } + + set cmdArgs(-gradient1) [option get $win gradient1 Color1] + if {$cmdArgs(-gradient1) == ""} { + set cmdArgs(-gradient1) royalblue3 + } + + set cmdArgs(-gradient2) [option get $win gradient2 Color1] + if {$cmdArgs(-gradient2) == ""} { + set cmdArgs(-gradient2) gray90 + } + + + set ar(sliderPressed) 0 + destroy .__temp + + array set cmdArgs $args + array set ar [array get cmdArgs] + + unset cmdArgs(-slidercolor) + unset cmdArgs(-gradient1) + unset cmdArgs(-gradient2) + + #synonym flags + foreach long {background foreground} short {bg fg} { + if {[info exists cmdArgs(-$long)] == 1} { + set cmdArgs(-$short) $cmdArgs(-$long) + unset cmdArgs(-long) + } + } + + if {$cmdArgs(-orient) == "vertical"} { + cscrollbar::createVertical $win $cmdArgs(-bg) $cmdArgs(-fg) + } elseif {$cmdArgs(-orient) == "horizontal"} { + cscrollbar::createHorizontal $win $cmdArgs(-bg) $cmdArgs(-fg) + } else { + return -code error {Invalid -orient option -- use vertical or horizontal} + } + + unset cmdArgs(-orient) + unset cmdArgs(-fg) + unset cmdArgs(-bg) + + if {[info exists cmdArgs(-command)] == 1} { + bind $win.1 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$cmdArgs(-command)} -1 %W" + bind $win.1 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$cmdArgs(-command)} -1 %W" + bind $win.c "cscrollbar::sliderNotPressed $win" + bind $win.2 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$cmdArgs(-command)} 1 %W" + bind $win.2 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$cmdArgs(-command)} 1 %W" + + bind $win.3 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$cmdArgs(-command)} -1 %W" + bind $win.3 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$cmdArgs(-command)} -1 %W" + bind $win.4 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$cmdArgs(-command)} 1 %W" + bind $win.4 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$cmdArgs(-command)} 1 %W" + + + bind $win "after idle [list cscrollbar::updateView $win]" + unset cmdArgs(-command) + } + + + if {[llength [array names cmdArgs]] != 0} { + return -code error "Invalid argument sent to cscrollbar: [array get cmdArgs]" + } + + rename $win _cscrollbarJunk$win + + bind $win "rename $win {};" + + proc $win {cmd args} "eval cscrollbar::instanceCmd $win \$cmd \$args" + return $win +} + +proc cscrollbar::updateView {win} { + upvar #0 _cscrollbar$win ar + if {[catch $ar(-command) res] && $res != ""} { + $win set 0 1 + } +} + +proc cscrollbar::instanceCmd {self cmd args} { + upvar #0 _cscrollbar$self ar + + switch -glob -- $cmd { + cget { + if {[info exists ar($args)] == 1} { + return $ar($args) + } else { + return -code error "unknown argument(s) to cget: $args" + } + } + + conf* { + if {[llength $args] == 0} { + foreach name [array names ar -*] { + append res "{$name $ar($name)} " + } + + return $res + } + + array set cmdArgs $args + + foreach long {background foreground} short {bg fg} { + if {[info exists cmdArgs(-$long)] == 1} { + set cmdArgs(-$short) $cmdArgs(-$long) + unset cmdArgs(-$long) + } + } + + if {[info exists cmdArgs(-gradient1)] == 1} { + set ar(-gradient1) $cmdArgs(-gradient1) + event generate $self + } + + if {[info exists cmdArgs(-gradient2)] == 2} { + set ar(-gradient2) $cmdArgs(-gradient2) + event generate $self + } + + if {[info exists cmdArgs(-bg)] == 1} { + set ar(-bg) $cmdArgs(-bg) + $self.1 config -bg $ar(-bg) + $self.c config -bg $ar(-bg) + $self.2 config -bg $ar(-bg) + + if {$ar(-orient) == "vertical"} { + $ar(upImage) config -background $ar(-bg) + $ar(upDisabledImage) config -background $ar(-bg) + $ar(downImage) config -background $ar(-bg) + $ar(downDisabledImage) config -background $ar(-bg) + } + + if {$ar(-orient) == "horizontal"} { + $ar(leftImage) config -background $ar(-bg) + $ar(leftDisabledImage) config -background $ar(-bg) + $ar(rightImage) config -background $ar(-bg) + $ar(rightDisabledImage) config -background $ar(-bg) + } + unset cmdArgs(-bg) + } + + if {[info exists cmdArgs(-fg)] == 1} { + set ar(-fg) $cmdArgs(-fg) + $self.1 config -fg $ar(-fg) + $self.2 config -fg $ar(-fg) + $self.3 config -fg $ar(-fg) + $self.4 config -fg $ar(-fg) + + if {$ar(-orient) == "vertical"} { + $ar(upImage) config -foreground $ar(-fg) + $ar(downImage) config -foreground $ar(-fg) + } + + if {$ar(-orient) == "horizontal"} { + $ar(leftImage) config -foreground $ar(-fg) + $ar(rightImage) config -foreground $ar(-fg) + } + unset cmdArgs(-fg) + } + + if {[info exists cmdArgs(-slidercolor)] == 1} { + set ar(-slidercolor) $cmdArgs(-slidercolor) + $self.c itemconfigure slider -fill $ar(-slidercolor) + unset cmdArgs(-slidercolor) + } + + if {[info exists cmdArgs(-command)] == 1} { + set ar(-command) $cmdArgs(-command) + bind $self.1 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$ar(-command)} -1 %W" + bind $self.1 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$ar(-command)} -1 %W" + bind $self.c "cscrollbar::sliderNotPressed $self" + bind $self.2 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$ar(-command)} 1 %W" + bind $self.2 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$ar(-command)} 1 %W" + + bind $self.3 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$ar(-command)} -1 %W" + bind $self.3 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$ar(-command)} -1 %W" + bind $self.4 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$ar(-command)} 1 %W" + bind $self.4 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$ar(-command)} 1 %W" + + bind $self " + if {\[catch {$ar(-command)} res\] == 0 && \$res != \"\"} { + $self set \$res + } + " + unset cmdArgs(-command) + } + + set res [llength [array names cmdArgs]] + if {$res != 0} { + return -code error "The following options were not recognized\ +by cscrollbar: [array get cmdArgs]" + } + } + + set { + set start [lindex $args 0] + set end [lindex $args 1] + + #somehow this becomes a list when I don't want it to be. + if {$end == ""} { + set end [lindex $start 1] + set start [lindex $start 0] + } + + if {$end <= 0} { + set end 1 + } + + update idletasks + + if {$ar(-orient) == "vertical"} { + if {$start == 0} { + $self.1 config -image $ar(upDisabledImage) + $self.3 config -image $ar(upDisabledImage) + } else { + $self.1 config -image $ar(upImage) + $self.3 config -image $ar(upImage) + } + + if {$end == 1} { + $self.2 config -image $ar(downDisabledImage) + $self.4 config -image $ar(downDisabledImage) + } else { + $self.2 config -image $ar(downImage) + $self.4 config -image $ar(downImage) + } + + if {$ar(sliderPressed) == 1} { + return + } + + #-2 is done for the border + set areaHeight [expr {([winfo height $self.c] - 2)}] + set startPos [expr {$start * $areaHeight}] + set endPos [expr {$end * $areaHeight}] + + if {$endPos <= 0} { + set endPos $areaHeight + } + + $self.c coords slider 0 $startPos [winfo width $self.c] $endPos + } + if {$ar(-orient) == "horizontal"} { + if {$start == 0} { + $self.1 config -image $ar(leftDisabledImage) + $self.3 config -image $ar(leftDisabledImage) + } else { + $self.1 config -image $ar(leftImage) + $self.3 config -image $ar(leftImage) + } + if {$end == 1} { + $self.2 config -image $ar(rightDisabledImage) + $self.4 config -image $ar(rightDisabledImage) + } else { + $self.2 config -image $ar(rightImage) + $self.4 config -image $ar(rightImage) + } + + if {$ar(sliderPressed) == 1} { + return + } + set areaWidth [expr {([winfo width $self.c] - 2)}] + set startPos [expr {$start * $areaWidth}] + set endPos [expr {$end * $areaWidth}] + + if {$endPos <= 0} { + set endPos $areaWidth + } + + $self.c coords slider $startPos 0 $endPos [winfo height $self.c] + } + } + + default { + #puts "$cmd $args" + } + } +} + +proc cscrollbar::createHorizontal {win bg fg} { + upvar #0 _cscrollbar$win ar + + set bd 1 + + set ar(leftImage) [image create bitmap -data $cscrollbar::left_xbm \ + -foreground $fg -background $bg] + set ar(leftDisabledImage) [image create bitmap -data $cscrollbar::left_xbm \ + -foreground gray50 -background $bg] + set ar(rightImage) [image create bitmap -data $cscrollbar::right_xbm \ + -foreground $fg -background $bg] + set ar(rightDisabledImage) [image create bitmap -data $cscrollbar::right_xbm \ + -foreground gray50 -background $bg] + + grid [label $win.1 -image $ar(leftDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 0 -column 0 -sticky w + + grid [label $win.2 -image $ar(rightDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 0 -column 1 -sticky w + + grid [canvas $win.c -relief flat -highlightthickness 0 \ + -height [winfo reqheight $win.1] -width 10 -bg $bg] \ + -row 0 -column 2 -sticky ew + + grid columnconfigure $win 2 -weight 1 + + grid [label $win.3 -image $ar(leftDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 0 -column 3 -sticky e + + grid [label $win.4 -image $ar(rightDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 0 -column 4 -sticky e + + cscrollbar::drawSlider $win 0 0 1 1 horizontal + + $win.c bind slider "cscrollbar::moveSlider $win horizontal %x" + $win.c bind slider " + set cscrollbar::lastX \[$win.c canvasx %x\] + set cscrollbar::lastY \[$win.c canvasy %y\] + " + bind $win.c "cscrollbar::drawBackground $win horizontal" +} + + +proc cscrollbar::createVertical {win bg fg} { + upvar #0 _cscrollbar$win ar + + set bd 1 + + set ar(upImage) [image create bitmap -data $cscrollbar::up_xbm \ + -foreground $fg -background $bg] + set ar(upDisabledImage) [image create bitmap -data $cscrollbar::up_xbm \ + -foreground gray50 -background $bg] + set ar(downImage) [image create bitmap -data $cscrollbar::down_xbm \ + -foreground $fg -background $bg] + set ar(downDisabledImage) [image create bitmap -data $cscrollbar::down_xbm \ + -foreground gray50 -background $bg] + + grid [label $win.1 -image $ar(upDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 0 -column 0 -sticky n + + grid [label $win.2 -image $ar(downDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 1 -column 0 -sticky n + + grid [canvas $win.c -relief flat -highlightthickness 0 \ + -width [winfo reqwidth $win.1] -height 10 -bg $bg] \ + -row 2 -column 0 -sticky ns + + grid rowconfigure $win 2 -weight 1 + grid [label $win.3 -image $ar(upDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 3 -column 0 -sticky s + grid [label $win.4 -image $ar(downDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 4 -column 0 -sticky s + + + cscrollbar::drawSlider $win 0 0 1 1 vertical + + $win.c bind slider "cscrollbar::moveSlider $win vertical %y" + $win.c bind slider " + set cscrollbar::lastX \[$win.c canvasx %x\] + set cscrollbar::lastY \[$win.c canvasy %y\] + " + bind $win.c "cscrollbar::drawBackground $win vertical" +} + + +#Based on Richard Suchenwirth's gradient code from one of his train +#projects. +proc cscrollbar::drawBackground {win type} { + upvar #0 _cscrollbar$win ar + set canv $win.c + set x1 0 + set y1 0 + set x2 [expr {[winfo width $canv] + 8}] + set y2 [expr {[winfo height $canv] + 8}] + set c1 $ar(-gradient1) + set c2 $ar(-gradient2) + + $canv delete background + + foreach {r1 g1 b1} [winfo rgb $canv $c1] break + foreach {r2 g2 b2} [winfo rgb $canv $c2] break + set redDiff [expr {$r2 - $r1}] + set greenDiff [expr {$g2 - $g1}] + set blueDiff [expr {$b2 - $b1}] + switch $type { + horizontal { + set yDiff [expr {$y2 - $y1}] + set steps [expr {int(abs($yDiff))}] + if {$steps > 255} { + set steps 255 + } + for {set i 2} {$i < $steps} {incr i} { + set p [expr {double($i) / $steps}] + set y [expr {$y1 + $yDiff * $p}] + set r [expr {int($r1 + $redDiff * $p)}] + set g [expr {int($g1 + $greenDiff * $p)}] + set b [expr {int($b1 + $blueDiff * $p)}] + + set fillColor "#" + foreach color {r g b} { + set preColor [format "%2.2x" [set $color]] + set color [format "%2.2s" $preColor] + append fillColor $color + } + + $canv create rectangle $x1 $y $x2 $y2 -outline {} -tag background \ + -fill $fillColor + } + } + + vertical { + set xDiff [expr {$x2 - $x1}] + set steps [expr {int(abs($xDiff))}] + + if {$steps > 255} { + set steps 255 + } + for {set i 2} {$i < $steps} {incr i} { + set p [expr {double($i) / $steps}] + set x [expr {$x1 + $xDiff * $p}] + set r [expr {int($r1 + $redDiff * $p)}] + set g [expr {int($g1 + $greenDiff * $p)}] + set b [expr {int($b1 + $blueDiff * $p)}] + + set fillColor "#" + foreach color {r g b} { + set preColor [format "%2.2x" [set $color]] + set color [format "%2.2s" $preColor] + append fillColor $color + } + + $canv create rectangle $x $y1 $x2 $y2 -outline {} -tag background \ + -fill $fillColor + } + } + + default { + return -code error "unknown direction \"$type\": must be one of horizontal or vertical" + } + } + + $win.c bind background "cscrollbar::scrollPages $win $type %x %y" + $win.c lower background +} + + +proc cscrollbar::drawSlider {win x1 y1 x2 y2 type} { + upvar #0 _cscrollbar$win ar + + #update idletasks + $win.c delete slider + + if {$type == "vertical"} { + set canvasWidth [winfo width $win.c] + $win.c create rectangle 0 $y1 $canvasWidth $y2 \ + -fill $ar(-slidercolor) -outline "" -tag slider -stipple gray50 + return + } + + if {$type == "horizontal"} { + set canvasHeight [winfo height $win.c] + $win.c create rectangle $x1 0 $x2 $canvasHeight \ + -fill $ar(-slidercolor) -outline "" -tag slider -stipple gray50 + return + } +} + + +proc cscrollbar::moveSlider {win type position} { + variable lastX + variable lastY + upvar #0 _cscrollbar$win ar + + if {$type == "vertical"} { + #move the slider y values which are 1 and 3 in the coords list + set sliderStartY [lindex [$win.c coords slider] 1] + set sliderEndY [lindex [$win.c coords slider] 3] + set sliderHeight [expr {$sliderEndY - $sliderStartY}] + set areaHeight [expr {[winfo height $win.c] - 1}] + + + set newY [expr {$position - $lastY}] + set upBoundResult [expr {($sliderStartY + $newY) < 0}] + set downBoundResult [expr {($sliderEndY + $newY) > $areaHeight}] + + if {$upBoundResult != 1 && $downBoundResult != 1} { + $win.c move slider 0 $newY + set lastY $position + } elseif {$upBoundResult == 1} { + set lastY [expr {$lastY - $sliderStartY}] + $win.c move slider 0 [expr {-$sliderStartY}] + } elseif {$downBoundResult == 1} { + set amountToMove [expr {-$sliderStartY + ($areaHeight - $sliderHeight)}] + set lastY [expr {$lastY + $amountToMove}] + $win.c move slider 0 $amountToMove + } + + if {[info exists ar(-command)] == 1} { + set ar(sliderPressed) 1 + eval $ar(-command) moveto [expr {$sliderStartY / $areaHeight}] + } + return + } + + if {$type == "horizontal"} { + #move the slider x values which are 0 and 2 in the coords list + set sliderStartX [lindex [$win.c coords slider] 0] + set sliderEndX [lindex [$win.c coords slider] 2] + set sliderWidth [expr {$sliderEndX - $sliderStartX}] + set areaWidth [expr {[winfo width $win.c] - 1}] + + set newX [expr {$position - $lastX}] + set leftBoundResult [expr {($sliderStartX + $newX) < 0}] + set rightBoundResult [expr {($sliderEndX + $newX) > $areaWidth}] + + if {$leftBoundResult != 1 && $rightBoundResult != 1} { + $win.c move slider $newX 0 + set lastX $position + } elseif {$leftBoundResult == 1} { + set lastX [expr {$lastX - $sliderStartX}] + $win.c move slider [expr {-$sliderStartX}] 0 + } elseif {$rightBoundResult == 1} { + set amountToMove [expr {-$sliderStartX + ($areaWidth - $sliderWidth)}] + set lastX [expr {$lastX + $amountToMove}] + $win.c move slider $amountToMove 0 + } + + if {[info exists ar(-command)] == 1} { + set ar(sliderPressed) 1 + eval $ar(-command) moveto [expr {$sliderStartX / $areaWidth}] + } + return + } +} + +#This moves the widget being scrolled a unit at a time. +#It is invoked by the arrow buttons. The arrow buttons +#are actually labels with bitmaps that have the -relief +#change. + +proc cscrollbar::moveUnit {cmd unit self} { + variable buttonPressed + + eval $cmd scroll $unit units + + $self config -relief sunken + if {$buttonPressed == 1} { + after 40 "cscrollbar::moveUnit {$cmd} $unit $self" + } else { + $self config -relief raised + } +} + +#This means that someone has pressed the trough/background +#of the scrollbar, so we should scroll a page at a time. +#Unlike Tk's scrollbar I don't continue scrolling while +#the mouse is held down. Instead I chose to scroll once. +#If the user wants it to continue they can press the mouse +#again. +proc cscrollbar::scrollPages {win type x y} { + upvar #0 _cscrollbar$win ar + + if {$type == "horizontal"} { + set sliderStartX [lindex [$win.c coords slider] 0] + set sliderEndX [lindex [$win.c coords slider] 2] + + if {$x < $sliderStartX} { + eval [concat $ar(-command) scroll -1 pages] + } + + if {$x > $sliderEndX} { + eval [concat $ar(-command) scroll 1 pages] + } + } + + if {$type == "vertical"} { + set sliderStartY [lindex [$win.c coords slider] 1] + set sliderEndY [lindex [$win.c coords slider] 3] + + if {$y < $sliderStartY} { + eval [concat $ar(-command) scroll -1 pages] + } + + if {$y > $sliderEndY} { + eval [concat $ar(-command) scroll 1 pages] + } + } +} + + +proc cscrollbar::sliderNotPressed {win} { + upvar #0 _cscrollbar$win ar + set ar(sliderPressed) 0 + + if {[catch {$ar(-command)} res] == 0 && $res != ""} { + $win set $res + } +} ADDED modules/ctext/pkgIndex.tcl Index: modules/ctext/pkgIndex.tcl ================================================================== --- /dev/null +++ modules/ctext/pkgIndex.tcl @@ -0,0 +1,1 @@ +package ifneeded ctext 3.1 [list source [file join $dir ctext.tcl]] ADDED modules/ctext/test.c Index: modules/ctext/test.c ================================================================== --- /dev/null +++ modules/ctext/test.c @@ -0,0 +1,1134 @@ +/*The Panache Window Manager*/ +/*By George Peter Staplin*/ +/*Please read the LICENSE file included with the Panache distribution + *for usage restrictions. + */ + +#include +#include +#include +#ifndef __STDC__ + #include +#endif +#include +#include +#include +#include +#include +#include +#include +#include "PanacheWindowList.h" + +/*Style +I use if (returnFromFunc == 1) instead of if (returnFromFunc) +I use if (returnFromFunc == 0) instead of if (!returnFromFunc) +*/ + +/*Automatic focus of new windows yes/no.*/ +/*Automatic focus of transient windows yes/no.*/ + +#define PANACHE_DIRECTORY "Panache" +#define CMD_ARGS (ClientData clientData, Tcl_Interp *interp, \ +int objc, Tcl_Obj *CONST objv[]) + +Display *dis; +XEvent report; +Window root; +Tcl_Interp *interp; +int distance_from_edge = 0; +Window mapped_window = None; +int screen; +Atom _XA_WM_STATE; +Atom _XA_WM_PROTOCOLS; +Atom _XA_WM_DELETE_WINDOW; +Window workspace_manager; +struct CList *keepAboveWindowList; +unsigned long eventMask = (ResizeRedirectMask | PropertyChangeMask | \ + EnterWindowMask | LeaveWindowMask | FocusChangeMask | KeyPressMask); + +#define winIdLength 14 +/*#define FORK_ON_START*/ + +int PanacheGetWMState (Window win); +void PanacheSelectInputForRootParented (Window win); +void PanacheConfigureNormalWindow (Window win, unsigned long value_mask); + +char Panache_Init_script[] = { + "if {[file exists $prefix/$panacheDirectory/Panache.tcl] != 1} {\n" + " puts stderr {unable to open Panache.tcl Did you run make install?}\n" + " puts stderr \"I looked in $prefix/$panacheDirectory\"\n" + " exit -1\n" + "}\n" + "proc sendToPipe str {\n" + " set str [string map {\"\n\" \"\" \"\r\" \"\"} $str]\n" + " puts $::pipe $str\n" + " flush $::pipe\n" + "}\n" + "proc getFromPipe {} {\n" + " gets $::pipe line\n" + " if {$line != \"\"} {\n" + " set cmd [lindex $line 0]\n" + " if {[llength $line] == 2} {\n" + " $cmd [lindex $line 1]\n" + " } else {\n" + " eval $line\n" + " }\n" + " }\n" + "}\n" + "set ::pipe [open \"|$wishInterpreter $prefix/$panacheDirectory/Panache.tcl\" w+]\n" + "fconfigure $::pipe -blocking 0\n" + "\n"}; + + +char *charMalloc (int size) { + char *mem = NULL; + + mem = (char *) malloc ((sizeof (char)) * size); + + if (mem == NULL) { + fprintf (stderr, "malloc failed to allocate memory This means that Panache \ +and other applications could have problems if they continue running.\n\n \ +exiting Panache now!"); + exit (-1); + } + + return mem; +} + + +void sendConfigureNotify (Window win, unsigned long value_mask, XWindowChanges *winChanges) { + XEvent xe; + XWindowAttributes wattr; + + if (XGetWindowAttributes (dis, win, &wattr) == 0) { + return; + } + + xe.type = ConfigureNotify; + xe.xconfigure.type = ConfigureNotify; + xe.xconfigure.event = win; + xe.xconfigure.window = win; + + + xe.xconfigure.x = (value_mask & CWX) ? winChanges->x : wattr.x; + xe.xconfigure.y = (value_mask & CWY) ? winChanges->y : wattr.y; + xe.xconfigure.width = (value_mask & CWWidth) ? winChanges->width : wattr.width; + xe.xconfigure.height = (value_mask & CWHeight) ? winChanges->height : wattr.height; + + xe.xconfigure.border_width = 0; + xe.xconfigure.above = None; + xe.xconfigure.override_redirect = 0; + + XSendEvent (dis, win, 0, StructureNotifyMask, &xe); + + XFlush (dis); +} + + +void sendMapNotify (Window win) { + XEvent mapNotify; + + mapNotify.type = MapNotify; + mapNotify.xmap.type = MapNotify; + mapNotify.xmap.window = win; + mapNotify.xmap.display = dis; + mapNotify.xmap.event = win; + XSendEvent (dis, win, 0, StructureNotifyMask, &mapNotify); + XFlush (dis); +} + + +int PanacheAddAllWindowsCmd CMD_ARGS { + Window dummy; + Window *children = NULL; + unsigned int nchildren; + unsigned int i; + char *winId; + char *transientForWinId; + char str[] = "sendToPipe [list add [list $winTitle] $winId $winType $transientForWinId]"; + Window twin; + + XSync (dis, 0); + /*XGrabServer (dis);*/ + + if (XQueryTree (dis, + root, + &dummy, + &dummy, + &children, + &nchildren) == 0) { + + fprintf (stderr, "Error querying the tree for the root window.\n"); + } + + for (i = 0; i < nchildren; i++) { + XTextProperty xtp; + XWMHints *wmHints = XGetWMHints (dis, children[i]); + XWindowAttributes wattr; + + xtp.value = NULL; + + if (wmHints == NULL) { + continue; + } + + if (wmHints->flags & IconWindowHint) { + continue; + } + + if (XGetWindowAttributes (dis, children[i], &wattr) == 0) { + continue; + } + + if (wattr.override_redirect == 1) { + continue; + } + + if (wmHints->flags & StateHint) { + if (wmHints->initial_state & WithdrawnState) { + continue; + } else if (wattr.map_state == 0 && PanacheGetWMState (children[i]) == 0) { + continue; + } + } + + XFree (wmHints); + + XGetWMName (dis, children[i], &xtp); + + winId = charMalloc (winIdLength); + + sprintf (winId, "%ld", children[i]); + Tcl_SetVar (interp, "winTitle", (char *) xtp.value, 0); + Tcl_SetVar (interp, "winId", winId, 0); + + if (XGetTransientForHint (dis, children[i], &twin) == 1) { + Tcl_SetVar (interp, "winType", "transient", 0); + + transientForWinId = charMalloc (winIdLength); + sprintf (transientForWinId, "%ld", twin); + Tcl_SetVar (interp, "transientForWinId", transientForWinId, 0); + free (transientForWinId); + + PanacheSelectInputForRootParented (children[i]); + + } else { + Tcl_SetVar (interp, "winType", "normal", 0); + Tcl_SetVar (interp, "transientForWinId", "", 0); + + /*Maybe I should compare the first char and then do strcmp?*/ + if (xtp.value != NULL && strcmp ((char *)xtp.value, "___Panache_GUI") != 0) { + PanacheConfigureNormalWindow (children[i], CWX|CWY|CWWidth|CWHeight); + PanacheSelectInputForRootParented (children[i]); + } + } + + XFree (xtp.value); + free (winId); + + if (Tcl_Eval (interp, str) != TCL_OK) { + fprintf (stderr, "Error in PanacheAddAllWindowsCmd: %s\n", Tcl_GetStringResult (interp)); + } + } + + if (children != NULL) { + XFree (children); + } + + /*XUngrabServer (dis);*/ + XSync (dis, 0); + + return TCL_OK; +} + + +void PanacheConfigureRequest (XConfigureRequestEvent *event) { + XWindowChanges wc; + Window twin; + int maxWidth; + int maxHeight; + + if (event->parent != root) { + return; + } + +#ifdef DEBUG + fprintf (stderr, "ConfigureRequest win %ld\n", event->window); + fprintf (stderr, "CWSibling %d\n", (event->value_mask & CWSibling) == 1); + fprintf (stderr, "CWStackMode %d\n", (event->value_mask & CWStackMode) == 1); +#endif + + maxWidth = (DisplayWidth (dis, screen) - distance_from_edge - 4); + maxHeight = DisplayHeight (dis, screen); + + wc.border_width = 0; + wc.sibling = None; + wc.stack_mode = Above; + + if (event->window == workspace_manager) { + wc.width = distance_from_edge; + wc.height = maxHeight; + wc.x = 0; + wc.y = 0; + XConfigureWindow(dis, event->window, CWX|CWY|CWWidth|CWHeight, &wc); + sendConfigureNotify (event->window, CWX|CWY|CWWidth|CWHeight, &wc); + return; + } else { + PanacheSelectInputForRootParented (event->window); + } + + if (XGetTransientForHint (dis, event->window, &twin) == 1) { + if (event->width > maxWidth) { + wc.width = maxWidth; + } else { + wc.width = event->width; + } + + wc.height = event->height; + + if (event->x < distance_from_edge) { + wc.x = distance_from_edge; + } else { + wc.x = event->x; + } + + wc.y = event->y; + XConfigureWindow (dis, event->window, event->value_mask, &wc); + sendConfigureNotify (event->window, event->value_mask, &wc); + } else { + PanacheConfigureNormalWindow (event->window, event->value_mask); + } + + XFlush (dis); +} + + +/*This configures the window and sends a ConfigureNotify event. + *It's designed for normal non-transient windows + */ +void PanacheConfigureNormalWindow ( + Window win, unsigned long value_mask) +{ + XWindowChanges wc; + XSizeHints sizeHints; + long ljunk = 0; + int maxWidth = (DisplayWidth (dis, screen) - distance_from_edge - 4); + int maxHeight = DisplayHeight (dis, screen); + + wc.border_width = 0; + wc.sibling = None; + wc.stack_mode = Above; + + wc.x = distance_from_edge; + wc.y = 0; + wc.width = maxWidth; + wc.height = maxHeight; + + if (XGetWMNormalHints (dis, win, &sizeHints, &ljunk)) { + if (sizeHints.flags & PMaxSize) { + wc.width = (sizeHints.max_width > maxWidth) ? maxWidth : sizeHints.max_width; + wc.height = (sizeHints.max_height > maxHeight) ? maxHeight : sizeHints.max_height; +#ifdef DEBUG + fprintf (stderr, "MaxSize %d %d\n", sizeHints.max_width, sizeHints.max_height); +#endif + } +#ifdef DEBUG + if (sizeHints.flags & PResizeInc) { + fprintf (stderr, "PResizeInc\n"); + fprintf (stderr, "incr %d %d\n", sizeHints.width_inc, sizeHints.height_inc); + } + if (sizeHints.flags & PAspect) { + fprintf (stderr, "PAspect x %d\n", sizeHints.min_aspect.x); + } +#endif + } + + XConfigureWindow (dis, win, value_mask, &wc); + sendConfigureNotify (win, value_mask, &wc); +} + + +/*This appends windows that are not to be managed by + *Panache to a list, and Panache will later on raise + *them above other windows. + */ +void PanacheCreateNotify (XCreateWindowEvent *event) { + + if (event->override_redirect == 0 || event->parent != root) { + return; + } + + CListAppend (keepAboveWindowList, event->window); +} + +/*X has told Panache that a DestroyNotify event occured + *to a child of the root window, so Panache removes the + *window from the window list. + */ +void PanacheDestroyNotify (XDestroyWindowEvent *event) { + Window win; + char *winId; + char str[] = "sendToPipe [list remove $winId]"; + + win = event->window; + + winId = charMalloc (winIdLength); + sprintf (winId, "%ld", win); + + Tcl_SetVar (interp, "winId", winId, 0); + free (winId); + +#ifdef DEBUG + fprintf (stderr, "DestroyNotify\n"); +#endif + + CListRemove (keepAboveWindowList, event->window); + + /*Tell Panache_GUI to remove the window*/ + if (Tcl_Eval (interp, str) != TCL_OK) { + fprintf (stderr, "Tcl_Eval error in PanacheDestroyNotify %s\n", Tcl_GetStringResult (interp)); + } +} + + +/*Panache_GUI calls this to send WM_DELETE_WINDOW or + *invoke XKillClient (if the window doesn't support + *WM_DELETE_WINDOW). We can't use XKillClient on all + *windows, because if the application has multiple + *toplevel windows sending XKillClient would destroy + *them all. + */ +int PanacheDestroyCmd CMD_ARGS { + XClientMessageEvent ev; + Window win; + Atom *wmProtocols = NULL; + Atom *protocol; + int i; + int numAtoms; + int handlesWM_DELETE_WINDOW = 0; + + + Tcl_GetLongFromObj (interp, objv[1], (long *) &win); + + if (XGetWMProtocols (dis, win, &wmProtocols, &numAtoms) == 1) { + for (i = 0, protocol = wmProtocols; i < numAtoms; i++, protocol++) { + if (*protocol == (Atom)_XA_WM_DELETE_WINDOW) { + handlesWM_DELETE_WINDOW = 1; + } + } + if (wmProtocols) { + XFree (wmProtocols); + } + } + + if (handlesWM_DELETE_WINDOW == 1) { + ev.type = ClientMessage; + ev.window = win; + ev.message_type = _XA_WM_PROTOCOLS; + ev.format = 32; + ev.data.l[0] = _XA_WM_DELETE_WINDOW; + ev.data.l[1] = CurrentTime; + XSendEvent (dis, win, 0, 0L, (XEvent *) &ev); + } else { + XKillClient (dis, win); + } + + XFlush (dis); + + return TCL_OK; +} + + +int PanacheDFECmd CMD_ARGS { + Tcl_GetIntFromObj (interp, objv[1], &distance_from_edge); + return TCL_OK; +} + + +/*Panache_GUI sends focus $winId to get here.*/ +int PanacheFocusCmd CMD_ARGS { + Window win; + + Tcl_GetLongFromObj (interp, objv[1], (long *) &win); + + if (XSetInputFocus (dis, win, RevertToParent, CurrentTime) != 1) { + fprintf (stderr, "XSetInputFocus failure within PanacheFocusCmd()"); + } + + XFlush (dis); + + return TCL_OK; +} + + +int PanacheGetWMState (Window win) { + int returnValue = 0; + Atom type; + int ijunk; + unsigned long ljunk; + unsigned long *state = NULL; + + XGetWindowProperty ( + dis, + win, + _XA_WM_STATE, + 0L, + 1L, + 0, + _XA_WM_STATE, + &type, + &ijunk, + &ljunk, + &ljunk, + (unsigned char **) &state + ); + + if (type == _XA_WM_STATE) { + returnValue = (int) *state; + } else { + /*Don't know what to do*/ + returnValue = 0; + } + + if (state != NULL) { + XFree (state); + } + + return returnValue; +} + +/*A window to keep above has the override_redirect + *attribute set to 1. + */ + +void PanacheRaiseKeepAboveWindows () { + Window win; + + CListRewind (keepAboveWindowList); + + while ((win = CListGet (keepAboveWindowList)) != NULL) { + XRaiseWindow (dis, win); + } + + XFlush (dis); +} + + +void PanacheRecursivelyGrabKey (Window win, int keycode) { + Window dummy; + Window *children = NULL; + unsigned int nchildren; + int i; + + + if (XQueryTree (dis, win, &dummy, &dummy, &children, &nchildren) == 0) { + return; + } + + for (i = 0; i < nchildren; i++) { + PanacheRecursivelyGrabKey (children[i], keycode); + XGrabKey (dis, keycode, Mod1Mask, win, 1, GrabModeAsync, GrabModeSync); + } + + if (children != NULL) { + XFree (children); + } +} + + +int PanacheReparentCmd CMD_ARGS { + Window newParent; + Window win; + + Tcl_GetLongFromObj (interp, objv[1], (long *) &win); + Tcl_GetLongFromObj (interp, objv[2], (long *) &newParent); + + XReparentWindow (dis, win, newParent, 0, 20); + + return TCL_OK; +} + + +void PanacheSelectInputForRootParented (Window win) { + + XSelectInput (dis, win, eventMask); +} + + +void PanacheSetWMState (Window win, int state) { + unsigned long data[2]; + data[0] = state; + data[1] = None; + + XChangeProperty (dis, win, _XA_WM_STATE, _XA_WM_STATE, 32, + PropModeReplace, (unsigned char *) data, 2 + ); + + XSync (dis, 0); +} + + +int PanacheTransientCmd CMD_ARGS { + Window parent; + Window win; + + Tcl_GetLongFromObj (interp, objv[1], (long *) &win); + Tcl_GetLongFromObj (interp, objv[2], (long *) &parent); + + XSetTransientForHint (dis, win, parent); + + return TCL_OK; +} + +/*This sends a string to Panache_GUI with info about the window, + *such as its title and window id. This information is processed + *within Panache_GUI and if desired PanacheMapCmd will map the + *window. + */ +void PanacheMapRequest (XMapRequestEvent *event) { + char *winId; + char *transientForWinId; + XTextProperty xtp; + char str[] = "sendToPipe [list add [list $winTitle] $winId $winType $transientForWinId]"; + Window twin; + + if (event->window == NULL) { + return; + } + + /*This makes the state iconic, so that if the user presses + *restart before mapping the window, the window will show up. + */ + PanacheSetWMState (event->window, IconicState); + + xtp.value = NULL; + + XGetWMName (dis, event->window, &xtp); + + winId = charMalloc (winIdLength); + + sprintf (winId, "%ld", event->window); + PanacheSelectInputForRootParented (event->window); + + Tcl_SetVar (interp, "winTitle", (char *) xtp.value, 0); + Tcl_SetVar (interp, "winId", winId, 0); + + if (XGetTransientForHint (dis, event->window, &twin) == 1) { + Tcl_SetVar (interp, "winType", "transient", 0); + transientForWinId = charMalloc (winIdLength); + sprintf (transientForWinId, "%ld", twin); + Tcl_SetVar (interp, "transientForWinId", transientForWinId, 0); + free (transientForWinId); + } else { + Tcl_SetVar (interp, "winType", "normal", 0); + Tcl_SetVar (interp, "transientForWinId", "", 0); + } + + XFree (xtp.value); + free (winId); + + if (Tcl_Eval (interp, str) != TCL_OK) { + fprintf (stderr, "Error in PanacheMapRequest: %s\n", Tcl_GetStringResult (interp)); + } +} + + +/*This maps a window. It may be called after PanacheMapRequest by + *Panache_GUI. This is also called when a window is over another + *window and the user selects the button for the window to display + *which causes this function to raise the window. + */ +int PanacheMapCmd CMD_ARGS { + Window win; + Window twin; + XWindowAttributes winAttrib; + + Tcl_GetLongFromObj (interp, objv[1], (long *) &win); + + PanacheSelectInputForRootParented (win); + + /*XGrabKey (dis, XK_Tab, Mod1Mask, win, 1, GrabModeAsync, GrabModeAsync);*/ + /*PanacheRecursivelyGrabKey (win, XK_Tab);*/ + + XGetWindowAttributes (dis, win, &winAttrib); + + if (winAttrib.x < distance_from_edge) { + winAttrib.x = distance_from_edge; + if (winAttrib.y < 0) { + winAttrib.y = 0; + } + XMoveWindow (dis, win, winAttrib.x, winAttrib.y); + } + + if (XGetTransientForHint (dis, win, &twin) == 1) { + PanacheSetWMState (win, NormalState); + XMapRaised (dis, win); + sendMapNotify (win); + mapped_window = win; + PanacheRaiseKeepAboveWindows (); + + return TCL_OK; + } + + + if ((PanacheGetWMState (win)) == 1) { + XRaiseWindow (dis, win); + PanacheRaiseKeepAboveWindows (); + + return TCL_OK; + } + + /*If we are here the window hasn't had its size set, or + *the WM_STATE was not 1. + */ + + PanacheSetWMState (win, NormalState); + + /*I've found that some applications get upset if you sent + *a ConfigureNotify before the MapNotify, when they are + *expecting the MapNotify to be eminent. + */ + + XMapRaised (dis, win); + sendMapNotify (win); + + PanacheConfigureNormalWindow (win, CWX|CWY|CWWidth|CWHeight); + + mapped_window = win; + PanacheRaiseKeepAboveWindows (); + + return TCL_OK; +} + + +int PanacheMapWorkspaceCmd CMD_ARGS { + XWindowChanges wc; + Window win; + + Tcl_GetLongFromObj (interp, objv[1], (long *) &win); + workspace_manager = win; + PanacheSetWMState (win, NormalState); + + wc.x = 0; + wc.y = 0; + wc.width = distance_from_edge; + wc.height = DisplayHeight (dis, screen); + + XConfigureWindow(dis, win, CWX|CWY|CWWidth|CWHeight, &wc); + sendConfigureNotify (win, CWX|CWY|CWWidth|CWHeight, &wc); + + XMapWindow (dis, win); + sendMapNotify (win); + mapped_window = win; + XFlush (dis); + + return TCL_OK; +} + + +int PanacheMoveCmd CMD_ARGS { + XEvent event; + unsigned int buttonPressed; + Window wjunk; + int ijunk; + Cursor handCursor; + Window win; + int oldX; + int oldY; + int x; + int y; + int internalX; + int internalY; + unsigned int maskReturn; + int continueEventLoop = 1; + XWindowAttributes winAttr; + + handCursor = XCreateFontCursor (dis, XC_hand2); + + XGrabPointer (dis, root, 1, + ButtonPressMask | ButtonReleaseMask | ButtonMotionMask | \ + PointerMotionHintMask, + GrabModeAsync, GrabModeAsync, + None, + handCursor, + CurrentTime + ); + + /*Wait until the user has selected the window to move.*/ + XMaskEvent (dis, ButtonPressMask, &event); + + /*The button being held down while dragging the window.*/ + buttonPressed = event.xbutton.button; + + /*fprintf (stderr, "ButtonPressed %d\n", buttonPressed);*/ + + XQueryPointer (dis, root, + &wjunk, &win, + &oldX, &oldY, + &internalX, &internalY, + &maskReturn + ); + + if (win == workspace_manager) { + XUngrabPointer (dis, CurrentTime); + XFreeCursor (dis, handCursor); + XSync (dis, 0); + + return TCL_OK; + } + + + XGetWindowAttributes (dis, win, &winAttr); + + while (continueEventLoop == 1) { + XNextEvent (dis, &event); + switch (event.type) { + case ButtonRelease: + { + if (event.xbutton.button == buttonPressed) { + continueEventLoop = 0; + } + } + break; + case MotionNotify: + { + XWindowChanges wc; + int newX; + int newY; + + while (XCheckTypedEvent (dis, MotionNotify, &event)); + + XQueryPointer (dis, root, &wjunk, &wjunk, + &x, &y, + &ijunk, &ijunk, + &maskReturn + ); + + newX = x - oldX + winAttr.x; + newY = y - oldY + winAttr.y; + + if (newX < distance_from_edge) { + + if (winAttr.override_redirect == 1) { + XMoveWindow (dis, win, distance_from_edge, newY); + } else { + wc.x = distance_from_edge; + wc.y = newY; + XConfigureWindow (dis, win, CWX | CWY, &wc); + sendConfigureNotify (win, CWX | CWY, &wc); + } + continue; + } + + if (winAttr.override_redirect == 1) { + XMoveWindow (dis, win, newX, newY); + } else { + wc.x = newX; + wc.y = newY; + XConfigureWindow (dis, win, CWX | CWY, &wc); + sendConfigureNotify (win, CWX | CWY, &wc); + } + } + break; + } + } + + /*fprintf (stderr, "win is %ld\n", win);*/ + + XUngrabPointer (dis, CurrentTime); + XFreeCursor (dis, handCursor); + + XSync (dis, 0); + + return TCL_OK; +} + + +XErrorHandler PanacheErrorHandler (Display *dis, XErrorEvent *event) { +/*I've discovered that errors are frequently timing problems. +Maybe XSync would help in some areas. +Most errors are not fatal. +*/ + return 0; +} + + +int main() { + fd_set readfds; + int nfds; + int xFd; + int pipeFd; + int inputPipeFd; + ClientData data; + int fdsTcl; + + + dis = XOpenDisplay (NULL); + screen = DefaultScreen (dis); + root = RootWindow (dis, screen); + interp = Tcl_CreateInterp (); + + XSetErrorHandler ((XErrorHandler) PanacheErrorHandler); + + _XA_WM_STATE = XInternAtom (dis, "WM_STATE", 0); + _XA_WM_PROTOCOLS = XInternAtom (dis, "WM_PROTOCOLS", 0); + _XA_WM_DELETE_WINDOW = XInternAtom (dis, "WM_DELETE_WINDOW", 0); + + keepAboveWindowList = CListInit (); + +#ifdef FORK_ON_START + { + int res; + res = fork(); + + if (res == -1) { + fprintf (stderr, "Unable to fork process."); + return 1; + } + + if (res != 0) { + exit (0); + } + } +#endif + + if (Tcl_Init (interp) != TCL_OK) { + printf ("Tcl_Init error\n"); + exit (-1); + } + +#define CREATE_CMD(cmdName,func) Tcl_CreateObjCommand (interp, \ +cmdName, func, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL) + + CREATE_CMD ("map_workspace", PanacheMapWorkspaceCmd); + CREATE_CMD ("distance_from_edge", PanacheDFECmd); + CREATE_CMD ("map", PanacheMapCmd); + CREATE_CMD ("destroy", PanacheDestroyCmd); + CREATE_CMD ("add_all_windows", PanacheAddAllWindowsCmd); + CREATE_CMD ("focus", PanacheFocusCmd); + CREATE_CMD ("transient", PanacheTransientCmd); + CREATE_CMD ("reparent", PanacheReparentCmd); + CREATE_CMD ("move", PanacheMoveCmd); + + Tcl_SetVar (interp, "wishInterpreter", WISH_INTERPRETER, 0); + Tcl_SetVar (interp, "prefix", PREFIX, 0); + Tcl_SetVar (interp, "panacheDirectory", PANACHE_DIRECTORY, 0); + + + if (Tcl_Eval (interp, Panache_Init_script) != TCL_OK) { + fprintf (stderr, "Error while evaluating Panache_Init_script within main()%s\n", Tcl_GetStringResult (interp)); + exit (-1); + } + + XSelectInput (dis, root, LeaveWindowMask | EnterWindowMask| \ + PropertyChangeMask | SubstructureRedirectMask | \ + SubstructureNotifyMask | KeyPressMask | KeyReleaseMask | \ + ResizeRedirectMask | FocusChangeMask + ); + + xFd = ConnectionNumber (dis); + + Tcl_GetChannelHandle (Tcl_GetChannel (interp, Tcl_GetVar (interp, "pipe", NULL), NULL), TCL_WRITABLE, &data); + pipeFd = (int) data; + /*fprintf (stderr, "pipeFd %d", pipeFd);*/ + + Tcl_GetChannelHandle (Tcl_GetChannel (interp, Tcl_GetVar (interp, "pipe", NULL), NULL), TCL_READABLE, &data); + inputPipeFd = (int) data; + + XFlush(dis); + + for (;;) { + + FD_ZERO (&readfds); + FD_SET (xFd, &readfds); + FD_SET (pipeFd, &readfds); + FD_SET (inputPipeFd, &readfds); + + fdsTcl = (pipeFd > inputPipeFd) ? pipeFd : inputPipeFd; + nfds = (xFd > fdsTcl) ? xFd + 1: fdsTcl + 1; + + select (nfds, &readfds, NULL, NULL, NULL); + + if (FD_ISSET (inputPipeFd, &readfds) != 0) { + if (Tcl_Eval (interp, "getFromPipe") != TCL_OK) { + fprintf (stderr, "getFromPipe error %s\n", Tcl_GetStringResult (interp)); + } + } + + if (FD_ISSET (pipeFd, &readfds) != 0) { + while (Tcl_DoOneEvent (TCL_DONT_WAIT)); + } + + if (FD_ISSET (xFd, &readfds) == 0) { + continue; + } + + while (XPending (dis) > 0) { + XNextEvent (dis, &report); + + /*fprintf (stderr, "type %d\n", report.type);*/ + switch (report.type) { + case ConfigureNotify: + /*fprintf (stderr, "ConfigureNotify \n");*/ + break; + + case CreateNotify: + PanacheCreateNotify (&report.xcreatewindow); + break; + + case ConfigureRequest: + PanacheConfigureRequest (&report.xconfigurerequest); + break; + + case DestroyNotify: + PanacheDestroyNotify (&report.xdestroywindow); + break; + + case EnterNotify: + { + Window win = report.xcrossing.window; + char *winId = NULL; + char cmd[] = "sendToPipe [list activateWindow $winId]"; + + winId = charMalloc (winIdLength); + sprintf (winId, "%ld", win); + Tcl_SetVar (interp, "winId", winId, 0); + free (winId); + + if (Tcl_Eval (interp, cmd) != TCL_OK) { + fprintf (stderr, "Error evaluating cmd in EnterNotify within main() %s\n", Tcl_GetStringResult (interp)); + } + + } + break; + + case FocusIn: + break; + + + case KeyPress: + { + char cmd[] = "sendToPipe next"; + + if (XLookupKeysym (&report.xkey, 0) == XK_Tab && (report.xkey.state & Mod1Mask)) { + fprintf (stderr, "alt tab win %ld\n", report.xkey.window); + if (Tcl_Eval (interp, cmd) != TCL_OK) { + fprintf (stderr, "Error evaluating cmd in KeyPress within main() %s\n", Tcl_GetStringResult (interp)); + } + } else { + /*Send XK_Tab*/ + } + + /* + fprintf (stderr, "1 %d \n", report.xkey.state == Mod1Mask); + fprintf (stderr, "2 %d \n", report.xkey.state == Mod2Mask); + fprintf (stderr, "3 %d \n", report.xkey.state == Mod3Mask); + fprintf (stderr, "4 %d \n", report.xkey.state == Mod4Mask); + fprintf (stderr, "5 %d \n", report.xkey.state == Mod5Mask); + */ + } + break; + + case MapRequest: + PanacheMapRequest (&report.xmaprequest); + break; + + case UnmapNotify: + { + int state = PanacheGetWMState (report.xunmap.window); + /*Mapped or Iconified*/ + if (state == 1 || state == 3) { + char *winId = NULL; + char cmd[] = "sendToPipe [list remove $winId]"; + + winId = charMalloc (winIdLength); + sprintf (winId, "%ld", report.xunmap.window); + + Tcl_SetVar (interp, "winId", winId, 0); + free (winId); + + PanacheSetWMState (report.xunmap.window, WithdrawnState); + + if (Tcl_Eval (interp, cmd) != TCL_OK) { + fprintf (stderr, "Tcl_Eval error in UnmapNotify within main() %s", Tcl_GetStringResult (interp)); + } + } + } + break; + + case PropertyNotify: + { + XTextProperty xtp; + xtp.value = NULL; + + if (XGetWMName (dis, report.xproperty.window, &xtp) == 1) { + char *winId; + char cmd[] = "sendToPipe [list title [list $winTitle] $winId]"; + + winId = charMalloc (winIdLength); + sprintf (winId, "%ld", report.xproperty.window); + + Tcl_SetVar (interp, "winTitle", (char *) xtp.value, 0); + Tcl_SetVar (interp, "winId", winId, 0); + + free (winId); + XFree (xtp.value); + + if (Tcl_Eval (interp, cmd) != TCL_OK) { + fprintf (stderr, "Tcl_Eval error in PropertyNotify: within main() %s\n", Tcl_GetStringResult (interp)); + } + } + } + break; + + + case ReparentNotify: + { + Window win = report.xreparent.window; + Window parent = report.xreparent.parent; + + /* + fprintf (stderr, "ReparentNotify\n"); + fprintf (stderr, "win %ld parent %ld event %ld\n", win, parent, event); + */ + XSelectInput (dis, win, 0); + + if (parent != root) { + char *winId; + char cmd[] = "sendToPipe [list remove $winId]"; + + winId = charMalloc (winIdLength); + sprintf (winId, "%ld", win); + Tcl_SetVar (interp, "winId", winId, 0); + free (winId); + + if (Tcl_Eval (interp, cmd) != TCL_OK) { + fprintf (stderr, "Tcl_Eval error in ReparentNotify within main() %s\n", Tcl_GetStringResult (interp)); + } + } + } + break; + + + case ResizeRequest: + { + Window twin; + Window win = report.xresizerequest.window; + + if (XGetTransientForHint (dis, win, &twin) == 1) { + XResizeWindow (dis, win, + report.xresizerequest.width, report.xresizerequest.height + ); + } + + XFlush (dis); + } + break; + + default: + break; + } + } + } + return 0; +}